diff --git a/.gitignore b/.gitignore index a9010e35..88e3f89a 100644 --- a/.gitignore +++ b/.gitignore @@ -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 diff --git a/GNUmakefile b/GNUmakefile index 49b817c5..6d6ad425 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -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: diff --git a/build-aux/compile-all.scm b/build-aux/compile-all.scm new file mode 100644 index 00000000..d2ed416f --- /dev/null +++ b/build-aux/compile-all.scm @@ -0,0 +1,152 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 Taylan Ulrich Bayırlı/Kammer +;;; Copyright © 2016, 2017 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(use-modules (system base target) + (system base message) + (ice-9 match) + (ice-9 threads)) + +(define (mkdir-p dir) + "Create directory DIR and all its ancestors." + (define absolute? + (string-prefix? "/" dir)) + + (define not-slash + (char-set-complement (char-set #\/))) + + (let loop ((components (string-tokenize dir not-slash)) + (root (if absolute? + "" + "."))) + (match components + ((head tail ...) + (let ((path (string-append root "/" head))) + (catch 'system-error + (lambda () + (mkdir path) + (loop tail path)) + (lambda args + (if (= EEXIST (system-error-errno args)) + (loop tail path) + (apply throw args)))))) + (() #t)))) + +(define warnings + '(unsupported-warning format unbound-variable arity-mismatch)) + +(define host (getenv "host")) + +(define srcdir (getenv "srcdir")) + +(define (relative-file file) + (if (string-prefix? (string-append srcdir "/") file) + (string-drop file (+ 1 (string-length srcdir))) + file)) + +(define (file-mtimego file) + (let* ((relative (relative-file file)) + (without-extension (string-drop-right relative 4))) + (string-append without-extension ".go"))) + +(define (file-needs-compilation? file) + (let ((go (scm->go file))) + (or (not (file-exists? go)) + (file-mtimemodule file) + (let* ((relative (relative-file file)) + (module-path (string-drop-right relative 4))) + (map string->symbol + (string-split module-path #\/)))) + +;;; To work around (FIXME), we want to load all +;;; files to be compiled first. We do this via resolve-interface so that the +;;; top-level of each file (module) is only executed once. +(define (load-module-file file) + (let ((module (file->module file))) + (format #t " LOAD ~a~%" module) + (resolve-interface module))) + +(cond-expand + (guile-2.2 (use-modules (language tree-il optimize) + (language cps optimize))) + (else #f)) + +(define %default-optimizations + ;; Default optimization options (equivalent to -O2 on Guile 2.2). + (cond-expand + (guile-2.2 (append (tree-il-default-optimization-options) + (cps-default-optimization-options))) + (else '()))) + +(define %lightweight-optimizations + ;; Lightweight optimizations (like -O0, but with partial evaluation). + (let loop ((opts %default-optimizations) + (result '())) + (match opts + (() (reverse result)) + ((#:partial-eval? _ rest ...) + (loop rest `(#t #:partial-eval? ,@result))) + ((kw _ rest ...) + (loop rest `(#f ,kw ,@result)))))) + +(define (optimization-options file) + (if (string-contains file "gnu/packages/") + %lightweight-optimizations ;build faster + '())) + +(define (compile-file* file output-mutex) + (let ((go (scm->go file))) + (with-mutex output-mutex + (format #t " GUILEC ~a~%" go) + (force-output)) + (mkdir-p (dirname go)) + (with-fluids ((*current-warning-prefix* "")) + (with-target host + (lambda () + (compile-file file + #:output-file go + #:opts `(#:warnings ,warnings + ,@(optimization-options file)))))))) + +;; Install a SIGINT handler to give unwind handlers in 'compile-file' an +;; opportunity to run upon SIGINT and to remove temporary output files. +(sigaction SIGINT + (lambda args + (exit 1))) + +(match (command-line) + ((_ . files) + (let ((files (filter file-needs-compilation? files))) + (for-each load-module-file files) + (let ((mutex (make-mutex))) + ;; Make sure compilation related modules are loaded before starting to + ;; compile files in parallel. + (compile #f) + (par-for-each (lambda (file) + (compile-file* file mutex)) + files))))) + +;;; Local Variables: +;;; eval: (put 'with-target 'scheme-indent-function 1) +;;; End: diff --git a/build-aux/mes-snarf.scm b/build-aux/mes-snarf.scm index 9bebfa97..be09704f 100755 --- a/build-aux/mes-snarf.scm +++ b/build-aux/mes-snarf.scm @@ -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 #: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))))) diff --git a/configure b/configure index d5168831..15aa7c64 100755 --- a/configure +++ b/configure @@ -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 +;;; Copyright © 2016,2017 Jan Nieuwenhuizen ;;; ;;; 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) diff --git a/guile/mescc.scm b/guile/mescc.scm index 364bfc50..e213b4de 100755 --- a/guile/mescc.scm +++ b/guile/mescc.scm @@ -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))) diff --git a/guix.scm b/guix.scm index a6b04d28..dda1d33d 100644 --- a/guix.scm +++ b/guix.scm @@ -1,7 +1,7 @@ ;;; guix.scm -- Guix package definition ;;; Mes --- Maxwell Equations of Software -;;; Copyright © 2016 Jan Nieuwenhuizen +;;; Copyright © 2016,2017 Jan Nieuwenhuizen ;;; 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= > 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= > 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 diff --git a/mlibc.c b/libc/mlibc.c similarity index 77% rename from mlibc.c rename to libc/mlibc.c index 1e64cfb4..f74caa34 100644 --- a/mlibc.c +++ b/libc/mlibc.c @@ -18,22 +18,25 @@ * along with Mes. If not, see . */ -#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 +#include +#include +#include +#include +#include +#include +#include +#include + +#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 diff --git a/mstart.c b/libc/mstart.c similarity index 100% rename from mstart.c rename to libc/mstart.c diff --git a/make/bin.make b/make/bin.make new file mode 100644 index 00000000..ce037dfd --- /dev/null +++ b/make/bin.make @@ -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 diff --git a/make/check.make b/make/check.make new file mode 100644 index 00000000..d55411fb --- /dev/null +++ b/make/check.make @@ -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 diff --git a/make/clean.make b/make/clean.make new file mode 100644 index 00000000..2c04d1b9 --- /dev/null +++ b/make/clean.make @@ -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 diff --git a/make/common.make b/make/common.make new file mode 100644 index 00000000..8400168b --- /dev/null +++ b/make/common.make @@ -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 diff --git a/make/compile.make b/make/compile.make new file mode 100644 index 00000000..3f5e9034 --- /dev/null +++ b/make/compile.make @@ -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 diff --git a/make/guile.make b/make/guile.make new file mode 100644 index 00000000..0b4766cc --- /dev/null +++ b/make/guile.make @@ -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 diff --git a/make/install.make b/make/install.make index 7eabf990..7428ee2c 100644 --- a/make/install.make +++ b/make/install.make @@ -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 diff --git a/make/mescc-guile.make b/make/mescc-guile.make new file mode 100644 index 00000000..5350f1d0 --- /dev/null +++ b/make/mescc-guile.make @@ -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 diff --git a/make/mescc-mes.make b/make/mescc-mes.make new file mode 100644 index 00000000..49d754bb --- /dev/null +++ b/make/mescc-mes.make @@ -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 diff --git a/make/reset.make b/make/reset.make new file mode 100644 index 00000000..e274d9c2 --- /dev/null +++ b/make/reset.make @@ -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:= + diff --git a/mes-mini-mes b/mes.mes old mode 100755 new mode 100644 similarity index 100% rename from mes-mini-mes rename to mes.mes diff --git a/module/language/c99/compiler.mes b/module/language/c99/compiler.mes index 838892bb..82c9756c 100644 --- a/module/language/c99/compiler.mes +++ b/module/language/c99/compiler.mes @@ -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 #: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))) diff --git a/module/language/c99/compiler.scm b/module/language/c99/compiler.scm index 4f3396c2..250e51b6 100644 --- a/module/language/c99/compiler.scm +++ b/module/language/c99/compiler.scm @@ -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) diff --git a/module/mes/as-i386.mes b/module/mes/as-i386.mes index 82bc844c..3e39cbbf 100644 --- a/module/mes/as-i386.mes +++ b/module/mes/as-i386.mes @@ -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 (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(%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(%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(%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%(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,%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<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(%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,%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(%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(%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(%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,%edx (define (i386:global->base n) - (or n global->base) + (or n (error "invalid value: global->base: " n)) `(#xba ,@(int->bv32 n))) ; mov $,%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,%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,%edx (define (i386:byte-base-mem->accu) @@ -232,19 +236,19 @@ `(#x8b #x40 ,n)) ; mov 0x(%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 (%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 $,%eax (define (i386:value->accu-address v) `(#xc7 #x00 ,@(int->bv32 v))) ; movl $0x,(%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 $,0x(%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(%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 $,%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 $,0x(%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 $,0x (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 $,() ,@(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 $,0x(%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 $,0x(%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 . + (define (i386:XXjump n) - (or n urg:XXjump) + (or n (error "invalid value: i386:XXjump: n: " n)) `(#xe9 ,@(int->bv32 n))) ; jmp . + (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 . + (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 . + (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 (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 (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 (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 (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 ;; 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 ;; 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 ;; 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 ;; 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 ;; ;; 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 (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 (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 (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 (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 diff --git a/module/mes/as-i386.scm b/module/mes/as-i386.scm index 2456ad9c..5ab95cdc 100644 --- a/module/mes/as-i386.scm +++ b/module/mes/as-i386.scm @@ -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 diff --git a/module/mes/libc.mes b/module/mes/libc.mes index f0b101ce..62ca4d02 100644 --- a/module/mes/libc.mes +++ b/module/mes/libc.mes @@ -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 diff --git a/module/mes/read-0-32.mo b/module/mes/read-0-32.mo index cbb5ec86..7a6c7ce7 100644 Binary files a/module/mes/read-0-32.mo and b/module/mes/read-0-32.mo differ diff --git a/module/module.make b/module/module.make new file mode 100644 index 00000000..c0c4512e --- /dev/null +++ b/module/module.make @@ -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 diff --git a/scaffold/cons-mes.c b/scaffold/cons-mes.c index 5c3d6d76..165944d2 100644 --- a/scaffold/cons-mes.c +++ b/scaffold/cons-mes.c @@ -18,37 +18,35 @@ * along with Mes. If not, see . */ -#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 ("\n"); switch (TYPE (x)) { - case CHAR: + case TCHAR: { //puts ("\n"); puts ("#\\"); @@ -706,7 +644,7 @@ display_ (SCM x) puts ("cdr"); break; } - case NUMBER: + case TNUMBER: { //puts ("\n"); #if __GNUC__ @@ -719,7 +657,7 @@ display_ (SCM x) #endif break; } - case PAIR: + case TPAIR: { //puts ("\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 + diff --git a/scaffold/hello.c b/scaffold/hello.c index cd1840ac..7cbb26c2 100644 --- a/scaffold/hello.c +++ b/scaffold/hello.c @@ -18,7 +18,7 @@ * along with Mes. If not, see . */ -#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 diff --git a/scaffold/m.c b/scaffold/m.c index 9606d8e8..4dd2472e 100644 --- a/scaffold/m.c +++ b/scaffold/m.c @@ -18,23 +18,22 @@ * along with Mes. If not, see . */ -#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 diff --git a/scaffold/malloc.c b/scaffold/malloc.c index dfd1c059..5bb48b95 100644 --- a/scaffold/malloc.c +++ b/scaffold/malloc.c @@ -18,10 +18,18 @@ * along with Mes. If not, see . */ -#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[]) diff --git a/scaffold/mesmes b/scaffold/mesmes new file mode 100644 index 00000000..037bc16e --- /dev/null +++ b/scaffold/mesmes @@ -0,0 +1 @@ +mesmes diff --git a/scaffold/micro-mes.c b/scaffold/micro-mes.c index 1adce349..01d9b589 100644 --- a/scaffold/micro-mes.c +++ b/scaffold/micro-mes.c @@ -18,13 +18,13 @@ * along with Mes. If not, see . */ -#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 diff --git a/scaffold/mini-mes.c b/scaffold/mini-mes.c index 39685e33..1399619f 100644 --- a/scaffold/mini-mes.c +++ b/scaffold/mini-mes.c @@ -18,24 +18,24 @@ * along with Mes. If not, see . */ +#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 diff --git a/scaffold/scaffold.make b/scaffold/scaffold.make new file mode 100644 index 00000000..7dda12f0 --- /dev/null +++ b/scaffold/scaffold.make @@ -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 diff --git a/scaffold/t.c b/scaffold/t.c index b7ee0013..2f10d2f8 100644 --- a/scaffold/t.c +++ b/scaffold/t.c @@ -18,10 +18,14 @@ * along with Mes. If not, see . */ -#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 diff --git a/scaffold/tiny-mes.c b/scaffold/tiny-mes.c index 23efacfc..831aa0a9 100644 --- a/scaffold/tiny-mes.c +++ b/scaffold/tiny-mes.c @@ -18,24 +18,18 @@ * along with Mes. If not, see . */ -#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 diff --git a/scripts/mes b/scripts/mes index f12eceec..4e5ce6ef 120000 --- a/scripts/mes +++ b/scripts/mes @@ -1 +1 @@ -../mes \ No newline at end of file +../out/mes \ No newline at end of file diff --git a/scripts/mescc.mes b/scripts/mescc.mes index 7052b76e..d9dde33e 100755 --- a/scripts/mescc.mes +++ b/scripts/mescc.mes @@ -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)) () diff --git a/scripts/scripts.make b/scripts/scripts.make new file mode 100644 index 00000000..7fb084ee --- /dev/null +++ b/scripts/scripts.make @@ -0,0 +1,4 @@ +CLEAN+=$(DIR)/mes + +$(DIR)/mes: $(OUT)/mes + ln -sf ../$< $@ diff --git a/gc.c b/src/gc.c similarity index 100% rename from gc.c rename to src/gc.c diff --git a/lib.c b/src/lib.c similarity index 83% rename from lib.c rename to src/lib.c index be37c7ac..048429a9 100644 --- a/lib.c +++ b/src/lib.c @@ -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 diff --git a/math.c b/src/math.c similarity index 100% rename from math.c rename to src/math.c diff --git a/mes.c b/src/mes.c similarity index 89% rename from mes.c rename to src/mes.c index 7bdbac6e..f1e2a387 100644 --- a/mes.c +++ b/src/mes.c @@ -18,24 +18,14 @@ * along with Mes. If not, see . */ -#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 -#include -#include -#include -#include -#include -#include -#include -#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) diff --git a/posix.c b/src/posix.c similarity index 76% rename from posix.c rename to src/posix.c index f7e64467..c583003f 100644 --- a/posix.c +++ b/src/posix.c @@ -18,58 +18,6 @@ * along with Mes. If not, see . */ -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; } diff --git a/reader.c b/src/reader.c similarity index 92% rename from reader.c rename to src/reader.c index c07fcd79..cd9434ce 100644 --- a/reader.c +++ b/src/reader.c @@ -18,11 +18,11 @@ * along with Mes. If not, see . */ -#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 $(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 diff --git a/vector.c b/src/vector.c similarity index 100% rename from vector.c rename to src/vector.c diff --git a/tests/tests.make b/tests/tests.make new file mode 100644 index 00000000..3b095c10 --- /dev/null +++ b/tests/tests.make @@ -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