635 lines
16 KiB
Scheme
635 lines
16 KiB
Scheme
;;;; Viability suite for Rebirth Lisp
|
||
;;;;
|
||
;;;; Copyright (C) 2018 Mike Gerwitz
|
||
;;;;
|
||
;;;; This file is part of Ulambda Scheme.
|
||
;;;;
|
||
;;;; Ulambda Scheme is free software: you can redistribute it and/or modify
|
||
;;;; it under the terms of the GNU Affero General Public License as
|
||
;;;; published by the Free Software Foundation, either version 3 of the
|
||
;;;; License, or (at your option) any later version.
|
||
;;;;
|
||
;;;; This program 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 Affero General Public License
|
||
;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||
;;;;
|
||
|
||
|
||
|
||
;;; Commentary:
|
||
|
||
;;; THIS IS BOOTSTRAP CODE INTENDED FOR USE ONLY IN REBIRTH.
|
||
;;;
|
||
;;;
|
||
;;; Rebirth has two major goals:
|
||
;;; 1. Be just good enough to begin writing Ulambda in a sane Lisp dialect
|
||
;;; without having to make too many negative compromises; and
|
||
;;; 2. To prove that certain implementation details are
|
||
;;; successful---Rebirth is an experiment in a number of concepts.
|
||
;;;
|
||
;;; Rebirth is to be considered _viable_ when it meets both of those
|
||
;;; goals. The viability of Rebirth is determined by this test suite.
|
||
;;;
|
||
;;; This file should be compiled using the last generation of Rebirth and
|
||
;;; directly executed. There are no external dependencies or fancy
|
||
;;; libraries here, since Rebirth is too primitive to support much of
|
||
;;; that. If successful, this compiled script should exit with a zero
|
||
;;; status code.
|
||
;;;
|
||
;;; Certain tests may be marked as skipped if Rebirth features are under
|
||
;;; development.
|
||
;;;
|
||
|
||
;;; Code:
|
||
|
||
|
||
|
||
;; TODO: These ought to be automatically included by Rebirth
|
||
(include "rebirth/es.scm")
|
||
(include "rebirth/relibprebirth.scm")
|
||
(include "rebirth/macro.scm")
|
||
(include "rebirth/compiler.scm")
|
||
|
||
|
||
|
||
;;; {Test Runner}
|
||
;;;
|
||
|
||
;; This runner uses an imperative style because Rebirth lacks convenient
|
||
;; functional primitives (and so this is far more concise). Mutators are
|
||
;; discouraged in Ulambda.
|
||
;;
|
||
;; These counts are increased during test execution.
|
||
(define testn 0)
|
||
(define testfail 0)
|
||
(define skipn 0)
|
||
|
||
|
||
;; Output message to standard out.
|
||
(define (output str)
|
||
(es:console str))
|
||
|
||
|
||
;; Run suite of tests described by TESTS.
|
||
;;
|
||
;; Test results are output as an S-expression.
|
||
(define-macro (test-suite . tests)
|
||
(`quote
|
||
(begin
|
||
(output "(test-results")
|
||
(unquote@ tests)
|
||
(test-report))))
|
||
|
||
|
||
;; Group tests TESTS into a topic with description DESC
|
||
;;
|
||
;; The description DESC will be output as a comment along with the number of
|
||
;; tests in TESTS. This is intended purely as a visual aid.
|
||
(define-macro (topic desc . tests)
|
||
(`quote
|
||
(begin
|
||
(output (string-append " ;; " (unquote desc)
|
||
" (" (unquote (length tests)) ")"))
|
||
(unquote@ tests))))
|
||
|
||
|
||
;; Verify that the given value VALUE matches the expected value EXPECTED.
|
||
;;
|
||
;; A line describing this test will be output as an S-expression (see
|
||
;; `test-result').
|
||
(define-macro (verify desc value expected)
|
||
(`quote
|
||
(let* ((result (es:try (unquote value)
|
||
(lambda (err) err)))
|
||
(ok (deep-eq? result (unquote expected))))
|
||
(test-result (unquote desc)
|
||
ok
|
||
(if ok "ok" "FAIL")
|
||
result)
|
||
(if (not ok) (set! testfail (+ 1 testfail))))))
|
||
|
||
|
||
;; Skip a test and output it as such.
|
||
;;
|
||
;; This should only ever be used when test cases are written to demonstrate
|
||
;; failing cases with the intent to fix them. It is dangerous to use this
|
||
;; template, since they could easily be forgotten about---skipped tests do
|
||
;; _not_ fail.
|
||
(define-macro (skip desc . _)
|
||
(`quote
|
||
(begin
|
||
(test-result (unquote desc) #t "SKIP" #f)
|
||
(set! skipn (+ 1 skipn)))))
|
||
|
||
|
||
;; Output result of a test.
|
||
;;
|
||
;; An S-expression will be output including the test number; result of the
|
||
;; test as a string TAG; a description DESC of the test; and, on failure, a
|
||
;; comment describing the bad value as a JSON-encoded string (because that's
|
||
;; convenient; Rebirth does not have a pretty-printer for S-expressions).
|
||
(define (test-result desc ok tag result)
|
||
(output (string-append " (" testn " '" tag " \"" desc "\")"
|
||
(if (not ok)
|
||
(string-append " ; " (es:json-stringify result)))))
|
||
(set! testn (+ 1 testn)))
|
||
|
||
|
||
;; Output a final test report with total, failure, and skip counts.
|
||
;;
|
||
;; This outputs a line as an S-expression and adds the closing parenthesis
|
||
;; for `test-suite'.
|
||
;;
|
||
;; If there are any failures, an error is thrown.
|
||
(define (test-report)
|
||
(output (string-append " (summary (tests . " testn ") "
|
||
"(failures . " testfail ") "
|
||
"(skipped . " skipn "))"))
|
||
(if (not (eq? testfail 0))
|
||
(error "Rebirth is not viable!")))
|
||
|
||
|
||
;; Primitive recursive eq? check.
|
||
(define (deep-eq? x y)
|
||
;; Universal quantifier over list LS for truthy values.
|
||
(define (everyt? ls)
|
||
(fold (lambda (x y) (and x y))
|
||
#t
|
||
ls))
|
||
|
||
(or (and (list? x)
|
||
(list? y)
|
||
(eq? (length x) (length y))
|
||
(everyt? (map deep-eq? x y)))
|
||
|
||
(and (not (or (list? x)
|
||
(list? y)))
|
||
(eq? x y))))
|
||
|
||
|
||
|
||
|
||
;;; {Test Cases}
|
||
;;;
|
||
|
||
(test-suite
|
||
(topic "car"
|
||
(verify "car of pair"
|
||
(car (list 1))
|
||
1)
|
||
(verify "car of multi-element pair"
|
||
(car (list 2 3))
|
||
2))
|
||
|
||
(topic "cdr"
|
||
(verify "cdr of pair"
|
||
(cdr (list 1))
|
||
(list))
|
||
(verify "cdr of multi-eement pair"
|
||
(cdr (list 1 2))
|
||
(list 2))
|
||
(skip "cdr of improper cons'd pair"
|
||
(cdr (cons 1 2))
|
||
2)
|
||
(skip "cdr of proper dotted pair"
|
||
(cdr (quote (1 . (2 3))))
|
||
(list 2 3))
|
||
(skip "cdr of improper dotted pair"
|
||
(cdr (quote (1 . 2)))
|
||
2))
|
||
|
||
(topic "lists"
|
||
(verify "list? with empty list"
|
||
(list? (list))
|
||
#t)
|
||
(verify "list? with non-empty list"
|
||
(list? (list 1 2))
|
||
#t)
|
||
(skip "list? with two-element improper list"
|
||
(list? (quote (1 . 2)))
|
||
#f)
|
||
(skip "list? with many-element improper list"
|
||
(list? (quote (1 2 3 . 4)))
|
||
#f)
|
||
(verify "list? with non-list object"
|
||
(or (list? 5)
|
||
(list? #t)
|
||
(list? #f)
|
||
(list? (quote symbol))
|
||
(list? "string"))
|
||
#f)
|
||
(verify "list? with proper cons"
|
||
(list? (cons 1 (list)))
|
||
#t)
|
||
(skip "list? with improper cons"
|
||
(list? (cons 1 2))
|
||
#f)
|
||
(verify "pair? with empty list"
|
||
(pair? (list))
|
||
#f)
|
||
(verify "pair? with single-element list"
|
||
(pair? (list 1))
|
||
#t)
|
||
(verify "pair? with multi-element list"
|
||
(pair? (list 1 2))
|
||
#t)
|
||
(skip "pair? with improper list"
|
||
(pair? (quote (1 . 2)))
|
||
#t)
|
||
(verify "pair? with proper cons"
|
||
(pair? (cons 1 (list)))
|
||
#t)
|
||
(skip "pair? with improper cons"
|
||
(pair? (cons 1 2))
|
||
#t)
|
||
(verify "length of list"
|
||
(length (list 1 2 3 4 5))
|
||
5))
|
||
|
||
(topic "lambda/define"
|
||
(verify "thunk"
|
||
(begin
|
||
(define f (lambda () (quote thunky)))
|
||
(f))
|
||
(quote thunky))
|
||
(verify "with parameters"
|
||
(begin
|
||
(define f (lambda (x y) (list x y)))
|
||
(f (quote a) (quote b)))
|
||
(list (quote a) (quote b)))
|
||
(verify "define procedure shorthand"
|
||
(begin
|
||
(define (f x y) (list x y))
|
||
(f (quote a) (quote b)))
|
||
(list (quote a) (quote b)))
|
||
(verify "define varadic"
|
||
(begin
|
||
(define (f x y . rest)
|
||
(list x y rest))
|
||
(f 1 2 3 4 5))
|
||
(list 1 2 (list 3 4 5)))
|
||
(verify "define value"
|
||
(begin
|
||
(define x 5)
|
||
x)
|
||
5))
|
||
|
||
(topic "let/let*"
|
||
(verify "let with no bindings"
|
||
(let () (quote ok))
|
||
(quote ok))
|
||
(verify "let with one binding"
|
||
(let ((x 1)) x)
|
||
1)
|
||
(verify "let with multiple bindings"
|
||
(let ((x 1)
|
||
(y 2))
|
||
(list x y))
|
||
(list 1 2))
|
||
(verify "let reference sibling binding"
|
||
(let ((x 1))
|
||
(let ((x 2)
|
||
(y x))
|
||
y))
|
||
1)
|
||
(verify "let with multiple body expressions"
|
||
(let ()
|
||
1
|
||
2
|
||
3)
|
||
3)
|
||
|
||
(verify "let* with no bindings"
|
||
(let* () (quote ok))
|
||
(quote ok))
|
||
(verify "let* with one binding"
|
||
(let* ((x 1)) x)
|
||
1)
|
||
(verify "let* with multiple bindings"
|
||
(let* ((x 1)
|
||
(y 2))
|
||
(list x y))
|
||
(list 1 2))
|
||
(verify "let* reference sibling binding"
|
||
(let* ((x 1))
|
||
(let* ((x 2)
|
||
(y x))
|
||
y))
|
||
2)
|
||
(verify "let* with multiple body expressions"
|
||
(let ()
|
||
2
|
||
3
|
||
4)
|
||
4))
|
||
|
||
(topic "begin"
|
||
(verify "begin with one expression"
|
||
(begin (quote ok))
|
||
(quote ok))
|
||
(verify "begin with multiple expressions"
|
||
(begin
|
||
(quote first)
|
||
(quote second)
|
||
(quote third))
|
||
(quote third))
|
||
(verify "begin with definition"
|
||
(begin
|
||
(define x 5)
|
||
x)
|
||
5))
|
||
|
||
(topic "strings"
|
||
(verify "substring with start and end"
|
||
(substring "foobar" 2 5)
|
||
"oba")
|
||
(verify "string-length"
|
||
(string-length "foo")
|
||
3)
|
||
(verify "string=? with differing strings"
|
||
(string=? "foo" "bar")
|
||
#f)
|
||
(verify "string=? with identical strings"
|
||
(string=? "baz" "baz")
|
||
#t)
|
||
(verify "string-append with no strings"
|
||
(string-append)
|
||
"")
|
||
(verify "string-append with one string"
|
||
(string-append "foo")
|
||
"foo")
|
||
(verify "string-append with many strings"
|
||
(string-append "foo" "bar" "baz" "quux")
|
||
"foobarbazquux"))
|
||
|
||
(topic "math"
|
||
(verify "+ with no argments"
|
||
(+)
|
||
0)
|
||
(verify "+ with one argument"
|
||
(+ 5)
|
||
5)
|
||
(verify "+ with two arguments"
|
||
(+ 5 4)
|
||
9)
|
||
(verify "+ with multiple arguments"
|
||
(+ 5 4 3 -2 -1)
|
||
9)
|
||
(verify "- with one argument"
|
||
(- 3)
|
||
-3)
|
||
(verify "- with two arguments"
|
||
(- 3 2)
|
||
1)
|
||
(verify "- with multiple arguments"
|
||
(- 3 2 1 -4)
|
||
4))
|
||
|
||
;; Rebirth comparison procedures support two arguments
|
||
(topic "comparison"
|
||
(verify "= with two arguments"
|
||
(and (= 5 5)
|
||
(not (= 4 3)))
|
||
#t)
|
||
(verify "< with two arguments"
|
||
(and (< 5 6)
|
||
(not (< 6 4)))
|
||
#t)
|
||
(verify "> with two arguments"
|
||
(and (> 5 4)
|
||
(not (> 3 4)))
|
||
#t)
|
||
(verify "zero? with two arguments"
|
||
(and (zero? 0)
|
||
(not (zero? 5)))
|
||
#t)
|
||
(verify "eq? given the same object"
|
||
(let ((x (list 1 2 3)))
|
||
(eq? x x))
|
||
#t)
|
||
(verify "eq? given different but similar objects"
|
||
(let ((x (list 1 2 3))
|
||
(y (list 1 2 3)))
|
||
(eq? x y))
|
||
#f))
|
||
|
||
(topic "if"
|
||
(verify "if #t is truthy"
|
||
(if #t 1)
|
||
1)
|
||
(verify "if #f is not truthy"
|
||
(if #f #f 2)
|
||
2)
|
||
(verify "if non-empty string is truthy"
|
||
(if "string" #t)
|
||
#t)
|
||
(verify "if empty string is truthy"
|
||
(if "" #t)
|
||
#t)
|
||
(verify "if symbol is truthy"
|
||
(if (quote symbol) #t)
|
||
#t)
|
||
(verify "if unspecified is truthy"
|
||
(if (if #f #f) #t)
|
||
#t)
|
||
(verify "if short-circuits when true"
|
||
(if #t #t (error "should not happen"))
|
||
#t)
|
||
(verify "if short-circuits when false"
|
||
(if #f (error "should not happen") #t)
|
||
#t))
|
||
|
||
(topic "and"
|
||
(verify "and nullary"
|
||
(and)
|
||
#t)
|
||
(verify "and unary truthy"
|
||
(and #t)
|
||
#t)
|
||
(verify "and unary false"
|
||
(and #f)
|
||
#f)
|
||
(verify "and nary all truthy"
|
||
(and #t "" 0 (lambda ()) (quote all))
|
||
(quote all))
|
||
(verify "and nary one false"
|
||
(and #t #t #f)
|
||
#f))
|
||
|
||
(topic "or"
|
||
(verify "or nullary"
|
||
(or)
|
||
#f)
|
||
(verify "or unary truthy"
|
||
(or #t)
|
||
#t)
|
||
(verify "or unary false"
|
||
(or #f)
|
||
#f)
|
||
(verify "or nary one truthy"
|
||
(or #f #f #f (quote any))
|
||
(quote any))
|
||
(verify "or nary all false"
|
||
(or #f #f #f)
|
||
#f))
|
||
|
||
(topic "case"
|
||
(verify "case with single clause predicate"
|
||
(case #t
|
||
((#t) (quote ok)))
|
||
(quote ok))
|
||
(verify "case with multiple clause predicates"
|
||
(case 5
|
||
((1 2 3 4 5) #t))
|
||
#t)
|
||
(verify "case with multiple clauses"
|
||
(case #f
|
||
((#t) (quote t))
|
||
((#f) (quote f)))
|
||
(quote f))
|
||
(verify "case with else"
|
||
(case 5
|
||
((#t) #f)
|
||
(else (quote else)))
|
||
(quote else)))
|
||
|
||
(topic "append"
|
||
(verify "append with no arguments"
|
||
(append)
|
||
(list))
|
||
(verify "append with one list"
|
||
(append (list 1 2))
|
||
(list 1 2))
|
||
(verify "append with multiple lists"
|
||
(append (list 1 2) (list) (list 3 4 5))
|
||
(list 1 2 3 4 5)))
|
||
|
||
(topic "map"
|
||
(verify "map with empty list"
|
||
(map (lambda (_))
|
||
(list))
|
||
(list))
|
||
(verify "map with non-empty list"
|
||
(map (lambda (x) (+ 1 x))
|
||
(list 1 2 3))
|
||
(list 2 3 4))
|
||
(verify "map with multiple lists"
|
||
(map (lambda (x y) (+ x y))
|
||
(list 1 2 3)
|
||
(list 11 12 13))
|
||
(list 12 14 16)))
|
||
|
||
(topic "fold"
|
||
(verify "fold with empty list"
|
||
(fold (lambda (_ __))
|
||
(list)
|
||
(list))
|
||
(list))
|
||
;; Rebirth's fold only supports one list
|
||
(verify "fold with non-empty list"
|
||
(fold (lambda (x y) (+ x y))
|
||
0
|
||
(list 1 2 3))
|
||
6))
|
||
|
||
;; certain things (like es:defined?) cannot be tested here because compiler
|
||
;; procedures are not available at runtime
|
||
(topic "es procedures/macros"
|
||
(verify "es:null?"
|
||
(and (es:null? es:null)
|
||
(not (es:null? "")))
|
||
#t)
|
||
(verify "es:array? given list"
|
||
(es:array? (list))
|
||
#t)
|
||
(verify "es:array? given non-list"
|
||
(or (es:array? "")
|
||
(es:array? #t)
|
||
(es:array? 5)
|
||
(es:array? es:array?))
|
||
#f)
|
||
(verify "es:error and es:try"
|
||
(es:try (error "test")
|
||
(lambda (e) (quote thrown)))
|
||
(quote thrown))
|
||
|
||
;; these also verify that the given Scheme object is properly recognized
|
||
;; by Rebirth (and produces the intended internal representation)
|
||
(verify "es:typeof on list"
|
||
(es:typeof (list 1 2))
|
||
"object")
|
||
(verify "es:typeof on string"
|
||
(es:typeof "string")
|
||
"string")
|
||
(verify "es:typeof on non-negative number"
|
||
(es:typeof 1)
|
||
"number")
|
||
(verify "es:typeof on negative number"
|
||
(es:typeof -1)
|
||
"number")
|
||
(verify "es:typeof on float"
|
||
(es:typeof 1.5)
|
||
"number")
|
||
(verify "es:typeof on float with no preceding digit"
|
||
(es:typeof .5)
|
||
"number")
|
||
(verify "es:typeof on negative float"
|
||
(es:typeof -0.5)
|
||
"number")
|
||
(verify "es:typeof on negative float with no preceding digit"
|
||
(es:typeof -.5)
|
||
"number")
|
||
(verify "es:typeof on #t"
|
||
(es:typeof #t)
|
||
"boolean")
|
||
(verify "es:typeof on #f"
|
||
(es:typeof #f)
|
||
"boolean")
|
||
(verify "es:typeof on procedure"
|
||
(es:typeof (lambda ()))
|
||
"function")
|
||
(verify "es:typeof on symbol"
|
||
(es:typeof (quote foo))
|
||
"symbol")
|
||
|
||
(verify "es:match with es:regexp"
|
||
(and (es:match (es:regexp "^foo") "foobar")
|
||
(not (es:match (es:regexp "^bar") "foobar")))
|
||
#t)
|
||
(verify "es:replace with string"
|
||
(es:replace "foo" "bar" "foobar")
|
||
"barbar")
|
||
(verify "es:replace with es:regexp"
|
||
(es:replace (es:regexp "^fo+") "q" "foobar")
|
||
"qbar")
|
||
|
||
(verify "es:while with predicate"
|
||
(let ((x 3))
|
||
(es:while (> x 1) (set! x (- x 1)))
|
||
x)
|
||
1)
|
||
(verify "es:while with es:break"
|
||
(let ((x 3))
|
||
(es:while (> x 1)
|
||
(set! x (- x 1))
|
||
(es:break))
|
||
x)
|
||
2))
|
||
|
||
(topic "eval and environment"
|
||
(skip "eval in new environment"
|
||
(eval (quote
|
||
(let ((x 5))
|
||
(+ x 5)))
|
||
(null-environment 5))
|
||
10)
|
||
(skip "eval inheriting environment"
|
||
(let ((x (quote xsym)))
|
||
(eval (`quote (list (unquote x)))
|
||
(es:inherit-env)))
|
||
(quote xsym))))
|