DRAFT test: Resurrect tests with module support.
* mes/module/mes/misc.mes: Remove. * tests/guile.test: Do not use it. * tests/module.test: New file. * build-aux/check-mes.sh (TESTS): Add it. * mes/module/srfi/srfi-26.mes: Remove. * mes/module/ice-9/rdelim.mes: New file. * module/mes/mes-0.mes: New file. WIP: tests
This commit is contained in:
parent
8c6837c795
commit
48f7eb7980
|
@ -38,16 +38,18 @@ tests/display.test
|
||||||
tests/cwv.test
|
tests/cwv.test
|
||||||
tests/math.test
|
tests/math.test
|
||||||
tests/vector.test
|
tests/vector.test
|
||||||
|
tests/fluids.test
|
||||||
|
tests/guile.test
|
||||||
|
tests/module.test
|
||||||
|
tests/boot-6.test
|
||||||
tests/srfi-1.test
|
tests/srfi-1.test
|
||||||
tests/srfi-9.test
|
tests/srfi-9.test
|
||||||
tests/srfi-13.test
|
tests/srfi-13.test
|
||||||
tests/srfi-14.test
|
tests/srfi-14.test
|
||||||
tests/srfi-43.test
|
tests/srfi-43.test
|
||||||
tests/optargs.test
|
tests/optargs.test
|
||||||
tests/fluids.test
|
|
||||||
tests/catch.test
|
tests/catch.test
|
||||||
tests/getopt-long.test
|
tests/getopt-long.test
|
||||||
tests/guile.test
|
|
||||||
tests/syntax.test
|
tests/syntax.test
|
||||||
tests/let-syntax.test
|
tests/let-syntax.test
|
||||||
tests/pmatch.test
|
tests/pmatch.test
|
||||||
|
|
|
@ -0,0 +1 @@
|
||||||
|
(define-module (ice-9 rdelim))
|
|
@ -132,7 +132,7 @@
|
||||||
|
|
||||||
(define (set-current-module m)
|
(define (set-current-module m)
|
||||||
(when (> %debug 2)
|
(when (> %debug 2)
|
||||||
(format (current-error-port) "set-current-module: name=~a" (module-name m)))
|
(format (current-error-port) "set-current-module: name=~a\n" (module-name m)))
|
||||||
(let ((o (guile:current-module)))
|
(let ((o (guile:current-module)))
|
||||||
(guile:current-module m)
|
(guile:current-module m)
|
||||||
(set! *current-module* m)
|
(set! *current-module* m)
|
||||||
|
@ -487,14 +487,14 @@
|
||||||
(set-port-revealed! port (+ (port-revealed port) 1))
|
(set-port-revealed! port (+ (port-revealed port) 1))
|
||||||
(fileno port))
|
(fileno port))
|
||||||
|
|
||||||
(define (setenv name value)
|
;; (define (setenv name value)
|
||||||
(if value
|
;; (if value
|
||||||
(putenv (string-append name "=" value))
|
;; (putenv (string-append name "=" value))
|
||||||
(putenv name)))
|
;; (putenv name)))
|
||||||
|
|
||||||
(define (unsetenv name)
|
;; (define (unsetenv name)
|
||||||
"Remove the entry for NAME from the environment."
|
;; "Remove the entry for NAME from the environment."
|
||||||
(putenv name))
|
;; (putenv name))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
@ -1784,7 +1784,7 @@
|
||||||
((%search-load-path file)
|
((%search-load-path file)
|
||||||
=> (lambda (full)
|
=> (lambda (full)
|
||||||
(with-fluids ((current-reader #f))
|
(with-fluids ((current-reader #f))
|
||||||
(load-file 'primitive-load full)))))))
|
(load-file 'primitive-load full)))))))
|
||||||
(lambda () (set-autoloaded! dir-hint name didit)))
|
(lambda () (set-autoloaded! dir-hint name didit)))
|
||||||
didit))))
|
didit))))
|
||||||
|
|
||||||
|
@ -2309,7 +2309,7 @@
|
||||||
`(let ((m (process-define-module
|
`(let ((m (process-define-module
|
||||||
(list ,@(compile-define-module-args args)))))
|
(list ,@(compile-define-module-args args)))))
|
||||||
(when (> %debug 3)
|
(when (> %debug 3)
|
||||||
(format (current-error-port) "define-module: name=~s" m))
|
(format (current-error-port) "define-module: name=~s\n" m))
|
||||||
(set-current-module m)
|
(set-current-module m)
|
||||||
;; XXX For Mes -- how/where does Guile define this 'module-procedure?
|
;; XXX For Mes -- how/where does Guile define this 'module-procedure?
|
||||||
,(let ((module (and (pair? args) (car args))))
|
,(let ((module (and (pair? args) (car args))))
|
||||||
|
|
|
@ -47,6 +47,7 @@
|
||||||
core:write-port
|
core:write-port
|
||||||
core:type
|
core:type
|
||||||
%compiler
|
%compiler
|
||||||
|
%program
|
||||||
equal2?
|
equal2?
|
||||||
keyword->string
|
keyword->string
|
||||||
pmatch-car
|
pmatch-car
|
||||||
|
@ -93,8 +94,7 @@
|
||||||
(define <cell:vector> 15)
|
(define <cell:vector> 15)
|
||||||
(define %arch (car (string-split %host-type #\-)))
|
(define %arch (car (string-split %host-type #\-)))
|
||||||
(define %compiler "gnuc")
|
(define %compiler "gnuc")
|
||||||
|
(define %program "the program text")
|
||||||
(define %compiler "gnuc")
|
|
||||||
(define keyword->string (compose symbol->string keyword->symbol))
|
(define keyword->string (compose symbol->string keyword->symbol))
|
||||||
|
|
||||||
(define (core:type x)
|
(define (core:type x)
|
||||||
|
|
|
@ -0,0 +1,39 @@
|
||||||
|
;;; -*-scheme-*-
|
||||||
|
|
||||||
|
;;; GNU Mes --- Maxwell Equations of Software
|
||||||
|
;;; Copyright © 2016,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
||||||
|
;;;
|
||||||
|
;;; mes-0.scm: 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/>.
|
||||||
|
|
||||||
|
;;; Commentary:
|
||||||
|
|
||||||
|
;;; mes-0.scm is the first file being loaded into Guile. It provides
|
||||||
|
;;; non-standard definitions that Mes modules and tests depend on.
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
(define-module (mes mes-0)
|
||||||
|
#:export (
|
||||||
|
mes?
|
||||||
|
guile?
|
||||||
|
guile-1.8?
|
||||||
|
guile-2?
|
||||||
|
))
|
||||||
|
|
||||||
|
(define mes? #t)
|
||||||
|
(define guile? #f)
|
||||||
|
(define guile-1.8? #f)
|
||||||
|
(define guile-2? #f)
|
|
@ -29,7 +29,6 @@
|
||||||
#:export (
|
#:export (
|
||||||
builtin?
|
builtin?
|
||||||
mes-use-module
|
mes-use-module
|
||||||
EOF
|
|
||||||
append2
|
append2
|
||||||
mes?
|
mes?
|
||||||
guile?
|
guile?
|
||||||
|
@ -37,7 +36,11 @@
|
||||||
guile-2?
|
guile-2?
|
||||||
%arch
|
%arch
|
||||||
%compiler
|
%compiler
|
||||||
|
%program
|
||||||
|
pmatch-car
|
||||||
|
pmatch-cdr
|
||||||
))
|
))
|
||||||
|
|
||||||
(cond-expand
|
(cond-expand
|
||||||
(guile-2)
|
(guile-2)
|
||||||
(guile
|
(guile
|
||||||
|
@ -50,7 +53,9 @@
|
||||||
(define guile? #t)
|
(define guile? #t)
|
||||||
(define guile-1.8? (equal? (effective-version) "1.8"))
|
(define guile-1.8? (equal? (effective-version) "1.8"))
|
||||||
(define guile-2? (equal? (major-version) "2"))
|
(define guile-2? (equal? (major-version) "2"))
|
||||||
(define EOF (if #f #f))
|
|
||||||
(define append2 append)
|
(define append2 append)
|
||||||
(define %arch (car (string-split %host-type #\-)))
|
(define %arch (car (string-split %host-type #\-)))
|
||||||
(define %compiler "gnuc")
|
(define %compiler "gnuc")
|
||||||
|
(define %program "the program text")
|
||||||
|
(define pmatch-car car)
|
||||||
|
(define pmatch-cdr cdr)
|
||||||
|
|
|
@ -17,54 +17,56 @@
|
||||||
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
|
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
(define-module (mes misc)
|
(define-module (mes misc)
|
||||||
#:use-module (srfi srfi-1)
|
;;#:use-module (srfi srfi-1)
|
||||||
#:export (%scheme
|
#:export (
|
||||||
disjoin
|
;; %scheme
|
||||||
guile?
|
;; disjoin
|
||||||
mes?
|
;; guile?
|
||||||
pk
|
;; mes?
|
||||||
pke
|
;; pk
|
||||||
warn
|
;; pke
|
||||||
stderr
|
;; warn
|
||||||
string-substitute))
|
;; stderr
|
||||||
|
string-substitute
|
||||||
|
))
|
||||||
|
|
||||||
(cond-expand
|
;; (cond-expand
|
||||||
(mes
|
;; (mes
|
||||||
(define %scheme "mes"))
|
;; (define %scheme "mes"))
|
||||||
(guile
|
;; (guile
|
||||||
(define %scheme "guile")))
|
;; (define %scheme "guile")))
|
||||||
|
|
||||||
(define guile? (equal? %scheme "guile"))
|
;; (define guile? (equal? %scheme "guile"))
|
||||||
(define mes? (equal? %scheme "mes"))
|
;; (define mes? (equal? %scheme "mes"))
|
||||||
|
|
||||||
(define (logf port string . rest)
|
;; (define (logf port string . rest)
|
||||||
(apply format (cons* port string rest))
|
;; (apply format (cons* port string rest))
|
||||||
(force-output port)
|
;; (force-output port)
|
||||||
#t)
|
;; #t)
|
||||||
|
|
||||||
(define (stderr string . rest)
|
;; (define (stderr string . rest)
|
||||||
(apply logf (cons* (current-error-port) string rest)))
|
;; (apply logf (cons* (current-error-port) string rest)))
|
||||||
|
|
||||||
(define (pk . stuff)
|
;; (define (pk . stuff)
|
||||||
(newline)
|
;; (newline)
|
||||||
(display ";;; ")
|
;; (display ";;; ")
|
||||||
(write stuff)
|
;; (write stuff)
|
||||||
(newline)
|
;; (newline)
|
||||||
(car (last-pair stuff)))
|
;; (car (last-pair stuff)))
|
||||||
|
|
||||||
(define (pke . stuff)
|
;; (define (pke . stuff)
|
||||||
(display "\n" (current-error-port))
|
;; (display "\n" (current-error-port))
|
||||||
(newline (current-error-port))
|
;; (newline (current-error-port))
|
||||||
(display ";;; " (current-error-port))
|
;; (display ";;; " (current-error-port))
|
||||||
(write stuff (current-error-port))
|
;; (write stuff (current-error-port))
|
||||||
(display "\n" (current-error-port))
|
;; (display "\n" (current-error-port))
|
||||||
(car (last-pair stuff)))
|
;; (car (last-pair stuff)))
|
||||||
|
|
||||||
(define warn pke)
|
;; (define warn pke)
|
||||||
|
|
||||||
(define (disjoin . predicates)
|
;; (define (disjoin . predicates)
|
||||||
(lambda (. arguments)
|
;; (lambda (. arguments)
|
||||||
(any (lambda (o) (apply o arguments)) predicates)))
|
;; (any (lambda (o) (apply o arguments)) predicates)))
|
||||||
|
|
||||||
(define (string-substitute string find replace)
|
(define (string-substitute string find replace)
|
||||||
(let ((index (string-contains string find)))
|
(let ((index (string-contains string find)))
|
||||||
|
|
|
@ -0,0 +1,53 @@
|
||||||
|
#! /bin/sh
|
||||||
|
# -*-scheme-*-
|
||||||
|
srcdir=${srcdir-.}
|
||||||
|
GUILE_LOAD_PATH=$srcdir/tests
|
||||||
|
export GUILE_LOAD_PATH
|
||||||
|
MES_BOOT=boot-5.mes
|
||||||
|
export MES_BOOT
|
||||||
|
exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests module)' -s "$0" "$@"
|
||||||
|
!#
|
||||||
|
|
||||||
|
;;; -*-scheme-*-
|
||||||
|
|
||||||
|
;;; GNU Mes --- Maxwell Equations of Software
|
||||||
|
;;; Copyright © 2019,2020 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 module)
|
||||||
|
#:use-module (data foo)
|
||||||
|
#:use-module (data bar)
|
||||||
|
#:use-module (mes test))
|
||||||
|
|
||||||
|
(pass-if "first dummy" #t)
|
||||||
|
(pass-if-not "second dummy" #f)
|
||||||
|
|
||||||
|
(pass-if "defined foo"
|
||||||
|
(defined? 'foo))
|
||||||
|
|
||||||
|
(pass-if-equal "foo"
|
||||||
|
"foo"
|
||||||
|
(and (defined? 'foo) foo))
|
||||||
|
|
||||||
|
(pass-if "defined bar"
|
||||||
|
(defined? 'bar))
|
||||||
|
|
||||||
|
(pass-if-equal "bar"
|
||||||
|
"bar"
|
||||||
|
(and (defined? 'bar) bar))
|
||||||
|
|
||||||
|
(result 'report)
|
|
@ -1,7 +1,5 @@
|
||||||
;;; -*-scheme-*-
|
|
||||||
|
|
||||||
;;; GNU Mes --- Maxwell Equations of Software
|
;;; GNU Mes --- Maxwell Equations of Software
|
||||||
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
||||||
;;;
|
;;;
|
||||||
;;; This file is part of GNU Mes.
|
;;; This file is part of GNU Mes.
|
||||||
;;;
|
;;;
|
||||||
|
@ -18,4 +16,13 @@
|
||||||
;;; You should have received a copy of the GNU General Public License
|
;;; You should have received a copy of the GNU General Public License
|
||||||
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
|
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
(include-from-path "mes/misc.scm")
|
;;; Commentary:
|
||||||
|
|
||||||
|
;;; bar.scm is used by tests/boot-6.test
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
(define-module (data bar)
|
||||||
|
#:export (bar))
|
||||||
|
|
||||||
|
(define bar "bar")
|
|
@ -1,7 +1,5 @@
|
||||||
;;; -*-scheme-*-
|
|
||||||
|
|
||||||
;;; GNU Mes --- Maxwell Equations of Software
|
;;; GNU Mes --- Maxwell Equations of Software
|
||||||
;;; Copyright © 2016 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
||||||
;;;
|
;;;
|
||||||
;;; This file is part of GNU Mes.
|
;;; This file is part of GNU Mes.
|
||||||
;;;
|
;;;
|
||||||
|
@ -20,9 +18,11 @@
|
||||||
|
|
||||||
;;; Commentary:
|
;;; Commentary:
|
||||||
|
|
||||||
;;; srfi-26.mes - cut, cute
|
;;; foo.scm is used by tests/boot-6.test
|
||||||
|
|
||||||
(mes-use-module (mes scm))
|
;;; Code:
|
||||||
(mes-use-module (mes guile))
|
|
||||||
(mes-use-module (srfi srfi-1))
|
(define-module (data foo)
|
||||||
(include-from-path "srfi/srfi-26.scm")
|
#:export (foo))
|
||||||
|
|
||||||
|
(define foo "foo")
|
|
@ -22,9 +22,9 @@ exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
|
||||||
;;; You should have received a copy of the GNU General Public License
|
;;; You should have received a copy of the GNU General Public License
|
||||||
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
|
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
;; (define-module (tests display)
|
(define-module (tests display)
|
||||||
;; #:use-module (mes mes-0)
|
#:use-module (mes mes-0)
|
||||||
;; #:use-module (mes test))
|
#:use-module (mes test))
|
||||||
|
|
||||||
(mes-use-module (mes display))
|
(mes-use-module (mes display))
|
||||||
(mes-use-module (mes guile))
|
(mes-use-module (mes guile))
|
||||||
|
|
|
@ -32,7 +32,6 @@ exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
|
||||||
(cond-expand
|
(cond-expand
|
||||||
(mes
|
(mes
|
||||||
(mes-use-module (mes test))
|
(mes-use-module (mes test))
|
||||||
(mes-use-module (mes misc))
|
|
||||||
(mes-use-module (mes guile)))
|
(mes-use-module (mes guile)))
|
||||||
(else))
|
(else))
|
||||||
|
|
||||||
|
|
|
@ -26,6 +26,7 @@ exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
|
||||||
(define-module (tests pmatch)
|
(define-module (tests pmatch)
|
||||||
#:use-module (system base pmatch)
|
#:use-module (system base pmatch)
|
||||||
#:use-module (mes mes-0)
|
#:use-module (mes mes-0)
|
||||||
|
#:use-module (mes guile)
|
||||||
#:use-module (mes test))
|
#:use-module (mes test))
|
||||||
|
|
||||||
(cond-expand
|
(cond-expand
|
||||||
|
|
|
@ -99,14 +99,6 @@ exec ${MES-mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests boot
|
||||||
(pass-if-equal "assoc-set!" '((a . 0) (b . 2)) (assoc-set! '((a . 0) (b . 1)) 'b 2))
|
(pass-if-equal "assoc-set!" '((a . 0) (b . 2)) (assoc-set! '((a . 0) (b . 1)) 'b 2))
|
||||||
(pass-if-equal "assoc-set! new" '((b . 2) (a . 0)) (assoc-set! '((a . 0)) 'b 2))
|
(pass-if-equal "assoc-set! new" '((b . 2) (a . 0)) (assoc-set! '((a . 0)) 'b 2))
|
||||||
|
|
||||||
(pass-if "builtin? car" (builtin? car))
|
|
||||||
(pass-if "builtin? cdr" (builtin? cdr))
|
|
||||||
(pass-if "builtin? cons" (builtin? cons))
|
|
||||||
(pass-if "builtin? eq?" (builtin? eq?))
|
|
||||||
(pass-if "builtin? if" (builtin? eq?))
|
|
||||||
(when (not guile?)
|
|
||||||
(pass-if "builtin? eval" (not (builtin? not))))
|
|
||||||
(pass-if "procedure?" (procedure? builtin?))
|
|
||||||
(pass-if "procedure?" (procedure? procedure?))
|
(pass-if "procedure?" (procedure? procedure?))
|
||||||
(pass-if "gensym"
|
(pass-if "gensym"
|
||||||
(symbol? (gensym)))
|
(symbol? (gensym)))
|
||||||
|
|
|
@ -39,7 +39,9 @@ exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
|
||||||
(pass-if "vector?" (vector? #(1 2 c)))
|
(pass-if "vector?" (vector? #(1 2 c)))
|
||||||
(pass-if "vector-length" (seq? (vector-length #(1)) 1))
|
(pass-if "vector-length" (seq? (vector-length #(1)) 1))
|
||||||
|
|
||||||
(pass-if "make-vector" (sequal? (make-vector 3) #(*unspecified* *unspecified* *unspecified*)))
|
(pass-if-equal "make-vector"
|
||||||
|
(list->vector (list *unspecified* *unspecified* *unspecified*))
|
||||||
|
(make-vector 3))
|
||||||
(pass-if "make-vector 1" (sequal? (make-vector 3 0) #(0 0 0)))
|
(pass-if "make-vector 1" (sequal? (make-vector 3 0) #(0 0 0)))
|
||||||
|
|
||||||
(pass-if "vector-ref" (seq? (vector-ref #(0 1) 1) 1))
|
(pass-if "vector-ref" (seq? (vector-ref #(0 1) 1) 1))
|
||||||
|
|
Loading…
Reference in New Issue