branch: elpa/geiser-stklos
commit 091aa5e1faa4081fc01ceb531e590068331d9463
Author: Jeronimo Pellegrini <j...@aleph0.info>
Commit: Jeronimo Pellegrini <j...@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 <e...@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 [e...@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")
