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

test: Add syntax tests.

Browse source 
* tests/syntax.test: New file.
* tests/syntax.test-guile: New file.

fixup: 1b0696f9 (Jan Nieuwenhuizen 2018-01-01 15:53:13 +0100 40) ,        (lambda ()
This commit is contained in:
Jan Nieuwenhuizen 2018-01-01 15:53:13 +01:00
parent 562d91466c
commit 08562b168d
15 changed files with 240 additions and 68 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

23
check.sh
View file

@ -1,5 +1,23 @@
#! /bin/sh
# Mes --- Maxwell Equations of Software
# Copyright © 2017,2018 Jan 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/>.
export GUILE=${GUILE-guile}
export MES=${MES-./mes}
@ -20,11 +38,12 @@ tests/srfi-14.test
tests/optargs.test
tests/fluids.test
tests/catch.test
tests/psyntax.test
tests/record.test
tests/syntax.test
tests/pmatch.test
tests/let-syntax.test
tests/guile.test
tests/record.test
tests/psyntax.test
"
slow="

30
make.scm
View file

@ -3,6 +3,24 @@
exec ${GUILE-guile} --no-auto-compile -L . -L guile -C . -C guile -s "$0" ${1+"$@"}
!#
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2017,2018 Jan 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/>.
(use-modules (srfi srfi-26)
(guix shell-utils))
@ -464,13 +482,14 @@ exec ${GUILE-guile} --no-auto-compile -L . -L guile -C . -C guile -s "$0" ${1+"$
"tests/optargs.test"
"tests/fluids.test"
"tests/catch.test"
"tests/psyntax.test"
"tests/record.test"
"tests/syntax.test"
"tests/pmatch.test"
"tests/let-syntax.test"
"tests/guile.test"
"tests/record.test"
;;sloooowwww
;;"tests/match.test"
"tests/psyntax.test"
"tests/match.test"
;;sloooowwww/broken?
;;"tests/peg.test"
))
@ -494,6 +513,8 @@ exec ${GUILE-guile} --no-auto-compile -L . -L guile -C . -C guile -s "$0" ${1+"$
;; ...mes.guile passes :-)
(for-each add-mes.guile-test mes-tests)
(add-target (group "check-tests" #:dependencies (filter (target-prefix? "check-tests/") %targets)))
;; FIXME: run tests/base.test
(setenv "MES" "src/mes.guile")
@ -543,6 +564,7 @@ exec ${GUILE-guile} --no-auto-compile -L . -L guile -C . -C guile -s "$0" ${1+"$
"module/mes/let.mes"
"module/mes/match.mes"
"module/mes/match.scm"
"module/mes/module.mes"
"module/mes/optargs.mes"
"module/mes/optargs.scm"
"module/mes/peg.mes"

36
module/mes/base-0.mes
View file

@ -1,7 +1,7 @@
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2016,2017,2018 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Mes.
;;;
@ -72,12 +72,10 @@
(define else #t)
(define (cadr x) (car (cdr x)))
(define-macro (simple-let bindings . rest)
(cons (cons 'lambda (cons (map1 car bindings) rest))
(map1 cadr bindings)))
(define-macro (let bindings . rest)
(cons 'simple-let (cons bindings rest)))
(cons (cons 'lambda (cons (map1 car bindings) rest))
(map1 cadr bindings)))
(define *input-ports* '())
(define-macro (push! stack o)
@ -151,35 +149,17 @@
(if (null? (cdr lst)) (car lst)
(string-append (car lst) infix (string-join (cdr lst) infix))))
(define (module->file o)
(string-append (string-join (map1 symbol->string o) "/") ".mes"))
(define *modules* '(mes/base-0.mes))
(define (mes-load-module-env module a)
(push! *input-ports* (current-input-port))
(set-current-input-port (open-input-file (string-append %moduledir (module->file module))))
(let ((x (core:eval (append2 (cons 'begin (read-input-file-env a))
'((current-module)))
a)))
(set-current-input-port (pop! *input-ports*))
x))
(define (not x)
(if x #f #t))
(define-macro (mes-use-module module)
(list
'begin
(list 'if (list 'not (list 'memq (list string->symbol (module->file module)) '*modules*))
(list
'begin
(list 'set! '*modules* (list cons (list string->symbol (module->file module)) '*modules*))
(list 'load (list string-append '%moduledir (module->file module)))))))
(include-from-path "mes/module.mes")
(mes-use-module (mes base))
(mes-use-module (srfi srfi-0))
(mes-use-module (mes quasiquote))
(mes-use-module (mes let))
(mes-use-module (mes scm))
(mes-use-module (srfi srfi-13))
(mes-use-module (mes display))
(mes-use-module (mes catch))
(mes-use-module (mes posix))

11
module/mes/catch.mes
View file

@ -1,7 +1,7 @@
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2016,2018 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Mes.
;;;
@ -23,7 +23,14 @@
(define %eh (make-fluid
(lambda (key . args)
(format (current-error-port) "unhandled exception: ~a ~a\n" key args)
(if (defined? 'simple-format)
(simple-format (current-error-port) "unhandled exception:~a:~a\n" key args)
(begin
(display "unhandled exception:" (current-error-port))
(display key (current-error-port))
(display ":" (current-error-port))
(display args (current-error-port))
(newline (current-error-port))))
(exit 1))))
(define (catch key thunk handler)

6
module/mes/guile.mes
View file

@ -1,7 +1,7 @@
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2016,2017,2018 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Mes.
;;;
@ -36,7 +36,10 @@
(if (access? file R_OK) `(load ,file)
(loop (cdr path)))))))
(mes-use-module (mes catch))
(mes-use-module (mes posix))
(mes-use-module (srfi srfi-16))
(mes-use-module (mes display))
(define (read-string)
(define (read-string c)
@ -58,7 +61,6 @@
(define (port-filename p) "<stdin>")
(define (port-line p) 0)
(define (simple-format port format . rest) (map (lambda (x) (display x port)) rest))
(define (with-input-from-string string thunk)
(define save-peek-char peek-char)

13
module/mes/let.mes
View file

@ -1,7 +1,7 @@
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2016,2018 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Mes.
;;;
@ -28,6 +28,10 @@
(mes-use-module (mes base))
(mes-use-module (mes quasiquote))
(define-macro (simple-let bindings . rest)
(cons (cons 'lambda (cons (map1 car bindings) rest))
(map1 cadr bindings)))
(define-macro (xsimple-let bindings rest)
`(,`(lambda ,(map car bindings) ,@rest)
,@(map cadr bindings)))
@ -37,11 +41,10 @@
(set! ,name (lambda ,(map car bindings) ,@rest))
(,name ,@(map cadr bindings))))
;; IF
(define-macro (let bindings-or-name . rest)
`(if ,(symbol? bindings-or-name) ;; IF
(xnamed-let ,bindings-or-name ,(car rest) ,(cdr rest))
(xsimple-let ,bindings-or-name ,rest)))
(if (symbol? bindings-or-name)
`(xnamed-let ,bindings-or-name ,(car rest) ,(cdr rest))
`(xsimple-let ,bindings-or-name ,rest)))
(define (expand-let* bindings body)
(if (null? bindings)

45
module/mes/module.mes Normal file
View file

@ -0,0 +1,45 @@
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017,2018 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Mes.
;;;
;;; Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(define (module->file o)
(string-append (string-join (map1 symbol->string o) "/") ".mes"))
(define *modules* '(mes/base-0.mes))
(define (mes-load-module-env module a)
(push! *input-ports* (current-input-port))
(set-current-input-port (open-input-file (string-append %moduledir (module->file module))))
(let ((x (core:eval (append2 (cons 'begin (read-input-file-env a))
'((current-module)))
a)))
(set-current-input-port (pop! *input-ports*))
x))
(define-macro (mes-use-module module)
(list
'begin
(list 'if (list 'not (list 'memq (list string->symbol (module->file module)) '*modules*))
(list
'begin
(list 'set! '*modules* (list cons (list string->symbol (module->file module)) '*modules*))
(list 'load (list string-append '%moduledir (module->file module)))))))

4
module/mes/read-0.mes
View file

@ -1,7 +1,7 @@
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2016,2017,2018 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Mes.
;;;
@ -116,7 +116,7 @@
(define (newline . rest) (core:display (list->string (list (integer->char 10)))))
(define (display x . rest) (if (null? rest) (core:display x)
(core:display x (car rest))))
(core:display-port x (car rest))))
(define (list->symbol lst) (core:lookup-symbol lst))

38
module/mes/repl.mes
View file

@ -1,7 +1,7 @@
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2016,2017,2018 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Mes.
;;;
@ -111,7 +111,7 @@ along with Mes. If not, see <http://www.gnu.org/licenses/>.
(define (repl)
(let ((count 0)
(print-sexp? #t))
(define (expand a)
(lambda ()
(let ((sexp (read)))
@ -120,16 +120,16 @@ along with Mes. If not, see <http://www.gnu.org/licenses/>.
(display sexp)
(display "]")
(newline))
(display (eval (list core:macro-expand sexp) a))
(newline))))
(core:macro-expand sexp))))
(define (help . x) (display help-commands))
(define (help . x) (display help-commands) *unspecified*)
(define (show . x)
(define topic-alist `((#\newline . ,show-commands)
(#\c . ,copying)
(#\w . ,warranty)))
(let ((topic (read-char)))
(display (assoc-ref topic-alist topic))))
(display (assoc-ref topic-alist topic))
*unspecified*))
(define (use a)
(lambda ()
(let ((module (read)))
@ -155,22 +155,26 @@ along with Mes. If not, see <http://www.gnu.org/licenses/>.
(display sexp)
(display "]")
(newline))
(cond ((and (pair? sexp) (eq? (car sexp) (string->symbol "unquote")))
(let ((r (meta (cadr sexp) a)))
(if (pair? r) (loop (append r a))
(loop a))))
((and (pair? sexp) (eq? (car sexp) 'mes-use-module))
(loop (mes-load-module-env (cadr sexp) a)))
(else
(let ((e (eval sexp a)))
(if (eq? e *unspecified*) (loop a)
(if (and (pair? sexp) (eq? (car sexp) 'mes-use-module))
(loop (mes-load-module-env (cadr sexp) a))
(let ((e (if (and (pair? sexp) (eq? (car sexp) (string->symbol "unquote")))
(meta (cadr sexp) a)
(eval sexp a))))
(if (eq? e *unspecified*) (loop a)
(let ((id (string->symbol (string-append "$" (number->string count)))))
(set! count (+ count 1))
(display id)
(display " = ")
(display e)
(newline)
(loop (acons id e a))))))))))
(loop (acons id e a)))))))))
(lambda (key . args)
(format (current-error-port) "exception: ~a ~a\n" key args)
(if (defined? 'with-output-to-string)
(simple-format (current-error-port) "exception:~a:~a\n" key args)
(begin
(display "exception:" (current-error-port))
(display key (current-error-port))
(display ":" (current-error-port))
(display args (current-error-port))
(newline (current-error-port))))
(loop a))))))

9
src/lib.c
View file

@ -1,6 +1,6 @@
/* -*-comment-start: "//";comment-end:""-*-
* Mes --- Maxwell Equations of Software
* Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
* Copyright © 2016,2017,2018 Jan Nieuwenhuizen <janneke@gnu.org>
*
* This file is part of Mes.
*
@ -130,6 +130,13 @@ display_error_ (SCM x)
return display_helper (x, 0, "", STDERR);
}
SCM
display_port_ (SCM x, SCM p)
{
assert (TYPE (p) == TNUMBER);
return fdisplay_ (x, VALUE (p));
}
SCM
fdisplay_ (SCM x, int fd) ///((internal))
{

6
src/mes.c
View file

@ -1,6 +1,6 @@
/* -*-comment-start: "//";comment-end:""-*-
* Mes --- Maxwell Equations of Software
* Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
* Copyright © 2016,2017,2018 Jan Nieuwenhuizen <janneke@gnu.org>
*
* This file is part of Mes.
*
@ -951,8 +951,8 @@ eval_apply ()
}
case cell_vm_macro_expand:
{
push_cc (CADR (r1), r1, r0, cell_vm_return);
goto macro_expand;
push_cc (CADR (r1), r1, r0, cell_vm_macro_expand);
goto eval;
}
default: {
push_cc (r1, r1, r0, cell_vm_eval_macro);

19
tests/base.test-guile
View file

@ -1,4 +1,23 @@
#! /bin/sh
# Mes --- Maxwell Equations of Software
# Copyright © 2017,2018 Jan 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/>.
test=$(dirname $0)/$(basename $0 -guile)
GUILE=${GUILE-guile}
cat guile/mes-0.scm module/mes/test.mes $test | exec $GUILE -s /dev/stdin

3
tests/optargs.test
View file

@ -9,7 +9,7 @@ exit $?
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2016,2018 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Mes.
;;;
@ -122,7 +122,6 @@ exit $?
;; (make <info> #:functions functions #:globals globals #:locals locals #:text text)))))
(define (clone o . rest)
(format (current-error-port) "clone rest=~a\n" rest)
(cond ((info? o)
(let ((functions (.functions o))
(globals (.globals o))

64
tests/syntax.test Executable file
View file

@ -0,0 +1,64 @@
#! /bin/sh
# -*-scheme-*-
MES=${MES-$(dirname $0)/../scripts/mes}
echo ' ()' | cat $(dirname $0)/../module/mes/base-0.mes $0 /dev/stdin | $MES $MES_FLAGS "$@"
#paredit:||
exit $?
!#
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017,2018 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Mes.
;;;
;;; Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
(mes-use-module (mes syntax))
(mes-use-module (mes test))
(pass-if "first dummy" #t)
(pass-if-not "second dummy" #f)
(pass-if "define-syntax when"
(sequal?
(let ()
(define-syntax sr:when
(syntax-rules ()
((sc:when condition exp ...)
(if condition
(begin exp ...)))))
(let ()
(sr:when #t "if not now, then?")))
"if not now, then?"))
(pass-if "define-syntax-rule"
(sequal?
(let ()
(define-syntax-rule (sre:when c e ...)
(if c (begin e ...)))
(let ()
(sre:when #t "if not now, then?")))
"if not now, then?"))
(pass-if-equal "syntax-rules plus"
(+ 1 2 3)
(let ()
(define-syntax plus
(syntax-rules ()
((plus x ...) (+ x ...))))
(plus 1 2 3)))
(result 'report)

1
tests/syntax.test-guile Symbolic link
View file

@ -0,0 +1 @@
base.test-guile