build: Separate Mes and Guile modules.
* scaffold/gc.scm: Move from guile/gc.scm. * guile/: Remove. * module/language/paren.mes: Remove. * mes/module/mes/base.mes: Move from module/mes/. * mes/module/mes/boot-0.scm: Likewise. * mes/module/mes/boot-00.scm: Likewise. * mes/module/mes/boot-01.scm: Likewise. * mes/module/mes/boot-02.scm: Likewise. * mes/module/mes/catch.mes: Likewise. * mes/module/mes/display.mes: Likewise. * mes/module/mes/fluids.mes: Likewise. * mes/module/mes/getopt-long.mes: Likewise. * mes/module/mes/guile.mes: Likewise. * mes/module/mes/lalr.mes: Likewise. * mes/module/mes/lalr.scm: Likewise. * mes/module/mes/let.mes: Likewise. * mes/module/mes/match.mes: Likewise. * mes/module/mes/match.scm: Likewise. * mes/module/mes/mescc.mes: Likewise. * mes/module/mes/misc.mes: Likewise. * mes/module/mes/module.mes: Likewise. * mes/module/mes/optargs.mes: Likewise. * mes/module/mes/optargs.scm: Likewise. * mes/module/mes/peg.mes: Likewise. * mes/module/mes/peg/cache.scm: Likewise. * mes/module/mes/peg/codegen.scm: Likewise. * mes/module/mes/peg/simplify-tree.scm: Likewise. * mes/module/mes/peg/string-peg.scm: Likewise. * mes/module/mes/peg/using-parsers.scm: Likewise. * mes/module/mes/pmatch.mes: Likewise. * mes/module/mes/pmatch.scm: Likewise. * mes/module/mes/posix.mes: Likewise. * mes/module/mes/pretty-print.mes: Likewise. * mes/module/mes/pretty-print.scm: Likewise. * mes/module/mes/psyntax-0.mes: Likewise. * mes/module/mes/psyntax-1.mes: Likewise. * mes/module/mes/psyntax.mes: Likewise. * mes/module/mes/psyntax.pp: Likewise. * mes/module/mes/psyntax.ss: Likewise. * mes/module/mes/quasiquote.mes: Likewise. * mes/module/mes/quasisyntax.mes: Likewise. * mes/module/mes/quasisyntax.scm: Likewise. * mes/module/mes/repl.mes: Likewise. * mes/module/mes/scm.mes: Likewise. * mes/module/mes/syntax.mes: Likewise. * mes/module/mes/syntax.scm: Likewise. * mes/module/mes/test.mes: Likewise. * mes/module/mes/tiny-0.mes: Likewise. * mes/module/mes/type-0.mes: Likewise. * mes/module/mescc/M1.mes: Likewise. * mes/module/mescc/as.mes: Likewise. * mes/module/mescc/bytevectors.mes: Likewise. * mes/module/mescc/compile.mes: Likewise. * mes/module/mescc/i386/as.mes: Likewise. * mes/module/mescc/info.mes: Likewise. * mes/module/mescc/mescc.mes: Likewise. * mes/module/mescc/preprocess.mes: Likewise. * mes/module/nyacc/lalr.mes: Likewise. * mes/module/nyacc/lang/c99/cpp.mes: Likewise. * mes/module/nyacc/lang/c99/parser.mes: Likewise. * mes/module/nyacc/lang/c99/pprint.mes: Likewise. * mes/module/nyacc/lang/calc/parser.mes: Likewise. * mes/module/nyacc/lang/util.mes: Likewise. * mes/module/nyacc/lex.mes: Likewise. * mes/module/nyacc/parse.mes: Likewise. * mes/module/nyacc/util.mes: Likewise. * mes/module/rnrs/arithmetic/bitwise.mes: Likewise. * mes/module/srfi/srfi-0.mes: Likewise. * mes/module/srfi/srfi-1.mes: Likewise. * mes/module/srfi/srfi-1.scm: Likewise. * mes/module/srfi/srfi-13.mes: Likewise. * mes/module/srfi/srfi-14.mes: Likewise. * mes/module/srfi/srfi-16.mes: Likewise. * mes/module/srfi/srfi-16.scm: Likewise. * mes/module/srfi/srfi-26.mes: Likewise. * mes/module/srfi/srfi-26.scm: Likewise. * mes/module/srfi/srfi-43.mes: Likewise. * mes/module/srfi/srfi-8.mes: Likewise. * mes/module/srfi/srfi-9.mes: Likewise. * mes/module/srfi/srfi-9/gnu.mes: Likewise. * mes/module/sxml/xpath.mes: Likewise. * mes/module/sxml/xpath.scm: Likewise. * module/mes/mes-0.scm: Likewise. * build-aux/build-guile.sh: Update for new layout. * build-aux/build-mes.sh: Likewise. * build-aux/check-boot.sh: Likewise. * build-aux/check-mescc.sh: Likewise. * install.sh: Likewise. * scaffold/boot/51-module.scm: Likewise. * scaffold/boot/52-define-module.scm: Likewise. * scripts/mescc: Likewise. * src/mes.c: Likewise. * tests/base.test-guile: Likewise. * tests/boot.test: Likewise. * tests/srfi-9.test: Likewise. * mes/include: New symlink. * mes/lib: New symlink. * AUTHORS: Update file names.
This commit is contained in:
Jan Nieuwenhuizen
parent
0535630913
commit
542289a3c6
27
AUTHORS
27
AUTHORS
|
|
@ -15,48 +15,45 @@ List of imported files
|
||||||
D A Gwyn
|
D A Gwyn
|
||||||
lib/alloca.c
|
lib/alloca.c
|
||||||
|
|
||||||
Based on Guile ECMAScript
|
|
||||||
module/language/c/lexer.mes
|
|
||||||
|
|
||||||
Included verbatim from gnulib
|
Included verbatim from gnulib
|
||||||
build-aux/gitlog-to-changelog
|
build-aux/gitlog-to-changelog
|
||||||
|
|
||||||
Portable hygienic pattern matcher
|
Portable hygienic pattern matcher
|
||||||
module/mes/match.scm
|
mes/module/mes/match.scm
|
||||||
|
|
||||||
Portable LALR(1) parser generator
|
Portable LALR(1) parser generator
|
||||||
module/mes/lalr.scm
|
mes/module/mes/lalr.scm
|
||||||
|
|
||||||
Portable syntax-case from Chez Scheme; patches from Guile
|
Portable syntax-case from Chez Scheme; patches from Guile
|
||||||
module/mes/psyntax.ss
|
mes/module/mes/psyntax.ss
|
||||||
module/mes/psyntax.pp [generated]
|
mes/module/mes/psyntax.pp [generated]
|
||||||
|
|
||||||
Getopt-long from Guile
|
Getopt-long from Guile
|
||||||
module/mes/getopt-long.scm
|
module/mes/getopt-long.scm
|
||||||
|
|
||||||
Optargs from Guile
|
Optargs from Guile
|
||||||
module/mes/optargs.scm
|
mes/module/mes/optargs.scm
|
||||||
|
|
||||||
PEG from Guile
|
PEG from Guile
|
||||||
module/mes/peg/
|
mes/module/mes/peg/
|
||||||
|
|
||||||
Pmatch from Guile
|
Pmatch from Guile
|
||||||
module/mes/pmatch.scm
|
mes/module/mes/pmatch.scm
|
||||||
|
|
||||||
Pretty-print from Guile
|
Pretty-print from Guile
|
||||||
module/mes/pretty-print.scm
|
mes/module/mes/pretty-print.scm
|
||||||
|
|
||||||
Srfi-1 bits from Guile
|
Srfi-1 bits from Guile
|
||||||
module/srfi/srfi-1.scm
|
mes/module/srfi/srfi-1.scm
|
||||||
|
|
||||||
Srfi-16 from Guile
|
Srfi-16 from Guile
|
||||||
module/srfi/srfi-16.scm
|
mes/module/srfi/srfi-16.scm
|
||||||
|
|
||||||
Srfi-26 from Guile
|
Srfi-26 from Guile
|
||||||
module/srfi/srfi-26.scm
|
mes/module/srfi/srfi-26.scm
|
||||||
|
|
||||||
Sxml bits from Guile
|
Sxml bits from Guile
|
||||||
module/sxml/xpath.scm
|
mes/module/sxml/xpath.scm
|
||||||
|
|
||||||
GNU FDL in texinfo from GNU
|
GNU FDL in texinfo from GNU
|
||||||
doc/fdl-1.3.texi
|
doc/fdl-1.3.texi
|
||||||
|
|
|
||||||
15
GNUmakefile
15
GNUmakefile
|
|
@ -16,7 +16,7 @@
|
||||||
# You should have received a copy of the GNU General Public License
|
# You should have received a copy of the GNU General Public License
|
||||||
# along with Mes. If not, see <http://www.gnu.org/licenses/>.
|
# along with Mes. If not, see <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
GUILE_FLAGS:=--no-auto-compile -L . -L guile -C . -C guile
|
GUILE_FLAGS:=--no-auto-compile -L . -L module -C . -C module
|
||||||
|
|
||||||
include .config.make
|
include .config.make
|
||||||
|
|
||||||
|
|
@ -24,7 +24,7 @@ include .config.make
|
||||||
./configure --prefix=$(prefix)
|
./configure --prefix=$(prefix)
|
||||||
|
|
||||||
PHONY_TARGETS:= all all-go build check clean clean-go default doc help install install-info man\
|
PHONY_TARGETS:= all all-go build check clean clean-go default doc help install install-info man\
|
||||||
cc mes mes-gcc mes-tcc
|
gcc mes src/mes mes-gcc mes-tcc
|
||||||
|
|
||||||
.PHONY: $(PHONY_TARGETS)
|
.PHONY: $(PHONY_TARGETS)
|
||||||
|
|
||||||
|
|
@ -116,14 +116,13 @@ install-info: info
|
||||||
|
|
||||||
man: doc/mes.1 doc/mescc.1
|
man: doc/mes.1 doc/mescc.1
|
||||||
|
|
||||||
doc/mes.1: src/mes.gcc-out
|
src/mes: build
|
||||||
MES_ARENA=10000000 $(HELP2MAN) $< > $@
|
|
||||||
|
|
||||||
src/mes.gcc-out:
|
doc/mes.1: src/mes
|
||||||
$(MAKE) cc
|
MES_ARENA=10000000 ./pre-inst-env $(HELP2MAN) $< > $@
|
||||||
|
|
||||||
doc/mescc.1: src/mes.gcc-out scripts/mescc
|
doc/mescc.1: src/mes scripts/mescc
|
||||||
MES_ARENA=10000000 $(HELP2MAN) $< > $@
|
MES_ARENA=10000000 ./pre-inst-env $(HELP2MAN) $< > $@
|
||||||
|
|
||||||
html: mes/index.html
|
html: mes/index.html
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -31,17 +31,18 @@ GUILE_AUTO_COMPILE=0
|
||||||
set -e
|
set -e
|
||||||
|
|
||||||
SCM_FILES="
|
SCM_FILES="
|
||||||
guile/mes/guile.scm
|
module/mes/getopt-long.scm
|
||||||
guile/mes/misc.scm
|
module/mes/guile.scm
|
||||||
guile/mes/test.scm
|
module/mes/misc.scm
|
||||||
guile/mescc/M1.scm
|
module/mes/test.scm
|
||||||
guile/mescc/as.scm
|
module/mescc/M1.scm
|
||||||
guile/mescc/bytevectors.scm
|
module/mescc/as.scm
|
||||||
guile/mescc/compile.scm
|
module/mescc/bytevectors.scm
|
||||||
guile/mescc/i386/as.scm
|
module/mescc/compile.scm
|
||||||
guile/mescc/info.scm
|
module/mescc/i386/as.scm
|
||||||
guile/mescc/mescc.scm
|
module/mescc/info.scm
|
||||||
guile/mescc/preprocess.scm
|
module/mescc/mescc.scm
|
||||||
|
module/mescc/preprocess.scm
|
||||||
"
|
"
|
||||||
|
|
||||||
export srcdir=.
|
export srcdir=.
|
||||||
|
|
@ -57,7 +58,7 @@ for i in $SCM_FILES; do
|
||||||
go=${i%%.scm}.go
|
go=${i%%.scm}.go
|
||||||
if [ $i -nt $go ]; then
|
if [ $i -nt $go ]; then
|
||||||
echo " GUILEC $i"
|
echo " GUILEC $i"
|
||||||
$GUILE_TOOLS compile -L ${abs}guile -L ${abs}scripts -o $go $i
|
$GUILE_TOOLS compile -L ${abs}module -L ${abs}scripts -o $go $i
|
||||||
fi
|
fi
|
||||||
done
|
done
|
||||||
|
|
||||||
|
|
@ -69,6 +70,6 @@ for i in $SCRIPTS; do
|
||||||
go=${i%%.scm}.go
|
go=${i%%.scm}.go
|
||||||
if [ $i -nt $go ]; then
|
if [ $i -nt $go ]; then
|
||||||
echo " GUILEC $i"
|
echo " GUILEC $i"
|
||||||
$GUILE_TOOLS compile -L ${abs}guile -L ${abs}scripts -o $go $i
|
$GUILE_TOOLS compile -L ${abs}module -L ${abs}scripts -o $go $i
|
||||||
fi
|
fi
|
||||||
done
|
done
|
||||||
|
|
|
||||||
|
|
@ -104,6 +104,7 @@ if [ ! -d "$MES_SEED" ] \
|
||||||
MES_ARENA=100000000
|
MES_ARENA=100000000
|
||||||
fi
|
fi
|
||||||
|
|
||||||
|
MES_ARENA=100000000
|
||||||
ARCHDIR=1 NOLINK=1 bash build-aux/cc-mes.sh lib/crt0
|
ARCHDIR=1 NOLINK=1 bash build-aux/cc-mes.sh lib/crt0
|
||||||
ARCHDIR=1 NOLINK=1 bash build-aux/cc-mes.sh lib/crt1
|
ARCHDIR=1 NOLINK=1 bash build-aux/cc-mes.sh lib/crt1
|
||||||
ARCHDIR=1 NOLINK=1 bash build-aux/cc-mes.sh lib/crti
|
ARCHDIR=1 NOLINK=1 bash build-aux/cc-mes.sh lib/crti
|
||||||
|
|
|
||||||
|
|
@ -116,7 +116,7 @@ for i in $tests; do
|
||||||
echo ' [SKIP]'
|
echo ' [SKIP]'
|
||||||
continue;
|
continue;
|
||||||
fi
|
fi
|
||||||
$GUILE -L guile -L . <(echo '(use-modules (mes guile))'; cat scaffold/boot/$i) >& /dev/null
|
$GUILE -L module -C module -L . <(echo '(use-modules (mes guile))'; cat scaffold/boot/$i) >& /dev/null
|
||||||
x=$(
|
x=$(
|
||||||
if [ -z "${i/5[0-9]-*/}" ]; then
|
if [ -z "${i/5[0-9]-*/}" ]; then
|
||||||
cat scaffold/boot/$i | MES_BOOT=boot-00.scm $MES 2>&1;
|
cat scaffold/boot/$i | MES_BOOT=boot-00.scm $MES 2>&1;
|
||||||
|
|
|
||||||
|
|
@ -31,7 +31,7 @@ export LIBC CC32LIBS MES_LIBS
|
||||||
MES=${MES-src/mes}
|
MES=${MES-src/mes}
|
||||||
MESCC=${MESCC-scripts/mescc}
|
MESCC=${MESCC-scripts/mescc}
|
||||||
GUILE=${GUILE-guile}
|
GUILE=${GUILE-guile}
|
||||||
MES_PREFIX=${MES_PREFIX-.}
|
MES_PREFIX=${MES_PREFIX-mes}
|
||||||
|
|
||||||
HEX2=${HEX2-hex2}
|
HEX2=${HEX2-hex2}
|
||||||
M1=${M1-M1}
|
M1=${M1-M1}
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
#! /bin/sh
|
#! /bin/sh
|
||||||
# -*-scheme-*-
|
# -*-scheme-*-
|
||||||
exec ${GUILE-guile} -L $(dirname 0) -e '(mes-snarf)' -s "$0" "$@"
|
exec ${GUILE-guile} --no-auto-compile -L $(dirname $0) -C $(dirname $0) -e '(mes-snarf)' -s "$0" "$@"
|
||||||
!#
|
!#
|
||||||
|
|
||||||
;;; Mes --- Maxwell Equations of Software
|
;;; Mes --- Maxwell Equations of Software
|
||||||
|
|
@ -218,7 +218,7 @@ exec ${GUILE-guile} -L $(dirname 0) -e '(mes-snarf)' -s "$0" "$@"
|
||||||
(string-join (map function->header functions (iota (length functions) (+ %start (length symbols)))) "")))
|
(string-join (map function->header functions (iota (length functions) (+ %start (length symbols)))) "")))
|
||||||
(source (make-file
|
(source (make-file
|
||||||
(string-append base-name ".i")
|
(string-append base-name ".i")
|
||||||
(string-join (map function->source (filter (negate no-environment?) functions) (iota (length functions) (+ (length symbols) %start))) "")))
|
(string-join (map function->source (filter (negate no-environment?) functions) (iota (length functions) (+ (length symbols) %start))) "")))
|
||||||
(environment (make-file
|
(environment (make-file
|
||||||
(string-append base-name ".environment.i")
|
(string-append base-name ".environment.i")
|
||||||
(string-join (map function->environment (filter (negate no-environment?) functions) (iota (length functions) (+ (length symbols) %start))) "")))
|
(string-join (map function->environment (filter (negate no-environment?) functions) (iota (length functions) (+ (length symbols) %start))) "")))
|
||||||
|
|
|
||||||
|
|
@ -22,6 +22,8 @@ if [ -n "$BUILD_DEBUG" ]; then
|
||||||
set -x
|
set -x
|
||||||
fi
|
fi
|
||||||
|
|
||||||
|
MES_ARENA=100000000
|
||||||
|
|
||||||
export LIBC MES_LIBS
|
export LIBC MES_LIBS
|
||||||
|
|
||||||
GUILE=${GUILE-$MES}
|
GUILE=${GUILE-$MES}
|
||||||
|
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
../module/language
|
|
||||||
174
guile/mes.mes
174
guile/mes.mes
|
|
@ -1,174 +0,0 @@
|
||||||
;;; -*-scheme-*-
|
|
||||||
|
|
||||||
;;; Mes --- Maxwell Equations of Software
|
|
||||||
;;; Copyright © 2016,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
|
||||||
;;;
|
|
||||||
;;; mes.mes: This file is part of Mes.
|
|
||||||
;;;
|
|
||||||
;;; Mes is free software; you can redistribute it and/or modify it
|
|
||||||
;;; under the terms of the GNU General Public License as published by
|
|
||||||
;;; the Free Software Foundation; either version 3 of the License, or (at
|
|
||||||
;;; your option) any later version.
|
|
||||||
;;;
|
|
||||||
;;; Mes is distributed in the hope that it will be useful, but
|
|
||||||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
||||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
||||||
;;; GNU General Public License for more details.
|
|
||||||
;;;
|
|
||||||
;;; You should have received a copy of the GNU General Public License
|
|
||||||
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
|
|
||||||
|
|
||||||
;; The Maxwell Equations of Software -- John McCarthy page 13
|
|
||||||
;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf
|
|
||||||
|
|
||||||
(define (caar x) (car (car x)))
|
|
||||||
(define (cadr x) (car (cdr x)))
|
|
||||||
(define (cdar x) (cdr (car x)))
|
|
||||||
(define (cddr x) (cdr (cdr x)))
|
|
||||||
(define (caadr x) (car (car (cdr x))))
|
|
||||||
(define (caddr x) (car (cdr (cdr x))))
|
|
||||||
(define (cddar x) (cdr (cdr (car x))))
|
|
||||||
(define (cdadr x) (cdr (car (cdr x))))
|
|
||||||
(define (cadar x) (car (cdr (car x))))
|
|
||||||
(define (cdddr x) (cdr (cdr (cdr x))))
|
|
||||||
|
|
||||||
;; Page 12
|
|
||||||
(define (pairlis x y a)
|
|
||||||
(cond
|
|
||||||
((null? x) a)
|
|
||||||
((atom? x) (cons (cons x y) a))
|
|
||||||
(#t (cons (cons (car x) (car y))
|
|
||||||
(pairlis (cdr x) (cdr y) a)))))
|
|
||||||
|
|
||||||
(define (assq x a)
|
|
||||||
(cond
|
|
||||||
((null? a) #f)
|
|
||||||
((eq? (caar a) x) (car a))
|
|
||||||
(#t (assq x (cdr a)))))
|
|
||||||
|
|
||||||
(define (assq-ref-env x a)
|
|
||||||
(let ((e (assq x a)))
|
|
||||||
(if (eq? e #f) '*undefined* (cdr e))))
|
|
||||||
|
|
||||||
;; Page 13
|
|
||||||
(define (evcon c a)
|
|
||||||
(cond
|
|
||||||
((null? c) *unspecified*)
|
|
||||||
;; single-statement cond
|
|
||||||
;; ((eval (caar c) a) (eval (cadar c) a))
|
|
||||||
((eval (caar c) a)
|
|
||||||
(cond ((null? (cddar c)) (eval (cadar c) a))
|
|
||||||
(#t (eval (cadar c) a)
|
|
||||||
(evcon
|
|
||||||
(cons (cons #t (cddar c)) '())
|
|
||||||
a))))
|
|
||||||
(#t (evcon (cdr c) a))))
|
|
||||||
|
|
||||||
(define (evlis-env m a)
|
|
||||||
(cond
|
|
||||||
((null? m) '())
|
|
||||||
((not (pair? m)) (eval-env m a))
|
|
||||||
(#t (cons (eval-env (car m) a) (evlis-env (cdr m) a)))))
|
|
||||||
|
|
||||||
(define (apply-env fn x a)
|
|
||||||
(cond
|
|
||||||
((atom? fn)
|
|
||||||
(cond
|
|
||||||
((builtin? fn) (call fn x))
|
|
||||||
((eq? fn 'call-with-values) (call call-with-values-env (append x (cons a '()))))
|
|
||||||
((eq? fn 'current-module) a)))
|
|
||||||
((eq? (car fn) 'lambda)
|
|
||||||
(let ((p (pairlis (cadr fn) x a)))
|
|
||||||
(eval-begin-env (cddr fn) (cons (cons '*closure* p) p))))
|
|
||||||
((eq? (car fn) '*closure*)
|
|
||||||
(let ((args (caddr fn))
|
|
||||||
(body (cdddr fn))
|
|
||||||
(a (cddr (cadr fn))))
|
|
||||||
(let ((p (pairlis args x a)))
|
|
||||||
(eval-begin-env body (cons (cons '*closure* p) p)))))
|
|
||||||
;;((eq? (car fn) 'label) (apply-env (caddr fn) x (cons (cons (cadr fn) (caddr fn)) a)))
|
|
||||||
(#t (apply-env (eval-env fn a) x a))))
|
|
||||||
|
|
||||||
;;return make_cell_ (tmp_num_ (TCLOSURE), cell_f, cons (cons (cell_circular, a), cons (formals, body)));
|
|
||||||
(define (make-closure formals body a)
|
|
||||||
(cons (cons '*closure* #f) (cons (cons '*circ* a) (cons formals body))))
|
|
||||||
|
|
||||||
(define (eval-expand e a)
|
|
||||||
(cond
|
|
||||||
((eq? e '*undefined*) e)
|
|
||||||
((symbol? e) (assq-ref-env e a))
|
|
||||||
((atom? e) e)
|
|
||||||
((atom? (car e))
|
|
||||||
(cond
|
|
||||||
((eq? (car e) 'quote) (cadr e))
|
|
||||||
((eq? (car e) 'syntax) (cadr e))
|
|
||||||
((eq? (car e) 'begin) (eval-begin-env e a))
|
|
||||||
((eq? (car e) 'lambda) e)
|
|
||||||
((eq? (car e) 'lambda) (make-closure (cadr e) (cddr e) (assq '*closure* a)))
|
|
||||||
((eq? (car e) '*closure*) e)
|
|
||||||
((eq? (car e) 'if) (eval-if-env (cdr e) a))
|
|
||||||
((eq? (car e) 'define) (env:define (cons (sexp:define e a) '()) a))
|
|
||||||
((eq? (car e) 'define-macro) (env:define (env:macro (sexp:define e a)) a))
|
|
||||||
((eq? (car e) 'set!) (set-env! (cadr e) (eval-env (caddr e) a) a))
|
|
||||||
((eq? (car e) 'apply-env) (apply-env (eval-env (cadr e) a) (evlis-env (caddr e) a) a))
|
|
||||||
((eq? (car e) 'unquote) (eval-env (cadr e) a))
|
|
||||||
((eq? (car e) 'quasiquote) (eval-quasiquote (cadr e) (add-unquoters a)))
|
|
||||||
(#t (apply-env (eval-env (car e) a) (evlis-env (cdr e) a) a))))
|
|
||||||
(#t (apply-env (eval-env (car e) a) (evlis-env (cdr e) a) a))))
|
|
||||||
|
|
||||||
(define (unquote x) (cons 'unquote x))
|
|
||||||
(define (unquote-splicing x) (cons 'quasiquote x))
|
|
||||||
|
|
||||||
(define %the-unquoters
|
|
||||||
(cons
|
|
||||||
(cons 'unquote unquote)
|
|
||||||
(cons (cons 'unquote-splicing unquote-splicing) '())))
|
|
||||||
|
|
||||||
(define (add-unquoters a)
|
|
||||||
(cons %the-unquoters a))
|
|
||||||
|
|
||||||
(define (eval-env e a)
|
|
||||||
(eval-expand (macro-expand-env e a) a))
|
|
||||||
|
|
||||||
(define (macro-expand-env e a)
|
|
||||||
(if (pair? e) ((lambda (macro)
|
|
||||||
(if macro (macro-expand-env (apply-env macro (cdr e) a) a)
|
|
||||||
e))
|
|
||||||
(lookup-macro (car e) a))
|
|
||||||
e))
|
|
||||||
|
|
||||||
(define (eval-begin-env e a)
|
|
||||||
(if (null? e) *unspecified*
|
|
||||||
(if (null? (cdr e)) (eval-env (car e) a)
|
|
||||||
(begin
|
|
||||||
(eval-env (car e) a)
|
|
||||||
(eval-begin-env (cdr e) a)))))
|
|
||||||
|
|
||||||
(define (eval-if-env e a)
|
|
||||||
(if (eval-env (car e) a) (eval-env (cadr e) a)
|
|
||||||
(if (pair? (cddr e)) (eval-env (caddr e) a))))
|
|
||||||
|
|
||||||
;; (define (eval-quasiquote e a)
|
|
||||||
;; (cond ((null? e) e)
|
|
||||||
;; ((atom? e) e)
|
|
||||||
;; ((eq? (car e) 'unquote) (eval-env (cadr e) a))
|
|
||||||
;; ((and (pair? (car e))
|
|
||||||
;; (eq? (caar e) 'unquote-splicing))
|
|
||||||
;; (append2 (eval-env (cadar e) a) (eval-quasiquote (cdr e) a)))
|
|
||||||
;; (#t (cons (eval-quasiquote (car e) a) (eval-quasiquote (cdr e) a)))))
|
|
||||||
|
|
||||||
(define (sexp:define e a)
|
|
||||||
(if (atom? (cadr e)) (cons (cadr e) (eval-env (caddr e) a))
|
|
||||||
(cons (caadr e) (eval-env (cons 'lambda (cons (cdadr e) (cddr e))) a))))
|
|
||||||
|
|
||||||
(define (env:define a+ a)
|
|
||||||
(set-cdr! a+ (cdr a))
|
|
||||||
(set-cdr! a a+)
|
|
||||||
(set-cdr! (assq '*closure* a) a))
|
|
||||||
|
|
||||||
(define (env:macro name+entry)
|
|
||||||
(cons
|
|
||||||
(cons (car name+entry)
|
|
||||||
(make-macro (car name+entry)
|
|
||||||
(cdr name+entry)))
|
|
||||||
'()))
|
|
||||||
228
guile/mes.scm
228
guile/mes.scm
|
|
@ -1,228 +0,0 @@
|
||||||
#! /bin/sh
|
|
||||||
# -*-scheme-*-
|
|
||||||
exec guile -L $(pwd) -e '(mes)' -s "$0" "$@"
|
|
||||||
!#
|
|
||||||
|
|
||||||
;;; Mes --- The Maxwell Equations of Software
|
|
||||||
;;; Copyright © 2016,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
|
||||||
;;;
|
|
||||||
;;; This file is part of GNU Guix.
|
|
||||||
;;;
|
|
||||||
;;; Mes is free software; you can redistribute it and/or modify it
|
|
||||||
;;; under the terms of the GNU General Public License as published by
|
|
||||||
;;; the Free Software Foundation; either version 3 of the License, or (at
|
|
||||||
;;; your option) any later version.
|
|
||||||
;;;
|
|
||||||
;;; Mes is distributed in the hope that it will be useful, but
|
|
||||||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
||||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
||||||
;;; GNU General Public License for more details.
|
|
||||||
;;;
|
|
||||||
;;; You should have received a copy of the GNU General Public License
|
|
||||||
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
|
|
||||||
|
|
||||||
;; The Maxwell Equations of Software -- John McCarthy page 13
|
|
||||||
;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf
|
|
||||||
|
|
||||||
(define-module (mes)
|
|
||||||
#:export (main))
|
|
||||||
|
|
||||||
(let ((guile (resolve-interface
|
|
||||||
'(guile)
|
|
||||||
#:select `(
|
|
||||||
;; Debugging
|
|
||||||
apply
|
|
||||||
cons*
|
|
||||||
current-module
|
|
||||||
display
|
|
||||||
eof-object?
|
|
||||||
eval
|
|
||||||
exit
|
|
||||||
force-output
|
|
||||||
format
|
|
||||||
list
|
|
||||||
map
|
|
||||||
newline
|
|
||||||
read
|
|
||||||
|
|
||||||
;; Guile admin
|
|
||||||
module-define!
|
|
||||||
resolve-interface
|
|
||||||
|
|
||||||
;; PRIMITIVE BUILTINS
|
|
||||||
car
|
|
||||||
cdr
|
|
||||||
cons
|
|
||||||
eq?
|
|
||||||
null?
|
|
||||||
pair?
|
|
||||||
*unspecified*
|
|
||||||
|
|
||||||
;; READER
|
|
||||||
char->integer
|
|
||||||
integer->char
|
|
||||||
|
|
||||||
;; non-primitive BUILTINS
|
|
||||||
char?
|
|
||||||
number?
|
|
||||||
procedure?
|
|
||||||
string?
|
|
||||||
<
|
|
||||||
-
|
|
||||||
)
|
|
||||||
#:renamer (symbol-prefix-proc 'guile:)))
|
|
||||||
(guile-2.0 (resolve-interface '(guile) #:select '(define)))
|
|
||||||
(guile-2.2 (resolve-interface '(guile) #:select '(quasiquote unquote)))
|
|
||||||
(ports (resolve-interface
|
|
||||||
(if (equal? (effective-version) "2.0")'(guile) '(ice-9 ports))
|
|
||||||
#:select '(
|
|
||||||
;; Debugging
|
|
||||||
current-error-port
|
|
||||||
current-output-port
|
|
||||||
|
|
||||||
;; READER
|
|
||||||
;;peek-char
|
|
||||||
read-char
|
|
||||||
unread-char)
|
|
||||||
#:renamer (symbol-prefix-proc 'guile:))))
|
|
||||||
(set-current-module
|
|
||||||
(make-module 10 `(,guile ,guile-2.0 ,guile-2.2 ,ports))))
|
|
||||||
|
|
||||||
(define (logf port string . rest)
|
|
||||||
(guile:apply guile:format (guile:cons* port string rest))
|
|
||||||
(guile:force-output port)
|
|
||||||
#t)
|
|
||||||
|
|
||||||
(define (stderr string . rest)
|
|
||||||
(guile:apply logf (guile:cons* (guile:current-error-port) string rest)))
|
|
||||||
|
|
||||||
(define (stdout string . rest)
|
|
||||||
(guile:apply logf (guile:cons* (guile:current-output-port) string rest)))
|
|
||||||
|
|
||||||
(define (debug . x) #t)
|
|
||||||
(define debug stderr)
|
|
||||||
|
|
||||||
;; TODO
|
|
||||||
(define (atom? x)
|
|
||||||
(cond
|
|
||||||
((guile:pair? x) #f)
|
|
||||||
((guile:null? x) #f)
|
|
||||||
(#t #t)))
|
|
||||||
|
|
||||||
;; PRIMITIVES
|
|
||||||
(define car guile:car)
|
|
||||||
(define cdr guile:cdr)
|
|
||||||
(define cons guile:cons)
|
|
||||||
(define eq? guile:eq?)
|
|
||||||
(define null? guile:null?)
|
|
||||||
(define pair? guile:pair?)
|
|
||||||
(define builtin? guile:procedure?)
|
|
||||||
(define char? guile:char?)
|
|
||||||
(define number? guile:number?)
|
|
||||||
(define string? guile:number?)
|
|
||||||
(define call guile:apply)
|
|
||||||
(define (peek-byte)
|
|
||||||
(unread-byte (read-byte)))
|
|
||||||
;;(define peek-byte guile:peek-char)
|
|
||||||
(define (read-byte)
|
|
||||||
(char->integer (guile:read-char)))
|
|
||||||
(define (unread-byte x)
|
|
||||||
(guile:unread-char (guile:integer->char x))
|
|
||||||
x)
|
|
||||||
(define (lookup x a)
|
|
||||||
;; TODO
|
|
||||||
(stderr "lookup x=~a\n" x)
|
|
||||||
x)
|
|
||||||
|
|
||||||
(define (char->integer c)
|
|
||||||
(if (guile:eof-object? c) -1 (guile:char->integer c)))
|
|
||||||
|
|
||||||
(include "mes.mes")
|
|
||||||
;; guile-2.2 only, guile-2.0 has no include?
|
|
||||||
(include "reader.mes")
|
|
||||||
|
|
||||||
(define (append2 x y)
|
|
||||||
(cond ((null? x) y)
|
|
||||||
(#t (cons (car x) (append2 (cdr x) y)))))
|
|
||||||
|
|
||||||
;; READER: TODO lookup
|
|
||||||
(define (read)
|
|
||||||
(let ((x (guile:read)))
|
|
||||||
(if (guile:eof-object? x) '()
|
|
||||||
x)))
|
|
||||||
|
|
||||||
(define (lookup-macro e a)
|
|
||||||
#f)
|
|
||||||
|
|
||||||
(define guile:dot '#{.}#)
|
|
||||||
|
|
||||||
(define environment
|
|
||||||
(guile:map
|
|
||||||
(lambda (x) (cons (car x) (guile:eval (cdr x) (guile:current-module))))
|
|
||||||
'(
|
|
||||||
(*closure* . #t)
|
|
||||||
((guile:list) . (guile:list))
|
|
||||||
(#t . #t)
|
|
||||||
(#f . #f)
|
|
||||||
|
|
||||||
(*unspecified* . guile:*unspecified*)
|
|
||||||
|
|
||||||
(atom? . atom?)
|
|
||||||
(car . car)
|
|
||||||
(cdr . cdr)
|
|
||||||
(cons . cons)
|
|
||||||
;; (cond . evcon)
|
|
||||||
(eq? . eq?)
|
|
||||||
|
|
||||||
(null? . null?)
|
|
||||||
(pair? . guile:pair?)
|
|
||||||
;; (quote . quote)
|
|
||||||
|
|
||||||
(evlis-env . evlis-env)
|
|
||||||
(evcon . evcon)
|
|
||||||
(pairlis . pairlis)
|
|
||||||
(assq . assq)
|
|
||||||
(assq-ref-env . assq-ref-env)
|
|
||||||
|
|
||||||
(eval-env . eval-env)
|
|
||||||
(apply-env . apply-env)
|
|
||||||
|
|
||||||
(read . read)
|
|
||||||
(display . guile:display)
|
|
||||||
(newline . guile:newline)
|
|
||||||
|
|
||||||
(builtin? . builtin?)
|
|
||||||
(number? . number?)
|
|
||||||
(call . call)
|
|
||||||
|
|
||||||
(< . guile:<)
|
|
||||||
(- . guile:-)
|
|
||||||
|
|
||||||
;; DERIVED
|
|
||||||
(caar . caar)
|
|
||||||
(cadr . cadr)
|
|
||||||
(cdar . cdar)
|
|
||||||
(cddr . cddr)
|
|
||||||
(caadr . caadr)
|
|
||||||
(caddr . caddr)
|
|
||||||
(cdadr . cdadr)
|
|
||||||
(cadar . cadar)
|
|
||||||
(cddar . cddar)
|
|
||||||
(cdddr . cdddr)
|
|
||||||
|
|
||||||
(append2 . append2)
|
|
||||||
(exit . guile:exit)
|
|
||||||
|
|
||||||
(*macro* . (guile:list))
|
|
||||||
(*dot* . guile:dot)
|
|
||||||
|
|
||||||
;;
|
|
||||||
(stderr . stderr))))
|
|
||||||
|
|
||||||
(define (main arguments)
|
|
||||||
(let ((program (cons 'begin (read-input-file))))
|
|
||||||
(stderr "program:~a\n" program)
|
|
||||||
(stderr "=> ~s\n" (eval-env program environment)))
|
|
||||||
(guile:newline))
|
|
||||||
|
|
||||||
(guile:module-define! (guile:resolve-interface '(mes)) 'main main)
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
../module/mescc
|
|
||||||
141
guile/reader.mes
141
guile/reader.mes
|
|
@ -1,141 +0,0 @@
|
||||||
;;; -*-scheme-*-
|
|
||||||
|
|
||||||
;;; Mes --- Maxwell Equations of Software
|
|
||||||
;;; Copyright © 2016 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
|
||||||
;;;
|
|
||||||
;;; This file is part of Mes.
|
|
||||||
;;;
|
|
||||||
;;; Mes is free software; you can redistribute it and/or modify it
|
|
||||||
;;; under the terms of the GNU General Public License as published by
|
|
||||||
;;; the Free Software Foundation; either version 3 of the License, or (at
|
|
||||||
;;; your option) any later version.
|
|
||||||
;;;
|
|
||||||
;;; Mes is distributed in the hope that it will be useful, but
|
|
||||||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
||||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
||||||
;;; GNU General Public License for more details.
|
|
||||||
;;;
|
|
||||||
;;; You should have received a copy of the GNU General Public License
|
|
||||||
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
|
|
||||||
|
|
||||||
;;; Commentary:
|
|
||||||
|
|
||||||
;;; copy of mes/read-0.mes, comment-out read-input-file
|
|
||||||
|
|
||||||
;;; Code:
|
|
||||||
|
|
||||||
(begin
|
|
||||||
|
|
||||||
;; (define car (make-function 'car 0))
|
|
||||||
;; (define cdr (make-function 'cdr 1))
|
|
||||||
;; (define cons (make-function 'cons 1))
|
|
||||||
|
|
||||||
;; TODO:
|
|
||||||
;; * use case/cond, expand
|
|
||||||
;; * etc int/char?
|
|
||||||
;; * lookup in Scheme
|
|
||||||
;; * read characters, quote, strings
|
|
||||||
|
|
||||||
(define (read)
|
|
||||||
(read-word (read-byte) (list) (current-module)))
|
|
||||||
|
|
||||||
(define (read-input-file)
|
|
||||||
(define (helper x)
|
|
||||||
(if (null? x) x
|
|
||||||
(cons x (helper (read)))))
|
|
||||||
(helper (read)))
|
|
||||||
|
|
||||||
(define-macro (cond . clauses)
|
|
||||||
(list (quote if) (null? clauses) *unspecified*
|
|
||||||
(if (null? (cdr clauses))
|
|
||||||
(list (quote if) (car (car clauses))
|
|
||||||
(list (cons (quote lambda) (cons (list) (cons (car (car clauses)) (cdr (car clauses))))))
|
|
||||||
*unspecified*)
|
|
||||||
(if (eq? (car (cadr clauses)) (quote else))
|
|
||||||
(list (quote if) (car (car clauses))
|
|
||||||
(list (cons (quote lambda) (cons (list) (car clauses))))
|
|
||||||
(list (cons (quote lambda) (cons (list) (cons *unspecified* (cdr (cadr clauses)))))))
|
|
||||||
(list (quote if) (car (car clauses))
|
|
||||||
(list (cons (quote lambda) (cons (list) (car clauses))))
|
|
||||||
(cons (quote cond) (cdr clauses)))))))
|
|
||||||
|
|
||||||
(define (eat-whitespace)
|
|
||||||
(cond
|
|
||||||
((eq? (peek-byte) 9) (read-byte) (eat-whitespace))
|
|
||||||
((eq? (peek-byte) 10) (read-byte) (eat-whitespace))
|
|
||||||
((eq? (peek-byte) 13) (read-byte) (eat-whitespace))
|
|
||||||
((eq? (peek-byte) 32) (read-byte) (eat-whitespace))
|
|
||||||
((eq? (peek-byte) 59) (begin (read-line-comment (read-byte))
|
|
||||||
(eat-whitespace)))
|
|
||||||
((eq? (peek-byte) 35) (begin (read-byte)
|
|
||||||
(if (eq? (peek-byte) 33) (begin (read-byte)
|
|
||||||
(read-block-comment (read-byte))
|
|
||||||
(eat-whitespace))
|
|
||||||
(unread-byte 35))))))
|
|
||||||
|
|
||||||
(define (read-block-comment c)
|
|
||||||
(if (eq? c 33) (if (eq? (peek-byte) 35) (read-byte)
|
|
||||||
(read-block-comment (read-byte)))
|
|
||||||
(read-block-comment (read-byte))))
|
|
||||||
|
|
||||||
;; (define (read-hex c)
|
|
||||||
;; (if (eq? c 10) c
|
|
||||||
;; (read-line-comment (read-byte))))
|
|
||||||
|
|
||||||
(define (read-line-comment c)
|
|
||||||
(if (eq? c 10) c
|
|
||||||
(read-line-comment (read-byte))))
|
|
||||||
|
|
||||||
(define (read-list a)
|
|
||||||
(eat-whitespace)
|
|
||||||
(if (eq? (peek-byte) 41) (begin (read-byte) (list))
|
|
||||||
((lambda (w)
|
|
||||||
(if (eq? w *dot*) (car (read-list a))
|
|
||||||
(cons w (read-list a))))
|
|
||||||
(read-word (read-byte) (list) a))))
|
|
||||||
|
|
||||||
;;(define (read-string))
|
|
||||||
|
|
||||||
(define (lookup-char c a)
|
|
||||||
(lookup (cons (integer->char c) (list)) a))
|
|
||||||
|
|
||||||
(define (read-word c w a)
|
|
||||||
(cond
|
|
||||||
((eq? c -1) (list))
|
|
||||||
((eq? c 10) (if (null? w) (read-word (read-byte) (list) a)
|
|
||||||
(lookup w a)))
|
|
||||||
((eq? c 32) (read-word 10 w a))
|
|
||||||
((eq? c 34) (if (null? w) (read-string)
|
|
||||||
(begin (unread-byte c) (lookup w a))))
|
|
||||||
((eq? c 35) (cond
|
|
||||||
((eq? (peek-byte) 33) (begin (read-byte)
|
|
||||||
(read-block-comment (read-byte))
|
|
||||||
(read-word (read-byte) w a)))
|
|
||||||
((eq? (peek-byte) 40) (read-byte) (list->vector (read-list a)))
|
|
||||||
((eq? (peek-byte) 92) (read-byte) (read-character))
|
|
||||||
((eq? (peek-byte) 120) (read-byte) (read-hex))
|
|
||||||
(else (read-word (read-byte) (append2 w (cons (integer->char c) (list))) a))))
|
|
||||||
((eq? c 39) (if (null? w) (cons (lookup (cons (integer->char c) (list)) a)
|
|
||||||
(cons (read-word (read-byte) w a) (list)))
|
|
||||||
(begin (unread-byte c) (lookup w a))))
|
|
||||||
((eq? c 40) (if (null? w) (read-list a)
|
|
||||||
(begin (unread-byte c) (lookup w a))))
|
|
||||||
((eq? c 41) (if (null? w) (cons (lookup (cons (integer->char c) (list)) a)
|
|
||||||
(cons (read-word (read-byte) w a) (list)))
|
|
||||||
(begin (unread-byte c) (lookup w a))))
|
|
||||||
((eq? c 44) (cond
|
|
||||||
((eq? (peek-byte) 64) (begin (read-byte)
|
|
||||||
(cons
|
|
||||||
(lookup (symbol->list (quote unquote-splicing)) a)
|
|
||||||
(cons (read-word (read-byte) w a) (list)))))
|
|
||||||
(else (cons (lookup-char c a) (cons (read-word (read-byte) w a)
|
|
||||||
(list))))))
|
|
||||||
((eq? c 96) (cons (lookup-char c a) (cons (read-word (read-byte) w a) (list))))
|
|
||||||
((eq? c 59) (read-line-comment c) (read-word 10 w a))
|
|
||||||
(else (read-word (read-byte) (append2 w (cons (integer->char c) (list))) a))))
|
|
||||||
|
|
||||||
;; ((lambda (p)
|
|
||||||
;; ;;(display (quote program=)) (display p) (newline)
|
|
||||||
;; (begin-env p (current-module)))
|
|
||||||
;; (read-input-file))
|
|
||||||
)
|
|
||||||
30
install.sh
30
install.sh
|
|
@ -15,6 +15,15 @@ MES_PREFIX=${MES_PREFIX-$prefix/share/mes}
|
||||||
MES_SEED=${MES_SEED-../MES-SEED}
|
MES_SEED=${MES_SEED-../MES-SEED}
|
||||||
TINYCC_SEED=${TINYCC_SEED-../TINYCC-SEED}
|
TINYCC_SEED=${TINYCC_SEED-../TINYCC-SEED}
|
||||||
|
|
||||||
|
GUILE_EFFECTIVE_VERSION=${GUILE_EFFECTIVE_VERSION-2.2}
|
||||||
|
datadir=${moduledir-$prefix/share/mes}
|
||||||
|
docdir=${moduledir-$prefix/share/doc/mes}
|
||||||
|
mandir=${mandir-$prefix/share/man}
|
||||||
|
moduledir=${moduledir-$datadir/module}
|
||||||
|
guile_site_dir=${guile_site_dir-$prefix/share/guile/site/$GUILE_EFFECTIVE_VERSION}
|
||||||
|
guile_site_ccache_dir=${guile_site_ccache_dir-$prefix/lib/guile/$GUILE_EFFECTIVE_VERSION/site-ccache}
|
||||||
|
docdir=${moduledir-$prefix/share/doc/mes}
|
||||||
|
|
||||||
mkdir -p $DESTDIR$prefix/bin
|
mkdir -p $DESTDIR$prefix/bin
|
||||||
cp src/mes $DESTDIR$prefix/bin/mes
|
cp src/mes $DESTDIR$prefix/bin/mes
|
||||||
|
|
||||||
|
|
@ -23,21 +32,18 @@ mkdir -p $DESTDIR$MES_PREFIX/lib
|
||||||
cp scripts/mescc $DESTDIR$prefix/bin/mescc
|
cp scripts/mescc $DESTDIR$prefix/bin/mescc
|
||||||
|
|
||||||
mkdir -p $DESTDIR$MES_PREFIX
|
mkdir -p $DESTDIR$MES_PREFIX
|
||||||
tar -cf- doc guile include lib module scaffold | tar -xf- -C $DESTDIR$MES_PREFIX
|
tar -cf- doc include lib scaffold | tar -xf- -C $DESTDIR$MES_PREFIX
|
||||||
|
tar -cf- --exclude='*.go' module | tar -xf- -C $DESTDIR$MES_PREFIX
|
||||||
|
tar -cf- -C mes module | tar -xf- -C $DESTDIR$MES_PREFIX
|
||||||
|
|
||||||
GUILE_EFFECTIVE_VERSION=${GUILE_EFFECTIVE_VERSION-2.2}
|
mkdir -p $DESTDIR$guile_site_dir
|
||||||
datadir=${moduledir-$prefix/share/mes}
|
mkdir -p $DESTDIR$guile_site_ccache_dir
|
||||||
docdir=${moduledir-$prefix/share/doc/mes}
|
tar -cf- -C module --exclude='*.go' . | tar -xf- -C $DESTDIR$guile_site_dir
|
||||||
mandir=${mandir-$prefix/share/man}
|
tar -cf- -C module --exclude='*.scm' . | tar -xf- -C $DESTDIR$guile_site_ccache_dir
|
||||||
moduledir=${moduledir-$datadir/module}
|
|
||||||
guile_site_dir=${moduledir-$prefix/share/guile/site/$GUILE_EFFECTIVE_VERSION}
|
|
||||||
guile_site_ccache_dir=${guile_site_ccache_dir-$prefix/lib/guile/$GUILE_EFFECTIVE_VERSION/site-ccache}
|
|
||||||
docdir=${moduledir-$prefix/share/doc/mes}
|
|
||||||
|
|
||||||
chmod +w $DESTDIR$prefix/bin/mescc
|
chmod +w $DESTDIR$prefix/bin/mescc
|
||||||
sed \
|
sed \
|
||||||
-e "s,^#! /bin/sh,#! $SHELL," \
|
-e "s,^#! /bin/sh,#! $SHELL," \
|
||||||
-e "s,module/,$moduledir/," \
|
|
||||||
-e "s,@datadir@,$datadir,g" \
|
-e "s,@datadir@,$datadir,g" \
|
||||||
-e "s,@docdir@,$docdir,g" \
|
-e "s,@docdir@,$docdir,g" \
|
||||||
-e "s,@guile_site_ccache_dir@,$guile_site_ccache_dir,g" \
|
-e "s,@guile_site_ccache_dir@,$guile_site_ccache_dir,g" \
|
||||||
|
|
@ -49,7 +55,7 @@ sed \
|
||||||
chmod +w $DESTDIR$moduledir/mes/boot-0.scm
|
chmod +w $DESTDIR$moduledir/mes/boot-0.scm
|
||||||
sed \
|
sed \
|
||||||
-e "s,^#! /bin/sh,#! $SHELL," \
|
-e "s,^#! /bin/sh,#! $SHELL," \
|
||||||
-e "s,module/,$moduledir/," \
|
-e "s,mes/module/,$moduledir/," \
|
||||||
-e "s,@datadir@,$datadir,g" \
|
-e "s,@datadir@,$datadir,g" \
|
||||||
-e "s,@docdir@,$docdir,g" \
|
-e "s,@docdir@,$docdir,g" \
|
||||||
-e "s,@guile_site_ccache_dir@,$guile_site_ccache_dir,g" \
|
-e "s,@guile_site_ccache_dir@,$guile_site_ccache_dir,g" \
|
||||||
|
|
@ -57,7 +63,7 @@ sed \
|
||||||
-e "s,@moduledir@,$moduledir,g" \
|
-e "s,@moduledir@,$moduledir,g" \
|
||||||
-e "s,@prefix@,$prefix,g" \
|
-e "s,@prefix@,$prefix,g" \
|
||||||
-e "s,@VERSION@,$VERSION,g" \
|
-e "s,@VERSION@,$VERSION,g" \
|
||||||
module/mes/boot-0.scm > $DESTDIR$moduledir/mes/boot-0.scm
|
mes/module/mes/boot-0.scm > $DESTDIR$moduledir/mes/boot-0.scm
|
||||||
|
|
||||||
sed \
|
sed \
|
||||||
-e "s,^#! /bin/sh,#! $SHELL," \
|
-e "s,^#! /bin/sh,#! $SHELL," \
|
||||||
|
|
|
||||||
1
mes/include
Symbolic link
1
mes/include
Symbolic link
|
|
@ -0,0 +1 @@
|
||||||
|
../include
|
||||||
|
|
@ -173,14 +173,12 @@
|
||||||
|
|
||||||
(define %prefix (getenv "MES_PREFIX"))
|
(define %prefix (getenv "MES_PREFIX"))
|
||||||
(define %moduledir
|
(define %moduledir
|
||||||
(if (not %prefix) "module/"
|
(if (not %prefix) "mes/module/"
|
||||||
(list->string
|
(list->string
|
||||||
(append (string->list %prefix)
|
(append (string->list %prefix) (string->list "/module/" )))))
|
||||||
(string->list "/module") ; `module/' gets replaced upon install
|
|
||||||
(string->list "/")))))
|
|
||||||
|
|
||||||
(include (list->string
|
(include (list->string
|
||||||
(append2 (string->list %moduledir) (string->list "/mes/type-0.mes"))))
|
(append2 (string->list %moduledir) (string->list "mes/type-0.mes"))))
|
||||||
|
|
||||||
(define (symbol->string s)
|
(define (symbol->string s)
|
||||||
(apply string (symbol->list s)))
|
(apply string (symbol->list s)))
|
||||||
|
|
@ -211,20 +209,26 @@
|
||||||
(include-from-path "mes/module.mes")
|
(include-from-path "mes/module.mes")
|
||||||
|
|
||||||
(mes-use-module (mes base))
|
(mes-use-module (mes base))
|
||||||
;; ;; (mes-use-module (srfi srfi-0))
|
|
||||||
(mes-use-module (mes quasiquote))
|
(mes-use-module (mes quasiquote))
|
||||||
(mes-use-module (mes let))
|
(mes-use-module (mes let))
|
||||||
|
|
||||||
(mes-use-module (mes scm))
|
(mes-use-module (mes scm))
|
||||||
|
(mes-use-module (srfi srfi-1))
|
||||||
(mes-use-module (srfi srfi-1)) ;; FIXME: module read order
|
|
||||||
(mes-use-module (srfi srfi-13))
|
(mes-use-module (srfi srfi-13))
|
||||||
|
(mes-use-module (mes fluids))
|
||||||
(mes-use-module (mes fluids)) ;; FIXME: module read order
|
|
||||||
(mes-use-module (mes catch))
|
(mes-use-module (mes catch))
|
||||||
|
|
||||||
(mes-use-module (mes posix))
|
(mes-use-module (mes posix))
|
||||||
|
|
||||||
|
(define-macro (include-from-path file)
|
||||||
|
(let loop ((path (cons* %moduledir "module" (string-split (or (getenv "GUILE_LOAD_PATH")) #\:))))
|
||||||
|
(cond ((and=> (getenv "MES_DEBUG") (compose (lambda (o) (> o 2)) string->number))
|
||||||
|
(core:display-error (string-append "include-from-path: " file " [PATH:" (string-join path ":") "]\n")))
|
||||||
|
((and=> (getenv "MES_DEBUG") (compose (lambda (o) (> o 1)) string->number))
|
||||||
|
(core:display-error (string-append "include-from-path: " file "\n"))))
|
||||||
|
(if (null? path) (error "include-from-path: not found: " file)
|
||||||
|
(let ((file (string-append (car path) "/" file)))
|
||||||
|
(if (access? file R_OK) `(load ,file)
|
||||||
|
(loop (cdr path)))))))
|
||||||
|
|
||||||
(define-macro (define-module module . rest)
|
(define-macro (define-module module . rest)
|
||||||
`(if ,(and (pair? module)
|
`(if ,(and (pair? module)
|
||||||
(= 1 (length module))
|
(= 1 (length module))
|
||||||
|
|
@ -233,8 +237,6 @@
|
||||||
|
|
||||||
(define-macro (use-modules . rest) #t)
|
(define-macro (use-modules . rest) #t)
|
||||||
|
|
||||||
;; ;; end boot-0.scm
|
|
||||||
|
|
||||||
(mes-use-module (mes getopt-long))
|
(mes-use-module (mes getopt-long))
|
||||||
|
|
||||||
(define %main #f)
|
(define %main #f)
|
||||||
|
|
@ -110,6 +110,10 @@
|
||||||
|
|
||||||
(define-macro (mes-use-module module)
|
(define-macro (mes-use-module module)
|
||||||
#t)
|
#t)
|
||||||
|
|
||||||
|
(define-macro (define-module module . rest)
|
||||||
|
#t)
|
||||||
|
|
||||||
;; end boot-02.scm
|
;; end boot-02.scm
|
||||||
|
|
||||||
(primitive-load 0)
|
(primitive-load 0)
|
||||||
|
|
@ -26,17 +26,6 @@
|
||||||
|
|
||||||
(define-macro (cond-expand-provide . rest) #t)
|
(define-macro (cond-expand-provide . rest) #t)
|
||||||
|
|
||||||
(define-macro (include-from-path file)
|
|
||||||
(let loop ((path (cons %moduledir (string-split (or (getenv "GUILE_LOAD_PATH") "") #\:))))
|
|
||||||
(cond ((and=> (getenv "MES_DEBUG") (compose (lambda (o) (> o 1)) string->number))
|
|
||||||
(core:display-error (string-append "include-from-path: " file "\n")))
|
|
||||||
((and=> (getenv "MES_DEBUG") (compose (lambda (o) (> o 1)) string->number)))
|
|
||||||
(core:display-error (string-append "include-from-path: " file " [PATH:" (string-join path ":") "]\n")))
|
|
||||||
(if (null? path) (error "include-from-path: not found: " file)
|
|
||||||
(let ((file (string-append (car path) "/" file)))
|
|
||||||
(if (access? file R_OK) `(load ,file)
|
|
||||||
(loop (cdr path)))))))
|
|
||||||
|
|
||||||
(mes-use-module (mes catch))
|
(mes-use-module (mes catch))
|
||||||
(mes-use-module (mes posix))
|
(mes-use-module (mes posix))
|
||||||
(mes-use-module (srfi srfi-16))
|
(mes-use-module (srfi srfi-16))
|
||||||
21
mes/module/mes/test.mes
Normal file
21
mes/module/mes/test.mes
Normal file
|
|
@ -0,0 +1,21 @@
|
||||||
|
;;; -*-scheme-*-
|
||||||
|
|
||||||
|
;;; Mes --- Maxwell Equations of Software
|
||||||
|
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
||||||
|
;;;
|
||||||
|
;;; This file is part of Mes.
|
||||||
|
;;;
|
||||||
|
;;; Mes is free software; you can redistribute it and/or modify it
|
||||||
|
;;; under the terms of the GNU General Public License as published by
|
||||||
|
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||||||
|
;;; your option) any later version.
|
||||||
|
;;;
|
||||||
|
;;; Mes is distributed in the hope that it will be useful, but
|
||||||
|
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||||
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||||
|
;;; GNU General Public License for more details.
|
||||||
|
;;;
|
||||||
|
;;; You should have received a copy of the GNU General Public License
|
||||||
|
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
(include-from-path "mes/test.scm")
|
||||||
|
|
@ -1,177 +0,0 @@
|
||||||
;;; -*-scheme-*-
|
|
||||||
|
|
||||||
;;; Mes --- Maxwell Equations of Software
|
|
||||||
;;; Copyright © 2008 Derek Peschel
|
|
||||||
;;; Copyright © 2016 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
|
||||||
;;;
|
|
||||||
;;; This file is part of Mes.
|
|
||||||
;;;
|
|
||||||
;;; Mes is free software; you can redistribute it and/or modify it
|
|
||||||
;;; under the terms of the GNU General Public License as published by
|
|
||||||
;;; the Free Software Foundation; either version 3 of the License, or (at
|
|
||||||
;;; your option) any later version.
|
|
||||||
;;;
|
|
||||||
;;; Mes is distributed in the hope that it will be useful, but
|
|
||||||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
||||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
||||||
;;; GNU General Public License for more details.
|
|
||||||
;;;
|
|
||||||
;;; You should have received a copy of the GNU General Public License
|
|
||||||
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
|
|
||||||
|
|
||||||
;;; Commentary:
|
|
||||||
|
|
||||||
;;; paren.mes is a simple yet full lalr test for Mes taken from the
|
|
||||||
;;; Gambit wiki.
|
|
||||||
;;;
|
|
||||||
;;; Run with Guile:
|
|
||||||
;;; echo '___P((()))' | guile -s <(echo '(paren-depth)' | cat cc/paren.mes -)
|
|
||||||
|
|
||||||
;;; Code:
|
|
||||||
|
|
||||||
(cond-expand
|
|
||||||
(guile
|
|
||||||
(use-modules (system base lalr)))
|
|
||||||
(mes
|
|
||||||
(mes-use-module (srfi srfi-9))
|
|
||||||
(mes-use-module (mes lalr))))
|
|
||||||
|
|
||||||
;;; Taken from http://gambitscheme.org/wiki/index.php/Lalr_example
|
|
||||||
;;; LGPL 2.1 / Apache 2.0
|
|
||||||
|
|
||||||
;;; Read C source code, breaking it into the following types of tokens:
|
|
||||||
;;; the identifier ___P, other identifiers, left and right parentheses,
|
|
||||||
;;; and any other non-spacing character. White space (space, tab, and
|
|
||||||
;;; newline characters) is never a token and may come between any two
|
|
||||||
;;; tokens, before the first, or after the last.
|
|
||||||
|
|
||||||
;;; Whenever the identifier ___P is seen, read a left parenthesis
|
|
||||||
;;; followed by a body (zero or more tokens) followed by a right
|
|
||||||
;;; parenthesis. If the body contains parentheses they must be properly
|
|
||||||
;;; paired. Other tokens in the body, including ___P, have no effect.
|
|
||||||
;;; Count the deepest nesting level used in the body. Count the maximum
|
|
||||||
;;; deepest level (of all the bodies seen so far).
|
|
||||||
|
|
||||||
;;; At the end of the file, print the maximum deepest level, or 0 if no
|
|
||||||
;;; bodies were found.
|
|
||||||
|
|
||||||
|
|
||||||
;;; Global variables used by lexical analyzer and parser.
|
|
||||||
;;; The lexical analyzer needs them to print the maximum level at the
|
|
||||||
;;; end of the file.
|
|
||||||
|
|
||||||
(define depth 0)
|
|
||||||
(define max-depth 0)
|
|
||||||
|
|
||||||
;;; Lexical analyzer. Passes tokens to the parser.
|
|
||||||
|
|
||||||
(define (paren-depth-lexer errorp)
|
|
||||||
(lambda ()
|
|
||||||
|
|
||||||
;; Utility functions, for identifying characters, skipping any
|
|
||||||
;; amount of white space, or reading multicharacter tokens.
|
|
||||||
|
|
||||||
(letrec ((char-whitespace?
|
|
||||||
(lambda (c)
|
|
||||||
(or (char=? c #\space)
|
|
||||||
(char=? c #\tab)
|
|
||||||
(char=? c #\newline))))
|
|
||||||
(skip-whitespace
|
|
||||||
(lambda ()
|
|
||||||
(let loop ((c (peek-char)))
|
|
||||||
(if (and (not (eof-object? c))
|
|
||||||
(char-whitespace? c))
|
|
||||||
(begin (read-char)
|
|
||||||
(loop (peek-char)))))))
|
|
||||||
|
|
||||||
(char-in-id?
|
|
||||||
(lambda (c)
|
|
||||||
(or (char-alphabetic? c)
|
|
||||||
(char=? c #\_))))
|
|
||||||
(read-___P-or-other-id
|
|
||||||
(lambda (l)
|
|
||||||
(let ((c (peek-char)))
|
|
||||||
(if (char-in-id? c)
|
|
||||||
(read-___P-or-other-id (cons (read-char) l))
|
|
||||||
;; else
|
|
||||||
(if (equal? l '(#\P #\_ #\_ #\_))
|
|
||||||
'___P
|
|
||||||
;; else
|
|
||||||
'ID))))))
|
|
||||||
|
|
||||||
;; The lexer function.
|
|
||||||
|
|
||||||
(skip-whitespace)
|
|
||||||
(let loop ((c (read-char)))
|
|
||||||
(cond
|
|
||||||
((eof-object? c) (begin (display "max depth ")
|
|
||||||
(display max-depth)
|
|
||||||
(newline)
|
|
||||||
'*eoi*))
|
|
||||||
((char-whitespace? c) (begin (errorp "didn't expect whitespace " c)
|
|
||||||
(loop (read-char))))
|
|
||||||
((char-in-id? c) (read-___P-or-other-id (list c)))
|
|
||||||
((char=? c #\() 'LPAREN)
|
|
||||||
((char=? c #\)) 'RPAREN)
|
|
||||||
(else 'CHAR))))))
|
|
||||||
|
|
||||||
;;; Parser.
|
|
||||||
|
|
||||||
(define paren-depth-parser
|
|
||||||
(lalr-parser
|
|
||||||
|
|
||||||
;; Options.
|
|
||||||
|
|
||||||
(expect: 0) ;; even one conflict is an error
|
|
||||||
|
|
||||||
;; List of terminal tokens.
|
|
||||||
|
|
||||||
(CHAR LPAREN RPAREN ID ___P)
|
|
||||||
|
|
||||||
;; Grammar rules.
|
|
||||||
|
|
||||||
(file (newfile tokens))
|
|
||||||
(newfile () : (begin (set! depth 0)
|
|
||||||
(set! max-depth 0)))
|
|
||||||
|
|
||||||
(tokens (tokens token)
|
|
||||||
(token))
|
|
||||||
|
|
||||||
;; When not after a ___P, the structure of the file is unimportant.
|
|
||||||
(token (CHAR)
|
|
||||||
(LPAREN)
|
|
||||||
(RPAREN)
|
|
||||||
(ID)
|
|
||||||
|
|
||||||
;; But after a ___P, we start counting parentheses.
|
|
||||||
(___P newexpr in LPAREN exprs RPAREN out)
|
|
||||||
(___P newexpr in LPAREN RPAREN out))
|
|
||||||
(newexpr () : (set! depth 0))
|
|
||||||
|
|
||||||
;; Inside an expression, ___P is treated like all other identifiers.
|
|
||||||
;; Only parentheses do anything very interesting. I'm assuming Lalr
|
|
||||||
;; will enforce the pairing of parentheses, so my in and out actions
|
|
||||||
;; don't check for too many or too few closing parens.
|
|
||||||
|
|
||||||
(exprs (exprs expr)
|
|
||||||
(expr))
|
|
||||||
|
|
||||||
(expr (CHAR)
|
|
||||||
(in LPAREN exprs RPAREN out)
|
|
||||||
(in LPAREN RPAREN out)
|
|
||||||
(ID)
|
|
||||||
(___P))
|
|
||||||
(in () : (begin (set! depth (+ depth 1))
|
|
||||||
(if (> depth max-depth)
|
|
||||||
(set! max-depth depth))))
|
|
||||||
(out () : (set! depth (- depth 1)))))
|
|
||||||
|
|
||||||
;;; Main program.
|
|
||||||
|
|
||||||
(define paren-depth
|
|
||||||
(let ((errorp
|
|
||||||
(lambda args
|
|
||||||
(for-each display args)
|
|
||||||
(newline))))
|
|
||||||
(lambda ()
|
|
||||||
(paren-depth-parser (paren-depth-lexer errorp) errorp))))
|
|
||||||
|
|
@ -27,10 +27,5 @@
|
||||||
|
|
||||||
(define-macro (mes-use-module . rest) #t)
|
(define-macro (mes-use-module . rest) #t)
|
||||||
(define builtin? procedure?) ; not strictly true, but ok for tests/*.test
|
(define builtin? procedure?) ; not strictly true, but ok for tests/*.test
|
||||||
(cond-expand
|
|
||||||
(mes)
|
|
||||||
(guile-2)
|
|
||||||
(guile
|
|
||||||
(use-modules (ice-9 syncase))))
|
|
||||||
(define EOF (if #f #f))
|
(define EOF (if #f #f))
|
||||||
(define append2 append)
|
(define append2 append)
|
||||||
|
|
@ -1,128 +0,0 @@
|
||||||
;;; -*-scheme-*-
|
|
||||||
|
|
||||||
;;; Mes --- Maxwell Equations of Software
|
|
||||||
;;; Copyright © 2016,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
|
||||||
;;;
|
|
||||||
;;; This file is part of Mes.
|
|
||||||
;;;
|
|
||||||
;;; Mes is free software; you can redistribute it and/or modify it
|
|
||||||
;;; under the terms of the GNU General Public License as published by
|
|
||||||
;;; the Free Software Foundation; either version 3 of the License, or (at
|
|
||||||
;;; your option) any later version.
|
|
||||||
;;;
|
|
||||||
;;; Mes is distributed in the hope that it will be useful, but
|
|
||||||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
||||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
||||||
;;; GNU General Public License for more details.
|
|
||||||
;;;
|
|
||||||
;;; You should have received a copy of the GNU General Public License
|
|
||||||
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
|
|
||||||
|
|
||||||
;;; Commentary:
|
|
||||||
|
|
||||||
;;; test.mes can be loaded after base.mes. It provides a minimalistic
|
|
||||||
;;; test framework: pass-if, pass-if-not, seq?, sequal? and result.
|
|
||||||
|
|
||||||
;;; Code:
|
|
||||||
|
|
||||||
(cond-expand
|
|
||||||
(mes
|
|
||||||
(mes-use-module (mes base)))
|
|
||||||
(else))
|
|
||||||
|
|
||||||
(cond-expand
|
|
||||||
(mes
|
|
||||||
(define mes? #t)
|
|
||||||
(define guile? #f)
|
|
||||||
(define guile-2? #f)
|
|
||||||
(define guile-1.8? #f))
|
|
||||||
(guile-2
|
|
||||||
(define mes? #f)
|
|
||||||
(define guile? #t)
|
|
||||||
(define guile-2? #t)
|
|
||||||
(define guile-1.8? #f))
|
|
||||||
(guile
|
|
||||||
(define mes? #f)
|
|
||||||
(define guile? #f)
|
|
||||||
(define guile-2? #f)
|
|
||||||
(define guile-1.8? #t)))
|
|
||||||
|
|
||||||
(define result
|
|
||||||
((lambda (pass fail)
|
|
||||||
(lambda (. t)
|
|
||||||
(if (or (null? t) (eq? (car t) 'result)) (list pass fail)
|
|
||||||
(if (eq? (car t) 'report)
|
|
||||||
(begin
|
|
||||||
((lambda (expect)
|
|
||||||
(begin (display "expect: ") (write expect) (newline))
|
|
||||||
(newline)
|
|
||||||
(display "passed: ") (display pass) (newline)
|
|
||||||
(display "failed: ") (display fail) (newline)
|
|
||||||
(if (not (eq? expect 0)) (begin (display "expect: ") (write expect) (newline)))
|
|
||||||
(display "total: ") (display (+ pass fail)) (newline)
|
|
||||||
(exit (if (eq? expect fail) 0 fail)))
|
|
||||||
(if (null? (cdr t)) 0 (cadr t))))
|
|
||||||
(if (car t) (begin (display ": pass") (newline) (set! pass (+ pass 1)))
|
|
||||||
(begin (display ": fail") (newline) (set! fail (+ fail 1))))))))
|
|
||||||
0 0))
|
|
||||||
|
|
||||||
(define (seq? expect a) ;;REMOVE ME
|
|
||||||
(or (eq? a expect)
|
|
||||||
(begin
|
|
||||||
(display ": fail")
|
|
||||||
(newline)
|
|
||||||
(display "expected: ")
|
|
||||||
(display expect) (newline)
|
|
||||||
(display "actual: ")
|
|
||||||
(display a)
|
|
||||||
(newline)
|
|
||||||
#f)))
|
|
||||||
|
|
||||||
(define (sequal? expect a) ;;REMOVE ME
|
|
||||||
(or (equal? a expect)
|
|
||||||
(begin
|
|
||||||
(display ": fail")
|
|
||||||
(newline)
|
|
||||||
(display "expected: ")
|
|
||||||
(display expect) (newline)
|
|
||||||
(display "actual: ")
|
|
||||||
(display a)
|
|
||||||
(newline)
|
|
||||||
#f)))
|
|
||||||
|
|
||||||
(define (seq2? a expect)
|
|
||||||
(or (eq? a expect)
|
|
||||||
(begin
|
|
||||||
(display ": fail") (newline)
|
|
||||||
(display "expected: ") (display expect) (newline)
|
|
||||||
(display "actual: ") (display a) (newline)
|
|
||||||
#f)))
|
|
||||||
|
|
||||||
(define (sequal2? actual expect)
|
|
||||||
(or (equal? actual expect)
|
|
||||||
(begin
|
|
||||||
(display ": fail") (newline)
|
|
||||||
(display "expected: ") (display expect) (newline)
|
|
||||||
(display "actual: ") (display actual) (newline)
|
|
||||||
#f)))
|
|
||||||
|
|
||||||
(define-macro (pass-if name t)
|
|
||||||
(list
|
|
||||||
'begin
|
|
||||||
(list display "test: ") (list display name)
|
|
||||||
(list 'result t))) ;; FIXME
|
|
||||||
|
|
||||||
(define-macro (pass-if-eq name expect . body)
|
|
||||||
(list 'pass-if name (list seq2? (cons 'begin body) expect)))
|
|
||||||
|
|
||||||
(define-macro (pass-if-equal name expect . body)
|
|
||||||
(list 'pass-if name (list sequal2? (cons 'begin body) expect)))
|
|
||||||
|
|
||||||
(define-macro (expect-fail name expect . body)
|
|
||||||
(list 'pass-if name (list not (list sequal2? (cons 'begin body) expect))))
|
|
||||||
|
|
||||||
(define-macro (pass-if-not name f)
|
|
||||||
(list
|
|
||||||
'begin
|
|
||||||
(list display "test: ") (list display name)
|
|
||||||
(list 'result (list not f)))) ;; FIXME
|
|
||||||
|
|
@ -1,7 +1,7 @@
|
||||||
;;; -*-scheme-*-
|
;;; -*-scheme-*-
|
||||||
|
|
||||||
;;; Mes --- Maxwell Equations of Software
|
;;; Mes --- Maxwell Equations of Software
|
||||||
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
;;; Copyright © 2016,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
||||||
;;;
|
;;;
|
||||||
;;; This file is part of Mes.
|
;;; This file is part of Mes.
|
||||||
;;;
|
;;;
|
||||||
|
|
@ -18,5 +18,106 @@
|
||||||
;;; You should have received a copy of the GNU General Public License
|
;;; You should have received a copy of the GNU General Public License
|
||||||
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
|
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
(define-module (mes test))
|
;;; Commentary:
|
||||||
(include-from-path "mes/test.mes")
|
|
||||||
|
;;; test.mes can be loaded after base.mes. It provides a minimalistic
|
||||||
|
;;; test framework: pass-if, pass-if-not, seq?, sequal? and result.
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
(cond-expand
|
||||||
|
(mes
|
||||||
|
(define mes? #t)
|
||||||
|
(define guile? #f)
|
||||||
|
(define guile-2? #f)
|
||||||
|
(define guile-1.8? #f))
|
||||||
|
(guile-2
|
||||||
|
(define mes? #f)
|
||||||
|
(define guile? #t)
|
||||||
|
(define guile-2? #t)
|
||||||
|
(define guile-1.8? #f))
|
||||||
|
(guile
|
||||||
|
(define mes? #f)
|
||||||
|
(define guile? #f)
|
||||||
|
(define guile-2? #f)
|
||||||
|
(define guile-1.8? #t)))
|
||||||
|
|
||||||
|
(define result
|
||||||
|
((lambda (pass fail)
|
||||||
|
(lambda (. t)
|
||||||
|
(if (or (null? t) (eq? (car t) 'result)) (list pass fail)
|
||||||
|
(if (eq? (car t) 'report)
|
||||||
|
(begin
|
||||||
|
((lambda (expect)
|
||||||
|
(begin (display "expect: ") (write expect) (newline))
|
||||||
|
(newline)
|
||||||
|
(display "passed: ") (display pass) (newline)
|
||||||
|
(display "failed: ") (display fail) (newline)
|
||||||
|
(if (not (eq? expect 0)) (begin (display "expect: ") (write expect) (newline)))
|
||||||
|
(display "total: ") (display (+ pass fail)) (newline)
|
||||||
|
(exit (if (eq? expect fail) 0 fail)))
|
||||||
|
(if (null? (cdr t)) 0 (cadr t))))
|
||||||
|
(if (car t) (begin (display ": pass") (newline) (set! pass (+ pass 1)))
|
||||||
|
(begin (display ": fail") (newline) (set! fail (+ fail 1))))))))
|
||||||
|
0 0))
|
||||||
|
|
||||||
|
(define (seq? expect a) ;;REMOVE ME
|
||||||
|
(or (eq? a expect)
|
||||||
|
(begin
|
||||||
|
(display ": fail")
|
||||||
|
(newline)
|
||||||
|
(display "expected: ")
|
||||||
|
(display expect) (newline)
|
||||||
|
(display "actual: ")
|
||||||
|
(display a)
|
||||||
|
(newline)
|
||||||
|
#f)))
|
||||||
|
|
||||||
|
(define (sequal? expect a) ;;REMOVE ME
|
||||||
|
(or (equal? a expect)
|
||||||
|
(begin
|
||||||
|
(display ": fail")
|
||||||
|
(newline)
|
||||||
|
(display "expected: ")
|
||||||
|
(display expect) (newline)
|
||||||
|
(display "actual: ")
|
||||||
|
(display a)
|
||||||
|
(newline)
|
||||||
|
#f)))
|
||||||
|
|
||||||
|
(define (seq2? a expect)
|
||||||
|
(or (eq? a expect)
|
||||||
|
(begin
|
||||||
|
(display ": fail") (newline)
|
||||||
|
(display "expected: ") (display expect) (newline)
|
||||||
|
(display "actual: ") (display a) (newline)
|
||||||
|
#f)))
|
||||||
|
|
||||||
|
(define (sequal2? actual expect)
|
||||||
|
(or (equal? actual expect)
|
||||||
|
(begin
|
||||||
|
(display ": fail") (newline)
|
||||||
|
(display "expected: ") (display expect) (newline)
|
||||||
|
(display "actual: ") (display actual) (newline)
|
||||||
|
#f)))
|
||||||
|
|
||||||
|
(define-macro (pass-if name t)
|
||||||
|
(list
|
||||||
|
'begin
|
||||||
|
(list display "test: ") (list display name)
|
||||||
|
(list 'result t))) ;; FIXME
|
||||||
|
|
||||||
|
(define-macro (pass-if-eq name expect . body)
|
||||||
|
(list 'pass-if name (list seq2? (cons 'begin body) expect)))
|
||||||
|
|
||||||
|
(define-macro (pass-if-equal name expect . body)
|
||||||
|
(list 'pass-if name (list sequal2? (cons 'begin body) expect)))
|
||||||
|
|
||||||
|
(define-macro (expect-fail name expect . body)
|
||||||
|
(list 'pass-if name (list not (list sequal2? (cons 'begin body) expect))))
|
||||||
|
|
||||||
|
(define-macro (pass-if-not name f)
|
||||||
|
(list
|
||||||
|
'begin
|
||||||
|
(list display "test: ") (list display name)
|
||||||
|
(list 'result (list not f)))) ;; FIXME
|
||||||
|
|
|
||||||
Some files were not shown because too many files have changed in this diff Show more
Loading…
Reference in a new issue