source: trunk/source/tests/ansi-tests/defun.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 11 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 3.0 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sun Feb 16 23:40:32 2003
4;;;; Contains: Tests of DEFUN
5
6(in-package :cl-test)
7
8
9;;; Tests for implicit blocks
10
11(defun defun-test-fun-1 ()
12  (return-from defun-test-fun-1 'good))
13
14(deftest defun.1
15  (defun-test-fun-1)
16  good)
17
18(defun defun-test-fun-2 ()
19  (return-from defun-test-fun-2 (values)))
20
21(deftest defun.2
22  (defun-test-fun-2))
23
24(defun defun-test-fun-3 ()
25  (return-from defun-test-fun-3 (values 'a 'b 'c 'd 'e 'f)))
26
27(deftest defun.3
28  (defun-test-fun-3)
29  a b c d e f)
30
31(defun defun-test-fun-4 (x)
32  (car x))
33
34(deftest defun.4
35  (let ((x (list 'a 'b)))
36    (values
37     (setf (defun-test-fun-4 x) 'c)
38     x))
39  c
40  (c b))
41
42(report-and-ignore-errors
43 (defun (setf defun-test-fun-4) (newval x)
44   (return-from defun-test-fun-4 (setf (car x) newval))))
45
46(deftest defun.5
47  (let ((x 1))
48    (declare (special x))
49    (let ((x 2))
50      (defun defun-test-fun-5 (&aux (y x))
51        (declare (special x))
52        (values y x))
53      (defun-test-fun-5)))
54  2 1)
55
56(deftest defun.6
57  (let ((x 1))
58    (declare (special x))
59    (let ((x 2))
60      (defun defun-test-fun-5 (&optional (y x))
61        (declare (special x))
62        (values y x))
63      (defun-test-fun-5)))
64  2 1)
65
66(deftest defun.7
67  (let ((x 1))
68    (declare (special x))
69    (let ((x 2))
70      (defun defun-test-fun-5 (&key (y x))
71        (declare (special x))
72        (values y x))
73      (defun-test-fun-5)))
74  2 1)
75
76;; Documentation
77
78(deftest defun.8
79  (let* ((sym (gensym))
80         (doc "DEFUN.8")
81         (form `(defun ,sym () ,doc nil)))
82    (or (documentation sym 'function) doc))
83  "DEFUN.8")
84
85;;; Error tests
86
87(deftest defun.error.1
88  (signals-error (funcall (macro-function 'defun))
89                 program-error)
90  t)
91
92(deftest defun.error.2
93  (signals-error (funcall (macro-function 'defun)
94                           '(defun nonexistent-function ()))
95                 program-error)
96  t)
97
98(deftest defun.error.3
99  (signals-error (funcall (macro-function 'defun)
100                           '(defun nonexistent-function ())
101                           nil nil)
102                 program-error)
103  t)
104
105;;; More comprehensive error handling tests of calls to
106;;; user-defined functions
107
108(deftest defun.error.4
109  (let* ((name (gensym)))
110    (loop for i below (min 100 lambda-parameters-limit)
111          for params = nil then (cons (gensym) params)
112          for args = nil then (cons nil args)
113          for expected = '(1 2 3)
114          for fn = (eval `(prog2 (proclaim '(optimize (safety 0)))
115                                 (defun ,name ,params (values ,@expected))
116                                 (proclaim '(optimize safety))))
117          when
118          (cond
119           ((not (equal (multiple-value-list (apply fn args)) expected))
120            (list i :fail1))
121           ((not (equal (multiple-value-list
122                         (apply (symbol-function fn) args))
123                        expected))
124            (list i :fail2))
125           ((not (equal (multiple-value-list (eval `(,name ,@args)))
126                        expected))
127            (list i :fail3))
128           ;; Error cases
129           ((and (> i 0)
130                 (let ((val (eval `(signals-error (,name ,@(cdr args)) program-error))))
131                   (and (not (eq val t)) :fail4))))
132           ((and (< i (1- call-arguments-limit))
133                 (let ((val (eval `(signals-error (,name nil ,@args) program-error))))
134                   (and (not (eq val t)) :fail5)))))
135          collect it))
136  nil)
137
Note: See TracBrowser for help on using the repository browser.