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

build: Refactor.

Browse source 
* GNUmakefile (OUT,QUIET,SUBDIRS): New variables.
  include make/common.make
* .gitignore: Remove toplevel targets.
* build-aux/compile-all.scm: Import from GNU Guix.
* configure (gulp-pipe): Check exit status.  Actually test for CC,
  CC32.
* make/bin.make: New file.
* make/check.make: New file.
* make/clean.make: New file.
* make/common.make: New file.
* make/compile.make: New file.
* make/guile.make: New file.
* make/mescc-guile.make: New file.
* make/mescc-mes.make: New file.
* make/reset.make: New file.
* lib/mlibc.c: Rename from top.
* lib/start.c: Rename from top.
* module/module.make: New file.
* scaffold/scaffold.make: New file.
* scripts/scripts.make: New file.
* src/mes.c: Rename from top.
* src/src.make: New file.
* src/mes.c: Rename from top.
* src/gc..c: Rename from top.
* src/lib.c: Rename from top.
* src/posix.c: Rename from top.
* src/reader.c: Rename from top.
* src/vector.c: Rename from top.
* tests/tests.make: New file.
This commit is contained in:
Jan Nieuwenhuizen 2017-04-12 21:27:59 +02:00
parent 26539214d9
commit 38d30a3e42
49 changed files with 1468 additions and 1111 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

29
.gitignore vendored
View file

@ -1,41 +1,14 @@
*-
*.cat
*.environment.h
*.go
*.h
*.i
*.o
*.o-32
*.symbols.i
*~
.#*
/.config.make
/.tarball-version
/ChangeLog
/a.out
/mes
/mes-32
/cons-mes
/m
/malloc
/main
/micro-mes
/mini-mes
/t
/tiny-mes
/guile-cons-mes
/guile-m
/guile-malloc
/guile-main
/guile-micro-mes
/guile-mini-mes
/guile-t
/guile-tiny-mes
#keep this: bootstrap
#/mes-mini-mes
#/mes.mes
/module/mes/tiny-0-32.mo
#keep this: bootstrap

327
GNUmakefile
View file

@ -1,312 +1,26 @@
SHELL:=bash
QUIET:=@
.PHONY: all check clean default distclean help install release
default: all
.config.make: configure GNUmakefile
./configure
GUILE:=guile
export GUILE
MES_DEBUG:=1
CFLAGS:=--std=gnu99 -O0 -g
OUT:=out
CFLAGS:=-std=c99 -O3 -finline-functions
#CFLAGS:=-std=c99 -O0
#CFLAGS:=-pg -std=c99 -O0
#CFLAGS:=-std=c99 -O0 -g
include .config.make
include make/install.make
MACHINE:=$(shell $(CC) -dumpmachine)
##CC:=gcc
LIBRARY_PATH=:$(dir $(shell type -p ldd))../lib
CC:=LIBRARY_PATH=$(LIBRARY_PATH) gcc
CPPFLAGS+=-I.
CPPFLAGS+=-DDATADIR='"$(DATADIR)/"'
CPPFLAGS+=-DDOCDIR='"$(DOCDIR)/"'
CPPFLAGS+=-DMODULEDIR='"$(MODULEDIR)/"'
CPPFLAGS+=-DPREFIX='"$(PREFIX)/"'
CPPFLAGS+=-DVERSION='"$(VERSION)"'
MINI_CPPFLAGS:=$(CPPFLAGS)
CPPFLAGS+=-D_POSIX_SOURCE
export BOOT
ifneq ($(BOOT),)
CPPFLAGS+=-DBOOT=1
endif
-include .local.make
all: mes module/mes/read-0.mo module/mes/read-0-32.mo
ifeq ($(MES_BOOTSTRAP),mes-mini-mes)
all: mes-mini-mes
endif
S:=
mes.o$(S): GNUmakefile
mes.o$(S): mes.c
mes.o$(S): mes.c mes.h mes.i mes.environment.i mes.symbols.i
mes.o$(S): lib.c lib.h lib.i lib.environment.i
mes.o$(S): math.c math.h math.i math.environment.i
mes.o$(S): posix.c posix.h posix.i posix.environment.i
mes.o$(S): reader.c reader.h reader.i reader.environment.i
mes.o$(S): gc.c gc.h gc.i gc.environment.i
mes.o$(S): vector.c vector.h vector.i vector.environment.i
clean:
rm -f mes *.o *.o-32 *.environment.i *.symbols.i *.environment.h *.cat a.out
rm -f mes-32
rm -f cons-mes m main micro-mes mini-mes t tiny-mes
rm -f guile-cons-mes guile-m guile-main guile-micro-mes guile-mini-mes guile-t guile-tiny-mes
rm -f module/mes/*.mo
distclean: clean
rm -f .config.make
%.h %.i %.environment.i %.symbols.i: %.c build-aux/mes-snarf.scm
build-aux/mes-snarf.scm $<
check: all guile-check mes-check mescc-check
TESTS:=\
tests/read.test\
tests/base.test\
tests/closure.test\
tests/quasiquote.test\
tests/let.test\
tests/scm.test\
tests/display.test\
tests/cwv.test\
tests/math.test\
tests/vector.test\
tests/srfi-1.test\
tests/srfi-13.test\
tests/srfi-14.test\
tests/optargs.test\
tests/fluids.test\
tests/catch.test\
tests/psyntax.test\
tests/pmatch.test\
tests/let-syntax.test\
tests/guile.test\
tests/record.test\
tests/match.test\
tests/peg.test\
SUBDIRS:=\
module\
src\
scaffold\
scripts\
tests\
#
BASE-0:=module/mes/base-0.mes
MES-0:=guile/mes-0.scm
MES:=./mes
# use module/mes/read-0.mes rather than C-core reader
MES_FLAGS:=--load
export MES_FLAGS
MES_DEBUG:=1
#export MES_DEBUG
export C_INCLUDE_PATH
mes-check: all
set -e; for i in $(TESTS); do MES_MAX_ARENA=20000000 ./$$i; done
mini-mes-check: all mini-mes
$(MAKE) mes-check MES=./mini-mes
module/mes/read-0.mo: module/mes/read-0.mes mes
rm -f $@
./mes --dump < $< > $@
dump: module/mes/read-0.mo
mes.o$(S): mes.c
$(CC) $(CPPFLAGS) $(CFLAGS) -c -o $@ $<
mes$(S): mes.o$(S)
$(CC) $(CFLAGS) $(LDFLAGS) $< -o $@
ifeq ($(MACHINE),i686-unknown-linux-gnu)
mes-32: mes
ln -f $< $@
else
mes$(S)-32: GNUmakefile
mes$(S)-32: mes.c gc.c lib.c math.c posix.c vector.c
guix environment --system=i686-linux --ad-hoc gcc-toolchain -- bash -c 'make mes-32 S=-32 CC=i686-unknown-linux-gnu-gcc LIBRARY_PATH=$${PATH%%/bin:*}/lib'
endif
module/mes/read-0-32.mo: module/mes/read-0.mes
module/mes/read-0-32.mo: module/mes/read-0.mo
module/mes/read-0-32.mo: mes-32
rm -f $@
MES_MINI=1 ./mes-32 --dump < $< > $@
module/mes/tiny-0-32.mo: module/mes/tiny-0.mes mes-32
rm -f $@
MES_TINY=1 ./mes-32 --dump < $< > $@
guile-check:
set -e; for i in $(TESTS); do\
$(GUILE) -s <(cat $(MES-0) module/mes/test.mes $$i);\
done
t-check: t
./t
mescc-check: t-check
rm -f a.out
guile/mescc.scm scaffold/t.c > a.out
chmod +x a.out
./a.out
%.h %.i %.environment.i %.symbols.i: scaffold/%.c build-aux/mes-snarf.scm GNUmakefile
build-aux/mes-snarf.scm --mini $<
mini-%.h mini-%.i mini-%.environment.i mini-%.symbols.i: %.c build-aux/mes-snarf.scm GNUmakefile
build-aux/mes-snarf.scm --mini $<
mini-mes.h mini-mes.i mini-mes.environment.i mini-mes.symbols.i: mes.c build-aux/mes-snarf.scm GNUmakefile
build-aux/mes-snarf.scm --mini $<
mini-mes: mini-mes.h mini-mes.i mini-mes.environment.i mini-mes.symbols.i
mini-mes: gc.c mini-gc.h mini-gc.i mini-gc.environment.i
mini-mes: vector.c mini-vector.h mini-vector.i mini-vector.environment.i
mini-mes: mlibc.c mstart.c
mini-mes: GNUmakefile
mini-mes: module/mes/read-0-32.mo
mini-mes: mes.c
rm -f $@
gcc -nostdlib --std=gnu99 -m32 -g -o $@ $(MINI_CPPFLAGS) $<
rm -f mes.o
chmod +x $@
guile-mini-mes: module/language/c99/compiler.mes # and others...
guile-mini-mes: mini-mes.h mini-mes.i mini-mes.environment.i mini-mes.symbols.i
guile-mini-mes: gc.c mini-gc.h mini-gc.i mini-gc.environment.i
guile-mini-mes: lib.c mini-lib.h mini-lib.i mini-lib.environment.i
guile-mini-mes: math.c mini-math.h mini-math.i mini-math.environment.i
guile-mini-mes: posix.c mini-posix.h mini-posix.i mini-posix.environment.i
guile-mini-mes: vector.c mini-vector.h mini-vector.i mini-vector.environment.i
guile-mini-mes: mlibc.c mstart.c
guile-mini-mes: GNUmakefile
guile-mini-mes: module/mes/read-0-32.mo
guile-mini-mes: mes.c
rm -f $@
guile/mescc.scm $< > $@ || rm -f $@
chmod +x $@
mes-mini-mes: mini-mes.h mini-mes.i mini-mes.environment.i mini-mes.symbols.i
mes-mini-mes: gc.c mini-gc.h mini-gc.i mini-gc.environment.i
mes-mini-mes: vector.c mini-vector.h mini-vector.i mini-vector.environment.i
mes-mini-mes: mlibc.c mstart.c
mes-mini-mes: GNUmakefile
mes-mini-mes: module/mes/read-0-32.mo
mes-mini-mes: mes.c
rm -f $@
# MES_FLAGS= MES_DEBUG=1 scripts/mescc.mes $< > $@ || rm -f $@
MES_FLAGS= MES_DEBUG=1 scripts/mescc.mes $< > $@
chmod +x $@
mes-hello: GNUmakefile
mes-hello: mlibc.c mstart.c
mes-hello: module/mes/read-0-32.mo
mes-hello: scaffold/hello.c
rm -f $@
MES_FLAGS= MES_DEBUG=1 scripts/mescc.mes $< > $@ || rm -f $@
chmod +x $@
cons-mes: module/mes/tiny-0-32.mo
cons-mes: scaffold/cons-mes.c GNUmakefile
gcc -nostdlib --std=gnu99 -m32 -g -o $@ $(MINI_CPPFLAGS) $<
chmod +x $@
guile-cons-mes: module/mes/tiny-0-32.mo
guile-cons-mes: scaffold/cons-mes.c
rm -f $@
guile/mescc.scm $< > $@ || rm -f $@
chmod +x $@
tiny-mes: module/mes/tiny-0-32.mo
tiny-mes: scaffold/tiny-mes.c GNUmakefile
gcc -nostdlib --std=gnu99 -m32 -g -o $@ $(MINI_CPPFLAGS) $<
chmod +x $@
guile-tiny-mes: module/mes/tiny-0-32.mo
guile-tiny-mes: scaffold/tiny-mes.c
rm -f $@
guile/mescc.scm $< > $@ || rm -f $@
chmod +x $@
m: scaffold/m.c GNUmakefile
gcc -nostdlib --std=gnu99 -m32 -g -o $@ $(MINI_CPPFLAGS) $<
# gcc --std=gnu99 -g -o $@ $(CPPFLAGS) $<
chmod +x $@
guile-m: scaffold/m.c
rm -f $@
guile/mescc.scm $< > $@ || rm -f $@
chmod +x $@
malloc: scaffold/malloc.c GNUmakefile
gcc -nostdlib --std=gnu99 -m32 -g -o $@ $(MINI_CPPFLAGS) $<
chmod +x $@
guile-malloc: scaffold/malloc.c
guile/mescc.scm $< > $@ || rm -f $@
chmod +x $@
micro-mes: scaffold/micro-mes.c GNUmakefile
rm -f $@
gcc -nostdlib --std=gnu99 -m32 -o $@ $(MINI_CPPFLAGS) $<
chmod +x $@
guile-micro-mes: scaffold/micro-mes.c
guile/mescc.scm $< > $@ || rm -f $@
chmod +x $@
main: doc/examples/main.c GNUmakefile
rm -f $@
gcc -nostdlib --std=gnu99 -m32 -o $@ $(MINI_CPPFLAGS) $<
chmod +x $@
guile-main: doc/examples/main.c
guile/mescc.scm $< > $@ || rm -f $@
chmod +x $@
t: mlibc.c
t: scaffold/t.c GNUmakefile
rm -f $@
gcc -nostdlib --std=gnu99 -m32 -g -o $@ $(MINI_CPPFLAGS) $<
chmod +x $@
guile-t: scaffold/t.c
guile/mescc.scm $< > $@ || rm -f $@
chmod +x $@
MAIN_C:=doc/examples/main.c
mescc: all $(MAIN_C)
mescc: doc/examples/main.c all
rm -f a.out
MES_DEBUG=1 scripts/mescc.mes $< > a.out
./a.out; r=$$?; [ $$r = 42 ]
guile-mescc: doc/examples/main.c
rm -f a.out
guile/mescc.scm $< > a.out
chmod +x a.out
./a.out; r=$$?; [ $$r = 42 ]
GUILE_GIT:=$(HOME)/src/guile-1.8
GUILE_COMMIT:=ba8a709
psyntax-import: module/mes/psyntax.ss module/mes/psyntax.pp
module/mes/psyntax.%: $(GUILE_GIT)/ice-9/psyntax.%
git --git-dir=$(GUILE_GIT)/.git --work-tree=$(GUILE_GIT) show $(GUILE_COMMIT):ice-9/$(@F > $@
include make/common.make
-include .local.make
help: help-top
install: all
release: all
help:
@ -316,15 +30,16 @@ define HELP_TOP
Usage: make [OPTION]... [TARGET]...
Targets:
all update everything
check run unit tests
clean remove all generated stuff
dist create tarball in $(TARBALL)
distclean also clean configuration
mescc compile cc/main.c to a.out
install install in $$(PREFIX) [$(PREFIX)]
release make a release
update-hash update hash in guix.scm
all update everything
check run unit tests
clean remove all generated stuff
dist create tarball in $(TARBALL)
distclean also clean configuration
maintainer-clean also clean expensive targets [$(strip $(MAINTAINER-CLEAN))]
mescc compile cc/main.c to a.out
install install in $$(DESTDIR)$$(PREFIX) [$(DESTDIR)$(PREFIX)]
release make a release
update-hash update hash in guix.scm
endef
export HELP_TOP
help-top:

152
build-aux/compile-all.scm Normal file
View file

@ -0,0 +1,152 @@
;;; 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 (file-needs-compilation? file)
(let ((go (scm->go file)))
(or (not (file-exists? go))
(file-mtime<? go file))))
(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:

8
build-aux/mes-snarf.scm
View file

@ -155,8 +155,10 @@ exec ${GUILE-guile} --no-auto-compile -L $HOME/src/mes/build-aux -L build-aux -e
(functions (filter (negate internal?) functions))
(symbols (snarf-symbols string))
(base-name (basename file-name ".c"))
(base-name (if (or %gcc? (string-prefix? "mini-" base-name)) base-name
(string-append "mini-" base-name)))
(dir (or (getenv "OUT") "out"))
(base-name (string-append dir "/" base-name))
(base-name (if %gcc? base-name
(string-append base-name ".mes")))
(header (make <file>
#:name (string-append base-name ".h")
#:content (string-join (map function->header functions (iota (length functions) (+ %start (length symbols)))) "")))
@ -181,7 +183,7 @@ exec ${GUILE-guile} --no-auto-compile -L $HOME/src/mes/build-aux -L build-aux -e
(with-output-to-file (.name file) (lambda () (display (.content file)))))
(define (main args)
(let* ((files (if (not (and (pair? (cdr args)) (equal? (cadr args) "--mini"))) (cdr args)
(let* ((files (if (not (and (pair? (cdr args)) (equal? (cadr args) "--mes"))) (cdr args)
(begin (set! %gcc? #f)
(cddr args)))))
(map file-write (filter content? (append-map generate-includes files)))))

75
configure vendored
View file

@ -22,7 +22,7 @@ exec ${GUILE} --no-auto-compile -L $(pwd) -e '(@@ (configure) main)' -s "$0" ${1
!#
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; configure: This file is part of Mes.
;;;
@ -53,19 +53,11 @@ exec ${GUILE} --no-auto-compile -L $(pwd) -e '(@@ (configure) main)' -s "$0" ${1
(define PACKAGE "mes")
(define VERSION "0.4")
(define PREFIX "/usr/local")
(define GUILE_EV (effective-version))
(define CC (or (getenv "CC") "gcc"))
(define CC32 (or (getenv "CC32") "i686-unknown-linux-gnu-gcc"))
(define GUILE_EFFECTIVE_VERSION (effective-version))
(define GUILE (or (getenv "guile") "guile"))
(define SYSCONFDIR "$(PREFIX)/etc")
;;; Utility
(define (gulp-pipe command)
(let* ((port (open-pipe* OPEN_READ *shell* "-c" command))
(output (read-string port)))
(close-port port)
(string-trim-right output #\newline)))
(define (logf port string . rest)
(apply format (cons* port string rest))
(force-output port)
@ -77,6 +69,18 @@ exec ${GUILE} --no-auto-compile -L $(pwd) -e '(@@ (configure) main)' -s "$0" ${1
(define (stdout string . rest)
(apply logf (cons* (current-output-port) string rest)))
(define *verbose?* #f)
(define (verbose string . rest)
(if *verbose?* (apply stderr (cons string rest))))
(define (gulp-pipe command)
(let* ((port (open-pipe* OPEN_READ *shell* "-c" command))
(output (read-string port))
(status (close-pipe port)))
(verbose "command[~a]: ~s => ~a\n" status command output)
(if (not (zero? status)) "" (string-trim-right output #\newline))))
(define* ((->string #:optional (infix "")) h . t)
(let ((o (if (pair? t) (cons h t) h)))
(match o
@ -123,14 +127,14 @@ exec ${GUILE} --no-auto-compile -L $(pwd) -e '(@@ (configure) main)' -s "$0" ${1
(stderr "checking for ~a~a..." command
(if (null? expected) ""
(format #f " [~a]" (version->string expected))))
(let* ((actual (gulp-pipe (format #f "~a ~a 2>&1" command version-option)))
(actual (string->version actual))
(let* ((output (gulp-pipe (format #f "~a ~a 2>&1" command version-option)))
(actual (string->version output))
(pass? (and actual (compare expected actual))))
(stderr "~a ~a\n" (if pass? (if (pair? actual) "" " yes")
(if actual " no, found" "")) (version->string actual))
(if (not pass?)
(set! required (cons (or deb command) required)))
pass?))
(or pass?
(if (not (pair? command)) (begin (set! required (cons (or deb command) required)) pass?)
(check-version (cdr command) expected deb version-option compare)))))
(define* (check-pkg-config package expected #:optional (deb #f))
(check-version (format #f "pkg-config --modversion ~a" package) expected deb))
@ -147,15 +151,24 @@ exec ${GUILE} --no-auto-compile -L $(pwd) -e '(@@ (configure) main)' -s "$0" ${1
(set! required (cons deb required)))))
(define guix?
(system "guix --version &>/dev/null"))
(and (zero? (system "guix --version &>/dev/null")) 1))
;;;
(define CC (or (getenv "CC") "gcc"))
(define BUILD_TRIPLET (gulp-pipe (string-append CC " -dumpmachine 2>/dev/null")))
(define ARCH (car (string-split BUILD_TRIPLET #\-)))
(define CC32 (or (getenv "CC32")
(if (equal? ARCH "i686") CC
"i686-unknown-linux-gnu-gcc")))
(define (parse-opts args)
(let* ((option-spec
'((build (value #t))
(host (value #t))
(help (single-char #\h))
(prefix (value #t))
(sysconfdir (value #t))
(verbose (single-char #\v))
;;ignore
(enable-fast-install)))
(options (getopt-long args option-spec))
@ -169,38 +182,46 @@ exec ${GUILE} --no-auto-compile -L $(pwd) -e '(@@ (configure) main)' -s "$0" ${1
((or (and usage? stderr) stdout) "\
Usage: ./configure [OPTION]...
-h, --help display this help
--build=BUILD configure for building on BUILD [guessed]
--host=HOST cross-compile to build programs to run on HOST [BUILD]
--prefix=DIR install in PREFIX [~a]
--sysconfdir=DIR read-only single-machine data [PREFIX/etc]
-v, --verbose be verbose
" PREFIX)
(exit (or (and usage? 2) 0)))
options)))
(define BUILD_TRIPLET (gulp-pipe "gcc -dumpmachine 2>/dev/null"))
(define (main args)
(let* ((options (parse-opts args))
(build-triplet (option-ref options 'build BUILD_TRIPLET))
(host-triplet (option-ref options 'host BUILD_TRIPLET))
(prefix (option-ref options 'prefix PREFIX))
(sysconfdir (option-ref options 'sysconfdir SYSCONFDIR)))
(sysconfdir (option-ref options 'sysconfdir SYSCONFDIR))
(verbose? (option-ref options 'verbose #f)))
(set! *verbose?* verbose?)
(check-version 'bash '(4 0))
(check-version 'gcc '(4 8))
(check-version 'i686-unknown-linux-gnu-gcc '(4 8))
(check-version CC '(4 8))
(check-version CC32 '(4 8))
(check-version 'guile '(2 0))
(check-version 'make '(4 0))
(check-version 'perl '(5))
(when (pair? required)
(stderr "\nMissing dependencies, run\n\n")
(if guix?
(stderr " guix environment -l guix.scm\n")
(stderr " sudo apt-get install ~a\n" ((->string " ") required)))
(exit 1))
(stderr "\nMissing dependencies [~a], run\n\n" ((->string ", ") required))
(if guix?
(stderr " guix environment -l guix.scm\n")
(stderr " sudo apt-get install ~a\n" ((->string " ") required)))
(exit 1))
(with-output-to-file ".config.make"
(lambda ()
(stdout "build:=~a\n" build-triplet)
(stdout "host:=~a\n" host-triplet)
(stdout "srcdir:=.\n")
(stdout "ARCH:=~a\n" ARCH)
(stdout "CC:=~a\n" CC)
(stdout "CC32:=~a\n" CC32)
(stdout "GUILE:=~a\n" GUILE)
(stdout "GUILE_EV:=~a\n" GUILE_EV)
(stdout "GUILE_EFFECTIVE_VERSION:=~a\n" GUILE_EFFECTIVE_VERSION)
(stdout "GUIX_P:=~a\n" (if guix? guix? ""))
(stdout "PACKAGE:=~a\n" PACKAGE)
(stdout "VERSION:=~a\n" VERSION)

10
guile/mescc.scm
View file

@ -1,9 +1,11 @@
#! /bin/sh
# -*-scheme-*-
DATADIR=${DATADIR-@DATADIR@}
[ "$DATADIR" = @"DATADIR"@ ] && DATADIR=.
GODIR=${GODIR-@GODIR@}
MODULEDIR=${MODULEDIR-@MODULEDIR@}
[ "$GODIR" = @"GODIR"@ ] && GODIR=guile
[ "$MODULEDIR" = @"MODULEDIR"@ ] && MODULEDIR=guile
export GUILE_AUTO_COMPILE=${GUILE_AUTO_COMPILE-0}
exec ${GUILE-guile} -L $DATADIR/guile -e '(mescc)' -s "$0" "$@"
exec ${GUILE-guile} -L $MODULEDIR -C $GODIR -e '(mescc)' -s "$0" "$@"
!#
;;; Mes --- The Maxwell Equations of Software
@ -61,4 +63,4 @@ GUILE='~/src/guile-1.8/build/pre-inst-guile --debug -q' guile/mescc.scm
(exit 0)))
(format (current-error-port) "compiling: ~a\n" file)
(with-input-from-file file
compile)))
c99-input->elf)))

73
guix.scm
View file

@ -1,7 +1,7 @@
;;; guix.scm -- Guix package definition
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Also borrowing code from:
;;; guile-sdl2 --- FFI bindings for SDL2
@ -47,6 +47,7 @@
(gnu packages)
(gnu packages base)
(gnu packages commencement)
(gnu packages cross-base)
(gnu packages gcc)
(gnu packages guile)
(gnu packages package-management)
@ -80,36 +81,54 @@
(_ #f)))))
(define-public mes
(let ((triplet "i686-unknown-linux-gnu"))
(package
(name "mes")
(version "0.4.f84e97fc")
(source (origin
(method git-fetch)
(uri (git-reference
(url "https://gitlab.com/janneke/mes")
(commit "f84e97fc33f5e2a2ad7033795967d44c95d34b8f")))
(file-name (string-append name "-" version))
(sha256
(base32 "1jpm8m8y2dqsl3sc6flf8da4rpdrqh6zgr2mghzjw0lg34v1r21j"))))
(build-system gnu-build-system)
(supported-systems '("x86_64-linux"))
(native-inputs
`(("git" ,git)
("guile" ,guile-2.2)
("gcc" ,gcc-toolchain-4.9)
;; Use cross-compiler rather than #:system "i686-linux" to get
;; MesCC 64 bit .go files installed ready for use with Guile.
("i686-linux-binutils" ,(cross-binutils triplet))
("i686-linux-gcc" ,(let ((triplet triplet)) (cross-gcc triplet)))
("perl" ,perl))) ; build-aux/gitlog-to-changelog
(supported-systems '("i686-linux"))
(synopsis "Maxwell Equations of Software")
(description
"Mes aims to create full source bootstrapping for GuixSD. It
consists of a mutual self-hosting [close to Guile-] Scheme interpreter
prototype in C and a Nyacc-based C compiler in [Guile] Scheme.")
(home-page "https://gitlab.com/janneke/mes")
(license gpl3+))))
(define-public mes.git
(package
(name "mes")
(inherit mes)
(name "mes.git")
(version "git")
(source (local-file %source-dir #:recursive? #t #:select? git-file?))
(build-system gnu-build-system)
(native-inputs
`(("git" ,git)
("guile" ,guile-2.2)
("gcc" ,gcc-toolchain-4.9)
("perl" ,perl))) ; build-aux/gitlog-to-changelog
(supported-systems '("i686-linux"))
(arguments
`(#:system "i686-linux"
;;#:make-flags '("MES_BOOTSTRAP=mes-mes")
#:phases
`(#:phases
(modify-phases %standard-phases
(add-before 'install 'generate-changelog
(lambda _
(with-output-to-file "ChangeLog"
(lambda ()
(display "Please run\n build-aux/gitlog-to-changelog --srcdir=<git-checkout> > ChangeLog\n")))
#t)))))
(synopsis "Maxwell Equations of Software")
(description
"Mes aims to create full source bootstrapping for GuixSD: an
entirely source-based bootstrap path. The target is to [have GuixSD]
boostrap from a minimal, easily inspectable binary --that should be
readable as source-- into something close to R6RS Scheme.")
(home-page "https://gitlab.com/janneke/mes")
(license gpl3+)))
(lambda _
(with-output-to-file "ChangeLog"
(lambda ()
(display "Please run
build-aux/gitlog-to-changelog --srcdir=<git-checkout> > ChangeLog\n")))
#t)))))))
;; Return it here so 'guix build/environment/package' can consume it directly.
mes
;; Return it here so `guix build/environment/package' can consume it directly.
mes.git

126
mlibc.c → libc/mlibc.c
View file

@ -18,22 +18,25 @@
* along with Mes. If not, see <http://www.gnu.org/licenses/>.
*/
#if __GNUC__
int g_stdin = 0;
typedef long size_t;
void *malloc (size_t i);
int open (char const *s, int mode);
int read (int fd, void* buf, size_t n);
void write (int fd, char const* s, int n);
#define O_RDONLY 0
#define INT_MIN -2147483648
#define INT_MAX 2147483647
#define EOF -1
#define STDIN 0
#define STDOUT 1
#define STDERR 2
#if __GNUC__ && !POSIX
#define O_RDONLY 0
#define INT_MIN -2147483648
#define INT_MAX 2147483647
typedef long size_t;
void *malloc (size_t i);
int open (char const *s, int mode);
int read (int fd, void* buf, size_t n);
int write (int fd, char const* s, int n);
void
exit (int code)
{
@ -96,22 +99,24 @@ open (char const *s, int mode)
int puts (char const*);
char const* itoa (int);
void
int
write (int fd, char const* s, int n)
{
int r;
//syscall (SYS_write, fd, s, n));
asm (
"mov %0,%%ebx\n\t"
"mov %1,%%ecx\n\t"
"mov %2,%%edx\n\t"
"mov %1,%%ebx\n\t"
"mov %2,%%ecx\n\t"
"mov %3,%%edx\n\t"
"mov $0x4, %%eax\n\t"
"int $0x80\n\t"
: // no outputs "=" (r)
"mov %%eax,%0\n\t"
: "=r" (r)
: "" (fd), "" (s), "" (n)
: "eax", "ebx", "ecx", "edx"
);
return r;
}
int
@ -151,7 +156,7 @@ brk (void *p)
}
int
putc (int c, int fd)
fputc (int c, int fd)
{
write (fd, (char*)&c, 1);
return 0;
@ -240,7 +245,6 @@ assert_fail (char* s)
#define assert(x) ((x) ? (void)0 : assert_fail (#x))
int ungetc_char = -1;
char ungetc_buf[2];
@ -271,6 +275,13 @@ ungetc (int c, int fd)
return c;
}
int
isdigit (int c)
{
return (c>='0') && (c<='9');
}
#endif
char itoa_buf[10];
char const*
@ -300,9 +311,88 @@ itoa (int x)
return p+1;
}
#if POSIX
#define _GNU_SOURCE
#include <assert.h>
#include <ctype.h>
#include <errno.h>
#include <fcntl.h>
#include <limits.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <unistd.h>
#undef puts
#define puts(x) fdputs(x, STDOUT)
#define eputs(x) fdputs(x, STDERR)
#define fputs fdputs
int
isdigit (int c)
fdputs (char const* s, int fd)
{
return (c>='0') && (c<='9');
int i = strlen (s);
write (fd, s, i);
return 0;
}
#ifdef putc
#undef putc
#endif
#define fputc fdputc
int
fdputc (int c, int fd)
{
write (fd, (char*)&c, 1);
return 0;
}
int
putchar (int c)
{
write (STDOUT, (char*)&c, 1);
return 0;
}
int ungetc_char = -1;
char ungetc_buf[2];
int
getchar ()
{
char c;
int i;
if (ungetc_char == -1)
{
int r = read (g_stdin, &c, 1);
if (r < 1) return -1;
i = c;
}
else
i = ungetc_buf[ungetc_char--];
if (i < 0) i += 256;
return i;
}
#define ungetc fdungetc
int
fdungetc (int c, int fd)
{
assert (ungetc_char < 2);
ungetc_buf[++ungetc_char] = c;
return c;
}
#else
#define fputs fdputs
int
fdputs (char const* s, int fd)
{
int i = strlen (s);
write (fd, s, i);
return 0;
}
#endif

