Interlisp.medley/internal/test/LANGUAGE/AUTO/PACKAGE-CONDITIONS.TEST

;;
;;	Creation date - Jan. 22, 1987	
;;	
;;	Created by    - Karin M. Sye
;;
;;	The following test code attemps to test all the PACKAGE conditions implemented by Xerox Common Lisp
;;
;;  **  CONDITIONS RAISED WHILE READING SYMBOL NAMES **
;;
(do-test "test xcl:read-conflict condition"
  	(catch 'done 
			(handler-bind 
						((xcl:read-conflict 
							#'(lambda (condition) (throw 'done t))   )
						 (xcl:condition 
								#'(lambda (condition)
											;  wrong type of condition was signaled
											(throw 'done nil))  )
						)
						(let (  (il:litatom-package-conversion-enabled t)
							   (xcl:*preferred-reading-symbols* (remove 'il:* xcl:*preferred-reading-symbols*))
							   (*readtable* il:coderdtbl)
							)
							(read (make-string-input-stream "*"))
							; no condition was signaled
							nil
						)
			)
	)
)
;;
;;
(do-test "test xcl:missing-external-symbol condition"
	(catch 'done (handler-bind ((xcl:missing-external-symbol 
								#'(lambda (condition) (throw 'done t))  )
						  (xcl:condition 
								#'(lambda (condition)
											;  wrong type of condition was signaled
											(throw 'done nil))  )
						 )
						 (progn
								(read (make-string-input-stream "lisp:dopey-sleepy"))
								; no condition was signaled
								nil
						 )
			  )
	)
)
;;
;;
(do-test "test xcl:symbol-colon-error condition"
	(catch 'done (handler-bind ((xcl:symbol-colon-error  #'(lambda (condition) (throw 'done t))  )
						  (xcl:condition 
								#'(lambda (condition)
											;  wrong type of condition was signaled
											(throw 'done nil))  )
						 ) 
						 (progn
							(read (make-string-input-stream "aa::bb:cc"))
							; no condition was signaled
							nil
						 )
			   )
	)
)
;;
;;
(do-test "test xcl:missing-package condition"
	(catch 'done (handler-bind ((xcl:missing-package #'(lambda (condition) (throw 'done t))  )
						  (xcl:condition 
								#'(lambda (condition)
											;  wrong type of condition was signaled
											(throw 'done nil))  )
						 )
						 (progn
								(read (make-string-input-stream "ugly:duckling"))
								; no condition was signaled
								nil
						 )
			   )
	)
)
;;
;;  ** CONDITION RAISED WHILE IN THE PACKAGE SYSTEM
;;
(do-test "test xcl:symbol-conflict condition"
	(every #'(lambda (subtype) (subtypep subtype 'xcl:symbol-conflict) ) 
				  '(xcl:use-conflict xcl:export-conflict xcl:import-conflict xcl:unintern-conflict)
	)
)
;;
;;
(do-test "test xcl:package-error condition"
	(subtypep 'xcl:export-missing 'xcl:package-error)
)
;;
;;  ** CONDITION RAISED WHILE CALLING USE-PACKAGE
;;
(do-test "test xcl:use-conflict condition"
	(catch 'fool 
			(unwind-protect
					  (handler-bind ((xcl:use-conflict 
									#'(lambda (condition) (throw 'fool t))  )
								  (xcl:condition 
									#'(lambda (condition)
											;  wrong type of condition was signaled
											(throw 'fool nil))  )
								 )
								 (progn
										(every #'(lambda (x) (make-package x :use nil)) '("p1" "p2" "p3"))
										(export (intern "a" "p1") "p1")
										(export (intern "a" "p2") "p2")
										(use-package '("p1" "p2") "p3")
										; no condition was signaled
										nil
								 )
					   )
					   (mapc #'(lambda (x) (xcl:delete-package x)) '("p1" "p2" "p3"))
			)
	)
)
			
;;
;;  ** CONDITION RAISED WHILE CALLING EXPORT
;;
(do-test "test xcl:export-conflict condition"
	(catch 'off 
		(unwind-protect
			(handler-bind 
					((xcl:export-conflict 
							#'(lambda (condition) (throw 'off t)
							  ))
					 (xcl:condition 
									#'(lambda (condition)
											;  wrong type of condition was signaled
											(throw 'off nil)
									  ))  
					)
					(progn
						(make-package "p1" :use nil)
						(make-package "p2" :use "p1")
						(export (intern "A" "p2") "p2")
						(export (intern "A" "p1") "p1")
						; no condition was signaled
						nil
					)
			)
			(mapc #'xcl:delete-package '("p1" "p2"))
		)
	)
)
;;
;;
(do-test "test xcl:export-missing condition"
	(catch 'bye
			(handler-bind ((xcl:export-missing  
									#'(lambda (condition) (throw 'bye t))  
									  )
						(xcl:condition 
									#'(lambda (condition)
											;  wrong type of condition was signaled
											(throw 'bye nil)
									  ))
					    )
						(progn
							  (export '( sssnow-whiteee  sssneezyyyy) 'lisp)
							   ; no condition was signaled
							   nil
						)
			)
	)
)					

;;
;;  ** CONDITION RAISED WHILE CALLING IMPORT
;;
(do-test "test xcl:import-conflict condition"
	(block exit
			(handler-bind (( xcl:import-conflict  
								#'(lambda (condition) (return-from exit t)  
								  ))
						(xcl:condition 
									#'(lambda (condition)
											;  wrong type of condition was signaled
											(return-from exit nil)
									  ))
					    )
					    (progn
							(import '(lisp:* lisp:length) 'il)
							;no condition was signaled
							nil
					    )
			)
	)
)
;;
;;  ** CONDITION RAISED WHILE CALLING UNINTERN
;;
(do-test "test xcl:unintern-conflict condition"
	(catch 'fool 
			(unwind-protect
					  (handler-bind 
						((xcl:unintern-conflict 
								#'(lambda (condition) (throw 'fool t)
								  ))
						 (xcl:condition 
									#'(lambda (condition)
											;  wrong type of condition was signaled
											(throw 'fool nil)
									  ))
						)
						(progn
							(every #'(lambda (x) (make-package x :use nil)) '("p1" "p2" "p3"))
							(export (intern "A" "p1") "p1")
							(export (intern "A" "p2") "p2")
							(shadow 'a "p3")
							(use-package '("p1" "p2") "p3")
							(unintern (find-symbol "A" "p3") "p3")
							; no condition was signaled
							nil
						)
					   )
					 (mapc #'(lambda (x) (xcl:delete-package x)) '("p1" "p2" "p3"))
			)
	)
)
STOP