get-setf-expansion.lsp 1.49 KB
Newer Older
1 2 3 4 5 6 7 8
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Mon Jan 13 17:05:17 2003
;;;; Contains: Tests for GET-SETF-EXPANSION

(in-package :cl-test)

(deftest get-setf-expansion.error.1
9 10
  (signals-error (get-setf-expansion) program-error)
  t)
11 12

(deftest get-setf-expansion.error.2
13 14
  (signals-error (get-setf-expansion 'x nil nil) program-error)
  t)
15

16
;;; FIXME
17
;;; Tests for proper behavior will go here
18 19 20 21 22 23 24 25 26
;;; There are tests in DEFINE-SETF-EXPANDER too

;;; For a function on which the setf expansion is otherwise
;;; undefined, produce a call to #'(setf <fn>).  Note: this
;;; form has to be present, since portable code walkers may
;;; grovel over the setf expansion (sorry, clisp).

(deftest get-setf-expansion.1
  (let* ((fn (gensym))
sds's avatar
sds committed
27
         (vals (multiple-value-list (get-setf-expansion (list fn)))))
28 29 30 31 32 33 34
    (values
     (length vals)
     (first  vals)
     (second vals)
     (length (third vals))
     (block done
       (subst-if nil
sds's avatar
sds committed
35 36 37 38
                 #'(lambda (term)
                     (when (equal term `(function (setf ,fn)))
                       (return-from done :good)))
                 (fourth vals)))
39
     (if (equal (fifth vals) (list fn))
sds's avatar
sds committed
40
         :good
41 42 43 44 45
       (fifth vals))))
  5 nil nil 1 :good :good)

(deftest get-setf-expansion.2
  (let* ((fn (gensym))
sds's avatar
sds committed
46
         (vals (multiple-value-list (get-setf-expansion (list fn) nil))))
47 48 49 50 51
    (length vals))
  5)

(deftest get-setf-expansion.3
  (let* ((var (gensym))
sds's avatar
sds committed
52
         (vals (multiple-value-list (get-setf-expansion var))))
53 54
    (length vals))
  5)