split-up test suite, implement quasiquote in scheme.
authorJan Nieuwenhuizen <janneke@gnu.org>
Mon, 25 Jul 2016 12:39:56 +0000 (14:39 +0200)
committerJan Nieuwenhuizen <janneke@gnu.org>
Mon, 25 Jul 2016 12:39:56 +0000 (14:39 +0200)
17 files changed:
GNUmakefile
TODO
base.mes [new file with mode: 0644]
base0.mes [new file with mode: 0644]
let.mes [new file with mode: 0644]
lib/srfi/srfi-0.scm
lib/test.mes [new file with mode: 0644]
mes.c
quasiquote.mes [new file with mode: 0644]
scm.mes
test.mes [deleted file]
test/base.test [new file with mode: 0644]
test/closure.test [new file with mode: 0644]
test/foo.test [new file with mode: 0644]
test/let.test [new file with mode: 0644]
test/quasiquote.test [new file with mode: 0644]
test/scm.test [new file with mode: 0644]

index e7e1ca672e96d8afd4912950540bfe95afa385f3..52eae27513a564cb025f0f582b4dd557cb90ffa4 100644 (file)
@@ -31,21 +31,36 @@ mes.h: mes.c GNUmakefile
        done; echo '#endif'; echo '#endif' 1>&2) > $@ 2>environment.i
 
 check: all guile-check
-       ./mes.test
-       ./mes.test ./mes
-       cat scm.mes lib/srfi/srfi-0.scm test.mes | ./mes
+#      ./mes.test
+#      ./mes.test ./mes
+       cat base0.mes base.mes lib/test.mes test/base.test | ./mes
+       cat base0.mes base.mes lib/test.mes test/closure.test | ./mes
+       cat base0.mes base.mes quasiquote.mes lib/test.mes test/quasiquote.test | ./mes
+       cat base0.mes base.mes quasiquote.mes let.mes lib/test.mes test/let.test | ./mes
+       cat base0.mes base.mes quasiquote.mes let.mes lib/srfi/srfi-0.scm scm.mes lib/test.mes test/scm.test | ./mes
 
 guile-check:
-       guile -s test.mes
+       guile -s <(cat base.mes lib/test.mes test/base.test)
+       guile -s <(cat base.mes lib/test.mes test/closure.test)
+       guile -s <(cat base.mes lib/test.mes test/quasiquote.test)
+       guile -s <(cat quasiquote.mes lib/test.mes test/quasiquote.test)
+#      guile -s <(cat base.mes let.mes test/foo.test)
+#      exit 1
+       guile -s <(cat lib/test.mes test/base.test)
+       guile -s <(cat lib/test.mes test/quasiquote.test)
+       guile -s <(cat lib/test.mes test/let.test)
+       guile -s <(cat quasiquote.mes lib/test.mes test/base.test)
+       guile -s <(cat quasiquote.mes lib/test.mes test/quasiquote.test)
+       guile -s <(cat lib/test.mes test/scm.test)
 
 run: all
        cat scm.mes test.mes | ./mes
 
 psyntax: all
-       cat scm.mes psyntax.mes psyntax.pp psyntax2.mes | ./mes
+       cat base0.mes base.mes quasiquote.mes let.mes psyntax.mes psyntax.pp psyntax2.mes | ./mes
 
 syntax: all
-       cat scm.mes syntax.mes syntax-test.mes | ./mes
+       cat base0.mes base.mes quasiquote.mes let.mes scm.mes syntax.mes syntax-test.mes | ./mes
 
 syntax.test: syntax.mes syntax-test.mes
        cat $^ > $@
@@ -63,7 +78,7 @@ guile-syntax-case: syntax-case.test
        guile -s $^
 
 macro: all
-       cat scm.mes macro.mes | ./mes
+       cat base0.mes base.mes quasiquote.mes let.mes scm.mes macro.mes | ./mes
 
 peg: all
        cat scm.mes syntax.mes syntax-case-lib.mes syntax-case.mes syntax-case-after.mes peg.mes peg/codegen.scm peg/string-peg.scm peg/simplify-tree.scm peg/using-parsers.scm peg/cache.scm peg-test.mes | ./mes
@@ -84,7 +99,7 @@ record: all
 
 
 paren: all
-       echo -e 'EOF\n___P((()))' | cat scm.mes syntax.mes lib/srfi/srfi-0.scm lib/record.mes lib/record.scm lib/srfi/srfi-9.scm lib/lalr.mes lib/lalr.scm paren.scm - | ./mes
+       echo -e 'EOF\n___P((()))' | cat base0.mes base.mes quasiquote.mes let.mes scm.mes syntax.mes lib/srfi/srfi-0.scm lib/record.mes lib/record.scm lib/srfi/srfi-9.scm lib/lalr.mes lib/lalr.scm paren.scm - | ./mes
 
 paren.test: lib/lalr.scm paren.scm
        cat $^ > $@
@@ -93,7 +108,7 @@ guile-paren: paren.test
        echo '___P((()))' | guile -s $^ 
 
 mescc: all
-       echo ' EOF ' | cat scm.mes syntax.mes lib/srfi/srfi-0.scm lib/record.mes lib/record.scm lib/srfi/srfi-9.scm lib/lalr.mes lib/lalr.scm c-lexer.scm mescc.scm - main.c | ./mes
+       echo ' EOF ' | cat base0.mes base.mes quasiquote.mes let.mes scm.mes syntax.mes lib/srfi/srfi-0.scm lib/record.mes lib/record.scm lib/srfi/srfi-9.scm lib/lalr.mes lib/lalr.scm c-lexer.scm mescc.scm - main.c | ./mes
 
 mescc.test: lib/lalr.scm c-lexer.scm mescc.scm
        cat $^ > $@
diff --git a/TODO b/TODO
index 0be14df05fc979acdb0583a37a8b67942877ef99..ddf838044db18b05db376af410eaf12126fe395d 100644 (file)
--- a/TODO
+++ b/TODO
@@ -4,6 +4,9 @@
 Using define-macro-based version.
 ** psyntax.pp
 Find out how to hook-up sc-expand in eval/apply.
+** make core smaller
+*** replase mes.c:quasiquote by qq.mes
+*** cleanup environment/closures
 ** bugs
 See bugs/
 ** run PEG
