mes/test.mes

;;; -*-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/>.

;; The Maxwell Equations of Software -- John McCarthy page 13
;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf

;; haha, broken...lat0r
(define result #f)
(let ((pass 0)
      (fail 0)
      (xresult #f))
  (set! result
    (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))
(define (guile?) #f)
(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))))

(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 "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))
                          '((1 . a) (2 . b) (3 . c) (4 . d))))
(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 "+" (seq? (+ 1 2 3) 6))
(pass-if "*" (seq? (* 3 3 3) 27))
(pass-if "/" (seq? (/ 9 3) 3))
(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 "eq?" (not (eq? (string-append "a" "b" "c") "abc")))
(pass-if "string-length" (seq? (string-length (string-append "a" "b" "c")) 3))
(pass-if "char" (seq? (char->integer #\A) 65))
(pass-if "char 2" (seq? (char->integer #\101) (char->integer #\A)))
(pass-if "char 3" (seq? (integer->char 10) #\newline))
(pass-if "char 4" (seq? (integer->char 32) #\space))
(pass-if "string " (sequal? (string #\a #\space #\s #\t #\r #\i #\n #\g) "a string"))
(pass-if "length" (seq? (length '()) 0))
(pass-if "length 2" (seq? (length '(a b c)) 3))
(pass-if "vector?" (vector? #(1 2 c)))
(pass-if "vector-length" (seq? (vector-length #(1)) 1))
(pass-if "list->vector" (sequal? (list->vector '(a b c)) #(a b c)))
(pass-if "vector" (sequal? #(vector 0 1 2) #(vector 0 1 2)))
(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 "equal?" (sequal? #(1) #(1)))
(pass-if "equal?" (not (equal? #() #(1))))
(pass-if "memq" (sequal? (memq 'a '(a b c)) '(a b c)))
(pass-if "memq" (sequal? (memq 'b '(a b c)) '(b c)))
(pass-if "memq" (seq? (memq 'd '(a b c)) #f))
(pass-if "member" (sequal? (member '(a) '((a) b c)) '((a) b c)))
(pass-if "assq-ref" (seq? (assq-ref '((b . 1) (c . 2)) 'c) 2))
(pass-if "assq-ref 2" (seq? (assq-ref '((b . 1) (c . 2)) 'a) #f))
(pass-if "assq-set!" (sequal? (assq-set! '((b . 1)) 'a 0) '((a . 0) (b . 1))))
(pass-if "assq-set! 2" (sequal? (assq-set! '((a . 0)) 'a 1) '((a . 1))))

;; works, but debugging is foo
;; (cond ((defined? 'loop2)
;;        (display "mes:values broken after loop2")
;;        (newline))
;;       (#t
;;        (values 0 1)
;;        (display "(values 0 1): ")
;;        (display (values 0 1))
;;        (newline)

;;        (display "call-with-values ==> 6: ")
;;        (display
;;         (call-with-values (lambda () (values 1 2 3))
;;           (lambda (a b c) (+ a b c))))
;;        (newline)
;;        (display "call-with-values ==> 1: ")
;;        (display ((lambda (x) x) (values 1 2 3)))
;;        (newline)))

(pass-if "builtin?" (builtin? eval))
;;(pass-if "builtin?" (builtin? cond))
(pass-if "procedure?" (procedure? builtin?))
(pass-if "procedure?" (procedure? procedure?))
(when (not (guile?))
  (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" (eq? (last-pair '()) '()))
;; (pass-if "circular-list? "
;;   (seq?
;;    (let ((x (list 1 2 3 4)))
;;      (set-cdr! (last-pair x) (cddr x))
;;      (circular-list? x))
;;    #t))

(pass-if "cond-expand" (sequal? (cond-expand (foobar #f) (mes (display ": pass: *YAY*") 'mes)) 'mes))

(newline)
(display "passed: ") (display (car (result))) (newline)
(display "failed: ") (display (cadr (result))) (newline)
(display "total: ") (display (apply + (result))) (newline)

(exit (cadr (result)))