From 361846e40869ec099e90d89128e2f4a2eec82297 Mon Sep 17 00:00:00 2001
From: pfdietz <pfdietz@localhost>
Date: Wed, 9 Oct 2002 12:28:17 +0000
Subject: [PATCH] Added tests for FLET.

---
 ansi-tests/aux.lsp      |  35 ++++++++-----
 ansi-tests/flet.lsp     | 112 ++++++++++++++++++++++++++++++++++++++++
 ansi-tests/gclload2.lsp |   1 +
 3 files changed, 135 insertions(+), 13 deletions(-)
 create mode 100644 ansi-tests/flet.lsp

diff --git a/ansi-tests/aux.lsp b/ansi-tests/aux.lsp
index 6b615ccc..b8d25612 100644
--- a/ansi-tests/aux.lsp
+++ b/ansi-tests/aux.lsp
@@ -65,7 +65,7 @@
    (error (c) c)))
 |#
 
-;; Use the next macro in place of SAFE
+;;; Use the next macro in place of SAFE
 
 (defmacro catch-type-error (form)
 "Evaluate form in safe mode, returning its value if there is no error.
@@ -76,12 +76,21 @@ condition itself on other errors."
      (type-error () 'type-error)
      (error (c) c))))
 
-;;
-;; A scaffold is a structure that is used to remember the object
-;; identities of the cons cells in a (noncircular) data structure.
-;; This lets us check if the data structure has been changed by
-;; an operation.
-;;
+(defmacro classify-error (form)
+"Evaluate form in safe mode, returning its value if there is no error.
+If an error does occur, return a symbol classify the error, or allow
+the condition to go uncaught if it cannot be classified."
+`(locally (declare (optimize (safety 3)))
+  (handler-case ,form
+     (program-error () 'program-error)
+     (type-error    () 'type-error))))
+
+;;;
+;;; A scaffold is a structure that is used to remember the object
+;;; identities of the cons cells in a (noncircular) data structure.
+;;; This lets us check if the data structure has been changed by
+;;; an operation.
+;;;
 
 (defstruct scaffold
   node
@@ -112,11 +121,11 @@ condition itself on other errors."
 	 (check-scaffold-copy (cdr x) (scaffold-cdr xcopy))))))
 
 
-;;
-;; The function SUBTYPEP returns two generalized booleans.
-;; This auxiliary function returns two booleans instead
-;; (which makes it easier to write tests).
-;;
+;;;
+;;; The function SUBTYPEP returns two generalized booleans.
+;;; This auxiliary function returns two booleans instead
+;;; (which makes it easier to write tests).
+;;;
 (defun subtypep* (obj type)
   (multiple-value-bind (result good)
       (subtypep obj type)
@@ -169,7 +178,7 @@ condition itself on other errors."
   "Flip an n-sided coin."
   (eql (random n) 0))
 
-;; Randomly permute a sequence
+;;; Randomly permute a sequence
 (defun random-permute (seq)
   (setq seq (copy-seq seq))
   (let ((len (length seq)))
diff --git a/ansi-tests/flet.lsp b/ansi-tests/flet.lsp
new file mode 100644
index 00000000..525aeca0
--- /dev/null
+++ b/ansi-tests/flet.lsp
@@ -0,0 +1,112 @@
+;-*- Mode:     Lisp -*-
+;;;; Author:   Paul Dietz
+;;;; Created:  Tue Oct  8 22:55:02 2002
+;;;; Contains: Tests of FLET
+
+(in-package :cl-test)
+
+(deftest flet.1
+  (flet ((%f () 1))
+    (%f))
+  1)
+
+(deftest flet.2
+  (flet ((%f (x) x))
+    (%f 2))
+  2)
+
+(deftest flet.3
+  (flet ((%f (&rest args) args))
+    (%f 'a 'b 'c))
+  (a b c))
+
+;;; The optional arguments are not in the block defined by
+;;; the local function declaration
+(deftest flet.4
+  (block %f
+    (flet ((%f (&optional (x (return-from %f 10)))
+	       20))
+      (%f)))
+  10)
+
+(deftest flet.5
+  (flet ((%f () (return-from %f 15) 35))
+    (%f))
+  15)
+
+;;; The aux parameters are not in the block defined by
+;;; the local function declaration
+(deftest flet.6
+  (block %f
+    (flet ((%f (&aux (x (return-from %f 10)))
+	       20))
+      (%f)))
+  10)
+
+;;; The function is not visible inside itself
+(deftest flet.7
+  (flet ((%f (x) (+ x 5)))
+    (flet ((%f (y) (cond ((eql y 20) 30)
+			 (t (%f 20)))))
+      (%f 15)))
+  25)
+
+;;; Keyword arguments
+(deftest flet.8
+  (flet ((%f (&key a (b 0 b-p)) (values a b (not (not b-p)))))
+    (%f))
+  nil 0 nil)
+
+(deftest flet.9
+  (flet ((%f (&key a (b 0 b-p)) (values a b (not (not b-p)))))
+    (%f :a 1))
+  1 0 nil)
+
+(deftest flet.10
+  (flet ((%f (&key a (b 0 b-p)) (values a b (not (not b-p)))))
+    (%f :b 2))
+  nil 2 t)
+
+(deftest flet.11
+  (flet ((%f (&key a (b 0 b-p)) (values a b (not (not b-p)))))
+    (%f :b 2 :a 3))
+  3 2 t)
+
+;;; Unknown keyword parameter should throw a program-error in safe code
+;;; (section 3.5.1.4)
+(deftest flet.12
+  (classify-error
+   (flet ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) (%f :c 4)))
+  program-error)
+
+;;; Odd # of keyword args should throw a program-error in safe code
+;;; (section 3.5.1.6)
+(deftest flet.13
+  (classify-error
+   (flet ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) (%f :a)))
+  program-error)
+
+;;; Too few arguments (section 3.5.1.2)
+(deftest flet.14
+  (classify-error (flet ((%f (a) a)) (%f)))
+  program-error)
+
+;;; Too many arguments (section 3.5.1.3)
+(deftest flet.15
+  (classify-error (flet ((%f (a) a)) (%f 1 2)))
+  program-error)
+
+;;; Invalid keyword argument (section 3.5.1.5)
+(deftest flet.16
+  (classify-error (flet ((%f (&key a) a)) (%f '(foo))))
+  program-error)
+
+
+    
+
+
+
+
+
+
+
diff --git a/ansi-tests/gclload2.lsp b/ansi-tests/gclload2.lsp
index 1daa7411..e1879878 100644
--- a/ansi-tests/gclload2.lsp
+++ b/ansi-tests/gclload2.lsp
@@ -9,6 +9,7 @@
 (load "constantly.lsp")
 (load "complement.lsp")
 (load "fboundp.lsp")
+(load "flet.lsp")
 (load "fmakunbound.lsp")
 (load "function.lsp")
 (load "functionp.lsp")
-- 
GitLab