0
mstart.c → libc/mstart.c
View file

23
make/bin.make Normal file
View file

@ -0,0 +1,23 @@
O_FILES := $(C_FILES:%.c=$(OUT)/%.$(CROSS)o)
D_FILES := $(O_FILES:%o=%d)
ifneq ($(DEBUG),)
$(info TARGET=$(TARGET))
$(info C_FILES=$(C_FILES))
$(info O_FILES=$(O_FILES))
$(info O_FILES=$(D_FILES))
endif
CLEAN+=$(O_FILES) $(OUT)/$(TARGET)
DIST-CLEAN+=$(D_FILES)
$(OUT)/$(TARGET): ld:=$(CROSS)LD
$(OUT)/$(TARGET): LD:=$(CROSS)$(LD)
$(OUT)/$(TARGET): CC:=$(CROSS)$(CC)
$(OUT)/$(TARGET): LDFLAGS:=$(LDFLAGS) $(LD_FLAGS) $(LINK)
$(OUT)/$(TARGET): O_FILES:=$(O_FILES)
$(OUT)/$(TARGET): $(O_FILES)
@echo " $(ld) $(notdir $^) -> $(notdir $@)"
$(QUIET)$(LINK.c) $^ $(LOADLIBES) $(LDLIBS) -o $@
include make/compile.make

14
make/check.make Normal file
View file

@ -0,0 +1,14 @@
ifeq ($(TEST),)
TEST:=$(TARGET)-check
$(TEST): EXPECT:=$(EXPECT)
$(TEST): $(OUT)/$(TARGET)
ifeq ($(EXPECT),)
$<
else
$<; r=$$?; [ $$r = $(EXPECT) ]
endif
endif
CHECK+=$(TEST)
$(TEST): TEST:=$(TEST)
$(DIR)-check: $(TEST)
include make/reset.make

17
make/clean.make Normal file
View file

@ -0,0 +1,17 @@
$(OUT):
$(QUIET)mkdir -p $@
clean:
$(QUIET)rm -rf $(CLEAN)
$(QUIET)mkdir -p $(OUT)
dist-clean: clean
$(QUIET)rm -rf $(DIST-CLEAN)
distclean: dist-clean
mostly-clean: dist-clean
mostlyclean: mostly-clean
maintainer-clean: dist-clean
$(QUIET)rm -rf $(MAINTAINER-CLEAN)
maintainerclean: maintainer-clean

49
make/common.make Normal file
View file

@ -0,0 +1,49 @@
.PHONY: all check clean distclean mostlyclean maintainer-clean install
cleaning?:=$(filter clean,$(MAKECMDGOALS))
ifeq ($(cleaning?),)
.config.make: configure $(filter-out .config.make,$(MAKEFILE_LIST))
./configure
endif
CC32:=arch-gcc
-include .config.make
CLEAN:=$(OUT)
DIST-CLEAN:=.config.make
MAINTAINER-CLEAN:=
CHECK:=
all: $(OUT)
include make/install.make
define subdir
ifneq ($(DEBUG),)
$$(info SUBDIR $(1))
endif
DIR:=$(patsubst %/,%,$(dir $(1)))
DOUT:=$(OUT)/$$(DIR)
include $(1)
endef
$(foreach dir,$(SUBDIRS),$(eval $(call subdir,$(dir)/$(dir).make)))
all: $(CLEAN)
ifneq ($(DEBUG),)
$(info CLEAN=$(CLEAN))
endif
subdirs: $(CLEAN)
check: $(CLEAN) $(CHECK)
include make/clean.make
CROSS_PREFIX:=$(CC32:%gcc=%)
ifeq ($(findstring clean,$(MAKECMDGOALS)),)
ifneq ($(DEBUG),)
$(info DEPS:=$(filter %.d %.$(CROSS_PREFIX)d,$(DIST-CLEAN)))
endif
-include $(filter %.d %.$(CROSS_PREFIX)d,$(DIST-CLEAN))
endif

14
make/compile.make Normal file
View file

@ -0,0 +1,14 @@
define c-compile
$(OUT)/$(1:.c=.$(CROSS)o): $(MAKEFILE_LIST)
$(OUT)/$(1:.c=.$(CROSS)o): cc:=$(CROSS)CC
$(OUT)/$(1:.c=.$(CROSS)o): CC:=$(CROSS)$(CC)
$(OUT)/$(1:.c=.$(CROSS)o): CPPFLAGS:=$$(CPPFLAGS) $$(CPP_FLAGS) $(2:%=-D%) $(3:%=-I%)
$(OUT)/$(1:.c=.$(CROSS)o): CFLAGS:=$$(CFLAGS) $$(C_FLAGS)
$(OUT)/$(1:.c=.$(CROSS)o): $(1)
@echo " $$(cc) $$(notdir $$<) -> $$(notdir $$@)"
@mkdir -p $$(dir $$@)
$$(QUIET)$$(COMPILE.c) $$(OUTPUT_OPTION) -MMD -MF $$(@:%.$(CROSS)o=%.$(CROSS)d) -MT '$$(@:.%$(CROSS)o=%.$(CROSS)d)' $$<
endef
$(foreach c-file,$(strip $(filter %.c,$(C_FILES))),$(eval $(call c-compile,$(c-file),$(DEFINES),$(INCLUDES))))
include make/reset.make

33
make/guile.make Normal file
View file

