mes/tests/base.test

#! /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)