intern.lsp 5.74 KB
Newer Older
1 2 3
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sat Apr 25 07:59:10 1998
4
;;;; Contains: Tests of INTERN
5 6 7 8 9 10 11

(in-package :cl-test)
(declaim (optimize (safety 3)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; intern

12
(deftest intern.1
13 14
  (progn
    (safely-delete-package "TEMP1")
15
    (let ((p (make-package "TEMP1" :use nil))
sds's avatar
sds committed
16
          (i 0) x y)
17
      (multiple-value-bind* (sym1 status1)
sds's avatar
sds committed
18 19 20 21 22 23 24 25 26 27 28 29 30 31
          (find-symbol "FOO" p)
        (intern (progn (setf x (incf i)) "FOO")
                (progn (setf y (incf i)) p))
        (multiple-value-bind* (sym2 status2)
            (find-symbol "FOO" p)
          (and (eql i 2)
               (eql x 1)
               (eql y 2)
               (null sym1)
               (null status1)
               (string= (symbol-name sym2) "FOO")
               (eqt (symbol-package sym2) p)
               (eqt status2 :internal)
               (progn (delete-package p) t))))))
32 33
  t)

34
(deftest intern.2
35 36
  (progn
    (safely-delete-package "TEMP1")
37
    (let ((p (make-package "TEMP1" :use nil)))
38
      (multiple-value-bind* (sym1 status1)
sds's avatar
sds committed
39 40 41 42 43 44 45 46 47 48
          (find-symbol "FOO" "TEMP1")
        (intern "FOO" "TEMP1")
        (multiple-value-bind* (sym2 status2)
            (find-symbol "FOO" p)
          (and (null sym1)
               (null status1)
               (string= (symbol-name sym2) "FOO")
               (eqt (symbol-package sym2) p)
               (eqt status2 :internal)
               (progn (delete-package p) t))))))
49
  t)
50

51
(deftest intern.3
52
  :notes (:nil-vectors-are-strings)
53 54
  (let ((cl-user-package (find-package "CL-USER")))
    (eqt (intern "" cl-user-package)
sds's avatar
sds committed
55
         (intern (make-array 0 :element-type nil) cl-user-package)))
56 57 58 59 60
  t)

(deftest intern.4
  (let ((cl-user-package (find-package "CL-USER")))
    (eqt (intern (make-array 5 :element-type 'character
sds's avatar
sds committed
61 62 63
                             :initial-contents "XYZZY") cl-user-package)
         (intern (make-array 5 :element-type 'base-char
                             :initial-contents "XYZZY") cl-user-package)))
64 65
  t)

66 67 68
;;; String is a specialized sequence type

(defmacro def-intern-test (test-name &key (symbol-name "FOO")
sds's avatar
sds committed
69
                                     (package-name "TEMP1"))
70 71
  `(deftest ,test-name
     (let ((sname ,symbol-name)
sds's avatar
sds committed
72
           (pname ,package-name))
73 74
       (safely-delete-package pname)
       (let ((p (make-package pname :use nil)))
sds's avatar
sds committed
75 76 77 78 79 80 81 82 83 84 85 86 87
         (multiple-value-bind*
          (sym1 status1)
          (find-symbol sname pname)
          (intern sname pname)
          (multiple-value-bind*
           (sym2 status2)
           (find-symbol sname p)
           (and (null sym1)
                (null status1)
                (string= (symbol-name sym2) sname)
                (eqt (symbol-package sym2) p)
                (eqt status2 :internal)
                (progn (delete-package p) t))))))
88 89 90 91
     t))

(def-intern-test intern.5
  :symbol-name (make-array 3 :element-type 'base-char
sds's avatar
sds committed
92
                           :initial-contents "BAR"))
93 94 95

(def-intern-test intern.6
  :symbol-name (make-array 13 :element-type 'base-char
sds's avatar
sds committed
96 97
                           :fill-pointer 3
                           :initial-contents "BAR1234567890"))
98 99 100

(def-intern-test intern.7
  :symbol-name (make-array 13 :element-type 'character
sds's avatar
sds committed
101 102
                           :fill-pointer 3
                           :initial-contents "BAR1234567890"))
103 104 105

(def-intern-test intern.8
  :symbol-name (make-array 3 :element-type 'base-char
sds's avatar
sds committed
106 107
                           :adjustable t
                           :initial-contents "BAR"))
108 109 110

(def-intern-test intern.9
  :symbol-name (make-array 3 :element-type 'character
sds's avatar
sds committed
111 112
                           :adjustable t
                           :initial-contents "BAR"))
113 114 115 116

(def-intern-test intern.10
  :symbol-name
  (let* ((etype 'base-char)
sds's avatar
sds committed
117 118
         (name0 (make-array 8 :element-type etype
                            :initial-contents "XBARYYYY")))
119
    (make-array 3 :element-type etype :displaced-to name0
sds's avatar
sds committed
120
                :displaced-index-offset 1)))
121 122 123 124

(def-intern-test intern.11
  :symbol-name
  (let* ((etype 'character)
sds's avatar
sds committed
125 126
         (name0 (make-array 8 :element-type etype
                            :initial-contents "XBARYYYY")))
127
    (make-array 3 :element-type etype :displaced-to name0
sds's avatar
sds committed
128
                :displaced-index-offset 1)))
129 130 131

(def-intern-test intern.12
  :package-name (make-array 3 :element-type 'base-char
sds's avatar
sds committed
132
                           :initial-contents "BAR"))
133 134 135

(def-intern-test intern.13
  :package-name (make-array 13 :element-type 'base-char
sds's avatar
sds committed
136 137
                           :fill-pointer 3
                           :initial-contents "BAR1234567890"))
138 139 140

(def-intern-test intern.14
  :package-name (make-array 13 :element-type 'character
sds's avatar
sds committed
141 142
                           :fill-pointer 3
                           :initial-contents "BAR1234567890"))
143 144 145

(def-intern-test intern.15
  :package-name (make-array 3 :element-type 'base-char
sds's avatar
sds committed
146 147
                           :adjustable t
                           :initial-contents "BAR"))
148 149 150

(def-intern-test intern.16
  :package-name (make-array 3 :element-type 'character
sds's avatar
sds committed
151 152
                           :adjustable t
                           :initial-contents "BAR"))
153 154 155 156

(def-intern-test intern.17
  :package-name
  (let* ((etype 'base-char)
sds's avatar
sds committed
157 158
         (name0 (make-array 8 :element-type etype
                            :initial-contents "XBARYYYY")))
159
    (make-array 3 :element-type etype :displaced-to name0
sds's avatar
sds committed
160
                :displaced-index-offset 1)))
161 162 163 164

(def-intern-test intern.18
  :package-name
  (let* ((etype 'character)
sds's avatar
sds committed
165 166
         (name0 (make-array 8 :element-type etype
                            :initial-contents "XBARYYYY")))
167
    (make-array 3 :element-type etype :displaced-to name0
sds's avatar
sds committed
168
                :displaced-index-offset 1)))
169 170 171

;;; Error tests

172
(deftest intern.error.1
173 174
  (signals-error (intern) program-error)
  t)
175 176

(deftest intern.error.2
177 178
  (signals-error (intern "X" "CL" nil) program-error)
  t)