@ -0,0 +1,33 @@
GO_FILES:=$(SCM_FILES:%.scm=%.go)
CLEAN+=$(GO_FILES)
clean-go: GO_FILES:=$(GO_FILES)
clean-go:
@$(QUIET)rm -f $(GO_FILES)
INSTALL_SCM_FILES+=$(SCM_FILES)
INSTALL_GO_FILES+=$(GO_FILES)
INSTALL_MES_FILES+=$(MES_FILES)
GUILE_FLAGS:=\
--no-auto-compile\
-L guile\
-C guile\
#
all-go: DIR:=$(DIR)
all-go: SCM_FILES:=$(SCM_FILES)
all-go: GUILE_FLAGS:=$(GUILE_FLAGS)
all-go: $(SCM_FILES)
$(QUIET)rm -f $@
$(QUIET)cd $(DIR) && srcdir=$(srcdir) host=$(host) $(GUILE) $(GUILE_FLAGS:guile=../guile) -s ../build-aux/compile-all.scm $(SCM_FILES:$(DIR)/%=%)
$(GO_FILES): all-go
# these .scm files include its .mes counterpart; must add dependency to be be remade
SCM_BASES:=$(SCM_FILES:%.scm=%)
SCM_MES_FILES:=$(filter $(SCM_BASES:%=%.mes),$(MES_FILES))
$(foreach scm_mes,$(SCM_MES_FILES),$(eval $(scm_mes:%.mes=%.go): $(scm_mes)))
CHECK := $(CHECK) $(TEST)
include make/reset.make

25
make/install.make
View file

@ -30,7 +30,9 @@ else
DATADIR:=$(PREFIX)/share
DOCDIR:=$(DATADIR)/doc
endif
MODULEDIR:=$(DATADIR)/module
LIBDIR:=$(PREFIX)/lib
MODULEDIR:=$(PREFIX)/share/guile/site/$(GUILE_EFFECTIVE_VERSION)
GODIR:=$(LIBDIR)/guile/$(GUILE_EFFECTIVE_VERSION)/site-ccache
.tarball-version: tree-clean-p
echo $(COMMIT) > $@
@ -51,10 +53,14 @@ $(TARBALL): tree-clean-p .tarball-version ChangeLog
ChangeLog:
build-aux/gitlog-to-changelog > $@
install: all ChangeLog
#FIXME: INSTALL like CLEAN
INSTALL_SCM_FILES:=
INSTALL_GO_FILES:=
install: $(CLEAN) ChangeLog
mkdir -p $(DESTDIR)$(PREFIX)/bin
install mes $(DESTDIR)$(PREFIX)/bin/mes
install mes-mini-mes $(DESTDIR)$(PREFIX)/bin/mes-mini-mes
install $(OUT)/mes $(DESTDIR)$(PREFIX)/bin/mes
install mes.mes $(DESTDIR)$(PREFIX)/bin/mes.mes
install scripts/mescc.mes $(DESTDIR)$(PREFIX)/bin/mescc.mes
install scripts/repl.mes $(DESTDIR)$(PREFIX)/bin/repl.mes
install guile/mescc.scm $(DESTDIR)$(PREFIX)/bin/mescc.scm
@ -67,9 +73,12 @@ install: all ChangeLog
-e 's,module/,$(DATADIR)/module/,' \
-e 's,@DATADIR@,$(DATADIR)/,g' \
-e 's,@DOCDIR@,$(DOCDIR)/,g' \
-e 's,@GODIR@,$(GODIR)/,g' \
-e 's,@MODULEDIR@,$(MODULEDIR)/,g' \
-e 's,@PREFIX@,$(PREFIX)/,g' \
-e 's,@VERSION@,$(VERSION),g' \
$(DESTDIR)$(DATADIR)/module/mes/base-0.mes \
$(DESTDIR)$(DATADIR)/module/language/c99/compiler.mes \
$(DESTDIR)$(PREFIX)/bin/mescc.mes \
$(DESTDIR)$(PREFIX)/bin/mescc.scm \
$(DESTDIR)$(PREFIX)/bin/repl.mes
@ -81,6 +90,12 @@ install: all ChangeLog
$(GIT_ARCHIVE_HEAD) doc \
| tar -C $(DESTDIR)$(DOCDIR) --strip=1 -xf-
cp ChangeLog $(DESTDIR)$(DOCDIR)
mkdir -p $(DESTDIR)$(MODULEDIR)
tar -cf- -C module $(INSTALL_SCM_FILES:module/%=%)\
| tar -C $(DESTDIR)$(MODULEDIR) -xf-
mkdir -p $(DESTDIR)$(GODIR)
tar -cf- -C module $(INSTALL_GO_FILES:module/%=%)\
| tar -C $(DESTDIR)$(GODIR) -xf-
release: tree-clean-p check dist
git tag v$(VERSION)
@ -96,7 +111,7 @@ update-hash: $(GUIX-HASH) .tarball-version
sed -i \
-e 's,(base32 "[^"]*"),(base32 "$(shell cat $<)"),'\
-e 's,(commit "[^"]*"),(commit "$(shell cat .tarball-version)"),'\
-e 's,(version "[^"]*"),(version "$(VERSION).$(shell cut -b1-8 .tarball-version)"),'\
-e 's,(version "[^g][^"]*"),(version "$(VERSION).$(shell cut -b1-8 .tarball-version)"),'\
guix.scm
! git diff --exit-code
git commit -m 'guix hash: $(shell cat $<)' guix.scm

9
make/mescc-guile.make Normal file
View file

@ -0,0 +1,9 @@
CLEAN+=$(OUT)/$(TARGET)
$(OUT)/$(TARGET): $(MAKEFILE_LIST)
$(OUT)/$(TARGET): $(INSTALL_GO_FILES)
$(OUT)/$(TARGET): $(C_FILES)
@echo " mescc.scm $(notdir $<) -> $(notdir $@)"
@rm -f $@
$(QUIET)guile/mescc.scm $< > $@ || rm -f $@
@[ -f $@ ] && chmod +x $@ ||:
include make/reset.make

15
make/mescc-mes.make Normal file
View file

@ -0,0 +1,15 @@
CLEAN+=$(OUT)/$(TARGET)
ifneq ($(MES_MAX_ARENA),)
$(OUT)/$(TARGET): MES_MAX_ARENA-flag:=MES_MAX_ARENA=$(MES_MAX_ARENA)
endif
$(OUT)/$(TARGET): $(MAKEFILE_LIST)
$(OUT)/$(TARGET): module/mes/read-0.mo
$(OUT)/$(TARGET): module/mes/read-0-32.mo
$(OUT)/$(TARGET): $(INSTALL_MES_FILES)
$(OUT)/$(TARGET): scripts/mes
$(OUT)/$(TARGET): $(C_FILES)
@echo " mescc.mes $(notdir $<) -> $(notdir $@)"
@rm -f $@
$(QUIET)MES_DEBUG=$(MES_DEBUG) $(MES_MAX_ARENA-flag) MES_FLAGS=--load scripts/mescc.mes $< > $@ || rm -f $@
@[ -f $@ ] && chmod +x $@ ||:
include make/reset.make

15
make/reset.make Normal file
View file

@ -0,0 +1,15 @@
C_FILES:=
C_FLAGS:=
CPP_FLAGS:=
CROSS:=
DEFINES:=
EXPECT:=
GO_FILES:=
INCLUDES:=
LD_FLAGS:=
MES_FILES:=
O_FILES:=
SCM_FILES:=
TARGET:=
TEST:=

0
mes-mini-mes → mes.mes Executable file → Normal file
View file

124
module/language/c99/compiler.mes
View file

