151 lines
4.2 KiB
Scheme
Executable File
151 lines
4.2 KiB
Scheme
Executable File
#! /bin/sh
|
|
# -*-scheme-*-
|
|
if [ "$MES" != guile ]; then
|
|
MES_BOOT=boot-03.scm exec ${MES-bin/mes} < $0
|
|
fi
|
|
exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests boot)' -s "$0" "$@"
|
|
!#
|
|
|
|
;;; -*-scheme-*-
|
|
|
|
;;; GNU Mes --- Maxwell Equations of Software
|
|
;;; Copyright © 2016,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
|
;;;
|
|
;;; This file is part of GNU Mes.
|
|
;;;
|
|
;;; GNU 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.
|
|
;;;
|
|
;;; GNU 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 GNU Mes. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
(define-module (tests base)
|
|
#:use-module (mes mes-0)
|
|
#:use-module (mes test))
|
|
|
|
(cond-expand
|
|
(mes
|
|
(primitive-load "module/mes/test.scm"))
|
|
(guile-2)
|
|
(guile
|
|
(use-modules (ice-9 syncase))))
|
|
|
|
(pass-if "first dummy" #t)
|
|
(pass-if-not "second dummy" #f)
|
|
|
|
(pass-if "lambda" (symbol? 'lambda))
|
|
|
|
(pass-if-equal "append" '(0 1) (append2 '(0) '(1)))
|
|
(pass-if-equal "append 2" '(0) (append2 '(0) '()))
|
|
(pass-if-equal "append 3" '(0 1 2) (append '(0) '(1) '(2)))
|
|
|
|
(pass-if-equal "cond #f" #t (cond (#f #f) (#t #t)))
|
|
(pass-if "cond #t" (cond (#t)))
|
|
(pass-if "cond #f" (cond (#f #f) (#t #t)))
|
|
(pass-if-equal "cond 2" *unspecified* (cond (#f)))
|
|
(pass-if-equal "cond 3" 0 (cond (#t 0)))
|
|
(pass-if-equal "cond 3a" 0 (cond (#f 1) (#t 0)))
|
|
(pass-if-equal "cond side effect"
|
|
1
|
|
((lambda (i)
|
|
(cond ((set! i (+ i 1)) i)))
|
|
0))
|
|
(pass-if-equal "cond => "
|
|
0 ((lambda (lst)
|
|
(define (next)
|
|
((lambda (r)
|
|
(set! lst (cdr lst))
|
|
r)
|
|
(car lst)))
|
|
(cond ((next) => identity)))
|
|
'(0 1 2)))
|
|
|
|
(pass-if-equal "and" 1 (and 1))
|
|
(pass-if-not "and 2" (and 1 (= 0 1) #f))
|
|
(pass-if-not "or" (or))
|
|
(pass-if-equal "or 2" 1 (or 1))
|
|
(pass-if-equal "or 3" 3 (or #f (= 0 1) 3))
|
|
(pass-if "or 4" (or (= 0 0) (= 0 1)))
|
|
(pass-if "or 5" (or (= 0 1) (= 0 0)))
|
|
(pass-if-equal "or only once"
|
|
1
|
|
((lambda ()
|
|
(define read
|
|
((lambda (lst)
|
|
(lambda ()
|
|
((lambda (r)
|
|
(set! lst (cdr lst))
|
|
r)
|
|
(car lst))))
|
|
'(1 0)))
|
|
(or (read) #t))))
|
|
|
|
(pass-if-eq "let" 0 (let () 0))
|
|
(pass-if-eq "let 2" 0 (let ((x 0)) x))
|
|
(pass-if-eq "let 3" 11 (let ((p 5) (q 6)) (+ p q)))
|
|
|
|
(let () (define *top-let-define-a* '*top-let-define-a*) #t)
|
|
(pass-if-not "top let define " (defined? '*top-let-define-a*))
|
|
|
|
(pass-if "apply" (sequal? (apply list '(1)) '(1)))
|
|
(pass-if "apply 2" (sequal? (apply list 1 '(2)) '(1 2)))
|
|
(pass-if "apply 3" (sequal? (apply list 1 2 '(3)) '(1 2 3)))
|
|
(begin
|
|
(define local-answer 41))
|
|
(pass-if-equal "begin 2" 41 (begin local-answer))
|
|
|
|
(pass-if-equal "primitive-load" 42 (primitive-load "tests/data/load.scm") the-answer)
|
|
|
|
(cond-expand
|
|
(mes
|
|
(pass-if-equal "include" 42 (include "tests/data/load.scm") the-answer))
|
|
(else))
|
|
|
|
(pass-if-eq "call/cc"
|
|
0
|
|
((lambda (cont seen?)
|
|
(+ 1 (call/cc (lambda (c) (set! cont c) 1)))
|
|
(if seen? 0
|
|
(begin (set! seen? #t)
|
|
(cont 2))))
|
|
#f #f))
|
|
|
|
(cond-expand
|
|
(mes
|
|
(pass-if-not "#<eof>"
|
|
(char? (integer->char -1))))
|
|
(else))
|
|
|
|
(pass-if-eq "reader: \\n"
|
|
#\newline
|
|
(car (string->list "\n")))
|
|
|
|
(pass-if-eq "reader: \\a"
|
|
#\alarm
|
|
(car (string->list "\a")))
|
|
|
|
(pass-if-eq "reader: \\x08"
|
|
#\backspace
|
|
(car (string->list "\x08")))
|
|
|
|
(pass-if-equal "setenv, getenv"
|
|
"bar"
|
|
(begin
|
|
(setenv "foo" "bar")
|
|
(getenv "bar")
|
|
(getenv "foo")))
|
|
|
|
(display (gc-stats))
|
|
(newline)
|
|
(gc)
|
|
(display (gc-stats))
|
|
(newline)
|
|
(result 'report)
|