split-up test suite, implement quasiquote in scheme.
This commit is contained in:
Jan Nieuwenhuizen
parent
384a88dd53
commit
3864d434fc
33
GNUmakefile
33
GNUmakefile
|
|
@ -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 $^ > $@
|
||||
|
|
|
|||
3
TODO
3
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
|
||||
|
|
|
|||
79
base.mes
Normal file
79
base.mes
Normal file
|
|
@ -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))
|
||||
22
base0.mes
Normal file
22
base0.mes
Normal file
|
|
@ -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))))
|
||||
100
let.mes
Normal file
100
let.mes
Normal file
|
|
@ -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))
|
||||
|
||||
|
|
@ -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)))))
|
||||
|
|
|
|||
71
lib/test.mes
Normal file
71
lib/test.mes
Normal file
|
|
@ -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))))
|
||||
45
mes.c
45
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)
|
||||
|
|
|
|||
85
quasiquote.mes
Normal file
85
quasiquote.mes
Normal file
|
|
@ -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))
|
||||
114
scm.mes
114
scm.mes
|
|
@ -18,56 +18,13 @@
|
|||
;;; 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
|
||||
|
|
@ -80,36 +37,25 @@
|
|||
`(member ,val ',pred))
|
||||
(begin ,@body)
|
||||
(case ,val ,@(cdr args)))
|
||||
`(begin ,@body))))) ; else clause
|
||||
`(begin ,@body)))))
|
||||
|
||||
(define-macro (or2 x y)
|
||||
`(cond (,x ,x) (#t ,y)))
|
||||
(define-macro (when expr . body)
|
||||
`(if ,expr
|
||||
((lambda () ,@body))))
|
||||
|
||||
(define-macro (and2 x y)
|
||||
`(cond (,x ,y) (#t #f)))
|
||||
(define-macro (do init test . body)
|
||||
`(let loop ((,(caar init) ,(cadar init)))
|
||||
(when (not ,@test)
|
||||
,@body
|
||||
(loop ,@(cddar init)))))
|
||||
|
||||
(define-macro (or . x)
|
||||
(cond
|
||||
((null? x) #f)
|
||||
((null? (cdr x)) (car x))
|
||||
(#t `(cond (,(car x))
|
||||
(#t (or ,@(cdr x)))))))
|
||||
(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 (and . x)
|
||||
(cond ((null? x) #t)
|
||||
((null? (cdr x)) (car x))
|
||||
(#t `(cond (,(car x) (and ,@(cdr x)))
|
||||
(#t #f)))))
|
||||
|
||||
(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 integer? number?)
|
||||
|
||||
(define (equal? a b) ;; FIXME: only 2 arg
|
||||
(cond ((and (null? a) (null? b)) #t)
|
||||
|
|
@ -129,17 +75,6 @@
|
|||
(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)
|
||||
|
|
@ -226,23 +161,6 @@
|
|||
(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)
|
||||
|
|
|
|||
39
test/base.test
Normal file
39
test/base.test
Normal file
|
|
@ -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)
|
||||
46
test/closure.test
Normal file
46
test/closure.test
Normal file
|
|
@ -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))
|
||||
6
test/foo.test
Normal file
6
test/foo.test
Normal file
|
|
@ -0,0 +1,6 @@
|
|||
(display (let () 0))
|
||||
(newline)
|
||||
(display (let ((x 0)) x))
|
||||
(newline)
|
||||
(display (let loop ((x 0)) 0))
|
||||
(newline)
|
||||
52
test/let.test
Normal file
52
test/let.test
Normal file
|
|
@ -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)
|
||||
|
||||
38
test/quasiquote.test
Normal file
38
test/quasiquote.test
Normal file
|
|
@ -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)
|
||||
|
|
@ -3,7 +3,7 @@
|
|||
;;; Mes --- Maxwell Equations of Software
|
||||
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
|
||||
;;;
|
||||
;;; test.mes: This file is part of Mes.
|
||||
;;; 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
|
||||
|
|
@ -18,79 +18,20 @@
|
|||
;;; 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))))
|
||||
(use-modules (srfi srfi-1))
|
||||
)
|
||||
|
||||
(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 "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))
|
||||
|
|
@ -99,6 +40,17 @@
|
|||
(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))
|
||||
|
|
@ -109,15 +61,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"))
|
||||
|
|
@ -139,9 +83,8 @@
|
|||
(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 "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)))
|
||||
|
|
@ -181,60 +124,6 @@
|
|||
(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 '()) '()))
|
||||
|
|
@ -249,12 +138,6 @@
|
|||
|
||||
(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)))
|
||||
|
|
@ -293,10 +176,6 @@
|
|||
(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))
|
||||
|
||||
Loading…
Reference in a new issue