;;;;
;;;;
;;;; test-misc.stk         -- Some tests which don't feat anywhere else
;;;;
;;;; Copyright © 2020-2024 Erick Gallesio <eg@stklos.net>
;;;;
;;;;
;;;; This program 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 2 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 General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;;           Author: Erick Gallesio [eg@unice.fr]
;;;;    Creation date:  5-Jul-2020 19:23
;;;;

(require "test")

(test-section "Miscellaneous tests")

;;------------------------------------------------------------------
(test-subsection "Symbols")

(test "symbol.1" '|a\x33;b| 'a3b)
(test "symbol.2" '|a\|b| 'a\|b)
(test "symbol.3" '|a\\b| 'a\\b)
(test "symbol.4" '|a\nb| '|a
b|)
(test "symbols.5" '|a\x8;b| (string->symbol "a\010b"))
(test "print-symbol.1" "a\nb"  (with-output-to-string (lambda() (display 'a\nb))))
(test "print-symbol.2" "|a\\nb|" (with-output-to-string (lambda() (write 'a\nb))))
(test "bars anywhere"  '|a   b| 'a|   |b)
(test "useless backslash.1" 'abcd '|ab\cd|)
(test "useless backslash.2" 'abc '|ab\c|)
(test "useless backslash.3" 'abc 'ab\c)
(test "special-name.1"       '|\b| '\b)
(test "special-name.2"       '|| (string->symbol ""))

(test "symbol with an hexa sequence" '|A B| (read-from-string "A\\x20;B"))
(test/error "non finished hex sequence.1" (read-from-string "a\\x123Z"))
(test/error "non finished hex sequence.2" (read-from-string "a\\x123"))
(test/error "too long hex sequence" (read-form-string "\\x111111111111111111111111"))


;;----------------------------------------------------------------------
(test-subsection "Paths")
(test "file-suffix.1" "gz" (file-suffix "./foo.tar.gz"))
(test "file-suffix.2" #f  (file-suffix "./a.b/c"))
(test "file-suffix.3" ""  (file-suffix "./a.b/c."))
(test "(file-suffix.4" #f  (file-suffix "~/.profile"))

;;----------------------------------------------------------------------
(test-subsection "Sharp syntax")

(test "#t #T"
      #t
      (eq? #t #T))

(test "#t #true"
      #t
      (eq? #t #true))

(test "#f #F"
      #t
      (eq? #f #F))

(test "f #false"
      #t
      (eq? #f #false))

(test "#eof"
      #t
      (eof-object? #eof))

(test "#void"
      #t
      (eq? #void (if #f 'WRONG)))

;;----------------------------------------------------------------------
(test-subsection "bonus.stk")

(test "improper-list?"
      '(#f #f #f #t #t #f #f)
      (map improper-list? (list 2 '() '(1 2 3) '(1 2 . 3) (cons 'a 'b) (list 1 2) #void)))

(let ((fct  (lambda (x y) (and (even? x) (even? y) (+ x y)))))
  (test "every.1"
        1
        (every (lambda (x y) (if (and (even? x) (even? y)) 1 -1))
               '(2 4 5) '(12 14)))

  (test "every.2" #t (every fct '() '()))
  (test "every.3" #f (every fct '(2 1) '(4 6)))
  (test "every.4" 12 (every fct '(2 4) '(6 8)))
  (test "every.5" 12 (every fct '(2 4 1) '(6 8)))

  (test "any.1"
        -1
        (any (lambda (x y)
               (if (or (even? x) (even? y)) 1 -1))
             '(1 3 4) '(11 13)))

  (test "any.2" #f (any fct '() '()))
  (test "any.3" #f (any fct '(2 4 6) '(1 3 5)))
  (test "any.4" 6  (any fct '(2 4 6) '(1 2 5)))
  (test "any.5" 2  (any fct '(2 4 6 8 10) '(-1 -3 -4))))

(test "void? #void" #t (void? #void))
(test "void? (void)"     #t (void? (void)))
(test "void? (if #f #t)" #t (void? (if #f #t)))
(test "void? set!"       #t (let ((a 0)) (void? (set! a 1))))
(test "void number"      #f (void? -2))
(test "void string"      #f (void? "str"))
(test "void nil"         #f (void? '()))
(test "void closure"     #f (void? (lambda () -1)))
(define-macro %%tmp (lambda lst 'ok))
(test "void syntax"      #f (void? %%tmp))

;;----------------------------------------------------------------------
(test-subsection "Escaped octals in strings")

;; similar tests are in test-r7rs, but since R7RS does not mention escaped octals,
;; we keep these here:
(test "read escaped octal"       "C"   (guard (e (else 'wrong)) (read-from-string "\"\\0103\"")))
(test "read only 3 octal digits" "S45" (guard (e (else 'wrong)) (read-from-string "\"\\012345\"")))

;;----------------------------------------------------------------------
(test-subsection "Arity, docstrings, signatures and sources")

(let ((f (lambda () (void)))
      (g (lambda (a) (void)))
      (h (lambda (a b c d) (void)))
      (i (lambda args (void)))
      (j (lambda (a b c . rest) void))
      (k (lambda (a b :optional c d) (void)))
      (l (lambda (a b :key e f) (void)))
      (m (lambda (a b :optional c d :rest r :key e f) (void))))
  (test "arity zero"  0 (%procedure-arity f))
  (test "arity one"   1 (%procedure-arity g))
  (test "arity four"  4 (%procedure-arity h))
  (test "arity args" -1 (%procedure-arity i))
  (test "arity rest" -4 (%procedure-arity j))
  (test "arity opke" -3 (%procedure-arity k))
  (test "arity opke" -3 (%procedure-arity l))
  (test "arity opke" -3 (%procedure-arity m)))

(test "arity nil"  #f (%procedure-arity '()))
(test "arity 5"    #f (%procedure-arity 5))
(test "arity code" #f (%procedure-arity '(lambda () -1)))

(compiler:keep-formals #t)

(define (d) 1)
(define (e x) 10)
(define (f a b) "docstring abc" 42)
(define g f)
(define h (lambda (x y) "h doc" 10))
(define i #f)
(set! i (lambda (w z) 0))

(test "empty signature"
      '()
      (procedure-formals d))
(test "no-docstring"
      #f
      (%procedure-doc e))
(test "no-docstring, but signature"
      '(x)
      (procedure-formals e))
(test "docstring"
      "docstring abc"
      (%procedure-doc f))
(test "docstring g"
      "docstring abc"
      (%procedure-doc g))
(test "signature"
      '(a b)
      (procedure-formals f))
(test "signature g"
      '(a b)
      (procedure-formals g))
(test "docstring h"
      "h doc"
      (%procedure-doc h))
(test "signature h"
      '(x y)
      (procedure-formals h))
(test "signature i"
      '(w z)
      (procedure-formals i))
(test "really anonymous lambda - sig"
      '(l i s p)
      (procedure-formals (lambda (l i s p) (+ l i s p))))
(test "really anonymous lambda sig, with docstring"
      '(l i s p)
      (procedure-formals (lambda (l i s p) "Hello!" (+ l i s p))))
(test "really anonymous lambda - docstring"
      "Hello!"
      (%procedure-doc (lambda (l i s p) "Hello!" (+ l i s p))))

(compiler:keep-formals #f)

(define (dd) 1)
(define (ee x) 10)
(define (ff a b) "docstring abcd" 42)
(define gg ff)
(define hh (lambda (x y) "hh doc" 10))
(define ii #f)
(set! ii (lambda (w z) 0))

(test "empty signature, not generated"
      #f
      (procedure-formals dd))
(test "no-docstring"
      #f
      (%procedure-doc ee))
(test "no-docstring, but sig, not generated"
      #f
      (procedure-formals ee))
(test "docstring"
      "docstring abcd"
      (%procedure-doc ff))
(test "docstring g"
      "docstring abcd"
      (%procedure-doc gg))
(test "signature"
      #f
      (procedure-formals ff))
(test "signature gg"
      #f
      (procedure-formals gg))
(test "docstring hh"
      "hh doc"
      (%procedure-doc hh))
(test "signature hh"
      #f
      (procedure-formals hh))
(test "signature ii"
      #f
      (procedure-formals ii))
(test "really anonymous lambda - sig (not generated)"
      #f
      (procedure-formals (lambda (l i s p) (+ l i s p))))
(test "really anonymous lambda sig - sig not generated, with docstring"
      #f
      (procedure-formals (lambda (l i s p) "Hello!" (+ l i s p))))
(test "really anonymous lambda doc - sig not generated, with docstring"
      "Hello!"
      (%procedure-doc (lambda (l i s p) "Hello!" (+ l i s p))))

;; source
(compiler:keep-source #t)

(define (cube x) (* x x x))
(test "source cube"
      '(lambda (x) (* x x x))
      (procedure-source cube))

(test "source cube different var"
      #f ;; the *exact* source is returned.
      (equal? (procedure-source cube)
              '(lambda (y) (* y y y))))

(let ((f (lambda (a b c) (list c b a))))
  (test "source f"
        '(lambda (a b c) (list c b a))
        (procedure-source f)))

(let ((f (lambda args (print args))))
  (test "source lambda args"
        '(lambda args (print args))
        (procedure-source f)))

;; not testing key and optionals, because the source of the
;; optional/keyword processing is included.
;; (let ((f (lambda (a b :optional c d :rest r :key e f)
;;            (values r (list a b c d e f)))))
;;   ...

(let ((f #f)
      (g #f))
  (let loop ( (a 1)
              (b 2) )
    (set! g (list b a))
    (set! f loop))
  (test "source named let"
        '(lambda (a b) (set! g (list b a)) (set! f loop))
        (procedure-source f)))

(letrec ((f (lambda (n) (if (positive? n)
                       (* n (f (- n 1)))
                       1))))
  (test "source letrec"
        '(lambda (n) (if (positive? n) (* n (f (- n 1))) 1))
        (procedure-source f)))

(test/error "source 1"    (procedure-source 1))
(test/error "source void" (procedure-source #void))
(test/error "source nil"  (procedure-source '()))
(test/error "source code" (procedure-source '(lambda (a) (- a))))


;; Disable and see if it's really off
(compiler:keep-source #f)

(define (cube x) (* x x x))
(test "source cube"
      #f
      (procedure-source cube))

(test "source cube different var"
      #f
      (equal? (procedure-source cube)
              '(lambda (y) (* y y y))))

(let ((f (lambda (a b c) (list c b a))))
  (test "source f"
        #f
        (procedure-source f)))

;;----------------------------------------------------------------------
(test-subsection "tagbody and repeat")

(test "tagbody without goto"
      3
      (tagbody 1 2 3))

(test "tagbody loop"
      "01234"
      (call-with-output-string
       (lambda (p)
         (let ((v 0))           ;; equivalent to (dotimes (v 5) (display v))
           (tagbody
            #:top (when (< v 5)
                    (display v p)
                    (set! v (fx+ v 1))
                    (-> #:top)))))))

(test "convoluted tagbody"
      "1234"
      (call-with-output-string
       (lambda (p)
         (tagbody (display 1 p)
             (tagbody (display 2 p)
                      (-> #:inner)
                      (display "never printed" p)
                      #:inner
                      (display 3 p)
                      (-> #:outer)
                      (display "never printed too"p))
             #:outer
             (display "4" p)))))


 (test/compile-error "tagbody absent label"
                     (tagbody (-> #:absent)))

(test "repeat.1"
      (make-string 100 #\.)
      (call-with-output-string (lambda (p)
                                 (repeat 100 (display "." p)))))

(test "repeat.2"
      ""
      (call-with-output-string (lambda (p)
                                 (repeat -4 (display "." p)))))
(test/error "repeat.3"
            (repeat 'not-a-number (display "." p)))

;;----------------------------------------------------------------------
(test-subsection "while and until")

(test "while.1"
      10
      (let ((a 1)) (while (< a 10) (set! a (fx+ 1 a))) a))

(test "while.2"
      (void)
      (while #f #f))

(test "while.3"
      '()
      (let ((x '(1 2 3)))
        (while (pair? x) (set! x (cdr x)))
        x))

(test "while.4"
      '(3)
      (let ((x '(1 2 3)))
        (while (pair? (cdr x)) (set! x (cdr x)))
        x))

(test "until.1"
      0
      (let ((a 10)) (until (= a 0) (set! a (fx- a 1))) a))

(test "until.2"
      (void)
      (until #t #f))

(test "until.3"
      '()
      (let ((x '(1 2 3)))
        (until (null? x) (set! x (cdr x)))
        x))

(test "until.4"
      '(3)
      (let ((x '(1 2 3)))
        (until (null? (cdr x)) (set! x (cdr x)))
        x))

;;----------------------------------------------------------------------
(test-subsection "push! and pop!")

(test "push!"
      '(10 20 30)
      (let ((S (list 20 30)))
        (push! S 10)
        S))

(test "pop!"
      '(10 (20 30))
      (let* ((S (list 10 20 30))
             (x (pop! S)))
        (list x S)))

(test "push!-pop!"
      '(-10 20 30)
      (let ((S (list 10 20 30)))
        (pop! S)
        (push! S -10)
        S))

(test "generalized push!"
      '((10 20 30) 0 (40 50))
      (let ((S (list (list 20 30) (list 40 50))))
        (push! (car S) 10)
        (push! (cdr S) 0)
        S))
(test "generalized pop!"
      '(10 #((20 30)))
      (let* ((V (vector (list 10 20 30)))
             (x (pop! (vector-ref V 0))))
        (list x V)))

(test "generalized push!-pop!"
      '(() -10 20 30)
      (let ((S (list (list 10) 20 30)))
        (pop! (car S))
        (push! (cdr S) -10)
        S))

;;----------------------------------------------------------------------
(test-subsection "1+ 1-")

(test "1+" 10 (1+ 9))
(test "1+" 10.5 (1+ 9.5))
(test "1+" 5/3 (1+ 2/3))
(test "1+" 2+3i (1+ 1+3i))
(test/error "1+" (1+ 'symbol))
(test "1-" 8 (1- 9))
(test "1-" 8.5 (1- 9.5))
(test "1-" -1/3 (1- 2/3))
(test "1-" 0+3i (1- 1+3i))
(test/error "1-" (1- 'symbol))


;;----------------------------------------------------------------------
(test-subsection "inc! dec!")
(let ((x 10)
      (lst (list 1 2 3))
      (vec (vector 1 2 (list 3 4))))
  (test "inc!.1" 11 (begin (inc! x)    x))
  (test "inc!.2" 21 (begin (inc! x 10) x))
  (test "dec!.1" 11 (begin (dec! x 10) x))
  (test "dec!.2" 10 (begin (dec! x)    x))

  (test "generalized inc!.1" '(1 2 4)
        (begin (inc! (list-ref lst 2)) lst))
  (test "generalized inc!.2" '(11 2 4)
        (begin (inc! (car lst) 10) lst))
  (test "generalized dec!.1" '(11 2 3)
        (begin (dec! (list-ref lst 2)) lst))
  (test "generalized dec!.2" '(1 2 3)
        (begin (dec! (car lst) 10) lst))
  (let ((l (vector-ref vec 2)))
    (test "generalized inc!.3" #(1 2 (45 4))
          (begin (inc! (car l) 42) vec))
    (test "generalized dec!.4" #(-1 2 (45 4))
          (begin (dec! (vector-ref vec 0) 2) vec))))

;;----------------------------------------------------------------------
(test-subsection "dolist")

(test "dolist"
      ""
      (with-output-to-string
        (lambda ()
          (dolist (x '()) (display x)))))

(test "dolist"
      #void
      (dolist (x '()) (display x)))

(test "dolist"
      "102030"
      (with-output-to-string
        (lambda ()
          (dolist (x '(10 20 30))
                  (display x)))))

;;----------------------------------------------------------------------
(test-subsection "(void)")

(test "void.1" #t (eq? (void) #void))
(test "void.2" #t (eq? (void 1 2 3) #void))
(test "void.3"
      '(-1 20 #void)
      (let ((x 1)
            (y 2))
        (let ((z (void (set! x -1)
                       (set! y (* y 10)))))
          (list x y z))))

;;----------------------------------------------------------------------
(test-subsection "syntax names in environment")

(test "syntax in env.1" '(1 2 3) (lambda (begin) (begin 1 2 3)) (lambda lambda lambda))
(test "syntax in env.2" 3 (lambda (_) (begin 1 2 3)) (lambda lambda lambda))


;;----------------------------------------------------------------------
(test-subsection "match-case & match-lambda")


(test "match-case.1"
      'bar
      (match-case '(a b a)
                  ((?x ?x) 'foo)
                  ((?x ?- ?x) 'bar)))

(test "match-case.2"
      '(length=3 d (b c) a)
      (match-case '(a (b c) d)
                  ((?x ?y) (list 'length=2 y x))
                  ((?x ?y ?z) (list 'length=3 z y x))))

(test "match-case.3"
      'bar
      (match-case '(a b c)
                  ((a (not (kwote b)) c) 'foo)
                  ((a (or (kwote a) (kwote b)) c) 'bar)))

(test "match-lambda.1"
      'bar
      ((match-lambda
         ((?x ?x) 'foo)
         ((?x ?- ?x) 'bar))
       '(a b a)))


(test "match-lambda.2"
      '(length=3 d (b c) a)
      ((match-lambda
         ((?x ?y) (list 'length=2 y x))
         ((?x ?y ?z) (list 'length=3 z y x)))
       '(a (b c) d)))

;;----------------------------------------------------------------------
(test-subsection "apropos")

(define (symbol<? s1 s2)
  (string<? (symbol->string s1) (symbol->string s2)))

(define-library (A)
  (export zeta-one)
  (begin (define zeta-one 1)
         (define zeta-two 2)
         (define theta-three 3)))
(define-library (B)
  (export zed)
  (begin (define zeta-two 2)
         (define zeta-three 3)
         (define theta-four 4)
         (define zed 5)))

(test "apropos.1"
      '(A B)
      (sort (map car (apropos/alist 'ze
                                    'A
                                    (find-module 'B)))
            symbol<?))

(test "apropos.2"
      '(A)
      (sort (map car (apropos/alist 'zeta
                                    (find-module 'A)
                                    "B"))
            symbol<?))


(test "apropos.3"
      '(1 1)
      (sort (map length
                 (map cadr (apropos/alist 'ze  'A 'B)))
            <))

(test "apropos.4"
      '(A . 1)
      (let ((x (apropos/alist "eta" (find-module 'A))))
        (cons (caar x) (length (cadar x)))))

(test "apropos.5"
      '()
      (apropos "x" (find-module 'A)
                   (find-module 'B)))
;; Changed #t to 'STklos, since it is too slow (more than 8s on my (old) i5)
;; This is normal: at the end of "make tests", the number of loaded modules
;; is really big
(test "apropos.6"
      #f
      (null? (apropos "a" 'STklos)))

(test/error "apropos.7" (apropos 'a 'b)) ; bad module list
(test/error "apropos.8" (apropos 5))     ; bad symbol / string
;; apropos/pp should return void:
;; changed again #t by 'STklos
(test "apropos.9" #void (let ((x #f))
                          (with-output-to-string ; suppress output, if any
                            (lambda ()
                              (set! x (apropos/pp "___blah___" 'STklos))))
                          x))

;------------------------------------------------------------------
(test-subsection "address-of")

(test "addresses-of symbol"
      #t
      (integer? (address-of 'a)))

(test "address-of string"
      #t
      (integer? (address-of "ABC")))

(test "address-of char"
      #t
      (integer? (address-of #\a)))

(test "address-of closure"
      #t
      (integer? (address-of (lambda () 2))))

(test "address-of void"
      #t
      (integer? (address-of #void)))


(test "address-of and read back, symbol"
      'a
      (read-from-string (format "#p~x" (address-of 'a))))

(test "address-of and read back, integer"
      -99
      (read-from-string (format "#p~x" (address-of -99))))

(test "address-of and read back, real"
      2.0
      (read-from-string (format "#p~x" (address-of 2.0))))

(test "address-of and read back, string"
      "xyz"
      (read-from-string (format "#p~x" (address-of "xyz"))))

(test "address-of and read back, date"
      #t
      (date? (read-from-string (format "#p~x" (address-of (current-date))))))


(test "read #pa 1010, ends in 10 but not char"
      -1
      (with-handler (lambda (x) -1) (read-from-string "#pa")))

(test "read #p1f tagged small constant, but too large"
      -1
      (with-handler (lambda (x) -1) (read-from-string "#p1f")))

(test "read #p9 = 10 01 = integer '2'"
      2
      (with-handler (lambda (x) -1) (read-from-string "#p9")))

(test "read #p0 = 00 = pointer to nowhere"
      -1
      (with-handler (lambda (x) -1) (read-from-string "#p0")))

(test "read #p4 = 1 00 = pointer to nowhere"
      -1
      (with-handler (lambda (x) -1) (read-from-string "#p4")))


(let ((mylist (list #void #f #t '() 0 1 (expt 2 500)
                    "abc" '(1 2 3) (list 10 20 30) #(1 2 3)
                    (current-time)
                    (lambda (x) -x))))
  (test "address-ref"
        mylist
        (map (lambda (thing) (address-ref (address-of thing)))
             mylist)))

(test "#p shouldn't crash"
      #void ;; return value from dotimes
      (dotimes (i  (expt 2 12)) ;; 12 so as to not slow down tests on older systems
        (with-handler (lambda (a) -1)
                      (eval-from-string (format "#p~a" i )))))

;------------------------------------------------------------------
(test-subsection "case insensitive read")

(test "read-from-string-ci.1"
      'abc
      (read-from-string-ci  "AbC"))

(test "read-from-string-ci.2"
      123
      (read-from-string-ci "123"))

(test "read-from-string (not ci).1"
      #f
      (eq?
       (string->symbol "AbC")
       (read-from-string-ci "AbC")))

(test "read-from-string (not ci).2"
      '|AbC|
      (read-from-string "AbC"))

(test "read-from-string (not ci).3"
      #t
      (eq?
       (string->symbol "AbC")
       (read-from-string "AbC")))

(test "read-ci"
      'abc
      (with-input-from-string "AbC" (lambda () (read-ci))))

(test "read (not ci)"
      '|AbC|
      (with-input-from-string "AbC" (lambda () (read))))

(test "eval-from-string-ci.1"
      8
      (eval-from-string-ci "(SqRt 64)"))

(test "eval-from-string-ci.2"
      "3.14"
      (with-output-to-string (lambda () (eval-from-string-ci "(DisPlaY 3.14)"))))


(test/error "eval-from-string (no ci)"
            (eval-from-string "(DisPlaY 3.14)"))


;;------------------------------------------------------------------
(test-section-end)
