2016-07-09 11:23:58 +00:00
|
|
|
;;; -*-scheme-*-
|
|
|
|
|
|
|
|
;;; Mes --- Maxwell Equations of Software
|
|
|
|
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
|
|
|
|
;;;
|
2016-07-25 12:39:56 +00:00
|
|
|
;;; scm.test: This file is part of Mes.
|
2016-07-09 11:23:58 +00:00
|
|
|
;;;
|
|
|
|
;;; 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/>.
|
|
|
|
|
2016-07-23 13:17:03 +00:00
|
|
|
(when guile?
|
2016-07-23 06:17:49 +00:00
|
|
|
(module-define! (current-module) 'builtin? (lambda (. x) #t))
|
2016-07-25 12:39:56 +00:00
|
|
|
(use-modules (srfi srfi-1))
|
|
|
|
)
|
2016-07-18 20:43:16 +00:00
|
|
|
|
|
|
|
(pass-if "first dummy" #t)
|
|
|
|
(pass-if-not "second dummy" #f)
|
|
|
|
|
2016-07-25 12:39:56 +00:00
|
|
|
(pass-if "when" (seq? (when #t 'true) 'true))
|
|
|
|
(pass-if "when 2" (seq? (when #f 'true) *unspecified*))
|
2016-07-18 20:43:16 +00:00
|
|
|
|
2016-07-18 20:52:12 +00:00
|
|
|
(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))
|
2016-07-24 10:40:44 +00:00
|
|
|
'((1 . a) (2 . b) (3 . c) (4 . d))))
|
|
|
|
(pass-if "for-each" (sequal? (let ((acc '())) (for-each (lambda (x) (set! acc (cons x acc))) '(1 2 3 4)) acc) '(4 3 2 1)))
|
2016-07-18 20:43:16 +00:00
|
|
|
(define xxxa 0)
|
2016-07-18 20:52:12 +00:00
|
|
|
(pass-if "set! " (seq? (begin (set! xxxa 1) xxxa) 1))
|
|
|
|
(pass-if "set! 2" (seq? (let ((a 0)) (set! a 1) a) 1))
|
2016-07-25 12:39:56 +00:00
|
|
|
|
|
|
|
|
|
|
|
(pass-if "list-ref" (seq? (list-ref '(0 1 2) 1) 1))
|
|
|
|
|
|
|
|
(pass-if "do" (sequal? (let ((acc '())) (do ((i 0 (+ i 1))) ((>= i 3)) (set! acc (cons i acc))) acc) '(2 1 0)))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
2016-07-18 20:52:12 +00:00
|
|
|
(pass-if "+" (seq? (+ 1 2 3) 6))
|
|
|
|
(pass-if "*" (seq? (* 3 3 3) 27))
|
|
|
|
(pass-if "/" (seq? (/ 9 3) 3))
|
2016-07-24 15:11:49 +00:00
|
|
|
(pass-if "remainder" (seq? (remainder 11 3) 2))
|
|
|
|
(pass-if "modulo" (seq? (modulo 11 3) 2))
|
2016-07-24 15:16:55 +00:00
|
|
|
(pass-if "expt" (seq? (expt 2 3) 8))
|
2016-07-24 15:21:30 +00:00
|
|
|
(pass-if "logior" (seq? (logior 0 1 2 4) 7))
|
2016-07-24 15:11:49 +00:00
|
|
|
|
2016-07-18 20:52:12 +00:00
|
|
|
(pass-if "=" (seq? 3 '3))
|
2016-07-18 20:43:16 +00:00
|
|
|
(pass-if "= 2" (not (= 3 '4)))
|
2016-07-25 12:39:56 +00:00
|
|
|
|
2016-07-18 20:52:12 +00:00
|
|
|
(pass-if "string-append" (sequal? (string-append "a" "b" "c") "abc"))
|
2016-07-24 22:06:18 +00:00
|
|
|
(pass-if "substring" (sequal? (substring "hello world" 6) "world"))
|
|
|
|
(pass-if "substring 2" (sequal? (substring "hello world" 4 7) "o w"))
|
|
|
|
(pass-if "string-ref" (seq? (string-ref "hello world" 4) #\o))
|
2016-07-18 20:59:33 +00:00
|
|
|
(pass-if "eq?" (not (eq? (string-append "a" "b" "c") "abc")))
|
2016-07-18 20:52:12 +00:00
|
|
|
(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))
|
2016-07-18 20:43:16 +00:00
|
|
|
(pass-if "vector?" (vector? #(1 2 c)))
|
2016-07-18 20:52:12 +00:00
|
|
|
(pass-if "vector-length" (seq? (vector-length #(1)) 1))
|
|
|
|
(pass-if "list->vector" (sequal? (list->vector '(a b c)) #(a b c)))
|
2016-08-13 15:05:29 +00:00
|
|
|
(pass-if "make-list" (sequal? (make-list 3 1) '(1 1 1)))
|
2016-07-18 20:52:12 +00:00
|
|
|
(pass-if "vector" (sequal? #(vector 0 1 2) #(vector 0 1 2)))
|
2016-07-24 12:10:18 +00:00
|
|
|
(when (not guile?)
|
|
|
|
(pass-if "make-vector" (sequal? (make-vector 3) #(*unspecified* *unspecified* *unspecified*))))
|
|
|
|
(pass-if "make-vector 2" (sequal? (make-vector 3 0) #(0 0 0)))
|
2016-07-18 20:52:12 +00:00
|
|
|
(pass-if "vector-ref" (seq? (vector-ref #(0 1) 1) 1))
|
2016-07-25 12:39:56 +00:00
|
|
|
(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) #())))
|
2016-07-18 20:52:12 +00:00
|
|
|
(pass-if "equal?" (sequal? #(1) #(1)))
|
2016-07-18 20:59:33 +00:00
|
|
|
(pass-if "equal?" (not (equal? #() #(1))))
|
2016-07-18 20:52:12 +00:00
|
|
|
(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)))
|
2016-07-22 23:38:25 +00:00
|
|
|
(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))))
|
2016-07-24 10:08:21 +00:00
|
|
|
(pass-if "assoc" (sequal? (assoc '(a . 0) '((a . 0) (b . 1) ((a . 0) aa))) '((a . 0) aa)))
|
2016-07-11 18:58:30 +00:00
|
|
|
|
2016-07-17 11:12:51 +00:00
|
|
|
;; 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)))
|
2016-07-11 17:32:11 +00:00
|
|
|
|
2016-07-18 20:43:16 +00:00
|
|
|
(pass-if "builtin?" (builtin? eval))
|
|
|
|
;;(pass-if "builtin?" (builtin? cond))
|
|
|
|
(pass-if "procedure?" (procedure? builtin?))
|
|
|
|
(pass-if "procedure?" (procedure? procedure?))
|
2016-07-23 13:17:03 +00:00
|
|
|
(when (not guile?)
|
2016-07-18 20:52:12 +00:00
|
|
|
(pass-if "gensym" (seq? (gensym) 'g0))
|
|
|
|
(pass-if "gensym" (seq? (gensym) 'g1))
|
|
|
|
(pass-if "gensym" (seq? (gensym) 'g2)))
|
2016-07-22 07:00:32 +00:00
|
|
|
|
2016-07-23 06:17:49 +00:00
|
|
|
(pass-if "last-pair " (sequal? (last-pair '(1 2 3 4)) '(4)))
|
2016-07-24 10:08:21 +00:00
|
|
|
(pass-if "last-pair 2" (seq? (last-pair '()) '()))
|
2016-07-23 06:17:49 +00:00
|
|
|
;; (pass-if "circular-list? "
|
|
|
|
;; (seq?
|
|
|
|
;; (let ((x (list 1 2 3 4)))
|
|
|
|
;; (set-cdr! (last-pair x) (cddr x))
|
|
|
|
;; (circular-list? x))
|
|
|
|
;; #t))
|
|
|
|
|
2016-07-24 10:08:21 +00:00
|
|
|
(pass-if "reverse" (sequal? (reverse '(1 2 3)) '(3 2 1)))
|
|
|
|
|
2016-07-23 13:17:03 +00:00
|
|
|
(pass-if "cond-expand" (sequal? (cond-expand (foobar #f) (mes (display ": pass: *YAY*") 'mes) (guile (display ": pass: *GUILE*") 'mes)) 'mes))
|
2016-07-23 10:54:34 +00:00
|
|
|
|
2016-07-24 11:27:05 +00:00
|
|
|
(pass-if "apply identity" (seq? (apply identity '(0)) 0))
|
|
|
|
(pass-if "apply identity 2" (sequal? (apply identity '((0 1))) '(0 1)))
|
|
|
|
(pass-if "apply append" (sequal? (apply append '((1 2) (3 4))) '(1 2 3 4)))
|
|
|
|
|
2016-07-24 13:26:49 +00:00
|
|
|
(pass-if "=" (seq? (=) #t))
|
|
|
|
(pass-if "= 1" (seq? (= 0) #t))
|
|
|
|
(pass-if "= 2" (seq? (= 0 0) #t))
|
|
|
|
(pass-if "= 3" (seq? (= 0 0) #t))
|
|
|
|
(pass-if "= 4" (seq? (= 0 1 0) #f))
|
|
|
|
|
|
|
|
(pass-if "<" (seq? (<) #t))
|
|
|
|
(pass-if "< 1" (seq? (< 0) #t))
|
|
|
|
(pass-if "< 2" (seq? (< 0 1) #t))
|
|
|
|
(pass-if "< 3" (seq? (< 1 0) #f))
|
|
|
|
(pass-if "< 4" (seq? (< 0 1 2) #t))
|
|
|
|
(pass-if "< 5" (seq? (< 0 2 1) #f))
|
|
|
|
|
|
|
|
(pass-if ">" (seq? (>) #t))
|
|
|
|
(pass-if "> 1" (seq? (> 0) #t))
|
|
|
|
(pass-if "> 2" (seq? (> 1 0) #t))
|
|
|
|
(pass-if "> 3" (seq? (> 0 1) #f))
|
|
|
|
(pass-if "> 4" (seq? (> 2 1 0) #t))
|
|
|
|
(pass-if "> 5" (seq? (> 1 2 0) #f))
|
|
|
|
|
2016-07-24 14:29:38 +00:00
|
|
|
(pass-if ">=" (seq? (>= 3 2 1) #t))
|
|
|
|
(pass-if ">= 2" (seq? (>= 1 2 3) #f))
|
|
|
|
|
|
|
|
(pass-if "<=" (seq? (<= 3 2 1) #f))
|
|
|
|
(pass-if "<= 2" (seq? (<= 1 2 3) #t))
|
|
|
|
|
2016-07-24 14:34:54 +00:00
|
|
|
(pass-if "max" (seq? (max 0) 0))
|
|
|
|
(pass-if "max 1" (seq? (max 0 1) 1))
|
|
|
|
(pass-if "max 2" (seq? (max 1 0 2) 2))
|
|
|
|
|
|
|
|
(pass-if "min" (seq? (min 0) 0))
|
|
|
|
(pass-if "min 1" (seq? (min 0 1) 0))
|
|
|
|
(pass-if "min 2" (seq? (min 1 0 2) 0))
|
|
|
|
|
2016-07-24 15:35:31 +00:00
|
|
|
(pass-if "char-alphabetic?" (seq? (char-alphabetic? #\a) #t))
|
|
|
|
(pass-if "char-alphabetic? 2" (seq? (char-alphabetic? #\[) #f))
|
|
|
|
|
2016-07-18 20:43:16 +00:00
|
|
|
(newline)
|
|
|
|
(display "passed: ") (display (car (result))) (newline)
|
|
|
|
(display "failed: ") (display (cadr (result))) (newline)
|
|
|
|
(display "total: ") (display (apply + (result))) (newline)
|
|
|
|
|
|
|
|
(exit (cadr (result)))
|