From 2634960b306d1076f3dc188bacdf32fddba4ccd6 Mon Sep 17 00:00:00 2001
From: pfdietz <pfdietz@localhost>
Date: Sun, 26 Dec 2004 15:58:08 +0000
Subject: [PATCH] Error handling of calls to user-defined functions

---
 ansi-tests/defun.lsp | 70 +++++++++++++++++++++++++++++++++-----------
 1 file changed, 53 insertions(+), 17 deletions(-)

diff --git a/ansi-tests/defun.lsp b/ansi-tests/defun.lsp
index 5ac3508d..9b4e3299 100644
--- a/ansi-tests/defun.lsp
+++ b/ansi-tests/defun.lsp
@@ -5,23 +5,6 @@
 
 (in-package :cl-test)
 
-(deftest defun.error.1
-  (signals-error (funcall (macro-function 'defun))
-		 program-error)
-  t)
-
-(deftest defun.error.2
-  (signals-error (funcall (macro-function 'defun)
-			   '(defun nonexistent-function ()))
-		 program-error)
-  t)
-
-(deftest defun.error.3
-  (signals-error (funcall (macro-function 'defun)
-			   '(defun nonexistent-function ())
-			   nil nil)
-		 program-error)
-  t)
 
 ;;; Tests for implicit blocks
 
@@ -60,3 +43,56 @@
  (defun (setf defun-test-fun-4) (newval x)
    (return-from defun-test-fun-4 (setf (car x) newval))))
 
+;;; Error tests
+
+(deftest defun.error.1
+  (signals-error (funcall (macro-function 'defun))
+		 program-error)
+  t)
+
+(deftest defun.error.2
+  (signals-error (funcall (macro-function 'defun)
+			   '(defun nonexistent-function ()))
+		 program-error)
+  t)
+
+(deftest defun.error.3
+  (signals-error (funcall (macro-function 'defun)
+			   '(defun nonexistent-function ())
+			   nil nil)
+		 program-error)
+  t)
+
+;;; More comprehensive error handling tests of calls to
+;;; user-defined functions
+
+(deftest defun.error.4
+  (let* ((name (gensym)))
+    (loop for i below (min 100 lambda-parameters-limit)
+	  for params = nil then (cons (gensym) params)
+	  for args = nil then (cons nil args)
+	  for expected = '(1 2 3)
+	  for fn = (eval `(prog2 (proclaim '(optimize (safety 0)))
+				 (defun ,name ,params (values ,@expected))
+				 (proclaim '(optimize safety))))
+	  when
+	  (cond
+	   ((not (equal (multiple-value-list (apply fn args)) expected))
+	    (list i :fail1))
+	   ((not (equal (multiple-value-list
+			 (apply (symbol-function fn) args))
+			expected))
+	    (list i :fail2))
+	   ((not (equal (multiple-value-list (eval `(,name ,@args)))
+			expected))
+	    (list i :fail3))
+	   ;; Error cases
+	   ((and (> i 0)
+		 (let ((val (eval `(signals-error (,name ,@(cdr args)) program-error))))
+		   (and (not (eq val t)) :fail4))))
+	   ((and (< i (1- call-arguments-limit))
+		 (let ((val (eval `(signals-error (,name nil ,@args) program-error))))
+		   (and (not (eq val t)) :fail5)))))
+	  collect it))
+  nil)
+
-- 
GitLab