[nongnu] elpa/geiser-stklos 091aa5e 07/30: A very small quantity of tests...

[Philip Kaludercic]

branch: elpa/geiser-stklos
commit 091aa5e1faa4081fc01ceb531e590068331d9463
Author: Jeronimo Pellegrini <j_p@aleph0.info>
Commit: Jeronimo Pellegrini <j_p@aleph0.info>

    A very small quantity of tests...
    
    STklos-side only for now
---
 Makefile               |   6 +++
 geiser-stklos-test.stk |  93 +++++++++++++++++++++++++++++++++++
 geiser-stklos.el       |   7 ++-
 geiser.stk             |  18 +++----
 test.stk               | 131 +++++++++++++++++++++++++++++++++++++++++++++++++
 5 files changed, 244 insertions(+), 11 deletions(-)

diff --git a/Makefile b/Makefile
new file mode 100644
index 0000000..2c3aad0
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,6 @@
+all:
+       @echo "There is no need to call make ot install Geiser-STklos."
+       @echo "You can call 'make test' to test it, though."
+
+test:
+       stklos --no-init-file --utf8-encoding=yes -f geiser-stklos-test.stk
diff --git a/geiser-stklos-test.stk b/geiser-stklos-test.stk
new file mode 100644
index 0000000..c8c16a4
--- /dev/null
+++ b/geiser-stklos-test.stk
@@ -0,0 +1,93 @@
+
+(load "./test.stk")
+(load "./geiser.stk")
+
+(test-init "TEST.LOG")
+
+(test-section "Geiser-STklos tests")
+
+;;; We will also need to test the other (non-exported)
+;;; procedures, like "call-with-result"
+
+(test-subsection "geiser:* procedures")
+
+(define l (load-path))
+(test "geiser:add-to-load-path"
+      (cons "some-path" l)
+      (begin (geiser:add-to-load-path "some-path")
+             (load-path)))
+
+
+(define-syntax g-macro
+  (syntax-rules ()
+    ((_ a b) (g a b))))
+      
+(test "geiser:macroexpand"
+      "(g 1 2)"
+      (geiser:macroexpand '(g-macro 1 2)))
+
+
+(define-module modified-modular-module
+  (export symbolic-symbol
+          heartless-horse-rehearsal
+          syntactic-synthesize-synchronicities
+          procedural-precedence-precaution)
+  (define symbolic-symbol 's)
+  (define heartless-horse-rehearsal -1)
+  (define hideous-hidden-hindrance "h")
+  (define-syntax syntactic-synthesize-synchronicities
+    (syntax-rules ()
+      ((_) 'SYNC)))
+  (define procedural-precedence-precaution
+    (lambda () '())))
+
+(test "geiser:module-completions"
+      #f
+      (not (member "stklos"
+                   (geiser:module-completions "s"))))
+
+(test "geiser:module-completions"
+      #f
+      (not (member "SRFI-0"
+                   (geiser:module-completions "S"))))
+
+(test "geiser:module-completions"
+      #f
+      (not (member "modified-modular-module"
+                   (geiser:module-completions "modi"))))
+
+
+(test "geiser:module-exports"
+      '(list ("modules")
+             ("procs" (procedural-precedence-precaution))
+             ("syntax" (syntactic-synthesize-synchronicities))
+             ("vars" (symbolic-symbol) (heartless-horse-rehearsal)))
+      (geiser:module-exports 'modified-modular-module))
+
+(define defying-definitive-definition 10)
+(define depth-depriving-dependence 20)
+(define (ex-executable-executive)
+  'EXECUTED)
+
+(test "geiser:completions"
+      '(#f #f #t)
+      (let ((completions (geiser:completions "de")))
+        (map (lambda (x) (not (member x completions)))
+             '("defying-definitive-definition"
+               "depth-depriving-dependence"
+               "dense-dental-denying-denardo"))))
+
+
+(test "geiser:completions 2"
+      #f
+      (not (member "ex-executable-executive"
+                   (geiser:completions "e"))))
+        
+
+(test "geiser:no-values"
+      (values)
+      (geiser:no-values))
+
+(test-section-end)
+
+(test-end)
diff --git a/geiser-stklos.el b/geiser-stklos.el
index 1be3862..00b20a3 100644
--- a/geiser-stklos.el
+++ b/geiser-stklos.el
@@ -298,10 +298,13 @@ This function uses `geiser-stklos-init-file' if it 
exists."
   (display-error          geiser-stklos--display-error)
   ;; (external-help geiser-stklos--manual-look-up) ;; cannot easily search by 
keyword
   (check-buffer           geiser-stklos--guess)
-  (keywords               geiser-stklos--keywords)      ; ok
-  (case-sensitive         geiser-stklos-case-sensitive) ; ok
+  (keywords               geiser-stklos--keywords)       ; ok
+  (case-sensitive         geiser-stklos-case-sensitive)  ; ok
+  (unsupported            '(autodoc callers callees))    ; doesn't seem to 
make any difference?
   )
 
+;; STklos files are .stk, and we may wat to open .scm files with STklos also:
+;;
 (geiser-impl--add-to-alist 'regexp "\\.scm$" 'stklos t)
 (geiser-impl--add-to-alist 'regexp "\\.stk$" 'stklos t)
 
diff --git a/geiser.stk b/geiser.stk
index 927a8b8..9746388 100644
--- a/geiser.stk
+++ b/geiser.stk
@@ -108,15 +108,15 @@
       (write-to-log form)
       (call-with-result thunk))))
 
-  ;; Load a file
-
-  (define (geiser:load-file file)
-    (let* ((file (if (symbol? file) (symbol->string file) file))
-           (found-file (geiser-find-file file)))
-      (call-with-result
-       (lambda ()
-         (when found-file
-           (load found-file))))))
+;; Load a file
+
+(define (geiser:load-file file)
+  (let* ((file (if (symbol? file) (symbol->string file) file))
+         (found-file (geiser-find-file file)))
+    (call-with-result
+     (lambda ()
+       (when found-file
+         (load found-file))))))
 
 ;; Geiser calls this function to add a string to STklos'
 ;; load path
diff --git a/test.stk b/test.stk
new file mode 100644
index 0000000..e45865f
--- /dev/null
+++ b/test.stk
@@ -0,0 +1,131 @@
+;;;;
+;;;; test.stk   -- STklos regression testing
+;;;;
+;;;; Copyright © 2005-2020 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
+;;;;
+;;;;
+;;;; 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@essi.fr]
+;;;;    Creation date:  3-May-2005 11:19 (eg)
+;;;; Last file update:  3-Jul-2020 12:14 (eg)
+;;;;
+
+(define *all-errors* '())
+(define *log* (current-output-port))
+(define *err* (current-error-port))
+(define *test-failed* (vector 'fail))
+(define *test-counter* 0)
+(define *test-ko* 0)
+
+;; ----------------------------------------------------------------------
+;;  %tester ...
+;; ----------------------------------------------------------------------
+(define (%tester message expect thunk code compare)
+  (format *log* "  testing ~A expects ~S ==> " message expect)
+  (flush-output-port)
+  (let ((res (with-handler
+            (lambda (c) *test-failed*)
+        (thunk))))
+    (set! *test-counter* (+ *test-counter* 1))
+    (if (compare expect res)
+    (format *log* "OK.\n")
+    (begin
+      (set! *test-ko* (+ *test-ko* 1))
+      (format *log* "ERROR: got ~S.\n" res)
+      (set! *all-errors* (cons (list message code expect res)
+                   *all-errors*)))))
+  (flush-output-port *log*))
+
+;; ----------------------------------------------------------------------
+;;  test-init ...
+;; ----------------------------------------------------------------------
+(define (test-init log-file)
+  (let ((port (open-output-file log-file)))
+    (set! *log* port)))
+
+;; ----------------------------------------------------------------------
+;;  test-end ...
+;; ----------------------------------------------------------------------
+(define (test-end)
+  (for-each (lambda (port)
+          (format port "~A\n" (make-string 70 #\-))
+          (format port "Number of tests: ~A (OK: ~A Error: ~A)\n"
+               *test-counter* (- *test-counter* *test-ko*) *test-ko*)
+          (format port "   Elapsed Time: ~Ams\n"
+              (inexact->exact (round (clock))))
+          (format port "*** End of tests ***\n")
+          (close-output-port port))
+        (list *log* *err*))
+  (exit (if (positive? *test-ko*) 1 0)))
+
+;; ----------------------------------------------------------------------
+;;  test-section ...
+;; ----------------------------------------------------------------------
+(define (test-section msg)
+  (let* ((s   (format "==== Testing ~a " msg))
+     (len (string-length s)))
+    (set! *all-errors* '())
+    ;; Log
+    (format *log* "~a ~a\n" s (make-string (- 70 len) #\=))
+    (flush-output-port *log*)
+    ;; Output
+    (format *err* "~a ... ~a" s (make-string (- 60 len) #\space))
+    (flush-output-port *err*)))
+
+;; ----------------------------------------------------------------------
+;;  test-section-end ...
+;; ----------------------------------------------------------------------
+(define (test-section-end)
+  (define (fmt . args)
+    (apply format *log* args)
+    (apply format *err* args)
+    (flush-output-port *log*)
+    (flush-output-port *err*))
+
+  (if (null? *all-errors*)
+      (fmt "passed\n")
+      (begin
+    (fmt "failed\n")
+    (fmt "Errors found in this section:\n")
+    (for-each (lambda (x) (apply fmt "test ~a on ~S expected ~S but got ~S\n" 
x))
+          (reverse! *all-errors*)))))
+
+;; ----------------------------------------------------------------------
+;;  test-subsection ...
+;; ----------------------------------------------------------------------
+(define (test-subsection msg)
+  (let* ((s (format "---- ~a " msg))
+     (len (string-length s)))
+  (format *log* "~a ~a\n" msg (make-string (- 70 len) #\=))
+  (flush-output-port *log*)))
+
+;; ----------------------------------------------------------------------
+;;  test ...
+;; ----------------------------------------------------------------------
+(define-macro (test msg expect expr :optional (compare equal?))
+  `(%tester ,msg ,expect (lambda () ,expr) ',expr ,compare))
+
+;; ----------------------------------------------------------------------
+;; test/error ...
+;; ----------------------------------------------------------------------
+
+(define-syntax test/error
+  (syntax-rules ()
+    ((_ str code)
+     (test str *test-failed* result))))
+
+(provide "test")