@ -46,14 +46,24 @@
(define (stderr string . rest)
(apply logf (cons* (current-error-port) string rest)))
(define (mescc)
(define %datadir (if (string-prefix? "@DATADIR" "@DATADIR@") "" "@DATADIR@"))
(define %docdir (if (string-prefix? "@DOCDIR" "@DOCDIR@") "doc/" "@DOCDIR@"))
(define %moduledir "module/")
(define %prefix (if (string-prefix? "@PREFIX" "@PREFIX@") "" "@PREFIX@"))
(define %version (if (string-prefix? "@VERSION" "@VERSION@") "git" "@VERSION@"))
(define mes? (pair? (current-module)))
(define (c99-input->ast)
(parse-c99
#:inc-dirs (string-split (getenv "C_INCLUDE_PATH") #\:)
#:inc-dirs (cons* "." "libc" "src" "out" "out/src" (string-split (getenv "C_INCLUDE_PATH") #\:))
#:cpp-defs `(
"POSIX=0"
"_POSIX_SOURCE=0"
"__GNUC__=0"
"__MESC__=1"
"__NYACC__=1" ;; REMOVEME
"EOF=-1"
"STDIN=0"
"STDOUT=1"
"STDERR=2"
@ -62,6 +72,11 @@
"INT_MIN=-2147483648"
"INT_MAX=2147483647"
"MES_FULL=0"
"FIXED_PRIMITIVES=1"
,(if mes? "__MESC_MES__=1" "__MESC_MES__=0")
,(string-append "DATADIR=\"" %datadir "\"")
,(string-append "DOCDIR=\"" %docdir "\"")
,(string-append "PREFIX=\"" %prefix "\"")
@ -70,16 +85,6 @@
)
#:mode 'code))
(define (write-any x)
(write-char (cond ((char? x) x)
((and (number? x) (< (+ x 256) 0)) (format (current-error-port) "***BROKEN*** x=~a ==> ~a\n" x (dec->hex x)) (integer->char #xaa))
((number? x) (integer->char (if (>= x 0) x (+ x 256))))
((procedure? x)
(stderr "write-any: proc: ~a\n" x)
(stderr " ==> ~a\n" (map dec->hex (x '() '() 0 0)))
barf)
(else (stderr "write-any: ~a\n" x) barf))))
(define (ast:function? o)
(and (pair? o) (eq? (car o) 'fctn-defn)))
@ -241,7 +246,7 @@
(if constant
(wrap-as (append (i386:value->accu constant)
(i386:push-accu)))
TODO:push-function))))))))
(error "TODO:push-function: " o)))))))))
(define (push-ident-address info)
(lambda (o)
@ -345,7 +350,7 @@
(let ((local (assoc-ref (.locals info) o)))
(if local (wrap-as (append (i386:local->accu (local:id local))
(i386:byte-base->accu-address)))
TODO:base->ident-address-global))))
(error "TODO:base->ident-address-global" o)))))
(define (value->ident info)
(lambda (o value)
@ -405,6 +410,9 @@
((p-expr (string ,string))
(append-text info (list (lambda (f g ta t d)
(i386:global->accu (+ (data-offset (add-s:-prefix string) globals) d))))))
((p-expr (string . ,strings))
(append-text info (list (lambda (f g ta t d)
(i386:global->accu (+ (data-offset (add-s:-prefix (apply string-append strings)) globals) d))))))
((p-expr (fixed ,value))
(append-text info (value->accu (cstring->number value))))
((p-expr (ident ,name))
@ -525,17 +533,17 @@
((ident-add info) name 1))))
((post-dec (p-expr (ident ,name)))
(or (assoc-ref locals name) (begin (stderr "i-- ~a\n" name) barf))
(or (assoc-ref locals name) (begin (stderr "i-- ~a\n" name) (error "undefined identifier: " name)))
(append-text info (append ((ident->accu info) name)
((ident-add info) name -1))))
((pre-inc (p-expr (ident ,name)))
(or (assoc-ref locals name) (begin (stderr "++i ~a\n" name) barf))
(or (assoc-ref locals name) (begin (stderr "++i ~a\n" name) (error "undefined identifier: " name)))
(append-text info (append ((ident-add info) name 1)
((ident->accu info) name))))
((pre-dec (p-expr (ident ,name)))
(or (assoc-ref locals name) (begin (stderr "--i ~a\n" name) barf))
(or (assoc-ref locals name) (begin (stderr "--i ~a\n" name) (error "undefined identifier: " name)))
(append-text info (append ((ident-add info) name -1)
((ident->accu info) name))))
@ -627,12 +635,9 @@
(wrap-as (append (i386:accu+n 4)
(i386:base+n 4)
(i386:base-address->accu-address))))))))))
(_ barf-assign))))
(_ (error "expr->accu: unsupported assign: " a)))))
(_
(format (current-error-port) "SKIP: expr->accu=~s\n" o)
barf
info)))))
(_ (error "expr->accu: unsupported: " o))))))
(define (expr->base info)
(lambda (o)
@ -692,11 +697,7 @@
(append-text info (append ((ident->accu info) name)
(wrap-as (i386:accu+value offset))))))
(_
(format (current-error-port) "SKIP: expr->accu*=~s\n" o)
barf
info)
)))
(_ (error "expr->accu*: unsupported: " o)))))
(define (ident->constant name value)
(cons name value))
@ -717,10 +718,7 @@
((decl (decl-spec-list (type-spec (struct-ref (ident ,name)))));; "scm"
(list "struct" name)) ;; FIXME
((typename ,name) name)
(_
(stderr "SKIP: decl type=~s\n" o)
barf
o)))
(_ (error "decl->type: unsupported: " o))))
(define (expr->global o)
(pmatch o
@ -899,7 +897,7 @@
(cons type name)) ;; FIXME function / int
((comp-decl (decl-spec-list (type-spec (fixed-type ,type))) (comp-declr-list (comp-declr (ptr-declr (pointer) (ident ,name)))))
(cons type name)) ;; FIXME: ptr/char
(_ (stderr "struct-field: no match: ~s\n" o) barf)))
(_ (error "struct-field: unsupported: " o))))
(define (ast->type o)
(pmatch o
@ -924,10 +922,7 @@
(type->size info type))
(_ (let ((type (assoc-ref (.types info) o)))
(if type (cadr type)
(begin
(stderr "***TYPE NOT FOUND**: o=~s\n" o)
barf
4))))))
(error "type->size: unsupported: " o))))))
(define (ident->decl info o)
;; (stderr "ident->decl o=~s\n" o)
@ -1233,7 +1228,7 @@
;; char c = 'A';
((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (char ,value))))))
(if (not (.function info)) decl-barf0)
(if (not (.function info)) (error "ast->info: unsupported: " o))
(let* ((locals (add-local locals name type 0))
(info (clone info #:locals locals))
(value (char->integer (car (string->list value)))))
@ -1250,7 +1245,7 @@
;; int i = argc;
((decl (decl-spec-list (type-spec (fixed-type ,type))) (init-declr-list (init-declr (ident ,name) (initzer (p-expr (ident ,local))))))
(if (not (.function info)) decl-barf2)
(if (not (.function info)) (error "ast->info: unsupported: " o))
(let* ((locals (add-local locals name type 0))
(info (clone info #:locals locals)))
(append-text info (append ((ident->accu info) local)
@ -1258,9 +1253,7 @@
;; char *p = "t.c";
((decl (decl-spec-list (type-spec (fixed-type ,type)) . _) (init-declr-list (init-declr (ptr-declr (pointer) (ident ,name)) (initzer (p-expr (string ,string))))))
(when (not (.function info))
(stderr "o=~s\n" o)
decl-barf3)
(if (not (.function info)) (error "ast->info: unsupported: " o))
(let* ((locals (add-local locals name type 1))
(globals (append globals (list (string->global string))))
(info (clone info #:locals locals #:globals globals)))
@ -1283,8 +1276,7 @@
;; char arena[20000];
((decl (decl-spec-list (type-spec ,type)) (init-declr-list (init-declr (array-of (ident ,name) (p-expr (fixed ,count))))))
(let ((type (ast->type type)))
(if (.function info)
TODO:decl-array
(if (.function info) (error "ast->info: unsupported: " o)
(let* ((globals (.globals info))
(count (cstring->number count))
(size (type->size info type))
@ -1507,10 +1499,7 @@
(format (current-error-port) "SKIP: at=~s\n" o)
info)
((decl . _)
(format (current-error-port) "SKIP: decl statement=~s\n" o)
barf
info)
((decl . _) (error "ast->info: unsupported: " o))
;; ...
((gt . _) ((expr->accu info) o))
@ -1544,20 +1533,13 @@
(int->bv32 value)))
((initzer (p-expr (string ,string)))
(int->bv32 (+ (data-offset (add-s:-prefix string) globals) d)))
(_ (stderr "initzer->data:SKIP: ~s\n" o)
barf
(int->bv32 0))))
(define (info->exe info)
(display "dumping elf\n" (current-error-port))
(for-each write-any (make-elf (.functions info) (.globals info) (.init info))))
(_ (error "initzer->data: unsupported: " o))))
(define (.formals o)
(pmatch o
((fctn-defn _ (ftn-declr _ ,formals) _) formals)
((fctn-defn _ (ptr-declr (pointer) (ftn-declr _ ,formals)) _) formals)
(_ (format (current-error-port) ".formals: no match: ~a\n" o)
barf)))
(_ (error ".formals: " o))))
(define (formal->text n)
(lambda (o i)
@ -1572,8 +1554,7 @@
(wrap-as (append (i386:function-preamble)
(append-map (formal->text n) formals (iota n))
(i386:function-locals)))))
(_ (format (current-error-port) "formals->text: no match: ~a\n" o)
barf)))
(_ (error "formals->text: unsupported: " o))))
(define (formal:ptr o)
(pmatch o
@ -1590,8 +1571,7 @@
((param-list . ,formals)
(let ((n (length formals)))
(map make-local (map .name formals) (map .type formals) (map formal:ptr formals) (iota n -2 -1))))
(_ (format (current-error-port) "formals->info: no match: ~a\n" o)
barf)))
(_ (error "formals->locals: unsupported: " o))))
(define (function->info info)
(lambda (o)
@ -1618,13 +1598,31 @@
(if (null? elements) info
(loop (cdr elements) ((ast->info info) (car elements)))))))
(define (compile)
(define (c99-input->info)
(stderr "COMPILE\n")
(let* ((ast (mescc))
(let* ((ast (c99-input->ast))
(info (make <info>
#:functions i386:libc
#:types i386:type-alist))
(ast (append libc ast))
(info ((ast->info info) ast))
(info ((ast->info info) _start)))
(info->exe info)))
info))
(define (write-any x)
(write-char (cond ((char? x) x)
((and (number? x) (< (+ x 256) 0))
(format (current-error-port) "***BROKEN*** x=~a ==> ~a\n" x (dec->hex x)) (integer->char #xaa))
((number? x) (integer->char (if (>= x 0) x (+ x 256))))
((procedure? x)
(stderr "write-any: proc: ~a\n" x)
(stderr " ==> ~a\n" (map dec->hex (x '() '() 0 0)))
(error "procedure: write-any:" x))
(else (stderr "write-any: ~a\n" x) (error "write-any: else: " x)))))
(define (info->elf info)
(display "dumping elf\n" (current-error-port))
(for-each write-any (make-elf (.functions info) (.globals info) (.init info))))
(define (c99-input->elf)
((compose info->elf c99-input->info)))

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

@ -33,7 +33,10 @@
#:use-module (mes libc-i386)
#:use-module (mes libc)
#:use-module (nyacc lang c99 parser)
#:export (compile))
#:export (c99-input->ast
c99-input->elf
c99-input->info
info->elf))
(cond-expand
(guile-2)

122
module/mes/as-i386.mes
View file

@ -41,25 +41,25 @@
'(#x83 #xec #x40)) ; sub $0x10,%esp -- 16 local vars
(define (i386:push-global-address o)
(or o push-global-address)
(or o (error "invalid value: push-global-address: " o))
`(#x68 ,@(int->bv32 o))) ; push $0x<o>
(define (i386:push-global o)
(or o push-global)
(or o (error "invalid value: push-global: " o))
`(#xa1 ,@(int->bv32 o) ; mov 0x804a000,%eax
#x50)) ; push %eax
(define (i386:push-local n)
(or n push-local)
(or n (error "invalid value: push-local: " n))
`(#xff #x75 ,(- 0 (* 4 n)))) ; pushl 0x<n>(%ebp)
(define (i386:push-local-address n)
(or n push-local-address)
(or n (error "invalid value: push-local-address: " n))
`(#x8d #x45 ,(- 0 (* 4 n)) ; lea 0x<n>(%ebp),%eax
#x50)) ; push %eax
(define (i386:push-local-de-ref n)
(or n push-local-de-ref)
(or n (error "invalid value: push-local-de-ref: " n))
`(#x8b #x45 ,(- 0 (* 4 n)) ; mov -0x<n>(%ebp),%eax
#x0f #xb6 #x00 ; movzbl (%eax),%eax
;;#x0f #xbe #xc0 ; movsbl %al,%eax ***FIXME BYTE****
@ -91,27 +91,27 @@
'(#x88 #x02)) ; mov %al,%(edx)
(define (i386:accu->base-address+n n)
(or n accu->base-address+n)
(or n (error "invalid value: accu->base-address+n: " n))
`(#x89 #x42 ,n)) ; mov %eax,$0x<n>%(edx)
(define (i386:accu->local n)
(or n accu->local)
(or n (error "invalid value: accu->local: " n))
`(#x89 #x45 ,(- 0 (* 4 n)))) ; mov %eax,-<0xn>(%ebp)
(define (i386:base->local n)
(or n base->local)
(or n (error "invalid value: base->local: " n))
`(#x89 #x55 ,(- 0 (* 4 n)))) ; mov %edx,-<0xn>(%ebp)
(define (i386:base->global n)
(or n base->global)
(or n (error "invalid value: base->global: " n))
`(#x89 #x15 ,@(int->bv32 n))) ; mov %edx,0x0
(define (i386:accu->global n)
(or n accu->global)
(or n (error "invalid value: accu->global: " n))
`(#xa3 ,@(int->bv32 n))) ; mov %eax,0x0
(define (i386:accu->global-address n)
(or n accu->global-address)
(or n (error "invalid value: accu->global-address: " n))
`(#x8b #x15 ,@(int->bv32 n) ; mov 0x<n>,%edx
#x89 #x02 )) ; mov %eax,(%edx)
@ -123,7 +123,7 @@
(i386:xor-zf)))
(define (i386:accu-shl n)
(or n accu:shl n)
(or n (error "invalid value: accu:shl n: " n))
`(#xc1 #xe0 ,n)) ; shl $0x8,%eax
(define (i386:accu<<base)
@ -146,7 +146,7 @@
`(#x01 #xd0)) ; add %edx,%eax
(define (i386:accu+value v)
(or v accu+value)
(or v (error "invalid value: accu+value: " v))
`(#x05 ,@(int->bv32 v))) ; add %eax,%eax
(define (i386:accu-base)
@ -170,45 +170,49 @@
'(#x89 #xd0)) ; mov %edx,%eax
(define (i386:local->accu n)
(or n local->accu)
(or n (error "invalid value: local->accu: " n))
`(#x8b #x45 ,(- 0 (* 4 n)))) ; mov -<0xn>(%ebp),%eax
(define (i386:local-address->accu n)
(or n ladd)
(or n (error "invalid value: ladd: " n))
`(#x8d #x45 ,(- 0 (* 4 n)))) ; lea 0x<n>(%ebp),%eax
(define (i386:local-ptr->accu n)
(or n local-ptr->accu)
(or n (error "invalid value: local-ptr->accu: " n))
`(#x89 #xe8 ; mov %ebp,%eax
#x83 #xc0 ,(- 0 (* 4 n)))) ; add $0x<n>,%eax
(define (i386:byte-local->accu n)
(or n byte-local->accu)
(or n (error "invalid value: byte-local->accu: " n))
`(#x0f #xb6 #x45 ,(- 0 (* 4 n)))) ; movzbl 0x<n>(%ebp),%eax
(define (i386:byte-local->base n)
(or n (error "invalid value: byte-local->base: " n))
`(x0f #xb6 #x95 ,(- 0 (* 4 n)))) ; movzbl 0x<n>(%ebp),%edx
(define (i386:local->base n)
(or n local->base)
(or n (error "invalid value: local->base: " n))
`(#x8b #x55 ,(- 0 (* 4 n)))) ; mov -<0xn>(%ebp),%edx
(define (i386:local-address->base n) ;; DE-REF
(or n local-address->base)
(or n (error "invalid value: local-address->base: " n))
`(#x8d #x55 ,(- 0 (* 4 n)))) ; lea 0x<n>(%ebp),%edx
(define (i386:local-ptr->base n)
(or n local-ptr->base)
(or n (error "invalid value: local-ptr->base: " n))
`(#x89 #xea ; mov %ebp,%edx
#x83 #xc2 ,(- 0 (* 4 n)))) ; add $0x<n>,%edx
(define (i386:global->base n)
(or n global->base)
(or n (error "invalid value: global->base: " n))
`(#xba ,@(int->bv32 n))) ; mov $<n>,%edx
(define (i386:global-address->accu n)
(or n global-address->accu)
(or n (error "invalid value: global-address->accu: " n))
`(#xa1 ,@(int->bv32 n))) ; mov 0x<n>,%eax
(define (i386:global-address->base n)
(or n global-address->base)
(or n (error "invalid value: global-address->base: " n))
`(#x8b #x15 ,@(int->bv32 n))) ; mov 0x<n>,%edx
(define (i386:byte-base-mem->accu)
@ -232,19 +236,19 @@
`(#x8b #x40 ,n)) ; mov 0x<n>(%eax),%eax
(define (i386:base-mem+n->accu n)
(or n base-mem+n->accu)
(or n (error "invalid value: base-mem+n->accu: " n))
`(#x01 #xd0 ; add %edx,%eax
#x8b #x40 ,n)) ; mov <n>(%eax),%eax
(define (i386:value->accu v)
(or v urg:value->accu)
(or v (error "invalid value: i386:value->accu: " v))
`(#xb8 ,@(int->bv32 v))) ; mov $<v>,%eax
(define (i386:value->accu-address v)
`(#xc7 #x00 ,@(int->bv32 v))) ; movl $0x<v>,(%eax)
(define (i386:value->accu-address+n n v)
(or v urg:value->accu-address+n)
(or v (error "invalid value: i386:value->accu-address+n: " v))
`(#xc7 #x40 ,n ,@(int->bv32 v))) ; movl $<v>,0x<n>(%eax)
(define (i386:base->accu-address)
@ -264,41 +268,41 @@
'(#x88 #x10)) ; mov %dl,(%eax)
(define (i386:byte-base->accu-address+n n)
(or n byte-base->accu-address+n)
(or n (error "invalid value: byte-base->accu-address+n: " n))
`(#x88 #x50 ,n)) ; mov %dl,0x<n>(%eax)
(define (i386:value->base v)
(or v urg:value->base)
(or v (error "invalid value: i386:value->base: " v))
`(#xba ,@(int->bv32 v))) ; mov $<v>,%edx
(define (i386:local-add n v)
(or n urg:local-add)
(or n (error "invalid value: i386:local-add: " n))
`(#x83 #x45 ,(- 0 (* 4 n)) ,v)) ; addl $<v>,0x<n>(%ebp)
(define (i386:global-add n v)
(or n urg:global-add)
(or n (error "invalid value: i386:global-add: " n))
`(#x83 #x05 ,@(int->bv32 n) ,v)) ; addl $<v>,0x<n>
(define (i386:global->accu o)
(or o urg:global->accu)
(or o (error "invalid value: i386:global->accu: " o))
`(#xb8 ,@(int->bv32 o))) ; mov $<>,%eax
(define (i386:value->global n v)
(or n value->global)
(or n (error "invalid value: value->global: " n))
`(#xc7 #x05 ,@(int->bv32 n) ; movl $<v>,(<n>)
,@(int->bv32 v)))
(define (i386:value->local n v)
(or n value->local)
(or n (error "invalid value: value->local: " n))
`(#xc7 #x45 ,(- 0 (* 4 n)) ; movl $<v>,0x<n>(%ebp)
,@(int->bv32 v)))
(define (i386:local-test n v)
(or n local-test)
(or n (error "invalid value: local-test: " n))
`(#x83 #x7d ,(- 0 (* 4 n)) ,v)) ; cmpl $<v>,0x<n>(%ebp)
(define (i386:call f g ta t d address n)
(or address urg:call)
(or address (error "invalid value: i386:call: " address))
`(#xe8 ,@(int->bv32 (- address 5)) ; call relative $00
#x83 #xc4 ,(* n 4))) ; add $00,%esp
@ -313,7 +317,7 @@
#x0f #xb6 #xc0)) ; movzbl %al,%eax
(define (i386:xor-accu v)
(or n urg:xor-accu)
(or v (error "invalid value: i386:xor-accu: n: " v))
`(#x35 ,@(int->bv32 v))) ;xor $0xff,%eax
(define (i386:xor-zf)
@ -328,59 +332,54 @@
'(#x85 #xc0)) ; test %eax,%eax
(define (i386:Xjump n)
(or n urg:Xjump)
(or n (error "invalid value: i386:Xjump: n: " n))
`(#xe9 ,@(int->bv32 (if (>= n 0) n (- n 5))))) ; jmp . + <n>
(define (i386:XXjump n)
(or n urg:XXjump)
(or n (error "invalid value: i386:XXjump: n: " n))
`(#xe9 ,@(int->bv32 n))) ; jmp . + <n>
(define (i386:Xjump-nz n)
(or n urg:Xjump-nz)
(or n (error "invalid value: i386:Xjump-nz: n: " n))
`(#x0f #x85 ,@(int->bv32 n))) ; jnz . + <n>
(define (i386:Xjump-z n)
(or n urg:Xjump-z)
(or n (error "invalid value: i386:Xjump-z: n: " n))
`(#x0f #x84 ,@(int->bv32 n))) ; jz . + <n>
(define (i386:jump n) ;;FIXME: NEED THIS WEIRDNESS for t.c
(when (or (> n #x80) (< n #x-80))
(format (current-error-port) "JUMP n=~a\n" n)
barf)
(error "JUMP n=" n))
`(#xeb ,(if (>= n 0) (- n 2) (- n 2)))) ; jmp <n>
(define (i386:jump-c n)
(when (or (> n #x80) (< n #x-80))
(format (current-error-port) "JUMP n=~a\n" n)
barf)
(error "JUMP n=" n))
`(#x72 ,(if (>= n 0) n (- n 2)))) ; jc <n>
(define (i386:jump-cz n)
(when (or (> n #x80) (< n #x-80))
(format (current-error-port) "JUMP n=~a\n" n)
barf)
(error "JUMP n=" n))
`(#x76 ,(if (>= n 0) n (- n 2)))) ; jbe <n>
(define (i386:jump-ncz n)
(when (or (> n #x80) (< n #x-80))
(format (current-error-port) "JUMP-ncz n=~a\n" n)
barf)
(error "JUMP-ncz n=" n))
`(#x77 ,(if (>= n 0) n (- n 2)))) ; ja <n>
(define (i386:jump-nc n)
(when (or (> n #x80) (< n #x-80))
(format (current-error-port) "JUMP-nc n=~a\n" n)
barf)
(error "JUMP-nc n=" n))
`(#x73 ,(if (>= n 0) n (- n 2)))) ; jnc <n>
;; unsigned
(define (i386:Xjump-nc n)
(or n urg:Xjump-nc)
(or n (error "invalid value i386:Xjump-nc: " n))
`(#x0f #x83 ,@(int->bv32 n))) ; jnc <n>
;; unsigned
(define (i386:Xjump-ncz n)
(or n urg:Xjump-ncz)
(or n (error "invalid value: i386:Xjump-ncz" n))
`(#x0f #x87 ,@(int->bv32 n))) ; ja <n>
;; unsigned
@ -395,12 +394,12 @@
;; signed
(define (i386:Xjump-g n)
(or n urg:Xjump-g)
(or n (error "invalid value: i386:Xjump-g: " n))
`(#x0f #x8f ,@(int->bv32 n))) ; jg/jnle <n>
;; signed
(define (i386:Xjump-ge n)
(or n urg:Xjump-ge)
(or n (error "invalid value: Xjump-ge: " n))
`(#x0f #x8d ,@(int->bv32 n))) ; jge/jnl <n>
;; ;; signed
@ -415,34 +414,29 @@
(define (i386:jump-z n)
(when (or (> n #x80) (< n #x-80))
(format (current-error-port) "JUMP-z n=~a\n" n)
barf)
(error "JUMP-z n=" n))
`(#x74 ,(if (>= n 0) n (- n 2)))) ; jz <n>
(define (i386:jump-nz n)
(when (or (> n #x80) (< n #x-80))
(format (current-error-port) "JUMP-nz n=~a\n" n)
barf)
(error "JUMP-nz n=" n))
`(#x75 ,(if (>= n 0) n (- n 2)))) ; jnz <n>
(define (i386:test-jump-z n)
(when (or (> n #x80) (< n #x-80))
(format (current-error-port) "JUMP-z n=~a\n" n)
barf)
(error "JUMP-z n=" n))
`(#x85 #xc0 ; test %eax,%eax
#x74 ,(if (>= n 0) n (- n 4)))) ; jz <n>
(define (i386:jump-byte-nz n)
(when (or (> n #x80) (< n #x-80))
(format (current-error-port) "JUMP-byte-nz n=~a\n" n)
barf)
(error "JUMP-byte-nz n=" n))
`(#x84 #xc0 ; test %al,%al
#x75 ,(if (>= n 0) n (- n 4)))) ; jne <n>
(define (i386:jump-byte-z n)
(when (or (> n #x80) (< n #x-80))
(format (current-error-port) "JUMP-byte-z n=~a\n" n)
barf)
(error "JUMP-byte-z n=" n))
`(#x84 #xc0 ; test %al,%al
#x74 ,(if (>= n 0) n (- n 4)))) ; jne <n>

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

@ -62,6 +62,7 @@
i386:byte-base-mem->accu
i386:local-address->accu
i386:byte-local->accu
i386:byte-local->base
i386:byte-mem->accu
i386:base-mem+n->accu
i386:byte-mem->base

6
module/mes/libc.mes
View file

@ -141,11 +141,11 @@ putchar (int c)
parse-c99)))
ast))
(define putc
(define fputc
(let* ((ast (with-input-from-string
"
int
putc (int c, int fd)
fputc (int c, int fd)
{
write (fd, (char*)&c, 1);
return 0;
@ -313,7 +313,7 @@ realloc (int *p, int size)
assert_fail
ungetc
putchar
putc
fputc
eputs
fputs
puts

BIN
module/mes/read-0-32.mo
View file

Binary file not shown.

57
module/module.make Normal file
View file

@ -0,0 +1,57 @@
CLEAN+=module/mes/read-0.mo
module/mes/read-0.mo: module/mes/read-0.mes $(OUT)/mes
@rm -f $@
@echo " DUMP $(notdir $^) -> $(notdir $@)"
$(QUIET)$(OUT)/mes --dump < $< > $@
CLEAN+=module/mes/read-0-32.mo
CROSS:=$(CC32:%gcc=%)
module/mes/read-0-32.mo: CROSS:=$(CROSS)
module/mes/read-0-32.mo: module/mes/read-0.mes
module/mes/read-0-32.mo: $(OUT)/$(CROSS)mes
@rm -f $@
@echo " DUMP $(notdir $^) -> $(notdir $@)"
$(QUIET)MES_MINI=1 $(OUT)/$(CROSS)mes --dump < $< > $@
CLEAN+=module/mes/tiny-0-32.mo
module/mes/tiny-0-32.mo: CROSS:=$(CROSS)
module/mes/tiny-0-32.mo: $(OUT)/$(CROSS)mes
@rm -f $@
@echo " DUMP $(notdir $^) -> $(notdir $@)"
$(QUIET) MES_TINY=1 $(OUT)/$(CROSS)mes --dump --tiny < $< > $@
MO_FILES:=\
module/mes/read-0.mo\
module/mes/read-0-32.mo\
module/mes/tiny-0-32.mo\
#
all-mo: $(MO_FILES)
clean-mo: MO_FILES:=$(MO_FILES)
clean-mo:
@$(QUIET)rm -f $(MO_FILES)
MES_FILES:=$(shell $(GIT_LS_FILES) module/*.mes)
SCM_FILES:=$(shell $(GIT_LS_FILES) module/language/ module/nyacc/ module/mes/)
SCM_FILES:=$(filter %.scm, $(SCM_FILES))
SCM_FILES:=$(filter-out %match.scm, $(SCM_FILES))
SCM_FILES:=$(filter-out %mes/lalr.scm, $(SCM_FILES))
SCM_FILES:=$(filter-out %optargs.scm, $(SCM_FILES))
SCM_FILES:=$(filter-out %pretty-print.scm, $(SCM_FILES))
SCM_FILES:=$(filter-out %syntax.scm, $(SCM_FILES))
SCM_FILES:=$(filter-out module/mes/peg/%.scm, $(SCM_FILES))
SCM_FILES:=$(filter-out module/nyacc/lang/c99/body.scm, $(SCM_FILES))
SCM_FILES:=$(filter-out module/nyacc/lang/c99/mach.d/%.scm, $(SCM_FILES))
SCM_FILES:=$(filter-out module/nyacc/lang/c99/mach.scm, $(SCM_FILES))
SCM_FILES:=$(filter-out module/nyacc/lang/c99/xparser.scm, $(SCM_FILES))
include make/guile.make
# FIXME: https://gitlab.com/janneke/guile/commits/1.8
# Include patches here
GUILE_GIT:=../guile-1.8
GUILE_COMMIT:=ba8a7097699f69b206c9f28c546fa6da88b8656f
psyntax-import: module/mes/psyntax.ss module/mes/psyntax.pp
module/mes/psyntax.%: $(GUILE_GIT)/ice-9/psyntax.%
git --git-dir=$(GUILE_GIT)/.git --work-tree=$(GUILE_GIT) show $(GUILE_COMMIT):ice-9/$(@F > $@
MAINTAINER-CLEAN+=module/mes/psyntax.pp

204
scaffold/cons-mes.c
View file

@ -18,37 +18,35 @@
* along with Mes. If not, see <http://www.gnu.org/licenses/>.
*/
#if __GNUC__
#if POSIX
#error "POSIX not supported"
#endif
#if __MESC__
int g_stdin = 0;
#define assert(x) ((x) ? (void)0 : assert_fail (#x))
#endif
#if !__MESC__
#include "mlibc.c"
#endif
#define assert(x) ((x) ? (void)0 : assert_fail (#x))
#define MES_MINI 1
#define FIXED_PRIMITIVES 0
char arena[2000];
//char buf0[400];
typedef int SCM;
#if __GNUC__
int g_debug = 0;
#endif
int g_free = 0;
SCM g_continuations = 0;
SCM g_symbols = 0;
SCM g_stack = 0;
// a/env
SCM r0 = 0;
// param 1
SCM r1 = 0;
// save 2+load/dump
SCM r2 = 0;
// continuation
SCM r3 = 0;
SCM r0 = 0; // a/env
SCM r1 = 0; // param 1
SCM r2 = 0; // save 2+load/dump
SCM r3 = 0; // continuation
enum type_t {CHAR, CLOSURE, CONTINUATION, TFUNCTION, KEYWORD, MACRO, NUMBER, PAIR, REF, SPECIAL, STRING, SYMBOL, VALUES, VECTOR, BROKEN_HEART};
enum type_t {TCHAR, TCLOSURE, TCONTINUATION, TFUNCTION, TKEYWORD, TMACRO, TNUMBER, TPAIR, TREF, TSPECIAL, TSTRING, TSYMBOL, TVALUES, TVECTOR, TBROKEN_HEART};
struct scm {
enum type_t type;
@ -56,14 +54,17 @@ struct scm {
SCM cdr;
};
typedef int (*f_t) (void);
struct function {
int (*function) (void);
int arity;
char *name;
};
#if __MESC__
struct scm *g_cells = arena;
#else
struct scm *g_cells = (struct scm*)arena;
#endif
#define cell_nil 1
#define cell_f 2
@ -144,8 +145,8 @@ SCM cell_cdr;
#define VALUE(x) g_cells[x].cdr
#define VECTOR(x) g_cells[x].cdr
#define MAKE_CHAR(n) make_cell_ (tmp_num_ (CHAR), 0, tmp_num2_ (n))
#define MAKE_NUMBER(n) make_cell_ (tmp_num_ (NUMBER), 0, tmp_num2_ (n))
#define MAKE_CHAR(n) make_cell_ (tmp_num_ (TCHAR), 0, tmp_num2_ (n))
#define MAKE_NUMBER(n) make_cell_ (tmp_num_ (TNUMBER), 0, tmp_num2_ (n))
#define CAAR(x) CAR (CAR (x))
#define CADAR(x) CAR (CDR (CAR (x)))
@ -167,9 +168,9 @@ SCM
make_cell_ (SCM type, SCM car, SCM cdr)
{
SCM x = alloc (1);
assert (TYPE (type) == NUMBER);
assert (TYPE (type) == TNUMBER);
TYPE (x) = VALUE (type);
if (VALUE (type) == CHAR || VALUE (type) == NUMBER) {
if (VALUE (type) == TCHAR || VALUE (type) == TNUMBER) {
if (car) CAR (x) = CAR (car);
if (cdr) CDR(x) = CDR(cdr);
}
@ -201,46 +202,19 @@ tmp_num2_ (int x)
SCM
cons (SCM x, SCM y)
{
#if 0
puts ("cons x=");
puts (itoa (x));
puts ("\n");
#endif
VALUE (tmp_num) = PAIR;
VALUE (tmp_num) = TPAIR;
return make_cell_ (tmp_num, x, y);
}
SCM
car (SCM x)
{
#if 0
puts ("car x=");
puts (itoa (x));
puts ("\n");
#endif
#if MES_MINI
//Nyacc
//assert ("!car");
#else
if (TYPE (x) != PAIR) error (cell_symbol_not_a_pair, cons (x, cell_symbol_car));
#endif
return CAR (x);
}
SCM
cdr (SCM x)
{
#if 0
puts ("cdr x=");
puts (itoa (x));
puts ("\n");
#endif
#if MES_MINI
//Nyacc
//assert ("!cdr");
#else
if (TYPE (x) != PAIR) error (cell_symbol_not_a_pair, cons (x, cell_symbol_cdr));
#endif
return CDR(x);
}
@ -256,10 +230,7 @@ SCM
append2 (SCM x, SCM y)
{
if (x == cell_nil) return y;
#if __GNUC__
//FIXME GNUC
assert (TYPE (x) == PAIR);
#endif
assert (TYPE (x) == TPAIR);
return cons (car (x), append2 (cdr (x), y));
}
@ -268,7 +239,7 @@ pairlis (SCM x, SCM y, SCM a)
{
if (x == cell_nil)
return a;
if (TYPE (x) != PAIR)
if (TYPE (x) != TPAIR)
return cons (cons (x, y), a);
return cons (cons (car (x), car (y)),
pairlis (cdr (x), cdr (y), a));
@ -277,7 +248,6 @@ pairlis (SCM x, SCM y, SCM a)
SCM
assq (SCM x, SCM a)
{
//while (a != cell_nil && eq_p (x, CAAR (a)) == cell_f) a = CDR (a);
while (a != cell_nil && x == CAAR (a)) a = CDR (a);
return a != cell_nil ? car (a) : cell_f;
}
@ -311,9 +281,6 @@ SCM
eval_apply ()
{
eval_apply:
// if (g_free + GC_SAFETY > ARENA_SIZE)
// gc_pop_frame (gc (gc_push_frame ()));
switch (r3)
{
case cell_vm_apply: {goto apply;}
@ -328,7 +295,6 @@ eval_apply ()
{
case TFUNCTION: {
puts ("apply.function\n");
//check_formals (car (r1), MAKE_NUMBER (FUNCTION (car (r1)).arity), cdr (r1));
r1 = call (car (r1), cdr (r1));
goto vm_return;
}
@ -345,27 +311,18 @@ call (SCM fn, SCM x)
{
puts ("call\n");
if ((FUNCTION (fn).arity > 0 || FUNCTION (fn).arity == -1)
&& x != cell_nil && TYPE (CAR (x)) == VALUES)
&& x != cell_nil && TYPE (CAR (x)) == TVALUES)
x = cons (CADAR (x), CDR (x));
if ((FUNCTION (fn).arity > 1 || FUNCTION (fn).arity == -1)
&& x != cell_nil && TYPE (CDR (x)) == PAIR && TYPE (CADR (x)) == VALUES)
&& x != cell_nil && TYPE (CDR (x)) == TPAIR && TYPE (CADR (x)) == TVALUES)
x = cons (CAR (x), cons (CDADAR (x), CDR (x)));
switch (FUNCTION (fn).arity)
{
// case 0: return FUNCTION (fn).function0 ();
// case 1: return FUNCTION (fn).function1 (car (x));
// case 2: return FUNCTION (fn).function2 (car (x), cadr (x));
// case 3: return FUNCTION (fn).function3 (car (x), cadr (x), car (cddr (x)));
// case -1: return FUNCTION (fn).functionn (x);
case 0: {return (FUNCTION (fn).function) ();}
case 1: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (car (x));}
case 2: {return ((SCM(*)(SCM,SCM))(FUNCTION (fn).function)) (car (x), cadr (x));}
case 3: {return ((SCM(*)(SCM,SCM,SCM))(FUNCTION (fn).function)) (car (x), cadr (x), car (cddr (x)));}
#if __GNUC__
// FIXME GNUC
case -1: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);}
#endif
default: {return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);}
}
return cell_unspecified;
}
@ -375,24 +332,9 @@ gc_peek_frame ()
{
SCM frame = car (g_stack);
r1 = car (frame);
#if __GNUC__
r2 = cadr (frame);
r3 = car (cddr (frame));
r0 = cadr (cddr (frame));
#else
r2 = cdr (frame);
r2 = car (r2);
r3 = cdr (frame);
r3 = cdr (r3);
r3 = car (r3);
r0 = cdr (frame);
r0 = cdr (r0);
r0 = cdr (r0);
r0 = cdr (r0);
r0 = car (r0);
#endif
return frame;
}
@ -420,18 +362,18 @@ SCM
make_tmps (struct scm* cells)
{
tmp = g_free++;
cells[tmp].type = CHAR;
cells[tmp].type = TCHAR;
tmp_num = g_free++;
cells[tmp_num].type = NUMBER;
cells[tmp_num].type = TNUMBER;
tmp_num2 = g_free++;
cells[tmp_num2].type = NUMBER;
cells[tmp_num2].type = TNUMBER;
return 0;
}
SCM
make_symbol_ (SCM s)
{
VALUE (tmp_num) = SYMBOL;
VALUE (tmp_num) = TSYMBOL;
SCM x = make_cell_ (tmp_num, s, 0);
g_symbols = cons (x, g_symbols);
return x;
@ -440,11 +382,7 @@ make_symbol_ (SCM s)
SCM
make_symbol (SCM s)
{
#if MES_MINI
SCM x = 0;
#else
SCM x = lookup_symbol_ (s);
#endif
return x ? x : make_symbol_ (s);
}
@ -552,7 +490,7 @@ g_free++;
SCM
make_closure (SCM args, SCM body, SCM a)
{
return make_cell_ (tmp_num_ (CLOSURE), cell_f, cons (cons (cell_circular, a), cons (args, body)));
return make_cell_ (tmp_num_ (TCLOSURE), cell_f, cons (cons (cell_circular, a), cons (args, body)));
}
SCM
@ -640,7 +578,7 @@ fill ()
CAR (0) = 0x6a746f6f;
CDR (0) = 0x00002165;
TYPE (1) = SYMBOL;
TYPE (1) = TSYMBOL;
CAR (1) = 0x2d2d2d2d;
CDR (1) = 0x3e3e3e3e;
@ -649,7 +587,7 @@ fill ()
CDR (9) = 0x3e3e3e3e;
// (cons 0 1)
TYPE (10) = PAIR;
TYPE (10) = TPAIR;
CAR (10) = 11;
CDR (10) = 12;
@ -660,20 +598,20 @@ fill ()
// 2 = car
CDR (11) = 1;
TYPE (12) = PAIR;
TYPE (12) = TPAIR;
CAR (12) = 13;
//CDR (12) = 1;
CDR (12) = 14;
TYPE (13) = NUMBER;
TYPE (13) = TNUMBER;
CAR (13) = 0x58585858;
CDR (13) = 0;
TYPE (14) = PAIR;
TYPE (14) = TPAIR;
CAR (14) = 15;
CDR (14) = 1;
TYPE (15) = NUMBER;
TYPE (15) = TNUMBER;
CAR (15) = 0x58585858;
CDR (15) = 1;
@ -686,7 +624,7 @@ display_ (SCM x)
//puts ("<display>\n");
switch (TYPE (x))
{
case CHAR:
case TCHAR:
{
//puts ("<char>\n");
puts ("#\\");
@ -706,7 +644,7 @@ display_ (SCM x)
puts ("cdr");
break;
}
case NUMBER:
case TNUMBER:
{
//puts ("<number>\n");
#if __GNUC__
@ -719,7 +657,7 @@ display_ (SCM x)
#endif
break;
}
case PAIR:
case TPAIR:
{
//puts ("<pair>\n");
//if (cont != cell_f) puts "(");
@ -728,13 +666,13 @@ display_ (SCM x)
if (CDR (x) && CDR (x) != cell_nil)
{
#if __GNUC__
if (TYPE (CDR (x)) != PAIR)
if (TYPE (CDR (x)) != TPAIR)
puts (" . ");
#else
int c;
c = CDR (x);
c = TYPE (c);
if (c != PAIR)
if (c != TPAIR)
puts (" . ");
#endif
display_ (CDR (x));
@ -743,7 +681,7 @@ display_ (SCM x)
puts (")");
break;
}
case SPECIAL:
case TSPECIAL:
{
switch (x)
{
@ -763,7 +701,7 @@ display_ (SCM x)
}
break;
}
case SYMBOL:
case TSYMBOL:
{
switch (x)
{
@ -821,32 +759,23 @@ simple_bload_env (SCM a) ///((internal))
char *p = (char*)g_cells;
int c;
#if 0
//__GNUC__
puts ("fd: ");
puts (itoa (g_stdin));
puts ("\n");
#endif
assert (getchar () == 'M');
assert (getchar () == 'E');
assert (getchar () == 'S');
puts (" *GOT MES*\n");
g_stack = getchar () << 8;
g_stack += getchar ();
#if __GNUC__
puts ("stack: ");
puts (itoa (g_stack));
puts ("\n");
#endif
c = getchar ();
while (c != -1)
{
*p++ = c;
c = getchar ();
putchar (c);
}
puts ("read done\n");
@ -855,18 +784,13 @@ simple_bload_env (SCM a) ///((internal))
if (g_free != 15) exit (33);
#if 0
gc_peek_frame ();
g_symbols = r1;
#else
g_symbols = 1;
#endif
g_stdin = STDIN;
r0 = mes_builtins (r0);
if (g_free != 19) exit (34);
#if __GNUC__
puts ("cells read: ");
puts (itoa (g_free));
puts ("\n");
@ -876,7 +800,6 @@ simple_bload_env (SCM a) ///((internal))
puts ("\n");
// display_ (g_symbols);
// puts ("\n");
#endif
display_ (10);
puts ("\n");
@ -884,13 +807,11 @@ simple_bload_env (SCM a) ///((internal))
fill ();
r2 = 10;
if (TYPE (12) != PAIR)
if (TYPE (12) != TPAIR)
exit (33);
puts ("program[");
#if __GNUC__
puts (itoa (r2));
#endif
puts ("]: ");
display_ (r2);
@ -916,24 +837,14 @@ main (int argc, char *argv[])
r0 = mes_environment ();
#if MES_MINI
SCM program = simple_bload_env (r0);
#else
SCM program = (argc > 1 && !strcmp (argv[1], "--load"))
? bload_env (r0) : load_env (r0);
if (argc > 1 && !strcmp (argv[1], "--dump")) return dump ();
#endif
#if __GNUC__
puts ("g_free=");
puts (itoa(g_free));
puts ("\n");
#endif
push_cc (r2, cell_unspecified, r0, cell_unspecified);
#if __GNUC__
puts ("g_free=");
puts (itoa(g_free));
puts ("\n");
@ -957,27 +868,16 @@ main (int argc, char *argv[])
puts ("r3=");
puts (itoa(r3));
puts ("\n");
#endif
r3 = cell_vm_apply;
r1 = eval_apply ();
display_ (r1);
eputs ("\n");
#if !MES_MINI
gc (g_stack);
#endif
#if __GNUC__
if (g_debug)
{
eputs ("\nstats: [");
eputs (itoa (g_free));
eputs ("]\n");
}
#endif
return 0;
}
#if __GNUC__
#if !__MESC__
#include "mstart.c"
#endif

9
scaffold/hello.c
View file

@ -18,7 +18,7 @@
* along with Mes. If not, see <http://www.gnu.org/licenses/>.
*/
#if __GNUC__
#if !__MESC__
#include "mlibc.c"
#endif
@ -26,10 +26,15 @@ int
main (int argc, char *argv[])
{
puts ("Hi Mes!\n");
#if __MESC_MES__
puts ("MESC.MES\n");
#else
puts ("MESC.GUILE\n");
#endif
if (argc > 1 && !strcmp (argv[1], "--help")) {puts ("argc > 1 && --help\n"); return argc;}
return 42;
}
#if __GNUC__
#if !__MESC__ && !POSIX
#include "mstart.c"
#endif

9
scaffold/m.c
View file

@ -18,23 +18,22 @@
* along with Mes. If not, see <http://www.gnu.org/licenses/>.
*/
#if __GNUC__
#if !__MESC__
#include "mlibc.c"
#endif
#define assert(x) ((x) ? (void)0 : assert_fail (#x))
int
main (int argc, char *argv[])
{
g_stdin = open ("mesmes", 0);
g_stdin = open ("scaffold/mesmes", 0);
int c = getchar ();
while (c != -1) {
while (c != EOF) {
putchar (c);
c = getchar ();
}
return c;
}
#if __GNUC__
#if !__MESC__ && !POSIX
#include "mstart.c"
#endif

12
scaffold/malloc.c
View file

@ -18,10 +18,18 @@
* along with Mes. If not, see <http://www.gnu.org/licenses/>.
*/
#if __GNUC__
#if POSIX
#error "POSIX not supported"
#endif
#if __MESC__
int g_stdin = 0;
#define assert(x) ((x) ? (void)0 : assert_fail (#x))
#endif
#if !__MESC__
#include "mlibc.c"
#endif
#define assert(x) ((x) ? (void)0 : assert_fail (#x))
int
main (int argc, char *argv[])

1
scaffold/mesmes Normal file
View file

@ -0,0 +1 @@
mesmes

42
scaffold/micro-mes.c
View file

@ -18,13 +18,13 @@
* along with Mes. If not, see <http://www.gnu.org/licenses/>.
*/
#if __GNUC__
#if POSIX
#error "POSIX not supported"
#endif
#if !__MESC__
#include "mlibc.c"
#endif
#define assert(x) ((x) ? (void)0 : assert_fail(#x))
#define MES_MINI 1
typedef int SCM;
@ -62,44 +62,18 @@ main (int argc, char *argv[])
#endif
//if (getenv ("MES_ARENA")) ARENA_SIZE = atoi (getenv ("MES_ARENA"));
if (argc > 1 && !strcmp (argv[1], "--help")) return eputs ("Usage: mes [--dump|--load] < FILE\n");
//FIXME: Nyacc on mes barfs: unhandled exception: not-a-pair (("0.4" . car))
// FIXME
//if (argc > 1 && !strcmp (argv[1], "--help")) return eputs ("Usage: mes [--dump|--load] < FILE\n");
//if (argc > 1 && !strcmp (argv[1], "--version")) {eputs ("Mes ");eputs (VERSION);return eputs ("\n");};
#if __GNUC__
g_stdin = STDIN;
r0 = mes_environment ();
#endif
#if MES_MINI
puts ("Hello micro-mes!\n");
SCM program = bload_env (r0);
#else
SCM program = (argc > 1 && !strcmp (argv[1], "--load"))
? bload_env (r0) : load_env (r0);
if (argc > 1 && !strcmp (argv[1], "--dump")) return dump ();
push_cc (r2, cell_unspecified, r0, cell_unspecified);
r3 = cell_vm_begin;
r1 = eval_apply ();
eputs ("\n");
gc (g_stack);
#endif
int i = argc;
//int i = strcmp (argv[1], "1");
return i;
#if __GNUC__
if (g_debug)
{
eputs ("\nstats: [");
eputs (itoa (g_free));
eputs ("]\n");
}
#endif
return 0;
}
#if __GNUC__
#if !__MESC__
#include "mstart.c"
#endif

194
scaffold/mini-mes.c
View file

@ -18,24 +18,24 @@
* along with Mes. If not, see <http://www.gnu.org/licenses/>.
*/
#if POSIX
#error "POSIX not supported"
#endif
#if __MESC__
int g_stdin = 0;
#define assert(x) ((x) ? (void)0 : assert_fail (#x))
#endif
#if !__MESC__
#include "mlibc.c"
#endif
#define assert(x) ((x) ? (void)0 : assert_fail (#x))
#define FIXED_PRIMITIVES 1
#define MES_GC 1
#if MES_GC
int ARENA_SIZE = 100000;
#else
int ARENA_SIZE = 1000000000;
#endif
int MAX_ARENA_SIZE = 40000000;
int GC_SAFETY = 10000;
char *g_arena = 0;
typedef int SCM;
int g_debug = 0;
@ -156,7 +156,7 @@ struct scm scm_symbol_mesc = {TSYMBOL, "%mesc",0};
struct scm scm_test = {TSYMBOL, "test",0};
#include "mini-mes.symbols.h"
#include "mes.mes.symbols.h"
SCM tmp;
SCM tmp_num;
@ -165,13 +165,13 @@ SCM tmp_num2;
struct function g_functions[200];
int g_function = 0;
#include "mini-gc.h"
#include "mini-lib.h"
#include "mini-math.h"
#include "mini-mes.h"
#include "mini-posix.h"
// #include "mini-reader.h"
#include "mini-vector.h"
#include "gc.mes.h"
#include "lib.mes.h"
#include "math.mes.h"
#include "mes.mes.h"
#include "posix.mes.h"
// #include "reader.mes.h"
#include "vector.mes.h"
#define TYPE(x) g_cells[x].type
#define CAR(x) g_cells[x].car
@ -268,11 +268,11 @@ make_symbol_ (SCM s) ///((internal))
SCM
list_of_char_equal_p (SCM a, SCM b) ///((internal))
{
while (a != cell_nil && b != cell_nil && VALUE (car (a)) == VALUE (car (b))) {
assert (TYPE (car (a)) == TCHAR);
assert (TYPE (car (b)) == TCHAR);
a = cdr (a);
b = cdr (b);
while (a != cell_nil && b != cell_nil && VALUE (CAR (a)) == VALUE (CAR (b))) {
assert (TYPE (CAR (a)) == TCHAR);
assert (TYPE (CAR (b)) == TCHAR);
a = CDR (a);
b = CDR (b);
}
return (a == cell_nil && b == cell_nil) ? cell_t : cell_f;
}
@ -282,10 +282,10 @@ lookup_symbol_ (SCM s)
{
SCM x = g_symbols;
while (x) {
if (list_of_char_equal_p (STRING (car (x)), s) == cell_t) break;
x = cdr (x);
if (list_of_char_equal_p (STRING (CAR (x)), s) == cell_t) break;
x = CDR (x);
}
if (x) x = car (x);
if (x) x = CAR (x);
if (!x) x = make_symbol_ (s);
return x;
}
@ -392,7 +392,7 @@ length (SCM x)
{
n++;
if (TYPE (x) != TPAIR) return MAKE_NUMBER (-1);
x = cdr (x);
x = CDR (x);
}
return MAKE_NUMBER (n);
}
@ -514,18 +514,18 @@ call (SCM fn, SCM x)
x = cons (CAR (x), cons (CDADAR (x), CDR (x)));
switch (FUNCTION (fn).arity)
{
#if __MESC__
#if __MESC__ || !_POSIX_SOURCE
case 0: return (FUNCTION (fn).function) ();
case 1: return ((SCM(*)(SCM))(FUNCTION (fn).function)) (CAR (x));
case 2: return ((SCM(*)(SCM,SCM))(FUNCTION (fn).function)) (CAR (x), CADR (x));
case 3: return ((SCM(*)(SCM,SCM,SCM))(FUNCTION (fn).function)) (CAR (x), CADR (x), car (CDDR (x)));
case 3: return ((SCM(*)(SCM,SCM,SCM))(FUNCTION (fn).function)) (CAR (x), CADR (x), CAR (CDDR (x)));
case -1: return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);
default: return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);
#else
case 0: return FUNCTION (fn).function0 ();
case 1: return FUNCTION (fn).function1 (car (x));
case 2: return FUNCTION (fn).function2 (car (x), CADR (x));
case 3: return FUNCTION (fn).function3 (car (x), CADR (x), car (CDDR (x)));
case 1: return FUNCTION (fn).function1 (CAR (x));
case 2: return FUNCTION (fn).function2 (CAR (x), CADR (x));
case 3: return FUNCTION (fn).function3 (CAR (x), CADR (x), CAR (CDDR (x)));
case -1: return FUNCTION (fn).functionn (x);
#endif
}
@ -626,7 +626,7 @@ SCM
gc_pop_frame () ///((internal))
{
SCM frame = gc_peek_frame (g_stack);
g_stack = cdr (g_stack);
g_stack = CDR (g_stack);
return frame;
}
@ -668,15 +668,14 @@ eval_apply ()
}
SCM x = cell_nil;
SCM y = cell_nil;
evlis:
gc_check ();
if (r1 == cell_nil) goto vm_return;
if (TYPE (r1) != TPAIR) goto eval;
push_cc (car (r1), r1, r0, cell_vm_evlis2);
push_cc (CAR (r1), r1, r0, cell_vm_evlis2);
goto eval;
evlis2:
push_cc (cdr (r2), r1, r0, cell_vm_evlis3);
push_cc (CDR (r2), r1, r0, cell_vm_evlis3);
goto evlis;
evlis3:
r1 = cons (r2, r1);
@ -684,22 +683,22 @@ eval_apply ()
apply:
gc_check ();
switch (TYPE (car (r1)))
switch (TYPE (CAR (r1)))
{
case TFUNCTION: {
check_formals (car (r1), MAKE_NUMBER (FUNCTION (car (r1)).arity), cdr (r1));
r1 = call (car (r1), cdr (r1)); /// FIXME: move into eval_apply
check_formals (CAR (r1), MAKE_NUMBER (FUNCTION (CAR (r1)).arity), CDR (r1));
r1 = call (CAR (r1), CDR (r1)); /// FIXME: move into eval_apply
goto vm_return;
}
case TCLOSURE:
{
SCM cl = CLOSURE (car (r1));
SCM cl = CLOSURE (CAR (r1));
SCM formals = CADR (cl);
SCM body = CDDR (cl);
SCM aa = CDAR (cl);
aa = cdr (aa);
check_formals (car (r1), formals, cdr (r1));
SCM p = pairlis (formals, cdr (r1), aa);
aa = CDR (aa);
check_formals (CAR (r1), formals, CDR (r1));
SCM p = pairlis (formals, CDR (r1), aa);
call_lambda (body, p, aa, r0);
goto begin;
}
@ -713,7 +712,7 @@ eval_apply ()
}
case TSPECIAL:
{
switch (car (r1))
switch (CAR (r1))
{
case cell_vm_apply:
{
@ -727,20 +726,20 @@ eval_apply ()
}
case cell_call_with_current_continuation:
{
r1 = cdr (r1);
r1 = CDR (r1);
goto call_with_current_continuation;
}
default: check_apply (cell_f, car (r1));
default: check_apply (cell_f, CAR (r1));
}
}
case TSYMBOL:
{
if (car (r1) == cell_symbol_call_with_values)
if (CAR (r1) == cell_symbol_call_with_values)
{
r1 = cdr (r1);
r1 = CDR (r1);
goto call_with_values;
}
if (car (r1) == cell_symbol_current_module)
if (CAR (r1) == cell_symbol_current_module)
{
r1 = r0;
goto vm_return;
@ -753,21 +752,21 @@ eval_apply ()
{
case cell_symbol_lambda:
{
SCM formals = CADR (car (r1));
SCM body = CDDR (car (r1));
SCM p = pairlis (formals, cdr (r1), r0);
check_formals (r1, formals, cdr (r1));
SCM formals = CADR (CAR (r1));
SCM body = CDDR (CAR (r1));
SCM p = pairlis (formals, CDR (r1), r0);
check_formals (r1, formals, CDR (r1));
call_lambda (body, p, p, r0);
goto begin;
}
}
}
}
push_cc (car (r1), r1, r0, cell_vm_apply2);
push_cc (CAR (r1), r1, r0, cell_vm_apply2);
goto eval;
apply2:
check_apply (r1, car (r2));
r1 = cons (r1, cdr (r2));
check_apply (r1, CAR (r2));
r1 = cons (r1, CDR (r2));
goto apply;
eval:
@ -776,20 +775,20 @@ eval_apply ()
{
case TPAIR:
{
switch (car (r1))
switch (CAR (r1))
{
#if FIXED_PRIMITIVES
case cell_symbol_car:
{
push_cc (CADR (r1), r1, r0, cell_vm_eval_car); goto eval;
eval_car:
x = r1; gc_pop_frame (); r1 = car (x); goto eval_apply;
x = r1; gc_pop_frame (); r1 = CAR (x); goto eval_apply;
}
case cell_symbol_cdr:
{
push_cc (CADR (r1), r1, r0, cell_vm_eval_cdr); goto eval;
eval_cdr:
x = r1; gc_pop_frame (); r1 = cdr (x); goto eval_apply;
x = r1; gc_pop_frame (); r1 = CDR (x); goto eval_apply;
}
case cell_symbol_cons: {
push_cc (CDR (r1), r1, r0, cell_vm_eval_cons); goto evlis;
@ -817,10 +816,10 @@ eval_apply ()
r1 = make_closure_ (CADR (r1), CDDR (r1), assq (cell_closure, r0));
goto vm_return;
}
case cell_symbol_if: {r1=cdr (r1); goto vm_if;}
case cell_symbol_if: {r1=CDR (r1); goto vm_if;}
case cell_symbol_set_x:
{
push_cc (car (CDDR (r1)), r1, r0, cell_vm_eval_set_x);
push_cc (CAR (CDDR (r1)), r1, r0, cell_vm_eval_set_x);
goto eval;
eval_set_x:
x = r2;
@ -836,21 +835,20 @@ eval_apply ()
push_cc (r1, r1, r0, cell_vm_eval_macro);
goto macro_expand;
eval_macro:
x = r2;
if (r1 != r2)
{
if (TYPE (r1) == TPAIR)
{
set_cdr_x (r2, cdr (r1));
set_car_x (r2, car (r1));
set_cdr_x (r2, CDR (r1));
set_car_x (r2, CAR (r1));
}
goto eval;
}
push_cc (car (r1), r1, r0, cell_vm_eval_check_func); goto eval;
push_cc (CAR (r1), r1, r0, cell_vm_eval_check_func); goto eval;
eval_check_func:
push_cc (CDR (r2), r2, r0, cell_vm_eval2); goto evlis;
eval2:
r1 = cons (car (r2), r1);
r1 = cons (CAR (r2), r1);
goto apply;
}
}
@ -867,7 +865,7 @@ eval_apply ()
SCM expanders;
macro_expand:
if (TYPE (r1) == TPAIR
&& (macro = lookup_macro_ (car (r1), r0)) != cell_f)
&& (macro = lookup_macro_ (CAR (r1), r0)) != cell_f)
{
r1 = cons (macro, CDR (r1));
goto apply;
@ -893,18 +891,18 @@ eval_apply ()
if (TYPE (r1) == TPAIR && TYPE (CAR (r1)) == TPAIR)
{
if (CAAR (r1) == cell_symbol_begin)
r1 = append2 (CDAR (r1), cdr (r1));
r1 = append2 (CDAR (r1), CDR (r1));
else if (CAAR (r1) == cell_symbol_primitive_load)
{
push_cc (cons (cell_symbol_read_input_file, cell_nil), r1, r0, cell_vm_begin_read_input_file);
goto apply;
begin_read_input_file:
r1 = append2 (r1, cdr (r2));
r1 = append2 (r1, CDR (r2));
}
}
if (CDR (r1) == cell_nil)
{
r1 = car (r1);
r1 = CAR (r1);
goto eval;
}
push_cc (CAR (r1), r1, r0, cell_vm_begin2);
@ -917,7 +915,7 @@ eval_apply ()
goto vm_return;
vm_if:
push_cc (car (r1), r1, r0, cell_vm_if_expr);
push_cc (CAR (r1), r1, r0, cell_vm_if_expr);
goto eval;
if_expr:
x = r1;
@ -929,7 +927,7 @@ eval_apply ()
}
if (CDDR (r1) != cell_nil)
{
r1 = car (CDDR (r1));
r1 = CAR (CDDR (r1));
goto eval;
}
r1 = cell_unspecified;
@ -939,14 +937,14 @@ eval_apply ()
gc_push_frame ();
x = MAKE_CONTINUATION (g_continuations++);
gc_pop_frame ();
push_cc (cons (car (r1), cons (x, cell_nil)), x, r0, cell_vm_call_with_current_continuation2);
push_cc (cons (CAR (r1), cons (x, cell_nil)), x, r0, cell_vm_call_with_current_continuation2);
goto apply;
call_with_current_continuation2:
CONTINUATION (r2) = g_stack;
goto vm_return;
call_with_values:
push_cc (cons (car (r1), cell_nil), r1, r0, cell_vm_call_with_values2);
push_cc (cons (CAR (r1), cell_nil), r1, r0, cell_vm_call_with_values2);
goto apply;
call_with_values2:
if (TYPE (r1) == TVALUES)
@ -1004,13 +1002,8 @@ SCM g_symbol_max;
SCM
gc_init_cells () ///((internal))
{
//return 0;
//g_cells = (scm *)malloc (ARENA_SIZE);
//int size = ARENA_SIZE * sizeof (struct scm);
int size = ARENA_SIZE * 12;
#if MES_GC
size = size * 2;
#endif
#if __GNUC__
g_arena = (char*)malloc (size);
#else
@ -1071,11 +1064,9 @@ SCM
mes_symbols () ///((internal))
{
gc_init_cells ();
#if MES_GC
gc_init_news ();
#endif
#include "mini-mes.symbols.i"
#include "mes.mes.symbols.i"
g_symbol_max = g_free;
make_tmps (g_cells);
@ -1086,7 +1077,7 @@ mes_symbols () ///((internal))
SCM a = cell_nil;
#include "mini-mes.symbol-names.i"
#include "mes.mes.symbol-names.i"
a = acons (cell_symbol_mes_version, MAKE_STRING (cstring_to_list (VERSION)), a);
a = acons (cell_symbol_mes_prefix, MAKE_STRING (cstring_to_list (PREFIX)), a);
@ -1121,23 +1112,23 @@ mes_environment () ///((internal))
SCM
mes_builtins (SCM a) ///((internal))
{
#include "mini-mes.i"
#include "mes.mes.i"
// Do not sort: Order of these includes define builtins
#include "mini-posix.i"
#include "mini-math.i"
#include "mini-lib.i"
#include "mini-vector.i"
#include "mini-gc.i"
// #include "mini-reader.i"
#include "posix.mes.i"
#include "math.mes.i"
#include "lib.mes.i"
#include "vector.mes.i"
#include "gc.mes.i"
// #include "reader.mes.i"
#include "mini-gc.environment.i"
#include "mini-lib.environment.i"
#include "mini-math.environment.i"
#include "mini-mes.environment.i"
#include "mini-posix.environment.i"
// #include "mini-reader.environment.i"
#include "mini-vector.environment.i"
#include "gc.mes.environment.i"
#include "lib.mes.environment.i"
#include "math.mes.environment.i"
#include "mes.mes.environment.i"
#include "posix.mes.environment.i"
// #include "reader.mes.environment.i"
#include "vector.mes.environment.i"
return a;
}
@ -1221,16 +1212,11 @@ main (int argc, char *argv[])
g_stdin = STDIN;
r0 = mes_environment ();
#if __MESC__
SCM program = bload_env (r0);
#else
SCM program = (argc > 1 && !strcmp (argv[1], "--load"))
? bload_env (r0) : load_env (r0);
if (argc > 1 && !strcmp (argv[1], "--dump")) return dump ();
#endif
SCM lst = cell_nil;
#if !__MESC__
for (int i=argc-1; i>=0; i--) lst = cons (MAKE_STRING (cstring_to_list (argv[i])), lst);
#endif
r0 = acons (cell_symbol_argv, lst, r0);
push_cc (r2, cell_unspecified, r0, cell_unspecified);
if (g_debug)
@ -1253,6 +1239,6 @@ main (int argc, char *argv[])
return 0;
}
#if __GNUC__
#if !__MESC__
#include "mstart.c"
#endif

232
scaffold/scaffold.make Normal file
View file

@ -0,0 +1,232 @@
TARGET:=m
C_FILES:=$(DIR)/m.c
DEFINES:=POSIX=1
INCLUDES:=libc
include make/bin.make
TARGET:=m
EXPECT:=255
include make/check.make
TARGET:=hello
C_FILES:=$(DIR)/hello.c
DEFINES:=POSIX=1
INCLUDES:=libc
include make/bin.make
TARGET:=hello
EXPECT:=42
include make/check.make
TARGET:=t
C_FILES:=$(DIR)/t.c
DEFINES:=POSIX=1
INCLUDES:=libc
include make/bin.make
TARGET:=t
include make/check.make
TARGET:=m.mlibc
C_FILES:=$(DIR)/m.c
INCLUDES:=libc
C_FLAGS:=-nostdinc
LD_FLAGS:=-nostdlib
CROSS:=$(CC32:%gcc=%)
include make/bin.make
TARGET:=m.mlibc
EXPECT:=255
include make/check.make
TARGET:=hello.mlibc
C_FILES:=$(DIR)/hello.c
INCLUDES:=libc
C_FLAGS:=-nostdinc
LD_FLAGS:=-nostdlib
CROSS:=$(CC32:%gcc=%)
include make/bin.make
TARGET:=hello.mlibc
EXPECT:=42
include make/check.make
TARGET:=micro-mes.mlibc
C_FILES:=$(DIR)/micro-mes.c
INCLUDES:=libc
C_FLAGS:=-nostdinc
LD_FLAGS:=-nostdlib
CROSS:=$(CC32:%gcc=%)
include make/bin.make
TEST:=micro-mes.mlibc-check
$(TEST): $(OUT)/micro-mes.mlibc
$< 2 3; r=$$?; [ $$r = 3 ]
include make/check.make
TARGET:=tiny-mes.mlibc
C_FILES:=$(DIR)/tiny-mes.c
INCLUDES:=libc
C_FLAGS:=-nostdinc
LD_FLAGS:=-nostdlib
CROSS:=$(CC32:%gcc=%)
include make/bin.make
TARGET:=tiny-mes.mlibc
include make/check.make
TARGET:=cons-mes.mlibc
C_FILES:=$(DIR)/cons-mes.c
INCLUDES:=libc
C_FLAGS:=-nostdinc
LD_FLAGS:=-nostdlib
DEFINES:=VERSION='"$(VERSION)"'
CROSS:=$(CC32:%gcc=%)
include make/bin.make
TARGET:=cons-mes.mlibc
include make/check.make
TARGET:=t.mlibc
C_FILES:=$(DIR)/t.c
INCLUDES:=libc
C_FLAGS:=-nostdinc
LD_FLAGS:=-nostdlib
CROSS:=$(CC32:%gcc=%)
include make/bin.make
TARGET:=t.mlibc
include make/check.make
$(OUT)/mini-mes: $(SNARF.MES)
TARGET:=mini-mes.mlibc
C_FILES:=$(DIR)/mini-mes.c
DEFINES:=FIXED_PRIMITIVES=1 VERSION='"$(VERSION)"' PREFIX='"$(PREFIX)"'
INCLUDES:=libc src $(OUT)/src
C_FLAGS:=-nostdinc
LD_FLAGS:=-nostdlib
CROSS:=$(CC32:%gcc=%)
include make/bin.make
TEST:=mini-mes.mlibc-check
$(TEST): $(OUT)/mini-mes.mlibc
echo 0 | $<
include make/check.make
# guile/mescc.scm
TARGET:=m.guile
C_FILES:=$(DIR)/m.c
include make/mescc-guile.make
TARGET:=m.guile
EXPECT:=255
include make/check.make
TARGET:=hello.guile
C_FILES:=$(DIR)/hello.c
include make/mescc-guile.make
TARGET:=hello.guile
EXPECT:=42
include make/check.make
TARGET:=micro-mes.guile
C_FILES:=$(DIR)/micro-mes.c
include make/mescc-guile.make
TEST:=micro-mes.guile-check
$(TEST): $(OUT)/micro-mes.guile
$< 2 3; r=$$?; [ $$r = 3 ]
include make/check.make
$(OUT)/tiny-mes.mes: module/mes/tiny-0-32.mo
TARGET:=tiny-mes.guile
C_FILES:=$(DIR)/tiny-mes.c
include make/mescc-guile.make
TARGET:=tiny-mes.guile
include make/check.make
TARGET:=cons-mes.guile
C_FILES:=$(DIR)/cons-mes.c
include make/mescc-guile.make
TARGET:=cons-mes.guile
include make/check.make
TARGET:=t.guile
C_FILES:=$(DIR)/t.c
include make/mescc-guile.make
TARGET:=t.guile
include make/check.make
$(OUT)/mini-mes.guile: module/mes/read-0-32.mo
TARGET:=mini-mes.guile
C_FILES:=$(DIR)/mini-mes.c
include make/mescc-guile.make
TEST:=mini-mes.guile-check
$(TEST): $(OUT)/mini-mes.guile
echo 0 | $<
include make/check.make
# scripts/mescc.mes
TARGET:=m.mes
C_FILES:=$(DIR)/m.c
include make/mescc-mes.make
TARGET:=m.mes
EXPECT:=255
include make/check.make
ifneq ($(SCAFFOLD),)
TARGET:=hello.mes
C_FILES:=$(DIR)/hello.c
include make/mescc-mes.make
TARGET:=hello.mes
EXPECT:=42
include make/check.make
TARGET:=micro-mes.mes
C_FILES:=$(DIR)/micro-mes.c
include make/mescc-mes.make
TEST:=micro-mes.mes-check
$(TEST): $(OUT)/micro-mes.mes
$< 2 3; r=$$?; [ $$r = 3 ]
include make/check.make
$(OUT)/tiny-mes.mes: module/mes/tiny-0-32.mo
TARGET:=tiny-mes.mes
C_FILES:=$(DIR)/tiny-mes.c
include make/mescc-mes.make
TARGET:=tiny-mes.mes
include make/check.make
TARGET:=cons-mes.mes
C_FILES:=$(DIR)/cons-mes.c
include make/mescc-mes.make
TARGET:=cons-mes.mes
include make/check.make
endif # !SCAFFOLD
TARGET:=t.mes
C_FILES:=$(DIR)/t.c
include make/mescc-mes.make
TARGET:=t.mes
include make/check.make
ifneq ($(BOOTSTRAP),)
$(OUT)/mini-mes.mes: module/mes/read-0-32.mo
TARGET:=mini-mes.mes
C_FILES:=$(DIR)/mini-mes.c
include make/mescc-mes.make
endif

14
scaffold/t.c
View file

@ -18,10 +18,14 @@
* along with Mes. If not, see <http://www.gnu.org/licenses/>.
*/
#if __GNUC__
#if __MESC__
int g_stdin = 0;
#define assert(x) ((x) ? (void)0 : assert_fail (#x))
#endif
#if !__MESC__
#include "mlibc.c"
#endif
#define assert(x) ((x) ? (void)0 : assert_fail (#x))
struct scm {
int type;
@ -31,7 +35,11 @@ struct scm {
int bla = 1234;
char arena[84];
#if __MESC__
struct scm *g_cells = arena;
#else
struct scm *g_cells = (struct scm*)arena;
#endif
char *g_chars = arena;
int foo () {puts ("t: foo\n"); return 0;};
@ -845,6 +853,6 @@ main (int argc, char *argv[])
return 22;
}
#if __GNUC__
#if !POSIX && !__MESC__
#include "mstart.c"
#endif

49
scaffold/tiny-mes.c
View file

@ -18,24 +18,18 @@
* along with Mes. If not, see <http://www.gnu.org/licenses/>.
*/
#if __GNUC__
#if POSIX
#error "POSIX not supported"
#endif
#if !__MESC__
#include "mlibc.c"
#endif
#define assert(x) ((x) ? (void)0 : assert_fail (#x))
#define MES_MINI 1
char arena[200];
char arena[300];
typedef int SCM;
#if __GNUC__
int g_debug = 0;
#endif
int g_free = 0;
SCM g_symbols = 0;
SCM g_stack = 0;
SCM r0 = 0; // a/env
SCM r1 = 0; // param 1
@ -50,10 +44,11 @@ struct scm {
SCM cdr;
};
//char arena[200];
//struct scm *g_cells = arena;
//struct scm *g_cells = (struct scm*)arena;
#if __MESC__
struct scm *g_cells = arena;
#else
struct scm *g_cells = (struct scm*)arena;
#endif
#define cell_nil 1
#define cell_f 2
@ -64,32 +59,20 @@ struct scm *g_cells = arena;
#define CAR(x) g_cells[x].car
#define CDR(x) g_cells[x].cdr
//#define VALUE(x) g_cells[x].value
#define VALUE(x) g_cells[x].cdr
SCM
car (SCM x)
{
#if MES_MINI
//Nyacc
//assert ("!car");
#else
if (TYPE (x) != PAIR) error (cell_symbol_not_a_pair, cons (x, cell_symbol_car));
#endif
return CAR (x);
}
SCM
cdr (SCM x)
{
#if MES_MINI
//Nyacc
//assert ("!cdr");
#else
if (TYPE (x) != PAIR) error (cell_symbol_not_a_pair, cons (x, cell_symbol_cdr));
#endif
return CDR(x);
return CDR (x);
}
SCM caar (SCM x) {return car (car (x));}
SCM cadr (SCM x) {return car (cdr (x));}
SCM cdar (SCM x) {return cdr (car (x));}
@ -324,9 +307,15 @@ bload_env (SCM a) ///((internal))
getchar ();
getchar ();
int i = 0;
c = getchar ();
while (c != -1)
{
i++;
eputs (itoa (i));
eputs (": ");
eputs (itoa (c));
eputs ("\n");
*p++ = c;
c = getchar ();
}
@ -352,6 +341,6 @@ main (int argc, char *argv[])
return 0;
}
#if __GNUC__
#if !__MESC__
#include "mstart.c"
#endif

2
scripts/mes
View file

@ -1 +1 @@
../mes
../out/mes

5
scripts/mescc.mes
View file

@ -49,6 +49,8 @@ exit $r
(mes-use-module (mes guile))
(mes-use-module (language c99 compiler))
(format (current-error-port) "mescc.mes...\n")
(define %datadir (if (string-prefix? "@DATADIR" "@DATADIR@") "" "@DATADIR@"))
(define %docdir (if (string-prefix? "@DOCDIR" "@DOCDIR@") "doc/" "@DOCDIR@"))
(define %moduledir "module/")
@ -63,7 +65,8 @@ exit $r
(car mfiles))))
(format (current-error-port) "compiling: ~a\n" mfile)
(with-input-from-file mfile
compile)))
c99-input->elf)))
(format (current-error-port) "calling main, command-line=~s\n" (command-line))
(main (command-line))
()

4
scripts/scripts.make Normal file
View file

@ -0,0 +1,4 @@
CLEAN+=$(DIR)/mes
$(DIR)/mes: $(OUT)/mes
ln -sf ../$< $@

0
gc.c → src/gc.c
View file

53
lib.c → src/lib.c
View file

@ -19,54 +19,6 @@
*/
int g_depth;
#if _POSIX_SOURCE
char const*
itoa (int x)
{
static char buf[10];
char *p = buf+9;
*p-- = 0;
int sign = x < 0;
if (sign)
x = -x;
do
{
*p-- = '0' + (x % 10);
x = x / 10;
} while (x);
if (sign)
*p-- = '-';
return p+1;
}
// from mlib.c
#define fputs fdputs
int
fdputs (char const* s, int fd)
{
int i = strlen (s);
write (fd, s, i);
return 0;
}
#ifdef putc
#undef putc
#endif
#define putc(x) fdputc(x, STDOUT)
#define fputc fdputc
int
fdputc (int c, int fd)
{
write (fd, (char*)&c, 1);
return 0;
}
#endif
SCM fdisplay_ (SCM, int);
SCM
@ -184,8 +136,3 @@ xassq (SCM x, SCM a) ///for speed in core only
while (a != cell_nil && x != CDAR (a)) a = CDR (a);
return a != cell_nil ? CAR (a) : cell_f;
}
#if _POSIX_SOURCE
#undef fdputs
#undef fdputc
#endif

0
math.c → src/math.c
View file

215
mes.c → src/mes.c
View file

@ -18,24 +18,14 @@
* along with Mes. If not, see <http://www.gnu.org/licenses/>.
*/
#if !_POSIX_SOURCE
#if __MESC__
int g_stdin = 0;
#define assert(x) ((x) ? (void)0 : assert_fail (#x))
#endif
#if !__MESC__
#include "mlibc.c"
#endif
#define assert(x) ((x) ? (void)0 : assert_fail (#x))
#else
#define _GNU_SOURCE
#include <assert.h>
#include <ctype.h>
#include <errno.h>
#include <limits.h>
#include <stdio.h>
#include <string.h>
#include <stdlib.h>
#include <stdbool.h>
#endif
#define FIXED_PRIMITIVES 1
int ARENA_SIZE = 100000;
int MAX_ARENA_SIZE = 20000000;
@ -204,7 +194,7 @@ struct scm scm_symbol_mesc = {TSYMBOL, "%mesc",0};
struct scm scm_test = {TSYMBOL, "test",0};
#if !_POSIX_SOURCE
#include "mini-mes.symbols.h"
#include "mes.mes.symbols.h"
#else
#include "mes.symbols.h"
#endif
@ -216,14 +206,16 @@ SCM tmp_num2;
struct function g_functions[200];
int g_function = 0;
#if !__GNUC__
#include "mini-gc.h"
#include "mini-lib.h"
#include "mini-math.h"
#include "mini-mes.h"
#include "mini-posix.h"
// #include "mini-reader.h"
#include "mini-vector.h"
#if !__GNUC__ || !_POSIX_SOURCE
#include "gc.mes.h"
#include "lib.mes.h"
#include "math.mes.h"
#include "mes.mes.h"
#include "posix.mes.h"
#if MES_FULL
#include "reader.mes.h"
#endif
#include "vector.mes.h"
#else
#include "gc.h"
#include "lib.h"
@ -293,16 +285,6 @@ int g_function = 0;
#define CADDR(x) CAR (CDR (CDR (x)))
#define CDADAR(x) CAR (CDR (CAR (CDR (x))))
#if 0
SCM vm_call (function0_t f, SCM p1, SCM a);
#endif
#if _POSIX_SOURCE
char const* itoa(int);
int fdputs (char const*, int);
#define eputs(s) fdputs(s, 2)
#endif
SCM
alloc (int n)
{
@ -359,11 +341,11 @@ make_symbol_ (SCM s) ///((internal))
SCM
list_of_char_equal_p (SCM a, SCM b) ///((internal))
{
while (a != cell_nil && b != cell_nil && VALUE (car (a)) == VALUE (car (b))) {
assert (TYPE (car (a)) == TCHAR);
assert (TYPE (car (b)) == TCHAR);
a = cdr (a);
b = cdr (b);
while (a != cell_nil && b != cell_nil && VALUE (CAR (a)) == VALUE (CAR (b))) {
assert (TYPE (CAR (a)) == TCHAR);
assert (TYPE (CAR (b)) == TCHAR);
a = CDR (a);
b = CDR (b);
}
return (a == cell_nil && b == cell_nil) ? cell_t : cell_f;
}
@ -373,10 +355,10 @@ lookup_symbol_ (SCM s)
{
SCM x = g_symbols;
while (x) {
if (list_of_char_equal_p (STRING (car (x)), s) == cell_t) break;
x = cdr (x);
if (list_of_char_equal_p (STRING (CAR (x)), s) == cell_t) break;
x = CDR (x);
}
if (x) x = car (x);
if (x) x = CAR (x);
if (!x) x = make_symbol_ (s);
return x;
}
@ -425,14 +407,18 @@ cons (SCM x, SCM y)
SCM
car (SCM x)
{
#if !__MESC_MES__
if (TYPE (x) != TPAIR) error (cell_symbol_not_a_pair, cons (x, cell_symbol_car));
#endif
return CAR (x);
}
SCM
cdr (SCM x)
{
#if !__MESC_MES__
if (TYPE (x) != TPAIR) error (cell_symbol_not_a_pair, cons (x, cell_symbol_cdr));
#endif
return CDR (x);
}
@ -483,7 +469,7 @@ length (SCM x)
{
n++;
if (TYPE (x) != TPAIR) return MAKE_NUMBER (-1);
x = cdr (x);
x = CDR (x);
}
return MAKE_NUMBER (n);
}
@ -493,9 +479,11 @@ SCM apply (SCM, SCM, SCM);
SCM
error (SCM key, SCM x)
{
#if !__MESC_MES__
SCM throw;
if ((throw = assq_ref_env (cell_symbol_throw, r0)) != cell_undefined)
return apply (throw, cons (key, cons (x, cell_nil)), r0);
#endif
display_error_ (key);
eputs (": ");
display_error_ (x);
@ -605,18 +593,18 @@ call (SCM fn, SCM x)
x = cons (CAR (x), cons (CDADAR (x), CDR (x)));
switch (FUNCTION (fn).arity)
{
#if __MESC__
#if __MESC__ || !_POSIX_SOURCE
case 0: return (FUNCTION (fn).function) ();
case 1: return ((SCM(*)(SCM))(FUNCTION (fn).function)) (CAR (x));
case 2: return ((SCM(*)(SCM,SCM))(FUNCTION (fn).function)) (CAR (x), CADR (x));
case 3: return ((SCM(*)(SCM,SCM,SCM))(FUNCTION (fn).function)) (CAR (x), CADR (x), car (CDDR (x)));
case 3: return ((SCM(*)(SCM,SCM,SCM))(FUNCTION (fn).function)) (CAR (x), CADR (x), CAR (CDDR (x)));
case -1: return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);
default: return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);
#else
case 0: return FUNCTION (fn).function0 ();
case 1: return FUNCTION (fn).function1 (car (x));
case 2: return FUNCTION (fn).function2 (car (x), CADR (x));
case 3: return FUNCTION (fn).function3 (car (x), CADR (x), car (CDDR (x)));
case 1: return FUNCTION (fn).function1 (CAR (x));
case 2: return FUNCTION (fn).function2 (CAR (x), CADR (x));
case 3: return FUNCTION (fn).function3 (CAR (x), CADR (x), CAR (CDDR (x)));
case -1: return FUNCTION (fn).functionn (x);
#endif
}
@ -717,7 +705,7 @@ SCM
gc_pop_frame () ///((internal))
{
SCM frame = gc_peek_frame (g_stack);
g_stack = cdr (g_stack);
g_stack = CDR (g_stack);
return frame;
}
@ -759,15 +747,14 @@ eval_apply ()
}
SCM x = cell_nil;
SCM y = cell_nil;
evlis:
gc_check ();
if (r1 == cell_nil) goto vm_return;
if (TYPE (r1) != TPAIR) goto eval;
push_cc (car (r1), r1, r0, cell_vm_evlis2);
push_cc (CAR (r1), r1, r0, cell_vm_evlis2);
goto eval;
evlis2:
push_cc (cdr (r2), r1, r0, cell_vm_evlis3);
push_cc (CDR (r2), r1, r0, cell_vm_evlis3);
goto evlis;
evlis3:
r1 = cons (r2, r1);
@ -775,22 +762,22 @@ eval_apply ()
apply:
gc_check ();
switch (TYPE (car (r1)))
switch (TYPE (CAR (r1)))
{
case TFUNCTION: {
check_formals (car (r1), MAKE_NUMBER (FUNCTION (car (r1)).arity), cdr (r1));
r1 = call (car (r1), cdr (r1)); /// FIXME: move into eval_apply
check_formals (CAR (r1), MAKE_NUMBER (FUNCTION (CAR (r1)).arity), CDR (r1));
r1 = call (CAR (r1), CDR (r1)); /// FIXME: move into eval_apply
goto vm_return;
}
case TCLOSURE:
{
SCM cl = CLOSURE (car (r1));
SCM cl = CLOSURE (CAR (r1));
SCM formals = CADR (cl);
SCM body = CDDR (cl);
SCM aa = CDAR (cl);
aa = cdr (aa);
check_formals (car (r1), formals, cdr (r1));
SCM p = pairlis (formals, cdr (r1), aa);
aa = CDR (aa);
check_formals (CAR (r1), formals, CDR (r1));
SCM p = pairlis (formals, CDR (r1), aa);
call_lambda (body, p, aa, r0);
goto begin;
}
@ -804,7 +791,7 @@ eval_apply ()
}
case TSPECIAL:
{
switch (car (r1))
switch (CAR (r1))
{
case cell_vm_apply:
{
@ -818,20 +805,20 @@ eval_apply ()
}
case cell_call_with_current_continuation:
{
r1 = cdr (r1);
r1 = CDR (r1);
goto call_with_current_continuation;
}
default: check_apply (cell_f, car (r1));
default: check_apply (cell_f, CAR (r1));
}
}
case TSYMBOL:
{
if (car (r1) == cell_symbol_call_with_values)
if (CAR (r1) == cell_symbol_call_with_values)
{
r1 = cdr (r1);
r1 = CDR (r1);
goto call_with_values;
}
if (car (r1) == cell_symbol_current_module)
if (CAR (r1) == cell_symbol_current_module)
{
r1 = r0;
goto vm_return;
@ -844,21 +831,21 @@ eval_apply ()
{
case cell_symbol_lambda:
{
SCM formals = CADR (car (r1));
SCM body = CDDR (car (r1));
SCM p = pairlis (formals, cdr (r1), r0);
check_formals (r1, formals, cdr (r1));
SCM formals = CADR (CAR (r1));
SCM body = CDDR (CAR (r1));
SCM p = pairlis (formals, CDR (r1), r0);
check_formals (r1, formals, CDR (r1));
call_lambda (body, p, p, r0);
goto begin;
}
}
}
}
push_cc (car (r1), r1, r0, cell_vm_apply2);
push_cc (CAR (r1), r1, r0, cell_vm_apply2);
goto eval;
apply2:
check_apply (r1, car (r2));
r1 = cons (r1, cdr (r2));
check_apply (r1, CAR (r2));
r1 = cons (r1, CDR (r2));
goto apply;
eval:
@ -867,20 +854,20 @@ eval_apply ()
{
case TPAIR:
{
switch (car (r1))
switch (CAR (r1))
{
#if FIXED_PRIMITIVES
case cell_symbol_car:
{
push_cc (CADR (r1), r1, r0, cell_vm_eval_car); goto eval;
eval_car:
x = r1; gc_pop_frame (); r1 = car (x); goto eval_apply;
x = r1; gc_pop_frame (); r1 = CAR (x); goto eval_apply;
}
case cell_symbol_cdr:
{
push_cc (CADR (r1), r1, r0, cell_vm_eval_cdr); goto eval;
eval_cdr:
x = r1; gc_pop_frame (); r1 = cdr (x); goto eval_apply;
x = r1; gc_pop_frame (); r1 = CDR (x); goto eval_apply;
}
case cell_symbol_cons: {
push_cc (CDR (r1), r1, r0, cell_vm_eval_cons); goto evlis;
@ -908,10 +895,10 @@ eval_apply ()
r1 = make_closure_ (CADR (r1), CDDR (r1), assq (cell_closure, r0));
goto vm_return;
}
case cell_symbol_if: {r1=cdr (r1); goto vm_if;}
case cell_symbol_if: {r1=CDR (r1); goto vm_if;}
case cell_symbol_set_x:
{
push_cc (car (CDDR (r1)), r1, r0, cell_vm_eval_set_x);
push_cc (CAR (CDDR (r1)), r1, r0, cell_vm_eval_set_x);
goto eval;
eval_set_x:
x = r2;
@ -927,21 +914,20 @@ eval_apply ()
push_cc (r1, r1, r0, cell_vm_eval_macro);
goto macro_expand;
eval_macro:
x = r2;
if (r1 != r2)
{
if (TYPE (r1) == TPAIR)
{
set_cdr_x (r2, cdr (r1));
set_car_x (r2, car (r1));
set_cdr_x (r2, CDR (r1));
set_car_x (r2, CAR (r1));
}
goto eval;
}
push_cc (car (r1), r1, r0, cell_vm_eval_check_func); goto eval;
push_cc (CAR (r1), r1, r0, cell_vm_eval_check_func); goto eval;
eval_check_func:
push_cc (CDR (r2), r2, r0, cell_vm_eval2); goto evlis;
eval2:
r1 = cons (car (r2), r1);
r1 = cons (CAR (r2), r1);
goto apply;
}
}
@ -958,7 +944,7 @@ eval_apply ()
SCM expanders;
macro_expand:
if (TYPE (r1) == TPAIR
&& (macro = lookup_macro_ (car (r1), r0)) != cell_f)
&& (macro = lookup_macro_ (CAR (r1), r0)) != cell_f)
{
r1 = cons (macro, CDR (r1));
goto apply;
@ -984,18 +970,18 @@ eval_apply ()
if (TYPE (r1) == TPAIR && TYPE (CAR (r1)) == TPAIR)
{
if (CAAR (r1) == cell_symbol_begin)
r1 = append2 (CDAR (r1), cdr (r1));
r1 = append2 (CDAR (r1), CDR (r1));
else if (CAAR (r1) == cell_symbol_primitive_load)
{
push_cc (cons (cell_symbol_read_input_file, cell_nil), r1, r0, cell_vm_begin_read_input_file);
goto apply;
begin_read_input_file:
r1 = append2 (r1, cdr (r2));
r1 = append2 (r1, CDR (r2));
}
}
if (CDR (r1) == cell_nil)
{
r1 = car (r1);
r1 = CAR (r1);
goto eval;
}
push_cc (CAR (r1), r1, r0, cell_vm_begin2);
@ -1008,7 +994,7 @@ eval_apply ()
goto vm_return;
vm_if:
push_cc (car (r1), r1, r0, cell_vm_if_expr);
push_cc (CAR (r1), r1, r0, cell_vm_if_expr);
goto eval;
if_expr:
x = r1;
@ -1020,7 +1006,7 @@ eval_apply ()
}
if (CDDR (r1) != cell_nil)
{
r1 = car (CDDR (r1));
r1 = CAR (CDDR (r1));
goto eval;
}
r1 = cell_unspecified;
@ -1030,14 +1016,14 @@ eval_apply ()
gc_push_frame ();
x = MAKE_CONTINUATION (g_continuations++);
gc_pop_frame ();
push_cc (cons (car (r1), cons (x, cell_nil)), x, r0, cell_vm_call_with_current_continuation2);
push_cc (cons (CAR (r1), cons (x, cell_nil)), x, r0, cell_vm_call_with_current_continuation2);
goto apply;
call_with_current_continuation2:
CONTINUATION (r2) = g_stack;
goto vm_return;
call_with_values:
push_cc (cons (car (r1), cell_nil), r1, r0, cell_vm_call_with_values2);
push_cc (cons (CAR (r1), cell_nil), r1, r0, cell_vm_call_with_values2);
goto apply;
call_with_values2:
if (TYPE (r1) == TVALUES)
@ -1142,7 +1128,7 @@ mes_symbols () ///((internal))
gc_init_news ();
#if !_POSIX_SOURCE
#include "mini-mes.symbols.i"
#include "mes.mes.symbols.i"
#else
#include "mes.symbols.i"
#endif
@ -1157,7 +1143,7 @@ mes_symbols () ///((internal))
SCM a = cell_nil;
#if !_POSIX_SOURCE
#include "mini-mes.symbol-names.i"
#include "mes.mes.symbol-names.i"
#else
#include "mes.symbol-names.i"
#endif
@ -1195,24 +1181,28 @@ mes_environment () ///((internal))
SCM
mes_builtins (SCM a) ///((internal))
{
#if !__GNUC__
#include "mini-mes.i"
#if !__GNUC__ || !_POSIX_SOURCE
#include "mes.mes.i"
// Do not sort: Order of these includes define builtins
#include "mini-posix.i"
#include "mini-math.i"
#include "mini-lib.i"
#include "mini-vector.i"
#include "mini-gc.i"
// #include "mini-reader.i"
#include "posix.mes.i"
#include "math.mes.i"
#include "lib.mes.i"
#include "vector.mes.i"
#include "gc.mes.i"
#if MES_FULL
#include "reader.mes.i"
#endif
#include "mini-gc.environment.i"
#include "mini-lib.environment.i"
#include "mini-math.environment.i"
#include "mini-mes.environment.i"
#include "mini-posix.environment.i"
// #include "mini-reader.environment.i"
#include "mini-vector.environment.i"
#include "gc.mes.environment.i"
#include "lib.mes.environment.i"
#include "math.mes.environment.i"
#include "mes.mes.environment.i"
#include "posix.mes.environment.i"
#if MES_FULL
#include "reader.mes.environment.i"
#endif
#include "vector.mes.environment.i"
#else
#include "mes.i"
@ -1335,7 +1325,7 @@ bload_env (SCM a) ///((internal))
#include "vector.c"
#include "gc.c"
#if _POSIX_SOURCE
#if _POSIX_SOURCE || MES_FULL
#include "reader.c"
#endif
@ -1343,10 +1333,12 @@ int
main (int argc, char *argv[])
{
#if __GNUC__
g_debug = getenv ("MES_DEBUG");
g_debug = getenv ("MES_DEBUG") != 0;
if (g_debug) {eputs ("MODULEDIR=");eputs (MODULEDIR);eputs ("\n");}
if (getenv ("MES_ARENA")) ARENA_SIZE = atoi (getenv ("MES_ARENA"));
#endif
#if _POSIX_SOURCE
if (getenv ("MES_MAX_ARENA")) MAX_ARENA_SIZE = atoi (getenv ("MES_MAX_ARENA"));
if (getenv ("MES_ARENA")) ARENA_SIZE = atoi (getenv ("MES_ARENA"));
#endif
if (argc > 1 && !strcmp (argv[1], "--help")) return puts ("Usage: mes [--dump|--load] < FILE");
if (argc > 1 && !strcmp (argv[1], "--version")) {puts ("Mes ");puts (VERSION);return 0;};
@ -1359,11 +1351,14 @@ main (int argc, char *argv[])
#else
SCM program = (argc > 1 && !strcmp (argv[1], "--load"))
? bload_env (r0) : load_env (r0);
g_tiny = argc > 2 && !strcmp (argv[2], "--tiny");
if (argc > 1 && !strcmp (argv[1], "--dump")) return dump ();
#endif
SCM lst = cell_nil;
#if !__MESC__
for (int i=argc-1; i>=0; i--) lst = cons (MAKE_STRING (cstring_to_list (argv[i])), lst);
#endif
r0 = acons (cell_symbol_argv, lst, r0);
push_cc (r2, cell_unspecified, r0, cell_unspecified);
if (g_debug)

54
posix.c → src/posix.c
View file

@ -18,58 +18,6 @@
* along with Mes. If not, see <http://www.gnu.org/licenses/>.
*/
int g_stdin;
#if _POSIX_SOURCE
int open (char const *s, int mode);
int read (int fd, void* buf, size_t n);
void write (int fd, char const* s, int n);
#define O_RDONLY 0
#define STDIN 0
#define STDOUT 1
#define STDERR 2
int
putchar (int c)
{
write (STDOUT, (char*)&c, 1);
return 0;
}
int ungetc_char = -1;
char ungetc_buf[2];
int
getchar ()
{
char c;
int i;
if (ungetc_char == -1)
{
int r = read (g_stdin, &c, 1);
if (r < 1) return -1;
i = c;
}
else
i = ungetc_buf[ungetc_char--];
if (i < 0) i += 256;
return i;
}
#define ungetc fdungetc
int
fdungetc (int c, int fd)
{
assert (ungetc_char < 2);
ungetc_buf[++ungetc_char] = c;
return c;
}
#endif
int
ungetchar (int c)
{
@ -112,7 +60,9 @@ write_byte (SCM x) ///((arity . n))
if (TYPE (p) == TPAIR && TYPE (car (p)) == TNUMBER) fd = VALUE (car (p));
char cc = VALUE (c);
write (fd, (char*)&cc, 1);
#if !__MESC__
assert (TYPE (c) == TNUMBER || TYPE (c) == TCHAR);
#endif
return c;
}

32
reader.c → src/reader.c
View file

@ -18,11 +18,11 @@
* along with Mes. If not, see <http://www.gnu.org/licenses/>.
*/
#if _POSIX_SOURCE
#undef fputs
#undef fdputs
#undef fdputc
#endif
// #if _POSIX_SOURCE
// #undef fputs
// #undef fdputs
// #undef fdputc
// #endif
SCM
___end_of_mes___ ()
@ -119,7 +119,8 @@ lookup_ (SCM s, SCM a)
return lookup_symbol_ (s);
}
//FILE *g_stdin;
int g_tiny = 0;
int
dump ()
{
@ -132,14 +133,17 @@ dump ()
gc ();
gc_peek_frame ();
char *p = (char*)g_cells;
putc ('M');
putc ('E');
putc ('S');
putc (g_stack >> 8);
putc (g_stack % 256);
putchar ('M');
putchar ('E');
putchar ('S');
putchar (g_stack >> 8);
putchar (g_stack % 256);
// See HACKING, simple crafted dump for tiny-mes.c
if (getenv ("MES_TINY"))
// if (getenv ("MES_TINY"))
if (g_tiny)
{
eputs ("dumping TINY\n");
TYPE (9) = 0x2d2d2d2d;
CAR (9) = 0x2d2d2d2d;
CDR (9) = 0x3e3e3e3e;
@ -166,7 +170,9 @@ dump ()
g_free = 15;
}
else
eputs ("dumping FULL\n");
for (int i=0; i<g_free * sizeof(struct scm); i++)
putc (*p++);
putchar (*p++);
return 0;
}

81
src/src.make Normal file
View file

@ -0,0 +1,81 @@
MODULES:=\
src/gc.c\
src/lib.c\
src/math.c\
src/mes.c\
src/posix.c\
src/reader.c\
src/vector.c
#
$(OUT)/%.h $(OUT)/%.i $(OUT)/%.environment.i $(OUT)/%.symbols.i: DIR:=$(DIR)
$(OUT)/%.h $(OUT)/%.i $(OUT)/%.environment.i $(OUT)/%.symbols.i: %.c build-aux/mes-snarf.scm
@echo " SNARF $(notdir $<) -> $(notdir $@)"
@mkdir -p $(dir $@)
$(QUIET)OUT=$(dir $@) build-aux/mes-snarf.scm $<
SNARF.GCC:=$(MODULES:%.c=$(OUT)/%.h) $(MODULES:%.c=$(OUT)/%.i) $(MODULES:%.c=$(OUT)/%.environment.i)
SNARF.GCC+=$(OUT)/$(DIR)/mes.symbols.i
CLEAN+=$(SNARF.GCC)
snarf-gcc: $(SNARF.GCC)
$(OUT)/$(DIR)/mes.o: $(SNARF.GCC)
DEFINES:=FIXED_PRIMITIVES=1 MES_FULL=1 POSIX=1 VERSION='"$(VERSION)"' MODULEDIR='"$(MODULEDIR)"' PREFIX='"$(PREFIX)"'
INCLUDES:=libc $(OUT)/$(DIR)
TARGET:=mes
C_FILES:=$(DIR)/mes.c
include make/bin.make
$(OUT)/%.mes.h $(OUT)/%.mes.i $(OUT)/%.mes.environment.i $(OUT)/%.mes.symbols.i: DIR:=$(DIR)
$(OUT)/%.mes.h $(OUT)/%.mes.i $(OUT)/%.mes.environment.i $(OUT)/%.mes.symbols.i: %.c build-aux/mes-snarf.scm
@echo " SNARF $(notdir $<) -> $(notdir $@)"
@mkdir -p $(dir $@)
$(QUIET)OUT=$(dir $@) build-aux/mes-snarf.scm --mes $<
SNARF.MES:=$(MODULES:%.c=$(OUT)/%.mes.h) $(MODULES:%.c=$(OUT)/%.mes.i) $(MODULES:%.c=$(OUT)/%.mes.environment.i)
SNARF.MES+=$(OUT)/$(DIR)/mes.mes.symbols.i
CLEAN+=$(SNARF.MES)
snarf-mes: $(SNARF.MES)
include make/reset.make
# a full 32 bit cross compiler with glibc
# CROSS:=$(CC32:%gcc=%)
# TARGET:=$(CROSS)mes
# $(OUT)/$(DIR)/mes.$(CROSS)o: $(SNARF.MES)
# C_FILES:=$(DIR)/mes.c
# DEFINES:=FIXED_PRIMITIVES=1 MES_FULL=1 POSIX=1 VERSION='"$(VERSION)"' MODULEDIR='"$(MODULEDIR)"' PREFIX='"$(PREFIX)"'
# INCLUDES:=libc $(OUT)/src
# include make/bin.make
# a simple non-glibc cross compiler, using mlibc.
CROSS:=$(CC32:%gcc=%)
TARGET:=$(CROSS)mes
$(OUT)/$(DIR)/mes.$(CROSS)o: $(SNARF.MES)
C_FILES:=$(DIR)/mes.c
DEFINES:=FIXED_PRIMITIVES=1 MES_FULL=1 VERSION='"$(VERSION)"' MODULEDIR='"$(MODULEDIR)"' PREFIX='"$(PREFIX)"'
INCLUDES:=libc $(OUT)/src
C_FLAGS:=-nostdinc
LD_FLAGS:=-nostdlib
include make/bin.make
TARGET:=mes.guile
$(OUT)/mes.mes: module/mes/read-0-32.mo
$(OUT)/mes.guile: $(SNARF.MES)
C_FILES:=$(DIR)/mes.c
include make/mescc-guile.make
MAINTAINER-CLEAN+=mes.mes
ifeq ($(wildcard mes.mes),)
safe-MES_MAX_ARENA=$(MES_MAX_ARENA)
MES_MAX_ARENA:=80000000
TARGET:=mes.mes
$(OUT)/mes.mes: module/mes/read-0-32.mo
$(OUT)/mes.mes: $(SNARF.MES)
mes.mes: $(OUT)/mes.mes
cp $< $@
C_FILES:=$(DIR)/mes.c
include make/mescc-mes.make
MES_MAX_ARENA=$(safe-MES_MAX_ARENA)
endif

0
vector.c → src/vector.c
View file

38
tests/tests.make Normal file
View file

@ -0,0 +1,38 @@
TESTS:=\
tests/read.test\
tests/base.test\
tests/closure.test\
tests/quasiquote.test\
tests/let.test\
tests/scm.test\
tests/display.test\
tests/cwv.test\
tests/math.test\
tests/vector.test\
tests/srfi-1.test\
tests/srfi-13.test\
tests/srfi-14.test\
tests/optargs.test\
tests/fluids.test\
tests/catch.test\
tests/psyntax.test\
tests/pmatch.test\
tests/let-syntax.test\
tests/guile.test\
tests/record.test\
tests/match.test\
tests/peg.test\
#
MES-0:=guile/mes-0.scm
TEST:=guile-check
$(TEST):
set -e; for i in $(TESTS); do\
$(GUILE) -s <(cat $(MES-0) module/mes/test.mes $$i);\
done
include make/check.make
TEST:=mes-check
$(TEST): $(OUT)/mes
set -e; for i in $(TESTS); do MES_MAX_ARENA=20000000 ./$$i; done
include make/check.make