test: Add syntax tests.

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

fixup: 1b0696f9 (Jan Nieuwenhuizen 2018-01-01 15:53:13 +0100 40) ,        (lambda ()

check.sh

@@ -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="

make.scm

@@ -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"
+    "tests/psyntax.test"
-    ;;sloooowwww
+    "tests/match.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"

module/mes/base-0.mes

@@ -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)
+(include-from-path "mes/module.mes")
-  (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)))))))
 
 (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))
+

module/mes/catch.mes

@@ -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)

module/mes/guile.mes

@@ -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)

module/mes/let.mes

@@ -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
+  (if (symbol? bindings-or-name)
-       (xnamed-let ,bindings-or-name ,(car rest) ,(cdr rest))
+      `(xnamed-let ,bindings-or-name ,(car rest) ,(cdr rest))
-       (xsimple-let ,bindings-or-name ,rest)))
+      `(xsimple-let ,bindings-or-name ,rest)))
 
 (define (expand-let* bindings body)
   (if (null? bindings)

module/mes/module.mes

@@ -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)))))))

module/mes/read-0.mes

@@ -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))
 

module/mes/repl.mes

@@ -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))
+          (core:macro-expand sexp))))
-          (newline))))
 
-    (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")))
+              (if (and (pair? sexp) (eq? (car sexp) 'mes-use-module))
-                     (let ((r (meta (cadr sexp) a)))
+                  (loop (mes-load-module-env (cadr sexp) a))
-                       (if (pair? r) (loop (append r a))
+                  (let ((e (if (and (pair? sexp) (eq? (car sexp) (string->symbol "unquote")))
-                           (loop a))))
+                               (meta (cadr sexp) a)
-                    ((and (pair? sexp) (eq? (car sexp) 'mes-use-module))
+                               (eval sexp a))))
-                     (loop (mes-load-module-env (cadr sexp) a)))
+                    (if (eq? e *unspecified*) (loop a)
-                    (else
-                     (let ((e (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))))))

src/lib.c

@@ -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))
 {

src/mes.c

@@ -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);
+              push_cc (CADR (r1), r1, r0, cell_vm_macro_expand);
-              goto macro_expand;
+              goto eval;
             }
           default: {
             push_cc (r1, r1, r0, cell_vm_eval_macro);

tests/base.test-guile

@@ -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

tests/optargs.test

@@ -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))

tests/syntax.test

@@ -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)

tests/syntax.test-guile

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