Merge remote-tracking branch 'origin/stable-2.0'

[bpt/guile.git] / test-suite / tests / eval.test

diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test
index a5fbfec..24afe2d 100644 (file)
--- a/test-suite/tests/eval.test
+++ b/test-suite/tests/eval.test
@@ -334,50 +334,64 @@
           1+
           0))
 
+(define (make-tagged-trimmed-stack tag spec)
+  (catch 'result
+    (lambda ()
+      (call-with-prompt
+        tag
+        (lambda ()
+          (with-throw-handler 'wrong-type-arg
+            (lambda () (substring 'wrong 'type 'arg))
+            (lambda _ (throw 'result (apply make-stack spec)))))
+        (lambda () (throw 'make-stack-failed))))
+    (lambda (key result) result)))
+
+(define tag (make-prompt-tag "foo"))
+
 (with-test-prefix "stacks"
   (pass-if "stack involving a primitive"
     ;; The primitive involving the error must appear exactly once on the
     ;; stack.
-    (catch 'result
-      (lambda ()
-        (start-stack 'foo
-                     (with-throw-handler 'wrong-type-arg
-                       (lambda ()
-                         ;; Trigger a `wrong-type-arg' exception.
-                         (hashq-ref 'wrong 'type 'arg))
-                       (lambda _
-                         (let* ((stack  (make-stack #t))
-                                (frames (stack->frames stack)))
-                           (throw 'result
-                                  (count (lambda (frame)
-                                           (eq? (frame-procedure frame)
-                                                hashq-ref))
-                                         frames)))))))
-      (lambda (key result)
-        (= 1 result))))
+    (let* ((stack (make-tagged-trimmed-stack tag '(#t)))
+           (frames (stack->frames stack))
+           (num (count (lambda (frame) (eq? (frame-procedure frame)
+                                       substring))
+                       frames)))
+      (= num 1)))
 
   (pass-if "arguments of a primitive stack frame"
     ;; Create a stack with two primitive frames and make sure the
     ;; arguments are correct.
-    (catch 'result
-      (lambda ()
-        (start-stack 'foo
-                     (with-throw-handler 'wrong-type-arg
-                       (lambda ()
-                         ;; Trigger a `wrong-type-arg' exception.
-                         (substring 'wrong 'type 'arg))
-                       (lambda _
-                         (let* ((stack  (make-stack #t))
-                                (frames (stack->frames stack)))
-                           (throw 'result
-                                  (map (lambda (frame)
-                                         (cons (frame-procedure frame)
-                                               (frame-arguments frame)))
-                                       frames)))))))
-      (lambda (key result)
-        (and (equal? (car result) `(,make-stack #t))
-             (pair? (member `(,substring  wrong type arg)
-                            (cdr result))))))))
+    (let* ((stack (make-tagged-trimmed-stack tag '(#t)))
+           (call-list (map (lambda (frame)
+                             (cons (frame-procedure frame)
+                                   (frame-arguments frame)))
+                           (stack->frames stack))))
+      (and (equal? (car call-list) `(,make-stack #t))
+           (pair? (member `(,substring wrong type arg)
+                          (cdr call-list))))))
+
+  (pass-if "inner trim with prompt tag"
+    (let* ((stack (make-tagged-trimmed-stack tag `(#t ,tag)))
+           (frames (stack->frames stack)))
+      ;; the top frame on the stack is the lambda inside the 'catch, and the
+      ;; next frame is the (catch 'result ...)
+      (and (eq? (frame-procedure (cadr frames))
+                catch)
+           (eq? (car (frame-arguments (cadr frames)))
+                'result))))
+
+  (pass-if "outer trim with prompt tag"
+    (let* ((stack (make-tagged-trimmed-stack tag `(#t 0 ,tag)))
+           (frames (stack->frames stack)))
+      ;; the top frame on the stack is the make-stack call, and the last
+      ;; frame is the (with-throw-handler 'wrong-type-arg ...)
+      (and (eq? (frame-procedure (car frames))
+                make-stack)
+           (eq? (frame-procedure (car (last-pair frames)))
+                with-throw-handler)
+           (eq? (car (frame-arguments (car (last-pair frames))))
+                'wrong-type-arg)))))
 
 ;;;
 ;;; letrec init evaluation
@@ -427,6 +441,36 @@
           (thunk (let loop () (cons 's (loop)))))
       (call-with-vm vm thunk))))
 
+;;;
+;;; docstrings
+;;;
+
+(with-test-prefix "docstrings"
+
+  (pass-if-equal "fixed closure"
+      '("hello" "world")
+    (map procedure-documentation
+         (list (eval '(lambda (a b) "hello" (+ a b))
+                     (current-module))
+               (eval '(lambda (a b) "world" (- a b))
+                     (current-module)))))
+
+  (pass-if-equal "fixed closure with many args"
+      "So many args."
+    (procedure-documentation
+     (eval '(lambda (a b c d e f g h i j k)
+              "So many args."
+              (+ a b))
+           (current-module))))
+
+  (pass-if-equal "general closure"
+      "How general."
+    (procedure-documentation
+     (eval '(lambda* (a b #:key k #:rest r)
+              "How general."
+              (+ a b))
+           (current-module)))))
+
 ;;;
 ;;; local-eval
 ;;;