diff --git a/base.mes b/base.mes
new file mode 100644 (file)
index 0000000..1564033
--- /dev/null
+++ b/base.mes
@@ -0,0 +1,79 @@
+;;; -*-scheme-*-
+
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; base.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/>.
+
+(define (not x)
+  (cond (x #f)
+        (#t #t)))
+
+(define guile? (not (pair? (current-module))))
+
+(define-macro (or2 x y)
+  `(cond (,x ,x) (#t ,y)))
+
+(define-macro (and2 x y)
+  `(cond (,x ,y) (#t #f)))
+
+(define-macro (and . x)
+  (cond ((null? x) #t)
+        ((null? (cdr x)) (car x))
+        (#t (list 'cond (list (car x) (cons 'and (cdr x)))
+                  '(#t #f)))))
+
+(define-macro (or . x)
+  (cond
+   ((null? x) #f)
+   ((null? (cdr x)) (car x))
+   (#t (list 'cond (list (car x))
+             (list #t (cons 'or (cdr x)))))))
+
+(define (cons* x . rest)
+  (define (loop rest)
+    (cond ((null? (cdr rest)) (car rest))
+          (#t (cons (car rest) (loop (cdr rest))))))
+  (loop (cons x rest)))
+
+(define (equal? a b) ;; FIXME: only 2 arg
+  (cond ((and (null? a) (null? b)) #t)
+        ((and (pair? a) (pair? b))
+         (and (equal? (car a) (car b))
+              (equal? (cdr a) (cdr b))))
+        ((and (string? a) (string? b))
+         (eq? (string->symbol a) (string->symbol b)))
+        ((and (vector? a) (vector? b))
+         (equal? (vector->list a) (vector->list b)))
+        (#t (eq? a b))))
+
+(define (memq x lst)
+  (cond ((null? lst) #f)
+        ((eq? x (car lst)) lst)
+        (#t (memq x (cdr lst)))))
+
+(define (map f l . r)
+  (cond ((null? l) '())
+        ((null? r) (cons (f (car l)) (map f (cdr l))))
+        ((null? (cdr r))
+         (cons (f (car l) (caar r)) (map f (cdr l) (cdar r))))))
+
+(define-macro (simple-let bindings . rest)
+  (cons (cons 'lambda (cons (map car bindings) rest))
+        (map cadr bindings)))
+
+(define-macro (let bindings . rest)
+  (cons* 'simple-let bindings rest))
diff --git a/base0.mes b/base0.mes
new file mode 100644 (file)
index 0000000..45f7877
--- /dev/null
+++ b/base0.mes
@@ -0,0 +1,22 @@
+;;; -*-scheme-*-
+
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; base0.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/>.
+
+(define-macro (defined? x)
+  `(assq ,x (cddr (current-module))))
diff --git a/let.mes b/let.mes
new file mode 100644 (file)
index 0000000..c42062d
--- /dev/null
+++ b/let.mes
@@ -0,0 +1,100 @@
+;;; -*-scheme-*-
+
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; test.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/>.
+
+(define-macro (simple-let bindings . rest)
+  `(,`(lambda ,(map car bindings) ,@rest)
+    ,@(map cadr bindings)))
+
+(define-macro (named-let label bindings . rest)
+  `(simple-let ((,label *unspecified*))
+     (set! ,label (lambda ,(map car bindings) ,@rest))
+     (,label ,@(map cadr bindings))))
+
+(define-macro (combined-let bindings-or-label . rest)
+  (display
+   `(,`(cond
+        (,(symbol? bindings-or-label)
+         (lambda () ,(cons* 'named-let bindings-or-label `(car ,rest) `(cdr ,rest))))
+        (#t
+         (lambda () ,(cons* 'simple-let bindings-or-label rest))
+         ))))
+  (newline)
+  `(,`(cond
+       (,(symbol? bindings-or-label)
+        (lambda () ,(cons* 'named-let bindings-or-label `(car ,rest) `(cdr ,rest))))
+       (#t
+        (lambda () ,(cons* 'simple-let bindings-or-label rest))
+        ))))
+
+
+
+
+(define (split-params bindings params)
+  (cond ((null? bindings) params)
+        (#t (split-params (cdr bindings)
+                          (append params (cons (caar bindings) '()))))))
+
+(define (split-values bindings values)
+  (cond ((null? bindings) values)
+        (#t (split-values (cdr bindings)
+                          (append values (cdar bindings) '())))))
+
+(define-macro (xsimple-let bindings rest)
+  `((lambda ,(split-params bindings '()) ,@rest)
+    ,@(split-values bindings '())))
+
+(define-macro (xnamed-let label bindings rest)
+  `((lambda (,label)
+      (set! ,label (lambda ,(split-params bindings '()) ,@rest))
+      (,label ,@(split-values bindings '())))
+    *unspecified*))
+
+(define-macro (let bindings-or-label . rest)
+  `(cond (,(symbol? bindings-or-label)
+          (xnamed-let ,bindings-or-label ,(car rest) ,(cdr rest)))
+         (#t (xsimple-let ,bindings-or-label ,rest))))
+
+(define (expand-let* bindings body)
+  (cond ((null? bindings)
+         `((lambda () ,@body)))
+        (#t `((lambda (,(caar bindings))
+                ,(expand-let* (cdr bindings) body))
+              ,@(cdar bindings)))))
+
+(define-macro (let* bindings . body)
+  (expand-let* bindings body))
+
+(define (unspecified-bindings bindings params)
+  (cond ((null? bindings) params)
+        (#t (unspecified-bindings
+             (cdr bindings)
+             (append params (cons (cons (caar bindings) '(*unspecified*)) '()))))))
+
+(define (letrec-setters bindings setters)
+  (cond ((null? bindings) setters)
+        (#t (letrec-setters (cdr bindings)
+                            (append setters
+                                    (cons (cons 'set! (car bindings)) '()))))))
+
+(define-macro (letrec bindings . body)
+  `(let ,(unspecified-bindings bindings '())
+     ,@(letrec-setters bindings '())
+     ,@body))
+
index 8d279a0fd0cba1f3cadea2ae4dc7bc59e050f8a9..9ef411848eb9ee4a78f7e93819f4cdb93aa825e5 100644 (file)
@@ -1,7 +1,10 @@
 (define mes '(0 1))
 
+(define-macro (defined? x)
+  `(assq ,x (cddr (current-module))))
+
 (define (cond-expand-expander clauses)
-  (let loop ((clauses clauses))
+  (named-let loop ((clauses clauses))
     (if (defined? (caar clauses))
         (eval (cons 'begin (cdar clauses)) (current-module))
         (loop (cdr clauses)))))
diff --git a/lib/test.mes b/lib/test.mes
new file mode 100644 (file)
index 0000000..e39cf2d
--- /dev/null
@@ -0,0 +1,71 @@
+;;; -*-scheme-*-
+
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; test.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/>.
+
+(define guile? (not (pair? (current-module))))
+
+(define result
+  (let ((pass 0)
+        (fail 0))
+    (lambda (. t)
+      (cond ((or (null? t) (eq? (car t) result)) (list pass fail))
+            ((eq? (car t) 'report)
+             (newline)
+             (display "passed: ") (display pass) (newline)
+             (display "failed: ") (display fail) (newline)
+             (display "total: ") (display (+ pass fail)) (newline)
+             (exit fail))
+            ((car t) (display ": pass") (newline) (set! pass (+ pass 1)))
+            (#t (display ": fail") (newline) (set! fail (+ fail 1)))))))
+
+(define (seq? a b)
+  (or (eq? a b)
+      (begin
+        (display ": fail")
+        (newline)
+        (display "expected: ")
+        (display b) (newline)
+        (display "actual: ")
+        (display a)
+        (newline)
+        #f)))
+
+(define (sequal? a b)
+  (or (equal? a b)
+      (begin
+        (display ": fail")
+        (newline)
+        (display "expected: ")
+        (display b) (newline)
+        (display "actual: ")
+        (display a)
+        (newline)
+        #f)))
+
+(define-macro (pass-if name t)
+  (list
+   'begin
+   (list display "test: ") (list display name)
+   (list result t)))
+
+(define-macro (pass-if-not name f)
+  (list
+   'begin
+   (list display "test: ") (list display name)
+   (list result (list not f))))
diff --git a/mes.c b/mes.c
index 5d6355101b297a19efd6ecdba5b3be957754c378..2cf75178731981f4595dfe89576c621999228ccf 100644 (file)
--- a/mes.c
+++ b/mes.c
@@ -315,13 +315,6 @@ assq (scm *x, scm *a)
 scm *
 apply_env (scm *fn, scm *x, scm *a)
 {
-#if DEBUG
-  printf ("\napply_env fn=");
-  display (fn);
-  printf (" x=");
-  display (x);
-  puts ("");
-#endif
   scm *macro;
   if (atom_p (fn) != &scm_f)
     {
@@ -362,16 +355,10 @@ apply (scm *f, scm *x)
 scm *
 eval (scm *e, scm *a)
 {
-#if DEBUG
-  printf ("\neval e=");
-  display (e);
-  puts ("");
-#endif
   scm *macro;
   if (e->type == SYMBOL) {
     scm *y = assq (e, a);
     if (y == &scm_f) {
-      //return e;
       fprintf (stderr, "eval: unbound variable: %s\n", e->name);
       assert (!"unbound variable");
     }
@@ -381,8 +368,6 @@ eval (scm *e, scm *a)
     return e;
   else if (atom_p (car (e)) == &scm_t)
     {
-      if ((macro = lookup_macro (car (e), a)) != &scm_f)
-        return eval (apply_env (macro, cdr (e), a), a);
       if (car (e) == &symbol_quote)
         return cadr (e);
       if (car (e) == &symbol_begin)
@@ -399,10 +384,6 @@ eval (scm *e, scm *a)
         return make_closure (cadr (e), cddr (e), assq (&symbol_closure, a));
       if (car (e) == &symbol_closure)
         return e;
-      if (car (e) == &symbol_unquote)
-        return eval (cadr (e), a);
-      if (car (e) == &symbol_quasiquote)
-        return eval_quasiquote (cadr (e), add_unquoters (a));
       if (car (e) == &symbol_cond)
         return evcon (cdr (e), a);
       if (eq_p (car (e), &symbol_define) == &scm_t)
@@ -411,9 +392,12 @@ eval (scm *e, scm *a)
         return define (e, a);
       if (car (e) == &symbol_set_x)
         return set_env_x (cadr (e), eval (caddr (e), a), a);
-      if ((macro = assq (&symbol_sc_expand, a)) != &scm_f)
-        if (cdr (macro) != &scm_f)
-          return eval (apply_env (cdr (macro), e, a), a);
+      if ((macro = lookup_macro (car (e), a)) != &scm_f)
+        return eval (apply_env (macro, cdr (e), a), a);
+      if (car (e) == &symbol_unquote)
+        return eval (cadr (e), a);
+      if (car (e) == &symbol_quasiquote)
+        return eval_quasiquote (cadr (e), add_unquoters (a));
     }
   return apply_env (car (e), evlis (cdr (e), a), a);
 }
@@ -774,15 +758,14 @@ lookup (char *x, scm *a)
 
   if (!strcmp (x, symbol_quasiquote.name)) return &symbol_quasiquote;
   if (!strcmp (x, symbol_quote.name)) return &symbol_quote;
-  if (!strcmp (x, symbol_set_x.name)) return &symbol_set_x;
+
   if (!strcmp (x, symbol_unquote.name)) return &symbol_unquote;
   if (!strcmp (x, symbol_unquote_splicing.name)) return &symbol_unquote_splicing;
-
+  
   if (!strcmp (x, symbol_quasisyntax.name)) return &symbol_quasisyntax;
   if (!strcmp (x, symbol_syntax.name)) return &symbol_syntax;
+
   if (!strcmp (x, symbol_set_x.name)) return &symbol_set_x;
-  if (!strcmp (x, symbol_unsyntax.name)) return &symbol_unsyntax;
-  if (!strcmp (x, symbol_unsyntax_splicing.name)) return &symbol_unsyntax_splicing;
 
   if (*x == '\'') return &symbol_quote;
   if (*x == '`') return &symbol_quasiquote;
@@ -937,18 +920,6 @@ display_helper (scm *x, bool cont, char *sep, bool quote)
       printf ("'");
       return display_helper (car (cdr (x)), cont, "", true);
     }
-    if (car (x) == &scm_quasiquote) {
-      printf ("`");
-      return display_helper (car (cdr (x)), cont, "", true);
-    }
-    if (car (x) == &scm_unquote) {
-      printf (",");
-      return display_helper (car (cdr (x)), cont, "", true);
-    }
-    if (car (x) == &scm_unquote_splicing) {
-      printf (",@");
-      return display_helper (car (cdr (x)), cont, "", true);
-    }
     if (!cont) printf ("(");
     display (car (x));
     if (cdr (x)->type == PAIR)
@@ -1350,7 +1321,7 @@ define (scm *x, scm *a)
   set_cdr_x (cl, aa);
   return entry;
 }
+
 scm *
 lookup_macro (scm *x, scm *a)
 {
diff --git a/quasiquote.mes b/quasiquote.mes
new file mode 100644 (file)
index 0000000..57d2422
--- /dev/null
@@ -0,0 +1,85 @@
+;;; -*-scheme-*-
+
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; quasiquote.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/>.
+
+(define-macro (quasiquote x)
+  (define (check x)
+    (cond ((pair? (cdr x)) (cond ((null? (cddr x)))
+                                 (#t (error (car x) "invalid form ~s" x))))))
+  (define (loop x)
+    ;;(display "LOOP") (newline)
+    (cond
+     ((not (pair? x)) (cons 'quote (cons x '())))
+     ((eq? (car x) 'quasiquote) (check x) (loop (loop (cadr x))))
+     ((eq? (car x) 'unquote) (check x) (cadr x))
+     ((eq? (car x) 'unquote-splicing)
+      (error 'unquote-splicing "invalid context for ~s" x))
+     (;;(and (pair? (car x)) (eq? (caar x) 'unquote-splicing))
+      (cond ((pair? (car x)) (eq? (caar x) 'unquote-splicing))
+            (#t #f))
+      (check (car x))
+      ;; (let ((d (loop (cdr x))))
+      ;;   (cond ((equal? d '(quote ())) (cadar x))
+      ;;         ;;(#t `(append ,(cadar x) ,d))
+      ;;         (#t (list 'append (cadar x) d))
+      ;;         ))
+      ((lambda (d)
+         (list 'append (cadar x) d))
+       (loop (cdr x))))
+     (#t
+      ;; (let ((a (loop (car x)))
+      ;;       (d (loop (cdr x))))
+      ;;   (cond ((pair? d)
+      ;;          (cond ((eq? (car d) 'quote)
+      ;;                 (cond ((and (pair? a) (eq? (car a) 'quote))
+      ;;                        `'(,(cadr a) . ,(cadr d)))
+      ;;                       (#t (cond ((null? (cadr d))
+      ;;                                  `(list ,a))
+      ;;                                 (#t `(cons* ,a ,d))))))
+      ;;                (#t (cond ((memq (car d) '(list cons*))
+      ;;                           `(,(car d) ,a ,@(cdr d)))
+      ;;                          (#t `(cons* ,a ,d))))))
+      ;;         (#t `(cons* ,a ,d))))
+
+      ((lambda (a d)
+         ;;(display "LAMBDA AD") (newline)
+         (cond ((pair? d)
+                (cond ((eq? (car d) 'quote)
+                       (cond (;;(and (pair? a) (eq? (car a) 'quote))
+                              (cond ((pair? a) (eq? (car a) 'quote))
+                                    (#t #f))
+                              (list 'quote (cons (cadr a) (cadr d))))
+                             (#t (cond ((null? (cadr d))
+                                        (list 'list a))
+                                       (#t (list 'cons* a d))))))
+                      (#t (cond ((memq (car d) '(list cons*))
+                                 ;;`(,(car d) ,a ,@(cdr d))
+                                 (cons (car d) (cons a (cdr d)))
+                                 )
+                                ;;(#t `(cons* ,a ,d))
+                                (#t (list 'cons* a d))
+                                ))))
+               ;;(#t `(cons* ,a ,d))
+               (#t (list 'cons* a d))
+               ))
+       (loop (car x))
+       (loop (cdr x)))
+
+      )))
+  (loop x))
diff --git a/scm.mes b/scm.mes
index bfcf1b0825dcb57742b99d468be891524ff7825d..3e22291d8d40418626af7b73030e46ea68160caf 100755 (executable)
--- a/scm.mes
+++ b/scm.mes
 ;;; 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 (list . rest) rest)
 
 (define-macro (if expr then . else)
   `(cond
     (,expr ,then)
     (#t (cond (,(pair? else) ((lambda () ,@else)))))))
 
-(define-macro (when expr . body)
-  `(if ,expr
-       ((lambda () ,@body))))
-
-(define (list . rest) rest)
-
-(define (split-params bindings params)
-  (cond ((null? bindings) params)
-        (#t (split-params (cdr bindings)
-                          (append params (cons (caar bindings) '()))))))
-
-(define (split-values bindings values)
-  (cond ((null? bindings) values)
-        (#t (split-values (cdr bindings)
-                          (append values (cdar bindings) '())))))
-
-(define-macro (simple-let bindings rest)
-  `((lambda ,(split-params bindings '()) ,@rest)
-    ,@(split-values bindings '())))
-
-(define-macro (let-loop label bindings . rest)
-  `(let ((,label *unspecified*))
-     (let ((,label (lambda ,(split-params bindings '()) ,@rest)))
-       (,label ,@(split-values bindings '())))))
-
-(define-macro (let-loop label bindings rest)
-  `((lambda (,label)
-      (set! ,label (lambda ,(split-params bindings '()) ,@rest))
-      (,label ,@(split-values bindings '())))
-    *unspecified*))
-
-(define-macro (let bindings-or-label . rest)
-  `(cond (,(symbol? bindings-or-label)
-          (let-loop ,bindings-or-label ,(car rest) ,(cdr rest)))
-         (#t (simple-let ,bindings-or-label ,rest))))
-
-(define-macro (do init test . body)
-  `(let loop ((,(caar init) ,(cadar init)))
-     (when (not ,@test)
-       ,@body
-       (loop ,@(cddar init)))))
-
 (define-macro (case val . args)
   (if (null? args)
       #f
                            `(member ,val ',pred))
                  (begin ,@body)
                  (case ,val ,@(cdr args)))
-            `(begin ,@body)))))  ; else clause
-
-(define-macro (or2 x y)
-  `(cond (,x ,x) (#t ,y)))
-
-(define-macro (and2 x y)
-  `(cond (,x ,y) (#t #f)))
+            `(begin ,@body)))))
 
-(define-macro (or . x)
-  (cond
-   ((null? x) #f)
-   ((null? (cdr x)) (car x))
-   (#t `(cond (,(car x))
-              (#t (or ,@(cdr x)))))))
+(define-macro (when expr . body)
+  `(if ,expr
+       ((lambda () ,@body))))
 
-(define-macro (and . x)
-  (cond ((null? x) #t)
-        ((null? (cdr x)) (car x))
-        (#t `(cond (,(car x) (and ,@(cdr x)))
-                   (#t #f)))))
+(define-macro (do init test . body)
+  `(let loop ((,(caar init) ,(cadar init)))
+     (when (not ,@test)
+       ,@body
+       (loop ,@(cddar init)))))
 
-(define (expand-let* bindings body)
-  (cond ((null? bindings)
-         `((lambda () ,@body)))
-        (#t `((lambda (,(caar bindings))
-                ,(expand-let* (cdr bindings) body))
-              ,@(cdar bindings)))))
+(define (procedure? p)
+  (cond ((builtin? p) #t)
+        ((and (pair? p) (eq? (car p) 'lambda)))
+        ((and (pair? p) (eq? (car p) '*closure*)))
+        (#t #f)))
 
-(define-macro (let* bindings . body)
-  (expand-let* bindings body))
+(define integer? number?)
 
 (define (equal? a b) ;; FIXME: only 2 arg
   (cond ((and (null? a) (null? b)) #t)
                     (if (= 0 n) '()
                         (cons fill (loop (- n 1))))))))
 
-(define-macro (defined? x)
-  `(assq ,x (cddr (current-module))))
-
-(define (procedure? p)
-  (cond ((builtin? p) #t)
-        ((and (pair? p) (eq? (car p) 'lambda)))
-        ((and (pair? p) (eq? (car p) '*closure*)))
-        (#t #f)))
-
-(define integer? number?)
-
 (define (assq-set! alist key val)
   (let ((entry (assq key alist)))
     (cond (entry (set-cdr! entry val)
   (or (null? x)
       (and (pair? x) (list? (cdr x)))))
 
-(define (unspecified-bindings bindings params)
-  (cond ((null? bindings) params)
-        (#t (unspecified-bindings
-             (cdr bindings)
-             (append params (cons (cons (caar bindings) '(*unspecified*)) '()))))))
-
-(define (letrec-setters bindings setters)
-  (cond ((null? bindings) setters)
-        (#t (letrec-setters (cdr bindings)
-                            (append setters
-                                    (cons (cons 'set! (car bindings)) '()))))))
-
-(define-macro (letrec bindings . body)
-  `(let ,(unspecified-bindings bindings '())
-     ,@(letrec-setters bindings '())
-     ,@body))
-
 (define gensym
   (let ((counter 0))
     (lambda (. rest)
diff --git a/test.mes b/test.mes
deleted file mode 100644 (file)
index 02ff08f..0000000
--- a/test.mes
+++ /dev/null
@@ -1,308 +0,0 @@
-;;; -*-scheme-*-
-
-;;; Mes --- Maxwell Equations of Software
-;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
-;;;
-;;; test.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 result
-  (let ((pass 0)
-        (fail 0))
-    (lambda (. t)
-      (cond ((null? t) (list pass fail))
-            ((car t) (display ": pass") (newline) (set! pass (+ pass 1)))
-            (#t (display ": fail") (newline) (set! fail (+ fail 1)))))))
-
-
-(define guile? (defined? 'gc))
-(when guile?
-  (module-define! (current-module) 'builtin? (lambda (. x) #t))
-  (use-modules (srfi srfi-1)))
-
-(define (seq? a b)
-  (or (eq? a b)
-      (begin
-        (display ": fail")
-        (newline)
-        (display "expected: ")
-        (display b) (newline)
-        (display "actual: ")
-        (display a)
-        (newline)
-        #f)))
-
-(define (sequal? a b)
-  (or (equal? a b)
-      (begin
-        (display ": fail")
-        (newline)
-        (display "expected: ")
-        (display b) (newline)
-        (display "actual: ")
-        (display a)
-        (newline)
-        #f)))
-
-
-(define-macro (pass-if name t)
-  `(let ()
-     (display "test: ") (display ,name)
-     (result ,t)))
-
-(define-macro (pass-if-not name f)
-  `(let ()
-     (display "test: ") (display ,name)
-     (result (not ,f))))
-
-(pass-if "first dummy" #t)
-(pass-if-not "second dummy" #f)
-
-(pass-if "and" (seq? (and 1) 1))
-(pass-if "and 2" (seq? (and 1 (= 0 1) #f) #f))
-(pass-if "or" (seq? (or) #f))
-(pass-if "or 2" (seq? (or 1) 1))
-(pass-if "or 3" (seq? (or #f (= 0 1) 3) 3))
-(pass-if "let" (seq? (let ((p 5) (q 6)) (+ p q)) 11))
-(pass-if "let loop" (sequal? (let loop ((lst '(3 2 1)))
-                              (if (null? lst) '()
-                                  (cons (car lst)
-                                        (loop (cdr lst))))) '(3 2 1)))
-(pass-if "quasiquote" (let ((cc 'bb)) (sequal? `(aa bb ,cc) '(aa bb bb))))
-(pass-if "let* comments" (seq? (let* ((aa 2)
-                                     (bb (+ aa 3))
-                                     #! boo !#
-                                     ;;(bb 4)
-                                     )
-                                bb)
-                              5))
-
-(pass-if "map" (sequal? (map identity '(1 2 3 4)) '(1 2 3 4)))
-(pass-if "map 2 " (sequal? (map (lambda (i a) (cons i a)) '(1 2 3 4) '(a b c d))
-                           '((1 . a) (2 . b) (3 . c) (4 . d))))
-(pass-if "for-each" (sequal? (let ((acc '())) (for-each (lambda (x) (set! acc (cons x acc))) '(1 2 3 4)) acc) '(4 3 2 1)))
-(define xxxa 0)
-(pass-if "set! " (seq? (begin (set! xxxa 1) xxxa) 1))
-(pass-if "set! 2" (seq? (let ((a 0)) (set! a 1) a) 1))
-(pass-if "+" (seq? (+ 1 2 3) 6))
-(pass-if "*" (seq? (* 3 3 3) 27))
-(pass-if "/" (seq? (/ 9 3) 3))
-(pass-if "remainder" (seq? (remainder 11 3) 2))
-(pass-if "modulo" (seq? (modulo 11 3) 2))
-(pass-if "expt" (seq? (expt 2 3) 8))
-(pass-if "logior" (seq? (logior 0 1 2 4) 7))
-
-(pass-if "=" (seq? 3 '3))
-(pass-if "= 2" (not (= 3 '4)))
-(pass-if "if" (seq? (if #t 'true) 'true))
-(pass-if "if 2" (seq? (if (seq? 0 '0) 'true 'false) 'true))
-(pass-if "if 3" (seq? (if (= 1 2) 'true 'false) 'false))
-(pass-if "letrec" (seq? (letrec ((factorial (lambda (n)
-                                           (if (= n 1) 1
-                                               (* n (factorial (- n 1)))))))
-                       (factorial 4))
-                     24))
-(pass-if "begin" (seq? (begin 'a 'b (+ 1 2)) 3))
-(pass-if "string-append" (sequal? (string-append "a" "b" "c") "abc"))
-(pass-if "substring" (sequal? (substring "hello world" 6) "world"))
-(pass-if "substring 2" (sequal? (substring "hello world" 4 7) "o w"))
-(pass-if "string-ref" (seq? (string-ref "hello world" 4) #\o))
-(pass-if "eq?" (not (eq? (string-append "a" "b" "c") "abc")))
-(pass-if "string-length" (seq? (string-length (string-append "a" "b" "c")) 3))
-(pass-if "char" (seq? (char->integer #\A) 65))
-(pass-if "char 2" (seq? (char->integer #\101) (char->integer #\A)))
-(pass-if "char 3" (seq? (integer->char 10) #\newline))
-(pass-if "char 4" (seq? (integer->char 32) #\space))
-(pass-if "string " (sequal? (string #\a #\space #\s #\t #\r #\i #\n #\g) "a string"))
-(pass-if "length" (seq? (length '()) 0))
-(pass-if "length 2" (seq? (length '(a b c)) 3))
-(pass-if "vector?" (vector? #(1 2 c)))
-(pass-if "vector-length" (seq? (vector-length #(1)) 1))
-(pass-if "list->vector" (sequal? (list->vector '(a b c)) #(a b c)))
-(pass-if "vector" (sequal? #(vector 0 1 2) #(vector 0 1 2)))
-(when (not guile?)
-  (pass-if "make-vector" (sequal? (make-vector 3) #(*unspecified* *unspecified* *unspecified*))))
-(pass-if "make-vector 2" (sequal? (make-vector 3 0) #(0 0 0)))
-(pass-if "vector-ref" (seq? (vector-ref #(0 1) 1) 1))
-(when (not guile?) ;; hmm guile segfaults
-  (pass-if "vector-set" (equal? (let ((v #(0 1))) (vector-set! v 1 'q) v) #(0 q)))
-  (pass-if "vector-set 2" (not (equal? (let ((v #(0 1))) (vector-set! v 1 'q) v) #()))))
-(pass-if "equal?" (sequal? #(1) #(1)))
-(pass-if "equal?" (not (equal? #() #(1))))
-(pass-if "memq" (sequal? (memq 'a '(a b c)) '(a b c)))
-(pass-if "memq" (sequal? (memq 'b '(a b c)) '(b c)))
-(pass-if "memq" (seq? (memq 'd '(a b c)) #f))
-(pass-if "member" (sequal? (member '(a) '((a) b c)) '((a) b c)))
-(pass-if "assq-ref" (seq? (assq-ref '((b . 1) (c . 2)) 'c) 2))
-(pass-if "assq-ref 2" (seq? (assq-ref '((b . 1) (c . 2)) 'a) #f))
-(pass-if "assq-set!" (sequal? (assq-set! '((b . 1)) 'a 0) '((a . 0) (b . 1))))
-(pass-if "assq-set! 2" (sequal? (assq-set! '((a . 0)) 'a 1) '((a . 1))))
-(pass-if "assoc" (sequal? (assoc '(a . 0) '((a . 0) (b . 1) ((a . 0) aa))) '((a . 0) aa)))
-
-;; works, but debugging is foo
-;; (cond ((defined? 'loop2)
-;;        (display "mes:values broken after loop2")
-;;        (newline))
-;;       (#t
-;;        (values 0 1)
-;;        (display "(values 0 1): ")
-;;        (display (values 0 1))
-;;        (newline)
-
-;;        (display "call-with-values ==> 6: ")
-;;        (display
-;;         (call-with-values (lambda () (values 1 2 3))
-;;           (lambda (a b c) (+ a b c))))
-;;        (newline)
-;;        (display "call-with-values ==> 1: ")
-;;        (display ((lambda (x) x) (values 1 2 3)))
-;;        (newline)))
-
-(pass-if "builtin?" (builtin? eval))
-;;(pass-if "builtin?" (builtin? cond))
-(pass-if "procedure?" (procedure? builtin?))
-(pass-if "procedure?" (procedure? procedure?))
-(when (not guile?)
-  (pass-if "gensym" (seq? (gensym) 'g0))
-  (pass-if "gensym" (seq? (gensym) 'g1))
-  (pass-if "gensym" (seq? (gensym) 'g2)))
-(pass-if "unquote" (sequal? `,(list 1 2 3 4) '(1 2 3 4)))
-(pass-if "splice" (sequal? `('boo ,@'(bah baz) 1 2) '((quote boo) bah baz 1 2)))
-(pass-if "splice" (sequal? `(1 ,@(list 2 3) 4) '(1 2 3 4)))
-(pass-if "splice" (sequal? (let ((s-r '(2 3))) `(1 ,@s-r 4)) '(1 2 3 4)))
-(pass-if "unquote" (sequal? `(1 2 '(,(+ 1 2))) '(1 2 '(3))))
-(pass-if "when" (seq? (when #t 'true) 'true))
-(pass-if "when 2" (seq? (when #f 'true) *unspecified*))
-
-(define b 0)
-(define x (lambda () b))
-(define (x) b)
-(pass-if "closure" (seq? (x) 0))
-(define (c b)
-  (x))
-(pass-if "closure 2" (seq? (c 1) 0))
-
-(define (x)
-  (define b 1)
-  (define (y) b)
-  (set! b 0)
-  (list b
-        (let ((b 2))
-          (y))))
-
-(pass-if "closure 3" (sequal? (x) '(0 0)))
-
-(pass-if "closure 4 "
-  (seq? (let ()
-          (let ((count (let ((counter 0))
-                         (lambda ()
-                           counter))))
-            (count)))
-        0))
-
-(pass-if "closure 5 "
-         (seq?
-          (let ()
-            (define name? 2)
-            (define (foo)
-              (define name? 0)
-              (lambda () name?))
-            ((foo)))
-          0))
-
-(pass-if "closure 6 "
-         (seq?
-          (let ()
-            (define foo
-              (lambda ()
-                (define name? symbol?)
-                (lambda ()
-                  (name? 'boo))))
-            ((foo)))
-               #t))
-
-(pass-if "last-pair " (sequal? (last-pair '(1 2 3 4)) '(4)))
-(pass-if "last-pair 2" (seq? (last-pair '()) '()))
-;; (pass-if "circular-list? "
-;;   (seq?
-;;    (let ((x (list 1 2 3 4)))
-;;      (set-cdr! (last-pair x) (cddr x))
-;;      (circular-list? x))
-;;    #t))
-
-(pass-if "reverse" (sequal? (reverse '(1 2 3)) '(3 2 1)))
-
-(pass-if "cond-expand" (sequal? (cond-expand (foobar #f) (mes (display ": pass: *YAY*") 'mes) (guile (display ": pass: *GUILE*") 'mes)) 'mes))
-
-(begin (define *top-begin-a* '*top-begin-a*))
-(pass-if "top begin " (seq? (and (defined? '*top-begin-a*) *top-begin-a*) '*top-begin-a*))
-
-(let () (define *top-let-a* '*top-let-a*) #f)
-(pass-if "top let " (seq? (and (defined? '*top-let-a*) *top-let-a*) #f))
-
-(pass-if "apply identity" (seq? (apply identity '(0)) 0))
-(pass-if "apply identity 2" (sequal? (apply identity '((0 1))) '(0 1)))
-(pass-if "apply append" (sequal? (apply append '((1 2) (3 4))) '(1 2 3 4)))
-
-(pass-if "=" (seq? (=) #t))
-(pass-if "= 1" (seq? (= 0) #t))
-(pass-if "= 2" (seq? (= 0 0) #t))
-(pass-if "= 3" (seq? (= 0 0) #t))
-(pass-if "= 4" (seq? (= 0 1 0) #f))
-
-(pass-if "<" (seq? (<) #t))
-(pass-if "< 1" (seq? (< 0) #t))
-(pass-if "< 2" (seq? (< 0 1) #t))
-(pass-if "< 3" (seq? (< 1 0) #f))
-(pass-if "< 4" (seq? (< 0 1 2) #t))
-(pass-if "< 5" (seq? (< 0 2 1) #f))
-
-(pass-if ">" (seq? (>) #t))
-(pass-if "> 1" (seq? (> 0) #t))
-(pass-if "> 2" (seq? (> 1 0) #t))
-(pass-if "> 3" (seq? (> 0 1) #f))
-(pass-if "> 4" (seq? (> 2 1 0) #t))
-(pass-if "> 5" (seq? (> 1 2 0) #f))
-
-(pass-if ">=" (seq? (>= 3 2 1) #t))
-(pass-if ">= 2" (seq? (>= 1 2 3) #f))
-
-(pass-if "<=" (seq? (<= 3 2 1) #f))
-(pass-if "<= 2" (seq? (<= 1 2 3) #t))
-
-(pass-if "max" (seq? (max 0) 0))
-(pass-if "max 1" (seq? (max 0 1) 1))
-(pass-if "max 2" (seq? (max 1 0 2) 2))
-
-(pass-if "min" (seq? (min 0) 0))
-(pass-if "min 1" (seq? (min 0 1) 0))
-(pass-if "min 2" (seq? (min 1 0 2) 0))
-
-(pass-if "list-ref" (seq? (list-ref '(0 1 2) 1) 1))
-
-(pass-if "do" (sequal? (let ((acc '())) (do ((i 0 (+ i 1))) ((>= i 3)) (set! acc (cons i acc))) acc) '(2 1 0)))
-
-(pass-if "char-alphabetic?" (seq? (char-alphabetic? #\a) #t))
-(pass-if "char-alphabetic? 2" (seq? (char-alphabetic? #\[) #f))
-
-(newline)
-(display "passed: ") (display (car (result))) (newline)
-(display "failed: ") (display (cadr (result))) (newline)
-(display "total: ") (display (apply + (result))) (newline)
-
-(exit (cadr (result)))
diff --git a/test/base.test b/test/base.test
new file mode 100644 (file)
index 0000000..c6dabfd
--- /dev/null
@@ -0,0 +1,39 @@
+;;; -*-scheme-*-
+
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; base.test: 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/>.
+
+(pass-if "first dummy" #t)
+(pass-if-not "second dummy" #f)
+
+
+(pass-if "begin" (seq? (begin 'a 'b (+ 1 2)) 3))
+
+(begin (define *top-begin-a* '*top-begin-a*))
+(pass-if "top begin " (seq? *top-begin-a* '*top-begin-a*))
+
+(pass-if "and" (seq? (and 1) 1))
+(pass-if "and 2" (seq? (and 1 (= 0 1) #f) #f))
+(pass-if "or" (seq? (or) #f))
+(pass-if "or 2" (seq? (or 1) 1))
+(pass-if "or 3" (seq? (or #f (= 0 1) 3) 3))
+(pass-if "let" (seq? (let () 0) 0))
+(pass-if "let 2" (seq? (let ((x 0)) x) 0))
+(pass-if "let 3" (seq? (let ((p 5) (q 6)) (+ p q)) 11))
+
+(result 'report)
diff --git a/test/closure.test b/test/closure.test
new file mode 100644 (file)
index 0000000..66411b6
--- /dev/null
@@ -0,0 +1,46 @@
+(define b 0)
+(define x (lambda () b))
+(define (x) b)
+(pass-if "closure" (seq? (x) 0))
+(define (c b)
+  (x))
+(pass-if "closure 2" (seq? (c 1) 0))
+
+(define (x)
+  (define b 1)
+  (define (y) b)
+  (set! b 0)
+  (list b
+        (let ((b 2))
+          (y))))
+
+(pass-if "closure 3" (sequal? (x) '(0 0)))
+
+(pass-if "closure 4 "
+  (seq? (let ()
+          (let ((count (let ((counter 0))
+                         (lambda ()
+                           counter))))
+            (count)))
+        0))
+
+(pass-if "closure 5 "
+         (seq?
+          (let ()
+            (define name? 2)
+            (define (foo)
+              (define name? 0)
+              (lambda () name?))
+            ((foo)))
+          0))
+
+(pass-if "closure 6 "
+         (seq?
+          (let ()
+            (define foo
+              (lambda ()
+                (define name? symbol?)
+                (lambda ()
+                  (name? 'boo))))
+            ((foo)))
+               #t))
diff --git a/test/foo.test b/test/foo.test
new file mode 100644 (file)
index 0000000..d947876
--- /dev/null
@@ -0,0 +1,6 @@
+(display (let () 0))
+(newline)
+(display (let ((x 0)) x))
+(newline)
+(display (let loop ((x 0)) 0))
+(newline)
diff --git a/test/let.test b/test/let.test
new file mode 100644 (file)
index 0000000..ba0edb3
--- /dev/null
@@ -0,0 +1,52 @@
+;;; -*-scheme-*-
+
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; let.test: 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/>.
+
+(pass-if "first dummy" #t)
+(pass-if-not "second dummy" #f)
+
+(let () (define *top-let-a* '*top-let-a*) #f)
+(pass-if "top let " (seq? (and (defined? '*top-let-a*) *top-let-a*) #f))
+
+(pass-if "let loop"
+  (sequal?
+   (let loop ((lst '(3 2 1)))
+     (cond ((null? lst) '())
+           (#t (cons (car lst) (loop (cdr lst))))))
+   '(3 2 1)))
+
+(pass-if "let* comments"
+  (seq? (let* ((aa 2)
+               (bb (+ aa 3))
+               #! boo !#
+               ;;(bb 4)
+               )
+          bb)
+        5))
+
+(pass-if "letrec"
+  (seq?
+   (letrec ((factorial (lambda (n)
+                         (cond ((= n 1) 1)
+                               (#t (* n (factorial (- n 1))))))))
+     (factorial 4))
+   24))
+
+(result 'report)
+
diff --git a/test/quasiquote.test b/test/quasiquote.test
new file mode 100644 (file)
index 0000000..39912ac
--- /dev/null
@@ -0,0 +1,38 @@
+;;; -*-scheme-*-
+
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; quasiquote.test: 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/>.
+
+(pass-if "first dummy" #t)
+(pass-if-not "second dummy" #f)
+
+(pass-if "quasiquote" `#t)
+(pass-if-not "quasiquote 2" `#f)
+(pass-if "quasiquote 3" (seq? `1 1))
+(pass-if "quasiquote 4" (sequal? '`0 '(quasiquote 0)))
+(pass-if "unquote" (let ((x 0)) (sequal? `,x 0)))
+(pass-if "unquote 1" (let ((b 1)) (sequal? `(a ,b c) '(a 1 c))))
+(pass-if "unquote 2" (sequal? `,(list 1 2 3 4) '(1 2 3 4)))
+(pass-if "unquote 3" (sequal? `(1 2 '(,(+ 1 2))) '(1 2 '(3))))
+
+(pass-if "unquote-splicing" (let ((b 1) (c '(2 3))) (sequal? `(a ,b ,@c) '(a 1 2 3))))
+(pass-if "unquote-splicing 2" (sequal? `('boo ,@'(bah baz) 1 2) '((quote boo) bah baz 1 2)))
+(pass-if "unquote-splicing 3" (sequal? `(1 ,@(list 2 3) 4) '(1 2 3 4)))
+(pass-if "unquote-splicing 4" (sequal? (let ((s-r '(2 3))) `(1 ,@s-r 4)) '(1 2 3 4)))
+
+(result 'report)
diff --git a/test/scm.test b/test/scm.test
new file mode 100644 (file)
index 0000000..b44374b
--- /dev/null
@@ -0,0 +1,187 @@
+;;; -*-scheme-*-
+
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; scm.test: 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/>.
+
+(when guile?
+  (module-define! (current-module) 'builtin? (lambda (. x) #t))
+  (use-modules (srfi srfi-1))
+  )
+
+(pass-if "first dummy" #t)
+(pass-if-not "second dummy" #f)
+
+(pass-if "if" (seq? (if #t 'true) 'true))
+(pass-if "if 2" (seq? (if (seq? 0 '0) 'true 'false) 'true))
+(pass-if "if 3" (seq? (if (= 1 2) 'true 'false) 'false))
+
+(pass-if "when" (seq? (when #t 'true) 'true))
+(pass-if "when 2" (seq? (when #f 'true) *unspecified*))
+
+(pass-if "map" (sequal? (map identity '(1 2 3 4)) '(1 2 3 4)))
+(pass-if "map 2 " (sequal? (map (lambda (i a) (cons i a)) '(1 2 3 4) '(a b c d))
+                           '((1 . a) (2 . b) (3 . c) (4 . d))))
+(pass-if "for-each" (sequal? (let ((acc '())) (for-each (lambda (x) (set! acc (cons x acc))) '(1 2 3 4)) acc) '(4 3 2 1)))
+(define xxxa 0)
+(pass-if "set! " (seq? (begin (set! xxxa 1) xxxa) 1))
+(pass-if "set! 2" (seq? (let ((a 0)) (set! a 1) a) 1))
+
+
+(pass-if "list-ref" (seq? (list-ref '(0 1 2) 1) 1))
+
+(pass-if "do" (sequal? (let ((acc '())) (do ((i 0 (+ i 1))) ((>= i 3)) (set! acc (cons i acc))) acc) '(2 1 0)))
+
+
+
+
+
+
+(pass-if "+" (seq? (+ 1 2 3) 6))
+(pass-if "*" (seq? (* 3 3 3) 27))
+(pass-if "/" (seq? (/ 9 3) 3))
+(pass-if "remainder" (seq? (remainder 11 3) 2))
+(pass-if "modulo" (seq? (modulo 11 3) 2))
+(pass-if "expt" (seq? (expt 2 3) 8))
+(pass-if "logior" (seq? (logior 0 1 2 4) 7))
+
+(pass-if "=" (seq? 3 '3))
+(pass-if "= 2" (not (= 3 '4)))
+
+(pass-if "string-append" (sequal? (string-append "a" "b" "c") "abc"))
+(pass-if "substring" (sequal? (substring "hello world" 6) "world"))
+(pass-if "substring 2" (sequal? (substring "hello world" 4 7) "o w"))
+(pass-if "string-ref" (seq? (string-ref "hello world" 4) #\o))
+(pass-if "eq?" (not (eq? (string-append "a" "b" "c") "abc")))
+(pass-if "string-length" (seq? (string-length (string-append "a" "b" "c")) 3))
+(pass-if "char" (seq? (char->integer #\A) 65))
+(pass-if "char 2" (seq? (char->integer #\101) (char->integer #\A)))
+(pass-if "char 3" (seq? (integer->char 10) #\newline))
+(pass-if "char 4" (seq? (integer->char 32) #\space))
+(pass-if "string " (sequal? (string #\a #\space #\s #\t #\r #\i #\n #\g) "a string"))
+(pass-if "length" (seq? (length '()) 0))
+(pass-if "length 2" (seq? (length '(a b c)) 3))
+(pass-if "vector?" (vector? #(1 2 c)))
+(pass-if "vector-length" (seq? (vector-length #(1)) 1))
+(pass-if "list->vector" (sequal? (list->vector '(a b c)) #(a b c)))
+(pass-if "vector" (sequal? #(vector 0 1 2) #(vector 0 1 2)))
+(when (not guile?)
+  (pass-if "make-vector" (sequal? (make-vector 3) #(*unspecified* *unspecified* *unspecified*))))
+(pass-if "make-vector 2" (sequal? (make-vector 3 0) #(0 0 0)))
+(pass-if "vector-ref" (seq? (vector-ref #(0 1) 1) 1))
+(pass-if "vector-set" (equal? (let ((v #(0 1))) (vector-set! v 1 'q) v) #(0 q)))
+(pass-if "vector-set 2" (not (equal? (let ((v #(0 1))) (vector-set! v 1 'q) v) #())))
+(pass-if "equal?" (sequal? #(1) #(1)))
+(pass-if "equal?" (not (equal? #() #(1))))
+(pass-if "memq" (sequal? (memq 'a '(a b c)) '(a b c)))
+(pass-if "memq" (sequal? (memq 'b '(a b c)) '(b c)))
+(pass-if "memq" (seq? (memq 'd '(a b c)) #f))
+(pass-if "member" (sequal? (member '(a) '((a) b c)) '((a) b c)))
+(pass-if "assq-ref" (seq? (assq-ref '((b . 1) (c . 2)) 'c) 2))
+(pass-if "assq-ref 2" (seq? (assq-ref '((b . 1) (c . 2)) 'a) #f))
+(pass-if "assq-set!" (sequal? (assq-set! '((b . 1)) 'a 0) '((a . 0) (b . 1))))
+(pass-if "assq-set! 2" (sequal? (assq-set! '((a . 0)) 'a 1) '((a . 1))))
+(pass-if "assoc" (sequal? (assoc '(a . 0) '((a . 0) (b . 1) ((a . 0) aa))) '((a . 0) aa)))
+
+;; works, but debugging is foo
+;; (cond ((defined? 'loop2)
+;;        (display "mes:values broken after loop2")
+;;        (newline))
+;;       (#t
+;;        (values 0 1)
+;;        (display "(values 0 1): ")
+;;        (display (values 0 1))
+;;        (newline)
+
+;;        (display "call-with-values ==> 6: ")
+;;        (display
+;;         (call-with-values (lambda () (values 1 2 3))
+;;           (lambda (a b c) (+ a b c))))
+;;        (newline)
+;;        (display "call-with-values ==> 1: ")
+;;        (display ((lambda (x) x) (values 1 2 3)))
+;;        (newline)))
+
+(pass-if "builtin?" (builtin? eval))
+;;(pass-if "builtin?" (builtin? cond))
+(pass-if "procedure?" (procedure? builtin?))
+(pass-if "procedure?" (procedure? procedure?))
+(when (not guile?)
+  (pass-if "gensym" (seq? (gensym) 'g0))
+  (pass-if "gensym" (seq? (gensym) 'g1))
+  (pass-if "gensym" (seq? (gensym) 'g2)))
+
+(pass-if "last-pair " (sequal? (last-pair '(1 2 3 4)) '(4)))
+(pass-if "last-pair 2" (seq? (last-pair '()) '()))
+;; (pass-if "circular-list? "
+;;   (seq?
+;;    (let ((x (list 1 2 3 4)))
+;;      (set-cdr! (last-pair x) (cddr x))
+;;      (circular-list? x))
+;;    #t))
+
+(pass-if "reverse" (sequal? (reverse '(1 2 3)) '(3 2 1)))
+
+(pass-if "cond-expand" (sequal? (cond-expand (foobar #f) (mes (display ": pass: *YAY*") 'mes) (guile (display ": pass: *GUILE*") 'mes)) 'mes))
+
+(pass-if "apply identity" (seq? (apply identity '(0)) 0))
+(pass-if "apply identity 2" (sequal? (apply identity '((0 1))) '(0 1)))
+(pass-if "apply append" (sequal? (apply append '((1 2) (3 4))) '(1 2 3 4)))
+
+(pass-if "=" (seq? (=) #t))
+(pass-if "= 1" (seq? (= 0) #t))
+(pass-if "= 2" (seq? (= 0 0) #t))
+(pass-if "= 3" (seq? (= 0 0) #t))
+(pass-if "= 4" (seq? (= 0 1 0) #f))
+
+(pass-if "<" (seq? (<) #t))
+(pass-if "< 1" (seq? (< 0) #t))
+(pass-if "< 2" (seq? (< 0 1) #t))
+(pass-if "< 3" (seq? (< 1 0) #f))
+(pass-if "< 4" (seq? (< 0 1 2) #t))
+(pass-if "< 5" (seq? (< 0 2 1) #f))
+
+(pass-if ">" (seq? (>) #t))
+(pass-if "> 1" (seq? (> 0) #t))
+(pass-if "> 2" (seq? (> 1 0) #t))
+(pass-if "> 3" (seq? (> 0 1) #f))
+(pass-if "> 4" (seq? (> 2 1 0) #t))
+(pass-if "> 5" (seq? (> 1 2 0) #f))
+
+(pass-if ">=" (seq? (>= 3 2 1) #t))
+(pass-if ">= 2" (seq? (>= 1 2 3) #f))
+
+(pass-if "<=" (seq? (<= 3 2 1) #f))
+(pass-if "<= 2" (seq? (<= 1 2 3) #t))
+
+(pass-if "max" (seq? (max 0) 0))
+(pass-if "max 1" (seq? (max 0 1) 1))
+(pass-if "max 2" (seq? (max 1 0 2) 2))
+
+(pass-if "min" (seq? (min 0) 0))
+(pass-if "min 1" (seq? (min 0 1) 0))
+(pass-if "min 2" (seq? (min 1 0 2) 0))
+
+(pass-if "char-alphabetic?" (seq? (char-alphabetic? #\a) #t))
+(pass-if "char-alphabetic? 2" (seq? (char-alphabetic? #\[) #f))
+
+(newline)
+(display "passed: ") (display (car (result))) (newline)
+(display "failed: ") (display (cadr (result))) (newline)
+(display "total: ") (display (apply + (result))) (newline)
+
+(exit (cadr (result)))