diff --git a/prolog/wam_cl/compile.pl b/prolog/wam_cl/compile.pl index 615152e..9f097a2 100644 --- a/prolog/wam_cl/compile.pl +++ b/prolog/wam_cl/compile.pl @@ -18,6 +18,9 @@ :- module(comp, []). :- set_module(class(library)). :- include('./header'). +:- use_module(library(pce)). + +lisp_eval(SExpression):- lisp_compiled_eval(SExpression),!. lisp_compiled_eval(SExpression):- quietly(as_sexp_interned(SExpression,Expression)), diff --git a/prolog/wam_cl/environs.pl b/prolog/wam_cl/environs.pl index d002d8f..e51b925 100644 --- a/prolog/wam_cl/environs.pl +++ b/prolog/wam_cl/environs.pl @@ -1,4 +1,4 @@ -/******************************************************************* +/* ****************************************************************** * * A Common Lisp compiler/interpretor, written in Prolog * @@ -42,7 +42,7 @@ set_el(O,Env,Name,Value):- HH=bv(Name,Value), H=[HH],ct(O,1,Env,H),ct(O,2,Env,H). -/** PUSH-PREPEND-IF-NEW **/ +/* * PUSH-PREPEND-IF-NEW **/ update_or_prepend(O,Env,Name,Value):- Env=el(List,_) -> (List==[]-> set_el(O,Env,Name,Value);update_lst_or_prepend(O,List,Name,Value)) @@ -52,7 +52,7 @@ (ct(O,2,H,Value)->true;(T\==[],update_lst_or_prepend(O,T,Name,Value))),!. update_lst_or_prepend(O,Env,Name,Value):- Env=[H|T],!,ct(O,2,Env,[H|T]),ct(O,1,Env,bv(Name,Value)). -/** PUSH-APPEND-IF-NEW **/ +/* * PUSH-APPEND-IF-NEW **/ update_or_append(O,Env,Name,Value):- Env=el(_,_) -> update_el_or_append(O,Env,Env,Name,Value); update_lst_or_append(O,Env,Name,Value). @@ -71,13 +71,13 @@ ct(O,N,P,E):- var(E) -> true ; call(O,N,P,E). -/** PUSH-APPEND **/ +/* PUSH-APPEND */ push_append(O,Env,Name,Value):- Env=el(_,_)->push_el_append(O,Env,Env,Name,Value);push_lst_append(O,Env,Name,Value). push_el_append(O,Env,el(_,[]),Name,Value):- set_el(O,Env,Name,Value). push_el_append(O,Env,el(_,Tail),Name,Value):- T=[bv(Name,Value)],ct(O,2,Tail,T),ct(O,2,Env,T). push_lst_append(O,Env,Name,Value):- Env=[_|T],(T==[]->(ct(O,2,Env,[bv(Name,Value)]));push_lst_append(O,T,Name,Value)). -/** PUSH-PREPEND **/ +/* * PUSH-PREPEND **/ push_prepend(O,Env,Name,Value):- Env=el(List,_)->push_le_prepend(O,Env,List,Name,Value);push_list_prepend(O,Env,Name,Value). push_le_prepend(O,Env,[],Name,Value):- !, set_el(O,Env,Name,Value). diff --git a/prolog/wam_cl/places.pl b/prolog/wam_cl/places.pl index 5b1e8a0..e52644c 100644 --- a/prolog/wam_cl/places.pl +++ b/prolog/wam_cl/places.pl @@ -96,6 +96,49 @@ is_place_op(incf). is_place_op(decf). /* + +(defun mapcar (f l)(cond ((null l) nil)(t (cons (funcall f (car l))(mapcar f (cdr l)))))) +(mapcar #'oddp '(1 2 3 4 5)) +(mapcar #'= '(1 2 3) '(3 2 1)) + + +(defun nconc (&optional lst &rest rest) + (if rest + (let ((rest-conc (apply #'nconc rest))) + (if (consp lst) + (progn (setf (cdr (last lst)) rest-conc) + lst) + rest-conc)) + lst)) + +(defun mapcan (fn &rest lsts) + (apply #'nconc (apply #'mapcar fn lsts))) + +(mapcan #'(lambda (x) (and (numberp x) (list x))) + '(a 1 b c 3 4 d 5)) + +(PRINT (permute '(A B Z) ) ) + +(DEFUN permute (LIST)(IF LIST (MAPCAN #'(LAMBDA (x)(MAPCAR #'(LAMBDA (y)(CONS x y) ) + (permute (REMOVE x LIST) ) ) ) LIST) '(NIL) ) ) + + + +prolog. + +f_mapcan(Fn_In, RestNKeys, FnResult) :- + GEnv=[bv(u_fn, Fn_In), bv(u_lsts, Lsts_In)], + as_rest(u_lsts, Lsts_In, 0, RestNKeys), + catch(( ( get_var(GEnv, u_fn, Fn_Get), + get_var(GEnv, u_lsts, Lsts_Get), + f_apply(f_mapcar, [Fn_Get, Lsts_Get], Nconc_Param), + f_nconc(Nconc_Param, Nconc_Ret) + ), + Nconc_Ret=FnResult + ), + block_exit(mapcan, FnResult), + true). + is_place_op(rotatef). is_place_op(shiftf). diff --git a/prolog/wam_cl/readtables.pl b/prolog/wam_cl/readtables.pl index 44bcf6d..cbb1cb0 100644 --- a/prolog/wam_cl/readtables.pl +++ b/prolog/wam_cl/readtables.pl @@ -176,8 +176,8 @@ fix_symbols:- - forall(symbol_overlap(sys(pkg_cl,S1),sys(pkg_clos,S2)),move_symbol_into(S2,sys(pkg_cl))), - forall(symbol_overlap(sys(pkg_sys,S1),sys(pkg_sys,S2)),move_symbol_into(S1,sys(pkg_sys))), + forall(symbol_overlap(sys(pkg_cl,_S1),sys(pkg_clos,S2)),move_symbol_into(S2,sys(pkg_cl))), + forall(symbol_overlap(sys(pkg_sys,S1),sys(pkg_sys,_S2)),move_symbol_into(S1,sys(pkg_sys))), forall(symbol_in(int(pkg_cl,S1)),move_symbol_into(S1,sys(pkg_sys))), forall(symbol_in(sys(pkg_sys,S1)),move_symbol_into(S1,sys(pkg_sys))). diff --git a/prolog/wam_cl/si.data b/prolog/wam_cl/si.data index a44321e..91504ed 100644 --- a/prolog/wam_cl/si.data +++ b/prolog/wam_cl/si.data @@ -4132,7 +4132,7 @@ o_p_v(map_into,symbol_name,"MAP-INTO"). o_p_v(map_into,symbol_package,pkg_cl). o_p_v(map_into,sys_call,t). o_p_v(map_into,type_of,symbol). -o_p_v(mapc,ftype_lambda_list,[sys_callable,list,c38_rest,list]). +o_p_v(mapc,ftype_lambda_list,[sys_callable,c38_rest,list]). o_p_v(mapc,ftype_result_type,list). o_p_v(mapc,symbol_function,f_mapc). o_p_v(mapc,symbol_name,"MAPC"). @@ -4140,21 +4140,21 @@ o_p_v(mapc,symbol_package,pkg_cl). o_p_v(mapc,sys_call,t). o_p_v(mapc,sys_foldable,t). o_p_v(mapc,type_of,symbol). -o_p_v(mapcan,ftype_lambda_list,[sys_callable,list,c38_rest,list]). +o_p_v(mapcan,ftype_lambda_list,[sys_callable,c38_rest,list]). o_p_v(mapcan,ftype_result_type,t). o_p_v(mapcan,symbol_function,f_mapcan). o_p_v(mapcan,symbol_name,"MAPCAN"). o_p_v(mapcan,symbol_package,pkg_cl). o_p_v(mapcan,sys_call,t). o_p_v(mapcan,type_of,symbol). -o_p_v(mapcar,ftype_lambda_list,[sys_callable,list,c38_rest,list]). +o_p_v(mapcar,ftype_lambda_list,[sys_callable,c38_rest,list]). o_p_v(mapcar,ftype_result_type,list). o_p_v(mapcar,symbol_function,f_mapcar). o_p_v(mapcar,symbol_name,"MAPCAR"). o_p_v(mapcar,symbol_package,pkg_cl). o_p_v(mapcar,sys_call,t). o_p_v(mapcar,type_of,symbol). -o_p_v(mapcon,ftype_lambda_list,[sys_callable,list,c38_rest,list]). +o_p_v(mapcon,ftype_lambda_list,[sys_callable,c38_rest,list]). o_p_v(mapcon,ftype_result_type,t). o_p_v(mapcon,symbol_function,f_mapcon). o_p_v(mapcon,symbol_name,"MAPCON"). @@ -4169,7 +4169,7 @@ o_p_v(maphash,symbol_package,pkg_cl). o_p_v(maphash,sys_call,t). o_p_v(maphash,sys_flushable,t). o_p_v(maphash,type_of,symbol). -o_p_v(mapl,ftype_lambda_list,[sys_callable,list,c38_rest,list]). +o_p_v(mapl,ftype_lambda_list,[sys_callable,c38_rest,list]). o_p_v(mapl,ftype_result_type,list). o_p_v(mapl,symbol_function,f_mapl). o_p_v(mapl,symbol_name,"MAPL"). @@ -4177,7 +4177,7 @@ o_p_v(mapl,symbol_package,pkg_cl). o_p_v(mapl,sys_call,t). o_p_v(mapl,sys_foldable,t). o_p_v(mapl,type_of,symbol). -o_p_v(maplist,ftype_lambda_list,[sys_callable,list,c38_rest,list]). +o_p_v(maplist,ftype_lambda_list,[sys_callable,c38_rest,list]). o_p_v(maplist,ftype_result_type,list). o_p_v(maplist,symbol_function,f_maplist). o_p_v(maplist,symbol_name,"MAPLIST"). diff --git a/prolog/wam_cl/socksrv.pl b/prolog/wam_cl/socksrv.pl index f43eb39..12a7158 100644 --- a/prolog/wam_cl/socksrv.pl +++ b/prolog/wam_cl/socksrv.pl @@ -72,13 +72,17 @@ option(description(Desc),Options,Alias), dmsg(Port=Desc), thread_create(lsp_server_loop(ServerSocket, Options), _, - [ alias(Alias) - ]),!. + [ alias(Alias),detached(true)]),!. -resolve_host(Peer,Host):- catch(tcp_host_to_address(Host, Peer),_,fail),!. -resolve_host(Peer,Host):- atom(Peer),Peer=Host,!. -resolve_host(Peer,Host):- compound(Peer),catch((Peer=..PeerL,atomic_list_concat(PeerL,'.',Host)),_,fail),!. -resolve_host(Peer,Host):- term_to_atom(Peer,Host),!. +lsp_server_loop(ServerSocket, Options):- + ignore(catch(lsp_server_loop_1(ServerSocket, Options),E,writeln(user_error, lsp_server_loop_1(ServerSocket, Options,E)))), + lsp_server_loop(ServerSocket, Options). + + +resolve_host_sksrv(Peer,Host):- catch(tcp_host_to_address(Host, Peer),_,fail),!. +resolve_host_sksrv(Peer,Host):- atom(Peer),Peer=Host,!. +resolve_host_sksrv(Peer,Host):- compound(Peer),catch((Peer=..PeerL,atomic_list_concat(PeerL,'.',Host)),_,fail),!. +resolve_host_sksrv(Peer,Host):- term_to_atom(Peer,Host),!. @@ -87,28 +91,19 @@ tcp_accept(ServerSocket, ClientSock, Peer), tcp_open_socket(ClientSock, In, Out), set_stream(In, close_on_abort(false)), - set_stream(Out, close_on_abort(false)), - - - resolve_host(Peer,Host), - ( Postfix = [] - ; between(2, 1000, Num), - Postfix = [-, Num] - ), + set_stream(Out, close_on_abort(false)), + resolve_host_sksrv(Peer,Host), + gensym('_',PostFix), option(alias(ServerAlias),Options,lspsrv_server),!, - atomic_list_concat(['client_',Host, '@', ServerAlias | Postfix], Alias), + atomic_list_concat(['client_',Host,PostFix, '@', ServerAlias], Alias), catch(thread_create( call_service_lsp_client(Host, Alias, ClientSock, In, Out, Peer, Options), - _, - [ alias(Alias),detached(true) - ]), + _, [ alias(Alias),detached(true)]), error(permission_error(create, thread, Alias), _), fail))). -lsp_server_loop(ServerSocket, Options):- - ignore(catch(lsp_server_loop_1(ServerSocket, Options),E,writeln(user_error,E))), - lsp_server_loop(ServerSocket, Options). + call_service_lsp_client(Host, Alias, ClientSock, In, Out, Peer, Options):- diff --git a/t/MicroPrologII/mlg.Start b/t/MicroPrologII/mlg.Start deleted file mode 100644 index 37cbad1..0000000 --- a/t/MicroPrologII/mlg.Start +++ /dev/null @@ -1,42 +0,0 @@ -% -% Startup MicroPrologII -% - -$ eq(X,X). -$ neq(X,X):- cUt, fail. -$ neq(X,Y). - -$ not(X) :- call(X), cUt, fail. -$ not(X). - -$ repeat. -$ repeat :- repeat. - -$ differents(L) :- freeze(L,differents1(L)). -$ differents1([]). -$ differents1([T|Q]) :- hors_de(T,Q), differents(Q). -$ hors_de(X,L) :- freeze(L,hors_de1(X,L)). -$ hors_de1(X,[]). -$ hors_de1(X,[T|Q]) :- dif(X,T), hors_de(X,Q). - -$ freeze2_ou(X,Y,B) :- freeze(X,une_fois(B,V)), - freeze(Y,une_fois(B,V)). -$ une_fois(B,V) :- var(V), cUt, call(B), eq(V,deja_fait). -$ une_fois(B,V). - - -$ conc([],X,X) . -$ conc([T|Q],L,[T|R]) :- conc(Q,L,R). -$ element(X,[X|Y]). -$ element(X,[Y|Z]) :- element(X,Z). -$ del(X,[X|Y],Y). -$ del(X,[Y|Z],[Y|R]) :- del(X,Z,R). - -$ wb(X) :- write(X), write(' '). -$ wf(X) :- write(X), nl, fail. - -$ fibp(0, 1) :- cUt. -$ fibp(1, 1) :- cUt. -$ fibp(N, F) :- le(1,N),minus(N,1,N1),minus(N,2,N2), fibp(N1, F1),fibp(N2, F2), plus(F1,F2,F). - - diff --git a/t/MicroPrologII/v4.lisp b/t/MicroPrologII/v4.lisp deleted file mode 100644 index 17f1e28..0000000 --- a/t/MicroPrologII/v4.lisp +++ /dev/null @@ -1,788 +0,0 @@ -; Version 3 -; boot.lsp -; -;; (in-package :USER) - -(declaim (optimize (speed 3) (debug 0) (safety 0))) - - -(require :sb-posix) -(import '(sb-posix:termios sb-posix:termios-lflag sb-posix:termios-cc -sb-posix:tcgetattr sb-posix:tcsetattr -sb-posix:tcsadrain -sb-posix:icanon sb-posix:echo sb-posix:echoe sb-posix:echok -sb-posix:echonl sb-posix:vmin sb-posix:vtime)) - -#| What "less" does: -s.c_lflag &= ~(ICANON|ECHO|ECHOE|ECHOK|ECHONL); -s.c_oflag |= (OPOST|ONLCR|TAB3); -s.c_oflag &= ~(OCRNL|ONOCR|ONLRET); -s.c_cc[VMIN] = 1; -s.c_cc[VTIME] = 0; -|# -(defun read-char-no-echo-cbreak (&optional (stream *query-io*)) -(let ((old (tcgetattr 0)) -(new (tcgetattr 0)) -(bits (logior icanon echo echoe echok echonl))) -(unwind-protect -(progn -(setf (termios-lflag new) (logandc2 (termios-lflag old) bits) -(aref (termios-cc new) vmin) 1 -(aref (termios-cc new) vtime) 0) -(tcsetattr 0 tcsadrain new) -(read-char stream)) -(tcsetattr 0 tcsadrain old)))) - - - -(defun mlg3 () - (banner) - (format t "~A~%" (time (load "mlg.Start"))) - ;(setq *gc-silence* t) - (myloop (read_prompt))) - -(defun read_prompt () - (terpri) - (format t "| ?- ") - (force-output) - ;(gc) - (read_code_tail)) - -(defun banner () - (dotimes (i 2) (terpri)) - (format t "Micro_Log3 pour vous servir~%") - (dotimes (i 2) (terpri))) - -(defun l () - (format t "Back to MicroLog3 top-level~%") - (myloop (read_prompt))) -; clecteur.lsp -; - -(defvar *lvarloc nil) -(defvar *lvarglob nil) -(set-macro-character #\% (get-macro-character #\;)) - -(defun rch () - (do ((ch (read-char) (read-char))) - ((char/= ch #\Newline) ch))) -(defun rchnsep () - (do ((ch (rch) (rch))) - ((char/= ch #\space) ch))) - -(defun special-plvar (ch) (char= ch '#\_)) -(defun alphanum (ch) (or (alphanumericp ch) (special-plvar ch))) -(defun valdigit (ch) (digit-char-p ch)) - -(defun read_number (ch) - (do ((v (valdigit ch) (+ (* v 10) (valdigit (read-char))))) - ((not (digit-char-p (peek-char))) v))) - -(defun implode (lch) (intern (map 'string #'identity lch))) - -(defun read_atom (ch) - (do ((lch (list ch) (push (read-char) lch))) - ((not (alphanum (peek-char))) (implode (reverse lch))))) - -(defun read_at (ch) - (do ((lch (list ch) (push (read-char) lch))) - ((char= (peek-char) #\') (read-char) (implode (reverse lch))))) - -(defun read_string (ch) - (do ((lch (list (char-int ch)) (push (char-int (read-char)) lch))) - ((char= (peek-char) #\") (read-char) (do_l (reverse lch))))) - -(defun read_var (ch n) - (status (read_atom ch) n)) - -(defun status (nom n) - (if (= n 1) - (unless (member nom *lvarglob) (pushnew nom *lvarloc)) - (progn (if (member nom *lvarloc) (setq *lvarloc (delete nom *lvarloc))) - (pushnew nom *lvarglob))) - nom) - -(defun read_simple (ch n) - (cond - ((or (upper-case-p ch) (special-plvar ch)) (read_var ch n)) - ((digit-char-p ch) (read_number ch)) - ((char= ch #\") (read_string (read-char))) - ((char= ch #\') (read_at (read-char))) - (t (read_atom ch)))) - -(defun read_fct (ch n) - (let ((fct (read_simple ch n)) (c (rchnsep))) - (if (char= c #\() - (let ((la (read_args (rchnsep) (1+ n)))) - (cons (list fct (length la)) la)) - (progn (unread-char c) fct)))) - -(defun read_args (ch n) - (let ((arg (read_term ch n))) - (if (char= (rchnsep) #\,) - (cons arg (read_args (rchnsep) n)) - (list arg)))) - -(defun read_list (ch n) - (if (char= ch #\]) - () - (let ((te (read_term ch n))) - (case (rchnsep) - (#\, (list '(\. 2) te (read_list (rchnsep) n))) - (#\| (prog1 (list '(\. 2) te (read_term (rchnsep) n)) (rchnsep))) - (#\] (list '(\. 2) te nil)))))) - -(defun read_term (ch n) - (if (char= ch #\[) (read_list (rchnsep) (1+ n)) (read_fct ch n))) - -(defun read_tail (ch) - (let ((tete (read_pred ch))) - (if (char= (rchnsep) #\.) - (list tete) - (cons tete (read_tail (rchnsep)))))) - -(defun read_clause (ch) - (let ((tete (read_pred ch))) - (if (char= (rchnsep) #\.) - (list tete) - (progn (read-char) (cons tete (read_tail (rchnsep))))))) - -(defun c (l) - (if (atom l) - (if (member l *lvarloc) - (cons 'L (position l *lvarloc)) - (if (member l *lvarglob) (cons 'G (position l *lvarglob)) l)) - (if (eq (car l) '|cUt|) - (list '|cUt| (length *lvarloc)) - (cons (c (car l)) (c (cdr l)))))) -; Version 3 -; lecteur.lsp -; - -(defun read_code_cl () - (let ((*lvarloc ()) (*lvarglob ())) - (let ((x (read_clause (rchnsep)))) - (maj_locglob (car x) (car (last x))) - (cons (cons (length *lvarloc) (length *lvarglob)) (c x))))) - -(defun read_code_tail () - (setq *lvarloc () *lvarglob ()) - (let ((x (read_tail (rchnsep)))) - (cons - (cons (length *lvarloc) (length *lvarglob)) - (append (c x) (list '(|true|)))))) - -(defun read_pred (ch) - (let ((nom (read_atom ch)) (c (rchnsep))) - (if (char= c #\() - (cons nom - (read_args (rchnsep) (if (member nom '(|dif| |freeze|)) 2 1))) - (progn (unread-char c) (list nom))))) - -(defun unsafe? (x h q) (and (member x q) (not (member x h)))) - -(defun maj_locglob (h q) - (mapc #'(lambda (x) - (when (unsafe? x h q) - (setq *lvarloc (delete x *lvarloc)) - (push x *lvarglob))) - *lvarloc)) -; Version 3 -; blocs.lsp -; - -; I. Registres -; -(defconstant BottomFR 1) -(defconstant BottomG 300000) -(defconstant BottomL 600000) -(defconstant BottomTR 1000000) -(defconstant A 1200000) - -; - -(defvar Mem (make-array 1205000 :initial-element 0)) -(defvar FR) (defvar TR) (defvar L) (defvar G) -(defvar CP) (defvar CL) (defvar Cut_pt) (defvar FRCP) -(defvar BL) (defvar BG) -(defvar PC) (defvar PCE) (defvar PCG) (defvar Duboulot) - -(defmacro vset (v i x) `(setf (svref ,v ,i) ,x)) - -; II. Local Stack -; - -;; fibp(20, X) - -; WAM notion of environment [CL CP G Cut E] -; -(defmacro CL (b) `(svref Mem ,b)) -(defmacro CP (b) `(svref Mem (1+ ,b))) -(defmacro G (b) `(svref Mem (+ ,b 2))) -(defmacro Cut (b) `(svref Mem (+ ,b 3))) -(defmacro E (b) `(+ ,b 4)) - -(defmacro push_cont () - `(progn (vset Mem L CL) (vset Mem (1+ L) CP))) - -(defmacro push_E (n) - `(let ((top (+ L 4 ,n))) - (if (>= top BottomTR) - (throw 'debord (print "Local Stack Overflow"))) - (vset Mem (+ L 3) Cut_pt) - (dotimes (i ,n top) (vset Mem (decf top) (cons 'LIBRE BottomG))))) - -(defmacro maj_L (nl) `(incf L (+ 4 ,nl))) - - -;choice-point : [a1 .. an A FR BCP BCL BG BL BP TR] -; -(defmacro TR (b) `(svref Mem (1- ,b))) -(defmacro BP (b) `(svref Mem (- ,b 2))) -(defmacro BL (b) `(svref Mem (- ,b 3))) -(defmacro BG (b) `(svref Mem (- ,b 4))) -(defmacro BCL (b) `(svref Mem (- ,b 5))) -(defmacro BCP (b) `(svref Mem (- ,b 6))) -(defmacro FR (b) `(svref Mem (- ,b 7))) -(defmacro A (b) `(svref Mem (- ,b 8))) - -(defun save_args () - (dotimes (i (svref Mem A) (vset Mem (incf L i) i)) - (vset Mem (+ L i) (svref Mem (+ A i 1))))) - -(defun push_choix () - (save_args) - (vset Mem (incf L) FR) - (vset Mem (incf L) CP) - (vset Mem (incf L) CL) - (vset Mem (incf L) G) - (vset Mem (incf L) BL) - (vset Mem (incf L 2) TR) - (setq BL (incf L) BG G)) - -(defun push_bpr (reste) (vset Mem (- BL 2) reste)) - -(defmacro size_C (b) `(+ 8 (A ,b))) - -(defun pop_choix () - (setq L (- BL (size_C BL)) BL (BL BL) BG (if (zerop BL) BottomG (BG BL)))) - -; III. Global Stack -; - -(defmacro push_G (n) - `(let ((top (+ G ,n))) - (if (>= top BottomL) (throw 'debord (print "Global Stack Overflow"))) - (dotimes (i ,n (vset Mem (+ L 2) G)) - (vset Mem (decf top) (cons 'LIBRE BottomG))))) -(defmacro maj_G (n) `(incf G ,n)) - -;IV. Trail -; -(defmacro fgblock (x) `(cdr (svref Mem ,x))) - -(defun pushtrail (x) - (if (>= TR A) (throw 'debord (print "Trail Overflow"))) - (vset Mem TR x) - (incf TR)) - -(defun poptrail (top) - (do () ((= TR top)) - (let ((x (svref Mem (decf TR)))) - (if (numberp x) - (vset Mem x (cons 'LIBRE BottomG)) - (vset Mem (car x) (cons 'LIBRE (cdr x))))))) - -; V. Frozen Goals Stack -; -(defmacro FGvar (x) `(svref Mem ,x)) -(defmacro FGtail (x) `(svref Mem (1+ ,x))) -(defmacro FGgoal (x) `(svref Mem (+ 2 ,x))) -(defmacro FGenv (x) `(svref Mem (+ 3 ,x))) -(defmacro frozen? (x) `(< (fgblock ,x) BottomG)) - -(defmacro push_fg (v b eb r) - `(if (>= (+ FR 3) BottomG) - (throw 'debord (print "Frozen Goals Stack Overflow")) - (progn (vset Mem FR ,v) - (vset Mem (incf FR) ,r) - (vset Mem (incf FR) ,b) - (vset Mem (incf FR) ,eb) - (incf FR)))) -; cutili.lsp -; - -(defmacro nloc (c) `(caar ,c)) -(defmacro nglob (c) `(cdar ,c)) -(defmacro head (c) `(cadr ,c)) -(defmacro tail (c) `(cddr ,c)) -(defmacro pred (g) `(car ,g)) -(defmacro largs (g) `(cdr ,g)) - -(defmacro functor (des) `(car ,des)) -(defmacro arity (des) `(cadr ,des)) -(defmacro des (te) `(car ,te)) -(defmacro var? (v) `(and (consp ,v) (numberp (cdr ,v)))) -(defmacro list? (x) `(eq (functor (des ,x)) '\.)) - -(defmacro user? (g) `(get (pred ,g) 'def)) -(defmacro builtin? (g) `(get (pred ,g) 'evaluable)) -(defmacro def_of (g) - `(get (pred ,g) - (if (largs ,g) - (nature (car (ultimate (car (largs ,g)) PCE PCG))) - 'def))) - -(defun nature (te) - (cond - ((var? te) 'def) - ((null te) 'empty) - ((atom te) 'atom) - ((list? te) 'list) - (t 'fonct))) - -(defun add_cl (pred c ind) - (setf (get pred ind) (append (get pred ind) (list c)))) - -(set-macro-character - #\$ - #'(lambda (stream char) - (let* ( (*standard-input* stream) (c (read_code_cl))) - (add_cl (pred (head c)) c 'def) - (if (largs (head c)) - (let ((b (nature (car (largs (head c)))))) - (if (eq b 'def) - (mapc - #' (lambda (x) (add_cl (pred (head c)) c x)) - '(atom empty list fonct)) - (add_cl (pred (head c)) c b))))) - (values))) - -(defun answer () - (printvar) - (if (zerop BL) - (setq Duboulot nil) - (if (and (progn (princ "More : ") (force-output) t) (member (read-char-no-echo-cbreak) '(#\o #\y))) - (backtrack) - (setq Duboulot nil)))) - -(defun printvar () - (if (and (null *lvarloc) (null *lvarglob)) - (format t "Yes ~%") - (let ((nl -1) (ng -1)) - (mapc - #' (lambda (x) - (format t "~A = " x) - (write1 (ult (cons 'L (incf nl)) (E BottomL))) (terpri)) - *lvarloc) - (mapc - #' (lambda (x) - (format t "~A = " x) - (write1 (ult (cons 'G (incf ng)) BottomG)) (terpri)) - *lvarglob)))) -; Version 3 -; unify.lsp -; - -(defmacro bind (x sq e xt) - `(progn (if (or (and (> ,x BottomL) (< ,x BL)) (< ,x BG)) (pushtrail ,xt)) - (rplaca (svref Mem ,x) ,sq) - (rplacd (svref Mem ,x) ,e))) - -(defun bindte (x sq e) - (if (frozen? x) - (let ((y (fgblock x))) (push y FRCP) (bind x sq e (cons x y))) - (bind x sq e x))) - -;(defun bindf0 (x b eb r) -; (pushtrail (cons x (fgblock x))) -; (rplacd (svref Mem x) FR) -; (push_fg b eb r)) - -(defun bindfg (x b eb r) - (bind x 'LIBRE FR (if (frozen? x) (cons x r) x)) - (push_fg x b eb r)) - -(defun unify_with (largs el eg) - (catch 'impossible - (dotimes (i (svref Mem A)) - (unif - (let ((te (svref Mem (+ A 1 i)))) (val (car te) (cdr te))) - (ultimate (pop largs) el eg))))) - -; cunify.lsp -; - -(defmacro adr (v e) `(+ (cdr ,v) ,e)) -(defmacro value (v e) `(svref Mem (adr ,v ,e))) - -(defun ult (v e) - (let ((te (value v e))) - (cond - ((eq (car te) 'LIBRE) (cons v e)) - ((var? (car te)) (ult (car te) (cdr te))) - ( te)))) - -(defun val (x e) (if (var? x) (ult x e) (cons x e))) - -(defun ultimate (x el eg) - (if (var? x) - (if (eq (car x) 'L) (ult x el) (ult x eg)) - (cons x eg))) - -(defmacro bindv (x ex y ey) - `(let ((ax (adr ,x ,ex)) (ay (adr ,y ,ey))) - (if (< ax ay) (bindte ay ,x ,ex) (bindte ax ,y ,ey)))) - -(defun unif (t1 t2) - (let ((x (car t1)) (ex (cdr t1)) (y (car t2)) (ey (cdr t2))) - (cond - ((var? y) - (if (var? x) - (if (= (adr x ex) (adr y ey)) t (bindv y ey x ex)) - (bindte (adr y ey) x ex))) - ((var? x) (bindte (adr x ex) y ey)) - ((and (atom x) (atom y)) (if (eql x y) t (throw 'impossible 'fail))) - ((or (atom x) (atom y)) (throw 'impossible 'fail)) - ( (let ((dx (pop x)) (dy (pop y))) - (if (and (eq (functor dx) (functor dy)) (= (arity dx) (arity dy))) - (do () ((null x)) - (unif (val (pop x) ex) (val (pop y) ey))) - (throw 'impossible 'fail))))))) -; Version 3 -; resol.lsp -; - -(defun forward () - (do () ((null Duboulot) (format t "no More~%")) - (cond ((and (null CP) (null FRCP)) (answer)) - ((load_PC) - (cond - ((user? PC) - (let ((d (def_of PC))) - (if d (pr2 d) (backtrack)))) - ((builtin? PC) - (if (eq (apply (car PC) (cdr PC)) 'fail) - (backtrack) - (cont_eval))) - ((backtrack))))))) - -(defun load_A (largs el eg) - (dotimes (i (length largs) (vset Mem A i)) - (vset Mem (+ A i 1) (ultimate (pop largs) el eg)))) - -(defun load_PC () - (if FRCP - (let ((x ())) - (do () ((null FRCP))(setq x (add_fg (pop FRCP) x))) - (do () ((null x)) (create_block (abs (pop x)))))) - (setq PC (pop CP) PCE (E CL) PCG (G CL) Cut_pt BL)) - ; (if dbg (dbg PC) t)) -(defun other_fg (b r) - (if (< (FGtail b) BottomG) (add_fg (FGtail b) r) r)) - -(defun add_fg (b r) - (let ((b1 (if (numberp (FGgoal b)) (FGgoal b) b))) - (if (eq (pred (FGgoal b1)) '|dif|) - (insert (- b1) (other_fg b r)) - (let* ((v (svref Mem (FGvar b1))) - (te (val (car v) (cdr v)))) - (if (var? (car te)) - (let ((y (adr (car te) (cdr te)))) - (bindfg y b1 nil (fgblock y)) - (other_fg b r)) - (insert b1 (other_fg b r))))))) - -(defun insert (b l) - (if (or (null l) (> b (car l))) - (cons b l) - (cons (car l) (insert b (cdr l))))) - -(defmacro dec_goal (x) -`(if (atom ,x) (list ,x) (cons (caar ,x) (cdr ,x)))) - -(defun create_block (b) - (push_cont) - (vset Mem (+ L 2) (FGenv b)) - (vset Mem (+ L 3) Cut_pt) - (setq CP (list (FGgoal b)) CL L) - (maj_L 0)) - -(defun pr2 (paq) - (load_A (largs PC) PCE PCG) - (if CP - (pr paq) - (progn - (if (<= BL CL) (setq L CL)) - (setq CP (CP CL) CL (CL CL)) - (pr paq)))) - -(defun cont_eval () - (unless CP (if (<= BL CL) (setq L CL)) (setq CP (CP CL) CL (CL CL)))) - -(defun pr (paq) - (if (cdr paq) - (progn (push_choix) (pr_choice paq)) - (pr_det (car paq)))) - -(defun pr_det (c) - (if (eq (unify_with - (largs (head c)) - (push_E (nloc c)) - (push_G (nglob c))) - 'fail) - (backtrack) - (progn - (maj_G (nglob c)) - (when (tail c)(push_cont) (setq CP (tail c) CL L) (maj_L (nloc c)))))) - -(defun pr_choice (paq) - (let* ((resu (shallow_backtrack paq)) (c (car resu)) (r (cdr resu))) - (cond ((null r) (pop_choix) (pr_det c)) - ( (push_bpr r) - (maj_G (nglob c)) - (when (tail c) - (push_cont) - (setq CP (tail c) CL L) - (maj_L (nloc c))))))) - -(defun shallow_backtrack (paq) - (if (and (cdr paq) - (eq (unify_with - (largs (head (car paq))) - (push_E (nloc (car paq))) - (push_G (nglob (car paq)))) - 'fail)) - (progn - (setq FRCP nil FR (FR BL)) - (poptrail (TR BL)) - (shallow_backtrack (cdr paq))) - paq)) - -(defun backtrack () - (if (zerop BL) - (setq Duboulot nil) - (progn (setq L BL G BG FR (FR L) FRCP nil Cut_pt (BL BL) - CP (BCP L) CL (BCL L) Cut_pt (BL BL)) - (load_A2) - (poptrail (TR BL)) - (pr_choice (BP L))))) - -(defun load_A2 () - (let ((deb (- L (size_C L)))) - (dotimes (i (A L) (vset Mem A i)) - (vset Mem (+ A i 1) (svref Mem (+ deb i)))))) - -(defun myloop (c) - (setq FR BottomFR G BottomG L BottomL TR BottomTR Cut_pt 0 - CP nil CL 0 BL 0 BG BottomG FRCP nil Duboulot t) - (push_cont) - (push_E (nloc c)) - (push_G (nglob c)) - (setq CP (cdr c) CL L) - (maj_L (nloc c)) - (maj_G (nglob c)) (read-char) - (catch 'debord ( time (forward))) - (myloop (read_prompt))) - -; Version 3 -; pred.lsp -; -(defvar Ob_Micro_Log - '(|write| |nl| |tab| |read| |get| |get0| - |var| |nonvar| |atomic| |atom| |number| - |cUt| |fail| |true| - |divi| |mod| |plus| |minus| |mult| |le| |lt| - |name| |consult| |abolish| |cputime| |statistics| - |call| |freeze| |dif| |frozen_goals|)) -(mapc #'(lambda (x) (setf (get x 'evaluable) t)) Ob_Micro_Log) - -; !/0 -(defun |cUt| (n) - (setq BL (Cut CL) BG (if (zerop BL) BottomG (BG BL)) - L (+ CL 4 n))) - -; call/1 (+term) - -(defun |call| (x) - (if (var? x) - (let ((te (ultimate x PCE PCG))) - (unless CP - (if (<= BL CL) (setq L CL)) - (setq CP (CP CL) CL (CL CL))) - (push_cont) - (vset Mem (+ L 2) (cdr te)) - (vset Mem (+ L 3) Cut_pt) - (setq CP (list (dec_goal (car te))) CL L) - (maj_L 0)) - (push (dec_goal x) CP))) - -; freeze/2 (?var,+term) -(defun |freeze| (x p) - (let ((xte (ultimate x PCE PCG))) - (if (var? (car xte)) - (let ((y (adr (car xte) (cdr xte))) (pte (ultimate p PCE PCG))) - (bindfg y (dec_goal (car pte)) (cdr pte) (fgblock y))) - (|call| p)))) - -; dif/2 (?term,?term) -(defun |dif| (x y) - (let ((BL L) (BG G) (str TR) (FRCP nil)) - (if (eq (uni x y) 'fail) - (poptrail str) - (if (/= TR str) - (let* ((xv (svref Mem (1- TR))) (v (if (numberp xv) xv (car xv)))) - (poptrail str) - (bindfg v PC PCG (fgblock v))) - 'fail)))) - -; statistics/0 -(defun |statistics| () - (format t " local stack : ~A (~A used)~%" (- BottomTR BottomL) (- L BottomL)) - (format t " global stack : ~A (~A used)~%" (- BottomL BottomG) (- G BottomG)) - (format t " trail : ~A (~A used)~%" (- A BottomTR) (- TR BottomTR)) - (format t " frozen-goals stack : ~A (~A used)~%" BottomG (- FR BottomFR))) - -; frozen_goals/0 -(defun |frozen_goals| () - (do ((i (- FR 4) (- i 4))) - ((< i 0)) - (if (eq (car (svref Mem (FGvar i))) 'LIBRE) - (let ((b (if (numberp (FGgoal i)) (FGgoal i) i))) - (writesf (pred (FGgoal b)) (largs (FGgoal b)) (FGenv b)) - (format t " frozen upon X~A~%" (FGvar i)))))) -; cpred.lsp -; - -(defmacro value1 (x) `(car (ultimate ,x PCE PCG))) -(defun uni (x y) - (catch 'impossible - (unif (ultimate x PCE PCG) (ultimate y PCE PCG)))) - - ;write/1 (?term) -(defun |write| (x) - (write1 (ultimate x PCE PCG))) - -(defun write1 (te) - (let ((x (car te)) (e (cdr te))) - (cond - ((null x) (format t "[]")) - ((atom x) (format t "~A" x)) - ((var? x) (format t "X~A" (adr x e))) - ((list? x) (format t "[") - (writesl (val (cadr x) e) (val (caddr x) e)) - (format t "]")) - ((writesf (functor (des x)) (largs x) e))))) - -(defun writesl (te r) - (write1 te) - (let ((q (car r)) (e (cdr r))) - (cond - ((null q)) - ((var? q) (format t "|X~A" (adr q e))) - (t (format t ",") (writesl (val (cadr q) e) (val (caddr q) e)))))) - -(defun writesf (fct largs e) - (format t "~A(" fct) - (write1 (val (car largs) e)) - (mapc #' (lambda (x) (format t ",") (write1 (val x e))) (cdr largs)) - (format t ")")) - - ;nl/0 -(defun |nl| () (terpri)) - ;tab/1 (+int) -(defun |tab| (x) - (dotimes (i (value1 x)) (format t " "))) - ;read/1 (?term) -(defun |read| (x) - (let ((te (read_terme))) - (catch 'impossible - (unif (ultimate x PCE PCG) (cons (cdr te) (push1_g (car te))))))) - -(defun read_terme () - (let ((*lvarloc nil) (*lvarglob nil)) - (let ((te (read_term (rchnsep) 2))) - (rchnsep) (cons (length *lvarglob) (c te))))) - -(defun push1_g (n) - (if (>= (+ G n) BottomL) (throw 'debord (print "Global Stack Overflow"))) - (dotimes (i n (- G n)) (vset Mem G (cons 'LIBRE BottomG)) (incf G))) - - ;get/1 (?car) -(defun |get| (x) - (uni x (char-int (rchnsep)))) - ;get0/1 (?car) -(defun |get0| (x) - (uni x (char-int (read-char)))) - ;var/1 (?term) -(defun |var| (x) - (unless (var? (value1 x)) 'fail)) - ;nonvar/1 (?term) -(defun |nonvar| (x) - (if (var? (value1 x)) 'fail)) - ;atomic/1 (?term) -(defun |atomic| (x) - (if (listp (value1 x)) 'fail)) - ;atom/1 (?term) -(defun |atom| (x) - (unless (symbolp (value1 x)) 'fail)) - ;number/1 (?term) -(defun |number| (x) - (unless (numberp (value1 x)) 'fail)) - ;fail/0 -(defun |fail| () 'fail) - ;true/0 -(defun |true| ()) - ;divi/3 (+int,+int,?int) -(defun |divi| (x y z) - (uni z (floor (value1 x) (value1 y)))) - ;mod/3 (+int,+int,?int) -(defun |mod| (x y z) - (uni z (rem (value1 x) (value1 y)))) - ;plus/3 (+int,+int,?int) -(defun |plus| (x y z) - (uni z (+ (value1 x) (value1 y)))) - ;minus/3 (+int,+int,?int) -(defun |minus| (x y z) - (uni z (- (value1 x) (value1 y)))) - ;mult/3 (+int,+int,?int) -(defun |mult| (x y z) - (uni z (* (value1 x) (value1 y)))) - ;le/2 (+int,+int) -(defun |le| (x y) - (if (> (value1 x) (value1 y)) 'fail)) - ;lt/2 (+int,+int) -(defun |lt| (x y) - (if (>= (value1 x) (value1 y)) 'fail)) - ;name/2 (?atom,?list) -(defun |name| (x y) - (let ((b (value1 x))) - (if (var? b) - (uni x (impl (undo_l (ultimate y PCE PCG)))) - (uni y (do_l (expl b)))))) - -(defun undo_l (te) - (let ((x (car te)) (e (cdr te))) - (if (atom x) - x - (cons (undo_l (val (cadr x) e)) (undo_l (val (caddr x) e)))))) -(defun do_l (x) - (if (atom x) x (list '(\. 2) (car x) (do_l (cdr x))))) -(defun impl (l) - (intern (map 'string #'int-char l))) -(defun expl (at) - (map 'list #'char-int (string at))) - - ;consult/1 (+atom) -(defun |consult| (f) - (format t "~A~%" (load (value1 f)))) - ; abolish/1 -(defun |abolish| (p) - (mapc #'(lambda (x) (setf (get p x) nil)) - '(atom empty list fonct def))) - ; cputime/1 -(defun |cputime| (x) - (uni x (float (/ (get-internal-run-time) internal-time-units-per-second)))) - - -(mlg3) diff --git a/t/ansi-test/.dir-locals.el b/t/ansi-test/.dir-locals.el deleted file mode 100644 index b8cc571..0000000 --- a/t/ansi-test/.dir-locals.el +++ /dev/null @@ -1,8 +0,0 @@ -;;; Directory Local Variables -;;; For more information see (info "(emacs) Directory Variables") - -((nil - (indent-tabs-mode . nil) ; Make sure to disable smart-tabs-mode if you're using it. - (whitespace-action . nil) - (whitespace-style . '(face trailing empty tabs)) - )) diff --git a/t/ansi-test/.gitignore b/t/ansi-test/.gitignore deleted file mode 100644 index 124d458..0000000 --- a/t/ansi-test/.gitignore +++ /dev/null @@ -1,70 +0,0 @@ -*~ -*.out -*.dat -*.fas -*.fasl -*.lx64fsl -*.lx32fsl -*.bc -sandbox/ -ansi-aux-macros.fas -ansi-aux.fas -array-aux.fas -backquote-aux.fas -bit-aux.fas -ceiling-aux.fas -char-aux.fas -cl-symbols-aux.fas -compile-file-test-file-2.fas -compile-file-test-file-2a.fas -compile-file-test-file-3.fas -compile-file-test-file-4.fas -compile-file-test-file-5.fas -compile-file-test-file.fas -compile-file-test-lp.fas -compile-file-test-lp.lsp -compile-file-test-lp.out -cons-aux.fas -defclass-aux.fas -defgeneric-method-combination-aux.fas -define-condition-aux.fas -division-aux.fas -exp-aux.fas -fceiling-aux.fas -ffloor-aux.fas -file-that-was-renamed.txt -floor-aux.fas -foo.fasl -foo.lsp -foo.txt -foo.ufsl -fround-aux.fas -ftruncate-aux.fas -gcd-aux.fas -hash-table-aux.fas -ldtest.lsp -load-test-file-2.fas -numbers-aux.fas -package-aux.fas -packages-00.fas -pathnames-aux.fas -printer-aux.fas -random-aux.fas -reader-aux.fas -remove-aux.fas -remove-duplicates-aux.fas -roman-numerals.fas -round-aux.fas -rt.fas -scratch/ -search-aux.fas -string-aux.fas -subseq-aux.fas -temp.dat -times-aux.fas -tmp.dat -tmp.dat.BAK -tmp.txt -tmp2.dat -truncate-aux.fas -types-aux.fas diff --git a/t/ansi-test/ISSUES b/t/ansi-test/ISSUES deleted file mode 100644 index 475926d..0000000 --- a/t/ansi-test/ISSUES +++ /dev/null @@ -1,29 +0,0 @@ -This file contains notes on problems in the ANSI CL spec found -during the construction of the tests. - -1. When building a composite stream, what happens when the component - streams have different element types? - -2. Should there be an UPGRADED-STREAM-ELEMENT-TYPE function. - -3. The spec requires that arrays specialized to type NIL exist. - Was this intended? - -4. If NIL specialized arrays exist, then NIL vectors are also strings. - Was this intended? - -5. The spec requires that (UPGRADED-COMPLEX-PART-TYPE NIL) be (type - equivalent to) NIL. - -6. The definition of UPGRADED-COMPLEX-PART-TYPE appears to require that - it work on arbitrary typespecs, including SATISFIES, which is not - possible. - -7. Was it intended that values of 'smaller' float types be coercible - to values of larger float types? In CLISP, short-float has a larger - range of exponents than single-float, so some shorts cannot be coerced - to singles without over/underflow. - -8. IMAGPART is defined as returning (* 0 number) on reals. If the - implementation supports negative zero and number is a negative float, this - will be -0.0 (of the appropriate type). Was this intended? diff --git a/t/ansi-test/README b/t/ansi-test/README deleted file mode 100644 index f0de4a0..0000000 --- a/t/ansi-test/README +++ /dev/null @@ -1,48 +0,0 @@ -This directory contains a partial Common Lisp standards compliance -test suite. - -To run the tests, load doit.lsp. This will load and -run the tests. To just load the tests, load gclload1.lsp -and gclload2.lsp. - -Individual tests may be run by (rt:do-test '). - -Tests can be invoked from the makefile setting the enviroment variable -LISP to the lisp executable to be tested, then invoking - - make test - Run tests with test bodies EVALed. - - make test-compiled - Run tests with test bodies compiled before being EVALed. - -Please tell me when you find incorrect test cases. - - Paul Dietz - dietz@dls.net - --------------------------------- - -(30 Jun 2003) I've decided to add metainformation to the tests, -in the form of : pairs after DEFTEST. Also, -I've added a DEFNOTE form to define note objects whose names -can be attached to properties of tests, to enable selective -disabling of classes of tests. - -The file doit.lsp disables some contentious tests under certain -implementations using the note mechanism. If any implementor -wishes that some of these tests be inhibited in their implementation, -please contact me and I will add code to do so. - --------------------------------- - -NOTE!!! - -This test suite is not intended to rank Common Lisp implementations. -The tests have not been selected to reflect the importance or -relative frequency of different CL features. Implementations may -even have extended the CL standard (arguably a good thing) in -a way that causes certain tests to fail. - - - diff --git a/t/ansi-test/TODO b/t/ansi-test/TODO deleted file mode 100644 index b87e5b2..0000000 --- a/t/ansi-test/TODO +++ /dev/null @@ -1,117 +0,0 @@ -Things to do to the test suite (not a complete list) - -1. subtypep and typep on complex types - -2. Refactor random type/element-of-type code. There's too much - duplication. - -3. More type tests on array types - -4. Extend random subtypep tester to array types. (complex types already added, - but should extend generator of random real types) - -5. Add JA's long form define-method-combination tests (from clisp), - or write own (partially done) - -6. adjust-array (need to add specialized integer arrays other than - bit vectors, and float vectors) - -7. Address synonym-stream issues (from Duane Rettig) - -8. accuracy tests for numeric functions - -9. Test that the streams operators that manipulate files - do the right things with *default-pathname-defaults*. - -10. Two-arg tests of FILE-POSITION on binary streams. - -11. Address issues with broadcast streams (C. Rhodes) -- apparent - contradictions in the spec. - -17. Tests that have an argument that provides a return value for special - conditions (like eof) that happens to be the same as a normal value the - functions would return (suggested by CR). - -18. Add random tests for COERCE (the result either is either typep of the - second arg (except for rational stuff) or a type-error is signalled.) - -19. Add two missing tests from CLOS (spotted by Bruno Haible): - -;; Shared slot remains shared. -;; CLHS 4.3.6.: "The value of a slot that is specified as shared both in the old -;; class and in the new class is retained." -(multiple-value-bind (value condition) - (ignore-errors - (defclass foo74 () ((size :initarg :size :initform 1 :allocation :class))) - (setq i (make-instance 'foo74)) - (defclass foo74 () ((size :initarg :size :initform 2 :allocation :class) (other))) - (slot-value i 'size)) - (list value (type-of condition))) -Expected: (1 NULL) -Got: (2 NULL) - -(progn - (defclass foo92b (foo92a) ((s :initarg :s))) - (defclass foo92a () ()) - (let ((x (make-instance 'foo92b :s 5)) (update-counter 0)) - (defclass foo92b (foo92a) ((s) (s1) (s2))) ; still subclass of foo92a - (slot-value x 's) - (defmethod update-instance-for-redefined-class ((object foo92b) added-slots discarded-slots property-list &rest initargs) - (incf update-counter)) - (make-instances-obsolete 'foo92a) - (slot-value x 's) - update-counter)) -Expected: 1 -Got: 0 - -21. The random tester showed (SETF AREF) wasn't being tested enough. Add tests. - -22. Add more symbol printing tests. In particular, there doesn't appear to - be a test that (princ :foo) >> :FOO (noticed by PG in ABCL) - -23. Modify rt so that when failing tests are reported, they are grouped by - :notes and the :notes comment is printed out. This will help explain - what the failures mean. - -28. Add tests for reading/printing with packages with weird names (lower case letters, - digits, etc.) - -30. Add more pathname equality tests to equal.lsp - -34. (from C Rhodes) Test that CERROR allows additional arguments after a - condition designating itself to be used in the continue format control. - -36. Add tests for bad default-initargs in object constructors. - -37. Add tests that methods on initialize-instance and - shared-initialize receive defaulted initargs from compiled - make-instance - -38, Floating point tests must be expanded. - -- Add tests for the floating point inspection functions (decode-float, etc.) - -- Add tests of -0.0 vs. 0.0 consistency (a bug here affected abcl) - -- transcendantal functions - -39. There are various constraints that things defined at the top level become - available at compile time. Test these constraints. - -40, Check that OPEN, etc. do pathname merging. - -41. Add tests for MOD, REM - -42. Add randomized tests for BIT-* functions (requested by piso on #lisp) - (partially done; tests on simple bit vectors going to a new bit vector - have been added; should add in-place versions and operations on non-simple - bit-vectors and non-vector arrays) - -43. Add tests for structs that defining subtypes using :include doesn't change - the parent type(s). (This came up in ABCL.) - -44. Add tests for SPECIAL declarations in MACROLET (requested by piso on #lisp) - (partially done) - -45. Sweep files for missing order-of-execution tests - -46. Add tests that class objects are valid class specifiers in method definitions. - -47. Test that :import-from in DEFPACKAGE can take a package object. diff --git a/t/ansi-test/ansi-test-common.asd b/t/ansi-test/ansi-test-common.asd deleted file mode 100644 index dcc5280..0000000 --- a/t/ansi-test/ansi-test-common.asd +++ /dev/null @@ -1,7 +0,0 @@ -(cl:in-package #:asdf-user) - -(defsystem :ansi-test-common - :depends-on (:regression-test) - :serial t - :components - ((:file "packages"))) diff --git a/t/ansi-test/arrays/adjust-array.lsp b/t/ansi-test/arrays/adjust-array.lsp deleted file mode 100644 index 4fd21e2..0000000 --- a/t/ansi-test/arrays/adjust-array.lsp +++ /dev/null @@ -1,1019 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Feb 15 07:27:22 2004 -;;;; Contains: Tests of ADJUST-ARRAY - - - -(defun listify-form (form) - (cond - ((integerp form) `'(,form)) - ((null form) nil) - ((and (consp form) - (eq (car form) 'quote) - (consp (cadr form))) - form) - (t `(let ((x ,form)) (if (listp x) x (list x)))))) - - -(defmacro def-adjust-array-test (name args1 args2 expected-result) - `(deftest ,name - (let* ((a1 (make-array ,@args1)) - (a2 (adjust-array a1 ,@args2))) - (assert (or (not (adjustable-array-p a1)) (eq a1 a2))) - (assert (or (adjustable-array-p a1) - (equal (array-dimensions a1) ,(listify-form (first args1))))) - (assert (equal (array-dimensions a2) ,(listify-form (first args2)))) - ,@(unless (or (member :displaced-to args1) - (member :displaced-to args2)) - (list '(assert (not (array-displacement a2))))) - a2) - ,expected-result)) - -(defmacro def-adjust-array-fp-test (name args1 args2 misc &rest expected-results) - `(deftest ,name - (let* ((a1 (make-array ,@args1)) - (a2 (adjust-array a1 ,@args2))) - (assert (or (not (adjustable-array-p a1)) (eq a1 a2))) - (assert (or (adjustable-array-p a1) - (equal (array-dimensions a1) ,(listify-form (first args1))))) - (assert (equal (array-dimensions a2) ,(listify-form (first args2)))) - ,@(unless (or (member :displaced-to args1) - (member :displaced-to args2)) - (list '(assert (not (array-displacement a2))))) - ,@(when misc (list misc)) - (values - (fill-pointer a2) - a2)) - ,@expected-results)) - -(def-adjust-array-test adjust-array.1 - (5 :initial-contents '(a b c d e)) - (4) - #(a b c d)) - -(def-adjust-array-test adjust-array.2 - (5 :initial-contents '(a b c d e)) - (8 :initial-element 'x) - #(a b c d e x x x)) - - -(def-adjust-array-test adjust-array.3 - (5 :initial-contents '(a b c d e)) - (4 :initial-contents '(w x y z)) - #(w x y z)) - -(def-adjust-array-test adjust-array.4 - (5 :initial-contents '(a b c d e)) - (8 :initial-contents '(8 7 6 5 4 3 2 1)) - #(8 7 6 5 4 3 2 1)) - -(def-adjust-array-fp-test adjust-array.5 - (5 :initial-contents '(a b c d e) :fill-pointer 3) - (4) - (assert (eq (aref a2 3) 'd)) - 3 #(a b c)) - -(def-adjust-array-fp-test adjust-array.6 - (5 :initial-contents '(a b c d e) :fill-pointer 3) - (4 :fill-pointer nil) - (assert (eq (aref a2 3) 'd)) - 3 #(a b c)) - -(def-adjust-array-fp-test adjust-array.7 - (5 :initial-contents '(a b c d e) :fill-pointer 3) - (4 :fill-pointer t) - nil - 4 #(a b c d)) - -(def-adjust-array-fp-test adjust-array.8 - (5 :initial-contents '(a b c d e) :fill-pointer 3) - (4 :fill-pointer 2) - (progn (assert (eq (aref a2 2) 'c)) - (assert (eq (aref a2 3) 'd))) - 2 #(a b)) - -(def-adjust-array-fp-test adjust-array.9 - (5 :initial-contents '(a b c d e) :fill-pointer 3) - (8 :fill-pointer 5 :initial-element 'x) - (assert (equal (list (aref a2 5) (aref a2 6) (aref a2 7)) '(x x x))) - 5 #(a b c d e)) - -(deftest adjust-array.10 - (let* ((a1 (make-array 5 :initial-contents '(a b c d e))) - (a2 (adjust-array a1 4 :displaced-to nil))) - (assert (if (adjustable-array-p a1) - (eq a1 a2) - (equal (array-dimensions a1) '(5)))) - (assert (not (array-displacement a2))) - a2) - #(a b c d)) - -(deftest adjust-array.11 - (let* ((a0 (make-array 7 :initial-contents '(x a b c d e y))) - (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1)) - (a2 (adjust-array a1 4))) - (assert (if (adjustable-array-p a1) - (eq a1 a2) - (equal (array-dimensions a1) '(5)))) - (assert (not (array-displacement a2))) - a2) - #(a b c d)) - -(deftest adjust-array.12 - (let* ((a0 (make-array 7 :initial-contents '(1 2 3 4 5 6 7))) - (a1 (make-array 5 :initial-contents '(a b c d e))) - (a2 (adjust-array a1 4 :displaced-to a0))) - (assert (if (adjustable-array-p a1) - (eq a1 a2) - (equal (array-dimensions a1) '(5)))) - (assert (equal (multiple-value-list (array-displacement a2)) - (list a0 0))) - a2) - #(1 2 3 4)) - -(deftest adjust-array.13 - (let* ((a0 (make-array 7 :initial-contents '(1 2 3 4 5 6 7))) - (a1 (make-array 5 :initial-contents '(a b c d e))) - (a2 (adjust-array a1 4 :displaced-to a0 - :displaced-index-offset 2))) - (assert (if (adjustable-array-p a1) - (eq a1 a2) - (equal (array-dimensions a1) '(5)))) - (assert (equal (multiple-value-list (array-displacement a2)) - (list a0 2))) - a2) - #(3 4 5 6)) - -(deftest adjust-array.14 - (let* ((a0 (make-array 7 :initial-contents '(1 2 3 4 5 6 7))) - (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1)) - (a2 (adjust-array a1 4 :displaced-to a0))) - (assert (if (adjustable-array-p a1) - (eq a1 a2) - (equal (array-dimensions a1) '(5)))) - (assert (equal (multiple-value-list (array-displacement a2)) - (list a0 0))) - a2) - #(1 2 3 4)) - -(deftest adjust-array.15 - (let* ((a0 (make-array 7 :initial-contents '(1 2 3 4 5 6 7))) - (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1)) - (a2 (make-array 4 :displaced-to a1 :displaced-index-offset 1)) - (a3 (adjust-array a2 4 :displaced-to a1))) - a3) - #(2 3 4 5)) - -(deftest adjust-array.16 - (let* ((a0 (make-array 7 :initial-contents '(1 2 3 4 5 6 7))) - (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1)) - (a2 (adjust-array a1 5 :displaced-to a0))) - a2) - #(1 2 3 4 5)) - -(def-adjust-array-test adjust-array.17 - (nil :initial-element 'x) - (nil) - #0ax) - -(def-adjust-array-test adjust-array.18 - (nil :initial-element 'x) - (nil :initial-contents 'y) - #0ay) - -(def-adjust-array-test adjust-array.19 - (nil :initial-element 'x) - (nil :initial-element 'y) - #0ax) - -(deftest adjust-array.20 - (let* ((a0 (make-array nil :initial-element 'x)) - (a1 (make-array nil :displaced-to a0)) - (a2 (adjust-array a1 nil))) - a2) - #0ax) - -;; 2-d arrays - -(def-adjust-array-test adjust-array.21 - ('(4 5) :initial-contents '((1 2 3 4 5) - (3 4 5 6 7) - (5 6 7 8 9) - (7 8 9 1 2))) - ('(2 3)) - #2a((1 2 3)(3 4 5))) - -(def-adjust-array-test adjust-array.22 - ('(4 5) :initial-contents '((1 2 3 4 5) - (3 4 5 6 7) - (5 6 7 8 9) - (7 8 9 1 2))) - ('(6 8) :initial-element 0) - #2a((1 2 3 4 5 0 0 0) - (3 4 5 6 7 0 0 0) - (5 6 7 8 9 0 0 0) - (7 8 9 1 2 0 0 0) - (0 0 0 0 0 0 0 0) - (0 0 0 0 0 0 0 0))) - -(deftest adjust-array.23 - (let* ((a1 (make-array '(4 5) :initial-contents '((#\1 #\2 #\3 #\4 #\5) - (#\3 #\4 #\5 #\6 #\7) - (#\5 #\6 #\7 #\8 #\9) - (#\7 #\8 #\9 #\1 #\2)) - :element-type 'character)) - (a2 (adjust-array a1 '(2 3) :element-type 'character))) - (assert (if (adjustable-array-p a1) - (eq a1 a2) - (equal (array-dimensions a2) '(2 3)))) - (assert (not (typep 0 (array-element-type a2)))) - a2) - #2a((#\1 #\2 #\3)(#\3 #\4 #\5))) - -;;; Macro expansion tests - -(deftest adjust-array.24 - (macrolet - ((%m (z) z)) - (let ((a (make-array '(4) :initial-contents '(a b c d)))) - (adjust-array (expand-in-current-env (%m a)) '(4)))) - #(a b c d)) - -(deftest adjust-array.25 - (macrolet - ((%m (z) z)) - (let ((a (make-array '(4) :initial-contents '(a b c d)))) - (adjust-array a (expand-in-current-env (%m '(4)))))) - #(a b c d)) - -(deftest adjust-array.26 - (macrolet - ((%m (z) z)) - (let ((a (make-array '(4) :initial-contents '(a b c d)))) - (adjust-array a '(4) (expand-in-current-env (%m :element-type)) t))) - #(a b c d)) - -(deftest adjust-array.27 - (macrolet - ((%m (z) z)) - (let ((a (make-array '(4) :initial-contents '(a b c d)))) - (adjust-array a '(4) :element-type - (expand-in-current-env (%m t))))) - #(a b c d)) - -(deftest adjust-array.28 - (macrolet - ((%m (z) z)) - (let ((a (make-array '(4) :initial-contents '(a b c d)))) - (adjust-array a '(6) (expand-in-current-env (%m :initial-element)) 17))) - #(a b c d 17 17)) - -(deftest adjust-array.29 - (macrolet - ((%m (z) z)) - (let ((a (make-array '(4) :initial-contents '(a b c d)))) - (adjust-array a '(7) :initial-element (expand-in-current-env (%m 5))))) - #(a b c d 5 5 5)) - -(deftest adjust-array.30 - (macrolet - ((%m (z) z)) - (let ((a (make-array '(4) :initial-contents '(a b c d)))) - (adjust-array a '(6) (expand-in-current-env (%m :initial-contents)) - '(1 2 3 4 5 6)))) - #(1 2 3 4 5 6)) - -(deftest adjust-array.31 - (macrolet - ((%m (z) z)) - (let ((a (make-array '(4) :initial-contents '(a b c d)))) - (adjust-array a '(3) :initial-contents - (expand-in-current-env (%m "ABC"))))) - #(#\A #\B #\C)) - -(deftest adjust-array.32 - (macrolet - ((%m (z) z)) - (let ((a (make-array '(4) :initial-contents '(a b c d)))) - (adjust-array a '(4) (expand-in-current-env (%m :fill-pointer)) nil))) - #(a b c d)) - -(deftest adjust-array.33 - (macrolet - ((%m (z) z)) - (let ((a (make-array '(4) :initial-contents '(a b c d)))) - (adjust-array a '(4) :fill-pointer (expand-in-current-env (%m nil))))) - #(a b c d)) - -(deftest adjust-array.34 - (macrolet - ((%m (z) z)) - (let ((a (make-array '(4) :initial-contents '(a b c d)))) - (adjust-array a '(4) (expand-in-current-env (%m :displaced-to)) nil))) - #(a b c d)) - -(deftest adjust-array.35 - (macrolet - ((%m (z) z)) - (let ((a (make-array '(4) :initial-contents '(a b c d)))) - (adjust-array a '(4) :displaced-to - (expand-in-current-env (%m nil))))) - #(a b c d)) - -(deftest adjust-array.36 - (macrolet - ((%m (z) z)) - (let ((a (make-array '(4) :initial-contents '(a b c d))) - (c (make-array '(8) :initial-contents '(1 2 3 4 5 6 7 8)))) - (adjust-array a '(3) :displaced-to c - (expand-in-current-env (%m :displaced-index-offset)) - 2))) - #(3 4 5)) - -(deftest adjust-array.37 - (macrolet - ((%m (z) z)) - (let ((a (make-array '(4) :initial-contents '(a b c d))) - (c (make-array '(8) :initial-contents '(1 2 3 4 5 6 7 8)))) - (adjust-array a '(5) :displaced-to c - :displaced-index-offset - (expand-in-current-env (%m 1))))) - #(2 3 4 5 6)) - -;;; Adjust an adjustable array - -(def-adjust-array-test adjust-array.adjustable.1 - (5 :initial-contents '(a b c d e) :adjustable t) - (4) - #(a b c d)) - -(def-adjust-array-test adjust-array.adjustable.2 - (5 :initial-contents '(a b c d e) :adjustable t) - (8 :initial-element 'x) - #(a b c d e x x x)) - -(def-adjust-array-test adjust-array.adjustable.3 - (5 :initial-contents '(a b c d e) :adjustable t) - (4 :initial-contents '(w x y z)) - #(w x y z)) - -(def-adjust-array-test adjust-array.adjustable.4 - (5 :initial-contents '(a b c d e) :adjustable t) - (8 :initial-contents '(8 7 6 5 4 3 2 1)) - #(8 7 6 5 4 3 2 1)) - -(def-adjust-array-fp-test adjust-array.adjustable.5 - (5 :initial-contents '(a b c d e) :fill-pointer 3 :adjustable t) - (4) - (assert (eq (aref a2 3) 'd)) - 3 #(a b c)) - -(def-adjust-array-fp-test adjust-array.adjustable.6 - (5 :initial-contents '(a b c d e) :fill-pointer 3 :adjustable t) - (4 :fill-pointer nil) - (assert (eq (aref a2 3) 'd)) - 3 #(a b c)) - -(def-adjust-array-fp-test adjust-array.adjustable.7 - (5 :initial-contents '(a b c d e) :fill-pointer 3 :adjustable t) - (4 :fill-pointer t) - nil - 4 #(a b c d)) - -(def-adjust-array-fp-test adjust-array.adjustable.8 - (5 :initial-contents '(a b c d e) :fill-pointer 3 :adjustable t) - (4 :fill-pointer 2) - (assert (equal (list (aref a2 2) (aref a2 3)) '(c d))) - 2 #(a b)) - -(def-adjust-array-fp-test adjust-array.adjustable.9 - (5 :initial-contents '(a b c d e) :fill-pointer 3 :adjustable t) - (8 :fill-pointer 5 :initial-element 'x) - (assert (equal (list (aref a2 5) (aref a2 6) (aref a2 7)) '(x x x))) - 5 #(a b c d e)) - -(deftest adjust-array.adjustable.10 - (let* ((a1 (make-array 5 :initial-contents '(a b c d e) - :adjustable t)) - (a2 (adjust-array a1 4 :displaced-to nil))) - (assert (eq a1 a2)) - (assert (not (array-displacement a2))) - a2) - #(a b c d)) - -(deftest adjust-array.adjustable.11 - (let* ((a0 (make-array 7 :initial-contents '(x a b c d e y))) - (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 - :adjustable t)) - (a2 (adjust-array a1 4))) - (assert (eq a1 a2)) - (assert (not (array-displacement a2))) - a2) - #(a b c d)) - -(deftest adjust-array.adjustable.12 - (let* ((a0 (make-array 7 :initial-contents '(x a b c d e y))) - (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 - :adjustable t)) - (a2 (adjust-array a1 4 :displaced-to a0))) - (assert (eq a1 a2)) - a2) - #(x a b c)) - -(deftest adjust-array.adjustable.13 - (let* ((a0 (make-array 7 :initial-contents '(x a b c d e y))) - (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 - :adjustable t)) - (a2 (make-array 4 :displaced-to a1 :displaced-index-offset 1))) - (assert (eq a1 (adjust-array a1 5 :displaced-to a0 - :displaced-index-offset 2))) - a2) - #(c d e y)) - - -;;;; Strings - -(loop for element-type in '(character base-char) - for forms = `( -(def-adjust-array-test adjust-array.string.1 - (5 :element-type 'character :initial-contents "abcde") - (4 :element-type 'character) - "abcd") - -(def-adjust-array-test adjust-array.string.2 - (5 :element-type 'character :initial-contents "abcde") - (8 :element-type 'character :initial-element #\x) - "abcdexxx") - -(def-adjust-array-test adjust-array.string.3 - (5 :element-type 'character :initial-contents "abcde") - (4 :element-type 'character :initial-contents "wxyz") - "wxyz") - -(def-adjust-array-test adjust-array.string.4 - (5 :element-type 'character :initial-contents "abcde") - (8 :element-type 'character :initial-contents "87654321") - "87654321") - -(def-adjust-array-fp-test adjust-array.string.5 - (5 :element-type 'character :initial-contents "abcde" :fill-pointer 3) - (4 :element-type 'character) - (assert (eql (aref a2 3) #\d)) - 3 "abc") - -(def-adjust-array-fp-test adjust-array.string.6 - (5 :element-type 'character :initial-contents "abcde" :fill-pointer 3) - (4 :element-type 'character :fill-pointer nil) - (assert (eql (aref a2 3) #\d)) - 3 "abc") - -(def-adjust-array-fp-test adjust-array.string.7 - (5 :element-type 'character :initial-contents "abcde" :fill-pointer 3) - (4 :element-type 'character :fill-pointer t) - nil - 4 "abcd") - -(def-adjust-array-fp-test adjust-array.string.8 - (5 :element-type 'character :initial-contents "abcde" :fill-pointer 3) - (4 :element-type 'character :fill-pointer 2) - (progn (assert (eql (aref a2 2) #\c)) - (assert (eql (aref a2 3) #\d))) - 2 "ab") - -(def-adjust-array-fp-test adjust-array.string.9 - (5 :element-type 'character :initial-contents "abcde" :fill-pointer 3) - (8 :element-type 'character :fill-pointer 5 :initial-element #\x) - (assert (equal (list (aref a2 5) (aref a2 6) (aref a2 7)) - '(#\x #\x #\x))) - 5 "abcde") - -(deftest adjust-array.string.10 - (let* ((a1 (make-array 5 :element-type 'character :initial-contents "abcde")) - (a2 (adjust-array a1 4 :displaced-to nil :element-type 'character))) - (assert (if (adjustable-array-p a1) - (eq a1 a2) - (equal (array-dimensions a1) '(5)))) - (assert (not (array-displacement a2))) - a2) - "abcd") - -(deftest adjust-array.string.11 - (let* ((a0 (make-array 7 :initial-contents "xabcdey" :element-type 'character)) - (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 - :element-type 'character)) - (a2 (adjust-array a1 4 :element-type 'character))) - (assert (if (adjustable-array-p a1) - (eq a1 a2) - (equal (array-dimensions a1) '(5)))) - (assert (not (array-displacement a2))) - a2) - "abcd") - -(deftest adjust-array.string.12 - (let* ((a0 (make-array 7 :initial-contents "1234567" :element-type 'character)) - (a1 (make-array 5 :initial-contents "abcde" :element-type 'character)) - (a2 (adjust-array a1 4 :displaced-to a0 :element-type 'character))) - (assert (if (adjustable-array-p a1) - (eq a1 a2) - (equal (array-dimensions a1) '(5)))) - (assert (equal (multiple-value-list (array-displacement a2)) - (list a0 0))) - a2) - "1234") - -(deftest adjust-array.string.13 - (let* ((a0 (make-array 7 :initial-contents "1234567" :element-type 'character)) - (a1 (make-array 5 :initial-contents "abcde" :element-type 'character)) - (a2 (adjust-array a1 4 :displaced-to a0 - :displaced-index-offset 2 - :element-type 'character))) - (assert (if (adjustable-array-p a1) - (eq a1 a2) - (equal (array-dimensions a1) '(5)))) - (assert (equal (multiple-value-list (array-displacement a2)) - (list a0 2))) - a2) - "3456") - -(deftest adjust-array.string.14 - (let* ((a0 (make-array 7 :initial-contents "1234567" :element-type 'character)) - (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 - :element-type 'character)) - (a2 (adjust-array a1 4 :displaced-to a0 :element-type 'character))) - (assert (if (adjustable-array-p a1) - (eq a1 a2) - (equal (array-dimensions a1) '(5)))) - (assert (equal (multiple-value-list (array-displacement a2)) - (list a0 0))) - a2) - "1234") - -(deftest adjust-array.string.15 - (let* ((a0 (make-array 7 :initial-contents "1234567" :element-type 'character)) - (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 - :element-type 'character)) - (a2 (make-array 4 :displaced-to a1 :displaced-index-offset 1 - :element-type 'character)) - (a3 (adjust-array a2 4 :displaced-to a1 :element-type 'character))) - a3) - "2345") - -(deftest adjust-array.string.16 - (let* ((a0 (make-array 7 :initial-contents "1234567" :element-type 'character)) - (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 - :element-type 'character)) - (a2 (adjust-array a1 5 :displaced-to a0 :element-type 'character))) - a2) - "12345") - -(def-adjust-array-test adjust-array.string.17 - (nil :initial-element #\x :element-type 'character) - (nil) - #.(make-array nil :initial-element #\x :element-type 'character)) - -(def-adjust-array-test adjust-array.string.18 - (nil :initial-element #\x :element-type 'character) - (nil :initial-contents #\y :element-type 'character) - #.(make-array nil :initial-element #\y :element-type 'character)) - -(def-adjust-array-test adjust-array.string.19 - (nil :initial-element #\x :element-type 'character) - (nil :initial-element #\y :element-type 'character) - #.(make-array nil :initial-element #\x :element-type 'character)) - - -(deftest adjust-array.string.20 - (let* ((a0 (make-array nil :initial-element #\x :element-type 'character)) - (a1 (make-array nil :displaced-to a0 :element-type 'character)) - (a2 (adjust-array a1 nil :element-type 'character))) - a2) - #.(make-array nil :initial-element #\x :element-type 'character)) - -(def-adjust-array-test adjust-array.string.adjustable.1 - (5 :initial-contents "abcde" :adjustable t :element-type 'character) - (4 :element-type 'character) - "abcd") - -(def-adjust-array-test adjust-array.string.adjustable.2 - (5 :initial-contents "abcde" :adjustable t :element-type 'character) - (8 :initial-element #\x :element-type 'character) - "abcdexxx") - -(def-adjust-array-test adjust-array.string.adjustable.3 - (5 :initial-contents "abcde" :adjustable t :element-type 'character) - (4 :initial-contents "wxyz" :element-type 'character) - "wxyz") - -(def-adjust-array-test adjust-array.string.adjustable.4 - (5 :initial-contents "abcde" :adjustable t :element-type 'character) - (8 :initial-contents "87654321" :element-type 'character) - "87654321") - -(def-adjust-array-fp-test adjust-array.string.adjustable.5 - (5 :initial-contents "abcde" :fill-pointer 3 :adjustable t :element-type 'character) - (4 :element-type 'character :initial-element #\Space) - (assert (eql (aref a2 3) #\d)) - 3 "abc") - -(def-adjust-array-fp-test adjust-array.string.adjustable.6 - (5 :initial-contents "abcde" :fill-pointer 3 :adjustable t :element-type 'character) - (4 :fill-pointer nil :element-type 'character :initial-element #\?) - (assert (eql (aref a2 3) #\d)) - 3 "abc") - -(def-adjust-array-fp-test adjust-array.string.adjustable.7 - (5 :initial-contents "abcde" :fill-pointer 3 :adjustable t :element-type 'character) - (4 :fill-pointer t :element-type 'character :initial-element #\!) - nil - 4 "abcd") - -(def-adjust-array-fp-test adjust-array.string.adjustable.8 - (5 :initial-contents "abcde" :fill-pointer 3 :adjustable t :element-type 'character) - (4 :fill-pointer 2 :element-type 'character :initial-element #\X) - (assert (equal (list (aref a2 2) (aref a2 3)) '(#\c #\d))) - 2 "ab") - -(def-adjust-array-fp-test adjust-array.string.adjustable.9 - (5 :initial-contents "abcde" :fill-pointer 3 :adjustable t :element-type 'character) - (8 :fill-pointer 5 :initial-element #\x :element-type 'character) - (assert (equal (list (aref a2 5) (aref a2 6) (aref a2 7)) '(#\x #\x #\x))) - 5 "abcde") - -(deftest adjust-array.string.adjustable.10 - (let* ((a1 (make-array 5 :initial-contents "abcde" - :adjustable t :element-type 'character)) - (a2 (adjust-array a1 4 :displaced-to nil :element-type 'character))) - (assert (eq a1 a2)) - (assert (not (array-displacement a2))) - a2) - "abcd") - -(deftest adjust-array.string.adjustable.11 - (let* ((a0 (make-array 7 :initial-contents "xabcdey" :element-type 'character)) - (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 - :adjustable t :element-type 'character)) - (a2 (adjust-array a1 4 :element-type 'character))) - (assert (eq a1 a2)) - (assert (not (array-displacement a2))) - a2) - "abcd") - -(deftest adjust-array.string.adjustable.12 - (let* ((a0 (make-array 7 :initial-contents "xabcdey" :element-type 'character)) - (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 - :adjustable t :element-type 'character)) - (a2 (adjust-array a1 4 :displaced-to a0 :element-type 'character))) - (assert (eq a1 a2)) - a2) - "xabc") - -(deftest adjust-array.string.adjustable.13 - (let* ((a0 (make-array 7 :initial-contents "xabcdey" :element-type 'character)) - (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 - :adjustable t :element-type 'character)) - (a2 (make-array 4 :displaced-to a1 :displaced-index-offset 1 - :element-type 'character))) - (assert (eq a1 (adjust-array a1 5 :displaced-to a0 - :displaced-index-offset 2 - :element-type 'character))) - a2) - "cdey") -) - for forms2 = (subst element-type 'character forms) - for forms3 = (mapcar #'(lambda (form) - (destructuring-bind (dt name . body) form - `(,dt ,(if (eql element-type 'character) name - (intern (replace (copy-seq (symbol-name name)) - "BASEST" - :start1 13 :end1 19) - (symbol-package name))) - ,@ body))) - forms2) - do (eval `(progn ,@forms3))) - -;; 2-d arrays - -(def-adjust-array-test adjust-array.string.21 - ('(4 5) :initial-contents '("12345" "34567" "56789" "78912") - :element-type 'character) - ('(2 3)) - #.(make-array '(2 3) :initial-contents '("123" "345") - :element-type 'character)) - -(def-adjust-array-test adjust-array.string.22 - ('(4 5) :initial-contents '("12345" "34567" "56789" "78912") - :element-type 'character) - ('(6 8) :initial-element #\0 :element-type 'character) - #.(make-array '(6 8) - :initial-contents '("12345000" "34567000" "56789000" - "78912000" "00000000" "00000000") - :element-type 'character)) - -(def-adjust-array-test adjust-array.bit-vector.1 - (5 :element-type 'bit :initial-contents #*01100) - (4 :element-type 'bit) - #*0110) - -(def-adjust-array-test adjust-array.bit-vector.2 - (5 :element-type 'bit :initial-contents #*01100) - (8 :element-type 'bit :initial-element 1) - #*01100111) - -(def-adjust-array-test adjust-array.bit-vector.3 - (5 :element-type 'bit :initial-contents #*01100) - (4 :element-type 'bit :initial-contents #*1011) - #*1011) - -(def-adjust-array-test adjust-array.bit-vector.4 - (5 :element-type 'bit :initial-contents #*01100) - (8 :element-type 'bit :initial-contents #*11110000) - #*11110000) - -(def-adjust-array-fp-test adjust-array.bit-vector.5 - (5 :element-type 'bit :initial-contents #*01100 :fill-pointer 3) - (4 :element-type 'bit) - (assert (eql (aref a2 3) 0)) - 3 #*011) - -(def-adjust-array-fp-test adjust-array.bit-vector.6 - (5 :element-type 'bit :initial-contents #*01100 :fill-pointer 3) - (4 :element-type 'bit :fill-pointer nil) - (assert (eql (aref a2 3) 0)) - 3 #*011) - -(def-adjust-array-fp-test adjust-array.bit-vector.7 - (5 :element-type 'bit :initial-contents #*01100 :fill-pointer 3) - (4 :element-type 'bit :fill-pointer t) - nil - 4 #*0110) - -(def-adjust-array-fp-test adjust-array.bit-vector.8 - (5 :element-type 'bit :initial-contents #*01100 :fill-pointer 3) - (4 :element-type 'bit :fill-pointer 2) - (progn (assert (eql (aref a2 2) 1)) - (assert (eql (aref a2 3) 0))) - 2 #*01) - -(def-adjust-array-fp-test adjust-array.bit-vector.9 - (5 :element-type 'bit :initial-contents #*01100 :fill-pointer 3) - (8 :element-type 'bit :fill-pointer 5 :initial-element 1) - (assert (equal (list (aref a2 5) (aref a2 6) (aref a2 7)) - '(1 1 1))) - 5 #*01100) - -(deftest adjust-array.bit-vector.10 - (let* ((a1 (make-array 5 :element-type 'bit :initial-contents #*01100)) - (a2 (adjust-array a1 4 :displaced-to nil :element-type 'bit))) - (assert (if (adjustable-array-p a1) - (eq a1 a2) - (equal (array-dimensions a1) '(5)))) - (assert (not (array-displacement a2))) - a2) - #*0110) - -(deftest adjust-array.bit-vector.11 - (let* ((a0 (make-array 7 :initial-contents #*0011001 :element-type 'bit)) - (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 - :element-type 'bit)) - (a2 (adjust-array a1 4 :element-type 'bit))) - (assert (if (adjustable-array-p a1) - (eq a1 a2) - (equal (array-dimensions a1) '(5)))) - (assert (not (array-displacement a2))) - a2) - #*0110) - -(deftest adjust-array.bit-vector.12 - (let* ((a0 (make-array 7 :initial-contents #*1010101 :element-type 'bit)) - (a1 (make-array 5 :initial-contents #*01100 :element-type 'bit)) - (a2 (adjust-array a1 4 :displaced-to a0 :element-type 'bit))) - (assert (if (adjustable-array-p a1) - (eq a1 a2) - (equal (array-dimensions a1) '(5)))) - (assert (equal (multiple-value-list (array-displacement a2)) - (list a0 0))) - a2) - #*1010) - -(deftest adjust-array.bit-vector.13 - (let* ((a0 (make-array 7 :initial-contents #*1011101 :element-type 'bit)) - (a1 (make-array 5 :initial-contents #*01100 :element-type 'bit)) - (a2 (adjust-array a1 4 :displaced-to a0 - :displaced-index-offset 2 - :element-type 'bit))) - (assert (if (adjustable-array-p a1) - (eq a1 a2) - (equal (array-dimensions a1) '(5)))) - (assert (equal (multiple-value-list (array-displacement a2)) - (list a0 2))) - a2) - #*1110) - -(deftest adjust-array.bit-vector.14 - (let* ((a0 (make-array 7 :initial-contents #*1011001 :element-type 'bit)) - (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 - :element-type 'bit)) - (a2 (adjust-array a1 4 :displaced-to a0 :element-type 'bit))) - (assert (if (adjustable-array-p a1) - (eq a1 a2) - (equal (array-dimensions a1) '(5)))) - (assert (equal (multiple-value-list (array-displacement a2)) - (list a0 0))) - a2) - #*1011) - -(deftest adjust-array.bit-vector.15 - (let* ((a0 (make-array 7 :initial-contents #*1100010 :element-type 'bit)) - (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 - :element-type 'bit)) - (a2 (make-array 4 :displaced-to a1 :displaced-index-offset 1 - :element-type 'bit)) - (a3 (adjust-array a2 4 :displaced-to a1 :element-type 'bit))) - a3) - #*1000) - -(deftest adjust-array.bit-vector.16 - (let* ((a0 (make-array 7 :initial-contents #*1011011 :element-type 'bit)) - (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 - :element-type 'bit)) - (a2 (adjust-array a1 5 :displaced-to a0 :element-type 'bit))) - a2) - #*10110) - -(def-adjust-array-test adjust-array.bit-vector.17 - (nil :initial-element 0 :element-type 'bit) - (nil) - #.(make-array nil :initial-element 0 :element-type 'bit)) - -(def-adjust-array-test adjust-array.bit-vector.18 - (nil :initial-element 0 :element-type 'bit) - (nil :initial-contents 1 :element-type 'bit) - #.(make-array nil :initial-element 1 :element-type 'bit)) - -(def-adjust-array-test adjust-array.bit-vector.19 - (nil :initial-element 1 :element-type 'bit) - (nil :initial-element 0 :element-type 'bit) - #.(make-array nil :initial-element 1 :element-type 'bit)) - -(deftest adjust-array.bit-vector.20 - (let* ((a0 (make-array nil :initial-element 1 :element-type 'bit)) - (a1 (make-array nil :displaced-to a0 :element-type 'bit)) - (a2 (adjust-array a1 nil :element-type 'bit))) - a2) - #.(make-array nil :initial-element 1 :element-type 'bit)) - -;; 2-d arrays - -(def-adjust-array-test adjust-array.bit-vector.21 - ('(4 5) :initial-contents '(#*11100 #*00110 #*00001 #*11111) - :element-type 'bit) - ('(2 3)) - #.(make-array '(2 3) :initial-contents '(#*111 #*001) - :element-type 'bit)) - -(def-adjust-array-test adjust-array.bit-vector.22 - ('(4 5) :initial-contents '(#*11100 #*00110 #*00001 #*11111) - :element-type 'bit) - ('(6 8) :initial-element 0 :element-type 'bit) - #.(make-array '(6 8) - :initial-contents '(#*11100000 #*00110000 #*00001000 - #*11111000 #*00000000 #*00000000) - :element-type 'bit)) - -;;; Adjustable bit vector tests - -(def-adjust-array-test adjust-array.bit-vector.adjustable.1 - (5 :initial-contents '(1 0 1 1 0) :adjustable t :element-type 'bit) - (4 :element-type 'bit) - #*1011) - -(def-adjust-array-test adjust-array.bit-vector.adjustable.2 - (5 :initial-contents '(1 0 1 0 1) :adjustable t :element-type 'bit) - (8 :initial-element '1 :element-type 'bit) - #*10101111) - -(def-adjust-array-test adjust-array.bit-vector.adjustable.3 - (5 :initial-contents '(0 1 0 1 0) :adjustable t :element-type 'bit) - (4 :initial-contents '(1 1 1 0) :element-type 'bit) - #*1110) - -(def-adjust-array-test adjust-array.bit-vector.adjustable.4 - (5 :initial-contents '(1 0 0 1 0) :adjustable t :element-type 'bit) - (8 :initial-contents '(0 1 0 1 1 0 1 0) :element-type 'bit) - #*01011010) - -(def-adjust-array-fp-test adjust-array.bit-vector.adjustable.5 - (5 :initial-contents '(1 1 1 0 0) :fill-pointer 3 :adjustable t :element-type 'bit) - (4 :element-type 'bit :initial-element 0) - (assert (eql (aref a2 3) 0)) - 3 #*111) - -(def-adjust-array-fp-test adjust-array.bit-vector.adjustable.6 - (5 :initial-contents '(0 0 0 1 1) :fill-pointer 3 :adjustable t :element-type 'bit) - (4 :fill-pointer nil :element-type 'bit :initial-element 1) - (assert (eql (aref a2 3) 1)) - 3 #*000) - -(def-adjust-array-fp-test adjust-array.bit-vector.adjustable.7 - (5 :initial-contents '(1 1 0 1 1) :fill-pointer 3 :adjustable t :element-type 'bit) - (4 :fill-pointer t :element-type 'bit :initial-element 1) - nil - 4 #*1101) - -(def-adjust-array-fp-test adjust-array.bit-vector.adjustable.8 - (5 :initial-contents '(0 1 1 1 0) :fill-pointer 3 :adjustable t :element-type 'bit) - (4 :fill-pointer 2 :element-type 'bit :initial-element 0) - (assert (equal (list (aref a2 2) (aref a2 3)) '(1 1))) - 2 #*01) - -(def-adjust-array-fp-test adjust-array.bit-vector.adjustable.9 - (5 :initial-contents '(1 0 0 0 1) :fill-pointer 3 :adjustable t :element-type 'bit) - (8 :fill-pointer 5 :initial-element 1 :element-type 'bit) - (assert (equal (list (aref a2 5) (aref a2 6) (aref a2 7)) '(1 1 1))) - 5 #*10001) - -(deftest adjust-array.bit-vector.adjustable.10 - (let* ((a1 (make-array 5 :initial-contents '(0 1 1 0 1) - :adjustable t :element-type 'bit)) - (a2 (adjust-array a1 4 :displaced-to nil :element-type 'bit))) - (assert (eq a1 a2)) - (assert (not (array-displacement a2))) - a2) - #*0110) - -(deftest adjust-array.bit-vector.adjustable.11 - (let* ((a0 (make-array 7 :initial-contents '(0 1 0 1 1 1 0) - :element-type 'bit)) - (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 - :adjustable t :element-type 'bit)) - (a2 (adjust-array a1 4 :element-type 'bit))) - (assert (eq a1 a2)) - (assert (not (array-displacement a2))) - a2) - #*1011) - -(deftest adjust-array.bit-vector.adjustable.12 - (let* ((a0 (make-array 7 :initial-contents '(0 0 1 1 1 1 1) - :element-type 'bit)) - (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 - :adjustable t :element-type 'bit)) - (a2 (adjust-array a1 4 :displaced-to a0 :element-type 'bit))) - (assert (eq a1 a2)) - a2) - #*0011) - -(deftest adjust-array.bit-vector.adjustable.13 - (let* ((a0 (make-array 7 :initial-contents '(1 0 0 0 0 0 1) :element-type 'bit)) - (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 - :adjustable t :element-type 'bit)) - (a2 (make-array 4 :displaced-to a1 :displaced-index-offset 1 - :element-type 'bit))) - (assert (eq a1 (adjust-array a1 5 :displaced-to a0 - :displaced-index-offset 2 - :element-type 'bit))) - a2) - #*0001) - -;;; FIXME. specialized integer array tests - -;;; FIXNME float array tests - -;;; Error cases - -(deftest adjust-array.error.1 - (signals-error (adjust-array) program-error) - t) - -(deftest adjust-array.error.2 - (signals-error (adjust-array (make-array 10 :initial-element nil)) - program-error) - t) - -(deftest adjust-array.error.3 - (signals-error (adjust-array (make-array 10 :initial-element nil) - 8 :bad t) - program-error) - t) - -(deftest adjust-array.error.4 - (signals-error (adjust-array (make-array 10 :initial-element nil) - 8 :initial-element) - program-error) - t) - -(deftest adjust-array.error.5 - (signals-error (adjust-array (make-array 10 :initial-element nil) - 8 - :allow-other-keys nil - :allow-other-keys t - :bad t) - program-error) - t) - -(deftest adjust-array.error.6 - (signals-error - (let ((a (make-array 5 :initial-element 'x))) - (adjust-array a :fill-pointer 4)) - error) - t) diff --git a/t/ansi-test/arrays/adjustable-array-p.lsp b/t/ansi-test/arrays/adjustable-array-p.lsp deleted file mode 100644 index 03abfdd..0000000 --- a/t/ansi-test/arrays/adjustable-array-p.lsp +++ /dev/null @@ -1,69 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Jan 20 21:25:22 2003 -;;;; Contains: Tests for ADJUSTABLE-ARRAY-P - - - -(deftest adjustable-array-p.1 - (notnot (adjustable-array-p (make-array '(5) :adjustable t))) - t) - -(deftest adjustable-array-p.2 - (notnot (adjustable-array-p (make-array nil :adjustable t))) - t) - -(deftest adjustable-array-p.3 - (notnot (adjustable-array-p (make-array '(2 3) :adjustable t))) - t) - -(deftest adjustable-array-p.4 - (notnot (adjustable-array-p (make-array '(2 2 2) :adjustable t))) - t) - -(deftest adjustable-array-p.5 - (notnot (adjustable-array-p (make-array '(2 2 2 2) :adjustable t))) - t) - -(deftest adjustable-array-p.6 - (macrolet ((%m (z) z)) - (let ((a (make-array '(5) :adjustable t))) - (notnot (adjustable-array-p (expand-in-current-env (%m a)))))) - t) - -(deftest adjustable-array-p.order.1 - (let ((i 0) x) - (values - (notnot (adjustable-array-p (progn (setf x (incf i)) - (make-array '(5) :adjustable t)))) - i x)) - t 1 1) - -;;; Error tests - -(deftest adjustable-array-p.error.1 - (signals-error (adjustable-array-p) program-error) - t) - -(deftest adjustable-array-p.error.2 - (signals-error (adjustable-array-p "aaa" nil) program-error) - t) - -(deftest adjustable-array-p.error.3 - (signals-type-error x 10 (adjustable-array-p x)) - t) - -(deftest adjustable-array-p.error.4 - (check-type-error #'adjustable-array-p #'arrayp) - nil) - -(deftest adjustable-array-p.error.5 - (signals-error (locally (adjustable-array-p 10)) type-error) - t) - -(deftest adjustable-array-p.error.6 - (signals-error (let ((x 10)) - (locally (declare (optimize (safety 3))) - (adjustable-array-p x))) - type-error) - t) diff --git a/t/ansi-test/arrays/aref.lsp b/t/ansi-test/arrays/aref.lsp deleted file mode 100644 index 73d54fb..0000000 --- a/t/ansi-test/arrays/aref.lsp +++ /dev/null @@ -1,168 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Feb 11 17:33:24 2003 -;;;; Contains: Tests for AREF - - - -;;; AREF is also tested in many other places - -(deftest aref.1 - (aref #0aT) - T) - -(deftest aref.2 - (aref #(1 2 3 4) 2) - 3) - -(deftest aref.3 - (aref #2a((a b c d)(e f g h)) 1 2) - g) - -(deftest aref.4 - (loop for i from 0 below 6 collect (aref "abcdef" i)) - (#\a #\b #\c #\d #\e #\f)) - -(deftest aref.5 - (let ((a (make-array '(2 3) :element-type 'base-char - :initial-contents '("abc" "def")))) - (loop for i below 2 - collect (loop for j below 3 - collect (aref a i j)))) - ((#\a #\b #\c) - (#\d #\e #\f))) - -(deftest aref.6 - (loop for i below 10 collect (aref #*1101100010 i)) - (1 1 0 1 1 0 0 0 1 0)) - -(deftest aref.7 - (let ((a (make-array '(2 5) :element-type 'bit - :initial-contents '((1 1 0 0 1) - (0 1 0 1 0))))) - (loop for i below 2 - collect (loop for j below 5 - collect (aref a i j)))) - ((1 1 0 0 1) - (0 1 0 1 0))) - -;;; Order of argument evaluation - -(deftest aref.order.1 - (let ((i 0) x y (a #(a b c d))) - (values - (aref (progn (setf x (incf i)) a) - (progn (setf y (incf i)) 2)) - i x y)) - c 2 1 2) - -(deftest aref.order.2 - (let ((i 0) x y z (a #2a((a b c)(d e f)))) - (values - (aref (progn (setf x (incf i)) a) - (progn (setf y (incf i)) 1) - (progn (setf z (incf i)) 2)) - i x y z)) - f 3 1 2 3) - - -;;; Setf of aref - -(deftest setf-aref.1 - (let ((a (copy-seq #(1 2 3 4)))) - (values - (setf (aref a 2) 'z) - a)) - z - #(1 2 z 4)) - -(deftest setf-aref.2 - (let ((a (make-array nil :initial-element 1))) - (values - (setf (aref a) 'z) - a)) - z #0az) - -(deftest setf-aref.3 - (let ((a (make-array '(2 3) :initial-element 'a))) - (values - (setf (aref a 0 1) 'z) - a)) - z - #2a((a z a)(a a a))) - -(deftest setf-aref.4 - (let ((a (copy-seq "abcd"))) - (values - (setf (aref a 0) #\z) - a)) - #\z - "zbcd") - -(deftest setf-aref.5 - (let ((a (copy-seq #*0011))) - (values - (setf (aref a 0) 1) - a)) - 1 - #*1011) - -(deftest setf-aref.6 - (let ((a (make-array '(2 3) :initial-element #\a :element-type 'base-char))) - (values - (setf (aref a 0 1) #\z) - a)) - #\z - #2a((#\a #\z #\a)(#\a #\a #\a))) - -(deftest setf-aref.7 - (let ((a (make-array '(2 3) :initial-element 1 :element-type 'bit))) - (values - (setf (aref a 0 1) 0) - a)) - 0 - #2a((1 0 1)(1 1 1))) - -(deftest setf-aref.order.1 - (let ((i 0) x y z (a (copy-seq #(a b c d)))) - (values - (setf (aref (progn (setf x (incf i)) a) - (progn (setf y (incf i)) 2)) - (progn (setf z (incf i)) 'z)) - a - i x y z)) - z #(a b z d) 3 1 2 3) - -;;; To add: aref on displaced arrays, arrays with fill pointers, etc. - -(deftest aref.special-integer.1 - (do-special-integer-vectors - (v #(1 1 0 1 0 1) nil) - (assert (= (aref v 0) 1)) - (assert (= (aref v 1) 1)) - (assert (= (aref v 2) 0)) - (assert (= (aref v 3) 1)) - (assert (= (aref v 4) 0)) - (assert (= (aref v 5) 1))) - nil) - -(deftest aref.special-strings.1 - (do-special-strings - (s "ABCDE" nil) - (assert (eql (aref s 0) #\A)) - (assert (eql (aref s 1) #\B)) - (assert (eql (aref s 2) #\C)) - (assert (eql (aref s 3) #\D)) - (assert (eql (aref s 4) #\E))) - nil) - -;;; Error tests - -(deftest aref.error.1 - (signals-error (aref) program-error) - t) - -(deftest aref.error.2 - (signals-error (funcall #'aref) program-error) - t) - diff --git a/t/ansi-test/arrays/array-as-class.lsp b/t/ansi-test/arrays/array-as-class.lsp deleted file mode 100644 index 183f036..0000000 --- a/t/ansi-test/arrays/array-as-class.lsp +++ /dev/null @@ -1,66 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jan 26 07:45:25 2003 -;;;; Contains: Tests for ARRAY as a class - - - -(deftest array-as-class.1 - (notnot-mv (typep #() (find-class 'array))) - t) - -(deftest array-as-class.2 - (notnot-mv (typep #(a b c) (find-class 'array))) - t) - -(deftest array-as-class.3 - (notnot-mv (typep #0aNIL (find-class 'array))) - t) - -(deftest array-as-class.4 - (notnot-mv (typep #2a((a b)(c d)) (find-class 'array))) - t) - -(deftest array-as-class.5 - (notnot-mv (typep "abcde" (find-class 'array))) - t) - -(deftest array-as-class.6 - (notnot-mv (typep #*0011101 (find-class 'array))) - t) - -(deftest array-as-class.7 - (subtypep* 'array (find-class 'array)) - t t) - -(deftest array-as-class.8 - (subtypep* (find-class 'array) 'array) - t t) - -(deftest array-as-class.9 - (typep nil (find-class 'array)) - nil) - -(deftest array-as-class.10 - (typep 'x (find-class 'array)) - nil) - -(deftest array-as-class.11 - (typep '(a b c) (find-class 'array)) - nil) - -(deftest array-as-class.12 - (typep 10.0 (find-class 'array)) - nil) - -(deftest array-as-class.13 - (typep #'(lambda (x) (cons x nil)) (find-class 'array)) - nil) - -(deftest array-as-class.14 - (typep 1 (find-class 'array)) - nil) - -(deftest array-as-class.15 - (typep (1+ most-positive-fixnum) (find-class 'array)) - nil) diff --git a/t/ansi-test/arrays/array-dimension.lsp b/t/ansi-test/arrays/array-dimension.lsp deleted file mode 100644 index 7454cd5..0000000 --- a/t/ansi-test/arrays/array-dimension.lsp +++ /dev/null @@ -1,72 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Jan 21 06:55:14 2003 -;;;; Contains: Tests of ARRAY-DIMENSION - - - -;;; array-dimension is also tested by the tests in make-array.lsp - -(deftest array-dimension.1 - (array-dimension #(0 1 2 3) 0) - 4) - -(deftest array-dimension.2 - (array-dimension "abcdef" 0) - 6) - -(deftest array-dimension.3 - (array-dimension #2a((1 2 3 4)(5 6 7 8)) 0) - 2) - -(deftest array-dimension.4 - (array-dimension #2a((1 2 3 4)(5 6 7 8)) 1) - 4) - -(deftest array-dimension.5 - (let ((a (make-array '(10) :fill-pointer 5))) - (array-dimension a 0)) - 10) - -(deftest array-dimension.6 - (let ((a (make-array '(10) :adjustable t))) - (values - (array-dimension a 0) - (progn - (adjust-array a '(20)) - (array-dimension a 0)))) - 10 20) - -(deftest array-dimension.7 - (macrolet ((%m (z) z)) - (array-dimension (expand-in-current-env (%m "abc")) 0)) - 3) - -(deftest array-dimension.8 - (macrolet ((%m (z) z)) - (array-dimension #2a((a b)(c d)(e f)) - (expand-in-current-env (%m 0)))) - 3) - -(deftest array-dimension.order.1 - (let ((i 0) a b) - (values - (array-dimension (progn (setf a (incf i)) #(a b c d)) - (progn (setf b (incf i)) 0)) - i a b)) - 4 2 1 2) - -;;; Error tests - -(deftest array-dimension.error.1 - (signals-error (array-dimension) program-error) - t) - -(deftest array-dimension.error.2 - (signals-error (array-dimension #(a b c)) program-error) - t) - -(deftest array-dimension.error.3 - (signals-error (array-dimension #(a b c) 0 nil) - program-error) - t) diff --git a/t/ansi-test/arrays/array-dimensions.lsp b/t/ansi-test/arrays/array-dimensions.lsp deleted file mode 100644 index 3178556..0000000 --- a/t/ansi-test/arrays/array-dimensions.lsp +++ /dev/null @@ -1,69 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Jan 21 06:59:37 2003 -;;;; Contains: Tests of ARRAY-DIMENSIONS - - - -;;; The tests in make-array.lsp also test this function - -(deftest array-dimensions.1 - (array-dimensions #0aX) - nil) - -(deftest array-dimensions.2 - (array-dimensions #(a b c d)) - (4)) - -(deftest array-dimensions.3 - (array-dimensions #*0011011011) - (10)) - -(deftest array-dimensions.4 - (array-dimensions "abcdef") - (6)) - -(deftest array-dimensions.5 - (array-dimensions #2a((1 2 3)(4 5 6)(7 8 9)(10 11 12))) - (4 3)) - -(deftest array-dimensions.6 - (let ((a (make-array '(2 3 4) :adjustable t))) - (values (array-dimension a 0) - (array-dimension a 1) - (array-dimension a 2))) - 2 3 4) - -(deftest array-dimensions.7 - (let ((a (make-array '(10) :fill-pointer 5))) - (array-dimension a 0)) - 10) - -(deftest array-dimensions.8 - (macrolet ((%m (z) z)) (array-dimensions - (expand-in-current-env (%m #2a((a b)(c d)(e f)))))) - (3 2)) - -;;; Error tests - -(deftest array-dimensions.error.1 - (signals-error (array-dimensions) program-error) - t) - -(deftest array-dimensions.error.2 - (signals-error (array-dimensions #(a b c) nil) - program-error) - t) - -(deftest array-dimensions.error.3 - (check-type-error #'array-dimensions #'arrayp) - nil) - -(deftest array-dimensions.error.4 - (signals-type-error x nil (array-dimensions x)) - t) - -(deftest array-dimensions.error.5 - (signals-error (locally (array-dimensions nil)) - type-error) - t) diff --git a/t/ansi-test/arrays/array-displacement.lsp b/t/ansi-test/arrays/array-displacement.lsp deleted file mode 100644 index f026ffa..0000000 --- a/t/ansi-test/arrays/array-displacement.lsp +++ /dev/null @@ -1,138 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Jan 21 06:20:51 2003 -;;;; Contains: Tests for ARRAY-DISPLACEMENT - - - -;;; The tests in make-array.lsp also test array-displacement - -;;; The standard is contradictory about whether arrays created with -;;; :displaced-to NIL should return NIL as their primary value or -;;; not. I will assume (as per Kent Pitman's comment on comp.lang.lisp) -;;; that an implementation is free to implement all arrays as actually -;;; displaced. Therefore, I've omitted all the tests of not-expressly -;;; displaced arrays. - -;;; Behavior on expressly displaced arrays - -(deftest array-displacement.7 - (let* ((a (make-array '(10))) - (b (make-array '(10) :displaced-to a))) - (multiple-value-bind* (dt disp) - (array-displacement b) - (and (eqt a dt) - (eqlt disp 0)))) - t) - -(deftest array-displacement.8 - (let* ((a (make-array '(10))) - (b (make-array '(5) :displaced-to a :displaced-index-offset 2))) - (multiple-value-bind* (dt disp) - (array-displacement b) - (and (eqt a dt) - (eqlt disp 2)))) - t) - -(deftest array-displacement.9 - (let* ((a (make-array '(10) :element-type 'base-char)) - (b (make-array '(5) :displaced-to a :displaced-index-offset 2 - :element-type 'base-char))) - (multiple-value-bind* (dt disp) - (array-displacement b) - (and (eqt a dt) - (eqlt disp 2)))) - t) - -(deftest array-displacement.10 - (let* ((a (make-array '(10) :element-type 'base-char)) - (b (make-array '(5) :displaced-to a - :element-type 'base-char))) - (multiple-value-bind* (dt disp) - (array-displacement b) - (and (eqt a dt) - (eqlt disp 0)))) - t) - -(deftest array-displacement.11 - (let* ((a (make-array '(10) :element-type 'bit)) - (b (make-array '(5) :displaced-to a :displaced-index-offset 2 - :element-type 'bit))) - (multiple-value-bind* (dt disp) - (array-displacement b) - (and (eqt a dt) - (eqlt disp 2)))) - t) - -(deftest array-displacement.12 - (let* ((a (make-array '(10) :element-type 'bit)) - (b (make-array '(5) :displaced-to a - :element-type 'bit))) - (multiple-value-bind* (dt disp) - (array-displacement b) - (and (eqt a dt) - (eqlt disp 0)))) - t) - -(deftest array-displacement.13 - (let* ((a (make-array '(10) :element-type '(integer 0 255))) - (b (make-array '(5) :displaced-to a :displaced-index-offset 2 - :element-type '(integer 0 255)))) - (multiple-value-bind* (dt disp) - (array-displacement b) - (and (eqt a dt) - (eqlt disp 2)))) - t) - -(deftest array-displacement.14 - (let* ((a (make-array '(10) :element-type '(integer 0 255))) - (b (make-array '(5) :displaced-to a - :element-type '(integer 0 255)))) - (multiple-value-bind* (dt disp) - (array-displacement b) - (and (eqt a dt) - (eqlt disp 0)))) - t) - -(deftest array-displacement.15 - (let* ((a (make-array '(10) :initial-contents '(a b c d e f g h i j))) - (b (make-array '(5) :displaced-to a :displaced-index-offset 2))) - (macrolet - ((%m (z) z)) - (multiple-value-bind - (x y) - (array-displacement (expand-in-current-env (%m b))) - (values (eqlt x a) y)))) - t 2) - -;;; FIXME: Add tests for other kinds of specialized arrays -;;; (character, other integer types, float types, complex types) - -(deftest array-displacement.order.1 - (let* ((a (make-array '(10))) - (b (make-array '(10) :displaced-to a)) - (i 0)) - (multiple-value-bind* (dt disp) - (array-displacement (progn (incf i) b)) - (and (eql i 1) - (eqt a dt) - (eqlt disp 0)))) - t) - -;;; Error tests - -(deftest array-displacement.error.1 - (signals-error (array-displacement) program-error) - t) - -(deftest array-displacement.error.2 - (signals-error (array-displacement #(a b c) nil) program-error) - t) - -(deftest array-displacement.error.3 - (check-type-error #'array-displacement #'arrayp) - nil) - -(deftest array-displacement.error.4 - (signals-type-error x nil (array-displacement x)) - t) diff --git a/t/ansi-test/arrays/array-element-type.lsp b/t/ansi-test/arrays/array-element-type.lsp deleted file mode 100644 index 97a0168..0000000 --- a/t/ansi-test/arrays/array-element-type.lsp +++ /dev/null @@ -1,39 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Contains: Tests of the function ARRAY-ELEMENT-TYPE - - - -;;; Mosts tests are in other files, incidental to testing of -;;; other things - -(deftest array-element-type.1 - (macrolet ((%m (z) z)) - (notnot (array-element-type (expand-in-current-env (%m #(a b c)))))) - t) - -(deftest array-element-type.order.1 - (let ((i 0)) - (array-element-type (progn (incf i) #(a b c))) - i) - 1) - -;;; Error tests - -(deftest array-element-type.error.1 - (signals-error (array-element-type) program-error) - t) - -(deftest array-element-type.error.2 - (signals-error (array-element-type #(a b c) nil) program-error) - t) - -(deftest array-element-type.error.3 - (check-type-error #'array-element-type #'arrayp) - nil) - -(deftest array-element-type.error.4 - (signals-type-error x nil (array-element-type x)) - t) - - diff --git a/t/ansi-test/arrays/array-has-fill-pointer-p.lsp b/t/ansi-test/arrays/array-has-fill-pointer-p.lsp deleted file mode 100644 index 380a982..0000000 --- a/t/ansi-test/arrays/array-has-fill-pointer-p.lsp +++ /dev/null @@ -1,52 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Contains: Tests of the function ARRAY-HAS-FILL-POINTER-P - -;;; Many tests are in other files, incidental to testing of -;;; other things - -(deftest array-has-fill-pointer-p.1 - (array-has-fill-pointer-p #0a1) - nil) - -(deftest array-has-fill-pointer-p.2 - (array-has-fill-pointer-p #2a((a b)(c d))) - nil) - -(deftest array-has-fill-pointer-p.3 - (array-has-fill-pointer-p #3a(((a)))) - nil) - -(deftest array-has-fill-pointer-p.4 - (array-has-fill-pointer-p #4a((((a))))) - nil) - -(deftest array-has-fill-pointer-p.5 - (macrolet - ((%m (z) z)) - (array-has-fill-pointer-p (expand-in-current-env (%m #2a((a b)(c d)))))) - nil) - -(deftest array-has-fill-pointer-p.order.1 - (let ((i 0)) - (array-has-fill-pointer-p (progn (incf i) #(a b c))) - i) - 1) - -;;; Error tests - -(deftest array-has-fill-pointer-p.error.1 - (signals-error (array-has-fill-pointer-p) program-error) - t) - -(deftest array-has-fill-pointer-p.error.2 - (signals-error (array-has-fill-pointer-p #(a b c) nil) program-error) - t) - -(deftest array-has-fill-pointer-p.error.3 - (check-type-error #'array-has-fill-pointer-p #'arrayp) - nil) - -(deftest array-has-fill-pointer-p.error.4 - (signals-type-error x nil (array-has-fill-pointer-p x)) - t) diff --git a/t/ansi-test/arrays/array-in-bounds-p.lsp b/t/ansi-test/arrays/array-in-bounds-p.lsp deleted file mode 100644 index dc95221..0000000 --- a/t/ansi-test/arrays/array-in-bounds-p.lsp +++ /dev/null @@ -1,162 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Jan 21 19:57:29 2003 -;;;; Contains: Tests for ARRAY-IN-BOUNDS-P - - - -(deftest array-in-bounds-p.1 - (array-in-bounds-p #() 0) - nil) - -(deftest array-in-bounds-p.2 - (array-in-bounds-p #() -1) - nil) - -(deftest array-in-bounds-p.3 - (let ((a #(a b c d))) - (loop for i from 0 to 4 collect (notnot (array-in-bounds-p a i)))) - (t t t t nil)) - -(deftest array-in-bounds-p.4 - (notnot (array-in-bounds-p #0aNIL)) - t) - -(deftest array-in-bounds-p.5 - (array-in-bounds-p "" 0) - nil) - -(deftest array-in-bounds-p.6 - (array-in-bounds-p "" -1) - nil) - -(deftest array-in-bounds-p.7 - (let ((a "abcd")) - (loop for i from 0 to 4 collect (notnot (array-in-bounds-p a i)))) - (t t t t nil)) - -(deftest array-in-bounds-p.8 - (array-in-bounds-p #* 0) - nil) - -(deftest array-in-bounds-p.9 - (array-in-bounds-p #* -1) - nil) - -(deftest array-in-bounds-p.10 - (let ((a #*0110)) - (loop for i from 0 to 4 collect (notnot (array-in-bounds-p a i)))) - (t t t t nil)) - -;; Fill pointer tests - -(deftest array-in-bounds-p.11 - (let ((a (make-array '(10) :fill-pointer 5))) - (loop for i from -1 to 10 collect (notnot (array-in-bounds-p a i)))) - (nil t t t t t t t t t t nil)) - -(deftest array-in-bounds-p.12 - (let ((a (make-array '(10) :fill-pointer 5 :element-type 'bit :initial-element 0))) - (loop for i from -1 to 10 collect (notnot (array-in-bounds-p a i)))) - (nil t t t t t t t t t t nil)) - -(deftest array-in-bounds-p.13 - (let ((a (make-array '(10) :fill-pointer 5 :element-type 'base-char :initial-element #\x))) - (loop for i from -1 to 10 collect (notnot (array-in-bounds-p a i)))) - (nil t t t t t t t t t t nil)) - -(deftest array-in-bounds-p.14 - (let ((a (make-array '(10) :fill-pointer 5 :element-type 'character :initial-element #\x))) - (loop for i from -1 to 10 collect (notnot (array-in-bounds-p a i)))) - (nil t t t t t t t t t t nil)) - -;;; Displaced arrays - -(deftest array-in-bounds-p.15 - (let* ((a1 (make-array '(20))) - (a2 (make-array '(10) :displaced-to a1))) - (loop for i from -1 to 10 collect (notnot (array-in-bounds-p a2 i)))) - (nil t t t t t t t t t t nil)) - -(deftest array-in-bounds-p.16 - (let* ((a1 (make-array '(20) :element-type 'bit :initial-element 0)) - (a2 (make-array '(10) :displaced-to a1 :element-type 'bit))) - (loop for i from -1 to 10 collect (notnot (array-in-bounds-p a2 i)))) - (nil t t t t t t t t t t nil)) - -(deftest array-in-bounds-p.17 - (let* ((a1 (make-array '(20) :element-type 'character :initial-element #\x)) - (a2 (make-array '(10) :displaced-to a1 :element-type 'character))) - (loop for i from -1 to 10 collect (notnot (array-in-bounds-p a2 i)))) - (nil t t t t t t t t t t nil)) - -;;; Multidimensional arrays - -(deftest array-in-bounds-p.18 - (let ((a (make-array '(3 4)))) - (loop for i from -1 to 3 collect - (loop for j from -1 to 4 collect - (notnot (array-in-bounds-p a i j))))) - ((nil nil nil nil nil nil) - (nil t t t t nil) - (nil t t t t nil) - (nil t t t t nil) - (nil nil nil nil nil nil))) - -(deftest array-in-bounds-p.19 - (let ((a (make-array '(1 3 4) :adjustable t))) - (loop for i from -1 to 3 collect - (loop for j from -1 to 4 collect - (notnot (array-in-bounds-p a 0 i j))))) - ((nil nil nil nil nil nil) - (nil t t t t nil) - (nil t t t t nil) - (nil t t t t nil) - (nil nil nil nil nil nil))) - -;;; Very large indices - -(deftest array-in-bounds-p.20 - (array-in-bounds-p #(a b c) (1+ most-positive-fixnum)) - nil) - -(deftest array-in-bounds-p.21 - (array-in-bounds-p #(a b c) (1- most-negative-fixnum)) - nil) - -(deftest array-in-bounds-p.22 - (array-in-bounds-p #(a b c) 1000000000000000000) - nil) - -(deftest array-in-bounds-p.23 - (array-in-bounds-p #(a b c) -1000000000000000000) - nil) - -;;; Macro expansion - -(deftest array-in-bounds-p.24 - (macrolet ((%m (z) z)) (array-in-bounds-p (expand-in-current-env (%m #(a b))) 3)) - nil) - -(deftest array-in-bounds-p.25 - (macrolet ((%m (z) z)) - (array-in-bounds-p #(a b) (expand-in-current-env (%m 2)))) - nil) - -;;; Order of evaluation tests - -(deftest array-in-bounds-p.order.1 - (let ((x 0) y z) - (values - (array-in-bounds-p (progn (setf y (incf x)) - #()) - (progn (setf z (incf x)) - 10)) - x y z)) - nil 2 1 2) - -;;; Error tests - -(deftest array-in-bounds-p.error.1 - (signals-error (array-in-bounds-p) program-error) - t) diff --git a/t/ansi-test/arrays/array-misc.lsp b/t/ansi-test/arrays/array-misc.lsp deleted file mode 100644 index 8591422..0000000 --- a/t/ansi-test/arrays/array-misc.lsp +++ /dev/null @@ -1,30 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Jan 22 21:17:25 2003 -;;;; Contains: Misc. tests of array features - - - -(deftest array-dimension-limit.1 - (and (<= 1024 array-dimension-limit) t) - t) - -(deftest array-dimension-limit.2 - (and (typep array-dimension-limit 'fixnum) t) - t) - -(deftest array-total-size-limit.1 - (and (<= 1024 array-total-size-limit) t) - t) - -(deftest array-total-size-limit.2 - (and (typep array-total-size-limit 'fixnum) t) - t) - -(deftest array-rank-limit.1 - (and (<= 8 array-rank-limit) t) - t) - -(deftest array-rank-limit.2 - (and (typep array-rank-limit 'fixnum) t) - t) diff --git a/t/ansi-test/arrays/array-rank.lsp b/t/ansi-test/arrays/array-rank.lsp deleted file mode 100644 index 5fc7b1b..0000000 --- a/t/ansi-test/arrays/array-rank.lsp +++ /dev/null @@ -1,50 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Jan 21 20:32:57 2003 -;;;; Contains: Tests for ARRAY-RANK - - - -;;; Most tests for ARRAY-RANK are in make-array.lsp - -(deftest array-rank.1 - (array-rank #0aNIL) - 0) - -(deftest array-rank.2 - (check-predicate #'(lambda (e) (or (not (typep e 'vector)) - (eql (array-rank e) 1)))) - nil) - -(deftest array-rank.3 - (macrolet ((%m (z) z)) (array-rank (expand-in-current-env (%m "abc")))) - 1) - -(deftest array-rank.order.1 - (let ((i 0) a) - (values - (array-rank (progn (setf a (incf i)) "abcd")) - i a)) - 1 1 1) - -;;; Error tests - -(deftest array-rank.error.1 - (signals-error (array-rank) program-error) - t) - -(deftest array-rank.error.2 - (signals-error (array-rank #(a b c) nil) program-error) - t) - -(deftest array-rank.error.3 - (check-type-error #'array-rank #'arrayp) - nil) - -(deftest array-rank.error.4 - (signals-error (array-rank nil) type-error) - t) - -(deftest array-rank.error.5 - (signals-type-error x nil (locally (array-rank x) t)) - t) diff --git a/t/ansi-test/arrays/array-row-major-index.lsp b/t/ansi-test/arrays/array-row-major-index.lsp deleted file mode 100644 index d2843f5..0000000 --- a/t/ansi-test/arrays/array-row-major-index.lsp +++ /dev/null @@ -1,52 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Jan 21 21:37:03 2003 -;;;; Contains: Tests of ARRAY-ROW-MAJOR-INDEX - - - -;;; More array-row-major-index tests are in make-array.lsp - -(deftest array-row-major-index.1 - (array-row-major-index #0aNIL) - 0) - -(deftest array-row-major-index.2 - (loop for i from 0 to 4 - collect (array-row-major-index #(a b c d e) i)) - (0 1 2 3 4)) - -(deftest array-row-major-index.3 - (let ((a (make-array '(5) :fill-pointer 1))) - (loop for i from 0 to 4 - collect (array-row-major-index a i))) - (0 1 2 3 4)) - -(deftest array-row-major-index.4 - (macrolet - ((%m (z) z)) - (array-row-major-index (expand-in-current-env (%m #(a b c))) 1)) - 1) - -(deftest array-row-major-index.5 - (macrolet - ((%m (z) z)) - (array-row-major-index #(a b c) (expand-in-current-env (%m 1)))) - 1) - -(deftest array-row-major-index.order.1 - (let ((x 0) y z - (a #(a b c d e f))) - (values - (array-row-major-index - (progn (setf y (incf x)) a) - (progn (setf z (incf x)) 0)) - x y z)) - 0 2 1 2) - -;;; Error tests - -(deftest array-row-major-index.error.1 - (signals-error (array-row-major-index) program-error) - t) - diff --git a/t/ansi-test/arrays/array-t.lsp b/t/ansi-test/arrays/array-t.lsp deleted file mode 100644 index 2c31d7d..0000000 --- a/t/ansi-test/arrays/array-t.lsp +++ /dev/null @@ -1,275 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Jan 25 11:55:48 2003 -;;;; Contains: Tests of (array t ...) type specifiers - - - -;;; Tests of (array t) - -(deftest array-t.2.1 - (notnot-mv (typep #() '(array t))) - t) - -(deftest array-t.2.2 - (notnot-mv (typep #0aX '(array t))) - t) - -(deftest array-t.2.3 - (notnot-mv (typep #2a(()) '(array t))) - t) - -(deftest array-t.2.4 - (notnot-mv (typep #(1 2 3) '(array t))) - t) - -(deftest array-t.2.5 - (typep "abcd" '(array t)) - nil) - -(deftest array-t.2.6 - (typep #*010101 '(array t)) - nil) - -;;; Tests of (array t ()) - -(deftest array-t.3.1 - (notnot-mv (typep #() '(array t nil))) - nil) - -(deftest array-t.3.2 - (notnot-mv (typep #0aX '(array t nil))) - t) - -(deftest array-t.3.3 - (typep #2a(()) '(array t nil)) - nil) - -(deftest array-t.3.4 - (typep #(1 2 3) '(array t nil)) - nil) - -(deftest array-t.3.5 - (typep "abcd" '(array t nil)) - nil) - -(deftest array-t.3.6 - (typep #*010101 '(array t nil)) - nil) - -;;; Tests of (array t 1) -;;; The '1' indicates rank, so this is equivalent to 'vector' - -(deftest array-t.4.1 - (notnot-mv (typep #() '(array t 1))) - t) - -(deftest array-t.4.2 - (typep #0aX '(array t 1)) - nil) - -(deftest array-t.4.3 - (typep #2a(()) '(array t 1)) - nil) - -(deftest array-t.4.4 - (notnot-mv (typep #(1 2 3) '(array t 1))) - t) - -(deftest array-t.4.5 - (typep "abcd" '(array t 1)) - nil) - -(deftest array-t.4.6 - (typep #*010101 '(array t 1)) - nil) - -;;; Tests of (array t 0) - -(deftest array-t.5.1 - (typep #() '(array t 0)) - nil) - -(deftest array-t.5.2 - (notnot-mv (typep #0aX '(array t 0))) - t) - -(deftest array-t.5.3 - (typep #2a(()) '(array t 0)) - nil) - -(deftest array-t.5.4 - (typep #(1 2 3) '(array t 0)) - nil) - -(deftest array-t.5.5 - (typep "abcd" '(array t 0)) - nil) - -(deftest array-t.5.6 - (typep #*010101 '(array t 0)) - nil) - -;;; Tests of (array t *) - -(deftest array-t.6.1 - (notnot-mv (typep #() '(array t *))) - t) - -(deftest array-t.6.2 - (notnot-mv (typep #0aX '(array t *))) - t) - -(deftest array-t.6.3 - (notnot-mv (typep #2a(()) '(array t *))) - t) - -(deftest array-t.6.4 - (notnot-mv (typep #(1 2 3) '(array t *))) - t) - -(deftest array-t.6.5 - (typep "abcd" '(array t *)) - nil) - -(deftest array-t.6.6 - (typep #*010101 '(array t *)) - nil) - -;;; Tests of (array t 2) - -(deftest array-t.7.1 - (typep #() '(array t 2)) - nil) - -(deftest array-t.7.2 - (typep #0aX '(array t 2)) - nil) - -(deftest array-t.7.3 - (notnot-mv (typep #2a(()) '(array t 2))) - t) - -(deftest array-t.7.4 - (typep #(1 2 3) '(array t 2)) - nil) - -(deftest array-t.7.5 - (typep "abcd" '(array t 2)) - nil) - -(deftest array-t.7.6 - (typep #*010101 '(array t 2)) - nil) - -;;; Testing '(array t (--)) - -(deftest array-t.8.1 - (typep #() '(array t (1))) - nil) - -(deftest array-t.8.2 - (notnot-mv (typep #() '(array t (0)))) - t) - -(deftest array-t.8.3 - (notnot-mv (typep #() '(array t (*)))) - t) - -(deftest array-t.8.4 - (typep #(a b c) '(array t (2))) - nil) - -(deftest array-t.8.5 - (notnot-mv (typep #(a b c) '(array t (3)))) - t) - -(deftest array-t.8.6 - (notnot-mv (typep #(a b c) '(array t (*)))) - t) - -(deftest array-t.8.7 - (typep #(a b c) '(array t (4))) - nil) - -(deftest array-t.8.8 - (typep #2a((a b c)) '(array t (*))) - nil) - -(deftest array-t.8.9 - (typep #2a((a b c)) '(array t (3))) - nil) - -(deftest array-t.8.10 - (typep #2a((a b c)) '(array t (1))) - nil) - -(deftest array-t.8.11 - (typep "abc" '(array t (2))) - nil) - -(deftest array-t.8.12 - (typep "abc" '(array t (3))) - nil) - -(deftest array-t.8.13 - (typep "abc" '(array t (*))) - nil) - -(deftest array-t.8.14 - (typep "abc" '(array t (4))) - nil) - -;;; Two dimensional array type tests - -(deftest array-t.9.1 - (typep #() '(array t (* *))) - nil) - -(deftest array-t.9.2 - (typep "abc" '(array t (* *))) - nil) - -(deftest array-t.9.3 - (typep #(a b c) '(array t (3 *))) - nil) - -(deftest array-t.9.4 - (typep #(a b c) '(array t (* 3))) - nil) - -(deftest array-t.9.5 - (typep "abc" '(array t (3 *))) - nil) - -(deftest array-t.9.6 - (typep "abc" '(array t (* 3))) - nil) - -(deftest array-t.9.7 - (notnot-mv (typep #2a((a b)(c d)(e f)) '(array t (* *)))) - t) - -(deftest array-t.9.8 - (notnot-mv (typep #2a((a b)(c d)(e f)) '(array t (3 *)))) - t) - -(deftest array-t.9.9 - (typep #2a((a b)(c d)(e f)) '(array t (2 *))) - nil) - -(deftest array-t.9.10 - (notnot-mv (typep #2a((a b)(c d)(e f)) '(array t (* 2)))) - t) - -(deftest array-t.9.11 - (typep #2a((a b)(c d)(e f)) '(array t (* 3))) - nil) - -(deftest array-t.9.12 - (notnot-mv (typep #2a((a b)(c d)(e f)) '(array t (3 2)))) - t) - -(deftest array-t.9.13 - (typep #2a((a b)(c d)(e f)) '(array t (2 3))) - nil) diff --git a/t/ansi-test/arrays/array-total-size.lsp b/t/ansi-test/arrays/array-total-size.lsp deleted file mode 100644 index 89d2dc2..0000000 --- a/t/ansi-test/arrays/array-total-size.lsp +++ /dev/null @@ -1,63 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Jan 21 22:01:09 2003 -;;;; Contains: Tests of ARRAY-TOTAL-SIZE - - - -;;; More tests of ARRAY-TOTAL-SIZE are in make-array.lsp - -(deftest array-total-size.1 - (array-total-size #0aNIL) - 1) - -(deftest array-total-size.2 - (array-total-size "abcdef") - 6) - -(deftest array-total-size.3 - (array-total-size #(a b c)) - 3) - -(deftest array-total-size.4 - (array-total-size #*0011010) - 7) - -(deftest array-total-size.5 - (array-total-size #2a((1 2 3)(4 5 6)(7 8 9)(a b c))) - 12) - -(deftest array-total-size.6 - (macrolet ((%m (z) z)) - (array-total-size (expand-in-current-env (%m #(a b c))))) - 3) - -(deftest array-total-size.order.1 - (let ((i 0) a) - (values - (array-total-size (progn (setf a (incf i)) #(a b c d))) - i a)) - 4 1 1) - -;;; Error tests - -(deftest array-total-size.error.1 - (signals-error (array-total-size) program-error) - t) - -(deftest array-total-size.error.2 - (signals-error (array-total-size #(a b c) nil) program-error) - t) - -(deftest array-total-size.error.3 - (check-type-error #'array-total-size #'arrayp) - nil) - -(deftest array-total-size.error.4 - (signals-error (array-total-size 0) type-error) - t) - -(deftest array-total-size.error.5 - (signals-type-error x 0 (locally (array-total-size x) t)) - t) - diff --git a/t/ansi-test/arrays/array.lsp b/t/ansi-test/arrays/array.lsp deleted file mode 100644 index 8549467..0000000 --- a/t/ansi-test/arrays/array.lsp +++ /dev/null @@ -1,330 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Jan 25 08:46:58 2003 -;;;; Contains: Tests of the ARRAY type specifier - - - -;;; Tests of array by itself - -(deftest array.1.1 - (notnot-mv (typep #() 'array)) - t) - -(deftest array.1.2 - (notnot-mv (typep #0aX 'array)) - t) - -(deftest array.1.3 - (notnot-mv (typep #2a(()) 'array)) - t) - -(deftest array.1.4 - (notnot-mv (typep #(1 2 3) 'array)) - t) - -(deftest array.1.5 - (notnot-mv (typep "abcd" 'array)) - t) - -(deftest array.1.6 - (notnot-mv (typep #*010101 'array)) - t) - -(deftest array.1.7 - (typep nil 'array) - nil) - -(deftest array.1.8 - (typep 'x 'array) - nil) - -(deftest array.1.9 - (typep '(a b c) 'array) - nil) - -(deftest array.1.10 - (typep 10.0 'array) - nil) - -(deftest array.1.11 - (typep #'(lambda (x) (cons x nil)) 'array) - nil) - -(deftest array.1.12 - (typep 1 'array) - nil) - -(deftest array.1.13 - (typep (1+ most-positive-fixnum) 'array) - nil) - - -;;; Tests of (array *) - -(deftest array.2.1 - (notnot-mv (typep #() '(array *))) - t) - -(deftest array.2.2 - (notnot-mv (typep #0aX '(array *))) - t) - -(deftest array.2.3 - (notnot-mv (typep #2a(()) '(array *))) - t) - -(deftest array.2.4 - (notnot-mv (typep #(1 2 3) '(array *))) - t) - -(deftest array.2.5 - (notnot-mv (typep "abcd" '(array *))) - t) - -(deftest array.2.6 - (notnot-mv (typep #*010101 '(array *))) - t) - -;;; Tests of (array * ()) - -(deftest array.3.1 - (notnot-mv (typep #() '(array * nil))) - nil) - -(deftest array.3.2 - (notnot-mv (typep #0aX '(array * nil))) - t) - -(deftest array.3.3 - (typep #2a(()) '(array * nil)) - nil) - -(deftest array.3.4 - (typep #(1 2 3) '(array * nil)) - nil) - -(deftest array.3.5 - (typep "abcd" '(array * nil)) - nil) - -(deftest array.3.6 - (typep #*010101 '(array * nil)) - nil) - -;;; Tests of (array * 1) -;;; The '1' indicates rank, so this is equivalent to 'vector' - -(deftest array.4.1 - (notnot-mv (typep #() '(array * 1))) - t) - -(deftest array.4.2 - (typep #0aX '(array * 1)) - nil) - -(deftest array.4.3 - (typep #2a(()) '(array * 1)) - nil) - -(deftest array.4.4 - (notnot-mv (typep #(1 2 3) '(array * 1))) - t) - -(deftest array.4.5 - (notnot-mv (typep "abcd" '(array * 1))) - t) - -(deftest array.4.6 - (notnot-mv (typep #*010101 '(array * 1))) - t) - -;;; Tests of (array * 0) - -(deftest array.5.1 - (typep #() '(array * 0)) - nil) - -(deftest array.5.2 - (notnot-mv (typep #0aX '(array * 0))) - t) - -(deftest array.5.3 - (typep #2a(()) '(array * 0)) - nil) - -(deftest array.5.4 - (typep #(1 2 3) '(array * 0)) - nil) - -(deftest array.5.5 - (typep "abcd" '(array * 0)) - nil) - -(deftest array.5.6 - (typep #*010101 '(array * 0)) - nil) - -;;; Tests of (array * *) - -(deftest array.6.1 - (notnot-mv (typep #() '(array * *))) - t) - -(deftest array.6.2 - (notnot-mv (typep #0aX '(array * *))) - t) - -(deftest array.6.3 - (notnot-mv (typep #2a(()) '(array * *))) - t) - -(deftest array.6.4 - (notnot-mv (typep #(1 2 3) '(array * *))) - t) - -(deftest array.6.5 - (notnot-mv (typep "abcd" '(array * *))) - t) - -(deftest array.6.6 - (notnot-mv (typep #*010101 '(array * *))) - t) - -;;; Tests of (array * 2) - -(deftest array.7.1 - (typep #() '(array * 2)) - nil) - -(deftest array.7.2 - (typep #0aX '(array * 2)) - nil) - -(deftest array.7.3 - (notnot-mv (typep #2a(()) '(array * 2))) - t) - -(deftest array.7.4 - (typep #(1 2 3) '(array * 2)) - nil) - -(deftest array.7.5 - (typep "abcd" '(array * 2)) - nil) - -(deftest array.7.6 - (typep #*010101 '(array * 2)) - nil) - -;;; Testing '(array * (--)) - -(deftest array.8.1 - (typep #() '(array * (1))) - nil) - -(deftest array.8.2 - (notnot-mv (typep #() '(array * (0)))) - t) - -(deftest array.8.3 - (notnot-mv (typep #() '(array * (*)))) - t) - -(deftest array.8.4 - (typep #(a b c) '(array * (2))) - nil) - -(deftest array.8.5 - (notnot-mv (typep #(a b c) '(array * (3)))) - t) - -(deftest array.8.6 - (notnot-mv (typep #(a b c) '(array * (*)))) - t) - -(deftest array.8.7 - (typep #(a b c) '(array * (4))) - nil) - -(deftest array.8.8 - (typep #2a((a b c)) '(array * (*))) - nil) - -(deftest array.8.9 - (typep #2a((a b c)) '(array * (3))) - nil) - -(deftest array.8.10 - (typep #2a((a b c)) '(array * (1))) - nil) - -(deftest array.8.11 - (typep "abc" '(array * (2))) - nil) - -(deftest array.8.12 - (notnot-mv (typep "abc" '(array * (3)))) - t) - -(deftest array.8.13 - (notnot-mv (typep "abc" '(array * (*)))) - t) - -(deftest array.8.14 - (typep "abc" '(array * (4))) - nil) - -;;; Two dimensional array type tests - -(deftest array.9.1 - (typep #() '(array * (* *))) - nil) - -(deftest array.9.2 - (typep "abc" '(array * (* *))) - nil) - -(deftest array.9.3 - (typep #(a b c) '(array * (3 *))) - nil) - -(deftest array.9.4 - (typep #(a b c) '(array * (* 3))) - nil) - -(deftest array.9.5 - (typep "abc" '(array * (3 *))) - nil) - -(deftest array.9.6 - (typep "abc" '(array * (* 3))) - nil) - -(deftest array.9.7 - (notnot-mv (typep #2a((a b)(c d)(e f)) '(array * (* *)))) - t) - -(deftest array.9.8 - (notnot-mv (typep #2a((a b)(c d)(e f)) '(array * (3 *)))) - t) - -(deftest array.9.9 - (typep #2a((a b)(c d)(e f)) '(array * (2 *))) - nil) - -(deftest array.9.10 - (notnot-mv (typep #2a((a b)(c d)(e f)) '(array * (* 2)))) - t) - -(deftest array.9.11 - (typep #2a((a b)(c d)(e f)) '(array * (* 3))) - nil) - -(deftest array.9.12 - (notnot-mv (typep #2a((a b)(c d)(e f)) '(array * (3 2)))) - t) - -(deftest array.9.13 - (typep #2a((a b)(c d)(e f)) '(array * (2 3))) - nil) diff --git a/t/ansi-test/arrays/arrayp.lsp b/t/ansi-test/arrays/arrayp.lsp deleted file mode 100644 index 32d1e6a..0000000 --- a/t/ansi-test/arrays/arrayp.lsp +++ /dev/null @@ -1,53 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Jan 21 22:08:21 2003 -;;;; Contains: Tests of ARRAYP - - - -;;; Also tested by make-array.lsp - -(deftest arrayp.1 - (notnot-mv (arrayp #(a b c))) - t) - -(deftest arrayp.2 - (notnot-mv (arrayp "abcd")) - t) - -(deftest arrayp.3 - (notnot-mv (arrayp #*001110101)) - t) - -(deftest arrayp.4 - (notnot-mv (arrayp #0aNIL)) - t) - -(deftest arrayp.5 - (notnot-mv (arrayp #2a((1 2 3)(4 5 6)))) - t) - -(deftest arrayp.6 - (check-type-predicate #'arrayp 'array) - nil) - -(deftest arrayp.7 - (macrolet ((%m (z) z)) (arrayp (expand-in-current-env (%m 0)))) - nil) - -(deftest arrayp.order.1 - (let ((i 0) a) - (values - (arrayp (progn (setf a (incf i)) nil)) - i a)) - nil 1 1) - -;;; Error tests - -(deftest arrayp.error.1 - (signals-error (arrayp) program-error) - t) - -(deftest arrayp.error.2 - (signals-error (arrayp #(a b c) nil) program-error) - t) diff --git a/t/ansi-test/arrays/bit-and.lsp b/t/ansi-test/arrays/bit-and.lsp deleted file mode 100644 index c9d4fa7..0000000 --- a/t/ansi-test/arrays/bit-and.lsp +++ /dev/null @@ -1,268 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jan 26 18:18:47 2003 -;;;; Contains: Tests of BIT-AND - - - - - -(deftest bit-and.1 - (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit))) - (values (bit-and s1 s2) s1 s2)) - #0a0 - #0a0 - #0a0) - -(deftest bit-and.2 - (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit))) - (values (bit-and s1 s2) s1 s2)) - #0a0 - #0a1 - #0a0) - -(deftest bit-and.3 - (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit))) - (values (bit-and s1 s2) s1 s2)) - #0a0 - #0a0 - #0a1) - -(deftest bit-and.4 - (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit))) - (values (bit-and s1 s2) s1 s2)) - #0a1 - #0a1 - #0a1) - -(deftest bit-and.5 - (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit)) - (s3 (make-array nil :initial-element 1 :element-type 'bit)) - (result (bit-and s1 s2 s3))) - (values s1 s2 s3 result (eqt s3 result))) - #0a0 - #0a0 - #0a0 - #0a0 - t) - -(deftest bit-and.6 - (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit)) - (s3 (make-array nil :initial-element 0 :element-type 'bit)) - (result (bit-and s1 s2 s3))) - (values s1 s2 s3 result (eqt s3 result))) - #0a1 - #0a1 - #0a1 - #0a1 - t) - -(deftest bit-and.7 - (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit)) - (result (bit-and s1 s2 t))) - (values s1 s2 result (eqt s1 result))) - #0a0 - #0a0 - #0a0 - t) - - -;;; Tests on bit vectors - -(deftest bit-and.8 - (let ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101))) - (values (check-values (bit-and a1 a2)) a1 a2)) - #*0001 #*0011 #*0101) - -(deftest bit-and.9 - (let* ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101)) - (result (check-values (bit-and a1 a2 t)))) - (values result a1 a2 (eqt result a1))) - #*0001 #*0001 #*0101 t) - -(deftest bit-and.10 - (let* ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101)) - (a3 (copy-seq #*1110)) - (result (check-values (bit-and a1 a2 a3)))) - (values result a1 a2 a3 (eqt result a3))) - #*0001 #*0011 #*0101 #*0001 t) - -(deftest bit-and.11 - (let ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101))) - (values (check-values (bit-and a1 a2 nil)) a1 a2)) - #*0001 #*0011 #*0101) - -;;; Tests on bit arrays - -(deftest bit-and.12 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-and a1 a2))) - (values a1 a2 result)) - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((0 0)(0 1))) - -(deftest bit-and.13 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-and a1 a2 t))) - (values a1 a2 result)) - #2a((0 0)(0 1)) - #2a((0 0)(1 1)) - #2a((0 0)(0 1))) - -(deftest bit-and.14 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-and a1 a2 nil))) - (values a1 a2 result)) - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((0 0)(0 1))) - -(deftest bit-and.15 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (a3 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(0 0)))) - (result (bit-and a1 a2 a3))) - (values a1 a2 a3 result)) - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((0 0)(0 1)) - #2a((0 0)(0 1))) - -;;; Adjustable arrays - -(deftest bit-and.16 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)) - :adjustable t)) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)) - :adjustable t)) - (result (bit-and a1 a2))) - (values a1 a2 result)) - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((0 0)(0 1))) - -;;; Displaced arrays - -(deftest bit-and.17 - (let* ((a0 (make-array '(8) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (result (bit-and a1 a2))) - (values a0 a1 a2 result)) - #*01010011 - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((0 0)(0 1))) - -(deftest bit-and.18 - (let* ((a0 (make-array '(8) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (result (bit-and a1 a2 t))) - (values a0 a1 a2 result)) - #*00010011 - #2a((0 0)(0 1)) - #2a((0 0)(1 1)) - #2a((0 0)(0 1))) - -(deftest bit-and.19 - (let* ((a0 (make-array '(12) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (a3 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 8)) - (result (bit-and a1 a2 a3))) - (values a0 a1 a2 result)) - #*010100110001 - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((0 0)(0 1))) - -(deftest bit-and.20 - (macrolet ((%m (z) z)) (bit-and (expand-in-current-env (%m #*0011)) #*0101)) - #*0001) - -(deftest bit-and.21 - (macrolet ((%m (z) z)) (bit-and #*1010 (expand-in-current-env (%m #*1100)))) - #*1000) - -(deftest bit-and.22 - (macrolet ((%m (z) z)) (bit-and #*10100011 #*01101010 - (expand-in-current-env (%m nil)))) - #*00100010) - -(deftest bit-and.order.1 - (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) - (s2 (make-array 1 :initial-element 0 :element-type 'bit)) - (x 0) y z) - (values - (bit-and (progn (setf y (incf x)) s1) - (progn (setf z (incf x)) s2)) - x y z)) - #*0 2 1 2) - -(def-fold-test bit-and.fold.1 (bit-and #*01101 #*01011)) - -;;; Randomized tests - -(deftest bit-and.random.1 - (bit-random-test-fn #'bit-and #'logand) - nil) - -;;; Error tests - -(deftest bit-and.error.1 - (signals-error (bit-and) program-error) - t) - -(deftest bit-and.error.2 - (signals-error (bit-and #*000) program-error) - t) - -(deftest bit-and.error.3 - (signals-error (bit-and #*000 #*0100 nil nil) - program-error) - t) - diff --git a/t/ansi-test/arrays/bit-andc1.lsp b/t/ansi-test/arrays/bit-andc1.lsp deleted file mode 100644 index 94f6abf..0000000 --- a/t/ansi-test/arrays/bit-andc1.lsp +++ /dev/null @@ -1,267 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jan 26 18:56:39 2003 -;;;; Contains: Tests of BIT-ANDC1 - - - - - -(deftest bit-andc1.1 - (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit))) - (values (bit-andc1 s1 s2) s1 s2)) - #0a0 - #0a0 - #0a0) - -(deftest bit-andc1.2 - (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit))) - (values (bit-andc1 s1 s2) s1 s2)) - #0a0 - #0a1 - #0a0) - -(deftest bit-andc1.3 - (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit))) - (values (bit-andc1 s1 s2) s1 s2)) - #0a1 - #0a0 - #0a1) - -(deftest bit-andc1.4 - (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit))) - (values (bit-andc1 s1 s2) s1 s2)) - #0a0 - #0a1 - #0a1) - -(deftest bit-andc1.5 - (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit)) - (s3 (make-array nil :initial-element 1 :element-type 'bit)) - (result (bit-andc1 s1 s2 s3))) - (values s1 s2 s3 result (eqt s3 result))) - #0a0 - #0a0 - #0a0 - #0a0 - t) - -(deftest bit-andc1.6 - (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit)) - (s3 (make-array nil :initial-element 0 :element-type 'bit)) - (result (bit-andc1 s1 s2 s3))) - (values s1 s2 s3 result (eqt s3 result))) - #0a0 - #0a1 - #0a1 - #0a1 - t) - -(deftest bit-andc1.7 - (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit)) - (result (bit-andc1 s1 s2 t))) - (values s1 s2 result (eqt s1 result))) - #0a0 - #0a0 - #0a0 - t) - - -;;; Tests on bit vectors - -(deftest bit-andc1.8 - (let ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101))) - (values (check-values (bit-andc1 a1 a2)) a1 a2)) - #*0100 #*0011 #*0101) - -(deftest bit-andc1.9 - (let* ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101)) - (result (check-values (bit-andc1 a1 a2 t)))) - (values result a1 a2 (eqt result a1))) - #*0100 #*0100 #*0101 t) - -(deftest bit-andc1.10 - (let* ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101)) - (a3 (copy-seq #*0000)) - (result (check-values (bit-andc1 a1 a2 a3)))) - (values result a1 a2 a3 (eqt result a3))) - #*0100 #*0011 #*0101 #*0100 t) - -(deftest bit-andc1.11 - (let ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101))) - (values (check-values (bit-andc1 a1 a2 nil)) a1 a2)) - #*0100 #*0011 #*0101) - -;;; Tests on bit arrays - -(deftest bit-andc1.12 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-andc1 a1 a2))) - (values a1 a2 result)) - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((0 0)(1 0))) - -(deftest bit-andc1.13 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-andc1 a1 a2 t))) - (values a1 a2 result)) - #2a((0 0)(1 0)) - #2a((0 0)(1 1)) - #2a((0 0)(1 0))) - -(deftest bit-andc1.14 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-andc1 a1 a2 nil))) - (values a1 a2 result)) - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((0 0)(1 0))) - -(deftest bit-andc1.15 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (a3 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(0 0)))) - (result (bit-andc1 a1 a2 a3))) - (values a1 a2 a3 result)) - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((0 0)(1 0)) - #2a((0 0)(1 0))) - -;;; Adjustable arrays - -(deftest bit-andc1.16 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)) - :adjustable t)) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)) - :adjustable t)) - (result (bit-andc1 a1 a2))) - (values a1 a2 result)) - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((0 0)(1 0))) - -;;; Displaced arrays - -(deftest bit-andc1.17 - (let* ((a0 (make-array '(8) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (result (bit-andc1 a1 a2))) - (values a0 a1 a2 result)) - #*01010011 - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((0 0)(1 0))) - -(deftest bit-andc1.18 - (let* ((a0 (make-array '(8) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (result (bit-andc1 a1 a2 t))) - (values a0 a1 a2 result)) - #*00100011 - #2a((0 0)(1 0)) - #2a((0 0)(1 1)) - #2a((0 0)(1 0))) - -(deftest bit-andc1.19 - (let* ((a0 (make-array '(12) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (a3 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 8)) - (result (bit-andc1 a1 a2 a3))) - (values a0 a1 a2 result)) - #*010100110010 - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((0 0)(1 0))) - -(deftest bit-andc1.20 - (macrolet ((%m (z) z)) (bit-andc1 (expand-in-current-env (%m #*0011)) #*0101)) - #*0100) - -(deftest bit-andc1.21 - (macrolet ((%m (z) z)) (bit-andc1 #*1010 (expand-in-current-env (%m #*1100)))) - #*0100) - -(deftest bit-andc1.22 - (macrolet ((%m (z) z)) (bit-andc1 #*10100011 #*01101010 - (expand-in-current-env (%m nil)))) - #*01001000) - -(deftest bit-andc1.order.1 - (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) - (s2 (make-array 1 :initial-element 0 :element-type 'bit)) - (x 0) y z) - (values - (bit-andc1 (progn (setf y (incf x)) s1) - (progn (setf z (incf x)) s2)) - x y z)) - #*0 2 1 2) - -(def-fold-test bit-andc1.fold.1 (bit-andc1 #*10010 #*01011)) - -;;; Random tests - -(deftest bit-andc1.random.1 - (bit-random-test-fn #'bit-andc1 #'logandc1) - nil) - -;;; Error tests - -(deftest bit-andc1.error.1 - (signals-error (bit-andc1) program-error) - t) - -(deftest bit-andc1.error.2 - (signals-error (bit-andc1 #*000) program-error) - t) - -(deftest bit-andc1.error.3 - (signals-error (bit-andc1 #*000 #*0100 nil nil) - program-error) - t) diff --git a/t/ansi-test/arrays/bit-andc2.lsp b/t/ansi-test/arrays/bit-andc2.lsp deleted file mode 100644 index 29a4e24..0000000 --- a/t/ansi-test/arrays/bit-andc2.lsp +++ /dev/null @@ -1,268 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jan 26 19:01:38 2003 -;;;; Contains: Tests of BIT-ANDC2 - - - - - -(deftest bit-andc2.1 - (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit))) - (values (bit-andc2 s1 s2) s1 s2)) - #0a0 - #0a0 - #0a0) - -(deftest bit-andc2.2 - (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit))) - (values (bit-andc2 s1 s2) s1 s2)) - #0a1 - #0a1 - #0a0) - -(deftest bit-andc2.3 - (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit))) - (values (bit-andc2 s1 s2) s1 s2)) - #0a0 - #0a0 - #0a1) - -(deftest bit-andc2.4 - (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit))) - (values (bit-andc2 s1 s2) s1 s2)) - #0a0 - #0a1 - #0a1) - -(deftest bit-andc2.5 - (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit)) - (s3 (make-array nil :initial-element 1 :element-type 'bit)) - (result (bit-andc2 s1 s2 s3))) - (values s1 s2 s3 result (eqt s3 result))) - #0a0 - #0a0 - #0a0 - #0a0 - t) - -(deftest bit-andc2.6 - (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit)) - (s3 (make-array nil :initial-element 0 :element-type 'bit)) - (result (bit-andc2 s1 s2 s3))) - (values s1 s2 s3 result (eqt s3 result))) - #0a1 - #0a0 - #0a1 - #0a1 - t) - -(deftest bit-andc2.7 - (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit)) - (result (bit-andc2 s1 s2 t))) - (values s1 s2 result (eqt s1 result))) - #0a0 - #0a1 - #0a0 - t) - - -;;; Tests on bit vectors - -(deftest bit-andc2.8 - (let ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101))) - (values (check-values (bit-andc2 a1 a2)) a1 a2)) - #*0010 #*0011 #*0101) - -(deftest bit-andc2.9 - (let* ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101)) - (result (check-values (bit-andc2 a1 a2 t)))) - (values result a1 a2 (eqt result a1))) - #*0010 #*0010 #*0101 t) - -(deftest bit-andc2.10 - (let* ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101)) - (a3 (copy-seq #*1110)) - (result (check-values (bit-andc2 a1 a2 a3)))) - (values result a1 a2 a3 (eqt result a3))) - #*0010 #*0011 #*0101 #*0010 t) - -(deftest bit-andc2.11 - (let ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101))) - (values (check-values (bit-andc2 a1 a2 nil)) a1 a2)) - #*0010 #*0011 #*0101) - -;;; Tests on bit arrays - -(deftest bit-andc2.12 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-andc2 a1 a2))) - (values a1 a2 result)) - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((0 1)(0 0))) - -(deftest bit-andc2.13 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-andc2 a1 a2 t))) - (values a1 a2 result)) - #2a((0 1)(0 0)) - #2a((0 0)(1 1)) - #2a((0 1)(0 0))) - -(deftest bit-andc2.14 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-andc2 a1 a2 nil))) - (values a1 a2 result)) - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((0 1)(0 0))) - -(deftest bit-andc2.15 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (a3 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(0 0)))) - (result (bit-andc2 a1 a2 a3))) - (values a1 a2 a3 result)) - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((0 1)(0 0)) - #2a((0 1)(0 0))) - -;;; Adjustable arrays - -(deftest bit-andc2.16 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)) - :adjustable t)) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)) - :adjustable t)) - (result (bit-andc2 a1 a2))) - (values a1 a2 result)) - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((0 1)(0 0))) - -;;; Displaced arrays - -(deftest bit-andc2.17 - (let* ((a0 (make-array '(8) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (result (bit-andc2 a1 a2))) - (values a0 a1 a2 result)) - #*01010011 - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((0 1)(0 0))) - -(deftest bit-andc2.18 - (let* ((a0 (make-array '(8) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (result (bit-andc2 a1 a2 t))) - (values a0 a1 a2 result)) - #*01000011 - #2a((0 1)(0 0)) - #2a((0 0)(1 1)) - #2a((0 1)(0 0))) - -(deftest bit-andc2.19 - (let* ((a0 (make-array '(12) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (a3 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 8)) - (result (bit-andc2 a1 a2 a3))) - (values a0 a1 a2 result)) - #*010100110100 - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((0 1)(0 0))) - -(deftest bit-andc2.20 - (macrolet ((%m (z) z)) (bit-andc2 (expand-in-current-env (%m #*0011)) #*0101)) - #*0010) - -(deftest bit-andc2.21 - (macrolet ((%m (z) z)) (bit-andc2 #*1010 (expand-in-current-env (%m #*1100)))) - #*0010) - -(deftest bit-andc2.22 - (macrolet ((%m (z) z)) (bit-andc2 #*10100011 #*01101010 - (expand-in-current-env (%m nil)))) - #*10000001) - -(deftest bit-andc2.order.1 - (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) - (s2 (make-array 1 :initial-element 0 :element-type 'bit)) - (x 0) y z) - (values - (bit-andc2 (progn (setf y (incf x)) s1) - (progn (setf z (incf x)) s2)) - x y z)) - #*0 2 1 2) - -(def-fold-test bit-andc2.fold.1 (bit-andc2 #*01101 #*10100)) - -;;; Random tests - -(deftest bit-andc2.random.1 - (bit-random-test-fn #'bit-andc2 #'logandc2) - nil) - -;;; Error tests - -(deftest bit-andc2.error.1 - (signals-error (bit-andc2) program-error) - t) - -(deftest bit-andc2.error.2 - (signals-error (bit-andc2 #*000) program-error) - t) - -(deftest bit-andc2.error.3 - (signals-error (bit-andc2 #*000 #*0100 nil nil) - program-error) - t) - diff --git a/t/ansi-test/arrays/bit-eqv.lsp b/t/ansi-test/arrays/bit-eqv.lsp deleted file mode 100644 index af24af1..0000000 --- a/t/ansi-test/arrays/bit-eqv.lsp +++ /dev/null @@ -1,268 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jan 26 19:07:23 2003 -;;;; Contains: Tests of BIT-EQV - - - - - - -(deftest bit-eqv.1 - (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit))) - (values (bit-eqv s1 s2) s1 s2)) - #0a1 - #0a0 - #0a0) - -(deftest bit-eqv.2 - (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit))) - (values (bit-eqv s1 s2) s1 s2)) - #0a0 - #0a1 - #0a0) - -(deftest bit-eqv.3 - (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit))) - (values (bit-eqv s1 s2) s1 s2)) - #0a0 - #0a0 - #0a1) - -(deftest bit-eqv.4 - (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit))) - (values (bit-eqv s1 s2) s1 s2)) - #0a1 - #0a1 - #0a1) - -(deftest bit-eqv.5 - (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit)) - (s3 (make-array nil :initial-element 0 :element-type 'bit)) - (result (bit-eqv s1 s2 s3))) - (values s1 s2 s3 result (eqt s3 result))) - #0a0 - #0a0 - #0a1 - #0a1 - t) - -(deftest bit-eqv.6 - (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit)) - (s3 (make-array nil :initial-element 0 :element-type 'bit)) - (result (bit-eqv s1 s2 s3))) - (values s1 s2 s3 result (eqt s3 result))) - #0a1 - #0a1 - #0a1 - #0a1 - t) - -(deftest bit-eqv.7 - (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit)) - (result (bit-eqv s1 s2 t))) - (values s1 s2 result (eqt s1 result))) - #0a0 - #0a0 - #0a0 - t) - - -;;; Tests on bit vectors - -(deftest bit-eqv.8 - (let ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101))) - (values (check-values (bit-eqv a1 a2)) a1 a2)) - #*1001 #*0011 #*0101) - -(deftest bit-eqv.9 - (let* ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101)) - (result (check-values (bit-eqv a1 a2 t)))) - (values result a1 a2 (eqt result a1))) - #*1001 #*1001 #*0101 t) - -(deftest bit-eqv.10 - (let* ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101)) - (a3 (copy-seq #*0000)) - (result (check-values (bit-eqv a1 a2 a3)))) - (values result a1 a2 a3 (eqt result a3))) - #*1001 #*0011 #*0101 #*1001 t) - -(deftest bit-eqv.11 - (let ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101))) - (values (check-values (bit-eqv a1 a2 nil)) a1 a2)) - #*1001 #*0011 #*0101) - -;;; Tests on bit arrays - -(deftest bit-eqv.12 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-eqv a1 a2))) - (values a1 a2 result)) - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((1 0)(0 1))) - -(deftest bit-eqv.13 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-eqv a1 a2 t))) - (values a1 a2 result)) - #2a((1 0)(0 1)) - #2a((0 0)(1 1)) - #2a((1 0)(0 1))) - -(deftest bit-eqv.14 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-eqv a1 a2 nil))) - (values a1 a2 result)) - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((1 0)(0 1))) - -(deftest bit-eqv.15 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (a3 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(0 0)))) - (result (bit-eqv a1 a2 a3))) - (values a1 a2 a3 result)) - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((1 0)(0 1)) - #2a((1 0)(0 1))) - -;;; Adjustable arrays - -(deftest bit-eqv.16 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)) - :adjustable t)) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)) - :adjustable t)) - (result (bit-eqv a1 a2))) - (values a1 a2 result)) - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((1 0)(0 1))) - -;;; Displaced arrays - -(deftest bit-eqv.17 - (let* ((a0 (make-array '(8) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (result (bit-eqv a1 a2))) - (values a0 a1 a2 result)) - #*01010011 - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((1 0)(0 1))) - -(deftest bit-eqv.18 - (let* ((a0 (make-array '(8) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (result (bit-eqv a1 a2 t))) - (values a0 a1 a2 result)) - #*10010011 - #2a((1 0)(0 1)) - #2a((0 0)(1 1)) - #2a((1 0)(0 1))) - -(deftest bit-eqv.19 - (let* ((a0 (make-array '(12) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (a3 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 8)) - (result (bit-eqv a1 a2 a3))) - (values a0 a1 a2 result)) - #*010100111001 - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((1 0)(0 1))) - -(deftest bit-eqv.20 - (macrolet ((%m (z) z)) (bit-eqv (expand-in-current-env (%m #*0011)) #*0101)) - #*1001) - -(deftest bit-eqv.21 - (macrolet ((%m (z) z)) (bit-eqv #*1010 (expand-in-current-env (%m #*1100)))) - #*1001) - -(deftest bit-eqv.22 - (macrolet ((%m (z) z)) (bit-eqv #*10100011 #*01101010 - (expand-in-current-env (%m nil)))) - #*00110110) - -(deftest bit-eqv.order.1 - (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) - (s2 (make-array 1 :initial-element 0 :element-type 'bit)) - (x 0) y z) - (values - (bit-eqv (progn (setf y (incf x)) s1) - (progn (setf z (incf x)) s2)) - x y z)) - #*1 2 1 2) - -(def-fold-test bit-eqv.fold.1 (bit-eqv #*01101 #*10100)) - -;;; Random tests - -(deftest bit-eqv.random.1 - (bit-random-test-fn #'bit-eqv #'logeqv) - nil) - -;;; Error tests - -(deftest bit-eqv.error.1 - (signals-error (bit-eqv) program-error) - t) - -(deftest bit-eqv.error.2 - (signals-error (bit-eqv #*000) program-error) - t) - -(deftest bit-eqv.error.3 - (signals-error (bit-eqv #*000 #*0100 nil nil) - program-error) - t) diff --git a/t/ansi-test/arrays/bit-ior.lsp b/t/ansi-test/arrays/bit-ior.lsp deleted file mode 100644 index 73918d1..0000000 --- a/t/ansi-test/arrays/bit-ior.lsp +++ /dev/null @@ -1,267 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jan 26 19:13:34 2003 -;;;; Contains: Tests of BIT-IOR - - - - - -(deftest bit-ior.1 - (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit))) - (values (bit-ior s1 s2) s1 s2)) - #0a0 - #0a0 - #0a0) - -(deftest bit-ior.2 - (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit))) - (values (bit-ior s1 s2) s1 s2)) - #0a1 - #0a1 - #0a0) - -(deftest bit-ior.3 - (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit))) - (values (bit-ior s1 s2) s1 s2)) - #0a1 - #0a0 - #0a1) - -(deftest bit-ior.4 - (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit))) - (values (bit-ior s1 s2) s1 s2)) - #0a1 - #0a1 - #0a1) - -(deftest bit-ior.5 - (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit)) - (s3 (make-array nil :initial-element 1 :element-type 'bit)) - (result (bit-ior s1 s2 s3))) - (values s1 s2 s3 result (eqt s3 result))) - #0a0 - #0a0 - #0a0 - #0a0 - t) - -(deftest bit-ior.6 - (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit)) - (s3 (make-array nil :initial-element 0 :element-type 'bit)) - (result (bit-ior s1 s2 s3))) - (values s1 s2 s3 result (eqt s3 result))) - #0a1 - #0a1 - #0a1 - #0a1 - t) - -(deftest bit-ior.7 - (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit)) - (result (bit-ior s1 s2 t))) - (values s1 s2 result (eqt s1 result))) - #0a1 - #0a1 - #0a1 - t) - - -;;; Tests on bit vectors - -(deftest bit-ior.8 - (let ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101))) - (values (check-values (bit-ior a1 a2)) a1 a2)) - #*0111 #*0011 #*0101) - -(deftest bit-ior.9 - (let* ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101)) - (result (check-values (bit-ior a1 a2 t)))) - (values result a1 a2 (eqt result a1))) - #*0111 #*0111 #*0101 t) - -(deftest bit-ior.10 - (let* ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101)) - (a3 (copy-seq #*1110)) - (result (check-values (bit-ior a1 a2 a3)))) - (values result a1 a2 a3 (eqt result a3))) - #*0111 #*0011 #*0101 #*0111 t) - -(deftest bit-ior.11 - (let ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101))) - (values (check-values (bit-ior a1 a2 nil)) a1 a2)) - #*0111 #*0011 #*0101) - -;;; Tests on bit arrays - -(deftest bit-ior.12 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-ior a1 a2))) - (values a1 a2 result)) - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((0 1)(1 1))) - -(deftest bit-ior.13 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-ior a1 a2 t))) - (values a1 a2 result)) - #2a((0 1)(1 1)) - #2a((0 0)(1 1)) - #2a((0 1)(1 1))) - -(deftest bit-ior.14 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-ior a1 a2 nil))) - (values a1 a2 result)) - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((0 1)(1 1))) - -(deftest bit-ior.15 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (a3 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(0 0)))) - (result (bit-ior a1 a2 a3))) - (values a1 a2 a3 result)) - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((0 1)(1 1)) - #2a((0 1)(1 1))) - -;;; Adjustable arrays - -(deftest bit-ior.16 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)) - :adjustable t)) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)) - :adjustable t)) - (result (bit-ior a1 a2))) - (values a1 a2 result)) - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((0 1)(1 1))) - -;;; Displaced arrays - -(deftest bit-ior.17 - (let* ((a0 (make-array '(8) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (result (bit-ior a1 a2))) - (values a0 a1 a2 result)) - #*01010011 - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((0 1)(1 1))) - -(deftest bit-ior.18 - (let* ((a0 (make-array '(8) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (result (bit-ior a1 a2 t))) - (values a0 a1 a2 result)) - #*01110011 - #2a((0 1)(1 1)) - #2a((0 0)(1 1)) - #2a((0 1)(1 1))) - -(deftest bit-ior.19 - (let* ((a0 (make-array '(12) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (a3 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 8)) - (result (bit-ior a1 a2 a3))) - (values a0 a1 a2 result)) - #*010100110111 - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((0 1)(1 1))) - -(deftest bit-ior.20 - (macrolet ((%m (z) z)) (bit-ior (expand-in-current-env (%m #*0011)) #*0101)) - #*0111) - -(deftest bit-ior.21 - (macrolet ((%m (z) z)) (bit-ior #*1010 (expand-in-current-env (%m #*1100)))) - #*1110) - -(deftest bit-ior.22 - (macrolet ((%m (z) z)) (bit-ior #*10100011 #*01101010 - (expand-in-current-env (%m nil)))) - #*11101011) - -(deftest bit-ior.order.1 - (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) - (s2 (make-array 1 :initial-element 0 :element-type 'bit)) - (x 0) y z) - (values - (bit-ior (progn (setf y (incf x)) s1) - (progn (setf z (incf x)) s2)) - x y z)) - #*0 2 1 2) - -(def-fold-test bit-ior.fold.1 (bit-ior #*00101 #*10100)) - -;;; Random tests - -(deftest bit-ior.random.1 - (bit-random-test-fn #'bit-ior #'logior) - nil) - -;;; Error tests - -(deftest bit-ior.error.1 - (signals-error (bit-ior) program-error) - t) - -(deftest bit-ior.error.2 - (signals-error (bit-ior #*000) program-error) - t) - -(deftest bit-ior.error.3 - (signals-error (bit-ior #*000 #*0100 nil nil) - program-error) - t) diff --git a/t/ansi-test/arrays/bit-nand.lsp b/t/ansi-test/arrays/bit-nand.lsp deleted file mode 100644 index 3e63392..0000000 --- a/t/ansi-test/arrays/bit-nand.lsp +++ /dev/null @@ -1,267 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jan 26 19:16:15 2003 -;;;; Contains: Tests for BIT-NAND - - - - - -(deftest bit-nand.1 - (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit))) - (values (bit-nand s1 s2) s1 s2)) - #0a1 - #0a0 - #0a0) - -(deftest bit-nand.2 - (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit))) - (values (bit-nand s1 s2) s1 s2)) - #0a1 - #0a1 - #0a0) - -(deftest bit-nand.3 - (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit))) - (values (bit-nand s1 s2) s1 s2)) - #0a1 - #0a0 - #0a1) - -(deftest bit-nand.4 - (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit))) - (values (bit-nand s1 s2) s1 s2)) - #0a0 - #0a1 - #0a1) - -(deftest bit-nand.5 - (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit)) - (s3 (make-array nil :initial-element 0 :element-type 'bit)) - (result (bit-nand s1 s2 s3))) - (values s1 s2 s3 result (eqt s3 result))) - #0a0 - #0a0 - #0a1 - #0a1 - t) - -(deftest bit-nand.6 - (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit)) - (s3 (make-array nil :initial-element 1 :element-type 'bit)) - (result (bit-nand s1 s2 s3))) - (values s1 s2 s3 result (eqt s3 result))) - #0a1 - #0a1 - #0a0 - #0a0 - t) - -(deftest bit-nand.7 - (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit)) - (result (bit-nand s1 s2 t))) - (values s1 s2 result (eqt s1 result))) - #0a1 - #0a0 - #0a1 - t) - - -;;; Tests on bit vectors - -(deftest bit-nand.8 - (let ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101))) - (values (check-values (bit-nand a1 a2)) a1 a2)) - #*1110 #*0011 #*0101) - -(deftest bit-nand.9 - (let* ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101)) - (result (check-values (bit-nand a1 a2 t)))) - (values result a1 a2 (eqt result a1))) - #*1110 #*1110 #*0101 t) - -(deftest bit-nand.10 - (let* ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101)) - (a3 (copy-seq #*1110)) - (result (check-values (bit-nand a1 a2 a3)))) - (values result a1 a2 a3 (eqt result a3))) - #*1110 #*0011 #*0101 #*1110 t) - -(deftest bit-nand.11 - (let ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101))) - (values (check-values (bit-nand a1 a2 nil)) a1 a2)) - #*1110 #*0011 #*0101) - -;;; Tests on bit arrays - -(deftest bit-nand.12 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-nand a1 a2))) - (values a1 a2 result)) - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((1 1)(1 0))) - -(deftest bit-nand.13 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-nand a1 a2 t))) - (values a1 a2 result)) - #2a((1 1)(1 0)) - #2a((0 0)(1 1)) - #2a((1 1)(1 0))) - -(deftest bit-nand.14 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-nand a1 a2 nil))) - (values a1 a2 result)) - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((1 1)(1 0))) - -(deftest bit-nand.15 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (a3 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(0 0)))) - (result (bit-nand a1 a2 a3))) - (values a1 a2 a3 result)) - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((1 1)(1 0)) - #2a((1 1)(1 0))) - -;;; Adjustable arrays - -(deftest bit-nand.16 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)) - :adjustable t)) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)) - :adjustable t)) - (result (bit-nand a1 a2))) - (values a1 a2 result)) - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((1 1)(1 0))) - -;;; Displaced arrays - -(deftest bit-nand.17 - (let* ((a0 (make-array '(8) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (result (bit-nand a1 a2))) - (values a0 a1 a2 result)) - #*01010011 - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((1 1)(1 0))) - -(deftest bit-nand.18 - (let* ((a0 (make-array '(8) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (result (bit-nand a1 a2 t))) - (values a0 a1 a2 result)) - #*11100011 - #2a((1 1)(1 0)) - #2a((0 0)(1 1)) - #2a((1 1)(1 0))) - -(deftest bit-nand.19 - (let* ((a0 (make-array '(12) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (a3 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 8)) - (result (bit-nand a1 a2 a3))) - (values a0 a1 a2 result)) - #*010100111110 - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((1 1)(1 0))) - -(deftest bit-nand.20 - (macrolet ((%m (z) z)) (bit-nand (expand-in-current-env (%m #*0011)) #*0101)) - #*1110) - -(deftest bit-nand.21 - (macrolet ((%m (z) z)) (bit-nand #*1010 (expand-in-current-env (%m #*1100)))) - #*0111) - -(deftest bit-nand.22 - (macrolet ((%m (z) z)) (bit-nand #*10100011 #*01101010 - (expand-in-current-env (%m nil)))) - #*11011101) - -(deftest bit-nand.order.1 - (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) - (s2 (make-array 1 :initial-element 0 :element-type 'bit)) - (x 0) y z) - (values - (bit-nand (progn (setf y (incf x)) s1) - (progn (setf z (incf x)) s2)) - x y z)) - #*1 2 1 2) - -(def-fold-test bit-nand.fold.1 (bit-nand #*00101 #*10100)) - -;;; Random tests - -(deftest bit-nand.random.1 - (bit-random-test-fn #'bit-nand #'lognand) - nil) - -;;; Error tests - -(deftest bit-nand.error.1 - (signals-error (bit-nand) program-error) - t) - -(deftest bit-nand.error.2 - (signals-error (bit-nand #*000) program-error) - t) - -(deftest bit-nand.error.3 - (signals-error (bit-nand #*000 #*0100 nil nil) - program-error) - t) diff --git a/t/ansi-test/arrays/bit-nor.lsp b/t/ansi-test/arrays/bit-nor.lsp deleted file mode 100644 index b30d925..0000000 --- a/t/ansi-test/arrays/bit-nor.lsp +++ /dev/null @@ -1,267 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jan 26 19:20:40 2003 -;;;; Contains: Tests for BIT-NOR - - - - - -(deftest bit-nor.1 - (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit))) - (values (bit-nor s1 s2) s1 s2)) - #0a1 - #0a0 - #0a0) - -(deftest bit-nor.2 - (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit))) - (values (bit-nor s1 s2) s1 s2)) - #0a0 - #0a1 - #0a0) - -(deftest bit-nor.3 - (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit))) - (values (bit-nor s1 s2) s1 s2)) - #0a0 - #0a0 - #0a1) - -(deftest bit-nor.4 - (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit))) - (values (bit-nor s1 s2) s1 s2)) - #0a0 - #0a1 - #0a1) - -(deftest bit-nor.5 - (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit)) - (s3 (make-array nil :initial-element 0 :element-type 'bit)) - (result (bit-nor s1 s2 s3))) - (values s1 s2 s3 result (eqt s3 result))) - #0a0 - #0a0 - #0a1 - #0a1 - t) - -(deftest bit-nor.6 - (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit)) - (s3 (make-array nil :initial-element 1 :element-type 'bit)) - (result (bit-nor s1 s2 s3))) - (values s1 s2 s3 result (eqt s3 result))) - #0a1 - #0a1 - #0a0 - #0a0 - t) - -(deftest bit-nor.7 - (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit)) - (result (bit-nor s1 s2 t))) - (values s1 s2 result (eqt s1 result))) - #0a0 - #0a0 - #0a0 - t) - - -;;; Tests on bit vectors - -(deftest bit-nor.8 - (let ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101))) - (values (check-values (bit-nor a1 a2)) a1 a2)) - #*1000 #*0011 #*0101) - -(deftest bit-nor.9 - (let* ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101)) - (result (check-values (bit-nor a1 a2 t)))) - (values result a1 a2 (eqt result a1))) - #*1000 #*1000 #*0101 t) - -(deftest bit-nor.10 - (let* ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101)) - (a3 (copy-seq #*1110)) - (result (check-values (bit-nor a1 a2 a3)))) - (values result a1 a2 a3 (eqt result a3))) - #*1000 #*0011 #*0101 #*1000 t) - -(deftest bit-nor.11 - (let ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101))) - (values (check-values (bit-nor a1 a2 nil)) a1 a2)) - #*1000 #*0011 #*0101) - -;;; Tests on bit arrays - -(deftest bit-nor.12 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-nor a1 a2))) - (values a1 a2 result)) - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((1 0)(0 0))) - -(deftest bit-nor.13 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-nor a1 a2 t))) - (values a1 a2 result)) - #2a((1 0)(0 0)) - #2a((0 0)(1 1)) - #2a((1 0)(0 0))) - -(deftest bit-nor.14 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-nor a1 a2 nil))) - (values a1 a2 result)) - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((1 0)(0 0))) - -(deftest bit-nor.15 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (a3 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(0 0)))) - (result (bit-nor a1 a2 a3))) - (values a1 a2 a3 result)) - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((1 0)(0 0)) - #2a((1 0)(0 0))) - -;;; Adjustable arrays - -(deftest bit-nor.16 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)) - :adjustable t)) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)) - :adjustable t)) - (result (bit-nor a1 a2))) - (values a1 a2 result)) - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((1 0)(0 0))) - -;;; Displaced arrays - -(deftest bit-nor.17 - (let* ((a0 (make-array '(8) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (result (bit-nor a1 a2))) - (values a0 a1 a2 result)) - #*01010011 - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((1 0)(0 0))) - -(deftest bit-nor.18 - (let* ((a0 (make-array '(8) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (result (bit-nor a1 a2 t))) - (values a0 a1 a2 result)) - #*10000011 - #2a((1 0)(0 0)) - #2a((0 0)(1 1)) - #2a((1 0)(0 0))) - -(deftest bit-nor.19 - (let* ((a0 (make-array '(12) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (a3 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 8)) - (result (bit-nor a1 a2 a3))) - (values a0 a1 a2 result)) - #*010100111000 - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((1 0)(0 0))) - -(deftest bit-nor.20 - (macrolet ((%m (z) z)) (bit-nor (expand-in-current-env (%m #*0011)) #*0101)) - #*1000) - -(deftest bit-nor.21 - (macrolet ((%m (z) z)) (bit-nor #*1010 (expand-in-current-env (%m #*1100)))) - #*0001) - -(deftest bit-nor.22 - (macrolet ((%m (z) z)) (bit-nor #*10100011 #*01101010 - (expand-in-current-env (%m nil)))) - #*00010100) - -(deftest bit-nor.order.1 - (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) - (s2 (make-array 1 :initial-element 0 :element-type 'bit)) - (x 0) y z) - (values - (bit-nor (progn (setf y (incf x)) s1) - (progn (setf z (incf x)) s2)) - x y z)) - #*1 2 1 2) - -(def-fold-test bit-nor.fold.1 (bit-nor #*00101 #*10100)) - -;;; Random tests - -(deftest bit-nor.random.1 - (bit-random-test-fn #'bit-nor #'lognor) - nil) - -;;; Error tests - -(deftest bit-nor.error.1 - (signals-error (bit-nor) program-error) - t) - -(deftest bit-nor.error.2 - (signals-error (bit-nor #*000) program-error) - t) - -(deftest bit-nor.error.3 - (signals-error (bit-nor #*000 #*0100 nil nil) - program-error) - t) diff --git a/t/ansi-test/arrays/bit-not.lsp b/t/ansi-test/arrays/bit-not.lsp deleted file mode 100644 index 012376b..0000000 --- a/t/ansi-test/arrays/bit-not.lsp +++ /dev/null @@ -1,156 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jan 26 19:40:13 2003 -;;;; Contains: Tests of BIT-NOT - - - -(deftest bit-not.1 - (let ((a1 (make-array nil :element-type 'bit :initial-element 0))) - (values (bit-not a1) a1)) - #0a1 #0a0) - -(deftest bit-not.2 - (let ((a1 (make-array nil :element-type 'bit :initial-element 1))) - (values (bit-not a1) a1)) - #0a0 #0a1) - -(deftest bit-not.3 - (let ((a1 (make-array nil :element-type 'bit :initial-element 0))) - (values (bit-not a1 t) a1)) - #0a1 #0a1) - -(deftest bit-not.4 - (let ((a1 (make-array nil :element-type 'bit :initial-element 1))) - (values (bit-not a1 t) a1)) - #0a0 #0a0) - -(deftest bit-not.5 - (let* ((a1 (make-array nil :element-type 'bit :initial-element 1)) - (a2 (make-array nil :element-type 'bit :initial-element 1)) - (result (bit-not a1 a2))) - (values a1 a2 (eqt a2 result))) - #0a1 #0a0 t) - -(deftest bit-not.6 - (let ((a1 (make-array nil :element-type 'bit :initial-element 0))) - (values (bit-not a1 nil) a1)) - #0a1 #0a0) - -;;; Tests on bit vectors - -(deftest bit-not.7 - (let ((a1 (copy-seq #*0011010110))) - (values (bit-not a1) a1)) - #*1100101001 - #*0011010110) - -(deftest bit-not.8 - (let ((a1 (copy-seq #*0011010110))) - (values (bit-not a1 t) a1)) - #*1100101001 - #*1100101001) - -(deftest bit-not.9 - (let ((a1 (copy-seq #*0011010110)) - (a2 (copy-seq #*0000000000))) - (values (bit-not a1 a2) a1 a2)) - #*1100101001 - #*0011010110 - #*1100101001) - -;;; Arrays - -(deftest bit-not.10 - (let ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(1 0))))) - (values (bit-not a1) a1)) - #2a((1 0)(0 1)) - #2a((0 1)(1 0))) - -(deftest bit-not.11 - (let ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(1 0))))) - (values (bit-not a1 nil) a1)) - #2a((1 0)(0 1)) - #2a((0 1)(1 0))) - -(deftest bit-not.12 - (let ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(1 0))))) - (values (bit-not a1 t) a1)) - #2a((1 0)(0 1)) - #2a((1 0)(0 1))) - -(deftest bit-not.13 - (let ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(1 0)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-element 0))) - (values (bit-not a1 a2) a1 a2)) - #2a((1 0)(0 1)) - #2a((0 1)(1 0)) - #2a((1 0)(0 1))) - -;;; Adjustable array - -(deftest bit-not.14 - (let ((a1 (make-array '(2 2) :element-type 'bit - :adjustable t - :initial-contents '((0 1)(1 0))))) - (values (bit-not a1) a1)) - #2a((1 0)(0 1)) - #2a((0 1)(1 0))) - -;;; Displaced arrays - -(deftest bit-not.15 - (let* ((a0 (make-array '(12) :element-type 'bit - :initial-contents '(0 0 0 1 1 0 0 0 0 0 0 0))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 2)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 6))) - (values (bit-not a1 a2) a0 a1 a2)) - #2a((1 0)(0 1)) - #*000110100100 - #2a((0 1)(1 0)) - #2a((1 0)(0 1))) - -;;; Macro env tests - -(deftest bit-not.16 - (macrolet - ((%m (z) z)) - (bit-not (expand-in-current-env (%m #*10010011)))) - #*01101100) - -(deftest bit-not.17 - (macrolet - ((%m (z) z)) - (bit-not #*1101011010 (expand-in-current-env (%m nil)))) - #*0010100101) - -;;; - -(deftest bit-not.order.1 - (let ((a (copy-seq #*001101)) - (i 0) x) - (values - (bit-not (progn (setf x (incf i)) a)) - i x)) - #*110010 1 1) - -(def-fold-test bit-not.fold.1 (bit-not #*00101)) - -;;; Error tests - -(deftest bit-not.error.1 - (signals-error (bit-not) program-error) - t) - -(deftest bit-not.error.2 - (signals-error (bit-not #*000 nil nil) program-error) - t) diff --git a/t/ansi-test/arrays/bit-orc1.lsp b/t/ansi-test/arrays/bit-orc1.lsp deleted file mode 100644 index 2f9dc44..0000000 --- a/t/ansi-test/arrays/bit-orc1.lsp +++ /dev/null @@ -1,274 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jan 26 19:25:28 2003 -;;;; Contains: Tests of BIT-ORC1 - - - - - -(deftest bit-orc1.1 - (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit))) - (values (bit-orc1 s1 s2) s1 s2)) - #0a1 - #0a0 - #0a0) - -(deftest bit-orc1.2 - (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit))) - (values (bit-orc1 s1 s2) s1 s2)) - #0a0 - #0a1 - #0a0) - -(deftest bit-orc1.3 - (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit))) - (values (bit-orc1 s1 s2) s1 s2)) - #0a1 - #0a0 - #0a1) - -(deftest bit-orc1.4 - (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit))) - (values (bit-orc1 s1 s2) s1 s2)) - #0a1 - #0a1 - #0a1) - -(deftest bit-orc1.5 - (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit)) - (s3 (make-array nil :initial-element 0 :element-type 'bit)) - (result (bit-orc1 s1 s2 s3))) - (values s1 s2 s3 result (eqt s3 result))) - #0a0 - #0a0 - #0a1 - #0a1 - t) - -(deftest bit-orc1.6 - (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit)) - (s3 (make-array nil :initial-element 0 :element-type 'bit)) - (result (bit-orc1 s1 s2 s3))) - (values s1 s2 s3 result (eqt s3 result))) - #0a1 - #0a1 - #0a1 - #0a1 - t) - -(deftest bit-orc1.7 - (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit)) - (result (bit-orc1 s1 s2 t))) - (values s1 s2 result (eqt s1 result))) - #0a0 - #0a0 - #0a0 - t) - - -;;; Tests on bit vectors - -(deftest bit-orc1.8 - (let ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101))) - (values (check-values (bit-orc1 a1 a2)) a1 a2)) - #*1101 #*0011 #*0101) - -(deftest bit-orc1.9 - (let* ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101)) - (result (check-values (bit-orc1 a1 a2 t)))) - (values result a1 a2 (eqt result a1))) - #*1101 #*1101 #*0101 t) - -(deftest bit-orc1.10 - (let* ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101)) - (a3 (copy-seq #*1110)) - (result (check-values (bit-orc1 a1 a2 a3)))) - (values result a1 a2 a3 (eqt result a3))) - #*1101 #*0011 #*0101 #*1101 t) - -(deftest bit-orc1.11 - (let ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101))) - (values (check-values (bit-orc1 a1 a2 nil)) a1 a2)) - #*1101 #*0011 #*0101) - -;;; Tests on bit arrays - -(deftest bit-orc1.12 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-orc1 a1 a2))) - (values a1 a2 result)) - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((1 0)(1 1))) - -(deftest bit-orc1.13 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-orc1 a1 a2 t))) - (values a1 a2 result)) - #2a((1 0)(1 1)) - #2a((0 0)(1 1)) - #2a((1 0)(1 1))) - -(deftest bit-orc1.14 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-orc1 a1 a2 nil))) - (values a1 a2 result)) - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((1 0)(1 1))) - -(deftest bit-orc1.15 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (a3 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(0 0)))) - (result (bit-orc1 a1 a2 a3))) - (values a1 a2 a3 result)) - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((1 0)(1 1)) - #2a((1 0)(1 1))) - -;;; Adjustable arrays - -(deftest bit-orc1.16 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)) - :adjustable t)) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)) - :adjustable t)) - (result (bit-orc1 a1 a2))) - (values a1 a2 result)) - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((1 0)(1 1))) - -;;; Displaced arrays - -(deftest bit-orc1.17 - (let* ((a0 (make-array '(8) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (result (bit-orc1 a1 a2))) - (values a0 a1 a2 result)) - #*01010011 - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((1 0)(1 1))) - -(deftest bit-orc1.18 - (let* ((a0 (make-array '(8) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (result (bit-orc1 a1 a2 t))) - (values a0 a1 a2 result)) - #*10110011 - #2a((1 0)(1 1)) - #2a((0 0)(1 1)) - #2a((1 0)(1 1))) - -(deftest bit-orc1.19 - (let* ((a0 (make-array '(12) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (a3 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 8)) - (result (bit-orc1 a1 a2 a3))) - (values a0 a1 a2 result)) - #*010100111011 - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((1 0)(1 1))) - -(deftest bit-orc1.20 - (macrolet ((%m (z) z)) (bit-orc1 (expand-in-current-env (%m #*0011)) #*0101)) - #*1101) - -(deftest bit-orc1.21 - (macrolet ((%m (z) z)) (bit-orc1 #*1010 (expand-in-current-env (%m #*1100)))) - #*1101) - -(deftest bit-orc1.22 - (macrolet ((%m (z) z)) (bit-orc1 #*10100011 #*01101010 - (expand-in-current-env (%m nil)))) - #*01111110) - - -(deftest bit-orc1.order.1 - (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) - (s2 (make-array 1 :initial-element 0 :element-type 'bit)) - (x 0) y z) - (values - (bit-orc1 (progn (setf y (incf x)) s1) - (progn (setf z (incf x)) s2)) - x y z)) - #*1 2 1 2) - -(deftest bit-orc1.fold.1 - (flet ((%f () (declare (optimize speed (safety 0) (space 0))) - (bit-orc1 #*11010 #*10100))) - (values (%f) (let ((bv (%f))) (setf (elt bv 0) 0) bv) (%f))) - #*10101 #*00101 #*10101) - -;;; Random tests - -(deftest bit-orc1.random.1 - (bit-random-test-fn #'bit-orc1 #'logorc1) - nil) - -;;; Error tests - -(deftest bit-orc1.error.1 - (signals-error (bit-orc1) program-error) - t) - -(deftest bit-orc1.error.2 - (signals-error (bit-orc1 #*000) program-error) - t) - -(deftest bit-orc1.error.3 - (signals-error (bit-orc1 #*000 #*0100 nil nil) - program-error) - t) - - diff --git a/t/ansi-test/arrays/bit-orc2.lsp b/t/ansi-test/arrays/bit-orc2.lsp deleted file mode 100644 index cfc9b22..0000000 --- a/t/ansi-test/arrays/bit-orc2.lsp +++ /dev/null @@ -1,273 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jan 26 19:31:35 2003 -;;;; Contains: Tests of BIT-ORC2 - - - - - -(deftest bit-orc2.1 - (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit))) - (values (bit-orc2 s1 s2) s1 s2)) - #0a1 - #0a0 - #0a0) - -(deftest bit-orc2.2 - (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit))) - (values (bit-orc2 s1 s2) s1 s2)) - #0a1 - #0a1 - #0a0) - -(deftest bit-orc2.3 - (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit))) - (values (bit-orc2 s1 s2) s1 s2)) - #0a0 - #0a0 - #0a1) - -(deftest bit-orc2.4 - (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit))) - (values (bit-orc2 s1 s2) s1 s2)) - #0a1 - #0a1 - #0a1) - -(deftest bit-orc2.5 - (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit)) - (s3 (make-array nil :initial-element 0 :element-type 'bit)) - (result (bit-orc2 s1 s2 s3))) - (values s1 s2 s3 result (eqt s3 result))) - #0a0 - #0a0 - #0a1 - #0a1 - t) - -(deftest bit-orc2.6 - (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit)) - (s3 (make-array nil :initial-element 0 :element-type 'bit)) - (result (bit-orc2 s1 s2 s3))) - (values s1 s2 s3 result (eqt s3 result))) - #0a1 - #0a1 - #0a1 - #0a1 - t) - -(deftest bit-orc2.7 - (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit)) - (result (bit-orc2 s1 s2 t))) - (values s1 s2 result (eqt s1 result))) - #0a1 - #0a0 - #0a1 - t) - - -;;; Tests on bit vectors - -(deftest bit-orc2.8 - (let ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101))) - (values (check-values (bit-orc2 a1 a2)) a1 a2)) - #*1011 #*0011 #*0101) - -(deftest bit-orc2.9 - (let* ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101)) - (result (check-values (bit-orc2 a1 a2 t)))) - (values result a1 a2 (eqt result a1))) - #*1011 #*1011 #*0101 t) - -(deftest bit-orc2.10 - (let* ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101)) - (a3 (copy-seq #*1110)) - (result (check-values (bit-orc2 a1 a2 a3)))) - (values result a1 a2 a3 (eqt result a3))) - #*1011 #*0011 #*0101 #*1011 t) - -(deftest bit-orc2.11 - (let ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101))) - (values (check-values (bit-orc2 a1 a2 nil)) a1 a2)) - #*1011 #*0011 #*0101) - -;;; Tests on bit arrays - -(deftest bit-orc2.12 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-orc2 a1 a2))) - (values a1 a2 result)) - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((1 1)(0 1))) - -(deftest bit-orc2.13 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-orc2 a1 a2 t))) - (values a1 a2 result)) - #2a((1 1)(0 1)) - #2a((0 0)(1 1)) - #2a((1 1)(0 1))) - -(deftest bit-orc2.14 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-orc2 a1 a2 nil))) - (values a1 a2 result)) - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((1 1)(0 1))) - -(deftest bit-orc2.15 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (a3 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(0 0)))) - (result (bit-orc2 a1 a2 a3))) - (values a1 a2 a3 result)) - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((1 1)(0 1)) - #2a((1 1)(0 1))) - -;;; Adjustable arrays - -(deftest bit-orc2.16 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)) - :adjustable t)) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)) - :adjustable t)) - (result (bit-orc2 a1 a2))) - (values a1 a2 result)) - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((1 1)(0 1))) - -;;; Displaced arrays - -(deftest bit-orc2.17 - (let* ((a0 (make-array '(8) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (result (bit-orc2 a1 a2))) - (values a0 a1 a2 result)) - #*01010011 - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((1 1)(0 1))) - -(deftest bit-orc2.18 - (let* ((a0 (make-array '(8) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (result (bit-orc2 a1 a2 t))) - (values a0 a1 a2 result)) - #*11010011 - #2a((1 1)(0 1)) - #2a((0 0)(1 1)) - #2a((1 1)(0 1))) - -(deftest bit-orc2.19 - (let* ((a0 (make-array '(12) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (a3 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 8)) - (result (bit-orc2 a1 a2 a3))) - (values a0 a1 a2 result)) - #*010100111101 - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((1 1)(0 1))) - -(deftest bit-orc2.20 - (macrolet ((%m (z) z)) (bit-orc2 (expand-in-current-env (%m #*0011)) #*0101)) - #*1011) - -(deftest bit-orc2.21 - (macrolet ((%m (z) z)) (bit-orc2 #*1010 (expand-in-current-env (%m #*1100)))) - #*1011) - -(deftest bit-orc2.22 - (macrolet ((%m (z) z)) (bit-orc2 #*10100011 #*01101010 - (expand-in-current-env (%m nil)))) - #*10110111) - -(deftest bit-orc2.order.1 - (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) - (s2 (make-array 1 :initial-element 0 :element-type 'bit)) - (x 0) y z) - (values - (bit-orc2 (progn (setf y (incf x)) s1) - (progn (setf z (incf x)) s2)) - x y z)) - #*1 2 1 2) - -(deftest bit-orc2.fold.1 - (flet ((%f () (declare (optimize speed (safety 0) (space 0))) - (bit-orc2 #*00101 #*01011))) - (values (%f) (let ((bv (%f))) (setf (elt bv 0) 0) bv) (%f))) - #*10101 #*00101 #*10101) - -;;; Random tests - -(deftest bit-orc2.random.1 - (bit-random-test-fn #'bit-orc2 #'logorc2) - nil) - -;;; Error tests - -(deftest bit-orc2.error.1 - (signals-error (bit-orc2) program-error) - t) - -(deftest bit-orc2.error.2 - (signals-error (bit-orc2 #*000) program-error) - t) - -(deftest bit-orc2.error.3 - (signals-error (bit-orc2 #*000 #*0100 nil nil) - program-error) - t) - - diff --git a/t/ansi-test/arrays/bit-vector-p.lsp b/t/ansi-test/arrays/bit-vector-p.lsp deleted file mode 100644 index 5fc780e..0000000 --- a/t/ansi-test/arrays/bit-vector-p.lsp +++ /dev/null @@ -1,81 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jan 26 20:16:50 2003 -;;;; Contains: Tests of BIT-VECTOR-P - - - -(deftest bit-vector-p.2 - (notnot-mv (bit-vector-p #*)) - t) - -(deftest bit-vector-p.3 - (notnot-mv (bit-vector-p #*00101)) - t) - -(deftest bit-vector-p.4 - (bit-vector-p #(0 1 1 1 0 0)) - nil) - -(deftest bit-vector-p.5 - (bit-vector-p "011100") - nil) - -(deftest bit-vector-p.6 - (bit-vector-p 0) - nil) - -(deftest bit-vector-p.7 - (bit-vector-p 1) - nil) - -(deftest bit-vector-p.8 - (bit-vector-p nil) - nil) - -(deftest bit-vector-p.9 - (bit-vector-p 'x) - nil) - -(deftest bit-vector-p.10 - (bit-vector-p '(0 1 1 0)) - nil) - -(deftest bit-vector-p.11 - (bit-vector-p (make-array '(2 2) :element-type 'bit - :initial-element 0)) - nil) - -(deftest bit-vector-p.12 - (check-type-predicate #'bit-vector-p 'bit-vector) - nil) - -(deftest bit-vector-p.13 - (macrolet - ((%m (z) z)) - (values (notnot (bit-vector-p (expand-in-current-env (%m #*110101)))) - (bit-vector-p (expand-in-current-env (%m nil))))) - t nil) - -(deftest bit-vector-p.order.1 - (let ((i 0) x) - (values - (notnot (bit-vector-p (progn (setf x (incf i)) #*0010))) - i x)) - t 1 1) - -(deftest bit-vector-p.order.2 - (let ((i 0) x) - (values - (bit-vector-p (progn (setf x (incf i)) 'a)) - i x)) - nil 1 1) - - -(deftest bit-vector-p.error.1 - (signals-error (bit-vector-p) program-error) - t) - -(deftest bit-vector-p.error.2 - (signals-error (bit-vector-p #* #*) program-error) - t) diff --git a/t/ansi-test/arrays/bit-vector.lsp b/t/ansi-test/arrays/bit-vector.lsp deleted file mode 100644 index e099db2..0000000 --- a/t/ansi-test/arrays/bit-vector.lsp +++ /dev/null @@ -1,121 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jan 26 13:03:22 2003 -;;;; Contains: Tests of type BIT-VECTOR - - - -(deftest bit-vector.1 - (notnot-mv (find-class 'bit-vector)) - t) - -(deftest bit-vector.2 - (notnot-mv (typep #* 'bit-vector)) - t) - -(deftest bit-vector.3 - (notnot-mv (typep #*00101 'bit-vector)) - t) - -(deftest bit-vector.4 - (typep #(0 1 1 1 0 0) 'bit-vector) - nil) - -(deftest bit-vector.5 - (typep "011100" 'bit-vector) - nil) - -(deftest bit-vector.6 - (typep 0 'bit-vector) - nil) - -(deftest bit-vector.7 - (typep 1 'bit-vector) - nil) - -(deftest bit-vector.8 - (typep nil 'bit-vector) - nil) - -(deftest bit-vector.9 - (typep 'x 'bit-vector) - nil) - -(deftest bit-vector.10 - (typep '(0 1 1 0) 'bit-vector) - nil) - -(deftest bit-vector.11 - (typep (make-array '(2 2) :element-type 'bit - :initial-element 0) - 'bit-vector) - nil) - -(deftest bit-vector.12 - (notnot-mv (typep #* '(bit-vector *))) - t) - -(deftest bit-vector.13 - (notnot-mv (typep #*01101 '(bit-vector *))) - t) - -(deftest bit-vector.14 - (notnot-mv (typep #* '(bit-vector 0))) - t) - -(deftest bit-vector.15 - (typep #*01101 '(bit-vector 0)) - nil) - -(deftest bit-vector.16 - (typep #* '(bit-vector 5)) - nil) - -(deftest bit-vector.17 - (notnot-mv (typep #*01101 '(bit-vector 5))) - t) - - -;;; Tests of typep on the class named bit-vector - -(deftest bit-vector.class.2 - (notnot-mv (typep #* (find-class 'bit-vector))) - t) - -(deftest bit-vector.class.3 - (notnot-mv (typep #*00101 (find-class 'bit-vector))) - t) - -(deftest bit-vector.class.4 - (typep #(0 1 1 1 0 0) (find-class 'bit-vector)) - nil) - -(deftest bit-vector.class.5 - (typep "011100" (find-class 'bit-vector)) - nil) - -(deftest bit-vector.class.6 - (typep 0 (find-class 'bit-vector)) - nil) - -(deftest bit-vector.class.7 - (typep 1 (find-class 'bit-vector)) - nil) - -(deftest bit-vector.class.8 - (typep nil (find-class 'bit-vector)) - nil) - -(deftest bit-vector.class.9 - (typep 'x (find-class 'bit-vector)) - nil) - -(deftest bit-vector.class.10 - (typep '(0 1 1 0) (find-class 'bit-vector)) - nil) - -(deftest bit-vector.class.11 - (typep (make-array '(2 2) :element-type 'bit - :initial-element 0) - (find-class 'bit-vector)) - nil) diff --git a/t/ansi-test/arrays/bit-xor.lsp b/t/ansi-test/arrays/bit-xor.lsp deleted file mode 100644 index c0111b7..0000000 --- a/t/ansi-test/arrays/bit-xor.lsp +++ /dev/null @@ -1,267 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jan 26 19:35:46 2003 -;;;; Contains: Tests of BIT-XOR - - - - - -(deftest bit-xor.1 - (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit))) - (values (bit-xor s1 s2) s1 s2)) - #0a0 - #0a0 - #0a0) - -(deftest bit-xor.2 - (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit))) - (values (bit-xor s1 s2) s1 s2)) - #0a1 - #0a1 - #0a0) - -(deftest bit-xor.3 - (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit))) - (values (bit-xor s1 s2) s1 s2)) - #0a1 - #0a0 - #0a1) - -(deftest bit-xor.4 - (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit))) - (values (bit-xor s1 s2) s1 s2)) - #0a0 - #0a1 - #0a1) - -(deftest bit-xor.5 - (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit)) - (s3 (make-array nil :initial-element 1 :element-type 'bit)) - (result (bit-xor s1 s2 s3))) - (values s1 s2 s3 result (eqt s3 result))) - #0a0 - #0a0 - #0a0 - #0a0 - t) - -(deftest bit-xor.6 - (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit)) - (s3 (make-array nil :initial-element 1 :element-type 'bit)) - (result (bit-xor s1 s2 s3))) - (values s1 s2 s3 result (eqt s3 result))) - #0a1 - #0a1 - #0a0 - #0a0 - t) - -(deftest bit-xor.7 - (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit)) - (result (bit-xor s1 s2 t))) - (values s1 s2 result (eqt s1 result))) - #0a1 - #0a0 - #0a1 - t) - - -;;; Tests on bit vectors - -(deftest bit-xor.8 - (let ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101))) - (values (check-values (bit-xor a1 a2)) a1 a2)) - #*0110 #*0011 #*0101) - -(deftest bit-xor.9 - (let* ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101)) - (result (check-values (bit-xor a1 a2 t)))) - (values result a1 a2 (eqt result a1))) - #*0110 #*0110 #*0101 t) - -(deftest bit-xor.10 - (let* ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101)) - (a3 (copy-seq #*1110)) - (result (check-values (bit-xor a1 a2 a3)))) - (values result a1 a2 a3 (eqt result a3))) - #*0110 #*0011 #*0101 #*0110 t) - -(deftest bit-xor.11 - (let ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101))) - (values (check-values (bit-xor a1 a2 nil)) a1 a2)) - #*0110 #*0011 #*0101) - -;;; Tests on bit arrays - -(deftest bit-xor.12 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-xor a1 a2))) - (values a1 a2 result)) - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((0 1)(1 0))) - -(deftest bit-xor.13 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-xor a1 a2 t))) - (values a1 a2 result)) - #2a((0 1)(1 0)) - #2a((0 0)(1 1)) - #2a((0 1)(1 0))) - -(deftest bit-xor.14 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-xor a1 a2 nil))) - (values a1 a2 result)) - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((0 1)(1 0))) - -(deftest bit-xor.15 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (a3 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(0 0)))) - (result (bit-xor a1 a2 a3))) - (values a1 a2 a3 result)) - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((0 1)(1 0)) - #2a((0 1)(1 0))) - -;;; Adjustable arrays - -(deftest bit-xor.16 - (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)) - :adjustable t)) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)) - :adjustable t)) - (result (bit-xor a1 a2))) - (values a1 a2 result)) - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((0 1)(1 0))) - -;;; Displaced arrays - -(deftest bit-xor.17 - (let* ((a0 (make-array '(8) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (result (bit-xor a1 a2))) - (values a0 a1 a2 result)) - #*01010011 - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((0 1)(1 0))) - -(deftest bit-xor.18 - (let* ((a0 (make-array '(8) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (result (bit-xor a1 a2 t))) - (values a0 a1 a2 result)) - #*01100011 - #2a((0 1)(1 0)) - #2a((0 0)(1 1)) - #2a((0 1)(1 0))) - -(deftest bit-xor.19 - (let* ((a0 (make-array '(12) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (a3 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 8)) - (result (bit-xor a1 a2 a3))) - (values a0 a1 a2 result)) - #*010100110110 - #2a((0 1)(0 1)) - #2a((0 0)(1 1)) - #2a((0 1)(1 0))) - -(deftest bit-xor.20 - (macrolet ((%m (z) z)) (bit-xor (expand-in-current-env (%m #*0011)) #*0101)) - #*0110) - -(deftest bit-xor.21 - (macrolet ((%m (z) z)) (bit-xor #*1010 (expand-in-current-env (%m #*1100)))) - #*0110) - -(deftest bit-xor.22 - (macrolet ((%m (z) z)) (bit-xor #*10100011 #*01101010 - (expand-in-current-env (%m nil)))) - #*11001001) - -(deftest bit-xor.order.1 - (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) - (s2 (make-array 1 :initial-element 0 :element-type 'bit)) - (x 0) y z) - (values - (bit-xor (progn (setf y (incf x)) s1) - (progn (setf z (incf x)) s2)) - x y z)) - #*0 2 1 2) - -(def-fold-test bit-xor.fold.1 (bit-xor #*00101 #*10100)) - -;;; Random tests - -(deftest bit-xor.random.1 - (bit-random-test-fn #'bit-xor #'logxor) - nil) - -;;; Error tests - -(deftest bit-xor.error.1 - (signals-error (bit-xor) program-error) - t) - -(deftest bit-xor.error.2 - (signals-error (bit-xor #*000) program-error) - t) - -(deftest bit-xor.error.3 - (signals-error (bit-xor #*000 #*0100 nil nil) - program-error) - t) diff --git a/t/ansi-test/arrays/bit.lsp b/t/ansi-test/arrays/bit.lsp deleted file mode 100644 index d012b4c..0000000 --- a/t/ansi-test/arrays/bit.lsp +++ /dev/null @@ -1,136 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jan 26 13:22:59 2003 -;;;; Contains: Tests for accessor BIT - - - -(deftest bit.1 - (bit #*0010 2) - 1) - -(deftest bit.2 - (let ((a #*00000000)) - (loop for i from 0 below (length a) - collect (let ((b (copy-seq a))) - (setf (bit b i) 1) - b))) - (#*10000000 - #*01000000 - #*00100000 - #*00010000 - #*00001000 - #*00000100 - #*00000010 - #*00000001)) - -(deftest bit.3 - (let ((a #*11111111)) - (loop for i from 0 below (length a) - collect (let ((b (copy-seq a))) - (setf (bit b i) 0) - b))) - (#*01111111 - #*10111111 - #*11011111 - #*11101111 - #*11110111 - #*11111011 - #*11111101 - #*11111110)) - -(deftest bit.4 - (let ((a (make-array nil :element-type 'bit :initial-element 0))) - (values - (aref a) - (bit a) - (setf (bit a) 1) - (aref a) - (bit a))) - 0 0 1 1 1) - -(deftest bit.5 - (let ((a (make-array '(1 1) :element-type 'bit :initial-element 0))) - (values - (aref a 0 0) - (bit a 0 0) - (setf (bit a 0 0) 1) - (aref a 0 0) - (bit a 0 0))) - 0 0 1 1 1) - -(deftest bit.6 - (let ((a (make-array '(10 10) :element-type 'bit :initial-element 0))) - (values - (aref a 5 5) - (bit a 5 5) - (setf (bit a 5 5) 1) - (aref a 5 5) - (bit a 5 5))) - 0 0 1 1 1) - -;;; Check that the fill pointer is ignored - -(deftest bit.7 - (let ((a (make-array '(10) :initial-contents '(0 1 1 0 0 1 1 1 0 0) - :element-type 'bit - :fill-pointer 5))) - (values - (coerce a 'list) - (loop for i from 0 below 10 collect (bit a i)) - (loop for i from 0 below 10 - collect (setf (bit a i) (- 1 (bit a i)))) - (coerce a 'list) - (loop for i from 0 below 10 collect (bit a i)) - (fill-pointer a))) - (0 1 1 0 0) - (0 1 1 0 0 1 1 1 0 0) - (1 0 0 1 1 0 0 0 1 1) - (1 0 0 1 1) - (1 0 0 1 1 0 0 0 1 1) - 5) - -;;; Check that adjustability is not relevant - -(deftest bit.8 - (let ((a (make-array '(10) :initial-contents '(0 1 1 0 0 1 1 1 0 0) - :element-type 'bit - :adjustable t))) - (values - (coerce a 'list) - (loop for i from 0 below 10 collect (bit a i)) - (loop for i from 0 below 10 - collect (setf (bit a i) (- 1 (bit a i)))) - (coerce a 'list) - (loop for i from 0 below 10 collect (bit a i)))) - (0 1 1 0 0 1 1 1 0 0) - (0 1 1 0 0 1 1 1 0 0) - (1 0 0 1 1 0 0 0 1 1) - (1 0 0 1 1 0 0 0 1 1) - (1 0 0 1 1 0 0 0 1 1)) - -;;; Order of evaluation tests - -(deftest bit.order.1 - (let ((x 0) y z - (b (copy-seq #*01010))) - (values - (bit (progn (setf y (incf x)) b) - (progn (setf z (incf x)) 1)) - x y z)) - 1 2 1 2) - -(deftest bit.order.2 - (let ((x 0) y z w - (b (copy-seq #*01010))) - (values - (setf (bit (progn (setf y (incf x)) b) - (progn (setf z (incf x)) 1)) - (progn (setf w (incf x)) 0)) - b - x y z w)) - 0 #*00010 3 1 2 3) - -(deftest bit.error.1 - (signals-error (bit) program-error) - t) diff --git a/t/ansi-test/arrays/fill-pointer.lsp b/t/ansi-test/arrays/fill-pointer.lsp deleted file mode 100644 index a77aea6..0000000 --- a/t/ansi-test/arrays/fill-pointer.lsp +++ /dev/null @@ -1,81 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Jan 21 22:14:23 2003 -;;;; Contains: Tests of FILL-POINTER - - - -;;; More tests are in make-array.lsp - -(deftest fill-pointer.1 - (fill-pointer (make-array '(10) :fill-pointer 5)) - 5) - -(deftest fill-pointer.2 - (fill-pointer (make-array '(10) :fill-pointer t)) - 10) - -(deftest fill-pointer.3 - (let ((a (make-array '(10) :fill-pointer 5 - :initial-contents '(1 2 3 4 5 6 7 8 9 10)))) - (values - (fill-pointer a) - (setf (fill-pointer a) 6) - a)) - 5 6 #(1 2 3 4 5 6)) - -(deftest fill-pointer.order.1 - (let ((i 0) - (a (make-array '(10) :fill-pointer 5))) - (values - (fill-pointer (progn (incf i) a)) - i)) - 5 1) - -(deftest fill-pointer.order.2 - (let ((i 0) x y - (a (make-array '(10) :fill-pointer 5 - :initial-contents '(1 2 3 4 5 6 7 8 9 10)))) - (values - i - (setf (fill-pointer (progn (setf x (incf i)) a)) - (progn (setf y (incf i)) 6)) - a - i x y)) - 0 6 #(1 2 3 4 5 6) 2 1 2) - -;;; Error tests - -(deftest fill-pointer.error.1 - (signals-error (fill-pointer) program-error) - t) - -(deftest fill-pointer.error.2 - (signals-error (fill-pointer (make-array '(10) :fill-pointer 4) nil) - program-error) - t) - -(deftest fill-pointer.error.3 - (let ((a (make-array '(10) :fill-pointer nil))) - (if (array-has-fill-pointer-p a) - t - (eval `(signals-error (fill-pointer ',a) type-error)))) - t) - -(deftest fill-pointer.error.4 - (signals-error (fill-pointer #0aNIL) type-error) - t) - -(deftest fill-pointer.error.5 - (signals-error (fill-pointer #2a((a b c)(d e f))) type-error) - t) - -(deftest fill-pointer.error.6 - (check-type-error #'fill-pointer #'(lambda (x) (and (vectorp x) - (array-has-fill-pointer-p x)))) - nil) - -(deftest fill-pointer.error.7 - (signals-error (locally (fill-pointer #2a((a b c)(d e f))) t) - type-error) - t) diff --git a/t/ansi-test/arrays/load.lsp b/t/ansi-test/arrays/load.lsp deleted file mode 100644 index d5f9756..0000000 --- a/t/ansi-test/arrays/load.lsp +++ /dev/null @@ -1,56 +0,0 @@ -;;; Tests on arrays -(compile-and-load "ANSI-TESTS:AUX;array-aux.lsp") -(compile-and-load "ANSI-TESTS:AUX;bit-aux.lsp") - -(in-package #:cl-test) - -(let ((*default-pathname-defaults* - (make-pathname - :directory (pathname-directory *load-pathname*)))) - (load "aref.lsp") - (load "array.lsp") - (load "array-t.lsp") - (load "array-as-class.lsp") - (load "simple-array.lsp") - (load "simple-array-t.lsp") - (load "bit-vector.lsp") - (load "simple-bit-vector.lsp") - (load "make-array.lsp") - (load "adjust-array.lsp") - (load "adjustable-array-p.lsp") - (load "array-displacement.lsp") - (load "array-dimension.lsp") - (load "array-dimensions.lsp") - (load "array-element-type.lsp") - (load "array-has-fill-pointer-p.lsp") - (load "array-in-bounds-p.lsp") - (load "array-misc.lsp") - (load "array-rank.lsp") - (load "array-row-major-index.lsp") - (load "array-total-size.lsp") - (load "arrayp.lsp") - (load "fill-pointer.lsp") - (load "row-major-aref.lsp") - (load "simple-vector-p.lsp") - (load "svref.lsp") - (load "upgraded-array-element-type.lsp") - (load "vector.lsp") - (load "vector-pop.lsp") - (load "vector-push.lsp") - (load "vector-push-extend.lsp") - (load "vectorp.lsp") - (load "bit.lsp") - (load "sbit.lsp") - (load "bit-and.lsp") - (load "bit-andc1.lsp") - (load "bit-andc2.lsp") - (load "bit-eqv.lsp") - (load "bit-ior.lsp") - (load "bit-nand.lsp") - (load "bit-nor.lsp") - (load "bit-orc1.lsp") - (load "bit-orc2.lsp") - (load "bit-xor.lsp") - (load "bit-not.lsp") - (load "bit-vector-p.lsp") - (load "simple-bit-vector-p.lsp")) diff --git a/t/ansi-test/arrays/make-array.lsp b/t/ansi-test/arrays/make-array.lsp deleted file mode 100644 index 333cb52..0000000 --- a/t/ansi-test/arrays/make-array.lsp +++ /dev/null @@ -1,747 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Sep 20 06:47:37 2002 -;;;; Contains: Tests for MAKE-ARRAY - - - - - -(deftest make-array.1 - (let ((a (make-array-with-checks 10))) - (and (symbolp a) a)) - nil) - -(deftest make-array.1a - (let ((a (make-array-with-checks '(10)))) - (and (symbolp a) a)) - nil) - -(deftest make-array.2 - (make-array-with-checks 3 :initial-element 'z) - #(z z z)) - -(deftest make-array.2a - (make-array-with-checks 3 :initial-contents '(a b c)) - #(a b c)) - -(deftest make-array.2b - (make-array-with-checks 3 :initial-contents #(a b c)) - #(a b c)) - -(deftest make-array.2c - (make-array-with-checks 3 :initial-contents "abc") - #(#\a #\b #\c)) - -(deftest make-array.2d - (make-array-with-checks 3 :initial-contents #*010) - #(0 1 0)) - -(deftest make-array.3 - (let ((a (make-array-with-checks 5 :element-type 'bit))) - (and (symbolp a) a)) - nil) - -(deftest make-array.4 - (make-array-with-checks 5 :element-type 'bit :initial-element 1) - #*11111) - -(deftest make-array.4a - (make-array-with-checks 5 :element-type 'bit :initial-contents '(1 0 0 1 0)) - #*10010) - -(deftest make-array.4b - (make-array-with-checks 5 :element-type 'bit :initial-contents #(1 0 0 1 0)) - #*10010) - -(deftest make-array.4c - (make-array-with-checks 5 :element-type 'bit :initial-contents #*10010) - #*10010) - -(deftest make-array.5 - (let ((a (make-array-with-checks 4 :element-type 'character))) - (and (symbolp a) a)) - nil) - -(deftest make-array.5a - (let ((a (make-array-with-checks '(4) :element-type 'character))) - (and (symbolp a) a)) - nil) - -(deftest make-array.6 - (make-array-with-checks 4 :element-type 'character - :initial-element #\x) - "xxxx") - -(deftest make-array.6a - (make-array-with-checks 4 :element-type 'character - :initial-contents '(#\a #\b #\c #\d)) - "abcd") - -(deftest make-array.6b - (make-array-with-checks 4 :element-type 'character - :initial-contents "abcd") - "abcd") - -(deftest make-array.7 - (make-array-with-checks 5 :element-type 'symbol - :initial-element 'a) - #(a a a a a)) - -(deftest make-array.7a - (make-array-with-checks 5 :element-type 'symbol - :initial-contents '(a b c d e)) - #(a b c d e)) - -(deftest make-array.7b - (make-array-with-checks '(5) :element-type 'symbol - :initial-contents '(a b c d e)) - #(a b c d e)) - -(deftest make-array.8 - (let ((a (make-array-with-checks 8 :element-type '(integer 0 (256))))) - ;; Should return a symbol only in error situations - (and (symbolp a) a)) - nil) - -(deftest make-array.8a - (make-array-with-checks 8 :element-type '(integer 0 (256)) - :initial-element 9) - #(9 9 9 9 9 9 9 9)) - -(deftest make-array.8b - (make-array-with-checks '(8) :element-type '(integer 0 (256)) - :initial-contents '(4 3 2 1 9 8 7 6)) - #(4 3 2 1 9 8 7 6)) - -(deftest make-array.8c - (loop for i from 1 to 32 - for tp = `(unsigned-byte ,i) - for a = (make-array 5 :fill-pointer 3 :element-type tp :initial-contents '(1 1 0 0 1)) - when (symbolp a) - collect (list i tp a)) - nil) - -(deftest make-array.8d - (loop for i from 2 to 32 - for tp = `(signed-byte ,i) - for a = (make-array 5 :fill-pointer 3 :element-type tp :initial-contents '(1 1 0 0 1)) - when (symbolp a) - collect (list i tp a)) - nil) - -(deftest make-array.8e - (loop for tp in '(short-float single-float double-float long-float) - for v in '(1.0s0 1.0f0 1.0d0 1.0l0) - for a = (make-array 5 :fill-pointer 3 :element-type tp :initial-element v) - when (symbolp a) - collect (list tp v a)) - nil) - -(deftest make-array.8f - (loop for tp in '(short-float single-float double-float long-float) - for v in '(1.0s0 1.0f0 1.0d0 1.0l0) - for a = (make-array 5 :fill-pointer 3 :element-type `(complex ,tp) - :initial-element (complex v)) - when (symbolp a) - collect (list tp v a)) - nil) - -;;; Zero dimensional arrays - -(deftest make-array.9 - (let ((a (make-array-with-checks nil))) - (and (symbolp a) a)) - nil) - -(deftest make-array.10 - (make-array-with-checks nil :initial-element 1) - #0a1) - -(deftest make-array.11 - (make-array-with-checks nil :initial-contents 2) - #0a2) - -(deftest make-array.12 - (make-array-with-checks nil :element-type 'bit :initial-contents 1) - #0a1) - -(deftest make-array.12a - (make-array-with-checks 10 :element-type 'bit :initial-contents '(1 0 0 1 1 0 0 1 0 0) - :fill-pointer 6) - #*100110) - -(deftest make-array.12b - (make-array-with-checks 10 :element-type 'character - :initial-contents "abcdefghij" - :fill-pointer 8) - "abcdefgh") - -(deftest make-array.12c - (make-array-with-checks 10 :element-type 'base-char - :initial-contents "abcdefghij" - :fill-pointer 8) - "abcdefgh") - -(deftest make-array.13 - (make-array-with-checks nil :element-type t :initial-contents 'a) - #0aa) - -;;; Higher dimensional arrays - -(deftest make-array.14 - (let ((a (make-array-with-checks '(2 3)))) - (and (symbolp a) a)) - nil) - -(deftest make-array.15 - (make-array-with-checks '(2 3) :initial-element 'x) - #2a((x x x) (x x x))) - -(deftest make-array.16 - (equalpt (make-array-with-checks '(0 0)) - (read-from-string "#2a()")) - t) - -(deftest make-array.17 - (make-array-with-checks '(2 3) :initial-contents '((a b c) (d e f))) - #2a((a b c) (d e f))) - -(deftest make-array.18 - (make-array-with-checks '(2 3) :initial-contents '(#(a b c) #(d e f))) - #2a((a b c) (d e f))) - -(deftest make-array.19 - (make-array-with-checks '(4) :initial-contents - (make-array '(10) :initial-element 1 - :fill-pointer 4)) - #(1 1 1 1)) - -(deftest make-array.20 - (let ((a (make-array '(10) :initial-element 1 - :fill-pointer 4))) - (make-array-with-checks '(3 4) :initial-contents - (list a a a))) - #2a((1 1 1 1) (1 1 1 1) (1 1 1 1))) - -(deftest make-array.21 - (make-array-with-checks '(3 4) :initial-contents - (make-array '(10) :initial-element '(1 2 3 4) - :fill-pointer 3)) - #2a((1 2 3 4) (1 2 3 4) (1 2 3 4))) - -(deftest make-array.22 - (loop for i from 3 below (min array-rank-limit 128) - always - (equalpt (make-array-with-checks (make-list i :initial-element 0)) - (read-from-string (format nil "#~Aa()" i)))) - t) - -(deftest make-array.23 - (let ((len (1- array-rank-limit))) - (equalpt (make-array-with-checks (make-list len :initial-element 0)) - (read-from-string (format nil "#~Aa()" len)))) - t) - -;;; (deftest make-array.24 -;;; (make-array-with-checks '(5) :initial-element 'a :displaced-to nil) -;;; #(a a a a a)) - -(deftest make-array.25 - (make-array '(4) :initial-element 'x :nonsense-argument t - :allow-other-keys t) - #(x x x x)) - -(deftest make-array.26 - (make-array '(4) :initial-element 'x - :allow-other-keys nil) - #(x x x x)) - -(deftest make-array.27 - (make-array '(4) :initial-element 'x - :allow-other-keys t - :allow-other-keys nil - :nonsense-argument t) - #(x x x x)) - -(deftest make-array.28 - (let ((*package* (find-package :cl-test))) - (let ((len (1- (min 10000 array-rank-limit)))) - (equalpt (make-array (make-list len :initial-element 1) :initial-element 'x) - (read-from-string (concatenate - 'string - (format nil "#~dA" len) - (make-string len :initial-element #\() - "x" - (make-string len :initial-element #\))))))) - t) - -(deftest make-array.29 - (make-array-with-checks '(5) :element-type '(integer 0 (256)) - :initial-contents '(0 5 255 119 57)) - #(0 5 255 119 57)) - -(deftest make-array.30 - (make-array-with-checks '(5) :element-type '(integer -128 127) - :initial-contents '(-10 5 -128 86 127)) - #(-10 5 -128 86 127)) - -(deftest make-array.31 - (make-array-with-checks '(5) :element-type '(integer 0 (65536)) - :initial-contents '(0 100 65535 7623 13)) - #(0 100 65535 7623 13)) - -(deftest make-array.32 - (make-array-with-checks '(5) :element-type 'fixnum - :initial-contents '(1 2 3 4 5)) - #(1 2 3 4 5)) - -(deftest make-array.33 - (make-array-with-checks '(5) :element-type 'short-float - :initial-contents '(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0)) - #(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0)) - -(deftest make-array.34 - (make-array-with-checks '(5) :element-type 'single-float - :initial-contents '(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0)) - #(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0)) - -(deftest make-array.35 - (make-array-with-checks '(5) :element-type 'double-float - :initial-contents '(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0)) - #(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0)) - -(deftest make-array.36 - (make-array-with-checks '(5) :element-type 'long-float - :initial-contents '(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0)) - #(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0)) - - -;;; Adjustable arrays - -(deftest make-array.adjustable.1 - (let ((a (make-array-with-checks '(10) :adjustable t))) - (and (symbolp a) a)) - nil) - -(deftest make-array.adjustable.2 - (make-array-with-checks '(4) :adjustable t - :initial-element 6) - #(6 6 6 6)) - -(deftest make-array.adjustable.3 - (make-array-with-checks nil :adjustable t :initial-element 7) - #0a7) - -(deftest make-array.adjustable.4 - (make-array-with-checks '(2 3) :adjustable t :initial-element 7) - #2a((7 7 7) (7 7 7))) - -(deftest make-array.adjustable.5 - (make-array-with-checks '(2 3) :adjustable t - :initial-contents '((1 2 3) "abc")) - #2a((1 2 3) (#\a #\b #\c))) - -(deftest make-array.adjustable.6 - (make-array-with-checks '(4) :adjustable t - :initial-contents '(a b c d)) - #(a b c d)) - -(deftest make-array.adjustable.7 - (make-array-with-checks '(4) :adjustable t - :fill-pointer t - :initial-contents '(a b c d)) - #(a b c d)) - -(deftest make-array.adjustable.7a - (make-array-with-checks '(4) :adjustable t - :element-type 'bit - :fill-pointer t - :initial-contents '(1 0 0 1)) - #(1 0 0 1)) - -(deftest make-array.adjustable.7b - (make-array-with-checks '(4) :adjustable t - :element-type 'base-char - :fill-pointer t - :initial-contents "abcd") - "abcd") - -(deftest make-array.adjustable.7c - (make-array-with-checks '(4) :adjustable t - :element-type 'character - :fill-pointer t - :initial-contents "abcd") - "abcd") - -(deftest make-array.adjustable.8 - (make-array-with-checks '(4) :adjustable t - :element-type '(integer 0 (256)) - :initial-contents '(1 4 7 9)) - #(1 4 7 9)) - -(deftest make-array.adjustable.9 - (make-array-with-checks '(4) :adjustable t - :element-type 'base-char - :initial-contents "abcd") - "abcd") - -(deftest make-array.adjustable.10 - (make-array-with-checks '(4) :adjustable t - :element-type 'bit - :initial-contents '(0 1 1 0)) - #*0110) - -(deftest make-array.adjustable.11 - (make-array-with-checks '(4) :adjustable t - :element-type 'symbol - :initial-contents '(a b c d)) - #(a b c d)) - -;;; Displaced arrays - -(deftest make-array.displaced.1 - (let ((a (make-array '(10) :initial-contents '(a b c d e f g h i j)))) - (make-array-with-checks '(5) :displaced-to a)) - #(a b c d e)) - -(deftest make-array.displaced.2 - (let ((a (make-array '(10) :initial-contents '(a b c d e f g h i j)))) - (make-array-with-checks '(5) :displaced-to a - :displaced-index-offset 3)) - #(d e f g h)) - -(deftest make-array.displaced.3 - (let ((a (make-array '(10) :initial-contents '(a b c d e f g h i j)))) - (make-array-with-checks '(5) :displaced-to a - :displaced-index-offset 5)) - #(f g h i j)) - -(deftest make-array.displaced.4 - (let ((a (make-array '(10) :initial-contents '(a b c d e f g h i j)))) - (make-array-with-checks '(0) :displaced-to a - :displaced-index-offset 10)) - #()) - -(deftest make-array.displaced.5 - (let ((a (make-array '(10) :element-type '(integer 0 (256)) - :initial-contents '(1 3 5 7 9 11 13 15 17 19)))) - (make-array-with-checks '(5) :element-type '(integer 0 (256)) - :displaced-to a)) - #(1 3 5 7 9)) - -(deftest make-array.displaced.6 - (let ((a (make-array '(10) :element-type '(integer 0 (256)) - :initial-contents '(1 3 5 7 9 11 13 15 17 19)))) - (loop for i from 0 to 5 collect - (make-array-with-checks '(5) :element-type '(integer 0 (256)) - :displaced-to a - :displaced-index-offset i))) - (#(1 3 5 7 9) - #(3 5 7 9 11) - #(5 7 9 11 13) - #(7 9 11 13 15) - #(9 11 13 15 17) - #(11 13 15 17 19))) - -(deftest make-array.displaced.7 - (let ((a (make-array '(10) :element-type '(integer 0 (256)) - :initial-contents '(1 3 5 7 9 11 13 15 17 19)))) - (make-array-with-checks '(0) :element-type '(integer 0 (256)) - :displaced-to a - :displaced-index-offset 10)) - #()) - -(deftest make-array.displaced.8 - (let ((a (make-array '(10) :element-type 'bit - :initial-contents '(0 1 1 0 1 1 1 0 1 0)))) - (make-array-with-checks '(5) :element-type 'bit - :displaced-to a)) - #*01101) - -(deftest make-array.displaced.9 - (let ((a (make-array '(10) :element-type 'bit - :initial-contents '(0 1 1 0 1 1 1 0 1 0)))) - (loop for i from 0 to 5 collect - (make-array-with-checks '(5) :element-type 'bit - :displaced-to a - :displaced-index-offset i))) - (#*01101 #*11011 #*10111 #*01110 #*11101 #*11010)) - -(deftest make-array.displaced.10 - (let ((a (make-array '(10) :element-type 'bit - :initial-contents '(0 1 1 0 1 1 1 0 1 0)))) - (make-array-with-checks '(0) :element-type 'bit - :displaced-to a - :displaced-index-offset 10)) - #*) - -(deftest make-array.displaced.11 - (let ((a (make-array '(10) :element-type 'base-char - :initial-contents "abcdefghij"))) - (make-array-with-checks '(5) :element-type 'base-char - :displaced-to a)) - "abcde") - -(deftest make-array.displaced.12 - (let ((a (make-array '(10) :element-type 'base-char - :initial-contents "abcdefghij"))) - (loop for i from 0 to 5 collect - (make-array-with-checks '(5) :element-type 'base-char - :displaced-to a - :displaced-index-offset i))) - ("abcde" - "bcdef" - "cdefg" - "defgh" - "efghi" - "fghij")) - -(deftest make-array.displaced.13 - (let ((a (make-array '(10) :element-type 'base-char - :initial-contents "abcdefghij"))) - (make-array-with-checks '(0) :element-type 'base-char - :displaced-to a - :displaced-index-offset 10)) - "") - -(deftest make-array.displaced.14 - (let ((a (make-array '(10) :element-type 'character - :initial-contents "abcdefghij"))) - (make-array-with-checks '(5) :element-type 'character - :displaced-to a)) - "abcde") - -(deftest make-array.displaced.15 - (let ((a (make-array '(10) :element-type 'character - :initial-contents "abcdefghij"))) - (loop for i from 0 to 5 collect - (make-array-with-checks '(5) :element-type 'character - :displaced-to a - :displaced-index-offset i))) - ("abcde" - "bcdef" - "cdefg" - "defgh" - "efghi" - "fghij")) - -(deftest make-array.displaced.16 - (let ((a (make-array '(10) :element-type 'character - :initial-contents "abcdefghij"))) - (make-array-with-checks '(0) :element-type 'character - :displaced-to a - :displaced-index-offset 10)) - "") - -;;; Multidimensional displaced arrays - -(deftest make-array.displaced.17 - (let ((a (make-array '(3 4) :initial-contents '((1 2 3 4) (5 6 7 8) - (9 10 11 12))))) - (make-array-with-checks '(8) :displaced-to a)) - #(1 2 3 4 5 6 7 8)) - -(deftest make-array.displaced.18 - (let ((a (make-array '(3 4) :initial-contents '((1 2 3 4) (5 6 7 8) - (9 10 11 12))))) - (make-array-with-checks '(8) :displaced-to a - :displaced-index-offset 3)) - #(4 5 6 7 8 9 10 11)) - -(deftest make-array.displaced.19 - (let ((a (make-array '(3 4) :initial-contents '((1 2 3 4) (5 6 7 8) - (9 10 11 12))))) - (make-array-with-checks '(2 4) :displaced-to a - :displaced-index-offset 4)) - #2a((5 6 7 8) (9 10 11 12))) - -(deftest make-array.displaced.20 - (let ((a (make-array '(2 3 4) - :initial-contents '(((a b c d) (e f g h) (i j k l)) - ((m n o p) (q r s t) (u v w x)))))) - (make-array-with-checks '(24) :displaced-to a)) - #(a b c d e f g h i j k l m n o p q r s t u v w x)) - -(deftest make-array.displaced.21 - (let ((a (make-array '(2 3 4) - :initial-contents '(((a b c d) (e f g h) (i j k l)) - ((m n o p) (q r s t) (u v w x)))))) - (make-array-with-checks '(3 8) :displaced-to a)) - #2a((a b c d e f g h) (i j k l m n o p) (q r s t u v w x))) - -(deftest make-array.displaced.22 - (let ((a (make-array '(2 3 4) - :initial-contents '(((a b c d) (e f g h) (i j k l)) - ((m n o p) (q r s t) (u v w x)))))) - (make-array-with-checks '(10) :displaced-to a - :displaced-index-offset 5)) - #(f g h i j k l m n o)) - -(deftest make-array.displaced.23 - (let ((a (make-array '(2 3 4) - :initial-contents '(((a b c d) (e f g h) (i j k l)) - ((m n o p) (q r s t) (u v w x)))))) - (make-array-with-checks '(10) :displaced-to a - :displaced-index-offset 5 - :fill-pointer t)) - #(f g h i j k l m n o)) - -(deftest make-array.displaced.24 - (let ((a (make-array '(2 3 4) - :initial-contents '(((a b c d) (e f g h) (i j k l)) - ((m n o p) (q r s t) (u v w x)))))) - (make-array-with-checks '(10) :displaced-to a - :displaced-index-offset 5 - :fill-pointer 5)) - #(f g h i j)) - -(deftest make-array.displaced.25 - (let ((a (make-array '(2 3 4) - :initial-contents '(((a b c d) (e f g h) (i j k l)) - ((m n o p) (q r s t) (u v w x)))))) - (make-array-with-checks '(10) :displaced-to a - :displaced-index-offset 5 - :adjustable t)) - #(f g h i j k l m n o)) - -(deftest make-array.displaced.26 - (let ((a (make-array '(2 3 4) - :initial-contents '(((a b c d) (e f g h) (i j k l)) - ((m n o p) (q r s t) (u v w x)))))) - (make-array-with-checks '(10) :displaced-to a - :displaced-index-offset 5 - :fill-pointer 8 - :adjustable t)) - #(f g h i j k l m)) - -(deftest make-array.displaced.27 - (let ((a (make-array '(10) - :initial-contents '(1 2 3 4 5 6 7 8 9 10) - :fill-pointer t))) - (make-array-with-checks '(2 4) :displaced-to a)) - #2a((1 2 3 4) (5 6 7 8))) - -(deftest make-array.displaced.28 - (let ((a (make-array '(10) - :initial-contents '(1 2 3 4 5 6 7 8 9 10) - :fill-pointer 4))) - (make-array-with-checks '(2 4) :displaced-to a)) - #2a((1 2 3 4) (5 6 7 8))) - -(deftest make-array.displaced.29 - (let ((a (make-array '(10) :initial-element 0))) - (prog1 - (make-array-with-checks '(2 4) :displaced-to a) - (loop for i below 10 do (setf (aref a i) (1+ i))))) - #2a((1 2 3 4) (5 6 7 8))) - -(deftest make-array.displaced.30 - (let* ((a1 (make-array '(10) :initial-element 0)) - (a2 (make-array '(10) :displaced-to a1))) - (prog1 - (make-array-with-checks '(2 4) :displaced-to a2) - (loop for i below 10 do (setf (aref a2 i) (1+ i))))) - #2a((1 2 3 4) (5 6 7 8))) - -(deftest make-array.displaced.31 - (let* ((a1 (make-array '(10) :initial-element 0)) - (a2 (make-array '(10) :displaced-to a1))) - (prog1 - (make-array-with-checks '(2 4) :displaced-to a2) - (loop for i below 10 do (setf (aref a1 i) (1+ i))))) - #2a((1 2 3 4) (5 6 7 8))) - - -;;; Keywords tests - -(deftest make-array.allow-other-keys.1 - (make-array '(5) :initial-element 'a :allow-other-keys t) - #(a a a a a)) - -(deftest make-array.allow-other-keys.2 - (make-array '(5) :initial-element 'a :allow-other-keys nil) - #(a a a a a)) - -(deftest make-array.allow-other-keys.3 - (make-array '(5) :initial-element 'a :allow-other-keys t '#:bad t) - #(a a a a a)) - -(deftest make-array.allow-other-keys.4 - (make-array '(5) :initial-element 'a :bad t :allow-other-keys t) - #(a a a a a)) - -(deftest make-array.allow-other-keys.5 - (make-array '(5) :bad t :initial-element 'a :allow-other-keys t) - #(a a a a a)) - -(deftest make-array.allow-other-keys.6 - (make-array '(5) :bad t :initial-element 'a :allow-other-keys t - :allow-other-keys nil :also-bad nil) - #(a a a a a)) - -(deftest make-array.allow-other-keys.7 - (make-array '(5) :allow-other-keys t :initial-element 'a) - #(a a a a a)) - -(deftest make-array.keywords.8. - (make-array '(5) :initial-element 'x :initial-element 'a) - #(x x x x x)) - -;;; Error tests - -(deftest make-array.error.1 - (signals-error (make-array) program-error) - t) - -(deftest make-array.error.2 - (signals-error (make-array '(10) :bad t) program-error) - t) - -(deftest make-array.error.3 - (signals-error (make-array '(10) :allow-other-keys nil :bad t) - program-error) - t) - -(deftest make-array.error.4 - (signals-error (make-array '(10) :allow-other-keys nil - :allow-other-keys t :bad t) - program-error) - t) - -(deftest make-array.error.5 - (signals-error (make-array '(10) :bad) program-error) - t) - -(deftest make-array.error.6 - (signals-error (make-array '(10) 1 2) program-error) - t) - -;;; Order of evaluation tests - -(deftest make-array.order.1 - (let ((i 0) a b c e) - (values - (make-array (progn (setf a (incf i)) 5) - :initial-element (progn (setf b (incf i)) 'a) - :fill-pointer (progn (setf c (incf i)) nil) - ;; :displaced-to (progn (setf d (incf i)) nil) - :element-type (progn (setf e (incf i)) t) - ) - i a b c e)) - #(a a a a a) 4 1 2 3 4) - -(deftest make-array.order.2 - (let ((i 0) a b d e) - (values - (make-array (progn (setf a (incf i)) 5) - :element-type (progn (setf b (incf i)) t) - ;; :displaced-to (progn (setf c (incf i)) nil) - :fill-pointer (progn (setf d (incf i)) nil) - :initial-element (progn (setf e (incf i)) 'a) - ) - i a b d e)) - #(a a a a a) 4 1 2 3 4) - -;; Must add back order tests for :displaced-to and :displaced-index-offset - diff --git a/t/ansi-test/arrays/row-major-aref.lsp b/t/ansi-test/arrays/row-major-aref.lsp deleted file mode 100644 index 2b0cc7f..0000000 --- a/t/ansi-test/arrays/row-major-aref.lsp +++ /dev/null @@ -1,112 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Jan 22 20:16:38 2003 -;;;; Contains: Tests of ROW-MAJOR-AREF - - - -;;; ROW-MAJOR-AREF is also used by equalp-with-case (see rt/rt.lsp) - -(deftest row-major-aref.1 - (loop for i from 0 to 5 collect (row-major-aref #(a b c d e f) i)) - (a b c d e f)) - -(deftest row-major-aref.2 - (loop for i from 0 to 5 collect (row-major-aref #2a((a b c d)(e f g h)) i)) - (a b c d e f)) - -(deftest row-major-aref.3 - (row-major-aref #0a100 0) - 100) - -(deftest row-major-aref.4 - (loop for i from 0 to 5 collect (row-major-aref #*011100 i)) - (0 1 1 1 0 0)) - -(deftest row-major-aref.5 - (loop for i from 0 to 5 collect (row-major-aref "abcdef" i)) - (#\a #\b #\c #\d #\e #\f)) - -(deftest row-major-aref.6 - (let ((a (make-array nil :initial-element 'x))) - (values - (aref a) - (setf (row-major-aref a 0) 'y) - (aref a) - a)) - x y y #0ay) - -(deftest row-major-aref.7 - (let ((a (make-array '(4) :initial-element 'x))) - (values - (aref a 0) - (aref a 1) - (aref a 2) - (aref a 3) - (setf (row-major-aref a 0) 'a) - (setf (row-major-aref a 1) 'b) - (setf (row-major-aref a 2) 'c) - a)) - x x x x a b c #(a b c x)) - -(deftest row-major-aref.8 - (let ((a (make-array '(4) :element-type 'base-char - :initial-element #\x))) - (values - (aref a 0) - (aref a 1) - (aref a 2) - (aref a 3) - (setf (row-major-aref a 0) #\a) - (setf (row-major-aref a 1) #\b) - (setf (row-major-aref a 2) #\c) - a)) - #\x #\x #\x #\x #\a #\b #\c "abcx") - -(deftest row-major-aref.9 - (let ((a (make-array '(4) :initial-element 0 - :element-type 'bit))) - (values - (aref a 0) - (aref a 1) - (aref a 2) - (aref a 3) - (setf (row-major-aref a 0) 1) - (setf (row-major-aref a 1) 1) - (setf (row-major-aref a 3) 1) - a)) - 0 0 0 0 1 1 1 #*1101) - -(deftest row-major-aref.10 - (let ((a (make-array '(2 3 4) - :initial-contents '(((a b c d)(e f g h)(i j k l)) - ((m n o p)(q r s t)(u v w x)))))) - (loop for i from 0 to 23 collect (row-major-aref a i))) - (a b c d e f g h i j k l m n o p q r s t u v w x)) - -(deftest row-major-aref.order.1 - (let ((i 0) x y) - (values - (row-major-aref - (progn (setf x (incf i)) #(a b c d e f)) - (progn (setf y (incf i)) 2)) - i x y)) - c 2 1 2) - -(deftest row-major-aref.order.2 - (let ((i 0) x y z - (a (copy-seq #(a b c d e f)))) - (values - (setf - (row-major-aref - (progn (setf x (incf i)) a) - (progn (setf y (incf i)) 2)) - (progn (setf z (incf i)) 'w)) - a i x y z)) - w #(a b w d e f) 3 1 2 3) - -;;; Error tests - -(deftest row-major-aref.error.1 - (signals-error (row-major-aref) program-error) - t) diff --git a/t/ansi-test/arrays/sbit.lsp b/t/ansi-test/arrays/sbit.lsp deleted file mode 100644 index 8fd040b..0000000 --- a/t/ansi-test/arrays/sbit.lsp +++ /dev/null @@ -1,95 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jan 26 15:30:31 2003 -;;;; Contains: Tests for SBIT - - - -(deftest sbit.1 - (sbit #*0010 2) - 1) - -(deftest sbit.2 - (let ((a #*00000000)) - (loop for i from 0 below (length a) - collect (let ((b (copy-seq a))) - (setf (sbit b i) 1) - b))) - (#*10000000 - #*01000000 - #*00100000 - #*00010000 - #*00001000 - #*00000100 - #*00000010 - #*00000001)) - -(deftest sbit.3 - (let ((a #*11111111)) - (loop for i from 0 below (length a) - collect (let ((b (copy-seq a))) - (setf (sbit b i) 0) - b))) - (#*01111111 - #*10111111 - #*11011111 - #*11101111 - #*11110111 - #*11111011 - #*11111101 - #*11111110)) - -(deftest sbit.4 - (let ((a (make-array nil :element-type 'bit :initial-element 0))) - (values - (aref a) - (sbit a) - (setf (sbit a) 1) - (aref a) - (sbit a))) - 0 0 1 1 1) - -(deftest sbit.5 - (let ((a (make-array '(1 1) :element-type 'bit :initial-element 0))) - (values - (aref a 0 0) - (sbit a 0 0) - (setf (sbit a 0 0) 1) - (aref a 0 0) - (sbit a 0 0))) - 0 0 1 1 1) - -(deftest sbit.6 - (let ((a (make-array '(10 10) :element-type 'bit :initial-element 0))) - (values - (aref a 5 5) - (sbit a 5 5) - (setf (sbit a 5 5) 1) - (aref a 5 5) - (sbit a 5 5))) - 0 0 1 1 1) - -(deftest sbit.order.1 - (let ((i 0) a b) - (values - (sbit (progn (setf a (incf i)) #*001001) - (progn (setf b (incf i)) 1)) - i a b)) - 0 2 1 2) - -(deftest sbit.order.2 - (let ((i 0) a b c - (v (copy-seq #*001001))) - (values - (setf (sbit (progn (setf a (incf i)) v) - (progn (setf b (incf i)) 1)) - (progn (setf c (incf i)) 1)) - v i a b c)) - 1 #*011001 3 1 2 3) - -(deftest sbit.error.1 - (signals-error (sbit) program-error) - t) - - - diff --git a/t/ansi-test/arrays/simple-array-t.lsp b/t/ansi-test/arrays/simple-array-t.lsp deleted file mode 100644 index 70a69cd..0000000 --- a/t/ansi-test/arrays/simple-array-t.lsp +++ /dev/null @@ -1,275 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jan 26 07:23:45 2003 -;;;; Contains: Tests of SIMPLE-ARRAY on T element type - - - -;;; Tests of (simple-array t) - -(deftest simple-array-t.2.1 - (notnot-mv (typep #() '(simple-array t))) - t) - -(deftest simple-array-t.2.2 - (notnot-mv (typep #0aX '(simple-array t))) - t) - -(deftest simple-array-t.2.3 - (notnot-mv (typep #2a(()) '(simple-array t))) - t) - -(deftest simple-array-t.2.4 - (notnot-mv (typep #(1 2 3) '(simple-array t))) - t) - -(deftest simple-array-t.2.5 - (typep "abcd" '(simple-array t)) - nil) - -(deftest simple-array-t.2.6 - (typep #*010101 '(simple-array t)) - nil) - -;;; Tests of (simple-array t ()) - -(deftest simple-array-t.3.1 - (notnot-mv (typep #() '(simple-array t nil))) - nil) - -(deftest simple-array-t.3.2 - (notnot-mv (typep #0aX '(simple-array t nil))) - t) - -(deftest simple-array-t.3.3 - (typep #2a(()) '(simple-array t nil)) - nil) - -(deftest simple-array-t.3.4 - (typep #(1 2 3) '(simple-array t nil)) - nil) - -(deftest simple-array-t.3.5 - (typep "abcd" '(simple-array t nil)) - nil) - -(deftest simple-array-t.3.6 - (typep #*010101 '(simple-array t nil)) - nil) - -;;; Tests of (simple-array t 1) -;;; The '1' indicates rank, so this is equivalent to 'vector' - -(deftest simple-array-t.4.1 - (notnot-mv (typep #() '(simple-array t 1))) - t) - -(deftest simple-array-t.4.2 - (typep #0aX '(simple-array t 1)) - nil) - -(deftest simple-array-t.4.3 - (typep #2a(()) '(simple-array t 1)) - nil) - -(deftest simple-array-t.4.4 - (notnot-mv (typep #(1 2 3) '(simple-array t 1))) - t) - -(deftest simple-array-t.4.5 - (typep "abcd" '(simple-array t 1)) - nil) - -(deftest simple-array-t.4.6 - (typep #*010101 '(simple-array t 1)) - nil) - -;;; Tests of (simple-array t 0) - -(deftest simple-array-t.5.1 - (typep #() '(simple-array t 0)) - nil) - -(deftest simple-array-t.5.2 - (notnot-mv (typep #0aX '(simple-array t 0))) - t) - -(deftest simple-array-t.5.3 - (typep #2a(()) '(simple-array t 0)) - nil) - -(deftest simple-array-t.5.4 - (typep #(1 2 3) '(simple-array t 0)) - nil) - -(deftest simple-array-t.5.5 - (typep "abcd" '(simple-array t 0)) - nil) - -(deftest simple-array-t.5.6 - (typep #*010101 '(simple-array t 0)) - nil) - -;;; Tests of (simple-array t *) - -(deftest simple-array-t.6.1 - (notnot-mv (typep #() '(simple-array t *))) - t) - -(deftest simple-array-t.6.2 - (notnot-mv (typep #0aX '(simple-array t *))) - t) - -(deftest simple-array-t.6.3 - (notnot-mv (typep #2a(()) '(simple-array t *))) - t) - -(deftest simple-array-t.6.4 - (notnot-mv (typep #(1 2 3) '(simple-array t *))) - t) - -(deftest simple-array-t.6.5 - (typep "abcd" '(simple-array t *)) - nil) - -(deftest simple-array-t.6.6 - (typep #*010101 '(simple-array t *)) - nil) - -;;; Tests of (simple-array t 2) - -(deftest simple-array-t.7.1 - (typep #() '(simple-array t 2)) - nil) - -(deftest simple-array-t.7.2 - (typep #0aX '(simple-array t 2)) - nil) - -(deftest simple-array-t.7.3 - (notnot-mv (typep #2a(()) '(simple-array t 2))) - t) - -(deftest simple-array-t.7.4 - (typep #(1 2 3) '(simple-array t 2)) - nil) - -(deftest simple-array-t.7.5 - (typep "abcd" '(simple-array t 2)) - nil) - -(deftest simple-array-t.7.6 - (typep #*010101 '(simple-array t 2)) - nil) - -;;; Testing '(simple-array t (--)) - -(deftest simple-array-t.8.1 - (typep #() '(simple-array t (1))) - nil) - -(deftest simple-array-t.8.2 - (notnot-mv (typep #() '(simple-array t (0)))) - t) - -(deftest simple-array-t.8.3 - (notnot-mv (typep #() '(simple-array t (*)))) - t) - -(deftest simple-array-t.8.4 - (typep #(a b c) '(simple-array t (2))) - nil) - -(deftest simple-array-t.8.5 - (notnot-mv (typep #(a b c) '(simple-array t (3)))) - t) - -(deftest simple-array-t.8.6 - (notnot-mv (typep #(a b c) '(simple-array t (*)))) - t) - -(deftest simple-array-t.8.7 - (typep #(a b c) '(simple-array t (4))) - nil) - -(deftest simple-array-t.8.8 - (typep #2a((a b c)) '(simple-array t (*))) - nil) - -(deftest simple-array-t.8.9 - (typep #2a((a b c)) '(simple-array t (3))) - nil) - -(deftest simple-array-t.8.10 - (typep #2a((a b c)) '(simple-array t (1))) - nil) - -(deftest simple-array-t.8.11 - (typep "abc" '(simple-array t (2))) - nil) - -(deftest simple-array-t.8.12 - (typep "abc" '(simple-array t (3))) - nil) - -(deftest simple-array-t.8.13 - (typep "abc" '(simple-array t (*))) - nil) - -(deftest simple-array-t.8.14 - (typep "abc" '(simple-array t (4))) - nil) - -;;; Two dimensional simple-array type tests - -(deftest simple-array-t.9.1 - (typep #() '(simple-array t (* *))) - nil) - -(deftest simple-array-t.9.2 - (typep "abc" '(simple-array t (* *))) - nil) - -(deftest simple-array-t.9.3 - (typep #(a b c) '(simple-array t (3 *))) - nil) - -(deftest simple-array-t.9.4 - (typep #(a b c) '(simple-array t (* 3))) - nil) - -(deftest simple-array-t.9.5 - (typep "abc" '(simple-array t (3 *))) - nil) - -(deftest simple-array-t.9.6 - (typep "abc" '(simple-array t (* 3))) - nil) - -(deftest simple-array-t.9.7 - (notnot-mv (typep #2a((a b)(c d)(e f)) '(simple-array t (* *)))) - t) - -(deftest simple-array-t.9.8 - (notnot-mv (typep #2a((a b)(c d)(e f)) '(simple-array t (3 *)))) - t) - -(deftest simple-array-t.9.9 - (typep #2a((a b)(c d)(e f)) '(simple-array t (2 *))) - nil) - -(deftest simple-array-t.9.10 - (notnot-mv (typep #2a((a b)(c d)(e f)) '(simple-array t (* 2)))) - t) - -(deftest simple-array-t.9.11 - (typep #2a((a b)(c d)(e f)) '(simple-array t (* 3))) - nil) - -(deftest simple-array-t.9.12 - (notnot-mv (typep #2a((a b)(c d)(e f)) '(simple-array t (3 2)))) - t) - -(deftest simple-array-t.9.13 - (typep #2a((a b)(c d)(e f)) '(simple-array t (2 3))) - nil) diff --git a/t/ansi-test/arrays/simple-array.lsp b/t/ansi-test/arrays/simple-array.lsp deleted file mode 100644 index 0c8212e..0000000 --- a/t/ansi-test/arrays/simple-array.lsp +++ /dev/null @@ -1,329 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jan 26 07:20:31 2003 -;;;; Contains: Tests of SIMPLE-ARRAY - - - -;;; Tests of simple-array by itself - -(deftest simple-array.1.1 - (notnot-mv (typep #() 'simple-array)) - t) - -(deftest simple-array.1.2 - (notnot-mv (typep #0aX 'simple-array)) - t) - -(deftest simple-array.1.3 - (notnot-mv (typep #2a(()) 'simple-array)) - t) - -(deftest simple-array.1.4 - (notnot-mv (typep #(1 2 3) 'simple-array)) - t) - -(deftest simple-array.1.5 - (notnot-mv (typep "abcd" 'simple-array)) - t) - -(deftest simple-array.1.6 - (notnot-mv (typep #*010101 'simple-array)) - t) - -(deftest simple-array.1.7 - (typep nil 'simple-array) - nil) - -(deftest simple-array.1.8 - (typep 'x 'simple-array) - nil) - -(deftest simple-array.1.9 - (typep '(a b c) 'simple-array) - nil) - -(deftest simple-array.1.10 - (typep 10.0 'simple-array) - nil) - -(deftest simple-array.1.11 - (typep #'(lambda (x) (cons x nil)) 'simple-array) - nil) - -(deftest simple-array.1.12 - (typep 1 'simple-array) - nil) - -(deftest simple-array.1.13 - (typep (1+ most-positive-fixnum) 'simple-array) - nil) - -;;; Tests of (simple-array *) - -(deftest simple-array.2.1 - (notnot-mv (typep #() '(simple-array *))) - t) - -(deftest simple-array.2.2 - (notnot-mv (typep #0aX '(simple-array *))) - t) - -(deftest simple-array.2.3 - (notnot-mv (typep #2a(()) '(simple-array *))) - t) - -(deftest simple-array.2.4 - (notnot-mv (typep #(1 2 3) '(simple-array *))) - t) - -(deftest simple-array.2.5 - (notnot-mv (typep "abcd" '(simple-array *))) - t) - -(deftest simple-array.2.6 - (notnot-mv (typep #*010101 '(simple-array *))) - t) - -;;; Tests of (simple-array * ()) - -(deftest simple-array.3.1 - (notnot-mv (typep #() '(simple-array * nil))) - nil) - -(deftest simple-array.3.2 - (notnot-mv (typep #0aX '(simple-array * nil))) - t) - -(deftest simple-array.3.3 - (typep #2a(()) '(simple-array * nil)) - nil) - -(deftest simple-array.3.4 - (typep #(1 2 3) '(simple-array * nil)) - nil) - -(deftest simple-array.3.5 - (typep "abcd" '(simple-array * nil)) - nil) - -(deftest simple-array.3.6 - (typep #*010101 '(simple-array * nil)) - nil) - -;;; Tests of (simple-array * 1) -;;; The '1' indicates rank, so this is equivalent to 'vector' - -(deftest simple-array.4.1 - (notnot-mv (typep #() '(simple-array * 1))) - t) - -(deftest simple-array.4.2 - (typep #0aX '(simple-array * 1)) - nil) - -(deftest simple-array.4.3 - (typep #2a(()) '(simple-array * 1)) - nil) - -(deftest simple-array.4.4 - (notnot-mv (typep #(1 2 3) '(simple-array * 1))) - t) - -(deftest simple-array.4.5 - (notnot-mv (typep "abcd" '(simple-array * 1))) - t) - -(deftest simple-array.4.6 - (notnot-mv (typep #*010101 '(simple-array * 1))) - t) - -;;; Tests of (simple-array * 0) - -(deftest simple-array.5.1 - (typep #() '(simple-array * 0)) - nil) - -(deftest simple-array.5.2 - (notnot-mv (typep #0aX '(simple-array * 0))) - t) - -(deftest simple-array.5.3 - (typep #2a(()) '(simple-array * 0)) - nil) - -(deftest simple-array.5.4 - (typep #(1 2 3) '(simple-array * 0)) - nil) - -(deftest simple-array.5.5 - (typep "abcd" '(simple-array * 0)) - nil) - -(deftest simple-array.5.6 - (typep #*010101 '(simple-array * 0)) - nil) - -;;; Tests of (simple-array * *) - -(deftest simple-array.6.1 - (notnot-mv (typep #() '(simple-array * *))) - t) - -(deftest simple-array.6.2 - (notnot-mv (typep #0aX '(simple-array * *))) - t) - -(deftest simple-array.6.3 - (notnot-mv (typep #2a(()) '(simple-array * *))) - t) - -(deftest simple-array.6.4 - (notnot-mv (typep #(1 2 3) '(simple-array * *))) - t) - -(deftest simple-array.6.5 - (notnot-mv (typep "abcd" '(simple-array * *))) - t) - -(deftest simple-array.6.6 - (notnot-mv (typep #*010101 '(simple-array * *))) - t) - -;;; Tests of (simple-array * 2) - -(deftest simple-array.7.1 - (typep #() '(simple-array * 2)) - nil) - -(deftest simple-array.7.2 - (typep #0aX '(simple-array * 2)) - nil) - -(deftest simple-array.7.3 - (notnot-mv (typep #2a(()) '(simple-array * 2))) - t) - -(deftest simple-array.7.4 - (typep #(1 2 3) '(simple-array * 2)) - nil) - -(deftest simple-array.7.5 - (typep "abcd" '(simple-array * 2)) - nil) - -(deftest simple-array.7.6 - (typep #*010101 '(simple-array * 2)) - nil) - -;;; Testing '(simple-array * (--)) - -(deftest simple-array.8.1 - (typep #() '(simple-array * (1))) - nil) - -(deftest simple-array.8.2 - (notnot-mv (typep #() '(simple-array * (0)))) - t) - -(deftest simple-array.8.3 - (notnot-mv (typep #() '(simple-array * (*)))) - t) - -(deftest simple-array.8.4 - (typep #(a b c) '(simple-array * (2))) - nil) - -(deftest simple-array.8.5 - (notnot-mv (typep #(a b c) '(simple-array * (3)))) - t) - -(deftest simple-array.8.6 - (notnot-mv (typep #(a b c) '(simple-array * (*)))) - t) - -(deftest simple-array.8.7 - (typep #(a b c) '(simple-array * (4))) - nil) - -(deftest simple-array.8.8 - (typep #2a((a b c)) '(simple-array * (*))) - nil) - -(deftest simple-array.8.9 - (typep #2a((a b c)) '(simple-array * (3))) - nil) - -(deftest simple-array.8.10 - (typep #2a((a b c)) '(simple-array * (1))) - nil) - -(deftest simple-array.8.11 - (typep "abc" '(simple-array * (2))) - nil) - -(deftest simple-array.8.12 - (notnot-mv (typep "abc" '(simple-array * (3)))) - t) - -(deftest simple-array.8.13 - (notnot-mv (typep "abc" '(simple-array * (*)))) - t) - -(deftest simple-array.8.14 - (typep "abc" '(simple-array * (4))) - nil) - -;;; Two dimensional simple-array type tests - -(deftest simple-array.9.1 - (typep #() '(simple-array * (* *))) - nil) - -(deftest simple-array.9.2 - (typep "abc" '(simple-array * (* *))) - nil) - -(deftest simple-array.9.3 - (typep #(a b c) '(simple-array * (3 *))) - nil) - -(deftest simple-array.9.4 - (typep #(a b c) '(simple-array * (* 3))) - nil) - -(deftest simple-array.9.5 - (typep "abc" '(simple-array * (3 *))) - nil) - -(deftest simple-array.9.6 - (typep "abc" '(simple-array * (* 3))) - nil) - -(deftest simple-array.9.7 - (notnot-mv (typep #2a((a b)(c d)(e f)) '(simple-array * (* *)))) - t) - -(deftest simple-array.9.8 - (notnot-mv (typep #2a((a b)(c d)(e f)) '(simple-array * (3 *)))) - t) - -(deftest simple-array.9.9 - (typep #2a((a b)(c d)(e f)) '(simple-array * (2 *))) - nil) - -(deftest simple-array.9.10 - (notnot-mv (typep #2a((a b)(c d)(e f)) '(simple-array * (* 2)))) - t) - -(deftest simple-array.9.11 - (typep #2a((a b)(c d)(e f)) '(simple-array * (* 3))) - nil) - -(deftest simple-array.9.12 - (notnot-mv (typep #2a((a b)(c d)(e f)) '(simple-array * (3 2)))) - t) - -(deftest simple-array.9.13 - (typep #2a((a b)(c d)(e f)) '(simple-array * (2 3))) - nil) diff --git a/t/ansi-test/arrays/simple-bit-vector-p.lsp b/t/ansi-test/arrays/simple-bit-vector-p.lsp deleted file mode 100644 index 06c169a..0000000 --- a/t/ansi-test/arrays/simple-bit-vector-p.lsp +++ /dev/null @@ -1,59 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jan 26 20:20:27 2003 -;;;; Contains: Tests of SIMPLE-BIT-VECTOR-P - - - -(deftest simple-bit-vector-p.2 - (notnot-mv (simple-bit-vector-p #*)) - t) - -(deftest simple-bit-vector-p.3 - (notnot-mv (simple-bit-vector-p #*00101)) - t) - -(deftest simple-bit-vector-p.4 - (simple-bit-vector-p #(0 1 1 1 0 0)) - nil) - -(deftest simple-bit-vector-p.5 - (simple-bit-vector-p "011100") - nil) - -(deftest simple-bit-vector-p.6 - (simple-bit-vector-p 0) - nil) - -(deftest simple-bit-vector-p.7 - (simple-bit-vector-p 1) - nil) - -(deftest simple-bit-vector-p.8 - (simple-bit-vector-p nil) - nil) - -(deftest simple-bit-vector-p.9 - (simple-bit-vector-p 'x) - nil) - -(deftest simple-bit-vector-p.10 - (simple-bit-vector-p '(0 1 1 0)) - nil) - -(deftest simple-bit-vector-p.11 - (simple-bit-vector-p (make-array '(2 2) :element-type 'bit - :initial-element 0)) - nil) - -(deftest simple-bit-vector-p.12 - (check-type-predicate #'simple-bit-vector-p 'simple-bit-vector) - nil) - -(deftest simple-bit-vector-p.error.1 - (signals-error (simple-bit-vector-p) program-error) - t) - -(deftest simple-bit-vector-p.error.2 - (signals-error (simple-bit-vector-p #* #*) program-error) - t) diff --git a/t/ansi-test/arrays/simple-bit-vector.lsp b/t/ansi-test/arrays/simple-bit-vector.lsp deleted file mode 100644 index 80a8c53..0000000 --- a/t/ansi-test/arrays/simple-bit-vector.lsp +++ /dev/null @@ -1,72 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jan 26 13:12:07 2003 -;;;; Contains: Tests for type SIMPLE-BIT-VECTOR - - - -(deftest simple-bit-vector.2 - (notnot-mv (typep #* 'simple-bit-vector)) - t) - -(deftest simple-bit-vector.3 - (notnot-mv (typep #*00101 'simple-bit-vector)) - t) - -(deftest simple-bit-vector.4 - (typep #(0 1 1 1 0 0) 'simple-bit-vector) - nil) - -(deftest simple-bit-vector.5 - (typep "011100" 'simple-bit-vector) - nil) - -(deftest simple-bit-vector.6 - (typep 0 'simple-bit-vector) - nil) - -(deftest simple-bit-vector.7 - (typep 1 'simple-bit-vector) - nil) - -(deftest simple-bit-vector.8 - (typep nil 'simple-bit-vector) - nil) - -(deftest simple-bit-vector.9 - (typep 'x 'simple-bit-vector) - nil) - -(deftest simple-bit-vector.10 - (typep '(0 1 1 0) 'simple-bit-vector) - nil) - -(deftest simple-bit-vector.11 - (typep (make-array '(2 2) :element-type 'bit - :initial-element 0) - 'simple-bit-vector) - nil) - -(deftest simple-bit-vector.12 - (notnot-mv (typep #* '(simple-bit-vector *))) - t) - -(deftest simple-bit-vector.13 - (notnot-mv (typep #*01101 '(simple-bit-vector *))) - t) - -(deftest simple-bit-vector.14 - (notnot-mv (typep #* '(simple-bit-vector 0))) - t) - -(deftest simple-bit-vector.15 - (typep #*01101 '(simple-bit-vector 0)) - nil) - -(deftest simple-bit-vector.16 - (typep #* '(simple-bit-vector 5)) - nil) - -(deftest simple-bit-vector.17 - (notnot-mv (typep #*01101 '(simple-bit-vector 5))) - t) diff --git a/t/ansi-test/arrays/simple-vector-p.lsp b/t/ansi-test/arrays/simple-vector-p.lsp deleted file mode 100644 index fd38395..0000000 --- a/t/ansi-test/arrays/simple-vector-p.lsp +++ /dev/null @@ -1,67 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Jan 22 21:23:45 2003 -;;;; Contains: Tests for SIMPLE-VECTOR-P - - - -;;; More tests for this are in make-array.lsp - -(deftest simple-vector-p.1 - (check-type-predicate #'simple-vector-p 'simple-vector) - nil) - -(deftest simple-vector-p.2 - (notnot-mv (simple-vector-p (make-array '(10)))) - t) - -;; (deftest simple-vector-p.3 -;; (simple-vector-p (make-array '(5) :fill-pointer t)) -;; nil) - -(deftest simple-vector-p.4 - (notnot-mv (simple-vector-p (vector 'a 'b 'c))) - t) - -;;; (deftest simple-vector-p.5 -;;; (simple-vector-p (make-array '(5) :adjustable t)) -;;; nil) - -;;; (deftest simple-vector-p.6 -;;; (let ((a #(a b c d e g h))) -;;; (simple-vector-p (make-array '(5) :displaced-to a))) -;;; nil) - -(deftest simple-vector-p.7 - (simple-vector-p #*001101) - nil) - -(deftest simple-vector-p.8 - (simple-vector-p "abcdef") - nil) - -(deftest simple-vector-p.9 - (simple-vector-p (make-array nil)) - nil) - -(deftest simple-vector-p.10 - (simple-vector-p (make-array '(10) :element-type 'base-char)) - nil) - -(deftest simple-vector-p.11 - (simple-vector-p (make-array '(10) :element-type 'character)) - nil) - -(deftest simple-vector-p.12 - (simple-vector-p (make-array '(10) :element-type 'bit)) - nil) - -;;; Error tests - -(deftest simple-vector-p.error.1 - (signals-error (simple-vector-p) program-error) - t) - -(deftest simple-vector-p.error.2 - (signals-error (simple-vector-p #(a b) nil) program-error) - t) diff --git a/t/ansi-test/arrays/svref.lsp b/t/ansi-test/arrays/svref.lsp deleted file mode 100644 index baa44ad..0000000 --- a/t/ansi-test/arrays/svref.lsp +++ /dev/null @@ -1,59 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Jan 22 21:39:30 2003 -;;;; Contains: Tests of SVREF - - - -(deftest svref.1 - (let ((a (vector 1 2 3 4))) - (loop for i below 4 collect (svref a i))) - (1 2 3 4)) - -(deftest svref.2 - (let ((a (vector 1 2 3 4))) - (values - (loop for i below 4 - collect (setf (svref a i) (+ i 10))) - a)) - (10 11 12 13) - #(10 11 12 13)) - -(deftest svref.order.1 - (let ((v (vector 'a 'b 'c 'd)) - (i 0) a b) - (values - (svref (progn (setf a (incf i)) v) - (progn (setf b (incf i)) 2)) - i a b)) - c 2 1 2) - -(deftest svref.order.2 - (let ((v (vector 'a 'b 'c 'd)) - (i 0) a b c) - (values - (setf - (svref (progn (setf a (incf i)) v) - (progn (setf b (incf i)) 2)) - (progn (setf c (incf i)) 'w)) - v i a b c)) - w #(a b w d) 3 1 2 3) - - -;;; Error tests - -(deftest svref.error.1 - (signals-error (svref) program-error) - t) - -(deftest svref.error.2 - (signals-error (svref (vector 1)) program-error) - t) - -(deftest svref.error.3 - (signals-error (svref (vector 1) 0 0) program-error) - t) - -(deftest svref.error.4 - (signals-error (svref (vector 1) 0 nil) program-error) - t) diff --git a/t/ansi-test/arrays/upgraded-array-element-type.lsp b/t/ansi-test/arrays/upgraded-array-element-type.lsp deleted file mode 100644 index b453349..0000000 --- a/t/ansi-test/arrays/upgraded-array-element-type.lsp +++ /dev/null @@ -1,126 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Jan 22 20:43:55 2003 -;;;; Contains: Tests of UPGRADED-ARRAY-ELEMENT-TYPE - - - -(deftest upgraded-array-element-type.1 - (let ((upgraded-bit (upgraded-array-element-type 'bit))) - (and (empirical-subtypep 'bit upgraded-bit) - (empirical-subtypep upgraded-bit 'bit))) - t) - -(deftest upgraded-array-element-type.2 - (let ((upgraded-base-char (upgraded-array-element-type 'base-char))) - (and (empirical-subtypep 'base-char upgraded-base-char) - (empirical-subtypep upgraded-base-char 'base-char))) - t) - -(deftest upgraded-array-element-type.3 - (let ((upgraded-character (upgraded-array-element-type 'character))) - (and (empirical-subtypep 'character upgraded-character) - (empirical-subtypep upgraded-character 'character))) - t) - -(defparameter *upgraded-array-types-to-check* - `(boolean - base-char - character - t - ,@(loop for i from 0 to 32 collect `(eql ,(ash 1 i))) - ,@(loop for i from 0 to 32 collect `(eql ,(1- (ash 1 i)))) - (eql -1) - ,@(loop for i from 0 to 32 - collect `(integer 0 (,(ash 1 i)))) - symbol - ,@(loop for i from 0 to 32 - collect `(integer ,(- (ash 1 i)) (,(ash 1 i)))) - (integer -10000000000000000000000000000000000 - 10000000000000000000000000000000000) - float - short-float - single-float - double-float - complex - rational - fixnum - function - sequence - list - cons - atom - symbol)) - -(deftest upgraded-array-element-type.4 - (loop for type in *upgraded-array-types-to-check* - for upgraded-type = (upgraded-array-element-type type) - unless (empirical-subtypep type upgraded-type) - collect (list type upgraded-type)) - nil) - -;; Include an environment (NIL, denoting the default null lexical -;; environment) - -(deftest upgraded-array-element-type.5 - (loop for type in *upgraded-array-types-to-check* - for upgraded-type = (upgraded-array-element-type type nil) - unless (empirical-subtypep type upgraded-type) - collect (list type upgraded-type)) - nil) - -(deftest upgraded-array-element-type.6 - (macrolet - ((%foo (&environment env) - (empirical-subtypep - 'bit - (upgraded-array-element-type 'bit env)))) - (%foo)) - t) - -(deftest upgraded-array-element-type.7 - (let ((upgraded-types (mapcar #'upgraded-array-element-type - *upgraded-array-types-to-check*))) - (loop for type in *upgraded-array-types-to-check* - for upgraded-type in upgraded-types - append - (loop for type2 in *upgraded-array-types-to-check* - for upgraded-type2 in upgraded-types - when (and (subtypep type type2) - (equal (subtypep* upgraded-type upgraded-type) - '(nil t))) - collect (list type type2)))) - nil) - -;;; Tests that if Tx is a subtype of Ty, then UAET(Tx) is a subtype -;;; of UAET(Ty) (see section 15.1.2.1, paragraph 3) - -(deftest upgraded-array-element-type.8 - (let ((upgraded-types (mapcar #'upgraded-array-element-type - *upgraded-array-types-to-check*))) - (loop for type1 in *upgraded-array-types-to-check* - for uaet1 in upgraded-types - append - (loop for type2 in *upgraded-array-types-to-check* - for uaet2 in upgraded-types - when (and (subtypep type1 type2) - (not (empirical-subtypep uaet1 uaet2))) - collect (list type1 type2)))) - nil) - -;;; Tests of upgrading NIL (it should be type equivalent to NIL) - -(deftest upgraded-array-element-type.nil.1 - (let ((uaet-nil (upgraded-array-element-type nil))) - (check-predicate (typef `(not ,uaet-nil)))) - nil) - -;;; Error tests - -(deftest upgraded-array-element-type.error.1 - (signals-error (upgraded-array-element-type) program-error) - t) - -(deftest upgraded-array-element-type.error.2 - (signals-error (upgraded-array-element-type 'bit nil nil) program-error) - t) diff --git a/t/ansi-test/arrays/vector-pop.lsp b/t/ansi-test/arrays/vector-pop.lsp deleted file mode 100644 index e64c376..0000000 --- a/t/ansi-test/arrays/vector-pop.lsp +++ /dev/null @@ -1,45 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Jan 24 07:46:29 2003 -;;;; Contains: Tests for VECTOR-POP - - - -(deftest vector-pop.1 - (let ((v (make-array '(5) :initial-contents '(a b c d e) - :fill-pointer 3))) - (values - (length v) - (check-values (vector-pop v)) - (fill-pointer v) - (length v) - v)) - 3 c 2 2 #(a b)) - -;;; Error cases - -(deftest vector-pop.error.1 - (signals-error (let ((v (vector 1 2 3))) - (if (array-has-fill-pointer-p v) - (error 'type-error :datum v :expected-type nil) - (vector-pop v))) - type-error) - t) - -(deftest vector-pop.error.2 - (let ((v (make-array '(5) :initial-element 'x - :fill-pointer 0))) - (handler-case (vector-pop v) - (error () 'error))) - error) - -(deftest vector-pop.error.3 - (signals-error (vector-pop) program-error) - t) - -(deftest vector-pop.error.4 - (signals-error (let ((v (make-array '(5) :fill-pointer t - :initial-element 'x))) - (vector-pop v nil)) - program-error) - t) diff --git a/t/ansi-test/arrays/vector-push-extend.lsp b/t/ansi-test/arrays/vector-push-extend.lsp deleted file mode 100644 index 8025616..0000000 --- a/t/ansi-test/arrays/vector-push-extend.lsp +++ /dev/null @@ -1,608 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Jan 25 08:04:35 2003 -;;;; Contains: Tests for VECTOR-PUSH-EXTEND - - - -(deftest vector-push-extend.1 - (let ((a (make-array '(5) :fill-pointer 2 - :initial-contents '(a b c d e))) - (i 0) x y) - (values - (fill-pointer a) - (vector-push-extend (progn (setf x (incf i)) 'x) - (progn (setf y (incf i)) a)) - (fill-pointer a) - a - i x y)) - 2 2 3 #(a b x) 2 1 2) - -(deftest vector-push-extend.2 - (let ((a (make-array '(5) :fill-pointer 5 - :adjustable t - :initial-contents '(a b c d e)))) - (values - (fill-pointer a) - (vector-push-extend 'x a) - (fill-pointer a) - (<= (array-total-size a) 5) - a)) - 5 5 6 nil #(a b c d e x)) - -(deftest vector-push-extend.3 - (let ((a (make-array '(5) :fill-pointer 2 - :initial-contents "abcde" - :element-type 'base-char))) - (values - (fill-pointer a) - (vector-push-extend #\x a) - (fill-pointer a) - a)) - 2 2 3 "abx") - -(deftest vector-push-extend.4 - (let ((a (make-array '(5) :fill-pointer 5 - :adjustable t - :initial-contents "abcde" - :element-type 'base-char)) - (i 0) x y z) - (values - (fill-pointer a) - (vector-push-extend (progn (setf x (incf i)) #\x) - (progn (setf y (incf i)) a) - (progn (setf z (incf i)) 1)) - (fill-pointer a) - (<= (array-total-size a) 5) - a - i x y z)) - 5 5 6 nil "abcdex" 3 1 2 3) - -(deftest vector-push-extend.5 - (let ((a (make-array '(5) :fill-pointer 2 - :initial-contents "abcde" - :element-type 'character))) - (values - (fill-pointer a) - (vector-push-extend #\x a) - (fill-pointer a) - a)) - 2 2 3 "abx") - -(deftest vector-push-extend.6 - (let ((a (make-array '(5) :fill-pointer 5 - :adjustable t - :initial-contents "abcde" - :element-type 'character))) - (values - (fill-pointer a) - (vector-push-extend #\x a 10) - (fill-pointer a) - (<= (array-total-size a) 5) - a)) - 5 5 6 nil "abcdex") - -(deftest vector-push-extend.7 - (let ((a (make-array '(5) :fill-pointer 2 - :initial-contents '(0 1 1 0 0) - :element-type 'bit))) - (values - (fill-pointer a) - (vector-push-extend 0 a) - (fill-pointer a) - a)) - 2 2 3 #*010) - -(deftest vector-push-extend.8 - (let ((a (make-array '(5) :fill-pointer 5 - :adjustable t - :initial-contents '(0 0 0 0 0) - :element-type 'bit))) - (values - (fill-pointer a) - (vector-push-extend 1 a 100) - (fill-pointer a) - (<= (array-total-size a) 5) - a)) - 5 5 6 nil #*000001) - -(deftest vector-push-extend.9 - (let ((a (make-array '(5) :fill-pointer 2 - :initial-contents '(1 2 3 4 5) - :element-type 'fixnum))) - (values - (fill-pointer a) - (vector-push-extend 0 a) - (fill-pointer a) - a)) - 2 2 3 #(1 2 0)) - -(deftest vector-push-extend.10 - (let ((a (make-array '(5) :fill-pointer 5 - :adjustable t - :initial-contents '(1 2 3 4 5) - :element-type 'fixnum))) - (values - (fill-pointer a) - (vector-push-extend 0 a 1) - (fill-pointer a) - (<= (array-total-size a) 5) - a)) - 5 5 6 nil #(1 2 3 4 5 0)) - -(deftest vector-push-extend.11 - (let ((a (make-array '(5) :fill-pointer 2 - :initial-contents '(1 2 3 4 5) - :element-type '(integer 0 (256))))) - (values - (fill-pointer a) - (vector-push-extend 0 a) - (fill-pointer a) - a)) - 2 2 3 #(1 2 0)) - -(deftest vector-push-extend.12 - (let ((a (make-array '(5) :fill-pointer 5 - :adjustable t - :initial-contents '(1 2 3 4 5) - :element-type '(integer 0 (256))))) - (values - (fill-pointer a) - (vector-push-extend 0 a 1) - (fill-pointer a) - (<= (array-total-size a) 5) - a)) - 5 5 6 nil #(1 2 3 4 5 0)) - -(deftest vector-push-extend.13 - (let ((a (make-array '(5) :fill-pointer 2 - :initial-contents '(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0) - :element-type 'short-float))) - (values - (fill-pointer a) - (vector-push-extend 0.0s0 a) - (fill-pointer a) - a)) - 2 2 3 #(1.0s0 2.0s0 0.0s0)) - -(deftest vector-push-extend.14 - (let ((a (make-array '(5) :fill-pointer 5 - :adjustable t - :initial-contents '(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0) - :element-type 'short-float))) - (values - (fill-pointer a) - (vector-push-extend 0.0s0 a 1) - (fill-pointer a) - (<= (array-total-size a) 5) - a)) - 5 5 6 nil #(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0 0.0s0)) - -(deftest vector-push-extend.15 - (let ((a (make-array '(5) :fill-pointer 2 - :initial-contents '(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0) - :element-type 'single-float))) - (values - (fill-pointer a) - (vector-push-extend 0.0f0 a) - (fill-pointer a) - a)) - 2 2 3 #(1.0f0 2.0f0 0.0f0)) - -(deftest vector-push-extend.16 - (let ((a (make-array '(5) :fill-pointer 5 - :adjustable t - :initial-contents '(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0) - :element-type 'single-float))) - (values - (fill-pointer a) - (vector-push-extend 0.0f0 a 1) - (fill-pointer a) - (<= (array-total-size a) 5) - a)) - 5 5 6 nil #(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0 0.0f0)) - - -(deftest vector-push-extend.17 - (let ((a (make-array '(5) :fill-pointer 2 - :initial-contents '(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0) - :element-type 'double-float))) - (values - (fill-pointer a) - (vector-push-extend 0.0d0 a) - (fill-pointer a) - a)) - 2 2 3 #(1.0d0 2.0d0 0.0d0)) - -(deftest vector-push-extend.18 - (let ((a (make-array '(5) :fill-pointer 5 - :adjustable t - :initial-contents '(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0) - :element-type 'double-float))) - (values - (fill-pointer a) - (vector-push-extend 0.0d0 a 1) - (fill-pointer a) - (<= (array-total-size a) 5) - a)) - 5 5 6 nil #(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0 0.0d0)) - -(deftest vector-push-extend.19 - (let ((a (make-array '(5) :fill-pointer 2 - :initial-contents '(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0) - :element-type 'long-float))) - (values - (fill-pointer a) - (vector-push-extend 0.0l0 a) - (fill-pointer a) - a)) - 2 2 3 #(1.0l0 2.0l0 0.0l0)) - -(deftest vector-push-extend.20 - (let ((a (make-array '(5) :fill-pointer 5 - :adjustable t - :initial-contents '(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0) - :element-type 'long-float))) - (values - (fill-pointer a) - (vector-push-extend 0.0l0 a 1) - (fill-pointer a) - (<= (array-total-size a) 5) - a)) - 5 5 6 nil #(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0 0.0l0)) - - -;;; Tests on displaced arrays - -(deftest vector-push-extend.21 - (let* ((a1 (make-array 10 :initial-element nil)) - (a2 (make-array 6 :displaced-to a1 - :displaced-index-offset 2 - :fill-pointer 0))) - (values - (fill-pointer a2) - (map 'list #'identity a2) - (vector-push-extend 'foo a2) - (fill-pointer a2) - (map 'list #'identity a2) - (map 'list #'identity a1))) - 0 - () - 0 - 1 - (foo) - (nil nil foo nil nil nil nil nil nil nil)) - -(deftest vector-push-extend.22 - (let* ((a1 (make-array 6 :initial-element nil)) - (a2 (make-array 0 :displaced-to a1 - :displaced-index-offset 2 - :adjustable t - :fill-pointer 0))) - (values - (fill-pointer a2) - (map 'list #'identity a2) - (vector-push-extend 'foo a2) - (fill-pointer a2) - (map 'list #'identity a2) - (map 'list #'identity a1) - (notnot (adjustable-array-p a2)) - (multiple-value-list (array-displacement a2)) - )) - 0 - () - 0 - 1 - (foo) - (nil nil nil nil nil nil) - t - (nil 0)) - -(deftest vector-push-extend.23 - (let* ((a1 (make-array 10 :initial-element nil)) - (a2 (make-array 6 :displaced-to a1 - :displaced-index-offset 2 - :adjustable t - :fill-pointer 1))) - (values - (fill-pointer a2) - (map 'list #'identity a2) - (vector-push-extend 'foo a2) - (fill-pointer a2) - (map 'list #'identity a2) - (map 'list #'identity a1) - (notnot (adjustable-array-p a2)) - (eqt (array-displacement a2) a1) - (nth-value 1 (array-displacement a2)) - )) - 1 - (nil) - 1 - 2 - (nil foo) - (nil nil nil foo nil nil nil nil nil nil) - t - t - 2) - -(deftest vector-push-extend.24 - (let* ((a1 (make-array 4 :initial-element nil)) - (a2 (make-array 2 :displaced-to a1 - :displaced-index-offset 2 - :adjustable t - :fill-pointer 2))) - (values - (map 'list #'identity a1) - (map 'list #'identity a2) - (vector-push-extend 'foo a2 7) - (fill-pointer a2) - (map 'list #'identity a1) - (map 'list #'identity a2) - (array-dimension a2 0) - (notnot (adjustable-array-p a2)) - (multiple-value-list (array-displacement a2)))) - (nil nil nil nil) - (nil nil) - 2 - 3 - (nil nil nil nil) - (nil nil foo) - 9 - t - (nil 0)) - -;;; Integer vectors - -(deftest vector-push-extend.25 - (loop for adj in '(nil t) - nconc - (loop for bits from 1 to 64 - for etype = `(unsigned-byte ,bits) - for a1 = (make-array 10 :initial-element 0 - :element-type etype) - for a2 =(make-array 6 - :element-type etype - :displaced-to a1 - :displaced-index-offset 2 - :adjustable adj - :fill-pointer 0) - for result = (list (fill-pointer a2) - (map 'list #'identity a2) - (vector-push-extend 1 a2) - (fill-pointer a2) - (map 'list #'identity a2) - (map 'list #'identity a1)) - unless (equal result '(0 () 0 1 (1) (0 0 1 0 0 0 0 0 0 0))) - collect (list etype adj result))) - nil) - -(deftest vector-push-extend.26 - (loop for bits from 1 to 64 - for etype = `(unsigned-byte ,bits) - for a1 = (make-array 8 :initial-element 0 - :element-type etype) - for a2 = (make-array 6 - :element-type etype - :displaced-to a1 - :displaced-index-offset 2 - :adjustable t - :fill-pointer 6) - for result = (list (fill-pointer a2) - (map 'list #'identity a2) - (vector-push-extend 1 a2) - (fill-pointer a2) - (map 'list #'identity a2) - (map 'list #'identity a1) - (notnot (adjustable-array-p a2)) - (multiple-value-list (array-displacement a1))) - unless (equal result '(6 (0 0 0 0 0 0) 6 7 (0 0 0 0 0 0 1) - (0 0 0 0 0 0 0 0) t (nil 0))) - collect (list etype result)) - nil) - -;;; strings - -(deftest vector-push-extend.27 - (loop for adj in '(nil t) - nconc - (loop for etype in '(character base-char standard-char) - for a1 = (make-array 10 :initial-element #\a - :element-type etype) - for a2 =(make-array 6 - :element-type etype - :displaced-to a1 - :displaced-index-offset 2 - :adjustable adj - :fill-pointer 0) - for result = (list (fill-pointer a2) - (map 'list #'identity a2) - (vector-push-extend #\b a2) - (fill-pointer a2) - (map 'list #'identity a2) - (map 'list #'identity a1)) - unless (equal result '(0 () 0 1 (#\b) (#\a #\a #\b #\a #\a #\a #\a #\a #\a #\a))) - collect (list etype adj result))) - nil) - -(deftest vector-push-extend.28 - (loop for etype in '(character base-char standard-char) - for a1 = (make-array 8 :initial-element #\a - :element-type etype) - for a2 = (make-array 6 - :element-type etype - :displaced-to a1 - :displaced-index-offset 2 - :adjustable t - :fill-pointer 6) - for result = (list (fill-pointer a2) - (map 'list #'identity a2) - (vector-push-extend #\b a2) - (fill-pointer a2) - (map 'list #'identity a2) - (map 'list #'identity a1) - (notnot (adjustable-array-p a2)) - (multiple-value-list (array-displacement a1))) - unless (equal result '(6 #.(coerce "aaaaaa" 'list) - 6 7 - #.(coerce "aaaaaab" 'list) - #.(coerce "aaaaaaaa" 'list) - t (nil 0))) - collect (list etype result)) - nil) - -;;; float tests - -(deftest vector-push-extend.29 - (loop for adj in '(nil t) - nconc - (loop for etype in '(short-float single-float double-float long-float) - for zero in '(0.0s0 0.0f0 0.0d0 0.0l0) - for one in '(1.0s0 1.0f0 1.0d0 1.0l0) - for a1 = (make-array 10 :initial-element zero - :element-type etype) - for a2 =(make-array 6 - :element-type etype - :displaced-to a1 - :displaced-index-offset 2 - :adjustable adj - :fill-pointer 0) - for result = (list (fill-pointer a2) - (map 'list #'identity a2) - (vector-push-extend one a2) - (fill-pointer a2) - (map 'list #'identity a2) - (map 'list #'identity a1)) - unless (equal result `(0 () 0 1 (,one) (,zero ,zero ,one ,zero ,zero ,zero ,zero ,zero ,zero ,zero))) - collect (list etype adj result))) - nil) - -(deftest vector-push-extend.30 - (loop for etype in '(short-float single-float double-float long-float) - for zero in '(0.0s0 0.0f0 0.0d0 0.0l0) - for one in '(1.0s0 1.0f0 1.0d0 1.0l0) - for a1 = (make-array 8 :initial-element zero - :element-type etype) - for a2 = (make-array 6 - :element-type etype - :displaced-to a1 - :displaced-index-offset 2 - :adjustable t - :fill-pointer 6) - for result = (list (fill-pointer a2) - (map 'list #'identity a2) - (vector-push-extend one a2) - (fill-pointer a2) - (map 'list #'identity a2) - (map 'list #'identity a1) - (notnot (adjustable-array-p a2)) - (multiple-value-list (array-displacement a1))) - unless (equal result `(6 (,zero ,zero ,zero ,zero ,zero ,zero) - 6 7 - (,zero ,zero ,zero ,zero ,zero ,zero ,one) - (,zero ,zero ,zero ,zero ,zero ,zero ,zero ,zero) - t (nil 0))) - collect (list etype result)) - nil) - - -;;; Error tests - -(defun vector-push-extend-error-test (seq val) - (declare (optimize (safety 3))) - (handler-case - (eval `(let ((a (copy-seq ,seq))) - (declare (optimize (safety 3))) - (or (notnot (array-has-fill-pointer-p a)) - (vector-push-extend ',val a 1)))) - (error () t))) - -(deftest vector-push-extend.error.1 - (vector-push-extend-error-test #(a b c d) 'x) - t) - -(deftest vector-push-extend.error.2 - (vector-push-extend-error-test #*00000 1) - t) - -(deftest vector-push-extend.error.3 - (vector-push-extend-error-test "abcde" #\x) - t) - -(deftest vector-push-extend.error.4 - (vector-push-extend-error-test #() 'x) - t) - -(deftest vector-push-extend.error.5 - (vector-push-extend-error-test #* 1) - t) - -(deftest vector-push-extend.error.6 - (vector-push-extend-error-test "" #\x) - t) - -(deftest vector-push-extend.error.7 - (vector-push-extend-error-test (make-array '5 :element-type 'base-char - :initial-element #\a) - #\x) - t) - -(deftest vector-push-extend.error.8 - (vector-push-extend-error-test (make-array '5 :element-type '(integer 0 (256)) - :initial-element 0) - 17) - t) - -(deftest vector-push-extend.error.9 - (vector-push-extend-error-test (make-array '5 :element-type 'float - :initial-element 1.0) - 2.0) - t) - -(deftest vector-push-extend.error.10 - (vector-push-extend-error-test (make-array '5 :element-type 'short-float - :initial-element 1.0s0) - 2.0s0) - t) - -(deftest vector-push-extend.error.11 - (vector-push-extend-error-test (make-array '5 :element-type 'long-float - :initial-element 1.0l0) - 2.0l0) - t) - -(deftest vector-push-extend.error.12 - (vector-push-extend-error-test (make-array '5 :element-type 'single-float - :initial-element 1.0f0) - 2.0f0) - t) - -(deftest vector-push-extend.error.13 - (vector-push-extend-error-test (make-array '5 :element-type 'double-float - :initial-element 1.0d0) - 2.0d0) - t) - -(deftest vector-push-extend.error.14 - (signals-error (vector-push-extend) program-error) - t) - -(deftest vector-push-extend.error.15 - (signals-error (vector-push-extend (vector 1 2 3)) program-error) - t) - -(deftest vector-push-extend.error.16 - (signals-error (vector-push-extend (vector 1 2 3) 4 1 nil) program-error) - t) - -(deftest vector-push-extend.error.17 - (handler-case - (eval - `(locally - (declare (optimize (safety 3))) - (let ((a (make-array '5 :fill-pointer t :adjustable nil - :initial-element nil))) - (or (notnot (adjustable-array-p a)) ; It's actually adjustable, or... - (vector-push-extend a 'x) ; ... this fails - )))) - (error () t)) - t) diff --git a/t/ansi-test/arrays/vector-push.lsp b/t/ansi-test/arrays/vector-push.lsp deleted file mode 100644 index 8288de8..0000000 --- a/t/ansi-test/arrays/vector-push.lsp +++ /dev/null @@ -1,319 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Jan 25 00:55:43 2003 -;;;; Contains: Tests for VECTOR-PUSH - - - -(deftest vector-push.1 - (let ((a (make-array '(5) :fill-pointer 2 - :initial-contents '(a b c d e))) - (i 0) x y) - (values - (fill-pointer a) - (vector-push (progn (setf x (incf i)) 'x) - (progn (setf y (incf i)) a)) - (fill-pointer a) - a i x y)) - 2 2 3 #(a b x) 2 1 2) - - -(deftest vector-push.2 - (let ((a (make-array '(5) :fill-pointer 5 - :initial-contents '(a b c d e)))) - (values - (fill-pointer a) - (vector-push 'x a) - (fill-pointer a) - a)) - 5 nil 5 #(a b c d e)) - -(deftest vector-push.3 - (let ((a (make-array '(5) :fill-pointer 2 - :initial-contents "abcde" - :element-type 'base-char))) - (values - (fill-pointer a) - (vector-push #\x a) - (fill-pointer a) - a)) - 2 2 3 "abx") - -(deftest vector-push.4 - (let ((a (make-array '(5) :fill-pointer 5 - :initial-contents "abcde" - :element-type 'base-char))) - (values - (fill-pointer a) - (vector-push #\x a) - (fill-pointer a) - a)) - 5 nil 5 "abcde") - -(deftest vector-push.5 - (let ((a (make-array '(5) :fill-pointer 2 - :initial-contents "abcde" - :element-type 'character))) - (values - (fill-pointer a) - (vector-push #\x a) - (fill-pointer a) - a)) - 2 2 3 "abx") - -(deftest vector-push.6 - (let ((a (make-array '(5) :fill-pointer 5 - :initial-contents "abcde" - :element-type 'character))) - (values - (fill-pointer a) - (vector-push #\x a) - (fill-pointer a) - a)) - 5 nil 5 "abcde") - -(deftest vector-push.7 - (let ((a (make-array '(5) :fill-pointer 2 - :initial-contents '(0 1 1 0 0) - :element-type 'bit))) - (values - (fill-pointer a) - (vector-push 0 a) - (fill-pointer a) - a)) - 2 2 3 #*010) - -(deftest vector-push.8 - (let ((a (make-array '(5) :fill-pointer 5 - :initial-contents '(0 0 0 0 0) - :element-type 'bit))) - (values - (fill-pointer a) - (vector-push 1 a) - (fill-pointer a) - a)) - 5 nil 5 #*00000) - -(deftest vector-push.9 - (let ((a (make-array '(5) :fill-pointer 2 - :initial-contents '(1 2 3 4 5) - :element-type 'fixnum))) - (values - (fill-pointer a) - (vector-push 0 a) - (fill-pointer a) - a)) - 2 2 3 #(1 2 0)) - -(deftest vector-push.10 - (let ((a (make-array '(5) :fill-pointer 5 - :initial-contents '(1 2 3 4 5) - :element-type 'fixnum))) - (values - (fill-pointer a) - (vector-push 0 a) - (fill-pointer a) - a)) - 5 nil 5 #(1 2 3 4 5)) - -(deftest vector-push.11 - (let ((a (make-array '(5) :fill-pointer 2 - :initial-contents '(1 2 3 4 5) - :element-type '(integer 0 (256))))) - (values - (fill-pointer a) - (vector-push 0 a) - (fill-pointer a) - a)) - 2 2 3 #(1 2 0)) - -(deftest vector-push.12 - (let ((a (make-array '(5) :fill-pointer 5 - :initial-contents '(1 2 3 4 5) - :element-type '(integer 0 (256))))) - (values - (fill-pointer a) - (vector-push 0 a) - (fill-pointer a) - a)) - 5 nil 5 #(1 2 3 4 5)) - -(deftest vector-push.13 - (let ((a (make-array '(5) :fill-pointer 2 - :initial-contents '(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0) - :element-type 'short-float))) - (values - (fill-pointer a) - (vector-push 0.0s0 a) - (fill-pointer a) - a)) - 2 2 3 #(1.0s0 2.0s0 0.0s0)) - -(deftest vector-push.14 - (let ((a (make-array '(5) :fill-pointer 5 - :initial-contents '(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0) - :element-type 'short-float))) - (values - (fill-pointer a) - (vector-push 0.0s0 a) - (fill-pointer a) - a)) - 5 nil 5 #(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0)) - -(deftest vector-push.15 - (let ((a (make-array '(5) :fill-pointer 2 - :initial-contents '(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0) - :element-type 'single-float))) - (values - (fill-pointer a) - (vector-push 0.0f0 a) - (fill-pointer a) - a)) - 2 2 3 #(1.0f0 2.0f0 0.0f0)) - -(deftest vector-push.16 - (let ((a (make-array '(5) :fill-pointer 5 - :initial-contents '(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0) - :element-type 'single-float))) - (values - (fill-pointer a) - (vector-push 0.0f0 a) - (fill-pointer a) - a)) - 5 nil 5 #(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0)) - - -(deftest vector-push.17 - (let ((a (make-array '(5) :fill-pointer 2 - :initial-contents '(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0) - :element-type 'double-float))) - (values - (fill-pointer a) - (vector-push 0.0d0 a) - (fill-pointer a) - a)) - 2 2 3 #(1.0d0 2.0d0 0.0d0)) - -(deftest vector-push.18 - (let ((a (make-array '(5) :fill-pointer 5 - :initial-contents '(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0) - :element-type 'double-float))) - (values - (fill-pointer a) - (vector-push 0.0d0 a) - (fill-pointer a) - a)) - 5 nil 5 #(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0)) - -(deftest vector-push.19 - (let ((a (make-array '(5) :fill-pointer 2 - :initial-contents '(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0) - :element-type 'long-float))) - (values - (fill-pointer a) - (vector-push 0.0l0 a) - (fill-pointer a) - a)) - 2 2 3 #(1.0l0 2.0l0 0.0l0)) - -(deftest vector-push.20 - (let ((a (make-array '(5) :fill-pointer 5 - :initial-contents '(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0) - :element-type 'long-float))) - (values - (fill-pointer a) - (vector-push 0.0l0 a) - (fill-pointer a) - a)) - 5 nil 5 #(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0)) - - - -;;; Error tests - -(defun vector-push-error-test (seq val) - (declare (optimize (safety 3))) - (handler-case - (eval `(let ((a (copy-seq ,seq))) - (declare (optimize (safety 3))) - (or (notnot (array-has-fill-pointer-p a)) - (vector-push ',val a)))) - (error () t))) - -(deftest vector-push.error.1 - (vector-push-error-test #(a b c d) 'x) - t) - -(deftest vector-push.error.2 - (vector-push-error-test #*00000 1) - t) - -(deftest vector-push.error.3 - (vector-push-error-test "abcde" #\x) - t) - -(deftest vector-push.error.4 - (vector-push-error-test #() 'x) - t) - -(deftest vector-push.error.5 - (vector-push-error-test #* 1) - t) - -(deftest vector-push.error.6 - (vector-push-error-test "" #\x) - t) - -(deftest vector-push.error.7 - (vector-push-error-test (make-array '5 :element-type 'base-char - :initial-element #\a) - #\x) - t) - -(deftest vector-push.error.8 - (vector-push-error-test (make-array '5 :element-type '(integer 0 (256)) - :initial-element 0) - 17) - t) - -(deftest vector-push.error.9 - (vector-push-error-test (make-array '5 :element-type 'float - :initial-element 1.0) - 2.0) - t) - -(deftest vector-push.error.10 - (vector-push-error-test (make-array '5 :element-type 'short-float - :initial-element 1.0s0) - 2.0s0) - t) - -(deftest vector-push.error.11 - (vector-push-error-test (make-array '5 :element-type 'long-float - :initial-element 1.0l0) - 2.0l0) - t) - -(deftest vector-push.error.12 - (vector-push-error-test (make-array '5 :element-type 'single-float - :initial-element 1.0f0) - 2.0f0) - t) - -(deftest vector-push.error.13 - (vector-push-error-test (make-array '5 :element-type 'double-float - :initial-element 1.0d0) - 2.0d0) - t) - -(deftest vector-push.error.14 - (signals-error (vector-push) program-error) - t) - -(deftest vector-push.error.15 - (signals-error (vector-push (vector 1 2 3)) program-error) - t) - -(deftest vector-push.error.16 - (signals-error (vector-push (vector 1 2 3) 4 nil) program-error) - t) diff --git a/t/ansi-test/arrays/vector.lsp b/t/ansi-test/arrays/vector.lsp deleted file mode 100644 index 2946464..0000000 --- a/t/ansi-test/arrays/vector.lsp +++ /dev/null @@ -1,331 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Jan 23 06:32:02 2003 -;;;; Contains: Tests of VECTOR (type and function) - - - -;;; More tests of type vector in make-array.lsp - -(deftest vector.type.1 - (notnot-mv (typep #(a b c) 'vector)) - t) - -(deftest vector.type.2 - (notnot-mv (typep #() 'vector)) - t) - -(deftest vector.type.3 - (notnot-mv (typep "" 'vector)) - t) - -(deftest vector.type.4 - (notnot-mv (typep "abcdef" 'vector)) - t) - -(deftest vector.type.5 - (notnot-mv (typep #* 'vector)) - t) - -(deftest vector.type.6 - (notnot-mv (typep #*011011101011 'vector)) - t) - -(deftest vector.type.7 - (typep #0aNIL 'vector) - nil) - -(deftest vector.type.8 - (typep #2a((a b c d)) 'vector) - nil) - -(deftest vector.type.9 - (subtypep* 'vector 'array) - t t) - -(deftest vector.type.10 - (notnot-mv (typep #(a b c) '(vector *))) - t) - -(deftest vector.type.11 - (notnot-mv (typep #(a b c) '(vector t))) - t) - -(deftest vector.type.12 - (notnot-mv (typep "abcde" '(vector *))) - t) - -(deftest vector.type.13 - (typep "abcdef" '(vector t)) - nil) - -(deftest vector.type.14 - (notnot-mv (typep #*00110 '(vector *))) - t) - -(deftest vector.type.15 - (typep #*00110 '(vector t)) - nil) - -(deftest vector.type.16 - (notnot-mv (typep #(a b c) '(vector * 3))) - t) - -(deftest vector.type.17 - (typep #(a b c) '(vector * 2)) - nil) - -(deftest vector.type.18 - (typep #(a b c) '(vector * 4)) - nil) - -(deftest vector.type.19 - (notnot-mv (typep #(a b c) '(vector t 3))) - t) - -(deftest vector.type.20 - (typep #(a b c) '(vector t 2)) - nil) - -(deftest vector.type.21 - (typep #(a b c) '(vector t 4)) - nil) - -(deftest vector.type.23 - (notnot-mv (typep #(a b c) '(vector t *))) - t) - -(deftest vector.type.23a - (notnot-mv (typep "abcde" '(vector * 5))) - t) - -(deftest vector.type.24 - (typep "abcde" '(vector * 4)) - nil) - -(deftest vector.type.25 - (typep "abcde" '(vector * 6)) - nil) - -(deftest vector.type.26 - (notnot-mv (typep "abcde" '(vector * *))) - t) - -(deftest vector.type.27 - (typep "abcde" '(vector t 5)) - nil) - -(deftest vector.type.28 - (typep "abcde" '(vector t 4)) - nil) - -(deftest vector.type.29 - (typep "abcde" '(vector t 6)) - nil) - -(deftest vector.type.30 - (typep "abcde" '(vector t *)) - nil) - -(deftest vector.type.31 - (let ((s (coerce "abc" 'simple-base-string))) - (notnot-mv (typep s '(vector base-char)))) - t) - -(deftest vector.type.32 - (let ((s (coerce "abc" 'simple-base-string))) - (notnot-mv (typep s '(vector base-char 3)))) - t) - -(deftest vector.type.33 - (let ((s (coerce "abc" 'simple-base-string))) - (typep s '(vector base-char 2))) - nil) - -(deftest vector.type.34 - (let ((s (coerce "abc" 'simple-base-string))) - (typep s '(vector base-char 4))) - nil) - -(deftest vector.type.35 - (let ((s (coerce "abc" 'simple-base-string))) - (notnot-mv (typep s 'vector))) - t) - -(deftest vector.type.36 - (let ((s (coerce "abc" 'simple-base-string))) - (notnot-mv (typep s '(vector *)))) - t) - -(deftest vector.type.37 - (let ((s (coerce "abc" 'simple-base-string))) - (notnot-mv (typep s '(vector * 3)))) - t) - -(deftest vector.type.38 - (let ((s (coerce "abc" 'simple-base-string))) - (notnot-mv (typep s '(vector * *)))) - t) - -(deftest vector.type.39 - (let ((s (coerce "abc" 'simple-base-string))) - (typep s '(vector t))) - nil) - -(deftest vector.type.40 - (let ((s (coerce "abc" 'simple-base-string))) - (typep s '(vector t *))) - nil) - -(deftest vector.type.41 - (notnot-mv (typep (make-array '10 :element-type 'short-float) 'vector)) - t) - -(deftest vector.type.42 - (notnot-mv (typep (make-array '10 :element-type 'single-float) 'vector)) - t) - -(deftest vector.type.43 - (notnot-mv (typep (make-array '10 :element-type 'double-float) 'vector)) - t) - -(deftest vector.type.44 - (notnot-mv (typep (make-array '10 :element-type 'long-float) 'vector)) - t) - - -;;; Tests of vector as class - -(deftest vector-as-class.1 - (notnot-mv (find-class 'vector)) - t) - -(deftest vector-as-class.2 - (notnot-mv (typep #() (find-class 'vector))) - t) - -(deftest vector-as-class.3 - (notnot-mv (typep #(a b c) (find-class 'vector))) - t) - -(deftest vector-as-class.4 - (notnot-mv (typep "" (find-class 'vector))) - t) - -(deftest vector-as-class.5 - (notnot-mv (typep "abcd" (find-class 'vector))) - t) - -(deftest vector-as-class.6 - (notnot-mv (typep #* (find-class 'vector))) - t) - -(deftest vector-as-class.7 - (notnot-mv (typep #*01101010100 (find-class 'vector))) - t) - -(deftest vector-as-class.8 - (typep #0aNIL (find-class 'vector)) - nil) - -(deftest vector-as-class.9 - (typep #2a((a b)(c d)) (find-class 'vector)) - nil) - -(deftest vector-as-class.10 - (typep (make-array '(1 0)) (find-class 'vector)) - nil) - -(deftest vector-as-class.11 - (typep (make-array '(0 1)) (find-class 'vector)) - nil) - -(deftest vector-as-class.12 - (typep 1 (find-class 'vector)) - nil) - -(deftest vector-as-class.13 - (typep nil (find-class 'vector)) - nil) - -(deftest vector-as-class.14 - (typep 'x (find-class 'vector)) - nil) - -(deftest vector-as-class.15 - (typep '(a b c) (find-class 'vector)) - nil) - -(deftest vector-as-class.16 - (typep 10.0 (find-class 'vector)) - nil) - -(deftest vector-as-class.17 - (typep 3/5 (find-class 'vector)) - nil) - -(deftest vector-as-class.18 - (typep (1+ most-positive-fixnum) (find-class 'vector)) - nil) - -;;;; Tests of the function VECTOR - -(deftest vector.1 - (vector) - #()) - -(deftest vector.2 - (vector 1 2 3) - #(1 2 3)) - -(deftest vector.3 - (let* ((len (min 1000 (1- call-arguments-limit))) - (args (make-int-list len)) - (v (apply #'vector args))) - (and - (typep v '(vector t)) - (typep v '(vector t *)) - (typep v `(vector t ,len)) - (typep v 'simple-vector) - (typep v `(simple-vector ,len)) - (eql (length v) len) - (loop for i from 0 - for e across v - always (eql i e)) - t)) - t) - -(deftest vector.4 - (notnot-mv (typep (vector) '(vector t 0))) - t) - -(deftest vector.5 - (notnot-mv (typep (vector) 'simple-vector)) - t) - -(deftest vector.6 - (notnot-mv (typep (vector) '(simple-vector 0))) - t) - -(deftest vector.7 - (notnot-mv (typep (vector 1 2 3) 'simple-vector)) - t) - -(deftest vector.8 - (notnot-mv (typep (vector 1 2 3) '(simple-vector 3))) - t) - -(deftest vector.9 - (typep (vector #\a #\b #\c) 'string) - nil) - -(deftest vector.10 - (notnot-mv (typep (vector 1 2 3) '(simple-vector *))) - t) - -(deftest vector.order.1 - (let ((i 0) a b c) - (values - (vector (setf a (incf i)) (setf b (incf i)) (setf c (incf i))) - i a b c)) - #(1 2 3) 3 1 2 3) diff --git a/t/ansi-test/arrays/vectorp.lsp b/t/ansi-test/arrays/vectorp.lsp deleted file mode 100644 index c60a8f2..0000000 --- a/t/ansi-test/arrays/vectorp.lsp +++ /dev/null @@ -1,82 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jan 26 13:17:05 2003 -;;;; Contains: Tests for VECTORP - - - -(deftest vectorp.1 - (vectorp 1) - nil) - -(deftest vectorp.2 - (vectorp (1+ most-positive-fixnum)) - nil) - -(deftest vectorp.3 - (vectorp #\a) - nil) - -(deftest vectorp.4 - (vectorp 10.0) - nil) - -(deftest vectorp.5 - (vectorp #'(lambda (x y) (cons y x))) - nil) - -(deftest vectorp.6 - (vectorp '(a b)) - nil) - -(deftest vectorp.7 - (vectorp #0aT) - nil) - -(deftest vectorp.8 - (vectorp #2a((a b)(c d))) - nil) - -(deftest vectorp.9 - (notnot-mv (vectorp "abcd")) - t) - -(deftest vectorp.10 - (notnot-mv (vectorp #*)) - t) - -(deftest vectorp.11 - (notnot-mv (vectorp #*1101)) - t) - -(deftest vectorp.12 - (notnot-mv (vectorp "")) - t) - -(deftest vectorp.13 - (notnot-mv (vectorp #(1 2 3))) - t) - -(deftest vectorp.14 - (notnot-mv (vectorp #())) - t) - -(deftest vectorp.15 - (vectorp #b11010) - nil) - -;;; Error tests - -(deftest vectorp.error.1 - (signals-error (vectorp) program-error) - t) - -(deftest vectorp.error.2 - (signals-error (vectorp #() #()) program-error) - t) - - - - - - diff --git a/t/ansi-test/atom-errors.lsp b/t/ansi-test/atom-errors.lsp deleted file mode 100644 index d68db59..0000000 --- a/t/ansi-test/atom-errors.lsp +++ /dev/null @@ -1,39 +0,0 @@ -(setf x - (loop - for tp in '(CONDITION -SERIOUS-CONDITION -ERROR -TYPE-ERROR -SIMPLE-TYPE-ERROR -SIMPLE-CONDITION -PARSE-ERROR -CELL-ERROR -UNBOUND-SLOT -WARNING -STYLE-WARNING -STORAGE-CONDITION -SIMPLE-WARNING -UNBOUND-VARIABLE -CONTROL-ERROR -PROGRAM-ERROR -UNDEFINED-FUNCTION -PACKAGE-ERROR -ARITHMETIC-ERROR -DIVISION-BY-ZERO -FLOATING-POINT-INVALID-OPERATION -FLOATING-POINT-INEXACT -FLOATING-POINT-OVERFLOW -FLOATING-POINT-UNDERFLOW -FILE-ERROR -BROADCAST-STREAM -CONCATENATED-STREAM -ECHO-STREAM -FILE-STREAM -STRING-STREAM -SYNONYM-STREAM -TWO-WAY-STREAM -STREAM-ERROR -END-OF-FILE -PRINT-NOT-READABLE - READER-ERROR) - collect (list tp (multiple-value-list (subtypep* tp 'atom))))) diff --git a/t/ansi-test/auxiliary/ansi-aux-macros.lsp b/t/ansi-test/auxiliary/ansi-aux-macros.lsp deleted file mode 100644 index 6b4b903..0000000 --- a/t/ansi-test/auxiliary/ansi-aux-macros.lsp +++ /dev/null @@ -1,46 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Jul 2 07:05:41 2003 -;;;; Contains: Macros used in ansi-aux and elsewhere. - - - -(declaim (optimize (safety 3))) - -;;; Macros to avoid annoying sbcl warning notes - -(defmacro handler-case (form &rest cases) - `(let () (cl:handler-case ,form ,@cases))) - -(defmacro handler-bind (handlers &rest body) - `(let () (cl:handler-bind ,handlers (normally (progn ,@body))))) - -;;; Macros for avoiding dead code warnings - -(defvar *should-always-be-true* t) - -(declaim (notinline should-never-be-called)) - -(defun should-never-be-called () nil) - -(defmacro normally (form &optional (default-form - '(should-never-be-called))) - `(if *should-always-be-true* ,form ,default-form)) - -;;; Macro to ignore errors, but report them anyway - -(defparameter *report-and-ignore-errors-break* nil - "When true, REPORT-AND-IGNORE-ERRORS breaks instead of discarding the error condition.") - -(defmacro report-and-ignore-errors (&body body) - `(eval-when (:load-toplevel :compile-toplevel :execute) - (#+sbcl let #+sbcl () #-sbcl progn - (handler-case - (progn ,@body) - (error (condition) - (princ condition) - (terpri) - (when *report-and-ignore-errors-break* (break)) - (values nil condition)))))) - - diff --git a/t/ansi-test/auxiliary/ansi-aux.lsp b/t/ansi-test/auxiliary/ansi-aux.lsp deleted file mode 100644 index c22e294..0000000 --- a/t/ansi-test/auxiliary/ansi-aux.lsp +++ /dev/null @@ -1,1187 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Mar 28 17:10:18 1998 -;;;; Contains: Aux. functions for CL-TEST - - - -(declaim (optimize (safety 3))) - -;;; A function for coercing truth values to BOOLEAN - -(defun notnot (x) (not (not x))) - -(defmacro notnot-mv (form) - `(notnot-mv-fn (multiple-value-list ,form))) - -(defun notnot-mv-fn (results) - (if (null results) - (values) - (apply #'values - (not (not (first results))) - (rest results)))) - -(defmacro not-mv (form) - `(not-mv-fn (multiple-value-list ,form))) - -(defun not-mv-fn (results) - (if (null results) - (values) - (apply #'values - (not (first results)) - (rest results)))) - -(declaim (ftype (function (t) function) to-function)) - -(defun to-function (fn) - (etypecase fn - (function fn) - (symbol (symbol-function fn)) - ((cons (eql setf) (cons symbol null)) (fdefinition fn)))) - -;;; Macro to check that a function is returning a specified number of values -;;; (defaults to 1) -(defmacro check-values (form &optional (num 1)) - (let ((v (gensym)) - (n (gensym))) - `(let ((,v (multiple-value-list ,form)) - (,n ,num)) - (check-values-length ,v ,n ',form) - (car ,v)))) - -(defun check-values-length (results expected-number form) - (declare (type fixnum expected-number)) - (let ((n expected-number)) - (declare (type fixnum n)) - (dolist (e results) - (declare (ignore e)) - (decf n)) - (unless (= n 0) - (error "Expected ~A results from ~A, got ~A results instead.~%~ -Results: ~A~%" expected-number form n results)))) - -;;; Do multiple-value-bind, but check # of arguments -(defmacro multiple-value-bind* ((&rest vars) form &body body) - (let ((len (length vars)) - (v (gensym))) - `(let ((,v (multiple-value-list ,form))) - (check-values-length ,v ,len ',form) - (destructuring-bind ,vars ,v ,@body)))) - -;;; Comparison functions that are like various builtins, -;;; but are guaranteed to return T for true. - -(defun eqt (x y) - "Like EQ, but guaranteed to return T for true." - (apply #'values (mapcar #'notnot (multiple-value-list (eq x y))))) - -(defun eqlt (x y) - "Like EQL, but guaranteed to return T for true." - (apply #'values (mapcar #'notnot (multiple-value-list (eql x y))))) - -(defun equalt (x y) - "Like EQUAL, but guaranteed to return T for true." - (apply #'values (mapcar #'notnot (multiple-value-list (equal x y))))) - -(defun equalpt (x y) - "Like EQUALP, but guaranteed to return T for true." - (apply #'values (mapcar #'notnot (multiple-value-list (equalp x y))))) - -(defun equalpt-or-report (x y) - "Like EQUALPT, but return either T or a list of the arguments." - (or (equalpt x y) (list x y))) - -(defun string=t (x y) - (notnot-mv (string= x y))) - -(defun =t (x &rest args) - "Like =, but guaranteed to return T for true." - (apply #'values (mapcar #'notnot (multiple-value-list (apply #'= x args))))) - -(defun <=t (x &rest args) - "Like <=, but guaranteed to return T for true." - (apply #'values (mapcar #'notnot (multiple-value-list (apply #'<= x args))))) - -(defun make-int-list (n) - (loop for i from 0 below n collect i)) - -(defun make-int-array (n &optional (fn #'make-array)) - (when (symbolp fn) - (assert (fboundp fn)) - (setf fn (symbol-function (the symbol fn)))) - (let ((a (funcall (the function fn) n))) - (declare (type (array * *) a)) - (loop for i from 0 below n do (setf (aref a i) i)) - a)) - -;;; Return true if A1 and A2 are arrays with the same rank -;;; and dimensions whose elements are EQUAL - -(defun equal-array (a1 a2) - (and (typep a1 'array) - (typep a2 'array) - (= (array-rank a1) (array-rank a2)) - (if (= (array-rank a1) 0) - (equal (regression-test::my-aref a1) (regression-test::my-aref a2)) - (let ((ad (array-dimensions a1))) - (and (equal ad (array-dimensions a2)) - (locally - (declare (type (array * *) a1 a2)) - (if (= (array-rank a1) 1) - (let ((as (first ad))) - (loop - for i from 0 below as - always (equal (regression-test::my-aref a1 i) - (regression-test::my-aref a2 i)))) - (let ((as (array-total-size a1))) - (and (= as (array-total-size a2)) - (loop - for i from 0 below as - always - (equal - (regression-test::my-row-major-aref a1 i) - (regression-test::my-row-major-aref a2 i)) - )))))))))) - -;;; *universe* is defined elsewhere -- it is a list of various -;;; lisp objects used when stimulating things in various tests. -(declaim (special *universe*)) - -;;; The function EMPIRICAL-SUBTYPEP checks two types -;;; for subtypeness, first using SUBTYPEP*, then (if that -;;; fails) empirically against all the elements of *universe*, -;;; checking if all that are in the first are also in the second. -;;; Return T if this is the case, NIL otherwise. This will -;;; always return T if type1 is truly a subtype of type2, -;;; but may return T even if this is not the case. - -(defun empirical-subtypep (type1 type2) - (multiple-value-bind (sub good) - (subtypep* type1 type2) - (if good - sub - (loop for e in *universe* - always (or (not (typep e type1)) (typep e type2)))))) - -(defun check-type-predicate (P TYPE) - "Check that a predicate P is the same as #'(lambda (x) (typep x TYPE)) - by applying both to all elements of *UNIVERSE*. Print message - when a mismatch is found, and return number of mistakes." - - (when (symbolp p) - (assert (fboundp p)) - (setf p (symbol-function p))) - (assert (typep p 'function)) - - (loop - for x in *universe* - when - (block failed - (let ((p1 (handler-case - (normally (funcall (the function p) x)) - (error () (format t "(FUNCALL ~S ~S) failed~%" - P x) - (return-from failed t)))) - (p2 (handler-case - (normally (typep x TYPE)) - (error () (format t "(TYPEP ~S '~S) failed~%" - x TYPE) - (return-from failed t))))) - (when (or (and p1 (not p2)) - (and (not p1) p2)) - (format t "(FUNCALL ~S ~S) = ~S, (TYPEP ~S '~S) = ~S~%" - P x p1 x TYPE p2) - t))) - collect x)) - -;;; We have a common idiom where a guarded predicate should be -;;; true everywhere - -(defun check-predicate (predicate &optional guard (universe *universe*)) - "Return all elements of UNIVERSE for which the guard (if present) is false - and for which PREDICATE is false." - (remove-if #'(lambda (e) (or (and guard (funcall guard e)) - (funcall predicate e))) - universe)) - -(declaim (special *catch-error-type*)) - -(defun catch-continue-debugger-hook (condition dbh) - "Function that when used as *debugger-hook*, causes - continuable errors to be continued without user intervention." - (declare (ignore dbh)) - (let ((r (find-restart 'continue condition))) - (cond - ((and *catch-error-type* - (not (typep condition *catch-error-type*))) - (format t "Condition ~S is not a ~A~%" condition *catch-error-type*) - (cond (r (format t "Its continue restart is ~S~%" r)) - (t (format t "It has no continue restart~%"))) - (throw 'continue-failed nil)) - (r (invoke-restart r)) - (t (throw 'continue-failed nil))))) - -#| -(defun safe (fn &rest args) - "Apply fn to args, trapping errors. Convert type-errors to the - symbol type-error." - (declare (optimize (safety 3))) - (handler-case - (apply fn args) - (type-error () 'type-error) - (error (c) c))) -|# - -;;; 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. -If an error does occur, return type-error on TYPE-ERRORs, or the error -condition itself on other errors." -`(locally (declare (optimize (safety 3))) - (handler-case (normally ,form) - (type-error () 'type-error) - (error (c) c)))) - -(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 (normally ,form) - (undefined-function () 'undefined-function) - (program-error () 'program-error) - (package-error () 'package-error) - (type-error () 'type-error) - (control-error () 'control-error) - (parse-error () 'parse-error) - (stream-error () 'stream-error) - (reader-error () 'reader-error) - (file-error () 'file-error) - (cell-error () 'cell-error) - (division-by-zero () 'division-by-zero) - (floating-point-overflow () 'floating-point-overflow) - (floating-point-underflow () 'floating-point-underflow) - (arithmetic-error () 'arithmetic-error) - (error () 'error) - ))) - -(defun classify-error** (form) - (handler-bind ((warning #'(lambda (c) (declare (ignore c)) - (muffle-warning)))) - (proclaim '(optimize (safety 3))) - (classify-error* - (if regression-test::*compile-tests* - (funcall (compile nil `(lambda () - (declare (optimize (safety 3))) - ,form))) - (eval form)) - ))) - -(defmacro classify-error (form) - `(classify-error** ',form)) - -;;; The above is badly designed, since it fails when some signals -;;; may be in more than one class/ - -(defmacro signals-error (form error-name &key (safety 3) (name nil name-p) (inline nil)) - `(handler-bind - ((warning #'(lambda (c) (declare (ignore c)) - (muffle-warning)))) - (proclaim '(optimize (safety 3))) - (handler-case - (apply #'values - nil - (multiple-value-list - ,(cond - (inline form) - (regression-test::*compile-tests* - `(funcall (compile nil '(lambda () - (declare (optimize (safety ,safety))) - ,form)))) - (t `(eval ',form))))) - (,error-name (c) - (cond - ,@(case error-name - (type-error - `(((typep (type-error-datum c) - (type-error-expected-type c)) - (values - nil - (list (list 'typep (list 'quote - (type-error-datum c)) - (list 'quote - (type-error-expected-type c))) - "==> true"))))) - ((undefined-function unbound-variable) - (and name-p - `(((not (eq (cell-error-name c) ',name)) - (values - nil - (list 'cell-error-name "==>" - (cell-error-name c))))))) - ((stream-error end-of-file reader-error) - `(((not (streamp (stream-error-stream c))) - (values - nil - (list 'stream-error-stream "==>" - (stream-error-stream c)))))) - (file-error - `(((not (pathnamep (pathname (file-error-pathname c)))) - (values - nil - (list 'file-error-pathname "==>" - (file-error-pathname c)))))) - (t nil)) - (t (printable-p c))))))) - -(defmacro signals-error-always (form error-name) - `(values - (signals-error ,form ,error-name) - (signals-error ,form ,error-name :safety 0))) - -(defmacro signals-type-error (var datum-form form &key (safety 3) (inline nil)) - (let ((lambda-form - `(lambda (,var) - (declare (optimize (safety ,safety))) - ,form))) - `(let ((,var ,datum-form)) - (declare (optimize safety)) - (handler-bind - ((warning #'(lambda (c) (declare (ignore c)) - (muffle-warning)))) - ; (proclaim '(optimize (safety 3))) - (handler-case - (apply #'values - nil - (multiple-value-list - (funcall - ,(cond - (inline `(function ,lambda-form)) - (regression-test::*compile-tests* - `(compile nil ',lambda-form)) - (t `(eval ',lambda-form))) - ,var))) - (type-error - (c) - (let ((datum (type-error-datum c)) - (expected-type (type-error-expected-type c))) - (cond - ((not (eql ,var datum)) - (list :datum-mismatch ,var datum)) - ((typep datum expected-type) - (list :is-typep datum expected-type)) - (t (printable-p c)))))))))) - -(declaim (special *mini-universe*)) - -(defun check-type-error* (pred-fn guard-fn &optional (universe *mini-universe*)) - "Check that for all elements in some set, either guard-fn is true or - pred-fn signals a type error." - (let (val) - (loop for e in universe - unless (or (funcall guard-fn e) - (equal - (setf val (multiple-value-list - (signals-type-error x e (funcall pred-fn x) :inline t))) - '(t))) - collect (list e val)))) - -(defmacro check-type-error (&body args) - `(locally (declare (optimize safety)) (check-type-error* ,@args))) - -(defun printable-p (obj) - "Returns T iff obj can be printed to a string." - (with-standard-io-syntax - (let ((*print-readably* nil) - (*print-escape* nil)) - (declare (optimize safety)) - (handler-case (and (stringp (write-to-string obj)) t) - (condition (c) (declare (ignore c)) nil))))) - -;;; -;;; The function SUBTYPEP should return two generalized booleans. -;;; This auxiliary function returns booleans instead -;;; (which makes it easier to write tests). -;;; -(defun subtypep* (type1 type2) - (apply #'values - (mapcar #'notnot - (multiple-value-list (subtypep type1 type2))))) - -(defun subtypep*-or-fail (type1 type2) - (let ((results (multiple-value-list (subtypep type1 type2)))) - (and (= (length results) 2) - (or (not (second results)) - (notnot (first results)))))) - -(defun subtypep*-not-or-fail (type1 type2) - (let ((results (multiple-value-list (subtypep type1 type2)))) - (and (= (length results) 2) - (or (not (second results)) - (not (first results)))))) - -;; (declaim (ftype (function (&rest function) (values function &optional)) -;; compose)) - -(defun compose (&rest fns) - (let ((rfns (reverse fns))) - #'(lambda (x) (loop for f - in rfns do (setf x (funcall (the function f) x))) x))) - -(defun evendigitp (c) - (notnot (find c "02468"))) - -(defun odddigitp (c) - (notnot (find c "13579"))) - -(defun nextdigit (c) - (cadr (member c '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)))) - -(defun is-eq-p (x) #'(lambda (y) (eqt x y))) -(defun is-not-eq-p (x) #'(lambda (y) (not (eqt x y)))) - -(defun is-eql-p (x) #'(lambda (y) (eqlt x y))) -(defun is-not-eql-p (x) #'(lambda (y) (not (eqlt x y)))) - -(defun onep (x) (eql x 1)) - -(defun char-invertcase (c) - (if (upper-case-p c) (char-downcase c) - (char-upcase c))) - -(defun string-invertcase (s) - (map 'string #'char-invertcase s)) - -(defun symbol< (x &rest args) - (apply #'string< (symbol-name x) (mapcar #'symbol-name args))) - - -(defun make-list-expr (args) - "Build an expression for computing (LIST . args), but that evades - CALL-ARGUMENTS-LIMIT." - (if (cddddr args) - (list 'list* - (first args) (second args) (third args) (fourth args) - (make-list-expr (cddddr args))) - (cons 'list args))) - -(defparameter +standard-chars+ - (coerce - "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789~!@#$%^&*()_+|\\=-`{}[]:\";'<>?,./ - " 'simple-base-string)) - -(defparameter - +base-chars+ #.(coerce - (concatenate 'string - "abcdefghijklmnopqrstuvwxyz" - "ABCDEFGHIJKLMNOPQRSTUVWXYZ" - "0123456789" - "<,>.?/\"':;[{]}~`!@#$%^&*()_-+= \\|") - 'simple-base-string)) - - -(declaim (type simple-base-string +base-chars+)) - -(defparameter +num-base-chars+ (length +base-chars+)) - -(defparameter +alpha-chars+ (subseq +standard-chars+ 0 52)) -(defparameter +lower-case-chars+ (subseq +alpha-chars+ 0 26)) -(defparameter +upper-case-chars+ (subseq +alpha-chars+ 26 52)) -(defparameter +alphanumeric-chars+ (subseq +standard-chars+ 0 62)) -(defparameter +digit-chars+ "0123456789") -(defparameter +extended-digit-chars+ (coerce - "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" - 'simple-base-string)) - -(declaim (type simple-base-string +alpha-chars+ +lower-case-chars+ - +upper-case-chars+ +alphanumeric-chars+ +extended-digit-chars+ - +standard-chars+)) - -(defparameter +code-chars+ - (coerce (loop for i from 0 below 256 - for c = (code-char i) - when c collect c) - 'simple-string)) - -(declaim (type simple-string +code-chars+)) - -(defparameter +rev-code-chars+ (reverse +code-chars+)) - -;;; Used in checking for continuable errors - -(defun has-non-abort-restart (c) - (throw 'handled - (if (position 'abort (the list (compute-restarts c)) - :key #'restart-name :test-not #'eq) - 'success - 'fail))) - -(defmacro handle-non-abort-restart (&body body) - `(catch 'handled - (handler-bind ((error #'has-non-abort-restart)) - ,@body))) - -;;; used in elt.lsp -(defun elt-v-6-body () - (let ((x (make-int-list 1000))) - (let ((a (make-array '(1000) :initial-contents x))) - (loop - for i from 0 to 999 do - (unless (eql i (elt a i)) (return nil)) - finally (return t))))) - -(defun make-adj-array (n &key initial-contents) - (if initial-contents - (make-array n :adjustable t :initial-contents initial-contents) - (make-array n :adjustable t))) - -;;; used in elt.lsp -(defun elt-adj-array-6-body () - (let ((x (make-int-list 1000))) - (let ((a (make-adj-array '(1000) :initial-contents x))) - (loop - for i from 0 to 999 do - (unless (eql i (elt a i)) (return nil)) - finally (return t))))) - -(defparameter *displaced* (make-int-array 100000)) - -(defun make-displaced-array (n displacement) - (make-array n :displaced-to *displaced* - - :displaced-index-offset displacement)) - -;;; used in fill.lsp -(defun array-unsigned-byte-fill-test-fn (byte-size &rest fill-args) - (let* ((a (make-array '(5) :element-type (list 'unsigned-byte byte-size) - :initial-contents '(1 2 3 4 5))) - (b (apply #'fill a fill-args))) - (values (eqt a b) - (map 'list #'identity a)))) - -;;; used in fill-strings.lsp -(defun array-string-fill-test-fn (a &rest fill-args) - (setq a (copy-seq a)) - (let ((b (apply #'fill a fill-args))) - (values (eqt a b) b))) - -;;; From types-and-class.lsp - -(defparameter +float-types+ - '(long-float double-float short-float single-float)) - -(defparameter *subtype-table* -(let ((table - '( - (null symbol) - (symbol t) - (boolean symbol) - (standard-object t) - (function t) - (compiled-function function) - (generic-function function) - (standard-generic-function generic-function) - (class standard-object) - (built-in-class class) - (structure-class class) - (standard-class class) - (method standard-object) - (standard-method method) - (structure-object t) - (method-combination t) - (condition t) - (serious-condition condition) - (error serious-condition) - (type-error error) - (simple-type-error type-error) - (simple-condition condition) - (simple-type-error simple-condition) - (parse-error error) - (hash-table t) - (cell-error error) - (unbound-slot cell-error) - (warning condition) - (style-warning warning) - (storage-condition serious-condition) - (simple-warning warning) - (simple-warning simple-condition) - (keyword symbol) - (unbound-variable cell-error) - (control-error error) - (program-error error) - (undefined-function cell-error) - (package t) - (package-error error) - (random-state t) - (number t) - (real number) - (complex number) - (float real) - (short-float float) - (single-float float) - (double-float float) - (long-float float) - (rational real) - (integer rational) - (ratio rational) - (signed-byte integer) - (integer signed-byte) - (unsigned-byte signed-byte) - (bit unsigned-byte) - (fixnum integer) - (bignum integer) - (bit fixnum) - (arithmetic-error error) - (division-by-zero arithmetic-error) - (floating-point-invalid-operation arithmetic-error) - (floating-point-inexact arithmetic-error) - (floating-point-overflow arithmetic-error) - (floating-point-underflow arithmetic-error) - (character t) - (base-char character) - (standard-char base-char) - (extended-char character) - (sequence t) - (list sequence) - (null list) - (null boolean) - (cons list) - (array t) - (simple-array array) - (vector sequence) - (vector array) - (string vector) - (bit-vector vector) - (simple-vector vector) - (simple-vector simple-array) - (simple-bit-vector bit-vector) - (simple-bit-vector simple-array) - (base-string string) - (simple-string string) - (simple-string simple-array) - (simple-base-string base-string) - (simple-base-string simple-string) - (pathname t) - (logical-pathname pathname) - (file-error error) - (stream t) - (broadcast-stream stream) - (concatenated-stream stream) - (echo-stream stream) - (file-stream stream) - (string-stream stream) - (synonym-stream stream) - (two-way-stream stream) - (stream-error error) - (end-of-file stream-error) - (print-not-readable error) - (readtable t) - (reader-error parse-error) - (reader-error stream-error) - ))) - (when (subtypep* 'character 'base-char) - (setq table - (append - '((character base-char) - ;; (string base-string) - ;; (simple-string simple-base-string) - ) - table))) - - table)) - -(defparameter *disjoint-types-list* - '(cons symbol array - number character hash-table function readtable package - pathname stream random-state condition restart)) - -(defparameter *disjoint-types-list2* - `((cons (cons t t) (cons t (cons t t)) (eql (nil))) - (symbol keyword boolean null (eql a) (eql nil) (eql t) (eql *)) - (array vector simple-array simple-vector string simple-string - base-string simple-base-string (eql #())) - (character base-char standard-char (eql #\a) - ,@(if (subtypep 'character 'base-char) nil - (list 'extended-char))) - (function compiled-function generic-function standard-generic-function - (eql ,#'car)) - (package (eql ,(find-package "COMMON-LISP"))) - (pathname logical-pathname (eql #p"")) - (stream broadcast-stream concatenated-stream echo-stream - file-stream string-stream synonym-stream two-way-stream) - (number real complex float integer rational ratio fixnum - bit (integer 0 100) (float 0.0 100.0) (integer 0 *) - (rational 0 *) (mod 10) - (eql 0) - ,@(and (not (subtypep 'bignum nil)) - (list 'bignum))) - (random-state) - ,*condition-types* - (restart) - (readtable))) - -(defparameter *types-list3* - (reduce #'append *disjoint-types-list2* :from-end t)) - -(defun trim-list (list n) - (let ((len (length list))) - (if (<= len n) list - (append (subseq list 0 n) - (format nil "And ~A more omitted." (- len n)))))) - -(defun is-t-or-nil (e) - (or (eqt e t) (eqt e nil))) - -(defun is-builtin-class (type) - (when (symbolp type) (setq type (find-class type nil))) - (typep type 'built-in-class)) - -(defun even-size-p (a) - (some #'evenp (array-dimensions a))) - - -(defun safe-elt (x n) - (classify-error* (elt x n))) - -(defmacro defstruct* (&body args) - `(eval-when (:load-toplevel :compile-toplevel :execute) - (handler-case (eval '(defstruct ,@args)) - (serious-condition () nil)))) - -(defun safely-delete-package (package-designator) - (let ((package (find-package package-designator))) - (when package - (let ((used-by (package-used-by-list package))) - (dolist (using-package used-by) - (unuse-package package using-package))) - (delete-package package)))) - -#-(or allegro openmcl lispworks) -(defun delete-all-versions (pathspec) - "Replace the versions field of the pathname specified by pathspec with - :wild, and delete all the files this refers to." - (let* ((wild-pathname (make-pathname :version :wild :defaults (pathname pathspec))) - (truenames (directory wild-pathname))) - (mapc #'delete-file truenames))) - -;;; This is a hack to get around an ACL bug; OpenMCL also apparently -;;; needs it -#+(or allegro openmcl lispworks) -(defun delete-all-versions (pathspec) - (when (probe-file pathspec) (delete-file pathspec))) - -(defconstant +fail-count-limit+ 20) - -(defun frob-simple-condition (c expected-fmt &rest expected-args) - "Try out the format control and format arguments of a simple-condition C, - but make no assumptions about what they print as, only that they - do print." - (declare (ignore expected-fmt expected-args)) - (and (typep c 'simple-condition) - (let ((fc (simple-condition-format-control c)) - (args (simple-condition-format-arguments c))) - (and - (stringp (apply #'format nil fc args)) - t)))) - -(defun frob-simple-error (c expected-fmt &rest expected-args) - (and (typep c 'simple-error) - (apply #'frob-simple-condition c expected-fmt expected-args))) - -(defun frob-simple-warning (c expected-fmt &rest expected-args) - (and (typep c 'simple-warning) - (apply #'frob-simple-condition c expected-fmt expected-args))) - -(defparameter *array-element-types* - '(t (integer 0 0) - bit (unsigned-byte 8) (unsigned-byte 16) - (unsigned-byte 32) float short-float - single-float double-float long-float - nil character base-char symbol boolean null)) - -(defun collect-properties (plist prop) - "Collect all the properties in plist for a property prop." - (loop for e on plist by #'cddr - when (eql (car e) prop) - collect (cadr e))) - -(defmacro def-macro-test (test-name macro-form) - (let ((macro-name (car macro-form))) - (assert (symbolp macro-name)) - `(deftest ,test-name - (values - (signals-error (funcall (macro-function ',macro-name)) - program-error) - (signals-error (funcall (macro-function ',macro-name) - ',macro-form) - program-error) - (signals-error (funcall (macro-function ',macro-name) - ',macro-form nil nil) - program-error)) - t t t))) - -(defun typep* (element type) - (not (not (typep element type)))) - -(defun applyf (fn &rest args) - (etypecase fn - (symbol - #'(lambda (&rest more-args) (apply (the symbol fn) (append args more-args)))) - (function - #'(lambda (&rest more-args) (apply (the function fn) (append args more-args)))))) - -(defun slot-boundp* (object slot) - (notnot (slot-boundp object slot))) - -(defun slot-exists-p* (object slot) - (notnot (slot-exists-p object slot))) - -(defun map-slot-boundp* (c slots) - (mapcar (applyf #'slot-boundp c) slots)) - -(defun map-slot-exists-p* (c slots) - (mapcar (applyf #'slot-exists-p* c) slots)) - -(defun map-slot-value (c slots) - (mapcar (applyf #'slot-value c) slots)) - -(defun map-typep* (object types) - (mapcar (applyf #'typep* object) types)) - -(defun slot-value-or-nil (object slot-name) - (and (slot-exists-p object slot-name) - (slot-boundp object slot-name) - (slot-value object slot-name))) - -(defun is-noncontiguous-sublist-of (list1 list2) - (loop - for x in list1 - do (loop - when (null list2) do (return-from is-noncontiguous-sublist-of nil) - when (eql x (pop list2)) do (return)) - finally (return t))) - -;;; This defines a new metaclass to allow us to get around -;;; the restriction in section 11.1.2.1.2, bullet 19 in some -;;; object system tests - -;;; (when (typep (find-class 'standard-class) 'standard-class) -;;; (defclass substandard-class (standard-class) ()) -;;; (defparameter *can-define-metaclasses* t)) - -;;; Macro for testing that something is undefined but 'harmless' - -(defmacro defharmless (name form) - `(deftest ,name - (block done - (let ((*debugger-hook* #'(lambda (&rest args) - (declare (ignore args)) - (return-from done :good)))) - (handler-case - (unwind-protect (eval ',form) (return-from done :good)) - (condition () :good)))) - :good)) - -(defun rational-safely (x) - "Rational a floating point number, making sure the rational - number isn't 'too big'. This is important in implementations such - as clisp where the floating bounds can be very large." - (assert (floatp x)) - (multiple-value-bind (significand exponent sign) - (integer-decode-float x) - (let ((limit 1000) - (radix (float-radix x))) - (cond - ((< exponent (- limit)) - (* significand (expt radix (- limit)) sign)) - ((> exponent limit) - (* significand (expt radix limit) sign)) - (t (rational x)))))) - -(declaim (special *similarity-list*)) - -(defun is-similar (x y) - (let ((*similarity-list* nil)) - (is-similar* x y))) - -(defgeneric is-similar* (x y)) - -(defmethod is-similar* ((x number) (y number)) - (and (eq (class-of x) (class-of y)) - (= x y) - t)) - -(defmethod is-similar* ((x character) (y character)) - (and (char= x y) t)) - -(defmethod is-similar* ((x symbol) (y symbol)) - (if (null (symbol-package x)) - (and (null (symbol-package y)) - (is-similar* (symbol-name x) (symbol-name y))) - ;; I think the requirements for interned symbols in - ;; 3.2.4.2.2 boils down to EQ after the symbols are in the lisp - (eq x y)) - t) - -(defmethod is-similar* ((x random-state) (y random-state)) - (let ((copy-of-x (make-random-state x)) - (copy-of-y (make-random-state y)) - (bound (1- (ash 1 24)))) - (and - ;; Try 50 values, and assume the random state are the same - ;; if all the values are the same. Assuming the RNG is not - ;; very pathological, this should be acceptable. - (loop repeat 50 - always (eql (random bound copy-of-x) - (random bound copy-of-y))) - t))) - -(defmethod is-similar* ((x cons) (y cons)) - (or (and (eq x y) t) - (and (loop for (x2 . y2) in *similarity-list* - thereis (and (eq x x2) (eq y y2))) - t) - (let ((*similarity-list* - (cons (cons x y) *similarity-list*))) - (and (is-similar* (car x) (car y)) - ;; If this causes stack problems, - ;; convert to a loop - (is-similar* (cdr x) (cdr y)))))) - -(defmethod is-similar* ((x vector) (y vector)) - (or (and (eq x y) t) - (and - (or (not (typep x 'simple-array)) - (typep x 'simple-array)) - (= (length x) (length y)) - (is-similar* (array-element-type x) - (array-element-type y)) - (loop for i below (length x) - always (is-similar* (aref x i) (aref y i))) - t))) - -(defmethod is-similar* ((x array) (y array)) - (or (and (eq x y) t) - (and - (or (not (typep x 'simple-array)) - (typep x 'simple-array)) - (= (array-rank x) (array-rank y)) - (equal (array-dimensions x) (array-dimensions y)) - (is-similar* (array-element-type x) - (array-element-type y)) - (let ((*similarity-list* - (cons (cons x y) *similarity-list*))) - (loop for i below (array-total-size x) - always (is-similar* (row-major-aref x i) - (row-major-aref y i)))) - t))) - -(defmethod is-similar* ((x hash-table) (y hash-table)) - ;; FIXME Add similarity check for hash tables - (error "Sorry, we're not computing this yet.")) - -(defmethod is-similar* ((x pathname) (y pathname)) - (and - (is-similar* (pathname-host x) (pathname-host y)) - (is-similar* (pathname-device x) (pathname-device y)) - (is-similar* (pathname-directory x) (pathname-directory y)) - (is-similar* (pathname-name x) (pathname-name y)) - (is-similar* (pathname-type x) (pathname-type y)) - (is-similar* (pathname-version x) (pathname-version y)) - t)) - -(defmethod is-similar* ((x t) (y t)) - (and (eql x y) t)) - -(defparameter *initial-print-pprint-dispatch* (if (boundp '*print-pprint-dispatch*) - *print-pprint-dispatch* - nil)) - -(defmacro my-with-standard-io-syntax (&body body) - `(let ((*package* (find-package "COMMON-LISP-USER")) - (*print-array* t) - (*print-base* 10) - (*print-case* :upcase) - (*print-circle* nil) - (*print-escape* t) - (*print-gensym* t) - (*print-length* nil) - (*print-level* nil) - (*print-lines* nil) - (*print-miser-width* nil) - (*print-pprint-dispatch* *initial-print-pprint-dispatch*) - (*print-pretty* nil) - (*print-radix* nil) - (*print-readably* t) - (*print-right-margin* nil) - (*read-base* 10) - (*read-default-float-format* 'single-float) - (*read-eval* t) - (*read-suppress* nil) - (*readtable* (copy-readtable nil))) - ,@body)) - -;;; Function to produce a non-simple string - -(defun make-special-string (string &key fill adjust displace base) - (let* ((len (length string)) - (len2 (if fill (+ len 4) len)) - (etype (if base 'base-char 'character))) - (if displace - (let ((s0 (make-array (+ len2 5) - :initial-contents - (concatenate 'string - (make-string 2 :initial-element #\X) - string - (make-string (if fill 7 3) - :initial-element #\Y)) - :element-type etype))) - (make-array len2 :element-type etype - :adjustable adjust - :fill-pointer (if fill len nil) - :displaced-to s0 - :displaced-index-offset 2)) - (make-array len2 :element-type etype - :initial-contents - (if fill (concatenate 'string string "ZZZZ") string) - :fill-pointer (if fill len nil) - :adjustable adjust)))) - -(defmacro do-special-strings ((var string-form &optional ret-form) &body forms) - (let ((string (gensym)) - (fill (gensym "FILL")) - (adjust (gensym "ADJUST")) - (base (gensym "BASE")) - (displace (gensym "DISPLACE"))) - `(let ((,string ,string-form)) - (dolist (,fill '(nil t) ,ret-form) - (dolist (,adjust '(nil t)) - (dolist (,base '(nil t)) - (dolist (,displace '(nil t)) - (let ((,var (make-special-string - ,string - :fill ,fill :adjust ,adjust - :base ,base :displace ,displace))) - ,@forms)))))))) - -(defun make-special-integer-vector (contents &key fill adjust displace (etype 'integer)) - (let* ((len (length contents)) - (min (reduce #'min contents)) - (max (reduce #'max contents)) - (len2 (if fill (+ len 4) len))) - (unless (and (typep min etype) - (typep max etype)) - (setq etype `(integer ,min ,max))) - (if displace - (let ((s0 (make-array (+ len2 5) - :initial-contents - (concatenate 'list - (make-list 2 :initial-element - (if (typep 0 etype) 0 min)) - contents - (make-list (if fill 7 3) - :initial-element - (if (typep 1 etype) 1 max))) - :element-type etype))) - (make-array len2 :element-type etype - :adjustable adjust - :fill-pointer (if fill len nil) - :displaced-to s0 - :displaced-index-offset 2)) - (make-array len2 :element-type etype - :initial-contents - (if fill (concatenate 'list - contents - (make-list 4 :initial-element - (if (typep 2 etype) 2 (floor (+ min max) 2)))) - contents) - :fill-pointer (if fill len nil) - :adjustable adjust)))) - -(defmacro do-special-integer-vectors ((var vec-form &optional ret-form) &body forms) - (let ((vector (gensym)) - (fill (gensym "FILL")) - (adjust (gensym "ADJUST")) - (etype (gensym "ETYPE")) - (displace (gensym "DISPLACE"))) - `(let ((,vector ,vec-form)) - (dolist (,fill '(nil t) ,ret-form) - (dolist (,adjust '(nil t)) - (dolist (,etype ',(append (loop for i from 1 to 32 collect `(unsigned-byte ,i)) - (loop for i from 2 to 32 collect `(signed-byte ,i)) - '(integer))) - (dolist (,displace '(nil t)) - (let ((,var (make-special-integer-vector - ,vector - :fill ,fill :adjust ,adjust - :etype ,etype :displace ,displace))) - ,@forms)))))))) - -;;; Return T if arg X is a string designator in this implementation - -(defun string-designator-p (x) - (handler-case - (progn (string x) t) - (error nil))) - -;;; Approximate comparison of numbers -#| -(defun approx= (x y) - (let ((eps 1.0d-4)) - (<= (abs (- x y)) - (* eps (max (abs x) (abs y)))))) -|# - -;;; Approximate equality function -(defun approx= (x y &optional (eps (epsilon x))) - (<= (abs (/ (- x y) (max (abs x) 1))) eps)) - -(defun epsilon (number) - (etypecase number - (complex (* 2 (epsilon (realpart number)))) ;; crude - (short-float short-float-epsilon) - (single-float single-float-epsilon) - (double-float double-float-epsilon) - (long-float long-float-epsilon) - (rational 0))) - -(defun negative-epsilon (number) - (etypecase number - (complex (* 2 (negative-epsilon (realpart number)))) ;; crude - (short-float short-float-negative-epsilon) - (single-float single-float-negative-epsilon) - (double-float double-float-negative-epsilon) - (long-float long-float-negative-epsilon) - (rational 0))) - -(defun sequencep (x) (typep x 'sequence)) - -(defun typef (type) #'(lambda (x) (typep x type))) - -(defun package-designator-p (x) - "TRUE if x could be a package designator. The package need not - actually exist." - (or (packagep x) - (handler-case (and (locally (declare (optimize safety)) - (string x)) - t) - (type-error () nil)))) - -(defmacro def-fold-test (name form) - "Create a test that FORM, which should produce a fresh value, - does not improperly introduce sharing during constant folding." - `(deftest ,name - (flet ((%f () (declare (optimize (speed 3) (safety 0) (space 0) - (compilation-speed 0) (debug 0))) - ,form)) - (eq (%f) (%f))) - nil)) - -;;; Macro used in tests of environments in system macros -;;; This was inspired by a bug in ACL 8.0 beta where CONSTANTP -;;; was being called in some system macros without the proper -;;; environment argument - -(defmacro expand-in-current-env (macro-form &environment env) - (macroexpand macro-form env)) diff --git a/t/ansi-test/auxiliary/array-aux.lsp b/t/ansi-test/auxiliary/array-aux.lsp deleted file mode 100644 index 84c1f33..0000000 --- a/t/ansi-test/auxiliary/array-aux.lsp +++ /dev/null @@ -1,205 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Jan 21 05:11:31 2003 -;;;; Contains: Auxiliary functions for array tests - - - -(defun make-array-check-upgrading (type) - (subtypep* type (array-element-type (make-array 0 :element-type type)))) - -(defun subtypep-or-unknown (subtype supertype) - (multiple-value-bind* (is-subtype is-known) - (subtypep subtype supertype) - (or (not is-known) (notnot is-subtype)))) - -(defun make-array-with-checks (dimensions - &rest options - &key - (element-type t element-type-p) - (initial-contents nil initial-contents-p) - (initial-element nil initial-element-p) - (adjustable nil) - (fill-pointer nil) - (displaced-to nil) - (displaced-index-offset 0 dio-p) - &aux - (dimensions-list (if (listp dimensions) - dimensions - (list dimensions)))) - "Call MAKE-ARRAY and do sanity tests on the output." - (declare (ignore element-type-p initial-contents initial-contents-p - initial-element initial-element-p dio-p)) - (let ((a (check-values (apply #'make-array dimensions options))) - (rank (length dimensions-list))) - (cond - - ((not (typep a 'array)) - :fail-not-array) - ((not (typep a (find-class 'array))) - :fail-not-array-class) - ((not (typep a '(array *))) - :fail-not-array2) - ((not (typep a `(array * ,dimensions-list))) - :fail-not-array3) - ((not (typep a `(array * *))) - :fail-not-array4) - ((not (typep a `(array ,element-type))) - :fail-not-array5) - ((not (typep a `(array ,element-type *))) - :fail-not-array6) - -; #-gcl - ((not (typep a `(array ,element-type ,rank))) - :fail-not-array7) - - ((not (typep a `(array ,element-type ,dimensions-list))) - :fail-not-array8) - - ((not (typep a `(array ,element-type ,(mapcar (constantly '*) - dimensions-list)))) - :fail-not-array9) - - ((loop for i from 0 below (min 10 rank) - thereis - (let ((x (append (subseq dimensions-list 0 i) - (list '*) - (subseq dimensions-list (1+ i))))) - (or (not (typep a `(array * ,x))) - (not (typep a `(array ,element-type ,x)))))) - :fail-not-array10) - - ((not (check-values (arrayp a))) :fail-not-arrayp) - - ((and ;; (eq t element-type) - (not adjustable) - (not fill-pointer) - (not displaced-to) - (cond - ((not (typep a 'simple-array)) - :fail-not-simple-array) - ((not (typep a '(simple-array *))) - :fail-not-simple-array2) - ((not (typep a `(simple-array * ,dimensions-list))) - :fail-not-simple-array3) - ((not (typep a `(simple-array * *))) - :fail-not-simple-array4) - ((not (typep a `(simple-array ,element-type))) - :fail-not-simple-array5) - ((not (typep a `(simple-array ,element-type *))) - :fail-not-simple-array6) - #-gcl - ((not (typep a `(simple-array ,element-type - ,rank))) - :fail-not-array7) - ((not (typep a `(simple-array ,element-type ,dimensions-list))) - :fail-not-simple-array8) - ((not (typep a `(simple-array ,element-type - ,(mapcar (constantly '*) - dimensions-list)))) - :fail-not-simple-array9) - ))) - - ;; If the array is a vector, check that... - ((and (eql rank 1) - (cond - ;; ...It's in type vector - ((not (typep a 'vector)) - :fail-not-vector) - ;; ...If the element type is a subtype of BIT, then it's a - ;; bit vector... - ((and (subtypep 'bit element-type) - (subtypep element-type 'bit) - (or (not (bit-vector-p a)) - (not (typep a 'bit-vector)))) - :fail-not-bit-vector) - ;; ...If not adjustable, fill pointered, or displaced, - ;; then it's a simple vector or simple bit vector - ;; (if the element-type is appropriate) - ((and (not adjustable) - (not fill-pointer) - (not displaced-to) - (cond - ((and (eq t element-type) - (or (not (simple-vector-p a)) - (not (typep a 'simple-vector)))) - :fail-not-simple-vector) - ((and (subtypep 'bit element-type) - (subtypep element-type 'bit) - (or (not (simple-bit-vector-p a)) - (not (typep a 'simple-bit-vector)))) - :fail-not-simple-bit-vector) ))) ))) - - ;; The dimensions of the array must be initialized properly - ((not (equal (array-dimensions a) dimensions-list)) - :fail-array-dimensions) - - ;; The rank of the array must equal the number of dimensions - ((not (equal (array-rank a) rank)) - :fail-array-rank) - - ;; Arrays other than vectors cannot have fill pointers - ((and (not (equal (array-rank a) 1)) - (array-has-fill-pointer-p a)) - :fail-non-vector-fill-pointer) - - ;; The actual element type must be a supertype of the element-type - ;; argument - ((not (subtypep-or-unknown element-type (array-element-type a))) - :failed-array-element-type) - - ;; If :adjustable is given, the array must be adjustable. - ((and adjustable - (not (check-values (adjustable-array-p a))) - :fail-adjustable)) - - ;; If :fill-pointer is given, the array must have a fill pointer - ((and fill-pointer - (not (check-values (array-has-fill-pointer-p a))) - :fail-has-fill-pointer)) - - ;; If the fill pointer is given as an integer, it must be the value - ;; of the fill pointer of the new array - ((and (check-values (integerp fill-pointer)) - (not (eql fill-pointer (check-values (fill-pointer a)))) - :fail-fill-pointer-1)) - - ;; If the fill-pointer argument is t, the fill pointer must be - ;; set to the vector size. - ((and (eq fill-pointer t) - (not (eql (first dimensions-list) (fill-pointer a))) - :fail-fill-pointer-2)) - - ;; If displaced-to another array, check that this is proper - ((and - displaced-to - (multiple-value-bind* (actual-dt actual-dio) - (array-displacement a) - (cond - ((not (eq actual-dt displaced-to)) - :fail-displacement-1) - ((not (eql actual-dio displaced-index-offset)) - :fail-displaced-index-offset))))) - - ;; Test of array-total-size - ((not (eql (check-values (array-total-size a)) - (reduce #'* dimensions-list :initial-value 1))) - :fail-array-total-size) - - ;; Test array-row-major-index on all zeros - ((and (> (array-total-size a) 0) - (not (eql (check-values - (apply #'array-row-major-index - a (make-list (array-rank a) :initial-element 0))) - 0))) - :fail-array-row-major-index-0) - - ;; For the last entry - ((and (> (array-total-size a) 0) - (not (eql (apply #'array-row-major-index - a (mapcar #'1- dimensions-list)) - (1- (reduce #'* dimensions-list :initial-value 1))))) - :fail-array-row-major-index-last) - - ;; No problems -- return the array - (t a)))) diff --git a/t/ansi-test/auxiliary/backquote-aux.lsp b/t/ansi-test/auxiliary/backquote-aux.lsp deleted file mode 100644 index d75303e..0000000 --- a/t/ansi-test/auxiliary/backquote-aux.lsp +++ /dev/null @@ -1,50 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Jun 11 08:04:23 2004 -;;;; Contains: Aux. functions associated with backquote tests - - - -;;; Not yet finished - - -;;; Create random backquoted forms -(defun make-random-backquoted-form (size) - (my-with-standard-io-syntax - (let ((*print-readably* nil) - (*package* (find-package "CL-TEST"))) - (read-from-string - (concatenate 'string - "`" - (make-random-backquoted-sequence-string size)))))) - -(defun make-random-backquoted-sequence-string (size) - (case size - ((0 1) (make-random-backquoted-string size)) - (t - (let* ((nelements (1+ (min (random (1- size)) (random (1- size)) 9))) - (sizes (random-partition (1- size) nelements)) - (substrings (mapcar #'make-random-backquoted-string sizes))) - (apply #'concatenate - 'string - "(" - (car substrings) - (if nil ; (and (> nelements 1) (coin)) - (nconc - (loop for s in (cddr substrings) collect " " collect s) - (list " . " (cadr substrings) ")")) - (nconc - (loop for s in (cdr substrings) collect " " collect s) - (list ")")))))))) - -;;; Create a string that is a backquoted form -(defun make-random-backquoted-string (size) - (if (<= size 1) - (rcase - (1 "()") - (1 (string (random-from-seq #.(coerce *cl-symbol-names* 'vector)))) - (1 (write-to-string (- (random 2001) 1000))) - (2 (concatenate 'string "," (string (random-from-seq "ABCDEFGHIJKLMNOPQRSTUVWXYZ")))) - ) - ;; size > 1 - (make-random-backquoted-sequence-string size))) diff --git a/t/ansi-test/auxiliary/bit-aux.lsp b/t/ansi-test/auxiliary/bit-aux.lsp deleted file mode 100644 index 3905a60..0000000 --- a/t/ansi-test/auxiliary/bit-aux.lsp +++ /dev/null @@ -1,22 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jul 24 19:25:39 2005 -;;;; Contains: Aux file for BIT-* tests - - - -(defun bit-random-test-fn (bit-fn log-fn &key (reps 5000) (maxlen 100)) - (assert (typep maxlen '(integer 1))) - (assert (typep reps 'unsigned-byte)) - (loop for len = (random maxlen) - for twos = (make-list len :initial-element 2) - for v1 = (map 'bit-vector #'random twos) - for v2 = (map 'bit-vector #'random twos) - for result = (funcall bit-fn v1 v2) - repeat reps - unless (and (= (length result) len) - (every #'(lambda (result-bit v1-bit v2-bit) - (= result-bit (logand 1 (funcall log-fn v1-bit v2-bit)))) - result v1 v2)) - collect (list len v1 v2 result))) - diff --git a/t/ansi-test/auxiliary/ceiling-aux.lsp b/t/ansi-test/auxiliary/ceiling-aux.lsp deleted file mode 100644 index 29c300b..0000000 --- a/t/ansi-test/auxiliary/ceiling-aux.lsp +++ /dev/null @@ -1,106 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Aug 19 06:52:02 2003 -;;;; Contains: Aux. functions for CEILING - - - -(defun ceiling.1-fn () - (loop for n = (- (random 2000000000) - 1000000000) - for d = (1+ (random 10000)) - for vals = (multiple-value-list (ceiling n d)) - for (q r) = vals - for n2 = (+ (* q d) r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (= n n2) - (integerp r) - (< (- d) r 1)) - collect (list n d q r n2))) - -(defun ceiling.2-fn () - (loop for num = (random 1000000000) - for denom = (1+ (random 1000)) - for n = (/ num denom) - for d = (1+ (random 10000)) - for vals = (multiple-value-list (ceiling n d)) - for (q r) = vals - for n2 = (+ (* q d) r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (<= r 0) - (< (- d) r) - (= n n2)) - collect (list n d q r n2))) - -(defun ceiling.3-fn (width) - (loop for n = (- (random width) (/ width 2)) - for vals = (multiple-value-list (ceiling n)) - for (q r) = vals - for n2 = (+ q r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (= n n2) - (<= 0 (- r)) - (< (- r) 1) - ) - collect (list n q r n2))) - -(defun ceiling.7-fn () - (loop for numerator = (- (random 10000000000) 5000000000) - for denominator = (1+ (random 100000)) - for n = (/ numerator denominator) - for vals = (multiple-value-list (ceiling n)) - for (q r) = vals - for n2 = (+ q r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (rationalp r) - (= n n2) - (<= 0 (- r)) - (< (- r) 1) - ) - collect (list n q r n2))) - -(defun ceiling.8-fn () - (loop for num1 = (- (random 10000000000) 5000000000) - for den1 = (1+ (random 100000)) - for n = (/ num1 den1) - for num2 = (- (1+ (random 1000000))) - for den2 = (1+ (random 1000000)) - for d = (/ num2 den2) - for vals = (multiple-value-list (ceiling n d)) - for (q r) = vals - for n2 = (+ (* q d) r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (rationalp r) - (<= 0 r) - (< r (- d)) - (= n n2)) - collect (list n q d r n2))) - -(defun ceiling.9-fn () - (loop for num1 = (- (random 1000000000000000) 500000000000000) - for den1 = (1+ (random 10000000000)) - for n = (/ num1 den1) - for num2 = (- (1+ (random 1000000000))) - for den2 = (1+ (random 10000000)) - for d = (/ num2 den2) - for vals = (multiple-value-list (ceiling n d)) - for (q r) = vals - for n2 = (+ (* q d) r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (rationalp r) - (<= 0 r) - (< r (- d)) - (= n n2)) - collect (list n q d r n2))) diff --git a/t/ansi-test/auxiliary/char-aux.lsp b/t/ansi-test/auxiliary/char-aux.lsp deleted file mode 100644 index 67f059f..0000000 --- a/t/ansi-test/auxiliary/char-aux.lsp +++ /dev/null @@ -1,333 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Oct 5 20:15:55 2002 -;;;; Contains: Auxiliary functions for character tests - - - -(defun is-ordered-by (seq fn) - (declare (type function fn)) - (let ((n (length seq))) - (loop for i from 0 below (1- n) - for e = (elt seq i) - always - (loop for j from (1+ i) below n - always (funcall fn e (elt seq j)))))) - -(defun is-antisymmetrically-ordered-by (seq fn) - (declare (type function fn)) - (and (is-ordered-by seq fn) - (is-ordered-by (reverse seq) (complement fn)))) - -(defun is-case-insensitive (fn) - (when (symbolp fn) - (assert (fboundp fn)) - (setf fn (symbol-function fn))) - (assert (typep fn 'function)) - (locally - (declare (type function fn)) - (loop for c across +code-chars+ - for c1 = (char-upcase c) - for c2 = (if (eql c c1) (char-downcase c) c1) - always - (loop for d across +code-chars+ - for d1 = (char-upcase d) - for d2 = (if (eql d d1) (char-downcase d) d1) - always (equiv (funcall fn c d) - (funcall fn c2 d) - (funcall fn c d2) - (funcall fn c2 d2)))))) - -(defun equiv (&rest args) - (declare (dynamic-extent args)) - (cond - ((null args) t) - ((car args) - (loop for e in (cdr args) always e)) - (t (loop for e in (cdr args) never e)))) - -;;; From character.lsp -(defun char-type-error-check (fn) - (when (symbolp fn) - (assert (fboundp fn)) - (setf fn (symbol-function fn))) - (assert (typep fn 'function)) - (locally - (declare (type function fn)) - (loop for x in *universe* - always (or (characterp x) - ;; FIXME -- catch the type error and check that datum - ;; is eql to x (and that datum is not in the expected type) - (eqt (catch-type-error (funcall fn x)) 'type-error))))) - -(defun standard-char.5.body () - (loop for i from 0 below (min 65536 char-code-limit) for c = (code-char i) - unless (not (and (typep c 'standard-char) - (not (standard-char-p c)))) - collect (char-name c))) - -(defun extended-char.3.body () - (loop for i from 0 below (min 65536 char-code-limit) for c = (code-char i) - unless (not (and (typep c 'base-char) - (typep c 'extended-char))) - collect (char-name c))) - -(defun character.1.body () - (loop for i from 0 below (min 65536 char-code-limit) for c = (code-char i) - unless (or (null c) - (let ((s (string c))) - (and - (eqlt (character c) c) - (eqlt (character s) c) - (eqlt (character (make-symbol s)) c)))) - collect (char-name c))) - -(defun character.2.body () - (loop for x in *universe* - when (not (or (characterp x) - (and (stringp x) (eqlt (length x) 1)) - (and (symbolp x) (eqlt (length (symbol-name x)) 1)) - (let ((c (catch-type-error (character x)))) - (or (eqlt c 'type-error) - (let ((s (catch-type-error (string x)))) - (and (stringp s) (eqlt (my-aref s 0) c))))))) - do (return x))) - -(defun characterp.2.body () - (loop for i from 0 below (min 65536 char-code-limit) for c = (code-char i) - unless (or (null c) (characterp c)) - collect (char-name c))) - -(defun characterp.3.body () - (loop for x in *universe* - unless (let ((p (characterp x)) - (q (typep x 'character))) - (if p (notnot q) (not q))) - collect x)) - -(defun alphanumericp.4.body () - (loop for x in *universe* - unless (or (not (characterp x)) - (if (or (digit-char-p x) (alpha-char-p x)) - (alphanumericp x) - ;; The hyperspec has an example that claims alphanumeric == - ;; digit-char-p or alpha-char-p, but the text seems to suggest - ;; that there can be numeric characters for which digit-char-p - ;; returns NIL. Therefore, I've weakened the next line - ;; (not (alphanumericp x)) - t)) - collect x)) - -(defun alphanumericp.5.body () - (loop for i from 0 below (min 65536 char-code-limit) - for x = (code-char i) - unless (or (not (characterp x)) - (if (or (digit-char-p x) (alpha-char-p x)) - (alphanumericp x) - ;; The hyperspec has an example that claims alphanumeric == - ;; digit-char-p or alpha-char-p, but the text seems to suggest - ;; that there can be numeric characters for which digit-char-p - ;; returns NIL. Therefore, I've weakened the next line - ;; (not (alphanumericp x)) - t)) - collect (char-name x))) - -(defun digit-char.1.body.old () - (loop for r from 2 to 36 always - (loop for i from 0 to 36 - always (let* ((c (digit-char i r)) - (result - (if (>= i r) (null c) - (eqlt c (char +extended-digit-chars+ i))))) - (unless result - (format t "~A ~A ~A~%" r i c)) - result)))) - -(defun digit-char.1.body () - (loop for r from 2 to 36 nconc - (loop for i from 0 to 36 - for c = (digit-char i r) - unless (if (>= i r) (null c) - (eqlt c (char +extended-digit-chars+ i))) - collect (list r i c)))) - -(defun digit-char-p.1.body () - (loop for x in *universe* - unless (not (and (characterp x) - (not (alphanumericp x)) - (digit-char-p x))) - collect x)) - -(defun digit-char-p.2.body () - (loop for i from 0 below (min 65536 char-code-limit) - for x = (code-char i) - unless (or (not x) - (not (and (not (alphanumericp x)) - (digit-char-p x)))) - collect (char-name x))) - -(defun digit-char-p.3.body () - (loop for r from 2 to 35 - for bad = - (loop for i from r to 35 - for c = (char +extended-digit-chars+ i) - when (or (digit-char-p c r) - (digit-char-p (char-downcase c) r)) - collect i) - when bad collect (cons r bad))) - -(defun digit-char-p.4.body () - (loop for r from 2 to 35 - for bad = - (loop for i from 0 below r - for c = (char +extended-digit-chars+ i) - unless (and (eqlt (digit-char-p c r) i) - (eqlt (digit-char-p (char-downcase c) r) i)) - collect i) - when bad collect (cons r bad))) - -(defun standard-char-p.2.body () - (loop for x in *universe* - unless (or (not (characterp x)) - (find x +standard-chars+) - (not (standard-char-p x))) - collect x)) - -(defun standard-char-p.2a.body () - (loop for i from 0 below (min 65536 char-code-limit) - for x = (code-char i) - unless (or (not (characterp x)) - (find x +standard-chars+) - (not (standard-char-p x))) - collect (char-name x))) - -(defun char-upcase.1.body () - (loop for x in *universe* - unless (or (not (characterp x)) - (let ((u (char-upcase x))) - (and - (or (lower-case-p x) (eqlt u x)) - (eqlt u (char-upcase u))))) - collect (char-name x))) - -(defun char-upcase.2.body () - (loop for i from 0 below (min 65536 char-code-limit) - for x = (code-char i) - unless (or (not x) - (let ((u (char-upcase x))) - (and - (or (lower-case-p x) (eqlt u x)) - (eqlt u (char-upcase u))))) - collect (char-name x))) - -(defun char-downcase.1.body () - (loop for x in *universe* - unless (or (not (characterp x)) - (let ((u (char-downcase x))) - (and - (or (upper-case-p x) (eqlt u x)) - (eqlt u (char-downcase u))))) - collect (char-name x))) - -(defun char-downcase.2.body () - (loop for i from 0 below (min 65536 char-code-limit) - for x = (code-char i) - unless (or (not x) - (let ((u (char-downcase x))) - (and - (or (upper-case-p x) (eqlt u x)) - (eqlt u (char-downcase u))))) - collect (char-name x))) - -(defun both-case-p.1.body () - (loop for x in *universe* - unless (or (not (characterp x)) - (if (both-case-p x) - (and (graphic-char-p x) - (or (upper-case-p x) - (lower-case-p x))) - (not (or (upper-case-p x) - (lower-case-p x))))) - collect (char-name x))) - -(defun both-case-p.2.body () - (loop for i from 0 below (min 65536 char-code-limit) - for x = (code-char i) - unless (or (not (characterp x)) - (if (both-case-p x) - (and (graphic-char-p x) - (or (upper-case-p x) - (lower-case-p x))) - (not (or (upper-case-p x) - (lower-case-p x))))) - collect (char-name x))) - -(defun char-code.2.body () - (loop for i from 0 below (min 65536 char-code-limit) - for c = (code-char i) - unless (or (not c) - (eqlt (char-code c) i)) - collect (char-name c))) - -(defun char-int.2.fn () - (declare (optimize (safety 3) (speed 1) (space 1))) - (let ((c->i (make-hash-table :test #'equal)) - (i->c (make-hash-table :test #'eql))) - (flet ((%insert - (c) - (or (not (characterp c)) - (let* ((i (char-int c)) - (j (gethash c c->i)) - (d (gethash i i->c))) - (and - (or (null j) (eqlt j i)) - (or (null d) (char= c d)) - (progn - (setf (gethash c c->i) i) - (setf (gethash i i->c) c) - t)))))) - (or - (loop for i from 0 below (min (ash 1 16) char-code-limit) - unless (%insert (code-char i)) - collect i) - (loop for i = (random char-code-limit) - repeat 1000 - unless (%insert (code-char i)) - collect i) - (find-if-not #'%insert +standard-chars+) - (find-if-not #'%insert *universe*))))) - -(defun char-name.1.fn () - (declare (optimize (safety 3) (speed 1) (space 1))) - (flet ((%check - (c) - (or (not (characterp c)) - (let ((name (char-name c))) - (or (null name) - (and (stringp name) - (eqlt c (name-char name)))))))) - (and - (loop for i from 0 below (min (ash 1 16) char-code-limit) - always (%check (code-char i))) - (every #'%check +standard-chars+) - (every #'%check *universe*) - t))) - -(defun name-char.1.body () - (declare (optimize (safety 3))) - (loop for x in *universe* - for s = (catch-type-error (string x)) - unless - (or (eqlt s 'type-error) - (let ((c (name-char x))) - (or (not c) - (characterp c) - ;; FIXME The rest of this wasn't reachable - #| - (let ((name (char-name c))) - (declare (type (or null string) name)) - (and name - (string-equal name s))) - |# - ))) - collect x)) diff --git a/t/ansi-test/auxiliary/cl-symbols-aux.lsp b/t/ansi-test/auxiliary/cl-symbols-aux.lsp deleted file mode 100644 index c6bdbf5..0000000 --- a/t/ansi-test/auxiliary/cl-symbols-aux.lsp +++ /dev/null @@ -1,42 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Nov 28 06:43:51 2002 -;;;; Contains: Aux. functions for cl-symbols.lsp - - - -(declaim (optimize (safety 3))) - -(defun is-external-symbol-of (sym package) - (multiple-value-bind (sym2 status) - (find-symbol (symbol-name sym) package) - (and (eqt sym sym2) - (eqt status :external)))) - -(defun test-if-not-in-cl-package (str) - (multiple-value-bind (sym status) - (find-symbol #+lower-case str #-lower-case (string-upcase str) 'common-lisp) - (or - ;; Symbol not present in the common lisp package as an external symbol - (not (eqt status :external)) - ;; Check if it has any properties whose indicators are - ;; external in any of the standard packages or are accessible - ;; in CL-USER - (let ((plist (symbol-plist sym))) - (loop for e = plist then (cddr e) - for indicator = (car e) - while e - when (and (symbolp indicator) - (or (is-external-symbol-of indicator - "COMMON-LISP") - (is-external-symbol-of indicator "KEYWORD") - (eqt indicator (find-symbol - (symbol-name indicator) - "COMMON-LISP-USER")))) - collect indicator))))) - -(defun safe-symbol-name (sym) - (catch-type-error (symbol-name sym))) - -(defun safe-make-symbol (name) - (catch-type-error (make-symbol name))) diff --git a/t/ansi-test/auxiliary/cons-aux.lsp b/t/ansi-test/auxiliary/cons-aux.lsp deleted file mode 100644 index 09596f6..0000000 --- a/t/ansi-test/auxiliary/cons-aux.lsp +++ /dev/null @@ -1,624 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Mar 6 17:45:42 2003 -;;;; Contains: Auxiliary functions for cons-related tests - - - -;;; -;;; 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 - car - cdr) - -(defun make-scaffold-copy (x) - "Make a tree that will be used to check if a tree has been changed." - (if - (consp x) - (make-scaffold :node x - :car (make-scaffold-copy (car x)) - :cdr (make-scaffold-copy (cdr x))) - (make-scaffold :node x - :car nil - :cdr nil))) - -(defun check-scaffold-copy (x xcopy) - "Return t if xcopy were produced from x by make-scaffold-copy, - and none of the cons cells in the tree rooted at x have been - changed." - - (and (eq x (scaffold-node xcopy)) - (or - (not (consp x)) - (and - (check-scaffold-copy (car x) (scaffold-car xcopy)) - (check-scaffold-copy (cdr x) (scaffold-cdr xcopy)))))) - -(defun create-c*r-test (n) - (cond - ((<= n 0) 'none) - (t - (cons (create-c*r-test (1- n)) - (create-c*r-test (1- n)))))) - -(defun nth-1-body (x) - (loop - for e in x - and i from 0 - count (not (eqt e (nth i x))))) - -(defun check-cons-copy (x y) - "Check that the tree x is a copy of the tree y, - returning t if it is, nil if not." - (cond - ((consp x) - (and (consp y) - (not (eqt x y)) - (check-cons-copy (car x) (car y)) - (check-cons-copy (cdr x) (cdr y)))) - ((eqt x y) t) - (t nil))) - -(defun check-sublis (a al &key (key 'no-key) test test-not) - "Apply sublis al a with various keys. Check that - the arguments are not themselves changed. Return nil - if the arguments do get changed." - (setf a (copy-tree a)) - (setf al (copy-tree al)) - (let ((acopy (make-scaffold-copy a)) - (alcopy (make-scaffold-copy al))) - (let ((as - (apply #'sublis al a - `(,@(when test `(:test ,test)) - ,@(when test-not `(:test-not ,test-not)) - ,@(unless (eqt key 'no-key) `(:key ,key)))))) - (and - (check-scaffold-copy a acopy) - (check-scaffold-copy al alcopy) - as)))) - -(defun check-nsublis (a al &key (key 'no-key) test test-not) - "Apply nsublis al a, copying these arguments first." - (setf a (copy-tree a)) - (setf al (copy-tree al)) - (let ((as - (apply #'sublis (copy-tree al) (copy-tree a) - `(,@(when test `(:test ,test)) - ,@(when test-not `(:test-not ,test-not)) - ,@(unless (eqt key 'no-key) `(:key ,key)))))) - as)) - -(defun check-subst (new old tree &key (key 'no-key) test test-not) - "Call subst new old tree, with keyword arguments if present. - Check that the arguments are not changed." - (setf new (copy-tree new)) - (setf old (copy-tree old)) - (setf tree (copy-tree tree)) - (let ((newcopy (make-scaffold-copy new)) - (oldcopy (make-scaffold-copy old)) - (treecopy (make-scaffold-copy tree))) - (let ((result - (apply #'subst new old tree - `(,@(unless (eqt key 'no-key) `(:key ,key)) - ,@(when test `(:test ,test)) - ,@(when test-not `(:test-not ,test-not)))))) - (and (check-scaffold-copy new newcopy) - (check-scaffold-copy old oldcopy) - (check-scaffold-copy tree treecopy) - result)))) - - -(defun check-subst-if (new pred tree &key (key 'no-key)) - "Call subst-if new pred tree, with various keyword arguments - if present. Check that the arguments are not changed." - (setf new (copy-tree new)) - (setf tree (copy-tree tree)) - (let ((newcopy (make-scaffold-copy new)) - (predcopy (make-scaffold-copy pred)) - (treecopy (make-scaffold-copy tree))) - (let ((result - (apply #'subst-if new pred tree - (unless (eqt key 'no-key) `(:key ,key))))) - (and (check-scaffold-copy new newcopy) - (check-scaffold-copy pred predcopy) - (check-scaffold-copy tree treecopy) - result)))) - -(defun check-subst-if-not (new pred tree &key (key 'no-key)) - "Call subst-if-not new pred tree, with various keyword arguments - if present. Check that the arguments are not changed." - (setf new (copy-tree new)) - (setf tree (copy-tree tree)) - (let ((newcopy (make-scaffold-copy new)) - (predcopy (make-scaffold-copy pred)) - (treecopy (make-scaffold-copy tree))) - (let ((result - (apply #'subst-if-not new pred tree - (unless (eqt key 'no-key) `(:key ,key))))) - (and (check-scaffold-copy new newcopy) - (check-scaffold-copy pred predcopy) - (check-scaffold-copy tree treecopy) - result)))) - -(defun check-nsubst (new old tree &key (key 'no-key) test test-not) - "Call nsubst new old tree, with keyword arguments if present." - (setf new (copy-tree new)) - (setf old (copy-tree old)) - (setf tree (copy-tree tree)) - (apply #'nsubst new old tree - `(,@(unless (eqt key 'no-key) `(:key ,key)) - ,@(when test `(:test ,test)) - ,@(when test-not `(:test-not ,test-not))))) - -(defun check-nsubst-if (new pred tree &key (key 'no-key)) - "Call nsubst-if new pred tree, with keyword arguments if present." - (setf new (copy-tree new)) - (setf tree (copy-tree tree)) - (apply #'nsubst-if new pred tree - (unless (eqt key 'no-key) `(:key ,key)))) - -(defun check-nsubst-if-not (new pred tree &key (key 'no-key)) - "Call nsubst-if-not new pred tree, with keyword arguments if present." - (setf new (copy-tree new)) - (setf tree (copy-tree tree)) - (apply #'nsubst-if-not new pred tree - (unless (eqt key 'no-key) `(:key ,key)))) - -(defun check-copy-list-copy (x y) - "Check that y is a copy of the list x." - (if - (consp x) - (and (consp y) - (not (eqt x y)) - (eqt (car x) (car y)) - (check-copy-list-copy (cdr x) (cdr y))) - (and (eqt x y) t))) - -(defun check-copy-list (x) - "Apply copy-list, checking that it properly copies, - and checking that it does not change its argument." - (let ((xcopy (make-scaffold-copy x))) - (let ((y (copy-list x))) - (and - (check-scaffold-copy x xcopy) - (check-copy-list-copy x y) - y)))) - -(defun append-6-body () - (let* ((cal (min 2048 call-arguments-limit)) - (step (max 1 (floor (/ cal) 64)))) - (loop - for n from 0 - below cal - by step - count - (not - (equal - (apply #'append (loop for i from 1 to n - collect '(a))) - (make-list n :initial-element 'a)))))) - -(defun is-intersection (x y z) - "Check that z is the intersection of x and y." - (and - (listp x) - (listp y) - (listp z) - (loop for e in x - always (or (not (member e y)) - (member e z))) - (loop for e in y - always (or (not (member e x)) - (member e z))) - (loop for e in z - always (and (member e x) (member e y))) - t)) - -(defun shuffle (x) - (cond - ((null x) nil) - ((null (cdr x)) x) - (t - (multiple-value-bind - (y z) - (split-list x) - (append (shuffle y) (shuffle z)))))) - -(defun split-list (x) - (cond - ((null x) (values nil nil)) - ((null (cdr x)) (values x nil)) - (t - (multiple-value-bind - (y z) - (split-list (cddr x)) - (values (cons (car x) y) (cons (cadr x) z)))))) - -(defun intersection-12-body (size niters &optional (maxelem (* 2 size))) - (let ((state (make-random-state))) - (loop - for i from 1 to niters do - (let ((x (shuffle (loop for j from 1 to size - collect (random maxelem state)))) - (y (shuffle (loop for j from 1 to size - collect (random maxelem state))))) - (let ((z (intersection x y))) - (let ((is-good (is-intersection x y z))) - (unless is-good (return (values x y z))))))) - nil)) - -(defun nintersection-with-check (x y &key test) - (let ((ycopy (make-scaffold-copy y))) - (let ((result (if test - (nintersection x y :test test) - (nintersection x y)))) - (if (check-scaffold-copy y ycopy) - result - 'failed)))) - -(defun nintersection-12-body (size niters &optional (maxelem (* 2 size))) - (let ((state (make-random-state t))) - (loop - for i from 1 to niters do - (let ((x (shuffle (loop for j from 1 to size - collect (random maxelem state)))) - (y (shuffle (loop for j from 1 to size - collect (random maxelem state))))) - (let ((z (nintersection-with-check (copy-list x) y))) - (when (eqt z 'failed) (return (values x y z))) - (let ((is-good (is-intersection x y z))) - (unless is-good (return (values x y z))))))) - nil)) - - -(defun union-with-check (x y &key test test-not) - (let ((xcopy (make-scaffold-copy x)) - (ycopy (make-scaffold-copy y))) - (let ((result (cond - (test (union x y :test test)) - (test-not (union x y :test-not test-not)) - (t (union x y))))) - (if (and (check-scaffold-copy x xcopy) - (check-scaffold-copy y ycopy)) - result - 'failed)))) - -(defun union-with-check-and-key (x y key &key test test-not) - (let ((xcopy (make-scaffold-copy x)) - (ycopy (make-scaffold-copy y))) - (let ((result (cond - (test (union x y :key key :test test)) - (test-not (union x y :key key :test-not test-not)) - (t (union x y :key key))))) - (if (and (check-scaffold-copy x xcopy) - (check-scaffold-copy y ycopy)) - result - 'failed)))) - -(defun check-union (x y z) - (and (listp x) - (listp y) - (listp z) - (loop for e in z always (or (member e x) (member e y))) - (loop for e in x always (member e z)) - (loop for e in y always (member e z)) - t)) - -(defun do-random-unions (size niters &optional (maxelem (* 2 size))) - (let ((state (make-random-state))) - (loop - for i from 1 to niters do - (let ((x (shuffle (loop for j from 1 to size collect - (random maxelem state)))) - (y (shuffle (loop for j from 1 to size collect - (random maxelem state))))) - (let ((z (union x y))) - (let ((is-good (check-union x y z))) - (unless is-good (return (values x y z))))))) - nil)) - -(defun nunion-with-copy (x y &key test test-not) - (setf x (copy-list x)) - (setf y (copy-list y)) - (cond - (test (nunion x y :test test)) - (test-not (nunion x y :test-not test-not)) - (t (nunion x y)))) - -(defun nunion-with-copy-and-key (x y key &key test test-not) - (setf x (copy-list x)) - (setf y (copy-list y)) - (cond - (test (nunion x y :key key :test test)) - (test-not (nunion x y :key key :test-not test-not)) - (t (nunion x y :key key)))) - -(defun do-random-nunions (size niters &optional (maxelem (* 2 size))) - (let ((state (make-random-state))) - (loop - for i from 1 to niters do - (let ((x (shuffle (loop for j from 1 to size collect - (random maxelem state)))) - (y (shuffle (loop for j from 1 to size collect - (random maxelem state))))) - (let ((z (nunion-with-copy x y))) - (let ((is-good (check-union x y z))) - (unless is-good (return (values x y z))))))) - nil)) - -(defun set-difference-with-check (x y &key (key 'no-key) - test test-not) - (setf x (copy-list x)) - (setf y (copy-list y)) - (let ((xcopy (make-scaffold-copy x)) - (ycopy (make-scaffold-copy y))) - (let ((result (apply #'set-difference - x y - `(,@(unless (eqt key 'no-key) `(:key ,key)) - ,@(when test `(:test ,test)) - ,@(when test-not `(:test-not ,test-not)))))) - (cond - ((and (check-scaffold-copy x xcopy) - (check-scaffold-copy y ycopy)) - result) - (t - 'failed))))) - -(defun check-set-difference (x y z &key (key #'identity) - (test #'eql)) - (and - ;; (not (eqt 'failed z)) - (listp x) - (listp y) - (listp z) - (loop for e in z always (member e x :key key :test test)) - (loop for e in x always (or (member e y :key key :test test) - (member e z :key key :test test))) - (loop for e in y never (member e z :key key :test test)) - t)) - -(defun do-random-set-differences (size niters &optional (maxelem (* 2 size))) - (let ((state (make-random-state))) - (loop - for i from 1 to niters do - (let ((x (shuffle (loop for j from 1 to size collect - (random maxelem state)))) - (y (shuffle (loop for j from 1 to size collect - (random maxelem state))))) - (let ((z (set-difference-with-check x y))) - (let ((is-good (check-set-difference x y z))) - (unless is-good (return (values x y z))))))) - nil)) -(defun nset-difference-with-check (x y &key (key 'no-key) - test test-not) - (setf x (copy-list x)) - (setf y (copy-list y)) - (apply #'nset-difference - x y - `(,@(unless (eqt key 'no-key) `(:key ,key)) - ,@(when test `(:test ,test)) - ,@(when test-not `(:test-not ,test-not))))) - -(defun check-nset-difference (x y z &key (key #'identity) - (test #'eql)) - (and - (listp x) - (listp y) - (listp z) - (loop for e in z always (member e x :key key :test test)) - (loop for e in x always (or (member e y :key key :test test) - (member e z :key key :test test))) - (loop for e in y never (member e z :key key :test test)) - t)) - -(defun do-random-nset-differences (size niters &optional (maxelem (* 2 size))) - (let ((state (make-random-state))) - (loop - for i from 1 to niters do - (let ((x (shuffle (loop for j from 1 to size collect - (random maxelem state)))) - (y (shuffle (loop for j from 1 to size collect - (random maxelem state))))) - (let ((z (nset-difference-with-check x y))) - (let ((is-good (check-nset-difference x y z))) - (unless is-good (return (values x y z))))))) - nil)) - -(defun set-exclusive-or-with-check (x y &key (key 'no-key) - test test-not) - (setf x (copy-list x)) - (setf y (copy-list y)) - (let ((xcopy (make-scaffold-copy x)) - (ycopy (make-scaffold-copy y))) - (let ((result (apply #'set-exclusive-or - x y - `(,@(unless (eqt key 'no-key) `(:key ,key)) - ,@(when test `(:test ,test)) - ,@(when test-not `(:test-not ,test-not)))))) - (cond - ((and (check-scaffold-copy x xcopy) - (check-scaffold-copy y ycopy)) - result) - (t - 'failed))))) - -(defun check-set-exclusive-or (x y z &key (key #'identity) - (test #'eql)) - (and - ;; (not (eqt 'failed z)) - (listp x) - (listp y) - (listp z) - (loop for e in z always (or (member e x :key key :test test) - (member e y :key key :test test))) - (loop for e in x always (if (member e y :key key :test test) - (not (member e z :key key :test test)) - (member e z :key key :test test))) - (loop for e in y always (if (member e x :key key :test test) - (not (member e z :key key :test test)) - (member e z :key key :test test))) - t)) - -#| -(defun do-random-set-exclusive-ors (size niters &optional (maxelem (* 2 size))) - (let ((state (make-random-state))) - (loop - for i from 1 to niters do - (let ((x (shuffle (loop for j from 1 to size collect - (random maxelem state)))) - (y (shuffle (loop for j from 1 to size collect - (random maxelem state))))) - (let ((z (set-exclusive-or-with-check x y))) - (let ((is-good (check-set-exclusive-or x y z))) - (unless is-good (return (values x y z))))))) - nil)) -|# - -(defun nset-exclusive-or-with-check (x y &key (key 'no-key) - test test-not) - (setf x (copy-list x)) - (setf y (copy-list y)) - (apply #'nset-exclusive-or - x y - `(,@(unless (eqt key 'no-key) `(:key ,key)) - ,@(when test `(:test ,test)) - ,@(when test-not `(:test-not ,test-not))))) - -#| -(defun do-random-nset-exclusive-ors (size niters &optional (maxelem (* 2 size))) - (let ((state (make-random-state))) - (loop - for i from 1 to niters do - (let ((x (shuffle (loop for j from 1 to size collect - (random maxelem state)))) - (y (shuffle (loop for j from 1 to size collect - (random maxelem state))))) - (let ((z (nset-exclusive-or-with-check x y))) - (let ((is-good (check-set-exclusive-or x y z))) - (unless is-good (return (values x y z))))))) - nil)) -|# - -(defun subsetp-with-check (x y &key (key 'no-key) test test-not) - (let ((xcopy (make-scaffold-copy x)) - (ycopy (make-scaffold-copy y))) - (let ((result - (apply #'subsetp x y - `(,@(unless (eqt key 'no-key) - `(:key ,key)) - ,@(when test `(:test ,test)) - ,@(when test-not `(:test-not ,test-not)))))) - (cond - ((and (check-scaffold-copy x xcopy) - (check-scaffold-copy y ycopy)) - (not (not result))) - (t 'failed))))) - -(defun my-set-exclusive-or (set1 set2 &key key test test-not) - - (assert (not (and test test-not))) - - (cond - (test-not (when (symbolp test-not) - (setq test-not (symbol-function test-not))) - (setq test (complement test-not))) - ((not test) (setq test #'eql))) - - ;;; (when (symbolp test) (setq test (symbol-function test))) - (etypecase test - (symbol (setq test (symbol-function test))) - (function nil)) - - (etypecase key - (null nil) - (symbol (setq key (symbol-function key))) - (function nil)) - - (let* ((keys1 (if key (mapcar (the function key) set1) set1)) - (keys2 (if key (mapcar (the function key) set2) set2)) - (mask1 (make-array (length set1) :element-type 'bit - :initial-element 0)) - (mask2 (make-array (length set2) :element-type 'bit - :initial-element 0))) - (loop for i1 from 0 - for k1 in keys1 - do - (loop for i2 from 0 - for k2 in keys2 - when (funcall (the function test) k1 k2) - do (setf (sbit mask1 i1) 1 - (sbit mask2 i2) 1))) - (nconc - (loop for e in set1 - for i across mask1 - when (= i 0) - collect e) - (loop for e in set2 - for i across mask2 - when (= i 0) - collect e)))) - -(defun make-random-set-exclusive-or-input (n) - (let* ((set1 (loop for i from 1 to n collect (random n))) - (set2 (loop for i from 1 to n collect (random n))) - (test-args - (random-case nil nil nil - (list :test 'eql) - (list :test #'eql) - (list :test (complement #'eql)))) - (test-not-args - (and (not test-args) - (random-case nil nil (list :test-not 'eql) - (list :test-not #'eql) - (list :test-not (complement #'eql))))) - (key-args - (random-case nil nil nil nil - (list :key nil) - (list :key 'identity) - (list :key 'not)))) - (list* set1 set2 - (reduce #'append (random-permute - (list test-args test-not-args key-args)))))) - -(defun random-set-exclusive-or-test (n reps &optional (fn 'set-exclusive-or)) - (let ((actual-fn (etypecase fn - (symbol (symbol-function fn)) - (function fn)))) - (declare (type function actual-fn)) - (loop for i below reps - for args = (make-random-set-exclusive-or-input n) - for set1 = (car args) - for set2 = (cadr args) - for result1 = (apply #'remove-duplicates - (sort (copy-list (apply #'my-set-exclusive-or args)) - #'<) - (cddr args)) - for result2 = (apply #'remove-duplicates - (sort (copy-list (apply actual-fn - (copy-list set1) - (copy-list set2) - (cddr args))) - #'<) - (cddr args)) - unless (equal result1 result2) - return (list (list 'remove-duplicates (list 'sort (cons fn args) '<) "...") - "actual: " result2 "should be: " result1)))) - -(defun rev-assoc-list (x) - (cond - ((null x) nil) - ((null (car x)) - (cons nil (rev-assoc-list (cdr x)))) - (t - (acons (cdar x) (caar x) (rev-assoc-list (cdr x)))))) - -(defvar *mapc.6-var* nil) -(defun mapc.6-fun (x) - (push x *mapc.6-var*) - x) diff --git a/t/ansi-test/auxiliary/defclass-aux.lsp b/t/ansi-test/auxiliary/defclass-aux.lsp deleted file mode 100644 index 1632e6b..0000000 --- a/t/ansi-test/auxiliary/defclass-aux.lsp +++ /dev/null @@ -1,314 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Mar 24 03:40:24 2003 -;;;; Contains: Auxiliary functions for testing CLOS - - - -(defun make-defclass-test-name (&rest args) - (intern (apply #'concatenate 'string (mapcar #'string args)) - (find-package :cl-test))) - -(defparameter *defclass-slot-readers* nil) -(defparameter *defclass-slot-writers* nil) -(defparameter *defclass-slot-accessors* nil) - -(defstruct my-class - (name nil :type symbol) - (direct-superclass-names nil :type list) - (slots nil :type list) - (default-initargs nil :type list) - (metaclass 'standard-class :type symbol) - (documentation nil :type (or null string)) - ;; Internal fields - (preds nil :type list) - (succs nil :type list) - (count 0 :type integer) - (index nil) - (min-pred-index 1000000) - ) - -(defstruct my-slot - (name nil :type symbol) - (has-initform nil :type boolean) - initform - (initargs nil :type list) - (documentation nil :type (or null string)) - (readers nil :type list) - (writers nil :type list) - (accessors nil :type list) - (allocation :instance :type (member :instance :class)) - (type t) - ) - -(defparameter *my-classes* (make-hash-table) - "Hash table mapping names of classes defined using DEFCLASS-WITH-TESTS - to their my-class objects.") - -(defun find-my-class (class-name) - (gethash class-name *my-classes*)) - -;;; This macro will assume that all the superclasses have already -;;; been defined. Tests will be written with defclass itself -;;; to test forward referenced superclasses - -(defmacro defclass-with-tests - (&whole args - class-name superclasses slot-specifiers - &rest class-options) - - (assert (typep class-name '(and (not null) symbol))) - (assert (listp superclasses)) - (assert (every #'(lambda (x) (typep x '(and (not null) symbol))) - superclasses)) - (assert (listp slot-specifiers)) - (assert (every #'(lambda (s) - (or (symbolp s) (and (consp s) (symbolp (car s))))) - slot-specifiers)) - (assert (every #'(lambda (x) - (and (consp x) - (member (car x) '(:default-initargs - :documentation - :metaclass)))) - class-options)) - (assert (eql (length class-options) - (length (remove-duplicates class-options)))) - - (let* ((default-initargs (rest (assoc :default-initargs class-options))) - (metaclass (or (second (assoc :metaclass class-options)) - 'standard-class)) - (doc (second (assoc :documentation class-options))) - (slot-names - (loop for slot-spec in slot-specifiers - collect (cond - ((symbolp slot-spec) slot-spec) - (t (assert (consp slot-spec)) - (assert (symbolp (car slot-spec))) - (car slot-spec))))) - (slot-options - (loop for slot-spec in slot-specifiers - collect (if (consp slot-spec) - (cdr slot-spec) - nil))) - (readers - (loop for slot-option in slot-options - append (collect-properties slot-option :reader))) - (writers - (loop for slot-option in slot-options - append (collect-properties slot-option :writer))) - (accessors - (loop for slot-option in slot-options - append (collect-properties slot-option :accessor))) - (allocations - (loop for slot-option in slot-options - collect (or (get slot-option :allocation) - :instance))) - (initargs - (loop for slot-option in slot-options - collect (collect-properties slot-option :initarg))) - (types - (loop for slot-option in slot-options - collect (collect-properties slot-option :type))) - (initforms - (loop for slot-option in slot-options - collect (collect-properties slot-option :initform))) - (class-var-name - (intern (concatenate 'string "*CLASS-" (symbol-name class-name) - "-RETURNED-BY-DEFCLASS*") - (find-package :cl-test))) - ) - - (declare (ignorable readers writers accessors allocations - initargs types initforms default-initargs - doc)) - - (assert (loop for e in types always (< (length e) 2))) - (assert (loop for e in initforms always (< (length e) 2))) - - (setf *defclass-slot-readers* (append readers *defclass-slot-readers*)) - (setf *defclass-slot-writers* (append writers *defclass-slot-writers*)) - (setf *defclass-slot-accessors* - (append accessors *defclass-slot-accessors*)) - - ;;; Store away information about the class and its slots - ;;; in a my-class object and associated my-slot objects. - - (let* ((my-slots - (loop for name in slot-names - for slot-option in slot-options - for readers = (collect-properties slot-option :reader) - for writers = (collect-properties slot-option :writer) - for accessors = (collect-properties slot-option :accessor) - for documentation = (getf slot-option :documentation) - for initarg-list in initargs - for type-list in types - for initform-list in initforms - for allocation in allocations - collect - (make-my-slot - :name name - :has-initform (notnot initform-list) - :initform (first initform-list) - :documentation documentation - :readers readers - :writers writers - :accessors accessors - :type (if type-list (first type-list) t) - ))) - (my-class-obj - (make-my-class :name class-name - :direct-superclass-names superclasses - :default-initargs default-initargs - :documentation doc - :metaclass metaclass - :slots my-slots))) - (setf (gethash class-name *my-classes*) my-class-obj)) - - `(progn - (declaim (special ,class-var-name)) - - (report-and-ignore-errors (setq ,class-var-name - (defclass ,@(cdr args)))) - - (deftest ,(make-defclass-test-name class-name "-DEFCLASS-RETURNS-CLASS") - (eqt (find-class ',class-name) ,class-var-name) - t) - - (deftest ,(make-defclass-test-name class-name - "-IS-IN-ITS-METACLASS") - (notnot-mv (typep (find-class ',class-name) ',metaclass)) - t) - - ,@(when (eq metaclass 'standard-class) - `((deftest ,(make-defclass-test-name class-name - "S-ARE-STANDARD-OBJECTS") - (subtypep* ',class-name 'standard-object) - t t))) - - ,@(loop for slot-name in slot-names - collect - `(deftest ,(make-defclass-test-name class-name - "-HAS-SLOT-NAMED-" - slot-name) - (notnot-mv (slot-exists-p (make-instance ',class-name) - ',slot-name)) - t)) - - (deftest ,(make-defclass-test-name class-name - "-ALLOCATE-INSTANCE") - (defclass-allocate-instance-test ',class-name ',slot-names) - nil) - - ))) - -(defun defclass-allocate-instance-test (class-name slot-names) - (let* ((class (find-class class-name)) - (instance (allocate-instance class))) - (append - (unless (eql (class-of instance) class) - (list (list 'not-instance-of class-name))) - (loop for slot in slot-names - when (slot-boundp instance slot) - collect (list 'is-bound slot)) - (loop for slot in slot-names - unless (equal (multiple-value-list - (notnot-mv (slot-exists-p instance slot))) - '(t)) - collect (list 'does-not-exist slot)) - (let ((bad-slot '#:foo)) - (when (slot-exists-p instance bad-slot) - (list (list 'should-not-exist bad-slot)))) - ))) - -(defmacro generate-slot-tests () - "Generate generic tests from the read/writer/accessor functions - for slots from defclass-with-tests." - (let ((funs (remove-duplicates - (append *defclass-slot-readers* - *defclass-slot-writers* - *defclass-slot-accessors*)))) - `(progn - (deftest class-readers/writers/accessors-are-generic-functions - (loop for sym in ',funs - unless (typep (symbol-function sym) 'generic-function) - collect sym) - nil) - - (deftest class-accessors-have-generic-setf-functions - (append - ,@(loop for sym in *defclass-slot-accessors* - collect - `(and (not (typep (function (setf ,sym)) - 'generic-function)) - '(,sym)))) - nil)))) - -(defun my-compute-class-precedence-list (class-name) - "Compute the class precdence list for classes defined using - DEFCLASS-WITH-TESTS." - (let ((class-names nil) - (class-names-to-consider (list class-name)) - classes) - ;; Find all classes - (loop - while class-names-to-consider - do (let ((name (pop class-names-to-consider))) - (unless (member name class-names) - (push name class-names) - (let ((my-class (find-my-class name))) - (assert my-class) - (setq class-names-to-consider - (append (my-class-direct-superclass-names my-class) - class-names-to-consider)))))) - (setq class-names (reverse class-names)) - (assert (eq class-name (first class-names))) - ;; class-names now contains class-name (which occurs first) and - ;; the names of all its superclasses except T - (setq classes (mapcar #'find-my-class class-names)) - ;; Walk the classes and set the predecessor links in the - ;; class precedence DAG - (loop for c in classes - for dsns = (my-class-direct-superclass-names c) - do (let ((pred c)) - (loop for superclass-name in dsns - for superclass = (find-my-class superclass-name) - do (push pred (my-class-preds superclass)) - do (pushnew superclass (my-class-succs pred)) - do (incf (my-class-count superclass)) - do (setq pred superclass)))) - ;; The list candidates will contain all the classes - ;; for which the count is zero. These are the candidates - ;; for selection as the next class in the class precedence list - (let ((candidates (loop for c in classes - when (zerop (my-class-count c)) - collect c)) - (n 0) - (result nil)) - (assert (equal candidates (list (first classes)))) - (loop - while candidates - do (let* ((next (first candidates)) - (min-pred-index (my-class-min-pred-index next))) - (loop - for c in (rest candidates) - for c-min-pred-index = (my-class-min-pred-index c) - do - (cond - ((< c-min-pred-index min-pred-index) - (setq next c - min-pred-index c-min-pred-index)) - (t (assert (not (= c-min-pred-index min-pred-index)))))) - (setq candidates (remove next candidates)) - (setf (my-class-index next) (incf n)) - (push next result) - (loop - for succ in (my-class-succs next) - do (decf (my-class-count succ)) - do (setf (my-class-min-pred-index succ) - (min (my-class-min-pred-index succ) - n)) - do (when (zerop (my-class-count succ)) - (push succ candidates))))) - (assert (eql (length result) (length classes))) - (setq result (reverse result)) - (mapcar #'my-class-name result)))) diff --git a/t/ansi-test/auxiliary/define-condition-aux.lsp b/t/ansi-test/auxiliary/define-condition-aux.lsp deleted file mode 100644 index 0035046..0000000 --- a/t/ansi-test/auxiliary/define-condition-aux.lsp +++ /dev/null @@ -1,84 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Mar 9 05:40:13 2003 -;;;; Contains: Auxiliary functions for testing DEFINE-CONDITION - - - -(defun make-def-cond-name (name &rest suffixes) - (intern (apply #'concatenate 'string (string name) "/" - (mapcar #'string suffixes)) - :cl-test)) - -(defmacro define-condition-with-tests (name-symbol - parents slot-specs &rest options) - - "Create a condition and some associated tests." - - (assert (symbolp name-symbol)) - (dolist (parent parents) (assert (symbolp parent))) - - (let ((name (symbol-name name-symbol))) - `(eval-when (:load-toplevel :compile-toplevel :execute) - (report-and-ignore-errors (eval '(define-condition ,name-symbol ,parents - ,slot-specs ,@options))) - ,@(loop for parent in (adjoin 'condition parents) - collect - `(deftest ,(make-def-cond-name name "IS-SUBTYPE-OF/" parent) - (subtypep* ',name-symbol ',parent) - t t)) - ,@(loop for parent in (adjoin 'condition parents) - collect - `(deftest ,(make-def-cond-name name "IS-SUBTYPE-OF-2/" parent) - (check-all-subtypep ',name-symbol ',parent) - nil)) - ,@(loop for parent in (adjoin 'condition parents) - collect - `(deftest ,(make-def-cond-name name - "IS-NOT-SUPERTYPE-OF/" parent) - (subtypep* ',parent ',name-symbol) - nil t)) - ,@(loop for parent in (adjoin 'condition parents) - collect - `(deftest ,(make-def-cond-name name "IS-A/" parent) - (let ((c (make-condition ',name-symbol))) - (notnot-mv (typep c ',parent))) - t)) - ,@(loop for parent in (adjoin 'condition parents) - collect - `(deftest ,(make-def-cond-name name "IS-SUBCLASS-OF/" parent) - (subtypep* (find-class ',name-symbol) - (find-class ',parent)) - t t)) - ,@(loop for parent in (adjoin 'condition parents) - collect - `(deftest ,(make-def-cond-name name - "IS-NOT-SUPERCLASS-OF/" parent) - (subtypep* (find-class ',parent) - (find-class ',name-symbol)) - nil t)) - ,@(loop for parent in (adjoin 'condition parents) - collect - `(deftest ,(make-def-cond-name name "IS-A-MEMBER-OF-CLASS/" - parent) - (let ((c (make-condition ',name-symbol))) - (notnot-mv (typep c (find-class ',parent)))) - t)) - (deftest ,(make-def-cond-name name "HANDLER-CASE-1") - (let ((c (make-condition ',name-symbol))) - (handler-case (normally (signal c)) - (,name-symbol (c1) (eqt c c1)))) - t) - (deftest ,(make-def-cond-name name "HANDLER-CASE-2") - (let ((c (make-condition ',name-symbol))) - (handler-case (normally (signal c)) - (condition (c1) (eqt c c1)))) - t) - ,@(unless (some #'(lambda (ct) (subtypep ct 'error)) parents) - `((deftest ,(make-def-cond-name name "HANDLER-CASE-3") - (let ((c (make-condition ',name-symbol))) - (handler-case (normally (signal c)) - (error () nil) - (,name-symbol (c2) (eqt c c2)))) - t))) - ))) diff --git a/t/ansi-test/auxiliary/division-aux.lsp b/t/ansi-test/auxiliary/division-aux.lsp deleted file mode 100644 index dfcf84b..0000000 --- a/t/ansi-test/auxiliary/division-aux.lsp +++ /dev/null @@ -1,12 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Sep 1 07:57:02 2003 -;;;; Contains: Aux. functions for testing / - - - -(defun divide-by-zero-test (&rest args) - (handler-case - (progn (apply #'/ args) (values)) - (division-by-zero () (values)) - (condition (c) c))) diff --git a/t/ansi-test/auxiliary/exp-aux.lsp b/t/ansi-test/auxiliary/exp-aux.lsp deleted file mode 100644 index 5f99a0f..0000000 --- a/t/ansi-test/auxiliary/exp-aux.lsp +++ /dev/null @@ -1,24 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Sep 1 21:30:38 2003 -;;;; Contains: Aux. functions for testing EXP, EXPT - - - -(defun my-exp (x n) - "Compute e^x in the appropriate float result type, summing - the first n terms of the Taylor series." - (assert (realp x)) - (let ((result 1) - (xrat (rational x))) - (loop - for i from (1- n) downto 1 - do (setq result (+ 1 (/ (* xrat result) i)))) - (if (floatp x) - (float result x) - (float result 1.0f0)))) - - - - - diff --git a/t/ansi-test/auxiliary/fceiling-aux.lsp b/t/ansi-test/auxiliary/fceiling-aux.lsp deleted file mode 100644 index ca6c1e1..0000000 --- a/t/ansi-test/auxiliary/fceiling-aux.lsp +++ /dev/null @@ -1,21 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Aug 20 06:24:45 2003 -;;;; Contains: Tests of FCEILING - - - -(defun fceiling.1-fn () - (loop for n = (- (random 200000) - 100000) - for d = (1+ (random 10000)) - for vals = (multiple-value-list (fceiling n d)) - for (q r) = vals - for n2 = (+ (* q d) r) - repeat 100 - unless (and (eql (length vals) 2) - (floatp q) - (= n n2) - (integerp r) - (< (- d) r 1)) - collect (list n d q r n2))) diff --git a/t/ansi-test/auxiliary/ffloor-aux.lsp b/t/ansi-test/auxiliary/ffloor-aux.lsp deleted file mode 100644 index 14ccd9a..0000000 --- a/t/ansi-test/auxiliary/ffloor-aux.lsp +++ /dev/null @@ -1,21 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Aug 12 07:02:07 2003 -;;;; Contains: Aux. functions used in FFLOOR tests - - - -(defun ffloor.1-fn () - (loop for n = (- (random 200000) - 100000) - for d = (1+ (random 10000)) - for vals = (multiple-value-list (ffloor n d)) - for (q r) = vals - for n2 = (+ (* q d) r) - repeat 100 - unless (and (eql (length vals) 2) - (floatp q) - (= n n2) - (integerp r) - (< -1 r d)) - collect (list n d q r n2))) diff --git a/t/ansi-test/auxiliary/floor-aux.lsp b/t/ansi-test/auxiliary/floor-aux.lsp deleted file mode 100644 index 314d5ab..0000000 --- a/t/ansi-test/auxiliary/floor-aux.lsp +++ /dev/null @@ -1,108 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Aug 9 08:08:00 2003 -;;;; Contains: Aux. functions used in FLOOR tests - - - -(defun floor.1-fn () - (loop for n = (- (random 2000000000) - 1000000000) - for d = (1+ (random 10000)) - for vals = (multiple-value-list (floor n d)) - for (q r) = vals - for n2 = (+ (* q d) r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (= n n2) - (integerp r) - (< -1 r d)) - collect (list n d q r n2))) - -(defun floor.2-fn () - (loop for num = (random 1000000000) - for denom = (1+ (random 1000)) - for n = (/ num denom) - for d = (1+ (random 10000)) - for vals = (multiple-value-list (floor n d)) - for (q r) = vals - for n2 = (+ (* q d) r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (<= 0 r) - (< r d) - (= n n2)) - collect (list n d q r n2))) - -(defun floor.3-fn (width) - (loop for n = (- (random width) (/ width 2)) - for vals = (multiple-value-list (floor n)) - for (q r) = vals - for n2 = (+ q r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (= n n2) - (<= 0 r) - (< r 1) - ) - collect (list n q r n2))) - -(defun floor.7-fn () - (loop for numerator = (- (random 10000000000) 5000000000) - for denominator = (1+ (random 100000)) - for n = (/ numerator denominator) - for vals = (multiple-value-list (floor n)) - for (q r) = vals - for n2 = (+ q r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (rationalp r) - (= n n2) - (<= 0 r) - (< r 1) - ) - collect (list n q r n2))) - -(defun floor.8-fn () - (loop for num1 = (- (random 10000000000) 5000000000) - for den1 = (1+ (random 100000)) - for n = (/ num1 den1) - for num2 = (- (1+ (random 1000000))) - for den2 = (1+ (random 1000000)) - for d = (/ num2 den2) - for vals = (multiple-value-list (floor n d)) - for (q r) = vals - for n2 = (+ (* q d) r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (rationalp r) - (>= 0 r) - (> r d) - (= n n2)) - collect (list n q d r n2))) - -(defun floor.9-fn () - (loop for num1 = (- (random 1000000000000000) 500000000000000) - for den1 = (1+ (random 10000000000)) - for n = (/ num1 den1) - for num2 = (- (1+ (random 1000000000))) - for den2 = (1+ (random 10000000)) - for d = (/ num2 den2) - for vals = (multiple-value-list (floor n d)) - for (q r) = vals - for n2 = (+ (* q d) r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (rationalp r) - (>= 0 r) - (> r d) - (= n n2)) - collect (list n q d r n2))) - -;;; Need float tests diff --git a/t/ansi-test/auxiliary/fround-aux.lsp b/t/ansi-test/auxiliary/fround-aux.lsp deleted file mode 100644 index 9f90613..0000000 --- a/t/ansi-test/auxiliary/fround-aux.lsp +++ /dev/null @@ -1,25 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Aug 21 16:08:55 2003 -;;;; Contains: Aux. functions for testing FROUND - - - -(defun fround.1-fn () - (loop for n = (- (random 200000) - 100000) - for d = (1+ (random 10000)) - for vals = (multiple-value-list (fround n d)) - for (q r) = vals - for n2 = (+ (* q d) r) - repeat 100 - unless (and (eql (length vals) 2) - (floatp q) - (= n n2) - (integerp r) - (<= (- (/ d 2)) r (/ d 2)) - (or (/= (abs r) (/ d 2)) - (evenp (floor q)))) - collect (list n d q r n2))) - - diff --git a/t/ansi-test/auxiliary/ftruncate-aux.lsp b/t/ansi-test/auxiliary/ftruncate-aux.lsp deleted file mode 100644 index aa9d292..0000000 --- a/t/ansi-test/auxiliary/ftruncate-aux.lsp +++ /dev/null @@ -1,23 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Aug 20 06:37:01 2003 -;;;; Contains: Aux. functions for testing FTRUNCATE - - - -(defun ftruncate.1-fn () - (loop for n = (- (random 200000) - 100000) - for d = (1+ (random 10000)) - for vals = (multiple-value-list (ftruncate n d)) - for (q r) = vals - for n2 = (+ (* q d) r) - repeat 100 - unless (and (eql (length vals) 2) - (floatp q) - (= n n2) - (integerp r) - (if (>= n 0) - (< -1 r d) - (< -1 (- r) d))) - collect (list n d q r n2))) diff --git a/t/ansi-test/auxiliary/gcd-aux.lsp b/t/ansi-test/auxiliary/gcd-aux.lsp deleted file mode 100644 index 06eeebb..0000000 --- a/t/ansi-test/auxiliary/gcd-aux.lsp +++ /dev/null @@ -1,34 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Sep 3 06:57:22 2003 -;;;; Contains: Aux. functions for testing GCD - - - -(defun my-gcd (x y) - (cond - ((< x 0) - (my-gcd (- x) y)) - ((< y 0) - (my-gcd x (- y))) - ((<= x y) - (my-gcd* x y)) - (t - (my-gcd* y x)))) - -(defun my-gcd* (x y) - ;;; 0 <= x <= y - (loop - (when (zerop x) (return y)) - (psetq x (mod y x) - y x))) - -(defun my-lcm (x y) - (when (< x 0) (setf x (- x))) - (when (< y 0) (setf y (- y))) - (if (or (= x 0) (= y 0)) - 0 - (/ (* x y) (my-gcd x y)))) - - - diff --git a/t/ansi-test/auxiliary/hash-table-aux.lsp b/t/ansi-test/auxiliary/hash-table-aux.lsp deleted file mode 100644 index 0d4f96e..0000000 --- a/t/ansi-test/auxiliary/hash-table-aux.lsp +++ /dev/null @@ -1,93 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Oct 4 09:24:24 2003 -;;;; Contains: Aux. functions for testing hash tables - - - -(eval-when (:load-toplevel :compile-toplevel :execute) - (compile-and-load "ANSI-TESTS:AUX;random-aux.lsp")) - -(defparameter *hash-table-test-iters* 1000) - -(defun test-hash-table-1 (&rest args) - (let ((table (apply #'make-hash-table args)) - (test (or (getf args :test) 'eql))) - (assert (member test '(eq eql equal equalp))) - (assert (hash-table-p table)) - (assert (typep table 'hash-table)) - ;; Build a hash table using the arguments in ARGS. - ;; Perform *hash-table-test-iters* iterations of - ;; random hash table operations - (let* ((universe-vec (coerce *universe* 'vector)) - ;; (universe-size (length universe-vec)) - (mapping nil) - (count 0)) - - (loop - for i from 0 below *hash-table-test-iters* - do (assert (eql (hash-table-count table) count)) - do (assert (let ((size (hash-table-size table))) - (and (integerp size) (>= size 0)))) - do - (flet ((%remove-pair - (rpair) - (decf count) - (let ((key (car rpair)) - (expected-value (cdr rpair))) - (multiple-value-bind (value present-p) - (gethash key table) - (assert present-p) - (assert (eql expected-value value)) - (setf mapping - (remove rpair mapping :count 1 :test 'eq))) - (assert (remhash key table)) - (multiple-value-bind (value present-p) - (gethash key table) - (assert (not present-p)) - (assert (null value)) - )))) - - (rcase - (1 ;; Insert - (let* ((new-elem (random-from-seq universe-vec)) - (pair (assoc new-elem mapping :test test))) - (cond - (pair - (multiple-value-bind - (value present-p) - (gethash new-elem table) - (assert present-p) - (assert (eql (cdr pair) value)) - (setf (cdr pair) i - (gethash new-elem table) i))) - (t - (assert - (equal (multiple-value-list (gethash new-elem table)) - '(nil nil))) - (incf count) - (push (cons new-elem i) mapping) - (setf (gethash new-elem table) i))))) - (1 ;; Delete element in the set - (when mapping - (%remove-pair (random-from-seq mapping)))) - (1 ;; Delete random element from universe - (let* ((key (random-from-seq universe-vec)) - (pair (assoc key mapping :test test))) - (cond - (pair (%remove-pair pair)) - (t - ;; Not present -- check that this is true - (assert (equal (multiple-value-list (gethash key table)) - '(nil nil))) - (assert (not (remhash key table))) - (assert (equal (multiple-value-list (gethash key table)) - '(nil nil))))) - )) - )))))) - - - - - - diff --git a/t/ansi-test/auxiliary/numbers-aux.lsp b/t/ansi-test/auxiliary/numbers-aux.lsp deleted file mode 100644 index eaa5d5b..0000000 --- a/t/ansi-test/auxiliary/numbers-aux.lsp +++ /dev/null @@ -1,369 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Apr 7 07:24:43 2003 -;;;; Contains: Auxiliary functions for number tests - - - -(eval-when (:compile-toplevel :load-toplevel :execute) - (compile-and-load "ANSI-TESTS:AUX;random-aux.lsp")) - -;;; Binary search on reals - -(defun float-binary-search (fn lo hi) - "FN is a function that, if true for X, is true for all Y > X. - Find the smallest float in [lo,hi] for which the function - return true." - - (assert (functionp fn)) - (assert (floatp lo)) - (assert (floatp hi)) - (assert (<= lo hi)) - (assert (funcall fn hi)) - - (loop while (<= lo hi) - do (let ((mid (/ (+ lo hi) 2))) - (if (funcall fn mid) - (if (= mid hi) - (return hi) - (setq hi mid)) - (if (= mid lo) - (return hi) - (setq lo mid)))))) - -(defun integer-binary-search (fn lo hi) - - "FN is a function that, if true for X, is true for all Y < X. - Find the largest integer in [lo,hi) for which the function - return true." - - (assert (functionp fn)) - (assert (integerp lo)) - (assert (integerp hi)) - (assert (<= lo hi)) - (assert (funcall fn lo)) - - (loop while (< lo hi) - do (let ((mid (ceiling (+ lo hi) 2))) - (if (funcall fn mid) - (setq lo mid) - (if (= mid hi) - (return lo) - (setq hi mid)))) - finally (return lo))) - -(defun find-largest-exactly-floatable-integer (upper-bound) - (integer-binary-search - #'(lambda (i) - (let* ((f (float i)) - (i- (1- i)) - (f- (float i-))) - (and (= f i) (= f- i-)))) - 0 upper-bound)) - -(defun eqlzt (x y) - "Return T if (eql x y) or if both are zero of the same type." - (cond - ((complexp x) - (and (complexp y) - (eqlzt (realpart x) (realpart y)) - (eqlzt (imagpart x) (imagpart y)))) - ((zerop x) - (eqlt (abs x) (abs y))) - (t (eqlt x y)))) - -(defconstant +rational-most-negative-short-float+ - (rational-safely most-negative-short-float)) - -(defconstant +rational-most-negative-single-float+ - (rational-safely most-negative-single-float)) - -(defconstant +rational-most-negative-double-float+ - (rational-safely most-negative-double-float)) - -(defconstant +rational-most-negative-long-float+ - (rational-safely most-negative-long-float)) - -(defconstant +rational-most-positive-short-float+ - (rational-safely most-positive-short-float)) - -(defconstant +rational-most-positive-single-float+ - (rational-safely most-positive-single-float)) - -(defconstant +rational-most-positive-double-float+ - (rational-safely most-positive-double-float)) - -(defconstant +rational-most-positive-long-float+ - (rational-safely most-positive-long-float)) - -(defun float-exponent (x) - (if (floatp x) - (nth-value 1 (decode-float x)) - 0)) - -(defun numbers-are-compatible (x y) - (cond - ((complexp x) - (and (numbers-are-compatible (realpart x) y) - (numbers-are-compatible (imagpart x) y))) - ((complexp y) - (and (numbers-are-compatible x (realpart y)) - (numbers-are-compatible x (imagpart y)))) - (t - (when (floatp x) (rotatef x y)) - (or (floatp x) - (not (floatp y)) - (etypecase y - (short-float - (<= +rational-most-negative-short-float+ - x - +rational-most-positive-short-float+)) - (single-float - (<= +rational-most-negative-single-float+ - x - +rational-most-positive-single-float+)) - (double-float - (<= +rational-most-negative-double-float+ - x - +rational-most-positive-double-float+)) - (long-float - (<= +rational-most-negative-long-float+ - x - +rational-most-positive-long-float+))))))) - -;;; NOTE! According to section 12.1.4.1, when a rational is compared -;;; to a float, the effect is as if the float is convert to a rational -;;; (by RATIONAL), not as if the rational is converted to a float. -;;; This means the calls to numbers-are-compatible are not necessary. - -(defun =.4-fn () - (loop for x in *numbers* - append - (loop for y in *numbers* - unless (or ;; (not (numbers-are-compatible x y)) - (if (= x y) (= y x) (not (= y x)))) - collect (list x y)))) - -(defun /=.4-fn () - (loop for x in *numbers* - append - (loop for y in *numbers* - unless (or ;; (not (numbers-are-compatible x y)) - (if (/= x y) (/= y x) (not (/= y x)))) - collect (list x y)))) - -(defun /=.4a-fn () - (loop for x in *numbers* - append - (loop for y in *numbers* - when (and ;; (numbers-are-compatible x y) - (if (= x y) - (/= x y) - (not (/= x y)))) - collect (list x y)))) - -(defun <.8-fn () - (loop for x in *reals* - nconc - (loop for y in *reals* - when - (handler-case - (and ;; (numbers-are-compatible x y) - (and (< x y) (> x y))) - (arithmetic-error () nil)) - collect (list x y)))) - -(defun <.9-fn () - (loop for x in *reals* - nconc - (loop for y in *reals* - when - (handler-case - (and ;; (numbers-are-compatible x y) - (if (< x y) (not (> y x)) - (> y x))) - (arithmetic-error () nil)) - collect (list x y)))) - -(defun <.10-fn () - (loop for x in *reals* - nconc - (loop for y in *reals* - when - (handler-case - (and ;; (numbers-are-compatible x y) - (if (< x y) (>= x y) - (not (>= x y)))) - (arithmetic-error () nil)) - collect (list x y)))) - -(defun <=.8-fn () - (loop for x in *reals* - nconc - (loop for y in *reals* - when - (handler-case - (and ;; (numbers-are-compatible x y) - (if (<= x y) (not (>= y x)) - (>= y x))) - (arithmetic-error () nil)) - collect (list x y)))) - -(defun <=.9-fn () - (loop for x in *reals* - nconc - (loop for y in *reals* - when - (handler-case - (and ;; (numbers-are-compatible x y) - (if (<= x y) (not (or (= x y) (< x y))) - (or (= x y) (< x y)))) - (arithmetic-error () nil)) - collect (list x y)))) - -(defun >.8-fn () - (loop for x in *reals* - nconc - (loop for y in *reals* - when - (handler-case - (and ;; (numbers-are-compatible x y) - (if (> x y) (<= x y) - (not (<= x y)))) - (arithmetic-error () nil)) - collect (list x y)))) - -(defun >=.8-fn () - (loop for x in *reals* - nconc - (loop for y in *reals* - when - (handler-case - (and ;; (numbers-are-compatible x y) - (if (>= x y) (not (or (= x y) (> x y))) - (or (= x y) (> x y)))) - (arithmetic-error () nil)) - collect (list x y)))) - -;;; Comparison of rationsls - -(defun compare-random-rationals (n m rep) - (loop for a = (- (random n) m) - for b = (- (random n) m) - for c = (- (random n) m) - for d = (- (random n) m) - repeat rep - when - (and (/= b 0) - (/= d 0) - (let ((q1 (/ a b)) - (q2 (/ c d)) - (ad (* a d)) - (bc (* b c))) - (when (< (* b d) 0) - (setq ad (- ad)) - (setq bc (- bc))) - (or (if (< q1 q2) (not (< ad bc)) (< ad bc)) - (if (<= q1 q2) (not (<= ad bc)) (<= ad bc)) - (if (> q1 q2) (not (> ad bc)) (> ad bc)) - (if (>= q1 q2) (not (>= ad bc)) (>= ad bc)) - (if (= q1 q2) (not (= ad bc)) (= ad bc)) - (if (/= q1 q2) (not (/= ad bc)) (/= ad bc))))) - collect (list a b c d))) - -(defun max.2-fn () - (loop for x in *reals* - nconc - (loop for y in *reals* - when (numbers-are-compatible x y) - unless - (handler-case - (let ((m (max x y))) - (and (>= m x) (>= m y) - (or (= m x) (= m y)))) - (floating-point-underflow () t) - (floating-point-overflow () t)) - collect (list x y (max x y))))) - -(defun min.2-fn () - (loop for x in *reals* - nconc - (loop for y in *reals* - when (numbers-are-compatible x y) - unless - (handler-case - (let ((m (min x y))) - (and (<= m x) (<= m y) - (or (= m x) (= m y)))) - (floating-point-underflow () t) - (floating-point-overflow () t)) - collect (list x y (min x y))))) - -;;; Compute the number of digits that can be added to 1.0 in the appropriate -;;; float type, a rational representation of the smallest radix^(-k) s.t. -;;; 1.0 + radix^(-k) /= 1.0, and the float representation of that value. -;;; Note that this will in general be > -epsilon. - -(defun find-epsilon (x) - (assert (floatp x)) - (let* ((one (float 1 x)) - (radix (float-radix one)) - (eps (/ 1 radix))) - (loop - for next-eps = (/ eps radix) - for i from 1 - until (eql one (+ one next-eps)) - do (setq eps next-eps) - finally (return (values i eps (float eps one)))))) - -(defun test-log-op-with-decls (op xlo xhi ylo yhi niters - &optional - (decls '((optimize (speed 3) (safety 1) - (debug 1))))) - "Test that a compiled form of the LOG* function OP computes - the expected result on two random integers drawn from the - types `(integer ,xlo ,xhi) and `(integer ,ylo ,yhi). Try - niters choices. Return a list of pairs on which the test fails." - - (assert (symbolp op)) - (assert (integerp xlo)) - (assert (integerp xhi)) - (assert (integerp ylo)) - (assert (integerp yhi)) - (assert (integerp niters)) - (assert (<= xlo xhi)) - (assert (<= ylo yhi)) - - (let* ((source - `(lambda (x y) - (declare (type (integer ,xlo ,xhi) x) - (type (integer ,ylo ,yhi) y) - ,@ decls) - (,op x y))) - (fn (compile nil source))) - (loop for i below niters - for x = (random-from-interval (1+ xhi) xlo) - for y = (random-from-interval (1+ yhi) ylo) - unless (eql (funcall (the symbol op) x y) - (funcall fn x y)) - collect (list x y)))) - -(defun test-log-op (op n1 n2) - (flet ((%r () (let ((r (random 33))) - (- (random (ash 1 (1+ r))) (ash 1 r))))) - (loop for x1 = (%r) - for x2 = (%r) - for y1 = (%r) - for y2 = (%r) - repeat n1 - nconc - (test-log-op-with-decls op - (min x1 x2) (max x1 x2) - (min y1 y2) (max y1 y2) - n2)))) -(defun safe-tan (x &optional (default 0.0)) - (handler-case - (let ((result (multiple-value-list (tan x)))) - (assert (null (cdr result))) - (car result)) - (arithmetic-error () default))) diff --git a/t/ansi-test/auxiliary/package-aux.lsp b/t/ansi-test/auxiliary/package-aux.lsp deleted file mode 100644 index 874c6b0..0000000 --- a/t/ansi-test/auxiliary/package-aux.lsp +++ /dev/null @@ -1,134 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Jun 21 20:59:17 2004 -;;;; Contains: Aux. functions for package tests - - - -(defmacro test-with-package-iterator (package-list-expr &rest symbol-types) - "Build an expression that tests the with-package-iterator form." - (let ((name (gensym)) - (cht-var (gensym)) - (pkg-list-var (gensym))) - `(let ((,cht-var (make-hash-table)) - (,pkg-list-var ,package-list-expr) - (fail-count 0)) - (with-package-iterator (,name ,pkg-list-var - ,@(copy-list symbol-types)) - ;; For each symbol, check that name is returning appropriate - ;; things - (loop - (block fail - (multiple-value-bind (more sym access pkg) - (,name) - (unless more (return nil)) - (setf (gethash sym ,cht-var) t) ;; note presence of symbol - ;; Check that its access status is in the list, - ;; that pkg is a package, - ;; that the symbol is in the package, - ;; and that (in the package) it has the correct access type - (unless (member access (quote ,(copy-list symbol-types))) - (unless (> fail-count +fail-count-limit+) - (format t "Bad access type: ~S ==> ~A~%" sym access)) - (when (= fail-count +fail-count-limit+) - (format t "Further messages suppressed~%")) - (incf fail-count) - (return-from fail nil)) - - (unless (packagep pkg) - (unless (> fail-count +fail-count-limit+) - (format t "Not a package: ~S ==> ~S~%" sym pkg)) - (when (= fail-count +fail-count-limit+) - (format t "Further messages suppressed~%")) - (incf fail-count) - (return-from fail nil)) - (multiple-value-bind (sym2 access2) - (find-symbol (symbol-name sym) pkg) - (unless (or (eqt sym sym2) - (member sym2 (package-shadowing-symbols pkg))) - (unless (> fail-count +fail-count-limit+) - (format t "Not same symbol: ~S ~S~%" sym sym2)) - (when (= fail-count +fail-count-limit+) - (format t "Further messages suppressed~%")) - (incf fail-count) - (return-from fail nil)) - (unless (eqt access access2) - (unless (> fail-count +fail-count-limit+) - (format t "Not same access type: ~S ~S ~S~%" - sym access access2)) - (when (= fail-count +fail-count-limit+) - (format t "Further messages suppressed~%")) - (incf fail-count) - (return-from fail nil))))))) - ;; now, check that each symbol in each package has - ;; been properly found - (loop - for p in ,pkg-list-var do - (block fail - (do-symbols (sym p) - (multiple-value-bind (sym2 access) - (find-symbol (symbol-name sym) p) - (unless (eqt sym sym2) - (unless (> fail-count +fail-count-limit+) - (format t "Not same symbol (2): ~S ~S~%" - sym sym2)) - (when (= fail-count +fail-count-limit+) - (format t "Further messages suppressed~%")) - (incf fail-count) - (return-from fail nil)) - (unless (or (not (member access - (quote ,(copy-list symbol-types)))) - (gethash sym ,cht-var)) - (format t "Symbol not found: ~S~%" sym) - (incf fail-count) - (return-from fail nil)))))) - (or (zerop fail-count) fail-count)))) - -(defun with-package-iterator-internal (packages) - (test-with-package-iterator packages :internal)) - -(defun with-package-iterator-external (packages) - (test-with-package-iterator packages :external)) - -(defun with-package-iterator-inherited (packages) - (test-with-package-iterator packages :inherited)) - -(defun with-package-iterator-all (packages) - (test-with-package-iterator packages :internal :external :inherited)) - -(defun num-external-symbols-in-package (p) - (let ((num 0)) - (declare (fixnum num)) - (do-external-symbols (s p num) - (declare (ignorable s)) - (incf num)))) - -(defun external-symbols-in-package (p) - (let ((symbols nil)) - (do-external-symbols (s p) - (push s symbols)) - (sort symbols #'(lambda (s1 s2) (string< (symbol-name s1) - (symbol-name s2)))))) - -(defun num-symbols-in-package (p) - (let ((num 0)) - (declare (fixnum num)) - (do-symbols (s p num) - (declare (ignorable s)) - (incf num)))) - -(defun sort-symbols (sl) - (sort (copy-list sl) - #'(lambda (x y) - (or - (string< (symbol-name x) - (symbol-name y)) - (and (string= (symbol-name x) - (symbol-name y)) - (string< (package-name (symbol-package x)) - (package-name (symbol-package y)))))))) - -(defun sort-package-list (x) - (sort (copy-list x) - #'string< - :key #'package-name)) diff --git a/t/ansi-test/auxiliary/packages00-aux.lsp b/t/ansi-test/auxiliary/packages00-aux.lsp deleted file mode 100644 index 5e2ecfd..0000000 --- a/t/ansi-test/auxiliary/packages00-aux.lsp +++ /dev/null @@ -1,68 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 25 08:07:31 1998 -;;;; Contains: Package test code (common code) - - -(declaim (optimize (safety 3))) - -(report-and-ignore-errors - (defpackage "A" - (:use) - (:nicknames "Q") - (:export "FOO"))) - -(report-and-ignore-errors - (defpackage "B" - (:use "A") - (:export "BAR"))) - -(defun set-up-packages () - (safely-delete-package "A") - (safely-delete-package "B") - (safely-delete-package "Q") - (defpackage "A" - (:use) - (:nicknames "Q") - (:export "FOO")) - (defpackage "B" - (:use "A") - (:export "BAR"))) - -(report-and-ignore-errors - (defpackage "FS-A" - (:use) - (:nicknames "FS-Q") - (:export "FOO"))) - -(report-and-ignore-errors - (defpackage "FS-B" - (:use "FS-A") - (:export "BAR"))) - -(report-and-ignore-errors - (defpackage "DS1" - (:use) - (:intern "C" "D") - (:export "A" "B"))) - -(report-and-ignore-errors - (defpackage "DS2" - (:use) - (:intern "E" "F") - (:export "G" "H" "A"))) - -(report-and-ignore-errors - (defpackage "DS3" - (:shadow "B") - (:shadowing-import-from "DS1" "A") - (:use "DS1" "DS2") - (:export "A" "B" "G" "I" "J" "K") - (:intern "L" "M"))) - -(report-and-ignore-errors - (defpackage "DS4" - (:shadowing-import-from "DS1" "B") - (:use "DS1" "DS3") - (:intern "X" "Y" "Z") - (:import-from "DS2" "F"))) diff --git a/t/ansi-test/auxiliary/pathnames-aux.lsp b/t/ansi-test/auxiliary/pathnames-aux.lsp deleted file mode 100644 index f203b8d..0000000 --- a/t/ansi-test/auxiliary/pathnames-aux.lsp +++ /dev/null @@ -1,25 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Dec 6 15:05:05 2003 -;;;; Contains: Functions associated with pathname tests - - - -(defun could-be-pathname-designator (x) - (or (stringp x) - (pathnamep x) - (typep x 'file-stream) - (and (typep x 'synonym-stream) - (could-be-pathname-designator - (symbol-value - (synonym-stream-symbol x)))))) - -(defun explode-pathname (pn) - (list - :host (pathname-host pn) - :device (pathname-device pn) - :directory (pathname-directory pn) - :name (pathname-name pn) - :type (pathname-type pn) - :version (pathname-version pn))) - diff --git a/t/ansi-test/auxiliary/printer-aux.lsp b/t/ansi-test/auxiliary/printer-aux.lsp deleted file mode 100644 index d1b3db0..0000000 --- a/t/ansi-test/auxiliary/printer-aux.lsp +++ /dev/null @@ -1,451 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Feb 23 06:20:00 2004 -;;;; Contains: Auxiliary functions and macros for printer tests - - - -(eval-when (:compile-toplevel :load-toplevel :execute) - (compile-and-load "ANSI-TESTS:AUX;random-aux.lsp")) - -(defmacro def-print-test (name form result &rest bindings) - `(deftest ,name - (if (equalpt - (my-with-standard-io-syntax - (let ((*print-readably* nil)) - (let ,bindings - (with-output-to-string (*standard-output*) (prin1 ,form))))) - ,result) - t - ,result) - t)) - -(defmacro def-pprint-test - (name form expected-value - &key - (margin 100) - (miser nil) - (circle nil) - (len nil) - (pretty t) - (escape nil) - (readably nil) - (package (find-package "CL-TEST"))) - `(deftest ,name - (with-standard-io-syntax - (let ((*print-pretty* ,pretty) - (*print-escape* ,escape) - (*print-readably* ,readably) - (*print-right-margin* ,margin) - (*package* ,package) - (*print-length* ,len) - (*print-miser-width* ,miser) - (*print-circle* ,circle)) - ,form)) - ,expected-value)) - -(defmacro def-ppblock-test (name form expected-value &rest key-args) - `(def-pprint-test ,name - (with-output-to-string - (*standard-output*) - (pprint-logical-block (*standard-output* nil) ,form)) - ,expected-value - ,@key-args)) - -;;; Function to test readable of printed forms, under random settings -;;; of various printer control variables. -;;; -;;; Return NIL if obj printed and read properly, or a list containing -;;; the object and the printer variable bindings otherwise. They key -;;; argument TEST is used to compared the reread object and obj. - -(defvar *random-read-check-debug* nil - "When set to true, RANDOMLY-CHECK-READABILITY will dump out parameter - settings before trying a test. This is intended for cases where the - error that occurs is fatal.") - -(defun randomly-check-readability (obj &key - (can-fail nil) - (test #'equal) - (readable t) - (circle nil circle-p) - (escape nil escape-p) - (gensym nil gensym-p) - (debug *random-read-check-debug*)) - (declare (type function test)) - ;; Generate random printer-control values - (my-with-standard-io-syntax - (let ((*print-array* (coin)) - (*print-base* (+ 2 (random 34))) - (*print-radix* (coin)) - (*print-case* (random-from-seq #(:upcase :downcase :capitalize))) - (*print-circle* (if circle-p circle (coin))) - (*print-escape* (if escape-p escape (coin))) - (*print-gensym* (if gensym-p gensym (coin))) - (*print-level* (random 50)) - (*print-length* (if readable (random 50) nil)) - (*print-lines* (if readable (random 50) nil)) - (*print-miser-width* (and (coin) (random 100))) - (*print-pretty* (coin)) - (*print-right-margin* (and (coin) (random 100))) - (*print-readably* readable) - (*read-default-float-format* (rcase (1 'short-float) (1 'single-float) - (1 'double-float) (1 'long-float) - (1 *read-default-float-format*))) - (*readtable* (copy-readtable)) - (readcase (random-from-seq #(:upcase :downcase :preserve :invert))) - ) - (flet ((%params () - (list (list '*print-readably* *print-readably*) - (list '*print-array* *print-array*) - (list '*print-base* *print-base*) - (list '*print-radix* *print-radix*) - (list '*print-case* *print-case*) - (list '*print-circle* *print-circle*) - (list '*print-escape* *print-escape*) - (list '*print-gensym* *print-gensym*) - (list '*print-level* *print-level*) - (list '*print-length* *print-length*) - (list '*print-lines* *print-lines*) - (list '*print-miser-width* *print-miser-width*) - (list '*print-pretty* *print-pretty*) - (list '*print-right-margin* *print-right-margin*) - (list '*read-default-float-format* *read-default-float-format*) - (list 'readtable-case readcase)))) - (when debug - (let ((params (%params))) - (with-standard-io-syntax (format *debug-io* "~%~A~%" params))) - (finish-output *debug-io*)) - - (setf (readtable-case *readtable*) readcase) - (let* ((str (handler-case - (with-output-to-string (s) (write obj :stream s)) - (print-not-readable - () - (if can-fail - (return-from randomly-check-readability nil) - ":print-not-readable-error")))) - (obj2 (let ((*read-base* *print-base*)) - (handler-case - (let ((*readtable* (if *print-readably* - (copy-readtable nil) - *readtable*))) - (read-from-string str)) - (reader-error () :reader-error) - (end-of-file () :end-of-file) - (stream-error () :stream-error) - (file-error () :file-error) - )))) - (unless (funcall test obj obj2) - (list - (list* obj str obj2 (%params) - )))))))) - -(defun parse-escaped-string (string) - "Parse a string into a list of either characters (representing - themselves unescaped) or lists ( :escape) (representing - escaped characters.)" - (assert (stringp string) () "Not a string: ~A" string) - (let ((result nil) - (len (length string)) - (index 0)) - (prog - () - normal ; parsing in normal mode - (when (= index len) (return)) - (let ((c (elt string index))) - (cond ((eql c #\\) - (assert (< (incf index) len) - () - "End of string after \\") - (push `(,(elt string index) :escaped) result) - (incf index) - (go normal)) - ((eql c #\|) - (incf index) - (go multiple-escaped)) - (t (push c result) - (incf index) - (go normal)))) - - multiple-escaped ; parsing inside |s - (assert (< index len) () "End of string inside |") - (let ((c (elt string index))) - (cond ((eq c #\|) - (incf index) - (go normal)) - (t - (push `(,c :escaped) result) - (incf index) - (go multiple-escaped))))) - (nreverse result))) - -(defun escaped-equal (list1 list2) - "Determine that everything escaped in list1 is also escaped - in list2, and that the characters are also the same." - (and (= (length list1) (length list2)) - (loop for e1 in list1 - for e2 in list2 - for is-escaped1 = (and (consp e1) (eq (cadr e1) :escaped)) - for is-escaped2 = (and (consp e2) (eq (cadr e2) :escaped)) - for c1 = (if is-escaped1 (car e1) e1) - for c2 = (if is-escaped2 (car e2) e2) - always - (and (if is-escaped1 is-escaped2 t) - (char= c1 c2))))) - -(defun similar-uninterned-symbols (s1 s2) - (and (symbolp s1) - (symbolp s2) - (null (symbol-package s1)) - (null (symbol-package s2)) - (string= (symbol-name s1) - (symbol-name s2)))) - -(defun make-random-cons-tree (size) - (if (<= size 1) - (rcase - (5 nil) - (1 (random 1000)) - (1 (random 1000.0)) - (2 (random-from-seq #(a b c d e f g |1| |2| |.|)))) - (let ((s1 (1+ (random (1- size))))) - (cons (make-random-cons-tree s1) - (make-random-cons-tree (- size s1)))))) - -(defun make-random-vector (size) - (if (> size 1) - (let* ((nelems (min (1- size) (1+ (random (max 2 (floor size 4)))))) - (sizes (mapcar #'1+ (random-partition* (- size nelems 1) nelems)))) - (make-array nelems :initial-contents (mapcar #'make-random-vector sizes))) - (rcase - (1 (random-from-seq #(a b c d e f g))) - (1 (- (random 2001) 1000)) - (1 (random 1000.0)) - ))) - -;;; Random printing test for WRITE and related functions - -(defun funcall-with-print-bindings - (fun &key - ((:array *print-array*) *print-array*) - ((:base *print-base*) *print-base*) - ((:case *print-case*) *print-case*) - ((:circle *print-circle*) *print-circle*) - ((:escape *print-escape*) *print-escape*) - ((:gensym *print-gensym*) *print-gensym*) - ((:length *print-length*) *print-length*) - ((:level *print-level*) *print-level*) - ((:lines *print-lines*) *print-lines*) - ((:miser-width *print-miser-width*) *print-miser-width*) - ((:pprint-dispatch *print-pprint-dispatch*) *print-pprint-dispatch*) - ((:pretty *print-pretty*) *print-pretty*) - ((:radix *print-radix*) *print-radix*) - ((:readably *print-readably*) *print-readably*) - ((:right-margin *print-right-margin*) *print-right-margin*) - ((:stream *standard-output*) *standard-output*)) - (funcall fun)) - -(defun output-test - (obj &key - (fun #'write) - ((:array *print-array*) *print-array*) - ((:base *print-base*) *print-base*) - ((:case *print-case*) *print-case*) - ((:circle *print-circle*) *print-circle*) - ((:escape *print-escape*) *print-escape*) - ((:gensym *print-gensym*) *print-gensym*) - ((:length *print-length*) *print-length*) - ((:level *print-level*) *print-level*) - ((:lines *print-lines*) *print-lines*) - ((:miser-width *print-miser-width*) *print-miser-width*) - ((:pprint-dispatch *print-pprint-dispatch*) *print-pprint-dispatch*) - ((:pretty *print-pretty*) *print-pretty*) - ((:radix *print-radix*) *print-radix*) - ((:readably *print-readably*) *print-readably*) - ((:right-margin *print-right-margin*) *print-right-margin*) - ((:stream *standard-output*) *standard-output*)) - (let ((results (multiple-value-list (funcall fun obj)))) - (assert (= (length results) 1)) - (assert (eql (car results) obj)) - obj)) - -(defun make-random-key-param (name) - (rcase (1 nil) - (1 `(,name nil)) - (1 `(,name t)))) - -(defun make-random-key-integer-or-nil-param (name bound) - (rcase (1 nil) - (1 `(,name nil)) - (1 `(,name ,(random bound))))) - -(defun make-random-write-args () - (let* ((arg-lists `(,@(mapcar #'make-random-key-param - '(:array :circle :escape :gensym :pretty :radix :readably)) - ,(rcase (1 nil) - (1 `(:base ,(+ 2 (random 35))))) - ,(and (coin) - `(:case ,(random-from-seq #(:upcase :downcase :capitalize)))) - ,@(mapcar #'make-random-key-integer-or-nil-param - '(:length :level :lines :miser-width :right-margin) - '(100 20 50 200 200))))) - (reduce #'append (random-permute arg-lists) :from-end t))) - -(defun filter-unreadable-forms (string) - "Find #<...> strings and replace with #<>." - (let ((len (length string)) - (pos 0)) - (loop while (< pos len) - do (let ((next (search "#<" string :start2 pos))) - (unless next (return string)) - (let ((end (position #\> string :start next))) - (unless end (return string)) - (setq string - (concatenate 'string - (subseq string 0 next) - "#<>" - (subseq string (1+ end))) - pos (+ next 3) - len (+ len (- next end) 3))))))) - - -(defmacro def-random-write-test-fun (name write-args test-fn - &key - (prefix "") - (suffix "")) - `(defun ,name (n &key (size 10)) - (loop - for args = (make-random-write-args) - for package = (find-package (random-from-seq #("CL-TEST" "CL-USER" "KEYWORD"))) - for obj = (let ((*random-readable* t)) - (declare (special *random-readable*)) - (random-thing (random size))) - for s1 = (let ((*package* package)) - (with-output-to-string (s) (apply #'write obj :stream s ,@write-args args))) - for s2 = (let ((*package* package)) - (with-output-to-string - (*standard-output*) - (apply #'output-test obj :fun ,test-fn args))) - repeat n - ;; We filter the contents of #<...> forms since they may change with time - ;; if they contain object addresses. - unless (string= (filter-unreadable-forms (concatenate 'string ,prefix s1 ,suffix)) - (filter-unreadable-forms s2)) - collect (list obj s1 s2 args)))) - -(def-random-write-test-fun random-write-test nil #'write) -(def-random-write-test-fun random-prin1-test (:escape t) #'prin1) -(def-random-write-test-fun random-princ-test (:escape nil :readably nil) #'princ) -(def-random-write-test-fun random-print-test (:escape t) #'print :prefix (string #\Newline) :suffix " ") -(def-random-write-test-fun random-pprint-test (:escape t :pretty t) - #'(lambda (obj) (assert (null (multiple-value-list (pprint obj)))) obj) - :prefix (string #\Newline)) - -(defmacro def-random-write-to-string-test-fun (name write-args test-fn - &key - (prefix "") - (suffix "")) - `(defun ,name (n) - (loop - for args = (make-random-write-args) - for package = (find-package (random-from-seq #("CL-TEST" "CL-USER" "KEYWORD"))) - for obj = (let ((*random-readable* t)) - (declare (special *random-readable*)) - (random-thing (random 10))) - for s1 = (let ((*package* package)) - (with-output-to-string (s) (apply #'write obj :stream s ,@write-args args))) - for s2 = (let ((*package* package)) - (apply ,test-fn obj args)) - repeat n - unless (string= (filter-unreadable-forms (concatenate 'string ,prefix s1 ,suffix)) - (filter-unreadable-forms s2)) - collect (list obj s1 s2)))) - -(def-random-write-to-string-test-fun random-write-to-string-test nil #'write-to-string) -(def-random-write-to-string-test-fun random-prin1-to-string-test (:escape t) - #'(lambda (obj &rest args) - (apply #'funcall-with-print-bindings #'(lambda () (prin1-to-string obj)) args))) -(def-random-write-to-string-test-fun random-princ-to-string-test (:escape nil :readably nil) - #'(lambda (obj &rest args) - (apply #'funcall-with-print-bindings #'(lambda () (princ-to-string obj)) args))) - -;;; Routines for testing floating point printing - -(defun decode-fixed-decimal-string (s) - "Return a rational equal to the number represented by a decimal floating - (without exponent). Trim off leading/trailing spaces." - - (setq s (string-trim " " s)) - (assert (> (length s) 0)) - (let (neg) - (when (eql (elt s 0) #\-) - (setq s (subseq s 1)) - (setq neg t)) - ;; Check it's of the form {digits}.{digits} - (let ((dot-pos (position #\. s))) - (assert dot-pos) - (let ((prefix (subseq s 0 dot-pos)) - (suffix (subseq s (1+ dot-pos)))) - (assert (every #'digit-char-p prefix)) - (assert (every #'digit-char-p suffix)) - (let* ((prefix-len (length prefix)) - (prefix-integer (if (eql prefix-len 0) - 0 - (parse-integer prefix))) - (suffix-len (length suffix)) - (suffix-integer (if (eql suffix-len 0) - 0 - (parse-integer suffix))) - (magnitude (+ prefix-integer - (* suffix-integer (expt 1/10 suffix-len))))) - (if neg (- magnitude) magnitude)))))) - - -;;; Macro to define both FORMAT and FORMATTER tests - -(defmacro def-format-test (name string args expected-output &optional (num-left 0)) - (assert (symbolp name)) - (let* ((s (symbol-name name)) - (expected-prefix (string 'format.)) - (expected-prefix-length (length expected-prefix))) - (assert (>= (length s) expected-prefix-length)) - (assert (string-equal (subseq s 0 expected-prefix-length) - expected-prefix)) - (let* ((formatter-test-name-string - (concatenate 'string (string 'formatter.) - (subseq s expected-prefix-length))) - (formatter-test-name (intern formatter-test-name-string - (symbol-package name))) - (formatter-form (if (stringp string) - `(formatter ,string) - (list 'formatter (eval string))))) - `(progn - (deftest ,name - (with-standard-io-syntax - (let ((*print-readably* nil) - (*package* (symbol-package 'ABC))) - (format nil ,string ,@args))) - ,expected-output) - (deftest ,formatter-test-name - (let ((fn ,formatter-form) - (args (list ,@args))) - (with-standard-io-syntax - (let ((*print-readably* nil) - (*package* (symbol-package 'ABC))) - (with-output-to-string - (stream) - (let ((tail (apply fn stream args))) - ;; FIXME -- Need to check that TAIL really is a tail of ARGS - (assert (= (length tail) ,num-left) (tail) "Tail is ~A, length should be ~A" - tail ,num-left) - ))))) - ,expected-output))))) - -;;; Macro used for an idiom in testing FORMATTER calls - -(defmacro formatter-call-to-string (fn &body args) - (let ((stream (gensym "S"))) - `(with-output-to-string - (,stream) - (assert (equal (funcall ,fn ,stream ,@args 'a) '(a)))))) diff --git a/t/ansi-test/auxiliary/random-aux.lsp b/t/ansi-test/auxiliary/random-aux.lsp deleted file mode 100644 index 4135ea2..0000000 --- a/t/ansi-test/auxiliary/random-aux.lsp +++ /dev/null @@ -1,304 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jun 8 06:56:15 2003 -;;;; Contains: Aux. functions and macros used for randomization - - - -(declaim (special +standard-chars+ *cl-symbols-vector*)) - -(defvar *maximum-random-int-bits* - (max 36 (1+ (integer-length most-positive-fixnum)))) - -(defun random-from-seq (seq) - "Generate a random member of a sequence." - (let ((len (length seq))) - (assert (> len 0)) - (elt seq (random len)))) - -(defmacro random-case (&body cases) - (let ((len (length cases))) - (assert (> len 0)) - `(case (random ,len) - ,@(loop for i from 0 for e in cases collect `(,i ,e)) - (t (error "Can't happen?! (in random-case)~%"))))) - -(defmacro rcase (&body cases) - "Usage: (RCASE (
+)+), where is a positive real - indicating the relative probability of executing the associated implicit - progn." - (assert cases) - (let* ((weights (mapcar #'car cases)) - (cumulative-weights (let ((sum 0)) - (loop for w in weights collect (incf sum w)))) - (total (car (last cumulative-weights))) - (r (gensym))) - (assert (every #'plusp weights)) - (when (typep total 'ratio) (setf total (coerce total 'double-float))) - `(let ((,r (random ,total))) - (cond - ,@(loop for case in (butlast cases) - for cw in cumulative-weights - collect `((< ,r ,cw) ,@(cdr case))) - (t ,@(cdar (last cases))))))) - -(defmacro rselect (cumulative-frequency-array &rest cases) - (let ((len (length cases)) - (a (gensym "A")) - (max (gensym "MAX")) - (r (gensym "R")) - (p (gensym "P")) - (done (gensym "DONE"))) - (assert (> len 0)) - `(let ((,a ,cumulative-frequency-array)) - (assert (eql ,len (length ,a))) - (let* ((,max (aref ,a ,(1- len))) - (,r (random ,max))) - (block ,done - ,@(loop for i from 0 - for c in cases - collect - `(let ((,p (aref ,a ,i))) - (when (< ,r ,p) (return-from ,done ,c)))) - (error "Should not happen!")))))) - -(defun make-random-integer-range (&optional var) - "Generate a list (LO HI) of integers, LO <= HI. This is used - for generating integer types." - (declare (ignore var)) - (rcase - (1 (flet ((%r () (let ((r (ash 1 (1+ (random *maximum-random-int-bits*))))) - (- (random r) (floor (/ r 2)))))) - (let ((x (%r)) - (y (%r))) - (list (min x y) (max x y))))) - (1 (let* ((b (ash 1 (1+ (random *maximum-random-int-bits*)))) - (b2 (floor (/ b 2)))) - (let ((x (- (random b) b2)) - (y (- (random b) b2))) - (list (min x y) (max x y))))))) - -(defun random-nonnegative-real () - (if (coin 3) - (random-case - (/ (random 10000) (1+ (random 1000))) - (/ (random 1000000) (1+ (random 100000))) - (/ (random 100000000) (1+ (random 10000000))) - (/ (random 1000000000000) (1+ (random 10000000)))) - (random (random-case - 1000 - 100000 - 10000000 - 1000000000 - (expt 2.0s0 (random 15)) - (expt 2.0f0 (random 32)) - (expt 2.0d0 (random 32)) - (expt 2.0l0 (random 32)))))) - -(defun make-random-integer () - (let ((r (ash 1 (1+ (random *maximum-random-int-bits*))))) - (rcase - (6 (- (random r) (floor (/ r 2)))) - (1 (- r (random (min 10 r)))) - (1 (+ (floor (/ r 2)) (random (min 10 r))))))) - -(defun make-random-rational () - (let* ((r (ash 1 (1+ (random *maximum-random-int-bits*)))) - (n (random r))) - (assert (>= r 2)) - (let ((d (loop for x = (random r) unless (zerop x) do (return x)))) - (if (coin) (/ n d) (- (/ n d)))))) - -(defun make-random-nonnegative-rational () - (let* ((r (ash 1 (1+ (random *maximum-random-int-bits*)))) - (n (random r))) - (assert (>= r 2)) - (let ((d (loop for x = (random r) unless (zerop x) do (return x)))) - (/ n d)))) - -(defun make-random-positive-rational () - (let* ((r (ash 1 (1+ (random *maximum-random-int-bits*)))) - (n (1+ (random r)))) - (assert (>= r 2)) - (let ((d (loop for x = (random r) unless (zerop x) do (return x)))) - (/ n d)))) - -(defun make-random-bounded-rational (upper-limit lower-inclusive upper-inclusive) - (assert (rationalp upper-limit)) - (assert (not (minusp upper-limit))) - (cond - ((= upper-limit 0) 0) - ((<= upper-limit 1/1000000) - (/ (make-random-bounded-rational (* 1000000 upper-limit) lower-inclusive upper-inclusive) - 1000000)) - ((>= upper-limit 1000000) - (* (random 1000000) - (make-random-bounded-rational (/ upper-limit 1000000) lower-inclusive upper-inclusive))) - (t - (assert (< 1/1000000 upper-limit 1000000)) - (let ((x 0)) - (loop do (setq x (* upper-limit (rational (random 1.0)))) - while (or (and (not lower-inclusive) (zerop x)) - (and (not upper-inclusive) (= x upper-limit))) - finally (return x)))))) - -(defun make-random-float () - (rcase - (1 (random most-positive-short-float)) - (1 (random most-positive-single-float)) - (1 (random most-positive-double-float)) - (1 (random most-positive-long-float)))) - -(defun make-random-symbol () - (rcase - (3 (random-from-seq #(a b c d e f g h i j k l m n o p q r s t u v w x y z))) - (2 (random-from-seq *cl-symbols-vector*)) - (1 (gensym)))) - -(defun random-real () - (if (coin) (random-nonnegative-real) - (- (random-nonnegative-real)))) - -(defun random-fixnum () - (+ (random (1+ (- most-positive-fixnum most-negative-fixnum))) - most-negative-fixnum)) - -(defun random-thing (n) - (if (<= n 1) - (random-leaf) - (rcase - (1 (apply #'cons (mapcar #'random-thing (random-partition (1- n) 2)))) - (1 (apply #'vector (mapcar #'random-thing - (random-partition (1- n) (max 10 (1- n)))))) - ))) - -(defparameter *use-random-byte* t) -(defparameter *random-readable* nil) - -(defun make-random-string (size-spec &key simple) - (let* - ((size (if (eql size-spec '*) (random 30) size-spec)) - (use-random-byte nil) - (etype 'character) - (s (random-case - (progn - (setf use-random-byte *use-random-byte*) - (make-string size :element-type 'character)) - (progn - (setf use-random-byte *use-random-byte*) - (make-array size :element-type 'character - :initial-element #\a)) - (make-array size :element-type (setf etype (if *random-readable* 'character 'standard-char)) - :adjustable (and (not simple) (not *random-readable*) (rcase (3 nil) (1 t))) - :fill-pointer (and (not simple) (not *random-readable*) (rcase (3 nil) (1 (random (1+ size))))) - :initial-element #\a) - (make-array size :element-type (setf etype (if *random-readable* 'character 'base-char)) - :adjustable (and (not simple) (not *random-readable*) (rcase (3 nil) (1 t))) - :fill-pointer (and (not simple) (not *random-readable*) (rcase (3 nil) (1 (random (1+ size))))) - :initial-element #\a)))) - (if (coin) - (dotimes (i size) - (setf (char s i) (elt #(#\a #\b #\A #\B) (random 4)))) - (dotimes (i size) - (setf (char s i) - (or (and (eql etype 'character) - use-random-byte - (or (code-char (random (min char-code-limit (ash 1 16)))) - (code-char (random 256)))) - (elt "abcdefghijklmnopqrstuvwyxzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" - (random 62)))))) - (when (and (not simple) (not *random-readable*) (coin 5)) - (let ((len (+ (random (1+ size)) size))) - (setq s (make-random-string len)) - (setq etype (array-element-type s)) - (setq s (make-array size - :element-type etype - :displaced-to s - :displaced-index-offset (random (1+ (- len size))))))) - - s)) - -(defun random-leaf () - (rcase - (1 (let ((k (ash 1 (1+ (random 40))))) - (random-from-interval k (- k)))) - (1 (random-from-seq +standard-chars+)) - (1 (random-real)) - (1 (make-random-string (random 20))) - (1 (gensym)) - (1 (make-symbol (make-random-string (random 20)))) - (1 (random-from-seq *cl-symbols-vector*)))) - -(defun random-from-interval (upper &optional (lower (- upper))) - (+ (random (- upper lower)) lower)) - -(defun coin (&optional (n 2)) - "Flip an n-sided coin." - (eql (random n) 0)) - -;;; Randomly permute a sequence -(defun random-permute (seq) - (setq seq (copy-seq seq)) - (let ((len (length seq))) - (loop for i from len downto 2 - do (let ((r (random i))) - (rotatef (elt seq r) (elt seq (1- i)))))) - seq) - -(defun binomial-distribution-test (n fn) - (let* ((count (loop repeat n count (funcall fn))) - (sigma (/ (sqrt n) 2.0)) - (bound (* sigma 6)) - (expected (/ n 2.0))) - (<= (- expected bound) - count - (+ expected bound)))) - -(defun random-partition* (n p) - "Partition n into p numbers, each >= 0. Return list of numbers." - (assert (<= 1 p)) - (cond - ((= p 1) (list n)) - ((= n 0) (make-list p :initial-element 0)) - (t (let* ((r (random p)) - (n1 (random (1+ n)))) - (cond - ((= r 0) - (cons n1 (random-partition* (- n n1) (1- p)))) - ((= r (1- p)) - (append (random-partition* (- n n1) (1- p)) (list n1))) - (t - (let* ((n2 (random (1+ (- n n1)))) - (n3 (- n n1 n2))) - (append (random-partition* n2 r) - (list n1) - (random-partition* n3 (- p 1 r)))))))))) - -(defun random-partition (n p) - "Partition n into p numbers, each >= 1 (if possible.)" - (cond - ((<= n p) - (make-list p :initial-element 1)) - (t (mapcar #'1+ (random-partition* (- n p) p))))) - - -;;; Random method combination -;;; Methods in this method combination take a single method qualifier, -;;; which is a positive integer. Each method is invoked -;;; with probability proportional to its qualifier. -;;; -;;; Inside a method, a throw to the symbol FAIL causes -;;; the application to repeat. This enables methods to abort -;;; and retry the random selection process. - -(defun positive-integer-qualifier-p (qualifiers) - (typep qualifiers '(cons (integer 1) null))) - -(define-method-combination randomized nil ((method-list positive-integer-qualifier-p)) - (assert method-list) - (let ((clauses (mapcar #'(lambda (method) - (let ((weight (car (method-qualifiers method)))) - `(,weight (call-method ,method)))) - method-list))) - `(loop (catch 'fail (return (rcase ,@clauses)))))) - diff --git a/t/ansi-test/auxiliary/random-class-aux.lsp b/t/ansi-test/auxiliary/random-class-aux.lsp deleted file mode 100644 index 3d53d05..0000000 --- a/t/ansi-test/auxiliary/random-class-aux.lsp +++ /dev/null @@ -1,36 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Oct 10 07:14:30 2004 -;;;; Contains: Aux. functions for random tests on classes - - - -(defun random-class-1-fn (&key (n 10) (rep 1000)) - "Randomly break and recreate a linear chain of class definitions" - (assert (typep n '(integer 1)) (n) "N is ~A" n) - (assert (typep rep 'unsigned-byte) (rep) "REP is ~A" rep) - (let ((class-names (make-array n - :initial-contents - (loop for i from 1 to n - collect (make-symbol - (format nil "CLASS-NAME-~D" i)))))) - (unwind-protect - (let ((parents (make-array n :initial-element nil))) - ;; Create classes - (loop for name across class-names - do (eval `(defclass ,name () nil))) - (loop for i = (1+ (random (1- n))) - for name = (elt class-names i) - for parent = (elt parents i) - repeat rep - do (if parent - (progn - (setf (elt parents i) nil) - (eval `(defclass ,name () nil))) - (eval `(defclass ,name - (,(setf (elt parents i) (elt class-names (1- i)))) - nil - ))))) - (loop for name across class-names - do (setf (find-class name) nil))))) - diff --git a/t/ansi-test/auxiliary/reader-aux.lsp b/t/ansi-test/auxiliary/reader-aux.lsp deleted file mode 100644 index c84ed28..0000000 --- a/t/ansi-test/auxiliary/reader-aux.lsp +++ /dev/null @@ -1,49 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Jan 14 07:43:48 2005 -;;;; Contains: Auxiliary functions and macros for reader tests - - - -;;; Define a test using standard io syntax - -(defmacro def-syntax-test (name form &body expected-results) - `(deftest ,name - (with-standard-io-syntax (let ((*package* (find-package :cl-test))) ,form)) - ,@expected-results)) - -;;; Macros for testing specific features - -(defmacro def-syntax-vector-test (name form &body expected-elements) - `(def-syntax-test ,name - (let ((v (read-from-string ,form))) - (assert (simple-vector-p v)) - v) - ,(apply #'vector expected-elements))) - -(defmacro def-syntax-bit-vector-test (name form &body expected-elements) - `(def-syntax-test ,name - (let ((v (read-from-string ,form))) - (assert (simple-bit-vector-p v)) - v) - ,(make-array (length expected-elements) :element-type 'bit :initial-contents expected-elements))) - -(defmacro def-syntax-unintern-test (name string) - `(deftest ,name - (let ((s (read-from-string ,(concatenate 'string "#:" string)))) - (values - (symbol-package s) - (symbol-name s))) - nil ,(string-upcase string))) - -(defmacro def-syntax-array-test (name form expected-result) - `(def-syntax-test ,name - (let ((v (read-from-string ,form))) - (assert (typep v 'simple-array)) - (assert (not (array-has-fill-pointer-p v))) - (assert (eql (array-element-type v) - (upgraded-array-element-type t))) - v) - ,(eval expected-result))) - - diff --git a/t/ansi-test/auxiliary/remove-aux.lsp b/t/ansi-test/auxiliary/remove-aux.lsp deleted file mode 100644 index 326b965..0000000 --- a/t/ansi-test/auxiliary/remove-aux.lsp +++ /dev/null @@ -1,297 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Sep 15 07:42:36 2002 -;;;; Contains: Auxiliary functions for testing REMOVE and related functions - - - -(defun make-random-element (type) - (cond - ((subtypep* 'fixnum type) - (random most-positive-fixnum)) - ((and (listp type) - (eql (car type) 'integer) - (integerp (cadr type)) - (integerp (caddr type)) - (null (cdddr type))) - (+ (cadr type) (random (- (1+ (caddr type)) (cadr type))))) - ((subtypep* '(integer 0 255) type) - (random 255)) - ((subtypep* '(integer 0 7) type) - (random 8)) - ((subtypep* 'bit type) - (random 2)) - ((subtypep* 'symbol type) - (elt '(a b c d e f g h) (random 8))) - ((subtypep* '(member #\a #\b #\c #\d #\e #\f #\g #\h) type) - (elt "abcdefgh" (random 8))) - (t (error "Can't get random element of type ~A~%." type)))) - -(defun make-random-remove-input (len type element-type) - - "Randomly generate a test case for REMOVE. Given a length - a sequence type, and an element type, produce a random - sequence of length LEN of sequence type TYPE, and either - generate a random member of the sequence or a random - element of the element type to delete from the sequence." - - (let* ((seq (if (subtypep* type 'list) - (loop for i from 1 to len collect - (make-random-element element-type)) - (let ((seq (if (and (subtypep type 'vector) - (coin 3)) - (make-array - (list (+ len (random (1+ len)))) - :initial-element (make-random-element element-type) - :fill-pointer len - :element-type element-type) - (make-sequence type len)))) - (dotimes (i len) - (setf (elt seq i) (make-random-element element-type))) - seq))) - (e (if (and (> len 0) (coin)) - (elt seq (random len)) - (make-random-element element-type))) - ) - (values len seq e))) - -(defun my-remove (element - sequence - &key - (start 0) - (end nil) - (test #'eql test-p) - (test-not nil test-not-p) - (key nil) - (from-end nil) - (count nil)) - (assert (not (and test-p test-not-p))) - (my-remove-if - (cond (test-p - (setf test (coerce test 'function)) - #'(lambda (x) (funcall (the function test) element x))) - (test-not-p - (setf test-not (coerce test-not 'function)) - #'(lambda (x) (not (funcall (the function test-not) element x)))) - (t #'(lambda (x) (eql element x)))) - sequence :start start :end end :key key :from-end from-end :count count)) - -(defun my-remove-if (predicate - original-sequence - &key (from-end nil) - (start 0) - (end nil) - (count nil) - (key #'identity)) - (let ((len (length original-sequence)) - (sequence (copy-seq original-sequence))) - (unless end (setq end len)) - (unless key (setq key #'identity)) - (unless count (setq count len)) - - ;; Check that everything's kosher - (assert (<= 0 start end len)) - (assert (typep sequence 'sequence)) - (assert (integerp count)) - (assert (or (symbolp predicate) (functionp predicate))) - (assert (or (symbolp key) (functionp key))) - - (setf predicate (coerce predicate 'function)) - (setf key (coerce key 'function)) - - ;; If FROM-END, reverse the sequence and flip - ;; start, end - (when from-end - (psetq sequence (nreverse sequence) - start (- len end) - end (- len start))) - - ;; Accumulate a list of elements for the result - (let ((pos 0) - (result nil)) ;; accumulate in reverse order - (map nil - #'(lambda (e) - (if (and (> count 0) - (>= pos start) - (< pos end) - (funcall (the function predicate) - (funcall (the function key) e))) - (decf count) - (push e result)) - (incf pos)) - sequence) - (unless from-end - (setq result (nreverse result))) - ;; Convert to the correct type - (if (listp sequence) - result - (let ((element-type (array-element-type original-sequence))) - (make-array (length result) :element-type element-type - :initial-contents result)))))) - -(defun my-remove-if-not (pred &rest args) - (when (symbolp pred) - (setq pred (coerce pred 'function))) - (assert (typep pred 'function)) - (apply #'my-remove-if (complement pred) args)) - -(defun make-random-rd-params (maxlen) - "Generate random paramaters for remove/delete/etc. functions." - (let* ((element-type - (rcase - (2 t) - (1 'bit) - (1 '(integer 0 2)) - (1 'symbol))) - (type-select (random 7)) - (type - (case type-select - (0 'list) - (1 'vector) - (2 (setq element-type 'character) 'string) - (3 (setq element-type 'bit) 'bit-vector) - (4 'simple-vector) - (5 (setq element-type '(integer 0 255)) - '(vector (integer 0 255))) - (6 (setq element-type 'fixnum) '(vector fixnum)) - (t (error "Can't happen?!~%")))) - (len (random maxlen)) - (start (and (coin) (> len 0) - (random len))) - (end (and (coin) - (if start (+ start (random (- len start))) - (random (1+ len))))) - (from-end (coin)) - (count (case (random 5) - ((0 1) nil) - ((2 3) (random (1+ len))) - (t (if (coin) -1 -10000000000000)))) - (seq (multiple-value-bind (x y z) (make-random-remove-input len type element-type) - (declare (ignore x z)) - y)) - (key (and (coin) - (case type-select - (2 (random-case - #'char-upcase 'char-upcase - #'char-downcase 'char-downcase)) - (3 #'(lambda (x) (- 1 x))) - ((5 6) (random-case #'1+ '1+ #'1- '1-)) - (t (random-case 'identity #'identity))))) - (test (and (eql (random 3) 0) - (random-case 'eq 'eql 'equal - #'eq #'eql #'equal))) - (test-not (and (not test) - (coin) - (random-case 'eq 'eql 'equal - #'eq #'eql #'equal))) - ) - ;; Return parameters - (values - element-type type len start end from-end count seq key test test-not))) - -(defun random-test-remove-args (maxlen) - (multiple-value-bind (element-type type len start end from-end count seq key test test-not) - (make-random-rd-params maxlen) - (declare (ignore type)) - (let ((element (if (and (coin) (> len 0)) - (random-from-seq seq) - (make-random-element element-type))) - (arg-list - (reduce #'nconc - (random-permute - (list - (when start (list :start start)) - (cond (end (list :end end)) - ((coin) (list :end nil))) - (cond (from-end (list :from-end from-end)) - ((coin) (list :from-end nil))) - (cond (count (list :count count)) - ((coin) (list :count nil))) - (cond (key (list :key key)) - ;; ((coin) (list :key nil)) - ) - (when test (list :test test)) - (when test-not (list :test test-not))))))) - (values element seq arg-list)))) - -(defparameter *remove-fail-args* nil) - -(defun random-test-remove (maxlen &key (tested-fn #'remove) - (check-fn #'my-remove) - (pure t)) - (setf tested-fn (coerce tested-fn 'function)) - (setf check-fn (coerce check-fn 'function)) - (multiple-value-bind (element seq arg-list) - (random-test-remove-args maxlen) - (let* ((seq1 (copy-seq seq)) - (seq2 (copy-seq seq)) - (seq1r (apply (the function tested-fn) element seq1 arg-list)) - (seq2r (apply (the function check-fn) element seq2 arg-list))) - (setq *remove-fail-args* (list* element seq arg-list)) - (cond - ((and pure (not (equalp seq seq1))) :fail1) - ((and pure (not (equalp seq seq2))) :fail2) - ((not (equalp seq1r seq2r)) :fail3) - (t t))))) - -(defun random-test-remove-if (maxlen &optional (negate nil)) - (multiple-value-bind (element seq arg-list) - (random-test-remove-args maxlen) - (let ((fn (getf arg-list :key)) - (test (getf arg-list :test))) - (remf arg-list :key) - (remf arg-list :test) - (remf arg-list :test-not) - (unless test (setq test #'eql)) - (setf test (coerce test 'function)) - (if fn - (case (random 3) - (0 (setf arg-list (list* :key 'identity arg-list))) - (1 (setf arg-list (list* :key #'identity arg-list))) - (t nil)) - (setf fn (if (coin) 'identity - #'(lambda (x) (funcall (the function test) - element x))))) - (let* ((seq1 (copy-seq seq)) - (seq2 (copy-seq seq)) - (seq1r (apply (if negate #'remove-if-not #'remove-if) - fn seq1 arg-list)) - (seq2r (apply (if negate #'my-remove-if-not #'my-remove-if) - fn seq2 arg-list))) - (setq *remove-fail-args* (cons seq1 arg-list)) - (cond - ((not (equalp seq seq1)) :fail1) - ((not (equalp seq seq2)) :fail2) - ((not (equalp seq1r seq2r)) :fail3) - (t t)))))) - -(defun random-test-delete (maxlen) - (random-test-remove maxlen :tested-fn #'delete :pure nil)) - -(defun random-test-delete-if (maxlen &optional (negate nil)) - (multiple-value-bind (element seq arg-list) - (random-test-remove-args maxlen) - (let ((fn (getf arg-list :key)) - (test (getf arg-list :test))) - (remf arg-list :key) - (remf arg-list :test) - (remf arg-list :test-not) - (unless test (setq test #'eql)) - (setf test (coerce test 'function)) - (if fn - (case (random 3) - (0 (setf arg-list (list* :key 'identity arg-list))) - (1 (setf arg-list (list* :key #'identity arg-list))) - (t nil)) - (setf fn (if (coin) 'identity - #'(lambda (x) (funcall (the function test) element x))))) - (setq *remove-fail-args* (list* seq arg-list)) - (let* ((seq1 (copy-seq seq)) - (seq2 (copy-seq seq)) - (seq1r (apply (if negate #'delete-if-not #'delete-if) - fn seq1 arg-list)) - (seq2r (apply (if negate #'my-remove-if-not #'my-remove-if) - fn seq2 arg-list))) - (cond - ((not (equalp seq1r seq2r)) :fail3) - (t t)))))) diff --git a/t/ansi-test/auxiliary/remove-duplicates-aux.lsp b/t/ansi-test/auxiliary/remove-duplicates-aux.lsp deleted file mode 100644 index de1d5fc..0000000 --- a/t/ansi-test/auxiliary/remove-duplicates-aux.lsp +++ /dev/null @@ -1,92 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Sep 23 20:59:10 2002 -;;;; Contains: Aux. functions for testing REMOVE-DUPLICATES/DELETE-DUPLICATES - - - -(defun my-remove-duplicates (orig-sequence - &key from-end test test-not (start 0) end key) - (assert (typep orig-sequence 'sequence)) - (let* ((sequence orig-sequence) - (len (length sequence))) - (unless end (setq end len)) - (unless key (setq key #'identity)) - (setf key (coerce key 'function)) - (cond - (test (setf test (coerce test 'function)) - (assert (not test-not))) - (test-not (setf test-not (coerce test-not 'function)) - (setq test #'(lambda (x y) - (not (funcall (the function test) x y))))) - (t (setq test #'eql))) - (assert (integerp start)) - (assert (integerp end)) - (assert (<= 0 start end len)) - ;; (format t "start = ~A, end = ~A, len = ~A~%" start end len) - (if from-end - (psetq start (- len end) - end (- len start) - sequence (reverse sequence)) - (setq sequence (copy-seq sequence))) - ;; (format t "start = ~A, end = ~A, len = ~A~%" start end len) - (assert (<= 0 start end len) (start end len)) - (let ((result nil)) - (loop for i from 0 below start - do (push (elt sequence i) result)) - (loop for i from start below end - for x = (elt sequence i) - for kx = (funcall (the function key) x) - unless (position kx - sequence - :start (1+ i) - :end end - :test (the function test) - :key (the function key)) - do (push x result)) - (loop for i from end below len - do (push (elt sequence i) result)) - (unless from-end (setq result (reverse result))) - (cond - ((listp orig-sequence) result) - ((arrayp orig-sequence) - (make-array (length result) :initial-contents result - :element-type (array-element-type orig-sequence))) - (t (assert nil)))))) - -(defun make-random-rdup-params (maxlen) - "Make random input parameters for REMOVE-DUPLICATES." - (multiple-value-bind (element-type type len start end from-end - count seq key test test-not) - (make-random-rd-params maxlen) - (declare (ignore count element-type len type)) - (let ((arg-list - (reduce #'nconc - (random-permute - (list - (when start (list :start start)) - (cond (end (list :end end)) - ((coin) (list :end nil))) - (cond (from-end (list :from-end from-end)) - ((coin) (list :from-end nil))) - (cond (key (list :key key)) - ;; ((coin) (list :key nil)) - ) - (when test (list :test test)) - (when test-not (list :test test-not))))))) - (values seq arg-list)))) - -(defun random-test-remove-dups (maxlen &optional (pure t)) - (multiple-value-bind (seq arg-list) - (make-random-rdup-params maxlen) - (let* ((seq1 (copy-seq seq)) - (seq2 (copy-seq seq)) - (seq1r (apply (if pure #'remove-duplicates - #'delete-duplicates) - seq1 arg-list)) - (seq2r (apply #'my-remove-duplicates seq2 arg-list))) - (cond - ((and pure (not (equalp seq seq1))) (list :fail1 seq seq1r seq2r arg-list)) - ((and pure (not (equalp seq seq2))) (list :fail2 seq seq1r seq2r arg-list)) - ((not (equalp seq1r seq2r)) (list :fail3 seq seq1r seq2r arg-list)) - (t t))))) diff --git a/t/ansi-test/auxiliary/round-aux.lsp b/t/ansi-test/auxiliary/round-aux.lsp deleted file mode 100644 index 97756d1..0000000 --- a/t/ansi-test/auxiliary/round-aux.lsp +++ /dev/null @@ -1,113 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Aug 21 14:21:07 2003 -;;;; Contains: Aux. functions for testing ROUND - - - -(defun round.1-fn () - (loop for n = (- (random 2000000000) - 1000000000) - for d = (1+ (random 10000)) - for vals = (multiple-value-list (round n d)) - for (q r) = vals - for n2 = (+ (* q d) r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (= n n2) - (integerp r) - (<= (- (/ d 2)) r (/ d 2))) - unless (or (not (= (abs r) (/ d 2))) - (evenp q)) - collect (list n d q r n2))) - -(defun round.2-fn () - (loop for num = (random 1000000000) - for denom = (1+ (random 1000)) - for n = (/ num denom) - for d = (1+ (random 10000)) - for vals = (multiple-value-list (round n d)) - for (q r) = vals - for n2 = (+ (* q d) r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (<= (- (/ d 2)) r (/ d 2)) - (or (not (= (abs r) (/ d 2))) - (evenp q)) - (= n n2)) - collect (list n d q r n2))) - -(defun round.3-fn (width) - (loop for n = (- (random width) (/ width 2)) - for vals = (multiple-value-list (round n)) - for (q r) = vals - for n2 = (+ q r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (= n n2) - (<= -1/2 r 1/2) - (or (not (= (abs r) 1/2)) - (evenp q)) - ) - collect (list n q r n2))) - -(defun round.7-fn () - (loop for numerator = (- (random 10000000000) 5000000000) - for denominator = (1+ (random 100000)) - for n = (/ numerator denominator) - for vals = (multiple-value-list (round n)) - for (q r) = vals - for n2 = (+ q r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (rationalp r) - (= n n2) - (<= -1/2 r 1/2) - (or (not (= (abs r) 1/2)) - (evenp q)) - ) - collect (list n q r n2))) - -(defun round.8-fn () - (loop for num1 = (- (random 10000000000) 5000000000) - for den1 = (1+ (random 100000)) - for n = (/ num1 den1) - for num2 = (- (1+ (random 1000000))) - for den2 = (1+ (random 1000000)) - for d = (/ num2 den2) - for vals = (multiple-value-list (round n d)) - for (q r) = vals - for n2 = (+ (* q d) r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (rationalp r) - (<= (/ d 2) r (- (/ d 2))) - (or (not (= (abs r) (- (/ d 2)))) - (evenp q)) - (= n n2)) - collect (list n q d r n2))) - -(defun round.9-fn () - (loop for num1 = (- (random 1000000000000000) 500000000000000) - for den1 = (1+ (random 10000000000)) - for n = (/ num1 den1) - for num2 = (- (1+ (random 1000000000))) - for den2 = (1+ (random 10000000)) - for d = (/ num2 den2) - for vals = (multiple-value-list (round n d)) - for (q r) = vals - for n2 = (+ (* q d) r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (rationalp r) - (<= (/ d 2) r (- (/ d 2))) - (or (not (= (abs r) (- (/ d 2)))) - (evenp q)) - (= n n2)) - collect (list n q d r n2))) diff --git a/t/ansi-test/auxiliary/search-aux.lsp b/t/ansi-test/auxiliary/search-aux.lsp deleted file mode 100644 index 0e442c5..0000000 --- a/t/ansi-test/auxiliary/search-aux.lsp +++ /dev/null @@ -1,93 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Aug 24 07:22:10 2002 -;;;; Contains: Aux. functions for testing SEARCH - - - -(defparameter *searched-list* - '(b b a b b b b b b b a b a b b b a b a b b b a a a a b a a b a a a a a - a b a b b a b a a b a a a b b a a b a a a a b b a b a b a a a b a b - b a b a a b b b b b a a a a a b a b b b b b a b a b b a b a b)) - -(defparameter *pattern-sublists* - (remove-duplicates - (let* ((s *searched-list*) (len (length s))) - (loop for x from 0 to 8 nconc - (loop for y from 0 to (- len x) - collect (subseq s y (+ y x))))) - :test #'equal)) - -(defparameter *searched-vector* - (make-array (length *searched-list*) - :initial-contents *searched-list*)) - -(defparameter *pattern-subvectors* - (mapcar #'(lambda (x) (apply #'vector x)) *pattern-sublists*)) - -(defparameter *searched-bitvector* - #*1101111111010111010111000010010000001011010010001100100001101010001011010011111000001011111010110101) - -(defparameter *pattern-subbitvectors* - (remove-duplicates - (let* ((s *searched-bitvector*) (len (length s))) - (loop for x from 0 to 8 nconc - (loop for y from 0 to (- len x) - collect (subseq s y (+ y x))))) - :test #'equalp)) - -(defparameter *searched-string* - "1101111111010111010111000010010000001011010010001100100001101010001011010011111000001011111010110101") - -(defparameter *pattern-substrings* - (remove-duplicates - (let* ((s *searched-string*) (len (length s))) - (loop for x from 0 to 8 nconc - (loop for y from 0 to (- len x) - collect (subseq s y (+ y x))))) - :test #'equalp)) - -(defun subseq-equalp (seq1 seq2 start1 start2 len &key (test #'equalp)) - (assert - (and - (>= start1 0) - (>= start2 0) - (<= (+ start1 len) (length seq1)) - (<= (+ start2 len) (length seq2)))) - (setq test (coerce test 'function)) - (if (and (listp seq1) (listp seq2)) - (loop for i from 0 to (1- len) - for e1 in (nthcdr start1 seq1) - for e2 in (nthcdr start2 seq2) - always (funcall test e1 e2)) - (loop for i from 0 to (1- len) - always - (funcall (the function test) - (elt seq1 (+ start1 i)) - (elt seq2 (+ start2 i)))))) - -(defun search-check (pattern searched pos - &key (start1 0) (end1 nil) (start2 0) (end2 nil) - key from-end (test #'equalp)) - (unless end1 (setq end1 (length pattern))) - (unless end2 (setq end2 (length searched))) - (assert (<= start1 end1)) - (assert (<= start2 end2)) - (let* ((plen (- end1 start1))) - (when key - (setq pattern (map 'list key pattern)) - (setq searched (map 'list key searched))) - (if pos - (and - (subseq-equalp searched pattern pos start1 plen :test test) - (if from-end - (loop for i from (1+ pos) to (- end2 plen) - never - (subseq-equalp searched pattern i start1 plen :test test)) - (loop for i from start2 to (1- pos) - never - (subseq-equalp searched pattern i start1 plen :test test)))) - (loop for i from start2 to (- end2 plen) - never (subseq-equalp searched pattern i start1 plen :test test))))) - - diff --git a/t/ansi-test/auxiliary/sort-aux.lsp b/t/ansi-test/auxiliary/sort-aux.lsp deleted file mode 100644 index 9601e38..0000000 --- a/t/ansi-test/auxiliary/sort-aux.lsp +++ /dev/null @@ -1,43 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Jul 17 06:42:27 2003 -;;;; Contains: Routines for testing SORT, NSORT - - - -(defun my-numeric-sort (list) - "Sort (nondestructively) a list of reals." - (if (null (cdr list)) - list - (let* ((len2 (ash (length list) -1)) - (l1 (my-numeric-sort (subseq list 0 len2))) - (l2 (my-numeric-sort (subseq list len2)))) - (my-numeric-merge l1 l2)))) - -(defun my-numeric-merge (l1 l2) - (cond - ((null l1) l2) - ((null l2) l1) - ((<= (car l1) (car l2)) - (cons (car l1) (my-numeric-merge (cdr l1) l2))) - (t - (cons (car l2) (my-numeric-merge l1 (cdr l2)))))) - -(defun generate-random-sort-test (n m) - (loop for i below n collect (random m))) - -(defun random-sort-test (n m reps) - (loop - for i below reps - for list = (generate-random-sort-test (random n) m) - unless (equal (my-numeric-sort list) - (sort (copy-seq list) #'<)) - collect list)) - -(defun random-stable-sort-test (n m reps) - (loop - for i below reps - for list = (generate-random-sort-test (random n) m) - unless (equal (my-numeric-sort list) - (stable-sort (copy-seq list) #'<)) - collect list)) diff --git a/t/ansi-test/auxiliary/string-aux.lsp b/t/ansi-test/auxiliary/string-aux.lsp deleted file mode 100644 index c7f16c4..0000000 --- a/t/ansi-test/auxiliary/string-aux.lsp +++ /dev/null @@ -1,155 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Oct 4 06:51:32 2002 -;;;; Contains: Auxiliary functions for string testing - - - -(eval-when (:compile-toplevel :load-toplevel :execute) - (compile-and-load "ANSI-TESTS:AUX;random-aux.lsp")) - -(defun my-string-compare (string1 string2 comparison - &key (start1 0) end1 (start2 0) end2 case - &aux - (len1 (progn (assert (stringp string1)) - (length string1))) - (len2 (progn (assert (stringp string2)) - (length string2))) - (compare-fn - (case comparison - (< (if case #'char-lessp #'char<)) - (<= (if case #'char-not-greaterp - #'char<=)) - (= (if case #'char-equal #'char=)) - (/= (if case #'char-not-equal #'char/=)) - (> (if case #'char-greaterp #'char>)) - (>= (if case #'char-not-lessp #'char>=)) - (t (error "Bad comparison arg: ~A~%" - comparison)))) - (equal-fn (if case #'char-equal #'char=))) - - (assert (integerp start1)) - (assert (integerp start2)) - (unless end1 (setq end1 len1)) - (unless end2 (setq end2 len2)) - (assert (<= 0 start1 end1)) - (assert (<= 0 start2 end2)) - (loop - for i1 from start1 - for i2 from start2 - do - (cond - ((= i1 end1) - (return - (cond - ((= i2 end2) - ;; Both ended -- equality case - (if (member comparison '(= <= >=)) - end1 - nil)) - (t ;; string2 still extending - (if (member comparison '(/= < <=)) - end1 - nil))))) - ((= i2 end2) - ;; string1 still extending - (return - (if (member comparison '(/= > >=)) - i1 - nil))) - (t - (let ((c1 (my-aref string1 i1)) - (c2 (my-aref string2 i2))) - (cond - ((funcall equal-fn c1 c2)) - (t ;; mismatch found -- what kind? - (return - (if (funcall compare-fn c1 c2) - i1 - nil))))))))) - -(defun make-random-string-compare-test (n) - (let* ((len (random n)) - ;; Maximum lengths of the two strings - (len1 (if (or (coin) (= len 0)) len (+ len (random len)))) - (len2 (if (or (coin) (= len 0)) len (+ len (random len)))) - (s1 (make-random-string len1)) - (s2 (make-random-string len2)) - ;; Actual lengths of the strings - (len1 (length s1)) - (len2 (length s2)) - ;; Lengths of the parts of the strings to be matched - (sublen1 (if (or (coin) (= len1 0)) (min len1 len2) (random len1))) - (sublen2 (if (or (coin) (= len2 0)) (min len2 sublen1) (random len2))) - ;; Start and end of the substring of the first string - (start1 (if (coin 3) 0 - (max 0 (min (1- len1) (random (- len1 sublen1 -1)))))) - (end1 (+ start1 sublen1)) - ;; Start and end of the substring of the second string - (start2 (if (coin 3) 0 - (max 0 (min (1- len2) (random (- len2 sublen2 -1)))))) - (end2 (+ start2 sublen2)) - ) - #| - (format t "len = ~A, len1 = ~A, len2 = ~A, sublen1 = ~A, sublen2 = ~A~%" - len len1 len2 sublen1 sublen2) - (format t "start1 = ~A, end1 = ~A, start2 = ~A, end2 = ~A~%" - start1 end1 start2 end2) - (format t "s1 = ~S, s2 = ~S~%" s1 s2) - |# - ;; Sometimes we want them to have a common prefix - (when (and (coin) - (equal (array-element-type s1) - (array-element-type s2))) - (if (<= sublen1 sublen2) - (setf (subseq s2 start2 (+ start2 sublen1)) - (subseq s1 start1 (+ start1 sublen1))) - (setf (subseq s1 start1 (+ start1 sublen2)) - (subseq s2 start2 (+ start2 sublen2))))) - (values - s1 - s2 - (reduce #'nconc - (random-permute - (list - (if (and (= start1 0) (coin)) - nil - (list :start1 start1)) - (if (and (= end1 len1) (coin)) - nil - (list :end1 end1)) - (if (and (= start2 0) (coin)) - nil - (list :start2 start2)) - (if (and (= end2 len2) (coin)) - nil - (list :end2 end2)))))))) - -(defun random-string-compare-test (n comparison case &optional (iterations 1)) - (loop for i from 1 to iterations - count - (multiple-value-bind (s1 s2 args) - (make-random-string-compare-test n) - ;; (format t "Strings: ~s ~s - Args = ~S~%" s1 s2 args) - (let ((x (apply (case comparison - (< (if case #'string-lessp #'string<)) - (<= (if case #'string-not-greaterp - #'string<=)) - (= (if case #'string-equal #'string=)) - (/= (if case #'string-not-equal #'string/=)) - (> (if case #'string-greaterp #'string>)) - (>= (if case #'string-not-lessp #'string>=)) - (t (error "Bad comparison arg: ~A~%" comparison))) - s1 s2 args)) - (y (apply #'my-string-compare s1 s2 comparison :case case args))) - (not - (or (eql x y) - (and x y (eqt comparison '=)))))))) - -(defun string-all-the-same (s) - (let ((len (length s))) - (or (= len 0) - (let ((c (my-aref s 0))) - (loop for i below len - for d = (my-aref s i) - always (eql c d)))))) diff --git a/t/ansi-test/auxiliary/subseq-aux.lsp b/t/ansi-test/auxiliary/subseq-aux.lsp deleted file mode 100644 index 585aca1..0000000 --- a/t/ansi-test/auxiliary/subseq-aux.lsp +++ /dev/null @@ -1,239 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Nov 26 20:01:27 2002 -;;;; Contains: Aux. functions for subseq tests - - - -(defun subseq-list.4-body () - (block done - (let ((x (loop for i from 0 to 19 collect i))) - (loop - for i from 0 to 20 do - (loop - for j from i to 20 do - (let ((y (subseq x i j))) - (loop - for e in y and k from i to (1- j) do - (unless (eqlt e k) (return-from done nil))))))) - t)) - -(defun subseq-list.5-body () - (block done - (let ((x (loop for i from 0 to 29 collect i))) - (loop - for i from 0 to 30 do - (unless (equalt (subseq x i) - (loop for j from i to 29 collect j)) - (return-from done nil)))) - t)) - -(defun subseq-list.6-body () - (let* ((x (make-list 100)) - (z (loop for e on x collect e)) - (y (subseq x 0))) - (loop - for e on x - and f on y - and g in z do - (when (or (not (eqt g e)) - (not (eqlt (car e) (car f))) - (car e) - (eqt e f)) - (return nil)) - finally (return t)))) - -(defun subseq-vector.1-body () - (block nil - (let* ((x (make-sequence 'vector 10 :initial-element 'a)) - (y (subseq x 4 8))) - (unless (every #'(lambda (e) (eqt e 'a)) x) - (return 1)) - (unless (every #'(lambda (e) (eqt e 'a)) y) - (return 2)) - (unless (eqlt (length x) 10) (return 3)) - (unless (eqlt (length y) 4) (return 4)) - (loop for i from 0 to 9 do (setf (elt x i) 'b)) - (unless (every #'(lambda (e) (eqt e 'a)) y) - (return 5)) - (loop for i from 0 to 3 do (setf (elt y i) 'c)) - (or - (not (not (every #'(lambda (e) (eqt e 'b)) x))) - 6)))) - -(defun subseq-vector.2-body () - (block nil - (let* ((x (make-sequence '(vector fixnum) 10 :initial-element 1)) - (y (subseq x 4 8))) - (unless (every #'(lambda (e) (eqlt e 1)) x) - (return 1)) - (unless (every #'(lambda (e) (eqlt e 1)) y) - (return 2)) - (unless (eqlt (length x) 10) (return 3)) - (unless (eqlt (length y) 4) (return 4)) - (loop for i from 0 to 9 do (setf (elt x i) 2)) - (unless (every #'(lambda (e) (eqlt e 1)) y) - (return 5)) - (loop for i from 0 to 3 do (setf (elt y i) 3)) - (or - (not (not (every #'(lambda (e) (eqlt e 2)) x))) - 6)))) - -(defun subseq-vector.3-body () - (block nil - (let* ((x (make-sequence '(vector single-float) 10 :initial-element 1.0)) - (y (subseq x 4 8))) - (unless (every #'(lambda (e) (= e 1.0)) x) - (return 1)) - (unless (every #'(lambda (e) (= e 1.0)) y) - (return 2)) - (unless (eqlt (length x) 10) (return 3)) - (unless (eqlt (length y) 4) (return 4)) - (loop for i from 0 to 9 do (setf (elt x i) 2.0)) - (unless (every #'(lambda (e) (= e 1.0)) y) - (return 5)) - (loop for i from 0 to 3 do (setf (elt y i) 3.0)) - (or - (not (not (every #'(lambda (e) (= e 2.0)) x))) - 6)))) - -(defun subseq-vector.4-body () - (block nil - (let* ((x (make-sequence '(vector double-float) 10 :initial-element 1.0d0)) - (y (subseq x 4 8))) - (unless (every #'(lambda (e) (= e 1.0)) x) - (return 1)) - (unless (every #'(lambda (e) (= e 1.0)) y) - (return 2)) - (unless (eqlt (length x) 10) (return 3)) - (unless (eqlt (length y) 4) (return 4)) - (loop for i from 0 to 9 do (setf (elt x i) 2.0d0)) - (unless (every #'(lambda (e) (= e 1.0)) y) - (return 5)) - (loop for i from 0 to 3 do (setf (elt y i) 3.0d0)) - (or - (not (not (every #'(lambda (e) (= e 2.0)) x))) - 6)))) - -(defun subseq-vector.5-body () - (block nil - (let* ((x (make-sequence '(vector short-float) 10 :initial-element 1.0s0)) - (y (subseq x 4 8))) - (unless (every #'(lambda (e) (= e 1.0)) x) - (return 1)) - (unless (every #'(lambda (e) (= e 1.0)) y) - (return 2)) - (unless (eqlt (length x) 10) (return 3)) - (unless (eqlt (length y) 4) (return 4)) - (loop for i from 0 to 9 do (setf (elt x i) 2.0s0)) - (unless (every #'(lambda (e) (= e 1.0)) y) - (return 5)) - (loop for i from 0 to 3 do (setf (elt y i) 3.0s0)) - (or - (not (not (every #'(lambda (e) (= e 2.0)) x))) - 6)))) - -(defun subseq-vector.6-body () - (block nil - (let* ((x (make-sequence '(vector long-float) 10 :initial-element 1.0l0)) - (y (subseq x 4 8))) - (unless (every #'(lambda (e) (= e 1.0)) x) - (return 1)) - (unless (every #'(lambda (e) (= e 1.0)) y) - (return 2)) - (unless (eqlt (length x) 10) (return 3)) - (unless (eqlt (length y) 4) (return 4)) - (loop for i from 0 to 9 do (setf (elt x i) 2.0l0)) - (unless (every #'(lambda (e) (= e 1.0)) y) - (return 5)) - (loop for i from 0 to 3 do (setf (elt y i) 3.0l0)) - (or - (not (not (every #'(lambda (e) (= e 2.0)) x))) - 6)))) - -(defun subseq-string.1-body () - (let* ((s1 "abcdefgh") - (len (length s1))) - (loop for start from 0 below len - always - (string= (subseq s1 start) - (coerce (loop for i from start to (1- len) - collect (elt s1 i)) - 'string))))) - -(defun subseq-string.2-body () - (let* ((s1 "abcdefgh") - (len (length s1))) - (loop for start from 0 below len - always - (loop for end from (1+ start) to len - always - (string= (subseq s1 start end) - (coerce (loop for i from start below end - collect (elt s1 i)) - 'string)))))) - -(defun subseq-string.3-body () - (let* ((s1 (make-array '(10) :initial-contents "abcdefghij" - :fill-pointer 8 - :element-type 'character)) - (len (length s1))) - (and - (eqlt len 8) - (loop for start from 0 below len - always - (string= (subseq s1 start) - (coerce (loop for i from start to (1- len) - collect (elt s1 i)) - 'string))) - (loop for start from 0 below len - always - (loop for end from (1+ start) to len - always - (string= (subseq s1 start end) - (coerce (loop for i from start below end - collect (elt s1 i)) - 'string))))))) -(defun subseq-bit-vector.1-body () - (let* ((s1 #*11001000) - (len (length s1))) - (loop for start from 0 below len - always - (equalp (subseq s1 start) - (coerce (loop for i from start to (1- len) - collect (elt s1 i)) - 'bit-vector))))) - -(defun subseq-bit-vector.2-body () - (let* ((s1 #*01101011) - (len (length s1))) - (loop for start from 0 below len - always - (loop for end from (1+ start) to len - always - (equalp (subseq s1 start end) - (coerce (loop for i from start below end - collect (elt s1 i)) - 'bit-vector)))))) - -(defun subseq-bit-vector.3-body () - (let* ((s1 (make-array '(10) :initial-contents #*1101100110 - :fill-pointer 8 - :element-type 'bit)) - (len (length s1))) - (and - (eqlt len 8) - (loop for start from 0 below len - always - (equalp (subseq s1 start) - (coerce (loop for i from start to (1- len) - collect (elt s1 i)) - 'bit-vector))) - (loop for start from 0 below len - always - (loop for end from (1+ start) to len - always - (equalp (subseq s1 start end) - (coerce (loop for i from start below end - collect (elt s1 i)) - 'bit-vector))))))) diff --git a/t/ansi-test/auxiliary/times-aux.lsp b/t/ansi-test/auxiliary/times-aux.lsp deleted file mode 100644 index b74a787..0000000 --- a/t/ansi-test/auxiliary/times-aux.lsp +++ /dev/null @@ -1,27 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Aug 28 11:23:40 2003 -;;;; Contains: Auxiliary functions for testing the multiplication operator * - - - -(defun integer-times (x y) - (assert (integerp x)) - (assert (integerp y)) - (let (neg) - (when (< x 0) - (setq neg t x (- x))) - (let ((result (nat-times x y))) - (if neg (- result) result)))) - -(defun nat-times (x y) - ;; Assumes x >= 0 - (if (= x 0) - 0 - (let ((lo (if (oddp x) y 0)) - (hi (nat-times (ash x -1) y))) - (+ lo (+ hi hi))))) - -(defun rat-times (x y) - (/ (integer-times (numerator x) (numerator y)) - (integer-times (denominator x) (denominator y)))) diff --git a/t/ansi-test/auxiliary/truncate-aux.lsp b/t/ansi-test/auxiliary/truncate-aux.lsp deleted file mode 100644 index aabdfa8..0000000 --- a/t/ansi-test/auxiliary/truncate-aux.lsp +++ /dev/null @@ -1,113 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Aug 20 05:15:17 2003 -;;;; Contains: Aux. functions associated with tests of TRUNCATE - - - -(defun truncate.1-fn () - (loop for n = (- (random 2000000000) - 1000000000) - for d = (1+ (random 10000)) - for vals = (multiple-value-list (truncate n d)) - for (q r) = vals - for n2 = (+ (* q d) r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (= n n2) - (integerp r) - (if (>= n 0) (< -1 r d) - (< (- d) r 1))) - collect (list n d q r n2))) - -(defun truncate.2-fn () - (loop for num = (random 1000000000) - for denom = (1+ (random 1000)) - for n = (/ num denom) - for d = (1+ (random 10000)) - for vals = (multiple-value-list (truncate n d)) - for (q r) = vals - for n2 = (+ (* q d) r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (<= 0 r) - (< r d) - (= n n2)) - collect (list n d q r n2))) - -(defun truncate.3-fn (width) - (loop for n = (- (random width) (/ width 2)) - for vals = (multiple-value-list (truncate n)) - for (q r) = vals - for n2 = (+ q r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (= n n2) - (if (>= n 0) - (and (<= 0 r) (< r 1)) - (and (< -1 r) (<= r 0))) - ) - collect (list n q r n2))) - -(defun truncate.7-fn () - (loop for numerator = (- (random 10000000000) 5000000000) - for denominator = (1+ (random 100000)) - for n = (/ numerator denominator) - for vals = (multiple-value-list (truncate n)) - for (q r) = vals - for n2 = (+ q r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (rationalp r) - (= n n2) - (if (>= n 0) - (and (<= 0 r) (< r 1)) - (and (< -1 r) (<= r 0))) - ) - collect (list n q r n2))) - -(defun truncate.8-fn () - (loop for num1 = (- (random 10000000000) 5000000000) - for den1 = (1+ (random 100000)) - for n = (/ num1 den1) - for num2 = (- (1+ (random 1000000))) - for den2 = (1+ (random 1000000)) - for d = (/ num2 den2) - for vals = (multiple-value-list (truncate n d)) - for (q r) = vals - for n2 = (+ (* q d) r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (rationalp r) - (if (> n 0) - (and (<= 0 r) (< r (- d))) - (and (>= 0 r) (> r d))) - (= n n2)) - collect (list n q d r n2))) - -(defun truncate.9-fn () - (loop for num1 = (- (random 1000000000000000) 500000000000000) - for den1 = (1+ (random 10000000000)) - for n = (/ num1 den1) - for num2 = (- (1+ (random 1000000000))) - for den2 = (1+ (random 10000000)) - for d = (/ num2 den2) - for vals = (multiple-value-list (truncate n d)) - for (q r) = vals - for n2 = (+ (* q d) r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (rationalp r) - (if (> n 0) - (and (<= 0 r) (< r (- d))) - (and (>= 0 r) (> r d))) - (= n n2)) - collect (list n q d r n2))) - - diff --git a/t/ansi-test/auxiliary/types-aux.lsp b/t/ansi-test/auxiliary/types-aux.lsp deleted file mode 100644 index 091af89..0000000 --- a/t/ansi-test/auxiliary/types-aux.lsp +++ /dev/null @@ -1,186 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Jun 21 20:14:38 2004 -;;;; Contains: Aux. functions for types tests - -(defun classes-are-disjoint (c1 c2) - "If either c1 or c2 is a builtin class or the name of a builtin - class, then check for disjointness. Return a non-NIL list - of failed subtypep relationships, if any." - (and (or (is-builtin-class c1) - (is-builtin-class c2)) - (check-disjointness c1 c2))) - -(declaim (special *subtype-table*)) - -(defun types.6-body () - (loop - for p in *subtype-table* - for tp = (car p) - append - (and (not (member tp '(sequence cons list t))) - (let ((message (check-subtypep tp 'atom t t))) - (if message (list message)))))) - -(defparameter *type-list* nil) -(defparameter *supertype-table* nil) - -(defun types.9-body () - (let ((tp-list (append '(keyword atom list) - (loop for p in *subtype-table* collect (car p)))) - (result-list)) - (setf tp-list (remove-duplicates tp-list)) - ;; TP-LIST is now a list of unique CL type names - ;; Store it in *TYPE-LIST* so we can inspect it later if this test - ;; fails. The variable is also used in test TYPES.9A - (setf *type-list* tp-list) - ;; Compute all pairwise SUBTYPEP relationships among - ;; the elements of *TYPE-LIST*. - (let ((subs (make-hash-table :test #'eq)) - (sups (make-hash-table :test #'eq))) - (loop - for x in tp-list do - (loop - for y in tp-list do - (multiple-value-bind (result good) - (subtypep* x y) - (declare (ignore good)) - (when result - (pushnew x (gethash y subs)) - (pushnew y (gethash x sups)))))) - ;; Store the supertype relations for later inspection - ;; and use in test TYPES.9A - (setf *supertype-table* sups) - ;; Check that the relation we just computed is transitive. - ;; Return a list of triples on which transitivity fails. - (loop - for x in tp-list do - (let ((sub-list (gethash x subs)) - (sup-list (gethash x sups))) - (loop - for t1 in sub-list do - (loop - for t2 in sup-list do - (multiple-value-bind (result good) - (subtypep* t1 t2) - (when (and good (not result)) - (pushnew (list t1 x t2) result-list - :test #'equal))))))) - - result-list))) - -;;; TYPES.9-BODY returns a list of triples (T1 T2 T3) -;;; where (AND (SUBTYPEP T1 T2) (SUBTYPEP T2 T3) (NOT (SUBTYPEP T1 T3))) -;;; (and where SUBTYPEP succeeds in each case, returning true as its -;;; second return value.) - -(defun types.9a-body () - (cond - ((not (and *type-list* *supertype-table*)) - (format nil "Run test type.9 first~%") - nil) - (t - (loop - for tp in *type-list* - sum - (let ((sups (gethash tp *supertype-table*))) - (loop - for x in *universe* - sum - (handler-case - (cond - ((not (typep x tp)) 0) - (t - (loop - for tp2 in sups - count - (handler-case - (and (not (typep x tp2)) - (progn - (format t "Found element of ~S not in ~S: ~S~%" - tp tp2 x) - t)) - (condition (c) (format t "Error ~S occured: ~S~%" - c tp2) - t))))) - (condition (c) (format t "Error ~S occured: ~S~%" c tp) - 1)))))))) - -(defun check-subtypep (type1 type2 is-sub &optional should-be-valid) - (multiple-value-bind - (sub valid) - (subtypep type1 type2) - (unless (constantp type1) (setq type1 (list 'quote type1))) - (unless (constantp type2) (setq type2 (list 'quote type2))) - (if (or (and valid sub (not is-sub)) - (and valid (not sub) is-sub) - (and (not valid) should-be-valid)) - `(((SUBTYPEP ,type1 ,type2) :==> ,sub ,valid)) - nil))) - -;;; Check that the subtype relationships implied -;;; by disjointness are not contradicted. Return NIL -;;; if ok, or a list of error messages if not. - -;;; Assumes the types are nonempty. - -(defun check-disjointness (type1 type2) - (append - (check-subtypep type1 type2 nil) - (check-subtypep type2 type1 nil) - (check-subtypep type1 `(not ,type2) t) - (check-subtypep type2 `(not ,type1) t) - (check-subtypep `(and ,type1 ,type2) nil t) - (check-subtypep `(and ,type2 ,type1) nil t) - (check-subtypep `(and ,type1 (not ,type2)) type1 t) - (check-subtypep `(and (not ,type2) ,type1) type1 t) - (check-subtypep `(and ,type2 (not ,type1)) type2 t) - (check-subtypep `(and (not ,type1) ,type2) type2 t) -;;; (check-subtypep type1 `(or ,type1 (not ,type2)) t) -;;; (check-subtypep type1 `(or (not ,type2) ,type1) t) -;;; (check-subtypep type2 `(or ,type2 (not ,type1)) t) -;;; (check-subtypep type2 `(or (not ,type1) ,type2) t) - (check-subtypep t `(or (not ,type1) (not ,type2)) t) - (check-subtypep t `(or (not ,type2) (not ,type1)) t) - )) - -(defun check-equivalence (type1 type2) - (append - (check-subtypep type1 type2 t) - (check-subtypep type2 type1 t) - (check-subtypep `(not ,type1) `(not ,type2) t) - (check-subtypep `(not ,type2) `(not ,type1) t) - (check-subtypep `(and ,type1 (not ,type2)) nil t) - (check-subtypep `(and ,type2 (not ,type1)) nil t) - (check-subtypep `(and (not ,type2) ,type1) nil t) - (check-subtypep `(and (not ,type1) ,type2) nil t) - (check-subtypep t `(or ,type1 (not ,type2)) t) - (check-subtypep t `(or ,type2 (not ,type1)) t) - (check-subtypep t `(or (not ,type2) ,type1) t) - (check-subtypep t `(or (not ,type1) ,type2) t))) - -(defun check-all-subtypep (type1 type2) - (append - (check-subtypep type1 type2 t) - (check-subtypep `(not ,type2) `(not ,type1) t) - (check-subtypep `(and ,type1 (not ,type2)) nil t) - (check-subtypep t `(or (not ,type1) ,type2) t))) - -(defun check-all-not-subtypep (type1 type2) - (append - (check-subtypep type1 type2 nil) - (check-subtypep `(not ,type2) `(not ,type1) nil))) - -(defun subtypep-and-contrapositive-are-consistent (t1 t2) - (multiple-value-bind (sub1 success1) - (subtypep* t1 t2) - (multiple-value-bind (sub2 success2) - (subtypep* `(not ,t2) `(not ,t1)) - (or (not success1) - (not success2) - (eqlt sub1 sub2))))) - -;;; For use in deftype tests -(deftype even-array (&optional type size) - `(and (array ,type ,size) - (satisfies even-size-p))) diff --git a/t/ansi-test/beyond-ansi/README b/t/ansi-test/beyond-ansi/README deleted file mode 100644 index d183015..0000000 --- a/t/ansi-test/beyond-ansi/README +++ /dev/null @@ -1,3 +0,0 @@ -This directory contains tests that go beyond the ANSI CL standard. -No conforming implementation is required to be able to pass these -tests. diff --git a/t/ansi-test/beyond-ansi/ba-aux.lsp b/t/ansi-test/beyond-ansi/ba-aux.lsp deleted file mode 100644 index b271242..0000000 --- a/t/ansi-test/beyond-ansi/ba-aux.lsp +++ /dev/null @@ -1,56 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon May 30 06:45:08 2005 -;;;; Contains: Aux. files for beyond-ansi tests - -(in-package :ba-test) - -(defun function-name-p (x) - (or (symbolp x) - (and (consp x) - (eql (car x) 'setf) - (consp (cdr x)) - (symbolp (cadr x)) - (null (cddr x))))) - -(defun symbol-or-function-p (x) - (or (symbolp x) - (and (consp x) - (eql (car x) 'function) - (consp (cdr x)) - (null (cddr x)) - (function-name-p (cadr x))))) - -(defun symbol-or-list-p (x) - (or (symbolp x) (listp x))) - -(defun function-designator-p (x) - (or (functionp x) - (and (symbolp x) (not (macro-function x)) (not (special-operator-p x))))) - -(defun type-specifier-p (x) - (typep x '(or symbol list class))) - -(defun causes-error-p (pred formf &key (vals *mini-universe*) (var 'x)) - (when (symbolp pred) - (assert (fboundp pred)) - (setf pred (symbol-function pred))) - (loop for x in vals - for inner-form = (if (functionp formf) - (funcall formf x) - (subst `',x var formf)) - for form = `(signals-error ,inner-form error) - unless (or (funcall pred x) (eval form)) - collect x)) - -(defmacro def-all-error-test (name pred form &rest other-args) - `(deftest ,name - (causes-error-p ,pred ,form ,@other-args) - nil)) - -(defmacro def-error-test (name form) - `(deftest ,name - (signals-error ,form error) - t)) - - diff --git a/t/ansi-test/beyond-ansi/ba-test-package.lsp b/t/ansi-test/beyond-ansi/ba-test-package.lsp deleted file mode 100644 index be42432..0000000 --- a/t/ansi-test/beyond-ansi/ba-test-package.lsp +++ /dev/null @@ -1,18 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat May 28 06:38:29 2005 -;;;; Contains: Definition of BA-TEST package. - -(in-package :cl-user) - -(let* ((name :ba-test) - (pkg (find-package name))) - (unless pkg (setq pkg (make-package name :use '(:cl :regression-test - :cl-test)))) - (let ((*package* pkg)) - (shadow '(#:handler-case #:handler-bind)) - (import '(common-lisp-user::compile-and-load) pkg) - (import '(cl-test::*universe* cl-test::*mini-universe*) pkg) - ) - (let ((s (find-symbol "QUIT" "CL-USER"))) - (when s (import s :ba-test)))) diff --git a/t/ansi-test/beyond-ansi/errors-data-and-control-flow-1.lsp b/t/ansi-test/beyond-ansi/errors-data-and-control-flow-1.lsp deleted file mode 100644 index 541c87a..0000000 --- a/t/ansi-test/beyond-ansi/errors-data-and-control-flow-1.lsp +++ /dev/null @@ -1,127 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon May 30 15:38:09 2005 -;;;; Contains: Tests of non-ANSI exceptional situations from CLHS section 5, part 1 - -(in-package :ba-test) - -(compile-and-load "ba-aux.lsp") - -;;; APPLY - -(def-all-error-test apply.1 'function-designator-p '(apply x nil)) -(def-all-error-test apply.2 'function-designator-p '(apply x '(1 2 3))) -(def-error-test apply.3 (apply 'cons . 1)) -(def-all-error-test apply.4 'listp '(apply 'cons '1 x)) - -;;; DEFUN - -(def-error-test defun.1 (defun)) -(def-error-test defun.2 (defun #.(gensym))) -(def-error-test defun.3 (defun . foo)) -(def-error-test defun.4 (defun #.(gensym) #.(gensym))) -(def-error-test defun.5 (defun #.(gensym) () . foo)) - -(def-error-test defun.6 (defun #.(gensym) () "foo" "bar" (declare))) -(def-error-test defun.7 (defun #.(gensym) () nil (declare))) - -;;; FIXME Add lambda list tests - -;;; FLET - -(def-error-test flet.1 (flet . foo)) -(def-error-test flet.2 (flet foo)) -(def-error-test flet.3 (flet (foo))) -(def-error-test flet.4 (flet ((foo)))) -(def-error-test flet.5 (flet ((foo . bar)))) -(def-error-test flet.6 (flet () . foo)) -(def-error-test flet.7 (flet ((foo () . bar)))) -(def-error-test flet.8 (flet ((foo z)))) -(def-error-test flet.9 (flet ((foo ((x y)))))) -(def-all-error-test flet.10 'symbolp - #'(lambda (x) (subst x 'x '(flet ((foo (&rest x))))))) -(def-all-error-test flet.11 (typef '(or symbol cons)) - #'(lambda (x) (subst x 'x '(flet ((foo (&optional x))))))) -(def-all-error-test flet.12 (typef '(or symbol cons)) - #'(lambda (x) (subst x 'x '(flet ((foo (&key x))))))) - -(def-error-test flet.13 (flet ((foo (&optional (x . bar)) nil)))) -(def-error-test flet.14 (flet ((foo (&optional (x nil . bar)) nil)))) -(def-error-test flet.15 (flet ((foo (&optional (x nil x-p . bar)) nil)))) -(def-error-test flet.16 (flet ((foo (&optional (x nil x-p nil)) nil)))) - -(def-error-test flet.17 (flet ((foo (&key (x . bar)) nil)))) -(def-error-test flet.18 (flet ((foo (&key (x nil . bar)) nil)))) -(def-error-test flet.19 (flet ((foo (&key (x nil x-p . bar)) nil)))) -(def-error-test flet.20 (flet ((foo (&key (x nil x-p nil)) nil)))) - -(def-error-test flet.21 (flet ((foo (&key ((x . bar))) nil)))) -(def-error-test flet.22 (flet ((foo (&key ((x y . z))) nil)))) -(def-error-test flet.23 (flet ((foo (&key ((x y z))) nil)))) - -(def-all-error-test flet.24 'symbolp - #'(lambda (x) `(flet ((foo (&key ((,x y))) nil))))) - -(def-all-error-test flet.25 'symbolp - #'(lambda (x) `(flet ((foo (&key ((y ,x))) nil))))) - -(def-error-test flet.26 (flet ((foo (&aux . bar))))) -(def-error-test flet.27 (flet ((foo (&aux (x . bar)))))) -(def-error-test flet.28 (flet ((foo (&aux (x nil . bar)))))) -(def-error-test flet.29 (flet ((foo (&aux (x nil nil)))))) - -(def-error-test flet.30 (flet ((foo () "x" "y" (declare))) (foo))) -(def-error-test flet.31 (flet ((foo () :bad1) (foo () :bad2)) (foo))) - -;;; FIXME Add tests for disallowed lambda list keywords - -;;; LABELS - -(def-error-test labels.1 (labels . foo)) -(def-error-test labels.2 (labels foo)) -(def-error-test labels.3 (labels (foo))) -(def-error-test labels.4 (labels ((foo)))) -(def-error-test labels.5 (labels ((foo . bar)))) -(def-error-test labels.6 (labels () . foo)) -(def-error-test labels.7 (labels ((foo () . bar)))) -(def-error-test labels.8 (labels ((foo z)))) -(def-error-test labels.9 (labels ((foo ((x y)))))) -(def-all-error-test labels.10 'symbolp - #'(lambda (x) (subst x 'x '(labels ((foo (&rest x))))))) -(def-all-error-test labels.11 (typef '(or symbol cons)) - #'(lambda (x) (subst x 'x '(labels ((foo (&optional x))))))) -(def-all-error-test labels.12 (typef '(or symbol cons)) - #'(lambda (x) (subst x 'x '(labels ((foo (&key x))))))) - -(def-error-test labels.13 (labels ((foo (&optional (x . bar)) nil)))) -(def-error-test labels.14 (labels ((foo (&optional (x nil . bar)) nil)))) -(def-error-test labels.15 (labels ((foo (&optional (x nil x-p . bar)) nil)))) -(def-error-test labels.16 (labels ((foo (&optional (x nil x-p nil)) nil)))) - -(def-error-test labels.17 (labels ((foo (&key (x . bar)) nil)))) -(def-error-test labels.18 (labels ((foo (&key (x nil . bar)) nil)))) -(def-error-test labels.19 (labels ((foo (&key (x nil x-p . bar)) nil)))) -(def-error-test labels.20 (labels ((foo (&key (x nil x-p nil)) nil)))) - -(def-error-test labels.21 (labels ((foo (&key ((x . bar))) nil)))) -(def-error-test labels.22 (labels ((foo (&key ((x y . z))) nil)))) -(def-error-test labels.23 (labels ((foo (&key ((x y z))) nil)))) - -(def-all-error-test labels.24 'symbolp - #'(lambda (x) `(labels ((foo (&key ((,x y))) nil))))) - -(def-all-error-test labels.25 'symbolp - #'(lambda (x) `(labels ((foo (&key ((y ,x))) nil))))) - -(def-error-test labels.26 (labels ((foo (&aux . bar))))) -(def-error-test labels.27 (labels ((foo (&aux (x . bar)))))) -(def-error-test labels.28 (labels ((foo (&aux (x nil . bar)))))) -(def-error-test labels.29 (labels ((foo (&aux (x nil nil)))))) - -(def-error-test labels.30 (labels ((foo () "x" "y" (declare))) (foo))) -(def-error-test labels.31 (labels ((foo () :bad1) (foo () :bad2)) (foo))) - -;;; FIXME Add tests for disallowed lambda list keywords - -;;; MACROLET -;;; FIXME: add these diff --git a/t/ansi-test/beyond-ansi/errors-data-and-control-flow-2.lsp b/t/ansi-test/beyond-ansi/errors-data-and-control-flow-2.lsp deleted file mode 100644 index d0d2e9b..0000000 --- a/t/ansi-test/beyond-ansi/errors-data-and-control-flow-2.lsp +++ /dev/null @@ -1,349 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue May 31 08:08:49 2005 -;;;; Contains: Tests of non-ANSI exceptional situations from CLHS section 5, part 2 - -(in-package :ba-test) - -(compile-and-load "ba-aux.lsp") - -;;; FUNCALL - -(def-all-error-test funcall.1 'function-designator-p '(funcall x)) -(def-error-test funcall.2 (funcall cons 1 . 2)) - -;;; FUNCTION - -(def-error-test function.1 (function)) -(def-error-test function.2 (function . cons)) -(def-error-test function.3 (function cons . foo)) -(def-error-test function.4 (function cons nil)) -(def-all-error-test function.5 'function-name-p '(function x)) -(def-all-error-test function.6 - (constantly nil) #'(lambda (x) `(function ,x)) - :vals cl-test::*cl-macro-symbols*) -(def-all-error-test function.7 - (constantly nil) #'(lambda (x) `(function ,x)) - :vals cl-test::*cl-special-operator-symbols*) -(def-error-test function.8 (macrolet ((%m () nil)) #'%m)) - -;;; FUNCTION-LAMBDA-EXPRESSION - -(def-all-error-test function-lambda-expression.1 - 'functionp '(function-lambda-expression x)) - -;;; DEFCONSTANT - -(def-error-test defconstant.1 (defconstant)) -(def-error-test defconstant.2 (defconstant . foo)) -(def-error-test defconstant.3 (defconstant #.(gensym))) -(def-error-test defconstant.4 (defconstant #.(gensym) . foo)) -(def-error-test defconstant.5 (defconstant #.(gensym) nil . foo)) -(def-error-test defconstant.6 (defconstant #.(gensym) nil "foo" . bar)) - -(def-all-error-test defconstant.7 'symbolp - #'(lambda (x) `(defconstant ,x nil))) - -(def-all-error-test defconstant.8 'stringp - #'(lambda (x) `(defconstant ,(gensym) nil ,x))) - -;;; DEFPARAMETER - -(def-error-test defparameter.1 (defparameter)) -(def-error-test defparameter.2 (defparameter . foo)) -(def-error-test defparameter.3 (defparameter #.(gensym))) -(def-error-test defparameter.4 (defparameter #.(gensym) . foo)) -(def-error-test defparameter.5 (defparameter #.(gensym) nil . foo)) -(def-error-test defparameter.6 (defparameter #.(gensym) nil "foo" . bar)) - -(def-all-error-test defparameter.7 'symbolp - #'(lambda (x) `(defparameter ,x nil))) - -(def-all-error-test defparameter.8 'stringp - #'(lambda (x) `(defparameter ,(gensym) nil ,x))) - -;;; DEFVAR - -(def-error-test defvar.1 (defvar)) -(def-error-test defvar.2 (defvar . foo)) -(def-error-test defvar.4 (defvar #.(gensym) . foo)) -(def-error-test defvar.5 (defvar #.(gensym) nil . foo)) -(def-error-test defvar.6 (defvar #.(gensym) nil "foo" . bar)) - -(def-all-error-test defvar.7 'symbolp - #'(lambda (x) `(defvar ,x nil))) - -(def-all-error-test defvar.8 'stringp - #'(lambda (x) `(defvar ,(gensym) nil ,x))) - -;;; DESTRUCTURING-BIND - -(def-error-test destructuring-bind.1 (destructuring-bind)) -(def-error-test destructuring-bind.2 (destructuring-bind x)) -(def-all-error-test destructuring-bind.3 - (typef '(or symbol cons)) - #'(lambda (x) `(destructuring-bind ,x nil))) -(def-error-test destructuring-bind.4 (destructuring-bind (x) '(a) nil (declare) x)) - -;;; LET - -(def-error-test let.1 (let)) -(def-error-test let.2 (let . x)) -(def-all-error-test let.3 'listp #'(lambda (x) `(let ,x nil))) -(def-error-test let.4 (let () . x)) -(def-error-test let.5 (let (x . 1) nil)) -(def-error-test let.6 (let ((x) . y) nil)) -(def-error-test let.7 (let ((x 1 . 2)) nil)) -(def-error-test let.8 (let ((x 1 2)) nil)) -(def-error-test let.9 (let ((x 1) (x 2)) x)) -(def-error-test let.10 (let ((t 1)) t)) -(def-all-error-test let.11 (typef '(or cons symbol)) - #'(lambda (x) `(let (,x) nil))) -(def-all-error-test let.12 'symbolp - #'(lambda (x) `(let ((,x)) nil))) - -(def-error-test let.13 (let ((x 0) (x 1)) x)) - -;;; LET* - -(def-error-test let*.1 (let*)) -(def-error-test let*.2 (let* . x)) -(def-all-error-test let*.3 'listp #'(lambda (x) `(let* ,x nil))) -(def-error-test let*.4 (let* () . x)) -(def-error-test let*.5 (let* (x . 1) nil)) -(def-error-test let*.6 (let* ((x) . y) nil)) -(def-error-test let*.7 (let* ((x 1 . 2)) nil)) -(def-error-test let*.8 (let* ((x 1 2)) nil)) -(def-error-test let*.10 (let* ((t 1)) t)) -(def-all-error-test let*.11 (typef '(or cons symbol)) - #'(lambda (x) `(let* (,x) nil))) -(def-all-error-test let*.12 'symbolp - #'(lambda (x) `(let* ((,x)) nil))) - -;;; PROGV - -(def-error-test progv.1 (progv)) -(def-error-test progv.2 (progv '(a))) -(def-all-error-test progv.3 'listp '(progv x nil nil)) -(def-all-error-test progv.4 'listp '(progv '(a) x nil)) - -;;; SETQ - -(def-error-test setq.1 (setq . x)) -(def-error-test setq.2 (let ((x t)) (setq x))) -(def-error-test setq.3 (let ((x t)) (setq x . foo))) -(def-error-test setq.4 (let ((x 1)) (setq x nil . foo))) -(def-error-test setq.5 (let ((x 1) (y 2)) (setq x nil y))) -(def-all-error-test setq.6 'symbolp #'(lambda (x) `(setq ,x nil))) -(def-error-test setq.7 - (let ((sym (gensym))) - (eval `(defconstant ,sym nil)) - (eval `(setq ,sym t)) - (eval sym))) - -;;; PSETQ - -(def-error-test psetq.1 (psetq . x)) -(def-error-test psetq.2 (let ((x t)) (psetq x))) -(def-error-test psetq.3 (let ((x t)) (psetq x . foo))) -(def-error-test psetq.4 (let ((x 1)) (psetq x nil . foo))) -(def-error-test psetq.5 (let ((x 1) (y 2)) (psetq x nil y))) -(def-all-error-test psetq.6 'symbolp #'(lambda (x) `(psetq ,x nil))) -(def-error-test psetq.7 - (let ((sym (gensym))) - (eval `(defconstant ,sym nil)) - (eval `(psetq ,sym t)) - (eval sym))) -;;; I suggest it would be useful for PSETQ to detect when it is -;;; being asked to assign to the same variable twice, since this -;;; isn't well defined. -(def-error-test psetq.8 (let ((x 0)) (psetq x 1 x 2) x)) - -;;; BLOCK - -(def-error-test block.1 (block)) -(def-error-test block.2 (block . foo)) -(def-all-error-test block.3 'symbolp #'(lambda (x) `(block ,x))) -(def-error-test block.4 (block nil . foo)) - -;;; CATCH - -(def-error-test catch.1 (catch)) -(def-error-test catch.2 (catch . foo)) -(def-error-test catch.3 (catch 'tag . foo)) -(def-all-error-test catch.4 (constantly nil) '(catch x (throw x nil)) - :vals *cl-symbols*) - - -;;; GO - -(def-error-test go.1 (go)) -(def-error-test go.2 (go . foo)) -(def-all-error-test go.3 (typef '(or symbol integer)) - #'(lambda (x) `(go ,x))) -(def-error-test go.4 (tagbody (go done . foo) done)) -(def-error-test go.5 (tagbody (go done foo) done)) - -;; try to use GO on tag outside of dynamic-extent of TAGBODY -(def-error-test go.6 - (let ((f nil)) - (tagbody (setf f (lambda () (go foo))) foo) - (funcall f))) -(def-error-test go.7 - (funcall (block nil - (tagbody - (return (lambda () (go :foo))) - :foo (return 42))))) - - -;;; RETURN-FROM - -(def-error-test return-from.1 (return-from)) -(def-error-test return-from.2 (return-from . foo)) -(def-error-test return-from.3 (return-from foo)) -(def-error-test return-from.4 (block foo (return-from foo . t))) -(def-error-test return-from.5 (block foo (return-from foo nil . 2))) -(def-error-test return-from.6 (block foo (return-from foo nil 3))) - -;;; RETURN - -(def-error-test return.1 (return . x)) -(def-error-test return.2 (return nil . x)) - -;;; TAGBODY - -(def-error-test tagbody.1 (tagbody . x)) -(def-all-error-test tagbody.2 (typef '(or symbol integer cons)) - #'(lambda (x) `(tagbody ,x))) - -;;; THROW - -(def-error-test throw.1 (throw)) -(def-error-test throw.2 (throw . x)) -(def-error-test throw.3 (catch 'a (throw 'a))) -(def-error-test throw.4 (catch 'a (throw 'a . x))) -(def-error-test throw.5 (catch 'a (throw 'a 1 . x))) -(def-error-test throw.6 (catch 'a (throw 'a 1 'x))) - -;;; UNWIND-PROTECT - -(def-error-test unwind-protect.1 (unwind-protect)) -(def-error-test unwind-protect.2 (unwind-protect . x)) -(def-error-test unwind-protect.3 (unwind-protect nil . x)) - -;;; NOT - -(def-error-test not.1 (not . x)) -(def-error-test not.2 (not nil . x)) - - -;;; EQ - -(def-error-test eq.1 (eq . 1)) -(def-error-test eq.2 (eq 'x . 2)) -(def-error-test eq.3 (eq :foo 2 . 17)) - -;;; EQL - -(def-error-test eql.1 (eql . 1)) -(def-error-test eql.2 (eql 'x . 2)) -(def-error-test eql.3 (eql :foo 2 . 17)) - -;;; EQUAL - -(def-error-test equal.1 (equal . 1)) -(def-error-test equal.2 (equal 'x . 2)) -(def-error-test equal.3 (equal :foo 2 . 17)) - -;;; EQUALP - -(def-error-test equalp.1 (equalp . 1)) -(def-error-test equalp.2 (equalp 'x . 2)) -(def-error-test equalp.3 (equalp :foo 2 . 17)) - -;;; IDENTITY - -(def-error-test identity.1 (identity . 0)) -(def-error-test identity.2 (identity 0 . "foo")) - -;;; COMPLEMENT - -(def-error-test complement.1 (complement . 1.2)) -(def-error-test complement.2 (complement #'plusp . #(1 2))) -(def-error-test complement.3 (complement #'zerop #*110101 . #c(1 2))) -(def-all-error-test complement.4 'functionp '(complement x)) - -;;; CONSTANTLY - -(def-error-test constantly.1 (constantly . 1/2)) -(def-error-test constantly.2 (constantly :foo . 1/2)) - -;;; EVERY - -(def-error-test every.1 (every . :foo)) -(def-error-test every.2 (every 'null . (list))) -(def-error-test every.3 (every (gensym) '(a b c d))) - -;;; SOME - -(def-error-test some.1 (some . :foo)) -(def-error-test some.2 (some 'null . (list))) -(def-error-test some.3 (some (gensym) '(a b c d))) - -;;; NOTEVERY - -(def-error-test notevery.1 (notevery . :foo)) -(def-error-test notevery.2 (notevery 'null . (list))) -(def-error-test notevery.3 (notevery (gensym) '(a b c d))) - -;;; NOTANY - -(def-error-test notany.1 (notany . :foo)) -(def-error-test notany.2 (notany 'null . (list))) -(def-error-test notany.3 (notany (gensym) '(a b c d))) - -;;; AND - -(def-error-test and.1 (and . #.(make-hash-table))) -(def-error-test and.2 (and t . :foo)) - -;;; COND - -(def-error-test cond.1 (cond . 1)) -(def-error-test cond.2 (cond (t . 2))) -(def-error-test cond.3 (cond nil)) -(def-error-test cond.4 (cond (nil) . "foo")) - -;;; IF - -(def-error-test if.1 (if)) -(def-error-test if.2 (if . t)) -(def-error-test if.3 (if t)) -(def-error-test if.4 (if nil)) -(def-error-test if.5 (if t . 1)) -(def-error-test if.6 (if nil . 2)) -(def-error-test if.7 (if t 1 . 2)) -(def-error-test if.8 (if nil #\x . #\y)) -(def-error-test if.9 (if t 1 2 . 3)) -(def-error-test if.10 (if nil #\x #\y . 1.23d4)) -(def-error-test if.11 (if t 1 2 3)) -(def-error-test if.12 (if nil #\x #\y nil nil nil)) - -;;; OR - -(def-error-test or.1 (or . :foo)) -(def-error-test or.2 (or nil . :bar)) - -;;; WHEN - -(def-error-test when.1 (when)) -(def-error-test when.2 (when . #\$)) -(def-error-test when.3 (when t . x)) -(def-error-test when.4 (when t nil . "A")) - -;;; UNLESS - -(def-error-test unless.1 (unless)) -(def-error-test unless.2 (unless . #*1011)) -(def-error-test unless.3 (unless nil . t)) -(def-error-test unless.4 (unless nil nil . #())) diff --git a/t/ansi-test/beyond-ansi/errors-data-and-control-flow-3.lsp b/t/ansi-test/beyond-ansi/errors-data-and-control-flow-3.lsp deleted file mode 100644 index 7f6c788..0000000 --- a/t/ansi-test/beyond-ansi/errors-data-and-control-flow-3.lsp +++ /dev/null @@ -1,265 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Jun 14 07:00:58 2005 -;;;; Contains: Tests of non-ANSI exceptions sutation from CLHS section 5, part 3 -(in-package :ba-test) - -(compile-and-load "ba-aux.lsp") - -;;; CASE - -(def-error-test case.1 (case . 1)) -(def-error-test case.2 (case nil . 1)) -(def-error-test case.3 (case nil (nil . 1))) -(def-error-test case.4 (case 'x nil)) -(def-error-test case.5 (case 'x ((nil . x) 1))) -(def-error-test case.6 (case)) - -;;; CCASE - -(def-error-test ccase.1 (ccase . 1)) -(def-error-test ccase.2 (let ((x nil)) (ccase x . 1))) -(def-error-test ccase.3 (let ((x nil)) (ccase x (nil . 1)))) -(def-error-test ccase.4 (let ((x 'x)) (ccase x nil))) -(def-error-test ccase.5 (let ((x 'x)) (ccase x ((nil . x) 1)))) -(def-error-test ccase.6 (ccase 1 (1 nil))) ;; 1 is not a place! -(def-error-test ccase.7 (ccase)) - -;;; ECASE - -(def-error-test ecase.1 (ecase . 1)) -(def-error-test ecase.2 (ecase nil . 1)) -(def-error-test ecase.3 (ecase nil (nil . 1))) -(def-error-test ecase.4 (ecase 'x nil)) -(def-error-test ecase.5 (ecase 'x ((nil . x) 1))) -(def-error-test ecase.6 (ecase)) - -;;; TYPECASE - -(def-error-test typecase.1 (typecase)) -(def-error-test typecase.2 (typecase . :foo)) -(def-error-test typecase.3 (typecase 'x . #\X)) -(def-error-test typecase.4 (typecase 'x (#.(gensym) t))) -(def-error-test typecase.5 (typecase 'x (symbol . :foo))) -(def-error-test typecase.6 (typecase 'x . :foo)) -(def-error-test typecase.7 (typepcase 'x (t . :foo))) -(def-error-test typecase.8 (typepcase 'x (otherwise . :foo))) - -;;; CTYPECASE - -(def-error-test ctypecase.1 (ctypecase)) -(def-error-test ctypecase.2 (ctypecase . :foo)) -(def-error-test ctypecase.3 (let ((x 'x)) (ctypecase x . #\X))) -(def-error-test ctypecase.4 (let ((x 'x)) (ctypecase x (#.(gensym) t)))) -(def-error-test ctypecase.5 (let ((x 'x)) (ctypecase x (symbol . :foo)))) -(def-error-test ctypecase.6 (let ((x 'x)) (ctypecase x . :foo))) -(def-error-test ctypecase.7 (let ((x 'x)) (ctypecase x (t . :foo)))) -(def-error-test ctypecase.8 (let ((x 'x)) (ctypecase x (otherwise . :foo)))) -(def-error-test ctypecase.9 (ctypecase 1 (integer :bad))) - -;;; ETYPECASE - -(def-error-test etypecase.1 (etypecase)) -(def-error-test etypecase.2 (etypecase . :foo)) -(def-error-test etypecase.3 (etypecase 'x . #\X)) -(def-error-test etypecase.4 (etypecase 'x (#.(gensym) t))) -(def-error-test etypecase.5 (etypecase 'x (symbol . :foo))) -(def-error-test etypecase.6 (etypecase 'x . :foo)) - -;;; MULTIPLE-VALUE-BIND - -(def-error-test multiple-value-bind.1 (multiple-value-bind)) -(def-error-test multiple-value-bind.2 (multiple-value-bind . - #.(1+ most-positive-fixnum))) -(def-error-test multiple-value-bind.3 (multiple-value-bind (x))) -(def-error-test multiple-value-bind.4 (multiple-value-bind (x . y) 1 x)) -(def-error-test multiple-value-bind.5 (multiple-value-bind (x) . :foo)) -(def-error-test multiple-value-bind.6 (multiple-value-bind (x) nil . :bar)) -(def-error-test multiple-value-bind.7 - (multiple-value-bind (x) nil "doc string" . 1)) -(def-error-test multiple-value-bind.8 - (multiple-value-bind (x) nil (declare) . 1)) -(def-error-test multiple-value-bind.9 - (multiple-value-bind (x) 1 (declare (type symbol x)) x)) -(def-error-test multiple-value-bind.10 - (multiple-value-bind (x) 1 nil (declare) nil)) -(def-error-test multiple-value-bind.11 - (multiple-value-bind (x) 1 "foo" "bar" (declare) nil)) - -;;; MULTIPLE-VALUE-CALL - -(def-error-test multiple-value-call.1 (multiple-value-call)) -(def-error-test multiple-value-call.2 (multiple-value-call . :x)) -(def-error-test multiple-value-call.3 (multiple-value-call 'list . :x)) -(def-error-test multiple-value-call.4 (multiple-value-call 'list 1 . :x)) -(def-all-error-test multiple-value-call.5 'function-designator-p - '(multiple-value-call x nil)) -(def-error-test multiple-value-call.6 (multiple-value-call (gensym))) - -;;; MULTIPLE-VALUE-LIST - -(def-error-test multiple-value-list.1 (multiple-value-list)) -(def-error-test multiple-value-list.2 (multiple-value-list . 1)) -(def-error-test multiple-value-list.3 (multiple-value-list 1 . 2)) -(def-error-test multiple-value-list.4 (multiple-value-list 1 2)) - -;;; MULTIPLE-VALUE-PROG1 - -(def-error-test multiple-value-prog1.1 (multiple-value-prog1)) -(def-error-test multiple-value-prog1.2 (multiple-value-prog1 . 1)) -(def-error-test multiple-value-prog1.3 (multiple-value-prog1 :x . :y)) - -;;; MULTIPLE-VALUE-SETQ - -(def-error-test multiple-value-setq.1 (multiple-value-setq)) -(def-error-test multiple-value-setq.2 (let (x) (multiple-value-setq (x)) x)) -(def-error-test multiple-value-setq.3 - (let (x y) (multiple-value-setq (x . y) nil (list x y)))) -(def-all-error-test multiple-value-setq.4 'symbolp - #'(lambda (x) `(multiple-value-setq (,x) nil))) -(def-all-error-test multiple-value-setq.5 (constantly nil) - #'(lambda (x) `(multiple-value-setq (,x) nil)) - :vals cl-test::*cl-constant-symbols*) - -;;; VALUES - -(def-all-error-test values.1 'listp #'(lambda (x) (cons 'values x))) -(def-all-error-test values.2 'listp #'(lambda (x) (list* 'values 1 x))) - -;;; NTH-VALUE - -(def-error-test nth-value.1 (nth-value)) -(def-error-test nth-value.2 (nth-value 0)) -(def-error-test nth-value.3 (nth-value 1 '(a b c) 2)) -(def-all-error-test nth-value.4 (constantly nil) #'(lambda (x) `(nth-value ',x))) -(def-all-error-test nth-value.5 (constantly nil) #'(lambda (x) `(nth-value . ,x))) -(def-all-error-test nth-value.6 (constantly nil) #'(lambda (x) `(nth-value 0 . ,x))) -(def-all-error-test nth-value.7 'integerp #'(lambda (x) `(nth-value ',x nil))) -(def-error-test nth-value.8 (nth-value -1 'x)) -(def-all-error-test nth-value.9 'null #'(lambda (x) `(nth-value 0 'a . ,x))) - -;;; PROG - -(def-error-test prog.1 (prog)) -(def-all-error-test prog.2 'listp #'(lambda (x) `(prog . ,x))) -(def-all-error-test prog.3 'listp #'(lambda (x) `(prog ,x))) -(def-all-error-test prog.4 'listp #'(lambda (x) `(prog () . ,x))) -(def-all-error-test prog.5 (typef '(or symbol cons)) #'(lambda (x) `(prog (,x)))) -(def-all-error-test prog.6 'listp #'(lambda (x) `(prog (v . ,x)))) -(def-all-error-test prog.7 'listp #'(lambda (x) `(prog ((v . ,x))))) -(def-error-test prog.8 (prog ((x nil nil)))) -(def-all-error-test prog.9 'null #'(lambda (x) `(prog ((v nil . ,x))))) - -;;; PROG* - -(def-error-test prog*.1 (prog*)) -(def-all-error-test prog*.2 'listp #'(lambda (x) `(prog* . ,x))) -(def-all-error-test prog*.3 'listp #'(lambda (x) `(prog* ,x))) -(def-all-error-test prog*.4 'listp #'(lambda (x) `(prog* () . ,x))) -(def-all-error-test prog*.5 (typef '(or symbol cons)) #'(lambda (x) `(prog* (,x)))) -(def-all-error-test prog*.6 'listp #'(lambda (x) `(prog* (v . ,x)))) -(def-all-error-test prog*.7 'listp #'(lambda (x) `(prog* ((v . ,x))))) -(def-error-test prog*.8 (prog* ((x nil nil)))) -(def-all-error-test prog*.9 'null #'(lambda (x) `(prog* ((v nil . ,x))))) - -;;; PROG1 - -(def-error-test prog1.1 (prog1)) -(def-all-error-test prog1.2 #'listp #'(lambda (x) `(prog1 . ,x))) -(def-all-error-test prog1.3 #'listp #'(lambda (x) `(prog1 nil . ,x))) - -;;; PROG2 - -(def-error-test prog2.1 (prog2)) -(def-all-error-test prog2.2 #'listp #'(lambda (x) `(prog2 . ,x))) -(def-error-test prog2.3 (prog2 t)) -(def-all-error-test prog2.4 #'listp #'(lambda (x) `(prog2 nil . ,x))) -(def-all-error-test prog2.5 #'listp #'(lambda (x) `(prog2 'a 'b . ,x))) -(def-all-error-test prog2.6 #'listp #'(lambda (x) `(prog2 'a 'b nil . ,x))) - -;;; PROGN - -(def-all-error-test progn.1 'listp #'(lambda (x) `(progn . ,x))) -(def-all-error-test progn.2 'listp #'(lambda (x) `(progn nil . ,x))) -(def-all-error-test progn.3 'listp #'(lambda (x) `(progn 'a 'b . ,x))) - -;;; DEFINE-MODIFY-MACRO - -(def-error-test define-modify-macro.1 (define-modify-macro)) -(def-error-test define-modify-macro.2 (define-modify-macro #.(gensym))) -(def-all-error-test define-modify-macro.3 'symbolp #'(lambda (x) `(define-modify-macro ,x ()))) -(def-all-error-test define-modify-macro.4 'listp #'(lambda (x) `(define-modify-macro #.(gensym) ,x))) -(def-all-error-test define-modify-macro.5 'listp #'(lambda (x) `(define-modify-macro #.(gensym) () . ,x))) -(def-all-error-test define-modify-macro.6 'symbolp #'(lambda (x) `(define-modify-macro #.(gensym) () ,x))) -(def-all-error-test define-modify-macro.7 'stringp #'(lambda (x) `(define-modify-macro #.(gensym) () #.(gensym) ,x))) -(def-all-error-test define-modify-macro.8 'listp #'(lambda (x) `(define-modify-macro #.(gensym) () #.(gensym) . ,x))) -(def-all-error-test define-modify-macro.9 'listp #'(lambda (x) `(define-modify-macro #.(gensym) () #.(gensym) "foo" . ,x))) -(def-all-error-test define-modify-macro.10 (constantly nil) - #'(lambda (x) `(define-modify-macro #.(gensym) () #.(gensym) "foo" ,x))) - -;;; DEFSETF - -(def-error-test defsetf.1 (defsetf)) -(def-error-test defsetf.2 (defsetf #.(gensym))) -(def-all-error-test defsetf.3 'listp #'(lambda (x) `(defsetf ,x))) -(def-all-error-test defsetf.4 'listp #'(lambda (x) `(defsetf #.(gensym) . ,x))) -(def-all-error-test defsetf.5 'listp #'(lambda (x) `(defsetf #.(gensym) #.(gensym) . ,x))) -(def-all-error-test defsetf.6 'stringp #'(lambda (x) `(defsetf #.(gensym) #.(gensym) ,x))) -(def-all-error-test defsetf.7 'null #'(lambda (x) `(defsetf #.(gensym) #.(gensym) "foo" . ,x))) -(def-all-error-test defsetf.8 (constantly nil) #'(lambda (x) `(defsetf #.(gensym) #.(gensym) "foo" ,x))) -(def-all-error-test defsetf.9 (typef '(or list symbol)) #'(lambda (x) `(defsetf #.(gensym) ,x))) - -;;; Need long form defsetf error tests - -;;; FIXME: add tests for defsetf-lambda-lists - -(def-all-error-test defsetf.10 'symbolp #'(lambda (x) `(defsetf #.(gensym) (#1=#.(gensym)) (,x) #1#))) -(def-all-error-test defsetf.11 'listp #'(lambda (x) `(defsetf #.(gensym) (#.(gensym)) ., x))) -(def-all-error-test defsetf.12 'listp #'(lambda (x) `(defsetf #.(gensym) (#.(gensym)) , x))) -(def-all-error-test defsetf.13 'listp #'(lambda (x) `(defsetf #.(gensym) (#.(gensym)) (a . ,x)))) - -(def-error-test defsetf.14 (defsetf #.(gensym) () () nil (declare (optimize)) nil)) -(def-error-test defsetf.15 (defsetf #.(gensym) () () "foo" "bar" (declare (optimize)) nil)) - -;;; FIXME -- Add tests for DEFINE-SETF-EXPANDER - -(def-error-test get-setf-expansion.1 (get-setf-expansion)) -(def-all-error-test get-setf-expansion.2 'listp #'(lambda (x) `(get-setf-expansion . ,x))) -(def-all-error-test get-setf-expansion.3 (typef '(or list symbol)) - #'(lambda (x) `(get-setf-expansion ,x))) - -;;; FIXME -- figure out how to test for invalid environment objects -;;; Must make an assumption about what can be an environment - -;;; SETF tests - -(def-all-error-test setf.1 (constantly nil) #'(lambda (x) `(setf ,x))) -(def-all-error-test setf.2 'listp #'(lambda (x) `(setf . ,x))) -(def-all-error-test setf.3 'listp #'(lambda (x) `(setf ,x nil))) -(def-all-error-test setf.4 'listp #'(lambda (x) `(let (a) (setf a . ,x)))) - -;;; PSETF tests - -(def-all-error-test psetf.1 (constantly nil) #'(lambda (x) `(psetf ,x))) -(def-all-error-test psetf.2 'listp #'(lambda (x) `(psetf . ,x))) -(def-all-error-test psetf.3 'listp #'(lambda (x) `(psetf ,x nil))) -(def-all-error-test psetf.4 'listp #'(lambda (x) `(let (a) (psetf a . ,x)))) - -;;; SHIFTF tests - -(def-error-test shiftf.1 (shiftf)) -(def-all-error-test shiftf.2 'listp #'(lambda (x) `(shiftf . ,x))) -(def-all-error-test shiftf.3 (constantly nil) #'(lambda (x) `(shiftf ,x))) -(def-all-error-test shiftf.4 'listp #'(lambda (x) `(let (a) (shiftf a . ,x)))) -(def-all-error-test shiftf.5 'listp #'(lambda (x) `(shiftf ,x nil))) -(def-all-error-test shiftf.6 'listp #'(lambda (x) `(let (a b) (shiftf a b . ,x)))) -(def-all-error-test shiftf.7 'listp #'(lambda (x) `(let (a) (shiftf ,x a nil)))) -(def-all-error-test shiftf.8 'listp #'(lambda (x) `(let (a) (shiftf a ,x nil)))) - -;;; ROTATEF tests - -(def-all-error-test rotatef.1 'listp #'(lambda (x) `(rotatef . ,x))) -(def-all-error-test rotatef.2 'listp #'(lambda (x) `(rotatef ,x))) -(def-all-error-test rotatef.3 'listp #'(lambda (x) `(let (a) (rotatef a ,x)))) -(def-all-error-test rotatef.4 'listp #'(lambda (x) `(let (a) (rotatef a . ,x)))) -(def-all-error-test rotatef.5 'listp #'(lambda (x) `(let (a) (rotatef ,x a)))) diff --git a/t/ansi-test/beyond-ansi/errors-eval-compile.lsp b/t/ansi-test/beyond-ansi/errors-eval-compile.lsp deleted file mode 100644 index a4b4ee1..0000000 --- a/t/ansi-test/beyond-ansi/errors-eval-compile.lsp +++ /dev/null @@ -1,331 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat May 28 06:37:41 2005 -;;;; Contains: Tests for nonstandard exceptional conditions in section 3 - -(in-package :ba-test) - -(declaim (notinline compile-fails?)) - -(compile-and-load "ba-aux.lsp") - -;;; Utility functions - -(defun compile-fails? (&rest args) - (cl:handler-case - (let ((vals (multiple-value-list (apply #'compile args)))) - (if (and (= (length vals) 3) - (cadr vals) - (caadr vals)) - t - (apply #'values nil vals))) - (error () t))) - -;;; Tests of COMPILE - -(deftest compile.1 - (loop for x in *mini-universe* - unless (or (function-name-p x) - (compile-fails? x)) - collect x) - nil) - -(deftest compile.2 - (compile-fails? nil) - t) - -(deftest compile.3 - (let ((sym (gensym))) - (eval `(defun ,sym () nil)) - (loop for x in *mini-universe* - unless (or (functionp x) (and (consp x) (eql (car x) 'lambda)) - (compile-fails? sym x)) - collect x)) - nil) - -(deftest compile.4 - (compile-fails? nil '(lambda)) - t) - -(deftest compile.5 - (compile-fails? nil '(lambda x)) - t) - -;;; EVAL-WHEN tests - -(def-all-error-test eval-when.1 'listp '(eval-when x nil)) - -;;; LOAD-TIME-VALUE - -(def-error-test load-time-value.1 (load-time-value)) -(def-error-test load-time-value.2 (load-time-value nil nil nil)) - -;;; QUOTE - -(def-error-test quote.1 (quote)) -(def-error-test quote.2 (quote . x)) -(def-error-test quote.3 (quote t . x)) -(def-error-test quote.4 (quote t x)) - -;;; COMPILER-MACRO-FUNCTION - -(def-all-error-test compiler-macro-function.1 - 'function-name-p '(compiler-macro-function x)) - -(def-all-error-test compiler-macro-function.2 - 'function-name-p - '(setf (compiler-macro-function x) #'rplacd)) - -;;; DEFINE-COMPILER-MACRO - -(def-error-test define-compiler-macro.1 (define-compiler-macro)) - -(deftest define-compiler-macro.2 - (let ((sym (gensym))) - (eval `(signals-error (define-compiler-macro ,sym) error))) - t) - -(def-error-test define-compiler-macro.3 (define-compiler-macro . foo)) - -(deftest define-compiler-macro.4 - (let ((sym (gensym))) - (eval `(signals-error (define-compiler-macro ,sym () . foo) error))) - t) - -;;; DEFMACRO - -(def-error-test defmacro.1 (defmacro)) -(deftest defmacro.2 - (let ((sym (gensym))) - (eval `(signals-error (defmacro ,sym) error))) - t) - -(def-error-test defmacro.3 (defmacro . foo)) -(deftest defmacro.4 - (let ((sym (gensym))) - (eval `(signals-error (defmacro ,sym () . foo) error))) - t) - -;;; MACRO-FUNCTION - -(def-all-error-test macro-funtion.1 'symbolp '(macro-function x)) - -(def-all-error-test macro-funtion.2 - 'symbolp '(setf (macro-function x) (macro-function 'pop))) - -;;; DEFINE-SYMBOL-MACRO - -(deftest define-symbol-macro.1 - (let ((sym (gensym))) - (eval `(signals-error (define-symbol-macro ,sym) error))) - t) - -(deftest define-symbol-macro.2 - (let ((sym (gensym))) - (eval `(signals-error (define-symbol-macro ,sym t nil) error))) - t) - -(def-all-error-test define-symbol-macro.3 'symbolp '(define-symbol-macro x)) - -;;; IGNORE - -(def-all-error-test ignore.1 - 'symbol-or-function-p '(locally (declare (ignore x)) nil)) - -(def-error-test ignore.2 (locally (declare (ignore . foo)) nil)) - -;;; IGNORABLE - -(def-all-error-test ignorable.1 - 'symbol-or-function-p '(locally (declare (ignorable x)) nil)) - -(def-error-test ignorable.2 (locally (declare (ignorable . foo)) nil)) - -;;; DYNAMIC-EXTENT - -(def-all-error-test dynamic-extent.1 - 'symbol-or-function-p '(locally (declare (dynamic-extent x)) nil)) - -(def-error-test dynamic-extent.2 - (locally (declare (dynamic-extent . foo)) nil)) - -;;; TYPE declarations -;;; Test that violation of the type declarations is detected, and -;;; leads to an error in safe code. - -#-sbcl -(deftest type.1 - (loop for x in *mini-universe* - for tp = (type-of x) - for lambda-form = `(lambda (y) (declare (optimize safety) - (type (not ,tp) y)) y) - for fn = (progn (print lambda-form) - (eval `(function ,lambda-form))) - unless (eval `(signals-error (funcall ',fn ',x) error)) - collect x) - nil) - -(deftest type.2 - (let* ((utypes (coerce (mapcar #'type-of *universe*) 'vector)) - (n (length utypes))) - (flet ((%rtype () (elt utypes (random n)))) - (loop for x in *mini-universe* - for tp = (loop for tp = (%rtype) - while (typep x tp) - finally (return tp)) - for lambda-form = `(lambda (y) (declare (optimize safety) - (type ,tp y)) y) - for fn = (progn ;; (print lambda-form) - (eval `(function ,lambda-form))) - unless (eval `(signals-error (funcall ',fn ',x) error)) - collect x))) - nil) - -(deftest type.2c - (let* ((utypes (coerce (mapcar #'type-of *universe*) 'vector)) - (n (length utypes))) - (flet ((%rtype () (elt utypes (random n)))) - (loop for x in *mini-universe* - for tp = (loop for tp = (%rtype) - while (typep x tp) - finally (return tp)) - for lambda-form = `(lambda (y) (declare (optimize safety) - (type ,tp y)) y) - for fn = (progn ;; (print lambda-form) - (compile nil lambda-form)) - unless (eval `(signals-error (funcall ',fn ',x) error)) - collect x))) - nil) - -(deftest type.3 - (loop for x in *mini-universe* - for tp = (type-of x) - for lambda-form = `(lambda (z) (declare (optimize safety)) - (let ((y z)) - (declare (type ,tp y)) - y)) - for fn = (progn ;; (print lambda-form) - (eval `(function ,lambda-form))) - unless (or (typep nil tp) - (eval `(signals-error (funcall ',fn nil) error))) - collect x) - nil) - -(deftest type.3c - (loop for x in *mini-universe* - for tp = (type-of x) - for lambda-form = `(lambda (z) (declare (optimize safety)) - (let ((y z)) - (declare (type ,tp y)) - y)) - for fn = (progn ;; (print lambda-form) - (compile nil lambda-form)) - unless (or (typep nil tp) - (eval `(signals-error (funcall ',fn nil) error))) - collect x) - nil) - -(deftest type.4 - (loop for x in *mini-universe* - for tp = (type-of x) - for lambda-form = `(lambda (z) (declare (optimize safety)) - (the ,tp z)) - for fn = (progn ;; (print lambda-form) - (eval `(function ,lambda-form))) - unless (or (typep nil tp) - (eval `(signals-error (funcall ',fn nil) error))) - collect x) - nil) - -(deftest type.5 - (signals-error (let () (declare (type . foo)) nil) error) - t) - -(deftest type.6 - (signals-error (let () (declare (type integer . foo)) nil) error) - t) - -(deftest type.7 - (signals-error (let () (declare (integer . foo)) nil) error) - t) - -(deftest type.8 - (signals-error (let ((x (make-array 3 :initial-element 0 - :element-type '(integer 0 2)))) - (declare (optimize safety) - (type (array (integer 0 2) (3)) x)) - (setf (aref x 0) 3) - (aref x 0)) - error) - t) - -;; Move the type tests off to another file, eventually. - -;;; INLINE - -(def-all-error-test inline.1 - 'function-name-p '(locally (declare (inline x)) nil)) - -(def-error-test inline.2 (locally (declare (inline . x)) nil)) - -;;; NOTINLINE - -(def-all-error-test notinline.1 - 'function-name-p '(locally (declare (notinline x)) nil)) - -(def-error-test notinline.2 (locally (declare (notinline . x)) nil)) - -;;; FTYPE - -(def-error-test ftype.1 - (macrolet ((%m () :foo)) - (declare (ftype (function (&rest t) t) %m)) - (%m))) - -(def-error-test ftype.2 - (flet ((%f () :foo)) - (declare (ftype (function () (eql :bar)) %f)) - (%f))) - -(def-error-test ftype.3 (locally (declare (ftype)) nil)) -(def-error-test ftype.4 (locally (declare (ftype symbol)) nil)) -(def-error-test ftype.5 (locally (declare (ftype (function () t) . foo)) nil)) - -(def-all-error-test ftype.6 - 'function-name-p '(locally (declare (ftype (function () t) x)) nil)) - -;;; DECLARATIONS - -(def-error-test declaration.1 (proclaim '(declaration . foo))) - -(def-all-error-test declaration.2 'symbolp '(proclaim (declaration x))) - -;;; OPTIMIZE - -(def-error-test optimize.1 (locally (declare (optimize .foo)) nil)) - -(def-all-error-test optimize.2 - 'symbolp '(locally (declare (optimize (x 0))) nil)) - -(def-all-error-test optimize.3 - (typef '(mod 4)) '(locally (declare (optimize (speed x))))) - -;;; SPECIAL - -(def-error-test special.1 (locally (declare (special . x)) nil)) -(def-all-error-test special.2 'symbolp '(locally (declare (special x)) nil)) - -;;; LOCALLY - -(def-error-test locally.1 (locally . x)) - -;;; THE - -(def-error-test the.1 (the)) -(def-error-test the.2 (the t)) -(def-error-test the.3 (the t :a :b)) -(def-error-test the.4 (setf (the) nil)) -(def-error-test the.5 (setf (the t) nil)) -(def-error-test the.6 (let (x y) (setf (the t x y) nil))) - -;;; diff --git a/t/ansi-test/beyond-ansi/errors-iteration.lsp b/t/ansi-test/beyond-ansi/errors-iteration.lsp deleted file mode 100644 index d6d67f1..0000000 --- a/t/ansi-test/beyond-ansi/errors-iteration.lsp +++ /dev/null @@ -1,60 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Contains: Tests of non-ANSI exceptions sutation from CLHS section 6 (Iteration) - -(in-package :ba-test) - -(compile-and-load "ba-aux.lsp") - -;;; DO tests - -(def-all-error-test do.1 'listp #'(lambda (x) `(do . ,x))) -(def-all-error-test do.2 'listp #'(lambda (x) `(do () . ,x))) -(def-all-error-test do.3 #'(lambda (x) (or (symbolp x) (listp x))) #'(lambda (x) `(do (,x)))) -(def-all-error-test do.4 'listp #'(lambda (x) `(do ((a 1 (1+ a)) . ,x)))) -(def-all-error-test do.5 'listp #'(lambda (x) `(do () ,x))) -(def-all-error-test do.6 'listp #'(lambda (x) `(do () (t . ,x)))) -(def-all-error-test do.7 'listp #'(lambda (x) `(do () (t) . ,x))) -(def-all-error-test do.8 'listp #'(lambda (x) `(do ((a . ,x)) (t)))) -(def-all-error-test do.9 'listp #'(lambda (x) `(do ((a 1 . ,x)) (t)))) -(def-all-error-test do.10 'listp #'(lambda (x) `(do ((a 1 (1+ a) . ,x)) (t)))) -(def-error-test do.11 (do)) - -;;; DO* tests - -(def-all-error-test do*.1 'listp #'(lambda (x) `(do* . ,x))) -(def-all-error-test do*.2 'listp #'(lambda (x) `(do* () . ,x))) -(def-all-error-test do*.3 #'(lambda (x) (or (symbolp x) (listp x))) #'(lambda (x) `(do* (,x)))) -(def-all-error-test do*.4 'listp #'(lambda (x) `(do* ((a 1 (1+ a)) . ,x)))) -(def-all-error-test do*.5 'listp #'(lambda (x) `(do* () ,x))) -(def-all-error-test do*.6 'listp #'(lambda (x) `(do* () (t . ,x)))) -(def-all-error-test do*.7 'listp #'(lambda (x) `(do* () (t) . ,x))) -(def-all-error-test do*.8 'listp #'(lambda (x) `(do* ((a . ,x)) (t)))) -(def-all-error-test do*.9 'listp #'(lambda (x) `(do* ((a 1 . ,x)) (t)))) -(def-all-error-test do*.10 'listp #'(lambda (x) `(do* ((a 1 (1+ a) . ,x)) (t)))) -(def-error-test do*.11 (do*)) - -;;; DOTIMES tests - -(def-error-test dotimes.1 (dotimes)) -(def-all-error-test dotimes.2 'listp #'(lambda (x) `(dotimes . ,x))) -(def-all-error-test dotimes.3 'symbolp #'(lambda (x) `(dotimes (,x 1)))) -(def-all-error-test dotimes.4 (constantly nil) #'(lambda (x) `(dotimes (,x)))) -(def-all-error-test dotimes.5 'integerp #'(lambda (x) `(dotimes (i ',x)))) -(def-all-error-test dotimes.6 'listp #'(lambda (x) `(dotimes (i . ,x)))) -(def-all-error-test dotimes.7 'listp #'(lambda (x) `(dotimes (i 1 . ,x)))) -(def-all-error-test dotimes.8 'listp #'(lambda (x) `(dotimes (i 1) . ,x))) -(def-all-error-test dotimes.9 'listp #'(lambda (x) `(dotimes (i 1 nil . ,x)))) -(def-all-error-test dotimes.10 'listp #'(lambda (x) `(dotimes (i 1 nil ,x)))) - -;;; DOLIST tests - -(def-error-test dolist.1 (dolist)) -(def-all-error-test dolist.2 'listp #'(lambda (x) `(dolist . ,x))) -(def-all-error-test dolist.3 'symbolp #'(lambda (x) `(dolist (,x nil)))) -(def-all-error-test dolist.4 'listp #'(lambda (x) `(dolist (e . ,x)))) -(def-all-error-test dolist.5 'listp #'(lambda (x) `(dolist (e nil . ,x)))) -(def-all-error-test dolist.6 'listp #'(lambda (x) `(dolist (e nil nil . ,x)))) -(def-all-error-test dolist.7 'listp #'(lambda (x) `(dolist (e nil nil ,x)))) -(def-all-error-test dolist.8 'listp #'(lambda (x) `(dolist (e ',x nil)))) -(def-all-error-test dolist.9 'listp #'(lambda (x) `(dolist (e nil nil) . ,x))) diff --git a/t/ansi-test/beyond-ansi/errors-loop.lsp b/t/ansi-test/beyond-ansi/errors-loop.lsp deleted file mode 100644 index 87a6b81..0000000 --- a/t/ansi-test/beyond-ansi/errors-loop.lsp +++ /dev/null @@ -1,56 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Contains: Tests of non-ANSI exceptions sutation from CLHS for the LOOP macro - -(in-package :ba-test) - -(compile-and-load "ba-aux.lsp") - -;;; LOOP tests - -(def-all-error-test loop.1 'listp #'(lambda (x) `(loop . ,x))) - -(def-all-error-test loop.named.1 'symbolp #'(lambda (x) `(loop named ,x return nil))) -(def-all-error-test loop.named.2 'listp #'(lambda (x) `(loop named . ,x))) - -(def-error-test loop.with.1 (loop with)) -(def-all-error-test loop.with.2 #'(lambda (x) (or (symbolp x) (listp x))) - #'(lambda (x) `(loop with ,x))) -(def-all-error-test loop.with.3 'listp #'(lambda (x) `(loop with . ,x))) -(def-all-error-test loop.with.4 'listp #'(lambda (x) `(loop with x . ,x))) -(def-all-error-test loop.with.5 'listp #'(lambda (x) `(loop with x = . ,x))) -(def-all-error-test loop.with.6 'listp #'(lambda (x) `(loop with x t = . ,x))) - -(def-error-test loop.initially.1 (loop initially)) -(def-all-error-test loop.initially.2 'listp #'(lambda (x) `(loop initially . ,x))) -(def-all-error-test loop.initially.3 'listp #'(lambda (x) `(loop initially (progn) . ,x))) - -(def-error-test loop.finally.1 (loop finally)) -(def-all-error-test loop.finally.2 'listp #'(lambda (x) `(loop finally . ,x))) -(def-all-error-test loop.finally.3 'listp #'(lambda (x) `(loop finally (progn) . ,x))) - -;;; LOOP FOR clauses - -(def-error-test loop.for.1 (loop for)) -(def-all-error-test loop.for.2 'listp #'(lambda (x) `(loop for . ,x))) -(def-all-error-test loop.for.3 'symbol-or-list-p #'(lambda (x) `(loop for ,x))) -(def-all-error-test loop.for.4 'symbol-or-list-p #'(lambda (x) `(loop for ,x = nil))) -(def-error-test loop.for.5 (loop for x from)) -(def-error-test loop.for.6 (loop for x upfrom)) -(def-error-test loop.for.7 (loop for x downfrom)) -(def-error-test loop.for.8 (loop for x upto)) -(def-error-test loop.for.9 (loop for x to)) -(def-error-test loop.for.10 (loop for x below)) - -(def-all-error-test loop.for.11 (typef '(or symbol list class)) - #'(lambda (x) `(loop for e ,x = nil return e))) - -(def-all-error-test loop.for.12 'listp #'(lambda (x) `(loop for x . ,x))) -(def-all-error-test loop.for.13 'listp #'(lambda (x) `(loop for x from . ,x))) -(def-all-error-test loop.for.14 'listp #'(lambda (x) `(loop for x downfrom . ,x))) -(def-all-error-test loop.for.15 'listp #'(lambda (x) `(loop for x upfrom . ,x))) -(def-all-error-test loop.for.16 'listp #'(lambda (x) `(loop for x upto . ,x))) -(def-all-error-test loop.for.17 'listp #'(lambda (x) `(loop for x to . ,x))) -(def-all-error-test loop.for.18 'listp #'(lambda (x) `(loop for x downto . ,x))) - - diff --git a/t/ansi-test/beyond-ansi/errors-types-and-class.lsp b/t/ansi-test/beyond-ansi/errors-types-and-class.lsp deleted file mode 100644 index efc630b..0000000 --- a/t/ansi-test/beyond-ansi/errors-types-and-class.lsp +++ /dev/null @@ -1,113 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon May 30 07:49:10 2005 -;;;; Contains: Tests for non-ansi exceptional situations in Section 4 of CLHS - -(in-package :ba-test) - -(compile-and-load "ba-aux.lsp") - -;;; COERCE - -(def-all-error-test coerce.1 'listp '(coerce t x)) - -;;; DEFTYPE - -(def-error-test deftype.1 (deftype)) -(def-error-test deftype.2 (deftype #.(gensym))) -(def-error-test deftype.3 (deftype . foo)) -(def-all-error-test deftype.4 'symbolp '(deftype x () t)) - -;;; SUBTYPEP - -(def-all-error-test subtypep.1 'type-specifier-p '(subtypep x t)) -(def-all-error-test subtypep.2 'type-specifier-p '(subtypep nil x)) - -;;; TYPEP - -(def-all-error-test typep.1 'type-specifier-p '(typep nil x)) - -;;; SATISFIES - -(def-error-test satisfies.1 (typep nil '(satifies))) -(def-error-test satisfies.2 (typep nil '(satifies null nil))) -(def-all-error-test satisfies.3 'symbolp '(typep nil (satisfies x))) - -;;; MEMBER (type specifier) - -(def-error-test member.type.1 (typep nil 'member)) -(def-error-test member.type.2 (typep nil '(member . foo))) -(def-error-test member.type.3 (typep nil '(member bar . foo))) - -;;; NOT (type specifier) - -(def-error-test not.type.1 (typep nil 'not)) -(def-error-test not.type.2 (typep nil '(not))) -(def-error-test not.type.3 (typep nil '(not *))) -(def-error-test not.type.4 (typep nil '(not nil nil))) -(def-all-error-test not.type.5 'type-specifier-p '(typep nil '(not x))) -(def-error-test not.type.6 (typep nil '(not . foo))) - -;;; AND (type specifier) - -(def-error-test and.type.1 (typep nil 'and)) -(def-error-test and.type.2 (typep nil '(and *))) -(def-error-test and.type.3 (typep nil '(and t * t))) -(def-error-test and.type.4 (typep nil '(and . foo))) -(def-all-error-test and.type.5 'type-specifier-p '(typep t '(and t t x t))) - -;;; OR (type specifier) - -(def-error-test or.type.1 (typep nil 'or)) -(def-error-test or.type.2 (typep nil '(or *))) -(def-error-test or.type.3 (typep nil '(or nil * nil))) -(def-error-test or.type.4 (typep nil '(or . foo))) -(def-all-error-test or.type.5 'type-specifier-p '(typep t '(or nil x nil))) - -;;; VALUES (type specifier) - -(def-error-test values.type.1 (typep nil 'values)) -(def-error-test values.type.2 (the values (values))) -(def-error-test values.type.3 (the (values . foo) (values))) -(def-error-test values.type.4 (the (values *) t)) -(def-all-error-test values.type.5 'type-specifier-p '(the (values x) t)) - -;;; EQL (type specifier) - -(def-error-test eql.type.1 (typep nil 'eql)) -(def-error-test eql.type.2 (typep nil '(eql))) -(def-error-test eql.type.3 (typep nil '(eql nil nil))) -(def-error-test eql.type.4 (typep nil '(eql . foo))) - -;;; TYPE-ERROR-DATUM - -(def-all-error-test type-error-datum.1 - (typef 'type-error) '(type-error-datum x)) - -;;; TYPE-ERROR-EXPECTED-TYPE - -(def-all-error-test type-error-expected-type.1 - (typef 'type-error) '(type-error-expected-type x)) - -;;; FUNCTION (type specifier) - -(def-error-test function.type.1 - (locally (declare (type (function . foo) f)) nil)) -(def-error-test function.type.2 - (locally (declare (type (function () . foo) f)) nil)) -(def-error-test function.type.3 - (locally (declare (type (function (t . t) t) f)) nil)) -(def-error-test function.type.4 - (locally (declare (type (function (&optional . foo) t) f)) nil)) -(def-error-test function.type.5 - (locally (declare (type (function (&rest . foo) t) f)) nil)) -(def-error-test function.type.6 - (locally (declare (type (function (&key . foo) t) f)) nil)) -(def-error-test function.type.7 - (locally (declare (type (function (&key :foo) t) f)) nil)) -(def-error-test function.type.8 - (locally (declare (type (function (&key (:foo . bar)) t) f)) nil)) -(def-error-test function.type.9 - (locally (declare (type (function (&key (:foo t . bar)) t) f)) nil)) -(def-error-test function.type.10 - (locally (declare (type (function (&key (:foo t nil)) t) f)) nil)) diff --git a/t/ansi-test/beyond-ansi/load-ba.lsp b/t/ansi-test/beyond-ansi/load-ba.lsp deleted file mode 100644 index a02fb73..0000000 --- a/t/ansi-test/beyond-ansi/load-ba.lsp +++ /dev/null @@ -1,19 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Jun 8 06:52:59 2005 -;;;; Contains: Load beyond-ansi tests - -(let ((*default-pathname-defaults* (pathname *load-pathname*))) - (let ((*default-pathname-defaults* - (merge-pathnames (make-pathname :directory '(:relative :up))))) - (load "gclload1.lsp")) - (load "ba-test-package.lsp") - (eval '(compile-and-load "ba-aux.lsp")) - (load "errors-eval-compile.lsp") - (load "errors-types-and-class.lsp") - (load "errors-data-and-control-flow-1.lsp") - (load "errors-data-and-control-flow-2.lsp") - (load "errors-data-and-control-flow-3.lsp") - (in-package :ba-test) - ) - diff --git a/t/ansi-test/beyond-ansi/makefile b/t/ansi-test/beyond-ansi/makefile deleted file mode 100644 index 4a1e269..0000000 --- a/t/ansi-test/beyond-ansi/makefile +++ /dev/null @@ -1,6 +0,0 @@ -test: - echo "(load \"load-ba.lsp\") (in-package :ba-test) (rt:do-tests)" | $(LISP) | tee test.out - -clean: - @rm -f test.out *.cls *.fasl *.o *.so *~ *.fn *.x86f *.fasl *.ufsl *.abcl *.fas *.lib \#*\# - @rm -f gazonk* out.class *.dfsl *.d64fsl diff --git a/t/ansi-test/characters/char-compare.lsp b/t/ansi-test/characters/char-compare.lsp deleted file mode 100644 index 8054d4b..0000000 --- a/t/ansi-test/characters/char-compare.lsp +++ /dev/null @@ -1,720 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Oct 5 19:36:00 2002 -;;;; Contains: Tests of character comparison functions - - - -;;; The character comparisons should throw a PROGRAM-ERROR when -;;; safe-called with no arguments -(deftest char-compare-no-args - (loop for f in '(char= char/= char< char> char<= char>= - char-lessp char-greaterp char-equal - char-not-lessp char-not-greaterp char-not-equal) - collect (eval `(signals-error (funcall ',f) program-error))) - (t t t t t t t t t t t t)) - -(deftest char=.1 - (is-ordered-by +code-chars+ #'(lambda (c1 c2) (not (char= c1 c2)))) - t) - -(deftest char=.2 - (loop for c across +code-chars+ - always (char= c c)) - t) - -(deftest char=.3 - (every #'char= +code-chars+) - t) - -(deftest char=.4 - (is-ordered-by +rev-code-chars+ - #'(lambda (c1 c2) (not (char= c1 c2)))) - t) - -(deftest char=.order.1 - (let ((i 0)) - (values (not (char= (progn (incf i) #\a))) i)) - nil 1) - -(deftest char=.order.2 - (let ((i 0) a b) - (values (char= (progn (setf a (incf i)) #\a) - (progn (setf b (incf i)) #\b)) - i a b)) - nil 2 1 2) - -(deftest char=.order.3 - (let ((i 0) a b c) - (values - (char= (progn (setq a (incf i)) #\a) - (progn (setq b (incf i)) #\a) - (progn (setq c (incf i)) #\b)) - i a b c)) - nil 3 1 2 3) - -;;; - -(deftest char/=.1 - (is-ordered-by +code-chars+ #'char/=) - t) - -(deftest char/=.2 - (loop for c across +code-chars+ - never (char/= c c)) - t) - -(deftest char/=.3 - (every #'char/= +code-chars+) - t) - -(deftest char/=.4 - (is-ordered-by +rev-code-chars+ #'char/=) - t) - -(deftest char/=.order.1 - (let ((i 0)) - (values (not (char/= (progn (incf i) #\a))) i)) - nil 1) - -(deftest char/=.order.2 - (let ((i 0) a b) - (values (not (char/= (progn (setf a (incf i)) #\a) - (progn (setf b (incf i)) #\b))) - i a b)) - nil 2 1 2) - -(deftest char/=.order.3 - (let ((i 0) a b c) - (values - (char/= (progn (setq a (incf i)) #\a) - (progn (setq b (incf i)) #\b) - (progn (setq c (incf i)) #\b)) - i a b c)) - nil 3 1 2 3) - -;;; - -(deftest char<=.1 - (loop for c across +code-chars+ - always (char<= c c)) - t) - -(deftest char<=.2 - (every #'char<= +code-chars+) - t) - -(deftest char<=.3 - (is-antisymmetrically-ordered-by +code-chars+ #'char<=) - t) - -(deftest char<=.4 - (is-antisymmetrically-ordered-by +lower-case-chars+ #'char<=) - t) - -(deftest char<=.5 - (is-antisymmetrically-ordered-by +upper-case-chars+ #'char<=) - t) - -(deftest char<=.6 - (is-antisymmetrically-ordered-by +digit-chars+ #'char<=) - t) - -(deftest char<=.7 - (notnot-mv (or (char<= #\9 #\A) (char<= #\Z #\0))) - t) - -(deftest char<=.8 - (notnot-mv (or (char<= #\9 #\a) (char<= #\z #\0))) - t) - -(deftest char<=.order.1 - (let ((i 0)) - (values (not (char<= (progn (incf i) #\a))) i)) - nil 1) - -(deftest char<=.order.2 - (let ((i 0) a b) - (values (not (char<= (progn (setf a (incf i)) #\a) - (progn (setf b (incf i)) #\b))) - i a b)) - nil 2 1 2) - -(deftest char<=.order.3 - (let ((i 0) a b c) - (values - (char<= (progn (setq a (incf i)) #\a) - (progn (setq b (incf i)) #\b) - (progn (setq c (incf i)) #\a)) - i a b c)) - nil 3 1 2 3) - -;;; - -(deftest char<.1 - (loop for c across +code-chars+ - never (char< c c)) - t) - -(deftest char<.2 - (every #'char< +code-chars+) - t) - -(deftest char<.3 - (is-antisymmetrically-ordered-by +code-chars+ #'char<) - t) - -(deftest char<.4 - (is-antisymmetrically-ordered-by +lower-case-chars+ #'char<) - t) - -(deftest char<.5 - (is-antisymmetrically-ordered-by +upper-case-chars+ #'char<) - t) - -(deftest char<.6 - (is-antisymmetrically-ordered-by +digit-chars+ #'char<) - t) - -(deftest char<.7 - (notnot-mv (or (char< #\9 #\A) (char< #\Z #\0))) - t) - -(deftest char<.8 - (notnot-mv (or (char< #\9 #\a) (char< #\z #\0))) - t) - -(deftest char<.order.1 - (let ((i 0)) - (values (not (char< (progn (incf i) #\a))) i)) - nil 1) - -(deftest char<.order.2 - (let ((i 0) a b) - (values (not (char< (progn (setf a (incf i)) #\a) - (progn (setf b (incf i)) #\b))) - i a b)) - nil 2 1 2) - -(deftest char<.order.3 - (let ((i 0) a b c) - (values - (char< (progn (setq a (incf i)) #\a) - (progn (setq b (incf i)) #\b) - (progn (setq c (incf i)) #\a)) - i a b c)) - nil 3 1 2 3) - -(deftest char<.order.4 - (let ((i 0) a b c) - (values - (char< (progn (setq a (incf i)) #\b) - (progn (setq b (incf i)) #\a) - (progn (setq c (incf i)) #\b)) - i a b c)) - nil 3 1 2 3) - -;;; - -(deftest char>=.1 - (loop for c across +code-chars+ - always (char>= c c)) - t) - -(deftest char>=.2 - (every #'char>= +code-chars+) - t) - -(deftest char>=.3 - (is-antisymmetrically-ordered-by +rev-code-chars+ #'char>=) - t) - -(deftest char>=.4 - (is-antisymmetrically-ordered-by (reverse +lower-case-chars+) #'char>=) - t) - -(deftest char>=.5 - (is-antisymmetrically-ordered-by (reverse +upper-case-chars+) #'char>=) - t) - -(deftest char>=.6 - (is-antisymmetrically-ordered-by (reverse +digit-chars+) #'char>=) - t) - -(deftest char>=.7 - (notnot-mv (or (char>= #\A #\9) (char>= #\0 #\Z))) - t) - -(deftest char>=.8 - (notnot-mv (or (char>= #\a #\9) (char>= #\0 #\z))) - t) - -(deftest char>=.order.1 - (let ((i 0)) - (values (not (char>= (progn (incf i) #\a))) i)) - nil 1) - -(deftest char>=.order.2 - (let ((i 0) a b) - (values (not (char>= (progn (setf a (incf i)) #\b) - (progn (setf b (incf i)) #\a))) - i a b)) - nil 2 1 2) - -(deftest char>=.order.3 - (let ((i 0) a b c) - (values - (char>= (progn (setq a (incf i)) #\b) - (progn (setq b (incf i)) #\a) - (progn (setq c (incf i)) #\b)) - i a b c)) - nil 3 1 2 3) - -(deftest char>=.order.4 - (let ((i 0) a b c) - (values - (char>= (progn (setq a (incf i)) #\a) - (progn (setq b (incf i)) #\b) - (progn (setq c (incf i)) #\a)) - i a b c)) - nil 3 1 2 3) - -;;; - -(deftest char>.1 - (loop for c across +code-chars+ - never (char> c c)) - t) - -(deftest char>.2 - (every #'char> +code-chars+) - t) - -(deftest char>.3 - (is-antisymmetrically-ordered-by +rev-code-chars+ #'char>) - t) - -(deftest char>.4 - (is-antisymmetrically-ordered-by (reverse +lower-case-chars+) #'char>) - t) - -(deftest char>.5 - (is-antisymmetrically-ordered-by (reverse +upper-case-chars+) #'char>) - t) - -(deftest char>.6 - (is-antisymmetrically-ordered-by (reverse +digit-chars+) #'char>) - t) - -(deftest char>.7 - (notnot-mv (or (char> #\A #\9) (char> #\0 #\Z))) - t) - -(deftest char>.8 - (notnot-mv (or (char> #\a #\9) (char> #\0 #\z))) - t) - -(deftest char>.order.1 - (let ((i 0)) - (values (not (char> (progn (incf i) #\a))) i)) - nil 1) - -(deftest char>.order.2 - (let ((i 0) a b) - (values (not (char> (progn (setf a (incf i)) #\b) - (progn (setf b (incf i)) #\a))) - i a b)) - nil 2 1 2) - -(deftest char>.order.3 - (let ((i 0) a b c) - (values - (char> (progn (setq a (incf i)) #\b) - (progn (setq b (incf i)) #\a) - (progn (setq c (incf i)) #\b)) - i a b c)) - nil 3 1 2 3) - -(deftest char>.order.4 - (let ((i 0) a b c) - (values - (char> (progn (setq a (incf i)) #\a) - (progn (setq b (incf i)) #\b) - (progn (setq c (incf i)) #\a)) - i a b c)) - nil 3 1 2 3) - -;;; Case-insensitive comparisons - -(deftest char-equal.1 - (is-ordered-by +code-chars+ - #'(lambda (c1 c2) - (or (char= (char-downcase c1) - (char-downcase c2)) - (not (char-equal c1 c2))))) - t) - -(deftest char-equal.2 - (loop for c across +code-chars+ - always (char-equal c c)) - t) - -(deftest char-equal.3 - (loop for c across +code-chars+ - always (char-equal c)) - t) - -(deftest char-equal.4 - (is-ordered-by +rev-code-chars+ - #'(lambda (c1 c2) - (or (char= (char-downcase c1) - (char-downcase c2)) - (not (char-equal c1 c2))))) - t) - -(deftest char-equal.order.1 - (let ((i 0)) - (values (not (char-equal (progn (incf i) #\a))) i)) - nil 1) - -(deftest char-equal.order.2 - (let ((i 0) a b) - (values (char-equal (progn (setf a (incf i)) #\b) - (progn (setf b (incf i)) #\a)) - i a b)) - nil 2 1 2) - -(deftest char-equal.order.3 - (let ((i 0) a b c) - (values - (char-equal (progn (setq a (incf i)) #\a) - (progn (setq b (incf i)) #\a) - (progn (setq c (incf i)) #\b)) - i a b c)) - nil 3 1 2 3) - -(deftest char-equal.order.4 - (let ((i 0) a b c) - (values - (char-equal (progn (setq a (incf i)) #\a) - (progn (setq b (incf i)) #\b) - (progn (setq c (incf i)) #\a)) - i a b c)) - nil 3 1 2 3) - -;;; - -(deftest char-not-equal.1 - (is-ordered-by +code-chars+ #'(lambda (c1 c2) - (or (char= (char-downcase c1) - (char-downcase c2)) - (char-not-equal c1 c2)))) - t) - -(deftest char-not-equal.2 - (loop for c across +code-chars+ - never (char-not-equal c c)) - t) - -(deftest char-not-equal.3 - (every #'char-not-equal +code-chars+) - t) - -(deftest char-not-equal.4 - (is-ordered-by +rev-code-chars+ #'(lambda (c1 c2) - (or (char= (char-downcase c1) - (char-downcase c2)) - (char-not-equal c1 c2)))) - t) - -(deftest char-not-equal.order.1 - (let ((i 0)) - (values (not (char-not-equal (progn (incf i) #\a))) i)) - nil 1) - -(deftest char-not-equal.order.2 - (let ((i 0) a b) - (values (not (char-not-equal (progn (setf a (incf i)) #\b) - (progn (setf b (incf i)) #\a))) - i a b)) - nil 2 1 2) - -(deftest char-not-equal.order.3 - (let ((i 0) a b c) - (values - (char-not-equal (progn (setq a (incf i)) #\a) - (progn (setq b (incf i)) #\b) - (progn (setq c (incf i)) #\b)) - i a b c)) - nil 3 1 2 3) - -(deftest char-not-equal.order.4 - (let ((i 0) a b c) - (values - (char-not-equal (progn (setq a (incf i)) #\a) - (progn (setq b (incf i)) #\a) - (progn (setq c (incf i)) #\b)) - i a b c)) - nil 3 1 2 3) - -;;; - -(deftest char-not-greaterp.1 - (loop for c across +code-chars+ - always (char-not-greaterp c c)) - t) - -(deftest char-not-greaterp.2 - (every #'char-not-greaterp +code-chars+) - t) - -(deftest char-not-greaterp.3 - (is-case-insensitive #'char-not-greaterp) - t) - -(deftest char-not-greaterp.4 - (is-antisymmetrically-ordered-by +lower-case-chars+ #'char-not-greaterp) - t) - -(deftest char-not-greaterp.5 - (is-antisymmetrically-ordered-by +upper-case-chars+ #'char-not-greaterp) - t) - -(deftest char-not-greaterp.6 - (is-antisymmetrically-ordered-by +digit-chars+ #'char-not-greaterp) - t) - -(deftest char-not-greaterp.7 - (notnot-mv (or (char-not-greaterp #\9 #\A) (char-not-greaterp #\Z #\0))) - t) - -(deftest char-not-greaterp.8 - (notnot-mv (or (char-not-greaterp #\9 #\a) (char-not-greaterp #\z #\0))) - t) - -(deftest char-not-greaterp.order.1 - (let ((i 0)) - (values (not (char-not-greaterp (progn (incf i) #\a))) i)) - nil 1) - -(deftest char-not-greaterp.order.2 - (let ((i 0) a b) - (values (not (char-not-greaterp (progn (setf a (incf i)) #\a) - (progn (setf b (incf i)) #\b))) - i a b)) - nil 2 1 2) - -(deftest char-not-greaterp.order.3 - (let ((i 0) a b c) - (values - (char-not-greaterp (progn (setq a (incf i)) #\a) - (progn (setq b (incf i)) #\b) - (progn (setq c (incf i)) #\a)) - i a b c)) - nil 3 1 2 3) - -(deftest char-not-greaterp.order.4 - (let ((i 0) a b c) - (values - (char-not-greaterp (progn (setq a (incf i)) #\b) - (progn (setq b (incf i)) #\a) - (progn (setq c (incf i)) #\a)) - i a b c)) - nil 3 1 2 3) - -;;; - -(deftest char-lessp.1 - (loop for c across +code-chars+ - never (char-lessp c c)) - t) - -(deftest char-lessp.2 - (every #'char-lessp +code-chars+) - t) - -(deftest char-lessp.3 - (is-case-insensitive #'char-lessp) - t) - -(deftest char-lessp.4 - (is-antisymmetrically-ordered-by +lower-case-chars+ #'char-lessp) - t) - -(deftest char-lessp.5 - (is-antisymmetrically-ordered-by +upper-case-chars+ #'char-lessp) - t) - -(deftest char-lessp.6 - (is-antisymmetrically-ordered-by +digit-chars+ #'char-lessp) - t) - -(deftest char-lessp.7 - (notnot-mv (or (char-lessp #\9 #\A) (char-lessp #\Z #\0))) - t) - -(deftest char-lessp.8 - (notnot-mv (or (char-lessp #\9 #\a) (char-lessp #\z #\0))) - t) - -(deftest char-lessp.order.1 - (let ((i 0)) - (values (not (char-lessp (progn (incf i) #\a))) i)) - nil 1) - -(deftest char-lessp.order.2 - (let ((i 0) a b) - (values (not (char-lessp (progn (setf a (incf i)) #\a) - (progn (setf b (incf i)) #\b))) - i a b)) - nil 2 1 2) - -(deftest char-lessp.order.3 - (let ((i 0) a b c) - (values - (char-lessp (progn (setq a (incf i)) #\a) - (progn (setq b (incf i)) #\b) - (progn (setq c (incf i)) #\a)) - i a b c)) - nil 3 1 2 3) - -(deftest char-lessp.order.4 - (let ((i 0) a b c) - (values - (char-lessp (progn (setq a (incf i)) #\b) - (progn (setq b (incf i)) #\a) - (progn (setq c (incf i)) #\a)) - i a b c)) - nil 3 1 2 3) - -;;; - -(deftest char-not-lessp.1 - (loop for c across +code-chars+ - always (char-not-lessp c c)) - t) - -(deftest char-not-lessp.2 - (every #'char-not-lessp +code-chars+) - t) - -(deftest char-not-lessp.3 - (is-case-insensitive #'char-not-lessp) - t) - -(deftest char-not-lessp.4 - (is-antisymmetrically-ordered-by (reverse +lower-case-chars+) - #'char-not-lessp) - t) - -(deftest char-not-lessp.5 - (is-antisymmetrically-ordered-by (reverse +upper-case-chars+) #'char-not-lessp) - t) - -(deftest char-not-lessp.6 - (is-antisymmetrically-ordered-by (reverse +digit-chars+) #'char-not-lessp) - t) - -(deftest char-not-lessp.7 - (notnot-mv (or (char-not-lessp #\A #\9) (char-not-lessp #\0 #\Z))) - t) - -(deftest char-not-lessp.8 - (notnot-mv (or (char-not-lessp #\a #\9) (char-not-lessp #\0 #\z))) - t) - -(deftest char-not-lessp.order.1 - (let ((i 0)) - (values (not (char-not-lessp (progn (incf i) #\a))) i)) - nil 1) - -(deftest char-not-lessp.order.2 - (let ((i 0) a b) - (values (not (char-not-lessp (progn (setf a (incf i)) #\b) - (progn (setf b (incf i)) #\a))) - i a b)) - nil 2 1 2) - -(deftest char-not-lessp.order.3 - (let ((i 0) a b c) - (values - (char-not-lessp (progn (setq a (incf i)) #\b) - (progn (setq b (incf i)) #\a) - (progn (setq c (incf i)) #\b)) - i a b c)) - nil 3 1 2 3) - -(deftest char-not-lessp.order.4 - (let ((i 0) a b c) - (values - (char-not-lessp (progn (setq a (incf i)) #\a) - (progn (setq b (incf i)) #\b) - (progn (setq c (incf i)) #\b)) - i a b c)) - nil 3 1 2 3) - -;;; - -(deftest char-greaterp.1 - (loop for c across +code-chars+ - never (char-greaterp c c)) - t) - -(deftest char-greaterp.2 - (every #'char-greaterp +code-chars+) - t) - -(deftest char-greaterp.3 - (is-case-insensitive #'char-greaterp) - t) - -(deftest char-greaterp.4 - (is-antisymmetrically-ordered-by (reverse +lower-case-chars+) - #'char-greaterp) - t) - -(deftest char-greaterp.5 - (is-antisymmetrically-ordered-by (reverse +upper-case-chars+) #'char-greaterp) - t) - -(deftest char-greaterp.6 - (is-antisymmetrically-ordered-by (reverse +digit-chars+) #'char-greaterp) - t) - -(deftest char-greaterp.7 - (notnot-mv (or (char-greaterp #\A #\9) (char-greaterp #\0 #\Z))) - t) - -(deftest char-greaterp.8 - (notnot-mv (or (char-greaterp #\a #\9) (char-greaterp #\0 #\z))) - t) - -(deftest char-greaterp.order.1 - (let ((i 0)) - (values (not (char-greaterp (progn (incf i) #\a))) i)) - nil 1) - -(deftest char-greaterp.order.2 - (let ((i 0) a b) - (values (not (char-greaterp (progn (setf a (incf i)) #\b) - (progn (setf b (incf i)) #\a))) - i a b)) - nil 2 1 2) - -(deftest char-greaterp.order.3 - (let ((i 0) a b c) - (values - (char-greaterp (progn (setq a (incf i)) #\b) - (progn (setq b (incf i)) #\a) - (progn (setq c (incf i)) #\b)) - i a b c)) - nil 3 1 2 3) - -(deftest char-greaterp.order.4 - (let ((i 0) a b c) - (values - (char-greaterp (progn (setq a (incf i)) #\a) - (progn (setq b (incf i)) #\b) - (progn (setq c (incf i)) #\a)) - i a b c)) - nil 3 1 2 3) diff --git a/t/ansi-test/characters/character.lsp b/t/ansi-test/characters/character.lsp deleted file mode 100644 index a8b768c..0000000 --- a/t/ansi-test/characters/character.lsp +++ /dev/null @@ -1,651 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Oct 5 12:52:18 2002 -;;;; Contains: Tests associated with the class CHARACTER - - - -(deftest character-class.1 - (subtypep* 'character t) - t t) - -(deftest base-char.1 - (subtypep* 'base-char 'character) - t t) - -(deftest base-char.2 - (subtypep* 'base-char t) - t t) - -(deftest base-char.3 - (every #'(lambda (c) (typep c 'base-char)) +standard-chars+) - t) - -(deftest standard-char.1 - (subtypep* 'standard-char 'base-char) - t t) - -(deftest standard-char.2 - (subtypep* 'standard-char 'character) - t t) - -(deftest standard-char.3 - (subtypep* 'standard-char t) - t t) - -(deftest standard-char.4 - (every #'(lambda (c) (typep c 'standard-char)) +standard-chars+) - t) - -(deftest standard-char.5 - (standard-char.5.body) - ()) - -(deftest extended-char.1 - (subtypep* 'extended-char 'character) - t t) - -(deftest extended-char.2 - (subtypep* 'extended-char t) - t t) - -(deftest extended-char.3 - (extended-char.3.body) - ()) - -;;; - -(deftest character.1 - (character.1.body) - ()) - -(deftest character.2 - (character.2.body) - nil) - -(deftest character.order.1 - (let ((i 0)) - (values - (character (progn (incf i) #\a)) - i)) - #\a 1) - -(deftest character.error.1 - (signals-error (character) program-error) - t) - -(deftest character.error.2 - (signals-error (character #\a #\a) program-error) - t) - -;;; - -(deftest characterp.1 - (every #'characterp +standard-chars+) - t) - -(deftest characterp.2 - (characterp.2.body) - ()) - -(deftest characterp.3 - (characterp.3.body) - ()) - -(deftest characterp.order.1 - (let ((i 0)) - (values - (characterp (incf i)) - i)) - nil 1) - -(deftest characterp.error.1 - (signals-error (characterp) program-error) - t) - -(deftest characterp.error.2 - (signals-error (characterp #\a #\b) program-error) - t) - - -(deftest alpha-char-p.1 - (loop for c across +standard-chars+ - unless (or (find c +alpha-chars+) - (not (alpha-char-p c))) - collect c) - ()) - -;;; - -(deftest alpha-char-p.2 - (every #'alpha-char-p +alpha-chars+) - t) - -(deftest alpha-char-p.3 - (char-type-error-check #'alpha-char-p) - t) - -(deftest alpha-char-p.4 - (macrolet ((%m (z) z)) (alpha-char-p (expand-in-current-env (%m #\?)))) - nil) - -(deftest alpha-char-p.order.1 - (let ((i 0)) - (values - (alpha-char-p (progn (incf i) #\8)) - i)) - nil 1) - -(deftest alpha-char-p.error.1 - (signals-error (alpha-char-p) program-error) - t) - -(deftest alpha-char-p.error.2 - (signals-error (alpha-char-p #\a #\b) program-error) - t) - -;;; - -(deftest alphanumericp.1 - (loop for c across +standard-chars+ - unless (or (find c +alphanumeric-chars+) - (not (alphanumericp c))) - collect c) - ()) - -(deftest alphanumericp.2 - (every #'alphanumericp +alphanumeric-chars+) - t) - -(deftest alphanumericp.3 - (char-type-error-check #'alphanumericp) - t) - -(deftest alphanumericp.4 - (alphanumericp.4.body) - ()) - -(deftest alphanumericp.5 - (alphanumericp.5.body) - ()) - -(deftest alphanumbericp.6 - (macrolet ((%m (z) z)) (alphanumericp (expand-in-current-env (%m #\=)))) - nil) - -(deftest alphanumericp.order.1 - (let ((i 0)) - (values - (alphanumericp (progn (incf i) #\?)) - i)) - nil 1) - -(deftest alphanumericp.error.1 - (signals-error (alphanumericp) program-error) - t) - -(deftest alphanumericp.error.2 - (signals-error (alphanumericp #\a #\b) program-error) - t) - -;;; - -(deftest digit-char.1 - (digit-char.1.body) - nil) - -(deftest digit-char.2 - (map 'list #'digit-char (loop for i from 0 to 39 collect i)) - (#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 - nil nil nil nil nil nil nil nil nil nil - nil nil nil nil nil nil nil nil nil nil - nil nil nil nil nil nil nil nil nil nil)) - -(deftest digit-char.order.1 - (let ((i 0)) - (values - (digit-char (incf i)) - i)) - #\1 1) - -(deftest digit-char.order.2 - (let ((i 0) x) - (values - (digit-char (incf i) (progn (setf x (incf i)) 10)) - i x)) - #\1 2 2) - -(deftest digit-char.error.1 - (signals-error (digit-char) program-error) - t) - -(deftest digit-char.error.2 - (signals-error (digit-char 0 10 'foo) program-error) - t) - -;;; - -(deftest digit-char-p.1 - (digit-char-p.1.body) - ()) - -(deftest digit-char-p.2 - (digit-char-p.2.body) - ()) - -(deftest digit-char-p.3 - (digit-char-p.3.body) - ()) - -(deftest digit-char-p.4 - (digit-char-p.4.body) - ()) - -(deftest digit-char-p.5 - (loop for i from 10 to 35 - for c = (char +extended-digit-chars+ i) - when (or (digit-char-p c) - (digit-char-p (char-downcase c))) - collect c) - ()) - -(deftest digit-char-p.6 - (loop for i from 0 below 10 - for c = (char +extended-digit-chars+ i) - unless (eqlt (digit-char-p c) i) - collect i) - ()) - -(deftest digit-char-p.order.1 - (let ((i 0)) - (values - (digit-char-p (progn (incf i) #\0)) - i)) - 0 1) - -(deftest digit-char-p.order.2 - (let ((i 0) x y) - (values - (digit-char-p (progn (setf x (incf i)) #\0) - (progn (setf y (incf i)) 10)) - i x y)) - 0 2 1 2) - -(deftest digit-char-p.error.1 - (signals-error (digit-char-p) program-error) - t) - -(deftest digit-char-p.error.2 - (signals-error (digit-char-p #\1 10 'foo) program-error) - t) - -;;; - -(deftest graphic-char-p.1 - (loop for c across +standard-chars+ - unless (if (eqlt c #\Newline) - (not (graphic-char-p c)) - (graphic-char-p c)) - collect c) - ()) - -(deftest graphic-char-p.2 - (loop - for name in '("Rubout" "Page" "Backspace" "Tab" "Linefeed" "Return") - for c = (name-char name) - when (and c (graphic-char-p c)) collect c) - nil) - -(deftest graphic-char-p.3 - (char-type-error-check #'graphic-char-p) - t) - -(deftest graphic-char-p.order.1 - (let ((i 0)) - (values - (not (graphic-char-p (progn (incf i) #\a))) - i)) - nil 1) - -(deftest graphic-char-p.error.1 - (signals-error (graphic-char-p) program-error) - t) - -(deftest graphic-char-p.error.2 - (signals-error (graphic-char-p #\a #\a) program-error) - t) - -;;; - -(deftest standard-char-p.1 - (every #'standard-char-p +standard-chars+) - t) - -(deftest standard-char-p.2 - (standard-char-p.2.body) - ()) - -(deftest standard-char-p.2a - (standard-char-p.2a.body) - ()) - -(deftest standard-char-p.3 - (char-type-error-check #'standard-char-p) - t) - -(deftest standard-char-p.order.1 - (let ((i 0)) - (values - (not (standard-char-p (progn (incf i) #\a))) - i)) - nil 1) - -(deftest standard-char-p.error.1 - (signals-error (standard-char-p) program-error) - t) - -(deftest standard-char-p.error.2 - (signals-error (standard-char-p #\a #\a) program-error) - t) - -;;; - -;; based on http://unicode.org/faq/casemap_charprop.html#2 -;; ABCL doesn't implement the pairwise case mappings -;; ABCL deems Unicode conformance more important than CLHS conformance -;; SBCL's solution to make these tests work is by declaring -;; characters to be without case, even though Unicode does declare -;; a case mapping -;; -;; this comment applies to char-upcase.1 and char-upcase.2 -;; and char-downcase.1 and char-downcase.2 - -#-abcl -(deftest char-upcase.1 - (char-upcase.1.body) - ()) - -#-abcl -(deftest char-upcase.2 - (char-upcase.2.body) - ()) - -(deftest char-upcase.3 - (map 'string #'char-upcase +alpha-chars+) - "ABCDEFGHIJKLMNOPQRSTUVWXYZABCDEFGHIJKLMNOPQRSTUVWXYZ") - -(deftest char-upcase.4 - (char-type-error-check #'char-upcase) - t) - -(deftest char-upcase.order.1 - (let ((i 0)) - (values - (char-upcase (progn (incf i) #\a)) - i)) - #\A 1) - -(deftest char-upcase.error.1 - (signals-error (char-upcase) program-error) - t) - -(deftest char-upcase.error.2 - (signals-error (char-upcase #\a #\a) program-error) - t) - -;;; - -;; see char-upcase.1 why this test is commented out for ABCL -#-abcl -(deftest char-downcase.1 - (char-downcase.1.body) - ()) - -#-abcl -(deftest char-downcase.2 - (char-downcase.2.body) - ()) - -(deftest char-downcase.3 - (map 'string #'char-downcase +alpha-chars+) - "abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz") - -(deftest char-downcase.4 - (char-type-error-check #'char-downcase) - t) - -(deftest char-downcase.order.1 - (let ((i 0)) - (values - (char-downcase (progn (incf i) #\A)) - i)) - #\a 1) - -(deftest char-downcase.error.1 - (signals-error (char-downcase) program-error) - t) - -(deftest char-downcase.error.2 - (signals-error (char-downcase #\A #\A) program-error) - t) - -;;; - -(deftest upper-case-p.1 - (find-if-not #'upper-case-p +standard-chars+ :start 26 :end 52) - nil) - -(deftest upper-case-p.2 - (find-if #'upper-case-p +standard-chars+ :end 26) - nil) - -(deftest upper-case-p.3 - (find #'upper-case-p +standard-chars+ :start 52) - nil) - -(deftest upper-case-p.4 - (char-type-error-check #'upper-case-p) - t) - -(deftest upper-case-p.order.1 - (let ((i 0)) - (values - (upper-case-p (progn (incf i) #\a)) - i)) - nil 1) - -(deftest upper-case-p.error.1 - (signals-error (upper-case-p) program-error) - t) - -(deftest upper-case-p.error.2 - (signals-error (upper-case-p #\a #\A) program-error) - t) - -;;; - -(deftest lower-case-p.1 - (find-if-not #'lower-case-p +standard-chars+ :end 26) - nil) - -(deftest lower-case-p.2 - (find-if #'lower-case-p +standard-chars+ :start 26) - nil) - -(deftest lower-case-p.3 - (char-type-error-check #'lower-case-p) - t) - -(deftest lower-case-p.order.1 - (let ((i 0)) - (values - (lower-case-p (progn (incf i) #\A)) - i)) - nil 1) - -(deftest lower-case-p.error.1 - (signals-error (lower-case-p) program-error) - t) - -(deftest lower-case-p.error.2 - (signals-error (lower-case-p #\a #\a) program-error) - t) - -;;; - -(deftest both-case-p.1 - (both-case-p.1.body) - ()) - -(deftest both-case-p.2 - (both-case-p.2.body) - ()) - -(deftest both-case-p.3 - (char-type-error-check #'both-case-p) - t) - -(deftest both-case-p.4 - (notnot (macrolet ((%m (z) z)) (both-case-p (expand-in-current-env (%m #\a))))) - t) - -(deftest both-case-p.order.1 - (let ((i 0)) - (values - (both-case-p (progn (incf i) #\5)) - i)) - nil 1) - -(deftest both-case-p.error.1 - (signals-error (both-case-p) program-error) - t) - -(deftest both-case-p.error.2 - (signals-error (both-case-p #\a #\a) program-error) - t) - -;;; - -(deftest char-code.1 - (char-type-error-check #'char-code) - t) - -(deftest char-code.2 - (char-code.2.body) - ()) - -(deftest char-code.order.1 - (let ((i 0)) - (values - (not (numberp (char-code (progn (incf i) #\a)))) - i)) - nil 1) - -(deftest char-code.error.1 - (signals-error (char-code) program-error) - t) - -(deftest char-code.error.2 - (signals-error (char-code #\a #\a) program-error) - t) - -;;; - -(deftest code-char.1 - (loop for x across +standard-chars+ - unless (eqlt (code-char (char-code x)) x) - collect x) - ()) - -(deftest code-char.order.1 - (let ((i 0)) - (values - (code-char (progn (incf i) (char-code #\a))) - i)) - #\a 1) - -(deftest code-char.error.1 - (signals-error (code-char) program-error) - t) - -(deftest code-char.error.2 - (signals-error (code-char 1 1) program-error) - t) - -;;; - -(deftest char-int.1 - (loop for x across +standard-chars+ - unless (eqlt (char-int x) (char-code x)) - collect x) - ()) - -(deftest char-int.2 - (char-int.2.fn) - nil) - -(deftest char-int.order.1 - (let ((i 0)) - (values - (code-char (char-int (progn (incf i) #\a))) - i)) - #\a 1) - -(deftest char-int.error.1 - (signals-error (char-int) program-error) - t) - -(deftest char-int.error.2 - (signals-error (char-int #\a #\a) program-error) - t) - -;;; - -(deftest char-name.1 - (char-name.1.fn) - t) - -(deftest char-name.2 - (notnot-mv (string= (char-name #\Space) "Space")) - t) - -(deftest char-name.3 - (notnot-mv (string= (char-name #\Newline) "Newline")) - t) - -;;; Check that the names of various semi-standard characters are -;;; appropriate. This is complicated by the possibility that two different -;;; names may refer to the same character (as is allowed by the standard, -;;; for example in the case of Newline and Linefeed). - -(deftest char-name.4 - (loop for s in '("Rubout" "Page" "Backspace" "Return" "Tab" "Linefeed") - for c = (name-char s) - unless (or (not c) - ;; If the char-name is not even string-equal, - ;; assume we're sharing the character with some other - ;; name, and assume it's ok - (not (string-equal (char-name c) s)) - (string= (char-name c) s)) - ;; Collect list of cases that failed - collect (list s c (char-name c))) - nil) - -(deftest char-name.5 - (char-type-error-check #'char-name) - t) - -(deftest char-name.order.1 - (let ((i 0)) - (values - (char-name (progn (incf i) #\Space)) - i)) - "Space" 1) - -(deftest char-name.error.1 - (signals-error (char-name) program-error) - t) - -(deftest char-name.error.2 - (signals-error (char-name #\a #\a) program-error) - t) diff --git a/t/ansi-test/characters/load.lsp b/t/ansi-test/characters/load.lsp deleted file mode 100644 index 232d8b1..0000000 --- a/t/ansi-test/characters/load.lsp +++ /dev/null @@ -1,12 +0,0 @@ -;;;; Character tests -(compile-and-load "ANSI-TESTS:AUX;char-aux.lsp") - -(in-package #:cl-test) - -(let ((*default-pathname-defaults* - (make-pathname - :directory (pathname-directory *load-pathname*)))) - (load "character.lsp") - (load "char-compare.lsp") - (load "name-char.lsp") -) diff --git a/t/ansi-test/characters/name-char.lsp b/t/ansi-test/characters/name-char.lsp deleted file mode 100644 index aae2989..0000000 --- a/t/ansi-test/characters/name-char.lsp +++ /dev/null @@ -1,91 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Aug 29 17:14:03 2004 -;;;; Contains: Tests of NAME-CHAR - - - - - -(deftest name-char.1 - (name-char.1.body) - ()) - -(deftest name-char.2 - (loop for s in '("RubOut" "PAGe" "BacKspace" "RetUrn" "Tab" "LineFeed" - "SpaCE" "NewLine") - unless - (let ((c1 (name-char (string-upcase s))) - (c2 (name-char (string-downcase s))) - (c3 (name-char (string-capitalize s))) - (c4 (name-char s))) - (and (eqlt c1 c2) (eqlt c2 c3) (eqlt c3 c4))) - collect s) - ()) - -(deftest name-char.order.1 - (let ((i 0)) - (values - (name-char (progn (incf i) "Space")) - i)) - #\Space 1) - -;;; Specialized sequence tests - -(deftest name-char.specialized.1 - (loop for etype in '(standard-char base-char character) - append - (loop for s in '("Rubout" "Page" "Backspace" "Return" "Tab" "Linefeed" - "Space" "Newline") - for s2 = (make-array (length s) :element-type 'base-char - :initial-contents s) - unless (eql (name-char s) (name-char s2)) - collect (list s s2))) - nil) - -(deftest name-char.specialized.2 - (loop for etype in '(standard-char base-char character) - append - (loop for s in '("Rubout" "Page" "Backspace" "Return" "Tab" "Linefeed" - "Space" "Newline") - for s2 = (make-array (length s) :element-type etype - :adjustable t - :initial-contents s) - unless (eql (name-char s) (name-char s2)) - collect (list etype s s2))) - nil) - -(deftest name-char.specialized.3 - (loop for etype in '(standard-char base-char character) - append - (loop for s in '("Rubout" "Page" "Backspace" "Return" "Tab" "Linefeed" - "Space" "Newline") - for s2 = (make-array (+ 3 (length s)) :element-type etype - :fill-pointer (length s) - :initial-contents (concatenate 'string s " ")) - unless (eql (name-char s) (name-char s2)) - collect (list etype s s2))) - nil) - -(deftest name-char.specialized.4 - (loop for etype in '(standard-char base-char character) - append - (loop for s in '("Rubout" "Page" "Backspace" "Return" "Tab" "Linefeed" - "Space" "Newline") - for s1 = (make-array (+ 4 (length s)) :element-type etype - :initial-contents (concatenate 'string " " s " ")) - for s2 = (make-array (length s) :element-type etype - :displaced-to s1 :displaced-index-offset 2) - unless (eql (name-char s) (name-char s2)) - collect (list etype s s2))) - nil) - -;;; Error tests - -(deftest name-char.error.1 - (signals-error (name-char) program-error) - t) - -(deftest name-char.error.2 - (signals-error (name-char "space" "space") program-error) - t) diff --git a/t/ansi-test/cl-symbol-names.lsp b/t/ansi-test/cl-symbol-names.lsp deleted file mode 100644 index 74370ca..0000000 --- a/t/ansi-test/cl-symbol-names.lsp +++ /dev/null @@ -1,2171 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Oct 6 21:49:33 2002 -;;;; Contains: Names of standard CL symbols - -(in-package :cl-test) - -;;; -;;; These are the names of the 978 symbols that can and must be external to -;;; the COMMON-LISP package. -;;; - -(defparameter *cl-symbol-names* -(mapcar #'string -'( -#:&allow-other-keys -#:&aux -#:&body -#:&environment -#:&key -#:&optional -#:&rest -#:&whole -#:* -#:** -#:*** -#:*break-on-signals* -#:*compile-file-pathname* -#:*compile-file-truename* -#:*compile-print* -#:*compile-verbose* -#:*debug-io* -#:*debugger-hook* -#:*default-pathname-defaults* -#:*error-output* -#:*features* -#:*gensym-counter* -#:*load-pathname* -#:*load-print* -#:*load-truename* -#:*load-verbose* -#:*macroexpand-hook* -#:*modules* -#:*package* -#:*print-array* -#:*print-base* -#:*print-case* -#:*print-circle* -#:*print-escape* -#:*print-gensym* -#:*print-length* -#:*print-level* -#:*print-lines* -#:*print-miser-width* -#:*print-pprint-dispatch* -#:*print-pretty* -#:*print-radix* -#:*print-readably* -#:*print-right-margin* -#:*query-io* -#:*random-state* -#:*read-base* -#:*read-default-float-format* -#:*read-eval* -#:*read-suppress* -#:*readtable* -#:*standard-input* -#:*standard-output* -#:*terminal-io* -#:*trace-output* -#:+ -#:++ -#:+++ -#:- -#:/ -#:// -#:/// -#:/= -#:1+ -#:1- -#:< -#:<= -#:= -#:> -#:>= -#:abort -#:abs -#:acons -#:acos -#:acosh -#:add-method -#:adjoin -#:adjust-array -#:adjustable-array-p -#:allocate-instance -#:alpha-char-p -#:alphanumericp -#:and -#:append -#:apply -#:apropos -#:apropos-list -#:aref -#:arithmetic-error -#:arithmetic-error-operands -#:arithmetic-error-operation -#:array -#:array-dimension -#:array-dimension-limit -#:array-dimensions -#:array-displacement -#:array-element-type -#:array-has-fill-pointer-p -#:array-in-bounds-p -#:array-rank -#:array-rank-limit -#:array-row-major-index -#:array-total-size -#:array-total-size-limit -#:arrayp -#:ash -#:asin -#:asinh -#:assert -#:assoc -#:assoc-if -#:assoc-if-not -#:atan -#:atanh -#:atom -#:base-char -#:base-string -#:bignum -#:bit -#:bit-and -#:bit-andc1 -#:bit-andc2 -#:bit-eqv -#:bit-ior -#:bit-nand -#:bit-nor -#:bit-not -#:bit-orc1 -#:bit-orc2 -#:bit-vector -#:bit-vector-p -#:bit-xor -#:block -#:boole -#:boole-1 -#:boole-2 -#:boole-and -#:boole-andc1 -#:boole-andc2 -#:boole-c1 -#:boole-c2 -#:boole-clr -#:boole-eqv -#:boole-ior -#:boole-nand -#:boole-nor -#:boole-orc1 -#:boole-orc2 -#:boole-set -#:boole-xor -#:boolean -#:both-case-p -#:boundp -#:break -#:broadcast-stream -#:broadcast-stream-streams -#:built-in-class -#:butlast -#:byte -#:byte-position -#:byte-size -#:caaaar -#:caaadr -#:caaar -#:caadar -#:caaddr -#:caadr -#:caar -#:cadaar -#:cadadr -#:cadar -#:caddar -#:cadddr -#:caddr -#:cadr -#:call-arguments-limit -#:call-method -#:call-next-method -#:car -#:case -#:catch -#:ccase -#:cdaaar -#:cdaadr -#:cdaar -#:cdadar -#:cdaddr -#:cdadr -#:cdar -#:cddaar -#:cddadr -#:cddar -#:cdddar -#:cddddr -#:cdddr -#:cddr -#:cdr -#:ceiling -#:cell-error -#:cell-error-name -#:cerror -#:change-class -#:char -#:char-code -#:char-code-limit -#:char-downcase -#:char-equal -#:char-greaterp -#:char-int -#:char-lessp -#:char-name -#:char-not-equal -#:char-not-greaterp -#:char-not-lessp -#:char-upcase -#:char/= -#:char< -#:char<= -#:char= -#:char> -#:char>= -#:character -#:characterp -#:check-type -#:cis -#:class -#:class-name -#:class-of -#:clear-input -#:clear-output -#:close -#:clrhash -#:code-char -#:coerce -#:compilation-speed -#:compile -#:compile-file -#:compile-file-pathname -#:compiled-function -#:compiled-function-p -#:compiler-macro -#:compiler-macro-function -#:complement -#:complex -#:complexp -#:compute-applicable-methods -#:compute-restarts -#:concatenate -#:concatenated-stream -#:concatenated-stream-streams -#:cond -#:condition -#:conjugate -#:cons -#:consp -#:constantly -#:constantp -#:continue -#:control-error -#:copy-alist -#:copy-list -#:copy-pprint-dispatch -#:copy-readtable -#:copy-seq -#:copy-structure -#:copy-symbol -#:copy-tree -#:cos -#:cosh -#:count -#:count-if -#:count-if-not -#:ctypecase -#:debug -#:decf -#:declaim -#:declaration -#:declare -#:decode-float -#:decode-universal-time -#:defclass -#:defconstant -#:defgeneric -#:define-compiler-macro -#:define-condition -#:define-method-combination -#:define-modify-macro -#:define-setf-expander -#:define-symbol-macro -#:defmacro -#:defmethod -#:defpackage -#:defparameter -#:defsetf -#:defstruct -#:deftype -#:defun -#:defvar -#:delete -#:delete-duplicates -#:delete-file -#:delete-if -#:delete-if-not -#:delete-package -#:denominator -#:deposit-field -#:describe -#:describe-object -#:destructuring-bind -#:digit-char -#:digit-char-p -#:directory -#:directory-namestring -#:disassemble -#:division-by-zero -#:do -#:do* -#:do-all-symbols -#:do-external-symbols -#:do-symbols -#:documentation -#:dolist -#:dotimes -#:double-float -#:double-float-epsilon -#:double-float-negative-epsilon -#:dpb -#:dribble -#:dynamic-extent -#:ecase -#:echo-stream -#:echo-stream-input-stream -#:echo-stream-output-stream -#:ed -#:eighth -#:elt -#:encode-universal-time -#:end-of-file -#:endp -#:enough-namestring -#:ensure-directories-exist -#:ensure-generic-function -#:eq -#:eql -#:equal -#:equalp -#:error -#:etypecase -#:eval -#:eval-when -#:evenp -#:every -#:exp -#:export -#:expt -#:extended-char -#:fboundp -#:fceiling -#:fdefinition -#:ffloor -#:fifth -#:file-author -#:file-error -#:file-error-pathname -#:file-length -#:file-namestring -#:file-position -#:file-stream -#:file-string-length -#:file-write-date -#:fill -#:fill-pointer -#:find -#:find-all-symbols -#:find-class -#:find-if -#:find-if-not -#:find-method -#:find-package -#:find-restart -#:find-symbol -#:finish-output -#:first -#:fixnum -#:flet -#:float -#:float-digits -#:float-precision -#:float-radix -#:float-sign -#:floating-point-inexact -#:floating-point-invalid-operation -#:floating-point-overflow -#:floating-point-underflow -#:floatp -#:floor -#:fmakunbound -#:force-output -#:format -#:formatter -#:fourth -#:fresh-line -#:fround -#:ftruncate -#:ftype -#:funcall -#:function -#:function-keywords -#:function-lambda-expression -#:functionp -#:gcd -#:generic-function -#:gensym -#:gentemp -#:get -#:get-decoded-time -#:get-dispatch-macro-character -#:get-internal-real-time -#:get-internal-run-time -#:get-macro-character -#:get-output-stream-string -#:get-properties -#:get-setf-expansion -#:get-universal-time -#:getf -#:gethash -#:go -#:graphic-char-p -#:handler-bind -#:handler-case -#:hash-table -#:hash-table-count -#:hash-table-p -#:hash-table-rehash-size -#:hash-table-rehash-threshold -#:hash-table-size -#:hash-table-test -#:host-namestring -#:identity -#:if -#:ignorable -#:ignore -#:ignore-errors -#:imagpart -#:import -#:in-package -#:incf -#:initialize-instance -#:inline -#:input-stream-p -#:inspect -#:integer -#:integer-decode-float -#:integer-length -#:integerp -#:interactive-stream-p -#:intern -#:internal-time-units-per-second -#:intersection -#:invalid-method-error -#:invoke-debugger -#:invoke-restart -#:invoke-restart-interactively -#:isqrt -#:keyword -#:keywordp -#:labels -#:lambda -#:lambda-list-keywords -#:lambda-parameters-limit -#:last -#:lcm -#:ldb -#:ldb-test -#:ldiff -#:least-negative-double-float -#:least-negative-long-float -#:least-negative-normalized-double-float -#:least-negative-normalized-long-float -#:least-negative-normalized-short-float -#:least-negative-normalized-single-float -#:least-negative-short-float -#:least-negative-single-float -#:least-positive-double-float -#:least-positive-long-float -#:least-positive-normalized-double-float -#:least-positive-normalized-long-float -#:least-positive-normalized-short-float -#:least-positive-normalized-single-float -#:least-positive-short-float -#:least-positive-single-float -#:length -#:let -#:let* -#:lisp-implementation-type -#:lisp-implementation-version -#:list -#:list* -#:list-all-packages -#:list-length -#:listen -#:listp -#:load -#:load-logical-pathname-translations -#:load-time-value -#:locally -#:log -#:logand -#:logandc1 -#:logandc2 -#:logbitp -#:logcount -#:logeqv -#:logical-pathname -#:logical-pathname-translations -#:logior -#:lognand -#:lognor -#:lognot -#:logorc1 -#:logorc2 -#:logtest -#:logxor -#:long-float -#:long-float-epsilon -#:long-float-negative-epsilon -#:long-site-name -#:loop -#:loop-finish -#:lower-case-p -#:machine-instance -#:machine-type -#:machine-version -#:macro-function -#:macroexpand -#:macroexpand-1 -#:macrolet -#:make-array -#:make-broadcast-stream -#:make-concatenated-stream -#:make-condition -#:make-dispatch-macro-character -#:make-echo-stream -#:make-hash-table -#:make-instance -#:make-instances-obsolete -#:make-list -#:make-load-form -#:make-load-form-saving-slots -#:make-method -#:make-package -#:make-pathname -#:make-random-state -#:make-sequence -#:make-string -#:make-string-input-stream -#:make-string-output-stream -#:make-symbol -#:make-synonym-stream -#:make-two-way-stream -#:makunbound -#:map -#:map-into -#:mapc -#:mapcan -#:mapcar -#:mapcon -#:maphash -#:mapl -#:maplist -#:mask-field -#:max -#:member -#:member-if -#:member-if-not -#:merge -#:merge-pathnames -#:method -#:method-combination -#:method-combination-error -#:method-qualifiers -#:min -#:minusp -#:mismatch -#:mod -#:most-negative-double-float -#:most-negative-fixnum -#:most-negative-long-float -#:most-negative-short-float -#:most-negative-single-float -#:most-positive-double-float -#:most-positive-fixnum -#:most-positive-long-float -#:most-positive-short-float -#:most-positive-single-float -#:muffle-warning -#:multiple-value-bind -#:multiple-value-call -#:multiple-value-list -#:multiple-value-prog1 -#:multiple-value-setq -#:multiple-values-limit -#:name-char -#:namestring -#:nbutlast -#:nconc -#:next-method-p -#:nil -#:nintersection -#:ninth -#:no-applicable-method -#:no-next-method -#:not -#:notany -#:notevery -#:notinline -#:nreconc -#:nreverse -#:nset-difference -#:nset-exclusive-or -#:nstring-capitalize -#:nstring-downcase -#:nstring-upcase -#:nsublis -#:nsubst -#:nsubst-if -#:nsubst-if-not -#:nsubstitute -#:nsubstitute-if -#:nsubstitute-if-not -#:nth -#:nth-value -#:nthcdr -#:null -#:number -#:numberp -#:numerator -#:nunion -#:oddp -#:open -#:open-stream-p -#:optimize -#:or -#:otherwise -#:output-stream-p -#:package -#:package-error -#:package-error-package -#:package-name -#:package-nicknames -#:package-shadowing-symbols -#:package-use-list -#:package-used-by-list -#:packagep -#:pairlis -#:parse-error -#:parse-integer -#:parse-namestring -#:pathname -#:pathname-device -#:pathname-directory -#:pathname-host -#:pathname-match-p -#:pathname-name -#:pathname-type -#:pathname-version -#:pathnamep -#:peek-char -#:phase -#:pi -#:plusp -#:pop -#:position -#:position-if -#:position-if-not -#:pprint -#:pprint-dispatch -#:pprint-exit-if-list-exhausted -#:pprint-fill -#:pprint-indent -#:pprint-linear -#:pprint-logical-block -#:pprint-newline -#:pprint-pop -#:pprint-tab -#:pprint-tabular -#:prin1 -#:prin1-to-string -#:princ -#:princ-to-string -#:print -#:print-not-readable -#:print-not-readable-object -#:print-object -#:print-unreadable-object -#:probe-file -#:proclaim -#:prog -#:prog* -#:prog1 -#:prog2 -#:progn -#:program-error -#:progv -#:provide -#:psetf -#:psetq -#:push -#:pushnew -#:quote -#:random -#:random-state -#:random-state-p -#:rassoc -#:rassoc-if -#:rassoc-if-not -#:ratio -#:rational -#:rationalize -#:rationalp -#:read -#:read-byte -#:read-char -#:read-char-no-hang -#:read-delimited-list -#:read-from-string -#:read-line -#:read-preserving-whitespace -#:read-sequence -#:reader-error -#:readtable -#:readtable-case -#:readtablep -#:real -#:realp -#:realpart -#:reduce -#:reinitialize-instance -#:rem -#:remf -#:remhash -#:remove -#:remove-duplicates -#:remove-if -#:remove-if-not -#:remove-method -#:remprop -#:rename-file -#:rename-package -#:replace -#:require -#:rest -#:restart -#:restart-bind -#:restart-case -#:restart-name -#:return -#:return-from -#:revappend -#:reverse -#:room -#:rotatef -#:round -#:row-major-aref -#:rplaca -#:rplacd -#:safety -#:satisfies -#:sbit -#:scale-float -#:schar -#:search -#:second -#:sequence -#:serious-condition -#:set -#:set-difference -#:set-dispatch-macro-character -#:set-exclusive-or -#:set-macro-character -#:set-pprint-dispatch -#:set-syntax-from-char -#:setf -#:setq -#:seventh -#:shadow -#:shadowing-import -#:shared-initialize -#:shiftf -#:short-float -#:short-float-epsilon -#:short-float-negative-epsilon -#:short-site-name -#:signal -#:signed-byte -#:signum -#:simple-array -#:simple-base-string -#:simple-bit-vector -#:simple-bit-vector-p -#:simple-condition -#:simple-condition-format-arguments -#:simple-condition-format-control -#:simple-error -#:simple-string -#:simple-string-p -#:simple-type-error -#:simple-vector -#:simple-vector-p -#:simple-warning -#:sin -#:single-float -#:single-float-epsilon -#:single-float-negative-epsilon -#:sinh -#:sixth -#:sleep -#:slot-boundp -#:slot-exists-p -#:slot-makunbound -#:slot-missing -#:slot-unbound -#:slot-value -#:software-type -#:software-version -#:some -#:sort -#:space -#:special -#:special-operator-p -#:speed -#:sqrt -#:stable-sort -#:standard -#:standard-char -#:standard-char-p -#:standard-class -#:standard-generic-function -#:standard-method -#:standard-object -#:step -#:storage-condition -#:store-value -#:stream -#:stream-element-type -#:stream-error -#:stream-error-stream -#:stream-external-format -#:streamp -#:string -#:string-capitalize -#:string-downcase -#:string-equal -#:string-greaterp -#:string-left-trim -#:string-lessp -#:string-not-equal -#:string-not-greaterp -#:string-not-lessp -#:string-right-trim -#:string-stream -#:string-trim -#:string-upcase -#:string/= -#:string< -#:string<= -#:string= -#:string> -#:string>= -#:stringp -#:structure -#:structure-class -#:structure-object -#:style-warning -#:sublis -#:subseq -#:subsetp -#:subst -#:subst-if -#:subst-if-not -#:substitute -#:substitute-if -#:substitute-if-not -#:subtypep -#:svref -#:sxhash -#:symbol -#:symbol-function -#:symbol-macrolet -#:symbol-name -#:symbol-package -#:symbol-plist -#:symbol-value -#:symbolp -#:synonym-stream -#:synonym-stream-symbol -#:t -#:tagbody -#:tailp -#:tan -#:tanh -#:tenth -#:terpri -#:the -#:third -#:throw -#:time -#:trace -#:translate-logical-pathname -#:translate-pathname -#:tree-equal -#:truename -#:truncate -#:two-way-stream -#:two-way-stream-input-stream -#:two-way-stream-output-stream -#:type -#:type-error -#:type-error-datum -#:type-error-expected-type -#:type-of -#:typecase -#:typep -#:unbound-slot -#:unbound-slot-instance -#:unbound-variable -#:undefined-function -#:unexport -#:unintern -#:union -#:unless -#:unread-char -#:unsigned-byte -#:untrace -#:unuse-package -#:unwind-protect -#:update-instance-for-different-class -#:update-instance-for-redefined-class -#:upgraded-array-element-type -#:upgraded-complex-part-type -#:upper-case-p -#:use-package -#:use-value -#:user-homedir-pathname -#:values -#:values-list -#:variable -#:vector -#:vector-pop -#:vector-push -#:vector-push-extend -#:vectorp -#:warn -#:warning -#:when -#:wild-pathname-p -#:with-accessors -#:with-compilation-unit -#:with-condition-restarts -#:with-hash-table-iterator -#:with-input-from-string -#:with-open-file -#:with-open-stream -#:with-output-to-string -#:with-package-iterator -#:with-simple-restart -#:with-slots -#:with-standard-io-syntax -#:write -#:write-byte -#:write-char -#:write-line -#:write-sequence -#:write-string -#:write-to-string -#:y-or-n-p -#:yes-or-no-p -#:zerop))) - -(defparameter *cl-symbols* - (let ((pkg (find-package :common-lisp))) - (#-clisp progn - #+clisp ext:without-package-lock #+clisp ("COMMON-LISP") - (mapcar #'(lambda (str) (intern str pkg)) - *cl-symbol-names*)))) - -(defparameter *cl-symbols-vector* - (make-array (length *cl-symbols*) :initial-contents *cl-symbols*)) - -;;; Symbols that name unary predicate that can be safely applied to any object -(defparameter *cl-safe-predicates* - '(arrayp atom bit-vector-p characterp compiled-function-p complexp - consp floatp functionp hash-table-p keywordp listp not null - numberp packagep pathnamep random-state-p rationalp readtablep - realp simple-bit-vector-p simple-string-p simple-vector-p - streamp stringp symbolp vectorp)) - -;;; Symbols classified by their kind in the spec -(defparameter *cl-function-symbols* - '( - * - + - - - / - /= - 1+ - 1- - < - <= - = - > - >= - abort - abs - acons - acos - acosh - adjoin - adjust-array - adjustable-array-p - alpha-char-p - alphanumericp - append - apply - apropos - apropos-list - arithmetic-error-operands - arithmetic-error-operation - array-dimension - array-dimensions - array-displacement - array-element-type - array-has-fill-pointer-p - array-in-bounds-p - array-rank - array-row-major-index - array-total-size - arrayp - ash - asin - asinh - assoc-if-not - assoc - assoc-if - atan - atanh - atom - bit-and - bit-andc1 - bit-andc2 - bit-eqv - bit-ior - bit-nand - bit-nor - bit-not - bit-orc1 - bit-orc2 - bit-vector-p - bit-xor - boole - both-case-p - boundp - break - broadcast-stream-streams - butlast - byte - byte-position - byte-size - ceiling - cell-error-name - cerror - char-code - char-downcase - char-equal - char-greaterp - char-int - char-lessp - char-name - char-not-equal - char-not-greaterp - char-not-lessp - char-upcase - char/= - char< - char<= - char= - char> - char>= - character - characterp - cis - class-of - clear-input - clear-output - close - clrhash - code-char - coerce - compile - compile-file - compile-file-pathname - compiled-function-p - complement - complex - complexp - compute-restarts - concatenate - concatenated-stream-streams - conjugate - cons - consp - constantly - constantp - continue - copy-alist - copy-list - copy-pprint-dispatch - copy-readtable - copy-seq - copy-structure - copy-symbol - copy-tree - cos - cosh - count - count-if - count-if-not - decode-float - decode-universal-time - delete - delete-duplicates - delete-file - delete-if - delete-if-not - delete-package - denominator - deposit-field - describe - digit-char - digit-char-p - directory - directory-namestring - disassemble - dpb - dribble - echo-stream-input-stream - echo-stream-output-stream - ;;; The function ED is commented out because an implementation - ;;; needn't provide this function. - ;; ed - encode-universal-time - endp - enough-namestring - ensure-directories-exist - ensure-generic-function - eq - eql - equal - equalp - error - eval - evenp - every - exp - export - expt - fboundp - fceiling - ffloor - file-author - file-error-pathname - file-length - file-namestring - file-position - file-string-length - file-write-date - fill - find - find-all-symbols - find-if - find-if-not - find-package - find-restart - find-symbol - finish-output - float - float-digits - float-precision - float-radix - float-sign - floatp - floor - fmakunbound - force-output - format - fresh-line - fround - funcall - function-lambda-expression - functionp - gcd - gensym - gentemp - get-decoded-time - get-dispatch-macro-character - get-internal-real-time - get-internal-run-time - get-macro-character - get-output-stream-string - get-properties - get-setf-expansion - get-universal-time - graphic-char-p - hash-table-count - hash-table-p - hash-table-rehash-size - hash-table-rehash-threshold - hash-table-size - hash-table-test - host-namestring - identity - imagpart - import - input-stream-p - inspect - integer-decode-float - integer-length - integerp - interactive-stream-p - intern - intersection - invalid-method-error - invoke-debugger - invoke-restart - invoke-restart-interactively - isqrt - keywordp - last - lcm - ldb-test - ldiff - length - lisp-implementation-type - lisp-implementation-version - list - list* - list-all-packages - list-length - listen - listp - load - load-logical-pathname-translations - log - logand - logandc1 - logandc2 - logbitp - logcount - logeqv - logical-pathname - logior - lognand - lognor - lognot - logorc1 - logorc2 - logtest - logxor - long-site-name - lower-case-p - machine-instance - machine-type - machine-version - macroexpand - macroexpand-1 - make-array - make-broadcast-stream - make-concatenated-stream - make-condition - make-dispatch-macro-character - make-echo-stream - make-hash-table - make-list - make-load-form-saving-slots - make-package - make-pathname - make-random-state - make-sequence - make-string - make-string-input-stream - make-string-output-stream - make-symbol - make-synonym-stream - make-two-way-stream - makunbound - map - map-into - mapc - mapcan - mapcar - mapcon - maphash - mapl - maplist - max - member - member-if - member-if-not - merge - merge-pathnames - method-combination-error - min - minusp - mismatch - mod - muffle-warning - name-char - namestring - nbutlast - nconc - nintersection - not - notany - notevery - nreconc - nreverse - nset-difference - nset-exclusive-or - nstring-capitalize - nstring-downcase - nstring-upcase - nsublis - nsubst - nsubst-if - nsubst-if-not - nsubstitute - nsubstitute-if - nsubstitute-if-not - nthcdr - null - numberp - numerator - nunion - oddp - open - open-stream-p - output-stream-p - package-error-package - package-name - package-nicknames - package-shadowing-symbols - package-use-list - package-used-by-list - packagep - pairlis - parse-integer - parse-namestring - pathname - pathname-device - pathname-directory - pathname-host - pathname-match-p - pathname-name - pathname-type - pathname-version - pathnamep - peek-char - phase - plusp - position - position-if - position-if-not - pprint - pprint-dispatch - pprint-fill - pprint-indent - pprint-linear - pprint-newline - pprint-tab - pprint-tabular - prin1 - prin1-to-string - princ - princ-to-string - print - print-not-readable-object - probe-file - proclaim - provide - random - random-state-p - rassoc - rassoc-if - rassoc-if-not - rational - rationalize - rationalp - read - read-byte - read-char - read-char-no-hang - read-delimited-list - read-from-string - read-line - read-preserving-whitespace - read-sequence - readtablep - realp - realpart - reduce - rem - remhash - remove - remove-duplicates - remove-if - remove-if-not - remprop - rename-file - rename-package - replace - require - restart-name - revappend - reverse - room - round - rplaca - rplacd - scale-float - search - set - set-difference - set-dispatch-macro-character - set-exclusive-or - set-macro-character - set-pprint-dispatch - set-syntax-from-char - shadow - shadowing-import - short-site-name - signal - signum - simple-bit-vector-p - simple-condition-format-arguments - simple-condition-format-control - simple-string-p - simple-vector-p - sin - sinh - slot-exists-p - sleep - slot-boundp - slot-makunbound - slot-value - software-type - software-version - some - sort - special-operator-p - sqrt - stable-sort - standard-char-p - store-value - stream-element-type - stream-error-stream - stream-external-format - streamp - string - string-capitalize - string-downcase - string-equal - string-greaterp - string-left-trim - string-lessp - string-not-equal - string-not-greaterp - string-not-lessp - string-right-trim - string-trim - string-upcase - string/= - string< - string<= - string= - string> - string>= - stringp - sublis - subsetp - subst - subst-if - subst-if-not - substitute - substitute-if - substitute-if-not - subtypep - sxhash - symbol-name - symbol-package - symbolp - synonym-stream-symbol - tailp - tan - tanh - terpri - translate-logical-pathname - translate-pathname - tree-equal - truename - truncate ftruncate - two-way-stream-input-stream - two-way-stream-output-stream - type-error-datum - type-error-expected-type - type-of - typep - unbound-slot-instance - unexport - unintern - union - unread-char - unuse-package - upgraded-array-element-type - upgraded-complex-part-type - upper-case-p - use-package - use-value - user-homedir-pathname - values-list - vector - vector-pop - vector-push - vector-push-extend - vectorp - warn - wild-pathname-p - write - write-byte - write-char - write-line - write-sequence - write-string - write-to-string - y-or-n-p - yes-or-no-p - zerop - )) - -(defparameter *cl-variable-symbols* - '( - * - ** - *** - *break-on-signals* - *compile-file-pathname* - *compile-file-truename* - *compile-print* - *compile-verbose* - *debug-io* - *debugger-hook* - *default-pathname-defaults* - *error-output* - *features* - *gensym-counter* - *load-pathname* - *load-print* - *load-truename* - *load-verbose* - *macroexpand-hook* - *modules* - *package* - *print-array* - *print-base* - *print-case* - *print-circle* - *print-escape* - *print-gensym* - *print-length* - *print-level* - *print-lines* - *print-miser-width* - *print-pprint-dispatch* - *print-pretty* - *print-radix* - *print-readably* - *print-right-margin* - *query-io* - *random-state* - *read-base* - *read-default-float-format* - *read-eval* - *read-suppress* - *readtable* - *standard-input* - *standard-output* - *terminal-io* - *trace-output* - + - ++ - +++ - / - // - /// - - - )) - -(defparameter *cl-constant-symbols* - '( - array-dimension-limit - array-rank-limit - array-total-size-limit - boole-1 - boole-2 - boole-and - boole-andc1 - boole-andc2 - boole-c1 - boole-c2 - boole-clr - boole-eqv - boole-ior - boole-nand - boole-nor - boole-orc1 - boole-orc2 - boole-set - boole-xor - call-arguments-limit - char-code-limit - double-float-epsilon - double-float-negative-epsilon - internal-time-units-per-second - lambda-list-keywords - lambda-parameters-limit - least-negative-double-float - least-negative-long-float - least-negative-normalized-double-float - least-negative-normalized-long-float - least-negative-normalized-short-float - least-negative-normalized-single-float - least-negative-short-float - least-negative-single-float - least-positive-double-float - least-positive-long-float - least-positive-normalized-double-float - least-positive-normalized-long-float - least-positive-normalized-short-float - least-positive-normalized-single-float - least-positive-short-float - least-positive-single-float - long-float-epsilon - long-float-negative-epsilon - most-negative-double-float - most-negative-fixnum - most-negative-long-float - most-negative-short-float - most-negative-single-float - most-positive-double-float - most-positive-fixnum - most-positive-long-float - most-positive-short-float - most-positive-single-float - multiple-values-limit - nil - pi - short-float-epsilon - short-float-negative-epsilon - single-float-epsilon - single-float-negative-epsilon - t - )) - -(defparameter *cl-macro-symbols* - '( - and - assert - case - ccase - ecase - check-type - cond - declaim - defclass - defconstant - defgeneric - define-compiler-macro - define-condition - define-method-combination - define-modify-macro - define-setf-expander - define-symbol-macro - defmacro - defmethod - defpackage - defparameter - defvar - defsetf - defstruct - deftype - defun - destructuring-bind - do - do* - do-symbols - do-external-symbols - do-all-symbols - dolist - dotimes - formatter - cl:handler-bind - cl:handler-case - ignore-errors - in-package - incf - decf - lambda - loop - multiple-value-bind - multiple-value-list - multiple-value-setq - nth-value - or - pop - pprint-logical-block - print-unreadable-object - prog - prog* - prog1 - prog2 - psetq - push - pushnew - remf - restart-bind - restart-case - return - rotatef - setf - psetf - shiftf - step - time - trace - untrace - typecase - ctypecase - etypecase - when - unless - with-accessors - with-compilation-unit - with-condition-restarts - with-hash-table-iterator - with-input-from-string - with-open-file - with-open-stream - with-output-to-string - with-package-iterator - with-simple-restart - with-slots - with-standard-io-syntax - )) - -(defparameter *cl-accessor-symbols* - '( - aref - bit - caaaar - caaadr - caaar - caadar - caaddr - caadr - caar - cadaar - cadadr - cadar - caddar - cadddr - caddr - cadr - car - cdaaar - cdaadr - cdaar - cdadar - cdaddr - cdadr - cdar - cddaar - cddadr - cddar - cdddar - cddddr - cdddr - cddr - cdr - char - compiler-macro-function - eighth - elt - fdefinition - fifth - fill-pointer - find-class - first - fourth - get - getf - gethash - ldb - logical-pathname-translations - macro-function - mask-field - ninth - nth - readtable-case - rest - row-major-aref - sbit - schar - second - seventh - sixth - subseq - svref - symbol-function - symbol-plist - symbol-value - tenth - third - values - )) - -(defparameter *cl-condition-type-symbols* - '( - arithmetic-error - cell-error - condition - control-error - division-by-zero - end-of-file - error - file-error - floating-point-inexact - floating-point-invalid-operation - floating-point-overflow - floating-point-underflow - package-error - parse-error - print-not-readable - program-error - reader-error - serious-condition - simple-condition - simple-error - simple-type-error - simple-warning - storage-condition - stream-error - style-warning - type-error - unbound-slot - unbound-variable - undefined-function - warning - )) - -(defparameter *cl-class-symbols* - '(standard-object structure-object)) - -(defparameter *cl-declaration-symbols* - '( - declaration - dynamic-extent - ftype - ignore - ignorable - inline - notinline - optimize - special - type)) - -(defparameter *cl-local-function-symbols* - '(call-next-method next-method-p)) - -(defparameter *cl-local-macro-symbols* - '( - call-method - make-method - loop-finish - pprint-exit-if-list-exhausted - pprint-pop - )) - -(defparameter *cl-special-operator-symbols* - '( - block - catch - eval-when - flet - function - go - if - labels - let - let* - load-time-value - locally - macrolet - multiple-value-call - multiple-value-prog1 - progn - progv - quote - return-from - setq - symbol-macrolet - tagbody - the - throw - unwind-protect -)) - -(defparameter *cl-standard-generic-function-symbols* - '( - add-method - allocate-instance - change-class - class-name - compute-applicable-methods - describe-object - documentation - find-method - function-keywords - initialize-instance - make-instance - make-instances-obsolete - make-load-form - method-qualifiers - no-applicable-method - no-next-method - print-object - reinitialize-instance - remove-method - shared-initialize - slot-missing - slot-unbound - update-instance-for-different-class - update-instance-for-redefined-class - )) - -(defparameter *cl-system-class-symbols* - '( - array - bit-vector - broadcast-stream - built-in-class - character - class - complex - concatenated-stream - cons - echo-stream - file-stream - float - function - generic-function - hash-table - integer - list - logical-pathname - method - method-combination - null - number - package - pathname - random-state - ratio - rational - readtable - real - restart - sequence - standard-class - standard-generic-function - standard-method - stream - string - string-stream - structure-class - symbol - synonym-stream - t - two-way-stream - vector - )) - -(defparameter *cl-type-symbols* - '( - atom - base-char - base-string - bignum - bit - boolean - compiled-function - extended-char - fixnum - keyword - nil - short-float - single-float - double-float - long-float - signed-byte - simple-array - simple-base-string - simple-bit-vector - simple-string - simple-vector - standard-char - unsigned-byte - )) - -(defparameter *cl-type-specifier-symbols* - '( - and - eql - member - mod - not - or - satisfies - values - )) - -(defparameter *cl-restart-symbols* - '( - abort - continue - muffle-warning - store-value - use-value - )) - -;;; Symbols that are names of types that are also classes -;;; See figure 4-8 in section 4.3.7 -(defparameter *cl-types-that-are-classes-symbols* - '( - arithmetic-error - array - bit-vector - broadcast-stream - built-in-class - cell-error - character - class - complex - concatenated-stream - condition - cons - control-error - division-by-zero - echo-stream - end-of-file - error - file-error - file-stream - float - floating-point-inexact - floating-point-invalid-operation - floating-point-overflow - floating-point-underflow - function - generic-function - hash-table - integer - list - logical-pathname - method - method-combination - null - number - package - package-error - parse-error - pathname - print-not-readable - program-error - random-state - ratio - rational - reader-error - readtable - real - restart - sequence - serious-condition - simple-condition - simple-error - simple-type-error - simple-warning - standard-class - standard-generic-function - standard-method - standard-object - storage-condition - stream - stream-error - string - string-stream - structure-class - structure-object - style-warning - symbol - synonym-stream - t - two-way-stream - type-error - unbound-slot - unbound-variable - undefined-function - vector - warning - )) - -(defparameter *cl-all-type-symbols* - (reduce #'union - (list *cl-type-symbols* *cl-types-that-are-classes-symbols* - *cl-system-class-symbols* *cl-class-symbols* - *cl-condition-type-symbols*))) - -(defparameter *cl-non-function-macro-special-operator-symbols* - (set-difference - *cl-symbols* - (reduce #'union - (list *cl-function-symbols* - *cl-macro-symbols* - *cl-accessor-symbols* - *cl-local-function-symbols* - *cl-local-macro-symbols* - *cl-special-operator-symbols* - *cl-standard-generic-function-symbols* - '(declare ed))))) - -(defparameter *cl-function-or-accessor-symbols* - (append *cl-function-symbols* *cl-accessor-symbols*)) - -(defparameter *cl-non-variable-constant-symbols* - (set-difference - *cl-symbols* - (union *cl-variable-symbols* - *cl-constant-symbols*))) diff --git a/t/ansi-test/cl-test-package.lsp b/t/ansi-test/cl-test-package.lsp deleted file mode 100644 index c0b1487..0000000 --- a/t/ansi-test/cl-test-package.lsp +++ /dev/null @@ -1,22 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Mar 14 10:13:21 1998 -;;;; Contains: CL test case package definition - -(let* ((name :cl-test) - (pkg (find-package name))) - (unless pkg (setq pkg (make-package name :use '(:cl :regression-test)))) - (let ((*package* pkg)) - (shadow '(#:handler-case #:handler-bind)) - (import '(common-lisp-user::compile-and-load) - pkg) - (export (mapcar #'intern - (mapcar #'symbol-name - '(#:random-from-seq #:random-case #:coin - #:random-permute #:*universe* #:*mini-universe* - #:*cl-symbols* - #:signals-error #:typef))))) - (let ((s (find-symbol "QUIT" "CL-USER"))) - (when s (import s :cl-test)))) - - diff --git a/t/ansi-test/compile-and-load.lsp b/t/ansi-test/compile-and-load.lsp deleted file mode 100644 index 838e859..0000000 --- a/t/ansi-test/compile-and-load.lsp +++ /dev/null @@ -1,47 +0,0 @@ -#-(and gcl (not ansi-cl)) (in-package :common-lisp-user) -#+(and gcl (not ansi-cl)) (in-package "USER") - -#+allegro -(progn - (setq *ignore-package-name-case* t) - (when (eq excl:*current-case-mode* :case-sensitive-lower) - (push :lower-case *features*))) - -(eval-when (:load-toplevel :compile-toplevel :execute) - ;; (intern "==>" "CL-USER") - (unless (fboundp 'compile-file-pathname) - (defun compile-file-pathname (pathname) - (make-pathname :defaults pathname :type "o")))) - -;;; On-demand compile and load - -(defvar *compiled-and-loaded-files* nil - "List containing pathname, creation times for files that have already - been loaded.") - -(defun compile-and-load (pathspec &key force) - "Find the file indicated by PATHSPEC, compiling it first if - the associated compiled file is out of date." - (let* ((pathname (pathname pathspec)) - (pathname (if *load-pathname* - (merge-pathnames pathname *load-pathname*) - pathname)) - (former-data (assoc pathname *compiled-and-loaded-files* - :test #'equalp)) - (compile-pathname (compile-file-pathname pathname)) - (source-write-time (file-write-date pathname)) - (target-write-time (and (probe-file compile-pathname) - (file-write-date compile-pathname)))) - (unless (and (not force) - former-data - (>= (cadr former-data) source-write-time)) - (when (or (not target-write-time) - (<= target-write-time source-write-time)) - (handler-bind - #-sbcl () - #+sbcl ((sb-ext:code-deletion-note #'muffle-warning)) - (compile-file pathname))) - (if former-data - (setf (cadr former-data) source-write-time) - (push (list pathname source-write-time) *compiled-and-loaded-files*)) - (load compile-pathname)))) diff --git a/t/ansi-test/compileit.lsp b/t/ansi-test/compileit.lsp deleted file mode 100644 index c68978c..0000000 --- a/t/ansi-test/compileit.lsp +++ /dev/null @@ -1,38 +0,0 @@ -;;; Uncomment the next line to make MAKE-STRING and MAKE-SEQUENCE -;;; tests require that a missing :initial-element argument defaults -;;; to a single value, rather than leaving the string/sequence filled -;;; with arbitrary legal garbage. -;; (pushnew :ansi-tests-strict-initial-element *features*) - -#+allegro (run-shell-command "rm -f *.fasl") -#+cmu (run-program "rm" (list "-f" - (concatenate 'string "*." - (pathname-type (compile-file-pathname "a.lisp"))))) - -(load "gclload1.lsp") -(load "gclload2.lsp") - -(setq rt::*compile-tests* t) - -#+allegro -(progn - (rt:disable-note :nil-vectors-are-strings) - (rt:disable-note :standardized-package-nicknames) - (rt:disable-note :type-of/strict-builtins) - (rt:disable-note :assume-no-simple-streams) - (rt:disable-note :assume-no-gray-streams)) - -(in-package :cl-test) - -;;; These two tests will misbehave if the tests are being -;;; invoked from a file that is being loaded, so remove them -(when *load-pathname* - (mapc #'regression-test:rem-test '(load-pathname.1 load-truename.1))) - -;; We could use uiop:chdir here, but what about new implementations? -(setf *default-pathname-defaults* (truename #P"sandbox/")) - -(time (regression-test:do-tests)) - -#+allegro :exit -#+(or cmu sbcl gcl) (quit) diff --git a/t/ansi-test/conditions/abort.lsp b/t/ansi-test/conditions/abort.lsp deleted file mode 100644 index a99aa14..0000000 --- a/t/ansi-test/conditions/abort.lsp +++ /dev/null @@ -1,54 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Mar 23 08:25:50 2003 -;;;; Contains: Tests of the ABORT restart and function - - - -(deftest abort.1 - (restart-case - (progn (abort) 'bad) - (abort () 'good)) - good) - -(deftest abort.2 - (let ((c1 (make-condition 'error)) - (c2 (make-condition 'error))) - (restart-case - (with-condition-restarts - c1 - (list (first (compute-restarts))) - (abort c2)) - (abort () 'bad) - (abort () 'good))) - good) - -(deftest abort.3 - (restart-case - (progn (abort nil) 'bad) - (abort () 'good)) - good) - -(deftest abort.4 - (let ((c1 (make-condition 'error)) - (c2 (make-condition 'error))) - (restart-case - (with-condition-restarts - c1 - (list (first (compute-restarts))) - (abort nil)) - (abort () 'good) - (abort () 'bad))) - good) - -(deftest abort.5 - (signals-error - (let ((c1 (make-condition 'error)) - (c2 (make-condition 'error))) - (with-condition-restarts - c1 - (compute-restarts) - ;; All conditions are now associated with c1 - (abort c2))) - control-error) - t) diff --git a/t/ansi-test/conditions/assert.lsp b/t/ansi-test/conditions/assert.lsp deleted file mode 100644 index 38eee23..0000000 --- a/t/ansi-test/conditions/assert.lsp +++ /dev/null @@ -1,105 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Jan 28 06:48:19 2003 -;;;; Contains: Tests of ASSERT - - - -(deftest assert.1 - (assert t) - nil) - -(deftest assert.2 - (assert t ()) - nil) - -;;; I am assuming that when no places are given to ASSERT, -;;; it doesn't invoke any interactive handler. - -(deftest assert.3 - (let ((x nil)) - (handler-bind - ((error #'(lambda (c) - (setq x 17) - (let ((r (find-restart 'continue c))) - (when r (invoke-restart r)))))) - (assert x) - x)) - 17) - -(deftest assert.3a - (let ((x nil)) - (handler-bind - ((error #'(lambda (c) - (setq x 17) - (continue c)))) - (assert x) - x)) - 17) - - -;;; I don't yet know how to test the interactive version of ASSERT -;;; that is normally invoked when places are given. - -;;; Tests of the syntax (at least) - -(deftest assert.4 - (let (x) - (assert t (x))) - nil) - -(deftest assert.5 - (let ((x (cons 'a 'b))) - (assert t ((car x) (cdr x)))) - nil) - -(deftest assert.6 - (let ((x (vector 'a 'b 'c))) - (assert t ((aref x 0) (aref x 1) (aref x 2)) - "Vector x has value: ~A." x)) - nil) - -(deftest assert.7 - (let ((x nil)) - (handler-bind - ((simple-error #'(lambda (c) - (setq x 17) - (continue c)))) - (assert x () 'simple-error) - x)) - 17) - -(deftest assert.8 - (let ((x 0)) - (handler-bind - ((type-error #'(lambda (c) - (incf x) - (continue c)))) - (assert (> x 5) () 'type-error) - x)) - 6) - -(deftest assert.9 - (let ((x 0)) - (handler-bind - ((type-error #'(lambda (c) (declare (ignore c)) - (incf x) - (continue)))) - (assert (> x 5) () 'type-error) - x)) - 6) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest assert.10 - (macrolet - ((%m (z) z)) - (assert (expand-in-current-env (%m t)))) - nil) - -(deftest assert.11 - (macrolet - ((%m (z) z)) - (assert (expand-in-current-env (%m t)) () "Foo!")) - nil) diff --git a/t/ansi-test/conditions/cell-error-name.lsp b/t/ansi-test/conditions/cell-error-name.lsp deleted file mode 100644 index 83b7e55..0000000 --- a/t/ansi-test/conditions/cell-error-name.lsp +++ /dev/null @@ -1,52 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Jan 27 22:36:48 2003 -;;;; Contains: Tests of CELL-ERROR-NAME - - - -(deftest cell-error-name.1 - (handler-case - (eval 'my-unbound-variable) - (cell-error (c) (cell-error-name c))) - my-unbound-variable) - -(deftest cell-error-name.2 - (handler-case - (eval '(my-undefined-function)) - ;; (warning (c) (muffle-warning c)) - (cell-error (c) (cell-error-name c))) - my-undefined-function) - -(deftest cell-error-name.3 - (cell-error-name (make-condition 'unbound-variable :name 'x)) - x) - -(deftest cell-error-name.4 - (cell-error-name (make-condition 'undefined-function :name 'f)) - f) - -(deftest cell-error-name.5 - (cell-error-name (make-condition 'unbound-slot :name 's)) - s) - -(deftest cell-error-name.6 - (let ((i 0)) - (values - (cell-error-name (progn (incf i) (make-condition - 'unbound-slot :name 's))) - i)) - s 1) - - -;;; Need test raising condition unbound-slot - - -(deftest cell-error-name.error.1 - (signals-error (cell-error-name) program-error) - t) - -(deftest cell-error-name.error.2 - (signals-error (cell-error-name (make-condition 'unbound-variable :name 'foo) nil) - program-error) - t) diff --git a/t/ansi-test/conditions/cerror.lsp b/t/ansi-test/conditions/cerror.lsp deleted file mode 100644 index 1f278c4..0000000 --- a/t/ansi-test/conditions/cerror.lsp +++ /dev/null @@ -1,71 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Feb 15 19:45:27 2003 -;;;; Contains: Tests of CERROR - - - - -(deftest cerror.1 - (let ((fmt "Cerror")) - (handler-case (cerror "Keep going." fmt) - (simple-error (c) (frob-simple-error c fmt)))) - t) - -(deftest cerror.2 - (let* ((fmt "Cerror") - (cnd (make-condition 'simple-error :format-control fmt))) - (handler-case (cerror "Continue on." cnd) - (simple-error (c) (frob-simple-error c fmt)))) - t) - -(deftest cerror.2a - (let* ((fmt (formatter "Cerror")) - (cnd (make-condition 'simple-error :format-control fmt))) - (handler-case (cerror "Continue on." cnd) - (simple-error (c) (frob-simple-error c fmt)))) - t) - -(deftest cerror.3 - (let ((fmt "Cerror")) - (handler-case (cerror "Continue" 'simple-error :format-control fmt) - (simple-error (c) (frob-simple-error c fmt)))) - t) - -(deftest cerror.4 - (let ((fmt "Cerror: ~A")) - (handler-case (cerror "On on" fmt 10) - (simple-error (c) (frob-simple-error c fmt 10)))) - t) - -(deftest cerror.4a - (let ((fmt (formatter "Cerror: ~A"))) - (handler-case (cerror "On on" fmt 10) - (simple-error (c) (frob-simple-error c fmt 10)))) - t) - -(deftest cerror.5 - (let ((fmt (formatter "Cerror"))) - (handler-case (cerror "Keep going." fmt) - (simple-error (c) (frob-simple-error c fmt)))) - t) - -;;; Continuing from a cerror - -(deftest cerror.6 - (handler-bind ((simple-error #'(lambda (c) (continue c)))) - (progn - (cerror "Wooo" 'simple-error) - 10)) - 10) - -;;; Program error cases - -(deftest cerror.error.1 - (signals-error (cerror) program-error) - t) - -(deftest cerror.error.2 - (signals-error (cerror "foo") program-error) - t) - diff --git a/t/ansi-test/conditions/check-type.lsp b/t/ansi-test/conditions/check-type.lsp deleted file mode 100644 index 7749c81..0000000 --- a/t/ansi-test/conditions/check-type.lsp +++ /dev/null @@ -1,83 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Feb 15 20:12:04 2003 -;;;; Contains: Tests of CHECK-TYPE - - - -(deftest check-type.1 - (let ((x 'a)) - (values (check-type x symbol) x)) - nil a) - -(deftest check-type.2 - (signals-type-error x 'a (check-type x integer)) - t) - -(deftest check-type.3 - (let ((x 'a)) - (handler-bind - ((type-error #'(lambda (c) - (assert (eql (type-error-datum c) x)) - (assert (not (typep x (type-error-expected-type c)))) - ;; Can we assume the expected-type is NUMBER? - (store-value 15 c)))) - (values (check-type x number) x))) - nil 15) - -(deftest check-type.4 - (let ((x 'a)) - (values (check-type x symbol "a symbol") x)) - nil a) - -(deftest check-type.5 - (let ((x 'a)) - (handler-bind - ((type-error #'(lambda (c) - (assert (eql (type-error-datum c) x)) - (assert (not (typep x (type-error-expected-type c)))) - ;; Can we assume the expected-type is STRING? - (store-value "abc" c)))) - (values (check-type x string "a string") x))) - nil "abc") - -(deftest check-type.6 - (let ((x 'a)) - (handler-bind - ((type-error #'(lambda (c) - (assert (eql (type-error-datum c) x)) - (assert (not (typep x (type-error-expected-type c)))) - ;; Can we assume the expected-type is NUMBER? - (store-value 15 nil)))) - (values (check-type x number) x))) - nil 15) - -(deftest check-type.7 - (let ((x 'a)) - (handler-bind - ((type-error #'(lambda (c) - (assert (eql (type-error-datum c) x)) - (assert (not (typep x (type-error-expected-type c)))) - ;; Can we assume the expected-type is NUMBER? - (store-value 15)))) - (values (check-type x number) x))) - nil 15) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest check-type.8 - (let ((x 10)) - (macrolet - ((%m (z) z)) - (check-type (expand-in-current-env (%m x)) - (integer 8 13)))) - nil) - -(deftest check-type.9 - (let ((x 10)) - (macrolet - ((%m (z) z)) - (check-type x (integer 9 12) (expand-in-current-env (%m "Foo!"))))) - nil) - diff --git a/t/ansi-test/conditions/compute-restarts.lsp b/t/ansi-test/conditions/compute-restarts.lsp deleted file mode 100644 index a16d06f..0000000 --- a/t/ansi-test/conditions/compute-restarts.lsp +++ /dev/null @@ -1,131 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Mar 22 23:48:53 2003 -;;;; Contains: Tests of COMPUTE-RESTARTS - - - -(deftest compute-restarts.1 - (loop for r in (compute-restarts) - always (typep r 'restart)) - t) - -(deftest compute-restarts.2 - (loop for r in (compute-restarts) - always (typep r (find-class 'restart))) - t) - -(deftest compute-restarts.3 - (restart-case - (let ((r (find-restart 'foo))) - (eqt r (find 'foo (compute-restarts) :key #'restart-name))) - (foo () nil)) - t) - -(deftest compute-restarts.4 - (loop for r1 in (compute-restarts) - for r2 in (compute-restarts) - always (eq r1 r2)) - t) - -(deftest compute-restarts.5 - (restart-case - (loop for r1 in (compute-restarts) - for r2 in (compute-restarts) - always (eq r1 r2)) - (foo () t) - (bar () t) - (foo () nil)) - t) - -(deftest compute-restarts.6 - (restart-case - (let* ((restarts (compute-restarts)) - (p (position 'foo restarts :key #'restart-name)) - (r (find 'foo restarts :start (1+ p) :key #'restart-name))) - (invoke-restart r)) - (foo () 'bad) - (foo () 'good) - (foo () 'bad)) - good) - -(deftest compute-restarts.7 - (handler-bind - ((error #'(lambda (c) - (let* ((restarts (compute-restarts c)) - (r (remove 'foo restarts - :test-not #'eq - :key #'restart-name))) - (invoke-restart (second r)))))) - (restart-case - (error "an error") - (foo () 'bad) - (foo () 'good) - (foo () 'bad))) - good) - -(deftest compute-restarts.8 - (handler-bind - ((error #'(lambda (c) - (declare (ignore c)) - (let* ((restarts (compute-restarts)) - (r (remove 'foo restarts - :test-not #'eq - :key #'restart-name))) - (invoke-restart (second r)))))) - (restart-case - (error "an error") - (foo () 'bad) - (foo () 'good) - (foo () 'bad))) - good) - -(deftest compute-restarts.9 - (let ((c2 (make-condition 'error))) - (block done - (handler-bind - ((error #'(lambda (c) - (declare (ignore c)) - (let* ((restarts (compute-restarts c2)) - (r (remove 'foo restarts - :test-not #'eq - :key #'restart-name))) - ;; (write restarts) - (return-from done - (values r - (mapcar #'restart-name r))))))) - (restart-case - (error "an error") - (foo () 'bad) - (foo () 'also-bad))))) - nil nil) - -;;; This test is disabled until I figure out how to fix -;;; it. See sbcl-devel mailing list, Oct 2005 -#| -(deftest compute-restarts.10 - (let ((c2 (make-condition 'error))) - (block done - (handler-bind - ((error #'(lambda (c) - (declare (ignore c)) - (let* ((restarts (compute-restarts c2)) - (r (remove 'foo restarts - :test-not #'eq - :key #'restart-name))) - ;; (write restarts) - (return-from done - (values r - (mapcar #'restart-name r))))))) - (restart-case - (progn (error "an error")) - (foo () :test (lambda (c) (or (null c) (not (eq c c2)))) - 'bad) - (foo () :test (lambda (c) (or (null c) (not (eq c c2)))) - 'also-bad))))) - nil nil) -|# - - - - diff --git a/t/ansi-test/conditions/condition.lsp b/t/ansi-test/conditions/condition.lsp deleted file mode 100644 index 2a96788..0000000 --- a/t/ansi-test/conditions/condition.lsp +++ /dev/null @@ -1,63 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Jan 27 22:13:25 2003 -;;;; Contains: Tests of class CONDITION - - - -(deftest condition.1 - (notnot-mv (find-class 'condition nil)) - t) - -(defparameter *allowed-condition-inclusions* - '( - (arithmetic-error error serious-condition condition) - (cell-error error serious-condition condition) - (condition) - (control-error error serious-condition condition) - (division-by-zero arithmetic-error error serious-condition condition) - (end-of-file stream-error error serious-condition condition) - (error serious-condition condition) - (file-error error serious-condition condition) - (floating-point-inexact arithmetic-error error serious-condition condition) - (floating-point-invalid-operation arithmetic-error error serious-condition condition) - (floating-point-overflow arithmetic-error error serious-condition condition) - (floating-point-underflow arithmetic-error error serious-condition condition) - (package-error error serious-condition condition) - (parse-error error serious-condition condition) - (print-not-readable error serious-condition condition) - (program-error error serious-condition condition) - (reader-error parse-error stream-error error serious-condition condition) - (serious-condition condition) - (simple-condition condition) - (simple-error simple-condition error serious-condition condition) - (simple-type-error simple-condition type-error error serious-condition condition) - (simple-warning simple-condition warning condition) - (storage-condition serious-condition condition) - (stream-error error serious-condition condition) - (style-warning warning condition) - (type-error error serious-condition condition) - (unbound-slot cell-error error serious-condition condition) - (unbound-variable cell-error error serious-condition condition) - (undefined-function cell-error error serious-condition condition) - (warning condition) - )) - -;;; Relationships given in *allowed-condition-inclusions* are the only -;;; subtype relationships allowed on condition types -(deftest condition.2 - (loop for (cnd . supers) in *allowed-condition-inclusions* - append (loop for super in supers - unless (subtypep cnd super) - collect (list cnd super))) - nil) - -(deftest condition.3 - ;; Relationships given in *allowed-condition-inclusions* are the only - ;; subtype relationships allowed on condition types - (loop for cnds in *allowed-condition-inclusions* - for cnd = (first cnds) - append (loop for super in (set-difference *condition-types* cnds) - when (subtypep cnd super) - collect (list cnd super))) - nil) diff --git a/t/ansi-test/conditions/continue.lsp b/t/ansi-test/conditions/continue.lsp deleted file mode 100644 index 35cecf4..0000000 --- a/t/ansi-test/conditions/continue.lsp +++ /dev/null @@ -1,54 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Mar 23 08:37:15 2003 -;;;; Contains: Tests of CONTINUE restart and function - - - -(deftest continue.1 - (restart-case - (progn (continue) 'bad) - (continue () 'good)) - good) - -(deftest continue.2 - (let ((c1 (make-condition 'error)) - (c2 (make-condition 'error))) - (restart-case - (with-condition-restarts - c1 - (list (first (compute-restarts))) - (continue c2)) - (continue () 'bad) - (continue () 'good))) - good) - -(deftest continue.3 - (restart-case - (progn (continue nil) 'bad) - (continue () 'good)) - good) - -(deftest continue.4 - (let ((c1 (make-condition 'error)) - (c2 (make-condition 'error))) - (restart-case - (with-condition-restarts - c1 - (list (first (compute-restarts))) - (continue nil)) - (continue () 'good) - (continue () 'bad))) - good) - -(deftest continue.5 - (let ((c1 (make-condition 'error)) - (c2 (make-condition 'error))) - (with-condition-restarts - c1 - (compute-restarts) - ;; All conditions are now associated with c1 - (continue c2))) - nil) - - diff --git a/t/ansi-test/conditions/define-condition.lsp b/t/ansi-test/conditions/define-condition.lsp deleted file mode 100644 index ae02b60..0000000 --- a/t/ansi-test/conditions/define-condition.lsp +++ /dev/null @@ -1,719 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Mar 8 22:38:53 2003 -;;;; Contains: Tests of DEFINE-CONDITION (part 1) - - - -;;; - -(define-condition-with-tests condition-1 nil nil) - -(define-condition-with-tests condition-2 (condition) nil) - -#-gcl (define-condition-with-tests #:condition-3 nil nil) - -(define-condition-with-tests condition-4 nil - ((slot1 :initarg :slot1 :reader condition-4/slot-1) - (slot2 :initarg :slot2 :reader condition-4/slot-2))) - -(deftest condition-4-slots.1 - (let ((c (make-condition 'condition-4 :slot1 'a :slot2 'b))) - (and (typep c 'condition-4) - (eqlt (condition-4/slot-1 c) 'a) - (eqlt (condition-4/slot-2 c) 'b))) - t) - -(define-condition-with-tests condition-5 nil - ((slot1 :initarg :slot1 :initform 'x :reader condition-5/slot-1) - (slot2 :initarg :slot2 :initform 'y :reader condition-5/slot-2))) - -(deftest condition-5-slots.1 - (let ((c (make-condition 'condition-5 :slot1 'a :slot2 'b))) - (and (typep c 'condition-5) - (eqlt (condition-5/slot-1 c) 'a) - (eqlt (condition-5/slot-2 c) 'b))) - t) - -(deftest condition-5-slots.2 - (let ((c (make-condition 'condition-5 :slot1 'a))) - (and (typep c 'condition-5) - (eqlt (condition-5/slot-1 c) 'a) - (eqlt (condition-5/slot-2 c) 'y))) - t) - -(deftest condition-5-slots.3 - (let ((c (make-condition 'condition-5 :slot2 'b))) - (and (typep c 'condition-5) - (eqlt (condition-5/slot-1 c) 'x) - (eqlt (condition-5/slot-2 c) 'b))) - t) - -(deftest condition-5-slots.4 - (let ((c (make-condition 'condition-5))) - (and (typep c 'condition-5) - (eqlt (condition-5/slot-1 c) 'x) - (eqlt (condition-5/slot-2 c) 'y))) - t) - -(define-condition-with-tests condition-6 nil - ((slot1 :initarg :slot1 :initarg :both-slots - :initform 'x :reader condition-6/slot-1) - (slot2 :initarg :slot2 :initarg :both-slots - :initform 'y :reader condition-6/slot-2))) - -(deftest condition-6-slots.1 - (let ((c (make-condition 'condition-6 :both-slots 'a))) - (and (typep c 'condition-6) - (eqlt (condition-6/slot-1 c) 'a) - (eqlt (condition-6/slot-2 c) 'a))) - t) - -(deftest condition-6-slots.2 - (let ((c (make-condition 'condition-6))) - (and (typep c 'condition-6) - (eqlt (condition-6/slot-1 c) 'x) - (eqlt (condition-6/slot-2 c) 'y))) - t) - -(deftest condition-6-slots.3 - (let ((c (make-condition 'condition-6 :slot1 'a :both-slots 'b))) - (and (typep c 'condition-6) - (eqlt (condition-6/slot-1 c) 'a) - (eqlt (condition-6/slot-2 c) 'b))) - t) - -(deftest condition-6-slots.4 - (let ((c (make-condition 'condition-6 :slot2 'b :both-slots 'a))) - (and (typep c 'condition-6) - (eqlt (condition-6/slot-1 c) 'a) - (eqlt (condition-6/slot-2 c) 'b))) - t) - -(deftest condition-6-slots.5 - (let ((c (make-condition 'condition-6 :both-slots 'a :slot1 'c :slot2 'd))) - (and (typep c 'condition-6) - (eqlt (condition-6/slot-1 c) 'a) - (eqlt (condition-6/slot-2 c) 'a))) - t) - -(define-condition-with-tests condition-7 nil - ((s :initarg :i1 :initarg :i2 :reader condition-7/s))) - -(deftest condition-7-slots.1 - (let ((c (make-condition 'condition-7 :i1 'a))) - (and (typep c 'condition-7) - (eqlt (condition-7/s c) 'a))) - t) - -(deftest condition-7-slots.2 - (let ((c (make-condition 'condition-7 :i2 'a))) - (and (typep c 'condition-7) - (eqlt (condition-7/s c) 'a))) - t) - -(deftest condition-7-slots.3 - (let ((c (make-condition 'condition-7 :i1 'a :i2 'b))) - (and (typep c 'condition-7) - (eqlt (condition-7/s c) 'a))) - t) - -(deftest condition-7-slots.4 - (let ((c (make-condition 'condition-7 :i2 'a :i1 'b))) - (and (typep c 'condition-7) - (eqlt (condition-7/s c) 'a))) - t) - -(defparameter *condition-8-counter* 0) - -(define-condition-with-tests condition-8 nil - ((s :initarg :i1 :initform (incf *condition-8-counter*) :reader condition-8/s))) - -(deftest condition-8-slots.1 - (let ((*condition-8-counter* 100)) - (declare (special *condition-8-counter*)) - (values - (condition-8/s (make-condition 'condition-8)) - *condition-8-counter*)) - 101 101) - -(define-condition-with-tests condition-9 nil - ((s1 :initarg :i1 :initform 15 :reader condition-9/s1) - (s2 :initarg :i2 :initform 37 :reader condition-9/s2))) - -(deftest condition-9-slots.1 - (let ((c (make-condition 'condition-9))) - (values (notnot (typep c 'condition-9)) - (condition-9/s1 c) - (condition-9/s2 c))) - t 15 37) - -(deftest condition-9-slots.2 - (let ((c (make-condition 'condition-9 :i1 3))) - (values (notnot (typep c 'condition-9)) - (condition-9/s1 c) - (condition-9/s2 c))) - t 3 37) - -(deftest condition-9-slots.3 - (let ((c (make-condition 'condition-9 :i2 3))) - (values (notnot (typep c 'condition-9)) - (condition-9/s1 c) - (condition-9/s2 c))) - t 15 3) - -(deftest condition-9-slots.4 - (let ((c (make-condition 'condition-9 :i2 3 :i2 8))) - (values (notnot (typep c 'condition-9)) - (condition-9/s1 c) - (condition-9/s2 c))) - t 15 3) - -(deftest condition-9-slots.5 - (let ((c (make-condition 'condition-9 :i1 3 :i2 8))) - (values (notnot (typep c 'condition-9)) - (condition-9/s1 c) - (condition-9/s2 c))) - t 3 8) - -(deftest condition-9-slots.6 - (let ((c (make-condition 'condition-9 :i1 3 :i2 8 :i1 100 :i2 500))) - (values (notnot (typep c 'condition-9)) - (condition-9/s1 c) - (condition-9/s2 c))) - t 3 8) - -;;; (define-condition-with-tests condition-10 nil -;;; ((s1 :initarg :i1 :writer condition-10/s1-w :reader condition-10/s1-r))) -;;; -;;; (deftest condition-10-slots.1 -;;; (let ((c (make-condition 'condition-10 :i1 11))) -;;; (condition-10/s1-r c)) -;;; 11) -;;; -;;; (deftest condition-10-slots.2 -;;; (let ((c (make-condition 'condition-10 :i1 11))) -;;; (condition-10/s1-w 17 c)) -;;; 17) -;;; -;;; (deftest condition-10-slots.3 -;;; (let ((c (make-condition 'condition-10 :i1 11))) -;;; (condition-10/s1-w 107 c) -;;; (condition-10/s1-r c)) -;;; 107) -;;; -;;; (define-condition-with-tests condition-11 nil -;;; ((s1 :initarg :i1 :writer (setf condition-11/w) :reader condition-11/r))) -;;; -;;; (deftest condition-11-slots.1 -;;; (let ((c (make-condition 'condition-11 :i1 11))) -;;; (condition-11/r c)) -;;; 11) -;;; -;;; (deftest condition-11-slots.2 -;;; (let ((c (make-condition 'condition-11 :i1 11))) -;;; (setf (condition-11/w c) 17)) -;;; 17) -;;; -;;; (deftest condition-11-slots.3 -;;; (let ((c (make-condition 'condition-11 :i1 11))) -;;; (setf (condition-11/w c) 117) -;;; (condition-11/r c)) -;;; 117) -;;; -;;; (deftest condition-11-slots.4 -;;; (let ((c (make-condition 'condition-11 :i1 11))) -;;; (values -;;; (funcall #'(setf condition-11/w) 117 c) -;;; (condition-11/r c))) -;;; 117 117) - -;;; The condition-12 and condition-13 tests have been removed. Duane Rettig -;;; convincingly argued that the feature being tested (non-symbol -;;; slot names) remains in the standard only because of editing errors. - -;;; (define-condition-with-tests condition-12 nil -;;; (((slot1) :initarg :slot1 :reader condition-12/slot-1) -;;; ((slot2) :initarg :slot2 :reader condition-12/slot-2))) -;;; -;;; (deftest condition-12-slots.1 -;;; (let ((c (make-condition 'condition-12 :slot1 'a :slot2 'b))) -;;; (and (typep c 'condition-12) -;;; (eqlt (condition-12/slot-1 c) 'a) -;;; (eqlt (condition-12/slot-2 c) 'b))) -;;; t) -;;; -;;; (define-condition-with-tests condition-13 nil -;;; (((slot1 10) :initarg :slot1 :reader condition-13/slot-1))) -;;; -;;; (deftest condition-13-slots.1 -;;; (let ((c (make-condition 'condition-13))) -;;; (and (typep c 'condition-13) -;;; (condition-13/slot-1 c))) -;;; 10) - -(define-condition-with-tests condition-14 nil - ((s1 :initarg :i1 :type fixnum :reader condition-14/s1) - (s2 :initarg :i2 :type t :reader condition-14/s2))) - -(deftest condition-14-slots.1 - (let ((c (make-condition 'condition-14 :i1 10))) - (and (typep c 'condition-14) - (condition-14/s1 c))) - 10) - -(deftest condition-14-slots.2 - (let ((c (make-condition 'condition-14 :i2 'a))) - (and (typep c 'condition-14) - (condition-14/s2 c))) - a) - -(deftest condition-14-slots.3 - (let ((c (make-condition 'condition-14 :i1 10 :i2 'h))) - (and (typep c 'condition-14) - (eqlt (condition-14/s1 c) 10) - (condition-14/s2 c))) - h) - -(define-condition-with-tests condition-15 nil - ((s1 :type nil))) - -(define-condition-with-tests condition-16 nil - ((slot1)) - (:report "The report for condition-16")) - -(deftest condition-16-report.1 - (let ((*print-escape* nil) - (c (make-condition 'condition-16))) - (with-output-to-string (s) (print-object c s))) - "The report for condition-16") - -(defun condition-17-report (c s) - (format s "condition-17: ~A" (condition-17/s c))) - -(define-condition-with-tests condition-17 nil - ((s :initarg :i1 :reader condition-17/s )) - (:report condition-17-report)) - -(deftest condition-17-report.1 - (let ((*print-escape* nil) - (c (make-condition 'condition-17 :i1 1234))) - (with-output-to-string (s) (print-object c s))) - "condition-17: 1234") - -(define-condition-with-tests condition-18 nil - ((s :initarg :i1 :reader condition-18/s )) - (:report (lambda (c s) (format s "condition-18: ~A" (condition-18/s c))))) - -(deftest condition-18-report.1 - (let ((*print-escape* nil) - (c (make-condition 'condition-18 :i1 4321))) - (with-output-to-string (s) (print-object c s))) - "condition-18: 4321") - -;;; -;;; Tests of :default-initargs -;;; -;;; There is an inconsistency in the ANSI spec. DEFINE-CONDITION -;;; says that in (:default-initargs . ), is a list of pairs. -;;; However, DEFCLASS says it's a list whose alternate elements -;;; are initargs and initforms. I have taken the second interpretation. -;;; - -(define-condition-with-tests condition-19 nil - ((s1 :reader condition-19/s1 :initarg :i1) - (s2 :reader condition-19/s2 :initarg :i2)) - (:default-initargs :i1 10 - :i2 20)) - -(deftest condition-19-slots.1 - (let ((c (make-condition 'condition-19))) - (values - (notnot (typep c 'condition-19)) - (condition-19/s1 c) - (condition-19/s2 c))) - t 10 20) - -(deftest condition-19-slots.2 - (let ((c (make-condition 'condition-19 :i1 'a))) - (values - (notnot (typep c 'condition-19)) - (condition-19/s1 c) - (condition-19/s2 c))) - t a 20) - -(deftest condition-19-slots.3 - (let ((c (make-condition 'condition-19 :i2 'a))) - (values - (notnot (typep c 'condition-19)) - (condition-19/s1 c) - (condition-19/s2 c))) - t 10 a) - -(deftest condition-19-slots.4 - (let ((c (make-condition 'condition-19 :i1 'x :i2 'y))) - (values - (notnot (typep c 'condition-19)) - (condition-19/s1 c) - (condition-19/s2 c))) - t x y) - -(deftest condition-19-slots.5 - (let ((c (make-condition 'condition-19 :i2 'y :i1 'x))) - (values - (notnot (typep c 'condition-19)) - (condition-19/s1 c) - (condition-19/s2 c))) - t x y) - -(defparameter *condition-20/s1-val* 0) -(defparameter *condition-20/s2-val* 0) - -(define-condition-with-tests condition-20 nil - ((s1 :reader condition-20/s1 :initarg :i1) - (s2 :reader condition-20/s2 :initarg :i2)) - (:default-initargs :i1 (incf *condition-20/s1-val*) - :i2 (incf *condition-20/s2-val*))) - -(deftest condition-20-slots.1 - (let ((*condition-20/s1-val* 0) - (*condition-20/s2-val* 10)) - (declare (special *condition-20/s1-val* *condition-20/s2-val*)) - (let ((c (make-condition 'condition-20))) - (values - (notnot (typep c 'condition-20)) - (condition-20/s1 c) - (condition-20/s2 c) - *condition-20/s1-val* - *condition-20/s2-val*))) - t 1 11 1 11) - -(deftest condition-20-slots.2 - (let ((*condition-20/s1-val* 0) - (*condition-20/s2-val* 10)) - (declare (special *condition-20/s1-val* *condition-20/s2-val*)) - (let ((c (make-condition 'condition-20 :i1 'x))) - (values - (notnot (typep c 'condition-20)) - (condition-20/s1 c) - (condition-20/s2 c) - *condition-20/s1-val* - *condition-20/s2-val*))) - t x 11 0 11) - -(deftest condition-20-slots.3 - (let ((*condition-20/s1-val* 0) - (*condition-20/s2-val* 10)) - (declare (special *condition-20/s1-val* *condition-20/s2-val*)) - (let ((c (make-condition 'condition-20 :i2 'y))) - (values - (notnot (typep c 'condition-20)) - (condition-20/s1 c) - (condition-20/s2 c) - *condition-20/s1-val* - *condition-20/s2-val*))) - t 1 y 1 10) - -(deftest condition-20-slots.4 - (let ((*condition-20/s1-val* 0) - (*condition-20/s2-val* 10)) - (declare (special *condition-20/s1-val* *condition-20/s2-val*)) - (let ((c (make-condition 'condition-20 :i2 'y :i1 'x))) - (values - (notnot (typep c 'condition-20)) - (condition-20/s1 c) - (condition-20/s2 c) - *condition-20/s1-val* - *condition-20/s2-val*))) - t x y 0 10) - - -;;;;;;;;; tests of inheritance - -(define-condition-with-tests condition-21 (condition-4) nil) - -(deftest condition-21-slots.1 - (let ((c (make-condition 'condition-21 :slot1 'a :slot2 'b))) - (and (typep c 'condition-4) - (typep c 'condition-21) - (eqlt (condition-4/slot-1 c) 'a) - (eqlt (condition-4/slot-2 c) 'b))) - t) - -(define-condition-with-tests condition-22 (condition-4) - ((slot3 :initarg :slot3 :reader condition-22/slot-3) - (slot4 :initarg :slot4 :reader condition-22/slot-4))) - -(deftest condition-22-slots.1 - (let ((c (make-condition 'condition-22 :slot1 'a :slot2 'b - :slot3 'c :slot4 'd))) - (and (typep c 'condition-4) - (typep c 'condition-22) - (eqlt (condition-4/slot-1 c) 'a) - (eqlt (condition-4/slot-2 c) 'b) - (eqlt (condition-22/slot-3 c) 'c) - (eqlt (condition-22/slot-4 c) 'd) - )) - t) - -(define-condition-with-tests condition-23 (condition-5) nil) - -(deftest condition-23-slots.1 - (let ((c (make-condition 'condition-23 :slot1 'a :slot2 'b))) - (and (typep c 'condition-5) - (typep c 'condition-23) - (eqlt (condition-5/slot-1 c) 'a) - (eqlt (condition-5/slot-2 c) 'b) - )) - t) - -(deftest condition-23-slots.2 - (let ((c (make-condition 'condition-23 :slot1 'a))) - (and (typep c 'condition-5) - (typep c 'condition-23) - (eqlt (condition-5/slot-1 c) 'a) - (eqlt (condition-5/slot-2 c) 'y) - )) - t) - -(deftest condition-23-slots.3 - (let ((c (make-condition 'condition-23 :slot2 'b))) - (and (typep c 'condition-5) - (typep c 'condition-23) - (eqlt (condition-5/slot-1 c) 'x) - (eqlt (condition-5/slot-2 c) 'b) - )) - t) - -(deftest condition-23-slots.4 - (let ((c (make-condition 'condition-23))) - (and (typep c 'condition-5) - (typep c 'condition-23) - (eqlt (condition-5/slot-1 c) 'x) - (eqlt (condition-5/slot-2 c) 'y) - )) - t) - -(define-condition-with-tests condition-24 (condition-5) - nil - (:default-initargs :slot1 'z)) - -(deftest condition-24-slots.1 - (let ((c (make-condition 'condition-24))) - (and (typep c 'condition-5) - (typep c 'condition-24) - (eqlt (condition-5/slot-1 c) 'z) - (eqlt (condition-5/slot-2 c) 'y) - )) - t) - -(deftest condition-24-slots.2 - (let ((c (make-condition 'condition-24 :slot1 'a))) - (and (typep c 'condition-5) - (typep c 'condition-24) - (eqlt (condition-5/slot-1 c) 'a) - (eqlt (condition-5/slot-2 c) 'y) - )) - t) - -(deftest condition-24-slots.3 - (let ((c (make-condition 'condition-24 :slot2 'a))) - (and (typep c 'condition-5) - (typep c 'condition-24) - (eqlt (condition-5/slot-1 c) 'z) - (eqlt (condition-5/slot-2 c) 'a) - )) - t) - -(deftest condition-24-slots.4 - (let ((c (make-condition 'condition-24 :slot1 'b :slot2 'a))) - (and (typep c 'condition-5) - (typep c 'condition-24) - (eqlt (condition-5/slot-1 c) 'b) - (eqlt (condition-5/slot-2 c) 'a) - )) - t) - -;;; Multiple inheritance - -(define-condition-with-tests condition-25a nil - ((s1 :initarg :s1 :initform 'a :reader condition-25a/s1))) - -(define-condition-with-tests condition-25b nil - ((s2 :initarg :s2 :initform 'b :reader condition-25b/s2))) - -(define-condition-with-tests condition-25 (condition-25a condition-25b) - ((s3 :initarg :s3 :initform 'c :reader condition-25/s3))) - -(deftest condition-25-slots.1 - (let ((c (make-condition 'condition-25))) - (and (typep c 'condition-25a) - (typep c 'condition-25b) - (typep c 'condition-25) - (eqlt (condition-25a/s1 c) 'a) - (eqlt (condition-25b/s2 c) 'b) - (eqlt (condition-25/s3 c) 'c))) - t) - -(deftest condition-25-slots.2 - (let ((c (make-condition 'condition-25 :s1 'x))) - (and (typep c 'condition-25a) - (typep c 'condition-25b) - (typep c 'condition-25) - (eqlt (condition-25a/s1 c) 'x) - (eqlt (condition-25b/s2 c) 'b) - (eqlt (condition-25/s3 c) 'c))) - t) - -(deftest condition-25-slots.3 - (let ((c (make-condition 'condition-25 :s2 'x))) - (and (typep c 'condition-25a) - (typep c 'condition-25b) - (typep c 'condition-25) - (eqlt (condition-25a/s1 c) 'a) - (eqlt (condition-25b/s2 c) 'x) - (eqlt (condition-25/s3 c) 'c))) - t) - -(deftest condition-25-slots.4 - (let ((c (make-condition 'condition-25 :s3 'x))) - (and (typep c 'condition-25a) - (typep c 'condition-25b) - (typep c 'condition-25) - (eqlt (condition-25a/s1 c) 'a) - (eqlt (condition-25b/s2 c) 'b) - (eqlt (condition-25/s3 c) 'x))) - t) - -(deftest condition-25-slots.5 - (let ((c (make-condition 'condition-25 :s3 'z :s2 'y :s1 'x))) - (and (typep c 'condition-25a) - (typep c 'condition-25b) - (typep c 'condition-25) - (eqlt (condition-25a/s1 c) 'x) - (eqlt (condition-25b/s2 c) 'y) - (eqlt (condition-25/s3 c) 'z))) - t) - -;;; - -(define-condition-with-tests condition-26a nil - ((s1 :initarg :s1 :initform 'a :reader condition-26a/s1))) - -(define-condition-with-tests condition-26b (condition-26a) nil) -(define-condition-with-tests condition-26c (condition-26a) nil) -(define-condition-with-tests condition-26 (condition-26b condition-26c) nil) - -(deftest condition-26-slots.1 - (let ((c (make-condition 'condition-26))) - (and (typep c 'condition-26a) - (typep c 'condition-26b) - (typep c 'condition-26c) - (typep c 'condition-26) - (eqlt (condition-26a/s1 c) 'a))) - t) - -(deftest condition-26-slots.2 - (let ((c (make-condition 'condition-26 :s1 'x))) - (and (typep c 'condition-26a) - (typep c 'condition-26b) - (typep c 'condition-26c) - (typep c 'condition-26) - (eqlt (condition-26a/s1 c) 'x))) - t) - - -;;; Test that a slot reader is truly a generic function - -(define-condition-with-tests condition-27a nil - ((s0 :initarg :s0 :initform 10 :reader condition-27a/s0) - (s1 :initarg :s1 :initform 'a :reader condition-27/s1))) - -(define-condition-with-tests condition-27b nil - ((s1 :initarg :s1 :initform 'a :reader condition-27/s1) - (s2 :initarg :s2 :initform 16 :reader condition-27b/s2))) - -(deftest condition-27-slots.1 - (let ((c (make-condition 'condition-27a))) - (and (typep c 'condition-27a) - (not (typep c 'condition-27b)) - (eqlt (condition-27/s1 c) 'a))) - t) - -(deftest condition-27-slots.2 - (let ((c (make-condition 'condition-27b))) - (and (typep c 'condition-27b) - (not (typep c 'condition-27a)) - (eqlt (condition-27/s1 c) 'a))) - t) - -(deftest condition-27-reader-is-generic - (notnot-mv (typep #'condition-27/s1 'generic-function)) - t) - -;;; More inheritance - -;;; These test that condition slots are inherited like CLOS -;;; slots. It's not entirely clear to me if the standard -;;; demands this (one of the issues does, but that issue wasn't -;;; fully integrated into the standard.) - -#| -(define-condition-with-tests condition-28a nil - ((s1 :initarg :i1 :initform 'x :reader condition-28a/s1))) - -(define-condition-with-tests condition-28 (condition-28a) - ((s1 :initarg :i1a :reader condition-28/s1))) - -(deftest condition-28-slots.1 - (let ((c (make-condition 'condition-28))) - (and (typep c 'condition-28a) - (typep c 'condition-28) - (eqlt (condition-28a/s1 c) 'x) - (eqlt (condition-28/s1 c) 'x))) - t) - -(deftest condition-28-slots.2 - (let ((c (make-condition 'condition-28 :i1 'z))) - (and (typep c 'condition-28a) - (typep c 'condition-28) - (eqlt (condition-28a/s1 c) 'z) - (eqlt (condition-28/s1 c) 'z))) - t) - -(deftest condition-28-slots.3 - (let ((c (make-condition 'condition-28 :i1a 'w))) - (and (typep c 'condition-28a) - (typep c 'condition-28) - (eqlt (condition-28a/s1 c) 'w) - (eqlt (condition-28/s1 c) 'w))) - t) - -(deftest condition-28-slots.4 - (let ((c (make-condition 'condition-28 :i1 'y :i1a 'w))) - (and (typep c 'condition-28a) - (typep c 'condition-28) - (eqlt (condition-28a/s1 c) 'y) - (eqlt (condition-28/s1 c) 'y))) - t) - -(deftest condition-28-slots.5 - (let ((c (make-condition 'condition-28 :i1a 'y :i1 'w))) - (and (typep c 'condition-28a) - (typep c 'condition-28) - (eqlt (condition-28a/s1 c) 'y) - (eqlt (condition-28/s1 c) 'y))) - t) -|# - - -;;; Documentation - -;;; Pitman says this should have been in the spec, but it isn't really -;;; (define-condition-with-tests condition-29 nil -;;; ((s1 :initarg :i1 :initform 'x -;;; :documentation "This is slot s1 in condition condition-29"))) - -(define-condition-with-tests condition-30 nil - ((s1 :initarg :i1 :initform 'x)) - (:documentation "This is class condition-30")) diff --git a/t/ansi-test/conditions/error.lsp b/t/ansi-test/conditions/error.lsp deleted file mode 100644 index 30fb689..0000000 --- a/t/ansi-test/conditions/error.lsp +++ /dev/null @@ -1,95 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Jan 28 21:37:43 2003 -;;;; Contains: Tests of ERROR - - - -(deftest error.1 - (let ((fmt "Error")) - (handler-case - (error fmt) - (simple-error (c) (frob-simple-error c fmt)))) - t) - -(deftest error.2 - (let* ((fmt "Error") - (cnd (make-condition 'simple-error :format-control fmt))) - (handler-case - (error cnd) - (simple-error (c) (frob-simple-error c fmt)))) - t) - -(deftest error.3 - (let ((fmt "Error")) - (handler-case - (error 'simple-error :format-control fmt) - (simple-error (c) (frob-simple-error c fmt)))) - t) - -(deftest error.4 - (let ((fmt "Error: ~A")) - (handler-case - (error fmt 10) - (simple-error (c) (frob-simple-error c fmt 10)))) - t) - -(deftest error.5 - (let ((fmt (formatter "Error"))) - (handler-case - (error fmt) - (simple-error (c) (frob-simple-error c fmt)))) - t) - -(deftest error.6 - (handler-case - (error 'simple-condition) - (error (c) (declare (ignore c)) :wrong) - (simple-condition (c) (declare (ignore c)) :right)) - :right) - -(deftest error.7 - (handler-case - (error 'simple-warning) - (error (c) (declare (ignore c)) :wrong) - (simple-warning (c) (declare (ignore c)) :right) - (condition (c) (declare (ignore c)) :wrong2)) - :right) - -(deftest error.8 - (let ((fmt "Boo!")) - (handler-case - (error 'simple-warning :format-control fmt) - (simple-warning (c) (frob-simple-warning c fmt)))) - t) - -(deftest error.9 - (let ((fmt (formatter "Boo!"))) - (handler-case - (error 'simple-warning :format-control fmt) - (simple-warning (c) (frob-simple-warning c fmt)))) - t) - -(deftest error.10 - (let ((fmt (formatter "Error"))) - (handler-case - (error 'simple-error :format-control fmt) - (simple-error (c) (frob-simple-error c fmt)))) - t) - -(deftest error.11 - (let ((fmt (formatter "Error"))) - (handler-case - (error fmt) - (simple-error (c) (frob-simple-error c fmt)))) - t) - -(deftest error.12 - (let* ((fmt (formatter "Error")) - (cnd (make-condition 'simple-error :format-control fmt))) - (handler-case - (error cnd) - (simple-error (c) (frob-simple-error c fmt)))) - t) - -;;; Tests for other conditions will in their own files. diff --git a/t/ansi-test/conditions/handler-bind.lsp b/t/ansi-test/conditions/handler-bind.lsp deleted file mode 100644 index 53ebb2b..0000000 --- a/t/ansi-test/conditions/handler-bind.lsp +++ /dev/null @@ -1,146 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Feb 28 22:07:25 2003 -;;;; Contains: Tests of HANDLER-BIND - - - -(deftest handler-bind.1 - (handler-bind ()) - nil) - -(deftest handler-bind.2 - (handler-bind () (values))) - -(deftest handler-bind.3 - (handler-bind () (values 1 2 3)) - 1 2 3) - -(deftest handler-bind.4 - (let ((x 0)) - (values - (handler-bind () (incf x) (+ x 10)) - x)) - 11 1) - -(deftest handler-bind.5 - (block foo - (handler-bind ((error #'(lambda (c) (return-from foo 'good)))) - (error "an error"))) - good) - -(deftest handler-bind.6 - (block foo - (handler-bind - ((error #'(lambda (c) (return-from foo 'good)))) - (handler-bind ((error #'(lambda (c) (error c))) - (error #'(lambda (c) (return-from foo 'bad)))) - (error "an error")))) - good) - -(defun handler-bind.7-handler-fn (c) - (declare (ignore c)) - (throw 'foo 'good)) - -(deftest handler-bind.7 - (catch 'foo - (handler-bind ((simple-error #'handler-bind.7-handler-fn)) - (error "simple error"))) - good) - -(deftest handler-bind.8 - (catch 'foo - (handler-bind ((simple-error 'handler-bind.7-handler-fn)) - (error "simple error"))) - good) - -(deftest handler-bind.9 - (catch 'foo - (handler-bind ((simple-error #.(symbol-function - 'handler-bind.7-handler-fn))) - (error "simple error"))) - good) - -(deftest handler-bind.10 - (block done - (flet ((%foo () (signal "A simple condition")) - (%succeed (c) (declare (ignore c)) (return-from done 'good)) - (%fail (c) (declare (ignore c)) (return-from done 'bad))) - (handler-bind - ((error #'%fail) - (simple-condition #'%succeed)) - (%foo)))) - good) - -(deftest handler-bind.11 - (block done - (handler-bind - ((error #'(lambda (c) c)) - (error #'(lambda (c) (declare (ignore c)) (return-from done 'good)))) - (error "an error"))) - good) - -(deftest handler-bind.12 - (block done - (handler-bind - ((error #'(lambda (c) (declare (ignore c)) (return-from done 'good)))) - (handler-bind - ((error #'(lambda (c) c))) - (error "an error")))) - good) - -(deftest handler-bind.13 - (handler-bind - ((error #'(lambda (c) (declare (ignore c)) - (throw 'done 'good)))) - (catch 'done - (error "an error"))) - good) - -(deftest handler-bind.14 - (catch 'done - (handler-bind - ((symbol #'identity) ;; can never succeed - (error #'(lambda (c) (declare (ignore c)) - (throw 'done 'good)))) - (error "an error"))) - good) - -(deftest handler-bind.15 - (catch 'done - (handler-bind - ((nil #'(lambda (c) (declare (ignore c)) - (throw 'done 'bad))) - (error #'(lambda (c) (declare (ignore c)) - (throw 'done 'good)))) - (error "an error"))) - good) - -(deftest handler-bind.16 - (catch 'done - (handler-bind - (((not error) #'identity) - (error - #'(lambda (c) (declare (ignore c)) - (throw 'done 'good)))) - (error "an error"))) - good) - -(deftest handler-bind.17 - (catch 'done - (handler-bind - ((#.(find-class 'error) - #'(lambda (c) (declare (ignore c)) - (throw 'done 'good)))) - (error "an error"))) - good) - -;;; More handler-bind tests elsewhere - - - - - - - - diff --git a/t/ansi-test/conditions/handler-case.lsp b/t/ansi-test/conditions/handler-case.lsp deleted file mode 100644 index 2101280..0000000 --- a/t/ansi-test/conditions/handler-case.lsp +++ /dev/null @@ -1,213 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Mar 1 14:08:07 2003 -;;;; Contains: Tests of HANDLER-CASE - - - -(deftest handler-case.1 - (handler-case - (error "an error") - (error () t)) - t) - -(deftest handler-case.2 - (handler-case - (error "an error") - (warning () nil) - (error () t)) - t) - -(deftest handler-case.3 - (handler-case - (error "an error") - (error (c) (and (typep c 'error) t)) - (error () 'bad) - (condition () 'bad2)) - t) - -(deftest handler-case.4 - (handler-case - (error "an error") - (warning (c) c) - (error (c) (and (typep c 'error) t)) - (error () 'bad) - (condition () 'bad2)) - t) - -(deftest handler-case.5 - (handler-case - (error "an error") - (#.(find-class 'error) (c) (and (typep c 'error) t)) - (error () 'bad)) - t) - -(deftest handler-case.6 - (handler-case (values) - (error () nil))) - -(deftest handler-case.7 - (handler-case 'foo (condition () 'bar)) - foo) - -;;; (deftest handler-case.8 -;;; (handler-case 'foo (t () 'bar)) -;;; foo) - -(deftest handler-case.9 - (handler-case (values 1 2 3 4 5 6 7 8) (condition () nil)) - 1 2 3 4 5 6 7 8) - -;;; (deftest handler-case.10 -;;; (handler-case -;;; (error "foo") -;;; (t () 'good)) -;;; good) - -(deftest handler-case.11 - (labels ((%f () (declare (special *c*)) - (and (typep *c* 'condition) t)) - (%g () - (let ((*c* nil)) - (declare (special *c*)) - (%h))) - (%h () - (handler-case - (error "foo") - (error (*c*) (declare (special *c*)) - (%f))))) - (%g)) - t) - -(deftest handler-case.12 - (handler-case (error "foo") - (nil () nil) - (error (c) (notnot-mv (typep c 'simple-error)))) - t) - -(deftest handler-case.13 - (handler-case (error "foo") - (error (c) (values)))) - -(deftest handler-case.14 - (handler-case (error "foo") - (error (c) - (values 1 2 3 4 5 6 7 8))) - 1 2 3 4 5 6 7 8) - -(deftest handler-case.15 - (handler-case - (handler-case (error "foo") - (warning () 'bad)) - (error () 'good)) - good) - -(deftest handler-case.16 - (handler-case - (handler-case (error "foo") - (error () 'good)) - (error () 'bad)) - good) - -(deftest handler-case.17 - (let ((i 0)) - (values - (handler-case - (handler-case (error "foo") - (error () (incf i) (error "bar"))) - (error () 'good)) - i)) - good 1) - -(deftest handler-case.18 - (let ((i 0)) - (values - (handler-case - (handler-case (error "foo") - (error (c) (incf i) (error c))) - (error () 'good)) - i)) - good 1) - -(deftest handler-case.19 - (handler-case - (error "foo") - (error (c) - ;; Test that declarations can go here - (declare (optimize (safety 3))) - (declare (type condition c)) - (declare (ignore c)) - t)) - t) - -(deftest handler-case.20 - (handler-case - 10 - (:no-error (x) (+ x 3))) - 13) - -(deftest handler-case.21 - (handler-case - (values) - (:no-error () 'foo)) - foo) - -(deftest handler-case.22 - (handler-case - (values 1 2 3 4 5) - (:no-error (a b c d e) (list e d c b a))) - (5 4 3 2 1)) - -(deftest handler-case.23 - (signals-error - (handler-case (values 1 2) (:no-error (x) x)) - program-error) - t) - -(deftest handler-case.24 - (signals-error - (handler-case (values) (:no-error (x) x)) - program-error) - t) - -(deftest handler-case.25 - (handler-case - (handler-case - (values) - (error () 'bad) - (:no-error () (error "foo"))) - (error () 'good)) - good) - -(deftest handler-case.26 - (handler-case - (values 1 'a 1.0) - (error () 'bad) - (:no-error (a b c) - ;; Test that declarations can go here - (declare (type integer a)) - (declare (type symbol b)) - (declare (type number c)) - (declare (ignore a c)) - b)) - a) - -(deftest handler-case.27 - (handler-case (error "foo") (error ())) - nil) - -(deftest handler-case.28 - (handler-case (error "foo") (error () (declare (optimize speed)))) - nil) - -;;; Free declaration scope - -(deftest handler-case.29 - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) - (handler-case nil - (:no-error (z &aux (y x)) - (declare (special x) (ignore z)) - y)))) - :good) diff --git a/t/ansi-test/conditions/ignore-errors.lsp b/t/ansi-test/conditions/ignore-errors.lsp deleted file mode 100644 index 87ed5a5..0000000 --- a/t/ansi-test/conditions/ignore-errors.lsp +++ /dev/null @@ -1,38 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Mar 2 20:38:25 2003 -;;;; Contains: Tests of IGNORE-ERRORS - - - -(deftest ignore-errors.1 - (ignore-errors) - nil) - -(deftest ignore-errors.2 - (ignore-errors 'a) - a) - -(deftest ignore-errors.3 - (ignore-errors (values 1 2 3 4 5 6 7 8)) - 1 2 3 4 5 6 7 8) - -(deftest ignore-errors.4 - (multiple-value-bind (val cond) - (ignore-errors (error "foo")) - (and (null val) - (typep cond 'simple-error) - t)) - t) - -(deftest ignore-errors.5 - (handler-case - (ignore-errors (signal "foo")) - (condition () 'good)) - good) - -(deftest ignore-errors.6 - (handler-case - (ignore-errors (signal "foo")) - (simple-condition () 'good)) - good) diff --git a/t/ansi-test/conditions/invoke-debugger.lsp b/t/ansi-test/conditions/invoke-debugger.lsp deleted file mode 100644 index 88d591f..0000000 --- a/t/ansi-test/conditions/invoke-debugger.lsp +++ /dev/null @@ -1,68 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Feb 28 21:59:57 2003 -;;;; Contains: Tests of INVOKE-DEBUGGER - - - -;;; We can't test actual entry into the debugger, but we can test -;;; that the function in *debugger-hook* is properly called. - -(deftest invoke-debugger.1 - (block done - (let (fn (cnd (make-condition 'simple-error))) - (setq fn #'(lambda (c hook) - (return-from done - (and (null *debugger-hook*) - (eqt hook fn) - (eqt cnd c) - 'good)))) - (let ((*debugger-hook* fn)) - (invoke-debugger cnd))) - 'bad) - good) - -(deftest invoke-debugger.error.1 - (signals-error - (block done - (let ((*debugger-hook* #'(lambda (&rest args) - (declare (ignore args)) - (return-from done 'bad)))) - (invoke-debugger))) - program-error) - t) - -(deftest invoke-debugger.error.2 - (signals-error - (block done - (let ((*debugger-hook* #'(lambda (&rest args) - (declare (ignore args)) - (return-from done 'bad)))) - (invoke-debugger (make-condition 'simple-error) nil))) - program-error) - t) - -;;; If the debugger hook function expects the wrong number -;;; of arguments, a program-error should be thrown in safe code -;;; This error is thrown 'prior to entry to the standard debugger'. - -(deftest invoke-debugger.error.3 - (signals-error - (let ((*debugger-hook* #'(lambda () nil))) - (invoke-debugger (make-condition 'simple-error))) - program-error) - t) - -(deftest invoke-debugger.error.4 - (signals-error - (let ((*debugger-hook* #'(lambda (c) c))) - (invoke-debugger (make-condition 'simple-error))) - program-error) - t) - -(deftest invoke-debugger.error.5 - (signals-error - (let ((*debugger-hook* #'(lambda (c hook x) (list c hook x)))) - (invoke-debugger (make-condition 'simple-error))) - program-error) - t) diff --git a/t/ansi-test/conditions/load.lsp b/t/ansi-test/conditions/load.lsp deleted file mode 100644 index 736452e..0000000 --- a/t/ansi-test/conditions/load.lsp +++ /dev/null @@ -1,33 +0,0 @@ -;;; Tests of conditions -(compile-and-load "ANSI-TESTS:AUX;types-aux.lsp") -(compile-and-load "ANSI-TESTS:AUX;define-condition-aux.lsp") - -(in-package #:cl-test) - -(let ((*default-pathname-defaults* - (make-pathname - :directory (pathname-directory *load-pathname*)))) - (load "condition.lsp") - (load "cell-error-name.lsp") - (load "assert.lsp") - (load "error.lsp") - (load "cerror.lsp") - (load "check-type.lsp") - (load "warn.lsp") - (load "invoke-debugger.lsp") - (load "handler-bind.lsp") - (load "handler-case.lsp") - (load "ignore-errors.lsp") - (load "define-condition.lsp") - (load "compute-restarts.lsp") - (load "restart-bind.lsp") - (load "restart-case.lsp") - (load "with-condition-restarts.lsp") - (load "with-simple-restart.lsp") - (load "abort.lsp") - (load "muffle-warning.lsp") - (load "continue.lsp") - (load "store-value.lsp") - (load "use-value.lsp") - (load "make-condition.lsp") -) diff --git a/t/ansi-test/conditions/make-condition.lsp b/t/ansi-test/conditions/make-condition.lsp deleted file mode 100644 index f81fd73..0000000 --- a/t/ansi-test/conditions/make-condition.lsp +++ /dev/null @@ -1,52 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Jun 23 11:54:10 2005 -;;;; Contains: Tests of MAKE-CONDITION - - - - -(deftest make-condition.1 - (loop for tp in *cl-condition-type-symbols* - for c = (make-condition tp) - unless (and (typep c tp) - (typep c 'condition)) - collect (list tp c)) - nil) - -(deftest make-condition.2 - (loop for tp in *cl-condition-type-symbols* - for class = (find-class tp) - for c = (and class (make-condition class)) - unless (or (not class) - (and (typep c tp) - (typep c class) - (typep c 'condition))) - collect (list tp c)) - nil) - -(deftest make-condition.3 - :notes (:make-condition-with-compound-name :ansi-spec-problem) - (let* ((tp '(or program-error type-error)) - (c (make-condition tp))) - (or (not (and (subtypep tp 'condition) - (or (subtypep 'program-error tp) - (subtypep 'type-error tp)))) - (notnot-mv (typep c tp)))) - t) - -(deftest make-condition.4 - :notes (:make-condition-with-compound-name :ansi-spec-problem) - (let* ((tp '(and simple-error type-error)) - (c (make-condition tp))) - (or (not (and (subtypep 'simple-error tp) - (subtypep 'type-error tp) - (subtypep tp 'condition))) - (notnot-mv (typep c tp)))) - t) - -;;; Error tests - -(deftest make-condition.error.1 - (signals-error (make-condition) program-error) - t) diff --git a/t/ansi-test/conditions/muffle-warning.lsp b/t/ansi-test/conditions/muffle-warning.lsp deleted file mode 100644 index 291656c..0000000 --- a/t/ansi-test/conditions/muffle-warning.lsp +++ /dev/null @@ -1,55 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Mar 23 08:46:05 2003 -;;;; Contains: Tests of the MUFFLE-WARNING restart and function - - - -(deftest muffle-warning.1 - (restart-case - (progn (muffle-warning) 'bad) - (muffle-warning () 'good)) - good) - -(deftest muffle-warning.2 - (let ((c1 (make-condition 'error)) - (c2 (make-condition 'error))) - (restart-case - (with-condition-restarts - c1 - (list (first (compute-restarts))) - (muffle-warning c2)) - (muffle-warning () 'bad) - (muffle-warning () 'good))) - good) - -(deftest muffle-warning.3 - (restart-case - (progn (muffle-warning nil) 'bad) - (muffle-warning () 'good)) - good) - -(deftest muffle-warning.4 - (let ((c1 (make-condition 'error)) - (c2 (make-condition 'error))) - (restart-case - (with-condition-restarts - c1 - (list (first (compute-restarts))) - (muffle-warning nil)) - (muffle-warning () 'good) - (muffle-warning () 'bad))) - good) - -(deftest muffle-warning.5 - (signals-error - (let ((c1 (make-condition 'error)) - (c2 (make-condition 'error))) - (with-condition-restarts - c1 - (compute-restarts) - ;; All conditions are now associated with c1 - (muffle-warning c2))) - control-error) - t) - diff --git a/t/ansi-test/conditions/restart-bind.lsp b/t/ansi-test/conditions/restart-bind.lsp deleted file mode 100644 index cd5e22d..0000000 --- a/t/ansi-test/conditions/restart-bind.lsp +++ /dev/null @@ -1,230 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Mar 21 22:28:53 2003 -;;;; Contains: Tests for RESTART-BIND - - - -(deftest restart-bind.1 - (restart-bind () nil) - nil) - -(deftest restart-bind.2 - (restart-bind () (values))) - -(deftest restart-bind.3 - (restart-bind () (values 'a 'b 'c 'd 'e 'f)) - a b c d e f) - -(deftest restart-bind.4 - (block nil - (restart-bind () (return 'good) 'bad)) - good) - -(deftest restart-bind.5 - (block done - (tagbody - (restart-bind () (go 10) (return-from done 'bad)) - 10 - (return-from done 'good))) - good) - -(deftest restart-bind.6 - (restart-bind ()) - nil) - -(deftest restart-bind.7 - (block done - (restart-bind ((foo #'(lambda () (return-from done 'good)))) - (invoke-restart 'foo) - 'bad)) - good) - -(deftest restart-bind.8 - (block done - (restart-bind ((foo #'(lambda () (return-from done 'good)))) - (let ((restart (find-restart 'foo))) - (and (typep restart 'restart) - (invoke-restart restart))) - 'bad)) - good) - -(deftest restart-bind.9 - (restart-bind ((foo #'(lambda (a b c) (list c a b)))) - (invoke-restart 'foo 1 2 3)) - (3 1 2)) - -(deftest restart-bind.10 - (flet ((%f () (invoke-restart 'foo 'x 'y 'z))) - (restart-bind ((foo #'(lambda (a b c) (list c a b)))) - (%f))) - (z x y)) - -(deftest restart-bind.11 - (restart-bind - ((foo #'(lambda () 'bad))) - (restart-bind - ((foo #'(lambda () 'good))) - (invoke-restart 'foo))) - good) - -(deftest restart-bind.12 - (let ((*x* 'bad)) - (declare (special *x*)) - (restart-bind - ((foo #'(lambda () (declare (special *x*)) *x*))) - (let ((*x* 'good)) - (declare (special *x*)) - (invoke-restart 'foo)))) - good) - -(deftest restart-bind.13 - (restart-bind - ((foo #'(lambda () 'bad))) - (flet ((%f () (invoke-restart 'foo))) - (restart-bind - ((foo #'(lambda () 'good))) - (%f)))) - good) - -(deftest restart-bind.14 - (let ((x 10) (y nil)) - (restart-bind - ((foo #'(lambda () - (when (> x 0) - (push 'a y) - (decf x) - (invoke-restart 'foo)) - y))) - (invoke-restart 'foo))) - (a a a a a a a a a a)) - -(deftest restart-bind.15 - (block done - (let ((i 0)) - (restart-bind ((foo (progn (incf i) - #'(lambda () (return-from done i))))) - (invoke-restart 'foo) - 'bad))) - 1) - -(deftest restart-bind.16 - (let ((i 0)) - (values - (with-output-to-string - (s) - (restart-bind - ((foo #'(lambda () nil) - :report-function (progn (incf i) - #'(lambda (s) (format s "A report"))))) - (let ((*print-escape* nil)) - (format s "~A" (find-restart 'foo))))) - i)) - "A report" - 1) - -(deftest restart-bind.17 - (restart-bind - ((foo #'(lambda () 'good)) - (foo #'(lambda () 'bad))) - (invoke-restart 'foo)) - good) - -(deftest restart-bind.18 - (restart-bind - ((foo #'(lambda () 'good)) - (bar #'(lambda () 'bad))) - (invoke-restart 'foo)) - good) - -(deftest restart-bind.19 - (restart-bind - ((foo #'(lambda () 'bad)) - (bar #'(lambda () 'good))) - (invoke-restart 'bar)) - good) - -;;; Using the :test-function to associate a restart with a condition - -;;; This test is disabled until I figure out how to fix -;;; it. See sbcl-devel mailing list, Oct 2005 -#| -(deftest restart-bind.20 - (let ((c (make-condition 'error))) - (restart-bind - ((foo #'(lambda () 'bad) - :test-function #'(lambda (c1) (not (eq c c1)))) - (foo #'(lambda () 'good) - :test-function #'(lambda (c2) (or (null c2) - (eq c c2))))) - (invoke-restart (find-restart 'foo c)))) - good) -|# - -(deftest restart-bind.21 - (let ((c (make-condition 'error))) - (restart-bind - ((foo #'(lambda () 'bad) - :test-function #'(lambda (c1) nil)) - (foo #'(lambda () 'good) - :test-function #'(lambda (c2) t))) - (invoke-restart (find-restart 'foo c)))) - good) - -(deftest restart-bind.22 - (let ((c (make-condition 'error)) - (i 0)) - (values - (restart-bind - ((foo #'(lambda () 'good) - :test-function (progn (incf i) #'(lambda (c2) t)))) - (invoke-restart (find-restart 'foo c))) - i)) - good - 1) - -;;; Error tests - -(deftest restart-bind.error.1 - (signals-error - (restart-bind - ((foo #'(lambda () t))) - (invoke-restart 'foo 'a)) - program-error) - t) - -(deftest restart-bind.error.2 - (signals-error - (restart-bind - ((foo #'(lambda (x) x))) - (invoke-restart 'foo)) - program-error) - t) - -(deftest restart-bind.error.3 - (signals-error - (restart-bind - ((foo #'identity)) - (invoke-restart 'foo)) - program-error) - t) - -(deftest restart-bind.23 - (restart-bind - ((foo #'(lambda () 'good))) - (invoke-restart-interactively 'foo)) - good) - -(deftest restart-bind.24 - (let ((i 0)) - (values - (restart-bind - ((foo - #'(lambda (x y z) (list z y x)) - :interactive-function (progn (incf i) - #'(lambda () (list 'a 'b 'c))))) - (invoke-restart-interactively 'foo)) - i)) - (c b a) - 1) - diff --git a/t/ansi-test/conditions/restart-case.lsp b/t/ansi-test/conditions/restart-case.lsp deleted file mode 100644 index ff4f3c1..0000000 --- a/t/ansi-test/conditions/restart-case.lsp +++ /dev/null @@ -1,318 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Mar 22 06:58:03 2003 -;;;; Contains: Tests for RESTART-CASE - - - -(deftest restart-case.1 - (restart-case (values))) - -(deftest restart-case.2 - (restart-case 1) - 1) - -(deftest restart-case.3 - (restart-case (values 'a 'b 'c 'd 'e 'f)) - a b c d e f) - -(deftest restart-case.4 - (restart-case (progn (invoke-restart 'foo) 'bad) - (foo () 'good)) - good) - -(deftest restart-case.5 - (restart-case (progn (invoke-restart 'foo) 'bad) - (foo ())) - nil) - -(deftest restart-case.6 - (restart-case - (progn (invoke-restart 'foo) 'bad) - (bar () 'bad2) - (foo () 'good) - (foo () 'bad3)) - good) - -(deftest restart-case.7 - (restart-case - (invoke-restart 'foo 'a 'b 'c 'd) - (foo (w x y z) (list z y x w))) - (d c b a)) - -(deftest restart-case.8 - (restart-case - (invoke-restart 'foo :a 1 :b 2) - (foo (&key a b c d) (list a b c d))) - (1 2 nil nil)) - -(deftest restart-case.9 - (restart-case - (invoke-restart 'foo 1 2 3 4) - (foo (&rest args) (reverse args))) - (4 3 2 1)) - -(deftest restart-case.10 - (restart-case - (invoke-restart 'foo 1 2 3) - (foo (a b &optional c d) (list a b c d))) - (1 2 3 nil)) - -(deftest restart-case.11 - (restart-case - (invoke-restart 'foo 1 2) - (foo (x y) (declare (type fixnum x y)) (+ x y))) - 3) - -(deftest restart-case.12 - (restart-case - (restart-case (invoke-restart 'foo 1) - (foo (x) (invoke-restart 'foo (1+ x)))) - (foo (y) (+ 4 y))) - 6) - -(deftest restart-case.13 - (let ((i 10)) - (values - (restart-case (progn (invoke-restart 'foo) 'bad) - (foo () (incf i 100) 'good)) - i)) - good 110) - -(deftest restart-case.14 - (restart-case - (invoke-restart 'foo 1 2) - (foo (x y) - (declare (type fixnum x)) - (declare (type fixnum y)) - (+ x y))) - 3) - -(deftest restart-case.15 - (restart-case - (invoke-restart 'foo 1 2) - (foo (x y) - (declare (ignore x y)) - (declare (type fixnum x)) - (declare (type fixnum y)))) - nil) - -(deftest restart-case.16 - (restart-case - (invoke-restart 'foo) - (foo () (values)))) - -(deftest restart-case.17 - (restart-case - (invoke-restart 'foo) - (foo () (values 'a 'b 'c 'd 'e 'f))) - a b c d e f) - -(deftest restart-case.18 - (restart-case - (invoke-restart 'foo) - (foo () :test (lambda (c) (declare (ignore c)) t) 'good)) - good) - -(deftest restart-case.19 - (restart-case - (invoke-restart 'foo) - (foo () :test (lambda (c) (declare (ignore c)) nil) 'bad) - (foo () 'good)) - good) - -(deftest restart-case.20 - (with-output-to-string - (s) - (restart-case - (let ((restart (find-restart 'foo)) - (*print-escape* nil)) - (format s "~A" restart)) - (foo () :report "A report"))) - "A report") - -(deftest restart-case.21 - (with-output-to-string - (s) - (flet ((%f (s2) (format s2 "A report"))) - (restart-case - (let ((restart (find-restart 'foo)) - (*print-escape* nil)) - (format s "~A" restart)) - (foo () :report %f)))) - "A report") - -(deftest restart-case.22 - (with-output-to-string - (s) - (restart-case - (let ((restart (find-restart 'foo)) - (*print-escape* nil)) - (format s "~A" restart)) - (foo () :report (lambda (s2) (format s2 "A report"))))) - "A report") - -;;; Special cases when restart-case associates the restarts with -;;; a condition - -(deftest restart-case.23 - (handler-bind - ((error #'(lambda (c) (declare (ignore c)) (invoke-restart 'foo)))) - (restart-case - (error "Boo!") - (foo () 'good))) - good) - -(deftest restart-case.24 - (handler-bind - ((error #'(lambda (c) (invoke-restart (find-restart 'foo c))))) - (restart-case - (error "Boo!") - (foo () 'good))) - good) - - -;;; Test that the inner restart-case has associated its restart with -;;; the condition to be raised by the error form. - -(deftest restart-case.25 - (handler-bind - ((error #'(lambda (c2) (invoke-restart (find-restart 'foo c2))))) - (handler-bind - ((error #'(lambda (c) (declare (ignore c)) (error "Blah")))) - (restart-case - (restart-case - (error "Boo!") - (foo () 'bad)) - (foo () 'good)))) - good) - -(deftest restart-case.26 - (handler-bind - ((error #'(lambda (c2) (invoke-restart (find-restart 'foo c2))))) - (handler-bind - ((simple-condition #'(lambda (c) (declare (ignore c)) (error "Blah")))) - (restart-case - (restart-case - (signal "Boo!") - (foo () 'bad)) - (foo () 'good)))) - good) - -(deftest restart-case.27 - (handler-bind - ((error #'(lambda (c2) (invoke-restart (find-restart 'foo c2))))) - (handler-bind - ((error #'(lambda (c) (declare (ignore c)) (error "Blah")))) - (restart-case - (restart-case - (cerror "" "") - (foo () 'bad)) - (foo () 'good)))) - good) - -(deftest restart-case.28 - (handler-bind - ((error #'(lambda (c2) (invoke-restart (find-restart 'foo c2))))) - (handler-bind - ((warning #'(lambda (c) (declare (ignore c)) (error "Blah")))) - (restart-case - (restart-case - (warn "Boo!") - (foo () 'bad)) - (foo () 'good)))) - good) - -(deftest restart-case.29 - (macrolet ((%m (&rest args) (cons 'error args))) - (handler-bind - ((error #'(lambda (c2) (invoke-restart (find-restart 'foo c2))))) - (handler-bind - ((error #'(lambda (c) (declare (ignore c)) (error "Blah")))) - (restart-case - (restart-case - (%m "Boo!") - (foo () 'bad)) - (foo () 'good))))) - good) - -(deftest restart-case.30 - (symbol-macrolet ((%s (error "Boo!"))) - (handler-bind - ((error #'(lambda (c2) (invoke-restart (find-restart 'foo c2))))) - (handler-bind - ((error #'(lambda (c) (declare (ignore c)) (error "Blah")))) - (restart-case - (restart-case - %s - (foo () 'bad)) - (foo () 'good))))) - good) - -(deftest restart-case.31 - (macrolet ((%m2 (&rest args) (cons 'error args))) - (macrolet ((%m (&rest args &environment env) - (macroexpand (cons '%m2 args) env))) - (handler-bind - ((error #'(lambda (c2) (invoke-restart (find-restart 'foo c2))))) - (handler-bind - ((error #'(lambda (c) (declare (ignore c)) (error "Blah")))) - (restart-case - (restart-case - (%m "Boo!") - (foo () 'bad)) - (foo () 'good)))))) - good) - -(deftest restart-case.32 - (restart-case - (invoke-restart-interactively 'foo) - (foo () 'good)) - good) - -(deftest restart-case.33 - (restart-case - (invoke-restart-interactively 'foo) - (foo (w x y z) - :interactive (lambda () (list 'a 'b 'c 'd)) - (list x w z y))) - (b a d c)) - -(deftest restart-case.34 - (flet ((%f () (list 'a 'b 'c 'd))) - (restart-case - (invoke-restart-interactively 'foo) - (foo (w x y z) - :interactive %f - (list x w z y)))) - (b a d c)) - -(deftest restart-case.35 - (restart-case - (loop for i from 1 to 4 - for r in (compute-restarts) - collect (restart-name r)) - (foo () t) - (bar () t) - (foo () 'a) - (nil () :report (lambda (s) (format s "Anonymous restart")) 10)) - (foo bar foo nil)) - -(deftest restart-case.36 - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) - (restart-case - (invoke-restart 'foo) - (foo (&aux (y x)) - (declare (special x)) - y)))) - :good) - -(deftest restart-case.37 - (progn - (define-condition x () ((y :initarg :y))) - (handler-bind ((x (lambda (c) (slot-value c 'y)))) - (restart-case - (signal 'x :y 1)))) - nil) diff --git a/t/ansi-test/conditions/store-value.lsp b/t/ansi-test/conditions/store-value.lsp deleted file mode 100644 index 3901a14..0000000 --- a/t/ansi-test/conditions/store-value.lsp +++ /dev/null @@ -1,52 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Mar 23 09:10:22 2003 -;;;; Contains: Tests for STORE-VALUE restart and function - - - -(deftest store-value.1 - (restart-case - (progn (store-value 10) 'bad) - (store-value (x) (list x 'good))) - (10 good)) - -(deftest store-value.2 - (let ((c1 (make-condition 'error)) - (c2 (make-condition 'error))) - (restart-case - (with-condition-restarts - c1 - (list (first (compute-restarts))) - (store-value 17 c2)) - (store-value (x) (list x 'bad)) - (store-value (x) (list x 'good)))) - (17 good)) - -(deftest store-value.3 - (restart-case - (progn (store-value 11 nil) 'bad) - (store-value (x) (list x 'good))) - (11 good)) - -(deftest store-value.4 - (let ((c1 (make-condition 'error)) - (c2 (make-condition 'error))) - (restart-case - (with-condition-restarts - c1 - (list (first (compute-restarts))) - (store-value 18 nil)) - (store-value (x) (list x 'good)) - (store-value (x) (list x 'bad)))) - (18 good)) - -(deftest store-value.5 - (let ((c1 (make-condition 'error)) - (c2 (make-condition 'error))) - (with-condition-restarts - c1 - (compute-restarts) - ;; All conditions are now associated with c1 - (store-value 21 c2))) - nil) diff --git a/t/ansi-test/conditions/use-value.lsp b/t/ansi-test/conditions/use-value.lsp deleted file mode 100644 index 9c59633..0000000 --- a/t/ansi-test/conditions/use-value.lsp +++ /dev/null @@ -1,53 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Mar 23 09:13:59 2003 -;;;; Contains: Tests for USE-VALUE restart and function - - - -(deftest use-value.1 - (restart-case - (progn (use-value 10) 'bad) - (use-value (x) (list x 'good))) - (10 good)) - -(deftest use-value.2 - (let ((c1 (make-condition 'error)) - (c2 (make-condition 'error))) - (restart-case - (with-condition-restarts - c1 - (list (first (compute-restarts))) - (use-value 17 c2)) - (use-value (x) (list x 'bad)) - (use-value (x) (list x 'good)))) - (17 good)) - -(deftest use-value.3 - (restart-case - (progn (use-value 11 nil) 'bad) - (use-value (x) (list x 'good))) - (11 good)) - -(deftest use-value.4 - (let ((c1 (make-condition 'error)) - (c2 (make-condition 'error))) - (restart-case - (with-condition-restarts - c1 - (list (first (compute-restarts))) - (use-value 18 nil)) - (use-value (x) (list x 'good)) - (use-value (x) (list x 'bad)))) - (18 good)) - -(deftest use-value.5 - (let ((c1 (make-condition 'error)) - (c2 (make-condition 'error))) - (with-condition-restarts - c1 - (compute-restarts) - ;; All conditions are now associated with c1 - (use-value 21 c2))) - nil) - diff --git a/t/ansi-test/conditions/warn.lsp b/t/ansi-test/conditions/warn.lsp deleted file mode 100644 index 699cae8..0000000 --- a/t/ansi-test/conditions/warn.lsp +++ /dev/null @@ -1,175 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Feb 23 20:48:12 2003 -;;;; Contains: Tests for WARN - - - -(deftest warn.1 - (let ((warned nil)) - (handler-bind - ((warning #'(lambda (c) - (assert (typep c 'simple-warning)) - (setf warned t) - (muffle-warning c)))) - (values - (multiple-value-list (warn "This is a warning")) - warned))) - (nil) t) - -(deftest warn.2 - (let ((warned nil)) - (handler-bind - ((warning #'(lambda (c) - (assert (typep c 'simple-warning)) - (setf warned t) - (muffle-warning)))) - (values - (multiple-value-list (warn "This is a warning")) - warned))) - (nil) t) - -(deftest warn.3 - (with-output-to-string - (*error-output*) - (let ((warned nil)) - (handler-bind - ((warning #'(lambda (c) - (assert (typep c 'simple-warning)) - (setf warned t) - (muffle-warning c)))) - (warn "Foo!")))) - "") - -(deftest warn.4 - (let ((str (with-output-to-string - (*error-output*) - (warn "Foo!")))) - (not (string= str ""))) - t) - -(deftest warn.5 - (let ((warned nil)) - (handler-bind - ((simple-warning #'(lambda (c) - (assert (typep c 'simple-warning)) - (setf warned t) - (muffle-warning c)))) - (values - (multiple-value-list (warn "This is a warning")) - warned))) - (nil) t) - -(deftest warn.6 - (let ((warned nil)) - (handler-bind - ((simple-condition #'(lambda (c) - (assert (typep c 'simple-warning)) - (setf warned t) - (muffle-warning c)))) - (values - (multiple-value-list (warn "This is a warning")) - warned))) - (nil) t) - -(deftest warn.7 - (let ((warned nil)) - (handler-bind - ((condition #'(lambda (c) - (assert (typep c 'simple-warning)) - (setf warned t) - (muffle-warning c)))) - (values - (multiple-value-list (warn "This is a warning")) - warned))) - (nil) t) - -(deftest warn.8 - (let ((warned nil)) - (handler-bind - ((warning #'(lambda (c) - (assert (typep c 'simple-warning)) - (setf warned t) - (muffle-warning c)))) - (values - (multiple-value-list (warn 'simple-warning :format-control "Foo!")) - warned))) - (nil) t) - -(deftest warn.9 - (let ((warned nil)) - (handler-bind - ((warning #'(lambda (c) - (assert (typep c 'warning)) - (setf warned t) - (muffle-warning c)))) - (values - (multiple-value-list (warn 'warning)) - warned))) - (nil) t) - -(deftest warn.10 - (let ((warned nil)) - (handler-bind - ((warning #'(lambda (c) - (assert (typep c 'simple-warning)) - (setf warned t) - (muffle-warning c)))) - (values - (multiple-value-list (warn (make-condition 'simple-warning :format-control "Foo!"))) - warned))) - (nil) t) - -(deftest warn.11 - (let ((warned nil)) - (handler-bind - ((warning #'(lambda (c) - (assert (typep c 'warning)) - (setf warned t) - (muffle-warning c)))) - (values - (multiple-value-list (warn (make-condition 'warning))) - warned))) - (nil) t) - -(deftest warn.12 - (signals-error (warn 'condition) type-error) - t) - -(deftest warn.13 - (signals-error (warn 'simple-condition) type-error) - t) - -(deftest warn.14 - (signals-error (warn (make-condition 'simple-warning) :format-control "Foo") type-error) - t) - -(deftest warn.15 - (signals-error (warn) program-error) - t) - -(deftest warn.16 - (signals-error (warn (make-condition 'condition)) type-error) - t) - -(deftest warn.17 - (signals-error (warn (make-condition 'simple-condition)) type-error) - t) - -(deftest warn.18 - (signals-error (warn (make-condition 'simple-error)) type-error) - t) - -(deftest warn.19 - (let ((warned nil)) - (handler-bind - ((warning #'(lambda (c) - (assert (typep c 'simple-warning)) - (setf warned t) - (muffle-warning c)))) - (values - (multiple-value-list - (warn (make-condition 'simple-warning - :format-control (formatter "Foo!")))) - warned))) - (nil) t) diff --git a/t/ansi-test/conditions/with-condition-restarts.lsp b/t/ansi-test/conditions/with-condition-restarts.lsp deleted file mode 100644 index 6447762..0000000 --- a/t/ansi-test/conditions/with-condition-restarts.lsp +++ /dev/null @@ -1,96 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Mar 23 04:06:06 2003 -;;;; Contains: Tests of WITH-CONDITION-RESTARTS - - - -(deftest with-condition-restarts.1 - (let (a b c (i 0)) - (values - (with-condition-restarts - (progn (setf a (incf i)) (make-condition 'error)) - (progn (setf b (incf i)) nil) - (setf c (incf i))) - a b c i)) - 3 1 2 3 3) - -(deftest with-condition-restarts.2 - (with-condition-restarts - (make-condition 'error) - nil - (values))) - -(deftest with-condition-restarts.3 - (with-condition-restarts - (make-condition 'error) - nil - (values 'a 'b 'c 'd 'e 'f)) - a b c d e f) - -(deftest with-condition-restarts.4 - (block done - (tagbody - (with-condition-restarts - (make-condition 'error) - nil - (go 10) - 10 - (return-from done 'bad)) - 10 - (return-from done 'good))) - good) - -(deftest with-condition-restarts.5 - (let ((c (make-condition 'error))) - (restart-case - (with-condition-restarts - c - (list (find-restart 'foo)) - 'good) - (foo () 'bad))) - good) - -(deftest with-condition-restarts.6 - (let ((c (make-condition 'error)) - (c2 (make-condition 'error))) - (handler-bind - ((error #'(lambda (c) (invoke-restart (find-restart 'foo c2))))) - (restart-case - (with-condition-restarts - c - (list (find-restart 'foo)) - (signal c2)) - (foo () 'bad) - (foo () 'good)))) - good) - -(deftest with-condition-restarts.7 - (let ((c (make-condition 'error)) - (c2 (make-condition 'error))) - (handler-bind - ((error #'(lambda (c) (invoke-restart 'foo)))) - (restart-case - (with-condition-restarts - c - (list (find-restart 'foo)) - (signal c2)) - (foo () 'good) - (foo () 'bad)))) - good) - -;;; test that the association of a restart with a condition -;;; has dynamic extent - -(deftest with-condition-restarts.8 - (let ((c (make-condition 'error)) - (c2 (make-condition 'error))) - (restart-case - (progn - (with-condition-restarts - c - (list (find-restart 'foo))) - (invoke-restart (find-restart 'foo c2))) - (foo () 'good) - (foo () 'bad))) - good) diff --git a/t/ansi-test/conditions/with-simple-restart.lsp b/t/ansi-test/conditions/with-simple-restart.lsp deleted file mode 100644 index 4f4a712..0000000 --- a/t/ansi-test/conditions/with-simple-restart.lsp +++ /dev/null @@ -1,54 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Mar 23 04:36:52 2003 -;;;; Contains: Tests for WITH-SIMPLE-RESTART - - - -(deftest with-simple-restart.1 - (with-simple-restart (foo "")) - nil) - -(deftest with-simple-restart.2 - (with-simple-restart (foo "") (values))) - -(deftest with-simple-restart.3 - (with-simple-restart (foo "") (values 1 2 3 4 5 6 7 8 9 10)) - 1 2 3 4 5 6 7 8 9 10) - -(deftest with-simple-restart.4 - (block nil - (tagbody - (with-simple-restart - (foo "") - (go 10) - 10 - (return 'bad)) - 10 - (return 'good))) - good) - -(deftest with-simple-restart.5 - (with-simple-restart - (foo "zzz") - (invoke-restart 'foo)) - nil t) - -(deftest with-simple-restart.6 - (flet ((%f () (invoke-restart 'foo))) - (with-simple-restart - (foo "zzz") - (%f))) - nil t) - -(deftest with-simple-restart.7 - (with-simple-restart - (foo (formatter "xxx")) - (invoke-restart 'foo)) - nil t) - -(deftest with-simple-restart.8 - (with-simple-restart - (nil "") - (invoke-restart (first (compute-restarts)))) - nil t) diff --git a/t/ansi-test/cons/acons.lsp b/t/ansi-test/cons/acons.lsp deleted file mode 100644 index 6025153..0000000 --- a/t/ansi-test/cons/acons.lsp +++ /dev/null @@ -1,81 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Apr 20 07:26:48 2003 -;;;; Contains: Tests of ACONS - - - - - -(deftest acons.1 - (let* ((x (copy-tree '((c . d) (e . f)))) - (xcopy (make-scaffold-copy x)) - (result (acons 'a 'b x))) - (and - (check-scaffold-copy x xcopy) - (eqt (cdr result) x) - result)) - ((a . b) (c . d) (e . f))) - -(deftest acons.2 - (acons 'a 'b nil) - ((a . b))) - -(deftest acons.3 - (acons 'a 'b 'c) - ((a . b) . c)) - -(deftest acons.4 - (acons '((a b)) '(((c d) e) f) '((1 . 2))) - (( ((a b)) . (((c d) e) f)) (1 . 2))) - -(deftest acons.5 - (acons "ancd" 1.143 nil) - (("ancd" . 1.143))) - -(deftest acons.6 - (acons #\R :foo :bar) - ((#\R . :foo) . :bar)) - -(deftest acons.7 - (macrolet ((%m (z) z)) (acons (expand-in-current-env (%m 'a)) 'b '(c))) - ((a . b) c)) - -(deftest acons.8 - (macrolet ((%m (z) z)) (acons 'a (expand-in-current-env (%m 'b)) '(c))) - ((a . b) c)) - -(deftest acons.9 - (macrolet ((%m (z) z)) (acons 'a 'b (expand-in-current-env (%m '(c))))) - ((a . b) c)) - -(deftest acons.order.1 - (let ((i 0) x y z) - (values - (acons (progn (setf x (incf i)) 'a) - (progn (setf y (incf i)) 'b) - (progn (setf z (incf i)) '((c . d)))) - i x y z)) - ((a . b)(c . d)) - 3 1 2 3) - -(def-fold-test acons.fold.1 (acons 'x 'y nil)) -(def-fold-test acons.fold.2 (acons 1 2 '((3 . 4) (5 . 6)))) - -;;; Error tests - -(deftest acons.error.1 - (signals-error (acons) program-error) - t) - -(deftest acons.error.2 - (signals-error (acons 'a) program-error) - t) - -(deftest acons.error.3 - (signals-error (acons 'a 'b) program-error) - t) - -(deftest acons.error.4 - (signals-error (acons 'a 'b 'c 'd) program-error) - t) diff --git a/t/ansi-test/cons/adjoin.lsp b/t/ansi-test/cons/adjoin.lsp deleted file mode 100644 index bb33f03..0000000 --- a/t/ansi-test/cons/adjoin.lsp +++ /dev/null @@ -1,226 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Mar 28 07:33:20 1998 -;;;; Contains: Tests of ADJOIN - - - - - -(deftest adjoin.1 - (adjoin 'a nil) - (a)) - -(deftest adjoin.2 - (adjoin nil nil) - (nil)) - -(deftest adjoin.3 - (adjoin 'a '(a)) - (a)) - -;; Check that a NIL :key argument is the same as no key argument at all -(deftest adjoin.4 - (adjoin 'a '(a) :key nil) - (a)) - -(deftest adjoin.5 - (adjoin 'a '(a) :key #'identity) - (a)) - -(deftest adjoin.6 - (adjoin 'a '(a) :key 'identity) - (a)) - -(deftest adjoin.7 - (adjoin (1+ 11) '(4 3 12 2 1)) - (4 3 12 2 1)) - -;; Check that the test is EQL, not EQ (by adjoining a bignum) -(deftest adjoin.8 - (adjoin (1+ 999999999999) '(4 1 1000000000000 3816734 a "aa")) - (4 1 1000000000000 3816734 a "aa")) - -(deftest adjoin.9 - (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a)) - ("aaa" aaa "AAA" "aaa" #\a)) - -(deftest adjoin.10 - (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) :test #'equal) - (aaa "AAA" "aaa" #\a)) - -(deftest adjoin.11 - (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) :test 'equal) - (aaa "AAA" "aaa" #\a)) - -(deftest adjoin.12 - (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) - :test-not (complement #'equal)) - (aaa "AAA" "aaa" #\a)) - -(deftest adjoin.14 - (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) - :test #'equal :key #'identity) - (aaa "AAA" "aaa" #\a)) - -(deftest adjoin.15 - (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) - :test 'equal :key #'identity) - (aaa "AAA" "aaa" #\a)) - -;; Test that a :key of NIL is the same as no key at all -(deftest adjoin.16 - (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) - :test #'equal :key nil) - (aaa "AAA" "aaa" #\a)) - -;; Test that a :key of NIL is the same as no key at all -(deftest adjoin.17 - (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) - :test 'equal :key nil) - (aaa "AAA" "aaa" #\a)) - -;; Test that a :key of NIL is the same as no key at all -(deftest adjoin.18 - (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) - :test-not (complement #'equal) :key nil) - (aaa "AAA" "aaa" #\a)) - -;;; Ordering in comparison function - -(deftest adjoin.19 - (adjoin 10 '(1 2 3) :test #'<) - (10 1 2 3)) - -(deftest adjoin.20 - (adjoin 10 '(1 2 3) :test #'>) - (1 2 3)) - -(deftest adjoin.21 - (adjoin 10 '(1 2 3) :test-not #'>) - (10 1 2 3)) - -(deftest adjoin.22 - (adjoin 10 '(1 2 3) :test-not #'<) - (1 2 3)) - -;;; Test that :key satisfies the description in 17.2.1 -;;; This contradicts other parts of the spec, particularly -;;; PUSHNEW, so the test is commented out. -;;; (deftest adjoin.23 -;;; (adjoin 1 '(1 2 3) :key '1+) -;;; (1 1 2 3)) - -(deftest adjoin.24 - (macrolet ((%m (z) z)) - (values - (adjoin (expand-in-current-env (%m 'a)) '(b c)) - (adjoin 'a (expand-in-current-env (%m '(b c)))) - (adjoin 'a '(b c) (expand-in-current-env (%m :test)) 'eql) - (adjoin 'a '(a a) (expand-in-current-env (%m :test-not)) 'eql) - (adjoin 'a '(b c) :test (expand-in-current-env (%m 'eql))) - (adjoin 'a '(b c) :test (expand-in-current-env (%m #'eql))) - (adjoin 1 '(1 2 3) :key (expand-in-current-env (%m 'identity))) - )) - (a b c) - (a b c) - (a b c) - (a a a) - (a b c) - (a b c) - (1 2 3)) - -(defharmless adjoin.test-and-test-not.1 - (adjoin 'a '(b c) :test #'eql :test-not #'eql)) - -(defharmless adjoin.test-and-test-not.2 - (adjoin 'a '(b c) :test-not #'eql :test #'eql)) - -(deftest adjoin.order.1 - (let ((i 0) w x y z) - (values - (adjoin (progn (setf w (incf i)) 'a) - (progn (setf x (incf i)) '(b c d a e)) - :key (progn (setf y (incf i)) #'identity) - :test (progn (setf z (incf i)) #'eql)) - i w x y z)) - (b c d a e) - 4 1 2 3 4) - -(deftest adjoin.order.2 - (let ((i 0) w x y z p) - (values - (adjoin (progn (setf w (incf i)) 'a) - (progn (setf x (incf i)) '(b c d e)) - :test-not (progn (setf y (incf i)) (complement #'eql)) - :key (progn (setf z (incf i)) #'identity) - :key (progn (setf p (incf i)) nil)) - i w x y z p)) - (a b c d e) - 5 1 2 3 4 5) - -(def-fold-test adjoin.fold.1 (adjoin 'x '(a b c nil d))) - -(deftest adjoin.allow-other-keys.1 - (adjoin 'a '(b c) :bad t :allow-other-keys t) - (a b c)) - -(deftest adjoin.allow-other-keys.2 - (adjoin 'a '(b c) :allow-other-keys t :foo t) - (a b c)) - -(deftest adjoin.allow-other-keys.3 - (adjoin 'a '(b c) :allow-other-keys t) - (a b c)) - -(deftest adjoin.allow-other-keys.4 - (adjoin 'a '(b c) :allow-other-keys nil) - (a b c)) - -(deftest adjoin.allow-other-keys.5 - (adjoin 'a '(b c) :allow-other-keys t :allow-other-keys nil 'bad t) - (a b c)) - -(deftest adjoin.repeat-key - (adjoin 'a '(b c) :test #'eq :test (complement #'eq)) - (a b c)) - -(deftest adjoin.error.1 - (signals-error (adjoin) program-error) - t) - -(deftest adjoin.error.2 - (signals-error (adjoin 'a) program-error) - t) - -(deftest adjoin.error.3 - (signals-error (adjoin 'a '(b c) :bad t) program-error) - t) - -(deftest adjoin.error.4 - (signals-error (adjoin 'a '(b c) :allow-other-keys nil :bad t) program-error) - t) - -(deftest adjoin.error.5 - (signals-error (adjoin 'a '(b c) 1 2) program-error) - t) - -(deftest adjoin.error.6 - (signals-error (adjoin 'a '(b c) :test) program-error) - t) - -(deftest adjoin.error.7 - (signals-error (adjoin 'a '(b c) :test #'identity) program-error) - t) - -(deftest adjoin.error.8 - (signals-error (adjoin 'a '(b c) :test-not #'identity) program-error) - t) - -(deftest adjoin.error.9 - (signals-error (adjoin 'a '(b c) :key #'cons) program-error) - t) - -(deftest adjoin.error.10 - (signals-error (adjoin 'a (list* 'b 'c 'd)) type-error) - t) diff --git a/t/ansi-test/cons/append.lsp b/t/ansi-test/cons/append.lsp deleted file mode 100644 index ff4933a..0000000 --- a/t/ansi-test/cons/append.lsp +++ /dev/null @@ -1,95 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 19 22:36:46 2003 -;;;; Contains: Tests of APPEND - - - - - -(deftest append.1 - (append) - nil) - -(deftest append.2 - (append 'x) - x) - -(deftest append.3 - (let ((x (list 'a 'b 'c 'd)) - (y (list 'e 'f 'g))) - (let ((xcopy (make-scaffold-copy x)) - (ycopy (make-scaffold-copy y))) - (let ((result (append x y))) - (and - (check-scaffold-copy x xcopy) - (check-scaffold-copy y ycopy) - result)))) - (a b c d e f g)) - -(deftest append.4 - (append (list 'a) (list 'b) (list 'c) - (list 'd) (list 'e) (list 'f) - (list 'g) 'h) - (a b c d e f g . h)) - -(deftest append.5 - (append nil nil nil nil nil nil nil nil 'a) - a) - -(deftest append.6 - (append-6-body) - 0) - -;;; Test suggested by Peter Graves -(deftest append.7 - (let ((x (list 'a 'b 'c 'd))) - (eq (append x nil) x)) - nil) - -;;; Compiler macro expansion in correct env - -(deftest append.8 - (macrolet ((%m (z) z)) - (append (expand-in-current-env (%m '(a b c))))) - (a b c)) - -(deftest append.9 - (macrolet ((%m (z) z)) - (append (expand-in-current-env (%m (list 1 2 3))) (list 4 5 6))) - (1 2 3 4 5 6)) - -(deftest append.10 - (macrolet ((%m (z) z)) - (append (list 1 2 3) (expand-in-current-env (%m (list 4 5 6))))) - (1 2 3 4 5 6)) - -;;; Order of evaluation tests - -(deftest append.order.1 - (let ((i 0) x y z) - (values - (append (progn (setf x (incf i)) (copy-list '(a b c))) - (progn (setf y (incf i)) (copy-list '(d e f))) - (progn (setf z (incf i)) (copy-list '(g h i)))) - i x y z)) - (a b c d e f g h i) 3 1 2 3) - -(deftest append.order.2 - (let ((i 0)) (values (append (incf i)) i)) - 1 1) - -(def-fold-test append.fold.1 (append '(a b c) nil)) -(def-fold-test append.fold.2 (append nil '(x) nil)) - -;;; Error tests - -(deftest append.error.1 - (signals-error (append '(a . b) '(z)) - type-error) - t) - -(deftest append.error.2 - (signals-error (append '(x y z) '(a . b) '(z)) - type-error) - t) diff --git a/t/ansi-test/cons/assoc-if-not.lsp b/t/ansi-test/cons/assoc-if-not.lsp deleted file mode 100644 index 6a53e99..0000000 --- a/t/ansi-test/cons/assoc-if-not.lsp +++ /dev/null @@ -1,184 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Apr 20 07:28:37 2003 -;;;; Contains: Tests of ASSOC-IF-NOT - - - - - -(deftest assoc-if-not.1 - (let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d)))) - (xcopy (make-scaffold-copy x)) - (result (assoc-if-not #'oddp x))) - (and - (check-scaffold-copy x xcopy) - (eqt result (third x)) - result)) - (6 . c)) - -(deftest assoc-if-not.2 - (let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d)))) - (xcopy (make-scaffold-copy x)) - (result (assoc-if-not #'evenp x :key #'1+))) - (and - (check-scaffold-copy x xcopy) - (eqt result (third x)) - result)) - (6 . c)) - -(deftest assoc-if-not.3 - (let* ((x (copy-list '((1 . a) nil (3 . b) (6 . c) (7 . d)))) - (xcopy (make-scaffold-copy x)) - (result (assoc-if-not #'oddp x))) - (and - (check-scaffold-copy x xcopy) - (eqt result (fourth x)) - result)) - (6 . c)) - -(deftest assoc-if-not.4 - (assoc-if-not #'identity '((a . b) nil (c . d) (nil . e) (f . g))) - (nil . e)) - -;;; Order of argument evaluation tests - -(deftest assoc-if-not.order.1 - (let ((i 0) x y) - (values - (assoc-if-not (progn (setf x (incf i)) #'identity) - (progn (setf y (incf i)) - '((a . 1) (b . 2) (nil . 17) (d . 4)))) - i x y)) - (nil . 17) 2 1 2) - -(deftest assoc-if-not.order.2 - (let ((i 0) x y z) - (values - (assoc-if-not (progn (setf x (incf i)) #'identity) - (progn (setf y (incf i)) - '((a . 1) (b . 2) (nil . 17) (d . 4))) - :key (progn (setf z (incf i)) #'null)) - i x y z)) - (a . 1) 3 1 2 3) - -;;; Keyword tests - -(deftest assoc-if-not.allow-other-keys.1 - (assoc-if-not #'identity - '((a . 1) (nil . 2) (c . 3)) :bad t :allow-other-keys t) - (nil . 2)) - -(deftest assoc-if-not.allow-other-keys.2 - (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3)) - :allow-other-keys t :also-bad t) - (nil . 2)) - -(deftest assoc-if-not.allow-other-keys.3 - (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3)) - :allow-other-keys t :also-bad t :key #'not) - (a . 1)) - -(deftest assoc-if-not.allow-other-keys.4 - (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3)) :allow-other-keys t) - (nil . 2)) - -(deftest assoc-if-not.allow-other-keys.5 - (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3)) :allow-other-keys nil) - (nil . 2)) - -(deftest assoc-if-not.keywords.6 - (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3)) - :key #'identity :key #'null) - (nil . 2)) - -(deftest assoc-if-not.keywords.7 - (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3)) :key nil :key #'null) - (nil . 2)) - -;;; Macro env tests - -(deftest assoc-if-not.env.1 - (macrolet - ((%m (z) z)) - (let ((alist '((1 . a) (3 . b) (4 . c) (6 . d)))) - (values - (assoc-if-not (expand-in-current-env (%m 'oddp)) alist) - (assoc-if-not (expand-in-current-env (%m #'oddp)) alist) - (assoc-if-not 'oddp (expand-in-current-env (%m alist)))))) - (4 . c) - (4 . c) - (4 . c)) - -(deftest assoc-if-not.env.2 - (macrolet - ((%m (z) z)) - (let ((alist '((1 . a) (3 . b) (4 . c) (6 . d)))) - (values - (assoc-if-not 'evenp alist (expand-in-current-env (%m :key)) #'1+) - (assoc-if-not #'evenp alist :key (expand-in-current-env (%m '1+))) - ))) - (4 . c) - (4 . c)) - -;;; Error tests - -(deftest assoc-if-not.error.1 - (signals-error (assoc-if-not) program-error) - t) - -(deftest assoc-if-not.error.2 - (signals-error (assoc-if-not #'null) program-error) - t) - -(deftest assoc-if-not.error.3 - (signals-error (assoc-if-not #'null nil :bad t) - program-error) - t) - -(deftest assoc-if-not.error.4 - (signals-error (assoc-if-not #'null nil :key) - program-error) - t) - -(deftest assoc-if-not.error.5 - (signals-error (assoc-if-not #'null nil 1 1) - program-error) - t) - -(deftest assoc-if-not.error.6 - (signals-error (assoc-if-not #'null nil :bad t :allow-other-keys nil) - program-error) - t) - -(deftest assoc-if-not.error.7 - (signals-error (assoc-if-not #'cons '((a b)(c d))) - program-error) - t) - -(deftest assoc-if-not.error.8 - (signals-error (assoc-if-not #'identity '((a b)(c d)) :key #'cons) - program-error) - t) - -(deftest assoc-if-not.error.9 - (signals-type-error x 'a (assoc-if-not #'car '((a b)(c d)))) - t) - -(deftest assoc-if-not.error.10 - (signals-type-error x 'a (assoc-if-not #'identity '((a b)(c d)) :key #'car)) - t) - -(deftest assoc-if-not.error.11 - (signals-error (assoc-if-not #'identity '((a . b) . c)) - type-error) - t) - -(deftest assoc-if-not.error.12 - (signals-error (assoc-if-not #'identity '((a . b) :bad (c . d))) - type-error) - t) - -(deftest assoc-if-not.error.13 - (signals-type-error x 'y (assoc-if-not #'identity x)) - t) diff --git a/t/ansi-test/cons/assoc-if.lsp b/t/ansi-test/cons/assoc-if.lsp deleted file mode 100644 index 48723f1..0000000 --- a/t/ansi-test/cons/assoc-if.lsp +++ /dev/null @@ -1,179 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Apr 20 07:27:57 2003 -;;;; Contains: Tests of ASSOC-IF - - - -(deftest assoc-if.1 - (let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d)))) - (xcopy (make-scaffold-copy x)) - (result (assoc-if #'evenp x))) - (and - (check-scaffold-copy x xcopy) - (eqt result (third x)) - result)) - (6 . c)) - -(deftest assoc-if.2 - (let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d)))) - (xcopy (make-scaffold-copy x)) - (result (assoc-if #'oddp x :key #'1+))) - (and - (check-scaffold-copy x xcopy) - (eqt result (third x)) - result)) - (6 . c)) - -(deftest assoc-if.3 - (let* ((x (copy-list '((1 . a) nil (3 . b) (6 . c) (7 . d)))) - (xcopy (make-scaffold-copy x)) - (result (assoc-if #'evenp x))) - (and - (check-scaffold-copy x xcopy) - (eqt result (fourth x)) - result)) - (6 . c)) - -(deftest assoc-if.4 - (assoc-if #'null '((a . b) nil (c . d) (nil . e) (f . g))) - (nil . e)) - -(deftest assoc-if.5 - (let () (assoc-if #'null '((a . b) nil (c . d) (nil . e) (f . g)))) - (nil . e)) - - -;;; Order of argument evaluation - -(deftest assoc-if.order.1 - (let ((i 0) x y) - (values - (assoc-if (progn (setf x (incf i)) #'null) - (progn (setf y (incf i)) - '((a . 1) (b . 2) (nil . 17) (d . 4)))) - i x y)) - (nil . 17) 2 1 2) - -(deftest assoc-if.order.2 - (let ((i 0) x y z) - (values - (assoc-if (progn (setf x (incf i)) #'null) - (progn (setf y (incf i)) - '((a . 1) (b . 2) (nil . 17) (d . 4))) - :key (progn (setf z (incf i)) #'null)) - i x y z)) - (a . 1) 3 1 2 3) - -;;; Keyword tests - -(deftest assoc-if.allow-other-keys.1 - (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) :bad t :allow-other-keys t) - (nil . 2)) - -(deftest assoc-if.allow-other-keys.2 - (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) - :allow-other-keys t :also-bad t) - (nil . 2)) - -(deftest assoc-if.allow-other-keys.3 - (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) - :allow-other-keys t :also-bad t :key #'not) - (a . 1)) - -(deftest assoc-if.allow-other-keys.4 - (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) :allow-other-keys t) - (nil . 2)) - -(deftest assoc-if.allow-other-keys.5 - (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) :allow-other-keys nil) - (nil . 2)) - -(deftest assoc-if.keywords.6 - (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) :key #'identity :key #'null) - (nil . 2)) - -(deftest assoc-if.keywords.7 - (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) :key nil :key #'null) - (nil . 2)) - -;;; Macro env tests - -(deftest assoc-if.env.1 - (macrolet - ((%m (z) z)) - (let ((alist '((1 . a) (3 . b) (6 . c) (8 . d) (-1 . e)))) - (values - (assoc-if (expand-in-current-env (%m 'evenp)) alist) - (assoc-if (expand-in-current-env (%m #'evenp)) alist) - (assoc-if #'evenp (expand-in-current-env (%m alist))) - (assoc-if 'oddp alist (expand-in-current-env (%m :key)) '1+) - (assoc-if 'oddp alist :key (expand-in-current-env (%m #'1+))) - ))) - (6 . c) - (6 . c) - (6 . c) - (6 . c) - (6 . c)) - -;;; Error cases - -(deftest assoc-if.error.1 - (signals-error (assoc-if) program-error) - t) - -(deftest assoc-if.error.2 - (signals-error (assoc-if #'null) program-error) - t) - -(deftest assoc-if.error.3 - (signals-error (assoc-if #'null nil :bad t) - program-error) - t) - -(deftest assoc-if.error.4 - (signals-error (assoc-if #'null nil :key) - program-error) - t) - -(deftest assoc-if.error.5 - (signals-error (assoc-if #'null nil 1 1) - program-error) - t) - -(deftest assoc-if.error.6 - (signals-error (assoc-if #'null nil :bad t :allow-other-keys nil) - program-error) - t) - -(deftest assoc-if.error.7 - (signals-error (assoc-if #'cons '((a b)(c d))) - program-error) - t) - -(deftest assoc-if.error.8 - (signals-error (assoc-if #'identity '((a b)(c d)) :key #'cons) - program-error) - t) - -(deftest assoc-if.error.9 - (signals-type-error x 'a (assoc-if #'car '((a b)(c d)))) - t) - -(deftest assoc-if.error.10 - (signals-type-error x 'a (assoc-if #'identity '((a b)(c d)) :key #'car)) - t) - -(deftest assoc-if.error.11 - (signals-error (assoc-if #'null '((a . b) . c)) - type-error) - t) - -(deftest assoc-if.error.12 - (signals-error (assoc-if #'null '((a . b) :bad (c . d))) - type-error) - t) - -(deftest assoc-if.error.13 - (signals-type-error x 'y (assoc-if #'null x)) - t) diff --git a/t/ansi-test/cons/assoc.lsp b/t/ansi-test/cons/assoc.lsp deleted file mode 100644 index bbe38bb..0000000 --- a/t/ansi-test/cons/assoc.lsp +++ /dev/null @@ -1,297 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Apr 20 07:27:20 2003 -;;;; Contains: Tests of ASSOC - - - - - -(deftest assoc.1 - (assoc nil nil) - nil) - -(deftest assoc.2 - (assoc nil '(nil)) - nil) - -(deftest assoc.3 - (assoc nil '(nil (nil . 2) (a . b))) - (nil . 2)) - -(deftest assoc.4 - (assoc nil '((a . b) (c . d))) - nil) - -(deftest assoc.5 - (assoc 'a '((a . b))) - (a . b)) - -(deftest assoc.6 - (assoc 'a '((:a . b) (#:a . c) (a . d) (a . e) (z . f))) - (a . d)) - -(deftest assoc.7 - (let* ((x (copy-tree '((a . b) (b . c) (c . d)))) - (xcopy (make-scaffold-copy x)) - (result (assoc 'b x))) - (and - (eqt result (second x)) - (check-scaffold-copy x xcopy))) - t) - -(deftest assoc.8 - (assoc 1 '((0 . a) (1 . b) (2 . c))) - (1 . b)) - -(deftest assoc.9 - (assoc (copy-seq "abc") - '((abc . 1) ("abc" . 2) ("abc" . 3))) - nil) - -(deftest assoc.10 - (assoc (copy-list '(a)) (copy-tree '(((a) b) ((a) (c))))) - nil) - -(deftest assoc.11 - (let ((x (list 'a 'b))) - (assoc x `(((a b) c) (,x . d) (,x . e) ((a b) 1)))) - ((a b) . d)) - - -(deftest assoc.12 - (assoc #\e '(("abefd" . 1) ("aevgd" . 2) ("edada" . 3)) - :key #'(lambda (x) (schar x 1))) - ("aevgd" . 2)) - -(deftest assoc.13 - (assoc nil '(((a) . b) ( nil . c ) ((nil) . d)) - :key #'car) - (nil . c)) - -(deftest assoc.14 - (assoc (copy-seq "abc") - '((abc . 1) ("abc" . 2) ("abc" . 3)) - :test #'equal) - ("abc" . 2)) - -(deftest assoc.15 - (assoc (copy-seq "abc") - '((abc . 1) ("abc" . 2) ("abc" . 3)) - :test #'equalp) - ("abc" . 2)) - -(deftest assoc.16 - (assoc (copy-list '(a)) (copy-tree '(((a) b) ((a) (c)))) - :test #'equal) - ((a) b)) - -(deftest assoc.17 - (assoc (copy-seq "abc") - '((abc . 1) (a . a) (b . b) ("abc" . 2) ("abc" . 3)) - :test-not (complement #'equalp)) - ("abc" . 2)) - -(deftest assoc.18 - (assoc 'a '((a . d)(b . c)) :test-not #'eq) - (b . c)) - -(deftest assoc.19 - (assoc 'a '((a . d)(b . c)) :test (complement #'eq)) - (b . c)) - -(deftest assoc.20 - (assoc "a" '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)) - :key #'(lambda (x) (and (stringp x) (string-downcase x))) - :test #'equal) - ("A" . 6)) - -(deftest assoc.21 - (assoc "a" '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)) - :key #'(lambda (x) (and (stringp x) x)) - :test #'equal) - ("a" . 3)) - -(deftest assoc.22 - (assoc "a" '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)) - :key #'(lambda (x) (and (stringp x) (string-downcase x))) - :test-not (complement #'equal)) - ("A" . 6)) - -(deftest assoc.23 - (assoc "a" '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)) - :key #'(lambda (x) (and (stringp x) x)) - :test-not (complement #'equal)) - ("a" . 3)) - -;; Check that it works when test returns a true value -;; other than T - -(deftest assoc.24 - (assoc 'a '((b . 1) (a . 2) (c . 3)) - :test #'(lambda (x y) (and (eqt x y) 'matched))) - (a . 2)) - -;; Check that the order of the arguments to test is correct - -(deftest assoc.25 - (block fail - (assoc 'a '((b . 1) (c . 2) (a . 3)) - :test #'(lambda (x y) - (unless (eqt x 'a) (return-from fail 'fail)) - (eqt x y)))) - (a . 3)) - -;;; Order of test arguments - -(deftest assoc.26 - (assoc 10 '((1 a) (5 b) (8 c) (11 d) (12 e)) :test #'<) - (11 d)) - -(deftest assoc.27 - (assoc 10 '((1 a) (5 b) (8 c) (11 d) (12 e)) :test-not #'>=) - (11 d)) - -;;; Special cases: the nil key does not match the nil pair - -(deftest assoc.30 - (let () (assoc nil '((a . b) nil (c . d) (nil . e) (nil . f) nil (g . h)))) - (nil . e)) - -(deftest assoc.31 - (let () (assoc nil '((a . b) nil (c . d) (nil . e) (nil . f) nil (g . h)) - :test #'eq)) - (nil . e)) - -;;; :test & :test-not together are harmless - -(defharmless assoc.test-and-test-not.1 - (assoc 'a '((a . 1) (b . 2)) :test #'eql :test-not #'eql)) - -(defharmless assoc.test-and-test-not.2 - (assoc 'a '((a . 1) (b . 2)) :test-not #'eql :test #'eql)) - -;;; Order of argument evaluation - -(deftest assoc.order.1 - (let ((i 0) x y) - (values - (assoc (progn (setf x (incf i)) 'c) - (progn (setf y (incf i)) '((a . 1) (b . 2) (c . 3) (d . 4)))) - i x y)) - (c . 3) 2 1 2) - -(deftest assoc.order.2 - (let ((i 0) x y z) - (values - (assoc (progn (setf x (incf i)) 'c) - (progn (setf y (incf i)) '((a . 1) (b . 2) (c . 3) (d . 4))) - :test (progn (setf z (incf i)) #'eq)) - i x y z)) - (c . 3) 3 1 2 3) - -(deftest assoc.order.3 - (let ((i 0) x y) - (values - (assoc (progn (setf x (incf i)) 'c) - (progn (setf y (incf i)) '((a . 1) (b . 2) (c . 3) (d . 4))) - :test #'eq) - i x y)) - (c . 3) 2 1 2) - -(deftest assoc.order.4 - (let ((i 0) x y z w) - (values - (assoc (progn (setf x (incf i)) 'c) - (progn (setf y (incf i)) '((a . 1) (b . 2) (c . 3) (d . 4))) - :key (progn (setf z (incf i)) #'identity) - :key (progn (setf w (incf i)) #'not)) - i x y z w)) - (c . 3) 4 1 2 3 4) - -;;; Keyword tests - -(deftest assoc.allow-other-keys.1 - (assoc 'b '((a . 1) (b . 2) (c . 3)) :bad t :allow-other-keys t) - (b . 2)) - -(deftest assoc.allow-other-keys.2 - (assoc 'b '((a . 1) (b . 2) (c . 3)) :allow-other-keys t :also-bad t) - (b . 2)) - -(deftest assoc.allow-other-keys.3 - (assoc 'b '((a . 1) (b . 2) (c . 3)) :allow-other-keys t :also-bad t - :test-not #'eql) - (a . 1)) - -(deftest assoc.allow-other-keys.4 - (assoc 'b '((a . 1) (b . 2) (c . 3)) :allow-other-keys t) - (b . 2)) - -(deftest assoc.allow-other-keys.5 - (assoc 'b '((a . 1) (b . 2) (c . 3)) :allow-other-keys nil) - (b . 2)) - -(deftest assoc.keywords.6 - (assoc 'b '((a . 1) (b . 2) (c . 3)) :key #'identity :key #'null) - (b . 2)) - -(deftest assoc.keywords.7 - (assoc 'b '((a . 1) (b . 2) (c . 3)) :key nil :key #'null) - (b . 2)) - - -(deftest assoc.error.1 - (signals-error (assoc) program-error) - t) - -(deftest assoc.error.2 - (signals-error (assoc nil) program-error) - t) - -(deftest assoc.error.3 - (signals-error (assoc nil nil :bad t) program-error) - t) - -(deftest assoc.error.4 - (signals-error (assoc nil nil :key) program-error) - t) - -(deftest assoc.error.5 - (signals-error (assoc nil nil 1 1) program-error) - t) - -(deftest assoc.error.6 - (signals-error (assoc nil nil :bad t :allow-other-keys nil) - program-error) - t) - -(deftest assoc.error.7 - (signals-error (assoc 'a '((a . b)) :test #'identity) - program-error) - t) - -(deftest assoc.error.8 - (signals-error (assoc 'a '((a . b)) :test-not #'identity) - program-error) - t) - -(deftest assoc.error.9 - (signals-error (assoc 'a '((a . b)) :key #'cons) - program-error) - t) - -(deftest assoc.error.10 - (signals-error (assoc 'z '((a . b) . c)) - type-error) - t) - -(deftest assoc.error.11 - (signals-error (assoc 'z '((a . b) :bad (c . d))) - type-error) - t) - -(deftest assoc.error.12 - (signals-type-error x 'y (assoc 'x x)) - t) - diff --git a/t/ansi-test/cons/atom.lsp b/t/ansi-test/cons/atom.lsp deleted file mode 100644 index 85a0759..0000000 --- a/t/ansi-test/cons/atom.lsp +++ /dev/null @@ -1,29 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 19 21:28:09 2003 -;;;; Contains: Tests of ATOM - - - -(deftest atom.1 - (loop for x in *universe* - unless (if (atom x) (not (consp x)) (consp x)) - collect x) - nil) - -(deftest atom.2 - (macrolet ((%m (z) z)) (atom (expand-in-current-env (%m 0)))) - t) - -(deftest atom.order.1 - (let ((i 0)) - (values (atom (progn (incf i) '(a b))) i)) - nil 1) - -(deftest atom.error.1 - (signals-error (atom) program-error) - t) - -(deftest atom.error.2 - (signals-error (atom 'a 'b) program-error) - t) diff --git a/t/ansi-test/cons/butlast.lsp b/t/ansi-test/cons/butlast.lsp deleted file mode 100644 index 86e3fe7..0000000 --- a/t/ansi-test/cons/butlast.lsp +++ /dev/null @@ -1,113 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 19 22:41:14 2003 -;;;; Contains: Tests of BUTLAST - - - - - -(deftest butlast.1 - (let ((x (list 'a 'b 'c 'd 'e))) - (let ((xcopy (make-scaffold-copy x))) - (let ((result (butlast x 2))) - (and - (check-scaffold-copy x xcopy) - result)))) - (a b c)) - -(deftest butlast.2 - (let ((x (list 'a 'b 'c 'd 'e))) - (let ((xcopy (make-scaffold-copy x))) - (let ((result (butlast x 0))) - (and - (check-scaffold-copy x xcopy) - result)))) - (a b c d e)) - -(deftest butlast.3 - (let ((x (list 'a 'b 'c 'd 'e))) - (let ((xcopy (make-scaffold-copy x))) - (let ((result (butlast x 5))) - (and - (check-scaffold-copy x xcopy) - result)))) - nil) - -(deftest butlast.4 - (let ((x (list 'a 'b 'c 'd 'e))) - (let ((xcopy (make-scaffold-copy x))) - (let ((result (butlast x 6))) - (and - (check-scaffold-copy x xcopy) - result)))) - nil) - -(deftest butlast.5 - (butlast (copy-tree '(a b c . d)) 1) - (a b)) - -(deftest butlast.6 - (butlast '(a b c d e) (1+ most-positive-fixnum)) - nil) - -(deftest butlast.7 - (butlast '(a b c d e) most-positive-fixnum) - nil) - -(deftest butlast.8 - (butlast '(a b c d e) (1- most-positive-fixnum)) - nil) - -(deftest butlast.9 - (macrolet ((%m (z) z)) - (values (butlast (expand-in-current-env (%m (list 'a 'b 'c)))) - (butlast (list 'a 'b 'c 'd 'e) (expand-in-current-env (%m 2))))) - (a b) - (a b c)) - -(deftest butlast.order.1 - (let ((i 0) x y) - (values - (butlast (progn (setf x (incf i)) - (list 'a 'b 'c 'd 'e)) - (progn (setf y (incf i)) - 2)) - i x y)) - (a b c) 2 1 2) - -(deftest butlast.order.2 - (let ((i 0)) - (values - (butlast (progn (incf i) '(a b c d))) - i)) - (a b c) 1) - -(def-fold-test butlast.fold.1 (butlast '(a b) 1)) -(def-fold-test butlast.fold.2 (butlast '(a b c d e f) 3)) -(def-fold-test butlast.fold.3 (butlast '(a b c d e f g h i) 7)) - -;;; Error tests - -(deftest butlast.error.1 - (signals-error (butlast (copy-tree '(a b c d)) 'a) - type-error) - t) - -(deftest butlast.error.2 - (signals-error (butlast 'a 0) type-error) - t) - -(deftest butlast.error.3 - (signals-error (butlast) program-error) - t) - -(deftest butlast.error.4 - (signals-error (butlast '(a b c) 3 3) program-error) - t) - -(deftest butlast.error.5 - (signals-error (locally (butlast 'a 0) t) type-error) - t) - - diff --git a/t/ansi-test/cons/cons-test-01.lsp b/t/ansi-test/cons/cons-test-01.lsp deleted file mode 100644 index 1c64cfc..0000000 --- a/t/ansi-test/cons/cons-test-01.lsp +++ /dev/null @@ -1,127 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Mar 28 07:29:48 1998 -;;;; Contains: Testing of CL Features related to "CONS", part 1 - - - -(declaim (optimize (safety 3))) - - - -;; -;; Test the subtype relationships between null, list, cons and atom -;; -(deftest subtypep-null-list - (subtypep* 'null 'list) - t t) - -(deftest subtypep-cons-list - (subtypep* 'cons 'list) - t t) - -(deftest subtypep-null-cons - (subtypep* 'null 'cons) - nil t) - -(deftest subtypep-cons-null - (subtypep* 'cons 'null) - nil t) - -(deftest subtypep-null-atom - (subtypep* 'null 'atom) - t t) - -(deftest subtypep-cons-atom - (subtypep* 'cons 'atom) - nil t) - -(deftest subtypep-atom-cons - (subtypep* 'atom 'cons) - nil t) - -(deftest subtypep-atom-list - (subtypep* 'atom 'list) - nil t) - -(deftest subtypep-list-atom - (subtypep* 'list 'atom) - nil t) - -;; -;; Check that the elements of *universe* in type null -;; are those for which the null predice is true. -;; -(deftest null-null-universe - (check-type-predicate 'null 'null) - nil) - -(defvar *cons-fns* - (list 'cons 'consp 'atom 'rplaca 'rplacd - 'car 'cdr 'caar 'cadr 'cdar 'cddr - 'caaar 'caadr 'cadar 'caddr - 'cdaar 'cdadr 'cddar 'cdddr - 'caaaar 'caaadr 'caadar 'caaddr - 'cadaar 'cadadr 'caddar 'cadddr - 'cdaaar 'cdaadr 'cdadar 'cdaddr - 'cddaar 'cddadr 'cdddar 'cddddr - 'copy-tree 'sublis 'nsublis - 'subst 'subst-if 'subst-if-not - 'nsubst 'nsubst-if 'nsubst-if-not - 'tree-equal - 'copy-list - 'list - 'list* - 'list-length - 'listp - 'make-list - 'first 'second 'third 'fourth - 'fifth 'sixth 'seventh 'eighth 'ninth 'tenth - 'nth - 'endp - 'null - 'nconc - 'append - 'revappend 'nreconc - 'butlast 'nbutlast - 'last 'ldiff 'tailp - 'nthcdr 'rest - 'member 'member-if 'member-if-not - 'mapc 'mapcar 'mapcan 'mapl 'maplist 'mapcon - 'acons - 'assoc 'assoc-if 'assoc-if-not - 'copy-alist - 'pairlis - 'rassoc 'rassoc-if 'rassoc-if-not - 'get-properties - 'getf - 'intersection - 'nintersection - 'adjoin - 'set-difference 'nset-difference - 'set-exclusive-or 'nset-exclusive-or - 'subsetp - 'union 'nunion - )) - -;; All the cons functions have a function binding - -(deftest function-bound-cons-fns - (loop - for x in *cons-fns* count - (when (or (not (fboundp x)) - (not (functionp (symbol-function x)))) - (format t "~%~S not bound to a function" x) - t)) - 0) - -;; All the cons-related macros have a macro binding -(deftest macro-bound-cons-macros - (notnot-mv (every #'macro-function - (list 'push 'pop 'pushnew 'remf))) - t) - -;; None of the cons-related functions have macro bindings -(deftest no-cons-fns-are-macros - (some #'macro-function *cons-fns*) - nil) diff --git a/t/ansi-test/cons/cons-test-03.lsp b/t/ansi-test/cons/cons-test-03.lsp deleted file mode 100644 index b94f82b..0000000 --- a/t/ansi-test/cons/cons-test-03.lsp +++ /dev/null @@ -1,35 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Mar 28 07:32:20 1998 -;;;; Contains: Testing of CL Features related to "CONS", part 3 - - - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; (typep 'list) - -;;; These tests are now somewhat redundant - -(deftest typep-nil-list - (notnot-mv (typep nil 'list)) - t) - -(deftest typep-symbol-list - (typep 'a 'list) - nil) - -(deftest typep-singleton-list-list - (notnot-mv (typep '(a) 'list)) - t) - -(deftest typep-circular-list-list - (let ((x (cons nil nil))) - (setf (cdr x) x) - (notnot-mv (typep x 'list))) - t) - -(deftest typep-longer-list-list - (notnot-mv (typep '(a b c d e f g h) 'list)) - t) diff --git a/t/ansi-test/cons/cons-test-05.lsp b/t/ansi-test/cons/cons-test-05.lsp deleted file mode 100644 index ef433b3..0000000 --- a/t/ansi-test/cons/cons-test-05.lsp +++ /dev/null @@ -1,140 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Mar 28 07:34:08 1998 -;;;; Contains: Testing of CL Features related to "CONS", part 5 - - - - - -(defparameter *cons-accessors* - '(first second third fourth fifth sixth seventh eighth ninth tenth - car cdr caar cadr cdar cddr - caaar caadr cadar caddr cdaar cdadr cddar cdddr - caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr - cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; first, ..., tenth - -(deftest first-etc-1 - (let ((x (loop for i from 1 to 20 collect i))) - (list (first x) - (second x) - (third x) - (fourth x) - (fifth x) - (sixth x) - (seventh x) - (eighth x) - (ninth x) - (tenth x))) - (1 2 3 4 5 6 7 8 9 10)) - -(deftest first-etc-2 - (let ((x (make-list 15 :initial-element 'a))) - (and - (eql (setf (first x) 1) 1) - (eql (setf (second x) 2) 2) - (eql (setf (third x) 3) 3) - (eql (setf (fourth x) 4) 4) - (eql (setf (fifth x) 5) 5) - (eql (setf (sixth x) 6) 6) - (eql (setf (seventh x) 7) 7) - (eql (setf (eighth x) 8) 8) - (eql (setf (ninth x) 9) 9) - (eql (setf (tenth x) 10) 10) - x)) - (1 2 3 4 5 6 7 8 9 10 a a a a a)) - -(deftest rest-set-1 - (let ((x (list 'a 'b 'c))) - (and - (eqt (setf (rest x) 'd) 'd) - x)) - (a . d)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; setting of C*R accessors - -(loop - for fn in '(car cdr caar cadr cdar cddr - caaar caadr cadar caddr cdaar cdadr cddar cdddr - caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr - cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr) - do - (let ((level (- (length (symbol-name fn)) 2))) - (eval `(deftest ,(intern - (concatenate 'string - (symbol-name fn) - "-SET") - :cl-test) - (let ((x (create-c*r-test ,level)) - (y (list (create-c*r-test ,level))) - (i 0)) - (and - (setf (,fn (progn (incf i) x)) 'a) - (eqlt (,fn x) 'a) - (eqlt i 1) - (setf (,fn x) 'none) - (equalt x (create-c*r-test ,level)) - (setf (,fn (progn (incf i) (car y))) 'a) - (eqlt (,fn (car y)) 'a) - (eqlt i 2) - (setf (,fn (car y)) 'none) - (null (cdr y)) - (equalt (car y) (create-c*r-test ,level)) - )) - t)))) - -(loop - for (fn len) in '((first 1) (second 2) (third 3) (fourth 4) - (fifth 5) (sixth 6) (seventh 7) (eighth 8) - (ninth 9) (tenth 10)) - do - (eval - `(deftest ,(intern - (concatenate 'string - (symbol-name fn) - "-SET") - :cl-test) - (let* ((x (make-list 20 :initial-element nil)) - (y (list (copy-list x))) - (cnt 0)) - (and - (setf (,fn (progn (incf cnt) x)) 'a) - (eqlt cnt 1) - (loop - for i from 1 to 20 - do (when (and (not (eql i ,len)) - (nth (1- i) x)) - (return nil)) - finally (return t)) - (setf (,fn (car y)) 'a) - (loop - for i from 1 to 20 - do (when (and (not (eql i ,len)) - (nth (1- i) (car y))) - (return nil)) - finally (return t)) - (eqlt (,fn x) 'a) - (eqlt (nth ,(1- len) x) 'a) - (eqlt (,fn (car y)) 'a) - (nth ,(1- len) (car y)))) - a))) - -;; set up program-error tests - -(loop for name in *cons-accessors* - do (eval - `(deftest ,(intern (concatenate 'string (symbol-name name) - ".ERROR.NO-ARGS") - :cl-test) - (signals-error (,name) program-error) - t)) - do (eval - `(deftest ,(intern (concatenate 'string (symbol-name name) - ".ERROR.EXCESS-ARGS") - :cl-test) - (signals-error (,name nil nil) program-error) - t))) diff --git a/t/ansi-test/cons/cons.lsp b/t/ansi-test/cons/cons.lsp deleted file mode 100644 index 3882f99..0000000 --- a/t/ansi-test/cons/cons.lsp +++ /dev/null @@ -1,53 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 19 21:24:25 2003 -;;;; Contains: Tests for CONS - - - - - -;;; Various easy tests of cons - -(deftest cons-of-symbols - (cons 'a 'b) - (a . b)) - -(deftest cons-with-nil - (cons 'a nil) - (a)) - -;;; successive calls to cons produces results that are equal, but not eq -(deftest cons-eq-equal - (let ((x (cons 'a 'b)) - (y (cons 'a 'b))) - (and (not (eqt x y)) - (equalt x y))) - t) - -;;; list can be expressed as a bunch of conses (with nil) -(deftest cons-equal-list - (equalt (cons 'a (cons 'b (cons 'c nil))) - (list 'a 'b 'c)) - t) - -;;; Order of evaluation of cons arguments -(deftest cons.order.1 - (let ((i 0)) (values (cons (incf i) (incf i)) i)) - (1 . 2) 2) - -(def-fold-test cons.fold.1 (cons 'a 'b)) - -;;; Error tests - -(deftest cons.error.1 - (signals-error (cons) program-error) - t) - -(deftest cons.error.2 - (signals-error (cons 'a) program-error) - t) - -(deftest cons.error.3 - (signals-error (cons 'a 'b 'c) program-error) - t) diff --git a/t/ansi-test/cons/consp.lsp b/t/ansi-test/cons/consp.lsp deleted file mode 100644 index e5b22c2..0000000 --- a/t/ansi-test/cons/consp.lsp +++ /dev/null @@ -1,60 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 19 21:27:16 2003 -;;;; Contains: Tests of CONSP - - - - - -;; Lists satisfy consp -(deftest consp-list - (notnot-mv (consp '(a))) - t) - -;; cons satisfies consp -(deftest consp-cons - (notnot-mv (consp (cons nil nil))) - t) - -;; nil is not a consp -(deftest consp-nil - (consp nil) - nil) - -;; The empty list is not a cons -(deftest consp-empty-list - (consp (list)) - nil) - -;; A single element list is a cons -(deftest consp-single-element-list - (notnot-mv (consp (list 'a))) - t) - -;; For everything in *universe*, it is either an atom, or satisfies -;; consp, but not both -(deftest consp-xor-atom-universe - (check-predicate #'(lambda (x) (or (and (consp x) (not (atom x))) - (and (not (consp x)) (atom x))))) - nil) - -;; Everything in type cons satisfies consp, and vice versa -(deftest consp-cons-universe - (check-type-predicate 'consp 'cons) - nil) - -(deftest consp.order.1 - (let ((i 0)) - (values (consp (incf i)) i)) - nil 1) - -;;; Error tests - -(deftest consp.error.1 - (signals-error (consp) program-error) - t) - -(deftest consp.error.2 - (signals-error (consp 'a 'b) program-error) - t) diff --git a/t/ansi-test/cons/copy-alist.lsp b/t/ansi-test/cons/copy-alist.lsp deleted file mode 100644 index 2e0067d..0000000 --- a/t/ansi-test/cons/copy-alist.lsp +++ /dev/null @@ -1,44 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Apr 20 07:29:07 2003 -;;;; Contains: Tests of COPY-ALIST - - - - - -(deftest copy-alist.1 - (let* ((x (copy-tree '((a . b) (c . d) nil (e f) ((x) ((y z)) w) - ("foo" . "bar") (#\w . 1.234) - (1/3 . 4123.4d5)))) - (xcopy (make-scaffold-copy x)) - (result (copy-alist x))) - (and - (check-scaffold-copy x xcopy) - (= (length x) (length result)) - (every #'(lambda (p1 p2) - (or (and (null p1) (null p2)) - (and (not (eqt p1 p2)) - (eqlt (car p1) (car p2)) - (eqlt (cdr p1) (cdr p2))))) - x result) - t)) - t) - -(def-fold-test copy-alist.2 (copy-alist '((a . b) nil (c . d)))) -(def-fold-test copy-alist.3 (car (copy-alist '((a . b) nil (c . d))))) -(def-fold-test copy-alist.4 (caddr (copy-alist '((a . b) nil (c . d))))) - -;;; Error tests - -(deftest copy-alist.error.1 - (signals-error (copy-alist) program-error) - t) - -(deftest copy-alist.error.2 - (signals-error (copy-alist nil nil) program-error) - t) - -(deftest copy-alist.error.3 - (signals-error (copy-alist '((a . b) . c)) type-error) - t) diff --git a/t/ansi-test/cons/copy-list.lsp b/t/ansi-test/cons/copy-list.lsp deleted file mode 100644 index 968661c..0000000 --- a/t/ansi-test/cons/copy-list.lsp +++ /dev/null @@ -1,41 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 19 21:55:19 2003 -;;;; Contains: Tests of COPY-LIST - - - - - -(deftest copy-list.1 - (check-copy-list '(a b c d)) - (a b c d)) - -;; Check that copy-list works on dotted lists - -(deftest copy-list.2 - (check-copy-list '(a . b)) - (a . b)) - -(deftest copy-list.3 - (check-copy-list '(a b c . d)) - (a b c . d)) - -(deftest copy-list.4 - (let ((i 0)) - (values (copy-list (progn (incf i) '(a b c))) - i)) - (a b c) 1) - -(def-fold-test copy-list.fold.1 (copy-list '(a b c d))) -(def-fold-test copy-list.fold.2 (copy-list '(a . b))) - -;;; Error tests - -(deftest copy-list.error.1 - (signals-error (copy-list) program-error) - t) - -(deftest copy-list.error.2 - (signals-error (copy-list nil nil) program-error) - t) diff --git a/t/ansi-test/cons/copy-tree.lsp b/t/ansi-test/cons/copy-tree.lsp deleted file mode 100644 index 2340eca..0000000 --- a/t/ansi-test/cons/copy-tree.lsp +++ /dev/null @@ -1,49 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 19 21:31:33 2003 -;;;; Contains: Tests of COPY-TREE - - - - - -;; Try copy-tree on a tree containing elements of various kinds -(deftest copy-tree.1 - (let* ((x (cons 'a (list - (cons 'b 'c) - (cons 1 1.2) - (list (list "abcde" - (make-array '(10) :initial-element - (cons 'e 'f))) - 'g)))) - (y (copy-tree x))) - (check-cons-copy x y)) - t) - -;; Try copy-tree on *universe* -(deftest copy-tree.2 - (let* ((x (copy-list *universe*)) - (y (copy-tree x))) - (check-cons-copy x y)) - t) - -(deftest copy-tree.order.1 - (let ((i 0)) - (values - (copy-tree (progn (incf i) '(a b c))) - i)) - (a b c) 1) - -(def-fold-test copy-tree.fold.1 (copy-tree '(a . b))) -(def-fold-test copy-tree.fold.2 (copy-tree '(a))) -(def-fold-test copy-tree.fold.3 (copy-tree '(a b c d e))) - -;;; Error tests - -(deftest copy-tree.error.1 - (signals-error (copy-tree) program-error) - t) - -(deftest copy-tree.error.2 - (signals-error (copy-tree 'a 'b) program-error) - t) diff --git a/t/ansi-test/cons/cxr.lsp b/t/ansi-test/cons/cxr.lsp deleted file mode 100644 index 2f27d9f..0000000 --- a/t/ansi-test/cons/cxr.lsp +++ /dev/null @@ -1,621 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 19 21:28:38 2003 -;;;; Contains: Tests of C*R functions - - - - - -;; Tests of car, cdr and compound forms -(deftest cons.23 - (car '(a)) - a) - -(deftest cons.24 - (cdr '(a . b)) - b) - -(deftest cons.25 - (caar '((a))) - a) - -(deftest cons.26 - (cdar '((a . b))) - b) - -(deftest cons.27 - (cadr '(a b)) - b) - -(deftest cons.28 - (cddr '(a b . c)) - c) - -(deftest cons.29 - (caaar '(((a)))) - a) - -(deftest cons.30 - (cdaar '(((a . b)))) - b) - -(deftest cons.31 - (cadar (cons (cons 'a (cons 'b 'c)) 'd)) - b) - -(deftest cons.32 - (cddar (cons (cons 'a (cons 'b 'c)) 'd)) - c) - -(deftest cons.33 - (caadr (cons 'a (cons (cons 'b 'c) 'd))) - b) - -(deftest cons.34 - (caddr (cons 'a (cons 'b (cons 'c 'd)))) - c) - -(deftest cons.36 - (cdadr (cons 'a (cons (cons 'b 'c) 'd))) - c) - -(deftest cons.37 - (cdddr (cons 'a (cons 'b (cons 'c 'd)))) - d) - -(defvar *cons-test-4* - (cons (cons (cons (cons 'a 'b) - (cons 'c 'd)) - (cons (cons 'e 'f) - (cons 'g 'h))) - (cons (cons (cons 'i 'j) - (cons 'k 'l)) - (cons (cons 'm 'n) - (cons 'o 'p))))) - -(deftest cons.38 - (caaaar *cons-test-4*) - a) - -(deftest cons.39 - (cdaaar *cons-test-4*) - b) - -(deftest cons.40 - (cadaar *cons-test-4*) - c) - -(deftest cons.41 - (cddaar *cons-test-4*) - d) - -(deftest cons.42 - (caadar *cons-test-4*) - e) - -(deftest cons.43 - (cdadar *cons-test-4*) - f) - -(deftest cons.44 - (caddar *cons-test-4*) - g) - -(deftest cons.45 - (cdddar *cons-test-4*) - h) - -;;; - -(deftest cons.46 - (caaadr *cons-test-4*) - i) - -(deftest cons.47 - (cdaadr *cons-test-4*) - j) - -(deftest cons.48 - (cadadr *cons-test-4*) - k) - -(deftest cons.49 - (cddadr *cons-test-4*) - l) - -(deftest cons.50 - (caaddr *cons-test-4*) - m) - -(deftest cons.51 - (cdaddr *cons-test-4*) - n) - -(deftest cons.52 - (cadddr *cons-test-4*) - o) - -(deftest cons.53 - (cddddr *cons-test-4*) - p) - -(deftest car.1 - (car '(a)) - a) - -(deftest car-nil - (car nil) - nil) - -(deftest car.error.1 - (check-type-error #'car #'listp) - nil) - -(deftest car.error.2 - (signals-error (locally (car 'a) t) type-error) - t) - -(deftest car.order.1 - (let ((i 0)) - (values (car (progn (incf i) '(a b))) i)) - a 1) - -(deftest cdr.1 - (cdr '(a b)) - (b)) - -(deftest cdr-nil - (cdr ()) - nil) - -(deftest cdr.order.1 - (let ((i 0)) - (values (cdr (progn (incf i) '(a b))) i)) - (b) 1) - -(deftest cdr.error.1 - (check-type-error #'cdr #'listp) - nil) - -(deftest cdr.error.2 - (signals-error (locally (cdr 'a) t) type-error) - t) - -;;; Error checking of c*r functions - -(deftest caar.error.1 - (signals-error (caar 'a) type-error) - t) - -(deftest caar.error.2 - (signals-error (caar '(a)) type-error) - t) - -(deftest cadr.error.1 - (signals-error (cadr 'a) type-error) - t) - -(deftest cadr.error.2 - (signals-error (cadr '(a . b)) type-error) - t) - -(deftest cdar.error.1 - (signals-error (cdar 'a) type-error) - t) - -(deftest cdar.error.2 - (signals-error (cdar '(a . b)) type-error) - t) - -(deftest cddr.error.1 - (signals-error (cddr 'a) type-error) - t) - -(deftest cddr.error.2 - (signals-error (cddr '(a . b)) type-error) - t) - -(deftest caaar.error.1 - (signals-error (caaar 'a) type-error) - t) - -(deftest caaar.error.2 - (signals-error (caaar '(a)) type-error) - t) - -(deftest caaar.error.3 - (signals-error (caaar '((a))) type-error) - t) - -(deftest caadr.error.1 - (signals-error (caadr 'a) type-error) - t) - -(deftest caadr.error.2 - (signals-error (caadr '(a . b)) type-error) - t) - -(deftest caadr.error.3 - (signals-error (caadr '(a . (b))) type-error) - t) - -(deftest cadar.error.1 - (signals-error (cadar 'a) type-error) - t) - -(deftest cadar.error.2 - (signals-error (cadar '(a . b)) type-error) - t) - -(deftest cadar.error.3 - (signals-error (cadar '((a . c) . b)) type-error) - t) - -(deftest caddr.error.1 - (signals-error (caddr 'a) type-error) - t) - -(deftest caddr.error.2 - (signals-error (caddr '(a . b)) type-error) - t) - -(deftest caddr.error.3 - (signals-error (caddr '(a c . b)) type-error) - t) - -(deftest cdaar.error.1 - (signals-error (cdaar 'a) type-error) - t) - -(deftest cdaar.error.2 - (signals-error (cdaar '(a)) type-error) - t) - -(deftest cdaar.error.3 - (signals-error (cdaar '((a . b))) type-error) - t) - -(deftest cdadr.error.1 - (signals-error (cdadr 'a) type-error) - t) - -(deftest cdadr.error.2 - (signals-error (cdadr '(a . b)) type-error) - t) - -(deftest cdadr.error.3 - (signals-error (cdadr '(a b . c)) type-error) - t) - -(deftest cddar.error.1 - (signals-error (cddar 'a) type-error) - t) - -(deftest cddar.error.2 - (signals-error (cddar '(a . b)) type-error) - t) - -(deftest cddar.error.3 - (signals-error (cddar '((a . b) . b)) type-error) - t) - -(deftest cdddr.error.1 - (signals-error (cdddr 'a) type-error) - t) - -(deftest cdddr.error.2 - (signals-error (cdddr '(a . b)) type-error) - t) - -(deftest cdddr.error.3 - (signals-error (cdddr '(a c . b)) type-error) - t) - -;; - -(deftest caaaar.error.1 - (signals-error (caaaar 'a) type-error) - t) - -(deftest caaaar.error.2 - (signals-error (caaaar '(a)) type-error) - t) - -(deftest caaaar.error.3 - (signals-error (caaaar '((a))) type-error) - t) - -(deftest caaaar.error.4 - (signals-error (caaaar '(((a)))) type-error) - t) - -(deftest caaadr.error.1 - (signals-error (caaadr 'a) type-error) - t) - -(deftest caaadr.error.2 - (signals-error (caaadr '(a . b)) type-error) - t) - -(deftest caaadr.error.3 - (signals-error (caaadr '(a . (b))) type-error) - t) - -(deftest caaadr.error.4 - (signals-error (caaadr '(a . ((b)))) type-error) - t) - -(deftest caadar.error.1 - (signals-error (caadar 'a) type-error) - t) - -(deftest caadar.error.2 - (signals-error (caadar '(a . b)) type-error) - t) - -(deftest caadar.error.3 - (signals-error (caadar '((a . c) . b)) type-error) - t) - -(deftest caadar.error.4 - (signals-error (caadar '((a . (c)) . b)) type-error) - t) - -(deftest caaddr.error.1 - (signals-error (caaddr 'a) type-error) - t) - -(deftest caaddr.error.2 - (signals-error (caaddr '(a . b)) type-error) - t) - -(deftest caaddr.error.3 - (signals-error (caaddr '(a c . b)) type-error) - t) - -(deftest caaddr.error.4 - (signals-error (caaddr '(a c . (b))) type-error) - t) - -(deftest cadaar.error.1 - (signals-error (cadaar 'a) type-error) - t) - -(deftest cadaar.error.2 - (signals-error (cadaar '(a)) type-error) - t) - -(deftest cadaar.error.3 - (signals-error (cadaar '((a . b))) type-error) - t) - -(deftest cadaar.error.4 - (signals-error (cadaar '((a . (b)))) type-error) - t) - -(deftest cadadr.error.1 - (signals-error (cadadr 'a) type-error) - t) - -(deftest cadadr.error.2 - (signals-error (cadadr '(a . b)) type-error) - t) - -(deftest cadadr.error.3 - (signals-error (cadadr '(a b . c)) type-error) - t) - -(deftest cadadr.error.4 - (signals-error (cadadr '(a (b . e) . c)) type-error) - t) - -(deftest caddar.error.1 - (signals-error (caddar 'a) type-error) - t) - -(deftest caddar.error.2 - (signals-error (caddar '(a . b)) type-error) - t) - -(deftest caddar.error.3 - (signals-error (caddar '((a . b) . b)) type-error) - t) - -(deftest caddar.error.4 - (signals-error (caddar '((a b . c) . b)) type-error) - t) - -(deftest cadddr.error.1 - (signals-error (cadddr 'a) type-error) - t) - -(deftest cadddr.error.2 - (signals-error (cadddr '(a . b)) type-error) - t) - -(deftest cadddr.error.3 - (signals-error (cadddr '(a c . b)) type-error) - t) - -(deftest cadddr.error.4 - (signals-error (cadddr '(a c e . b)) type-error) - t) - -(deftest cdaaar.error.1 - (signals-error (cdaaar 'a) type-error) - t) - -(deftest cdaaar.error.2 - (signals-error (cdaaar '(a)) type-error) - t) - -(deftest cdaaar.error.3 - (signals-error (cdaaar '((a))) type-error) - t) - -(deftest cdaaar.error.4 - (signals-error (cdaaar '(((a . b)))) type-error) - t) - -(deftest cdaadr.error.1 - (signals-error (cdaadr 'a) type-error) - t) - -(deftest cdaadr.error.2 - (signals-error (cdaadr '(a . b)) type-error) - t) - -(deftest cdaadr.error.3 - (signals-error (cdaadr '(a . (b))) type-error) - t) - -(deftest cdaadr.error.4 - (signals-error (cdaadr '(a . ((b . c)))) type-error) - t) - -(deftest cdadar.error.1 - (signals-error (cdadar 'a) type-error) - t) - -(deftest cdadar.error.2 - (signals-error (cdadar '(a . b)) type-error) - t) - -(deftest cdadar.error.3 - (signals-error (cdadar '((a . c) . b)) type-error) - t) - -(deftest cdadar.error.4 - (signals-error (cdadar '((a . (c . d)) . b)) type-error) - t) - -(deftest cdaddr.error.1 - (signals-error (cdaddr 'a) type-error) - t) - -(deftest cdaddr.error.2 - (signals-error (cdaddr '(a . b)) type-error) - t) - -(deftest cdaddr.error.3 - (signals-error (cdaddr '(a c . b)) type-error) - t) - -(deftest cdaddr.error.4 - (signals-error (cdaddr '(a c b . d)) type-error) - t) - -(deftest cddaar.error.1 - (signals-error (cddaar 'a) type-error) - t) - -(deftest cddaar.error.2 - (signals-error (cddaar '(a)) type-error) - t) - -(deftest cddaar.error.3 - (signals-error (cddaar '((a . b))) type-error) - t) - -(deftest cddaar.error.4 - (signals-error (cddaar '((a . (b)))) type-error) - t) - -(deftest cddadr.error.1 - (signals-error (cddadr 'a) type-error) - t) - -(deftest cddadr.error.2 - (signals-error (cddadr '(a . b)) type-error) - t) - -(deftest cddadr.error.3 - (signals-error (cddadr '(a b . c)) type-error) - t) - -(deftest cddadr.error.4 - (signals-error (cddadr '(a (b . e) . c)) type-error) - t) - -(deftest cdddar.error.1 - (signals-error (cdddar 'a) type-error) - t) - -(deftest cdddar.error.2 - (signals-error (cdddar '(a . b)) type-error) - t) - -(deftest cdddar.error.3 - (signals-error (cdddar '((a . b) . b)) type-error) - t) - -(deftest cdddar.error.4 - (signals-error (cdddar '((a b . c) . b)) type-error) - t) - -(deftest cddddr.error.1 - (signals-error (cddddr 'a) type-error) - t) - -(deftest cddddr.error.2 - (signals-error (cddddr '(a . b)) type-error) - t) - -(deftest cddddr.error.3 - (signals-error (cddddr '(a c . b)) type-error) - t) - -(deftest cddddr.error.4 - (signals-error (cddddr '(a c e . b)) type-error) - t) - -;;; Need to add 'locally' wrapped forms of these - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; setting of C*R accessors - -(loop - for fn in '(car cdr caar cadr cdar cddr - caaar caadr cadar caddr cdaar cdadr cddar cdddr - caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr - cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr) - do - (let ((level (- (length (symbol-name fn)) 2))) - (eval `(deftest ,(intern - (concatenate 'string - (symbol-name fn) - "-SET-ALT") - :cl-test) - (let ((x (create-c*r-test ,level))) - (and - (setf (,fn x) 'a) - (eql (,fn x) 'a) - (setf (,fn x) 'none) - (equalt x (create-c*r-test ,level)) - )) - t)))) - -(loop - for (fn len) in '((first 1) (second 2) (third 3) (fourth 4) - (fifth 5) (sixth 6) (seventh 7) (eighth 8) - (ninth 9) (tenth 10)) - do - (eval - `(deftest ,(intern - (concatenate 'string - (symbol-name fn) - "-SET-ALT") - :cl-test) - (let ((x (make-list 20 :initial-element nil))) - (and - (setf (,fn x) 'a) - (loop - for i from 1 to 20 - do (when (and (not (eql i ,len)) - (nth (1- i) x)) - (return nil)) - finally (return t)) - (eql (,fn x) 'a) - (nth ,(1- len) x))) - a))) diff --git a/t/ansi-test/cons/endp.lsp b/t/ansi-test/cons/endp.lsp deleted file mode 100644 index 7baea45..0000000 --- a/t/ansi-test/cons/endp.lsp +++ /dev/null @@ -1,43 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Mar 28 07:34:40 1998 -;;;; Contains: Tests of ENDP - - - - - -(deftest endp-nil - (notnot-mv (endp nil)) - t) - -(deftest endp-cons - (endp (cons 'a 'a)) - nil) - -(deftest endp-singleton-list - (endp '(a)) - nil) - -(deftest endp.order.1 - (let ((i 0)) - (values - (endp (progn (incf i) '(a b c))) - i)) - nil 1) - -(deftest endp.error.1 - (check-type-error #'endp #'listp) - nil) - -(deftest endp.error.4 - (signals-error (endp) program-error) - t) - -(deftest endp.error.5 - (signals-error (endp nil nil) program-error) - t) - -(deftest endp.error.6 - (signals-error (locally (endp 1)) type-error) - t) diff --git a/t/ansi-test/cons/get-properties.lsp b/t/ansi-test/cons/get-properties.lsp deleted file mode 100644 index 318b707..0000000 --- a/t/ansi-test/cons/get-properties.lsp +++ /dev/null @@ -1,95 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Apr 20 07:37:00 2003 -;;;; Contains: Tests of GET-PROPERTIES - - - - - -(deftest get-properties.1 - (get-properties nil nil) - nil nil nil) - -(deftest get-properties.2 - (get-properties '(a b) nil) - nil nil nil) - -(deftest get-properties.3 - (get-properties '(a b c d) '(a)) - a b (a b c d)) - -(deftest get-properties.4 - (get-properties '(a b c d) '(c)) - c d (c d)) - -(deftest get-properties.5 - (get-properties '(a b c d) '(c a)) - a b (a b c d)) - -(deftest get-properties.6 - (get-properties '(a b c d) '(b)) - nil nil nil) - -(deftest get-properties.7 - (get-properties '("aa" b c d) (list (copy-seq "aa"))) - nil nil nil) - -;;; I removed the next test (noticed by Duane Rettig) because -;;; the non-eqness of numbers may not be necesarily preserved. -;;; The standard says numbers may be copied at any time, and -;;; this might mean eql numbers are copied to a canonical eq -;;; value -#| -(deftest get-properties.8 - (get-properties '(1000000000000 b c d) (list (1+ 999999999999))) - nil nil nil) -|# - -(deftest get-properties.9 - (let* ((x (copy-list '(a b c d e f g h a c))) - (xcopy (make-scaffold-copy x)) - (y (copy-list '(x y f g))) - (ycopy (make-scaffold-copy y))) - (multiple-value-bind - (indicator value tail) - (get-properties x y) - (and - (check-scaffold-copy x xcopy) - (check-scaffold-copy y ycopy) - (eqt tail (nthcdr 6 x)) - (values indicator value tail)))) - g h (g h a c)) - -(deftest get-properties.order.1 - (let ((i 0) x y) - (values - (multiple-value-list - (get-properties (progn (setf x (incf i)) '(a b c d)) - (progn (setf y (incf i)) '(c)))) - i x y)) - (c d (c d)) 2 1 2) - -(deftest get-properties.error.1 - (signals-error (get-properties) program-error) - t) - -(deftest get-properties.error.2 - (signals-error (get-properties nil) program-error) - t) - -(deftest get-properties.error.3 - (signals-error (get-properties nil nil nil) program-error) - t) - -(deftest get-properties.error.4 - (signals-error (get-properties '(a 1 b 2 c 3) '(x . y)) type-error) - t) - -(deftest get-properties.error.5 - (signals-error (get-properties '(a 1 b 2 c 3 . d) '(x y)) type-error) - t) - -(deftest get-properties.error.6 - (signals-error (get-properties '(a 1 b 2 c . d) '(x y)) type-error) - t) diff --git a/t/ansi-test/cons/getf.lsp b/t/ansi-test/cons/getf.lsp deleted file mode 100644 index da57dbf..0000000 --- a/t/ansi-test/cons/getf.lsp +++ /dev/null @@ -1,223 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Apr 20 07:37:41 2003 -;;;; Contains: Tests of GETF - - - - - -(deftest getf.1 - (getf nil 'a) - nil) - -(deftest getf.2 - (getf nil 'a 'b) - b) - -(deftest getf.3 - (getf '(a b) 'a) - b) - -(deftest getf.4 - (getf '(a b) 'a 'c) - b) - -(deftest getf.5 - (let ((x 0)) - (values - (getf '(a b) 'a (incf x)) - x)) - b 1) - -(deftest getf.order.1 - (let ((i 0) x y) - (values - (getf (progn (setf x (incf i)) '(a b)) - (progn (setf y (incf i)) 'a)) - i x y)) - b 2 1 2) - -(deftest getf.order.2 - (let ((i 0) x y z) - (values - (getf (progn (setf x (incf i)) '(a b)) - (progn (setf y (incf i)) 'a) - (setf z (incf i))) - i x y z)) - b 3 1 2 3) - -(deftest setf-getf.1 - (let ((p (copy-list '(a 1 b 2)))) - (setf (getf p 'c) 3) - ;; Must check that only a, b, c have properties - (and - (eqlt (getf p 'a) 1) - (eqlt (getf p 'b) 2) - (eqlt (getf p 'c) 3) - (eqlt - (loop - for ptr on p by #'cddr count - (not (member (car ptr) '(a b c)))) - 0) - t)) - t) - -(deftest setf-getf.2 - (let ((p (copy-list '(a 1 b 2)))) - (setf (getf p 'a) 3) - ;; Must check that only a, b have properties - (and - (eqlt (getf p 'a) 3) - (eqlt (getf p 'b) 2) - (eqlt - (loop - for ptr on p by #'cddr count - (not (member (car ptr) '(a b)))) - 0) - t)) - t) - -(deftest setf-getf.3 - (let ((p (copy-list '(a 1 b 2)))) - (setf (getf p 'c 17) 3) - ;; Must check that only a, b, c have properties - (and - (eqlt (getf p 'a) 1) - (eqlt (getf p 'b) 2) - (eqlt (getf p 'c) 3) - (eqlt - (loop - for ptr on p by #'cddr count - (not (member (car ptr) '(a b c)))) - 0) - t)) - t) - -(deftest setf-getf.4 - (let ((p (copy-list '(a 1 b 2)))) - (setf (getf p 'a 17) 3) - ;; Must check that only a, b have properties - (and - (eqlt (getf p 'a) 3) - (eqlt (getf p 'b) 2) - (eqlt - (loop - for ptr on p by #'cddr count - (not (member (car ptr) '(a b)))) - 0) - t)) - t) - -(deftest setf-getf.5 - (let ((p (copy-list '(a 1 b 2))) - (foo nil)) - (setf (getf p 'a (progn (setf foo t) 0)) 3) - ;; Must check that only a, b have properties - (and - (eqlt (getf p 'a) 3) - (eqlt (getf p 'b) 2) - (eqlt - (loop - for ptr on p by #'cddr count - (not (member (car ptr) '(a b)))) - 0) - foo)) - t) - -(deftest setf-getf.order.1 - (let ((p (list (copy-list '(a 1 b 2)))) - (cnt1 0) (cnt2 0) (cnt3 0)) - (setf (getf (car (progn (incf cnt1) p)) 'c (incf cnt3)) - (progn (incf cnt2) 3)) - ;; Must check that only a, b, c have properties - (values - cnt1 ; (eqlt cnt1 1) - cnt2 ; (eqlt cnt2 1) - cnt3 ; (eqlt cnt3 1) - (getf (car p) 'a) - (getf (car p) 'b) - (getf (car p) 'c) - (loop - for ptr on (car p) by #'cddr count - (not (member (car ptr) '(a b c)))))) - 1 1 1 - 1 2 3 - 0) - -(deftest setf-getf.order.2 - (let ((p (list (copy-list '(a 1 b 2)))) - (i 0) x y z w) - (setf (getf (car (progn (setf x (incf i)) p)) - (progn (setf y (incf i)) 'c) - (setf z (incf i))) - (progn (setf w (incf i)) 3)) - ;; Must check that only a, b, c have properties - (values - i x y z w - (getf (car p) 'a) - (getf (car p) 'b) - (getf (car p) 'c) - (loop for ptr on (car p) by #'cddr count - (not (member (car ptr) '(a b c)))))) - 4 1 2 3 4 1 2 3 0) - -(deftest incf-getf.1 - (let ((p (copy-list '(a 1 b 2)))) - (incf (getf p 'b)) - ;; Must check that only a, b have properties - (and - (eqlt (getf p 'a) 1) - (eqlt (getf p 'b) 3) - (eqlt - (loop - for ptr on p by #'cddr count - (not (member (car ptr) '(a b)))) - 0) - t)) - t) - -(deftest incf-getf.2 - (let ((p (copy-list '(a 1 b 2)))) - (incf (getf p 'c 19)) - ;; Must check that only a, b have properties - (and - (eqlt (getf p 'a) 1) - (eqlt (getf p 'b) 2) - (eqlt (getf p 'c) 20) - (eqlt - (loop - for ptr on p by #'cddr count - (not (member (car ptr) '(a b c)))) - 0) - t)) - t) - -(deftest push-getf.1 - (let ((p nil)) - (values - (push 'x (getf p 'a)) - p)) - (x) (a (x))) - -;;; Error tests - -(deftest getf.error.1 - (signals-error (getf) program-error) - t) - -(deftest getf.error.2 - (signals-error (getf nil) program-error) - t) - -(deftest getf.error.3 - (signals-error (getf nil nil nil nil) program-error) - t) - -(deftest getf.error.4 - (signals-error (getf '(a . b) 'c) type-error) - t) - -(deftest getf.error.5 - (signals-error (getf '(a 10 . b) 'c) type-error) - t) diff --git a/t/ansi-test/cons/intersection.lsp b/t/ansi-test/cons/intersection.lsp deleted file mode 100644 index 7f3b0b2..0000000 --- a/t/ansi-test/cons/intersection.lsp +++ /dev/null @@ -1,417 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Apr 20 07:39:19 2003 -;;;; Contains: Tests of INTERSECTION - - - - - -(deftest intersection.1 - (intersection nil nil) - nil) - -(deftest intersection.2 - (intersection (loop for i from 1 to 100 collect i) nil) - nil) - -(deftest intersection.3 - (intersection nil (loop for i from 1 to 100 collect i)) - nil) - -(deftest intersection.4 - (let* ((x (copy-list '(a 1 c 7 b 4 3 z))) - (xcopy (make-scaffold-copy x)) - (y (copy-list '(3 y c q z a 18))) - (ycopy (make-scaffold-copy y)) - (result (intersection x y))) - (and - (check-scaffold-copy x xcopy) - (check-scaffold-copy y ycopy) - (+ - (loop - for e in x count - (and (member e y) - (not (member e result)))) - (loop - for e in result count - (or (not (member e x)) - (not (member e y)))) - (loop - for hd on result count - (and (consp hd) - (member (car hd) (cdr hd))))))) - 0) - -(deftest intersection.5 - (let* ((x (copy-list '(a a a))) - (xcopy (make-scaffold-copy x)) - (y (copy-list '(a a a b b b))) - (ycopy (make-scaffold-copy y)) - (result (intersection x y))) - (and - (check-scaffold-copy x xcopy) - (check-scaffold-copy y ycopy) - (member 'a result) - (not (member 'b result)))) - t) - -(deftest intersection.6 - (intersection (list 1000000000000 'a 'b 'c) - (list (1+ 999999999999) 'd 'e 'f)) - (1000000000000)) - -(deftest intersection.7 - (intersection (list 'a 10 'b 17) - (list 'c 'd 4 'e 'f 10 1 13 'z)) - (10)) - -(deftest intersection.8 - (intersection (list 'a (copy-seq "aaa") 'b) - (list 'd (copy-seq "aaa") 'e)) - nil) - -(deftest intersection.9 - (intersection (list 'a (copy-seq "aaa") 'b) - (list 'd (copy-seq "aaa") 'e) - :test #'equal) - ("aaa")) - -;; Same as 9, but with a symbol function designator for :test -(deftest intersection.9-a - (intersection (list 'a (copy-seq "aaa") 'b) - (list 'd (copy-seq "aaa") 'e) - :test 'equal) - ("aaa")) - -(deftest intersection.9-b - (intersection (list 'a (copy-seq "aaa") 'b) - (list 'd (copy-seq "aaa") 'e) - :test-not #'(lambda (p q) (not (equal p q)))) - ("aaa")) - -(deftest intersection.10 - (equalt - (sort - (intersection (loop - for i from 0 to 1000 by 3 - collect i) - (loop - for i from 0 to 1000 by 7 - collect i)) - #'<) - (loop for i from 0 to 1000 by 21 collect i)) - t) - -(deftest intersection.11 - (equalt - (sort - (intersection (loop - for i from 0 to 999 by 5 - collect i) - (loop - for i from 0 to 999 by 7 - collect i) - :test #'(lambda (a b) - (and (eql a b) - (= (mod a 3) 0)))) - #'<) - (loop for i from 0 to 999 by (* 3 5 7) collect i)) - t) - -(deftest intersection.11-a - (equalt - (sort - (intersection (loop - for i from 0 to 999 by 5 - collect i) - (loop - for i from 0 to 999 by 7 - collect i) - :test-not - #'(lambda (a b) - (not (and (eql a b) - (= (mod a 3) 0))))) - #'<) - (loop for i from 0 to 999 by (* 3 5 7) collect i)) - t) - -;; -;; Do large numbers of random intersection tests -;; - -(deftest intersection.12 - (intersection-12-body 100 100) - nil) - - -;; -;; :key argument -;; - -(deftest intersection.13 - (let ((x (copy-list '(0 5 8 13 31 42))) - (y (copy-list '(3 5 42 0 7 100 312 33)))) - (equalt - (sort (copy-list (intersection x y)) #'<) - (sort (copy-list (intersection x y :key #'1+)) #'<))) - t) - -;; Same as 13, but with a symbol function designator for :key -(deftest intersection.13-a - (let ((x (copy-list '(0 5 8 13 31 42))) - (y (copy-list '(3 5 42 0 7 100 312 33)))) - (equalt - (sort (copy-list (intersection x y)) #'<) - (sort (copy-list (intersection x y :key '1+)) #'<))) - t) - -;; Test that a nil key argument is ignored - -(deftest intersection.14 - (let - ((result (intersection (copy-list '(a b c d)) - (copy-list '(e c f b g)) - :key nil))) - (and - (member 'b result) - (member 'c result) - (every #'(lambda (x) (member x '(b c))) result) - t)) - t) - -;; Test that intersection preserves the order of arguments to :test, :test-not - -(deftest intersection.15 - (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) - (block fail - (intersection - list1 list2 - :test - #'(lambda (x y) - (when (< y x) (return-from fail 'fail)) - (eql x y))))) - (4)) - -(deftest intersection.16 - (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) - (block fail - (intersection - list1 list2 - :key #'identity - :test - #'(lambda (x y) - (when (< y x) (return-from fail 'fail)) - (eql x y))))) - (4)) - -(deftest intersection.17 - (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) - (block fail - (intersection - list1 list2 - :test-not - #'(lambda (x y) - (when (< y x) (return-from fail 'fail)) - (not (eql x y)))))) - (4)) - -(deftest intersection.18 - (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) - (block fail - (intersection - list1 list2 - :key #'identity - :test-not - #'(lambda (x y) - (when (< y x) (return-from fail 'fail)) - (not (eql x y)))))) - (4)) - -(defharmless intersection.test-and-test-not.1 - (intersection '(a b c) '(a c e) :test #'eql :test-not #'eql)) - -(defharmless intersection.test-and-test-not.2 - (intersection '(a b c) '(a c e) :test-not #'eql :test #'eql)) - -;;; Order of argument evaluation tests - -(deftest intersection.order.1 - (let ((i 0) x y) - (values - (intersection (progn (setf x (incf i)) (list 'a 'b)) - (progn (setf y (incf i)) (list 'c 'd))) - i x y)) - nil 2 1 2) - -(deftest intersection.order.2 - (let ((i 0) x y) - (values - (intersection (progn (setf x (incf i)) (list 'a 'b)) - (progn (setf y (incf i)) (list 'c 'd)) - :test #'eq) - i x y)) - nil 2 1 2) - -(deftest intersection.order.3 - (let ((i 0) x y z w) - (values - (intersection (progn (setf x (incf i)) (list 'a 'b)) - (progn (setf y (incf i)) (list 'c 'd)) - :test (progn (setf z (incf i)) #'eq) - :test (progn (setf w (incf i)) - (complement #'eq))) - i x y z w)) - nil 4 1 2 3 4) - -(deftest intersection.order.4 - (let ((i 0) x y z w) - (values - (intersection (progn (setf x (incf i)) (list 'a 'b)) - (progn (setf y (incf i)) (list 'c 'd)) - :test (progn (setf z (incf i)) #'eq) - :key (progn (setf w (incf i)) #'identity)) - i x y z w)) - nil 4 1 2 3 4) - -(deftest intersection.order.5 - (let ((i 0) x y z w) - (values - (intersection (progn (setf x (incf i)) (list 'a 'b)) - (progn (setf y (incf i)) (list 'c 'd)) - :key (progn (setf z (incf i)) #'identity) - :test (progn (setf w (incf i)) #'eq)) - i x y z w)) - nil 4 1 2 3 4) - - -;;; Keyword tests - -(deftest intersection.allow-other-keys.1 - (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) - (intersection list1 list2 :bad t :allow-other-keys 1)) - (4)) - -(deftest intersection.allow-other-keys.2 - (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) - (intersection list1 list2 :allow-other-keys :foo :also-bad t)) - (4)) - -(deftest intersectionallow-other-keys.3 - (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) - (intersection list1 list2 :allow-other-keys :foo :also-bad t - :test #'(lambda (x y) (= x (1+ y))))) - nil) - -(deftest intersection.allow-other-keys.4 - (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) - (intersection list1 list2 :allow-other-keys t)) - (4)) - -(deftest intersection.allow-other-keys.5 - (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) - (intersection list1 list2 :allow-other-keys nil)) - (4)) - -(deftest intersection.allow-other-keys.6 - (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) - (intersection list1 list2 :allow-other-keys t - :allow-other-keys nil :bad t)) - (4)) - -(deftest intersection.allow-other-keys.7 - (sort - (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) - (intersection list1 list2 :allow-other-keys t - :allow-other-keys nil - :test #'(lambda (x y) (eql x (1- y))))) - #'<) - (3 4)) - -(deftest intersection.keywords.8 - (sort - (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) - (intersection list1 list2 - :test #'(lambda (x y) (eql x (1- y))) - :test #'eql)) - #'<) - (3 4)) - -(def-fold-test intersection.fold.1 (intersection '(a b c d e f) '(d w a x b y))) - -;;; Error tests - -(deftest intersection.error.1 - (signals-error (intersection) program-error) - t) - -(deftest intersection.error.2 - (signals-error (intersection nil) program-error) - t) - -(deftest intersection.error.3 - (signals-error (intersection nil nil :bad t) program-error) - t) - -(deftest intersection.error.4 - (signals-error (intersection nil nil :key) program-error) - t) - -(deftest intersection.error.5 - (signals-error (intersection nil nil 1 2) program-error) - t) - -(deftest intersection.error.6 - (signals-error (intersection nil nil :bad t :allow-other-keys nil) - program-error) - t) - -(deftest intersection.error.7 - (signals-error (intersection '(a b c) '(d e f) :test #'identity) - program-error) - t) - -(deftest intersection.error.8 - (signals-error (intersection '(a b c) '(d e f) :test-not #'identity) - program-error) - t) - -(deftest intersection.error.9 - (signals-error (intersection '(a b c) '(d e f) :key #'cons) - program-error) - t) - -(deftest intersection.error.10 - (signals-error (intersection '(a b c) '(d e f) :key #'car) - type-error) - t) - -(deftest intersection.error.11 - (signals-error (intersection '(a b c) '(d e f . g)) - type-error) - t) - -(deftest intersection.error.12 - (signals-error (intersection '(a b . c) '(d e f)) - type-error) - t) - -(deftest intersection.error.13 - (check-type-error #'(lambda (x) (intersection x '(a b c))) #'listp) - nil) - -(deftest intersection.error.14 - (check-type-error #'(lambda (x) (intersection '(a b c) x)) #'listp) - nil) diff --git a/t/ansi-test/cons/last.lsp b/t/ansi-test/cons/last.lsp deleted file mode 100644 index 56f36b8..0000000 --- a/t/ansi-test/cons/last.lsp +++ /dev/null @@ -1,115 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Mar 28 07:37:21 1998 -;;;; Contains: Testing of CL Features related to "CONS", part 10 - - - - - -(deftest last.1 - (last nil) - nil) - -(deftest last.2 - (last (copy-tree '(a b))) - (b)) - -(deftest last.3 - (last (copy-tree '(a b . c))) - (b . c)) - -(deftest last.4 - (last (copy-tree '(a b c d)) 0) - nil) - -(deftest last.5 - (last (copy-tree '(a b c d)) 1) - (d)) - -(deftest last.6 - (last (copy-tree '(a b c d)) 2) - (c d)) - -(deftest last.7 - (last (copy-tree '(a b c d)) 5) - (a b c d)) - -(deftest last.8 - (last (cons 'a 'b) 0) - b) - -(deftest last.9 - (last (cons 'a 'b) 1) - (a . b)) - -(deftest last.10 - (last (cons 'a 'b) 2) - (a . b)) - -(deftest last.11 - (let ((x '(a b c))) - (eqt (last x (1+ most-positive-fixnum)) x)) - t) - -(deftest last.12 - (let ((x '(a b c . d))) - (eqt (last x (1+ most-positive-fixnum)) x)) - t) - -(deftest last.13 - (let ((x '(a b c . d))) - (eqt (last x most-positive-fixnum) x)) - t) - -(deftest last.14 - (let ((x '(a b c . d))) - (eqt (last x (1- most-positive-fixnum)) x)) - t) - -(deftest last.order.1 - (let ((i 0) x y) - (values - (last (progn (setf x (incf i)) (list 'a 'b 'c 'd)) - (setf y (incf i))) - i x y)) - (c d) 2 1 2) - -(deftest last.order.2 - (let ((i 0)) - (values (last (progn (incf i) (list 'a 'b 'c 'd))) i)) - (d) 1) - -(deftest last.error.1 - (signals-error (last (list 'a 'b 'c) -1) type-error) - t) - -(deftest last.error.2 - (signals-error (last (list 'a 'b 'c) 'a) type-error) - t) - -(deftest last.error.3 - (signals-error (last (list 'a 'b 'c) 10.0) type-error) - t) - -(deftest last.error.4 - (signals-error (last (list 'a 'b 'c) -10.0) type-error) - t) - -(deftest last.error.5 - (signals-error (last (list 'a 'b 'c) #\w) type-error) - t) - -(deftest last.error.6 - (signals-error (last) program-error) - t) - -(deftest last.error.7 - (signals-error (last '(a b c) 2 nil) program-error) - t) - -(deftest last.error.8 - (signals-error (locally (last (list 'a 'b 'c) 'a) t) - type-error) - t) - diff --git a/t/ansi-test/cons/ldiff.lsp b/t/ansi-test/cons/ldiff.lsp deleted file mode 100644 index f9ceace..0000000 --- a/t/ansi-test/cons/ldiff.lsp +++ /dev/null @@ -1,169 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 19 22:46:56 2003 -;;;; Contains: Tests of LDIFF - - - - - -(deftest ldiff.1 - (let* ((x (copy-tree '(a b c d e f))) - (xcopy (make-scaffold-copy x))) - (let ((result (ldiff x (cdddr x)))) - (and (check-scaffold-copy x xcopy) - result))) - (a b c)) - -(deftest ldiff.2 - (let* ((x (copy-tree '(a b c d e f))) - (xcopy (make-scaffold-copy x))) - (let ((result (ldiff x 'a))) - (and - (check-scaffold-copy x xcopy) - (zerop - (loop - for a on x and b on result count - (eqt a b))) - result))) - (a b c d e f)) - -;; Works when the end of the dotted list is a symbol -(deftest ldiff.3 - (let* ((x (copy-tree '(a b c d e . f))) - (xcopy (make-scaffold-copy x))) - (let ((result (ldiff x 'a))) - (and - (check-scaffold-copy x xcopy) - result))) - (a b c d e . f)) - -;; Works when the end of the dotted list is a fixnum -(deftest ldiff.4 - (let* ((n 18) - (x (list* 'a 'b 'c 18)) - (xcopy (make-scaffold-copy x))) - (let ((result (ldiff x n))) - (and - (check-scaffold-copy x xcopy) - result))) - (a b c)) - -;; Works when the end of the dotted list is a larger -;; integer (that is eql, but probably not eq). -(deftest ldiff.5 - (let* ((n 18000000000000) - (x (list* 'a 'b 'c (1- 18000000000001))) - (xcopy (make-scaffold-copy x))) - (let ((result (ldiff x n))) - (and - (check-scaffold-copy x xcopy) - result))) - (a b c)) - -;; Test works when the end of a dotted list is a string -(deftest ldiff.6 - (let* ((n (copy-seq "abcde")) - (x (list* 'a 'b 'c n)) - (xcopy (make-scaffold-copy x))) - (let ((result (ldiff x n))) - (if (equal result (list 'a 'b 'c)) - (check-scaffold-copy x xcopy) - result))) - t) - -;; Check that having the cdr of a dotted list be string-equal, but -;; not eql, does not result in success -(deftest ldiff.7 - (let* ((n (copy-seq "abcde")) - (x (list* 'a 'b 'c n)) - (xcopy (make-scaffold-copy x))) - (let ((result (ldiff x (copy-seq n)))) - (if (equal result x) - (check-scaffold-copy x xcopy) - result))) - t) - -;; Check that on failure, the list returned by ldiff is -;; a copy of the list, not the list itself. - -(deftest ldiff.8 - (let ((x (list 'a 'b 'c 'd))) - (let ((result (ldiff x '(e)))) - (and (equal x result) - (loop - for c1 on x - for c2 on result - count (eqt c1 c2))))) - 0) - -(deftest ldiff.order.1 - (let ((i 0) x y) - (values - (ldiff (progn (setf x (incf i)) - (list* 'a 'b 'c 'd)) - (progn (setf y (incf i)) - 'd)) - i x y)) - (a b c) 2 1 2) - -(def-fold-test ldiff.fold.1 (ldiff '(a b c) 'x)) -(def-fold-test ldiff.fold.2 (let ((x '(a b c))) (ldiff x (cddr x)))) - -;; Error checking - -(deftest ldiff.error.1 - (signals-type-error x 10 (ldiff x 'a)) - t) - -;; Single atoms are not dotted lists, so the next -;; case should be a type-error -(deftest ldiff.error.2 - (signals-type-error x 'a (ldiff x 'a)) - t) - -(deftest ldiff.error.3 - (signals-type-error x (make-array '(10) :initial-element 'a) (ldiff x '(a))) - t) - -(deftest ldiff.error.4 - (signals-type-error x 1.23 (ldiff x t)) - t) - -(deftest ldiff.error.5 - (signals-type-error x #\w (ldiff x 'a)) - t) - -(deftest ldiff.error.6 - (signals-error (ldiff) program-error) - t) - -(deftest ldiff.error.7 - (signals-error (ldiff nil) program-error) - t) - -(deftest ldiff.error.8 - (signals-error (ldiff nil nil nil) program-error) - t) - -;; Note! The spec is ambiguous on whether this next test -;; is correct. The spec says that ldiff should be prepared -;; to signal an error if the list argument is not a proper -;; list or dotted list. If listp is false, the list argument -;; is neither (atoms are not dotted lists). -;; -;; However, the sample implementation *does* work even if -;; the list argument is an atom. -;; -#| -(defun ldiff-12-body () - (loop - for x in *universe* - count (and (not (listp x)) - (not (eqt 'type-error - (catch-type-error (ldiff x x))))))) - -(deftest ldiff-12 - (ldiff-12-body) - 0) -|# diff --git a/t/ansi-test/cons/list-length.lsp b/t/ansi-test/cons/list-length.lsp deleted file mode 100644 index 80b5e50..0000000 --- a/t/ansi-test/cons/list-length.lsp +++ /dev/null @@ -1,71 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 19 22:03:01 2003 -;;;; Contains: Tests of LIST-LENGTH - - - - - -(deftest list-length-nil - (list-length nil) - 0) - -(deftest list-length-list - (list-length '(a b c d e f)) - 6) - -;; check that list-length returns nil -;; on a circular list - -(deftest list-length-circular-list - (let ((x (cons nil nil))) - (let ((y (list* 1 2 3 4 5 6 7 8 9 x))) - (setf (cdr x) y) - (let ((z (list* 'a 'b 'c 'd 'e y))) - (list-length z)))) - nil) - -(deftest list-length.order.1 - (let ((i 0)) - (values (list-length (progn (incf i) '(a b c))) i)) - 3 1) - - -(deftest list-length.4 - (list-length (copy-tree '(a b c))) - 3) - -;; Check that list-length produces a type-error -;; on arguments that are not proper lists or circular lists - -(deftest list-length.error.1 - (loop - for x in (list 'a 1 1.0 #\w (make-array '(10)) - '(a b . c) (symbol-package 'cons)) - count (not (eval `(signals-type-error x ',x (list-length x))))) - 0) - -(deftest list-length.error.2 - (signals-error (list-length) program-error) - t) - -(deftest list-length.error.3 - (signals-error (list-length nil nil) program-error) - t) - -(deftest list-length.error.4 - (signals-error (list-length 'a) type-error) - t) - -(deftest list-length.error.5 - (signals-error (locally (list-length 'a) t) type-error) - t) - -(deftest list-length-symbol - (signals-error (list-length 'a) type-error) - t) - -(deftest list-length-dotted-list - (signals-error (list-length (copy-tree '(a b c d . e))) type-error) - t) diff --git a/t/ansi-test/cons/list.lsp b/t/ansi-test/cons/list.lsp deleted file mode 100644 index d58a2df..0000000 --- a/t/ansi-test/cons/list.lsp +++ /dev/null @@ -1,74 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 19 21:56:04 2003 -;;;; Contains: Tests of LIST, LIST* - - - - - -(deftest list.1 - (list 'a 'b 'c) - (a b c)) - -(deftest list.2 - (list) - nil) - -(deftest list.order.1 - (let ((i 0)) - (list (incf i) (incf i) (incf i) (incf i))) - (1 2 3 4)) - -(deftest list.order.2 - (let ((i 0)) - (list (incf i) (incf i) (incf i) (incf i) - (incf i) (incf i) (incf i) (incf i))) - (1 2 3 4 5 6 7 8)) - -(deftest list.order.3 - (let ((i 0)) - (list (incf i) (incf i) (incf i) (incf i) - (incf i) (incf i) (incf i) (incf i) - (incf i) (incf i) (incf i) (incf i) - (incf i) (incf i) (incf i) (incf i))) - (1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16)) - -(def-fold-test list.fold.1 (list 'a)) -(def-fold-test list.fold.2 (list 'a 'b)) -(def-fold-test list.fold.3 (list 'a 'b 'c 'd 'e 'f)) - -;;; LIST* tests - -(deftest list*.1 - (list* 1 2 3) - (1 2 . 3)) - -(deftest list*.2 - (list* 'a) - a) - -(deftest list-list*.1 - (list* 'a 'b 'c (list 'd 'e 'f)) - (a b c d e f)) - -(deftest list*.3 - (list* 1) - 1) - -(deftest list*.order.1 - (let ((i 0)) - (list* (incf i) (incf i) (incf i) (incf i))) - (1 2 3 . 4)) - -(deftest list*.order.2 - (let ((i 0)) - (list* (incf i) (incf i) (incf i) (incf i) - (incf i) (incf i) (incf i) (incf i) - (incf i) (incf i) (incf i) (incf i) - (incf i) (incf i) (incf i) (incf i))) - (1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 . 16)) - -(def-fold-test list*.fold.1 (list* 'a 'b)) -(def-fold-test list*.fold.2 (list* 'a 'b 'c)) -(def-fold-test list*.fold.3 (list* 'a 'b 'c 'd 'e 'f)) diff --git a/t/ansi-test/cons/listp.lsp b/t/ansi-test/cons/listp.lsp deleted file mode 100644 index e755d5d..0000000 --- a/t/ansi-test/cons/listp.lsp +++ /dev/null @@ -1,49 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 19 22:03:37 2003 -;;;; Contains: Tests of LISTP - - - - - -(deftest listp-nil - (notnot-mv (listp nil)) - t) - -(deftest listp-symbol - (listp 'a) - nil) - -(deftest listp-singleton-list - (notnot-mv (listp '(a))) - t) - -(deftest listp-circular-list - (let ((x (cons nil nil))) - (setf (cdr x) x) - (notnot-mv (listp x))) - t) - -(deftest listp-longer-list - (notnot-mv (listp '(a b c d e f g h))) - t) - -;;; Check that (listp x) == (typep x 'list) - -(deftest listp-universe - (check-type-predicate 'listp 'list) - nil) - -(deftest listp.order.1 - (let ((i 0)) - (values (listp (incf i)) i)) - nil 1) - -(deftest listp.error.1 - (signals-error (listp) program-error) - t) - -(deftest listp.error.2 - (signals-error (listp nil nil) program-error) - t) diff --git a/t/ansi-test/cons/load.lsp b/t/ansi-test/cons/load.lsp deleted file mode 100644 index b3b496b..0000000 --- a/t/ansi-test/cons/load.lsp +++ /dev/null @@ -1,85 +0,0 @@ -;;; Tests of conses -(compile-and-load "ANSI-TESTS:AUX;cons-aux.lsp") - -(in-package #:cl-test) - -(let ((*default-pathname-defaults* - (make-pathname - :directory (pathname-directory *load-pathname*)))) - (load "cons.lsp") - (load "consp.lsp") - (load "atom.lsp") - (load "cxr.lsp") - (load "rplaca.lsp") - (load "rplacd.lsp") - (load "copy-tree.lsp") - (load "sublis.lsp") - (load "nsublis.lsp") - (load "subst.lsp") - (load "subst-if.lsp") - (load "subst-if-not.lsp") - (load "nsubst.lsp") - (load "nsubst-if.lsp") - (load "nsubst-if-not.lsp") - (load "tree-equal.lsp") - (load "copy-list.lsp") - (load "list.lsp") - (load "list-length.lsp") - (load "listp.lsp") - (load "make-list.lsp") - (load "push.lsp") - (load "pop.lsp") - (load "pushnew.lsp") - (load "adjoin.lsp") - (load "nth.lsp") - (load "endp.lsp") - (load "nconc.lsp") - (load "append.lsp") - (load "revappend.lsp") - (load "nreconc.lsp") - (load "butlast.lsp") - (load "nbutlast.lsp") - (load "last.lsp") - (load "ldiff.lsp") - (load "tailp.lsp") - (load "nthcdr.lsp") - (load "rest.lsp") - (load "member.lsp") - (load "member-if.lsp") - (load "member-if-not.lsp") - - (load "mapc.lsp") - (load "mapcar.lsp") - (load "mapcan.lsp") - (load "mapl.lsp") - (load "maplist.lsp") - (load "mapcon.lsp") - - (load "acons.lsp") - (load "assoc.lsp") - (load "assoc-if.lsp") - (load "assoc-if-not.lsp") - (load "rassoc.lsp") - (load "rassoc-if.lsp") - (load "rassoc-if-not.lsp") - (load "copy-alist.lsp") - (load "pairlis.lsp") - - (load "get-properties.lsp") - (load "getf.lsp") - (load "remf.lsp") - - (load "intersection.lsp") - (load "nintersection.lsp") - (load "union.lsp") - (load "nunion.lsp") - (load "set-difference.lsp") - (load "nset-difference.lsp") - (load "set-exclusive-or.lsp") - (load "nset-exclusive-or.lsp") - (load "subsetp.lsp") - -;;; Misc. stuff that should be moved elsewhere - (load "cons-test-01.lsp") - (load "cons-test-03.lsp") - (load "cons-test-05.lsp")) diff --git a/t/ansi-test/cons/make-list.lsp b/t/ansi-test/cons/make-list.lsp deleted file mode 100644 index 4812ac6..0000000 --- a/t/ansi-test/cons/make-list.lsp +++ /dev/null @@ -1,104 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 19 22:04:27 2003 -;;;; Contains: Tests of MAKE-LIST - - - - - -(deftest make-list-empty.1 - (make-list 0) - nil) - -(deftest make-list-empty.2 - (make-list 0 :initial-element 'a) - nil) - -(deftest make-list-no-initial-element - (make-list 6) - (nil nil nil nil nil nil)) - -(deftest make-list-with-initial-element - (make-list 6 :initial-element 'a) - (a a a a a a)) - -(deftest make-list.allow-other-keys.1 - (make-list 5 :allow-other-keys t :foo 'a) - (nil nil nil nil nil)) - -(deftest make-list.allow-other-keys.2 - (make-list 5 :bar nil :allow-other-keys t) - (nil nil nil nil nil)) - -(deftest make-list.allow-other-keys.3 - (make-list 5 :allow-other-keys nil) - (nil nil nil nil nil)) - -(deftest make-list.allow-other-keys.4 - (make-list 5 :allow-other-keys t :allow-other-keys nil 'bad t) - (nil nil nil nil nil)) - -(deftest make-list.allow-other-keys.5 - (make-list 5 :allow-other-keys t) - (nil nil nil nil nil)) - -(deftest make-list-repeated-keyword - (make-list 5 :initial-element 'a :initial-element 'b) - (a a a a a)) - -(deftest make-list.order.1 - (let ((i 0) x y) - (values - (make-list (progn (setf x (incf i)) 5) - :initial-element - (progn (setf y (incf i)) 'a)) - i x y)) - (a a a a a) - 2 1 2) - -(deftest make-list.order.2 - (let ((i 0) x y z) - (values - (make-list (progn (setf x (incf i)) 5) - :initial-element - (progn (setf y (incf i)) 'a) - :initial-element - (progn (setf z (incf i)) 'b)) - i x y z)) - (a a a a a) - 3 1 2 3) - -(def-fold-test make-list.fold.1 (make-list 1)) -(def-fold-test make-list.fold.2 (make-list 10 :initial-element 'x)) - -;;; Error tests - -(deftest make-list.error.1 - (check-type-error #'make-list (typef 'unsigned-byte)) - nil) - -(deftest make-list.error.3 - (signals-error (make-list) program-error) - t) - -(deftest make-list.error.4 - (signals-error (make-list 5 :bad t) program-error) - t) - -(deftest make-list.error.5 - (signals-error (make-list 5 :initial-element) program-error) - t) - -(deftest make-list.error.6 - (signals-error (make-list 5 1 2) program-error) - t) - -(deftest make-list.error.7 - (signals-error (make-list 5 :bad t :allow-other-keys nil) - program-error) - t) - -(deftest make-list.error.8 - (signals-error (locally (make-list 'a) t) type-error) - t) diff --git a/t/ansi-test/cons/mapc.lsp b/t/ansi-test/cons/mapc.lsp deleted file mode 100644 index 262be66..0000000 --- a/t/ansi-test/cons/mapc.lsp +++ /dev/null @@ -1,103 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Apr 20 07:21:24 2003 -;;;; Contains: Tests of MAPC - - - - - -(deftest mapc.1 - (mapc #'list nil) - nil) - -(deftest mapc.2 - (let ((x 0)) - (let ((result - (mapc #'(lambda (y) (incf x y)) - '(1 2 3 4)))) - (list result x))) - ((1 2 3 4) 10)) - -(deftest mapc.3 - (let ((x 0)) - (list - (mapc #'(lambda (y z) (declare (ignore y z)) (incf x)) - (make-list 5 :initial-element 'a) - (make-list 5 )) - x)) - ((a a a a a) 5)) - -(deftest mapc.4 - (let ((x 0)) - (list - (mapc #'(lambda (y z) (declare (ignore y z)) (incf x)) - (make-list 5 :initial-element 'a) - (make-list 10)) - x)) - ((a a a a a) 5)) - -(deftest mapc.5 - (let ((x 0)) - (list - (mapc #'(lambda (y z) (declare (ignore y z)) (incf x)) - (make-list 5 :initial-element 'a) - (make-list 3)) - x)) - ((a a a a a) 3)) - -(deftest mapc.6 - (let* ((x (copy-list '(a b c d e f g h))) - (xcopy (make-scaffold-copy x))) - (setf *mapc.6-var* nil) - (let ((result (mapc 'mapc.6-fun x))) - (and (check-scaffold-copy x xcopy) - (eqt result x) - *mapc.6-var*))) - (h g f e d c b a)) - -(deftest mapc.order.1 - (let ((i 0) x y z) - (values - (mapc (progn (setf x (incf i)) - #'list) - (progn (setf y (incf i)) - '(a b c)) - (progn (setf z (incf i)) - '(1 2 3))) - i x y z)) - (a b c) 3 1 2 3) - -;;; Error tests - -(deftest mapc.error.1 - (check-type-error #'(lambda (x) (mapc #'identity x)) #'listp) - nil) - -(deftest mapc.error.2 - (signals-error (mapc) program-error) - t) - -(deftest mapc.error.3 - (signals-error (mapc #'append) program-error) - t) - -(deftest mapc.error.4 - (signals-error (locally (mapc #'identity 1) t) type-error) - t) - -(deftest mapc.error.5 - (signals-error (mapc #'cons '(a b c)) program-error) - t) - -(deftest mapc.error.6 - (signals-error (mapc #'cons '(a b c) '(1 2 3) '(4 5 6)) program-error) - t) - -(deftest mapc.error.7 - (signals-error (mapc #'car '(a b c)) type-error) - t) - -(deftest mapc.error.8 - (signals-error (mapc #'identity (list* 1 2 3 4)) type-error) - t) diff --git a/t/ansi-test/cons/mapcan.lsp b/t/ansi-test/cons/mapcan.lsp deleted file mode 100644 index c321748..0000000 --- a/t/ansi-test/cons/mapcan.lsp +++ /dev/null @@ -1,122 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Apr 20 07:22:46 2003 -;;;; Contains: Tests of MAPCAN - - - - - -(deftest mapcan.1 - (mapcan #'list nil) - nil) - -(deftest mapcan.2 - (mapcan #'list (copy-list '(a b c d e f))) - (a b c d e f)) - -(deftest mapcan.3 - (let* ((x (list 'a 'b 'c 'd)) - (xcopy (make-scaffold-copy x)) - (result (mapcan #'list x))) - (and - (= (length x) (length result)) - (check-scaffold-copy x xcopy) - (loop - for e1 on x - and e2 on result - count (or (eqt e1 e2) (not (eql (car e1) (car e2))))))) - 0) - -(deftest mapcan.4 - (mapcan #'list - (copy-list '(1 2 3 4)) - (copy-list '(a b c d))) - (1 a 2 b 3 c 4 d)) - -(deftest mapcan.5 - (mapcan #'(lambda (x y) (make-list y :initial-element x)) - (copy-list '(a b c d)) - (copy-list '(1 2 3 4))) - (a b b c c c d d d d)) - -(defvar *mapcan.6-var* nil) -(defun mapcan.6-fun (x) - (push x *mapcan.6-var*) - (copy-list *mapcan.6-var*)) - -(deftest mapcan.6 - (progn - (setf *mapcan.6-var* nil) - (mapcan 'mapcan.6-fun (copy-list '(a b c d)))) - (a b a c b a d c b a)) - -(deftest mapcan.order.1 - (let ((i 0) x y z) - (values - (mapcan (progn (setf x (incf i)) - #'list) - (progn (setf y (incf i)) - '(a b c)) - (progn (setf z (incf i)) - '(1 2 3))) - i x y z)) - (a 1 b 2 c 3) - 3 1 2 3) - -(deftest mapcan.8 - (mapcan #'(lambda (x y) (make-list y :initial-element x)) - (copy-list '(a b c d)) - (copy-list '(1 2 3 4 5 6))) - (a b b c c c d d d d)) - -(deftest mapcan.9 - (mapcan #'(lambda (x y) (make-list y :initial-element x)) - (copy-list '(a b c d e f)) - (copy-list '(1 2 3 4))) - (a b b c c c d d d d)) - -(deftest mapcan.10 - (mapcan #'list - (copy-list '(a b c d)) - (copy-list '(1 2 3 4)) - nil) - nil) - -(deftest mapcan.11 - (mapcan (constantly 1) (list 'a)) - 1) - -(deftest mapcan.error.1 - (check-type-error #'(lambda (x) (mapcan #'identity x)) #'listp) - nil) - -(deftest mapcan.error.2 - (signals-error (mapcan) program-error) - t) - -(deftest mapcan.error.3 - (signals-error (mapcan #'append) program-error) - t) - -(deftest mapcan.error.4 - (signals-error (locally (mapcan #'identity 1) t) type-error) - t) - -(deftest mapcan.error.5 - (signals-error (mapcan #'car '(a b c)) type-error) - t) - -(deftest mapcan.error.6 - (signals-error (mapcan #'cons '(a b c)) program-error) - t) - -(deftest mapcan.error.7 - (signals-error (mapcan #'cons '(a b c) '(1 2 3) '(4 5 6)) - program-error) - t) - -(deftest mapcan.error.8 - (signals-error (mapcan #'identity (list* (list 1) (list 2) 3)) - type-error) - t) diff --git a/t/ansi-test/cons/mapcar.lsp b/t/ansi-test/cons/mapcar.lsp deleted file mode 100644 index 14af638..0000000 --- a/t/ansi-test/cons/mapcar.lsp +++ /dev/null @@ -1,118 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Apr 20 07:22:16 2003 -;;;; Contains: Tests of MAPCAR - - - - - -(deftest mapcar.1 - (mapcar #'1+ nil) - nil) - -(deftest mapcar.2 - (let* ((x (copy-list '(1 2 3 4))) - (xcopy (make-scaffold-copy x))) - (let ((result (mapcar #'1+ x))) - (and (check-scaffold-copy x xcopy) - result))) - (2 3 4 5)) - -(deftest mapcar.3 - (let* ((n 0) - (x (copy-list '(a b c d))) - (xcopy (make-scaffold-copy x))) - (let ((result - (mapcar #'(lambda (y) (declare (ignore y)) (incf n)) - x))) - (and (check-scaffold-copy x xcopy) - result))) - (1 2 3 4)) - -(deftest mapcar.4 - (let* ((n 0) - (x (copy-list '(a b c d))) - (xcopy (make-scaffold-copy x)) - (x2 (copy-list '(a b c d e f))) - (x2copy (make-scaffold-copy x2)) - (result - (mapcar #'(lambda (y z) (declare (ignore y z)) (incf n)) - x x2))) - (and (check-scaffold-copy x xcopy) - (check-scaffold-copy x2 x2copy) - (list result n))) - ((1 2 3 4) 4)) - -(deftest mapcar.5 - (let* ((n 0) - (x (copy-list '(a b c d))) - (xcopy (make-scaffold-copy x)) - (x2 (copy-list '(a b c d e f))) - (x2copy (make-scaffold-copy x2)) - (result - (mapcar #'(lambda (y z) (declare (ignore y z)) (incf n)) - x2 x))) - (and (check-scaffold-copy x xcopy) - (check-scaffold-copy x2 x2copy) - (list result n))) - ((1 2 3 4) 4)) - -(deftest mapcar.6 - (let* ((x (copy-list '(a b c d e f g h))) - (xcopy (make-scaffold-copy x))) - (setf *mapc.6-var* nil) - (let ((result (mapcar 'mapc.6-fun x))) - (and (check-scaffold-copy x xcopy) - (list *mapc.6-var* result)))) - ((h g f e d c b a) (a b c d e f g h))) - -(deftest mapcar.order.1 - (let ((i 0) x y z) - (values - (mapcar (progn (setf x (incf i)) - #'list) - (progn (setf y (incf i)) - '(a b c)) - (progn (setf z (incf i)) - '(1 2 3))) - i x y z)) - ((a 1) (b 2) (c 3)) - 3 1 2 3) - -(def-fold-test mapcar.fold.1 (mapcar 'identity '(a b c d))) -(def-fold-test mapcar.fold.2 (mapcar 'not '(t nil nil t t))) - -;;; Error tests - -(deftest mapcar.error.1 - (check-type-error #'(lambda (x) (mapcar #'identity x)) #'listp) - nil) - -(deftest mapcar.error.2 - (signals-error (mapcar) program-error) - t) - -(deftest mapcar.error.3 - (signals-error (mapcar #'append) program-error) - t) - -(deftest mapcar.error.4 - (signals-error (locally (mapcar #'identity 1) t) type-error) - t) - -(deftest mapcar.error.5 - (signals-error (mapcar #'car '(a b c)) type-error) - t) - -(deftest mapcar.error.6 - (signals-error (mapcar #'cons '(a b c)) program-error) - t) - -(deftest mapcar.error.7 - (signals-error (mapcar #'cons '(a b c) '(1 2 3) '(4 5 6)) program-error) - t) - -(deftest mapcar.error.8 - (signals-error (mapcar #'identity (list* 1 2 3 4)) type-error) - t) diff --git a/t/ansi-test/cons/mapcon.lsp b/t/ansi-test/cons/mapcon.lsp deleted file mode 100644 index 3001690..0000000 --- a/t/ansi-test/cons/mapcon.lsp +++ /dev/null @@ -1,86 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Apr 20 07:24:28 2003 -;;;; Contains: Tests of MAPCON - - - - - -(deftest mapcon.1 - (mapcon #'(lambda (x) (append '(a) x nil)) nil) - nil) - -(deftest mapcon.2 - (let* ((x (copy-list '(1 2 3 4))) - (xcopy (make-scaffold-copy x)) - (result - (mapcon #'(lambda (y) (append '(a) y nil)) x))) - (and - (check-scaffold-copy x xcopy) - result)) - (a 1 2 3 4 a 2 3 4 a 3 4 a 4)) - -(deftest mapcon.3 - (let* ((x (copy-list '(4 2 3 2 2))) - (y (copy-list '(a b c d e f g h i j k l))) - (xcopy (make-scaffold-copy x)) - (ycopy (make-scaffold-copy y)) - (result - (mapcon #'(lambda (xt yt) - (subseq yt 0 (car xt))) - x y))) - (and - (check-scaffold-copy x xcopy) - (check-scaffold-copy y ycopy) - result)) - (a b c d b c c d e d e e f)) - -(deftest mapcon.4 - (mapcon (constantly 1) (list 'a)) - 1) - -(deftest mapcon.order.1 - (let ((i 0) x y z) - (values - (mapcon (progn (setf x (incf i)) - #'(lambda (x y) (list (car x) (car y)))) - (progn (setf y (incf i)) - '(a b c)) - (progn (setf z (incf i)) - '(1 2 3))) - i x y z)) - (a 1 b 2 c 3) - 3 1 2 3) - -(deftest mapcon.error.1 - (check-type-error #'(lambda (x) (mapcon #'identity x)) #'listp) - nil) - -(deftest mapcon.error.2 - (signals-error (mapcon) program-error) - t) - -(deftest mapcon.error.3 - (signals-error (mapcon #'append) program-error) - t) - -(deftest mapcon.error.4 - (signals-error (locally (mapcon #'identity 1) t) type-error) - t) - -(deftest mapcon.error.5 - (signals-error (mapcon #'caar '(a b c)) type-error) - t) - -(deftest mapcon.error.6 - (signals-error (mapcon #'cons '(a b c)) program-error) - t) - -(deftest mapcon.error.7 - (signals-error (mapcon #'cons '(a b c) '(1 2 3) '(4 5 6)) program-error) - t) - -(deftest mapcon.error.8 - (signals-error (mapcon #'copy-tree (cons 1 2)) type-error) - t) diff --git a/t/ansi-test/cons/mapl.lsp b/t/ansi-test/cons/mapl.lsp deleted file mode 100644 index cb1f249..0000000 --- a/t/ansi-test/cons/mapl.lsp +++ /dev/null @@ -1,133 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Apr 20 07:23:23 2003 -;;;; Contains: Tests of MAPL - - - - - -(deftest mapl.1 - (mapl #'list nil) - nil) - -(deftest mapl.2 - (let* ((a nil) - (x (copy-list '(a b c))) - (xcopy (make-scaffold-copy x)) - (result - (mapl #'(lambda (y) (push y a)) - x))) - (and - (check-scaffold-copy x xcopy) - (eqt result x) - a)) - ((c) (b c) (a b c))) - -(deftest mapl.3 - (let* ((a nil) - (x (copy-list '(a b c d))) - (y (copy-list '(1 2 3 4))) - (xcopy (make-scaffold-copy x)) - (ycopy (make-scaffold-copy y)) - (result - (mapl #'(lambda (xtail ytail) - (setf a - (append (mapcar #'list xtail ytail) - a))) - x y))) - (and - (eqt result x) - (check-scaffold-copy x xcopy) - (check-scaffold-copy y ycopy) - a)) - ((d 4) (c 3) (d 4) (b 2) (c 3) (d 4) - (a 1) (b 2) (c 3) (d 4))) - -(deftest mapl.4 - (let* ((a nil) - (x (copy-list '(a b c d))) - (y (copy-list '(1 2 3 4 5 6 7 8))) - (xcopy (make-scaffold-copy x)) - (ycopy (make-scaffold-copy y)) - (result - (mapl #'(lambda (xtail ytail) - (setf a - (append (mapcar #'list xtail ytail) - a))) - x y))) - (and - (eqt result x) - (check-scaffold-copy x xcopy) - (check-scaffold-copy y ycopy) - a)) - ((d 4) (c 3) (d 4) (b 2) (c 3) (d 4) - (a 1) (b 2) (c 3) (d 4))) - -(deftest mapl.5 - (let* ((a nil) - (x (copy-list '(a b c d e f g))) - (y (copy-list '(1 2 3 4))) - (xcopy (make-scaffold-copy x)) - (ycopy (make-scaffold-copy y)) - (result - (mapl #'(lambda (xtail ytail) - (setf a - (append (mapcar #'list xtail ytail) - a))) - x y))) - (and - (eqt result x) - (check-scaffold-copy x xcopy) - (check-scaffold-copy y ycopy) - a)) - ((d 4) (c 3) (d 4) (b 2) (c 3) (d 4) - (a 1) (b 2) (c 3) (d 4))) - -(deftest mapl.order.1 - (let ((i 0) x y z) - (values - (mapl (progn - (setf x (incf i)) - (constantly nil)) - (progn - (setf y (incf i)) - '(a b c)) - (progn - (setf z (incf i)) - '(1 2 3))) - i x y z)) - (a b c) 3 1 2 3) - -(deftest mapl.error.1 - (check-type-error #'(lambda (x) (mapl #'identity x)) #'sequencep) - nil) - -(deftest mapl.error.2 - (signals-error (mapl) program-error) - t) - -(deftest mapl.error.3 - (signals-error (mapl #'append) program-error) - t) - -(deftest mapl.error.4 - (signals-error (locally (mapl #'identity 1) t) type-error) - t) - -(deftest mapl.error.5 - (signals-error (mapl #'cons '(a b c)) program-error) - t) - -(deftest mapl.error.6 - (signals-error (mapl #'cons '(a b c) '(1 2 3) '(4 5 6)) program-error) - t) - -(deftest mapl.error.7 - (signals-error (mapl #'caar '(a b c)) type-error) - t) - -(deftest mapl.error.8 - (signals-error (mapl #'identity (list* (list 1) (list 2) 3)) type-error) - t) - diff --git a/t/ansi-test/cons/maplist.lsp b/t/ansi-test/cons/maplist.lsp deleted file mode 100644 index 5a2d589..0000000 --- a/t/ansi-test/cons/maplist.lsp +++ /dev/null @@ -1,148 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Apr 20 07:24:00 2003 -;;;; Contains: Tests of MAPLIST - - - - - -(deftest maplist.1 - (maplist #'list nil) - nil) - -(deftest maplist.2 - (let* ((x (copy-list '(a b c))) - (xcopy (make-scaffold-copy x)) - (result (maplist #'identity x))) - (and (check-scaffold-copy x xcopy) - result)) - ((a b c) (b c) (c))) - -(deftest maplist.3 - (let* ((x (copy-list '(a b c d))) - (y (copy-list '(1 2 3 4))) - (xcopy (make-scaffold-copy x)) - (ycopy (make-scaffold-copy y)) - (result - (maplist #'append x y))) - (and - (check-scaffold-copy x xcopy) - (check-scaffold-copy y ycopy) - result)) - ((a b c d 1 2 3 4) - (b c d 2 3 4) - (c d 3 4) - (d 4))) - -(deftest maplist.4 - (let* ((x (copy-list '(a b c d))) - (y (copy-list '(1 2 3 4 5))) - (xcopy (make-scaffold-copy x)) - (ycopy (make-scaffold-copy y)) - (result - (maplist #'append x y))) - (and - (check-scaffold-copy x xcopy) - (check-scaffold-copy y ycopy) - result)) - ((a b c d 1 2 3 4 5) - (b c d 2 3 4 5) - (c d 3 4 5) - (d 4 5))) - -(deftest maplist.5 - (let* ((x (copy-list '(a b c d e))) - (y (copy-list '(1 2 3 4))) - (xcopy (make-scaffold-copy x)) - (ycopy (make-scaffold-copy y)) - (result - (maplist #'append x y))) - (and - (check-scaffold-copy x xcopy) - (check-scaffold-copy y ycopy) - result)) - ((a b c d e 1 2 3 4) - (b c d e 2 3 4) - (c d e 3 4) - (d e 4))) - -(deftest maplist.6 - (maplist 'append '(a b c) '(1 2 3)) - ((a b c 1 2 3) (b c 2 3) (c 3))) - -(deftest maplist.7 - (maplist #'(lambda (x y) (nth (car x) y)) - '(0 1 0 1 0 1 0) - '(a b c d e f g) - ) - (a c c e e g g)) - -(deftest maplist.order.1 - (let ((i 0) x y z) - (values - (maplist - (progn - (setf x (incf i)) - #'(lambda (x y) (declare (ignore x)) (car y))) - (progn - (setf y (incf i)) - '(a b c)) - (progn - (setf z (incf i)) - '(1 2 3))) - i x y z)) - (1 2 3) 3 1 2 3) - -(def-fold-test maplist.fold.1 (maplist 'car '(a b c d e))) -(def-fold-test maplist.fold.2 (maplist #'cadr '(a b c d e))) - -;;; Error tests - -(deftest maplist.error.1 - (check-type-error #'(lambda (x) (maplist #'identity x)) #'listp) - nil) - -(deftest maplist.error.2 - (signals-error (maplist #'identity 1) type-error) - t) - -(deftest maplist.error.3 - (signals-error (maplist #'identity 1.1323) type-error) - t) - -(deftest maplist.error.4 - (signals-error (maplist #'identity "abcde") type-error) - t) - -(deftest maplist.error.5 - (signals-error (maplist) program-error) - t) - -(deftest maplist.error.6 - (signals-error (maplist #'append) program-error) - t) - -(deftest maplist.error.7 - (signals-error (locally (maplist #'identity 'a) t) type-error) - t) - -(deftest maplist.error.8 - (signals-error (maplist #'caar '(a b c)) type-error) - t) - -(deftest maplist.error.9 - (signals-error (maplist #'cons '(a b c)) program-error) - t) - -(deftest maplist.error.10 - (signals-error (maplist #'cons '(a b c) '(1 2 3) '(4 5 6)) - program-error) - t) - -(deftest maplist.error.11 - (signals-error (maplist #'identity (list* (list 1) (list 2) 3)) - type-error) - t) - - diff --git a/t/ansi-test/cons/member-if-not.lsp b/t/ansi-test/cons/member-if-not.lsp deleted file mode 100644 index ee4e8ca..0000000 --- a/t/ansi-test/cons/member-if-not.lsp +++ /dev/null @@ -1,138 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Mar 28 07:39:29 1998 -;;;; Contains: Tests of MEMBER-IF-NOT - - - - - -(deftest member-if-not.1 - (member-if-not #'listp nil) - nil) - -(deftest member-if-not.2 - (member-if-not #'(lambda (x) (eqt x 'a)) '(a 1 2 a 3 4)) - (1 2 a 3 4)) - -(deftest member-if-not.3 - (member-if-not #'(lambda (x) (not (eql x 12))) '(4 12 11 73 11) :key #'1+) - (11 73 11)) - -(deftest member-if-not.4 - (let ((test-inputs - `(1 a 11.3121 11.31s3 1.123f5 -1 0 - 13.13122d34 581.131e-10 - ((a) (b) (c) . d) - ,(make-array '(10)) - "ancadas" #\w))) - (not (every - #'(lambda (x) - (let ((result (catch-type-error (member-if-not #'listp x)))) - (or (eqt result 'type-error) - (progn - (format t "~%On x = ~S, returns: ~%~S" x result) - nil)))) - test-inputs))) - nil) - -(deftest member-if-not.5 - (member-if-not #'not '(1 2 3 4 5) :key #'evenp) - (2 3 4 5)) - -;;; Order of evaluation tests - -(deftest member-if-not.order.1 - (let ((i 0) x y) - (values - (member-if-not (progn (setf x (incf i)) - #'not) - (progn (setf y (incf i)) - '(nil nil a b nil c d))) - i x y)) - (a b nil c d) 2 1 2) - -(deftest member-if-not.order.2 - (let ((i 0) x y z w) - (values - (member-if-not (progn (setf x (incf i)) - #'not) - (progn (setf y (incf i)) - '(nil nil a b nil c d)) - :key (progn (setf z (incf i)) #'identity) - :key (progn (setf w (incf i)) #'not)) - - i x y z w)) - (a b nil c d) 4 1 2 3 4) - -;;; Keyword tests - -(deftest member-if-not.keywords.1 - (member-if-not #'not '(1 2 3 4 5) :key #'evenp :key #'oddp) - (2 3 4 5)) - -(deftest member-if-not.allow-other-keys.2 - (member-if-not #'not '(nil 2 3 4 5) :allow-other-keys t :bad t) - (2 3 4 5)) - -(deftest member-if-not.allow-other-keys.3 - (member-if-not #'not '(nil 2 3 4 5) :bad t :allow-other-keys t) - (2 3 4 5)) - -(deftest member-if-not.allow-other-keys.4 - (member-if-not #'not '(nil 2 3 4 5) :allow-other-keys t) - (2 3 4 5)) - -(deftest member-if-not.allow-other-keys.5 - (member-if-not #'not '(nil 2 3 4 5) :allow-other-keys nil) - (2 3 4 5)) - -(deftest member-if-not.allow-other-keys.6 - (member-if-not #'not '(nil 2 3 4 5) :allow-other-keys t - :allow-other-keys nil :key #'identity :key #'null) - (2 3 4 5)) - -;;; Error tests - -(deftest member-if-not.error.1 - (check-type-error #'(lambda (x) (member-if-not #'identity x)) #'listp) - nil) - -(deftest member-if-not.error.2 - (signals-error (member-if-not) program-error) - t) - -(deftest member-if-not.error.3 - (signals-error (member-if-not #'null) program-error) - t) - -(deftest member-if-not.error.4 - (signals-error (member-if-not #'null '(a b c) :bad t) program-error) - t) - -(deftest member-if-not.error.5 - (signals-error (member-if-not #'null '(a b c) :bad t :allow-other-keys nil) - program-error) - t) - -(deftest member-if-not.error.6 - (signals-error (member-if-not #'null '(a b c) :key) program-error) - t) - -(deftest member-if-not.error.7 - (signals-error (member-if-not #'null '(a b c) 1 2) program-error) - t) - -(deftest member-if-not.error.8 - (signals-error (locally (member-if-not #'identity 'a) t) - type-error) - t) - -(deftest member-if-not.error.9 - (signals-error (member-if-not #'cons '(a b c)) program-error) - t) - -(deftest member-if-not.error.10 - (signals-error (member-if-not #'identity '(a b c) :key #'cons) - program-error) - t) diff --git a/t/ansi-test/cons/member-if.lsp b/t/ansi-test/cons/member-if.lsp deleted file mode 100644 index 2c21363..0000000 --- a/t/ansi-test/cons/member-if.lsp +++ /dev/null @@ -1,142 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 19 22:51:56 2003 -;;;; Contains: Tests of MEMBER-IF - - - - - -(deftest member-if.1 - (member-if #'listp nil) - nil) - -(deftest member-if.2 - (member-if #'(lambda (x) (eqt x 'a)) '(1 2 a 3 4)) - (a 3 4)) - -(deftest member-if.3 - (member-if #'(lambda (x) (eql x 12)) '(4 12 11 73 11) :key #'1+) - (11 73 11)) - -(deftest member-if.4 - (let ((test-inputs - `(1 a 11.3121 11.31s3 1.123f5 -1 0 - 13.13122d34 581.131e-10 - (a b c . d) - ,(make-array '(10)) - "ancadas" #\w))) - (notnot-mv - (every - #'(lambda (x) - (let ((result (catch-type-error (member-if #'listp x)))) - (or (eqt result 'type-error) - (progn - (format t "~%On ~S: returned ~%~S" x result) - nil)))) - test-inputs))) - t) - -(deftest member-if.5 - (member-if #'identity '(1 2 3 4 5) :key #'evenp) - (2 3 4 5)) - -;;; Order of argument tests - -(deftest member-if.order.1 - (let ((i 0) x y) - (values - (member-if (progn (setf x (incf i)) - #'identity) - (progn (setf y (incf i)) - '(nil nil a b nil c d))) - i x y)) - (a b nil c d) 2 1 2) - -(deftest member-if.order.2 - (let ((i 0) x y z w) - (values - (member-if (progn (setf x (incf i)) - #'identity) - (progn (setf y (incf i)) - '(nil nil a b nil c d)) - :key (progn (setf z (incf i)) #'identity) - :key (progn (setf w (incf i)) #'not)) - - i x y z w)) - (a b nil c d) 4 1 2 3 4) - -;;; Keyword tests - -(deftest member-if.keywords.1 - (member-if #'identity '(1 2 3 4 5) :key #'evenp :key #'oddp) - (2 3 4 5)) - -(deftest member-if.allow-other-keys.2 - (member-if #'identity '(nil 2 3 4 5) :allow-other-keys t :bad t) - (2 3 4 5)) - -(deftest member-if.allow-other-keys.3 - (member-if #'identity '(nil 2 3 4 5) :bad t :allow-other-keys t) - (2 3 4 5)) - -(deftest member-if.allow-other-keys.4 - (member-if #'identity '(nil 2 3 4 5) :allow-other-keys t) - (2 3 4 5)) - -(deftest member-if.allow-other-keys.5 - (member-if #'identity '(nil 2 3 4 5) :allow-other-keys nil) - (2 3 4 5)) - -(deftest member-if.allow-other-keys.6 - (member-if #'identity '(nil 2 3 4 5) :allow-other-keys t - :allow-other-keys nil) - (2 3 4 5)) - -(deftest member-if.allow-other-keys.7 - (member-if #'identity '(nil 2 3 4 5) :allow-other-keys t - :allow-other-keys nil :key #'identity :key #'null) - (2 3 4 5)) - -;;; Error cases - -(deftest member-if.error.1 - (check-type-error #'(lambda (x) (member-if #'identity x)) #'listp) - nil) - -(deftest member-if.error.2 - (signals-error (member-if) program-error) - t) - -(deftest member-if.error.3 - (signals-error (member-if #'null) program-error) - t) - -(deftest member-if.error.4 - (signals-error (member-if #'null '(a b c) :bad t) program-error) - t) - -(deftest member-if.error.5 - (signals-error (member-if #'null '(a b c) :bad t :allow-other-keys nil) - program-error) - t) - -(deftest member-if.error.6 - (signals-error (member-if #'null '(a b c) :key) program-error) - t) - -(deftest member-if.error.7 - (signals-error (member-if #'null '(a b c) 1 2) program-error) - t) - -(deftest member-if.error.8 - (signals-error (locally (member-if #'identity 'a) t) type-error) - t) - -(deftest member-if.error.9 - (signals-error (member-if #'cons '(a b c)) program-error) - t) - -(deftest member-if.error.10 - (signals-error (member-if #'identity '(a b c) :key #'cons) program-error) - t) diff --git a/t/ansi-test/cons/member.lsp b/t/ansi-test/cons/member.lsp deleted file mode 100644 index 7aaaa8c..0000000 --- a/t/ansi-test/cons/member.lsp +++ /dev/null @@ -1,304 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Mar 28 07:38:57 1998 -;;;; Contains: Tests of MEMBER - - - - - -(deftest member.1 - (let* ((x (copy-tree '(a b c d e f))) - (xcopy (make-scaffold-copy x)) - (result (member 'c x))) - (and - (eqt result (cddr x)) - (check-scaffold-copy x xcopy))) - t) - -(deftest member.2 - (let* ((x (copy-tree '(a b c d e f))) - (xcopy (make-scaffold-copy x)) - (result (member 'e x))) - (and - (eqt result (cddddr x)) - (check-scaffold-copy x xcopy))) - t) - -(deftest member.3 - (let* ((x (copy-tree '(1 2 3 4 5 6 7))) - (xcopy (make-scaffold-copy x)) - (result (member 4 x))) - (and - (eqt result (cdddr x)) - (check-scaffold-copy x xcopy))) - t) - -(deftest member.4 - (let* ((x (copy-tree '(2 4 6 8 10 12))) - (xcopy (make-scaffold-copy x)) - (result (member 9 x :key #'1+))) - (and - (eqt result (cdddr x)) - (check-scaffold-copy x xcopy))) - t) - -(deftest member.5 - (let* ((x (copy-tree '((a b) (c d) (e f) (g h)))) - (xcopy (make-scaffold-copy x)) - (result (member '(c d) x :test #'equal))) - (and - (eqt result (cdr x)) - (check-scaffold-copy x xcopy))) - t) - -(deftest member.6 - (let* ((x (copy-tree '((a b) (c d) (e f) (g h)))) - (xcopy (make-scaffold-copy x)) - (result (member 'c x :key #'car))) - (and - (eqt result (cdr x)) - (check-scaffold-copy x xcopy))) - t) - -(deftest member.7 - (let* ((x (copy-tree '((a b) (c d) (e f) (g h)))) - (xcopy (make-scaffold-copy x)) - (result (member 'c x :key #'car :test #'eq))) - (and - (eqt result (cdr x)) - (check-scaffold-copy x xcopy))) - t) - -(deftest member.8 - (let* ((x (copy-tree '((a b) (c d) (e f) (g h)))) - (xcopy (make-scaffold-copy x)) - (result (member 'c x :key #'car :test-not (complement #'eq)))) - (and - (eqt result (cdr x)) - (check-scaffold-copy x xcopy))) - t) - -(deftest member.9 - (let* ((x (copy-tree '((a b) (c d) (e f) (g h)))) - (xcopy (make-scaffold-copy x)) - (result (member 'c x :key #'car :test #'eql))) - (and - (eqt result (cdr x)) - (check-scaffold-copy x xcopy))) - t) - -(deftest member.10 - (let* ((x (copy-tree '((a b) (c d) (e f) (g h)))) - (xcopy (make-scaffold-copy x)) - (result (member (list 'd) x :key #'cdr :test #'equal))) - (and - (eqt result (cdr x)) - (check-scaffold-copy x xcopy))) - t) - -(deftest member.11 - (member (copy-seq "cc") (copy-tree '("aa" "bb" "cc" "dd" "ee"))) - nil) - -(deftest member.12 - (member 1 (copy-tree '(3 4 1 31 423))) - (1 31 423)) - -(deftest member.13 - (member (copy-seq "cc") (copy-tree '("aa" "bb" "cc" "dd" "ee")) - :test #'equal) - ("cc" "dd" "ee")) - -(deftest member.14 - (member 'a nil) - nil) - -(deftest member.15 - (member nil nil) - nil) - -(deftest member.16 - (member nil nil :test #'equal) - nil) - -(deftest member.16-a - (member nil nil :test #'(lambda (x y) (error "Should not call this function"))) - nil) - -(deftest member.17 - (member 'a nil :test #'(lambda (x y) (error "Should not call this function"))) - nil) - -;; Check that a null key argument is ignored - -(deftest member.18 - (member 'a '(c d a b e) :key nil) - (a b e)) - -(deftest member.19 - (member 'z '(a b c d) :key nil) - nil) - -(deftest member.20 - (member 10 '(1 2 3 4 10 11 14 18) :test #'<) - (11 14 18)) - -(deftest member.21 - (member 10 '(1 2 3 4 10 11 14 18) :test-not #'>=) - (11 14 18)) - -(defharmless member.test-and-test-not.1 - (member 'b '(a b c) :test #'eql :test-not #'eql)) - -(defharmless member.test-and-test-not.2 - (member 'b '(a b c) :test-not #'eql :test #'eql)) - -;;; Order of evaluation - -(deftest member.order.1 - (let ((i 0) x y) - (values - (member (progn (setf x (incf i)) 'c) - (progn (setf y (incf i)) '(a b c d))) - i x y)) - (c d) 2 1 2) - -(deftest member.order.2 - (let ((i 0) x y z p) - (values - (member (progn (setf x (incf i)) 'c) - (progn (setf y (incf i)) '(a b c d)) - :key (progn (setf z (incf i)) #'identity) - :test (progn (setf p (incf i)) #'eq)) - i x y z p)) - (c d) 4 1 2 3 4) - -(deftest member.order.3 - (let ((i 0) x y) - (values - (member (progn (setf x (incf i)) 'c) - (progn (setf y (incf i)) '(a b c d)) - :test #'eq) - i x y)) - (c d) 2 1 2) - -(deftest member.order.4 - (let ((i 0) x y z p q) - (values - (member (progn (setf x (incf i)) 'c) - (progn (setf y (incf i)) '(a b c d)) - :key (progn (setf z (incf i)) #'identity) - :test (progn (setf p (incf i)) #'eq) - :key (progn (setf q (incf i)) (constantly 'z))) - i x y z p q)) - (c d) 5 1 2 3 4 5) - -(deftest member.order.5 - (let ((i 0) x y z q) - (values - (member (progn (setf x (incf i)) 'c) - (progn (setf y (incf i)) '(a b c d)) - :test #'eq - :key (progn (setf z (incf i)) #'identity) - :key (progn (setf q (incf i)) (constantly 'z))) - i x y z q)) - (c d) 4 1 2 3 4) - - -;;; Keyword tests - -(deftest member.allow-other-keys.1 - (member 'b '(a b c) :bad t :allow-other-keys t) - (b c)) - -(deftest member.allow-other-keys.2 - (member 'b '(a b c) :allow-other-keys t :bad t) - (b c)) - -(deftest member.allow-other-keys.3 - (member 'b '(a b c) :allow-other-keys t) - (b c)) - -(deftest member.allow-other-keys.4 - (member 'b '(a b c) :allow-other-keys nil) - (b c)) - -(deftest member.allow-other-keys.5 - (member 'b '(a b c) :allow-other-keys 17 :allow-other-keys nil '#:x t) - (b c)) - -(deftest member.keywords.6 - (member 'b '(a b c) :test #'eq :test (complement #'eq)) - (b c)) - -;;; Error cases - -(deftest member.error.1 - (check-type-error #'(lambda (x) (member 'a x)) #'listp) - nil) - -(deftest member.error.2 - (signals-error (member 'a 1.3) type-error) - t) - -(deftest member.error.3 - (signals-error (member 'a 1) type-error) - t) - -(deftest member.error.4 - (signals-error (member 'a 0) type-error) - t) - -(deftest member.error.5 - (signals-error (member 'a "abcde") type-error) - t) - -(deftest member.error.6 - (signals-error (member 'a #\w) type-error) - t) - -(deftest member.error.7 - (signals-error (member 'a t) type-error) - t) - -(deftest member.error.8 - (signals-error (member) program-error) - t) - -(deftest member.error.9 - (signals-error (member nil) program-error) - t) - -(deftest member.error.10 - (signals-error (member nil nil :bad t) program-error) - t) - -(deftest member.error.11 - (signals-error (member nil nil :test) program-error) - t) - -(deftest member.error.12 - (signals-error (member nil nil :bad t :allow-other-keys nil) - program-error) - t) - -(deftest member.error.13 - (signals-error (member nil nil nil) program-error) - t) - -(deftest member.error.14 - (signals-error (locally (member 'a t) t) type-error) - t) - -(deftest member.error.15 - (signals-error (member 'a '(a b c) :test #'identity) program-error) - t) - -(deftest member.error.16 - (signals-error (member 'a '(a b c) :test-not #'identity) program-error) - t) - -(deftest member.error.17 - (signals-error (member 'a '(a b c) :key #'cons) program-error) - t) diff --git a/t/ansi-test/cons/nbutlast.lsp b/t/ansi-test/cons/nbutlast.lsp deleted file mode 100644 index ceaddb4..0000000 --- a/t/ansi-test/cons/nbutlast.lsp +++ /dev/null @@ -1,118 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 19 22:41:54 2003 -;;;; Contains: Tests of NBUTLAST - - - - - -(deftest nbutlast.1 - (let ((x (list 'a 'b 'c 'd 'e))) - (let ((y (cdr x)) - (z (cddr x))) - (let ((result (nbutlast x 2))) - (and (eqt x result) - (eqt (cdr x) y) - (eqt (cddr x) z) - result)))) - (a b c)) - -(deftest nbutlast.2 - (let ((x (list 'a 'b 'c 'd 'e))) - (let ((result (nbutlast x 5))) - (list x result))) - ((a b c d e) nil)) - -(deftest nbutlast.3 - (let ((x (list 'a 'b 'c 'd 'e))) - (let ((result (nbutlast x 500))) - (list x result))) - ((a b c d e) nil)) - -(deftest nbutlast.4 - (let ((x (list* 'a 'b 'c 'd))) - (let ((result (nbutlast x 1))) - (and (eqt result x) - result))) - (a b)) - -(deftest nbutlast.5 - (nbutlast nil) - nil) - -(deftest nbutlast.6 - (nbutlast (list 'a)) - nil) - -(deftest nbutlast.7 - (nbutlast (list 'a 'b 'c 'd) (1+ most-positive-fixnum)) - nil) - -(deftest nbutlast.8 - (nbutlast (list 'a 'b 'c 'd) most-positive-fixnum) - nil) - -(deftest nbutlast.9 - (nbutlast (list 'a 'b 'c 'd) (1- most-positive-fixnum)) - nil) - -(deftest nbutlast.order.1 - (let ((i 0) x y) - (values - (nbutlast (progn (setf x (incf i)) - (list 'a 'b 'c 'd 'e)) - (progn (setf y (incf i)) - 2)) - i x y)) - (a b c) 2 1 2) - -(deftest nbutlast.order.2 - (let ((i 0)) - (values - (nbutlast (progn (incf i) (list 'a 'b 'c 'd))) - i)) - (a b c) 1) - -;;; Error tests - -(deftest nbutlast.error.1 - (signals-error (let ((x (list* 'a 'b 'c 'd))) (nbutlast x 'a)) - type-error) - t) - -(deftest nbutlast.error.2 - (signals-error (nbutlast 'a 10) type-error) - t) - -(deftest nbutlast.error.3 - (signals-error (nbutlast 2 10) type-error) - t) - -(deftest nbutlast.error.4 - (signals-error (nbutlast #\w 10) type-error) - t) - -(deftest nbutlast.error.5 - (signals-error (nbutlast (list 'a 'b 'c 'd) -3) type-error) - t) - -(deftest nbutlast.error.6 - (signals-error (nbutlast (list 'a) 20.0) type-error) - t) - -(deftest nbutlast.error.7 - (signals-error (nbutlast (list 'a) -100.0) type-error) - t) - -(deftest nbutlast.error.8 - (signals-error (nbutlast) program-error) - t) - -(deftest nbutlast.error.9 - (signals-error (nbutlast (list 'a 'b 'c) 3 3) program-error) - t) - -(deftest nbutlast.error.10 - (signals-error (locally (nbutlast 'a 10) t) type-error) - t) diff --git a/t/ansi-test/cons/nconc.lsp b/t/ansi-test/cons/nconc.lsp deleted file mode 100644 index 187a26b..0000000 --- a/t/ansi-test/cons/nconc.lsp +++ /dev/null @@ -1,74 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 19 22:35:53 2003 -;;;; Contains: Tests of NCONC - - - - - -(deftest nconc.1 - (nconc) - nil) - -(deftest nconc.2 - (nconc (copy-tree '(a b c d e f))) - (a b c d e f)) - -;;; (deftest nconc.3 -;;; (nconc 1) -;;; 1) - -(deftest nconc.4 - (let ((x (list 'a 'b 'c)) - (y (list 'd 'e 'f))) - (let ((ycopy (make-scaffold-copy y))) - (let ((result (nconc x y))) - (and - (check-scaffold-copy y ycopy) - (eqt (cdddr x) y) - result)))) - (a b c d e f)) - -(deftest nconc.5 - (let ((x (list 'a 'b 'c))) - (nconc x x) - (and - (eqt (cdddr x) x) - (null (list-length x)))) - t) - -(deftest nconc.6 - (let ((x (list 'a 'b 'c)) - (y (list 'd 'e 'f 'g 'h)) - (z (list 'i 'j 'k))) - (let ((result (nconc x y z 'foo))) - (and - (eqt (nthcdr 3 x) y) - (eqt (nthcdr 5 y) z) - (eqt (nthcdr 3 z) 'foo) - result))) - (a b c d e f g h i j k . foo)) - -(deftest nconc.7 - (nconc (copy-tree '(a . b)) - (copy-tree '(c . d)) - (copy-tree '(e . f)) - 'foo) - (a c e . foo)) - -(deftest nconc.order.1 - (let ((i 0) x y z) - (values - (nconc (progn (setf x (incf i)) (copy-list '(a b c))) - (progn (setf y (incf i)) (copy-list '(d e f))) - (progn (setf z (incf i)) (copy-list '(g h i)))) - i x y z)) - (a b c d e f g h i) 3 1 2 3) - -(deftest nconc.order.2 - (let ((i 0)) - (values - (nconc (list 'a) (incf i)) - i)) - (a . 1) 1) diff --git a/t/ansi-test/cons/nintersection.lsp b/t/ansi-test/cons/nintersection.lsp deleted file mode 100644 index 6cc8d93..0000000 --- a/t/ansi-test/cons/nintersection.lsp +++ /dev/null @@ -1,376 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Apr 20 07:40:02 2003 -;;;; Contains: Tests of NINTERSECTION - - - - - -(deftest nintersection.1 - (nintersection nil nil) - nil) - -(deftest nintersection.2 - (nintersection (loop for i from 1 to 100 collect i) nil) - nil) - -(deftest nintersection.3 - (nintersection-with-check nil (loop for i from 1 to 100 collect i)) - nil) - -(deftest nintersection.4 - (let* ((x (copy-list '(a 1 c 7 b 4 3 z))) - (xc (copy-list x)) - (y (copy-list '(3 y c q z a 18))) - (result (nintersection-with-check xc y))) - (and - (not (eqt result 'failed)) - (+ - (loop for e in x count - (and (member e y) - (not (member e result)))) - (loop for e in result count - (or (not (member e x)) (not (member e y)))) - (loop for hd on result count - (and (consp hd) - (member (car hd) (cdr hd))))))) - 0) - -(deftest nintersection.5 - (let* ((x (copy-list '(a a a))) - (y (copy-list '(a a a b b b))) - (result (nintersection-with-check x y))) - (and - (not (eqt result 'failed)) - (member 'a result) - (not (member 'b result)))) - t) - -(deftest nintersection.6 - (nintersection-with-check - (list 1000000000000 'a 'b 'c) - (list (1+ 999999999999) 'd 'e 'f)) - (1000000000000)) - -(deftest nintersection.7 - (nintersection-with-check (list 'a 10 'b 17) - (list 'c 'd 4 'e 'f 10 1 13 'z)) - (10)) - -(deftest nintersection.8 - (nintersection-with-check - (list 'a (copy-seq "aaa") 'b) - (list 'd (copy-seq "aaa") 'e)) - nil) - -(deftest nintersection.9 - (nintersection-with-check - (list 'a (copy-seq "aaa") 'b) - (list 'd (copy-seq "aaa") 'e) - :test #'equal) - ("aaa")) - -(deftest nintersection.9-a - (nintersection-with-check - (list 'a (copy-seq "aaa") 'b) - (list 'd (copy-seq "aaa") 'e) - :test 'equal) - ("aaa")) - -(deftest nintersection.9-b - (nintersection - (list 'a (copy-seq "aaa") 'b) - (list 'd (copy-seq "aaa") 'e) - :test-not #'(lambda (p q) (not (equal p q)))) - ("aaa")) - -(deftest nintersection.10 - (equalt - (sort - (let ((result - (nintersection-with-check - (loop for i from 0 to 1000 by 3 collect i) - (loop for i from 0 to 1000 by 7 collect i)))) - (if (eqt result 'failed) () result)) - #'<) - (loop for i from 0 to 1000 by 21 collect i)) - t) - -(deftest nintersection.11 - (equalt - (sort - (let ((result - (nintersection-with-check - (loop for i from 0 to 999 by 5 collect i) - (loop for i from 0 to 999 by 7 collect i) - :test #'(lambda (a b) - (and (eql a b) - (= (mod a 3) 0)))))) - (if (eqt result 'failed) () result)) - #'<) - (loop - for i from 0 to 999 by (* 3 5 7) collect i)) - t) - -(deftest nintersection.12 - (nintersection-12-body 100 100) - nil) - -;; Key argument - -(deftest nintersection.13 - (let ((x '(0 5 8 13 31 42)) - (y (copy-list '(3 5 42 0 7 100 312 33)))) - (equalt - (sort (copy-list (nintersection - (copy-list x) y)) #'<) - (sort (copy-list (nintersection - (copy-list x) y :key #'1+)) #'<))) - t) - -;; Check that a nil key argument is ignored - -(deftest nintersection.14 - (let - ((result (nintersection - (copy-list '(a b c d)) - (copy-list '(e c f b g)) - :key nil))) - (and - (member 'b result) - (member 'c result) - (every #'(lambda (x) (member x '(b c))) result) - t)) - t) - -;; Test that nintersection preserves the order of arguments to :test, :test-not - -(deftest nintersection.15 - (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) - (block fail - (nintersection - list1 list2 - :test - #'(lambda (x y) - (when (< y x) (return-from fail 'fail)) - (eql x y))))) - (4)) - -(deftest nintersection.16 - (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) - (block fail - (nintersection - list1 list2 - :key #'identity - :test - #'(lambda (x y) - (when (< y x) (return-from fail 'fail)) - (eql x y))))) - (4)) - -(deftest nintersection.17 - (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) - (block fail - (nintersection - list1 list2 - :test-not - #'(lambda (x y) - (when (< y x) (return-from fail 'fail)) - (not (eql x y)))))) - (4)) - -(deftest nintersection.18 - (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) - (block fail - (nintersection - list1 list2 - :key #'identity - :test-not - #'(lambda (x y) - (when (< y x) (return-from fail 'fail)) - (not (eql x y)))))) - (4)) - -(defharmless nintersection.test-and-test-not.1 - (nintersection (list 'a 'b 'c) (list 'a 'c 'e) :test #'eql :test-not #'eql)) - -(defharmless nintersection.test-and-test-not.2 - (nintersection (list 'a 'b 'c) (list 'a 'c 'e) :test-not #'eql :test #'eql)) - -;;; Order of argument evaluation tests - -(deftest nintersection.order.1 - (let ((i 0) x y) - (values - (nintersection (progn (setf x (incf i)) (list 'a 'b)) - (progn (setf y (incf i)) (list 'c 'd))) - i x y)) - nil 2 1 2) - -(deftest nintersection.order.2 - (let ((i 0) x y) - (values - (nintersection (progn (setf x (incf i)) (list 'a 'b)) - (progn (setf y (incf i)) (list 'c 'd)) - :test #'eq) - i x y)) - nil 2 1 2) - -(deftest nintersection.order.3 - (let ((i 0) x y z w) - (values - (nintersection (progn (setf x (incf i)) (list 'a 'b)) - (progn (setf y (incf i)) (list 'c 'd)) - :test (progn (setf z (incf i)) #'eq) - :test (progn (setf w (incf i)) - (complement #'eq))) - i x y z w)) - nil 4 1 2 3 4) - -(deftest nintersection.order.4 - (let ((i 0) x y z w) - (values - (nintersection (progn (setf x (incf i)) (list 'a 'b)) - (progn (setf y (incf i)) (list 'c 'd)) - :test (progn (setf z (incf i)) #'eq) - :key (progn (setf w (incf i)) #'identity)) - i x y z w)) - nil 4 1 2 3 4) - -(deftest nintersection.order.5 - (let ((i 0) x y z w) - (values - (nintersection (progn (setf x (incf i)) (list 'a 'b)) - (progn (setf y (incf i)) (list 'c 'd)) - :key (progn (setf z (incf i)) #'identity) - :test (progn (setf w (incf i)) #'eq)) - i x y z w)) - nil 4 1 2 3 4) - -;;; Keyword tests - -(deftest nintersection.allow-other-keys.1 - (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) - (nintersection list1 list2 :bad t :allow-other-keys 1)) - (4)) - -(deftest nintersection.allow-other-keys.2 - (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) - (nintersection list1 list2 :allow-other-keys :foo :also-bad t)) - (4)) - -(deftest nintersection.allow-other-keys.3 - (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) - (nintersection list1 list2 :allow-other-keys :foo :also-bad t - :test #'(lambda (x y) (= x (1+ y))))) - nil) - -(deftest nintersection.allow-other-keys.4 - (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) - (nintersection list1 list2 :allow-other-keys t)) - (4)) - -(deftest nintersection.allow-other-keys.5 - (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) - (nintersection list1 list2 :allow-other-keys nil)) - (4)) - -(deftest nintersection.allow-other-keys.6 - (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) - (nintersection list1 list2 :allow-other-keys t - :allow-other-keys nil :bad t)) - (4)) - -(deftest nintersection.allow-other-keys.7 - (sort - (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) - (nintersection list1 list2 :allow-other-keys t - :allow-other-keys nil - :test #'(lambda (x y) (eql x (1- y))))) - #'<) - (3 4)) - -(deftest nintersection.keywords.8 - (sort - (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) - (nintersection list1 list2 - :test #'(lambda (x y) (eql x (1- y))) - :test #'eql)) - #'<) - (3 4)) - -(deftest nintersection.allow-other-keys.9 - (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) - (nintersection list1 list2 :allow-other-keys :foo :also-bad t - :test #'(lambda (x y) (= x (1+ y))))) - nil) - -(deftest nintersection.error.1 - (signals-error (nintersection) program-error) - t) - -(deftest nintersection.error.2 - (signals-error (nintersection nil) program-error) - t) - -(deftest nintersection.error.3 - (signals-error (nintersection nil nil :bad t) program-error) - t) - -(deftest nintersection.error.4 - (signals-error (nintersection nil nil :key) program-error) - t) - -(deftest nintersection.error.5 - (signals-error (nintersection nil nil 1 2) program-error) - t) - -(deftest nintersection.error.6 - (signals-error (nintersection nil nil :bad t :allow-other-keys nil) program-error) - t) - -(deftest nintersection.error.7 - (signals-error (nintersection (list 1 2 3) (list 4 5 6) :test #'identity) program-error) - t) - -(deftest nintersection.error.8 - (signals-error (nintersection (list 1 2 3) (list 4 5 6) :test-not #'identity) program-error) - t) - -(deftest nintersection.error.9 - (signals-error (nintersection (list 1 2 3) (list 4 5 6) :key #'cons) program-error) - t) - -(deftest nintersection.error.10 - (signals-error (nintersection (list 1 2 3) (list 4 5 6) :key #'car) type-error) - t) - -(deftest nintersection.error.11 - (signals-error (nintersection (list 1 2 3) (list* 4 5 6 7)) type-error) - t) - -(deftest nintersection.error.12 - (signals-error (nintersection (list* 1 2 3) (list 4 5 6)) type-error) - t) - -(deftest nintersection.error.13 - (check-type-error #'(lambda (x) (nintersection x (copy-seq '(a b c)))) #'listp) - nil) - -(deftest nintersection.error.14 - (check-type-error #'(lambda (x) (nintersection (copy-seq '(a b c)) x)) #'listp) - nil) diff --git a/t/ansi-test/cons/nreconc.lsp b/t/ansi-test/cons/nreconc.lsp deleted file mode 100644 index 2f99868..0000000 --- a/t/ansi-test/cons/nreconc.lsp +++ /dev/null @@ -1,44 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 19 22:38:12 2003 -;;;; Contains: Tests of NRECONC - - - - - -(deftest nreconc.1 - (let* ((x (list 'a 'b 'c)) - (y (copy-tree '(d e f))) - (result (nreconc x y))) - (and (equal y '(d e f)) - result)) - (c b a d e f)) - -(deftest nreconc.2 - (nreconc nil 'a) - a) - -(deftest nreconc.order.1 - (let ((i 0) x y) - (values - (nreconc (progn (setf x (incf i)) (copy-list '(a b c))) - (progn (setf y (incf i)) (copy-list '(d e f)))) - i x y)) - (c b a d e f) 2 1 2) - -(deftest nreconc.error.1 - (signals-error (nreconc) program-error) - t) - -(deftest nreconc.error.2 - (signals-error (nreconc nil) program-error) - t) - -(deftest nreconc.error.3 - (signals-error (nreconc nil nil nil) program-error) - t) - -(deftest nreconc.error.4 - (signals-error (nreconc (cons 'a 'b) (list 'z)) type-error) - t) diff --git a/t/ansi-test/cons/nset-difference.lsp b/t/ansi-test/cons/nset-difference.lsp deleted file mode 100644 index 0cabd80..0000000 --- a/t/ansi-test/cons/nset-difference.lsp +++ /dev/null @@ -1,328 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Apr 20 07:44:44 2003 -;;;; Contains: Tests of NSET-DIFFERENCE - - - - - -(deftest nset-difference.1 - (nset-difference nil nil) - nil) - -(deftest nset-difference.2 - (let ((result - (nset-difference-with-check '(a b c) nil))) - (check-nset-difference '(a b c) nil result)) - t) - -(deftest nset-difference.3 - (let ((result - (nset-difference-with-check '(a b c d e f) '(f b d)))) - (check-nset-difference '(a b c d e f) '(f b d) result)) - t) - -(deftest nset-difference.4 - (sort - (copy-list - (nset-difference-with-check (shuffle '(1 2 3 4 5 6 7 8)) - '(10 101 4 74 2 1391 7 17831))) - #'<) - (1 3 5 6 8)) - -(deftest nset-difference.5 - (nset-difference-with-check nil '(a b c d e f g h)) - nil) - -(deftest nset-difference.6 - (nset-difference-with-check '(a b c d e) '(d a b e) - :key nil) - (c)) - -(deftest nset-difference.7 - (nset-difference-with-check '(a b c d e) '(d a b e) :test #'eq) - (c)) - -(deftest nset-difference.8 - (nset-difference-with-check '(a b c d e) '(d a b e) :test #'eql) - (c)) - -(deftest nset-difference.9 - (nset-difference-with-check '(a b c d e) '(d a b e) :test #'equal) - (c)) - -(deftest nset-difference.10 - (nset-difference-with-check '(a b c d e) '(d a b e) - :test 'eq) - (c)) - -(deftest nset-difference.11 - (nset-difference-with-check '(a b c d e) '(d a b e) - :test 'eql) - (c)) - -(deftest nset-difference.12 - (nset-difference-with-check '(a b c d e) '(d a b e) - :test 'equal) - (c)) - -(deftest nset-difference.13 - (do-random-nset-differences 100 100) - nil) - -(deftest nset-difference.14 - (nset-difference-with-check '((a . 1) (b . 2) (c . 3)) - '((a . 1) (c . 3)) - :key 'car) - ((b . 2))) - -(deftest nset-difference.15 - (nset-difference-with-check '((a . 1) (b . 2) (c . 3)) - '((a . 1) (c . 3)) - :key #'car) - ((b . 2))) - -;; -;; Verify that the :test argument is called with the arguments -;; in the correct order -;; -(deftest nset-difference.16 - (block fail - (sort - (copy-list - (nset-difference-with-check - '(1 2 3 4) '(e f g h) - :test #'(lambda (x y) - (when (or (member x '(e f g h)) - (member y '(1 2 3 4))) - (return-from fail 'fail)) - (eqt x y)))) - #'<)) - (1 2 3 4)) - -(deftest nset-difference.17 - (block fail - (sort - (copy-list - (nset-difference-with-check - '(1 2 3 4) '(e f g h) - :key #'identity - :test #'(lambda (x y) - (when (or (member x '(e f g h)) - (member y '(1 2 3 4))) - (return-from fail 'fail)) - (eqt x y)))) - #'<)) - (1 2 3 4)) - -(deftest nset-difference.18 - (block fail - (sort - (copy-list - (nset-difference-with-check - '(1 2 3 4) '(e f g h) - :test-not - #'(lambda (x y) - (when (or (member x '(e f g h)) - (member y '(1 2 3 4))) - (return-from fail 'fail)) - (not (eqt x y))))) - #'<)) - (1 2 3 4)) - -(deftest nset-difference.19 - (block fail - (sort (copy-list - (nset-difference-with-check - '(1 2 3 4) '(e f g h) - :test-not - #'(lambda (x y) - (when (or (member x '(e f g h)) - (member y '(1 2 3 4))) - (return-from fail 'fail)) - (not (eqt x y))))) - #'<)) - (1 2 3 4)) - -(defharmless nset-difference.test-and-test-not.1 - (nset-difference (list 1 2 3 4) (list 1 7 3 8) :test #'eql :test-not #'eql)) - -(defharmless nset-difference.test-and-test-not.2 - (nset-difference (list 1 2 3 4) (list 1 7 3 8) :test-not #'eql :test #'eql)) - -;;; Order of argument evaluation tests - -(deftest nset-difference.order.1 - (let ((i 0) x y) - (values - (nset-difference (progn (setf x (incf i)) (list 1 2 3 4)) - (progn (setf y (incf i)) (list 2 3 4))) - i x y)) - (1) 2 1 2) - -(deftest nset-difference.order.2 - (let ((i 0) x y z) - (values - (nset-difference (progn (setf x (incf i)) (list 1 2 3 4)) - (progn (setf y (incf i)) (list 2 3 4)) - :test (progn (setf z (incf i)) - #'(lambda (x y) (= x (1- y))))) - i x y z)) - (4) 3 1 2 3) - -(deftest nset-difference.order.3 - (let ((i 0) x y z w) - (values - (nset-difference (progn (setf x (incf i)) (list 1 2 3 4)) - (progn (setf y (incf i)) (list 2 3 4)) - :test (progn (setf z (incf i)) - #'(lambda (x y) (= x (1- y)))) - :key (progn (setf w (incf i)) nil)) - i x y z w)) - (4) 4 1 2 3 4) - - -;;; Keyword tests - -(deftest nset-difference.allow-other-keys.1 - (sort - (copy-list - (nset-difference - (list 1 2 3 4 5) (list 2 3 4) - :bad t :allow-other-keys t)) - #'<) - (1 5)) - -(deftest nset-difference.allow-other-keys.2 - (sort - (copy-list - (nset-difference - (list 1 2 3 4 5) (list 2 3 4) - :allow-other-keys t :bad t)) - #'<) - (1 5)) - -(deftest nset-difference.allow-other-keys.3 - (sort - (copy-list - (nset-difference - (list 1 2 3 4 5) (list 2 3 4) - :allow-other-keys t :bad t :test #'(lambda (x y) (= x (1- y))))) - #'<) - (4 5)) - -(deftest nset-difference.allow-other-keys.4 - (sort - (copy-list - (nset-difference - (list 1 2 3 4 5) (list 2 3 4) - :allow-other-keys t)) - #'<) - (1 5)) - -(deftest nset-difference.allow-other-keys.5 - (sort - (copy-list - (nset-difference - (list 1 2 3 4 5) (list 2 3 4) - :allow-other-keys nil)) - #'<) - (1 5)) - -(deftest nset-difference.allow-other-keys.6 - (sort - (copy-list - (nset-difference - (list 1 2 3 4 5) (list 2 3 4) - :allow-other-keys t - :allow-other-keys nil)) - #'<) - (1 5)) - -(deftest nset-difference.allow-other-keys.7 - (sort - (copy-list - (nset-difference - (list 1 2 3 4 5) (list 2 3 4) - :allow-other-keys t - :allow-other-keys nil - '#:x 1)) - #'<) - (1 5)) - -(deftest nset-difference.keywords.8 - (sort - (copy-list - (nset-difference - (list 1 2 3 4 5) (list 2 3 4) - :test #'eql :test (complement #'eql))) - #'<) - (1 5)) - -(deftest nset-difference.keywords.9 - (sort - (copy-list - (nset-difference - (list 1 2 3 4 5) (list 2 3 4) - :test (complement #'eql) :test #'eql)) - #'<) - nil) - -;;; Error tests - -(deftest nset-difference.error.1 - (signals-error (nset-difference) program-error) - t) - -(deftest nset-difference.error.2 - (signals-error (nset-difference nil) program-error) - t) - -(deftest nset-difference.error.3 - (signals-error (nset-difference nil nil :bad t) program-error) - t) - -(deftest nset-difference.error.4 - (signals-error (nset-difference nil nil :key) program-error) - t) - -(deftest nset-difference.error.5 - (signals-error (nset-difference nil nil 1 2) program-error) - t) - -(deftest nset-difference.error.6 - (signals-error (nset-difference nil nil :bad t :allow-other-keys nil) program-error) - t) - -(deftest nset-difference.error.7 - (signals-error (nset-difference (list 1 2) (list 3 4) :test #'identity) program-error) - t) - -(deftest nset-difference.error.8 - (signals-error (nset-difference (list 1 2) (list 3 4) :test-not #'identity) program-error) - t) - -(deftest nset-difference.error.9 - (signals-error (nset-difference (list 1 2) (list 3 4) :key #'cons) program-error) - t) - -(deftest nset-difference.error.10 - (signals-error (nset-difference (list 1 2) (list 3 4) :key #'car) type-error) - t) - -(deftest nset-difference.error.11 - (signals-error (nset-difference (list 1 2 3) (list* 4 5 6)) type-error) - t) - -(deftest nset-difference.error.12 - (signals-error (nset-difference (list* 1 2 3) (list 4 5 6)) type-error) - t) - -(deftest nset-difference.error.13 - (check-type-error #'(lambda (x) (nset-difference (list 'a 'b) x)) #'listp) - nil) - -(deftest nset-difference.error.14 - (check-type-error #'(lambda (x) (nset-difference x (list 'a 'b))) #'listp) - nil) diff --git a/t/ansi-test/cons/nset-exclusive-or.lsp b/t/ansi-test/cons/nset-exclusive-or.lsp deleted file mode 100644 index 2cbc031..0000000 --- a/t/ansi-test/cons/nset-exclusive-or.lsp +++ /dev/null @@ -1,377 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Apr 20 07:47:05 2003 -;;;; Contains: Tests of NSET-EXCLUSIVE-OR - - - - - -(deftest nset-exclusive-or.1 - (nset-exclusive-or nil nil) - nil) - -(deftest nset-exclusive-or.2 - (let ((result - (nset-exclusive-or-with-check '(a b c) nil))) - (check-set-exclusive-or '(a b c) nil result)) - t) - -(deftest nset-exclusive-or.3 - (let ((result - (nset-exclusive-or-with-check '(a b c d e f) '(f b d)))) - (check-set-exclusive-or '(a b c d e f) '(f b d) result)) - t) - -(deftest nset-exclusive-or.4 - (sort - (copy-list - (nset-exclusive-or-with-check (shuffle '(1 2 3 4 5 6 7 8)) - '(10 101 4 74 2 1391 7 17831))) - #'<) - (1 3 5 6 8 10 74 101 1391 17831)) - -(deftest nset-exclusive-or.5 - (check-set-exclusive-or - nil - '(a b c d e f g h) - (nset-exclusive-or-with-check nil '(a b c d e f g h))) - t) - -(deftest nset-exclusive-or.6 - (nset-exclusive-or-with-check '(a b c d e) '(d a b e) - :key nil) - (c)) - -(deftest nset-exclusive-or.7 - (nset-exclusive-or-with-check '(a b c d e) '(d a b e) :test #'eq) - (c)) - -(deftest nset-exclusive-or.7-a - (nset-exclusive-or-with-check '(d a b e) '(a b c d e) :test #'eq) - (c)) - -(deftest nset-exclusive-or.8 - (nset-exclusive-or-with-check '(a b c d e) '(d a b e) :test #'eql) - (c)) - -(deftest nset-exclusive-or.8-a - (nset-exclusive-or-with-check '(e d b a) '(a b c d e) :test #'eql) - (c)) - -(deftest nset-exclusive-or.8-b - (nset-exclusive-or-with-check '(a b c d e) '(d a b e) - :test-not (complement #'eql)) - (c)) - -(deftest nset-exclusive-or.9 - (nset-exclusive-or-with-check '(a b c d e) '(d a b e) :test #'equal) - (c)) - -(deftest nset-exclusive-or.10 - (nset-exclusive-or-with-check '(a b c d e) '(d a b e) - :test 'eq) - (c)) - -(deftest nset-exclusive-or.11 - (nset-exclusive-or-with-check '(a b c d e) '(d a b e) - :test 'eql) - (c)) - -(deftest nset-exclusive-or.12 - (nset-exclusive-or-with-check '(a b c d e) '(d a b e) - :test 'equal) - (c)) - -;;; (deftest nset-exclusive-or.13 -;;; (do-random-nset-exclusive-ors 100 100) -;;; nil) - -(deftest nset-exclusive-or.14 - (nset-exclusive-or-with-check '((a . 1) (b . 2) (c . 3012)) - '((a . 10) (c . 3)) - :key 'car) - ((b . 2))) - -(deftest nset-exclusive-or.15 - (nset-exclusive-or-with-check '((a . xx) (b . 2) (c . 3)) - '((a . 1) (c . 3313)) - :key #'car) - ((b . 2))) - -(deftest nset-exclusive-or.16 - (nset-exclusive-or-with-check '((a . xx) (b . 2) (c . 3)) - '((a . 1) (c . 3313)) - :key #'car - :test-not (complement #'eql)) - ((b . 2))) - -;; -;; Check that nset-exclusive-or does not invert -;; the order of the arguments to the test function -;; -(deftest nset-exclusive-or.17 - (let ((list1 '(a b c d)) - (list2 '(e f g h))) - (block fail - (notnot-mv - (nset-exclusive-or-with-check - list1 list2 - :test #'(lambda (s1 s2) - (when (or (member s1 list2) - (member s2 list1)) - (return-from fail 'failed))))))) - t) - -(deftest nset-exclusive-or.17-a - (let ((list1 '(a b c d)) - (list2 '(e f g h))) - (block fail - (notnot-mv - (nset-exclusive-or-with-check - list1 list2 - :key #'identity - :test #'(lambda (s1 s2) - (when (or (member s1 list2) - (member s2 list1)) - (return-from fail 'failed))))))) - t) - -(deftest nset-exclusive-or.18 - (let ((list1 '(a b c d)) - (list2 '(e f g h))) - (block fail - (notnot-mv - (nset-exclusive-or-with-check - list1 list2 - :test-not - #'(lambda (s1 s2) - (when (or (member s1 list2) - (member s2 list1)) - (return-from fail 'failed)) - t))))) - t) - -(deftest nset-exclusive-or.18-a - (let ((list1 '(a b c d)) - (list2 '(e f g h))) - (block fail - (notnot-mv - (nset-exclusive-or-with-check - list1 list2 - :key #'identity - :test-not - #'(lambda (s1 s2) - (when (or (member s1 list2) - (member s2 list1)) - (return-from fail 'failed)) - t))))) - t) - -(defharmless nset-exclusive-or.test-and-test-not.1 - (nset-exclusive-or (list 1 2 3 4) (list 1 7 3 8) - :test #'eql :test-not #'eql)) - -(defharmless nset-exclusive-or.test-and-test-not.2 - (nset-exclusive-or (list 1 2 3 4) (list 1 7 3 8) - :test-not #'eql :test #'eql)) - -;;; Order of argument evaluation tests - -(deftest nset-exclusive-or.order.1 - (let ((i 0) x y) - (values - (sort - (nset-exclusive-or (progn (setf x (incf i)) - (list 1 2 3 4)) - (progn (setf y (incf i)) - (list 1 3 6 10))) - #'<) - i x y)) - (2 4 6 10) 2 1 2) - -(deftest nset-exclusive-or.order.2 - (let ((i 0) x y z) - (values - (sort - (nset-exclusive-or (progn (setf x (incf i)) - (list 1 2 3 4)) - (progn (setf y (incf i)) - (list 1 3 6 10)) - :test (progn (setf z (incf i)) - #'eql)) - #'<) - i x y z)) - (2 4 6 10) 3 1 2 3) - -(deftest nset-exclusive-or.order.3 - (let ((i 0) x y z w) - (values - (sort - (nset-exclusive-or (progn (setf x (incf i)) - (list 1 2 3 4)) - (progn (setf y (incf i)) - (list 1 3 6 10)) - :test (progn (setf z (incf i)) - #'eql) - :key (progn (setf w (incf i)) nil)) - #'<) - i x y z w)) - (2 4 6 10) 4 1 2 3 4) - -(deftest nset-exclusive-or.order.4 - (let ((i 0) x y z w) - (values - (sort - (nset-exclusive-or (progn (setf x (incf i)) - (list 1 2 3 4)) - (progn (setf y (incf i)) - (list 1 3 6 10)) - :key (progn (setf z (incf i)) nil) - :test (progn (setf w (incf i)) - #'eql)) - #'<) - i x y z w)) - (2 4 6 10) 4 1 2 3 4) - -(deftest nset-exclusive-or.order.5 - (let ((i 0) x y z w) - (values - (sort - (nset-exclusive-or (progn (setf x (incf i)) - (list 1 2 3 4)) - (progn (setf y (incf i)) - (list 1 3 6 10)) - :key (progn (setf z (incf i)) nil) - :key (progn (setf w (incf i)) - (complement #'eql))) - #'<) - i x y z w)) - (2 4 6 10) 4 1 2 3 4) - - -;;; Keyword tests - -(deftest nset-exclusive.allow-other-keys.1 - (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :bad t :allow-other-keys t) - #'<) - (1 2 5 6)) - -(deftest nset-exclusive.allow-other-keys.2 - (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :allow-other-keys t :bad t) - #'<) - (1 2 5 6)) - -(deftest nset-exclusive.allow-other-keys.3 - (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :allow-other-keys t :bad t - :test #'(lambda (x y) (= x (1- y)))) - #'<) - (1 6)) - -(deftest nset-exclusive.allow-other-keys.4 - (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :allow-other-keys t) - #'<) - (1 2 5 6)) - -(deftest nset-exclusive.allow-other-keys.5 - (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :allow-other-keys nil) - #'<) - (1 2 5 6)) - -(deftest nset-exclusive.allow-other-keys.6 - (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :allow-other-keys t - :allow-other-keys nil) - #'<) - (1 2 5 6)) - -(deftest nset-exclusive.allow-other-keys.7 - (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :allow-other-keys t - :allow-other-keys nil - '#:x 1) - #'<) - (1 2 5 6)) - -(deftest nset-exclusive.keywords.8 - (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :test #'eql - :test #'/=) - #'<) - (1 2 5 6)) - -(deftest nset-exclusive.keywords.9 - (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :test #'/= - :test #'eql) - #'<) - nil) - -;;; Randomized test - -(deftest random-nset-exclusive-or - (random-set-exclusive-or-test 10 1000 'nset-exclusive-or) - nil) - -;;; Error tests - -(deftest nset-exclusive-or.error.1 - (signals-error (nset-exclusive-or) program-error) - t) - -(deftest nset-exclusive-or.error.2 - (signals-error (nset-exclusive-or nil) program-error) - t) - -(deftest nset-exclusive-or.error.3 - (signals-error (nset-exclusive-or nil nil :bad t) program-error) - t) - -(deftest nset-exclusive-or.error.4 - (signals-error (nset-exclusive-or nil nil :key) program-error) - t) - -(deftest nset-exclusive-or.error.5 - (signals-error (nset-exclusive-or nil nil 1 2) program-error) - t) - -(deftest nset-exclusive-or.error.6 - (signals-error (nset-exclusive-or nil nil :bad t :allow-other-keys nil) program-error) - t) - -(deftest nset-exclusive-or.error.7 - (signals-error (nset-exclusive-or (list 1 2) (list 3 4) :test #'identity) program-error) - t) - -(deftest nset-exclusive-or.error.8 - (signals-error (nset-exclusive-or (list 1 2) (list 3 4) :test-not #'identity) program-error) - t) - -(deftest nset-exclusive-or.error.9 - (signals-error (nset-exclusive-or (list 1 2) (list 3 4) :key #'cons) program-error) - t) - -(deftest nset-exclusive-or.error.10 - (signals-error (nset-exclusive-or (list 1 2) (list 3 4) :key #'car) type-error) - t) - -(deftest nset-exclusive-or.error.11 - (signals-error (nset-exclusive-or (list 1 2 3) (list* 4 5 6)) type-error) - t) - -(deftest nset-exclusive-or.error.12 - (signals-error (nset-exclusive-or (list* 1 2 3) (list 4 5 6)) type-error) - t) - -(deftest nset-exclusive-or.error.13 - (check-type-error #'(lambda (x) (nset-exclusive-or x (list 'a 'b))) #'listp) - nil) - -(deftest nset-exclusive-or.error.14 - (check-type-error #'(lambda (x) (nset-exclusive-or (list 'a 'b) x)) #'listp) - nil) diff --git a/t/ansi-test/cons/nsublis.lsp b/t/ansi-test/cons/nsublis.lsp deleted file mode 100644 index 6b1c976..0000000 --- a/t/ansi-test/cons/nsublis.lsp +++ /dev/null @@ -1,194 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 19 21:35:33 2003 -;;;; Contains: Tests of NSUBLIS - - - - - -(deftest nsublis.1 - (check-nsublis '((a b) g (d e 10 g h) 15 . g) - '((e . e2) (g . 17))) - ((a b) 17 (d e2 10 17 h) 15 . 17)) - -(deftest nsublis.2 - (check-nsublis '(f6 10 (f4 (f3 (f1 a b) (f1 a p)) (f2 a b))) - '(((f1 a b) . (f2 a b)) ((f2 a b) . (f1 a b))) - :test #'equal) - (f6 10 (f4 (f3 (f2 a b) (f1 a p)) (f1 a b)))) - -(deftest nsublis.3 - (check-nsublis '(10 ((10 20 (a b c) 30)) (((10 20 30 40)))) - '((30 . "foo"))) - (10 ((10 20 (a b c) "foo")) (((10 20 "foo" 40))))) - -(deftest nsublis.4 - (check-nsublis - (nsublis (copy-tree '((a . 2) (b . 4) (c . 1))) - (copy-tree '(a b c d e (a b c a d b) f))) - '((t . "yes")) - :key #'(lambda (x) (and (typep x 'integer) - (evenp x)))) - ("yes" "yes" 1 d e ("yes" "yes" 1 "yes" d "yes") f)) - -(deftest nsublis.5 - (check-nsublis '("fee" (("fee" "Fie" "foo")) - fie ("fee" "fie")) - `((,(copy-seq "fie") . #\f))) - ("fee" (("fee" "Fie" "foo")) fie ("fee" "fie"))) - -(deftest nsublis.6 - (check-nsublis '("fee" fie (("fee" "Fie" "foo") 1) - ("fee" "fie")) - `((,(copy-seq "fie") . #\f)) - :test 'equal) - ("fee" fie (("fee" "Fie" "foo") 1) ("fee" #\f))) - -(deftest nsublis.7 - (check-nsublis '(("aa" a b) - (z "bb" d) - ((x . "aa"))) - `((,(copy-seq "aa") . 1) - (,(copy-seq "bb") . 2)) - :test 'equal - :key #'(lambda (x) (if (consp x) (car x) - '*not-present*))) - (1 (z . 2) ((x . "aa")))) - -(deftest nsublis.8 - (nsublis nil 'a :bad-keyword t :allow-other-keys t) - a) - -;; Check that a null key arg is ignored. - -(deftest nsublis.9 - (check-nsublis - '(1 2 a b) - '((1 . 2) (a . b)) - :key nil) - (2 2 b b)) - -(deftest nsublis.10 - (check-nsublis (list 0 3 8 20) - '((1 . x) (5 . y) (10 . z)) - :test #'(lambda (x y) (and (realp x) (realp y) (< x y)))) - (x y z 20)) - -(deftest nsublis.11 - (check-nsublis (list 0 3 8 20) - '((1 . x) (5 . y) (10 . z)) - :test-not - #'(lambda (x y) (not (and (realp x) (realp y) (< x y))))) - (x y z 20)) - -(defharmless nsublis.test-and-test-not.1 - (nsublis '((a . 1) (b . 2)) (list 'a 'b 'c 'd) - :test #'eql :test-not #'eql)) - -(defharmless nsublis.test-and-test-not.2 - (nsublis '((a . 1) (b . 2)) (list 'a 'b 'c 'd) - :test-not #'eql :test #'eql)) - -;;; Order of argument evaluation -(deftest nsublis.order.1 - (let ((i 0) w x y z) - (values - (nsublis - (progn (setf w (incf i)) - '((a . z))) - (progn (setf x (incf i)) - (copy-tree '(a b c d))) - :test (progn (setf y (incf i)) #'eql) - :key (progn (setf z (incf i)) #'identity)) - i w x y z)) - (z b c d) - 4 1 2 3 4) - -(deftest nsublis.order.2 - (let ((i 0) w x y z) - (values - (nsublis - (progn (setf w (incf i)) - '((a . z))) - (progn (setf x (incf i)) - (copy-tree '(a b c d))) - :key (progn (setf y (incf i)) #'identity) - :test-not (progn (setf z (incf i)) (complement #'eql)) - ) - i w x y z)) - (z b c d) - 4 1 2 3 4) - -;;; Keyword tests - -(deftest nsublis.allow-other-keys.1 - (nsublis nil 'a :bad t :allow-other-keys t) - a) - -(deftest nsublis.allow-other-keys.2 - (nsublis nil 'a :allow-other-keys t :bad t) - a) - -(deftest nsublis.allow-other-keys.3 - (nsublis nil 'a :allow-other-keys t) - a) - -(deftest nsublis.allow-other-keys.4 - (nsublis nil 'a :allow-other-keys nil) - a) - -(deftest nsublis.allow-other-keys.5 - (nsublis nil 'a :allow-other-keys t :allow-other-keys t :bad t) - a) - -(deftest nsublis.keywords.6 - (nsublis '((1 . a)) (list 0 1 2) - :key #'(lambda (x) (if (numberp x) (1+ x) x)) - :key #'identity) - (a 1 2)) - -;; Argument error cases - -(deftest nsublis.error.1 - (signals-error (nsublis) program-error) - t) - -(deftest nsublis.error.2 - (signals-error (nsublis nil) program-error) - t) - -(deftest nsublis.error.3 - (signals-error (nsublis nil 'a :test) program-error) - t) - -(deftest nsublis.error.4 - (signals-error (nsublis nil 'a :bad-keyword t) program-error) - t) - -(deftest nsublis.error.5 - (signals-error (nsublis '((a . 1) (b . 2)) - (list 'a 'b 'c 'd) - :test #'identity) - program-error) - t) - -(deftest nsublis.error.6 - (signals-error (nsublis '((a . 1) (b . 2)) - (list 'a 'b 'c 'd) - :key #'cons) - program-error) - t) - -(deftest nsublis.error.7 - (signals-error (nsublis '((a . 1) (b . 2)) - (list 'a 'b 'c 'd) - :test-not #'identity) - program-error) - t) - -(deftest nsublis.error.8 - (signals-error (nsublis '((a . 1) . bad) - (list 'a 'b 'c 'd)) - type-error) - t) diff --git a/t/ansi-test/cons/nsubst-if-not.lsp b/t/ansi-test/cons/nsubst-if-not.lsp deleted file mode 100644 index 2b010c8..0000000 --- a/t/ansi-test/cons/nsubst-if-not.lsp +++ /dev/null @@ -1,121 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 19 21:54:12 2003 -;;;; Contains: Tests of NSUBST-IF-NOT - - - - - -(deftest nsubst-if-not.1 - (check-nsubst-if-not '(x) 'consp '(1 (1 2) (1 2 3) (1 2 3 4))) - ((x) - ((x) (x) x) - ((x) (x) (x) x) - ((x) (x) (x) (x) x) - x)) - -(deftest nsubst-if-not.2 - (check-nsubst-if-not 'a (complement #'listp) - '((100 1) (2 3) (4 3 2 1) (a b c))) - a) - -(deftest nsubst-if-not.3 - (check-nsubst-if-not 'c #'identity - '((100 1) (2 3) (4 3 2 1) (a b c)) - :key (complement #'listp)) - c) - -(deftest nsubst-if-not.4 - (check-nsubst-if-not - 40 - #'(lambda (x) (not (eql x 17))) - '((17) (17 22) (17 22 31) (17 21 34 54)) - :key #'(lambda (x) - (and (consp x) - (car x)))) - (40 40 40 40)) - -(deftest nsubst-if-not.5 - (check-nsubst-if-not 'a #'(lambda (x) (not (eql x 'b))) - '((a) (b) (c) (d)) - :key nil) - ((a) (a) (c) (d))) - -(deftest nsubst-if-not.6 - (nsubst-if-not 'a #'null nil :bad t :allow-other-keys t) - nil) - -(deftest nsubst-if-not.7 - (let ((i 0) w x y z) - (values - (nsubst-if-not - (progn (setf w (incf i)) 'a) - (progn (setf x (incf i)) #'(lambda (x) (not (eql x 'b)))) - (progn (setf y (incf i)) (copy-list '(1 2 a b c))) - :key (progn (setf z (incf i)) #'identity)) - i w x y z)) - (1 2 a a c) - 4 1 2 3 4) - -;;; Keywords tests for nsubst-if-not - -(deftest nsubst-if-not.allow-other-keys.1 - (nsubst-if-not 'a #'identity nil :bad t :allow-other-keys t) - a) - -(deftest nsubst-if-not.allow-other-keys.2 - (nsubst-if-not 'a #'identity nil :allow-other-keys t) - a) - -(deftest nsubst-if-not.allow-other-keys.3 - (nsubst-if-not 'a #'identity nil :allow-other-keys nil) - a) - -(deftest nsubst-if-not.allow-other-keys.4 - (nsubst-if-not 'a #'identity nil :allow-other-keys t :bad t) - a) - -(deftest nsubst-if-not.allow-other-keys.5 - (nsubst-if-not 'a #'identity nil :allow-other-keys t :allow-other-keys nil :bad t) - a) - -(deftest nsubst-if-not.keywords.6 - (nsubst-if-not 'a #'identity nil :key nil :key (constantly 'b)) - a) - -;;; error cases - -(deftest nsubst-if-not.error.1 - (signals-error (nsubst-if-not) program-error) - t) - -(deftest nsubst-if-not.error.2 - (signals-error (nsubst-if-not 'a) program-error) - t) - -(deftest nsubst-if-not.error.3 - (signals-error (nsubst-if-not 'a #'null) program-error) - t) - -(deftest nsubst-if-not.error.4 - (signals-error (nsubst-if-not 'a #'null nil :foo nil) program-error) - t) - -(deftest nsubst-if-not.error.5 - (signals-error (nsubst-if-not 'a #'null nil :test) program-error) - t) - -(deftest nsubst-if-not.error.6 - (signals-error (nsubst-if-not 'a #'null nil 1) program-error) - t) - -(deftest nsubst-if-not.error.7 - (signals-error (nsubst-if-not 'a #'null nil - :bad t :allow-other-keys nil) program-error) - t) - -(deftest nsubst-if-not.error.8 - (signals-error (nsubst-if-not 'a #'null (list 'a nil 'c) :key #'cons) program-error) - t) - diff --git a/t/ansi-test/cons/nsubst-if.lsp b/t/ansi-test/cons/nsubst-if.lsp deleted file mode 100644 index d6e6ec4..0000000 --- a/t/ansi-test/cons/nsubst-if.lsp +++ /dev/null @@ -1,123 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 19 21:51:41 2003 -;;;; Contains: Tests of NSUBST-IF - - - - - -(deftest nsubst-if.1 - (check-nsubst-if 'a #'consp '((100 1) (2 3) (4 3 2 1) (a b c))) - a) - -(deftest nsubst-if.2 - (check-nsubst-if 17 (complement #'listp) '(a (a b) (a c d) (a nil e f g))) - (17 (17 17) (17 17 17) (17 nil 17 17 17))) - -(deftest nsubst-if.3 - (check-nsubst-if '(z) - (complement #'consp) - '(a (a b) (c d e) (f g h i))) - ((z) - ((z) (z) z) - ((z) (z) (z) z) - ((z) (z) (z) (z) z) - z)) - -(deftest nsubst-if.4 - (check-nsubst-if 'b #'identity '((100 1) (2 3) (4 3 2 1) (a b c)) - :key #'listp) - b) - -(deftest nsubst-if.5 - (check-nsubst-if 4 #'(lambda (x) (eql x 1)) - '((1 3) (1) (1 10 20 30) (1 3 x y)) - :key #'(lambda (x) - (and (consp x) - (car x)))) - (4 4 4 4)) - -(deftest nsubst-if.6 - (check-nsubst-if 'a #'(lambda (x) (eql x 'b)) - '((a) (b) (c) (d)) - :key nil) - ((a) (a) (c) (d))) - -(deftest nsubst-if.7 - (nsubst-if 'a #'null nil :bad t :allow-other-keys t) - a) - -(deftest nsubst-if.8 - (let ((i 0) w x y z) - (values - (nsubst-if - (progn (setf w (incf i)) 'a) - (progn (setf x (incf i)) #'(lambda (x) (eql x 'b))) - (progn (setf y (incf i)) (copy-list '(1 2 a b c))) - :key (progn (setf z (incf i)) #'identity)) - i w x y z)) - (1 2 a a c) - 4 1 2 3 4) - -;;; Keyword tests for nsubst-if - -(deftest nsubst-if.allow-other-keys.1 - (nsubst-if 'a #'null nil :bad t :allow-other-keys t) - a) - -(deftest nsubst-if.allow-other-keys.2 - (nsubst-if 'a #'null nil :allow-other-keys t) - a) - -(deftest nsubst-if.allow-other-keys.3 - (nsubst-if 'a #'null nil :allow-other-keys nil) - a) - -(deftest nsubst-if.allow-other-keys.4 - (nsubst-if 'a #'null nil :allow-other-keys t :bad t) - a) - -(deftest nsubst-if.allow-other-keys.5 - (nsubst-if 'a #'null nil :allow-other-keys t :allow-other-keys nil :bad t) - a) - -(deftest nsubst-if.keywords.6 - (nsubst-if 'a #'null nil :key nil :key (constantly 'b)) - a) - -;;; error cases - -(deftest nsubst-if.error.1 - (signals-error (nsubst-if) program-error) - t) - -(deftest nsubst-if.error.2 - (signals-error (nsubst-if 'a) program-error) - t) - -(deftest nsubst-if.error.3 - (signals-error (nsubst-if 'a #'null) program-error) - t) - -(deftest nsubst-if.error.4 - (signals-error (nsubst-if 'a #'null nil :foo nil) program-error) - t) - -(deftest nsubst-if.error.5 - (signals-error (nsubst-if 'a #'null nil :test) program-error) - t) - -(deftest nsubst-if.error.6 - (signals-error (nsubst-if 'a #'null nil 1) program-error) - t) - -(deftest nsubst-if.error.7 - (signals-error (nsubst-if 'a #'null nil :bad t :allow-other-keys nil) - program-error) - t) - -(deftest nsubst-if.error.8 - (signals-error (nsubst-if 'a #'null (list 'a nil 'c) :key #'cons) - program-error) - t) diff --git a/t/ansi-test/cons/nsubst.lsp b/t/ansi-test/cons/nsubst.lsp deleted file mode 100644 index b762db6..0000000 --- a/t/ansi-test/cons/nsubst.lsp +++ /dev/null @@ -1,176 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 19 21:49:58 2003 -;;;; Contains: Tests of NSUBST - - - - - -(defvar *nsubst-tree-1* '(10 (30 20 10) (20 10) (10 20 30 40))) - -(deftest nsubst.1 - (check-nsubst "Z" 30 (copy-tree *nsubst-tree-1*)) - (10 ("Z" 20 10) (20 10) (10 20 "Z" 40))) - -(deftest nsubst.2 - (check-nsubst "A" 0 (copy-tree *nsubst-tree-1*)) - (10 (30 20 10) (20 10) (10 20 30 40))) - -(deftest nsubst.3 - (check-nsubst "Z" 100 (copy-tree *nsubst-tree-1*) :test-not #'eql) - "Z") - -(deftest nsubst.4 - (check-nsubst 'grape 'dick - '(melville wrote (moby dick))) - (melville wrote (moby grape))) - -(deftest nsubst.5 - (check-nsubst 'cha-cha-cha 'nil '(melville wrote (moby dick))) - (melville wrote (moby dick . cha-cha-cha) . cha-cha-cha)) - -(deftest nsubst.6 - (check-nsubst - '(1 2) '(foo . bar) - '((foo . baz) (foo . bar) (bar . foo) (baz foo . bar)) - :test #'equal) - ((foo . baz) (1 2) (bar . foo) (baz 1 2))) - -(deftest nsubst.7 - (check-nsubst - 'foo "aaa" - '((1 . 2) (4 . 5) (6 7 8 9 10 (11 12))) - :key #'(lambda (x) (if (and (numberp x) (evenp x)) - "aaa" - nil)) - :test #'string=) - ((1 . foo) (foo . 5) (foo 7 foo 9 foo (11 foo)))) - -(deftest nsubst.8 - (check-nsubst - 'foo nil - '((1 . 2) (4 . 5) (6 7 8 9 10 (11 12))) - :key #'(lambda (x) (if (and (numberp x) (evenp x)) - (copy-seq "aaa") - nil)) - :test-not #'equal) - ((1 . foo) (foo . 5) (foo 7 foo 9 foo (11 foo)))) - -(deftest nsubst.9 - (check-nsubst 'a 'b - (copy-tree '(a b c d a b)) - :key nil) - (a a c d a a)) - -(deftest nsubst.10 - (check-nsubst 'x 10 (copy-tree '(1 2 10 20 30 4)) - :test #'(lambda (x y) (and (realp x) (realp y) (< x y)))) - (1 2 10 x x 4)) - -(deftest nsubst.11 - (check-nsubst 'x 10 (copy-tree '(1 2 10 20 30 4)) - :test-not #'(lambda (x y) - (not (and (realp x) (realp y) (< x y))))) - (1 2 10 x x 4)) - -(defharmless nsubset.test-and-test-not.1 - (nsubst 'a 'b (list 'a 'b 'c 'd 'e) :test #'eq :test-not #'eq)) - -(defharmless nsubset.test-and-test-not.2 - (nsubst 'a 'b (list 'a 'b 'c 'd 'e) :test-not #'eq :test #'eq)) - -;;; Order of argument evaluation -(deftest nsubst.order.1 - (let ((i 0) v w x y z) - (values - (nsubst (progn (setf v (incf i)) 'b) - (progn (setf w (incf i)) 'a) - (progn (setf x (incf i)) (copy-tree '((10 a . a) a b c ((a)) z))) - :key (progn (setf y (incf i)) #'identity) - :test (progn (setf z (incf i)) #'eql)) - i v w x y z)) - ((10 b . b) b b c ((b)) z) - 5 1 2 3 4 5) - -(deftest nsubst.order.2 - (let ((i 0) v w x y z) - (values - (nsubst (progn (setf v (incf i)) 'b) - (progn (setf w (incf i)) 'a) - (progn (setf x (incf i)) (copy-tree '((10 a . a) a b c ((a)) z))) - :test-not (progn (setf y (incf i)) (complement #'eql)) - :key (progn (setf z (incf i)) #'identity) - ) - i v w x y z)) - ((10 b . b) b b c ((b)) z) - 5 1 2 3 4 5) - -;;; Keyword tests for nsubst - -(deftest nsubst.allow-other-keys.1 - (nsubst 'a 'b (list 'a 'b 'c) :bad t :allow-other-keys t) - (a a c)) - -(deftest nsubst.allow-other-keys.2 - (nsubst 'a 'b (list 'a 'b 'c) :allow-other-keys t) - (a a c)) - -(deftest nsubst.allow-other-keys.3 - (nsubst 'a 'b (list 'a 'b 'c) :allow-other-keys nil) - (a a c)) - -(deftest nsubst.allow-other-keys.4 - (nsubst 'a 'b (list 'a 'b 'c) :allow-other-keys t :bad t) - (a a c)) - -(deftest nsubst.allow-other-keys.5 - (nsubst 'a 'b (list 'a 'b 'c) :allow-other-keys t :allow-other-keys nil - :bad t) - (a a c)) - -(deftest nsubst.keywords.6 - (nsubst 'a 'b (list 'a 'b 'c) :test #'eq :test (complement #'eq)) - (a a c)) - -;;; Error cases - -(deftest nsubst.error.1 - (signals-error (nsubst) program-error) - t) - -(deftest nsubst.error.2 - (signals-error (nsubst 'a) program-error) - t) - -(deftest nsubst.error.3 - (signals-error (nsubst 'a 'b) program-error) - t) - -(deftest nsubst.error.4 - (signals-error (nsubst 'a 'b nil :foo nil) program-error) - t) - -(deftest nsubst.error.5 - (signals-error (nsubst 'a 'b nil :test) program-error) - t) - -(deftest nsubst.error.6 - (signals-error (nsubst 'a 'b nil 1) program-error) - t) - -(deftest nsubst.error.7 - (signals-error (nsubst 'a 'b nil :bad t :allow-other-keys nil) program-error) - t) - -(deftest nsubst.error.8 - (signals-error (nsubst 'a 'b (list 'a 'b) :test #'identity) program-error) - t) - -(deftest nsubst.error.9 - (signals-error (nsubst 'a 'b (list 'a 'b) :test-not #'identity) program-error) - t) - -(deftest nsubst.error.10 - (signals-error (nsubst 'a 'b (list 'a 'b) :key #'equal) program-error) - t) diff --git a/t/ansi-test/cons/nth.lsp b/t/ansi-test/cons/nth.lsp deleted file mode 100644 index 8b75601..0000000 --- a/t/ansi-test/cons/nth.lsp +++ /dev/null @@ -1,57 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 19 22:33:23 2003 -;;;; Contains: Tests of NTH - - - - - -(deftest nth.1 - (nth-1-body (loop for i from 1 to 2000 collect (* 4 i))) - 0) - -(deftest nth.2 - (let ((x (loop for i from 1 to 2000 collect i))) - (loop - for i from 0 to 1999 do - (setf (nth i x) (- 1999 i))) - (equalt x (loop for i from 1999 downto 0 collect i))) - t) - -;;; Test side effects, evaluation order in assignment to NTH -(deftest nth.order.1 - (let ((i 0) - (x (list 'a 'b 'c 'd)) - y z) - (and - (eqlt (setf (nth (setf y (incf i)) x) (progn (setf z (incf i)) 'z)) - 'z) - (eqlt y 1) - (eqlt z 2) - x)) - (a z c d)) - -(deftest nth.order.2 - (let ((i 0) x y (z '(a b c d e))) - (values - (nth (progn (setf x (incf i)) 1) - (progn (setf y (incf i)) z)) - i x y)) - b 2 1 2) - -(deftest nth.error.1 - (signals-error (nth) program-error) - t) - -(deftest nth.error.2 - (signals-error (nth 0) program-error) - t) - -(deftest nth.error.3 - (signals-error (nth 1 '(a b c) nil) program-error) - t) - -(deftest nth.error.4 - (signals-error (nth 0 '(a b c) nil) program-error) - t) diff --git a/t/ansi-test/cons/nthcdr.lsp b/t/ansi-test/cons/nthcdr.lsp deleted file mode 100644 index 52221f1..0000000 --- a/t/ansi-test/cons/nthcdr.lsp +++ /dev/null @@ -1,69 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 19 22:48:36 2003 -;;;; Contains: Tests of NTHCDR - - - - - -;;; Error tests - -(deftest nthcdr.error.1 - (check-type-error #'(lambda (x) (nthcdr x (copy-list '(a b c d)))) (typef 'unsigned-byte)) - nil) - -(deftest nthcdr.error.6 - (signals-error (nthcdr -10 (copy-tree '(a b c d))) type-error) - t) - -(deftest nthcdr.error.7 - (signals-error (nthcdr) program-error) - t) - -(deftest nthcdr.error.8 - (signals-error (nthcdr 0) program-error) - t) - -(deftest nthcdr.error.9 - (signals-error (nthcdr 0 nil nil) program-error) - t) - -(deftest nthcdr.error.10 - (signals-error (nthcdr 3 (cons 'a 'b)) type-error) - t) - -(deftest nthcdr.error.11 - (signals-error (locally (nthcdr 'a (copy-tree '(a b c d))) t) type-error) - t) - -;;; Non-error tests - -(deftest nthcdr.1 - (nthcdr 0 (copy-tree '(a b c d . e))) - (a b c d . e)) - -(deftest nthcdr.2 - (nthcdr 1 (copy-tree '(a b c d))) - (b c d)) - -(deftest nthcdr.3 - (nthcdr 10 nil) - nil) - -(deftest nthcdr.4 - (nthcdr 4 (list 'a 'b 'c)) - nil) - -(deftest nthcdr.5 - (nthcdr 1 (cons 'a 'b)) - b) - -(deftest nthcdr.order.1 - (let ((i 0) x y) - (values - (nthcdr (setf x (incf i)) - (progn (setf y (incf i)) '(a b c d))) - i x y)) - (b c d) 2 1 2) - diff --git a/t/ansi-test/cons/nunion.lsp b/t/ansi-test/cons/nunion.lsp deleted file mode 100644 index f89812a..0000000 --- a/t/ansi-test/cons/nunion.lsp +++ /dev/null @@ -1,418 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Apr 20 07:42:35 2003 -;;;; Contains: Tests of NUNION - - - - - -(deftest nunion.1 - (nunion nil nil) - nil) - -(deftest nunion.2 - (nunion-with-copy (list 'a) nil) - (a)) - -(deftest nunion.3 - (nunion-with-copy (list 'a) (list 'a)) - (a)) - -(deftest nunion.4 - (nunion-with-copy (list 1) (list 1)) - (1)) - -(deftest nunion.5 - (let ((x (list 'a 'b))) - (nunion-with-copy (list x) (list x))) - ((a b))) - -(deftest nunion.6 - (let ((x '(a b c d e f)) - (y '(z c y a v b))) - (let ((result (nunion-with-copy x y))) - (check-union x y result))) - t) - -(deftest nunion.6-a - (let ((x '(a b c d e f)) - (y '(z c y a v b))) - (let ((result (nunion-with-copy x y :test #'eq))) - (check-union x y result))) - t) - -(deftest nunion.7 - (let ((x '(a b c d e f)) - (y '(z c y a v b))) - (let ((result (nunion-with-copy x y :test #'eql))) - (check-union x y result))) - t) - -(deftest nunion.8 - (let ((x '(a b c d e f)) - (y '(z c y a v b))) - (let ((result (nunion-with-copy x y :test #'equal))) - (check-union x y result))) - t) - -(deftest nunion.9 - (let ((x '(a b c d e f)) - (y '(z c y a v b))) - (let ((result (nunion-with-copy x y :test-not (complement #'eql)))) - (check-union x y result))) - t) - -(deftest nunion.10 - (let ((x '(a b c d e f)) - (y '(z c y a v b))) - (let ((result (nunion-with-copy x y :test-not (complement #'equal)))) - (check-union x y result))) - t) - -(deftest nunion.11 - (let ((x '(a b c d e f)) - (y '(z c y a v b))) - (let ((result (nunion-with-copy x y :test-not (complement #'eq)))) - (check-union x y result))) - t) - -(deftest nunion.12 - (let ((x '(1 2 3 4 5 6 7)) - (y '(10 19 5 3 17 1001 2))) - (let ((result (nunion-with-copy x y))) - (check-union x y result))) - t) - -(deftest nunion.13 - (let ((x '(1 2 3 4 5 6 7)) - (y '(10 19 5 3 17 1001 2))) - (let ((result (nunion-with-copy x y :test #'equal))) - (check-union x y result))) - t) - -(deftest nunion.14 - (let ((x '(1 2 3 4 5 6 7)) - (y '(10 19 5 3 17 1001 2))) - (let ((result (nunion-with-copy x y :test #'eql))) - (check-union x y result))) - t) - -(deftest nunion.15 - (let ((x '(1 2 3 4 5 6 7)) - (y '(10 19 5 3 17 1001 2))) - (let ((result (nunion-with-copy x y :test-not (complement #'equal)))) - (check-union x y result))) - t) - -(deftest nunion.16 - (let ((x '(1 2 3 4 5 6 7)) - (y '(10 19 5 3 17 1001 2))) - (let ((result (nunion-with-copy x y :test-not (complement #'eql)))) - (check-union x y result))) - t) - -(deftest nunion.17 - (let ((x '(1 2 3 4 5 6 7)) - (y '(10 19 5 3 17 1001 2))) - (let ((result (nunion-with-copy-and-key x y #'1+))) - (check-union x y result))) - t) - -(deftest nunion.18 - (let ((x '(1 2 3 4 5 6 7)) - (y '(10 19 5 3 17 1001 2))) - (let ((result (nunion-with-copy-and-key x y #'1+ :test #'equal))) - (check-union x y result))) - t) - -(deftest nunion.19 - (let ((x '(1 2 3 4 5 6 7)) - (y '(10 19 5 3 17 1001 2))) - (let ((result (nunion-with-copy-and-key x y #'1+ :test #'eql))) - (check-union x y result))) - t) - -(deftest nunion.20 - (let ((x '(1 2 3 4 5 6 7)) - (y '(10 19 5 3 17 1001 2))) - (let ((result (nunion-with-copy-and-key x y #'1+ - :test-not (complement #'equal)))) - (check-union x y result))) - t) - -(deftest nunion.21 - (let ((x '(1 2 3 4 5 6 7)) - (y '(10 19 5 3 17 1001 2))) - (let ((result (nunion-with-copy-and-key x y #'1+ - :test-not (complement #'equal)))) - (check-union x y result))) - t) - -(deftest nunion.22 - (let ((x '(1 2 3 4 5 6 7)) - (y '(10 19 5 3 17 1001 2))) - (let ((result (nunion-with-copy-and-key x y nil))) - (check-union x y result))) - t) - -(deftest nunion.23 - (let ((x '(1 2 3 4 5 6 7)) - (y '(10 19 5 3 17 1001 2))) - (let ((result (nunion-with-copy-and-key x y '1+))) - (check-union x y result))) - t) - -;; Do large numbers of random nunions - -(deftest nunion.24 - (do-random-nunions 100 100 200) - nil) - -(deftest nunion.25 - (let ((x (shuffle '(1 4 6 10 45 101))) - (y '(102 5 2 11 44 6))) - (let ((result (nunion-with-copy x y - :test #'(lambda (a b) - (<= (abs (- a b)) 1))))) - (sort - (sublis - '((2 . 1) (5 . 4) (11 . 10) (45 . 44) (102 . 101)) - (copy-list result)) - #'<))) - (1 4 6 10 44 101)) - -;; Check that nunion uses eql, not equal or eq - -(deftest nunion.26 - (let ((x 1000) - (y 1000)) - (loop - while (not (typep x 'bignum)) - do (progn - (setf x (* x x)) - (setf y (* y y)))) - (notnot-mv - (or - (eqt x y) ;; if bignums are eq, the test is worthless - (eql (length - (nunion-with-copy (list x) (list x))) - 1)))) - t) - -(deftest nunion.27 - (nunion-with-copy (list (copy-seq "aa")) - (list (copy-seq "aa"))) - ("aa" "aa")) - -(defharmless nunion.test-and-test-not.1 - (nunion (list 1 4 8 10) (list 1 2 3 9 10 13) :test #'eql :test-not #'eql)) - -(defharmless nunion.test-and-test-not.2 - (nunion (list 1 4 8 10) (list 1 2 3 9 10 13) :test-not #'eql :test #'eql)) - -;; Check that nunion does not reverse the arguments to :test, :test-not - -(deftest nunion.28 - (block fail - (sort - (nunion-with-copy - '(1 2 3) - '(4 5 6) - :test #'(lambda (x y) - (when (< y x) (return-from fail 'fail)) - (eql x y))) - #'<)) - (1 2 3 4 5 6)) - -(deftest nunion.29 - (block fail - (sort - (nunion-with-copy-and-key - '(1 2 3) - '(4 5 6) - #'identity - :test #'(lambda (x y) - (when (< y x) (return-from fail 'fail)) - (eql x y))) - #'<)) - (1 2 3 4 5 6)) - -(deftest nunion.30 - (block fail - (sort - (nunion-with-copy - '(1 2 3) - '(4 5 6) - :test-not - #'(lambda (x y) - (when (< y x) (return-from fail 'fail)) - (not (eql x y)))) - #'<)) - (1 2 3 4 5 6)) - -(deftest nunion.31 - (block fail - (sort - (nunion-with-copy-and-key - '(1 2 3) - '(4 5 6) - #'identity - :test-not #'(lambda (x y) - (when (< y x) (return-from fail 'fail)) - (not (eql x y)))) - #'<)) - (1 2 3 4 5 6)) - -;;; Order of evaluation tests - -(deftest nunion.order.1 - (let ((i 0) x y) - (values - (sort - (nunion (progn (setf x (incf i)) (copy-list '(1 3 5))) - (progn (setf y (incf i)) (copy-list '(2 5 8)))) - #'<) - i x y)) - (1 2 3 5 8) - 2 1 2) - -(deftest nunion.order.2 - (let ((i 0) x y z w) - (values - (sort - (nunion (progn (setf x (incf i)) (copy-list '(1 3 5))) - (progn (setf y (incf i)) (copy-list '(2 5 8))) - :test (progn (setf z (incf i)) #'eql) - :key (progn (setf w (incf i)) #'identity)) - #'<) - i x y z w)) - (1 2 3 5 8) - 4 1 2 3 4) - - -(deftest nunion.order.3 - (let ((i 0) x y z w) - (values - (sort - (nunion (progn (setf x (incf i)) (copy-list '(1 3 5))) - (progn (setf y (incf i)) (copy-list '(2 5 8))) - :key (progn (setf z (incf i)) #'identity) - :test (progn (setf w (incf i)) #'eql)) - #'<) - i x y z w)) - (1 2 3 5 8) - 4 1 2 3 4) - -;;; Keyword tests - -(deftest nunion.allow-other-keys.1 - (sort (nunion (list 7 9 1 5) (list 10 11 9 20 1 2) :bad t - :allow-other-keys "yes") - #'<) - (1 2 5 7 9 10 11 20)) - -(deftest nunion.allow-other-keys.2 - (sort (nunion (list 7 9 1 5) (list 10 11 9 20 1 2) - :allow-other-keys t :also-bad t) - #'<) - (1 2 5 7 9 10 11 20)) - -(deftest nunion.allow-other-keys.3 - (sort (nunion (list 1 2 3) (list 1 2 3) - :allow-other-keys t :also-bad t - :test #'(lambda (x y) (= x (+ y 100)))) - #'<) - (1 1 2 2 3 3)) - -(deftest nunion.allow-other-keys.4 - (sort (nunion (list 7 9 1 5) (list 10 11 9 20 1 2) - :allow-other-keys t) - #'<) - (1 2 5 7 9 10 11 20)) - -(deftest nunion.allow-other-keys.5 - (sort (nunion (list 7 9 1 5) (list 10 11 9 20 1 2) - :allow-other-keys nil) - #'<) - (1 2 5 7 9 10 11 20)) - -(deftest nunion.allow-other-keys.6 - (sort (nunion (list 7 9 1 5) (list 10 11 9 20 1 2) - :allow-other-keys t - :allow-other-keys nil) - #'<) - (1 2 5 7 9 10 11 20)) - -(deftest nunion.allow-other-keys.7 - (sort (nunion (list 7 9 1 5) (list 10 11 9 20 1 2) - :allow-other-keys t - :allow-other-keys nil - '#:x 1) - #'<) - (1 2 5 7 9 10 11 20)) - -(deftest nunion.keywords.9 - (sort (nunion (list 1 2 3) (list 1 2 3) - :test #'(lambda (x y) (= x (+ y 100))) - :test #'eql) - #'<) - (1 1 2 2 3 3)) - -;;; Error tests - -(deftest nunion.error.1 - (signals-error (nunion) program-error) - t) - -(deftest nunion.error.2 - (signals-error (nunion nil) program-error) - t) - -(deftest nunion.error.3 - (signals-error (nunion nil nil :bad t) program-error) - t) - -(deftest nunion.error.4 - (signals-error (nunion nil nil :key) program-error) - t) - -(deftest nunion.error.5 - (signals-error (nunion nil nil 1 2) program-error) - t) - -(deftest nunion.error.6 - (signals-error (nunion nil nil :bad t :allow-other-keys nil) program-error) - t) - -(deftest nunion.error.7 - (signals-error (nunion (list 1 2) (list 3 4) :test #'identity) program-error) - t) - -(deftest nunion.error.8 - (signals-error (nunion (list 1 2) (list 3 4) :test-not #'identity) program-error) - t) - -(deftest nunion.error.9 - (signals-error (nunion (list 1 2) (list 3 4) :key #'cons) program-error) - t) - -(deftest nunion.error.10 - (signals-error (nunion (list 1 2) (list 3 4) :key #'car) type-error) - t) - -(deftest nunion.error.11 - (signals-error (nunion (list 1 2 3) (list* 4 5 6)) type-error) - t) - -(deftest nunion.error.12 - (signals-error (nunion (list* 1 2 3) (list 4 5 6)) type-error) - t) - -(deftest nunion.error.13 - (check-type-error #'(lambda (x) (nunion x (list 1 2 3))) #'listp) - nil) - -(deftest nunion.error.14 - (check-type-error #'(lambda (x) (nunion (list 1 2 3) x)) #'listp) - nil) diff --git a/t/ansi-test/cons/pairlis.lsp b/t/ansi-test/cons/pairlis.lsp deleted file mode 100644 index 86c4424..0000000 --- a/t/ansi-test/cons/pairlis.lsp +++ /dev/null @@ -1,100 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Apr 20 07:30:55 2003 -;;;; Contains: Tests of PAIRLIS - - - - - -;; Pairlis has two legal behaviors: the pairs -;; can be prepended in the same order, or in the -;; reverse order, that they appear in the first -;; two arguments - -(defun my-pairlis (x y &optional alist) - (if (null x) - alist - (acons (car x) (car y) - (my-pairlis (cdr x) (cdr y) alist)))) - -(deftest pairlis.1 - (pairlis nil nil nil) - nil) - -(deftest pairlis.2 - (pairlis '(a) '(b) nil) - ((a . b))) - -(deftest pairlis.3 - (let* ((x (copy-list '(a b c d e))) - (xcopy (make-scaffold-copy x)) - (y (copy-list '(1 2 3 4 5))) - (ycopy (make-scaffold-copy y)) - (result (pairlis x y)) - (expected (my-pairlis x y))) - (and - (check-scaffold-copy x xcopy) - (check-scaffold-copy y ycopy) - (or - (equal result expected) - (equal result (reverse expected))) - t)) - t) - -(deftest pairlis.4 - (let* ((x (copy-list '(a b c d e))) - (xcopy (make-scaffold-copy x)) - (y (copy-list '(1 2 3 4 5))) - (ycopy (make-scaffold-copy y)) - (z '((x . 10) (y . 20))) - (zcopy (make-scaffold-copy z)) - (result (pairlis x y z)) - (expected (my-pairlis x y z))) - (and - (check-scaffold-copy x xcopy) - (check-scaffold-copy y ycopy) - (check-scaffold-copy z zcopy) - (eqt (cdr (cddr (cddr result))) z) - (or - (equal result expected) - (equal result (append (reverse (subseq expected 0 5)) - (subseq expected 5)))) - t)) - t) - -(def-fold-test pairlis.fold.1 (pairlis '(a b) '(c d))) - -;;; Error tests - -(deftest pairlis.error.1 - (signals-error (pairlis) program-error) - t) - -(deftest pairlis.error.2 - (signals-error (pairlis nil) program-error) - t) - -(deftest pairlis.error.3 - (signals-error (pairlis nil nil nil nil) program-error) - t) - -(deftest pairlis.error.4 - (signals-error (pairlis 'a '(1)) type-error) - t) - -(deftest pairlis.error.5 - (signals-error (pairlis '(a) 'b) type-error) - t) - -(deftest pairlis.error.6 - (signals-error (pairlis '(a . b) '(c . d)) type-error) - t) - -(deftest pairlis.error.7 - (check-type-error #'(lambda (x) (pairlis x '(a b))) #'listp) - nil) - -(deftest pairlis.error.8 - (check-type-error #'(lambda (x) (pairlis '(a b) x)) #'listp) - nil) diff --git a/t/ansi-test/cons/pop.lsp b/t/ansi-test/cons/pop.lsp deleted file mode 100644 index 5751497..0000000 --- a/t/ansi-test/cons/pop.lsp +++ /dev/null @@ -1,53 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 19 22:27:18 2003 -;;;; Contains: Tests of POP - - - - - -(deftest pop.1 - (let ((x (copy-tree '(a b c)))) - (let ((y (pop x))) - (list x y))) - ((b c) a)) - -(deftest pop.2 - (let ((x nil)) - (let ((y (pop x))) - (list x y))) - (nil nil)) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest pop.3 - (macrolet - ((%m (z) z)) - (let ((x (list 'a 'b 'c))) - (values - (pop (expand-in-current-env (%m x))) - x))) - a (b c)) - -;;; Confirm argument is executed just once. -(deftest pop.order.1 - (let ((i 0) - (a (vector (list 'a 'b 'c)))) - (pop (aref a (progn (incf i) 0))) - (values a i)) - #((b c)) 1) - -(deftest push-and-pop - (let* ((x (copy-tree '(a b))) - (y x)) - (push 'c x) - (and - (eqt (cdr x) y) - (pop x))) - c) - -(def-macro-test pop.error.1 (pop x)) - -;;; Need to add tests of POP vs. various accessors diff --git a/t/ansi-test/cons/push.lsp b/t/ansi-test/cons/push.lsp deleted file mode 100644 index 1ec98f9..0000000 --- a/t/ansi-test/cons/push.lsp +++ /dev/null @@ -1,80 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 19 22:05:34 2003 -;;;; Contains: Tests of PUSH - - - - - -;;; See also places.lsp - -(deftest push.1 - (let ((x nil)) - (push 'a x)) - (a)) - -(deftest push.2 - (let ((x 'b)) - (push 'a x) - (push 'c x)) - (c a . b)) - -(deftest push.3 - (let ((x (copy-tree '(a)))) - (push x x) - (and - (eqt (car x) (cdr x)) - x)) - ((a) a)) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest push.4 - (macrolet - ((%m (z) z)) - (let ((x nil)) - (values - (push (expand-in-current-env (%m 1)) x) - x))) - (1) (1)) - -(deftest push.5 - (macrolet - ((%m (z) z)) - (let ((x nil)) - (values - (push 1 (expand-in-current-env (%m x))) - x))) - (1) (1)) - -(deftest push.order.1 - (let ((x (list nil)) (i 0) a b) - (values - (push (progn (setf a (incf i)) 'z) - (car (progn (setf b (incf i)) x))) - x - i a b)) - (z) ((z)) 2 1 2) - -(deftest push.order.2 - (let ((x (vector nil nil nil nil)) - (y (vector 'a 'b 'c 'd)) - (i 1)) - (push (aref y (incf i)) (aref x (incf i))) - (values x y i)) - #(nil nil nil (c)) - #(a b c d) - 3) - -(deftest push.order.3 - (let ((x '(a b c))) - (values - (push (progn (setq x '(d e)) 'z) x) - x)) - (z d e) (z d e)) - -(def-macro-test push.error.1 (push x y)) - -;;; Need to add push vs. various accessors diff --git a/t/ansi-test/cons/pushnew.lsp b/t/ansi-test/cons/pushnew.lsp deleted file mode 100644 index 57d0030..0000000 --- a/t/ansi-test/cons/pushnew.lsp +++ /dev/null @@ -1,294 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 19 22:28:35 2003 -;;;; Contains: Tests of PUSHNEW - - - - - -(deftest pushnew.1 - (let ((x nil)) - (let ((y (pushnew 'a x))) - (and - (eqt x y) - (equal x '(a)) - t))) - t) - -(deftest pushnew.2 - (let* ((x (copy-tree '(b c d a k f q))) - (y (pushnew 'a x))) - (and - (eqt x y) - x)) - (b c d a k f q)) - -(deftest pushnew.3 - (let* ((x (copy-tree '(1 2 3 4 5 6 7 8))) - (y (pushnew 7 x))) - (and - (eqt x y) - x)) - (1 2 3 4 5 6 7 8)) - -(deftest pushnew.4 - (let* ((x (copy-tree '((a b) 1 "and" c d e))) - (y (pushnew (copy-tree '(c d)) x - :test 'equal))) - (and (eqt x y) - x)) - ((c d) (a b) 1 "and" c d e)) - -(deftest pushnew.5 - (let* ((x (copy-tree '((a b) 1 "and" c d e))) - (y (pushnew (copy-tree '(a b)) x - :test 'equal))) - (and - (eqt x y) - x)) - ((a b) 1 "and" c d e)) - -(deftest pushnew.6 - (let* ((x (copy-tree '((a b) (c e) (d f) (g h)))) - (y (pushnew (copy-tree '(d i)) x :key #'car)) - (z (pushnew (copy-tree '(z 10)) x :key #'car))) - (and (eqt y (cdr z)) - (eqt z x) - x)) - ((z 10) (a b) (c e) (d f) (g h))) - -(deftest pushnew.7 - (let* ((x (copy-tree '(("abc" 1) ("def" 2) ("ghi" 3)))) - (y (pushnew (copy-tree '("def" 4)) x - :key #'car :test #'string=)) - (z (pushnew (copy-tree '("xyz" 10)) - x - :key #'car :test #'string=))) - (and - (eqt y (cdr x)) - (eqt x z) - x)) - (("xyz" 10) ("abc" 1) ("def" 2) ("ghi" 3))) - -(deftest pushnew.8 - (let* ((x (copy-tree '(("abc" 1) ("def" 2) ("ghi" 3)))) - (y (pushnew (copy-tree '("def" 4)) x - :key #'car :test-not (complement #'string=))) - (z (pushnew (copy-tree '("xyz" 10)) x - :key #'car :test-not (complement #'string=)))) - (and - (eqt y (cdr x)) - (eqt x z) - x)) - (("xyz" 10) ("abc" 1) ("def" 2) ("ghi" 3))) - -(deftest pushnew.9 - (let* ((x (copy-tree '(("abc" 1) ("def" 2) ("ghi" 3)))) - (y (pushnew (copy-tree '("def" 4)) x - :key 'car :test-not (complement #'string=))) - (z (pushnew (copy-tree '("xyz" 10)) x - :key 'car :test-not (complement #'string=)))) - (and - (eqt y (cdr x)) - (eqt x z) - x)) - (("xyz" 10) ("abc" 1) ("def" 2) ("ghi" 3))) - -;; Check that a NIL :key argument is the same as no key argument at all -(deftest pushnew.10 - (let* ((x (list 'a 'b 'c 'd)) - (result (pushnew 'z x :key nil))) - result) - (z a b c d)) - -;; Check that a NIL :key argument is the same as no key argument at all -(deftest pushnew.11 - (let* ((x (copy-tree '((a b) 1 "and" c d e))) - (y (pushnew (copy-tree '(a b)) x - :test 'equal :key nil))) - (and - (eqt x y) - x)) - ((a b) 1 "and" c d e)) - -(deftest pushnew.12 - (let ((i 0) x y z (d '(b c))) - (values - (pushnew (progn (setf x (incf i)) 'a) - d - :key (progn (setf y (incf i)) #'identity) - :test (progn (setf z (incf i)) #'eql)) - d i x y z)) - (a b c) (a b c) - 3 1 2 3) - -(deftest pushnew.13 - (let ((i 0) x y z (d '(b c))) - (values - (pushnew (progn (setf x (incf i)) 'a) - d - :key (progn (setf y (incf i)) #'identity) - :test-not (progn (setf z (incf i)) (complement #'eql))) - d i x y z)) - (a b c) (a b c) - 3 1 2 3) - -(deftest pushnew.14 - (let ((i 0) x y z (d '(b c))) - (values - (pushnew (progn (setf x (incf i)) 'a) - d - :test (progn (setf z (incf i)) #'eql) - :key (progn (setf y (incf i)) #'identity)) - d i x y z)) - (a b c) (a b c) - 3 1 3 2) - -(deftest pushnew.15 - (let ((i 0) x y z (d '(b c))) - (values - (pushnew (progn (setf x (incf i)) 'a) - d - :test-not (progn (setf z (incf i)) (complement #'eql)) - :key (progn (setf y (incf i)) #'identity)) - d i x y z)) - (a b c) (a b c) - 3 1 3 2) - -(deftest pushnew.16 - (let ((x '(1 2 3))) - (values - (pushnew 10 x :test #'<=) - x)) - (10 1 2 3) - (10 1 2 3)) - -(deftest pushnew.17 - (let ((x '(1 2 3))) - (values - (pushnew 10 x :test #'>) - x)) - (1 2 3) - (1 2 3)) -(deftest pushnew.18 - (let ((x '(1 2 3))) - (values - (pushnew 10 x :test-not #'>) - x)) - (10 1 2 3) - (10 1 2 3)) - -(deftest pushnew.19 - (let ((x '(1 2 3))) - (values - (pushnew 10 x :test-not #'<=) - x)) - (1 2 3) - (1 2 3)) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest pushnew.20 - (macrolet - ((%m (z) z)) - (let ((x nil)) - (values - (pushnew (expand-in-current-env (%m 1)) x) - x))) - (1) (1)) - -(deftest pushnew.21 - (macrolet - ((%m (z) z)) - (let ((x nil)) - (values - (pushnew 1 (expand-in-current-env (%m x))) - x))) - (1) (1)) - -(deftest pushnew.22 - (macrolet - ((%m (z) z)) - (let ((x '(a b))) - (values - (pushnew 1 x :test (expand-in-current-env (%m #'eql))) - x))) - (1 a b) (1 a b)) - -(deftest pushnew.23 - (macrolet - ((%m (z) z)) - (let ((x '(1))) - (values - (pushnew 1 x :test-not (expand-in-current-env (%m #'eql))) - x))) - (1 1) (1 1)) - -(deftest pushnew.24 - (macrolet - ((%m (z) z)) - (let ((x '(3))) - (values - (pushnew 1 x :key (expand-in-current-env (%m #'evenp))) - x))) - (3) (3)) - -(defharmless pushnew.test-and-test-not.1 - (let ((x '(b c))) (pushnew 'a x :test #'eql :test-not #'eql))) - -(defharmless pushnew.test-and-test-not.2 - (let ((x '(b c))) (pushnew 'a x :test-not #'eql :test #'eql))) - - -(deftest pushnew.order.1 - (let ((x (vector nil nil nil nil)) - (y (vector 'a 'b 'c 'd)) - (i 1)) - (pushnew (aref y (incf i)) (aref x (incf i))) - (values x y i)) - #(nil nil nil (c)) - #(a b c d) - 3) - -(deftest pushnew.order.2 - (let ((x (vector nil nil nil nil nil)) - (y (vector 'a 'b 'c 'd 'e)) - (i 1)) - (pushnew (aref y (incf i)) (aref x (incf i)) - :test (progn (incf i) #'eql)) - (values x y i)) - #(nil nil nil (c) nil) - #(a b c d e) - 4) - -(deftest pushnew.order.3 - (let ((x '(a b c))) - (values - (pushnew (progn (setq x '(d e)) 'z) x) - x)) - (z d e) (z d e)) - -(deftest pushnew.error.1 - (signals-error - (let ((x '(a b))) - (pushnew 'c x :test #'identity)) - program-error) - t) - -(deftest pushnew.error.2 - (signals-error - (let ((x '(a b))) - (pushnew 'c x :test-not #'identity)) - program-error) - t) - -(deftest pushnew.error.3 - (signals-error - (let ((x '(a b))) - (pushnew 'c x :key #'cons)) - program-error) - t) - -(def-macro-test pushnew.error.4 (pushnew x y)) diff --git a/t/ansi-test/cons/rassoc-if-not.lsp b/t/ansi-test/cons/rassoc-if-not.lsp deleted file mode 100644 index cef3097..0000000 --- a/t/ansi-test/cons/rassoc-if-not.lsp +++ /dev/null @@ -1,146 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Apr 20 07:35:27 2003 -;;;; Contains: Tests of RASSOC-IF-NOT - - - - - -(deftest rassoc-if-not.1 - (let* ((x (rev-assoc-list '((1 . a) (3 . b) (6 . c) (7 . d)))) - (xcopy (make-scaffold-copy x)) - (result (rassoc-if-not #'oddp x))) - (and - (check-scaffold-copy x xcopy) - (eqt result (third x)) - result)) - (c . 6)) - -(deftest rassoc-if-not.2 - (let* ((x (rev-assoc-list '((1 . a) (3 . b) (6 . c) (7 . d)))) - (xcopy (make-scaffold-copy x)) - (result (rassoc-if-not #'evenp x :key #'1+))) - (and - (check-scaffold-copy x xcopy) - (eqt result (third x)) - result)) - (c . 6)) - -(deftest rassoc-if-not.3 - (let* ((x (rev-assoc-list '((1 . a) nil (3 . b) (6 . c) (7 . d)))) - (xcopy (make-scaffold-copy x)) - (result (rassoc-if-not #'oddp x))) - (and - (check-scaffold-copy x xcopy) - (eqt result (fourth x)) - result)) - (c . 6)) - -(deftest rassoc-if-not.4 - (rassoc-if-not #'identity - (rev-assoc-list '((a . b) nil (c . d) (nil . e) (f . g)))) - (e)) - -;;; Order of argument evaluation - -(deftest rassoc-if-not.order.1 - (let ((i 0) x y) - (values - (rassoc-if-not (progn (setf x (incf i)) #'identity) - (progn (setf y (incf i)) - '((1 . a) (2 . b) (17) (4 . d)))) - i x y)) - (17) 2 1 2) - -(deftest rassoc-if-not.order.2 - (let ((i 0) x y z) - (values - (rassoc-if-not (progn (setf x (incf i)) #'identity) - (progn (setf y (incf i)) - '((1 . a) (2 . b) (17) (4 . d))) - :key (progn (setf z (incf i)) #'null)) - i x y z)) - (1 . a) 3 1 2 3) - -;;; Keyword tests - -(deftest rassoc-if-not.allow-other-keys.1 - (rassoc-if-not #'identity '((1 . a) (2) (3 . c)) :bad t :allow-other-keys t) - (2)) - -(deftest rassoc-if-not.allow-other-keys.2 - (rassoc-if-not #'values '((1 . a) (2) (3 . c)) :allow-other-keys t :bad t) - (2)) - -(deftest rassoc-if-not.allow-other-keys.3 - (rassoc-if-not #'not '((1 . a) (2) (3 . c)) :allow-other-keys t :bad t - :key 'not) - (2)) - -(deftest rassoc-if-not.allow-other-keys.4 - (rassoc-if-not #'identity '((1 . a) (2) (3 . c)) :allow-other-keys t) - (2)) - -(deftest rassoc-if-not.allow-other-keys.5 - (rassoc-if-not #'identity '((1 . a) (2) (3 . c)) :allow-other-keys nil) - (2)) - -(deftest rassoc-if-not.allow-other-keys.6 - (rassoc-if-not #'identity '((1 . a) (2) (3 . c)) :allow-other-keys t - :allow-other-keys nil :bad t) - (2)) - -(deftest rassoc-if-not.keywords.7 - (rassoc-if-not #'identity '((1 . a) (2) (3 . c)) :key #'not :key nil) - (1 . a)) - -;;; Error tests - -(deftest rassoc-if-not.error.1 - (signals-error (rassoc-if-not) program-error) - t) - -(deftest rassoc-if-not.error.2 - (signals-error (rassoc-if-not #'null) program-error) - t) - -(deftest rassoc-if-not.error.3 - (signals-error (rassoc-if-not #'null nil :bad t) program-error) - t) - -(deftest rassoc-if-not.error.4 - (signals-error (rassoc-if-not #'null nil :key) program-error) - t) - -(deftest rassoc-if-not.error.5 - (signals-error (rassoc-if-not #'null nil 1 1) program-error) - t) - -(deftest rassoc-if-not.error.6 - (signals-error (rassoc-if-not #'null nil :bad t :allow-other-keys nil) program-error) - t) - -(deftest rassoc-if-not.error.7 - (signals-error (rassoc-if-not #'cons '((a . b)(c . d))) program-error) - t) - -(deftest rassoc-if-not.error.8 - (signals-error (rassoc-if-not #'car '((a . b)(c . d))) type-error) - t) - -(deftest rassoc-if-not.error.9 - (signals-error (rassoc-if-not #'identity '((a . b)(c . d)) :key #'cons) program-error) - t) - -(deftest rassoc-if-not.error.10 - (signals-error (rassoc-if-not #'identity '((a . b)(c . d)) :key #'car) type-error) - t) - -(deftest rassoc-if-not.error.11 - (signals-error (rassoc-if-not #'identity '((a . b) . c)) type-error) - t) - -(deftest rassoc-if-not.error.12 - (check-type-error #'(lambda (x) (rassoc-if-not #'identity x)) #'listp) - nil) diff --git a/t/ansi-test/cons/rassoc-if.lsp b/t/ansi-test/cons/rassoc-if.lsp deleted file mode 100644 index 240fa52..0000000 --- a/t/ansi-test/cons/rassoc-if.lsp +++ /dev/null @@ -1,142 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Apr 20 07:34:59 2003 -;;;; Contains: Tests of RASSOC-IF - - - - - -(deftest rassoc-if.1 - (let* ((x (rev-assoc-list '((1 . a) (3 . b) (6 . c) (7 . d)))) - (xcopy (make-scaffold-copy x)) - (result (rassoc-if #'evenp x))) - (and - (check-scaffold-copy x xcopy) - (eqt result (third x)) - result)) - (c . 6)) - -(deftest rassoc-if.2 - (let* ((x (rev-assoc-list '((1 . a) (3 . b) (6 . c) (7 . d)))) - (xcopy (make-scaffold-copy x)) - (result (rassoc-if #'oddp x :key #'1+))) - (and - (check-scaffold-copy x xcopy) - (eqt result (third x)) - result)) - (c . 6)) - -(deftest rassoc-if.3 - (let* ((x (rev-assoc-list '((1 . a) nil (3 . b) (6 . c) (7 . d)))) - (xcopy (make-scaffold-copy x)) - (result (rassoc-if #'evenp x))) - (and - (check-scaffold-copy x xcopy) - (eqt result (fourth x)) - result)) - (c . 6)) - -(deftest rassoc-if.4 - (rassoc-if #'null - (rev-assoc-list '((a . b) nil (c . d) (nil . e) (f . g)))) - (e)) - -;;; Order of argument evaluation - -(deftest rassoc-if.order.1 - (let ((i 0) x y) - (values - (rassoc-if (progn (setf x (incf i)) #'null) - (progn (setf y (incf i)) - '((1 . a) (2 . b) (17) (4 . d)))) - i x y)) - (17) 2 1 2) - -(deftest rassoc-if.order.2 - (let ((i 0) x y z) - (values - (rassoc-if (progn (setf x (incf i)) #'null) - (progn (setf y (incf i)) - '((1 . a) (2 . b) (17) (4 . d))) - :key (progn (setf z (incf i)) #'null)) - i x y z)) - (1 . a) 3 1 2 3) - - -;;; Keyword tests - -(deftest rassoc-if.allow-other-keys.1 - (rassoc-if #'null '((1 . a) (2) (3 . c)) :bad t :allow-other-keys t) - (2)) - -(deftest rassoc-if.allow-other-keys.2 - (rassoc-if #'null '((1 . a) (2) (3 . c)) :allow-other-keys t :bad t) - (2)) - -(deftest rassoc-if.allow-other-keys.3 - (rassoc-if #'identity '((1 . a) (2) (3 . c)) :allow-other-keys t :bad t - :key 'not) - (2)) - -(deftest rassoc-if.allow-other-keys.4 - (rassoc-if #'null '((1 . a) (2) (3 . c)) :allow-other-keys t) - (2)) - -(deftest rassoc-if.allow-other-keys.5 - (rassoc-if #'null '((1 . a) (2) (3 . c)) :allow-other-keys nil) - (2)) - -(deftest rassoc-if.keywords.6 - (rassoc-if #'identity '((1 . a) (2) (3 . c)) :key #'not :key #'identity) - (2)) - -;;; Error tests - -(deftest rassoc-if.error.1 - (signals-error (rassoc-if) program-error) - t) - -(deftest rassoc-if.error.2 - (signals-error (rassoc-if #'null) program-error) - t) - -(deftest rassoc-if.error.3 - (signals-error (rassoc-if #'null nil :bad t) program-error) - t) - -(deftest rassoc-if.error.4 - (signals-error (rassoc-if #'null nil :key) program-error) - t) - -(deftest rassoc-if.error.5 - (signals-error (rassoc-if #'null nil 1 1) program-error) - t) - -(deftest rassoc-if.error.6 - (signals-error (rassoc-if #'null nil :bad t :allow-other-keys nil) program-error) - t) - -(deftest rassoc-if.error.7 - (signals-error (rassoc-if #'cons '((a . b)(c . d))) program-error) - t) - -(deftest rassoc-if.error.8 - (signals-error (rassoc-if #'car '((a . b)(c . d))) type-error) - t) - -(deftest rassoc-if.error.9 - (signals-error (rassoc-if #'identity '((a . b)(c . d)) :key #'cons) program-error) - t) - -(deftest rassoc-if.error.10 - (signals-error (rassoc-if #'identity '((a . b)(c . d)) :key #'car) type-error) - t) - -(deftest rassoc-if.error.11 - (signals-error (rassoc-if #'not '((a . b) . c)) type-error) - t) - -(deftest rassoc-if.error.12 - (check-type-error #'(lambda (x) (rassoc-if #'identity x)) #'listp) - nil) diff --git a/t/ansi-test/cons/rassoc.lsp b/t/ansi-test/cons/rassoc.lsp deleted file mode 100644 index 6410341..0000000 --- a/t/ansi-test/cons/rassoc.lsp +++ /dev/null @@ -1,309 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Apr 20 07:33:49 2003 -;;;; Contains: Tests of RASSOC - - - - - -(deftest rassoc.1 - (rassoc nil nil) - nil) - -(deftest rassoc.2 - (rassoc nil '(nil)) - nil) - -(deftest rassoc.3 - (rassoc nil (rev-assoc-list '(nil (nil . 2) (a . b)))) - (2 . nil)) - -(deftest rassoc.4 - (rassoc nil '((a . b) (c . d))) - nil) - -(deftest rassoc.5 - (rassoc 'a '((b . a))) - (b . a)) - -(deftest rassoc.6 - (rassoc 'a (rev-assoc-list '((:a . b) (#:a . c) (a . d) (a . e) (z . f)))) - (d . a)) - -(deftest rassoc.7 - (let* ((x (copy-tree (rev-assoc-list '((a . b) (b . c) (c . d))))) - (xcopy (make-scaffold-copy x)) - (result (rassoc 'b x))) - (and - (eqt result (second x)) - (check-scaffold-copy x xcopy))) - t) - -(deftest rassoc.8 - (rassoc 1 (rev-assoc-list '((0 . a) (1 . b) (2 . c)))) - (b . 1)) - -(deftest rassoc.9 - (rassoc (copy-seq "abc") - (rev-assoc-list '((abc . 1) ("abc" . 2) ("abc" . 3)))) - nil) - -(deftest rassoc.10 - (rassoc (copy-list '(a)) - (copy-tree (rev-assoc-list '(((a) b) ((a) (c)))))) - nil) - -(deftest rassoc.11 - (let ((x (list 'a 'b))) - (rassoc x - (rev-assoc-list `(((a b) c) (,x . d) (,x . e) ((a b) 1))))) - (d a b)) - - -(deftest rassoc.12 - (rassoc #\e - (copy-tree - (rev-assoc-list '(("abefd" . 1) ("aevgd" . 2) ("edada" . 3)))) - :key #'(lambda (x) (schar x 1))) - (2 . "aevgd")) - -(deftest rassoc.13 - (rassoc nil - (copy-tree - (rev-assoc-list - '(((a) . b) ( nil . c ) ((nil) . d)))) - :key #'car) - (c)) - -(deftest rassoc.14 - (rassoc (copy-seq "abc") - (copy-tree - (rev-assoc-list - '((abc . 1) ("abc" . 2) ("abc" . 3)))) - :test #'equal) - (2 . "abc")) - -(deftest rassoc.15 - (rassoc (copy-seq "abc") - (copy-tree - (rev-assoc-list - '((abc . 1) ("abc" . 2) ("abc" . 3)))) - :test #'equalp) - (2 . "abc")) - -(deftest rassoc.16 - (rassoc (copy-list '(a)) - (copy-tree - (rev-assoc-list '(((a) b) ((a) (c))))) - :test #'equal) - ((b) a)) - -(deftest rassoc.17 - (rassoc (copy-seq "abc") - (copy-tree - (rev-assoc-list - '((abc . 1) (a . a) (b . b) ("abc" . 2) ("abc" . 3)))) - :test-not (complement #'equalp)) - (2 . "abc")) - -(deftest rassoc.18 - (rassoc 'a - (copy-tree - (rev-assoc-list - '((a . d)(b . c)))) - :test-not #'eq) - (c . b)) - -(deftest rassoc.19 - (rassoc 'a - (copy-tree - (rev-assoc-list - '((a . d)(b . c)))) - :test (complement #'eq)) - (c . b)) - -(deftest rassoc.20 - (rassoc "a" - (copy-tree - (rev-assoc-list - '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)))) - :key #'(lambda (x) (and (stringp x) (string-downcase x))) - :test #'equal) - (6 . "A")) - -(deftest rassoc.21 - (rassoc "a" - (copy-tree - (rev-assoc-list - '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)))) - :key #'(lambda (x) (and (stringp x) x)) - :test #'equal) - (3 . "a")) - -(deftest rassoc.22 - (rassoc "a" - (copy-tree - (rev-assoc-list - '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)))) - :key #'(lambda (x) (and (stringp x) (string-downcase x))) - :test-not (complement #'equal)) - (6 . "A")) - -(deftest rassoc.23 - (rassoc "a" - (copy-tree - (rev-assoc-list - '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)))) - :key #'(lambda (x) (and (stringp x) x)) - :test-not (complement #'equal)) - (3 . "a")) - -;; Check that it works when test returns a true value -;; other than T - -(deftest rassoc.24 - (rassoc 'a - (copy-tree - (rev-assoc-list - '((b . 1) (a . 2) (c . 3)))) - :test #'(lambda (x y) (and (eqt x y) 'matched))) - (2 . a)) - -;; Check that the order of the arguments to :test is correct - -(deftest rassoc.25 - (block fail - (rassoc 'a '((1 . b) (2 . c) (3 . a)) - :test #'(lambda (x y) - (unless (eqt x 'a) (return-from fail 'fail)) - (eqt x y)))) - (3 . a)) - -(deftest rassoc.26 - (rassoc 10 '((a . 1) (b . 5) (c . 10) (d . 15) (e . 40)) - :test #'<) - (d . 15)) - -(deftest rassoc.27 - (rassoc 10 '((a . 1) (b . 5) (c . 10) (d . 15) (e . 40)) - :test-not #'>=) - (d . 15)) - -(defharmless rassoc.test-and-test-not.1 - (rassoc 'a '((x . b) (y . a) (z . c)) :test #'eql :test-not #'eql)) - -(defharmless rassoc.test-and-test-not.2 - (rassoc 'a '((x . b) (y . a) (z . c)) :test-not #'eql :test #'eql)) - -;;; Order of argument evaluation - -(deftest rassoc.order.1 - (let ((i 0) x y) - (values - (rassoc (progn (setf x (incf i)) 'c) - (progn (setf y (incf i)) '((1 . a) (2 . b) (3 . c) (4 . c)))) - i x y)) - (3 . c) 2 1 2) - -(deftest rassoc.order.2 - (let ((i 0) x y z) - (values - (rassoc (progn (setf x (incf i)) 'c) - (progn (setf y (incf i)) '((1 . a) (2 . b) (3 . c) (4 . c))) - :test (progn (setf z (incf i)) #'eql)) - i x y z)) - (3 . c) 3 1 2 3) - -(deftest rassoc.order.3 - (let ((i 0) x y) - (values - (rassoc (progn (setf x (incf i)) 'c) - (progn (setf y (incf i)) '((1 . a) (2 . b) (3 . c) (4 . c))) - :test #'eql) - i x y)) - (3 . c) 2 1 2) - -(deftest rassoc.order.4 - (let ((i 0) x y z w) - (values - (rassoc (progn (setf x (incf i)) 'c) - (progn (setf y (incf i)) '((1 . a) (2 . b) (3 . c) (4 . c))) - :key (progn (setf z (incf i)) #'identity) - :key (progn (setf w (incf i)) #'not)) - i x y z w)) - (3 . c) 4 1 2 3 4) - -;;; Keyword tests - -(deftest rassoc.allow-other-keys.1 - (rassoc 'b '((1 . a) (2 . b) (3 . c)) :bad t :allow-other-keys t) - (2 . b)) - -(deftest rassoc.allow-other-keys.2 - (rassoc 'b '((1 . a) (2 . b) (3 . c)) :allow-other-keys t :bad t) - (2 . b)) - -(deftest rassoc.allow-other-keys.3 - (rassoc 'a '((1 . a) (2 . b) (3 . c)) :allow-other-keys t :bad t - :test-not #'eql) - (2 . b)) - -(deftest rassoc.allow-other-keys.4 - (rassoc 'b '((1 . a) (2 . b) (3 . c)) :allow-other-keys t) - (2 . b)) - -(deftest rassoc.allow-other-keys.5 - (rassoc 'b '((1 . a) (2 . b) (3 . c)) :allow-other-keys nil) - (2 . b)) - -(deftest rassoc.keywords.6 - (rassoc 'b '((1 . a) (2 . b) (3 . c)) - :test #'eql :test (complement #'eql)) - (2 . b)) - -;;; Error tests - -(deftest rassoc.error.1 - (signals-error (rassoc) program-error) - t) - -(deftest rassoc.error.2 - (signals-error (rassoc nil) program-error) - t) - -(deftest rassoc.error.3 - (signals-error (rassoc nil nil :bad t) program-error) - t) - -(deftest rassoc.error.4 - (signals-error (rassoc nil nil :key) program-error) - t) - -(deftest rassoc.error.5 - (signals-error (rassoc nil nil 1 1) program-error) - t) - -(deftest rassoc.error.6 - (signals-error (rassoc nil nil :bad t :allow-other-keys nil) program-error) - t) - -(deftest rassoc.error.7 - (signals-error (rassoc 'a '((b . a)(c . d)) :test #'identity) program-error) - t) - -(deftest rassoc.error.8 - (signals-error (rassoc 'a '((b . a)(c . d)) :test-not #'identity) program-error) - t) - -(deftest rassoc.error.9 - (signals-error (rassoc 'a '((b . a)(c . d)) :key #'cons) program-error) - t) - -(deftest rassoc.error.10 - (signals-error (rassoc 'z '((a . b) . c)) type-error) - t) - -(deftest rassoci.error.11 - (check-type-error #'(lambda (x) (rassoc 'a x)) #'listp) - nil) diff --git a/t/ansi-test/cons/remf.lsp b/t/ansi-test/cons/remf.lsp deleted file mode 100644 index fab804f..0000000 --- a/t/ansi-test/cons/remf.lsp +++ /dev/null @@ -1,96 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Apr 20 07:38:18 2003 -;;;; Contains: Tests of REMF - - - - - -(deftest remf.1 - (let ((x nil)) - (values (remf x 'a) x)) - nil ()) - -(deftest remf.2 - (let ((x (list 'a 'b))) - (values (not (null (remf x 'a))) x)) - t ()) - -(deftest remf.3 - (let ((x (list 'a 'b 'a 'c))) - (values (not (null (remf x 'a))) x)) - t (a c)) - -(deftest remf.4 - (let ((x (list 'a 'b 'c 'd))) - (values - (and (remf x 'c) t) - (loop - for ptr on x by #'cddr count - (not (eqt (car ptr) 'a))))) - t 0) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest remf.5 - (macrolet - ((%m (z) z)) - (let ((x nil)) - (values - (remf (expand-in-current-env (%m x)) 'a) - x))) - nil nil) - -(deftest remf.6 - (macrolet - ((%m (z) z)) - (let ((x (list 'a 'b))) - (values - (notnot (remf (expand-in-current-env (%m x)) 'a)) - x))) - t nil) - -(deftest remf.7 - (macrolet - ((%m (z) z)) - (let ((x (list 'a 'b 'c 'd))) - (values - (notnot (remf x (expand-in-current-env (%m 'a)))) - x))) - t (c d)) - - - -(deftest remf.order.1 - (let ((i 0) x y - (p (make-array 1 :initial-element (copy-list '(a b c d e f))))) - (values - (notnot - (remf (aref p (progn (setf x (incf i)) 0)) - (progn (setf y (incf i)) - 'c))) - (aref p 0) - i x y)) - t (a b e f) 2 1 2) - -(deftest remf.order.2 - (let ((x (copy-seq #(nil :a :b))) - (pa (vector (list :a 1) (list :b 2) (list :c 3) (list :d 4))) - (i 0)) - (values - (not (remf (aref pa (incf i)) (aref x (incf i)))) - pa)) - nil #((:a 1) nil (:c 3) (:d 4))) - -(deftest remf.order.3 - (let ((x (list 'a 'b 'c 'd))) - (progn - "See CLtS 5.1.3" - (values - (remf x (progn (setq x (list 'e 'f)) 'a)) - x))) - nil (e f)) - -(def-macro-test remf.error.1 (remf x 'a)) diff --git a/t/ansi-test/cons/rest.lsp b/t/ansi-test/cons/rest.lsp deleted file mode 100644 index ef16a8a..0000000 --- a/t/ansi-test/cons/rest.lsp +++ /dev/null @@ -1,27 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 19 22:49:14 2003 -;;;; Contains: Tests of REST - - - - - -(deftest rest.1 - (rest (list 'a 'b 'c)) - (b c)) - -(deftest rest.order.1 - (let ((i 0)) - (values (rest (progn (incf i) '(a b))) i)) - (b) 1) - -(deftest rest.error.1 - (signals-error (rest) program-error) - t) - -(deftest rest.error.2 - (signals-error (rest nil nil) program-error) - t) - - diff --git a/t/ansi-test/cons/revappend.lsp b/t/ansi-test/cons/revappend.lsp deleted file mode 100644 index 2142f55..0000000 --- a/t/ansi-test/cons/revappend.lsp +++ /dev/null @@ -1,63 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 19 22:37:43 2003 -;;;; Contains: Tests of REVAPPEND - - - - - -(deftest revappend.1 - (let* ((x (list 'a 'b 'c)) - (y (list 'd 'e 'f)) - (xcopy (make-scaffold-copy x)) - (ycopy (make-scaffold-copy y)) - ) - (let ((result (revappend x y))) - (and - (check-scaffold-copy x xcopy) - (check-scaffold-copy y ycopy) - (eqt (cdddr result) y) - result))) - (c b a d e f)) - -(deftest revappend.2 - (revappend (copy-tree '(a b c d e)) 10) - (e d c b a . 10)) - -(deftest revappend.3 - (revappend nil 'a) - a) - -(deftest revappend.4 - (revappend (copy-tree '(a (b c) d)) nil) - (d (b c) a)) - -(deftest revappend.order.1 - (let ((i 0) x y) - (values - (revappend (progn (setf x (incf i)) (copy-list '(a b c))) - (progn (setf y (incf i)) (copy-list '(d e f)))) - i x y)) - (c b a d e f) 2 1 2) - -(def-fold-test revappend.fold.1 (revappend '(x) nil)) -(def-fold-test revappend.fold.2 (revappend '(x y z) nil)) - -;;; Error tests - -(deftest revappend.error.1 - (signals-error (revappend) program-error) - t) - -(deftest revappend.error.2 - (signals-error (revappend nil) program-error) - t) - -(deftest revappend.error.3 - (signals-error (revappend nil nil nil) program-error) - t) - -(deftest revappend.error.4 - (signals-error (revappend '(a . b) '(z)) type-error) - t) diff --git a/t/ansi-test/cons/rplaca.lsp b/t/ansi-test/cons/rplaca.lsp deleted file mode 100644 index 4ef8a9e..0000000 --- a/t/ansi-test/cons/rplaca.lsp +++ /dev/null @@ -1,47 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 19 21:29:43 2003 -;;;; Contains: Tests of RPLACA - - - - - -(deftest rplaca.1 - (let ((x (cons 'a 'b))) - (let ((y x)) - (and (eqt (rplaca x 'c) y) - (eqt x y) - (eqt (car x) 'c) - (eqt (cdr x) 'b)))) - t) - -(deftest rplaca.order.1 - (let ((x (cons 'a 'b)) - (i 0) a b) - (values - (rplaca (progn (setf a (incf i)) x) - (progn (setf b (incf i)) 'c)) - i a b)) - (c . b) 2 1 2) - -;; rplaca on a non-cons is a type error -(deftest rplaca.error.1 - (check-type-error #'(lambda (x) (rplaca x 1)) #'consp) - nil) - -(deftest rplaca.error.2 - (signals-error (rplaca) program-error) - t) - -(deftest rplaca.error.3 - (signals-error (rplaca (cons 'a 'b)) program-error) - t) - -(deftest rplaca.error.4 - (signals-error (rplaca (cons 'a 'b) (cons 'c 'd) 'garbage) program-error) - t) - -(deftest rplaca.error.6 - (signals-error (locally (rplaca 'a 1) t) type-error) - t) diff --git a/t/ansi-test/cons/rplacd.lsp b/t/ansi-test/cons/rplacd.lsp deleted file mode 100644 index 76b7760..0000000 --- a/t/ansi-test/cons/rplacd.lsp +++ /dev/null @@ -1,48 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 19 21:30:28 2003 -;;;; Contains: Tests of RPLACD - - - - - -(deftest rplacd.1 - (let ((x (cons 'a 'b))) - (let ((y x)) - (and (eqt (rplacd x 'd) y) - (eqt x y) - (eqt (car x) 'a) - (eqt (cdr x) 'd)))) - t) - -(deftest rplacd.order.1 - (let ((x (cons 'a 'b)) - (i 0) a b) - (values - (rplacd (progn (setf a (incf i)) x) - (progn (setf b (incf i)) 'c)) - i a b)) - (a . c) 2 1 2) - -;; rplacd on a non-cons is a type error -(deftest rplacd.error.1 - (check-type-error #'(lambda (x) (rplacd x 1)) #'consp) - nil) - -(deftest rplacd.error.2 - (signals-error (rplacd) program-error) - t) - -(deftest rplacd.error.3 - (signals-error (rplacd (cons 'a 'b)) program-error) - t) - -(deftest rplacd.error.4 - (signals-error (rplacd (cons 'a 'b) (cons 'c 'd) 'garbage) program-error) - t) - -(deftest rplacd.error.6 - (signals-error (locally (rplacd 'a 1) t) type-error) - t) - diff --git a/t/ansi-test/cons/set-difference.lsp b/t/ansi-test/cons/set-difference.lsp deleted file mode 100644 index 569863e..0000000 --- a/t/ansi-test/cons/set-difference.lsp +++ /dev/null @@ -1,333 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Apr 20 07:44:06 2003 -;;;; Contains: Tests of SET-DIFFERENCE - - - - - -(deftest set-difference.1 - (set-difference nil nil) - nil) - -(deftest set-difference.2 - (let ((result - (set-difference-with-check '(a b c) nil))) - (check-set-difference '(a b c) nil result)) - t) - -(deftest set-difference.3 - (let ((result - (set-difference-with-check '(a b c d e f) '(f b d)))) - (check-set-difference '(a b c d e f) '(f b d) result)) - t) - -(deftest set-difference.4 - (sort - (copy-list - (set-difference-with-check (shuffle '(1 2 3 4 5 6 7 8)) - '(10 101 4 74 2 1391 7 17831))) - #'<) - (1 3 5 6 8)) - -(deftest set-difference.5 - (set-difference-with-check nil '(a b c d e f g h)) - nil) - -(deftest set-difference.6 - (set-difference-with-check '(a b c d e) '(d a b e) - :key nil) - (c)) - -(deftest set-difference.7 - (set-difference-with-check '(a b c d e) '(d a b e) :test #'eq) - (c)) - -(deftest set-difference.8 - (set-difference-with-check '(a b c d e) '(d a b e) :test #'eql) - (c)) - -(deftest set-difference.9 - (set-difference-with-check '(a b c d e) '(d a b e) :test #'equal) - (c)) - -(deftest set-difference.10 - (set-difference-with-check '(a b c d e) '(d a b e) - :test 'eq) - (c)) - -(deftest set-difference.11 - (set-difference-with-check '(a b c d e) '(d a b e) - :test 'eql) - (c)) - -(deftest set-difference.12 - (set-difference-with-check '(a b c d e) '(d a b e) - :test 'equal) - (c)) - -(deftest set-difference.13 - (do-random-set-differences 100 100) - nil) - -(deftest set-difference.14 - (set-difference-with-check '((a . 1) (b . 2) (c . 3)) - '((a . 1) (c . 3)) - :key 'car) - ((b . 2))) - -(deftest set-difference.15 - (set-difference-with-check '((a . 1) (b . 2) (c . 3)) - '((a . 1) (c . 3)) - :key #'car) - ((b . 2))) - -;; -;; Verify that the :test argument is called with the arguments -;; in the correct order -;; -(deftest set-difference.16 - (block fail - (sort - (copy-list - (set-difference-with-check - '(1 2 3 4) '(e f g h) - :test #'(lambda (x y) - (when (or (member x '(e f g h)) - (member y '(1 2 3 4))) - (return-from fail 'fail)) - (eqt x y)))) - #'<)) - (1 2 3 4)) - -(deftest set-difference.17 - (block fail - (sort - (copy-list - (set-difference-with-check - '(1 2 3 4) '(e f g h) - :key #'identity - :test #'(lambda (x y) - (when (or (member x '(e f g h)) - (member y '(1 2 3 4))) - (return-from fail 'fail)) - (eqt x y)))) - #'<)) - (1 2 3 4)) - -(deftest set-difference.18 - (block fail - (sort - (copy-list - (set-difference-with-check - '(1 2 3 4) '(e f g h) - :test-not - #'(lambda (x y) - (when (or (member x '(e f g h)) - (member y '(1 2 3 4))) - (return-from fail 'fail)) - (not (eqt x y))))) - #'<)) - (1 2 3 4)) - -(deftest set-difference.19 - (block fail - (sort - (copy-list - (set-difference-with-check - '(1 2 3 4) '(e f g h) - :test-not - #'(lambda (x y) - (when (or (member x '(e f g h)) - (member y '(1 2 3 4))) - (return-from fail 'fail)) - (not (eqt x y))))) - #'<)) - (1 2 3 4)) - -(defharmless set-difference.test-and-test-not.1 - (set-difference (list 1 2 3 4) (list 1 7 3 8) :test #'eql :test-not #'eql)) - -(defharmless set-difference.test-and-test-not.2 - (set-difference (list 1 2 3 4) (list 1 7 3 8) :test-not #'eql :test #'eql)) - -;;; Order of argument evaluation tests - -(deftest set-difference.order.1 - (let ((i 0) x y) - (values - (set-difference (progn (setf x (incf i)) (list 1 2 3 4)) - (progn (setf y (incf i)) (list 2 3 4))) - i x y)) - (1) 2 1 2) - -(deftest set-difference.order.2 - (let ((i 0) x y z) - (values - (set-difference (progn (setf x (incf i)) (list 1 2 3 4)) - (progn (setf y (incf i)) (list 2 3 4)) - :test (progn (setf z (incf i)) - #'(lambda (x y) (= x (1- y))))) - i x y z)) - (4) 3 1 2 3) - -(deftest set-difference.order.3 - (let ((i 0) x y z w) - (values - (set-difference (progn (setf x (incf i)) (list 1 2 3 4)) - (progn (setf y (incf i)) (list 2 3 4)) - :test (progn (setf z (incf i)) - #'(lambda (x y) (= x (1- y)))) - :key (progn (setf w (incf i)) nil)) - i x y z w)) - (4) 4 1 2 3 4) - - -;;; Keyword tests - -(deftest set-difference.allow-other-keys.1 - (sort - (copy-list - (set-difference - (list 1 2 3 4 5) (list 2 3 4) - :bad t :allow-other-keys t)) - #'<) - (1 5)) - -(deftest set-difference.allow-other-keys.2 - (sort - (copy-list - (set-difference - (list 1 2 3 4 5) (list 2 3 4) - :allow-other-keys t :bad t)) - #'<) - (1 5)) - -(deftest set-difference.allow-other-keys.3 - (sort - (copy-list - (set-difference - (list 1 2 3 4 5) (list 2 3 4) - :allow-other-keys t :bad t :test #'(lambda (x y) (= x (1- y))))) - #'<) - (4 5)) - -(deftest set-difference.allow-other-keys.4 - (sort - (copy-list - (set-difference - (list 1 2 3 4 5) (list 2 3 4) - :allow-other-keys t)) - #'<) - (1 5)) - -(deftest set-difference.allow-other-keys.5 - (sort - (copy-list - (set-difference - (list 1 2 3 4 5) (list 2 3 4) - :allow-other-keys nil)) - #'<) - (1 5)) - -(deftest set-difference.allow-other-keys.6 - (sort - (copy-list - (set-difference - (list 1 2 3 4 5) (list 2 3 4) - :allow-other-keys t - :allow-other-keys nil)) - #'<) - (1 5)) - -(deftest set-difference.allow-other-keys.7 - (sort - (copy-list - (set-difference - (list 1 2 3 4 5) (list 2 3 4) - :allow-other-keys t - :allow-other-keys nil - '#:x 1)) - #'<) - (1 5)) - -(deftest set-difference.keywords.8 - (sort - (copy-list - (set-difference - (list 1 2 3 4 5) (list 2 3 4) - :test #'eql :test (complement #'eql))) - #'<) - (1 5)) - -(deftest set-difference.keywords.9 - (sort - (copy-list - (set-difference - (list 1 2 3 4 5) (list 2 3 4) - :test (complement #'eql) :test #'eql)) - #'<) - nil) - -(def-fold-test set-difference.fold.1 (set-difference '(a b c d e f g h) '(b w h x e y))) - -;;; Error tests - - -(deftest set-difference.error.1 - (signals-error (set-difference) program-error) - t) - -(deftest set-difference.error.2 - (signals-error (set-difference nil) program-error) - t) - -(deftest set-difference.error.3 - (signals-error (set-difference nil nil :bad t) program-error) - t) - -(deftest set-difference.error.4 - (signals-error (set-difference nil nil :key) program-error) - t) - -(deftest set-difference.error.5 - (signals-error (set-difference nil nil 1 2) program-error) - t) - -(deftest set-difference.error.6 - (signals-error (set-difference nil nil :bad t :allow-other-keys nil) program-error) - t) - -(deftest set-difference.error.7 - (signals-error (set-difference (list 1 2) (list 3 4) :test #'identity) program-error) - t) - -(deftest set-difference.error.8 - (signals-error (set-difference (list 1 2) (list 3 4) :test-not #'identity) program-error) - t) - -(deftest set-difference.error.9 - (signals-error (set-difference (list 1 2) (list 3 4) :key #'cons) program-error) - t) - -(deftest set-difference.error.10 - (signals-error (set-difference (list 1 2) (list 3 4) :key #'car) type-error) - t) - -(deftest set-difference.error.11 - (signals-error (set-difference (list 1 2 3) (list* 4 5 6)) type-error) - t) - -(deftest set-difference.error.12 - (signals-error (set-difference (list* 1 2 3) (list 4 5 6)) type-error) - t) - -(deftest set-difference.error.13 - (check-type-error #'(lambda (x) (set-difference x '(a b c))) #'listp) - nil) - -(deftest set-difference.error.14 - (check-type-error #'(lambda (x) (set-difference '(a b c) x)) #'listp) - nil) - diff --git a/t/ansi-test/cons/set-exclusive-or.lsp b/t/ansi-test/cons/set-exclusive-or.lsp deleted file mode 100644 index dde380f..0000000 --- a/t/ansi-test/cons/set-exclusive-or.lsp +++ /dev/null @@ -1,382 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Apr 20 07:45:46 2003 -;;;; Contains: Tests of SET-EXCLUSIVE-OR - - - - - -(deftest set-exclusive-or.1 - (set-exclusive-or nil nil) - nil) - -(deftest set-exclusive-or.2 - (let ((result - (set-exclusive-or-with-check '(a b c) nil))) - (check-set-exclusive-or '(a b c) nil result)) - t) - -(deftest set-exclusive-or.3 - (let ((result - (set-exclusive-or-with-check '(a b c d e f) '(f b d)))) - (check-set-exclusive-or '(a b c d e f) '(f b d) result)) - t) - -(deftest set-exclusive-or.4 - (sort - (copy-list - (set-exclusive-or-with-check (shuffle '(1 2 3 4 5 6 7 8)) - '(10 101 4 74 2 1391 7 17831))) - #'<) - (1 3 5 6 8 10 74 101 1391 17831)) - -(deftest set-exclusive-or.5 - (check-set-exclusive-or - nil - '(a b c d e f g h) - (set-exclusive-or-with-check nil '(a b c d e f g h))) - t) - -(deftest set-exclusive-or.6 - (set-exclusive-or-with-check '(a b c d e) '(d a b e) - :key nil) - (c)) - -(deftest set-exclusive-or.7 - (set-exclusive-or-with-check '(a b c d e) '(d a b e) :test #'eq) - (c)) - -(deftest set-exclusive-or.7-a - (set-exclusive-or-with-check '(d a b e) '(a b c d e) :test #'eq) - (c)) - -(deftest set-exclusive-or.8 - (set-exclusive-or-with-check '(a b c d e) '(d a b e) :test #'eql) - (c)) - -(deftest set-exclusive-or.8-a - (set-exclusive-or-with-check '(e d b a) '(a b c d e) :test #'eql) - (c)) - -(deftest set-exclusive-or.8-b - (set-exclusive-or-with-check '(a b c d e) '(d a b e) - :test-not (complement #'eql)) - (c)) - -(deftest set-exclusive-or.9 - (set-exclusive-or-with-check '(a b c d e) '(d a b e) :test #'equal) - (c)) - -(deftest set-exclusive-or.10 - (set-exclusive-or-with-check '(a b c d e) '(d a b e) - :test 'eq) - (c)) - -(deftest set-exclusive-or.11 - (set-exclusive-or-with-check '(a b c d e) '(d a b e) - :test 'eql) - (c)) - -(deftest set-exclusive-or.12 - (set-exclusive-or-with-check '(a b c d e) '(d a b e) - :test 'equal) - (c)) - -;;; (deftest set-exclusive-or.13 -;;; (do-random-set-exclusive-ors 100 100) -;;; nil) - -(deftest set-exclusive-or.14 - (set-exclusive-or-with-check '((a . 1) (b . 2) (c . 3012)) - '((a . 10) (c . 3)) - :key 'car) - ((b . 2))) - -(deftest set-exclusive-or.15 - (set-exclusive-or-with-check '((a . xx) (b . 2) (c . 3)) - '((a . 1) (c . 3313)) - :key #'car) - ((b . 2))) - -(deftest set-exclusive-or.16 - (set-exclusive-or-with-check '((a . xx) (b . 2) (c . 3)) - '((a . 1) (c . 3313)) - :key #'car - :test-not (complement #'eql)) - ((b . 2))) - -;; -;; Check that set-exclusive-or does not invert -;; the order of the arguments to the test function -;; -(deftest set-exclusive-or.17 - (let ((list1 '(a b c d)) - (list2 '(e f g h))) - (block fail - (notnot-mv - (set-exclusive-or-with-check - list1 list2 - :test #'(lambda (s1 s2) - (when (or (member s1 list2) - (member s2 list1)) - (return-from fail 'failed))))))) - t) - -(deftest set-exclusive-or.17-a - (let ((list1 '(a b c d)) - (list2 '(e f g h))) - (block fail - (notnot-mv - (set-exclusive-or-with-check - list1 list2 - :key #'identity - :test #'(lambda (s1 s2) - (when (or (member s1 list2) - (member s2 list1)) - (return-from fail 'failed))))))) - t) - -(deftest set-exclusive-or.18 - (let ((list1 '(a b c d)) - (list2 '(e f g h))) - (block fail - (notnot-mv - (set-exclusive-or-with-check - list1 list2 - :test-not - #'(lambda (s1 s2) - (when (or (member s1 list2) - (member s2 list1)) - (return-from fail 'failed)) - t))))) - t) - -(deftest set-exclusive-or.18-a - (let ((list1 '(a b c d)) - (list2 '(e f g h))) - (block fail - (notnot-mv - (set-exclusive-or-with-check - list1 list2 - :key #'identity - :test-not - #'(lambda (s1 s2) - (when (or (member s1 list2) - (member s2 list1)) - (return-from fail 'failed)) - t))))) - t) - -(defharmless set-exclusive-or.test-and-test-not.1 - (set-exclusive-or (list 1 2 3 4) (list 1 7 3 8) - :test #'eql :test-not #'eql)) - -(defharmless set-exclusive-or.test-and-test-not.2 - (set-exclusive-or (list 1 2 3 4) (list 1 7 3 8) - :test-not #'eql :test #'eql)) - - -;;; Order of argument evaluation tests - -(deftest set-exclusive-or.order.1 - (let ((i 0) x y) - (values - (sort - (set-exclusive-or (progn (setf x (incf i)) - (list 1 2 3 4)) - (progn (setf y (incf i)) - (list 1 3 6 10))) - #'<) - i x y)) - (2 4 6 10) 2 1 2) - -(deftest set-exclusive-or.order.2 - (let ((i 0) x y z) - (values - (sort - (set-exclusive-or (progn (setf x (incf i)) - (list 1 2 3 4)) - (progn (setf y (incf i)) - (list 1 3 6 10)) - :test (progn (setf z (incf i)) - #'eql)) - #'<) - i x y z)) - (2 4 6 10) 3 1 2 3) - -(deftest set-exclusive-or.order.3 - (let ((i 0) x y z w) - (values - (sort - (set-exclusive-or (progn (setf x (incf i)) - (list 1 2 3 4)) - (progn (setf y (incf i)) - (list 1 3 6 10)) - :test (progn (setf z (incf i)) - #'eql) - :key (progn (setf w (incf i)) nil)) - #'<) - i x y z w)) - (2 4 6 10) 4 1 2 3 4) - -(deftest set-exclusive-or.order.4 - (let ((i 0) x y z w) - (values - (sort - (set-exclusive-or (progn (setf x (incf i)) - (list 1 2 3 4)) - (progn (setf y (incf i)) - (list 1 3 6 10)) - :key (progn (setf z (incf i)) nil) - :test (progn (setf w (incf i)) - #'eql)) - #'<) - i x y z w)) - (2 4 6 10) 4 1 2 3 4) - -(deftest set-exclusive-or.order.5 - (let ((i 0) x y z w) - (values - (sort - (set-exclusive-or (progn (setf x (incf i)) - (list 1 2 3 4)) - (progn (setf y (incf i)) - (list 1 3 6 10)) - :key (progn (setf z (incf i)) nil) - :key (progn (setf w (incf i)) - (complement #'eql))) - #'<) - i x y z w)) - (2 4 6 10) 4 1 2 3 4) - - -;;; Keyword tests - -(deftest set-exclusive.allow-other-keys.1 - (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :bad t :allow-other-keys t) - #'<) - (1 2 5 6)) - -(deftest set-exclusive.allow-other-keys.2 - (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :allow-other-keys t :bad t) - #'<) - (1 2 5 6)) - -(deftest set-exclusive.allow-other-keys.3 - (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :allow-other-keys t :bad t - :test #'(lambda (x y) (= x (1- y)))) - #'<) - (1 6)) - -(deftest set-exclusive.allow-other-keys.4 - (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :allow-other-keys t) - #'<) - (1 2 5 6)) - -(deftest set-exclusive.allow-other-keys.5 - (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :allow-other-keys nil) - #'<) - (1 2 5 6)) - -(deftest set-exclusive.allow-other-keys.6 - (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :allow-other-keys t - :allow-other-keys nil) - #'<) - (1 2 5 6)) - -(deftest set-exclusive.allow-other-keys.7 - (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :allow-other-keys t - :allow-other-keys nil - '#:x 1) - #'<) - (1 2 5 6)) - -(deftest set-exclusive.keywords.8 - (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :test #'eql - :test #'/=) - #'<) - (1 2 5 6)) - -(deftest set-exclusive.keywords.9 - (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :test #'/= - :test #'eql) - #'<) - nil) - -(def-fold-test set-exclusive-or.fold.1 (set-exclusive-or '(a b c d e f) '(b x e y z c))) - -;;; Error tests - -(deftest set-exclusive-or.error.1 - (signals-error (set-exclusive-or) program-error) - t) - -(deftest set-exclusive-or.error.2 - (signals-error (set-exclusive-or nil) program-error) - t) - -(deftest set-exclusive-or.error.3 - (signals-error (set-exclusive-or nil nil :bad t) program-error) - t) - -(deftest set-exclusive-or.error.4 - (signals-error (set-exclusive-or nil nil :key) program-error) - t) - -(deftest set-exclusive-or.error.5 - (signals-error (set-exclusive-or nil nil 1 2) program-error) - t) - -(deftest set-exclusive-or.error.6 - (signals-error (set-exclusive-or nil nil :bad t :allow-other-keys nil) program-error) - t) - -(deftest set-exclusive-or.error.7 - (signals-error (set-exclusive-or (list 1 2) (list 3 4) :test #'identity) program-error) - t) - -(deftest set-exclusive-or.error.8 - (signals-error (set-exclusive-or (list 1 2) (list 3 4) :test-not #'identity) program-error) - t) - -(deftest set-exclusive-or.error.9 - (signals-error (set-exclusive-or (list 1 2) (list 3 4) :key #'cons) program-error) - t) - -(deftest set-exclusive-or.error.10 - (signals-error (set-exclusive-or (list 1 2) (list 3 4) :key #'car) type-error) - t) - -(deftest set-exclusive-or.error.11 - (signals-error (set-exclusive-or (list 1 2 3) (list* 4 5 6)) type-error) - t) - -(deftest set-exclusive-or.error.12 - (signals-error (set-exclusive-or (list* 1 2 3) (list 4 5 6)) type-error) - t) - -(deftest set-exclusive-or.error.13 - (check-type-error #'(lambda (x) (set-exclusive-or x '(a b c))) #'listp) - nil) - -(deftest set-exclusive-or.error.14 - (check-type-error #'(lambda (x) (set-exclusive-or '(a b c) x)) #'listp) - nil) - - -;;; Randomized test - -(deftest random-set-exclusive-or - (random-set-exclusive-or-test 10 100) - nil) - diff --git a/t/ansi-test/cons/sublis.lsp b/t/ansi-test/cons/sublis.lsp deleted file mode 100644 index 426203e..0000000 --- a/t/ansi-test/cons/sublis.lsp +++ /dev/null @@ -1,201 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 19 21:32:50 2003 -;;;; Contains: Tests of SUBLIS - - - - - -(deftest sublis.1 - (check-sublis '((a b) g (d e 10 g h) 15 . g) - '((e . e2) (g . 17))) - ((a b) 17 (d e2 10 17 h) 15 . 17)) - -(deftest sublis.2 - (check-sublis '(f6 10 (f4 (f3 (f1 a b) (f1 a p)) (f2 a b))) - '(((f1 a b) . (f2 a b)) ((f2 a b) . (f1 a b))) - :test #'equal) - (f6 10 (f4 (f3 (f2 a b) (f1 a p)) (f1 a b)))) - -(deftest sublis.3 - (check-sublis '(10 ((10 20 (a b c) 30)) (((10 20 30 40)))) - '((30 . "foo"))) - (10 ((10 20 (a b c) "foo")) (((10 20 "foo" 40))))) - -(deftest sublis.4 - (check-sublis (sublis - (copy-tree '((a . 2) (b . 4) (c . 1))) - (copy-tree '(a b c d e (a b c a d b) f))) - '((t . "yes")) - :key #'(lambda (x) (and (typep x 'integer) - (evenp x)))) - ("yes" "yes" 1 d e ("yes" "yes" 1 "yes" d "yes") f)) - -(deftest sublis.5 - (check-sublis '("fee" (("fee" "Fie" "foo")) - fie ("fee" "fie")) - `((,(copy-seq "fie") . #\f))) - ("fee" (("fee" "Fie" "foo")) fie ("fee" "fie"))) - -(deftest sublis.6 - (check-sublis '("fee" fie (("fee" "Fie" "foo") 1) - ("fee" "fie")) - `((,(copy-seq "fie") . #\f)) - :test 'equal) - ("fee" fie (("fee" "Fie" "foo") 1) ("fee" #\f))) - -(deftest sublis.7 - (check-sublis '(("aa" a b) - (z "bb" d) - ((x . "aa"))) - `((,(copy-seq "aa") . 1) - (,(copy-seq "bb") . 2)) - :test 'equal - :key #'(lambda (x) (if (consp x) (car x) - '*not-present*))) - (1 (z . 2) ((x . "aa")))) - -;; Check that a null key arg is ignored. - -(deftest sublis.8 - (check-sublis - '(1 2 a b) - '((1 . 2) (a . b)) - :key nil) - (2 2 b b)) - -(deftest sublis.9 - (check-sublis (list 0 3 8 20) - '((1 . x) (5 . y) (10 . z)) - :test #'(lambda (x y) (and (realp x) (realp y) (< x y)))) - (x y z 20)) - -(deftest sublis.10 - (check-sublis (list 0 3 8 20) - '((1 . x) (5 . y) (10 . z)) - :test-not - #'(lambda (x y) (not (and (realp x) (realp y) (< x y))))) - (x y z 20)) - -(defharmless sublis.test-and-test-not.1 - (sublis '((a . 1) (b . 2)) (list 'a 'b 'c 'd) - :test #'eql :test-not #'eql)) - -(defharmless sublis.test-and-test-not.2 - (sublis '((a . 1) (b . 2)) (list 'a 'b 'c 'd) - :test-not #'eql :test #'eql)) - -;;; Order of argument evaluation -(deftest sublis.order.1 - (let ((i 0) w x y z) - (values - (sublis - (progn (setf w (incf i)) - '((a . z))) - (progn (setf x (incf i)) - (copy-tree '(a b c d))) - :test (progn (setf y (incf i)) #'eql) - :key (progn (setf z (incf i)) #'identity)) - i w x y z)) - (z b c d) - 4 1 2 3 4) - -(deftest sublis.order.2 - (let ((i 0) w x y z) - (values - (sublis - (progn (setf w (incf i)) - '((a . z))) - (progn (setf x (incf i)) - (copy-tree '(a b c d))) - :key (progn (setf y (incf i)) #'identity) - :test-not (progn (setf z (incf i)) (complement #'eql)) - ) - i w x y z)) - (z b c d) - 4 1 2 3 4) - -;;; Const fold tests - -(def-fold-test sublis.fold.1 (sublis '((a . b)) '(a x y . a))) - - -;;; Keyword tests - -(deftest sublis.allow-other-keys.1 - (sublis nil 'a :bad t :allow-other-keys t) - a) - -(deftest sublis.allow-other-keys.2 - (sublis nil 'a :allow-other-keys t :bad t) - a) - -(deftest sublis.allow-other-keys.3 - (sublis nil 'a :allow-other-keys t) - a) - -(deftest sublis.allow-other-keys.4 - (sublis nil 'a :allow-other-keys nil) - a) - -(deftest sublis.allow-other-keys.5 - (sublis nil 'a :allow-other-keys t :allow-other-keys t :bad t) - a) - -(deftest sublis.keywords.6 - (sublis '((1 . a)) (list 0 1 2) :key #'(lambda (x) (if (numberp x) (1+ x) x)) - :key #'identity) - (a 1 2)) - - -;; Argument error cases - -(deftest sublis.error.1 - (signals-error (sublis) program-error) - t) - -(deftest sublis.error.2 - (signals-error (sublis nil) program-error) - t) - -(deftest sublis.error.3 - (signals-error (sublis nil 'a :test) program-error) - t) - -(deftest sublis.error.4 - (signals-error (sublis nil 'a :bad-keyword t) program-error) - t) - -(deftest sublis.error.5 - (signals-error (sublis '((a . 1) (b . 2)) - (list 'a 'b 'c 'd) - :test #'identity) - program-error) - t) - -(deftest sublis.error.6 - (signals-error (sublis '((a . 1) (b . 2)) - (list 'a 'b 'c 'd) - :key #'cons) - program-error) - t) - -(deftest sublis.error.7 - (signals-error (sublis '((a . 1) (b . 2)) - (list 'a 'b 'c 'd) - :test-not #'identity) - program-error) - t) - -(deftest sublis.error.8 - (signals-error (sublis '((a . 1) . bad) - (list 'a 'b 'c 'd)) - type-error) - t) - -(deftest sublis.shared - (let* ((shared-piece (list 'a 'b)) - (a (list shared-piece shared-piece))) - (check-sublis a '((a . b) (b . a)))) - ((b a) (b a))) diff --git a/t/ansi-test/cons/subsetp.lsp b/t/ansi-test/cons/subsetp.lsp deleted file mode 100644 index b1e5a32..0000000 --- a/t/ansi-test/cons/subsetp.lsp +++ /dev/null @@ -1,274 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Apr 1 22:10:54 1998 -;;;; Contains: Tests of SUBSETP - - - - - -(defvar cons-test-24-var '(78 "z" (8 9))) - -(deftest subsetp.1 - (subsetp-with-check (copy-tree '(78)) cons-test-24-var) - t) - -(deftest subsetp.2 - (subsetp-with-check (copy-tree '((8 9))) cons-test-24-var) - nil) - -(deftest subsetp.3 - (subsetp-with-check (copy-tree '((8 9))) - cons-test-24-var :test 'equal) - t) - -(deftest subsetp.4 - (subsetp-with-check (list 78 (copy-seq "Z")) cons-test-24-var - :test #'equalp) - t) - -(deftest subsetp.5 - (subsetp-with-check (list 1) (list 0 2 3 4) - :key #'(lambda (i) (floor (/ i 2)))) - t) - -(deftest subsetp.6 - (subsetp-with-check (list 1 6) (list 0 2 3 4) - :key #'(lambda (i) (floor (/ i 2)))) - nil) - -(deftest subsetp.7 - (subsetp-with-check (list '(a . 10) '(b . 20) '(c . 30)) - (list '(z . c) '(a . y) '(b . 100) '(e . f) - '(c . foo)) - :key #'car) - t) - -(deftest subsetp.8 - (subsetp-with-check (copy-tree '((a . 10) (b . 20) (c . 30))) - (copy-tree '((z . c) (a . y) (b . 100) (e . f) - (c . foo))) - :key 'car) - t) - -(deftest subsetp.9 - (subsetp-with-check (list 'a 'b 'c) - (copy-tree - (list '(z . c) '(a . y) '(b . 100) '(e . f) - '(c . foo))) - :test #'(lambda (e1 e2) - (eqt e1 (car e2)))) - t) - -(deftest subsetp.10 - (subsetp-with-check (list 'a 'b 'c) - (copy-tree - (list '(z . c) '(a . y) '(b . 100) '(e . f) - '(c . foo))) - :test #'(lambda (e1 e2) - (eqt e1 (car e2))) - :key nil) - t) - -(deftest subsetp.11 - (subsetp-with-check (list 'a 'b 'c) - (copy-tree - (list '(z . c) '(a . y) '(b . 100) '(e . f) - '(c . foo))) - :test-not #'(lambda (e1 e2) - (not (eqt e1 (car e2))))) - t) - -;; Check that it maintains order of arguments - -(deftest subsetp.12 - (block fail - (subsetp-with-check - (list 1 2 3) - (list 4 5 6) - :test #'(lambda (x y) - (when (< y x) (return-from fail 'fail)) - t))) - t) - -(deftest subsetp.13 - (block fail - (subsetp-with-check - (list 1 2 3) - (list 4 5 6) - :key #'identity - :test #'(lambda (x y) - (when (< y x) (return-from fail 'fail)) - t))) - t) - -(deftest subsetp.14 - (block fail - (subsetp-with-check - (list 1 2 3) - (list 4 5 6) - :test-not #'(lambda (x y) - (when (< y x) (return-from fail 'fail)) - nil))) - t) - -(deftest subsetp.15 - (block fail - (subsetp-with-check - (list 1 2 3) - (list 4 5 6) - :key #'identity - :test-not #'(lambda (x y) - (when (< y x) (return-from fail 'fail)) - nil))) - t) - -(defharmless subsetp.test-and-test-not.1 - (subsetp '(a b c) '(a g c e b) :test #'eql :test-not #'eql)) - -(defharmless subsetp.test-and-test-not.3 - (subsetp '(a b c) '(a g c e b) :test-not #'eql :test #'eql)) - -;;; Order of argument evaluation tests - -(deftest subsetp.order.1 - (let ((i 0) x y) - (values - (notnot (subsetp (progn (setf x (incf i)) - '(a b c)) - (progn (setf y (incf i)) - '(a b c d)))) - i x y)) - t 2 1 2) - -(deftest subsetp.order.2 - (let ((i 0) x y z w) - (values - (notnot (subsetp (progn (setf x (incf i)) - '(a b c)) - (progn (setf y (incf i)) - '(a b c d)) - :test (progn (setf z (incf i)) #'eql) - :key (progn (setf w (incf i)) nil))) - i x y z w)) - t 4 1 2 3 4) - -(deftest subsetp.order.3 - (let ((i 0) x y z w) - (values - (notnot (subsetp (progn (setf x (incf i)) - '(a b c)) - (progn (setf y (incf i)) - '(a b c d)) - :key (progn (setf z (incf i)) nil) - :test (progn (setf w (incf i)) #'eql))) - i x y z w)) - t 4 1 2 3 4) - -;;; Keyword tests - -(deftest subsetp.allow-other-keys.1 - (notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4 5) :bad t :allow-other-keys 67)) - t) - -(deftest subsetp.allow-other-keys.2 - (notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4 5) - :allow-other-keys #'cons :bad t)) - t) - -(deftest subsetp.allow-other-keys.3 - (notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4) - :allow-other-keys (make-hash-table) - :bad t - :test #'(lambda (x y) (= (1+ x) y)))) - nil) - -(deftest subsetp.allow-other-keys.4 - (notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4 5) :allow-other-keys t)) - t) - -(deftest subsetp.allow-other-keys.5 - (notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4 5) :allow-other-keys nil)) - t) - -(deftest subsetp.allow-other-keys.6 - (notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4 5) - :allow-other-keys t :bad1 t - :allow-other-keys nil :bad2 t)) - t) - -(deftest subsetp.keywords.7 - (notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4) - :test #'(lambda (x y) (= (1+ x) y)) - :test #'eql)) - nil) - -(deftest subsetp.keywords.8 - (notnot-mv (subsetp '(1 2 3 4 10) '(0 1 2 3 4) - :key nil - :key #'(lambda (x) (mod x 2)))) - nil) - - -;;; Error tests - -(deftest subsetp.error.1 - (signals-error (subsetp) program-error) - t) - -(deftest subsetp.error.2 - (signals-error (subsetp nil) program-error) - t) - -(deftest subsetp.error.3 - (signals-error (subsetp nil nil :bad t) program-error) - t) - -(deftest subsetp.error.4 - (signals-error (subsetp nil nil :key) program-error) - t) - -(deftest subsetp.error.5 - (signals-error (subsetp nil nil 1 2) program-error) - t) - -(deftest subsetp.error.6 - (signals-error (subsetp nil nil :bad t :allow-other-keys nil) program-error) - t) - -(deftest subsetp.error.7 - (signals-error (subsetp (list 1 2) (list 3 4) :test #'identity) program-error) - t) - -(deftest subsetp.error.8 - (signals-error (subsetp (list 1 2) (list 3 4) :test-not #'identity) program-error) - t) - -(deftest subsetp.error.9 - (signals-error (subsetp (list 1 2) (list 3 4) :key #'cons) program-error) - t) - -(deftest subsetp.error.10 - (signals-error (subsetp (list 1 2) (list 3 4) :key #'car) type-error) - t) - -(deftest subsetp.error.11 - (signals-error (subsetp (list 1 2 3) (list* 4 5 6)) type-error) - t) - -(deftest subsetp.error.12 - (signals-error (subsetp (list* 1 2 3) (list 1 2 3 4 5 6)) type-error) - t) - -;;; The next two tests previously compared against NIL, but arguably -;;; a conforming implementation is not required to signal an error -;;; in these cases, since it doesn't have to traverse the other list. - -(deftest subsetp.error.13 - (check-type-error #'(lambda (x) (subsetp x '(a b))) #'listp) - nil) - -(deftest subsetp.error.14 - (check-type-error #'(lambda (x) (subsetp '(a b) x)) #'listp) - nil) - diff --git a/t/ansi-test/cons/subst-if-not.lsp b/t/ansi-test/cons/subst-if-not.lsp deleted file mode 100644 index 8cf5fdd..0000000 --- a/t/ansi-test/cons/subst-if-not.lsp +++ /dev/null @@ -1,119 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 19 21:48:22 2003 -;;;; Contains: Tests of SUBST-IF-NOT - - - - - -(deftest subst-if-not.1 - (check-subst-if-not '(x) 'consp '(1 (1 2) (1 2 3) (1 2 3 4))) - ((x) - ((x) (x) x) - ((x) (x) (x) x) - ((x) (x) (x) (x) x) - x)) - -(deftest subst-if-not.2 - (check-subst-if-not 'a (complement #'listp) - '((100 1) (2 3) (4 3 2 1) (a b c))) - a) - -(deftest subst-if-not.3 - (check-subst-if-not 'c #'identity - '((100 1) (2 3) (4 3 2 1) (a b c)) - :key (complement #'listp)) - c) - -(deftest subst-if-not.4 - (check-subst-if-not - 40 - #'(lambda (x) (not (eql x 17))) - '((17) (17 22) (17 22 31) (17 21 34 54)) - :key #'(lambda (x) - (and (consp x) - (car x)))) - (40 40 40 40)) - -(deftest subst-if-not.5 - (check-subst-if-not 'a #'(lambda (x) (not (eql x 'b))) - '((a) (b) (c) (d)) - :key nil) - ((a) (a) (c) (d))) - -(deftest subst-if-not.7 - (let ((i 0) w x y z) - (values - (subst-if-not - (progn (setf w (incf i)) 'a) - (progn (setf x (incf i)) #'(lambda (x) (not (eql x 'b)))) - (progn (setf y (incf i)) (copy-list '(1 2 a b c))) - :key (progn (setf z (incf i)) #'identity)) - i w x y z)) - (1 2 a a c) - 4 1 2 3 4) - -(def-fold-test subst-if-not.fold.1 (subst-if-not 'a #'consp '((1 . 2) 3 . 4))) - -;;; Keywords tests for subst-if-not - -(deftest subst-if-not.allow-other-keys.1 - (subst-if-not 'a #'identity nil :bad t :allow-other-keys t) - a) - -(deftest subst-if-not.allow-other-keys.2 - (subst-if-not 'a #'identity nil :allow-other-keys t) - a) - -(deftest subst-if-not.allow-other-keys.3 - (subst-if-not 'a #'identity nil :allow-other-keys nil) - a) - -(deftest subst-if-not.allow-other-keys.4 - (subst-if-not 'a #'identity nil :allow-other-keys t :bad t) - a) - -(deftest subst-if-not.allow-other-keys.5 - (subst-if-not 'a #'identity nil :allow-other-keys t - :allow-other-keys nil :bad t) - a) - -(deftest subst-if-not.keywords.6 - (subst-if-not 'a #'identity nil :key nil :key (constantly 'b)) - a) - -;;; error cases - -(deftest subst-if-not.error.1 - (signals-error (subst-if-not) program-error) - t) - -(deftest subst-if-not.error.2 - (signals-error (subst-if-not 'a) program-error) - t) - -(deftest subst-if-not.error.3 - (signals-error (subst-if-not 'a #'null) program-error) - t) - -(deftest subst-if-not.error.4 - (signals-error (subst-if-not 'a #'null nil :foo nil) program-error) - t) - -(deftest subst-if-not.error.5 - (signals-error (subst-if-not 'a #'null nil :test) program-error) - t) - -(deftest subst-if-not.error.6 - (signals-error (subst-if-not 'a #'null nil 1) program-error) - t) - -(deftest subst-if-not.error.7 - (signals-error (subst-if-not 'a #'null nil - :bad t :allow-other-keys nil) program-error) - t) - -(deftest subst-if-not.error.8 - (signals-error (subst-if-not 'a #'null (list 'a nil 'c) :key #'cons) program-error) - t) diff --git a/t/ansi-test/cons/subst-if.lsp b/t/ansi-test/cons/subst-if.lsp deleted file mode 100644 index 3316805..0000000 --- a/t/ansi-test/cons/subst-if.lsp +++ /dev/null @@ -1,119 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 19 21:39:42 2003 -;;;; Contains: Tests of SUBST-IF - - - - - -(deftest subst-if.1 - (check-subst-if 'a #'consp '((100 1) (2 3) (4 3 2 1) (a b c))) - a) - -(deftest subst-if.2 - (check-subst-if 17 (complement #'listp) '(a (a b) (a c d) (a nil e f g))) - (17 (17 17) (17 17 17) (17 nil 17 17 17))) - -(deftest subst-if.3 - (check-subst-if '(z) - (complement #'consp) - '(a (a b) (c d e) (f g h i))) - ((z) - ((z) (z) z) - ((z) (z) (z) z) - ((z) (z) (z) (z) z) - z)) - -(deftest subst-if.4 - (check-subst-if 'b #'identity '((100 1) (2 3) (4 3 2 1) (a b c)) - :key #'listp) - b) - -(deftest subst-if.5 - (check-subst-if 4 #'(lambda (x) (eql x 1)) - '((1 3) (1) (1 10 20 30) (1 3 x y)) - :key #'(lambda (x) - (and (consp x) - (car x)))) - (4 4 4 4)) - -(deftest subst-if.6 - (check-subst-if 'a #'(lambda (x) (eql x 'b)) - '((a) (b) (c) (d)) - :key nil) - ((a) (a) (c) (d))) - -(deftest subst-if.7 - (let ((i 0) w x y z) - (values - (subst-if - (progn (setf w (incf i)) 'a) - (progn (setf x (incf i)) #'(lambda (x) (eql x 'b))) - (progn (setf y (incf i)) (copy-list '(1 2 a b c))) - :key (progn (setf z (incf i)) #'identity)) - i w x y z)) - (1 2 a a c) - 4 1 2 3 4) - -(def-fold-test subst-if.fold.1 (subst-if 'x 'numberp '(a b 3 (4) c d . 12))) - -;;; Keyword tests for subst-if - -(deftest subst-if.allow-other-keys.1 - (subst-if 'a #'null nil :bad t :allow-other-keys t) - a) - -(deftest subst-if.allow-other-keys.2 - (subst-if 'a #'null nil :allow-other-keys t) - a) - -(deftest subst-if.allow-other-keys.3 - (subst-if 'a #'null nil :allow-other-keys nil) - a) - -(deftest subst-if.allow-other-keys.4 - (subst-if 'a #'null nil :allow-other-keys t :bad t) - a) - -(deftest subst-if.allow-other-keys.5 - (subst-if 'a #'null nil :allow-other-keys t :allow-other-keys nil :bad t) - a) - -(deftest subst-if.keywords.6 - (subst-if 'a #'null nil :key nil :key (constantly 'b)) - a) - -;;; Error tests - -(deftest subst-if.error.1 - (signals-error (subst-if) program-error) - t) - -(deftest subst-if.error.2 - (signals-error (subst-if 'a) program-error) - t) - -(deftest subst-if.error.3 - (signals-error (subst-if 'a #'null) program-error) - t) - -(deftest subst-if.error.4 - (signals-error (subst-if 'a #'null nil :foo nil) program-error) - t) - -(deftest subst-if.error.5 - (signals-error (subst-if 'a #'null nil :test) program-error) - t) - -(deftest subst-if.error.6 - (signals-error (subst-if 'a #'null nil 1) program-error) - t) - -(deftest subst-if.error.7 - (signals-error (subst-if 'a #'null nil :bad t :allow-other-keys nil) program-error) - t) - -(deftest subst-if.error.8 - (signals-error (subst-if 'a #'null (list 'a nil 'c) :key #'cons) program-error) - t) diff --git a/t/ansi-test/cons/subst.lsp b/t/ansi-test/cons/subst.lsp deleted file mode 100644 index 03d1322..0000000 --- a/t/ansi-test/cons/subst.lsp +++ /dev/null @@ -1,179 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 19 21:37:56 2003 -;;;; Contains: Tests of SUBST - - - - - -(defvar *subst-tree-1* '(10 (30 20 10) (20 10) (10 20 30 40))) - -(deftest subst.1 - (check-subst "Z" 30 (copy-tree *subst-tree-1*)) - (10 ("Z" 20 10) (20 10) (10 20 "Z" 40))) - -(deftest subst.2 - (check-subst "A" 0 (copy-tree *subst-tree-1*)) - (10 (30 20 10) (20 10) (10 20 30 40))) - -(deftest subst.3 - (check-subst "Z" 100 (copy-tree *subst-tree-1*) :test-not #'eql) - "Z") - -(deftest subst.4 - (check-subst 'grape 'dick - '(melville wrote (moby dick))) - (melville wrote (moby grape))) - -(deftest subst.5 - (check-subst 'cha-cha-cha 'nil '(melville wrote (moby dick))) - (melville wrote (moby dick . cha-cha-cha) . cha-cha-cha)) - -(deftest subst.6 - (check-subst - '(1 2) '(foo . bar) - '((foo . baz) (foo . bar) (bar . foo) (baz foo . bar)) - :test #'equal) - ((foo . baz) (1 2) (bar . foo) (baz 1 2))) - -(deftest subst.7 - (check-subst - 'foo "aaa" - '((1 . 2) (4 . 5) (6 7 8 9 10 (11 12))) - :key #'(lambda (x) (if (and (numberp x) (evenp x)) - "aaa" - nil)) - :test #'string=) - ((1 . foo) (foo . 5) (foo 7 foo 9 foo (11 foo)))) - -(deftest subst.8 - (check-subst - 'foo nil - '((1 . 2) (4 . 5) (6 7 8 9 10 (11 12))) - :key #'(lambda (x) (if (and (numberp x) (evenp x)) - (copy-seq "aaa") - nil)) - :test-not #'equal) - ((1 . foo) (foo . 5) (foo 7 foo 9 foo (11 foo)))) - -(deftest subst.9 - (check-subst 'a 'b - (copy-tree '(a b c d a b)) - :key nil) - (a a c d a a)) - -(deftest subst.10 - (check-subst 'x 10 (copy-tree '(1 2 10 20 30 4)) - :test #'(lambda (x y) (and (realp x) (realp y) (< x y)))) - (1 2 10 x x 4)) - -(deftest subst.11 - (check-subst 'x 10 (copy-tree '(1 2 10 20 30 4)) - :test-not #'(lambda (x y) - (not (and (realp x) (realp y) (< x y))))) - (1 2 10 x x 4)) - -(defharmless subset.test-and-test-not.1 - (subst 'a 'b (list 'a 'b 'c 'd 'e) :test #'eq :test-not #'eq)) - -(defharmless subset.test-and-test-not.2 - (subst 'a 'b (list 'a 'b 'c 'd 'e) :test-not #'eq :test #'eq)) - - -;;; Order of argument evaluation -(deftest subst.order.1 - (let ((i 0) v w x y z) - (values - (subst (progn (setf v (incf i)) 'b) - (progn (setf w (incf i)) 'a) - (progn (setf x (incf i)) (copy-tree '((10 a . a) a b c ((a)) z))) - :key (progn (setf y (incf i)) #'identity) - :test (progn (setf z (incf i)) #'eql)) - i v w x y z)) - ((10 b . b) b b c ((b)) z) - 5 1 2 3 4 5) - -(deftest subst.order.2 - (let ((i 0) v w x y z) - (values - (subst (progn (setf v (incf i)) 'b) - (progn (setf w (incf i)) 'a) - (progn (setf x (incf i)) (copy-tree '((10 a . a) a b c ((a)) z))) - :test-not (progn (setf y (incf i)) (complement #'eql)) - :key (progn (setf z (incf i)) #'identity) - ) - i v w x y z)) - ((10 b . b) b b c ((b)) z) - 5 1 2 3 4 5) - -;;; Const fold tests - -(def-fold-test subst.fold.1 (subst 'a 'b '(a b c (a . b) . a))) - -;;; Keyword tests for subst - -(deftest subst.allow-other-keys.1 - (subst 'a 'b (list 'a 'b 'c) :bad t :allow-other-keys t) - (a a c)) - -(deftest subst.allow-other-keys.2 - (subst 'a 'b (list 'a 'b 'c) :allow-other-keys t) - (a a c)) - -(deftest subst.allow-other-keys.3 - (subst 'a 'b (list 'a 'b 'c) :allow-other-keys nil) - (a a c)) - -(deftest subst.allow-other-keys.4 - (subst 'a 'b (list 'a 'b 'c) :allow-other-keys t :bad t) - (a a c)) - -(deftest subst.allow-other-keys.5 - (subst 'a 'b (list 'a 'b 'c) :allow-other-keys t :allow-other-keys nil - :bad t) - (a a c)) - -(deftest subst.keywords.6 - (subst 'a 'b (list 'a 'b 'c) :test #'eq :test (complement #'eq)) - (a a c)) - -(deftest subst.error.1 - (signals-error (subst) program-error) - t) - -(deftest subst.error.2 - (signals-error (subst 'a) program-error) - t) - -(deftest subst.error.3 - (signals-error (subst 'a 'b) program-error) - t) - -(deftest subst.error.4 - (signals-error (subst 'a 'b nil :foo nil) program-error) - t) - -(deftest subst.error.5 - (signals-error (subst 'a 'b nil :test) program-error) - t) - -(deftest subst.error.6 - (signals-error (subst 'a 'b nil 1) program-error) - t) - -(deftest subst.error.7 - (signals-error (subst 'a 'b nil :bad t :allow-other-keys nil) program-error) - t) - -(deftest subst.error.8 - (signals-error (subst 'a 'b (list 'a 'b) :test #'identity) program-error) - t) - -(deftest subst.error.9 - (signals-error (subst 'a 'b (list 'a 'b) :test-not #'identity) program-error) - t) - -(deftest subst.error.10 - (signals-error (subst 'a 'b (list 'a 'b) :key #'equal) program-error) - t) diff --git a/t/ansi-test/cons/tailp.lsp b/t/ansi-test/cons/tailp.lsp deleted file mode 100644 index 1b4b4c5..0000000 --- a/t/ansi-test/cons/tailp.lsp +++ /dev/null @@ -1,97 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 19 22:47:26 2003 -;;;; Contains: Tests of TAILP - - - - - -(deftest tailp.1 - (let ((x (copy-tree '(a b c d e . f)))) - (and - (tailp x x) - (tailp (cdr x) x) - (tailp (cddr x) x) - (tailp (cdddr x) x) - (tailp (cddddr x) x) - t)) - t) - -;; The next four tests test that tailp handles dotted lists. See -;; TAILP-NIL:T in the X3J13 documentation. - -(deftest tailp.2 - (notnot-mv (tailp 'e (copy-tree '(a b c d . e)))) - t) - -(deftest tailp.3 - (tailp 'z (copy-tree '(a b c d . e))) - nil) - -(deftest tailp.4 - (notnot-mv (tailp 10203040506070 - (list* 'a 'b (1- 10203040506071)))) - t) - -(deftest tailp.5 - (let ((x "abcde")) (tailp x (list* 'a 'b (copy-seq x)))) - nil) - -(deftest tailp.error.5 - (signals-error (tailp) program-error) - t) - -(deftest tailp.error.6 - (signals-error (tailp nil) program-error) - t) - -(deftest tailp.error.7 - (signals-error (tailp nil nil nil) program-error) - t) - -;; Test that tailp does not modify its arguments - -(deftest tailp.6 - (let* ((x (copy-list '(a b c d e))) - (y (cddr x))) - (let ((xcopy (make-scaffold-copy x)) - (ycopy (make-scaffold-copy y))) - (and - (tailp y x) - (check-scaffold-copy x xcopy) - (check-scaffold-copy y ycopy)))) - t) - -;; Note! The spec is ambiguous on whether this next test -;; is correct. The spec says that tailp should be prepared -;; to signal an error if the list argument is not a proper -;; list or dotted list. If listp is false, the list argument -;; is neither (atoms are not dotted lists). -;; -;; However, the sample implementation *does* work even if -;; the list argument is an atom. -;; - -#| -(defun tailp.7-body () - (loop - for x in *universe* - count (and (not (listp x)) - (eqt 'type-error - (catch-type-error (tailp x x)))))) - -(deftest tailp.7 - (tailp.7-body) - 0) -|# - -(deftest tailp.order.1 - (let ((i 0) x y) - (values - (notnot - (tailp (progn (setf x (incf i)) 'd) - (progn (setf y (incf i)) '(a b c . d)))) - i x y)) - t 2 1 2) - diff --git a/t/ansi-test/cons/tree-equal.lsp b/t/ansi-test/cons/tree-equal.lsp deleted file mode 100644 index 469ebab..0000000 --- a/t/ansi-test/cons/tree-equal.lsp +++ /dev/null @@ -1,140 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Jun 14 07:23:03 2003 -;;;; Contains: Tests of TREE-EQUAL - - - - - -(deftest tree-equal.1 - (notnot-mv (tree-equal 'a 'a)) - t) - -(deftest tree-equal.2 - (tree-equal 'a 'b) - nil) - -(deftest tree-equal.3 - (notnot-mv (tree-equal (list 'a 'b (list 'c 'd)) - (list 'a 'b (list 'c 'd)))) - t) - -(deftest tree-equal.4 - (tree-equal '(a b c d) '(a b c e)) - nil) - -(deftest tree-equal.5 - (notnot-mv (tree-equal 1 2 :test #'<)) - t) - -(deftest tree-equal.6 - (notnot-mv (tree-equal 1 2 :test #'(lambda (x y) (values (< x y) t)))) - t) - -(deftest tree-equal.7 - (tree-equal 1 2 :test #'>) - nil) - -(deftest tree-equal.8 - (tree-equal (list 1) 2 :test (constantly t)) - nil) - -(deftest tree-equal.9 - (tree-equal (list 1) (list 2) - :test #'(lambda (x y) (or (and (consp x) (consp y)) - (eql x y)))) - nil) - -(deftest tree-equal.10 - (notnot-mv (tree-equal '(10 20 . 30) '(11 22 . 34) :test #'<)) - t) - -(deftest tree-equal.11 - (let* ((x (list 'a 'b)) - (y (list x x)) - (z (list (list 'a 'b) (list 'a 'b)))) - (notnot-mv (tree-equal y z))) - t) - -(deftest tree-equal.12 - (tree-equal 'a '(a b)) - nil) - -(deftest tree-equal.13 - (tree-equal '(a) '(a b)) - nil) - -(deftest tree-equal.14 - (tree-equal '(a b) '(a)) - nil) - -(deftest tree-equal.15 - (let ((x (vector 'a 'b 'c)) - (y (vector 'a' 'b 'c))) - (tree-equal x y)) - nil) - -(deftest tree-equal.16 - (let ((x (copy-seq "")) - (y (copy-seq ""))) - (tree-equal x y)) - nil) - -(defharmless tree-equal.test-and-test-not.1 - (tree-equal '(a b) '(a b) :test #'eql :test-not #'eql)) - -(defharmless tree-equal.test-and-test-not.2 - (tree-equal '(a b) '(a b) :test-not #'eql :test #'eql)) - -;;; Keywords tests - -(deftest tree-equal.allow-other-keys.1 - (notnot-mv (tree-equal '(a b) (list 'a 'b) :allow-other-keys nil)) - t) - -(deftest tree-equal.allow-other-keys.2 - (tree-equal '(a b) (list 'a 'c) :allow-other-keys nil :test #'eql) - nil) - -(deftest tree-equal.allow-other-keys.3 - (tree-equal '(a b) (list 'a 'z) :allow-other-keys t :foo t) - nil) - -(deftest tree-equal.allow-other-keys.4 - (notnot-mv (tree-equal '(a b) (list 'a 'b) :allow-other-keys t - :allow-other-keys nil :foo t)) - t) - -(deftest tree-equal.keywords.1 - (notnot-mv (tree-equal '(a . b) '(b . a) - :test (complement #'eql) - :test #'eql)) - t) - - -;;; Error tests - -(deftest tree-equal.error.1 - (signals-error (tree-equal) program-error) - t) - -(deftest tree-equal.error.2 - (signals-error (tree-equal '(a b)) program-error) - t) - -(deftest tree-equal.error.3 - (signals-error (tree-equal '(a b) '(a b) (gensym) t) program-error) - t) - -(deftest tree-equal.error.4 - (signals-error (tree-equal '(a b) '(a b) (gensym) t :allow-other-keys nil) program-error) - t) - -(deftest tree-equal.error.5 - (signals-error (tree-equal '(a b) '(a b) :test #'identity) program-error) - t) - -(deftest tree-equal.error.6 - (signals-error (tree-equal '(a b) '(a b) :test #'(lambda (x y z) (eq x y))) program-error) - t) diff --git a/t/ansi-test/cons/union.lsp b/t/ansi-test/cons/union.lsp deleted file mode 100644 index 04b7d81..0000000 --- a/t/ansi-test/cons/union.lsp +++ /dev/null @@ -1,429 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Apr 20 07:41:24 2003 -;;;; Contains: Tests of UNION - - - - - -(deftest union.1 - (union nil nil) - nil) - -(deftest union.2 - (union-with-check (list 'a) nil) - (a)) - -(deftest union.3 - (union-with-check (list 'a) (list 'a)) - (a)) - -(deftest union-4 - (union-with-check (list 1) (list 1)) - (1)) - -(deftest union.5 - (let ((x (list 'a 'b))) - (union-with-check (list x) (list x))) - ((a b))) - -(deftest union.6 - (let ((x (copy-list '(a b c d e f))) - (y (copy-list '(z c y a v b)))) - (let ((result (union-with-check x y))) - (check-union x y result))) - t) - -(deftest union.6-a - (let ((x (copy-list '(a b c d e f))) - (y (copy-list '(z c y a v b)))) - (let ((result (union-with-check x y :test #'eq))) - (check-union x y result))) - t) - -(deftest union.7 - (let ((x (copy-list '(a b c d e f))) - (y (copy-list '(z c y a v b)))) - (let ((result (union-with-check x y :test #'eql))) - (check-union x y result))) - t) - -(deftest union.8 - (let ((x (copy-list '(a b c d e f))) - (y (copy-list '(z c y a v b)))) - (let ((result (union-with-check x y :test #'equal))) - (check-union x y result))) - t) - -(deftest union.9 - (let ((x (copy-list '(a b c d e f))) - (y (copy-list '(z c y a v b)))) - (let ((result (union-with-check x y :test-not (complement #'eql)))) - (check-union x y result))) - t) - -(deftest union.10 - (let ((x (copy-list '(a b c d e f))) - (y (copy-list '(z c y a v b)))) - (let ((result (union-with-check x y :test-not (complement #'equal)))) - (check-union x y result))) - t) - -(deftest union.11 - (let ((x (copy-list '(a b c d e f))) - (y (copy-list '(z c y a v b)))) - (let ((result (union-with-check x y :test-not (complement #'eq)))) - (check-union x y result))) - t) - -(deftest union.12 - (let ((x (copy-list '(1 2 3 4 5 6 7))) - (y (copy-list '(10 19 5 3 17 1001 2)))) - (let ((result (union-with-check x y))) - (check-union x y result))) - t) - -(deftest union.13 - (let ((x (copy-list '(1 2 3 4 5 6 7))) - (y (copy-list '(10 19 5 3 17 1001 2)))) - (let ((result (union-with-check x y :test #'equal))) - (check-union x y result))) - t) - -(deftest union.14 - (let ((x (copy-list '(1 2 3 4 5 6 7))) - (y (copy-list '(10 19 5 3 17 1001 2)))) - (let ((result (union-with-check x y :test #'eql))) - (check-union x y result))) - t) - -(deftest union.15 - (let ((x (copy-list '(1 2 3 4 5 6 7))) - (y (copy-list '(10 19 5 3 17 1001 2)))) - (let ((result (union-with-check x y :test-not (complement #'equal)))) - (check-union x y result))) - t) - -(deftest union.16 - (let ((x (copy-list '(1 2 3 4 5 6 7))) - (y (copy-list '(10 19 5 3 17 1001 2)))) - (let ((result (union-with-check x y :test-not (complement #'eql)))) - (check-union x y result))) - t) - -(deftest union.17 - (let ((x (copy-list '(1 2 3 4 5 6 7))) - (y (copy-list '(10 19 5 3 17 1001 2)))) - (let ((result (union-with-check-and-key x y #'1+))) - (check-union x y result))) - t) - -(deftest union.18 - (let ((x (copy-list '(1 2 3 4 5 6 7))) - (y (copy-list '(10 19 5 3 17 1001 2)))) - (let ((result (union-with-check-and-key x y #'1+ :test #'equal))) - (check-union x y result))) - t) - -(deftest union.19 - (let ((x (copy-list '(1 2 3 4 5 6 7))) - (y (copy-list '(10 19 5 3 17 1001 2)))) - (let ((result (union-with-check-and-key x y #'1+ :test #'eql))) - (check-union x y result))) - t) - -(deftest union.20 - (let ((x (copy-list '(1 2 3 4 5 6 7))) - (y (copy-list '(10 19 5 3 17 1001 2)))) - (let ((result (union-with-check-and-key x y #'1+ - :test-not (complement #'equal)))) - (check-union x y result))) - t) - -(deftest union.21 - (let ((x (copy-list '(1 2 3 4 5 6 7))) - (y (copy-list '(10 19 5 3 17 1001 2)))) - (let ((result (union-with-check-and-key x y #'1+ - :test-not (complement #'equal)))) - (check-union x y result))) - t) - -(deftest union.22 - (let ((x (copy-list '(1 2 3 4 5 6 7))) - (y (copy-list '(10 19 5 3 17 1001 2)))) - (let ((result (union-with-check-and-key x y nil))) - (check-union x y result))) - t) - -(deftest union.23 - (let ((x (copy-list '(1 2 3 4 5 6 7))) - (y (copy-list '(10 19 5 3 17 1001 2)))) - (let ((result (union-with-check-and-key x y '1+))) - (check-union x y result))) - t) - -;; Do large numbers of random units - -(deftest union.24 - (do-random-unions 100 100 200) - nil) - -(deftest union.25 - (let ((x (shuffle '(1 4 6 10 45 101))) - (y (copy-list '(102 5 2 11 44 6)))) - (let ((result (union-with-check x y - :test #'(lambda (a b) - (<= (abs (- a b)) 1))))) - (and - (not (eqt result 'failed)) - (sort - (sublis - '((2 . 1) (5 . 4) (11 . 10) (45 . 44) (102 . 101)) - (copy-list result)) - #'<)))) - (1 4 6 10 44 101)) - -;;; Check that union uses eql, not equal or eq - -(deftest union.26 - (let ((x 1000) - (y 1000)) - (loop - while (not (typep x 'bignum)) - do (progn - (setf x (* x x)) - (setf y (* y y)))) - (notnot-mv - (or - (eqt x y) ;; if bignums are eq, the test is worthless - (eql (length - (union-with-check - (list x) (list x))) - 1)))) - t) - -(deftest union.27 - (union-with-check (list (copy-seq "aa")) - (list (copy-seq "aa"))) - ("aa" "aa")) - -;; Check that union does not reverse the arguments to :test, :test-not - -(deftest union.28 - (block fail - (sort - (union-with-check - (list 1 2 3) - (list 4 5 6) - :test #'(lambda (x y) - (when (< y x) (return-from fail 'fail)) - (eql x y))) - #'<)) - (1 2 3 4 5 6)) - -(deftest union.29 - (block fail - (sort - (union-with-check-and-key - (list 1 2 3) - (list 4 5 6) - #'identity - :test #'(lambda (x y) - (when (< y x) (return-from fail 'fail)) - (eql x y))) - #'<)) - (1 2 3 4 5 6)) - -(deftest union.30 - (block fail - (sort - (union-with-check - (list 1 2 3) - (list 4 5 6) - :test-not - #'(lambda (x y) - (when (< y x) (return-from fail 'fail)) - (not (eql x y)))) - #'<)) - (1 2 3 4 5 6)) - -(deftest union.31 - (block fail - (sort - (union-with-check-and-key - (list 1 2 3) - (list 4 5 6) - #'identity - :test-not #'(lambda (x y) - (when (< y x) (return-from fail 'fail)) - (not (eql x y)))) - #'<)) - (1 2 3 4 5 6)) - -(defharmless union.test-and-test-not.1 - (union (list 1 4 8 10) (list 1 2 3 9 10 13) :test #'eql :test-not #'eql)) - -(defharmless union.test-and-test-not.2 - (union (list 1 4 8 10) (list 1 2 3 9 10 13) :test-not #'eql :test #'eql)) - - -;;; Order of evaluation tests - -(deftest union.order.1 - (let ((i 0) x y) - (values - (sort - (union (progn (setf x (incf i)) (copy-list '(1 3 5))) - (progn (setf y (incf i)) (copy-list '(2 5 8)))) - #'<) - i x y)) - (1 2 3 5 8) - 2 1 2) - -(deftest union.order.2 - (let ((i 0) x y z w) - (values - (sort - (union (progn (setf x (incf i)) (copy-list '(1 3 5))) - (progn (setf y (incf i)) (copy-list '(2 5 8))) - :test (progn (setf z (incf i)) #'eql) - :key (progn (setf w (incf i)) #'identity)) - #'<) - i x y z w)) - (1 2 3 5 8) - 4 1 2 3 4) - - -(deftest union.order.3 - (let ((i 0) x y z w) - (values - (sort - (union (progn (setf x (incf i)) (copy-list '(1 3 5))) - (progn (setf y (incf i)) (copy-list '(2 5 8))) - :key (progn (setf z (incf i)) #'identity) - :test (progn (setf w (incf i)) #'eql)) - #'<) - i x y z w)) - (1 2 3 5 8) - 4 1 2 3 4) - -;;; Keyword tests - -(deftest union.allow-other-keys.1 - (sort (union (list 7 9 1 5) (list 10 11 9 20 1 2) :bad t - :allow-other-keys "yes") - #'<) - (1 2 5 7 9 10 11 20)) - -(deftest union.allow-other-keys.2 - (sort (union (list 7 9 1 5) (list 10 11 9 20 1 2) - :allow-other-keys t :also-bad t) - #'<) - (1 2 5 7 9 10 11 20)) - -(deftest union.allow-other-keys.3 - (sort (union (list 1 2 3) (list 1 2 3) - :allow-other-keys t :also-bad t - :test #'(lambda (x y) (= x (+ y 100)))) - #'<) - (1 1 2 2 3 3)) - -(deftest union.allow-other-keys.4 - (sort (union (list 7 9 1 5) (list 10 11 9 20 1 2) - :allow-other-keys t) - #'<) - (1 2 5 7 9 10 11 20)) - -(deftest union.allow-other-keys.5 - (sort (union (list 7 9 1 5) (list 10 11 9 20 1 2) - :allow-other-keys nil) - #'<) - (1 2 5 7 9 10 11 20)) - -(deftest union.allow-other-keys.6 - (sort (union (list 7 9 1 5) (list 10 11 9 20 1 2) - :allow-other-keys t - :allow-other-keys nil) - #'<) - (1 2 5 7 9 10 11 20)) - -(deftest union.allow-other-keys.7 - (sort (union (list 7 9 1 5) (list 10 11 9 20 1 2) - :allow-other-keys t - :allow-other-keys nil - '#:x 1) - #'<) - (1 2 5 7 9 10 11 20)) - -(deftest union.keywords.9 - (sort (union (list 1 2 3) (list 1 2 3) - :test #'(lambda (x y) (= x (+ y 100))) - :test #'eql) - #'<) - (1 1 2 2 3 3)) - -(def-fold-test union.fold.1 (union '(a b c d e) '(d x y a w c))) - -;;; Error tests - -(deftest union.error.1 - (signals-error (union) program-error) - t) - -(deftest union.error.2 - (signals-error (union nil) program-error) - t) - -(deftest union.error.3 - (signals-error (union nil nil :bad t) program-error) - t) - -(deftest union.error.4 - (signals-error (union nil nil :key) program-error) - t) - -(deftest union.error.5 - (signals-error (union nil nil 1 2) program-error) - t) - -(deftest union.error.6 - (signals-error (union nil nil :bad t :allow-other-keys nil) program-error) - t) - -(deftest union.error.7 - (signals-error (union (list 1 2) (list 3 4) :test #'identity) program-error) - t) - -(deftest union.error.8 - (signals-error (union (list 1 2) (list 3 4) :test-not #'identity) program-error) - t) - -(deftest union.error.9 - (signals-error (union (list 1 2) (list 3 4) :key #'cons) program-error) - t) - -(deftest union.error.10 - (signals-error (union (list 1 2) (list 3 4) :key #'car) type-error) - t) - -(deftest union.error.11 - (signals-error (union (list 1 2 3) (list* 4 5 6)) type-error) - t) - -(deftest union.error.12 - (signals-error (union (list* 1 2 3) (list 4 5 6)) type-error) - t) - -;;; The next two tests used to check for union with NIL, but arguably -;;; that goes beyond the 'be prepared to signal an error' requirement, -;;; since a union algorithm doesn't have to traverse one argument -;;; if the other is the empty list. - -(deftest union.error.13 - (check-type-error #'(lambda (x) (union x '(1 2))) #'listp) - nil) - -(deftest union.error.14 - (check-type-error #'(lambda (x) (union '(1 2) x)) #'listp) - nil) diff --git a/t/ansi-test/data-and-control-flow/and.lsp b/t/ansi-test/data-and-control-flow/and.lsp deleted file mode 100644 index 304f18a..0000000 --- a/t/ansi-test/data-and-control-flow/and.lsp +++ /dev/null @@ -1,84 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Oct 18 07:23:48 2002 -;;;; Contains: Tests for AND - - - -(deftest and.1 - (and) - t) - -(deftest and.2 - (and nil) - nil) - -(deftest and.3 - (and 'a) - a) - -(deftest and.4 - (and (values 'a 'b 'c)) - a b c) - -(deftest and.5 (and (values))) - -(deftest and.6 - (and (values t nil) 'a) - a) - -(deftest and.7 - (and nil (values 'a 'b 'c)) - nil) - -(deftest and.8 - (and (values 1 nil) (values nil 2)) - nil 2) - -(deftest and.9 - (and (values nil t) t) - nil) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest and.10 - (macrolet - ((%m (z) z)) - (and (expand-in-current-env (%m :a)) - (expand-in-current-env (%m :b)) - (expand-in-current-env (%m :c)))) - :c) - -;;; Error tests - -(deftest and.order.1 - (let ((x 0)) - (values (and nil (incf x)) - x)) - nil 0) - -(deftest and.order.2 - (let ((i 0) a b c d) - (values - (and (setf a (incf i)) - (setf b (incf i)) - (setf c (incf i)) - (setf d (incf i))) - i a b c d)) - 4 4 1 2 3 4) - -(deftest and.error.1 - (signals-error (funcall (macro-function 'and)) - program-error) - t) - -(deftest and.error.2 - (signals-error (funcall (macro-function 'and) '(and)) - program-error) - t) - -(deftest and.error.3 - (signals-error (funcall (macro-function 'and) '(and) nil nil) - program-error) - t) diff --git a/t/ansi-test/data-and-control-flow/apply.lsp b/t/ansi-test/data-and-control-flow/apply.lsp deleted file mode 100644 index 6622925..0000000 --- a/t/ansi-test/data-and-control-flow/apply.lsp +++ /dev/null @@ -1,77 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Jan 13 15:13:07 2003 -;;;; Contains: Tests of APPLY - - - -;;; Error cases - -(deftest apply.error.1 - (signals-error (apply) program-error) - t) - -(deftest apply.error.2 - (signals-error (apply #'cons) program-error) - t) - -(deftest apply.error.3 - (signals-error (apply #'cons nil) program-error) - t) - -(deftest apply.error.4 - (signals-error (apply #'cons (list 1 2 3)) - program-error) - t) - -;;; Non-error cases - -(deftest apply.1 - (apply #'cons 'a 'b nil) - (a . b)) - -(deftest apply.2 - (apply #'cons 'a '(b)) - (a . b)) - -(deftest apply.3 - (apply #'cons '(a b)) - (a . b)) - -(deftest apply.4 - (let ((zeros (make-list (min 10000 (1- call-arguments-limit)) - :initial-element 1))) - (apply #'+ zeros)) - #.(min 10000 (1- call-arguments-limit))) - -(deftest apply.5 - (apply 'cons '(a b)) - (a . b)) - -(deftest apply.6 - (macrolet ((%m (z) z)) - (apply (expand-in-current-env (%m 'cons)) 1 2 nil)) - (1 . 2)) - -(deftest apply.7 - (macrolet ((%m (z) z)) - (apply #'cons (expand-in-current-env (%m 1)) '(2))) - (1 . 2)) - -(deftest apply.8 - (macrolet ((%m (z) z)) - (apply #'cons (expand-in-current-env (%m '(1 2))))) - (1 . 2)) - -(deftest apply.order.1 - (let ((i 0) x y z) - (values - (apply (progn (setf x (incf i)) - #'list) - (progn (setf y (incf i)) - 'b) - (progn (setf z (incf i)) - (list 'a))) - i x y z)) - (b a) 3 1 2 3) - diff --git a/t/ansi-test/data-and-control-flow/block.lsp b/t/ansi-test/data-and-control-flow/block.lsp deleted file mode 100644 index fa802f9..0000000 --- a/t/ansi-test/data-and-control-flow/block.lsp +++ /dev/null @@ -1,93 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Oct 12 12:30:46 2002 -;;;; Contains: Tests of BLOCK - - - -(deftest block.1 - (block foo - (return-from foo 1)) - 1) - -(deftest block.2 - (block nil - (block foo - (return 'good)) - 'bad) - good) - -(deftest block.3 - (block done - (flet ((%f (x) (return-from done x))) - (%f 'good)) - 'bad) - good) - -(deftest block.4 - (block foo - (block foo - (return-from foo 'bad)) - 'good) - good) - -(deftest block.5 - (block done - (flet ((%f (x) (return-from done x))) - (mapcar #'%f '(good bad bad))) - 'bad) - good) - -(deftest block.6 - (block b1 - (return-from b1 (values)) - 1)) - -(deftest block.7 - (block b1 - (return-from b1 (values 1 2 3 4)) - 1) - 1 2 3 4) - -(deftest block.8 - (block foo) - nil) - -(deftest block.9 - (block foo (values 'a 'b) (values 'c 'd)) - c d) - -(deftest block.10 - (block done - (flet ((%f (x) (return-from done x))) - (block done (mapcar #'%f '(good bad bad)))) - 'bad) - good) - -;;; Block has no tagbody -(deftest block.11 - (block done - (tagbody - (block nil - (go 10) - 10 - (return-from done 'bad)) - 10 - (return-from done 'good))) - good) - -;;; Macros are expanded in the appropriate environment - -(deftest block.12 - (macrolet ((%m (z) z)) - (block foo (expand-in-current-env (%m :good)))) - :good) - -#| -(deftest return.error.1 - (signals-error - (block nil - (return 'a 'b)) - program-error) - t) -|# diff --git a/t/ansi-test/data-and-control-flow/call-arguments-limit.lsp b/t/ansi-test/data-and-control-flow/call-arguments-limit.lsp deleted file mode 100644 index 1c27e12..0000000 --- a/t/ansi-test/data-and-control-flow/call-arguments-limit.lsp +++ /dev/null @@ -1,29 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Oct 10 22:39:25 2002 -;;;; Contains: Tests for CALL-ARGUMENTS-LIMIT - - - -(deftest call-arguments-limit.1 - (notnot-mv (constantp 'call-arguments-limit)) - t) - -(deftest call-arguments-limit.2 - (notnot-mv (typep call-arguments-limit 'integer)) - t) - -(deftest call-arguments-limit.3 - (< call-arguments-limit 50) - nil) - -(deftest call-arguments-limit.4 - (let* ((m (min 65536 (1- call-arguments-limit))) - (args (make-list m :initial-element 'a))) - (equalt (apply #'list args) args)) - t) - -(deftest call-arguments-limit.5 - (< call-arguments-limit lambda-parameters-limit) - nil) - diff --git a/t/ansi-test/data-and-control-flow/case.lsp b/t/ansi-test/data-and-control-flow/case.lsp deleted file mode 100644 index 8ead570..0000000 --- a/t/ansi-test/data-and-control-flow/case.lsp +++ /dev/null @@ -1,222 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Oct 18 19:56:44 2002 -;;;; Contains: Tests of CASE - - - -(deftest case.1 - (case 'a) - nil) - -(deftest case.2 - (case 10 (10 'a)) - a) - -(deftest case.3 - (case (copy-seq "abc") ("abc" 'a)) - nil) - -(deftest case.4 - (case 'z ((a b c) 1) - ((d e) 2) - ((f z g) 3) - (t 4)) - 3) - -(deftest case.5 - (case (1+ most-positive-fixnum) - (#.(1+ most-positive-fixnum) 'a)) - a) - -(deftest case.6 - (case nil (nil 'a) (t 'b)) - b) - -(deftest case.7 - (case nil ((nil) 'a) (t 'b)) - a) - -(deftest case.8 - (case 'a (b 0) (a (values 1 2 3)) (t nil)) - 1 2 3) - -(deftest case.9 - (case 'c (b 0) (a (values 1 2 3)) (t (values 'x 'y 'z))) - x y z) - -(deftest case.10 - (case 'z (b 1) (a 2) (z (values)) (t nil))) - -(deftest case.11 - (case 'z (b 1) (a 2) (t (values)))) - -(deftest case.12 - (case t (a 10)) - nil) - -(deftest case.13 - (case t ((t) 10) (t 20)) - 10) - -(deftest case.14 - (let ((x (list 'a 'b))) - (eval `(case (quote ,x) ((,x) 1) (t 2)))) - 1) - -(deftest case.15 - (case 'otherwise ((t) 10)) - nil) - -(deftest case.16 - (case t ((otherwise) 10)) - nil) - -(deftest case.17 - (case 'a (b 0) (c 1) (otherwise 2)) - 2) - -(deftest case.18 - (case 'a (b 0) (c 1) ((otherwise) 2)) - nil) - -(deftest case.19 - (case 'a (b 0) (c 1) ((t) 2)) - nil) - -(deftest case.20 - (case #\a - ((#\b #\c) 10) - ((#\d #\e #\A) 20) - (() 30) - ((#\z #\a #\y) 40)) - 40) - -(deftest case.21 (case 1 (1 (values)))) - -(deftest case.22 (case 2 (t (values)))) - -(deftest case.23 (case 1 (1 (values 'a 'b 'c))) - a b c) - -(deftest case.24 (case 2 (t (values 'a 'b 'c))) - a b c) - -;;; Show that the key expression is evaluated only once. -(deftest case.25 - (let ((x 0)) - (values - (case (progn (incf x) 'c) - (a 1) - (b 2) - (c 3) - (t 4)) - x)) - 3 1) - -;;; Repeated keys are allowed (all but the first are ignored) - -(deftest case.26 - (case 'b ((a b c) 10) (b 20)) - 10) - -(deftest case.27 - (case 'b (b 20) ((a b c) 10)) - 20) - -(deftest case.28 - (case 'b (b 20) (b 10) (t 0)) - 20) - -;;; There are implicit progns - -(deftest case.29 - (let ((x nil)) - (values - (case 2 - (1 (setq x 'a) 'w) - (2 (setq x 'b) 'y) - (t (setq x 'c) 'z)) - x)) - y b) - -(deftest case.30 - (let ((x nil)) - (values - (case 10 - (1 (setq x 'a) 'w) - (2 (setq x 'b) 'y) - (t (setq x 'c) 'z)) - x)) - z c) - -(deftest case.31 - (case (values 'b 'c) (c 0) ((a b) 10) (t 20)) - 10) - -(deftest case.32 - (case 'a (a) (t 'b)) - nil) - -(deftest case.33 - (case 'a (b 'b) (t)) - nil) - -(deftest case.34 - (case 'a (b 'b) (otherwise)) - nil) - -;;; No implicit tagbody -(deftest case.35 - (block done - (tagbody - (case 'a (a (go 10) - 10 - (return-from done 'bad))) - 10 - (return-from done 'good))) - good) - -(deftest case.36 - (block done - (tagbody - (case 'b - (a 'bad) - (otherwise (go 10) - 10 - (return-from done 'bad))) - 10 - (return-from done 'good))) - good) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest case.37 - (macrolet - ((%m (z) z)) - (case (expand-in-current-env (%m :b)) - (:a :bad1) - (:b :good) - (:c :bad2) - (t :bad3))) - :good) - -;;; (deftest case.error.1 -;;; (signals-error (case) program-error) -;;; t) - -(deftest case.error.1 - (signals-error (funcall (macro-function 'case)) - program-error) - t) - -(deftest case.error.2 - (signals-error (funcall (macro-function 'case) '(case t)) - program-error) - t) - -(deftest case.error.3 - (signals-error (funcall (macro-function 'case) '(case t) nil nil) - program-error) - t) diff --git a/t/ansi-test/data-and-control-flow/catch.lsp b/t/ansi-test/data-and-control-flow/catch.lsp deleted file mode 100644 index bd7d435..0000000 --- a/t/ansi-test/data-and-control-flow/catch.lsp +++ /dev/null @@ -1,109 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Oct 12 13:04:02 2002 -;;;; Contains: Tests of CATCH and THROW - - - -(deftest catch.1 - (catch 'foo) - nil) - -(deftest catch.2 - (catch 'foo 'a) - a) - -(deftest catch.3 - (catch 'foo (values))) - -(deftest catch.4 - (catch 'foo (values 1 2 3)) - 1 2 3) - -(deftest catch.5 - (catch 'foo 'a (throw 'foo 'b) 'c) - b) - -;; -;; The test below is wrong: -;; Numbers can't be assumed to be EQ at -;; any time by conforming programs. -;; -;; (deftest catch.6 -;; (let ((tag1 (1+ most-positive-fixnum)) -;; (tag2 (1+ most-positive-fixnum))) -;; (if (eqt tag1 tag2) -;; 'good -;; (catch tag1 -;; (catch tag2 (throw tag1 'good)) -;; 'bad))) -;; good) - -(deftest catch.7 - (catch 'foo 'a (throw 'foo (values)) 'c)) - -(deftest catch.8 - (catch 'foo 'a (throw 'foo (values 1 2 3)) 'c) - 1 2 3) - -(deftest catch.9 - (let ((i 0)) - (catch (progn (incf i) 'foo) - (assert (eql i 1)) - (throw (progn (incf i 2) 'foo) i))) - 3) - -(deftest catch.10 - (flet ((%f (x) (throw 'foo x))) - (catch 'foo - (%f 'good) - 'bad)) - good) - -(defun catch.11-fn (x) (throw 'foo x)) - -(deftest catch.11 - (catch 'foo - (catch.11-fn 'good) - 'bad) - good) - -(deftest catch.12 - (labels ((%f (x) (throw 'foo x))) - (catch 'foo - (%f 'good) - 'bad)) - good) - -;;; No implicit tagbody -(deftest catch.13 - (block done - (tagbody - (catch 'foo - (go 10) - 10 - (return-from done 'bad)) - 10 - (return-from done 'good))) - good) - -;;; Macros are expanded in the appropriate environment - -(deftest catch.14 - (macrolet ((%m (z) z)) - (catch 'foo (expand-in-current-env (%m :good)))) - :good) - -(deftest catch.15 - (macrolet ((%m (z) z)) - (catch 'foo (throw (expand-in-current-env (%m 'foo)) :good) :bad)) - :good) - -(deftest catch.16 - (macrolet ((%m (z) z)) - (catch 'foo (throw 'foo (expand-in-current-env (%m :good))) :bad)) - :good) - -(deftest throw-error - (signals-error (throw (gensym) nil) control-error) - t) diff --git a/t/ansi-test/data-and-control-flow/ccase.lsp b/t/ansi-test/data-and-control-flow/ccase.lsp deleted file mode 100644 index 25914b9..0000000 --- a/t/ansi-test/data-and-control-flow/ccase.lsp +++ /dev/null @@ -1,209 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Oct 18 21:06:45 2002 -;;;; Contains: Tests of CCASE - - - -(deftest ccase.1 - (let ((x 'b)) - (ccase x (a 1) (b 2) (c 3))) - 2) - -(deftest ccase.2 - (signals-type-error x 1 (ccase x)) - t) - -(deftest ccase.3 - (signals-type-error x 1 (ccase x (a 1) (b 2) (c 3))) - t) - -;;; It is legal to use T or OTHERWISE as key designators -;;; in CCASE forms. They have no special meaning here. - -(deftest ccase.4 - (signals-type-error x 1 (ccase x (t nil))) - t) - -(deftest ccase.5 - (signals-type-error x 1 (ccase x (otherwise nil))) - t) - -(deftest ccase.6 - (let ((x 'b)) - (ccase x ((a z) 1) ((y b w) 2) ((b c) 3))) - 2) - -(deftest ccase.7 - (let ((x 'z)) - (ccase x - ((a b c) 1) - ((d e) 2) - ((f z g) 3))) - 3) - -(deftest ccase.8 - (let ((x (1+ most-positive-fixnum))) - (ccase x (#.(1+ most-positive-fixnum) 'a))) - a) - -(deftest ccase.9 - (signals-type-error x nil (ccase x (nil 'a))) - t) - -(deftest ccase.10 - (let (x) - (ccase x ((nil) 'a))) - a) - -(deftest ccase.11 - (let ((x 'a)) - (ccase x (b 0) (a (values 1 2 3)) (c nil))) - 1 2 3) - -(deftest ccase.12 - (signals-type-error x t (ccase x (a 10))) - t) - -(deftest ccase.13 - (let ((x t)) - (ccase x ((t) 10) (t 20))) - 10) - -(deftest ccase.14 - (let ((x (list 'a 'b))) - (eval `(let ((y (quote ,x))) (ccase y ((,x) 1) (a 2))))) - 1) - -(deftest ccase.15 - (signals-type-error x 'otherwise (ccase x ((t) 10))) - t) - -(deftest ccase.16 - (signals-type-error x t (ccase x ((otherwise) 10))) - t) - -(deftest ccase.17 - (signals-type-error x 'a (ccase x (b 0) (c 1) (otherwise 2))) - t) - -(deftest ccase.19 - (signals-type-error x 'a (ccase x (b 0) (c 1) ((t) 2))) - t) - -(deftest ccase.20 - (let ((x #\a)) - (ccase x - ((#\b #\c) 10) - ((#\d #\e #\A) 20) - (() 30) - ((#\z #\a #\y) 40))) - 40) - -(deftest ccase.21 (let ((x 1)) (ccase x (1 (values)) (2 'a)))) - -(deftest ccase.23 (let ((x 1)) (ccase x (1 (values 'a 'b 'c)))) - a b c) - -;;; Show that the key expression is evaluated only once. -(deftest ccase.25 - (let ((a (vector 'a 'b 'c 'd 'e)) - (i 1)) - (values - (ccase (aref a (incf i)) - (a 1) - (b 2) - (c 3) - (d 4)) - i)) - 3 2) - -;;; Repeated keys are allowed (all but the first are ignored) - -(deftest ccase.26 - (let ((x 'b)) - (ccase x ((a b c) 10) (b 20))) - 10) - -(deftest ccase.27 - (let ((x 'b)) - (ccase x (b 20) ((a b c) 10))) - 20) - -(deftest ccase.28 - (let ((x 'b)) - (ccase x (b 20) (b 10) (d 0))) - 20) - -;;; There are implicit progns - -(deftest ccase.29 - (let ((x nil) (y 2)) - (values - (ccase y - (1 (setq x 'a) 'w) - (2 (setq x 'b) 'y) - (3 (setq x 'c) 'z)) - x)) - y b) - -(deftest ccase.30 - (let ((x 'a)) - (ccase x (a))) - nil) - -(deftest ccase.31 - (handler-bind - ((type-error #'(lambda (c) (store-value 7 c)))) - (let ((x 0)) - (ccase x - (1 :bad) - (7 :good) - (2 nil)))) - :good) - -;;; No implicit tagbody -(deftest ccase.32 - (block done - (tagbody - (let ((x 'a)) - (ccase x (a (go 10) - 10 - (return-from done 'bad)))) - 10 - (return-from done 'good))) - good) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest ccase.33 - (let ((x :b)) - (macrolet - ((%m (z) z)) - (ccase (expand-in-current-env (%m x)) - (:a :bad1) - (:b :good) - (:c :bad2)))) - :good) - - - -;;; (deftest ccase.error.1 -;;; (signals-error (ccase) program-error) -;;; t) - -(deftest ccase.error.1 - (signals-error (funcall (macro-function 'ccase)) - program-error) - t) - -(deftest ccase.error.2 - (signals-error (funcall (macro-function 'ccase) '(ccase t)) - program-error) - t) - -(deftest ccase.error.3 - (signals-error (funcall (macro-function 'ccase) '(ccase t) nil nil) - program-error) - t) diff --git a/t/ansi-test/data-and-control-flow/compiled-function-p.lsp b/t/ansi-test/data-and-control-flow/compiled-function-p.lsp deleted file mode 100644 index e6ac92b..0000000 --- a/t/ansi-test/data-and-control-flow/compiled-function-p.lsp +++ /dev/null @@ -1,33 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Jan 13 16:32:44 2003 -;;;; Contains: Tests of COMPILED-FUNCTION-P - - - -(deftest compiled-function-p.1 - (check-type-predicate #'compiled-function-p 'compiled-function) - nil) - -(deftest compiled-function-p.2 - (compiled-function-p '(lambda (x y) (cons y x))) - nil) - -(deftest compiled-function-p.3 - (notnot-mv (compiled-function-p (compile nil '(lambda (y x) (cons x y))))) - t) - -(deftest compiled-function-p.order.1 - (let ((i 0)) - (values - (compiled-function-p (progn (incf i) '(lambda () nil))) - i)) - nil 1) - -(deftest compiled-function-p.error.1 - (signals-error (compiled-function-p) program-error) - t) - -(deftest compiled-function-p.error.2 - (signals-error (compiled-function-p nil nil) program-error) - t) diff --git a/t/ansi-test/data-and-control-flow/complement.lsp b/t/ansi-test/data-and-control-flow/complement.lsp deleted file mode 100644 index b37de56..0000000 --- a/t/ansi-test/data-and-control-flow/complement.lsp +++ /dev/null @@ -1,139 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Oct 6 20:04:33 2002 -;;;; Contains: Tests for COMPLEMENT - - - -(deftest complement.1 - (notnot-mv (funcall (complement #'identity) nil)) - t) - -(deftest complement.2 - (funcall (complement #'identity) t) - nil) - -(deftest complement.3 - (check-predicate - #'(lambda (x) (eql (funcall (cl::complement #'not) x) - (not (not x))))) - nil) - -(deftest complement.4 - (let ((x '(#\b))) - (loop for i from 2 to (min 256 (1- call-arguments-limit)) - always (progn - (push #\a x) - (apply (complement #'char=) x)))) - t) - -(deftest complement.5 - (notnot-mv (complement #'identity)) - t) - -(deftest complement.6 - (flet ((%f (&rest args) (notnot (evenp (length args))))) - (let ((cf (complement #'%f))) - (values - (%f) (%f 'a) (%f 'a 'b) (%f 'a 'b 'c) - (funcall cf) (funcall cf 'a) (funcall cf 'a 'b) (funcall cf 'a 'b 'c)))) - t nil t nil - nil t nil t) - -(deftest complement.7 - (flet ((%f (&optional x y) (if x (not y) y))) - (let ((cf (complement #'%f))) - (values - (%f) (%f nil) (%f t) (%f nil nil) (%f t nil) (%f nil t) (%f t t) - (funcall cf) (funcall cf nil) (funcall cf t) - (funcall cf nil nil) (funcall cf t nil) - (funcall cf nil t) (funcall cf t t)))) - nil nil t nil t t nil - t t nil t nil nil t) - -(deftest complement.8 - (flet ((%f (&key x y) (if x (not y) y))) - (let ((cf (complement #'%f))) - (values - (list - (%f) - (%f :x nil) (%f :x t) - (%f :y nil) (%f :y t :y nil) - (%f :x nil :y nil) (%f :x t :y nil) - (%f :y t :x nil) (%f :x t :y t)) - - (list - (funcall cf) (funcall cf :x nil) (funcall cf :x t) - (funcall cf :y nil) (funcall cf :y t) - (funcall cf :x nil :y nil) (funcall cf :x t :y nil) - (funcall cf :y t :x nil) (funcall cf :x t :y t :x nil)) - (list - (funcall cf :x nil :y t :foo nil :allow-other-keys t) - (funcall cf :x nil :y t :allow-other-keys nil))))) - (nil nil t nil t nil t t nil) - (t t nil t nil t nil nil t) - (nil nil)) - -(deftest complement.9 - (let ((sym (gensym))) - (eval `(defgeneric ,sym (x y))) - (eval `(defmethod ,sym ((x integer) (y integer)) (evenp (+ x y)))) - (eval `(defmethod ,sym ((x t) (y t)) nil)) - (let ((cf (complement (symbol-function sym)))) - (values (funcall cf 'a 'b) - (funcall cf 0 0) - (funcall cf 0 1) - (funcall cf 1 0) - (funcall cf 1 1)))) - t nil t t nil) - -(deftest complement.10 - (let ((cf (complement (compile nil '(lambda (x y) (evenp (+ x y))))))) - (values (funcall cf 0 0) - (funcall cf 0 1) - (funcall cf 1 0) - (funcall cf 1 1))) - nil t t nil) - -(deftest complement.order.1 - (let ((i 0)) - (let ((fn (complement (progn (incf i) #'null)))) - (values - i - (mapcar fn '(a b nil c 1 nil t nil)) - i))) - 1 (t t nil t t nil t nil) 1) - -;;; Error tests - -(deftest complement.error.1 - (signals-error (complement) program-error) - t) - -(deftest complement.error.2 - (signals-error (complement #'not t) program-error) - t) - -(deftest complement.error.3 - (signals-error (funcall (complement #'identity)) - program-error) - t) - -(deftest complement.error.4 - (signals-error (funcall (complement #'identity) t t) - program-error) - t) - -(deftest complement.error.5 - (signals-error (funcall (complement #'(lambda (&key) t)) :foo t) program-error) - t) - -(deftest complement.error.6 - (signals-error (funcall (complement #'(lambda (&key) t)) :allow-other-keys nil - :allow-other-keys t :foo t) program-error) - t) - -(deftest complement.error.7 - (signals-error (funcall (complement #'(lambda (x &rest y) (and x (evenp (length y)))))) - program-error) - t) diff --git a/t/ansi-test/data-and-control-flow/cond.lsp b/t/ansi-test/data-and-control-flow/cond.lsp deleted file mode 100644 index d583210..0000000 --- a/t/ansi-test/data-and-control-flow/cond.lsp +++ /dev/null @@ -1,118 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Oct 18 07:37:58 2002 -;;;; Contains: Tests of COND - - - -(deftest cond.1 - (cond) - nil) - -(deftest cond.2 - (cond ('a)) - a) - -(deftest cond.3 - (cond (nil)) - nil) - -(deftest cond.4 - (cond (nil 'a) (nil 'b)) - nil) - -(deftest cond.5 - (cond (nil 'a) ('b)) - b) - -(deftest cond.6 - (cond (t 'a) (t 'b)) - a) - -(deftest cond.7 - (let ((x 0)) - (values - (cond ((progn (incf x) nil) 'a) (t 'b) ((incf x) 'c)) - x)) - b 1) - -(deftest cond.8 - (let ((x 0)) - (values - (cond (nil (incf x) 'a) - (nil (incf x 10) 'b) - (t (incf x 2) 'c) - (t (incf x 100) 'd)) - x)) - c 2) - -(deftest cond.9 - (cond ((values 'a 'b 'c))) - a) - -(deftest cond.10 - (cond (t (values 'a 'b 'c))) - a b c) - -(deftest cond.11 - (cond - ((values nil t) 'a) - (t 'b)) - b) - -(deftest cond.12 - (cond ((values))) - nil) - -(deftest cond.13 - (cond ((values)) (t 'a)) - a) - -(deftest cond.14 (cond (t (values)))) - -;;; No implicit tagbody -(deftest cond.15 - (block done - (tagbody - (cond (t (go 10) - 10 - (return-from done 'bad))) - 10 - (return-from done 'good))) - good) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest cond.16 - (macrolet - ((%m (z) z)) - (cond ((expand-in-current-env (%m nil)) :bad) - (t :good))) - :good) - -(deftest cond.17 - (macrolet - ((%m (z) z)) - (cond (nil :bad1) - ((expand-in-current-env (%m :good))) - (t :bad2))) - :good) - -;;; Error tests - -(deftest cond.error.1 - (signals-error (funcall (macro-function 'cond)) - program-error) - t) - -(deftest cond.error.2 - (signals-error (funcall (macro-function 'cond) '(cond)) - program-error) - t) - -(deftest cond.error.3 - (signals-error (funcall (macro-function 'cond) '(cond) nil nil) - program-error) - t) - diff --git a/t/ansi-test/data-and-control-flow/constantly.lsp b/t/ansi-test/data-and-control-flow/constantly.lsp deleted file mode 100644 index 02e5d68..0000000 --- a/t/ansi-test/data-and-control-flow/constantly.lsp +++ /dev/null @@ -1,37 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Oct 6 19:47:16 2002 -;;;; Contains: Tests for CONSTANTLY - - - -(deftest constantly.1 - (let ((fn (cl:constantly 10)) - (x nil)) - (loop for i from 0 to (min 256 (1- call-arguments-limit)) - always (prog1 (eql (apply fn x) 10) - (push 'a x)))) - t) - -(deftest constantly.2 - (notnot-mv (cl:constantly 1)) - t) - -(deftest constantly.3 - (let ((i 0)) - (let ((fn (cl:constantly (progn (incf i) 'a)))) - (values - i - (mapcar fn '(1 2 3 4)) - i))) - 1 (a a a a) 1) - -(deftest constantly.error.1 - (signals-error (cl:constantly) program-error) - t) - -;;; The next test fails in CMUCL, which has non-conformantly extended -;;; the syntax of constantly. -(deftest constantly.error.2 - (signals-error (cl:constantly 1 1) program-error) - t) diff --git a/t/ansi-test/data-and-control-flow/ctypecase.lsp b/t/ansi-test/data-and-control-flow/ctypecase.lsp deleted file mode 100644 index 08dbe95..0000000 --- a/t/ansi-test/data-and-control-flow/ctypecase.lsp +++ /dev/null @@ -1,147 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Oct 18 23:05:10 2002 -;;;; Contains: Tests of CTYPECASE - - - -(deftest ctypecase.1 - (let ((x 1)) - (ctypecase x (integer 'a) (t 'b))) - a) - -(deftest ctypecase.2 - (check-type-error #'(lambda (x) (ctypecase x (symbol 'a))) #'symbolp) - nil) - -(deftest ctypecase.3 - (let ((x 1)) - (ctypecase x (symbol 'a) (t 'b))) - b) - -(deftest ctypecase.4 - (let ((x 1)) - (ctypecase x (t (values))))) - -(deftest ctypecase.5 - (let ((x 1)) - (ctypecase x (integer (values)) (t 'a)))) - -(deftest ctypecase.6 - (let ((x 1)) - (ctypecase x (bit 'a) (integer 'b))) - a) - -(deftest ctypecase.7 - (let ((x 1)) - (ctypecase x (t 'a))) - a) - -(deftest ctypecase.8 - (let ((x 1)) - (ctypecase x (t (values 'a 'b 'c)))) - a b c) - -(deftest ctypecase.9 - (let ((x 1)) - (ctypecase x (integer (values 'a 'b 'c)) (t nil))) - a b c) - -(deftest ctypecase.10 - (let ((x 0) (y 1)) - (values - (ctypecase y - (bit (incf x) 'a) - (integer (incf x 2) 'b) - (t (incf x 4) 'c)) - x)) - a 1) - -(deftest ctypecase.11 - (let ((x 1)) - (ctypecase x (integer) (t 'a))) - nil) - -(deftest ctypecase.12 - (let ((x 1)) - (values - (handler-bind - ((type-error #'(lambda (c) - (assert (eql (type-error-datum c) 1)) - (assert (not (typep 1 (type-error-expected-type c)))) - (store-value 'a c)))) - (ctypecase x - (symbol :good) - (float :bad))) - x)) - :good a) - -;;; (deftest ctypecase.error.1 -;;; (signals-error (ctypecase) program-error) -;;; t) - - -(deftest ctypecase.13 - (let ((x 'a)) - (ctypecase x - (number 'bad) - (#.(find-class 'symbol nil) 'good))) - good) - -(deftest ctypecase.14 - (block done - (tagbody - (let ((x 'a)) - (ctypecase x (symbol (go 10) - 10 - (return-from done 'bad)))) - 10 - (return-from done 'good))) - good) - -;; Following tests (ctypecase.15 and ctypecase.16) are invalid, since -;; ctypecase provides restart, which evaluates to assignment to :foo, -;; which is constant. Both tests were transformed into valid ones and -;; moved to typecase.lsp (typecase.22 and typecase.23). -;; -;; Related discussion: -;; https://mailman.common-lisp.net/pipermail/ansi-test-devel/2012-January/000108.html - -#+(or) -(deftest ctypecase.15 - (macrolet - ((%m (z) z)) - (ctypecase - (expand-in-current-env (%m :foo)) - (integer :bad1) - (keyword :good) - (symbol :bad2))) - :good) - -#+(or) -(deftest ctypecase.16 - (macrolet - ((%m (z) z)) - (ctypecase :foo - (integer (expand-in-current-env (%m :bad1))) - (keyword (expand-in-current-env (%m :good))) - (symbol (expand-in-current-env (%m :bad2))))) - :good) - -(deftest ctypecase.error.1 - (signals-error (funcall (macro-function 'ctypecase)) - program-error) - t) - -(deftest ctypecase.error.2 - (signals-error (funcall (macro-function 'ctypecase) - '(ctypecase t)) - program-error) - t) - -(deftest ctypecase.error.3 - (signals-error (funcall (macro-function 'ctypecase) - '(ctypecase t) - nil nil) - program-error) - t) diff --git a/t/ansi-test/data-and-control-flow/data-and-control-flow.lsp b/t/ansi-test/data-and-control-flow/data-and-control-flow.lsp deleted file mode 100644 index 550703e..0000000 --- a/t/ansi-test/data-and-control-flow/data-and-control-flow.lsp +++ /dev/null @@ -1,34 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Oct 21 22:21:48 2002 -;;;; Contains: Overall tests for section 5 of spec, "Data and Control Flow" - - - -;;; Functions from section 5 -(defparameter *dcf-fns* - '(apply fboundp fmakunbound funcall function-lambda-expression - functionp compiled-function-p not eq eql equal equalp identity - complement constantly every some notevery notany - values-list get-setf-expansion)) - -;;; Macros from section 5 -(defparameter *dcf-macros* - '(defun defconstant defparameter defvar destructuring-bind - psetq return and cond or when unless case ccase ecase - multiple-value-list multiple-value-setq nth-value - prog prog* prog1 prog2 define-modify-macro defsetf - define-setf-expander setf psetf shiftf rotatef)) - -(deftest dcf-funs - (remove-if #'fboundp *dcf-fns*) - nil) - -(deftest dcf-macros - (remove-if #'macro-function *dcf-macros*) - nil) - - - - - diff --git a/t/ansi-test/data-and-control-flow/defconstant.lsp b/t/ansi-test/data-and-control-flow/defconstant.lsp deleted file mode 100644 index 1402b19..0000000 --- a/t/ansi-test/data-and-control-flow/defconstant.lsp +++ /dev/null @@ -1,64 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Oct 10 23:05:39 2002 -;;;; Contains: Tests of DEFCONSTANT - - - -(defconstant test-constant-1 17) - -(deftest defconstant.1 - (symbol-value 'test-constant-1) - 17) - -(deftest defconstant.2 - (notnot-mv (constantp 'test-constant-1)) - t) - -(deftest defconstant.3 - (documentation 'test-constant-1 'variable) - nil) - -(defconstant test-constant-2 'a - "This is the documentation.") - -(deftest defconstant.4 - (documentation 'test-constant-2 'variable) - "This is the documentation.") - -(deftest defconstant.5 - (defconstant test-constant-3 0) - test-constant-3) - -;;; (deftest defconstant.error.1 -;;; (signals-error (defconstant) program-error) -;;; t) -;;; -;;; (deftest defconstant.error.2 -;;; (signals-error (defconstant +ignorable-constant-name+) program-error) -;;; t) -;;; -;;; (deftest defconstant.error.3 -;;; (signals-error (defconstant +ignorable-constant-name2+ nil -;;; "This is a docstring" -;;; "This is an unnecessary extra argument.") -;;; program-error) -;;; t) - -(deftest defconstant.error.1 - (signals-error (funcall (macro-function 'defconstant)) - program-error) - t) - -(deftest defconstant.error.2 - (signals-error (funcall (macro-function 'defconstant) - '(defconstant +nonexistent-constant+ 0)) - program-error) - t) - -(deftest defconstant.error.3 - (signals-error (funcall (macro-function 'defconstant) - '(defconstant +nonexistent-constant+ 0) - nil nil) - program-error) - t) diff --git a/t/ansi-test/data-and-control-flow/define-modify-macro.lsp b/t/ansi-test/data-and-control-flow/define-modify-macro.lsp deleted file mode 100644 index 27b3a89..0000000 --- a/t/ansi-test/data-and-control-flow/define-modify-macro.lsp +++ /dev/null @@ -1,107 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Oct 19 11:42:14 2002 -;;;; Contains: Tests of DEFINE-MODIFY-MACRO - - - -(deftest define-modify-macro.1 - (values - (eval '(define-modify-macro dmm1-appendf (&rest args) - append "Append lists onto a list")) - (eval - '(let ((u '(p q r)) v) - (list - (setq v u) - (dmm1-appendf u '(a b c d)) - (dmm1-appendf u ()) - (dmm1-appendf u '(e f g)) - u - v)))) - dmm1-appendf - ((p q r) - (p q r a b c d) - (p q r a b c d) - (p q r a b c d e f g) - (p q r a b c d e f g) - (p q r))) - -(deftest define-modify-macro.2 - (values - (eval '(define-modify-macro new-incf (&optional (delta 1)) +)) - (eval - '(let ((i 10)) - (list - (new-incf i) - (new-incf i 100) - i)))) - new-incf - (11 111 111)) - -(deftest define-modify-macro.3 - (values - (eval '(define-modify-macro new-incf1 (&optional (delta 1)) +)) - (eval - '(let ((a (vector 0 0 0 0 0)) - (i 1)) - (list - (new-incf1 (aref a (incf i))) - a - i)))) - new-incf1 - (1 #(0 0 1 0 0) 2)) - -(deftest define-modify-macro.4 - (values - (eval '(define-modify-macro new-incf2 (&optional (delta 1)) +)) - (eval - '(let ((a (vector 0 0 0 0 0)) - (i 1)) - (list - (new-incf2 (aref a (incf i)) (incf i)) - a - i)))) - new-incf2 - (3 #(0 0 3 0 0) 3)) - -;;; (deftest define-modify-macro.error.1 -;;; (signals-error (define-modify-macro) program-error) -;;; t) -;;; -;;; (deftest define-modify-macro.error.2 -;;; (signals-error (define-modify-macro dfm-error-1) program-error) -;;; t) -;;; -;;; (deftest define-modify-macro.error.3 -;;; (signals-error (define-modify-macro dfm-error-2 ()) program-error) -;;; t) -;;; -;;; (deftest define-modify-macro.error.4 -;;; (signals-error (define-modify-macro dfm-error-2 () nil "Documentation" -;;; "extra illegal argument") -;;; program-error) -;;; t) - -(def-macro-test define-modify-macro.error.1 - (define-modify-macro nonexistent-modify-macro () foo)) - -;;; Documentation tests - -(deftest define-modify-macro.documentation.1 - (let ((sym (gensym))) - (eval `(define-modify-macro ,sym (&optional (delta 1)) +)) - (values - (documentation sym 'function) - (documentation (macro-function sym) 'function) - (documentation (macro-function sym) t))) - nil nil nil) - -(deftest define-modify-macro.documentation.2 - (let ((sym (gensym)) - (doc "DMM-DOC")) - (eval `(define-modify-macro ,sym (&optional (delta 1)) + ,doc)) - (values - (equalt doc (or (documentation sym 'function) doc)) - (equalt doc (or (documentation (macro-function sym) 'function) doc)) - (equalt doc (or (documentation (macro-function sym) t) doc)))) - t t t) diff --git a/t/ansi-test/data-and-control-flow/define-setf-expander.lsp b/t/ansi-test/data-and-control-flow/define-setf-expander.lsp deleted file mode 100644 index 94a595e..0000000 --- a/t/ansi-test/data-and-control-flow/define-setf-expander.lsp +++ /dev/null @@ -1,126 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Apr 20 17:19:35 2003 -;;;; Contains: Tests of DEFINE-SETF-EXPANDER - - - -(def-macro-test define-setf-expander.error.1 - (define-setf-expander nonexistent-access-fn (x))) - -;;; Non-error tests - -(defun my-car (x) (car x)) - -(ignore-errors - (defparameter *define-setf-expander-vals.1* - (multiple-value-list - (define-setf-expander my-car (place &environment env) - (multiple-value-bind (temps vals stores set-form get-form) - (get-setf-expansion place env) - (declare (ignore stores set-form)) - (let ((store (gensym)) - (temp (gensym))) - (values - `(,@temps ,temp) - `(,@vals ,get-form) - `(,store) - `(progn (rplaca ,temp ,store) ,store) - `(my-car ,temp)))))))) - -(deftest define-setf-expander.1 - *define-setf-expander-vals.1* - (my-car)) - -(deftest define-setf-expander.2 - (let ((a (list 'x 'y))) - (values - (copy-list a) - (my-car a) - (setf (my-car a) 'z) - a)) - (x y) x z (z y)) - -(deftest define-setf-expander.3 - (multiple-value-bind (temps vals stores set get) - (get-setf-expansion '(my-car x)) - (values - (and (listp temps) - (notnot (every #'symbolp temps))) - (notnot (listp vals)) - (and (listp stores) - (= (length stores) 1) - (notnot (every #'symbolp stores))) - (equalt get `(my-car ,(second (second set)))))) - t t t t) - -(deftest define-setf-expander.4 - (let ((a (list (list 1)))) - (values - (copy-tree a) - (my-car (my-car a)) - (setf (my-car (my-car a)) 2) - a)) - ((1)) 1 2 ((2))) - -(defun my-assoc (key alist) - (loop for pair in alist - when (and (consp pair) (eql key (car pair))) - return pair)) - -(ignore-errors - (define-setf-expander my-assoc (key place &environment env) - (multiple-value-bind (temps vals stores set-form get-form) - (get-setf-expansion place env) - (let ((store (gensym)) - (key-temp (gensym)) - (pair-temp (gensym)) - (place-temp (gensym))) - (return-from my-assoc - (values - `(,@temps ,key-temp ,place-temp ,pair-temp) - `(,@vals ,key ,get-form (my-assoc ,key-temp ,place-temp)) - `(,store) - `(if (null ,pair-temp) - (let ((,(car stores) - (cons (cons ,key-temp ,store) ,place-temp))) - ,set-form - ,store) - (setf (cdr ,pair-temp) ,store)) - `(cdr ,pair-temp))))))) - -(deftest define-setf-expander.5 - (let ((x nil)) - (values - (copy-tree x) - (setf (my-assoc 'foo x) 1) - (copy-tree x) - (setf (my-assoc 'foo x) 2) - (copy-tree x) - (setf (my-assoc 'bar x) 3) - (copy-tree x))) - nil 1 ((foo . 1)) 2 ((foo . 2)) 3 ((bar . 3) (foo . 2))) - -(deftest define-setf-expander.6 - (let ((n (gensym)) - (doc "D-S-EX.6")) - (assert (null (documentation n 'setf))) - (assert (eql (eval `(define-setf-expander ,n () - ,doc (values nil nil nil nil nil))) - n)) - (or (documentation n 'setf) doc)) - "D-S-EX.6") - -(deftest define-setf-expander.7 - (let ((n (gensym)) - (doc "D-S-EX.7")) - (assert (null (documentation n 'setf))) - (assert (eql (eval `(define-setf-expander ,n () - (values nil nil nil nil nil))) - n)) - (assert (null (documentation n 'setf))) - (values - (setf (documentation n 'setf) doc) - (or (documentation n 'setf) doc))) - "D-S-EX.7" - "D-S-EX.7") diff --git a/t/ansi-test/data-and-control-flow/defparameter.lsp b/t/ansi-test/data-and-control-flow/defparameter.lsp deleted file mode 100644 index bfdf4b4..0000000 --- a/t/ansi-test/data-and-control-flow/defparameter.lsp +++ /dev/null @@ -1,86 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Oct 10 23:13:22 2002 -;;;; Contains: Tests of DEFPARAMETER - - - -(defparameter *defparameter-test-var-1* 100) - -(deftest defparameter.1 - *defparameter-test-var-1* - 100) - -(deftest defparameter.2 - (documentation '*defparameter-test-var-1* 'variable) - nil) - -;;; Show that it's declared special. -(deftest defparameter.3 - (flet ((%f () *defparameter-test-var-1*)) - (let ((*defparameter-test-var-1* 29)) - (%f))) - 29) - -(deftest defparameter.4 - (values - (makunbound '*defparameter-test-var-2*) - (defparameter *defparameter-test-var-2* 200 "Whatever.") - (documentation '*defparameter-test-var-2* 'variable) - *defparameter-test-var-2*) - *defparameter-test-var-2* - *defparameter-test-var-2* - "Whatever." - 200) - -(deftest defparameter.5 - (values - (makunbound '*defparameter-test-var-2*) - (defparameter *defparameter-test-var-2* 200 "Whatever.") - (documentation '*defparameter-test-var-2* 'variable) - *defparameter-test-var-2* - (defparameter *defparameter-test-var-2* 300 "And ever.") - (documentation '*defparameter-test-var-2* 'variable) - *defparameter-test-var-2* - ) - *defparameter-test-var-2* - *defparameter-test-var-2* - "Whatever." - 200 - *defparameter-test-var-2* - "And ever." - 300) - -;;; (deftest defparameter.error.1 -;;; (signals-error (defparameter) program-error) -;;; t) -;;; -;;; (deftest defparameter.error.2 -;;; (signals-error (defparameter *ignored-defparameter-name*) -;;; program-error) -;;; t) -;;; -;;; (deftest defparameter.error.3 -;;; (signals-error (defparameter *ignored-defparameter-name* nil -;;; "documentation" -;;; "illegal extra argument") -;;; program-error) -;;; t) - -(deftest defparameter.error.1 - (signals-error (funcall (macro-function 'defparameter)) - program-error) - t) - -(deftest defparameter.error.2 - (signals-error (funcall (macro-function 'defparameter) - '(defparameter *nonexistent-variable* nil)) - program-error) - t) - -(deftest defparameter.error.3 - (signals-error (funcall (macro-function 'defparameter) - '(defparameter *nonexistent-variable* nil) - nil nil) - program-error) - t) diff --git a/t/ansi-test/data-and-control-flow/defsetf.lsp b/t/ansi-test/data-and-control-flow/defsetf.lsp deleted file mode 100644 index dc8904b..0000000 --- a/t/ansi-test/data-and-control-flow/defsetf.lsp +++ /dev/null @@ -1,167 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Apr 20 17:18:01 2003 -;;;; Contains: Tests of DEFSETF - - - -;;; Need to add non-error tests - -(def-macro-test defsetf.error.1 (defsetf nonexistent-access-fn - nonexistent-update-fn)) - -;;; Short form - -(defun defsetf.1-accessor (x) - (cadr x)) - -(defun defsetf.1-accessor-settor (x val) - (setf (cadr x) val)) - -(deftest defsetf.1 - (progn - (let ((vals (multiple-value-list - (defsetf defsetf.1-accessor defsetf.1-accessor-settor)))) - (assert (equal vals '(defsetf.1-accessor)) - () - "Return values are ~A~%" vals)) - (eval - '(let ((x (list 1 2 3))) - (values - (setf (defsetf.1-accessor x) 4) - x)))) - 4 - (1 4 3)) - -;;; Use a macro instead of a function for updatefn - -(defun defsetf.2-accessor (x) - (cadr x)) - -(defmacro defsetf.2-accessor-settor (x val) - `(setf (cadr ,x) ,val)) - -(defparameter *defsetf.2-vals* - (multiple-value-list - (defsetf defsetf.2-accessor defsetf.2-accessor-settor))) - -(deftest defsetf.2a - *defsetf.2-vals* - (defsetf.2-accessor)) - -(deftest defsetf.2b - (let ((x (list 1 2 3))) - (values - (setf (defsetf.2-accessor x) 4) - x)) - 4 - (1 4 3)) - -;;; Documentation string - -(defun defsetf.3-accessor (x) - (cadr x)) - -(defun defsetf.3-accessor-settor (x val) - (setf (cadr x) val)) - -(defparameter *defsetf.3-vals* - (multiple-value-list - (defsetf defsetf.3-accessor defsetf.3-accessor-settor - "A doc string"))) - -(deftest defsetf.3a - *defsetf.3-vals* - (defsetf.3-accessor)) - -(deftest defsetf.3b - (let ((doc (documentation 'defsetf.3-accessor 'setf))) - (or (null doc) (equalt doc "A doc string"))) - t) - -(deftest defsetf.3c - (let ((x (list 1 2 3))) - (values - (setf (defsetf.3-accessor x) 4) - x)) - 4 - (1 4 3)) - -;;; Long form of defsetf - -(defun defsetf.4-accessor (n seq) - (elt seq n)) - -(defparameter *defsetf.4-vals* - (multiple-value-list - (defsetf defsetf.4-accessor (n seq) (val) - (declare) - "Doc string for defsetf.4-accessor setf" - `(setf (elt ,seq ,n) ,val)))) - -(deftest defsetf.4a - *defsetf.4-vals* - (defsetf.4-accessor)) - -(deftest defsetf.4b - (let ((doc (documentation 'defsetf.4-accessor 'setf))) - (or (null doc) (equalt doc "Doc string for defsetf.4-accessor setf"))) - t) - -(deftest defsetf.4c - (let ((x (list 1 2 3 4)) - (i 0) - (j nil) - (k nil)) - (values - (setf (defsetf.4-accessor - (progn (setf j (incf i)) - 2) - (progn (setf k (incf i)) x)) - (progn (incf i) 'a)) - x - i j k)) - a - (1 2 a 4) - 3 1 2) - -;;; Test that there's a block around the forms in long form defsetf - -(defun defsetf.5-accessor (x) (car x)) - -(defsetf defsetf.5-accessor (y) (val) - (return-from defsetf.5-accessor `(setf (car ,y) ,val))) - -(deftest defsetf.5a - (let ((x (cons 'a 'b))) - (values - (setf (defsetf.5-accessor x) 'c) - x)) - c (c . b)) - -;;; Test that the defsetf expansion function is defined in the same -;;; lexical environment that the defsetf appears in - -(defun defsetf.6-accessor (x) (car x)) - -(let ((z 'car)) - (defsetf defsetf.6-accessor (y) (val) - `(setf (,z ,y) ,val))) - -(deftest defsetf.6a - (let ((x (cons 'a 'b))) - (values - (setf (defsetf.6-accessor x) 'c) - x)) - c (c . b)) - - - -;;; Test that defsetf works with places -(deftest defsetf.7a - (progn - (defsetf access-fn (x) (val-1 val-2) - `(list ,x ,val-1 ,val-2)) - (eval (read-from-string - "(setf (access-fn 1) (values 2 3))"))) - (1 2 3)) diff --git a/t/ansi-test/data-and-control-flow/defun.lsp b/t/ansi-test/data-and-control-flow/defun.lsp deleted file mode 100644 index 64801ef..0000000 --- a/t/ansi-test/data-and-control-flow/defun.lsp +++ /dev/null @@ -1,137 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Feb 16 23:40:32 2003 -;;;; Contains: Tests of DEFUN - - - - -;;; Tests for implicit blocks - -(defun defun-test-fun-1 () - (return-from defun-test-fun-1 'good)) - -(deftest defun.1 - (defun-test-fun-1) - good) - -(defun defun-test-fun-2 () - (return-from defun-test-fun-2 (values))) - -(deftest defun.2 - (defun-test-fun-2)) - -(defun defun-test-fun-3 () - (return-from defun-test-fun-3 (values 'a 'b 'c 'd 'e 'f))) - -(deftest defun.3 - (defun-test-fun-3) - a b c d e f) - -(defun defun-test-fun-4 (x) - (car x)) - -(deftest defun.4 - (let ((x (list 'a 'b))) - (values - (setf (defun-test-fun-4 x) 'c) - x)) - c - (c b)) - -(report-and-ignore-errors - (defun (setf defun-test-fun-4) (newval x) - (return-from defun-test-fun-4 (setf (car x) newval)))) - -(deftest defun.5 - (let ((x 1)) - (declare (special x)) - (let ((x 2)) - (defun defun-test-fun-5 (&aux (y x)) - (declare (special x)) - (values y x)) - (defun-test-fun-5))) - 2 1) - -(deftest defun.6 - (let ((x 1)) - (declare (special x)) - (let ((x 2)) - (defun defun-test-fun-6 (&optional (y x)) - (declare (special x)) - (values y x)) - (defun-test-fun-6))) - 2 1) - -(deftest defun.7 - (let ((x 1)) - (declare (special x)) - (let ((x 2)) - (defun defun-test-fun-7 (&key (y x)) - (declare (special x)) - (values y x)) - (defun-test-fun-7))) - 2 1) - -;; Documentation - -(deftest defun.8 - (let* ((sym (gensym)) - (doc "DEFUN.8") - (form `(defun ,sym () ,doc nil))) - (or (documentation sym 'function) doc)) - "DEFUN.8") - -;;; Error tests - -(deftest defun.error.1 - (signals-error (funcall (macro-function 'defun)) - program-error) - t) - -(deftest defun.error.2 - (signals-error (funcall (macro-function 'defun) - '(defun nonexistent-function ())) - program-error) - t) - -(deftest defun.error.3 - (signals-error (funcall (macro-function 'defun) - '(defun nonexistent-function ()) - nil nil) - program-error) - t) - -;;; More comprehensive error handling tests of calls to -;;; user-defined functions - -(deftest defun.error.4 - (let* ((name (gensym))) - (loop for i below (min 100 lambda-parameters-limit) - for params = nil then (cons (gensym) params) - for args = nil then (cons nil args) - for expected = '(1 2 3) - for fn = (eval `(prog2 (proclaim '(optimize (safety 0))) - (defun ,name ,params (values ,@expected)) - (proclaim '(optimize safety)))) - when - (cond - ((not (equal (multiple-value-list (apply fn args)) expected)) - (list i :fail1)) - ((not (equal (multiple-value-list - (apply (symbol-function fn) args)) - expected)) - (list i :fail2)) - ((not (equal (multiple-value-list (eval `(,name ,@args))) - expected)) - (list i :fail3)) - ;; Error cases - ((and (> i 0) - (let ((val (eval `(signals-error (,name ,@(cdr args)) program-error)))) - (and (not (eq val t)) :fail4)))) - ((and (< i (1- call-arguments-limit)) - (let ((val (eval `(signals-error (,name nil ,@args) program-error)))) - (and (not (eq val t)) :fail5))))) - collect it)) - nil) - diff --git a/t/ansi-test/data-and-control-flow/defvar.lsp b/t/ansi-test/data-and-control-flow/defvar.lsp deleted file mode 100644 index da07fbe..0000000 --- a/t/ansi-test/data-and-control-flow/defvar.lsp +++ /dev/null @@ -1,83 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Oct 10 23:21:50 2002 -;;;; Contains: Tests for DEFVAR - - - -(defvar *defvar-test-var-1* 100) - -(deftest defvar.1 - *defvar-test-var-1* - 100) - -(deftest defvar.2 - (documentation '*defvar-test-var-1* 'variable) - nil) - -;;; Show that it's declared special. -(deftest defvar.3 - (flet ((%f () *defvar-test-var-1*)) - (let ((*defvar-test-var-1* 29)) - (%f))) - 29) - -(deftest defvar.4 - (values - (makunbound '*defvar-test-var-2*) - (defvar *defvar-test-var-2* 200 "Whatever.") - (documentation '*defvar-test-var-2* 'variable) - *defvar-test-var-2*) - *defvar-test-var-2* - *defvar-test-var-2* - "Whatever." - 200) - -(deftest defvar.5 - (let ((x 0)) - (values - (makunbound '*defvar-test-var-2*) - (defvar *defvar-test-var-2* 200 "Whatever.") - (documentation '*defvar-test-var-2* 'variable) - *defvar-test-var-2* - (defvar *defvar-test-var-2* (incf x) "And ever.") - (documentation '*defvar-test-var-2* 'variable) - *defvar-test-var-2* - x - )) - *defvar-test-var-2* - *defvar-test-var-2* - "Whatever." - 200 - *defvar-test-var-2* - "And ever." - 200 - 0) - -;;; (deftest defvar.error.1 -;;; (signals-error (defvar) program-error) -;;; t) -;;; -;;; (deftest defvar.error.2 -;;; (signals-error (defvar *ignored-defvar-name* nil "documentation" -;;; "illegal extra argument") -;;; program-error) -;;; t) - -(deftest defvar.error.1 - (signals-error (funcall (macro-function 'defvar)) - program-error) - t) - -(deftest defvar.error.2 - (signals-error (funcall (macro-function 'defvar) - '(defvar *nonexistent-variable* nil)) - program-error) - t) - -(deftest defvar.error.3 - (signals-error (funcall (macro-function 'defvar) - '(defvar *nonexistent-variable* nil) - nil nil) - program-error) - t) diff --git a/t/ansi-test/data-and-control-flow/destructuring-bind.lsp b/t/ansi-test/data-and-control-flow/destructuring-bind.lsp deleted file mode 100644 index 63aca78..0000000 --- a/t/ansi-test/data-and-control-flow/destructuring-bind.lsp +++ /dev/null @@ -1,221 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Oct 10 23:25:50 2002 -;;;; Contains: Tests for DESTRUCTURING-BIND - - - -;;; See the page for this in section 5.3 -;;; Also, see destructuring lambda lists in section 3.4.5 - -(deftest destructuring-bind.1 - (destructuring-bind (x y z) '(a b c) (values x y z)) - a b c) - -(deftest destructuring-bind.2 - (destructuring-bind (x y &rest z) '(a b c d) (values x y z)) - a b (c d)) - -(deftest destructuring-bind.3 - (destructuring-bind (x y &optional z) '(a b c) (values x y z)) - a b c) - -(deftest destructuring-bind.4 - (destructuring-bind (x y &optional z) '(a b) (values x y z)) - a b nil) - -(deftest destructuring-bind.5 - (destructuring-bind (x y &optional (z 'w)) '(a b) (values x y z)) - a b w) - -(deftest destructuring-bind.6 - (destructuring-bind (x y &optional (z 'w z-p)) '(a b) (values x y z z-p)) - a b w nil) - -(deftest destructuring-bind.7 - (destructuring-bind (x y &optional (z 'w z-p)) '(a b c) (values x y z (notnot z-p))) - a b c t) - -(deftest destructuring-bind.7a - (destructuring-bind (x y &optional (z x z-p)) '(a b) (values x y z z-p)) - a b a nil) - -(deftest destructuring-bind.8 - (destructuring-bind (x y &optional z w) '(a b c) (values x y z w)) - a b c nil) - -(deftest destructuring-bind.9 - (destructuring-bind ((x y)) '((a b)) (values x y)) - a b) - -(deftest destructuring-bind.10 - (destructuring-bind (&whole w (x y)) '((a b)) (values x y w)) - a b ((a b))) - -(deftest destructuring-bind.11 - (destructuring-bind ((x . y) . w) '((a b) c) (values x y w)) - a (b) (c)) - -(deftest destructuring-bind.12 - (destructuring-bind (x y &body z) '(a b c d) (values x y z)) - a b (c d)) - -(deftest destructuring-bind.12a - (destructuring-bind ((x y &body z)) '((a b c d)) (values x y z)) - a b (c d)) - -(deftest destructuring-bind.13 - (destructuring-bind (&whole x y z) '(a b) (values x y z)) - (a b) a b) - -(deftest destructuring-bind.14 - (destructuring-bind (w (&whole x y z)) '(1 (a b)) (values w x y z)) - 1 (a b) a b) - -(deftest destructuring-bind.15 - (destructuring-bind (&key a b c) '(:a 1) (values a b c)) - 1 nil nil) - -(deftest destructuring-bind.16 - (destructuring-bind (&key a b c) '(:b 1) (values a b c)) - nil 1 nil) - -(deftest destructuring-bind.17 - (destructuring-bind (&key a b c) '(:c 1) (values a b c)) - nil nil 1) - -(deftest destructuring-bind.17a - (destructuring-bind (&key (a 'foo) (b 'bar) c) '(:c 1) (values a b c)) - foo bar 1) - -(deftest destructuring-bind.17c - (destructuring-bind (&key (a 'foo a-p) (b a b-p) (c 'zzz c-p)) '(:c 1) - (values a b c a-p b-p (notnot c-p))) - foo foo 1 nil nil t) - -(deftest destructuring-bind.18 - (destructuring-bind ((&key a b c)) '((:c 1 :b 2)) (values a b c)) - nil 2 1) - -;;; Test that destructuring-bind does not have a tagbody -(deftest destructuring-bind.19 - (block nil - (tagbody - (destructuring-bind (a . b) '(1 2) (go 10) 10 (return 'bad)) - 10 - (return 'good))) - good) - -(deftest destructuring-bind.20 - (destructuring-bind (&whole (a . b) c . d) '(1 . 2) (list a b c d)) - (1 2 1 2)) - -(deftest destructuring-bind.21 - (destructuring-bind - (x &rest (y z)) - '(1 2 3) - (values x y z)) - 1 2 3) - -(deftest destructuring-bind.22 - (destructuring-bind (x y &key) '(1 2) (values x y)) - 1 2) - -(deftest destructuring-bind.23 - (destructuring-bind (&rest x &key) '(:allow-other-keys 1) x) - (:allow-other-keys 1)) - -(deftest destructuring-bind.24 - (destructuring-bind (&rest x &key) nil x) - nil) - -(deftest destructuring-bind.25 - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) - (destructuring-bind (y) (list x) - (declare (special x)) - y))) - :good) - -(deftest destructuring-bind.26 - (destructuring-bind (x) (list 1)) - nil) - -(deftest destructuring-bind.27 - (destructuring-bind (x) (list 1) - (declare (optimize))) - nil) - -(deftest destructuring-bind.28 - (destructuring-bind (x) (list 1) - (declare (optimize)) - (declare)) - nil) - -(deftest destructuring-bind.29 - (destructuring-bind (x &aux y) '(:foo) (values x y)) - :foo nil) - -(deftest destructuring-bind.30 - (destructuring-bind (x &aux (y (list x))) '(:foo) (values x y)) - :foo (:foo)) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest destructuring-bind.31 - (macrolet - ((%m (z) z)) - (destructuring-bind (a b c) (expand-in-current-env (%m '(1 2 3))) (values a b c))) - 1 2 3) - -;;; Error cases - -#| -(deftest destructuring-bind.error.1 - (signals-error (destructuring-bind (a b c) nil (list a b c)) - program-error) - t) - -(deftest destructuring-bind.error.2 - (signals-error (destructuring-bind ((a b c)) nil (list a b c)) - program-error) - t) - -(deftest destructuring-bind.error.3 - (signals-error (destructuring-bind (a b) 'x (list a b)) - program-error) - t) - -(deftest destructuring-bind.error.4 - (signals-error (destructuring-bind (a . b) 'x (list a b)) - program-error) - t) -|# - -;;; (deftest destructuring-bind.error.5 -;;; (signals-error (destructuring-bind) program-error) -;;; t) -;;; -;;; (deftest destructuring-bind.error.6 -;;; (signals-error (destructuring-bind x) program-error) -;;; t) - -(deftest destructuring-bind.error.7 - (signals-error (funcall (macro-function 'destructuring-bind)) - program-error) - t) - -(deftest destructuring-bind.error.8 - (signals-error (funcall (macro-function 'destructuring-bind) - '(destructuring-bind (a . b) '(1 2) nil)) - program-error) - t) - -(deftest destructuring-bind.error.9 - (signals-error (funcall (macro-function 'destructuring-bind) - '(destructuring-bind (a . b) '(1 2) nil) - nil nil) - program-error) - t) diff --git a/t/ansi-test/data-and-control-flow/ecase.lsp b/t/ansi-test/data-and-control-flow/ecase.lsp deleted file mode 100644 index c42adf0..0000000 --- a/t/ansi-test/data-and-control-flow/ecase.lsp +++ /dev/null @@ -1,186 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Oct 18 20:17:30 2002 -;;;; Contains: Tests for ECASE - - - -(deftest ecase.1 - (ecase 'b (a 1) (b 2) (c 3)) - 2) - -(deftest ecase.2 - (signals-type-error x 1 (ecase x)) - t) - -(deftest ecase.3 - (signals-type-error x 1 (ecase x (a 1) (b 2) (c 3))) - t) - -;;; It is legal to use T or OTHERWISE as key designators -;;; in ECASE forms. They have no special meaning here. - -(deftest ecase.4 - (signals-type-error x 1 (ecase x (t nil))) - t) - -(deftest ecase.5 - (signals-type-error x 1 (ecase x (otherwise nil))) - t) - -(deftest ecase.6 - (ecase 'b ((a z) 1) ((y b w) 2) ((b c) 3)) - 2) - -(deftest ecase.7 - (ecase 'z - ((a b c) 1) - ((d e) 2) - ((f z g) 3)) - 3) - -(deftest ecase.8 - (ecase (1+ most-positive-fixnum) - (#.(1+ most-positive-fixnum) 'a)) - a) - -(deftest ecase.9 - (signals-type-error x nil (ecase x (nil 'a))) - t) - -(deftest ecase.10 - (ecase nil ((nil) 'a)) - a) - -(deftest ecase.11 - (ecase 'a (b 0) (a (values 1 2 3)) (c nil)) - 1 2 3) - -(deftest ecase.12 - (signals-type-error x t (ecase x (a 10))) - t) - -(deftest ecase.13 - (ecase t ((t) 10) (t 20)) - 10) - -(deftest ecase.14 - (let ((x (list 'a 'b))) - (eval `(ecase (quote ,x) ((,x) 1) (a 2)))) - 1) - -(deftest ecase.15 - (signals-type-error x 'otherwise (ecase x ((t) 10))) - t) - -(deftest ecase.16 - (signals-type-error x t (ecase x ((otherwise) 10))) - t) - -(deftest ecase.17 - (signals-type-error x 'a (ecase x (b 0) (c 1) (otherwise 2))) - t) - -(deftest ecase.18 - (signals-type-error x 'a (ecase x (b 0) (c 1) ((otherwise) 2))) - t) - -(deftest ecase.19 - (signals-type-error x 'a (ecase x (b 0) (c 1) ((t) 2))) - t) - -(deftest ecase.20 - (ecase #\a - ((#\b #\c) 10) - ((#\d #\e #\A) 20) - (() 30) - ((#\z #\a #\y) 40)) - 40) - -(deftest ecase.21 (ecase 1 (1 (values)) (2 'a))) - -(deftest ecase.23 (ecase 1 (1 (values 'a 'b 'c))) - a b c) - -;;; Show that the key expression is evaluated only once. -(deftest ecase.25 - (let ((x 0)) - (values - (ecase (progn (incf x) 'c) - (a 1) - (b 2) - (c 3) - (d 4)) - x)) - 3 1) - -;;; Repeated keys are allowed (all but the first are ignored) - -(deftest ecase.26 - (ecase 'b ((a b c) 10) (b 20)) - 10) - -(deftest ecase.27 - (ecase 'b (b 20) ((a b c) 10)) - 20) - -(deftest ecase.28 - (ecase 'b (b 20) (b 10) (d 0)) - 20) - -;;; There are implicit progns - -(deftest ecase.29 - (let ((x nil)) - (values - (ecase 2 - (1 (setq x 'a) 'w) - (2 (setq x 'b) 'y) - (3 (setq x 'c) 'z)) - x)) - y b) - -(deftest ecase.31 - (ecase (values 'b 'c) (c 0) ((a b) 10) (d 20)) - 10) - -(deftest ecase.32 - (ecase 'a (a) (b 'b)) - nil) - -;;; No implicit tagbody -(deftest ecase.33 - (block done - (tagbody - (ecase 'a (a (go 10) - 10 - (return-from done 'bad))) - 10 - (return-from done 'good))) - good) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest ecase.34 - (macrolet - ((%m (z) z)) - (ecase (expand-in-current-env (%m :b)) - (:a :bad1) - (:b :good) - (:c :bad2))) - :good) - -(deftest ecase.error.1 - (signals-error (funcall (macro-function 'ecase)) program-error) - t) - -(deftest ecase.error.2 - (signals-error (funcall (macro-function 'ecase) '(ecase t)) - program-error) - t) - -(deftest ecase.error.3 - (signals-error (funcall (macro-function 'ecase) '(ecase t) nil nil) - program-error) - t) diff --git a/t/ansi-test/data-and-control-flow/eql.lsp b/t/ansi-test/data-and-control-flow/eql.lsp deleted file mode 100644 index d0716e0..0000000 --- a/t/ansi-test/data-and-control-flow/eql.lsp +++ /dev/null @@ -1,87 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Oct 17 19:36:33 2002 -;;;; Contains: Tests of EQL - - - -;;; EQLT is defined in ansi-aux.lsp -;;; It calls EQL, returning NIL when the result is false and T when it -;;; is true. - -(deftest eql.1 - (check-predicate #'(lambda (x) (eql x x))) - nil) - -(deftest eql.2 - (eqlt 2 (1+ 1)) - t) - -(deftest eql.3 - (let ((x "abc")) - (eql x (copy-seq x))) - nil) - -(deftest eql.4 - (eqlt #\a #\a) - t) - -(deftest eql.5 - (eqlt 12345678901234567890 12345678901234567890) - t) - -(deftest eql.7 - (eql 12.0 12) - nil) - -(deftest eql.8 - (eqlt #c(1 -2) #c(1 -2)) - t) - -(deftest eql.9 - (let ((x "abc") (y "abc")) - (if (eq x y) (eqlt x y) (not (eql x y)))) - t) - -(deftest eql.10 - (eql (list 'a) (list 'b)) - nil) - -(deftest eql.11 - (eqlt #c(1 -2) (- #c(-1 2))) - t) - -(deftest eql.order.1 - (let ((i 0) x y) - (values - (eql (setf x (incf i)) (setf y (incf i))) - i x y)) - nil 2 1 2) - -;;; Error tests for EQL - -(deftest eql.error.1 - (signals-error (eql) program-error) - t) - -(deftest eql.error.2 - (signals-error (eql nil) program-error) - t) - -(deftest eql.error.3 - (signals-error (eql nil nil nil) program-error) - t) - -;;; Error tests for EQ - -(deftest eq.error.1 - (signals-error (eq) program-error) - t) - -(deftest eq.error.2 - (signals-error (eq nil) program-error) - t) - -(deftest eq.error.3 - (signals-error (eq nil nil nil) program-error) - t) diff --git a/t/ansi-test/data-and-control-flow/equal.lsp b/t/ansi-test/data-and-control-flow/equal.lsp deleted file mode 100644 index aa70e86..0000000 --- a/t/ansi-test/data-and-control-flow/equal.lsp +++ /dev/null @@ -1,130 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Oct 17 21:38:16 2002 -;;;; Contains: Tests for EQUAL - - - -(deftest equal.1 - (loop for x in *symbols* - always (loop for y in *symbols* - always (if (eq x y) (equal x y) - (not (equal x y))))) - t) - -(deftest equal.2 - (equalt (cons 'a 'b) (cons 'a 'b)) - t) - -(deftest equal.3 - (equalt (cons 'a 'c) (cons 'a 'b)) - nil) - -(deftest equal.4 - (equalt (vector 1 2 3) (vector 1 2 3)) - nil) - -(deftest equal.5 - (loop for c in *characters* - always (loop for d in *characters* - always (if (eql c d) (equalt c d) - (not (equalt c d))))) - t) - -(deftest equal.6 - (equalt (make-pathname :name (copy-seq "foo")) - (make-pathname :name (copy-seq "foo"))) - t) - -(deftest equal.7 - (equalt (make-pathname :name (copy-seq "foo")) - (make-pathname :name (copy-seq "bar"))) - nil) - -(deftest equal.8 - (equalt (copy-seq "abcd") (copy-seq "abcd")) - t) - -(deftest equal.9 - (equalt (copy-seq "abcd") (copy-seq "abc")) - nil) - -(deftest equal.10 - (equalt (copy-seq "abcd") (copy-seq "ABCD")) - nil) - -(deftest equal.11 - (equalt (copy-seq #*000110) (copy-seq #*000110)) - t) - -(deftest equal.12 - (equalt (copy-seq #*000110) (copy-seq #*000111)) - nil) - -(deftest equal.13 - :notes (:nil-vectors-are-strings) - (let ((x (make-array '(0) :element-type nil)) - (y (make-array '(0) :element-type nil))) - (equalt x y)) - t) - -(deftest equal.14 - :notes (:nil-vectors-are-strings) - (and - (equalt (make-array '(0) :element-type nil) "") - (equalt "" (make-array '(0) :element-type nil))) - t) - -(deftest equal.15 - (equalt (make-array '(0) :element-type 'character) - (make-array '(0) :element-type 'base-char)) - t) - -(deftest equal.16 - (equalt "abc" (make-array '(3) :element-type 'base-char - :initial-contents '(#\a #\b #\c))) - t) - -(deftest equal.17 - (let ((s (make-array '(10) :element-type 'character - :initial-contents "0123456789" - :fill-pointer 3))) - (values (equalt s "012") (equalt "012" s))) - t t) - -(deftest equal.18 - (let ((b (make-array '(10) :element-type 'bit - :initial-contents #*0110001110 - :fill-pointer 5))) - (values (equalt #*01100 b) (equalt #*01100 b))) - t t) - -(deftest equal.19 - (let ((s (make-array '(10) :element-type 'base-char - :initial-contents "0123456789" - :fill-pointer 3))) - (values (equalt s "012") (equalt "012" s))) - t t) - -;;; Should add more pathname equality tests - -(deftest equal.order.1 - (let ((i 0) x y) - (values - (equal (setf x (incf i)) (setf y (incf i))) - i x y)) - nil 2 1 2) - -;;; Error tests - -(deftest equal.error.1 - (signals-error (equal) program-error) - t) - -(deftest equal.error.2 - (signals-error (equal nil) program-error) - t) - -(deftest equal.error.3 - (signals-error (equal nil nil nil) program-error) - t) diff --git a/t/ansi-test/data-and-control-flow/equalp.lsp b/t/ansi-test/data-and-control-flow/equalp.lsp deleted file mode 100644 index 1b00b8d..0000000 --- a/t/ansi-test/data-and-control-flow/equalp.lsp +++ /dev/null @@ -1,314 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Oct 17 22:14:42 2002 -;;;; Contains: Tests for EQUALP - - - -(deftest equalp.1 - (loop for c across +base-chars+ - always (loop for d across +base-chars+ - always (if (char-equal c d) (equalpt c d) - (not (equalpt c d))))) - t) - -(deftest equalp.2 - (loop for i from 1 to 100 - always (loop for j from 1 to 100 - always (if (eqlt i j) (equalpt i j) - (not (equalpt i j))))) - t) - -(deftest equalp.3 - (equalpt "abc" "ABC") - t) - -(deftest equalp.4 - (equalpt "abc" "abd") - nil) - -(deftest equalp.5 - :notes (:allow-nil-arrays) - (equalpt (make-array '(0) :element-type nil) #()) - t) - -(deftest equalp.6 - :notes (:allow-nil-arrays) - (equalpt (make-array '(0) :element-type nil) "") - t) - -(deftest equalp.7 - (loop for nbits from 1 to 100 - for type = `(unsigned-byte ,nbits) - for bound = (ash 1 nbits) - for val = (random bound) - for a1 = (make-array nil :initial-element val :element-type type) - for a2 = (make-array nil :initial-element val) - unless (equalp a1 a2) - collect (list nbits type val)) - nil) - -(deftest equalp.8 - (loop for nbits from 1 to 100 - for type = `(unsigned-byte ,nbits) - for bound = (ash 1 nbits) - for n = (1+ (random 20)) - for vals = (loop repeat n collect (random bound)) - for a1 = (make-array n :initial-contents vals :element-type type) - for a2 = (make-array n :initial-contents vals) - unless (equalp a1 a2) - collect (list nbits type vals)) - nil) - -(deftest equalp.9 - (loop for nbits from 1 to 100 - for type = `(signed-byte ,nbits) - for bound = (ash 1 nbits) - for n = (1+ (random 20)) - for vals = (loop repeat n collect (- (random bound) (/ bound 2))) - for a1 = (make-array n :initial-contents vals :element-type type) - for a2 = (make-array n :initial-contents vals) - unless (equalp a1 a2) - collect (list nbits type vals)) - nil) - -(deftest equalp.10 - (equalpt #*0010 #(0 0 1 0)) - t) - -(deftest equalp.11 - (let ((v1 #(1 2 3)) - (v2 (make-array 8 :initial-contents '(1 2 3 4 5 6 7 8) - :fill-pointer 3))) - (equalpt v1 v2)) - t) - -(deftest equalp.12 - (equalpt '(#\a #\b) "ab") - nil) - -(deftest equalp.13 - (equalpt '(#\a #\b) '(#\A #\B)) - t) - -(deftest equalp.14 - (let ((s1 (make-array '(4) :initial-contents '(#\a #\b #\c #\d) - :element-type 'base-char)) - (s2 (make-array '(4) :initial-contents '(#\a #\b #\c #\d) - :element-type 'character))) - (equalpt s1 s2)) - t) - -(deftest equalp.15 - (let ((bv (make-array '(4) :initial-contents '(0 0 1 0) - :element-type 'bit)) - (v #(0 0 1 0))) - (equalpt bv v)) - t) - -(defstruct equalp-struct-16 - a b c) - -(defstruct equalp-struct-16-alt - a b c) - -(deftest equalp.16 - (let ((s1 (make-equalp-struct-16 :a 1 :b 2 :c #\a)) - (s2 (make-equalp-struct-16 :a 1.0 :b 2.0 :c #\A)) - (s3 (make-equalp-struct-16-alt :a 1.0 :b 2.0 :c #\A))) - (values (equalpt s1 s2) - (equalpt s1 s3) - (equalpt s2 s3))) - t nil nil) - -(deftest equalp.17 - (loop for i below 8192 - for f = (float i 1.0s0) - repeat 1000 - unless (equalp i f) - collect (list i f)) - nil) - -(deftest equalp.18 - (loop for i = (- (random 10000000) 5000000) - for f = (float i 1.0f0) - repeat 1000 - unless (equalp i f) - collect (list i f)) - nil) - -(deftest equalp.19 - (loop for i = (- (random 10000000) 5000000) - for f = (float i 1.0d0) - repeat 1000 - unless (equalp i f) - collect (list i f)) - nil) - -(deftest equalp.20 - (loop for i = (- (random 10000000) 5000000) - for f = (float i 1.0l0) - repeat 1000 - unless (equalp i f) - collect (list i f)) - nil) - -(deftest equalp.21 - (let ((ht1 (make-hash-table :test #'eq)) - (ht2 (make-hash-table :test #'eql)) - (ht3 (make-hash-table :test #'equal)) - (ht4 (make-hash-table :test #'equalp))) - (values (equalpt ht1 ht2) - (equalpt ht1 ht3) - (equalpt ht1 ht4) - (equalpt ht2 ht3) - (equalpt ht2 ht4) - (equalpt ht3 ht4))) - nil nil nil nil nil nil) - -(deftest equalp.22 - (equalpt (make-hash-table :test 'eq) - (make-hash-table :test #'eq)) - t) - -(deftest equalp.23 - (equalpt (make-hash-table :test 'eql) - (make-hash-table :test #'eql)) - t) - -(deftest equalp.24 - (equalpt (make-hash-table :test 'equal) - (make-hash-table :test #'equal)) - t) - -(deftest equalp.25 - (equalpt (make-hash-table :test 'equalp) - (make-hash-table :test #'equalp)) - t) - -(deftest equalp.26 - (let ((ht1 (make-hash-table :test #'eq)) - (ht2 (make-hash-table :test #'eq))) - (setf (gethash #\a ht1) t) - (setf (gethash #\A ht2) t) - (equalpt ht1 ht2)) - nil) - -(deftest equalp.27 - (let ((ht1 (make-hash-table :test #'eq)) - (ht2 (make-hash-table :test #'eq))) - (setf (gethash 'a ht1) #\a) - (setf (gethash 'a ht2) #\A) - (equalpt ht1 ht2)) - t) - -(deftest equalp.28 - (let ((ht1 (make-hash-table :test #'eql)) - (ht2 (make-hash-table :test #'eql))) - (setf (gethash #\a ht1) t) - (setf (gethash #\A ht2) t) - (equalpt ht1 ht2)) - nil) - -(deftest equalp.29 - (let ((ht1 (make-hash-table :test #'eql)) - (ht2 (make-hash-table :test #'eql))) - (setf (gethash #\a ht1) "a") - (setf (gethash #\a ht2) "A") - (equalpt ht1 ht2)) - t) - -(deftest equalp.30 - (let ((ht1 (make-hash-table :test #'equal)) - (ht2 (make-hash-table :test #'equal))) - (setf (gethash #\a ht1) t) - (setf (gethash #\A ht2) t) - (equalpt ht1 ht2)) - nil) - -(deftest equalp.31 - (let ((ht1 (make-hash-table :test #'equal)) - (ht2 (make-hash-table :test #'equal))) - (setf (gethash #\a ht1) "a") - (setf (gethash #\a ht2) "A") - (equalpt ht1 ht2)) - t) - -(deftest equalp.32 - (let ((ht1 (make-hash-table :test #'equalp)) - (ht2 (make-hash-table :test #'equalp))) - (setf (gethash #\a ht1) t) - (setf (gethash #\A ht2) t) - (equalpt ht1 ht2)) - t) - -(deftest equalp.33 - (let ((ht1 (make-hash-table :test #'equalp)) - (ht2 (make-hash-table :test #'equalp))) - (setf (gethash #\a ht1) "a") - (setf (gethash #\a ht2) "A") - (equalpt ht1 ht2)) - t) - -(deftest equalp.34 - (let ((ht1 (make-hash-table :test #'equalp)) - (ht2 (make-hash-table :test #'equalp))) - (setf (gethash '#:a ht1) t) - (setf (gethash '#:a ht2) t) - (equalpt ht1 ht2)) - nil) - -(deftest equalp.35 - (loop for test in '(eq eql equal equalp) - collect - (flet ((%make-table - () - (apply #'make-hash-table - :test test - `(,@(when (coin) - (list :size (random 100))) - ,@(when (coin) - (list :rehash-size (1+ (random 50)))) - ,@(when (coin) - (list :rehash-threshold (random 1.0)) ))))) - (loop repeat 200 - count - (let ((ht1 (%make-table)) - (ht2 (%make-table)) - (pairs (loop for i below (random 100) collect (cons (gensym) i)))) - (loop for (k . v) in pairs do (setf (gethash k ht1) v)) - (setf pairs (random-permute pairs)) - (loop for (k . v) in pairs do (setf (gethash k ht2) v)) - (not (equalp ht1 ht2)))))) - (0 0 0 0)) - -(defclass equalp-class-36 () ((slot1 :initarg :slot1) (slot2 :initarg :slot2))) - -;;; If structure is baked up by an instance, it may happen that -;;; instances are compared like structures for `equalp' - slot by -;;; slot. This was a problem in ECL 16.1.3. -(deftest equalp.36 - (equalp (make-instance 'test-object :slot1 1 :slot2 2) - (make-instance 'test-object :slot1 1 :slot2 2)) - nil) - -(deftest equalp.order.1 - (let ((i 0) x y) - (values - (equalp (setf x (incf i)) (setf y (incf i))) - i x y)) - nil 2 1 2) - -;;; Error tests - -(deftest equalp.error.1 - (signals-error (equalp) program-error) - t) - -(deftest equalp.error.2 - (signals-error (equalp nil) program-error) - t) - -(deftest equalp.error.3 - (signals-error (equalp nil nil nil) program-error) - t) diff --git a/t/ansi-test/data-and-control-flow/etypecase.lsp b/t/ansi-test/data-and-control-flow/etypecase.lsp deleted file mode 100644 index 746c43e..0000000 --- a/t/ansi-test/data-and-control-flow/etypecase.lsp +++ /dev/null @@ -1,148 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Oct 18 23:02:23 2002 -;;;; Contains: Tests of ETYPECASE - - - -(deftest etypecase.1 - (etypecase 1 (integer 'a) (t 'b)) - a) - -(deftest etypecase.2 - (signals-type-error x 1 (etypecase x (symbol 'a))) - t) - -(deftest etypecase.3 - (etypecase 1 (symbol 'a) (t 'b)) - b) - -(deftest etypecase.4 - (etypecase 1 (t (values)))) - -(deftest etypecase.5 - (etypecase 1 (integer (values)) (t 'a))) - -(deftest etypecase.6 - (etypecase 1 (bit 'a) (integer 'b)) - a) - -(deftest etypecase.7 - (etypecase 1 (t 'a)) - a) - -(deftest etypecase.8 - (etypecase 1 (t (values 'a 'b 'c))) - a b c) - -(deftest etypecase.9 - (etypecase 1 (integer (values 'a 'b 'c)) (t nil)) - a b c) - -(deftest etypecase.10 - (let ((x 0)) - (values - (etypecase 1 - (bit (incf x) 'a) - (integer (incf x 2) 'b) - (t (incf x 4) 'c)) - x)) - a 1) - -(deftest etypecase.11 - (etypecase 1 (integer) (t 'a)) - nil) - -(deftest etypecase.12 - (etypecase 'a - (number 'bad) - (#.(find-class 'symbol nil) 'good)) - good) - -(deftest etypecase.13 - (block nil - (tagbody - (let ((x 'a)) - (etypecase x (symbol (go 10) - 10 - (return 'bad)))) - 10 - (return 'good))) - good) - -(deftest etypecase.14 - (loop - for x in '(1 a 1.3 "") - collect - (etypecase x (t :good) (integer :bad) (symbol :bad) - (float :bad) (string :bad))) - (:good :good :good :good)) - -(deftest etypecase.15 - (let* ((u (coerce *universe* 'vector)) - (len1 (length u)) - (types (coerce *cl-all-type-symbols* 'vector)) - (len2 (length types))) - (loop - for n = (random 10) - for my-types = (loop repeat n collect (elt types (random len2))) - for val = (elt u (random len1)) - for i = (position val my-types :test #'typep) - for form = `(function - (lambda (x) - (handler-case - (etypecase x - ,@(loop for i from 0 for type in my-types collect `(,type ,i))) - (type-error (c) - (assert (eql x (type-error-datum c))) - (let* ((expected (type-error-expected-type c))) - (let ((equiv (check-equivalence expected - ',(cons 'or my-types)))) - (assert (null equiv) () "EQUIV = ~A" EQUIV))) - nil)))) - for j = (funcall (eval form) val) - repeat 200 - unless (eql i j) - collect (list n my-types val i form j))) - nil) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest etypecase.16 - (macrolet - ((%m (z) z)) - (etypecase - (expand-in-current-env (%m :foo)) - (integer :bad1) - (keyword :good) - (symbol :bad2))) - :good) - -(deftest etypecase.17 - (macrolet - ((%m (z) z)) - (etypecase :foo - (integer (expand-in-current-env (%m :bad1))) - (keyword (expand-in-current-env (%m :good))) - (symbol (expand-in-current-env (%m :bad2))))) - :good) - -;;; Error cases - -(deftest etypecase.error.1 - (signals-error (funcall (macro-function 'etypecase)) - program-error) - t) - -(deftest etypecase.error.2 - (signals-error (funcall (macro-function 'etypecase) - '(etypecase t)) - program-error) - t) - -(deftest etypecase.error.3 - (signals-error (funcall (macro-function 'etypecase) - '(etypecase t) nil nil) - program-error) - t) diff --git a/t/ansi-test/data-and-control-flow/every.lsp b/t/ansi-test/data-and-control-flow/every.lsp deleted file mode 100644 index b23ada4..0000000 --- a/t/ansi-test/data-and-control-flow/every.lsp +++ /dev/null @@ -1,322 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Oct 17 23:25:58 2002 -;;;; Contains: Tests of EVERY - - - -(deftest every.1 - (notnot-mv (every #'identity nil)) - t) - -(deftest every.2 - (notnot-mv (every #'identity #())) - t) - -(deftest every.3 - (let ((count 0)) - (values - (every #'(lambda (x) (incf count) (< x 10)) - '(1 2 4 13 5 1)) - count)) - nil 4) - -(deftest every.4 - (notnot-mv (every #'= '(1 2 3 4) '(1 2 3 4 5))) - t) - -(deftest every.5 - (notnot-mv (every #'= '(1 2 3 4 5) '(1 2 3 4))) - t) - -(deftest every.6 - (every #'= '(1 2 3 4 5) '(1 2 3 4 6)) - nil) - -(deftest every.7 - (notnot-mv (every #'(lambda (x y) (or x y)) - '(nil t t nil t) #(t nil t t nil nil))) - t) - -(deftest every.8 - (let ((x '(1)) - (args nil)) - (loop for i from 1 below (1- (min 100 call-arguments-limit)) - do (push x args) - always (apply #'every #'= args))) - t) - -(deftest every.9 - (notnot-mv (every #'zerop #*000000000000)) - t) - -(deftest every.10 - (notnot-mv (every #'zerop #*)) - t) - -(deftest every.11 - (every #'zerop #*0000010000) - nil) - -(deftest every.12 - (notnot-mv (every #'(lambda (x) (eql x #\a)) "aaaaaaaa")) - t) - -(deftest every.13 - (notnot-mv (every #'(lambda (x) (eql x #\a)) "")) - t) - -(deftest every.14 - (every #'(lambda (x) (eql x #\a)) "aaaaaabaaaa") - nil) - -(deftest every.15 - (every 'null '(nil nil t nil)) - nil) - -(deftest every.16 - (notnot-mv (every 'null '(nil nil nil nil))) - t) - -;;; Other specialized sequences - -(deftest every.17 - (let ((v (make-array '(10) :initial-contents '(0 0 0 0 1 2 3 4 5 6) - :fill-pointer 4))) - (loop for j from 0 to 9 - do (setf (fill-pointer v) j) - collect (notnot (every #'zerop v)))) - (t t t t t nil nil nil nil nil)) - -(deftest every.18 - (loop for i from 1 to 40 - for type = `(unsigned-byte ,i) - unless - (let ((v (make-array '(10) :initial-contents '(0 0 0 0 1 1 1 1 1 1) - :element-type type - :fill-pointer 4))) - (equal (loop for j from 0 to 9 - do (setf (fill-pointer v) j) - collect (notnot (every #'zerop v))) - '(t t t t t nil nil nil nil nil))) - collect i) - nil) - -(deftest every.19 - (loop for i from 1 to 40 - for type = `(signed-byte ,i) - unless - (let ((v (make-array '(10) :initial-contents '(0 0 0 0 -1 -1 -1 -1 -1 -1) - :element-type type - :fill-pointer 4))) - (equal (loop for j from 0 to 9 - do (setf (fill-pointer v) j) - collect (notnot (every #'zerop v))) - '(t t t t t nil nil nil nil nil))) - collect i) - nil) - -(deftest every.20 - (let ((v (make-array '(10) :initial-contents "abcd012345" - :element-type 'character - :fill-pointer 4))) - (loop for j from 0 to 9 - do (setf (fill-pointer v) j) - collect (notnot (every #'alpha-char-p v)))) - (t t t t t nil nil nil nil nil)) - -(deftest every.21 - (let ((v (make-array '(10) :initial-contents "abcd012345" - :element-type 'base-char - :fill-pointer 4))) - (loop for j from 0 to 9 - do (setf (fill-pointer v) j) - collect (notnot (every #'alpha-char-p v)))) - (t t t t t nil nil nil nil nil)) - -(deftest every.22 - (let ((v (make-array '(5) :initial-contents "abcde" - :element-type 'base-char))) - (values - (notnot (every #'alpha-char-p v)) - (setf (aref v 2) #\0) - (every #'alpha-char-p v))) - t #\0 nil) - -;;; Displaced vectors - -(deftest every.23 - (let* ((v1 (make-array '(10) :initial-contents '(1 3 2 4 6 8 5 7 9 1))) - (v2 (make-array '(4) :displaced-to v1 - :displaced-index-offset 2))) - (values - (every #'evenp v1) - (notnot (every 'evenp v2)))) - nil t) - -(deftest every.24 - (loop for i from 1 to 40 - for type = `(unsigned-byte ,i) - unless - (let* ((v1 (make-array '(10) :initial-contents '(1 1 0 0 0 0 1 1 1 1) - :element-type type)) - (v2 (make-array '(4) :displaced-to v1 - :displaced-index-offset 2 - :element-type type))) - (and (not (every 'evenp v1)) - (every #'evenp v2))) - collect i) - nil) - -(deftest every.25 - (loop for i from 1 to 40 - for type = `(signed-byte ,i) - unless - (let* ((v1 (make-array '(10) :initial-contents '(-1 -1 0 0 0 0 -1 -1 -1 -1) - :element-type type)) - (v2 (make-array '(4) :displaced-to v1 - :displaced-index-offset 2 - :element-type type))) - (and (not (every 'evenp v1)) - (every #'evenp v2))) - collect i) - nil) - -(deftest every.26 - (let* ((s1 (make-array '(8) :initial-contents "12abc345" :element-type 'character))) - (loop for i from 0 to 6 - for s2 = (make-array '(2) :element-type 'character - :displaced-to s1 - :displaced-index-offset i) - collect (notnot (every 'alpha-char-p s2)))) - (nil nil t t nil nil nil)) - -(deftest every.27 - (let* ((s1 (make-array '(8) :initial-contents "12abc345" :element-type 'base-char))) - (loop for i from 0 to 6 - for s2 = (make-array '(2) :element-type 'base-char - :displaced-to s1 - :displaced-index-offset i) - collect (notnot (every 'alpha-char-p s2)))) - (nil nil t t nil nil nil)) - -;;; adjustable vectors - -(deftest every.28 - (let ((v (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) - :adjustable t))) - (values - (notnot (every #'plusp v)) - (progn - (adjust-array v '(11) :initial-element -1) - (every #'plusp v)))) - t nil) - -(deftest every.29 - (let ((v (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) - :fill-pointer 10 - :adjustable t))) - (values - (notnot (every #'plusp v)) - (progn - (adjust-array v '(11) :initial-element -1) - (every #'plusp v)))) - t t) - -;;; Float, complex vectors - -(deftest every.30 - (loop for type in '(short-float single-float double-float long-float) - for v = (make-array '(6) - :element-type type - :initial-contents - (mapcar #'(lambda (x) (coerce x type)) '(1 2 3 4 5 6))) - unless (every #'plusp v) - collect (list type v)) - nil) - -(deftest every.31 - (loop for type in '(short-float single-float double-float long-float) - for v = (make-array '(6) - :element-type type - :fill-pointer 5 - :initial-contents - (mapcar #'(lambda (x) (coerce x type)) '(1 2 3 4 5 -1))) - unless (every #'plusp v) - collect (list type v)) - nil) - -(deftest every.32 - (loop for type in '(short-float single-float double-float long-float) - for ctype = `(complex ,type) - for v = (make-array '(6) - :element-type ctype - :initial-contents - (mapcar #'(lambda (x) (complex x (coerce x type))) '(1 2 3 4 5 6))) - unless (every #'complexp v) - collect (list type v)) - nil) - -;;; Order of arguments - -(deftest every.order.1 - (let ((i 0) x y) - (values - (every (progn (setf x (incf i)) #'null) - (progn (setf y (incf i)) '(nil nil a nil))) - i x y)) - nil 2 1 2) - -(deftest every.order.2 - (let ((i 0) x y z) - (values - (every (progn (setf x (incf i)) #'equal) - (progn (setf y (incf i)) '(nil nil a nil)) - (progn (setf z (incf i)) '(nil nil a b))) - i x y z)) - nil 3 1 2 3) - -;;; Error cases - -(deftest every.error.1 - (check-type-error #'(lambda (x) (every x '(a b c))) - #'(lambda (x) (typep x '(or function symbol)))) - nil) - -(deftest every.error.2 - (check-type-error #'(lambda (x) (every #'null x)) - #'(lambda (x) (typep x 'sequence))) - nil) - -(deftest every.error.3 - (check-type-error #'(lambda (x) (every #'eq () x)) - #'(lambda (x) (typep x 'sequence))) - nil) - -(deftest every.error.8 - (signals-error (every) program-error) - t) - -(deftest every.error.9 - (signals-error (every #'null) program-error) - t) - -(deftest every.error.10 - (signals-error (locally (every 1 '(a b c)) t) type-error) - t) - -(deftest every.error.11 - (signals-error (every #'cons '(a b c)) program-error) - t) - -(deftest every.error.12 - (signals-error (every #'cons '(a b c) '(1 2 3) '(4 5 6)) program-error) - t) - -(deftest every.error.13 - (signals-error (every #'car '(a b c)) type-error) - t) - -(deftest every.error.14 - (signals-error (every #'identity '(1 2 3 . 4)) type-error) - t) diff --git a/t/ansi-test/data-and-control-flow/fboundp.lsp b/t/ansi-test/data-and-control-flow/fboundp.lsp deleted file mode 100644 index dfe6b9e..0000000 --- a/t/ansi-test/data-and-control-flow/fboundp.lsp +++ /dev/null @@ -1,101 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Oct 7 22:37:22 2002 -;;;; Contains: Tests of FBOUNDP - - - -(deftest fboundp.1 - (not-mv (fboundp 'car)) - nil) - -(deftest fboundp.2 - (not-mv (fboundp 'cdr)) - nil) - -(deftest fboundp.3 - (not-mv (fboundp 'defun)) ; a macro - nil) - -(deftest fboundp.4 - ;; fresh symbols are not fbound - (let ((g (gensym))) (fboundp g)) - nil) - -(defun fboundp-5-fn (x) x) -(deftest fboundp.5 - (not-mv (fboundp 'fboundp-5-fn)) - nil) - -(report-and-ignore-errors - (defun (setf fboundp-6-accessor) (y x) (setf (car x) y))) - -(deftest fboundp.6 - (not-mv (fboundp '(setf fboundp-6-accessor))) - nil) - -(deftest fboundp.7 - (let ((g (gensym))) (fboundp (list 'setf g))) - nil) - -;;; See 11.1.2.1.1 -(deftest fboundp.8 - (loop for x in *cl-non-function-macro-special-operator-symbols* - when (and (fboundp x) (not (eq x 'ed))) - collect x) - nil) - -(deftest fboundp.order.1 - (let ((i 0)) - (values (notnot (fboundp (progn (incf i) 'car))) i)) - t 1) - -(deftest fboundp.error.1 - (check-type-error #'fboundp #'(lambda (x) (typep x '(or symbol (cons (eql setf) (cons symbol null)))))) - nil) - -(deftest fboundp.error.2 - (signals-type-error x '(x) (fboundp x)) - t) - -(deftest fboundp.error.3 - (signals-type-error x '(setf) (fboundp x)) - t) - -(deftest fboundp.error.4 - (signals-type-error x '(setf foo . bar) (fboundp x)) - t) - -(deftest fboundp.error.5 - (signals-type-error x '(setf foo bar) (fboundp x)) - t) - -(deftest fboundp.error.6 - (signals-error (fboundp) program-error) - t) - -(deftest fboundp.error.7 - (signals-error (fboundp 'cons nil) program-error) - t) - -(deftest fboundp.error.8 - (signals-error (locally (fboundp 1) t) type-error) - t) - -(deftest fboundp.error.9 - (signals-type-error x '(setf . foo) (fboundp x)) - t) - -(deftest fboundp.error.10 - (loop for x in *mini-universe* - unless (symbolp x) - nconc - (handler-case - (list x (fboundp `(setf ,x))) - (type-error (c) - (assert (not (typep (type-error-datum c) - (type-error-expected-type c)))) - nil) - (error (c) (list (list x c))))) - nil) - diff --git a/t/ansi-test/data-and-control-flow/fdefinition.lsp b/t/ansi-test/data-and-control-flow/fdefinition.lsp deleted file mode 100644 index 67538ac..0000000 --- a/t/ansi-test/data-and-control-flow/fdefinition.lsp +++ /dev/null @@ -1,104 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Jan 13 15:27:51 2003 -;;;; Contains: Tests for FDEFINITION - - - -;;; Error cases - -(deftest fdefinition.error.1 - (signals-error (fdefinition) program-error) - t) - -(deftest fdefinition.error.2 - (signals-error (fdefinition 'cons nil) program-error) - t) - -(deftest fdefinition.error.3 - (let ((v (gensym))) - (eval `(signals-error (fdefinition ',v) undefined-function - :name ,v))) - t) - -(deftest fdefinition.error.4 - (check-type-error #'fdefinition #'(lambda (x) (typep x '(or symbol (cons (eql setf) (cons symbol null)))))) - nil) - -;;; (deftest fdefinition.error.5 -;;; (let ((fn `(setf ,(gensym)))) -;;; (eval `(signals-error (fdefinition ',fn) undefined-function -;;; :name ,fn))) -;;; t) - -(deftest fdefinition.error.6 - (signals-error (locally (fdefinition 10) t) type-error) - t) - -(deftest fdefinition.error.7 - (check-type-error #'fdefinition (constantly nil) '((setf) (setf . foo) (setf foo . bar) (setf foo bar))) - nil) - -(deftest fdefinition.error.8 - (loop for x in *mini-universe* - unless (symbolp x) - nconc - (handler-case - (list x (fdefinition `(setf ,x))) - (type-error (c) - (assert (not (typep (type-error-datum c) - (type-error-expected-type c)))) - nil) - (error (c) (list (list x c))))) - nil) - -;;; Non-error cases - -(deftest fdefinition.1 - (let ((fun (fdefinition 'cons))) - (funcall fun 'a 'b)) - (a . b)) - -(deftest fdefinition.2 - (progn - (fdefinition 'cond) - :good) - :good) - -(deftest fdefinition.3 - (progn - (fdefinition 'setq) - :good) - :good) - -(deftest fdefinition.4 - (let ((sym (gensym))) - (values - (fboundp sym) - (progn - (setf (fdefinition sym) (fdefinition 'cons)) - (funcall (symbol-function sym) 'a 'b)) - (notnot (fboundp sym)))) - nil - (a . b) - t) - -(deftest fdefinition.5 - (let* ((sym (gensym)) - (fname (list 'setf sym))) - (values - (fboundp fname) - (progn - (setf (fdefinition fname) (fdefinition 'cons)) - (eval `(setf (,sym 'a) 'b))) - (notnot (fboundp fname)))) - nil - (b . a) - t) - -(deftest fdefinition.order.1 - (let ((i 0)) - (fdefinition (progn (incf i) 'setq)) - i) - 1) - diff --git a/t/ansi-test/data-and-control-flow/flet.lsp b/t/ansi-test/data-and-control-flow/flet.lsp deleted file mode 100644 index f4e0912..0000000 --- a/t/ansi-test/data-and-control-flow/flet.lsp +++ /dev/null @@ -1,585 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Oct 8 22:55:02 2002 -;;;; Contains: Tests of FLET - - - -(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 :good))) - nil)) - (%f) - :bad)) - :good) - -;;; Key arguments are not in the block defined by -;;; the local function declaration -(deftest flet.4a - (block %f - (flet ((%f (&key (x (return-from %f :good))) - nil)) - (%f) - :bad)) - :good) - -(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 - (signals-error - (flet ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) (%f :c 4)) - program-error) - t) - -;;; Odd # of keyword args should throw a program-error in safe code -;;; (section 3.5.1.6) -(deftest flet.13 - (signals-error - (flet ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) (%f :a)) - program-error) - t) - -;;; Too few arguments (section 3.5.1.2) -(deftest flet.14 - (signals-error (flet ((%f (a) a)) (%f)) program-error) - t) - -;;; Too many arguments (section 3.5.1.3) -(deftest flet.15 - (signals-error (flet ((%f (a) a)) (%f 1 2)) program-error) - t) - -;;; Invalid keyword argument (section 3.5.1.5) -(deftest flet.16 - (signals-error (flet ((%f (&key a) a)) (%f '(foo))) program-error) - t) - - -;;; Definition of a (setf ...) function - -(deftest flet.17 - (flet (((setf %f) (x y) (setf (car y) x))) - (let ((z (list 1 2))) - (setf (%f z) 'a) - z)) - (a 2)) - -;;; Body is an implicit progn -(deftest flet.18 - (flet ((%f (x) (incf x) (+ x x))) - (%f 10)) - 22) - -;;; Can handle at least 50 lambda parameters -(deftest flet.19 - (flet ((%f (a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 - b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 - c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 - d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 - e1 e2 e3 e4 e5 e6 e7 e8 e9 e10) - (+ a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 - b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 - c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 - d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 - e1 e2 e3 e4 e5 e6 e7 e8 e9 e10))) - (%f 1 2 3 4 5 6 7 8 9 10 - 11 12 13 14 15 16 17 18 19 20 - 21 22 23 24 25 26 27 28 29 30 - 31 32 33 34 35 36 37 38 39 40 - 41 42 43 44 45 46 47 48 49 50)) - 1275) - -;;; flet works with a large (maximal?) number of arguments -(deftest flet.20 - (let* ((n (min (1- lambda-parameters-limit) 1024)) - (vars (loop repeat n collect (gensym)))) - (eval - `(eqlt ,n - (flet ((%f ,vars (+ ,@ vars))) - (%f ,@(loop for e in vars collect 1)))))) - t) - -;;; Declarations and documentation strings are ok -(deftest flet.21 - (flet ((%f (x) - (declare (type fixnum x)) - "Add one to the fixnum x." - (1+ x))) - (declare (ftype (function (fixnum) integer) %f)) - (%f 10)) - 11) - -(deftest flet.22 - (flet ((%f (x &optional (y 1 y-p) (z 2 z-p)) - (list x y (not (not y-p)) z (not (not z-p))))) - (values (%f 10) (%f 20 40) (%f 'a 'b 'c))) - (10 1 nil 2 nil) - (20 40 t 2 nil) - (a b t c t)) - -(deftest flet.23 - (flet ((%f (x &optional (y 1 y-p) (z 2 z-p) &rest r) - (list x y (not (not y-p)) z (not (not z-p)) r))) - (values (%f 10) (%f 20 40) (%f 'a 'b 'c) (%f 'd 'e 'f 'g 'h))) - (10 1 nil 2 nil nil) - (20 40 t 2 nil nil) - (a b t c t nil) - (d e t f t (g h))) - -(deftest flet.24 - (flet ((%f (x &optional (y 1 y-p) (z 2 z-p) &rest r &key foo bar) - (list x y (not (not y-p)) z (not (not z-p)) r foo bar))) - (values (%f 10) (%f 20 40) (%f 'a 'b 'c) - (%f 'd 'e 'f :foo 'h) - (%f 'd 'e 'f :bar 'i) )) - (10 1 nil 2 nil nil nil nil) - (20 40 t 2 nil nil nil nil) - (a b t c t nil nil nil) - (d e t f t (:foo h) h nil) - (d e t f t (:bar i) nil i)) - -(deftest flet.25 - (flet ((%f (x &optional (y 1 y-p) (z 2 z-p) &rest r &key foo bar - &allow-other-keys) - (list x y (not (not y-p)) z (not (not z-p)) r foo bar))) - (values (%f 10) (%f 20 40) (%f 'a 'b 'c) - (%f 'd 'e 'f :foo 'h :whatever nil) - (%f 'd 'e 'f :bar 'i :illegal t :foo 'z) )) - (10 1 nil 2 nil nil nil nil) - (20 40 t 2 nil nil nil nil) - (a b t c t nil nil nil) - (d e t f t (:foo h :whatever nil) h nil) - (d e t f t (:bar i :illegal t :foo z) z i)) - -(deftest flet.26 - (flet ((%f (x &optional (y 1 y-p) (z 2 z-p) &rest r &key foo bar) - (list x y (not (not y-p)) z (not (not z-p)) r foo bar))) - (values (%f 10) (%f 20 40) (%f 'a 'b 'c) - (%f 'd 'e 'f :foo 'h :whatever nil :allow-other-keys t) - (%f 'd 'e 'f :bar 'i :illegal t :foo 'z :allow-other-keys t) )) - (10 1 nil 2 nil nil nil nil) - (20 40 t 2 nil nil nil nil) - (a b t c t nil nil nil) - (d e t f t (:foo h :whatever nil :allow-other-keys t) h nil) - (d e t f t (:bar i :illegal t :foo z :allow-other-keys t) z i)) - -;;; Section 3.4.1.4.1: "The :allow-other-keys argument is permissible -;;; in all situations involving keyword[2] arguments, even when its -;;; associated value is false." -(deftest flet.27 - (flet ((%f (x &optional (y 1 y-p) (z 2 z-p) &rest r &key foo bar) - (list x y (not (not y-p)) z (not (not z-p)) r foo bar))) - (values (%f 10) (%f 20 40) (%f 'a 'b 'c) - (%f 'd 'e 'f :foo 'h :allow-other-keys nil) - (%f 'd 'e 'f :bar 'i :allow-other-keys nil) )) - (10 1 nil 2 nil nil nil nil) - (20 40 t 2 nil nil nil nil) - (a b t c t nil nil nil) - (d e t f t (:foo h :allow-other-keys nil) h nil) - (d e t f t (:bar i :allow-other-keys nil) nil i)) - -(deftest flet.28 - (flet ((%f (x &optional (y 1 y-p) (z 2 z-p) &rest r - &key foo bar allow-other-keys) - (list x y (not (not y-p)) z (not (not z-p)) allow-other-keys - r foo bar))) - (values (%f 10) (%f 20 40) (%f 'a 'b 'c) - (%f 'd 'e 'f :foo 'h :whatever nil :allow-other-keys 100) - (%f 'd 'e 'f :bar 'i :illegal t :foo 'z :allow-other-keys 200) )) - (10 1 nil 2 nil nil nil nil nil) - (20 40 t 2 nil nil nil nil nil) - (a b t c t nil nil nil nil) - (d e t f t 100 (:foo h :whatever nil :allow-other-keys 100) h nil) - (d e t f t 200 (:bar i :illegal t :foo z :allow-other-keys 200) z i)) - -(deftest flet.29 - (flet ((%f (x &optional (y 1 y-p) (z 2 z-p) &rest r - &key foo bar allow-other-keys &allow-other-keys) - (list x y (not (not y-p)) z (not (not z-p)) allow-other-keys - r foo bar))) - (values (%f 10) (%f 20 40) (%f 'a 'b 'c) - (%f 'd 'e 'f :foo 'h :whatever nil :allow-other-keys nil :blah t) - (%f 'd 'e 'f :bar 'i :illegal t :foo 'z - :allow-other-keys nil :zzz 10) )) - (10 1 nil 2 nil nil nil nil nil) - (20 40 t 2 nil nil nil nil nil) - (a b t c t nil nil nil nil) - (d e t f t nil (:foo h :whatever nil :allow-other-keys nil :blah t) h nil) - (d e t f t nil (:bar i :illegal t :foo z :allow-other-keys nil :zzz 10) z i)) - -;;; Tests of non-keyword keywords (see section 3.4.1.4, paragrph 2). -(deftest flet.30 - (flet ((%f (&key ((foo bar) nil)) bar)) - (values (%f) (%f 'foo 10))) - nil 10) - -(deftest flet.31 - (flet ((%f (&key ((:foo bar) nil)) bar)) - (values (%f) (%f :foo 10))) - nil 10) - -;;; Multiple keyword actual parameters -(deftest flet.32 - (flet ((%f (&key a b c) (list a b c))) - (%f :a 10 :b 20 :c 30 :a 40 :b 50 :c 60)) - (10 20 30)) - -;;; More aux parameters -(deftest flet.33 - (flet ((%f (x y &aux (a (1+ x)) (b (+ x y a)) (c (list x y a b))) - c)) - (%f 5 9)) - (5 9 6 20)) - -(deftest flet.34 - (flet ((%f (x y &rest r &key foo bar &aux (c (list x y r foo bar))) - c)) - (values - (%f 1 2) - (%f 1 2 :foo 'a) - (%f 1 2 :bar 'b) - (%f 1 2 :foo 'a :bar 'b) - (%f 1 2 :bar 'b :foo 'a))) - (1 2 nil nil nil) - (1 2 (:foo a) a nil) - (1 2 (:bar b) nil b) - (1 2 (:foo a :bar b) a b) - (1 2 (:bar b :foo a) a b)) - -;;; Binding of formal parameters that are also special variables -(deftest flet.35 - (let ((x 'bad)) - (declare (special x)) - (flet ((%f () x)) - (flet ((%g (x) - (declare (special x)) - (%f))) - (%g 'good)))) - good) - -(deftest flet.36 - (let ((x 'bad)) - (declare (special x)) - (flet ((%f () x)) - (flet ((%g (&aux (x 'good)) - (declare (special x)) - (%f))) - (%g)))) - good) - -(deftest flet.37 - (let ((x 'bad)) - (declare (special x)) - (flet ((%f () x)) - (flet ((%g (&rest x) - (declare (special x)) - (%f))) - (%g 'good)))) - (good)) - -(deftest flet.38 - (let ((x 'bad)) - (declare (special x)) - (flet ((%f () x)) - (flet ((%g (&key (x 'good)) - (declare (special x)) - (%f))) - (%g)))) - good) - -(deftest flet.39 - (let ((x 'bad)) - (declare (special x)) - (flet ((%f () x)) - (flet ((%g (&key (x 'bad)) - (declare (special x)) - (%f))) - (%g :x 'good)))) - good) - -(deftest flet.40 - (let ((x 'good)) - (declare (special x)) - (flet ((%f () x)) - (flet ((%g (&key (x 'bad)) - (%f))) - (%g :x 'worse)))) - good) - - -(deftest flet.45 - (flet ((nil () 'a)) (nil)) - a) - -(deftest flet.46 - (flet ((t () 'b)) (t)) - b) - -;;; Keywords can be function names -(deftest flet.47 - (flet ((:foo () 'bar)) (:foo)) - bar) - -(deftest flet.48 - (flet ((:foo () 'bar)) (funcall #':foo)) - bar) - -(deftest flet.49 - (loop for s in *cl-non-function-macro-special-operator-symbols* - for form = `(ignore-errors (flet ((,s () 'a)) (,s))) - unless (eq (eval form) 'a) - collect s) - nil) - -(deftest flet.50 - (loop for s in *cl-non-function-macro-special-operator-symbols* - for form = `(ignore-errors (flet ((,s () 'a)) - (declare (ftype (function () symbol) - ,s)) - (,s))) - unless (eq (eval form) 'a) - collect s) - nil) - -;;; Binding SETF functions of certain COMMON-LISP symbols -(deftest flet.51 - (loop for s in *cl-non-function-macro-special-operator-symbols* - for form = `(ignore-errors - (flet (((setf ,s) (&rest args) - (declare (ignore args)) - 'a)) - (setf (,s) 10))) - unless (eq (eval form) 'a) - collect s) - nil) - -;;; Check that FLET does not have a tagbody -(deftest flet.52 - (block done - (tagbody - (flet ((%f () (go 10) 10 (return-from done 'bad))) - (%f)) - 10 - (return-from done 'good))) - good) - -;;; Check that nil keyword arguments do not enable the default values - -(deftest flet.53 - (flet ((%f (&key (a 'wrong)) a)) (%f :a nil)) - nil) - -(deftest flet.54 - (flet ((%f (&key (a 'wrong a-p)) (list a (not a-p)))) (%f :a nil)) - (nil nil)) - -(deftest flet.55 - (flet ((%f (&key ((:a b) 'wrong)) b)) (%f :a nil)) - nil) - -(deftest flet.56 - (flet ((%f (&key ((:a b) 'wrong present?)) (list b (not present?)))) (%f :a nil)) - (nil nil)) - -(deftest flet.57 - (flet ((%f (&key) 'good)) - (%f :allow-other-keys nil)) - good) - -(deftest flet.58 - (flet ((%f (&key) 'good)) - (%f :allow-other-keys t)) - good) - -(deftest flet.59 - (flet ((%f (&key) 'good)) - (%f :allow-other-keys t :a 1 :b 2)) - good) - -(deftest flet.60 - (flet ((%f (&key &allow-other-keys) 'good)) - (%f :a 1 :b 2)) - good) - -;;; NIL as a disallowed keyword argument -(deftest flet.61 - (signals-error - (flet ((%f (&key) :bad)) (%f nil nil)) - program-error) - t) - -;;; Free declarations do not affect argument forms - -(deftest flet.62 - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) - (flet ((%f (&optional (y x)) - (declare (special x)) - y)) - (%f)))) - :good) - -(deftest flet.63 - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) - (flet ((%f (&key (y x)) - (declare (special x)) - y)) - (%f)))) - :good) - -(deftest flet.64 - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) - (flet () (declare (special x))) - x)) - :good) - -(deftest flet.65 - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) - (flet ((%f () (declare (special x))))) - x)) - :good) - -(deftest flet.66 - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) - (flet ((%f () (declare (special x)))) - x))) - :good) - -(deftest flet.67 - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) - (flet ((%f (&aux (y x)) - (declare (special x)) - y)) - (%f)))) - :good) - -(deftest flet.68 - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) - (flet ((%f () x)) - (declare (special x)) - (%f)))) - :good) - -(deftest flet.69 - (let ((*x* 0)) - (declare (special *x*)) - (flet ((%f (i) - #'(lambda (arg) - (declare (ignore arg)) - (incf *x* i)))) - (values - (mapcar (%f 1) '(a b c)) - (mapcar (%f 2) '(a b c))))) - (1 2 3) - (5 7 9)) - -;;; Macros are expanded in the appropriate environment - -(deftest flet.70 - (macrolet ((%m (z) z)) - (flet () (expand-in-current-env (%m :good)))) - :good) - -(deftest flet.71 - (macrolet ((%m (z) z)) - (flet ((%f () (expand-in-current-env (%m :good)))) - (%f))) - :good) - -;;; local function bindings shadow global functions, macros -;;; and compiler-macros - -(defun flet.72 () :bad) - -(deftest flet.72 - (flet ((flet.72 () :good)) - (flet.72)) - :good) - -(defmacro flet.73 () :bad) - -(deftest flet.73 - (flet ((flet.73 () :good)) - (flet.73)) - :good) - -(define-compiler-macro flet.74 (&whole form) - :bad) - -(deftest flet.74 - (flet ((flet.74 () :good)) - (flet.74)) - :good) diff --git a/t/ansi-test/data-and-control-flow/fmakunbound.lsp b/t/ansi-test/data-and-control-flow/fmakunbound.lsp deleted file mode 100644 index 213de5c..0000000 --- a/t/ansi-test/data-and-control-flow/fmakunbound.lsp +++ /dev/null @@ -1,82 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Oct 8 00:09:14 2002 -;;;; Contains: Tests for FMAKUNBOUND - - - -(deftest fmakunbound.1 - (let ((g (gensym))) - (and (not (fboundp g)) - (setf (symbol-function g) #'car) - (fboundp g) - (values (eqt (check-values (fmakunbound g)) g) - (fboundp g)))) - t nil) - -(deftest fmakunbound.2 - (let ((g (gensym))) - (and (not (fboundp g)) - (eval `(defun ,g () nil)) - (fboundp g) - (values (eqt (check-values (fmakunbound g)) g) - (fboundp g)))) - t nil) - -(deftest fmakunbound.3 - (let ((g (gensym))) - (and (not (fboundp g)) - (eval `(defmacro ,g () nil)) - (fboundp g) - (values (eqt (check-values (fmakunbound g)) g) - (fboundp g)))) - t nil) - -(deftest fmakunbound.4 - (let* ((g (gensym)) - (n `(setf ,g))) - (and (not (fboundp n)) - (eval `(defun ,n () nil)) - (fboundp n) - (values (equalt (check-values (fmakunbound n)) n) - (fboundp n)))) - t nil) - -(deftest fmakunbound.error.1 - (check-type-error #'fmakunbound - #'(lambda (x) (typep x '(or symbol (cons (eql setf) (cons symbol null)))))) - nil) - -(deftest fmakunbound.error.2 - (check-type-error #'fmakunbound (constantly nil) - '((setf) (setf . foo) (setf foo . bar) (setf foo bar))) - nil) - -(deftest fmakunbound.error.3 - (signals-type-error x '(x) (fmakunbound x)) - t) - -(deftest fmakunbound.error.4 - (signals-error (fmakunbound) program-error) - t) - -(deftest fmakunbound.error.5 - (signals-error (fmakunbound (gensym) nil) program-error) - t) - -(deftest fmakunbound.error.6 - (signals-error (locally (fmakunbound 1) t) type-error) - t) - -(deftest fmakunbound.error.7 - (loop for x in *mini-universe* - unless (symbolp x) - nconc - (handler-case - (list x (fmakunbound `(setf ,x))) - (type-error (c) - (assert (not (typep (type-error-datum c) - (type-error-expected-type c)))) - nil) - (error (c) (list (list x c))))) - nil) diff --git a/t/ansi-test/data-and-control-flow/funcall.lsp b/t/ansi-test/data-and-control-flow/funcall.lsp deleted file mode 100644 index 6ded38d..0000000 --- a/t/ansi-test/data-and-control-flow/funcall.lsp +++ /dev/null @@ -1,105 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Oct 9 21:45:07 2002 -;;;; Contains: Tests of FUNCALL - - - -(deftest funcall.1 - (let ((fn #'cons)) - (funcall fn 'a 'b)) - (a . b)) - -(deftest funcall.2 - (funcall (symbol-function 'cons) 'a 'b) - (a . b)) - -(deftest funcall.3 - (let ((fn 'cons)) - (funcall fn 'a 'b)) - (a . b)) - -(deftest funcall.4 - (funcall 'cons 'a 'b) - (a . b)) - -(deftest funcall.5 - (let ((fn #'+)) - (funcall fn 1 2 3 4)) - 10) - -(deftest funcall.6 - (funcall #'(lambda (x y) (cons x y)) 'a 'b) - (a . b)) - -(defun xcons (x y) (cons x y)) - -(deftest funcall.7 - (flet ((xcons (x y) (list y x))) - (values (funcall 'xcons 1 2) - (funcall #'xcons 1 2))) - (1 . 2) - (2 1)) - -(deftest funcall.8 - (flet ((foo (x y z) (values x y z))) - (funcall #'foo 1 2 3)) - 1 2 3) - -(deftest funcall.9 - (flet ((foo () (values))) - (funcall #'foo)) - ) - -(deftest funcall.order.1 - (let ((i 0) a b) - (values - (funcall (progn (setf a (incf i)) #'car) - (progn (setf b (incf i)) '(x . y))) - i a b)) - x 2 1 2) - -(deftest funcall.order.2 - (let ((i 0) a b c) - (values - (funcall (progn (setf a (incf i)) #'cons) - (progn (setf b (incf i)) 'x) - (progn (setf c (incf i)) 'y)) - i a b c)) - (x . y) 3 1 2 3) - - -;;; FUNCALL should throw an UNDEFINED-FUNCTION condition when -;;; called on a symbol with a global definition as a special -;;; operator -(deftest funcall.error.1 - (signals-error (funcall 'quote 1) undefined-function :name quote) - t) - -(deftest funcall.error.2 - (signals-error (funcall 'progn 1) undefined-function :name progn) - t) - -;;; FUNCALL should throw an UNDEFINED-FUNCTION condition when -;;; called on a symbol with a global definition as a macro -(deftest funcall.error.3 - (signals-error (funcall 'defconstant '(defconstant x 10)) - undefined-function - :name defconstant) - t) - -(deftest funcall.error.4 - (signals-error (funcall) program-error) - t) - -(deftest funcall.error.5 - (signals-error (funcall #'cons) program-error) - t) - -(deftest funcall.error.6 - (signals-error (funcall #'cons 1) program-error) - t) - -(deftest funcall.error.7 - (signals-type-error x 'a (funcall #'car x)) - t) diff --git a/t/ansi-test/data-and-control-flow/function-lambda-expression.lsp b/t/ansi-test/data-and-control-flow/function-lambda-expression.lsp deleted file mode 100644 index 6a28294..0000000 --- a/t/ansi-test/data-and-control-flow/function-lambda-expression.lsp +++ /dev/null @@ -1,44 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Jan 13 16:27:12 2003 -;;;; Contains: Tests for FUNCTION-LAMBDA-EXPRESSION - - - -(deftest function-lambda-expression.1 - (length - (multiple-value-list - (function-lambda-expression #'cons))) - 3) - -(deftest function-lambda-expression.2 - (let ((x nil)) - (flet ((%f () x)) - (let ((ret-vals - (multiple-value-list - (function-lambda-expression #'%f)))) - (values (length ret-vals) - (notnot (second ret-vals)))))) - 3 t) - -;;; Verify that it doesn't barf on generic functions -(deftest function-lambda-expression.3 - (length - (multiple-value-list - (function-lambda-expression - #'meaningless-user-generic-function-for-universe))) - 3) - -(deftest function-lambda-expression.order.1 - (let ((i 0)) - (function-lambda-expression (progn (incf i) #'cons)) - i) - 1) - -(deftest function-lambda-expression.error.1 - (signals-error (function-lambda-expression) program-error) - t) - -(deftest function-lambda-expression.error.2 - (signals-error (function-lambda-expression #'cons nil) program-error) - t) diff --git a/t/ansi-test/data-and-control-flow/function.lsp b/t/ansi-test/data-and-control-flow/function.lsp deleted file mode 100644 index d042875..0000000 --- a/t/ansi-test/data-and-control-flow/function.lsp +++ /dev/null @@ -1,184 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Oct 7 07:34:29 2002 -;;;; Contains: Tests for type FUNCTION and the special form FUNCTION - - - -;;; -;;; Note! There are significant incompatibilities between CLTL1 and ANSI CL -;;; in the meaning of FUNCTION and FUNCTIONP. -;;; - -(deftest function.1 - (typep nil 'function) - nil) - -;;; The next test demonstrates an incompatibility between CLtL1 and ANSI CL. -;;; In ANSI CL, symbols are no longer of type FUNCTION. -(deftest function.2 - (typep 'identity 'function) - nil) - -(deftest function.3 - (not-mv (typep #'identity 'function)) - nil) - -(deftest function.4 - (loop for x in *cl-symbol-names* - for s = (find-symbol x "CL") - for f = (and (fboundp s) - (symbol-function s) - (not (special-operator-p s)) - (not (macro-function s)) - (symbol-function s)) - unless (or (null f) - (typep f 'function)) - collect x) - nil) - -(deftest function.5 - (typep '(setf car) 'function) - nil) - -;;; The next test demonstrates an incompatibility between CLtL1 and ANSI CL. -;;; In ANSI CL, lambda forms are no longer of type FUNCTION. -(deftest function.6 - (typep '(lambda (x) x) 'function) - nil) - -(report-and-ignore-errors - (defun (setf function-7-accessor) (y x) (setf (car x) y) y)) - -(deftest function.7 - (not-mv (typep #'(setf function-7-accessor) 'function)) - nil) - -(deftest function.8 - (not-mv (typep #'(lambda (x) x) 'function)) - nil) - -(deftest function.9 - (not-mv (typep (compile nil '(lambda (x) x)) 'function)) - nil) - -;;; The next test demonstrates an incompatibility between CLtL1 and ANSI CL. -;;; In ANSI CL, symbols and cons can no longer also be of type FUNCTION. -(deftest function.10 - (check-predicate (typef '(not (and (or number character symbol - cons array) - function)))) - nil) - -(deftest function.11 - (flet ((%f () nil)) (typep '%f 'function)) - nil) - -(deftest function.12 - (flet ((%f () nil)) (not-mv (typep #'%f 'function))) - nil) - -(deftest function.13 - (labels ((%f () nil)) (not-mv (typep #'%f 'function))) - nil) - -;;; "If name is a function name, the functional definition of that -;;; name is that established by the innermost lexically enclosing flet, -;;; labels, or macrolet form, if there is one." (page for FUNCTION, sec. 5.3) -;;; ^^^^^^^^ -;;;(deftest function.14 -;;; (macrolet ((%f () nil)) (not-mv (typep #'%f 'function))) -;;; nil) - -;;; Tests of FUNCTION type specifiers - -(deftest function.14 - (flet ((%f () nil)) - (declare (optimize safety debug)) - (let ((f #'%f)) - (declare (type (function () null) f)) - (funcall f))) - nil) - -(deftest function.15 - (flet ((%f (x) (declare (ignore x)) nil)) - (declare (ftype (function (nil) nil) %f)) - :good) - :good) - -(deftest function.16 - (flet ((%f (x) (declare (ignore x)) nil)) - (declare (ftype (function (t) null) %f)) - (values - (%f 'a) - (locally (declare (ftype (function (integer) t) %f)) - (%f 10)) - (%f 'b))) - nil nil nil) - -(deftest function.17 - (flet ((%f (&optional x) x)) - (declare (ftype (function (&optional integer) t) %f)) - (values (%f) (%f 10) (%f) (%f (1+ most-positive-fixnum)))) - nil 10 nil #.(1+ most-positive-fixnum)) - -(deftest function.18 - (flet ((%f (&rest x) x)) - (declare (ftype (function (&rest symbol) t) %f)) - (values (%f) (%f 'a) (%f 'a 'b 'c))) - () (a) (a b c)) - -(deftest function.19 - (flet ((%f (&key foo bar) (list foo bar))) - (declare (ftype (function (&key (:foo t) (:bar t)) list) %f)) - (values - (%f) (%f :foo 1) - (%f :foo 1 :foo 2) - (%f :bar 'a) - (%f :bar 'a :bar 'b) - (%f :foo 'x :bar 'y) - (%f :bar 'x :foo 'y) - (%f :bar 'x :foo 'y :bar 'z :foo 'w) - )) - (nil nil) - (1 nil) - (1 nil) - (nil a) - (nil a) - (x y) - (y x) - (y x)) - -(deftest function.20 - (flet ((%f (&key foo) foo)) - (declare (ftype (function (&key (:foo t) (:allow-other-keys t)) t) %f)) - (values (%f) (%f :foo 'a) (%f :allow-other-keys nil) - (%f :allow-other-keys t :foo 'z))) - nil a nil z) - -(deftest function.21 - (flet ((%f (&key foo &allow-other-keys) foo)) - (declare (ftype (function (&key (:foo integer)) t) %f)) - (values (%f) (%f :foo 123))) - nil 123) - -(deftest function.22 - (flet ((%f (&key foo &allow-other-keys) foo)) - (declare (ftype (function (&key (:foo integer) (:bar t)) t) %f)) - (values (%f) (%f :foo 123) (%f :bar 'x) (%f :foo 12 :bar 'y))) - nil 123 nil 12) - -(deftest function.23 - (flet ((%f (&key foo &allow-other-keys) foo)) - (declare (ftype (function (&key (:foo integer) &allow-other-keys) t) %f)) - (values (%f) (%f :foo 123) (%f :bar 'x) (%f :foo 12 :bar 'y))) - nil 123 nil 12) - -(deftest function.24 - (flet ((%f (&rest r &key foo bar) (list r foo bar))) - (declare (ftype (function (&rest symbol &key (:foo t) (:bar t)) list) %f)) - (values (%f) (%f :foo 'a) (%f :bar 'b) (%f :bar 'd :foo 'c))) - (nil nil nil) - ((:foo a) a nil) - ((:bar b) nil b) - ((:bar d :foo c) c d)) diff --git a/t/ansi-test/data-and-control-flow/functionp.lsp b/t/ansi-test/data-and-control-flow/functionp.lsp deleted file mode 100644 index dac5679..0000000 --- a/t/ansi-test/data-and-control-flow/functionp.lsp +++ /dev/null @@ -1,96 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Oct 7 06:39:21 2002 -;;;; Contains: Tests for FUNCTIONP - - - -;;; -;;; Note! FUNCTIONP and FUNCTION behave differently in ANSI CL than -;;; in CLTL1. In particular, symbols and various lists are no longer -;;; in the class FUNCTION in ANSI CL. -;;; - -(deftest functionp.1 - (functionp nil) - nil) - -;;; In ANSI CL, symbols can no longer be functions -(deftest functionp.2 - (functionp 'identity) - nil) - -(deftest functionp.3 - (not (functionp #'identity)) - nil) - -(deftest functionp.4 - (loop for x in *cl-symbol-names* - for s = (find-symbol x "CL") - for f = (and (fboundp s) - (symbol-function s) - (not (special-operator-p s)) - (not (macro-function s)) - (symbol-function s)) - unless (or (null f) - (functionp f)) - collect x) - nil) - -(deftest functionp.5 - (functionp '(setf car)) - nil) - -;;; In ANSI CL, lambda forms are no longer functions -(deftest functionp.6 - (functionp '(lambda (x) x)) - nil) - -(report-and-ignore-errors - (defun (setf functionp-7-accessor) (y x) (setf (car x) y) y)) - -(deftest functionp.7 - (not-mv (functionp #'(setf functionp-7-accessor))) - nil) - -(deftest functionp.8 - (not-mv (functionp #'(lambda (x) x))) - nil) - -(deftest functionp.9 - (not-mv (functionp (compile nil '(lambda (x) x)))) - nil) - -;;; In ANSI CL, symbols and cons can no longer be functions -(deftest functionp.10 - (check-predicate #'(lambda (x) - (not (and (or (numberp x) (characterp x) - (symbolp x) (consp x) - (typep x 'array)) - (functionp x))))) - nil) - -(deftest functionp.11 - (flet ((%f () nil)) (functionp '%f)) - nil) - -(deftest functionp.12 - (flet ((%f () nil)) (not-mv (functionp #'%f))) - nil) - -;;; TODO: Add check-type-predicate test? - -(deftest functionp.order.1 - (let ((i 0)) - (values - (notnot (functionp (progn (incf i) #'cons))) - i)) - t 1) - -(deftest functionp.error.1 - (signals-error (functionp) program-error) - t) - -(deftest functionp.error.2 - (signals-error (functionp #'cons nil) program-error) - t) diff --git a/t/ansi-test/data-and-control-flow/get-setf-expansion.lsp b/t/ansi-test/data-and-control-flow/get-setf-expansion.lsp deleted file mode 100644 index 36d0c89..0000000 --- a/t/ansi-test/data-and-control-flow/get-setf-expansion.lsp +++ /dev/null @@ -1,54 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Jan 13 17:05:17 2003 -;;;; Contains: Tests for GET-SETF-EXPANSION - - - -(deftest get-setf-expansion.error.1 - (signals-error (get-setf-expansion) program-error) - t) - -(deftest get-setf-expansion.error.2 - (signals-error (get-setf-expansion 'x nil nil) program-error) - t) - -;;; FIXME -;;; Tests for proper behavior will go here -;;; There are tests in DEFINE-SETF-EXPANDER too - -;;; For a function on which the setf expansion is otherwise -;;; undefined, produce a call to #'(setf ). 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)) - (vals (multiple-value-list (get-setf-expansion (list fn))))) - (values - (length vals) - (first vals) - (second vals) - (length (third vals)) - (block done - (subst-if nil - #'(lambda (term) - (when (equal term `(function (setf ,fn))) - (return-from done :good))) - (fourth vals))) - (if (equal (fifth vals) (list fn)) - :good - (fifth vals)))) - 5 nil nil 1 :good :good) - -(deftest get-setf-expansion.2 - (let* ((fn (gensym)) - (vals (multiple-value-list (get-setf-expansion (list fn) nil)))) - (length vals)) - 5) - -(deftest get-setf-expansion.3 - (let* ((var (gensym)) - (vals (multiple-value-list (get-setf-expansion var)))) - (length vals)) - 5) diff --git a/t/ansi-test/data-and-control-flow/identity.lsp b/t/ansi-test/data-and-control-flow/identity.lsp deleted file mode 100644 index 81a4816..0000000 --- a/t/ansi-test/data-and-control-flow/identity.lsp +++ /dev/null @@ -1,34 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Oct 17 23:21:11 2002 -;;;; Contains: Tests for IDENTITY - - - -(deftest identity.1 - (check-predicate #'(lambda (x) (eqlt x (check-values (identity x))))) - nil) - -(deftest identity.2 - (let ((x (ash 1 100))) - (eqlt x (check-values (identity x)))) - t) - -(deftest identity.3 - (let ((x 1.00000001)) - (eqlt x (check-values (identity x)))) - t) - -(deftest identity.order.1 - (let ((i 0)) - (values (identity (incf i)) i)) - 1 1) - -(deftest identity.error.1 - (signals-error (identity) program-error) - t) - -(deftest identity.error.2 - (signals-error (identity 'a 'a) program-error) - t) - diff --git a/t/ansi-test/data-and-control-flow/if.lsp b/t/ansi-test/data-and-control-flow/if.lsp deleted file mode 100644 index 5120a6a..0000000 --- a/t/ansi-test/data-and-control-flow/if.lsp +++ /dev/null @@ -1,73 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Oct 18 08:21:29 2002 -;;;; Contains: Tests for IF - - - -(deftest if.1 - (if t 1 2) - 1) - -(deftest if.2 - (if nil 1 2) - 2) - -(deftest if.3 (if t (values) 'a)) - -(deftest if.4 - (if nil 'a) - nil) - -(deftest if.5 - (if t (values 'a 'b 'c) 'd) - a b c) - -(deftest if.6 - (if nil 'a (values 'b 'c 'd)) - b c d) - -(deftest if.7 (if nil 'a (values))) - -;;; Macros are expanded in the appropriate environment - -(deftest if.8 - (macrolet ((%m (z) z)) - (if (expand-in-current-env (%m t)) :good :bad)) - :good) - -(deftest if.9 - (macrolet ((%m (z) z)) - (if (expand-in-current-env (%m nil)) :bad)) - nil) - -(deftest if.10 - (macrolet ((%m (z) z)) - (if (expand-in-current-env (%m t)) :good)) - :good) - -(deftest if.11 - (macrolet ((%m (z) z)) - (if (expand-in-current-env (%m nil)) :bad :good)) - :good) - -(deftest if.12 - (macrolet - ((%m (z) z)) - (flet ((%f (x y) (if x (expand-in-current-env (%m y))))) - (declare (notinline %f)) - (values (%f t :good) (%f nil :bad)))) - :good nil) - -(deftest if.13 - (macrolet - ((%m (z) z)) - (flet ((%f (x y z) (if x y (expand-in-current-env (%m z))))) - (declare (notinline %f)) - (values (%f t :good :bad) (%f nil :bad :good)))) - :good :good) - -(deftest if.order.1 - (let ((i 0)) - (values (if (= (incf i) 1) 't nil) i)) - t 1) diff --git a/t/ansi-test/data-and-control-flow/labels.lsp b/t/ansi-test/data-and-control-flow/labels.lsp deleted file mode 100644 index 47ee6c9..0000000 --- a/t/ansi-test/data-and-control-flow/labels.lsp +++ /dev/null @@ -1,437 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Oct 9 19:06:33 2002 -;;;; Contains: Tests of LABELS - - - -(deftest labels.1 - (labels ((%f () 1)) - (%f)) - 1) - -(deftest labels.2 - (labels ((%f (x) x)) - (%f 2)) - 2) - -(deftest labels.3 - (labels ((%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 labels.4 - (block %f - (labels ((%f (&optional (x (return-from %f :good))) - nil)) - (%f) - :bad)) - :good) - -;;; Keyword parameter initializers are not in the blocked defined -;;; by the local function declaration - -(deftest labels.4a - (block %f - (labels ((%f (&key (x (return-from %f :good))) - nil)) - (%f) - :bad)) - :good) - -(deftest labels.5 - (labels ((%f () (return-from %f 15) 35)) - (%f)) - 15) - -;;; The aux parameters are not in the block defined by -;;; the local function declaration -(deftest labels.6 - (block %f - (labels ((%f (&aux (x (return-from %f 10))) - 20)) - (%f) - :bad)) - 10) - -;;; The function is visible inside itself -(deftest labels.7 - (labels ((%f (x n) (cond ((eql n 0) x) - (t (%f (+ x n) (1- n)))))) - (%f 0 10)) - 55) - -;;; Scope of defined function names includes &AUX parameters - -(deftest labels.7b - (labels ((%f (x &aux (b (%g x))) b) - (%g (y) (+ y y))) - (%f 10)) - 20) - -;;; Scope of defined function names includes &OPTIONAL parameters - -(deftest labels.7c - (labels ((%f (x &optional (b (%g x))) b) - (%g (y) (+ y y))) - (%f 10)) - 20) - -;;; Scope of defined function names includes &KEY parameters - -(deftest labels.7d - (labels ((%f (x &key (b (%g x))) b) - (%g (y) (+ y y))) - (%f 10)) - 20) - -;;; Keyword arguments -(deftest labels.8 - (labels ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) - (%f)) - nil 0 nil) - -(deftest labels.9 - (labels ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) - (%f :a 1)) - 1 0 nil) - -(deftest labels.10 - (labels ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) - (%f :b 2)) - nil 2 t) - -(deftest labels.11 - (labels ((%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 labels.12 - (signals-error - (labels ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) (%f :c 4)) - program-error) - t) - -;;; Odd # of keyword args should throw a program-error in safe code -;;; (section 3.5.1.6) -(deftest labels.13 - (signals-error - (labels ((%f (&key a (b 0 b-p)) (values a b (not (not b-p))))) (%f :a)) - program-error) - t) - -;;; Too few arguments (section 3.5.1.2) -(deftest labels.14 - (signals-error (labels ((%f (a) a)) (%f)) - program-error) - t) - -;;; Too many arguments (section 3.5.1.3) -(deftest labels.15 - (signals-error (labels ((%f (a) a)) (%f 1 2)) - program-error) - t) - -;;; Invalid keyword argument (section 3.5.1.5) -(deftest labels.16 - (signals-error (labels ((%f (&key a) a)) (%f '(foo))) - program-error) - t) - -;;; Definition of a (setf ...) function - -(deftest labels.17 - (labels (((setf %f) (x y) (setf (car y) x))) - (let ((z (list 1 2))) - (setf (%f z) 'a) - z)) - (a 2)) - -;;; Body is an implicit progn -(deftest labels.18 - (labels ((%f (x) (incf x) (+ x x))) - (%f 10)) - 22) - -;;; Can handle at least 50 lambda parameters -(deftest labels.19 - (labels ((%f (a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 - b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 - c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 - d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 - e1 e2 e3 e4 e5 e6 e7 e8 e9 e10) - (+ a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 - b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 - c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 - d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 - e1 e2 e3 e4 e5 e6 e7 e8 e9 e10))) - (%f 1 2 3 4 5 6 7 8 9 10 - 11 12 13 14 15 16 17 18 19 20 - 21 22 23 24 25 26 27 28 29 30 - 31 32 33 34 35 36 37 38 39 40 - 41 42 43 44 45 46 47 48 49 50)) - 1275) - -;;; labels works with the maximum number of arguments (if -;;; not too many.) -(deftest labels.20 - (let* ((n (min (1- lambda-parameters-limit) 1024)) - (vars (loop repeat n collect (gensym)))) - (eval - `(eqlt ,n - (labels ((%f ,vars (+ ,@ vars))) - (%f ,@(loop for e in vars collect 1)))))) - t) - -;;; Declarations and documentation strings are ok -(deftest labels.21 - (labels ((%f (x) - (declare (type fixnum x)) - "Add one to the fixnum x." - (1+ x))) - (declare (ftype (function (fixnum) integer) %f)) - (%f 10)) - 11) - -;;; Keywords can be function names -(deftest labels.22 - (labels ((:foo () 10) - (:bar () (1+ (:foo)))) - (:bar)) - 11) - -(deftest labels.23 - (labels ((:foo () 10) - (:bar () (1+ (funcall #':foo)))) - (funcall #':bar)) - 11) - -(deftest labels.24 - (loop for s in *cl-non-function-macro-special-operator-symbols* - for form = `(ignore-errors (labels ((,s (x) (foo (1- x))) - (foo (y) - (if (<= y 0) 'a - (,s (1- y))))) - (,s 10))) - unless (eq (eval form) 'a) - collect s) - nil) - -(deftest labels.25 - (loop for s in *cl-non-function-macro-special-operator-symbols* - for form = `(ignore-errors - (labels ((,s (x) (foo (1- x))) - (foo (y) - (if (<= y 0) 'a - (,s (1- y))))) - (declare (ftype (function (integer) symbol) - foo ,s)) - (,s 10))) - unless (eq (eval form) 'a) - collect s) - nil) - -(deftest labels.26 - (loop for s in *cl-non-function-macro-special-operator-symbols* - for form = `(ignore-errors - (labels (((setf ,s) (&rest args) - (declare (ignore args)) - 'a)) - (setf (,s) 10))) - unless (eq (eval form) 'a) - collect s) - nil) - -;;; Check that LABELS does not have a tagbody -(deftest labels.27 - (block done - (tagbody - (labels ((%f () (go 10) 10 (return-from done 'bad))) - (%f)) - 10 - (return-from done 'good))) - good) - -;;; Check that nil keyword arguments do not enable the default values - -(deftest labels.28 - (labels ((%f (&key (a 'wrong)) a)) (%f :a nil)) - nil) - -(deftest labels.29 - (labels ((%f (&key (a 'wrong a-p)) (list a (not a-p)))) (%f :a nil)) - (nil nil)) - -(deftest labels.30 - (labels ((%f (&key ((:a b) 'wrong)) b)) (%f :a nil)) - nil) - -(deftest labels.31 - (labels ((%f (&key ((:a b) 'wrong present?)) (list b (not present?)))) - (%f :a nil)) - (nil nil)) - -(deftest labels.32 - (labels ((%f (&key) 'good)) - (%f :allow-other-keys nil)) - good) - -(deftest labels.33 - (labels ((%f (&key) 'good)) - (%f :allow-other-keys t)) - good) - -(deftest labels.34 - (labels ((%f (&key) 'good)) - (%f :allow-other-keys t :a 1 :b 2)) - good) - -(deftest labels.35 - (labels ((%f (&key &allow-other-keys) 'good)) - (%f :a 1 :b 2)) - good) - -;;; NIL as a disallowed keyword argument -(deftest labels.36 - (signals-error - (labels ((%f (&key) :bad)) (%f nil nil)) - program-error) - t) - -;;; Identity of function objects -;;; Since (FUNCTION ) returns *the* functional value, it -;;; should be the case that different invocations of this form -;;; in the same lexical environment return the same value. - -(deftest labels.37 - (labels ((f () 'foo)) - (eqt #'f #'f)) - t) - -(deftest labels.38 - (labels ((f () 'foo)) - (destructuring-bind (x y) (loop repeat 2 collect #'f) (eqlt x y))) - t) - -(deftest labels.39 - (labels ((f () #'f)) - (eqlt (f) #'f)) - t) - -(deftest labels.40 - (let ((x (labels ((f () #'f)) #'f))) - (eqlt x (funcall x))) - t) - -;;; Test that free declarations do not affect argument forms - -(deftest labels.41 - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) - (labels ((%f (&optional (y x)) - (declare (special x)) - y)) - (%f)))) - :good) - -(deftest labels.42 - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) - (labels ((%f (&key (y x)) - (declare (special x)) - y)) - (%f)))) - :good) - -(deftest labels.43 - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) - (labels () (declare (special x))) - x)) - :good) - -(deftest labels.44 - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) - (labels ((%f () (declare (special x))))) - x)) - :good) - -(deftest labels.45 - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) - (labels ((%f () (declare (special x)))) - x))) - :good) - -(deftest labels.46 - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) - (labels ((%f (&aux (y x)) - (declare (special x)) - y)) - (%f)))) - :good) - -(deftest labels.47 - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) - (labels ((%f () x)) - (declare (special x)) - (%f)))) - :good) - -;;; Macros are expanded in the appropriate environment - -(deftest labels.48 - (macrolet ((%m (z) z)) - (labels () (expand-in-current-env (%m :good)))) - :good) - -(deftest labels.49 - (macrolet ((%m (z) z)) - (labels ((%f () (expand-in-current-env (%m :good)))) - (%f))) - :good) - - -;;; local function bindings shadow global functions, macros -;;; and compiler-macros - - - -(defun labels.50 () :bad) - - -(deftest labels.50 - (labels ((labels.50 () :good)) - (labels.50)) - :good) - -(defmacro labels.51 () :bad) - -(deftest labels.51 - (labels ((labels.51 () :good)) - (labels.51)) - :good) - -(define-compiler-macro labels.52 (&whole form) - :bad) - -(deftest labels.52 - (labels ((labels.52 () :good)) - (labels.52)) - :good) - - \ No newline at end of file diff --git a/t/ansi-test/data-and-control-flow/lambda-list-keywords.lsp b/t/ansi-test/data-and-control-flow/lambda-list-keywords.lsp deleted file mode 100644 index 1bd6daf..0000000 --- a/t/ansi-test/data-and-control-flow/lambda-list-keywords.lsp +++ /dev/null @@ -1,40 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Oct 7 22:11:31 2002 -;;;; Contains: Tests for LAMBDA-LIST-KEYWORDS - - - -;;; The variable is bound -(deftest lambda-list-keywords.1 - (not-mv (boundp 'lambda-list-keywords)) - nil) - -;;; The variable is a constant -(deftest lambda-list-keywords.2 - (not-mv (constantp 'lambda-list-keywords)) - nil) - -;;; The standard keywords are present in the list -(deftest lambda-list-keywords.3 - (and (consp lambda-list-keywords) - (not-mv (set-difference '(&allow-other-keys - &aux &body &environment - &key &optional &rest &whole) - lambda-list-keywords))) - t) - -;;; No lambda list keywords are in the keyword package -;;; (deftest lambda-list-keywords.4 -;;; (some #'keywordp lambda-list-keywords) -;;; nil) - -;;; Every keyword starts with an ampersand -(deftest lambda-list-keywords.5 - (notevery #'(lambda (sym) - (and (symbolp sym) - (let ((name (symbol-name sym))) - (and (> (length name) 0) - (eql (aref name 0) #\&))))) - lambda-list-keywords) - nil) diff --git a/t/ansi-test/data-and-control-flow/lambda-parameters-limit.lsp b/t/ansi-test/data-and-control-flow/lambda-parameters-limit.lsp deleted file mode 100644 index d7397ff..0000000 --- a/t/ansi-test/data-and-control-flow/lambda-parameters-limit.lsp +++ /dev/null @@ -1,17 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Oct 10 22:45:44 2002 -;;;; Contains: Tests for LAMBDA-PARAMETERS-LIMIT - - - -(deftest lambda-parameters-limit.1 - (not (typep lambda-parameters-limit 'integer)) - nil) - -(deftest lambda-parameters-limit.2 - (< lambda-parameters-limit 50) - nil) - -;;; See also tests is flet.lsp, labels.lsp - diff --git a/t/ansi-test/data-and-control-flow/let.lsp b/t/ansi-test/data-and-control-flow/let.lsp deleted file mode 100644 index a540136..0000000 --- a/t/ansi-test/data-and-control-flow/let.lsp +++ /dev/null @@ -1,170 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Oct 12 09:24:36 2002 -;;;; Contains: Tests for LET, LET* - - - -;;; LET and LET* are also heavily exercised in the many other tests. - -;;; NOTE! Some of these tests bind a variable with the same name -;;; more than once. This apparently has underdetermined semantics that -;;; varies in different Lisps. - -(deftest let.1 - (let ((x 0)) x) - 0) - -(deftest let.2 - (let ((x 0) (y 1)) (values x y)) - 0 1) - -(deftest let.3 - (let ((x 0) (y 1)) (declare (special x y)) (values x y)) - 0 1) - -(deftest let.4 - (let ((x 0)) - (let ((x 1)) - x)) - 1) - -(deftest let.5 - (let ((x 0)) - (let ((#:x 1)) - x)) - 0) - -(deftest let.6 - (let ((x 0)) - (declare (special x)) - (let ((x 1)) - (values x (locally (declare (special x)) x)))) - 1 0) - -(deftest let.7 - (let ((x '(a b c))) - (declare (dynamic-extent x)) - x) - (a b c)) - -;;;(deftest let.8 -;;; (let ((x 0) (x 1)) x) -;;; 1) - -(deftest let.9 - (let (x y z) (values x y z)) - nil nil nil) - -;;; (deftest let.10 -;;; (let ((x 1) x) x) -;;; nil) - -(deftest let.11 - (let ((x 1)) - (list x - (let (x) - (declare (special x)) - x) - x)) - (1 nil 1)) - -;;; (deftest let.12 -;;; (let ((x 0)) -;;; (values -;;; (let ((x 20) -;;; (x (1+ x))) -;;; x) -;;; x)) -;;; 1 0) - -;;; (deftest let.13 -;;; (flet ((%f () (declare (special x)) -;;; (if (boundp 'x) x 10))) -;;; (let ((x 1) -;;; (x (1+ (%f)))) -;;; (declare (special x)) -;;; x)) -;;; 11) - -;;; Tests of large number of LET variables -(deftest let.14 - (let* ((n 100) - (vars (mapcar #'gensym (make-list n :initial-element "G"))) - (expr `(let ,(let ((i 0)) - (mapcar #'(lambda (v) (list v (incf i))) vars)) - ,(let ((sumexpr 0)) - (dolist (v vars) - (setq sumexpr `(+ ,v ,sumexpr))) - sumexpr))) - (val (eval expr))) - (or (eqlt val (/ (* n (1+ n)) 2)) (list val))) - t) - -;;; Test that all non-variables exported from COMMON-LISP can be bound -;;; in LET forms. -(deftest let.15 - (loop for s in *cl-non-variable-constant-symbols* - for form = `(ignore-errors (let ((,s 17)) ,s)) - unless (eql (eval form) 17) - collect s) - nil) - -;;; Check that LET does not have a tagbody -(deftest let.16 - (block done - (tagbody - (let () (go 10) 10 (return-from done 'bad)) - 10 - (return-from done 'good))) - good) - -;;; Check that free declarations do not apply to the init forms - -(deftest let.17 - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) ;; lexical binding - (let ((y x)) - (declare (special x)) ;; free declaration - y))) - :good) - -(deftest let.17a - (funcall - (compile - nil - '(lambda () - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) ;; lexical binding - (let ((y x)) - (declare (special x)) ;; free declaration - y)))))) - :good) - -(deftest let.18 - (let ((foo 'special)) - (declare (special foo)) - (let ((foo 'lexical)) - (locally (declare (special foo))) - foo)) - lexical) - -(deftest let.19 - (loop for k in lambda-list-keywords - unless (eql (eval `(let ((,k :foo)) ,k)) :foo) - collect k) - nil) - -;;; Macros are expanded in the appropriate environment - -(deftest let.20 - (macrolet ((%m (z) z)) - (let () (expand-in-current-env (%m :good)))) - :good) - -(deftest let.21 - (macrolet ((%m (z) z)) - (let ((x (expand-in-current-env (%m 1)))) (+ x x x))) - 3) diff --git a/t/ansi-test/data-and-control-flow/letstar.lsp b/t/ansi-test/data-and-control-flow/letstar.lsp deleted file mode 100644 index 9902095..0000000 --- a/t/ansi-test/data-and-control-flow/letstar.lsp +++ /dev/null @@ -1,185 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Jun 24 20:53:36 2005 -;;;; Contains: Tests for LET* - - - -(deftest let*.1 - (let* ((x 0)) x) - 0) - -(deftest let*.2 - (let* ((x 0) (y 1)) (values x y)) - 0 1) - -(deftest let*.3 - (let* ((x 0) (y 1)) (declare (special x y)) (values x y)) - 0 1) - -(deftest let*.4 - (let* ((x 0)) - (let* ((x 1)) - x)) - 1) - -(deftest let*.5 - (let* ((x 0)) - (let* ((#:x 1)) - x)) - 0) - -(deftest let*.6 - (let* ((x 0)) - (declare (special x)) - (let* ((x 1)) - (values x (locally (declare (special x)) x)))) - 1 0) - -(deftest let*.7 - (let* ((x '(a b c))) - (declare (dynamic-extent x)) - x) - (a b c)) - -(deftest let*.8 - (let* ((x 0) (x 1)) x) - 1) - -(deftest let*.9 - (let* (x y z) (values x y z)) - nil nil nil) - -(deftest let*.10 - (let* ((x 1) x) x) - nil) - -(deftest let*.11 - (let* ((x 1)) - (list x - (let* (x x x) - (declare (special x)) - x) - x)) - (1 nil 1)) - -(deftest let*.12 - (let* ((x 1) - (y (1+ x)) - (x (1+ y)) - (z (+ x y))) - (values x y z)) - 3 2 5) - -;;; (deftest let*.13 -;;; (flet ((%f () (declare (special x)) x)) -;;; (let* ((x 1) -;;; (x (1+ (%f)))) -;;; (declare (special x)) -;;; x)) -;;; 2) - -;;; Tests of large number of LET* variables -(deftest let*.14 - (let* ((n 100) - (vars (mapcar #'gensym (make-list n :initial-element "G"))) - (expr `(let* ,(let ((i 0)) - (mapcar #'(lambda (v) (list v (incf i))) vars)) - ,(let ((sumexpr 0)) - (dolist (v vars) - (setq sumexpr `(+ ,v ,sumexpr))) - sumexpr))) - (val (eval expr))) - (or (eqlt val (/ (* n (1+ n)) 2)) (list val))) - t) - -;;; Test that all non-variables exported from COMMON-LISP can be bound -;;; in LET* forms. -(deftest let*.15 - (loop for s in *cl-non-variable-constant-symbols* - for form = `(ignore-errors (let* ((,s 17)) ,s)) - unless (eql (eval form) 17) - collect s) - nil) - -;;; Check that LET* does not have a tagbody -(deftest let*.16 - (block done - (tagbody - (let () (go 10) 10 (return-from done 'bad)) - 10 - (return-from done 'good))) - good) - -;;; Check that free declarations do not apply to the init forms - -(deftest let*.17 - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) ;; lexical binding - (let* ((y x)) - (declare (special x)) ;; free declaration - y))) - :good) - -(deftest let*.17a - (funcall - (compile - nil - '(lambda () - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) ;; lexical binding - (let* ((y x)) - (declare (special x)) ;; free declaration - y)))))) - :good) - -(deftest let*.18 - (let ((x :bad1) - (z :bad2)) - (declare (special x z)) - (let ((x :good) - (z :good)) ;; lexical bindings - (let* ((y x) - (w z)) - (declare (special x)) ;; free declaration - (values y w)))) - :good - :good) - -(deftest let*.19 - (let ((foo 'special)) - (declare (special foo)) - (let* ((foo 'lexical)) - (locally (declare (special foo))) - foo)) - lexical) - -(deftest let*.20 - (loop for k in lambda-list-keywords - unless (eql (eval `(let* ((,k :foo)) ,k)) :foo) - collect k) - nil) - -;;; Macros are expanded in the appropriate environment - -(deftest let*.21 - (macrolet ((%m (z) z)) - (let* () (expand-in-current-env (%m :good)))) - :good) - -(deftest let*.22 - (macrolet ((%m (z) z)) - (let* ((x (expand-in-current-env (%m 1)))) (+ x x x))) - 3) - -(deftest let*.23 - (macrolet ((%m (z) z)) - (let* ((x (expand-in-current-env (%m 1))) - (y (expand-in-current-env (%m 2)))) - (+ x y))) - 3) - - - diff --git a/t/ansi-test/data-and-control-flow/load.lsp b/t/ansi-test/data-and-control-flow/load.lsp deleted file mode 100644 index 7e95673..0000000 --- a/t/ansi-test/data-and-control-flow/load.lsp +++ /dev/null @@ -1,88 +0,0 @@ -;;; Tests of data and control flow -(compile-and-load "ANSI-TESTS:AUX;cons-aux.lsp") -(compile-and-load "ANSI-TESTS:AUX;random-aux.lsp") -(compile-and-load "ANSI-TESTS:AUX;types-aux.lsp") - -(in-package #:cl-test) - -(let ((*default-pathname-defaults* - (make-pathname - :directory (pathname-directory *load-pathname*)))) - (load "data-and-control-flow.lsp") - (load "places.lsp") - (load "psetq.lsp") - (load "psetf.lsp") - (load "shiftf.lsp") - (load "rotatef.lsp") - (load "return.lsp") - (load "return-from.lsp") - (load "defsetf.lsp") - (load "define-setf-expander.lsp") - - (load "and.lsp") - (load "apply.lsp") - (load "block.lsp") - (load "call-arguments-limit.lsp") - (load "case.lsp") - (load "catch.lsp") - (load "ccase.lsp") - (load "compiled-function-p.lsp") - (load "complement.lsp") - (load "cond.lsp") - (load "constantly.lsp") - (load "ctypecase.lsp") - (load "defconstant.lsp") - (load "define-modify-macro.lsp") - (load "defparameter.lsp") - (load "defun.lsp") - (load "defvar.lsp") - (load "destructuring-bind.lsp") - (load "ecase.lsp") - (load "eql.lsp") - (load "equal.lsp") - (load "equalp.lsp") - (load "etypecase.lsp") - (load "every.lsp") - (load "fboundp.lsp") - (load "fdefinition.lsp") - (load "flet.lsp") - (load "fmakunbound.lsp") - (load "funcall.lsp") - (load "function-lambda-expression.lsp") - (load "function.lsp") - (load "functionp.lsp") - (load "get-setf-expansion.lsp") - (load "identity.lsp") - (load "if.lsp") - (load "labels.lsp") - (load "lambda-list-keywords.lsp") - (load "lambda-parameters-limit.lsp") - (load "let.lsp") - (load "letstar.lsp") - (load "macrolet.lsp") - (load "multiple-value-bind.lsp") - (load "multiple-value-call.lsp") ;; include multiple-value-list - (load "multiple-value-prog1.lsp") - (load "multiple-value-setq.lsp") - (load "multiple-value-list.lsp") - (load "nil.lsp") - (load "not-and-null.lsp") - (load "notany.lsp") - (load "notevery.lsp") - (load "nth-value.lsp") - (load "or.lsp") - (load "prog.lsp") - (load "prog1.lsp") - (load "prog2.lsp") - (load "progn.lsp") - (load "progv.lsp") - (load "some.lsp") - (load "t.lsp") - (load "tagbody.lsp") - (load "typecase.lsp") - (load "unless.lsp") - (load "unwind-protect.lsp") - (load "values-list.lsp") - (load "values.lsp") - (load "when.lsp") -) diff --git a/t/ansi-test/data-and-control-flow/macrolet.lsp b/t/ansi-test/data-and-control-flow/macrolet.lsp deleted file mode 100644 index 3cb5d19..0000000 --- a/t/ansi-test/data-and-control-flow/macrolet.lsp +++ /dev/null @@ -1,472 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Oct 9 19:41:24 2002 -;;;; Contains: Tests of MACROLET - - - -(deftest macrolet.1 - (let ((z (list 3 4))) - (macrolet ((%m (x) `(car ,x))) - (let ((y (list 1 2))) - (values (%m y) (%m z))))) - 1 3) - -(deftest macrolet.2 - (let ((z (list 3 4))) - (macrolet ((%m (x) `(car ,x))) - (let ((y (list 1 2))) - (values - (setf (%m y) 6) - (setf (%m z) 'a) - y z)))) - 6 a (6 2) (a 4)) - -;;; Inner definitions shadow outer ones -(deftest macrolet.3 - (macrolet ((%m (w) `(cadr ,w))) - (let ((z (list 3 4))) - (macrolet ((%m (x) `(car ,x))) - (let ((y (list 1 2))) - (values - (%m y) (%m z) - (setf (%m y) 6) - (setf (%m z) 'a) - y z))))) - 1 3 6 a (6 2) (a 4)) - -;;; &whole parameter -(deftest macrolet.4 - (let ((x nil)) - (macrolet ((%m (&whole w arg) - `(progn (setq x (quote ,w)) - ,arg))) - (values (%m 1) x))) - 1 (%m 1)) - -;;; &whole parameter (nested, destructuring; see section 3.4.4) -(deftest macrolet.5 - (let ((x nil)) - (macrolet ((%m ((&whole w arg)) - `(progn (setq x (quote ,w)) - ,arg))) - (values (%m (1)) x))) - 1 (1)) - -;;; key parameter -(deftest macrolet.6 - (let ((x nil)) - (macrolet ((%m (&key (a 'xxx) b) - `(setq x (quote ,a)))) - - (values (%m :a foo) x - (%m :b bar) x))) - foo foo xxx xxx) - -;;; nested key parameters -(deftest macrolet.7 - (let ((x nil)) - (macrolet ((%m ((&key a b)) - `(setq x (quote ,a)))) - - (values (%m (:a foo)) x - (%m (:b bar)) x))) - foo foo nil nil) - -;;; nested key parameters -(deftest macrolet.8 - (let ((x nil)) - (macrolet ((%m ((&key (a 10) b)) - `(setq x (quote ,a)))) - - (values (%m (:a foo)) x - (%m (:b bar)) x))) - foo foo 10 10) - -;;; keyword parameter with supplied-p parameter -(deftest macrolet.9 - (let ((x nil)) - (macrolet ((%m (&key (a 'xxx a-p) b) - `(setq x (quote ,(list a (not (not a-p))))))) - - (values (%m :a foo) x - (%m :b bar) x))) - (foo t) (foo t) (xxx nil) (xxx nil)) - - -;;; rest parameter -(deftest macrolet.10 - (let ((x nil)) - (macrolet ((%m (b &rest a) - `(setq x (quote ,a)))) - (values (%m a1 a2) x))) - (a2) (a2)) - -;;; rest parameter w. destructuring -(deftest macrolet.11 - (let ((x nil)) - (macrolet ((%m ((b &rest a)) - `(setq x (quote ,a)))) - (values (%m (a1 a2)) x))) - (a2) (a2)) - -;;; rest parameter w. whole -(deftest macrolet.12 - (let ((x nil)) - (macrolet ((%m (&whole w b &rest a) - `(setq x (quote ,(list a w))))) - (values (%m a1 a2) x))) - ((a2) (%m a1 a2)) - ((a2) (%m a1 a2))) - -;;; Interaction with symbol-macrolet - -(deftest macrolet.13 - (symbol-macrolet ((a b)) - (macrolet ((foo (x &environment env) - (let ((y (macroexpand x env))) - (if (eq y 'a) 1 2)))) - (foo a))) - 2) - -(deftest macrolet.14 - (symbol-macrolet ((a b)) - (macrolet ((foo (x &environment env) - (let ((y (macroexpand-1 x env))) - (if (eq y 'a) 1 2)))) - (foo a))) - 2) - -(deftest macrolet.15 - (macrolet ((nil () ''a)) - (nil)) - a) - -(deftest macrolet.16 - (loop for s in *cl-non-function-macro-special-operator-symbols* - for form = `(ignore-errors (macrolet ((,s () ''a)) (,s))) - unless (eq (eval form) 'a) - collect s) - nil) - -(deftest macrolet.17 - (macrolet ((%m (&key (a t)) `(quote ,a))) - (%m :a nil)) - nil) - -(deftest macrolet.18 - (macrolet ((%m (&key (a t a-p)) `(quote (,a ,(notnot a-p))))) - (%m :a nil)) - (nil t)) - -(deftest macrolet.19 - (macrolet ((%m (x &optional y) `(quote (,x ,y)))) - (values (%m 1) (%m 2 3))) - (1 nil) - (2 3)) - -(deftest macrolet.20 - (macrolet ((%m (x &optional (y 'a)) `(quote (,x ,y)))) - (values (%m 1) (%m 2 3))) - (1 a) - (2 3)) - -;;; Note -- the supplied-p parameter in a macrolet &optional -;;; is required to be T (not just true) if the parameter is present. -;;; See section 3.4.4.1.2 -(deftest macrolet.21 - (macrolet ((%m (x &optional (y 'a y-p)) `(quote (,x ,y ,y-p)))) - (values (%m 1) (%m 2 3))) - (1 a nil) - (2 3 t)) - -(deftest macrolet.22 - (macrolet ((%m (x &optional ((y z) '(2 3))) `(quote (,x ,y ,z)))) - (values - (%m a) - (%m a (b c)))) - (a 2 3) - (a b c)) - -(deftest macrolet.22a - (macrolet ((%m (x &optional ((y z) '(2 3) y-z-p)) - `(quote (,x ,y ,z ,y-z-p)))) - (values - (%m a) - (%m a (b c)))) - (a 2 3 nil) - (a b c t)) - -(deftest macrolet.23 - (macrolet ((%m (&rest y) `(quote ,y))) - (%m 1 2 3)) - (1 2 3)) - -;;; According to 3.4.4.1.2, the entity following &rest is -;;; 'a destructuring pattern that matches the rest of the list.' - -(deftest macrolet.24 - (macrolet ((%m (&rest (x y z)) `(quote (,x ,y ,z)))) - (%m 1 2 3)) - (1 2 3)) - -(deftest macrolet.25 - (macrolet ((%m (&body (x y z)) `(quote (,x ,y ,z)))) - (%m 1 2 3)) - (1 2 3)) - -;;; More key parameters - -(deftest macrolet.26 - (macrolet ((%m (&key ((:a b))) `(quote ,b))) - (values (%m) - (%m :a x))) - nil - x) - -(deftest macrolet.27 - (macrolet ((%m (&key ((:a (b c)))) `(quote (,c ,b)))) - (%m :a (1 2))) - (2 1)) - -(deftest macrolet.28 - (macrolet ((%m (&key ((:a (b c)) '(3 4))) `(quote (,c ,b)))) - (values (%m :a (1 2)) - (%m :a (1 2) :a (10 11)) - (%m))) - (2 1) - (2 1) - (4 3)) - -(deftest macrolet.29 - (macrolet ((%m (&key a (b a)) `(quote (,a ,b)))) - (values (%m) - (%m :a 1) - (%m :b 2) - (%m :a 3 :b 4) - (%m :b 5 :a 6) - (%m :a 7 :a 8) - (%m :a 9 :b nil) - (%m :a 10 :b nil :b 11))) - (nil nil) - (1 1) - (nil 2) - (3 4) - (6 5) - (7 7) - (9 nil) - (10 nil)) - -(deftest macrolet.30 - (macrolet ((%m ((&key a) &key (b a)) `(quote (,a ,b)))) - (values (%m ()) - (%m (:a 1)) - (%m () :b 2) - (%m (:a 3) :b 4) - (%m (:a 7 :a 8)) - (%m (:a 9) :b nil) - (%m (:a 10) :b nil :b 11))) - (nil nil) - (1 1) - (nil 2) - (3 4) - (7 7) - (9 nil) - (10 nil)) - -(deftest macrolet.31 - (macrolet ((%m (&key ((:a (b c)) '(3 4) a-p)) - `(quote (,(notnot a-p) ,c ,b)))) - (values (%m :a (1 2)) - (%m :a (1 2) :a (10 11)) - (%m))) - (t 2 1) - (t 2 1) - (nil 4 3)) - -;;; Allow-other-keys tests - -(deftest macrolet.32 - (macrolet ((%m (&key a b c) `(quote (,a ,b ,c)))) - (values - (%m :allow-other-keys nil) - (%m :a 1 :allow-other-keys nil) - (%m :allow-other-keys t) - (%m :allow-other-keys t :allow-other-keys nil :foo t) - (%m :allow-other-keys t :c 1 :b 2 :a 3) - (%m :allow-other-keys nil :c 1 :b 2 :a 3))) - (nil nil nil) - (1 nil nil) - (nil nil nil) - (nil nil nil) - (3 2 1) - (3 2 1)) - -(deftest macrolet.33 - (macrolet ((%m (&key allow-other-keys) `(quote ,allow-other-keys))) - (values - (%m) - (%m :allow-other-keys nil) - (%m :allow-other-keys t :foo t))) - nil - nil - t) - -(deftest macrolet.34 - (macrolet ((%m (&key &allow-other-keys) :good)) - (values - (%m) - (%m :foo t) - (%m :allow-other-keys nil :foo t))) - :good - :good - :good) - -(deftest macrolet.35 - (macrolet ((%m (&key a b &allow-other-keys) `(quote (,a ,b)))) - (values - (%m :a 1) - (%m :foo t :b 2) - (%m :allow-other-keys nil :a 1 :foo t :b 2))) - (1 nil) - (nil 2) - (1 2)) - -;;; &whole is followed by a destructuring pattern (see 3.4.4.1.2) -(deftest macrolet.36 - (macrolet ((%m (&whole (m a b) c d) `(quote (,m ,a ,b ,c ,d)))) - (%m 1 2)) - (%m 1 2 1 2)) - -;;; Macro names are shadowed by local functions - -(deftest macrolet.37 - (macrolet ((%f () :bad)) - (flet ((%f () :good)) - (%f))) - :good) - - -;;; The &environment parameter is bound first - -(deftest macrolet.38 - (macrolet ((foo () 1)) - (macrolet ((%f (&optional (x (macroexpand '(foo) env)) &environment env) - x)) - (%f))) - 1) - -;;; Test for bug that showed up in sbcl - -(deftest macrolet.39 - (macrolet ((%m (()) :good)) (%m ())) - :good) - -;;; Test that macrolets accept declarations - -(deftest macrolet.40 - (macrolet ((%x () t)) - (declare (optimize))) - nil) - -(deftest macrolet.41 - (macrolet ((%x () t)) - (declare (optimize)) - (declare (notinline identity))) - nil) - -(deftest macrolet.42 - (macrolet ((%x () t)) - (declare (optimize)) - (%x)) - t) - -(deftest macrolet.43 - (let ((*x-in-macrolet.43* nil)) - (declare (special *x-in-macrolet.43*)) - (let ((*f* #'(lambda () *x-in-macrolet.43*))) - (declare (special *f*)) - (eval `(macrolet ((%m (*x-in-macrolet.43*) - (declare (special *f*)) - (funcall *f*))) - (%m t))))) - nil) - -(deftest macrolet.44 - (let ((*x-in-macrolet.44* nil)) - (declare (special *x-in-macrolet.44*)) - (let ((*f* #'(lambda () *x-in-macrolet.44*))) - (declare (special *f*)) - (eval `(macrolet ((%m (*x-in-macrolet.44*) - (declare (special *f* *x-in-macrolet.44*)) - (funcall *f*))) - (%m t))))) - t) - -(deftest macrolet.45 - (let ((*x-in-macrolet.45* nil)) - (declare (special *x-in-macrolet.45*)) - (let ((*f* #'(lambda () *x-in-macrolet.45*))) - (declare (special *f*)) - (eval `(macrolet ((%m ((*x-in-macrolet.45*)) - (declare (special *f* *x-in-macrolet.45*)) - (funcall *f*))) - (%m (t)))))) - t) - -;;; Macros are expanded in the appropriate environment - -(deftest macrolet.46 - (macrolet ((%m (z) z)) - (macrolet () (expand-in-current-env (%m :good)))) - :good) - -;;; Free declarations in macrolet - -(deftest macrolet.47 - (let ((x :good)) - (declare (special x)) - (let ((x :bad)) - (macrolet () (declare (special x)) x))) - :good) - -(deftest macrolet.48 - (let ((x :good)) - (let ((y :bad)) - (macrolet () (declare (ignore y)) x))) - :good) - -(deftest macrolet.49 - (let ((x :good)) - (let ((y :bad)) - (macrolet () (declare (ignorable y)) x))) - :good) - - -;;; TODO: more special declarations for other macrolet arguments - - -;;; macrolet shadows global macro, function and compiler-macro -;;; definitions - -(defmacro macrolet.50 () :bad) - -(deftest macrolet.50 - (macrolet ((macrolet.50 () :good)) - (macrolet.50)) - :good) - -(defun macrolet.51 () :bad) - -(deftest macrolet.51 - (macrolet ((macrolet.51 () :good)) - (macrolet.51)) - :good) - -(define-compiler-macro macrolet.52 (&whole form) - :bad) - -(deftest macrolet.52 - (macrolet ((macrolet.52 () :good)) - (macrolet.52)) - :good) diff --git a/t/ansi-test/data-and-control-flow/multiple-value-bind.lsp b/t/ansi-test/data-and-control-flow/multiple-value-bind.lsp deleted file mode 100644 index 421a76f..0000000 --- a/t/ansi-test/data-and-control-flow/multiple-value-bind.lsp +++ /dev/null @@ -1,116 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Oct 18 23:16:23 2002 -;;;; Contains: Tests for MULTIPLE-VALUE-BIND - - - -(deftest multiple-value-bind.1 - (multiple-value-bind (x y z) (values 1 2 3) - (declare (type integer x)) - (declare (type integer y)) - (declare (type integer z)) - (list z y x)) - (3 2 1)) - -(deftest multiple-value-bind.2 - (multiple-value-bind (x y z) (values 1 2 3) - (let ((x 4)) - (list x y z))) - (4 2 3)) - -(deftest multiple-value-bind.3 - (multiple-value-bind (x y z) (values 1 2 3 4 5 6) - (list x y z)) - (1 2 3)) - -(deftest multiple-value-bind.4 - (multiple-value-bind (x y z) (values 1 2) - (list x y z)) - (1 2 nil)) - -(deftest multiple-value-bind.5 - (multiple-value-bind () (values 1 2) (values 'a 'b 'c)) - a b c) - -(deftest multiple-value-bind.6 - (multiple-value-bind (x y z) (values) - (list x y z)) - (nil nil nil)) - -(deftest multiple-value-bind.7 - (let ((z 0) x y) - (declare (special z)) - (values - (flet ((%x () (symbol-value 'x)) - (%y () (symbol-value 'y)) - (%z () (symbol-value 'z))) - (multiple-value-bind (x y z) (values 1 2 3) - (declare (special x y)) - (list (%x) (%y) (%z)))) - x y z)) - (1 2 0) nil nil 0) - -;;; No implicit tagbody -(deftest multiple-value-bind.8 - (block nil - (tagbody - (multiple-value-bind (x) nil - (go 10) - 10 - (return 'bad)) - 10 - (return 'good))) - good) - -;;; Works with single values -(deftest multiple-value-bind.9 - (multiple-value-bind (x y z) :foo (list x y z)) - (:foo nil nil)) - -(deftest multiple-value-bind.10 - (multiple-value-bind (x) :foo x) - :foo) - -(deftest multiple-value-bind.11 - (multiple-value-bind () :foo) - nil) - -(deftest multiple-value-bind.12 - (multiple-value-bind () (values)) - nil) - -(deftest multiple-value-bind.13 - (multiple-value-bind () (values 1 2 3 4 5)) - nil) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest multiple-value-bind.14 - (macrolet - ((%m (z) z)) - (multiple-value-bind (x y z) - (expand-in-current-env (%m (values 1 2 3))) - (list x y z))) - (1 2 3)) - -;;; Error cases - -(deftest multiple-value-bind.error.1 - (signals-error (funcall (macro-function 'multiple-value-bind)) - program-error) - t) - -(deftest multiple-value-bind.error.2 - (signals-error (funcall (macro-function 'multiple-value-bind) - '(multiple-value-bind nil nil)) - program-error) - t) - -(deftest multiple-value-bind.error.3 - (signals-error (funcall (macro-function 'multiple-value-bind) - '(multiple-value-bind nil nil) - nil nil) - program-error) - t) diff --git a/t/ansi-test/data-and-control-flow/multiple-value-call.lsp b/t/ansi-test/data-and-control-flow/multiple-value-call.lsp deleted file mode 100644 index 22887d9..0000000 --- a/t/ansi-test/data-and-control-flow/multiple-value-call.lsp +++ /dev/null @@ -1,34 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Oct 18 23:35:07 2002 -;;;; Contains: Tests of MULTIPLE-VALUE-CALL, MULTIPLE-VALUE-LIST - - - -(deftest multiple-value-call.1 - (multiple-value-call #'+ (values 1 2) (values) 3 (values 4 5 6)) - 21) - -(deftest multiple-value-call.2 - (multiple-value-call 'list) - nil) - -(deftest multiple-value-call.3 - (multiple-value-call 'list (floor 13 4)) - (3 1)) - -;;; Macros are expanded in the appropriate environment - -(deftest multiple-value-call.4 - (macrolet - ((%m (z) z)) - (multiple-value-call (expand-in-current-env (%m #'list)) (values 1 2))) - (1 2)) - -(deftest multiple-value-call.5 - (macrolet - ((%m (z) z)) - (multiple-value-call 'list (expand-in-current-env (%m (values 1 2))))) - (1 2)) - - diff --git a/t/ansi-test/data-and-control-flow/multiple-value-list.lsp b/t/ansi-test/data-and-control-flow/multiple-value-list.lsp deleted file mode 100644 index 20a6f3a..0000000 --- a/t/ansi-test/data-and-control-flow/multiple-value-list.lsp +++ /dev/null @@ -1,80 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Feb 17 06:38:07 2003 -;;;; Contains: Tests of MULTIPLE-VALUE-LIST - - - -(deftest multiple-value-list.1 - (multiple-value-list 'a) - (a)) - -(deftest multiple-value-list.2 - (multiple-value-list (values)) - nil) - -(deftest multiple-value-list.3 - (multiple-value-list (values 'a 'b 'c 'd 'e)) - (a b c d e)) - -(deftest multiple-value-list.4 - (multiple-value-list (values (values 'a 'b 'c 'd 'e))) - (a)) - -(deftest multiple-value-list.5 - (multiple-value-list (values 'a)) - (a)) - -(deftest multiple-value-list.6 - (multiple-value-list (values 'a 'b)) - (a b)) - -(deftest multiple-value-list.7 - (not - (loop - for i from 0 below (min multiple-values-limit 100) - for x = (make-list i :initial-element 'a) - always (equal x (multiple-value-list (values-list x))))) - nil) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest multiple-value-list.8 - (macrolet - ((%m (z) z)) - (multiple-value-list (expand-in-current-env (%m 1)))) - (1)) - -(deftest multiple-value-list.9 - (macrolet - ((%m (z) z)) - (multiple-value-list (expand-in-current-env (%m (values 1 2 3))))) - (1 2 3)) - -;;; Test that the argument is evaluated just once - -(deftest multiple-value-list.order.1 - (let ((i 0)) - (values (multiple-value-list (incf i)) i)) - (1) 1) - -;;; Error tests - -(deftest multiple-value-list.error.1 - (signals-error (funcall (macro-function 'multiple-value-list)) - program-error) - t) - -(deftest multiple-value-list.error.2 - (signals-error (funcall (macro-function 'multiple-value-list) - '(multiple-value-list nil)) - program-error) - t) - -(deftest multiple-value-list.error.3 - (signals-error (funcall (macro-function 'multiple-value-list) - '(multiple-value-list nil) - nil nil) - program-error) - t) diff --git a/t/ansi-test/data-and-control-flow/multiple-value-prog1.lsp b/t/ansi-test/data-and-control-flow/multiple-value-prog1.lsp deleted file mode 100644 index 716f757..0000000 --- a/t/ansi-test/data-and-control-flow/multiple-value-prog1.lsp +++ /dev/null @@ -1,98 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Oct 19 06:48:02 2002 -;;;; Contains: Tests for MULTIPLE-VALUE-PROG1 - - - -(deftest multiple-value-prog1.1 - (multiple-value-prog1 nil) - nil) - -(deftest multiple-value-prog1.2 - (multiple-value-prog1 '(a b c)) - (a b c)) - -(deftest multiple-value-prog1.3 - (multiple-value-prog1 (values-list '(a b c))) - a b c) - -(deftest multiple-value-prog1.4 - (multiple-value-prog1 (values))) - -(deftest multiple-value-prog1.5 - (let ((x 0) (y 0)) - (multiple-value-prog1 (values x y) - (incf x) (incf y 2))) - 0 0) - -(deftest multiple-value-prog1.6 - (let ((x 0) (y 0)) - (multiple-value-call - #'list - (multiple-value-prog1 (values x y) - (incf x) (incf y 2)) - x y)) - (0 0 1 2)) - -(deftest multiple-value-prog1.7 - (let ((x 0) (y 0)) - (multiple-value-call - #'list - (multiple-value-prog1 (values (incf x) y) - (incf x x) - (incf y 10)) - x y)) - (1 0 2 10)) - - -(deftest multiple-value-prog1.8 - (let* ((n (min 100 multiple-values-limit))) - (not-mv - (loop for i from 0 below n - for x = (make-int-list i) - always - (equalt - (multiple-value-list - (eval `(multiple-value-prog1 (values-list (quote ,(copy-seq x))) - nil))) - x)))) - nil) - - -(deftest multiple-value-prog1.9 - (let ((x 0) (y 0)) - (values - (block foo - (multiple-value-prog1 - (values (incf x) (incf y 2)) - (return-from foo 'a))) - x y)) - a 1 2) - -;;; No implicit tagbody -(deftest multiple-value-prog1.10 - (block nil - (tagbody - (multiple-value-prog1 - (values) - (go 10) - 10 - (return 'bad)) - 10 - (return 'good))) - good) - -;;; Macros are expanded in the appropriate environment - -(deftest multiple-value-prog1.11 - (macrolet - ((%m (z) z)) - (multiple-value-prog1 (expand-in-current-env (%m :good)))) - :good) - -(deftest multiple-value-prog1.12 - (macrolet - ((%m (z) z)) - (multiple-value-prog1 :good (expand-in-current-env (%m :foo)))) - :good) diff --git a/t/ansi-test/data-and-control-flow/multiple-value-setq.lsp b/t/ansi-test/data-and-control-flow/multiple-value-setq.lsp deleted file mode 100644 index 809a1b7..0000000 --- a/t/ansi-test/data-and-control-flow/multiple-value-setq.lsp +++ /dev/null @@ -1,163 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Oct 19 07:00:57 2002 -;;;; Contains: Tests of MULTIPLE-VALUE-SETQ - - - -(deftest multiple-value-setq.1 - (let ((x 1) (y 2)) - (values - (multiple-value-list - (multiple-value-setq (x y) (values 3 4))) - x y)) - (3) 3 4) - -(deftest multiple-value-setq.2 - (let (x) - (multiple-value-setq (x) (values 1 2)) - x) - 1) - -(deftest multiple-value-setq.3 - (let (x) - (symbol-macrolet ((y x)) - (multiple-value-setq (y) (values 1 2)) - x)) - 1) - -(deftest multiple-value-setq.4 - (let ((x (list nil))) - (symbol-macrolet ((y (car x))) - (multiple-value-setq (y) (values 1 2)) - x)) - (1)) - -;;; test of order of evaluation -;;; The (INCF I) should be evaluated before the assigned form I. -(deftest multiple-value-setq.5 - (let ((i 0) (x (list nil))) - (symbol-macrolet ((y (car (progn (incf i) x)))) - (multiple-value-setq (y) i)) - x) - (1)) - -(deftest multiple-value-setq.6 - (let ((x (list nil)) z) - (symbol-macrolet ((y (car x))) - (multiple-value-setq (y z) (values 1 2))) - (values x z)) - (1) 2) - -(deftest multiple-value-setq.7 - (let ((x (list nil)) (z (list nil))) - (symbol-macrolet ((y (car x)) - (w (car z))) - (multiple-value-setq (y w) (values 1 2))) - (values x z)) - (1) (2)) - -;;; Another order of evaluation tests, this time with two -;;; symbol macro arguments -(deftest multiple-value-setq.8 - (let ((x (list nil)) (z (list nil)) (i 0)) - (symbol-macrolet ((y (car (progn (incf i 3) x))) - (w (car (progn (incf i i) z)))) - (multiple-value-setq (y w) (values i 10))) - (values x z)) - (6) (10)) - -(deftest multiple-value-setq.9 - (let (x) - (values - (multiple-value-setq (x x) (values 1 2)) - x)) - 1 2) - -(deftest multiple-value-setq.10 - (let (x) - (values - (multiple-value-setq (x x) (values 1)) - x)) - 1 nil) - -(deftest multiple-value-setq.11 - (let ((x 1) (y 2) (z 3)) - (multiple-value-setq (x y z) (values)) - (values x y z)) - nil nil nil) - - -(deftest multiple-value-setq.12 - (let ((n (min 100 multiple-values-limit)) - (vars nil) - (result nil)) - (loop - for i from 1 below n - for form = - (progn - (push (gensym) vars) - (push i result) - `(let ,vars - (and (eql (multiple-value-setq ,vars (values-list (quote ,result))) - ,(car result)) - (equal ,(make-list-expr vars) - (quote ,result))))) - unless (eval form) - collect (list i form))) - nil) - -(deftest multiple-value-setq.13 - (multiple-value-setq nil :good) - :good) - -(deftest multiple-value-setq.14 - (multiple-value-setq nil (values)) - nil) - -(deftest multiple-value-setq.15 - (multiple-value-setq nil (values 'a 'b)) - a) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest multiple-value-setq.16 - (macrolet - ((%m (z) z)) - (let ((x :bad)) - (symbol-macrolet ((z (expand-in-current-env (%m x)))) - (multiple-value-setq (z) :good)) - x)) - :good) - -(deftest multiple-value-setq.17 - (macrolet - ((%m (z) z)) - (let ((x :bad)) - (values - (multiple-value-setq (x) (expand-in-current-env (%m :good))) - x))) - :good :good) - -;;; Error tests - -(deftest multiple-value-setq.error.1 - (signals-error (funcall (macro-function 'multiple-value-setq)) - program-error) - t) - -(deftest multiple-value-setq.error.2 - (signals-error (funcall (macro-function 'multiple-value-setq) - '(multiple-value-setq nil nil)) - program-error) - t) - -(deftest multiple-value-setq.error.3 - (signals-error (funcall (macro-function 'multiple-value-setq) - '(multiple-value-setq nil nil) - nil nil) - program-error) - t) - - diff --git a/t/ansi-test/data-and-control-flow/nil.lsp b/t/ansi-test/data-and-control-flow/nil.lsp deleted file mode 100644 index 3930295..0000000 --- a/t/ansi-test/data-and-control-flow/nil.lsp +++ /dev/null @@ -1,41 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Oct 17 06:32:46 2002 -;;;; Contains: Tests for NIL - - - -(deftest nil.1 - (check-predicate #'(lambda (x) (not (subtypep (type-of x) nil)))) - nil) - - -(deftest nil.2 - (check-predicate #'(lambda (x) (subtypep nil (type-of x)))) - nil) - -(deftest nil.3 - (not-mv (constantp nil)) - nil) - -(deftest nil.4 - (car nil) - nil) - -(deftest nil.5 - (cdr nil) - nil) - -(deftest nil.6 - (eval nil) - nil) - -(deftest nil.7 - (symbol-value nil) - nil) - -(deftest nil.8 - (eqt nil 'nil) - t) - -;;; NIL is, of course, present in many other files diff --git a/t/ansi-test/data-and-control-flow/not-and-null.lsp b/t/ansi-test/data-and-control-flow/not-and-null.lsp deleted file mode 100644 index b3bbaf7..0000000 --- a/t/ansi-test/data-and-control-flow/not-and-null.lsp +++ /dev/null @@ -1,59 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Oct 17 06:38:33 2002 -;;;; Contains: Tests of NOT and NULL - - - -(deftest null.1 - (null nil) - t) - -(deftest null.2 - (null t) - nil) - -(deftest null.3 - (some #'(lambda (x) (and x (null x))) *universe*) - nil) - -(deftest null.4 - (not (some #'null - `(1 a 1.2 "a" #\w (a) ,*terminal-io* - #'car (make-array '(10))))) - t) - -(deftest null.error.1 - (signals-error (null) program-error) - t) - -(deftest null.error.2 - (signals-error (null nil nil) program-error) - t) - -(deftest not.1 - (not nil) - t) - -(deftest not.2 - (not t) - nil) - -(deftest not.3 - (some #'(lambda (x) (and x (not x))) *universe*) - nil) - -(deftest not.4 - (not (some #'not - `(1 a 1.2 "a" #\w (a) ,*terminal-io* - #'car (make-array '(10))))) - t) - - -(deftest not.error.1 - (signals-error (not) program-error) - t) - -(deftest not.error.2 - (signals-error (not nil nil) program-error) - t) diff --git a/t/ansi-test/data-and-control-flow/notany.lsp b/t/ansi-test/data-and-control-flow/notany.lsp deleted file mode 100644 index d650d97..0000000 --- a/t/ansi-test/data-and-control-flow/notany.lsp +++ /dev/null @@ -1,304 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Oct 18 07:14:14 2002 -;;;; Contains: Tests for NOTANY - - - -(deftest notany.1 - (not-mv (notany #'identity nil)) - nil) - -(deftest notany.2 - (not-mv (notany #'identity #())) - nil) - -(deftest notany.3 - (let ((count 0)) - (values - (notany #'(lambda (x) (incf count) (if (>= x 10) x nil)) - '(1 2 4 13 5 1)) - count)) - nil 4) - -(deftest notany.4 - (not-mv (notany #'/= '(1 2 3 4) '(1 2 3 4 5))) - nil) - -(deftest notany.5 - (not-mv (notany #'/= '(1 2 3 4 5) '(1 2 3 4))) - nil) - -(deftest notany.6 - (notany #'/= '(1 2 3 4 5) '(1 2 3 4 6)) - nil) - -(deftest notany.7 - (not-mv (notany #'(lambda (x y) (and x y)) - '(nil t t nil t) #(t nil nil t nil nil))) - nil) - -(deftest notany.8 - (let* ((x '(1)) - (args (list x))) - (not - (loop for i from 2 below (1- (min 100 call-arguments-limit)) - do (push x args) - always (apply #'notany #'/= args)))) - nil) - -(deftest notany.9 - (not-mv (notany #'zerop #*11111111111111)) - nil) - -(deftest notany.10 - (not-mv (notany #'zerop #*)) - nil) - -(deftest notany.11 - (notany #'zerop #*1111111011111) - nil) - -(deftest notany.12 - (not-mv (notany #'(lambda (x) (not (eql x #\a))) "aaaaaaaa")) - nil) - -(deftest notany.13 - (not-mv (notany #'(lambda (x) (eql x #\a)) "")) - nil) - -(deftest notany.14 - (notany #'(lambda (x) (not (eql x #\a))) "aaaaaabaaaa") - nil) - -(deftest notany.15 - (not-mv (notany 'null '(1 2 3 4))) - nil) - -(deftest notany.16 - (notany 'null '(1 2 3 nil 5)) - nil) - -;;; Other specialized sequences - -(deftest notany.17 - (let ((v (make-array '(10) :initial-contents '(0 0 0 0 1 2 3 4 5 6) - :fill-pointer 4))) - (loop for j from 0 to 9 - do (setf (fill-pointer v) j) - collect (not (notany #'plusp v)))) - (nil nil nil nil nil t t t t t)) - -(deftest notany.18 - (loop for i from 1 to 40 - for type = `(unsigned-byte ,i) - unless - (let ((v (make-array '(10) :initial-contents (loop for j in '(0 0 0 0 1 2 3 4 5 6) - collect (mod j (ash 1 i))) - :element-type type - :fill-pointer 4))) - (equal (loop for j from 0 to 9 - do (setf (fill-pointer v) j) - collect (not (notany #'plusp v))) - '(nil nil nil nil nil t t t t t))) - collect i) - nil) - -(deftest notany.19 - (loop for i from 1 to 40 - for type = `(signed-byte ,i) - unless - (let ((v (make-array '(10) :initial-contents '(0 0 0 0 -1 -1 -1 -1 -1 -1) - :element-type type - :fill-pointer 4))) - (equal (loop for j from 0 to 9 - do (setf (fill-pointer v) j) - collect (not (notany #'minusp v))) - '(nil nil nil nil nil t t t t t))) - collect i) - nil) - -(deftest notany.20 - (let ((v (make-array '(10) :initial-contents "abcd012345" - :element-type 'character - :fill-pointer 4))) - (loop for j from 0 to 9 - do (setf (fill-pointer v) j) - collect (not (notany #'digit-char-p v)))) - (nil nil nil nil nil t t t t t)) - -(deftest notany.21 - (let ((v (make-array '(10) :initial-contents "abcd012345" - :element-type 'base-char - :fill-pointer 4))) - (loop for j from 0 to 9 - do (setf (fill-pointer v) j) - collect (not (notany #'digit-char-p v)))) - (nil nil nil nil nil t t t t t)) - -(deftest notany.22 - (let ((v (make-array '(5) :initial-contents "abcde" - :element-type 'base-char))) - (values - (notnot (notany #'digit-char-p v)) - (setf (aref v 2) #\0) - (notany #'digit-char-p v))) - t #\0 nil) - -(deftest notany.23 - (loop for type in '(short-float single-float double-float long-float) - for v = (make-array '(9) - :element-type type - :initial-contents - (mapcar #'(lambda (x) (coerce x type)) '(1 2 3 4 5 6 0 8 3))) - when (notany #'zerop v) - collect (list type v)) - nil) - -(deftest notany.24 - (loop for type in '(short-float single-float double-float long-float) - for v = (make-array '(9) - :element-type type - :fill-pointer 6 - :initial-contents - (mapcar #'(lambda (x) (coerce x type)) '(1 2 3 4 5 6 0 8 3))) - unless (notany #'zerop v) - collect (list type v)) - nil) - -(deftest notany.25 - (loop for type in '(short-float single-float double-float long-float) - for ctype = `(complex ,type) - for v = (make-array '(6) - :element-type ctype - :initial-contents - (mapcar #'(lambda (x) (complex x (coerce x type))) '(1 2 3 4 5 6))) - unless (notany (complement #'complexp) v) - collect (list type v)) - nil) - -;;; Displaced vectors - -(deftest notany.26 - (let* ((v1 (make-array '(10) :initial-contents '(1 3 2 4 6 8 5 7 9 1))) - (v2 (make-array '(4) :displaced-to v1 - :displaced-index-offset 2))) - (values - (notany #'oddp v1) - (notnot (notany #'oddp v2)))) - nil t) - -(deftest notany.27 - (loop for i from 1 to 40 - for type = `(unsigned-byte ,i) - unless - (let* ((v1 (make-array '(10) :initial-contents '(1 1 0 0 0 0 1 1 1 1) - :element-type type)) - (v2 (make-array '(4) :displaced-to v1 - :displaced-index-offset 2 - :element-type type))) - (and (not (notany 'oddp v1)) - (notany #'oddp v2))) - collect i) - nil) - -(deftest notany.28 - (loop for i from 1 to 40 - for type = `(signed-byte ,i) - unless - (let* ((v1 (make-array '(10) :initial-contents '(-1 -1 0 0 0 0 -1 -1 -1 -1) - :element-type type)) - (v2 (make-array '(4) :displaced-to v1 - :displaced-index-offset 2 - :element-type type))) - (and (not (notany 'oddp v1)) - (notany #'oddp v2))) - collect i) - nil) - -(deftest notany.29 - (let* ((s1 (make-array '(8) :initial-contents "12abc345" :element-type 'character))) - (loop for i from 0 to 6 - for s2 = (make-array '(2) :element-type 'character - :displaced-to s1 - :displaced-index-offset i) - collect (not (notany 'digit-char-p s2)))) - (t t nil nil t t t)) - -(deftest notany.30 - (let* ((s1 (make-array '(8) :initial-contents "12abc345" :element-type 'base-char))) - (loop for i from 0 to 6 - for s2 = (make-array '(2) :element-type 'base-char - :displaced-to s1 - :displaced-index-offset i) - collect (not (notany 'digit-char-p s2)))) - (t t nil nil t t t)) - -(deftest notany.31 - (let ((v (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) - :adjustable t))) - (values - (notnot (notany #'minusp v)) - (progn - (adjust-array v '(11) :initial-element -1) - (notany #'minusp v)))) - t nil) - -(deftest notany.32 - (let ((v (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) - :fill-pointer 10 - :adjustable t))) - (values - (notnot (notany #'minusp v)) - (progn - (adjust-array v '(11) :initial-element -1) - (notnot (notany #'minusp v))))) - t t) - - -(deftest notany.order.1 - (let ((i 0) a b) - (values - (not (notany (progn (setf a (incf i)) 'null) - (progn (setf b (incf i)) '(a b c)))) - i a b)) - nil 2 1 2) - -;;; Error cases - -(deftest notany.error.1 - (check-type-error #'(lambda (x) (notany x '(a b c))) - (typef '(or symbol function))) - nil) - -(deftest notany.error.4 - (check-type-error #'(lambda (x) (notany #'null x)) #'sequencep) - nil) - -(deftest notany.error.7 - (check-type-error #'(lambda (x) (notany #'eql () x)) #'sequencep) - nil) - -(deftest notany.error.8 - (signals-error (notany) program-error) - t) - -(deftest notany.error.9 - (signals-error (notany #'null) program-error) - t) - -(deftest notany.error.10 - (signals-error (locally (notany 1 '(a b c)) t) type-error) - t) - -(deftest notany.error.11 - (signals-error (notany #'cons '(a b c)) program-error) - t) - -(deftest notany.error.12 - (signals-error (notany #'cons '(a b c) '(1 2 4) '(g h j)) program-error) - t) - -(deftest notany.error.13 - (signals-error (notany #'car '(a b c)) type-error) - t) diff --git a/t/ansi-test/data-and-control-flow/notevery.lsp b/t/ansi-test/data-and-control-flow/notevery.lsp deleted file mode 100644 index 50e9192..0000000 --- a/t/ansi-test/data-and-control-flow/notevery.lsp +++ /dev/null @@ -1,307 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Oct 18 07:20:12 2002 -;;;; Contains: Tests for NOTEVERY - - - -(deftest notevery.1 - (notevery #'identity nil) - nil) - -(deftest notevery.2 - (notevery #'identity #()) - nil) - -(deftest notevery.3 - (let ((count 0)) - (values - (not (notevery #'(lambda (x) (incf count) (< x 10)) - '(1 2 4 13 5 1))) - count)) - nil 4) - -(deftest notevery.4 - (notevery #'= '(1 2 3 4) '(1 2 3 4 5)) - nil) - -(deftest notevery.5 - (notevery #'= '(1 2 3 4 5) '(1 2 3 4)) - nil) - -(deftest notevery.6 - (not-mv (notevery #'= '(1 2 3 4 5) '(1 2 3 4 6))) - nil) - -(deftest notevery.7 - (notevery #'(lambda (x y) (or x y)) - '(nil t t nil t) #(t nil t t nil nil)) - nil) - -(deftest notevery.8 - (let ((x '(1)) - (args nil)) - (not - (loop for i from 1 below (1- (min 100 call-arguments-limit)) - do (push x args) - always (not (apply #'notevery #'= args))))) - nil) - -(deftest notevery.9 - (notevery #'zerop #*000000000000) - nil) - -(deftest notevery.10 - (notevery #'zerop #*) - nil) - -(deftest notevery.11 - (not-mv (notevery #'zerop #*0000010000)) - nil) - -(deftest notevery.12 - (notevery #'(lambda (x) (eql x #\a)) "aaaaaaaa") - nil) - -(deftest notevery.13 - (notevery #'(lambda (x) (eql x #\a)) "") - nil) - -(deftest notevery.14 - (not-mv (notevery #'(lambda (x) (eql x #\a)) "aaaaaabaaaa")) - nil) - -(deftest notevery.15 - (not-mv (notevery 'null '(nil nil t nil))) - nil) - -(deftest notevery.16 - (notevery 'null '(nil nil nil nil)) - nil) - -;;; Other specialized sequences - -(deftest notevery.17 - (let ((v (make-array '(10) :initial-contents '(0 0 0 0 1 2 3 4 5 6) - :fill-pointer 4))) - (loop for j from 0 to 9 - do (setf (fill-pointer v) j) - collect (not (notevery #'zerop v)))) - (t t t t t nil nil nil nil nil)) - -(deftest notevery.18 - (loop for i from 1 to 40 - for type = `(unsigned-byte ,i) - unless - (let ((v (make-array '(10) :initial-contents '(0 0 0 0 1 1 1 1 1 1) - :element-type type - :fill-pointer 4))) - (equal (loop for j from 0 to 9 - do (setf (fill-pointer v) j) - collect (not (notevery #'zerop v))) - '(t t t t t nil nil nil nil nil))) - collect i) - nil) - -(deftest notevery.19 - (loop for i from 1 to 40 - for type = `(signed-byte ,i) - unless - (let ((v (make-array '(10) :initial-contents '(0 0 0 0 -1 -1 -1 -1 -1 -1) - :element-type type - :fill-pointer 4))) - (equal (loop for j from 0 to 9 - do (setf (fill-pointer v) j) - collect (not (notevery #'zerop v))) - '(t t t t t nil nil nil nil nil))) - collect i) - nil) - -(deftest notevery.20 - (let ((v (make-array '(10) :initial-contents "abcd012345" - :element-type 'character - :fill-pointer 4))) - (loop for j from 0 to 9 - do (setf (fill-pointer v) j) - collect (not (notevery #'alpha-char-p v)))) - (t t t t t nil nil nil nil nil)) - -(deftest notevery.21 - (let ((v (make-array '(10) :initial-contents "abcd012345" - :element-type 'base-char - :fill-pointer 4))) - (loop for j from 0 to 9 - do (setf (fill-pointer v) j) - collect (not (notevery #'alpha-char-p v)))) - (t t t t t nil nil nil nil nil)) - -(deftest notevery.22 - (let ((v (make-array '(5) :initial-contents "abcde" - :element-type 'base-char))) - (values - (not (notevery #'alpha-char-p v)) - (setf (aref v 2) #\0) - (not (notevery #'alpha-char-p v)))) - t #\0 nil) - -;;; Displaced vectors - -(deftest notevery.23 - (let* ((v1 (make-array '(10) :initial-contents '(1 3 2 4 6 8 5 7 9 1))) - (v2 (make-array '(4) :displaced-to v1 - :displaced-index-offset 2))) - (values - (not (notevery #'evenp v1)) - (not (notevery 'evenp v2)))) - nil t) - -(deftest notevery.24 - (loop for i from 1 to 40 - for type = `(unsigned-byte ,i) - unless - (let* ((v1 (make-array '(10) :initial-contents '(1 1 0 0 0 0 1 1 1 1) - :element-type type)) - (v2 (make-array '(4) :displaced-to v1 - :displaced-index-offset 2 - :element-type type))) - (and (notevery 'evenp v1) - (not (notevery #'evenp v2)))) - collect i) - nil) - -(deftest notevery.25 - (loop for i from 1 to 40 - for type = `(signed-byte ,i) - unless - (let* ((v1 (make-array '(10) :initial-contents '(-1 -1 0 0 0 0 -1 -1 -1 -1) - :element-type type)) - (v2 (make-array '(4) :displaced-to v1 - :displaced-index-offset 2 - :element-type type))) - (and (notevery 'evenp v1) - (not (notevery #'evenp v2)))) - collect i) - nil) - -(deftest notevery.26 - (let* ((s1 (make-array '(8) :initial-contents "12abc345" :element-type 'character))) - (loop for i from 0 to 6 - for s2 = (make-array '(2) :element-type 'character - :displaced-to s1 - :displaced-index-offset i) - collect (not (notevery 'alpha-char-p s2)))) - (nil nil t t nil nil nil)) - -(deftest notevery.27 - (let* ((s1 (make-array '(8) :initial-contents "12abc345" :element-type 'base-char))) - (loop for i from 0 to 6 - for s2 = (make-array '(2) :element-type 'base-char - :displaced-to s1 - :displaced-index-offset i) - collect (not (notevery 'alpha-char-p s2)))) - (nil nil t t nil nil nil)) - -;;; adjustable vectors - -(deftest notevery.28 - (let ((v (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) - :adjustable t))) - (values - (not (notevery #'plusp v)) - (progn - (adjust-array v '(11) :initial-element -1) - (not (notevery #'plusp v))))) - t nil) - -(deftest notevery.29 - (let ((v (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) - :fill-pointer 10 - :adjustable t))) - (values - (not (notevery #'plusp v)) - (progn - (adjust-array v '(11) :initial-element -1) - (not (notevery #'plusp v))))) - t t) - -;;; Float, complex vectors - -(deftest notevery.30 - (loop for type in '(short-float single-float double-float long-float) - for v = (make-array '(6) - :element-type type - :initial-contents - (mapcar #'(lambda (x) (coerce x type)) '(1 2 3 4 5 6))) - when (notevery #'plusp v) - collect (list type v)) - nil) - -(deftest notevery.31 - (loop for type in '(short-float single-float double-float long-float) - for v = (make-array '(6) - :element-type type - :fill-pointer 5 - :initial-contents - (mapcar #'(lambda (x) (coerce x type)) '(1 2 3 4 5 -1))) - when (notevery #'plusp v) - collect (list type v)) - nil) - -(deftest notevery.32 - (loop for type in '(short-float single-float double-float long-float) - for ctype = `(complex ,type) - for v = (make-array '(6) - :element-type ctype - :initial-contents - (mapcar #'(lambda (x) (complex x (coerce x type))) '(1 2 3 4 5 6))) - when (notevery #'complexp v) - collect (list type v)) - nil) - - -(deftest notevery.order.1 - (let ((i 0) a b) - (values - (notevery (progn (setf a (incf i)) #'identity) - (progn (setf b (incf i)) '(a b c d))) - i a b)) - nil 2 1 2) - -;;; Error cases - -(deftest notevery.error.1 - (check-type-error #'(lambda (x) (notevery x '(a b c))) - (typef '(or symbol function))) - nil) - -(deftest notevery.error.4 - (check-type-error #'(lambda (x) (notevery #'null x)) #'sequencep) - nil) - -(deftest notevery.error.7 - (check-type-error #'(lambda (x) (notevery #'eql () x)) #'sequencep) - nil) - -(deftest notevery.error.8 - (signals-error (notevery) program-error) - t) - -(deftest notevery.error.9 - (signals-error (notevery #'null) program-error) - t) - -(deftest notevery.error.10 - (signals-error (locally (notevery 1 '(a b c)) t) type-error) - t) - -(deftest notevery.error.11 - (signals-error (notevery #'cons '(a b c)) program-error) - t) - -(deftest notevery.error.12 - (signals-error (notevery #'cons '(a b c) '(1 2 4) '(g h j)) program-error) - t) - -(deftest notevery.error.13 - (signals-error (notevery #'car '(a b c)) type-error) - t) diff --git a/t/ansi-test/data-and-control-flow/nth-value.lsp b/t/ansi-test/data-and-control-flow/nth-value.lsp deleted file mode 100644 index 8c8444e..0000000 --- a/t/ansi-test/data-and-control-flow/nth-value.lsp +++ /dev/null @@ -1,73 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Oct 19 08:24:14 2002 -;;;; Contains: Tests of NTH-VALUE - - - -(deftest nth-value.1 - (nth-value 0 'a) - a) - -(deftest nth-value.2 - (nth-value 1 'a) - nil) - -(deftest nth-value.3 - (nth-value 0 (values)) - nil) - -(deftest nth-value.4 - (loop for i from 0 to 19 - collect (nth-value i (values 'a 'b 'c 'd 'e 'f 'g 'h 'i 'j 'k - 'l 'm 'n 'o 'p 'q 'r 's))) - (a b c d e f g h i j k l m n o p q r s nil)) - -(deftest nth-value.5 - (nth-value 100 'a) - nil) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest nth-value.6 - (macrolet - ((%m (z) z)) - (nth-value (expand-in-current-env (%m 1)) (values 'a 'b 'c))) - b) - -(deftest nth-value.7 - (macrolet - ((%m (z) z)) - (nth-value 1 (expand-in-current-env (%m (values 'a 'b 'c))))) - b) - -;;; Order of evaluation test - -(deftest nth-value.order.1 - (let ((i 0) x y) - (values - (nth-value (progn (setf x (incf i)) 3) - (progn (setf y (incf i)) (values 'a 'b 'c 'd 'e 'f 'g))) - i x y)) - d 2 1 2) - -;;; Error tests - -(deftest nth-value.error.1 - (signals-error (funcall (macro-function 'nth-value)) - program-error) - t) - -(deftest nth-value.error.2 - (signals-error (funcall (macro-function 'nth-value) - '(nth-value 1 '(a b c))) - program-error) - t) - -(deftest nth-value.error.3 - (signals-error (funcall (macro-function 'nth-value) - '(nth-value 1 '(a b c)) - nil nil) - program-error) - t) diff --git a/t/ansi-test/data-and-control-flow/or.lsp b/t/ansi-test/data-and-control-flow/or.lsp deleted file mode 100644 index e119564..0000000 --- a/t/ansi-test/data-and-control-flow/or.lsp +++ /dev/null @@ -1,76 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Oct 18 07:29:27 2002 -;;;; Contains: Tests of OR - - - -(deftest or.1 - (or) - nil) - -(deftest or.2 - (or nil) - nil) - -(deftest or.3 - (or 'a) - a) - -(deftest or.4 - (or (values 'a 'b 'c)) - a b c) - -(deftest or.5 (or (values))) - -(deftest or.6 - (or (values t nil) 'a) - t) - -(deftest or.7 - (or nil (values 'a 'b 'c)) - a b c) - -(deftest or.8 - (let ((x 0)) - (values (or t (incf x)) - x)) - t 0) - -(deftest or.9 - (or (values nil 1 2) (values 1 nil 2)) - 1 nil 2) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest or.10 - (macrolet - ((%m (z) z)) - (or (expand-in-current-env (%m 'x)) - (expand-in-current-env (%m nil)) - (expand-in-current-env (%m 'y)) - t)) - x) - -(deftest or.11 - (macrolet - ((%m (z) z)) - (or (expand-in-current-env (%m nil)) - (expand-in-current-env (%m 'a)) - nil)) - a) - -;;; Error tests - -(deftest or.error.1 - (signals-error (funcall (macro-function 'or)) program-error) - t) - -(deftest or.error.2 - (signals-error (funcall (macro-function 'or) '(or)) program-error) - t) - -(deftest or.error.3 - (signals-error (funcall (macro-function 'or) '(or) nil nil) program-error) - t) diff --git a/t/ansi-test/data-and-control-flow/places.lsp b/t/ansi-test/data-and-control-flow/places.lsp deleted file mode 100644 index a4101dd..0000000 --- a/t/ansi-test/data-and-control-flow/places.lsp +++ /dev/null @@ -1,300 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Oct 7 19:20:17 2002 -;;;; Contains: Tests of various kinds of places (section 5.1) - - - -;;; Section 5.1.1.1 - -(deftest setf.order.1 - (let ((x (vector nil nil nil nil)) - (i 0)) - (setf (aref x (incf i)) (incf i)) - (values x i)) - #(nil 2 nil nil) 2) - -(deftest setf.order.2 - (let ((x (vector nil nil nil nil)) - (i 0)) - (setf (aref x (incf i)) (incf i) - (aref x (incf i)) (incf i 10)) - (values x i)) - #(nil 2 nil 13) 13) - -(deftest incf.order.1 - (let ((x (copy-seq #(0 0 0 0 0))) - (i 1)) - (values - (incf (aref x (incf i)) (incf i)) - x i)) - 3 #(0 0 3 0 0) 3) - -(deftest decf.order.1 - (let ((x (copy-seq #(0 0 0 0 0))) - (i 1)) - (values - (decf (aref x (incf i)) (incf i)) - x i)) - -3 #(0 0 -3 0 0) 3) - - -;;; Section 5.1.2.1 -(deftest setf-var - (let ((x nil)) - (setf x 'a) - x) - a) - -;;; Section 5.1.2.2 -;;; See SETF forms at various accessor functions - -;;; Section 5.1.2.3 -(deftest setf-values.1 - (let ((x nil) (y nil) (z nil)) - (setf (values x y z) (values 1 2 3))) - 1 2 3) - -(deftest setf-values.2 - (let ((x nil) (y nil) (z nil)) - (setf (values x y z) (values 1 2 3)) - (values z y x)) - 3 2 1) - -(deftest setf-values.3 - (let ((x nil) (y nil) (z nil)) - (setf (values x x x) (values 1 2 3)) - x) - 3) - -;;; Test that the subplaces of a VALUES place can be -;;; complex, and that the various places' subforms are -;;; evaluated in the correct (left-to-right) order. - -(deftest setf-values.4 - (let ((x (list 'a 'b))) - (setf (values (car x) (cadr x)) (values 1 2)) - x) - (1 2)) - -(deftest setf-values.5 - (let ((a (vector nil nil)) - (i 0) - x y z) - (setf (values (aref a (progn (setf x (incf i)) 0)) - (aref a (progn (setf y (incf i)) 1))) - (progn - (setf z (incf i)) - (values 'foo 'bar))) - (values a i x y z)) - #(foo bar) 3 1 2 3) - -(deftest setf-values.6 - (setf (values) (values))) - -;;; Section 5.1.2.4 -(deftest setf-the.1 - (let ((x 1)) - (setf (the integer x) 2) - x) - 2) - -(deftest setf-the.2 - (let ((x (list 'a))) - (values - (setf (the symbol (car x)) 'b) - x)) - b (b)) - -;;; Section 5.1.2.5 -(deftest setf-apply.1 - (let ((x (vector 0 1 2 3 4 5))) - (setf (apply #'aref x '(0)) 10) - x) - #(10 1 2 3 4 5)) - -(deftest setf-apply.2 - (let ((a (make-array '(2 2) :initial-contents '((0 0)(0 0))))) - (setf (apply #'aref a 1 1 nil) 'a) - (equalp a (make-array '(2 2) :initial-contents '((0 0)(0 a))))) - t) - -(deftest setf-apply.3 - (let ((bv (copy-seq #*0000000000))) - (setf (apply #'bit bv 4 nil) 1) - bv) - #*0000100000) - -(deftest setf-apply.4 - (let ((bv (copy-seq #*0000000000))) - (setf (apply #'sbit bv 4 nil) 1) - bv) - #*0000100000) - -;;; Section 5.1.2.6 -(defun accessor-5-1-2-6-update-fn (x y) - (setf (car x) y) - y) - -(defsetf accessor-5-1-2-6 accessor-5-1-2-6-update-fn) - -(deftest setf-expander.1 - (let ((x (list 1))) - (values (setf (accessor-5-1-2-6 x) 2) - (1+ (car x)))) - 2 3) - -;;; Section 5.1.2.7 - -(defmacro accessor-5-1-2-7 (x) `(car ,x)) -(deftest setf-macro.1 - (let ((x (list 1))) - (values (setf (accessor-5-1-2-7 x) 2) - (1+ (car x)))) - 2 3) - -(defun accessor-5-1-2-7a-update-fn (x y) - (declare (special *x*)) - (setf (car x) y) - (setf *x* 'boo) - y) - -(defmacro accessor-5-1-2-7a (x) `(car ,x)) -(defsetf accessor-5-1-2-7a accessor-5-1-2-7a-update-fn) -;; Test that the defsetf override the macro expansion -(deftest setf-macro.2 - (let ((x (list 1)) - (*x* nil)) - (declare (special *x*)) - (values (setf (accessor-5-1-2-7a x) 2) - *x* - (1+ (car x)))) - 2 boo 3) - -(defmacro accessor-5-1-2-7b (x) `(accessor-5-1-2-7 ,x)) -;; Test that the macroexpansion occurs more than once -(deftest setf-macro.3 - (let ((x (list 1))) - (values (setf (accessor-5-1-2-7b x) 2) - (1+ (car x)))) - 2 3) - -;; Macroexpansion from a macrolet -(deftest setf-macro.4 - (macrolet ((%m (y) `(car ,y))) - (let ((x (list 1))) - (values (setf (%m x) 2) - (1+ (car x))))) - 2 3) - -;;; section 5.1.2.8 -- symbol macros -(deftest setf-symbol-macro.1 - (symbol-macrolet ((x y)) - (let ((y nil)) - (values (setf x 1) x y))) - 1 1 1) - -;;; Symbol macros in SETQs are treated as if the form were a SETF -(deftest setf-symbol-macro.2 - (symbol-macrolet ((x y)) - (let ((y nil)) - (values (setq x 1) x y))) - 1 1 1) - -;;; Tests that, being treated like SETF, this causes multiple values -;;; to be assigned to (values y z) -(deftest setf-symbol-macro.3 - (symbol-macrolet ((x (values y z))) - (let ((y nil) (z nil)) - (values (setq x (values 1 2)) x y z))) - 1 1 1 2) - -(deftest setq.1 - (setq) - nil) - -(deftest setq.2 - (let ((x 0) (y 0)) - (values (setq x 1 y 2) x y)) - 2 1 2) - -(deftest setq.3 - (let ((x 0) (y 0)) - (values (setq x (values 1 3) y (values 2 4)) x y)) - 2 1 2) - -(deftest setq.4 - (let (x) (setq x (values 1 2))) - 1) - -(deftest setq.5 - (let ((*x* 0)) - (declare (special *x*)) - (values *x* (setq *x* 1) *x*)) - 0 1 1) - -(deftest setq.6 - (let ((*x* 0)) - (declare (special *x*)) - (setq *x* 1)) - 1) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest setq.7 - (macrolet - ((%m (z) z)) - (let ((x nil)) - (values (setq x (expand-in-current-env (%m :good))) - x))) - :good :good) - -;;; Tests of SETF - -(deftest setf.1 - (setf) - nil) - -(deftest setf.2 - (let ((x 0) (y 0)) - (values (setf x 1 y 2) x y)) - 2 1 2) - -(deftest setf.3 - (let ((x 0) (y 0)) - (values (setf x (values 1 3) y (values 2 4)) x y)) - 2 1 2) - -(deftest setf.4 - (let (x) (setf x (values 1 2))) - 1) - -(deftest setf.5 - (let ((*x* 0)) - (declare (special *x*)) - (values *x* (setf *x* 1) *x*)) - 0 1 1) - -(deftest setf.6 - (let ((*x* 0)) - (declare (special *x*)) - (setf *x* 1)) - 1) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest setf.7 - (macrolet - ((%m (z) z)) - (let ((x nil)) - (values x (setf (expand-in-current-env (%m x)) t) x))) - nil t t) - -(deftest setf.8 - (macrolet - ((%m (z) z)) - (let ((x nil)) - (values x (setf x (expand-in-current-env (%m t))) x))) - nil t t) diff --git a/t/ansi-test/data-and-control-flow/prog.lsp b/t/ansi-test/data-and-control-flow/prog.lsp deleted file mode 100644 index e206726..0000000 --- a/t/ansi-test/data-and-control-flow/prog.lsp +++ /dev/null @@ -1,180 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Oct 19 09:21:57 2002 -;;;; Contains: Tests of PROG - - - -(deftest prog.1 - (prog ()) - nil) - -(deftest prog.2 - (prog () 'a) - nil) - -(deftest prog.3 - (prog () (return 'a)) - a) - -(deftest prog.4 - (prog () (return (values 1 2 3 4 5))) - 1 2 3 4 5) - -(deftest prog.5 - (let ((x 'a)) - (prog ((x 'b) (y x)) - (declare (type symbol x y)) - (return (values x y)))) - b a) - -(deftest prog.6 - (let ((x 'a)) - (prog (x) (setq x 'b)) - x) - a) - -(deftest prog.7 - (prog ((i 1) (s 0)) - (declare (type fixnum i s)) - again - (when (> i 10) (return s)) - (incf s i) - (incf i) - (go again)) - 55) - -(deftest prog.8 - (let ((x 0)) - (prog ((y (incf x)) (z (incf x))) - (return (values x y z)))) - 2 1 2) - -(deftest prog.9 - (flet ((%f () (locally (declare (special z)) z))) - (prog ((z 10)) - (declare (special z)) - (return (%f)))) - 10) - -(deftest prog.10 - (prog () - (return - (1+ - (prog () - (go end) - done - (return 1) - end - (go done)))) - done - (return 'bad)) - 2) - -(deftest prog.11 - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) - (prog ((y x)) - (declare (special x)) - (return y)))) - :good) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest prog.12 - (macrolet - ((%m (z) z)) - (prog ((x (expand-in-current-env (%m :good)))) (return x))) - :good) - -(def-macro-test prog.error.1 (prog nil)) - -;;; Tests of PROG* - -(deftest prog*.1 - (prog* ()) - nil) - -(deftest prog*.2 - (prog* () 'a) - nil) - -(deftest prog*.3 - (prog* () (return 'a)) - a) - -(deftest prog*.4 - (prog* () (return (values 1 2 3 4 5))) - 1 2 3 4 5) - -(deftest prog*.5 - (let ((x 'a)) - (prog* ((z x) (x 'b) (y x)) - (declare (type symbol x y)) - (return (values x y z)))) - b b a) - -(deftest prog*.6 - (let ((x 'a)) - (prog* (x) (setq x 'b)) - x) - a) - -(deftest prog*.7 - (prog* ((i 1) (s 0)) - (declare (type fixnum i s)) - again - (when (> i 10) (return s)) - (incf s i) - (incf i) - (go again)) - 55) - -(deftest prog*.8 - (let ((x 0)) - (prog* ((y (incf x)) (z (incf x))) - (return (values x y z)))) - 2 1 2) - -(deftest prog*.9 - (flet ((%f () (locally (declare (special z)) z))) - (prog* ((z 10)) - (declare (special z)) - (return (%f)))) - 10) - -(deftest prog*.10 - (prog* () - (return - (1+ - (prog* () - (go end) - done - (return 1) - end - (go done)))) - done - (return 'bad)) - 2) - -(deftest prog*.11 - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) - (prog* ((y x)) - (declare (special x)) - (return y)))) - :good) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest prog*.12 - (macrolet - ((%m (z) z)) - (prog* ((x (expand-in-current-env (%m :good)))) (return x))) - :good) - -(def-macro-test prog*.error.1 (prog* nil)) diff --git a/t/ansi-test/data-and-control-flow/prog1.lsp b/t/ansi-test/data-and-control-flow/prog1.lsp deleted file mode 100644 index d7c53fd..0000000 --- a/t/ansi-test/data-and-control-flow/prog1.lsp +++ /dev/null @@ -1,48 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Oct 19 09:37:14 2002 -;;;; Contains: Tests for PROG1 - - - -(deftest prog1.1 - (prog1 'a) - a) - -(deftest prog1.2 - (prog1 'a 'b) - a) - -(deftest prog1.3 - (prog1 (values 'a 'b) 'c) - a) - -(deftest prog1.4 - (prog1 (values) 'c) - nil) - -(deftest prog1.5 - (let ((x 0)) - (values (prog1 x (incf x)) x)) - 0 1) - -;;; Test that prog1 doesn't have a tagbody - -(deftest prog1.6 - (block nil - (tagbody - (return (prog1 'bad (go 10) 10)) - 10 - (return 'good))) - good) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest prog1.7 - (macrolet - ((%m (z) z)) - (prog1 (expand-in-current-env (%m 'good)))) - good) - -(def-macro-test prog1.error.1 (prog1 nil)) diff --git a/t/ansi-test/data-and-control-flow/prog2.lsp b/t/ansi-test/data-and-control-flow/prog2.lsp deleted file mode 100644 index 1a5d18a..0000000 --- a/t/ansi-test/data-and-control-flow/prog2.lsp +++ /dev/null @@ -1,60 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Oct 19 09:40:51 2002 -;;;; Contains: Tests for PROG2 - - - -(deftest prog2.1 - (prog2 'a 'b) - b) - -(deftest prog2.2 - (prog2 'a 'b 'c) - b) - -(deftest prog2.3 - (prog2 'a (values) 'c) - nil) - -(deftest prog2.4 - (prog2 'a (values 'b 'd) 'c) - b) - -(deftest prog2.5 - (let ((x 0)) - (values - (prog2 (incf x) (incf x) (incf x)) - x)) - 2 3) - -(deftest prog2.6 - (let ((x 1)) - (values - (prog2 (incf x (1+ x)) (incf x (+ 2 x)) (incf x 100)) - x)) - 8 108) - -;;; Test that prog2 doesn't have a tagbody - -(deftest prog2.7 - (block nil - (tagbody - (return (prog2 17 'bad (go 10) 10)) - 10 - (return 'good))) - good) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest prog2.8 - (macrolet - ((%m (z) z)) - (prog2 - (expand-in-current-env (%m 'bad1)) - (expand-in-current-env (%m 'good)) - (expand-in-current-env (%m 'bad2)))) - good) - -(def-macro-test prog2.error.1 (prog2 nil nil)) diff --git a/t/ansi-test/data-and-control-flow/progn.lsp b/t/ansi-test/data-and-control-flow/progn.lsp deleted file mode 100644 index 04bac3c..0000000 --- a/t/ansi-test/data-and-control-flow/progn.lsp +++ /dev/null @@ -1,67 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Oct 19 09:33:51 2002 -;;;; Contains: Tests of PROGN - - - -(deftest progn.1 - (progn) - nil) - -(deftest progn.2 - (progn 'a) - a) - -(deftest progn.3 - (progn 'b 'a) - a) - -(deftest progn.4 - (let ((x 0)) - (values (progn (incf x) x) x)) - 1 1) - -(deftest progn.5 (progn (values))) - -(deftest progn.6 - (progn (values 1 2) (values 'a 'b 'c 'd 'e)) - a b c d e) - -(deftest progn.7 - (let ((x 0)) - (prog () - (progn (go x) x 'a) - (return 'bad) - x - (return 'good))) - good) - -;;; No implicit tagbody -(deftest progn.8 - (block nil - (tagbody - (progn - (go 10) - 10 - (return 'bad)) - 10 - (return 'good))) - good) - -;;; Macros are expanded in the appropriate environment - -(deftest progn.9 - (macrolet - ((%m (z) z)) - (progn (expand-in-current-env (%m :good)))) - :good) - -(deftest progn.10 - (macrolet - ((%m (z) z)) - (progn (expand-in-current-env (%m :bad)) - (expand-in-current-env (%m :good)))) - :good) - - diff --git a/t/ansi-test/data-and-control-flow/progv.lsp b/t/ansi-test/data-and-control-flow/progv.lsp deleted file mode 100644 index d0e917a..0000000 --- a/t/ansi-test/data-and-control-flow/progv.lsp +++ /dev/null @@ -1,135 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Oct 12 10:00:50 2002 -;;;; Contains: Tests for PROGV - - - -(deftest progv.1 - (progv () () t) - t) - -(deftest progv.2 - (progv '(x) '(1) (not (not (boundp 'x)))) - t) - -(deftest progv.3 - (progv '(x) '(1) (symbol-value 'x)) - 1) - -(deftest progv.4 - (progv '(x) '(1) - (locally (declare (special x)) - x)) - 1) - -(deftest progv.5 - (let ((x 0)) - (progv '(x) '(1) x)) - 0) - -(deftest progv.6 - (let ((x 0)) - (declare (special x)) - (progv '(x) () - (boundp 'x))) - nil) - -(deftest progv.6a - (let ((x 0)) - (declare (special x)) - (progv '(x) () (setq x 1)) - x) - 0) - -(deftest progv.7 - (progv '(x y z) '(1 2 3) - (locally (declare (special x y z)) - (values x y z))) - 1 2 3) - -(deftest progv.8 - (progv '(x y z) '(1 2 3 4 5 6 7 8) - (locally (declare (special x y z)) - (values x y z))) - 1 2 3) - -(deftest progv.9 - (let ((x 0)) - (declare (special x)) - (progv '(x y z w) '(1) - (values (not (not (boundp 'x))) - (boundp 'y) - (boundp 'z) - (boundp 'w)))) - t nil nil nil) - -;; forms are evaluated in order - -(deftest progv.10 - (let ((x 0) (y 0) (c 0)) - (progv - (progn (setf x (incf c)) nil) - (progn (setf y (incf c)) nil) - (values x y c))) - 1 2 2) - -;;; No tagbody - -(deftest progv.11 - (block nil - (tagbody - (progv nil nil (go 10) 10 (return 'bad)) - 10 - (return 'good))) - good) - -;;; Variables that are not bound don't have any type constraints - -(deftest progv.12 - (progv '(x y) '(1) - (locally (declare (special x y) (type nil y)) - (values - x - (boundp 'y)))) - 1 nil) - -;;; Macros are expanded in the appropriate environment - -(deftest progv.13 - (macrolet - ((%m (z) z)) - (progv (expand-in-current-env (%m '(x))) - '(:good) - (locally (declare (special x)) x))) - :good) - -(deftest progv.14 - (macrolet - ((%m (z) z)) - (progv (list (expand-in-current-env (%m 'x))) - '(:good) - (locally (declare (special x)) x))) - :good) - -(deftest progv.15 - (macrolet - ((%m (z) z)) - (progv '(x) - (expand-in-current-env (%m '(:good))) - (locally (declare (special x)) x))) - :good) - -(deftest progv.16 - (macrolet - ((%m (z) z)) - (progv '(x) - (list (expand-in-current-env (%m :good))) - (locally (declare (special x)) x))) - :good) - -(deftest progv.17 - (macrolet - ((%m (z) z)) - (progv nil nil (expand-in-current-env (%m :good)))) - :good) diff --git a/t/ansi-test/data-and-control-flow/psetf.lsp b/t/ansi-test/data-and-control-flow/psetf.lsp deleted file mode 100644 index b3d97be..0000000 --- a/t/ansi-test/data-and-control-flow/psetf.lsp +++ /dev/null @@ -1,422 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Apr 20 15:38:30 2003 -;;;; Contains: Tests of PSETF - - - -(deftest psetf.order.1 - (let ((x (vector nil nil nil nil)) - (i 0)) - (psetf (aref x (incf i)) (incf i)) - (values x i)) - #(nil 2 nil nil) 2) - -(deftest psetf.order.2 - (let ((x (vector nil nil nil nil)) - (i 0)) - (psetf (aref x (incf i)) (incf i) - (aref x (incf i)) (incf i 10)) - (values x i)) - #(nil 2 nil 13) 13) - -(deftest psetf.1 - (psetf) - nil) - -(deftest psetf.2 - (let ((x 0)) - (values (psetf x 1) x)) - nil 1) - -(deftest psetf.3 - (let ((x 0) (y 1)) - (values (psetf x y y x) x y)) - nil 1 0) - -(deftest psetf.4 - (let ((x 0)) - (values - (symbol-macrolet ((x y)) - (let ((y 1)) - (psetf x 2) - y)) - x)) - 2 0) - -(deftest psetf.5 - (let ((w (list nil))) - (values - (symbol-macrolet ((x (car w))) - (psetf x 2)) - w)) - nil (2)) - -(deftest psetf.6 - (let ((c 0) x y) - (psetf x (incf c) - y (incf c)) - (values c x y)) - 2 1 2) - -;;; According to the standard, the forms to be assigned and -;;; the subforms in the places to be assigned to are evaluated -;;; from left to right. Therefore, PSETF.7 and PSETF.8 should -;;; do the same thing to A as PSETF.9 does. -;;; (See the page for PSETF) - -(deftest psetf.7 - (symbol-macrolet ((x (aref a (incf i))) - (y (aref a (incf i)))) - (let ((a (copy-seq #(0 1 2 3 4 5 6 7 8 9))) - (i 0)) - (psetf x (aref a (incf i)) - y (aref a (incf i))) - (values a i))) - #(0 2 2 4 4 5 6 7 8 9) - 4) - -(deftest psetf.8 - (let ((a (copy-seq #(0 1 2 3 4 5 6 7 8 9))) - (i 0)) - (psetf (aref a (incf i)) (aref a (incf i)) - (aref a (incf i)) (aref a (incf i))) - (values a i)) - #(0 2 2 4 4 5 6 7 8 9) - 4) - -(deftest psetf.9 - (let ((a (copy-seq #(0 1 2 3 4 5 6 7 8 9)))) - (psetf (aref a 1) (aref a 2) - (aref a 3) (aref a 4)) - a) - #(0 2 2 4 4 5 6 7 8 9)) - -(deftest psetf.10 - (let ((*x* 0) (*y* 10)) - (declare (special *x* *y*)) - (values - *x* *y* - (psetf *x* 6 - *y* 15) - *x* *y*)) - 0 10 nil 6 15) - -(deftest psetf.11 - (let ((*x* 0) (*y* 10)) - (declare (special *x* *y*)) - (values - *x* *y* - (psetf *x* *y* - *y* *x*) - *x* *y*)) - 0 10 nil 10 0) - -(def-macro-test psetf.error.1 (psetf)) - -;;; PSETF is a good testbed for finding conflicts in setf expansions -;;; These tests apply psetf to various accessors - -(deftest psetf.12 - (let* ((x (list 'a 'b)) - (y (list 'c 'd))) - (psetf (car x) 1 (car y) 2) - (values x y)) - (1 b) (2 d)) - -(deftest psetf.12a - (let* ((x (list 'a 'b)) - (y (list 'c 'd))) - (psetf (first x) 1 (first y) 2) - (values x y)) - (1 b) (2 d)) - -(deftest psetf.13 - (let* ((x (list 'a 'b)) - (y (list 'c 'd))) - (psetf (cdr x) 1 (cdr y) 2) - (values x y)) - (a . 1) (c . 2)) - -(deftest psetf.13a - (let* ((x (list 'a 'b)) - (y (list 'c 'd))) - (psetf (rest x) 1 (rest y) 2) - (values x y)) - (a . 1) (c . 2)) - -(deftest psetf.14 - (let* ((x (list 'a 'b)) - (y (list 'c 'd))) - (psetf (cadr x) 1 (cadr y) 2) - (values x y)) - (a 1) (c 2)) - -(deftest psetf.15 - (let* ((x (list 'a 'b)) - (y (list 'c 'd))) - (psetf (cddr x) 1 (cddr y) 2) - (values x y)) - (a b . 1) (c d . 2)) - -(deftest psetf.16 - (let* ((x (list (list 'a))) - (y (list (list 'c)))) - (psetf (caar x) 1 (caar y) 2) - (values x y)) - ((1)) ((2))) - -(deftest psetf.17 - (let* ((x (list (list 'a))) - (y (list (list 'c)))) - (psetf (cdar x) 1 (cdar y) 2) - (values x y)) - ((a . 1)) ((c . 2))) - -;;; TODO: c*r accessors with > 2 a/d -;;; TODO: third,...,tenth - -(deftest psetf.18 - (let* ((x (vector 'a 'b)) - (y (vector 'c 'd))) - (psetf (aref x 0) 1 (aref y 0) 2) - (values x y)) - #(1 b) #(2 d)) - -(deftest psetf.18a - (let* ((x (vector 'a 'b)) - (y (vector 'c 'd))) - (psetf (svref x 0) 1 (svref y 0) 2) - (values x y)) - #(1 b) #(2 d)) - -(deftest psetf.19 - (let* ((x (copy-seq #*11000)) - (y (copy-seq #*11100))) - (psetf (bit x 1) 0 (bit x 2) 1 (bit y 4) 1 (bit y 0) 0) - (values x y)) - #*10100 #*01101) - -(deftest psetf.20 - (let* ((x (copy-seq "abcde")) - (y (copy-seq "fghij"))) - (psetf (char x 1) #\X (char y 2) #\Y) - (values x y)) - "aXcde" "fgYij") - -(deftest psetf.21 - (let* ((x (copy-seq #*11000)) - (y (copy-seq #*11100))) - (psetf (sbit x 1) 0 (sbit x 2) 1 (sbit y 4) 1 (sbit y 0) 0) - (values x y)) - #*10100 #*01101) - -(deftest psetf.22 - (let* ((x (copy-seq "abcde")) - (y (copy-seq "fghij"))) - (psetf (schar x 1) #\X (schar y 2) #\Y) - (values x y)) - "aXcde" "fgYij") - -(deftest psetf.23 - (let* ((x (copy-seq '(a b c d e))) - (y (copy-seq '(f g h i j)))) - (psetf (elt x 1) 'u (elt y 2) 'v) - (values x y)) - (a u c d e) (f g v i j)) - -(deftest psetf.24 - (let ((x #b110110001) - (y #b101001100)) - (psetf (ldb (byte 5 1) x) #b10110 - (ldb (byte 3 6) y) #b10) - (values x y)) - #b110101101 - #b010001100) - -(deftest psetf.25 - (let* ((f1 (gensym)) - (f2 (gensym)) - (fn1 (constantly :foo)) - (fn2 (constantly :bar))) - (psetf (fdefinition f1) fn1 - (fdefinition f2) fn2) - (values (funcall f1) (funcall f2))) - :foo :bar) - -(deftest psetf.26 - (let* ((a1 (make-array '(10) :fill-pointer 5)) - (a2 (make-array '(20) :fill-pointer 7))) - (psetf (fill-pointer a1) (1+ (fill-pointer a2)) - (fill-pointer a2) (1- (fill-pointer a1))) - (values (fill-pointer a1) (fill-pointer a2))) - 8 4) - -(deftest psetf.27 - (let* ((x (list 'a 'b 'c 'd)) - (y (list 'd 'e 'f 'g)) - (n1 1) (n2 2) - (v1 :foo) (v2 :bar)) - (psetf (nth n1 x) v1 - (nth n2 y) v2) - (values x y)) - (a :foo c d) - (d e :bar g)) - -(deftest psetf.28 - (let* ((f1 (gensym)) - (f2 (gensym)) - (fn1 (constantly :foo)) - (fn2 (constantly :bar))) - (psetf (symbol-function f1) fn1 - (symbol-function f2) fn2) - (values (funcall f1) (funcall f2))) - :foo :bar) - -(deftest psetf.29 - (let* ((s1 (gensym)) - (s2 (gensym)) - (v1 :foo) - (v2 :bar)) - (psetf (symbol-value s1) v1 - (symbol-value s2) v2) - (values (symbol-value s1) (symbol-value s2))) - :foo :bar) - -(deftest psetf.30 - (let* ((s1 (gensym)) - (s2 (gensym)) - (v1 (list :foo 1)) - (v2 (list :bar 2))) - (psetf (symbol-plist s1) v1 - (symbol-plist s2) v2) - (values (symbol-plist s1) (symbol-plist s2))) - (:foo 1) (:bar 2)) - -(deftest psetf.31 - (let* ((x (list 'a 'b 'c 'd 'e)) - (y (list 'f 'g 'h 'i 'j)) - (v1 (list 1 2)) - (v2 (list 3 4 5)) - (p1 1) (p2 2) - (l1 (length v1)) - (l2 (length v2))) - (psetf (subseq x p1 (+ p1 l1)) v1 - (subseq y p2 (+ p2 l2)) v2) - (values x y)) - (a 1 2 d e) - (f g 3 4 5)) - -(deftest psetf.32 - (let* ((x (gensym)) - (y (gensym)) - (k1 :foo) - (k2 :bar) - (v1 1) - (v2 2)) - (psetf (get x k1) v1 (get y k2) v2) - (values (symbol-plist x) (symbol-plist y))) - (:foo 1) (:bar 2)) - -(deftest psetf.33 - (let* ((x nil) - (y nil) - (k1 :foo) - (k2 :bar) - (v1 1) - (v2 2)) - (psetf (getf x k1) v1 (getf y k2) v2) - (values x y)) - (:foo 1) (:bar 2)) - -(deftest psetf.34 - (let* ((ht1 (make-hash-table)) - (ht2 (make-hash-table)) - (k1 :foo) (v1 1) - (k2 :bar) (v2 2)) - (psetf (gethash k1 ht1) v1 - (gethash k2 ht2) v2) - (values (gethash k1 ht1) (gethash k2 ht2))) - 1 2) - -(deftest psetf.35 - (let ((n1 (gensym)) - (n2 (gensym)) - (n3 (gensym)) - (n4 (gensym))) - (eval `(defclass ,n1 () ())) - (eval `(defclass ,n2 () ())) - (psetf (find-class n3) (find-class n1) - (find-class n4) (find-class n2)) - (values (eqlt (find-class n1) (find-class n3)) - (eqlt (find-class n2) (find-class n4)))) - t t) - -(deftest psetf.36 - (let ((fn1 (constantly :foo)) - (fn2 (constantly :bar)) - (n1 (gensym)) - (n2 (gensym))) - (psetf (macro-function n1) fn1 - (macro-function n2) fn2) - (values (eval `(,n1)) (eval `(,n2)))) - :foo :bar) - -(deftest psetf.37 - (let ((b1 (byte 3 1)) - (b2 (byte 4 2)) - (x #b1100101011010101) - (y #b11010101000110) - (m1 #b101010101101101) - (m2 #b11110010110101)) - (psetf (mask-field b1 x) m1 - (mask-field b2 y) m2) - (values x y)) - #b1100101011011101 - #b11010101110110) - -(deftest psetf.38 - (let* ((a1 (make-array '(2 3) :initial-contents '((a b c)(d e f)))) - (a2 (make-array '(3 4) :initial-contents - '((1 2 3 4) (5 6 7 8) (9 10 11 12)))) - (i1 2) (i2 5) - (v1 'u) (v2 'v)) - (psetf (row-major-aref a1 i1) v1 - (row-major-aref a2 i2) v2) - (values a1 a2)) - #2a((a b u)(d e f)) - #2a((1 2 3 4)(5 v 7 8)(9 10 11 12))) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest psetf.39 - (macrolet - ((%m (z) z)) - (let ((x 1) (y 2)) - (values - (psetf (expand-in-current-env (%m x)) y - y x) - x y))) - nil 2 1) - -(deftest psetf.40 - (macrolet - ((%m (z) z)) - (let ((x 1) (y 2)) - (values - (psetf x (expand-in-current-env (%m y)) - y x) - x y))) - nil 2 1) - -;; Test, if psetf handles correctly multiple values. -(deftest psetf.41 - (let ((y 2) (z 3) u x a b c) - (psetf (values a b c) (values 1 2 3) - (values u x) (values y z)) - (values a b c u x)) - 1 2 3 2 3) - - -;;; TODO: logical-pathname-translations, readtable-case diff --git a/t/ansi-test/data-and-control-flow/psetq.lsp b/t/ansi-test/data-and-control-flow/psetq.lsp deleted file mode 100644 index 052186d..0000000 --- a/t/ansi-test/data-and-control-flow/psetq.lsp +++ /dev/null @@ -1,106 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Apr 20 15:37:20 2003 -;;;; Contains: Tests of PSETQ - - - -(deftest psetq.1 - (psetq) - nil) - -(deftest psetq.2 - (let ((x 0)) - (values (psetq x 1) x)) - nil 1) - -(deftest psetq.3 - (let ((x 0) (y 1)) - (values (psetq x y y x) x y)) - nil 1 0) - -(deftest psetq.4 - (let ((x 0)) - (values - (symbol-macrolet ((x y)) - (let ((y 1)) - (psetq x 2) - y)) - x)) - 2 0) - -(deftest psetq.5 - (let ((w (list nil))) - (values - (symbol-macrolet ((x (car w))) - (psetq x 2)) - w)) - nil (2)) - -(deftest psetq.6 - (let ((c 0) x y) - (psetq x (incf c) - y (incf c)) - (values c x y)) - 2 1 2) - -;;; The next test is a PSETQ that is equivalent to a PSETF -;;; See PSETF.7 for comments related to this test. - -(deftest psetq.7 - (symbol-macrolet ((x (aref a (incf i))) - (y (aref a (incf i)))) - (let ((a (copy-seq #(0 1 2 3 4 5 6 7 8 9))) - (i 0)) - (psetq x (aref a (incf i)) - y (aref a (incf i))) - (values a i))) - #(0 2 2 4 4 5 6 7 8 9) - 4) - -(deftest psetq.8 - (let ((*x* 0) (*y* 10)) - (declare (special *x* *y*)) - (values - *x* *y* - (psetq *x* 6 - *y* 15) - *x* *y*)) - 0 10 nil 6 15) - -(deftest psetq.9 - (let ((*x* 0) (*y* 10)) - (declare (special *x* *y*)) - (values - *x* *y* - (psetq *x* *y* - *y* *x*) - *x* *y*)) - 0 10 nil 10 0) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest psetq.10 - (macrolet - ((%m (z) z)) - (let ((x nil) (y nil)) - (values - (psetq x (expand-in-current-env (%m 1)) - y (expand-in-current-env (%m 2))) - x y))) - nil 1 2) - -(deftest psetq.error.1 - (signals-error (funcall (macro-function 'psetq)) program-error) - t) - -(deftest psetq.error.2 - (signals-error (funcall (macro-function 'psetq) '(psetq)) - program-error) - t) - -(deftest psetq.error.3 - (signals-error (funcall (macro-function 'psetq) '(psetq) nil nil) - program-error) - t) diff --git a/t/ansi-test/data-and-control-flow/return-from.lsp b/t/ansi-test/data-and-control-flow/return-from.lsp deleted file mode 100644 index b775aad..0000000 --- a/t/ansi-test/data-and-control-flow/return-from.lsp +++ /dev/null @@ -1,24 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Feb 24 20:22:23 2004 -;;;; Contains: Tests of RETURN-FROM - - - -;;; RETURN-FROM is tested extensively in other files - -(deftest return-from.1 - (block xyz (return-from xyz) :bad) - nil) - -(deftest return-from.2 - (block nil (return-from nil :good) :bad) - :good) - -;;; Macros are expanded in the appropriate environment - -(deftest return-from.3 - (macrolet - ((%m (z) z)) - (block foo (return-from foo (expand-in-current-env (%m :good))))) - :good) diff --git a/t/ansi-test/data-and-control-flow/return.lsp b/t/ansi-test/data-and-control-flow/return.lsp deleted file mode 100644 index 69d1d88..0000000 --- a/t/ansi-test/data-and-control-flow/return.lsp +++ /dev/null @@ -1,42 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Apr 20 16:00:32 2003 -;;;; Contains: Tests of RETURN - - - -;;; RETURN is tested extensively in other files - -(deftest return.error.1 - (signals-error (funcall (macro-function 'return)) program-error) - t) - -(deftest return.error.2 - (signals-error (funcall (macro-function 'return) '(return nil)) - program-error) - t) - -(deftest return.error.3 - (signals-error (funcall (macro-function 'return) - '(return nil) nil nil) - program-error) - t) - -;;; - -(deftest return.1 - (block nil (return) :bad) - nil) - -(deftest return.2 - (block nil (return :good) :bad) - :good) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest return.3 - (macrolet - ((%m (z) z)) - (block nil (return (expand-in-current-env (%m :good))) :bad)) - :good) diff --git a/t/ansi-test/data-and-control-flow/rotatef.lsp b/t/ansi-test/data-and-control-flow/rotatef.lsp deleted file mode 100644 index 0b90b0e..0000000 --- a/t/ansi-test/data-and-control-flow/rotatef.lsp +++ /dev/null @@ -1,371 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Apr 20 15:44:38 2003 -;;;; Contains: Tests for ROTATEF - - - -(deftest rotatef-order.1 - (let ((x (vector 'a 'b 'c 'd 'e 'f)) - (i 2)) - (values - (rotatef (aref x (incf i)) (aref x (incf i))) - x i)) - nil - #(a b c e d f) - 4) - -(deftest rotatef-order.2 - (let ((x (vector 'a 'b 'c 'd 'e 'f)) - (i 2)) - (values - (rotatef (aref x (incf i)) (aref x (incf i)) (aref x (incf i))) - x i)) - nil - #(a b c e f d) - 5) - -(deftest rotatef.1 - (let ((x (vector 0 1 2))) - (values - (rotatef (aref x (aref x 0)) (aref x (aref x 1)) (aref x (aref x 2))) - x)) - nil - #(1 2 0)) - -(deftest rotatef.2 - (let ((x (vector 0 1 2 3 4 5 6 7 8 9))) - (values - (rotatef (aref x (aref x 0)) - (aref x (aref x 1)) - (aref x (aref x 2)) - (aref x (aref x 3)) - (aref x (aref x 4)) - (aref x (aref x 5)) - (aref x (aref x 6)) - (aref x (aref x 7)) - (aref x (aref x 8)) - (aref x (aref x 9))) - x)) - nil - #(1 2 3 4 5 6 7 8 9 0)) - -(deftest rotatef.3 - (rotatef) - nil) - -(deftest rotatef.4 - (let ((x 10)) - (values - x - (rotatef x) - x)) - 10 nil 10) - -(deftest rotatef.5 - (let ((x 'a) (y 'b)) - (values x y (rotatef x y) x y)) - a b nil b a) - - -;;; ROTATEF is a good testbed for finding conflicts in setf expansions -;;; These tests apply rotatef to various accessors - -(deftest rotatef.6 - (let* ((x (list 'a 'b)) - (y (list 'c 'd)) - (z 'e)) - (rotatef (car x) (car y) z) - (values x y z)) - (c b) (e d) a) - -(deftest rotatef.7 - (let* ((x (list 'a 'b)) - (y (list 'c 'd)) - (z 'e)) - (rotatef (first x) (first y) z) - (values x y z)) - (c b) (e d) a) - -(deftest rotatef.8 - (let* ((x (list 'a 'b)) - (y (list 'c 'd)) - (z '(e))) - (rotatef (cdr x) (cdr y) z) - (values x y z)) - (a d) (c e) (b)) - -(deftest rotatef.9 - (let* ((x (list 'a 'b)) - (y (list 'c 'd)) - (z '(e))) - (rotatef (rest x) (rest y) z) - (values x y z)) - (a d) (c e) (b)) - -(deftest rotatef.10 - (let* ((x (list 'a 'b)) - (y (list 'c 'd)) - (z 'e)) - (rotatef (cadr x) (cadr y) z) - (values x y z)) - (a d) (c e) b) - -(deftest rotatef.11 - (let* ((x (list 'a 'b)) - (y (list 'c 'd)) - (z 'e)) - (rotatef (second x) (second y) z) - (values x y z)) - (a d) (c e) b) - -(deftest rotatef.12 - (let* ((x (list 'a 'b 'c)) - (y (list 'd 'e 'f)) - (z (list 'g))) - (rotatef (cddr x) (cddr y) z) - (values x y z)) - (a b f) (d e g) (c)) - -(deftest rotatef.13 - (let* ((x (list (list 'a))) - (y (list (list 'c))) - (z 'e)) - (rotatef (caar x) (caar y) z) - (values x y z)) - ((c)) ((e)) a) - -(deftest rotatef.14 - (let* ((x (list (list 'a 'b))) - (y (list (list 'c 'd))) - (z (list 'e))) - (rotatef (cdar x) (cdar y) z) - (values x y z)) - ((a d)) ((c e)) (b)) - -;;; TODO: c*r accessors with > 2 a/d -;;; TODO: third,...,tenth - -(deftest rotatef.15 - (let* ((x (vector 'a 'b)) - (y (vector 'c 'd)) - (z 'e)) - (rotatef (aref x 0) (aref y 0) z) - (values x y z)) - #(c b) #(e d) a) - -(deftest rotatef.16 - (let* ((x (vector 'a 'b)) - (y (vector 'c 'd)) - (z 'e)) - (rotatef (svref x 0) (svref y 0) z) - (values x y z)) - #(c b) #(e d) a) - -(deftest rotatef.17 - (let* ((x (copy-seq #*11000)) - (y (copy-seq #*11100)) - (z 1)) - (rotatef (bit x 1) (bit y 3) z) - (values x y z)) - #*10000 #*11110 1) - -(deftest rotatef.18 - (let* ((x (copy-seq "abcde")) - (y (copy-seq "fghij")) - (z #\X)) - (rotatef (char x 1) (char y 2) z) - (values x y z)) - "ahcde" "fgXij" #\b) - -(deftest rotatef.21 - (let* ((x (copy-seq #*11000)) - (y (copy-seq #*11100)) - (z 1)) - (rotatef (bit x 1) (bit y 3) z) - (values x y z)) - #*10000 #*11110 1) - -(deftest rotatef.22 - (let* ((x (copy-seq "abcde")) - (y (copy-seq "fghij")) - (z #\X)) - (rotatef (char x 1) (char y 2) z) - (values x y z)) - "ahcde" "fgXij" #\b) - -(deftest rotatef.23 - (let* ((x (copy-seq '(a b c d e))) - (y (copy-seq '(f g h i j))) - (z 'k)) - (rotatef (elt x 1) (elt y 2) z) - (values x y z)) - (a h c d e) (f g k i j) b) - -(deftest rotatef.24 - (let ((x #b01010101) - (y #b1111) - (z 0)) - (rotatef (ldb (byte 4 2) x) - (ldb (byte 4 1) y) - z) - (values x y z)) - #b01011101 - 1 - #b0101) - -(deftest rotatef.25 - (let* ((f1 (gensym)) - (f2 (gensym)) - (fn1 (constantly :foo)) - (fn2 (constantly :bar)) - (fn3 (constantly :zzz))) - (setf (fdefinition f1) fn1 - (fdefinition f2) fn2) - (rotatef (fdefinition f1) - (fdefinition f2) - fn3) - (values (funcall f1) (funcall f2) (funcall fn3))) - :bar :zzz :foo) - -(deftest rotatef.26 - (let* ((a1 (make-array '(10) :fill-pointer 5)) - (a2 (make-array '(20) :fill-pointer 7)) - (z 3)) - (rotatef (fill-pointer a1) (fill-pointer a2) z) - (values (fill-pointer a1) (fill-pointer a2) z)) - 7 3 5) - -(deftest rotatef.27 - (let* ((x (list 'a 'b 'c 'd)) - (y (list 'd 'e 'f 'g)) - (n1 1) (n2 2) - (z 'h)) - (rotatef (nth n1 x) (nth n2 y) z) - (values x y z)) - (a f c d) - (d e h g) - b) - -(deftest rotatef.28 - (let* ((f1 (gensym)) - (f2 (gensym)) - (fn1 (constantly :foo)) - (fn2 (constantly :bar)) - (fn3 (constantly :zzz))) - (setf (symbol-function f1) fn1 - (symbol-function f2) fn2) - (rotatef (symbol-function f1) (symbol-function f2) fn3) - (values (funcall f1) (funcall f2) (funcall fn3))) - :bar :zzz :foo) - -(deftest rotatef.29 - (let* ((s1 (gensym)) - (s2 (gensym)) - (z 1)) - (setf (symbol-value s1) :foo - (symbol-value s2) :bar) - (rotatef (symbol-value s1) - (symbol-value s2) - z) - (values (symbol-value s1) (symbol-value s2) z)) - :bar 1 :foo) - -(deftest rotatef.30 - (let* ((s1 (gensym)) - (s2 (gensym)) - (v1 (list :foo 1)) - (v2 (list :bar 2)) - (z nil)) - (setf (symbol-plist s1) v1 - (symbol-plist s2) v2) - (rotatef (symbol-plist s1) (symbol-plist s2) z) - (values (symbol-plist s1) (symbol-plist s2) z)) - (:bar 2) nil (:foo 1)) - -(deftest rotatef.31 - (let* ((x (list 'a 'b 'c 'd 'e)) - (y (list 'f 'g 'h 'i 'j)) - (p1 1) (p2 2) (len 3) - (z '(10 11 12))) - (rotatef (subseq x p1 (+ p1 len)) - (subseq y p2 (+ p2 len)) - z) - (values x y z)) - (a h i j e) - (f g 10 11 12) - (b c d)) - -(deftest rotatef.32 - (let* ((x (gensym)) - (y (gensym)) - (k1 :foo) - (k2 :bar) - (v1 1) - (v2 2) - (z 17)) - (setf (get x k1) v1 (get y k2) v2) - (rotatef (get x k1) (get y k2) z) - (values (symbol-plist x) (symbol-plist y) z)) - (:foo 2) (:bar 17) 1) - -(deftest rotatef.33 - (let* ((x nil) - (y nil) - (k1 :foo) - (k2 :bar) - (v1 1) - (v2 2) - (z 21)) - (setf (getf x k1) v1 (getf y k2) v2) - (rotatef (getf x k1) (getf y k2) z) - (values x y z)) - (:foo 2) (:bar 21) 1) - -(deftest rotatef.34 - (let* ((ht1 (make-hash-table)) - (ht2 (make-hash-table)) - (k1 :foo) (v1 1) - (k2 :bar) (v2 2) - (z 3)) - (setf (gethash k1 ht1) v1 - (gethash k2 ht2) v2) - (rotatef z (gethash k1 ht1) (gethash k2 ht2)) - (values z (gethash k1 ht1) (gethash k2 ht2))) - 1 2 3) - -(deftest rotatef.35 - (let ((n1 (gensym)) - (n2 (gensym)) - (n3 (gensym)) - (n4 (gensym))) - (eval `(defclass ,n1 () ())) - (eval `(defclass ,n2 () ())) - (setf (find-class n3) (find-class n1) - (find-class n4) (find-class n2)) - (rotatef (find-class n3) (find-class n4)) - (values (eqlt (find-class n1) (find-class n4)) - (eqlt (find-class n2) (find-class n3)))) - t t) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest rotatef.36 - (macrolet - ((%m (z) z)) - (let ((x 1) (y 2)) - (rotatef (expand-in-current-env (%m x)) y) - (values x y))) - 2 1) - -(deftest rotatef.37 - (macrolet - ((%m (z) z)) - (let ((x 1) (y 2)) - (rotatef x (expand-in-current-env (%m y))) - (values x y))) - 2 1) - -;;; TODO: macro-function, mask-field, row-major-aref, -;;; logical-pathname-translations, readtable-case diff --git a/t/ansi-test/data-and-control-flow/shiftf.lsp b/t/ansi-test/data-and-control-flow/shiftf.lsp deleted file mode 100644 index 15ca3d9..0000000 --- a/t/ansi-test/data-and-control-flow/shiftf.lsp +++ /dev/null @@ -1,91 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Apr 20 15:43:44 2003 -;;;; Contains: Tests of SHIFTF - - - -(deftest shiftf-order.1 - (let ((x (vector 'a 'b 'c 'd 'e)) - (i 2)) - (values (shiftf (aref x (incf i)) (incf i)) x i)) - d #(a b c 4 e) 4) - -(deftest shiftf-order.2 - (let ((x (vector 'a 'b 'c 'd 'e 'f 'g 'h)) - (i 2)) - (values (shiftf (aref x (incf i)) (aref x (incf i)) (incf i)) x i)) - d #(a b c e 5 f g h) 5) - -(deftest shiftf.1 - (let ((x 0)) - (values - x - (shiftf x 1) - x)) - 0 0 1) - -(deftest shiftf.2 - (let ((x 'a) (y 'b) (z 'c)) - (values - x y z - (shiftf x y z 'd) - x y z)) - a b c - a - b c d) - -(deftest shiftf.3 - (let ((x (vector 0 1 2 3))) - (values - (copy-seq x) - (shiftf (aref x (aref x 0)) - (aref x (aref x 1)) - (aref x (aref x 2)) - (aref x (aref x 3)) - 'foo) - (copy-seq x))) - #(0 1 2 3) - 0 - #(1 2 3 foo)) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest shiftf.4 - (macrolet - ((%m (z) z)) - (let ((x 1) (y 2)) - (values - (shiftf (expand-in-current-env (%m x)) y 'foo) - x y))) - 1 2 foo) - -(deftest shiftf.5 - (macrolet - ((%m (z) z)) - (let ((x 1) (y 2)) - (values - (shiftf x (expand-in-current-env (%m y)) 'foo) - x y))) - 1 2 foo) - -(deftest shiftf.6 - (macrolet - ((%m (z) z)) - (let ((x 1) (y 2)) - (values - (shiftf x y (expand-in-current-env (%m 'foo))) - x y))) - 1 2 foo) - -;;; Test that SHIFTF returns a single value, even though the first -;;; place has multiple values. -(deftest shiftf.7 - (let ((x 'a) (y 'b)) - (values - (multiple-value-list (shiftf (values x y) (floor 10 3))) - x y)) - (a) 3 1) - -;;; Need to add more shiftf tests here diff --git a/t/ansi-test/data-and-control-flow/some.lsp b/t/ansi-test/data-and-control-flow/some.lsp deleted file mode 100644 index acaadc9..0000000 --- a/t/ansi-test/data-and-control-flow/some.lsp +++ /dev/null @@ -1,315 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Oct 18 07:07:07 2002 -;;;; Contains: Tests for SOME - - - -(deftest some.1 - (some #'identity nil) - nil) - -(deftest some.2 - (some #'identity #()) - nil) - -(deftest some.3 - (let ((count 0)) - (values - (some #'(lambda (x) (incf count) (if (>= x 10) x nil)) - '(1 2 4 13 5 1)) - count)) - 13 4) - -(deftest some.4 - (some #'/= '(1 2 3 4) '(1 2 3 4 5)) - nil) - -(deftest some.5 - (some #'/= '(1 2 3 4 5) '(1 2 3 4)) - nil) - -(deftest some.6 - (not-mv (some #'/= '(1 2 3 4 5) '(1 2 3 4 6))) - nil) - -(deftest some.7 - (some #'(lambda (x y) (and x y)) - '(nil t t nil t) #(t nil nil t nil nil)) - nil) - -(deftest some.8 - (let ((x '(1)) - (args nil)) - (loop for i from 1 below (1- (min 100 call-arguments-limit)) - do (push x args) - always (apply #'some #'/= args))) - nil) - -(deftest some.9 - (some #'zerop #*11111111111111) - nil) - -(deftest some.10 - (some #'zerop #*) - nil) - -(deftest some.11 - (not-mv (some #'zerop #*1111111011111)) - nil) - -(deftest some.12 - (some #'(lambda (x) (not (eql x #\a))) "aaaaaaaa") - nil) - -(deftest some.13 - (some #'(lambda (x) (eql x #\a)) "") - nil) - -(deftest some.14 - (not-mv (some #'(lambda (x) (not (eql x #\a))) "aaaaaabaaaa")) - nil) - -(deftest some.15 - (some 'null '(1 2 3 4)) - nil) - -(deftest some.16 - (not-mv (some 'null '(1 2 3 nil 5))) - nil) - -;;; Other specialized sequences - -(deftest some.17 - (let ((v (make-array '(10) :initial-contents '(0 0 0 0 1 2 3 4 5 6) - :fill-pointer 4))) - (loop for j from 0 to 9 - do (setf (fill-pointer v) j) - collect (notnot (some #'plusp v)))) - (nil nil nil nil nil t t t t t)) - -(deftest some.18 - (loop for i from 1 to 40 - for type = `(unsigned-byte ,i) - unless - (let ((v (make-array '(10) :initial-contents (loop for j in '(0 0 0 0 1 2 3 4 5 6) - collect (mod j (ash 1 i))) - :element-type type - :fill-pointer 4))) - (equal (loop for j from 0 to 9 - do (setf (fill-pointer v) j) - collect (notnot (some #'plusp v))) - '(nil nil nil nil nil t t t t t))) - collect i) - nil) - -(deftest some.19 - (loop for i from 1 to 40 - for type = `(signed-byte ,i) - unless - (let ((v (make-array '(10) :initial-contents '(0 0 0 0 -1 -1 -1 -1 -1 -1) - :element-type type - :fill-pointer 4))) - (equal (loop for j from 0 to 9 - do (setf (fill-pointer v) j) - collect (notnot (some #'minusp v))) - '(nil nil nil nil nil t t t t t))) - collect i) - nil) - -(deftest some.20 - (let ((v (make-array '(10) :initial-contents "abcd012345" - :element-type 'character - :fill-pointer 4))) - (loop for j from 0 to 9 - do (setf (fill-pointer v) j) - collect (notnot (some #'digit-char-p v)))) - (nil nil nil nil nil t t t t t)) - -(deftest some.21 - (let ((v (make-array '(10) :initial-contents "abcd012345" - :element-type 'base-char - :fill-pointer 4))) - (loop for j from 0 to 9 - do (setf (fill-pointer v) j) - collect (notnot (some #'digit-char-p v)))) - (nil nil nil nil nil t t t t t)) - -(deftest some.22 - (let ((v (make-array '(5) :initial-contents "abcde" - :element-type 'base-char))) - (values - (some #'digit-char-p v) - (setf (aref v 2) #\0) - (notnot (some #'digit-char-p v)))) - nil #\0 t) - -(deftest some.23 - (loop for type in '(short-float single-float double-float long-float) - for v = (make-array '(9) - :element-type type - :initial-contents - (mapcar #'(lambda (x) (coerce x type)) '(1 2 3 4 5 6 0 8 3))) - unless (some #'zerop v) - collect (list type v)) - nil) - -(deftest some.24 - (loop for type in '(short-float single-float double-float long-float) - for v = (make-array '(9) - :element-type type - :fill-pointer 6 - :initial-contents - (mapcar #'(lambda (x) (coerce x type)) '(1 2 3 4 5 6 0 8 3))) - when (some #'zerop v) - collect (list type v)) - nil) - -(deftest some.25 - (loop for type in '(short-float single-float double-float long-float) - for ctype = `(complex ,type) - for v = (make-array '(6) - :element-type ctype - :initial-contents - (mapcar #'(lambda (x) (complex x (coerce x type))) '(1 2 3 4 5 6))) - when (some (complement #'complexp) v) - collect (list type v)) - nil) - -;;; Displaced vectors - -(deftest some.26 - (let* ((v1 (make-array '(10) :initial-contents '(1 3 2 4 6 8 5 7 9 1))) - (v2 (make-array '(4) :displaced-to v1 - :displaced-index-offset 2))) - (values - (notnot (some #'oddp v1)) - (some #'oddp v2))) - t nil) - -(deftest some.27 - (loop for i from 1 to 40 - for type = `(unsigned-byte ,i) - unless - (let* ((v1 (make-array '(10) :initial-contents '(1 1 0 0 0 0 1 1 1 1) - :element-type type)) - (v2 (make-array '(4) :displaced-to v1 - :displaced-index-offset 2 - :element-type type))) - (and (some 'oddp v1)) - (not (some #'oddp v2))) - collect i) - nil) - -(deftest some.28 - (loop for i from 1 to 40 - for type = `(signed-byte ,i) - unless - (let* ((v1 (make-array '(10) :initial-contents '(-1 -1 0 0 0 0 -1 -1 -1 -1) - :element-type type)) - (v2 (make-array '(4) :displaced-to v1 - :displaced-index-offset 2 - :element-type type))) - (and (some 'oddp v1) - (not (some #'oddp v2)))) - collect i) - nil) - -(deftest some.29 - (let* ((s1 (make-array '(8) :initial-contents "12abc345" :element-type 'character))) - (loop for i from 0 to 6 - for s2 = (make-array '(2) :element-type 'character - :displaced-to s1 - :displaced-index-offset i) - collect (notnot (some 'digit-char-p s2)))) - (t t nil nil t t t)) - -(deftest some.30 - (let* ((s1 (make-array '(8) :initial-contents "12abc345" :element-type 'base-char))) - (loop for i from 0 to 6 - for s2 = (make-array '(2) :element-type 'base-char - :displaced-to s1 - :displaced-index-offset i) - collect (notnot (some 'digit-char-p s2)))) - (t t nil nil t t t)) - -(deftest some.31 - (let ((v (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) - :adjustable t))) - (values - (some #'minusp v) - (progn - (adjust-array v '(11) :initial-element -1) - (notnot (some #'minusp v))))) - nil t) - -(deftest some.32 - (let ((v (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) - :fill-pointer 10 - :adjustable t))) - (values - (some #'minusp v) - (progn - (adjust-array v '(11) :initial-element -1) - (some #'minusp v)))) - nil nil) - -(deftest some.order.1 - (let ((i 0) x y) - (values - (some (progn (setf x (incf i)) #'null) - (progn (setf y (incf i)) '(a b c d))) - i x y)) - nil 2 1 2) - -(deftest some.order.2 - (let ((i 0) x y z) - (values - (some (progn (setf x (incf i)) #'eq) - (progn (setf y (incf i)) '(a b c d)) - (progn (setf z (incf i)) '(e f g h))) - i x y z)) - nil 3 1 2 3) - - -(deftest some.error.1 - (check-type-error #'(lambda (x) (some x '(a b c))) - (typef '(or symbol function))) - nil) - -(deftest some.error.4 - (check-type-error #'(lambda (x) (some #'null x)) #'sequencep) - nil) - -(deftest some.error.7 - (check-type-error #'(lambda (x) (some #'eql () x)) #'sequencep) - nil) - -(deftest some.error.8 - (signals-error (some) program-error) - t) - -(deftest some.error.9 - (signals-error (some #'null) program-error) - t) - -(deftest some.error.10 - (signals-error (locally (some 1 '(a b c)) t) type-error) - t) - -(deftest some.error.11 - (signals-error (some #'cons '(a b c)) program-error) - t) - -(deftest some.error.12 - (signals-error (some #'car '(a b c)) type-error) - t) - -(deftest some.error.13 - (signals-error (some #'cons '(a b c) '(b c d) '(c d e)) program-error) - t) - -(deftest some.error.14 - (signals-error (some #'null '(a b . c)) type-error) - t) - diff --git a/t/ansi-test/data-and-control-flow/t.lsp b/t/ansi-test/data-and-control-flow/t.lsp deleted file mode 100644 index c4759b4..0000000 --- a/t/ansi-test/data-and-control-flow/t.lsp +++ /dev/null @@ -1,24 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Oct 17 06:44:45 2002 -;;;; Contains: Tests of T - - - -(deftest t.1 - t t) - -(deftest t.2 - (not-mv (constantp t)) - nil) - -(deftest t.3 - (eqt t 't) - t) - -(deftest t.4 - (symbol-value t) - t) - -;;; Tests for use of T in case forms, as a stream designator, or as a class -;;; designator will be elsewhere diff --git a/t/ansi-test/data-and-control-flow/tagbody.lsp b/t/ansi-test/data-and-control-flow/tagbody.lsp deleted file mode 100644 index bed1155..0000000 --- a/t/ansi-test/data-and-control-flow/tagbody.lsp +++ /dev/null @@ -1,185 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Oct 12 13:27:22 2002 -;;;; Contains: Tests of TAGBODY - - - -(deftest tagbody.1 - (tagbody) - nil) - -(deftest tagbody.2 - (tagbody 'a) - nil) - -(deftest tagbody.3 - (tagbody (values)) - nil) - -(deftest tagbody.4 - (tagbody (values 1 2 3 4 5)) - nil) - -(deftest tagbody.5 - (let ((x 0)) - (values - (tagbody - (setq x 1) - (go a) - (setq x 2) - a) - x)) - nil 1) - -(deftest tagbody.6 - (let ((x 0)) - (tagbody - (setq x 1) - (go a) - b - (setq x 2) - (go c) - a - (setq x 3) - (go b) - c) - x) - 2) - -;;; Macroexpansion occurs after tag determination -(deftest tagbody.7 - (let ((x 0)) - (macrolet ((%m () 'a)) - (tagbody - (tagbody - (go a) - (%m) - (setq x 1)) - a )) - x) - 0) - -(deftest tagbody.8 - (let ((x 0)) - (tagbody - (flet ((%f (y) (setq x y) (go a))) - (%f 10)) - (setq x 1) - a) - x) - 10) - -;;; Tag names are in their own name space -(deftest tagbody.9 - (let (result) - (tagbody - (flet ((a (x) x)) - (setq result (a 10)) - (go a)) - a) - result) - 10) - -(deftest tagbody.10 - (let (result) - (tagbody - (block a - (setq result 10) - (go a)) - (setq result 20) - a) - result) - 10) - -(deftest tagbody.11 - (let (result) - (tagbody - (catch 'a - (setq result 10) - (go a)) - (setq result 20) - a) - result) - 10) - -(deftest tagbody.12 - (let (result) - (tagbody - (block a - (setq result 10) - (return-from a nil)) - (setq result 20) - a) - result) - 20) - -;;; Test that integers are accepted as go tags - -(deftest tagbody.13 - (block done - (tagbody - (go around) - 10 - (return-from done 'good) - around - (go 10))) - good) - -(deftest tagbody.14 - (block done - (tagbody - (go around) - -10 - (return-from done 'good) - around - (go -10))) - good) - -(deftest tagbody.15 - (block done - (tagbody - (go around) - #.(1+ most-positive-fixnum) - (return-from done 'good) - around - (go #.(1+ most-positive-fixnum)))) - good) - -(deftest tagbody.16 - (let* ((t1 (1+ most-positive-fixnum)) - (t2 (1+ most-positive-fixnum)) - (form `(block done - (tagbody - (go around) - ,t1 - (return-from done 'good) - around - (go ,t2))))) - (eval form)) - good) - -;;; Check that macros are not expanded before finding tags -;;; Test for issue TAGBODY-TAG-EXPANSION - -(deftest tagbody.17 - (block done - (tagbody - (macrolet ((foo () 'tag)) - (let (tag) - (tagbody - (go tag) - (foo) - (return-from done :bad)))) - tag - (return-from done :good))) - :good) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest tagbody.18 - (macrolet ((%m (z) z)) - (tagbody - (expand-in-current-env (%m :foo)))) - nil) diff --git a/t/ansi-test/data-and-control-flow/typecase.lsp b/t/ansi-test/data-and-control-flow/typecase.lsp deleted file mode 100644 index 0e6c467..0000000 --- a/t/ansi-test/data-and-control-flow/typecase.lsp +++ /dev/null @@ -1,182 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Oct 18 22:51:25 2002 -;;;; Contains: Tests for TYPECASE - - - -(deftest typecase.1 - (typecase 1 (integer 'a) (t 'b)) - a) - -(deftest typecase.2 - (typecase 1 (symbol 'a)) - nil) - -(deftest typecase.3 - (typecase 1 (symbol 'a) (t 'b)) - b) - -(deftest typecase.4 - (typecase 1 (t (values)))) - -(deftest typecase.5 - (typecase 1 (integer (values)) (t 'a))) - -(deftest typecase.6 - (typecase 1 (bit 'a) (integer 'b)) - a) - -(deftest typecase.7 - (typecase 1 (otherwise 'a)) - a) - -(deftest typecase.8 - (typecase 1 (t (values 'a 'b 'c))) - a b c) - -(deftest typecase.9 - (typecase 1 (integer (values 'a 'b 'c)) (t nil)) - a b c) - -(deftest typecase.10 - (let ((x 0)) - (values - (typecase 1 - (bit (incf x) 'a) - (integer (incf x 2) 'b) - (t (incf x 4) 'c)) - x)) - a 1) - -(deftest typecase.11 - (typecase 1 (otherwise 'a)) - a) - -(deftest typecase.12 - (typecase 1 (integer) (t 'a)) - nil) - -(deftest typecase.13 - (typecase 1 (symbol 'a) (t)) - nil) - -(deftest typecase.14 - (typecase 1 (symbol 'a) (otherwise)) - nil) - -(deftest typecase.15 - (typecase 'a - (number 'bad) - (#.(find-class 'symbol nil) 'good)) - good) - -(deftest typecase.16 - (block done - (tagbody - (typecase 'a (symbol (go 10) - 10 - (return-from done 'bad))) - 10 - (return-from done 'good))) - good) - -(deftest typecase.17 - (block done - (tagbody - (typecase 'a - (integer 'bad) - (t (go 10) - 10 - (return-from done 'bad))) - 10 - (return-from done 'good))) - good) - -(deftest typecase.18 - (loop for x in '(a 1 1.4 "c") - collect (typecase x - (t :good) - (otherwise :bad))) - (:good :good :good :good)) - -;;; A randomized test - -(deftest typecase.19 - (let* ((u (coerce *universe* 'vector)) - (len1 (length u)) - (types (coerce *cl-all-type-symbols* 'vector)) - (len2 (length types))) - (loop - for n = (random 10) - for my-types = (loop repeat n collect (elt types (random len2))) - for val = (elt u (random len1)) - for i = (position val my-types :test #'typep) - for form = `(typecase ',val - ,@(loop for i from 0 for type in my-types collect `(,type ,i)) - (otherwise nil)) - for j = (eval form) - repeat 1000 - unless (eql i j) - collect (list n my-types val i form j))) - nil) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest typecase.20 - (macrolet - ((%m (z) z)) - (typecase (expand-in-current-env (%m 2)) - ((integer 0 1) :bad1) - ((integer 2 10) :good) - (t :bad2))) - :good) - -(deftest typecase.21 - (macrolet - ((%m (z) z)) - (typecase 2 - ((integer 0 1) (expand-in-current-env (%m :bad1))) - ((integer 2 10) (expand-in-current-env (%m :good))) - (t (expand-in-current-env (%m :bad2))))) - :good) - -(deftest typecase.22 - (macrolet - ((%m (z) z)) - (typecase - (expand-in-current-env (%m :foo)) - (integer :bad1) - (keyword :good) - (symbol :bad2))) - :good) - -(deftest typecase.23 - (macrolet - ((%m (z) z)) - (typecase :foo - (integer (expand-in-current-env (%m :bad1))) - (keyword (expand-in-current-env (%m :good))) - (symbol (expand-in-current-env (%m :bad2))))) - :good) - -;;; Error cases - -(deftest typecase.error.1 - (signals-error (funcall (macro-function 'typecase)) program-error) - t) - -(deftest typecase.error.2 - (signals-error (funcall (macro-function 'typecase) - '(typecase t)) program-error) - t) - -(deftest typecase.error.3 - (signals-error (funcall (macro-function 'typecase) - '(typecase t) - nil nil) program-error) - t) - - - diff --git a/t/ansi-test/data-and-control-flow/unless.lsp b/t/ansi-test/data-and-control-flow/unless.lsp deleted file mode 100644 index 6f15776..0000000 --- a/t/ansi-test/data-and-control-flow/unless.lsp +++ /dev/null @@ -1,97 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Oct 18 19:39:34 2002 -;;;; Contains: Tests of UNLESS - - - -(deftest unless.1 - (unless t) - nil) - -(deftest unless.2 - (unless nil) - nil) - -(deftest unless.3 - (unless 'b 'a) - nil) - -(deftest unless.4 - (unless nil 'a) - a) - -(deftest unless.5 (unless nil (values))) - -(deftest unless.6 - (unless nil (values 1 2 3 4)) - 1 2 3 4) - -(deftest unless.7 - (unless 1 (values)) - nil) - -(deftest unless.8 - (unless #() (values 1 2 3 4)) - nil) - -(deftest unless.9 - (let ((x 0)) - (values - (unless nil - (incf x) - 'a) - x)) - a 1) - -;;; No implicit tagbody -(deftest unless.10 - (block done - (tagbody - (unless nil - (go 10) - 10 - (return-from done 'bad)) - 10 - (return-from done 'good))) - good) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest unless.11 - (macrolet - ((%m (z) z)) - (unless (expand-in-current-env (%m nil)) :good)) - :good) - -(deftest unless.12 - (macrolet - ((%m (z) z)) - (unless (expand-in-current-env (%m t)) :bad)) - nil) - -(deftest unless.13 - (macrolet - ((%m (z) z)) - (let ((x 1) (p nil)) - (values - (unless p (expand-in-current-env (%m (incf x)))) - x))) - 2 2) - -(deftest unless.error.1 - (signals-error (funcall (macro-function 'unless)) program-error) - t) - -(deftest unless.error.2 - (signals-error (funcall (macro-function 'unless) - '(unless t)) - program-error) - t) - -(deftest unless.error.3 - (signals-error (funcall (macro-function 'unless) - '(unless t) nil nil) - program-error) - t) diff --git a/t/ansi-test/data-and-control-flow/unwind-protect.lsp b/t/ansi-test/data-and-control-flow/unwind-protect.lsp deleted file mode 100644 index 1825dc9..0000000 --- a/t/ansi-test/data-and-control-flow/unwind-protect.lsp +++ /dev/null @@ -1,131 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Oct 12 14:41:16 2002 -;;;; Contains: Tests of UNWIND-PROTECT - - - -(deftest unwind-protect.1 - (let ((x nil)) - (unwind-protect - (push 1 x) - (incf (car x)))) - (2)) - -(deftest unwind-protect.2 - (let ((x nil)) - (block foo - (unwind-protect - (progn (push 1 x) (return-from foo x)) - (incf (car x))))) - (2)) - -(deftest unwind-protect.3 - (let ((x nil)) - (tagbody - (unwind-protect - (progn (push 1 x) (go done)) - (incf (car x))) - done) - x) - (2)) - -(deftest unwind-protect.4 - (let ((x nil)) - (catch 'done - (unwind-protect - (progn (push 1 x) (throw 'done x)) - (incf (car x))))) - (2)) - -(deftest unwind-protect.5 - (let ((x nil)) - (ignore-errors - (unwind-protect - (progn (push 1 x) (error "Boo!")) - (incf (car x)))) - x) - (2)) - -(deftest unwind-protect.6 - (let ((x nil)) - (block done - (flet ((%f () (return-from done nil))) - (unwind-protect (%f) - (push 'a x)))) - x) - (a)) - -(deftest unwind-protect.7 - (let ((x nil)) - (block done - (flet ((%f () (return-from done nil))) - (unwind-protect - (unwind-protect (%f) - (push 'b x)) - (push 'a x)))) - x) - (a b)) - -(deftest unwind-protect.8 - (let ((x nil)) - (block done - (unwind-protect - (flet ((%f () (return-from done nil))) - (unwind-protect - (unwind-protect (%f) - (push 'b x)) - (push 'a x))) - (push 'c x))) - x) - (c a b)) - -(deftest unwind-protect.9 - (let ((x nil)) - (handler-case - (flet ((%f () (error 'type-error :datum 'foo :expected-type nil))) - (unwind-protect (handler-case (%f)) - (push 'a x))) - (type-error () x))) - (a)) - -;;; No implicit tagbody -(deftest unwind-protect.10 - (block done - (tagbody - (unwind-protect - 'foo - (go 10) - 10 - (return-from done 'bad)) - 10 - (return-from done 'good))) - good) - -;;; Executes all forms of the implicit progn -(deftest unwind-protect.11 - (let ((x nil) (y nil)) - (values - (block nil - (unwind-protect (return 'a) - (setf y 'c) - (setf x 'b))) - x y)) - a b c) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest unwind-protect.12 - (macrolet - ((%m (z) z)) - (unwind-protect (expand-in-current-env (%m :good)) :bad)) - :good) - -(deftest unwind-protect.13 - (macrolet - ((%m (z) z)) - (unwind-protect :good (expand-in-current-env (%m :bad)))) - :good) - - diff --git a/t/ansi-test/data-and-control-flow/values-list.lsp b/t/ansi-test/data-and-control-flow/values-list.lsp deleted file mode 100644 index 8917912..0000000 --- a/t/ansi-test/data-and-control-flow/values-list.lsp +++ /dev/null @@ -1,48 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Jan 13 16:53:39 2003 -;;;; Contains: Tests for VALUES-LIST - - - -(deftest values-list.error.1 - (signals-error (values-list) program-error) - t) - -(deftest values-list.error.2 - (signals-error (values-list nil nil) program-error) - t) - -(deftest values-list.error.3 - (check-type-error #'values-list #'list) - nil) - -(deftest values-list.error.4 - (signals-error (values-list '(a b c . d)) type-error) - t) - -(deftest values-list.1 - (values-list nil)) - -(deftest values-list.2 - (values-list '(1)) - 1) - -(deftest values-list.3 - (values-list '(1 2)) - 1 2) - -(deftest values-list.4 - (values-list '(a b c d e f g h i j)) - a b c d e f g h i j) - -(deftest values-list.5 - (let ((x (loop for i from 1 to (min 1000 - (1- call-arguments-limit) - (1- multiple-values-limit)) - collect i))) - (equalt x - (multiple-value-list (values-list x)))) - t) - - diff --git a/t/ansi-test/data-and-control-flow/values.lsp b/t/ansi-test/data-and-control-flow/values.lsp deleted file mode 100644 index 5d1c3ed..0000000 --- a/t/ansi-test/data-and-control-flow/values.lsp +++ /dev/null @@ -1,76 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Oct 19 08:18:50 2002 -;;;; Contains: Tests of VALUES - - - -(deftest values.0 - (values)) - -(deftest values.1 - (values 1) - 1) - -(deftest values.2 - (values 1 2) - 1 2) - -(deftest values.3 - (values 1 2 3) - 1 2 3) - -(deftest values.4 - (values 1 2 3 4) - 1 2 3 4) - -(deftest values.10 - (values 1 2 3 4 5 6 7 8 9 10) - 1 2 3 4 5 6 7 8 9 10) - -(deftest values.15 - (values 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15) - 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15) - -(deftest values.19 - (values 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19) - 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19) - -(deftest values.20 - (let ((a t) (b t) (c t) (d t) (e t) (f t)) - (setf (values a (values b c) (values d) (values e f)) (values 0 1 2 3 4 5 6)) - (list a b c d e f)) - (0 1 nil 2 3 nil)) - -(deftest values.21 - (let (a b c d e f) - (setf (values a (values b c) (values d) (values e f)) (values 0 1 2 3 4 5 6))) - 0 1 2 3) - -(deftest values.A - (values (values 1 2) (values 3 4 5) (values) (values 10)) - 1 3 nil 10) - -(deftest values.B - (funcall #'values 1 2 3 4) - 1 2 3 4) - -(deftest values.C - (let ((x (loop for i from 1 to (min 1000 - (1- call-arguments-limit) - (1- multiple-values-limit)) - collect i))) - (equalt x - (multiple-value-list (apply #'values x)))) - t) - -(deftest values.order.1 - (let ((i 0) a b c) - (values (multiple-value-list - (values (setf a (incf i)) (setf b (incf i)) (setf c (incf i)))) - i a b c)) - (1 2 3) 3 1 2 3) - -(deftest values.order.2 - ((lambda (a) (lcm (values a (setq a 1)))) 10) - 10) diff --git a/t/ansi-test/data-and-control-flow/when.lsp b/t/ansi-test/data-and-control-flow/when.lsp deleted file mode 100644 index 20ef2f4..0000000 --- a/t/ansi-test/data-and-control-flow/when.lsp +++ /dev/null @@ -1,87 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Oct 18 19:36:57 2002 -;;;; Contains: Tests of WHEN - - - -(deftest when.1 - (when t) - nil) - -(deftest when.2 - (when nil 'a) - nil) - -(deftest when.3 (when t (values))) - -(deftest when.4 - (when t (values 'a 'b 'c 'd)) - a b c d) - -(deftest when.5 - (when nil (values)) - nil) - -(deftest when.6 - (when nil (values 'a 'b 'c 'd)) - nil) - -(deftest when.7 - (let ((x 0)) - (values - (when t (incf x) 'a) - x)) - a 1) - -;;; No implicit tagbody -(deftest when.8 - (block done - (tagbody - (when t - (go 10) - 10 - (return-from done 'bad)) - 10 - (return-from done 'good))) - good) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest when.9 - (macrolet - ((%m (z) z)) - (when (expand-in-current-env (%m t)) :good)) - :good) - -(deftest when.10 - (macrolet - ((%m (z) z)) - (when (expand-in-current-env (%m nil)) :bad)) - nil) - -(deftest when.11 - (macrolet - ((%m (z) z)) - (let ((x t)) - (values (when x (expand-in-current-env (%m (setf x 'foo)))) x))) - foo foo) - -;;; Error tests - -(deftest when.error.1 - (signals-error (funcall (macro-function 'when)) program-error) - t) - -(deftest when.error.2 - (signals-error (funcall (macro-function 'when) - '(when t)) - program-error) - t) - -(deftest when.error.3 - (signals-error (funcall (macro-function 'when) - '(when t) nil nil) - program-error) - t) diff --git a/t/ansi-test/doc/ilc2005-slides.pdf b/t/ansi-test/doc/ilc2005-slides.pdf deleted file mode 100644 index f8ab519..0000000 Binary files a/t/ansi-test/doc/ilc2005-slides.pdf and /dev/null differ diff --git a/t/ansi-test/doc/ilc2005.pdf b/t/ansi-test/doc/ilc2005.pdf deleted file mode 100644 index f877632..0000000 Binary files a/t/ansi-test/doc/ilc2005.pdf and /dev/null differ diff --git a/t/ansi-test/doc/ilc2005.tex b/t/ansi-test/doc/ilc2005.tex deleted file mode 100644 index 299e7cb..0000000 --- a/t/ansi-test/doc/ilc2005.tex +++ /dev/null @@ -1,631 +0,0 @@ -\documentclass[11pt]{article} -% \setlength{\oddsidemargin}{0in} -% \setlength{\evensidemargin}{0in} -% \setlength{\footskip}{1in} -% \setlength{\textwidth}{6.5in} - -\usepackage[letterpaper,textwidth=6.7in,textheight=8.7in]{geometry} -\usepackage{graphics} -\usepackage{url} -\usepackage{times} -%\usepackage[british]{babel} -% \usepackage{theorem} -\setlength{\topmargin}{.35in} -\newtheorem{theorem}{Theorem} - -\pagestyle{empty} - -\begin{document} -\title{The GCL ANSI Common Lisp Test Suite} -\author{Paul F. Dietz\footnote{Motorola Global Software Group, 1303 -E. Algonquin Road, Annex 2, Schaumburg, IL 60196. paul.f.dietz@motorola.com}} -\date{} -\maketitle -\thispagestyle{empty} - -\begin{abstract} -I describe the conformance test suite for ANSI Common Lisp distributed -as part of GNU Common Lisp (GCL). The test suite includes more than -20,000 individual tests, as well as random test generators for -exercising specific parts of Common Lisp implementations, and has -revealed many conformance bugs in all implementations on -which it has been run. -\end{abstract} - -\section{Introduction} - -One of the strengths of Common Lisp is the existence of a large, -detailed standard specifying the behavior of conforming -implementations. The value of the standard to users is enhanced when -they can be confident that implementations that purport to conform -actually do. - -In the 1990s I found substantial numbers of conformance bugs in many -Lisp implementations. As a result, I decided to build a -comprehensive functional test suite for Common Lisp. The goals of the -effort were, in no particular order: - -\begin{itemize} -\item To thoroughly familiarize myself with the standard. -\item To provide a tool to locate conformance problems in CL -implementations, both commercial and free. -\item To enable implementors to improve CL implementations while - maintaining conformance. -\item To explore the standard itself for ambiguities, unintended - consequences, and other problems. -\item To explore different testing strategies. -\end{itemize} - -I deliberately did not design the test suite to measure or rank -conformance of Lisp implementations. For this reason, I will not here -report the overall score of any implementation. - -I decided to locate the test suite in the GCL development tree for two -reasons. First, its development team had a goal of making GCL more -ANSI compliant, and tests would assist there. Secondly, the GCL CVS -tree is easily publicly accessible\footnote{See -\url{http://savannah.gnu.org/projects/gcl/}}, so any developers or users of -Common Lisp implementations would have easy access to it. - -The test suite was constructed over the period from 1998 to 2005, with -most of the work done in 2002 to 2004. -As of 24 May 2005, the test suite contains over 20,000 tests. - -The test suite is based on a version of the ANSI Common Lisp -specification (ANSI/INCITS 226-1994, formerly ANSI X3.226-1994) that -was made publicly available by Harlequin (now LispWorks) in -hyperlinked form in 1996 \cite{X3J13:94}. - -Table \ref{lispimpltab} contains a list of Lisp implementations on -which I am aware the test suite has been run. - -\begin{table} -\begin{center} -\begin{tabular}{lr} -Implementation & Hardware Platforms \\ \hline -GNU Common Lisp & All debian platforms \\ -GNU CLISP & x86 \\ -CMUCL & x86, Sparc \\ -SBCL & x86, x86-64, Sparc, MIPS, Alpha, PowerPC \\ -Allegro CL (6.2, 7) & x86, Sparc, PowerPC \\ -LispWorks (4.3) & x86 \\ -OpenMCL & PowerPC \\ -ABCL & x86 (JVM) \\ -ECL & x86 \\ -\end{tabular} -\end{center} -\caption{\label{lispimpltab} Implementations Tested} -\end{table} - -\section {Infrastructure} - -The test suite uses Waters' RT package \cite{Waters:91a}. This -package provides a simple interface for defining tests. In its -original form, tests are defined with a name (typically a symbol -or string), a form to be evaluated, and zero or more expected -values. The test passes if the form evaluates to the specified -number of values, and those values are as specified. See figure -\ref{examplefig} for an example from the test suite: - -\begin{figure} -\begin{verbatim} - (deftest let.17 - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) ;; lexical binding - (let ((y x)) - (declare (special x)) ;; free declaration - y))) - :good) -\end{verbatim} -\caption{\label{examplefig} Example of a test} -\end{figure} - -As the test suite evolved RT was extended. Features added include: -\begin{itemize} - \item Error conditions raised by tests may be trapped. - \item Tests may optionally be executed by wrapping the form to be -evaluated in a lambda form, compiling it, and calling the compiled -code. This makes sense for testing Lisp itself, but would not be -useful for testing Lisp applications. - \item A subset of the tests can be run repeatedly, in random order, a -style of testing called \emph{Repeated Random Regression} by Kaner, -Bond and McGee \cite{KanerBondMcGee:04}\footnote{This was previously -called `Extended Random Regression'; McGee renamed it to avoid the -confusing acronym.} - \item Notes may be attached to tests, and these notes used to turn off -groups of tests. - -\item Tests can be marked as being expected to fail. Unexpected - failures are reported separately. -\end{itemize} - -\section {Functional Tests} - -The bulk of the test suite consists of functional tests derived from -specific parts of the ANSI specification. Typically, for each -standardized operator there is a file \emph{operator}.lsp containing -tests for that operator. This provides a crude form of traceability. -There are exceptions to this naming convention, and many tests that -test more than one operator are located somewhat arbitrarily. -Table \ref{tab:testsize} shows the number and size of tests for each -section of the ANSI specification. - -\begin{table} -\begin{center} -\begin{tabular}{|l|r|r|} -\hline -Section of CLHS & Size (Bytes) & Number of Tests \\ -\hline \hline -Arrays & 212623 & 1109 \\ -Characters & 38655 & 256 \\ -Conditions & 71250 & 658 \\ -Cons & 264208 & 1816 \\ -Data \& Control Flow & 185973 & 1217 \\ -Environment & 51110 & 206 \\ -Eval/Compile & 41638 & 234 \\ -Files & 26375 & 87 \\ -Hash Tables & 38752 & 158 \\ -Iteration & 98339 & 767 \\ -Numbers & 290991 & 1382 \\ -Objects & 283549 & 774 \\ -Packages & 162203 & 493 \\ -Pathnames & 47100 & 215 \\ -Printer & 454314 & 2364 \\ -Reader & 101662 & 663 \\ -Sequences & 562210 & 3219 \\ -Streams & 165956 & 796 \\ -Strings & 83982 & 415 \\ -Structures & 46271 & 1366 \\ -Symbols & 106063 & 1141 \\ -System Construction & 16909 & 77 \\ -Types & 104804 & 599 \\ -Misc & 291883 & 679 \\ \hline -Infrastructure & 115090 & \\ -Random Testers & 190575 & \\ -\hline -Total & 4052485 & 20702 \\ -\hline -\end{tabular} -\end{center} - -\caption{\label{tab:testsize} Sizes of Parts of the Test Suite} -\end{table} - -Individual tests vary widely in power. Some are as simple as a -test that {\tt (CAR NIL)} is {\tt NIL}. Others are more involved. -For example, {\tt TYPES.9} checks that {\tt SUBTYPEP} is transitive -on a large collection of built-in types. - -The time required to run the test suite depends on the implementation, -but it is not excessive on modern hardware. SBCL 0.9.0.41 on a -machine with 2 GHz 64 bit AMD processor, for example, runs the test -suite in under eight minutes. - -Error tests have been written where the error behavior is specified by -the standard. This includes specifications in the `Exceptional -Situations' sections for operator dictionary entries, as well as tests -for calls to functions with too few or too many arguments, keyword -parameter errors, and violations of the first paragraph of CLHS -section 14.1.2.3. When type errors are specified or when the CLHS -requires that some operator have a well-defined meaning on any Lisp -value, the tests iterate over a set of precomputed Lisp objects -called the `universe' that contains representatives of all -standardized Lisp classes. In some cases a subset of this universe is -used, for efficiency reasons. - -There are some rules that perform random input testing. This testing -technique is described more fully in the next section. Other tests -are themselves deterministic, but are the product of one of the -suite's high volume random test harnesses. The `Misc' entry in table -\ref{tab:testsize} refers to these randomly generated tests. Each of -these tests caused a failure in at least one implementation. - -Inevitably, bugs have appeared in the test suite. Running the test -suite on multiple implementations (see table \ref{lispimpltab}) -exposes most problems. If a test fails in most of them, it is likely -(but not certain) that the test is flawed. Feedback from implementors -has also been invaluable, and is deeply appreciated. In some cases, -when it has not been possible to agree on the proper interpretation -of the standard, I've added a note to the set of disputed tests so -they can be disabled as a group. This is in keeping with the purpose -of the test suite -- to help implementors, not judge implementations. - - -\section {Random Testing} - -Random testing (more properly, random-input testing) is a standard -technique in the testing of hardware systems. However, it has been the -subject of controversy in the software testing community for more than -two decades. Myers \cite{Myers:79} called it ``Probably the poorest -... methodology of all''. This assessment presumes that the cost of -executing tests and checking their results for validity dominates the -cost of constructing the tests. If test inputs can be constructed and -results checked automatically, it may be very cost-effective to -generate and execute many lower quality tests. Kaner et -al. call this High Volume Automated Testing \cite{KanerBondMcGee:04}. - -Duran and Ntafos \cite{DuranNtafos:81} report favorably on the ability -of random testing to find relatively subtle bugs without a great deal -of effort. Random testing has been used to test Unix utilities -(so-called `fuzz testing') \cite{MillerFredriksenSo:90}, database -systems \cite{Slutz:98}, and C compilers \cite{McKeeman:98,Lindig:05,Faigon:05}. -Bach and Schroeder \cite{BachSchroeder:04} report that random input -testing compares well with the ability of the popular All-Pairs -testing technique at actually finding bugs. - -Random input testing provides a powerful means of testing algebraic -properties of systems. Common Lisp has many instances where such -properties can be checked, and the test suite tests many of them. -Random testing is used to test numeric operators, type operators, -the compiler, some sequence operators, and the readability of -objects printed in `print readably' mode. - -One criticism of random testing is its irreproducibility. -With care, this needn't be a problem. If a random failure -is sufficiently frequent, it can be reproduced with high -probability by simply running a randomized test again. Tests -can also be designed so that on failure, they print sufficient -information so that a non-randomized test can be constructed -exercising the bug. Most of the randomized tests in the test -suite have this property. - -\subsection {Compiler Tests} -\label{sec:compilertests} - -Efficiency of compiled code has long been one of Common Lisp's -strengths. Implementations have been touted as in some cases -approaching the speed of statically typed languages. Achieving this -efficiency places strong demands on Lisp compilers. A sufficiently -smart compiler needs a sufficiently smart test suite. - -Compilers (and Lisp compilers in particular) are an ideal target for -random input testing. Inputs may have many parts that interact in -the compiler in unpredictable ways. Because the language has a -well-defined semantics, it is easy to generate related, but different, -forms that should yield the same result (thereby providing a test -oracle.) - -The Random Tester performs the following steps. For some input -parameters $n$ and $s$ (each positive integers): -\begin{enumerate} - \item Produce a list of $n$ symbols that will be the parameters - of a lambda expression. These parameters will have integer - values. - \item Produce a list of $n$ finite integer subrange types. These - will be the types of the lambda parameters. The endpoints of - these types are not uniformly distributed, but instead follow - an approximately exponential distribution, preferring small - integers over larger ones. Integers close in absolute value - to integer powers of 2 are also overrepresented. - \item Generate a random conforming Lisp form of `size' approximately $s$ - containing (mostly) integer-valued forms. The parameters from - step 1 occur as free variables. - \item From this form, construct two lambda forms. In the first, - the lambda parameters are declared to have their integer - types, and random {\tt OPTIMIZE} settings are included. In the - second, a different set of {\tt OPTIMIZE} settings is declared, and - all the standardized Lisp functions that occur in the form - are declared {\tt NOTINLINE}. The goal here is to attempt to make - optimizations work differently on the two forms. - \item For each lambda form, its value on each set of inputs is - computed. This is done either by compiling the lambda form - and calling it on the inputs, or by evaling forms in which - the lambda form is the {\tt CAR} and the argument list the - {\tt CDR}. - \item A failure occurs if any call to the compiler or evaluator - signals an error, or if the two lambda forms yield different - results on any of the inputs. -\end{enumerate} - -This procedure very quickly -- within seconds -- found failures in -every Lisp implementation on which it was tried. Failures included -assertion failures in the compiler, type errors, differing return -values, code that caused segmentation faults, and in some cases code -that crashed the Lisps entirely. Most of the 679 `Misc' tests in -table \ref{tab:testsize} were produced by this tester; each represents -a failure in one or more implementations. - -Generating failing tests was easy, but minimizing them was tedious -and time consuming. I therefore wrote a pruner that repeatedly tries -to simplify a failing random form, replacing integer-valued subforms -with simpler ones, until no substitution preserving failure -exists. In most cases, this greatly reduced the size of the failing -form. Others have previously observed that bug-exposing random inputs -can often be automatically simplified -\cite{HildZeller:02a,McKeeman:98}. The desire to be able to -automatically simplify the failing forms constrained the tester; -I will discuss this problem later in section \ref{sec:future}. - -\begin{table} -\begin{center} -\begin{tabular}{|l|l|l|} -\hline Sourceforge Bug \# & Type of Bug & Description \\ -\hline -813119 & C & Simplification of conditional forms \\ -842910 & C & Simplification of conditional forms \\ -842912 & R & Incorrect generated code \\ -842913 & R & Incorrect generated code \\ -858011 & C & Compiler didn't handle implicit block in {\tt FLET} \\ -858658 & R & Incorrect code for {\tt UNWIND-PROTECT} and multiple values \\ -860052 & C & Involving {\tt RETURN-FROM} and {\tt MULTIPLE-VALUE-PROG1}. \\ -864220 & C & Integer tags in tagbody forms. \\ -864479 & C & Compiler bug in stack analysis. \\ -866282 & V & Incorrect value computed due to erroneous side effect \\ -& & analysis in compiler on special variables \\ -874859 & R & Stack mixup causing catch tag to be returned. \\ -889037 & V & Bug involving nested {\tt LABELS}, {\tt UNWIND-PROTECT}, -{\tt DOTIMES} forms. \\ -890138 & R & Incorrect bytecodes for {\tt CASE}, crashing the Lisp. \\ -1167991 & C & Simplification of conditional forms. \\ \hline -\end{tabular} - -Legend: -\begin{tabular}{ll} -C & Condition thrown by the compiler (assert or type check failure.) \\ -R & Condition thrown at runtime (incorrectly compiled code). \\ -V & Incorrect value returned by compiled code. \\ -\end{tabular} -\end{center} -\caption{\label{clispbugs} Compiler bugs found in GNU CLISP by Random Tester} -\end{table} - -Table \ref{clispbugs} contains a list of the fourteen compiler bugs -detected by the random tester in GNU CLISP. Roughly 200 million -iterations of the random tester were executed to find these bugs, -using a single 1.2 GHz Athlon XP+ workstation running intermittently -over a period of months. All these bugs have been fixed (in CVS) and -CLISP now fails only when the random forms produce bignum values that -exceed CLISP's internal limit. - -The greatest obstacle to using the random tester is the presence of -unfixed, high probability bugs. If an implementation has such a bug, -it will generate many useless hits that will conceal -lower probability bugs. - -\subsection {Types and Compilation} - -Type inference and type-based specialization of built-in operators is a -vital part of any high performance Lisp compiler for stock hardware, -so it makes sense to focus testing effort on it. The test suite -contains a facility for generating random inputs for operators and -compiling them with appropriate randomly generated type annotations, -then checking if the result matches that from an unoptimized version -of the operator. - -As an example, the operator {\tt ISQRT} had this bug in one commercial -implementation: -\begin{verbatim} - (compile nil '(lambda (x) (declare (type (member 4 -1) x) - (optimize speed (safety 1))) - (isqrt x))) - ==> Error: -1 is illegal argument to isqrt -\end{verbatim} -Amusingly, the bug occurs only when the negative integer is the second -item in the {\tt MEMBER} list. The test that found this bug is -succinctly defined via a macro: -\begin{verbatim} - (def-type-prop-test isqrt 'isqrt '((integer 0)) 1) -\end{verbatim} -The function to be compiled can be generated in such a way that it stores -the result value into an array specialized to a type that contains -the expected value. This is intended to allow the result value to -remain unboxed. - -The general random testing framework of section -\ref{sec:compilertests} is also useful for testing type-based compiler -optimizations, with two drawbacks: it currently only handles integer -operators, and it is less efficient than the more focused tests. -Even so, it was used to improve unboxed arithmetic in several -implementations (SBCL, CMUCL, GCL, ABCL). - -\subsection {{\tt SUBTYPEP} Testing} - -The test suite uses the algebraic properties of the {\tt SUBTYPEP} -function in both deterministic and randomized tests. For example, -if {\tt T1} is known to be a subtype of {\tt T2}, we can also check: -\begin{verbatim} - (subtypep '(not t2) '(not t1)) - (subtypep '(and t1 (not t2)) nil) - (subtypep '(or (not t1) t2) t) -\end{verbatim} - -The generator/pruner approach of the compiler random tester was -applied to testing {\tt SUBTYPEP}. Random types were generated and, -if one was a subtype of the other, the three alternative formulas -were also tested. If any return the two values (false, true), a -failure has been found. - -Christophe Rhodes used feedback from this tester to fix logic and -performance bugs in SBCL's {\tt SUBTYPEP} implementation. The -handling of {\tt CONS} types is particularly interesting, since -deciding the subtype relationship in the presence of cons types is -NP-hard. At least one implementation's {\tt SUBTYPEP} will run wild -on moderately complicated cons types, consuming large amounts of -memory before aborting. - -\subsection {Repeated Random Regression} - -As mentioned earlier, RRR is a technique for executing tests in an -extended random sequence, in order to flush out interaction bugs and -slow corruption problems. As an experiment, RT was extended to -support RRR on subsets of the tests. The main result was to find many -unwanted dependencies in the test suite, particularly among the -package tests. These dependencies had not surfaced when the tests had -been run in their normal order. - -After fixing these problems, RRR did find one CLOS bug in CLISP, -involving interaction between generic functions and class -redefinitions. The bug was localized by bisecting the set of tests -being run until a minimal core had been found, then minimizing the -sequence of invocations of those tests. If more bugs of this kind are -found it may be worthwhile to add a delta debugging -\cite{HildZeller:02a} facility to perform automatic test minimization. - -In Lisps that support preemptively scheduled threads, it would be -interesting to use RRR with subsets of the tests that lack global side -effects. The tests would be run in two or more threads at once in -order to find thread safety problems. - -\section {Issues with the ANSI Common Lisp Specification} - -Building the test suite involved going over the standard in detail. -Many points were unclear, ambiguous, or contradictory; some -parts of the standard proved difficult to test in a portable -way. This section describes some of these findings. - -See `Proposed ANSI Revisions and Clarifications' on -\url{http://www.cliki.net/} for a more complete list that includes -issues arising from the test suite. - -\subsection {Testability} - -Some parts of the standard proved difficult to test in a completely -conforming way. The specification of pathnames, for example, was -difficult to test. The suite has assumed that UNIX-like filenames -are legal as physical pathnames. - -Floating point operators presented problems. The standard does not -specify the accuracy of floating point computations, even if it -does specify a minimum precision for each of the standardized float -types. \footnote{The standard does specify a feature indicating -the implementation purports to conform to the IEEE Standard for Binary -Floating Point Arithmetic (ANSI/IEEE Std 754-1985); this suite -does not test this.} Some implementations have accuracy that varies -depending on the details of compilation; in particular, boxed values -may be constrained to 64 bits while unboxed values in machine -registers may have additional `hidden' bits. These differences -make differential testing challenging. - -The Objects chapter contains interfaces that are intended to be used -with the Metaobject Protocol (MOP). Since the MOP is not part of the -standard, some of these cannot be tested. For example, there is -apparently no conforming way to obtain an instance of class {\tt -METHOD-COMBINATION}, or to produce any subclass of {\tt -GENERIC-FUNCTION} except for {\tt STANDARD-GENERIC-FUNCTION}. - -\subsection {Unintended Consequences} - -There seem to be many issues associated with Common Lisp's type -system. One example is the {\tt TYPE-OF} function. According -to the standard, this function has the property that -\begin{quote} - For any object that is an element of some built-in type: [\ldots] - the type returned is a recognizable subtype of that built-in type. -\end{quote} -A \emph{built-in} type is defined to be -\begin{quote} - built-in type {\it n}. one of the types in Figure 4-2. -\end{quote} -Figure 4-2 of the standard contains {\tt UNSIGNED-BYTE}, the type of -nonnegative integers. These constraints imply that {\tt TYPE-OF} can -never return {\tt FIXNUM} or {\tt BIGNUM} for any nonnegative integer, -since neither of those types is a subtype of {\tt UNSIGNED-BYTE}. - -A more serious set of problems involves {\tt -UPGRADED-ARRAY-ELEMENT-TYPE}. \footnote{I ignore the issue that, -strictly speaking, {\tt UPGRADED-ARRAY-ELEMENT-TYPE} is either an -identity function or is not computable, since as defined it must work -on {\tt SATISFIES} types.} This function (from types to types) is -specified to satisfy these two axioms for all types $T_1$ and $T_2$: -\begin{displaymath} - T_1 \subseteq UAET(T_1) -\end{displaymath} -and -\begin{displaymath} - T_1 \subseteq T_2 \Longrightarrow UAET(T_1) \subseteq UAET(T_2) -\end{displaymath} -A type $T_1$ is a \emph{specialized array element type} if $T_1 = UAET(T_1)$. -These axioms imply: -\begin{theorem} -If two types $T_1$ and $T_2$ are specialized -array element types, then so is $T_1 \cap T_2$. -\end{theorem} - -This theorem has a number of unpleasant consequences. For example, -if {\tt (UNSIGNED-BYTE 16)} and {\tt (SIGNED-BYTE 16)} are specialized -array element types, then so must be {\tt (UNSIGNED-BYTE 15)}. Even -worse, since {\tt BIT} and {\tt CHARACTER} are required to be -specialized array element types, and since they are disjoint, -then {\tt NIL}, the empty type, must also be a specialized array -element type. Topping all this off, note that -\begin{quote} - A string is a specialized vector whose elements are of type - character or a subtype of type character. (CLHS page for {\tt STRING}) -\end{quote} -Since {\tt NIL} is a subtype of {\tt CHARACTER}, a vector with -array element type {\tt NIL} is a string. It is -impossible for a conforming implementation to have only a -single representation of strings.\footnote{But since `nil strings' can -never be accessed, it's acceptable in non-safe code to just assume -string accesses are to some other string representation. The SBCL -implementors took advantage of this when using nil strings as a stepping -stone to Unicode support.} - -\section {Directions For Future Work} -\label{sec:future} - -The test suite still has a few areas that are not sufficiently tested. -Setf expanders need more testing, as do logical pathnames and file -compilation. Floating point functions are inadequately tested. As -mentioned earlier, it isn't clear what precision is expected of these -functions, but perhaps tests can be written that check if the error -is too large (in some sufficiently useful sense.) - -The random compiler tester, as implemented, is constrained to generate -forms that remain conforming as they are simplified. This limits the -use of certain operators that do not take the entire set of integers -as their arguments. For example, {\tt ISQRT} appears only in forms -like {\tt (ISQRT (ABS ...))}, and this pattern is preserved during -pruning. The forms also make very limited use of non-numeric types. - -More sophisticated random tester could avoid these limitations. One -approach would be to randomly generate trees from which Lisp forms -could be produced, but that also carry along information that would -enable pruning to be done more intelligently. Another approach would -be to check each pruned form for validity on the set of chosen random -inputs by doing a trial run with all operators replaced by special -versions that always check for illegal behaviors. I intend to explore -both options. - -The test suite has been written mostly as a `black box' suite (aside -from the randomly generated Misc tests). It would be interesting to -add more implementation knowledge, with tests that, while conforming, -will be more useful if the Lisp has been implemented in a particular -way. The type propagation tester is an example of this kind of `gray -box' testing. - -It would be interesting to determine the level of coverage achieved by -the test suite in various implementations. The coverage is probably -not very good, since the suite cannot contain tests of nonstandardized -error situations, but this should be confirmed, and compared against -the coverage obtained from running typical applications. Internal -coverage could also provide feedback for nudging the random tester -toward testing relatively untested parts of the compiler, say by using -an evolutionary algorithm on the parameters governing the construction -of random forms. - -\section {Acknowledgments} - -I would like to thank Camm Maguire, the head of the GCL development -team, for allowing the GCL ANSI test suite to be a part of that -project. I also would like to thank users of the test suite who have -returned feedback, including Camm, Christophe Rhodes, Sam Steingold, -Bruno Haible, Duane Rettig, Raymond Toy, Dan Barlow, Juan Jos\'{e} -Garc\'{i}a-Ripoll, Brian Mastenbrook and many others. - -\nocite{X3J13:94} -\nocite{McKeeman:98} -\nocite{DuranNtafos:81} -\nocite{KanerBondMcGee:04} -\nocite{Waters:91a} -\nocite{HildZeller:02a} -\nocite{BachSchroeder:04} -\nocite{Slutz:98} -\nocite{Lindig:05} -\nocite{Myers:79} - -\bibliography{lisp} -\bibliographystyle{plain} - -\end{document} diff --git a/t/ansi-test/doc/lisp.bib b/t/ansi-test/doc/lisp.bib deleted file mode 100644 index f916be5..0000000 --- a/t/ansi-test/doc/lisp.bib +++ /dev/null @@ -1,121 +0,0 @@ -@booklet{X3J13:94, - title = "Common {Lisp} {HyperSpec}", - author = "K. M. Pitman", - howpublished = "http://www.lispworks.com/reference/HyperSpec/Front/index.htm", - note = "A hyperlinked form of ANSI/INCITS document 226-1994. Translated in 1996 and updated in 2005." -} - -@article{McKeeman:98, - title = {Differential Testing for Software}, - author = {W. M. McKeeman}, - journal = {Digital Technical Journal}, - volume = {10}, - number = {1}, - year = {1998}, - pages = {100--107} -} - -@article{DuranNtafos:84, - title = {An Evaluation of Random Testing}, - author = {J. W. Duran and S. Ntafos}, - journal = {IEEE TSE}, - volume = {SE-10}, - year = {1984}, - pages = {438--444}, - publisher = {IEEE Press} -} - -@inproceedings{DuranNtafos:81, - author = {Joe W. Duran and Simeon Ntafos}, - title = {A report on random testing}, - booktitle = {ICSE '81: Proceedings of the 5th international conference on Software engineering}, - year = {1981}, - pages = {179--183}, - location = {San Diego, California, United States}, - publisher = {IEEE Press} - } - -@misc{KanerBondMcGee:04, - author={C. Kaner, W. P. Bond, P. McGee}, - title={High Volume Test Automation}, - howpublished={At http://testingeducation.org/a/hvta.pdf}, - year={2004}, - month={May}, - note={Keynote address presented at the International Conference on Software Testing, Analysis, and Review (STAR East), Orlando, FL} -} - -@article{Waters:91a, - author = {Richard C. Waters}, - title = {Supporting the regression testing of Lisp programs}, - journal = {SIGPLAN Lisp Pointers}, - volume = {IV}, - number = {2}, - year = {1991}, - pages = {47--53}, - publisher = {ACM Press}, - address = {New York, NY, USA}, - } - -@article{HildZeller:02a, - author={Andreas Zeller and Ralf Hildebrandt}, - title={Simplifying and Isolating Failure-Inducing Input}, - journal={IEEE Transactions on Software Engineering}, - volume={28}, - number={2}, - month={Feb}, - year={2002}, - pages={183--200}, -} - -@inproceedings {BachSchroeder:04, - author={James Bach and Patrick J. Schroeder}, - title={Pairwise Testing: A Best Practice That Isn't}, - booktitle={Proc. 22nd Annual Pacific Northwest Software Quality Conference}, - year={2004}, - note={See http://www.pnsqc.org/proceedings/pnsqc2004.pdf}, -} - -@inproceedings {Slutz:98, - author={Don R. Slutz}, - title={Massive Stochastic Testing of {SQL}}, - booktitle={Proc. 24th International Conference on Very Large Database Systems (VLDB'98)}, - year={1998}, - month={Aug.}, - pages={618-622}, -} - -@misc{Lindig:05, - author={Christian Lindig}, - title={Random Testing the Translation of {C} Function Calls}, - month={Feb.}, - year={2005}, - howpublished={At http://www.st.cs.uni-sb.de/~lindig/src/quest/quest.pdf}, -} - -@book{Myers:79, - author={Glenford J. Myers}, - title={The Art of Software Testing}, - publisher={John Wiley \& Sons}, - year={1979}, -} - -@article{MillerFredriksenSo:90, - author = {Barton P. Miller and Louis Fredriksen and Bryan So}, - title = {An empirical study of the reliability of UNIX utilities}, - journal = {Commun. ACM}, - volume = {33}, - number = {12}, - year = {1990}, - issn = {0001-0782}, - pages = {32--44}, - doi = {http://doi.acm.org/10.1145/96267.96279}, - publisher = {ACM Press}, - address = {New York, NY, USA}, - } - -@misc{Faigon:05, - author={Ariel Faigon}, - title={Testing for Zero Bugs}, - year={2005}, - howpublished={At http://www.yendor.com/testing/}, -} diff --git a/t/ansi-test/doit.lsp b/t/ansi-test/doit.lsp deleted file mode 100644 index b040ddf..0000000 --- a/t/ansi-test/doit.lsp +++ /dev/null @@ -1,90 +0,0 @@ -;;; Uncomment the next line to make MAKE-STRING and MAKE-SEQUENCE -;;; tests require that a missing :initial-element argument defaults -;;; to a single value, rather than leaving the string/sequence filled -;;; with arbitrary legal garbage. -;; (pushnew :ansi-tests-strict-initial-element *features*) - -#+allegro (setq *enclose-printer-errors* nil) - -(let ((wd (or *compile-file-pathname* *load-pathname*))) - (when wd - (setf *default-pathname-defaults* - (make-pathname :name nil :type nil :version nil :defaults wd)))) - -;;; Remove compiled files -(let* ((fn (compile-file-pathname "doit.lsp")) - (type (pathname-type fn)) - (dir-pathname (make-pathname :name :wild :type type)) - (subdir-pathname (make-pathname :directory '(:relative :wild) - :name :wild :type type)) - (format-pathname (make-pathname :directory '(:relative "printer" "format") - :name :wild :type type)) - (files (append (directory dir-pathname) - (directory subdir-pathname) - (directory format-pathname)))) - (assert type) - (assert (not (string-equal type "lsp"))) - (mapc #'delete-file files)) - -(load "gclload1.lsp") -(load "gclload2.lsp") - -#+allegro -(progn - (rt:disable-note :nil-vectors-are-strings) - (rt:disable-note :standardized-package-nicknames) - (rt:disable-note :type-of/strict-builtins) - (rt:disable-note :assume-no-simple-streams) - (rt:disable-note :assume-no-gray-streams)) - -#+lispworks -(progn - (rtest:disable-note :allow-nil-arrays) - (rtest:disable-note :nil-vectors-are-strings)) - -#+cmu -(progn - (setf ext:*ignore-extra-close-parentheses* nil) - (rt:disable-note :nil-vectors-are-strings)) - -#+gcl(si::use-fast-links nil) - -#+clisp -(progn ; see also clisp/utils/clispload.lsp - ;; Paul Dietz assumes a particular implementation for sequence functions - ;; (MAKE-SEQUENCE, CONCATENATE, MAP, ...) that rejects result types like - ;; (OR (VECTOR BIT) (VECTOR T)) because the element type is ambiguous. - ;; CLISP handles these ambiguous cases by computing the union type of the - ;; possible element types and therefore does not need to give an error. - (rt:disable-note :result-type-element-type-by-subtype) - ;; for the pretty-printer - (setq custom:*pprint-first-newline* nil) - ;; for READ-BYTE.ERROR.3 READ-BYTE.ERROR.4 READ-BYTE.ERROR.6 - ;; WRITE-BYTE.ERROR.3 OPEN.66 OPEN.OUTPUT.30 - (setq custom:*reopen-open-file* 'warn) - ;; For ENSURE-DIRECTORIES-EXIST.8 - (when (ext:probe-directory "scratch/") - (mapc #'delete-file (directory "scratch/*")) - (ext:delete-dir "scratch/")) - ;; A few tests call DISASSEMBLE. Make it work without user intervention. - (setf (ext:getenv "PAGER") "cat") - ;; One test exceeds the memory available in the SPVW_PURE_BLOCKS model. - (when (and (= (logand (sys::address-of nil) #xffffff) 0) ; SPVW_PURE_BLOCKS ? - (<= (integer-length most-positive-fixnum) 26)) ; 32-bit machine ? - ;; Inhibit the CHAR-INT.2 test. - (rt:rem-test 'cl-test:char-int.2))) - -(in-package :cl-test) - -;;; These two tests will misbehave if the tests are being -;;; invoked from a file that is being loaded, so remove them -(when *load-pathname* - (mapc #'regression-test:rem-test '(load-pathname.1 load-truename.1))) - -;; We could use uiop:chdir here, but what about new implementations? -(setf *default-pathname-defaults* (truename #P"sandbox/")) - -(time (regression-test:do-tests)) - -#+allegro (cl-user::exit) -#+(or cmu sbcl gcl armedbear clisp) (cl-user::quit) diff --git a/t/ansi-test/doit1.lsp b/t/ansi-test/doit1.lsp deleted file mode 100644 index 5884f7c..0000000 --- a/t/ansi-test/doit1.lsp +++ /dev/null @@ -1,18 +0,0 @@ -;;; Uncomment the next line to make MAKE-STRING and MAKE-SEQUENCE -;;; tests require that a missing :initial-element argument defaults -;;; to a single value, rather than leaving the string/sequence filled -;;; with arbitrary legal garbage. -;; (pushnew :ansi-tests-strict-initial-element *features*) - -#+allegro (setq *enclose-printer-errors* nil) - -;;; Remove compiled files -(let* ((fn (compile-file-pathname "doit.lsp")) - (type (pathname-type fn)) - (dir-pathname (make-pathname :name :wild :type type)) - (files (directory dir-pathname))) - (assert type) - (assert (not (string-equal type "lsp"))) - (mapc #'delete-file files)) - -(load "gclload1.lsp") diff --git a/t/ansi-test/doit2.lsp b/t/ansi-test/doit2.lsp deleted file mode 100644 index 70556c9..0000000 --- a/t/ansi-test/doit2.lsp +++ /dev/null @@ -1,27 +0,0 @@ -#+allegro -(progn - (rt:disable-note :nil-vectors-are-strings) - (rt:disable-note :standardized-package-nicknames) - (rt:disable-note :type-of/strict-builtins) - (rt:disable-note :assume-no-simple-streams) - (rt:disable-note :assume-no-gray-streams)) - -#+lispworks -(progn - (rtest:disable-note :allow-nil-arrays) - (rtest:disable-note :nil-vectors-are-strings)) - -(in-package :cl-test) - -;;; These two tests will misbehave if the tests are being -;;; invoked from a file that is being loaded, so remove them -(when *load-pathname* - (mapc #'regression-test:rem-test '(load-pathname.1 load-truename.1))) - -;; We could use uiop:chdir here, but what about new implementations? -(setf *default-pathname-defaults* (truename #P"sandbox/")) - -(time (regression-test:do-tests)) - -#+allegro (cl-user::exit) -#+(or cmu sbcl gcl armedbear) (cl-user::quit) diff --git a/t/ansi-test/environment/apropos-list.lsp b/t/ansi-test/environment/apropos-list.lsp deleted file mode 100644 index 8ca5254..0000000 --- a/t/ansi-test/environment/apropos-list.lsp +++ /dev/null @@ -1,101 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Dec 14 06:21:45 2004 -;;;; Contains: Tests of APROPOS-LIST - - - -(deftest apropos-list.1 - (let ((pkg "CL-TEST-APROPOS-LIST-PACKAGE")) - (safely-delete-package pkg) - (unwind-protect - (progn - (eval `(defpackage ,pkg (:use))) - (let* ((sym (intern "FOO" pkg))) - (loop for p in (list pkg (find-package pkg) (make-symbol pkg)) - nconc - (loop for string-designator in - '("F" "O" #\F #\O "" "FOO" "FO" - "OO" :|F| :|FO| :|FOO| :|O| :|OO|) - for result = (apropos-list string-designator p) - unless (equal result (list sym)) - collect (list string-designator result))))) - (safely-delete-package pkg))) - nil) - -(deftest apropos-list.2 - (let ((pkg #\A)) - (safely-delete-package pkg) - (unwind-protect - (progn - (eval `(defpackage ,pkg (:use))) - (let* ((sym (intern "FOO" pkg))) - (loop for string-designator in - '("F" "O" #\F #\O "" "FOO" "FO" - "OO" :|F| :|FO| :|FOO| :|O| :|OO|) - for result = (apropos-list string-designator pkg) - unless (equal result (list sym)) - collect (list string-designator result)))) - (safely-delete-package pkg))) - nil) - -(deftest apropos-list.3 - (let ((pkg "CL-TEST-APROPOS-LIST-PACKAGE")) - (safely-delete-package pkg) - (unwind-protect - (progn - (eval `(defpackage ,pkg (:use))) - (intern "FOO" pkg) - (apropos-list "X" pkg)) - (safely-delete-package pkg))) - nil) - -(deftest apropos-list.4 - (let ((sym :|X|) - (symbols (apropos-list "X"))) - (notnot (member sym symbols))) - t) - -(deftest apropos-list.5 - (let ((sym :|X|) - (symbols (apropos-list '#:|X|))) - (notnot (member sym symbols))) - t) - -(deftest apropos-list.6 - (let ((sym :|X|) - (symbols (apropos-list #\X))) - (notnot (member sym symbols))) - t) - -(deftest apropos-list.7 - (let ((sym :|X|) - (symbols (apropos-list "X" nil))) - (notnot (member sym symbols))) - t) - -(deftest apropos-list.8 - (let ((*package* (find-package "COMMON-LISP"))) - (macrolet - ((%m (z) z)) - (intersection '(car) - (apropos-list (expand-in-current-env (%m "CAR")))))) - (car)) - -(deftest apropos-list.9 - (macrolet - ((%m (z) z)) - (intersection '(car) - (apropos-list "CAR" (expand-in-current-env - (%m (find-package "COMMON-LISP")))))) - (car)) - -;;; Error tests - -(deftest apropos-list.error.1 - (signals-error (apropos-list) program-error) - t) - -(deftest apropos-list.error.2 - (signals-error (apropos-list "X" (find-package "CL-TEST") nil) program-error) - t) diff --git a/t/ansi-test/environment/apropos.lsp b/t/ansi-test/environment/apropos.lsp deleted file mode 100644 index 828e35e..0000000 --- a/t/ansi-test/environment/apropos.lsp +++ /dev/null @@ -1,101 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Dec 12 16:17:47 2004 -;;;; Contains: Tests for APROPOS - - - -(deftest apropos.1 - (loop for n from 10 - for x = (coerce (loop repeat n collect (random-from-seq +standard-chars+)) 'string) - unless (apropos-list x) - return (with-output-to-string (*standard-output*) - (assert (null (multiple-value-list (apropos x)))))) - "") - -(deftest apropos.2 - (let ((s (with-output-to-string - (*standard-output*) - (assert (null (multiple-value-list (apropos "CAR"))))))) - (notnot (search "CAR" s :test #'string-equal))) - t) - -(deftest apropos.3 - (let ((s (with-output-to-string - (*standard-output*) - (assert (null (multiple-value-list (apropos "CAR" (find-package "CL")))))))) - (notnot (search "CAR" s :test #'string-equal))) - t) - -(deftest apropos.4 - (let ((result nil)) - (do-special-strings - (s "CAR" t) - (setq result (with-output-to-string - (*standard-output*) - (assert (null (multiple-value-list (apropos s)))))) - (assert (search "CAR" result :test #'string-equal)))) - t) - -(deftest apropos.5 - (let ((result nil) - (pkg (find-package "COMMON-LISP"))) - (do-special-strings - (s "APROPOS" t) - (setq result (with-output-to-string - (*standard-output*) - (assert (null (multiple-value-list (apropos s pkg)))))) - (assert (search "APROPOS" result :test #'string-equal)))) - t) - -(deftest apropos.6 - (let ((s (with-output-to-string - (*standard-output*) - (assert (null (multiple-value-list (apropos "CAR" "CL"))))))) - (notnot (search "CAR" s :test #'string-equal))) - t) - -(deftest apropos.7 - (let ((s (with-output-to-string - (*standard-output*) - (assert (null (multiple-value-list (apropos "CAR" :|CL|))))))) - (notnot (search "CAR" s :test #'string-equal))) - t) - -(deftest apropos.8 - (let ((s (with-output-to-string - (*standard-output*) - (assert (null (multiple-value-list (apropos "CAR" nil))))))) - (notnot (search "CAR" s :test #'string-equal))) - t) - -(deftest apropos.9 - (macrolet - ((%m (z) z)) - (let ((s (with-output-to-string - (*standard-output*) - (assert (null (multiple-value-list - (apropos (expand-in-current-env (%m "CAR"))))))))) - (notnot (search "CAR" s :test #'string-equal)))) - t) - -(deftest apropos.10 - (macrolet - ((%m (z) z)) - (let ((s (with-output-to-string - (*standard-output*) - (assert (null (multiple-value-list - (apropos "CAR" - (expand-in-current-env (%m nil))))))))) - (notnot (search "CAR" s :test #'string-equal)))) - t) - -;;; Error tests - -(deftest apropos.error.1 - (signals-error (apropos) program-error) - t) - -(deftest apropos.error.2 - (signals-error (apropos "SJLJALKSJDKLJASKLDJKLAJDLKJA" (find-package "CL") nil) program-error) - t) diff --git a/t/ansi-test/environment/decode-universal-time.lsp b/t/ansi-test/environment/decode-universal-time.lsp deleted file mode 100644 index 60a198e..0000000 --- a/t/ansi-test/environment/decode-universal-time.lsp +++ /dev/null @@ -1,122 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat May 7 07:00:58 2005 -;;;; Contains: Tests of DECODE-UNIVERSAL-TIME - - - -(deftest decode-universal-time.1 - (decode-universal-time 0 0) - 0 0 0 1 1 1900 0 nil 0) - -(deftest decode-universal-time.2 - (decode-universal-time 0 -1) - 0 0 1 1 1 1900 0 nil -1) - -(deftest decode-universal-time.3 - (let ((count 0)) - (loop for time = (random 10000000000) - for tz = (- (random 49) 24) - for (second minute hour date month year day daylight-p zone) - = (multiple-value-list (decode-universal-time time tz)) - for time2 = (encode-universal-time second minute hour date month year zone) - repeat 1000 - unless (and (eql tz zone) (eql time time2) (null daylight-p)) - collect (progn (incf count) - (list time tz (list second minute hour date month year day daylight-p zone) time2)) - until (>= count 100))) - nil) - -(deftest decode-universal-time.4 - (let ((count 0)) - (loop for time = (random 10000000000) - for tz = (/ (- (random (1+ (* 48 3600))) (* 24 3600)) 3600) - for (second minute hour date month year day daylight-p zone) - = (multiple-value-list (decode-universal-time time tz)) - for time2 = (encode-universal-time second minute hour date month year zone) - repeat 1000 - unless (and (eql tz zone) (eql time time2) (null daylight-p)) - collect (progn (incf count) - (list time tz (list second minute hour date month year day daylight-p zone) time2)) - until (>= count 100))) - nil) - -(deftest decode-universal-time.5 - (let ((count 0)) - (loop for time = (random 10000000000) - for (second minute hour date month year day daylight-p zone) - = (handler-case - (multiple-value-list (decode-universal-time time)) - (error (c) (print time) (error c))) - for time2 = (encode-universal-time second minute hour date month year) - repeat 1000 - unless (let ((daylight-p-2 (nth-value 7 (decode-universal-time time2)))) - (or (eql time time2) - (and daylight-p (not daylight-p-2) ; (eql time (- time2 3600)) - ) - (and (not daylight-p) daylight-p-2 ; (eql time (+ time2 3600)) - ))) - collect (progn (incf count) - (list time (list second minute hour date month year day daylight-p zone) time2)) - until (>= count 100))) - nil) - -(deftest decode-universal-time.6 - (let ((vals0 (multiple-value-list (get-decoded-time))) - (vals1 (multiple-value-list (decode-universal-time (get-universal-time)))) - (vals2 (multiple-value-list (get-decoded-time)))) - (when (equal vals0 vals2) - (assert (= (length vals1) 9)) - (assert (= (length vals2) 9)) - (assert (equal (subseq vals1 0 7) (subseq vals2 0 7))) - (assert (if (elt vals1 7) (elt vals2 7) (not (elt vals2 7)))) - (assert (= (elt vals1 8) (elt vals2 8)))) - (values))) - -(deftest decode-universal-time.7 - (decode-universal-time (* 365 3600 24) 0) - 0 0 0 1 1 1901 1 nil 0) - -(deftest decode-universal-time.8 - (decode-universal-time (* 2 365 3600 24) 0) - 0 0 0 1 1 1902 2 nil 0) - -(deftest decode-universal-time.9 - (decode-universal-time (* 3 365 3600 24) 0) - 0 0 0 1 1 1903 3 nil 0) - -(deftest decode-universal-time.10 - (decode-universal-time (* 4 365 3600 24) 0) - 0 0 0 1 1 1904 4 nil 0) - -(deftest decode-universal-time.11 - (decode-universal-time (+ (* 24 3600) (* 5 365 3600 24)) 0) - 0 0 0 1 1 1905 6 nil 0) - -(deftest decode-universal-time.12 - (loop for time = (random 100000000000) - for tz = (- (random 49) 24) - for interval = (1+ (random 10000)) - for time2 = (+ time (* interval 24 3600)) - ;; 'time2' is exactly interval days after 'time' - for day = (nth-value 6 (decode-universal-time time tz)) - for day2 = (nth-value 6 (decode-universal-time time2 tz)) - repeat 1000 - ;; Check that the days of the week are consistent - unless (= (mod day2 7) (mod (+ day interval) 7)) - collect (list time time2 tz interval day day2)) - nil) - -;;; Error tests - -(deftest decode-universal-time.error.1 - (signals-error (decode-universal-time) program-error) - t) - -(deftest decode-universal-time.error.2 - (signals-error (decode-universal-time 0 0 nil) program-error) - t) - - - - diff --git a/t/ansi-test/environment/describe.lsp b/t/ansi-test/environment/describe.lsp deleted file mode 100644 index 7ccf6e2..0000000 --- a/t/ansi-test/environment/describe.lsp +++ /dev/null @@ -1,82 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Dec 12 13:22:13 2004 -;;;; Contains: Tests of DESCRIBE - - - -(defun harness-for-describe (fn) - (let (s1 s2) - (with-open-stream - (*standard-output* (make-string-output-stream)) - (with-open-stream - (tio-input (make-string-input-stream "X")) - (with-open-stream - (tio-output (make-string-output-stream)) - (with-open-stream - (*terminal-io* (make-two-way-stream tio-input tio-output)) - (let ((*print-circle* t) - (*print-readably* nil)) - (assert (null (multiple-value-list (funcall fn)))))) - (setq s2 (get-output-stream-string tio-output))) - (assert (equal (read-char tio-input) #\X))) - (setq s1 (get-output-stream-string *standard-output*))) - (values s1 s2))) - -(deftest describe.1 - (loop for x in *universe* - for (s1 s2) = (multiple-value-list (harness-for-describe #'(lambda () (describe x)))) - when (and (equal s1 "") (equal s2 "")) - collect x) - nil) - -(deftest describe.2 - (loop for x in *universe* - for s1 = nil - for s2 = nil - for s3 = (with-output-to-string (s) - (setf (values s1 s2) (harness-for-describe #'(lambda () (describe x s))))) - when (or (equal s3 "") (not (equal "" s2)) (not (equal "" s1))) - collect (list x s1 s2 s3)) - nil) - -(deftest describe.3 - (loop for x in *universe* - for (s1 s2) = (multiple-value-list (harness-for-describe #'(lambda () (describe x t)))) - when (or (equal "" s2) (not (equal "" s1))) - collect (list x s1 s2)) - nil) - -(deftest describe.4 - (loop for x in *universe* - for (s1 s2) = (multiple-value-list (harness-for-describe #'(lambda () (describe x nil)))) - when (or (equal "" s1) (not (equal "" s2))) - collect (list x s1 s2)) - nil) - -;;; Defining methods for describe-object - -(defclass describe-object-test-class-01 () ((s1 :initarg :s1) (s2 :initarg :s2) (s3 :initarg :s3))) - -(defmethod describe-object ((obj describe-object-test-class-01) stream) - (format stream "ABCDE ~A ~A ~A XYZ" (slot-value obj 's1) (slot-value obj 's2) (slot-value obj 's3))) - -(deftest describe.5 - (let ((obj (make-instance 'describe-object-test-class-01 :s1 2 :s2 6 :s3 17))) - (multiple-value-bind (str1 str2) (harness-for-describe #'(lambda () (describe obj))) - (if (or (search "ABCDE 2 6 17 XYZ" str1) - (search "ABCDE 2 6 17 XYZ" str2)) - :good - (list str1 str2)))) - :good) - -;;; Error cases - -(deftest describe.error.1 - (signals-error (describe) program-error) - t) - -(deftest describe.error.2 - (signals-error (with-output-to-string (s) (describe nil s nil)) program-error) - t) - diff --git a/t/ansi-test/environment/disassemble.lsp b/t/ansi-test/environment/disassemble.lsp deleted file mode 100644 index 9724f4c..0000000 --- a/t/ansi-test/environment/disassemble.lsp +++ /dev/null @@ -1,99 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun May 18 20:47:58 2003 -;;;; Contains: Tests of DISASSEMBLE - - - -(defun disassemble-it (fn) - (let (val) - (values - (notnot - (stringp - (with-output-to-string (*standard-output*) - (setf val (disassemble fn))))) - val))) - -(deftest disassemble.1 - (disassemble-it 'car) - t nil) - -(deftest disassemble.2 - (disassemble-it (symbol-function 'car)) - t nil) - -(deftest disassemble.3 - (disassemble-it '(lambda (x y) (cons y x))) - t nil) - -(deftest disassemble.4 - (disassemble-it (eval '(function (lambda (x y) (cons x y))))) - t nil) - -(deftest disassemble.5 - (disassemble-it - (funcall (compile nil '(lambda () (let ((x 0)) #'(lambda () (incf x))))))) - t nil) - -(deftest disassemble.6 - (let ((name 'disassemble.fn.1)) - (fmakunbound name) - (eval `(defun ,name (x) x)) - (disassemble-it name)) - t nil) - -(deftest disassemble.7 - (let ((name 'disassemble.fn.2)) - (fmakunbound name) - (eval `(defun ,name (x) x)) - (compile name) - (disassemble-it name)) - t nil) - -(deftest disassemble.8 - (progn - (eval '(defun (setf disassemble-example-fn) (val arg) - (setf (car arg) val))) - (disassemble-it '(setf disassemble-example-fn))) - t nil) - -(deftest disassemble.9 - (progn - (eval '(defgeneric disassemble-example-fn2 (x y z))) - (disassemble-it 'disassemble-example-fn2)) - t nil) - -(deftest disassemble.10 - (progn - (eval '(defgeneric disassemble-example-fn3 (x y z))) - (eval '(defmethod disassemble-example-fn3 ((x t)(y t)(z t)) (list x y z))) - (disassemble-it 'disassemble-example-fn3)) - t nil) - -(deftest disassemble.11 - (let ((fn 'disassemble-example-fn4)) - (when (fboundp fn) (fmakunbound fn)) - (eval `(defun ,fn (x) x)) - (let ((is-compiled? (typep (symbol-function fn) 'compiled-function))) - (multiple-value-call - #'values - (disassemble-it fn) - (if is-compiled? (notnot (typep (symbol-function fn) 'compiled-function)) - (not (typep (symbol-function fn) 'compiled-function)))))) - t nil t) - -;;; Error tests - -(deftest disassemble.error.1 - (signals-error (disassemble) program-error) - t) - -(deftest disassemble.error.2 - (signals-error (disassemble 'car nil) program-error) - t) - -(deftest disassemble.error.3 - (check-type-error #'disassemble - (typef '(or function symbol (cons (eql setf) (cons symbol null))))) - nil) - diff --git a/t/ansi-test/environment/documentation.lsp b/t/ansi-test/environment/documentation.lsp deleted file mode 100644 index 33e2e9f..0000000 --- a/t/ansi-test/environment/documentation.lsp +++ /dev/null @@ -1,643 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Dec 14 07:30:01 2004 -;;;; Contains: Tests of DOCUMENTATION - - - -;;; documentation (x function) (doc-type (eql 't)) - -(deftest documentation.function.t.1 - (let* ((sym (gensym))) - (eval `(defun ,sym () nil)) - (documentation (symbol-function sym) t)) - nil) - -(deftest documentation.function.t.2 - (let* ((sym (gensym))) - (eval `(defun ,sym () nil)) - (let ((fn (symbol-function sym)) - (doc "FOO1")) - (multiple-value-prog1 - (setf (documentation fn t) (copy-seq doc)) - (assert (or (null (documentation fn t)) - (equal doc (documentation fn t))))))) - "FOO1") - -(deftest documentation.function.t.3 - (let* ((sym (gensym))) - (eval `(defmacro ,sym () nil)) - (documentation (macro-function sym) t)) - nil) - -(deftest documentation.function.t.4 - (let* ((sym (gensym))) - (eval `(defmacro ,sym () nil)) - (let ((fn (macro-function sym)) - (doc "FOO2")) - (multiple-value-prog1 - (setf (documentation fn t) (copy-seq doc)) - (assert (or (null (documentation fn t)) - (equal doc (documentation fn t))))))) - "FOO2") - -(deftest documentation.function.t.6 - (let* ((sym (gensym)) - (fn (eval `#'(lambda () ',sym))) - (doc "FOO3")) - (multiple-value-prog1 - (setf (documentation fn t) (copy-seq doc)) - (assert (or (null (documentation fn t)) - (equal doc (documentation fn t)))))) - "FOO3") - -(deftest documentation.function.t.6a - (let* ((sym (gensym)) - (fn (compile nil `(lambda () ',sym))) - (doc "FOO3A")) - (multiple-value-prog1 - (setf (documentation fn t) (copy-seq doc)) - (assert (or (null (documentation fn t)) - (equal doc (documentation fn t)))))) - "FOO3A") - -;; Reorder 5, 5a and 6, 6a to expose possible interaction bug - -(deftest documentation.function.t.5 - (let* ((sym (gensym)) - (fn (eval `#'(lambda () ',sym)))) - (documentation fn t)) - nil) - -(deftest documentation.function.t.5a - (let* ((sym (gensym)) - (fn (compile nil `(lambda () ',sym)))) - (documentation fn t)) - nil) - -(deftest documentation.function.t.7 - (let* ((sym (gensym)) - (fn (eval `(defgeneric ,sym (x))))) - (documentation fn t)) - nil) - -(deftest documentation.function.t.8 - (let* ((sym (gensym)) - (fn (eval `(defgeneric ,sym (x)))) - (doc "FOO4")) - (multiple-value-prog1 - (setf (documentation fn t) (copy-seq doc)) - (assert (or (null (documentation fn t)) - (equal doc (documentation fn t)))))) - "FOO4") - -(deftest documentation.function.t.9 - (loop for s in *cl-function-symbols* - for fn = (symbol-function s) - for doc = (documentation fn t) - unless (or (null doc) (string doc)) - collect (list s doc)) - nil) - -(deftest documentation.function.t.10 - (loop for s in *cl-accessor-symbols* - for fn = (symbol-function s) - for doc = (documentation fn t) - unless (or (null doc) (string doc)) - collect (list s doc)) - nil) - -(deftest documentation.function.t.11 - (loop for s in *cl-macro-symbols* - for fn = (macro-function s) - for doc = (documentation fn t) - unless (or (null doc) (string doc)) - collect (list s doc)) - nil) - -(deftest documentation.function.t.12 - (loop for s in *cl-standard-generic-function-symbols* - for fn = (symbol-function s) - for doc = (documentation fn t) - unless (or (null doc) (string doc)) - collect (list s doc)) - nil) - -;;; documentation (x function) (doc-type (eql 'function)) - -(deftest documentation.function.function.1 - (let* ((sym (gensym))) - (eval `(defun ,sym () nil)) - (documentation (symbol-function sym) 'function)) - nil) - -(deftest documentation.function.function.2 - (let* ((sym (gensym))) - (eval `(defun ,sym () nil)) - (let ((fn (symbol-function sym)) - (doc "FOO5")) - (multiple-value-prog1 - (setf (documentation fn 'function) (copy-seq doc)) - (assert (or (null (documentation fn 'function)) - (equal doc (documentation fn 'function))))))) - "FOO5") - -(deftest documentation.function.function.3 - (let* ((sym (gensym))) - (eval `(defmacro ,sym () nil)) - (documentation (macro-function sym) 'function)) - nil) - -(deftest documentation.function.function.4 - (let* ((sym (gensym))) - (eval `(defmacro ,sym () nil)) - (let ((fn (macro-function sym)) - (doc "FOO6")) - (multiple-value-prog1 - (setf (documentation fn t) (copy-seq doc)) - (assert (or (null (documentation fn 'function)) - (equal doc (documentation fn 'function))))))) - "FOO6") - -(deftest documentation.function.function.5 - (let* ((sym (gensym)) - (fn (eval `(defgeneric ,sym (x))))) - (documentation fn 'function)) - nil) - -(deftest documentation.function.function.8 - (let* ((sym (gensym)) - (fn (eval `(defgeneric ,sym (x)))) - (doc "FOO4A")) - (multiple-value-prog1 - (setf (documentation fn t) (copy-seq doc)) - (assert (or (null (documentation fn 'function)) - (equal doc (documentation fn 'function)))))) - "FOO4A") - -;;; documentation (x list) (doc-type (eql 'function)) - -(deftest documentation.list.function.1 - (let* ((sym (gensym))) - (eval `(defun (setf ,sym) (&rest args) (declare (ignore args)) nil)) - (documentation `(setf ,sym) 'function)) - nil) - -(deftest documentation.list.function.2 - (let* ((sym (gensym))) - (eval `(defun (setf ,sym) (&rest args) (declare (ignore args)) nil)) - (let ((fn `(setf ,sym)) - (doc "FOO7")) - (multiple-value-prog1 - (setf (documentation fn 'function) (copy-seq doc)) - (assert (or (null (documentation fn 'function)) - (equal doc (documentation fn 'function))))))) - "FOO7") - -;;; documentation (x list) (doc-type (eql 'compiler-macro)) - -(deftest documentation.list.compiler-macro.1 - (let* ((sym (gensym))) - (eval `(define-compiler-macro (setf ,sym) (&rest args) (declare (ignore args)) nil)) - (documentation `(setf ,sym) 'compiler-macro)) - nil) - -(deftest documentation.list.compiler-macro.2 - (let* ((sym (gensym))) - (eval `(define-compiler-macro (setf ,sym) (&rest args) (declare (ignore args)) nil)) - (let ((fn `(setf ,sym)) - (doc "FOO8")) - (multiple-value-prog1 - (setf (documentation fn 'compiler-macro) (copy-seq doc)) - (assert (or (null (documentation fn 'function)) - (equal doc (documentation fn 'compiler-macro))))))) - "FOO8") - -;;; documentation (x symbol) (doc-type (eql 'function)) - -(deftest documentation.symbol.function.1 - (let* ((sym (gensym))) - (eval `(defun ,sym () nil)) - (documentation sym 'function)) - nil) - -(deftest documentation.symbol.function.2 - (let* ((sym (gensym))) - (eval `(defun ,sym () nil)) - (let ((doc "FOO9")) - (multiple-value-prog1 - (setf (documentation sym 'function) (copy-seq doc)) - (assert (or (null (documentation sym 'function)) - (equal doc (documentation sym 'function))))))) - "FOO9") - -(deftest documentation.symbol.function.3 - (let* ((sym (gensym))) - (eval `(defmacro ,sym () nil)) - (documentation sym 'function)) - nil) - -(deftest documentation.symbol.function.4 - (let* ((sym (gensym))) - (eval `(defmacro ,sym () nil)) - (let ((doc "FOO9A")) - (multiple-value-prog1 - (setf (documentation sym 'function) (copy-seq doc)) - (assert (or (null (documentation sym 'function)) - (equal doc (documentation sym 'function))))))) - "FOO9A") - -(deftest documentation.symbol.function.5 - (let* ((sym (gensym))) - (eval `(defgeneric ,sym (x))) - (documentation sym 'function)) - nil) - -(deftest documentation.symbol.function.6 - (let* ((sym (gensym))) - (eval `(defgeneric ,sym (x))) - (let ((doc "FOO9B")) - (multiple-value-prog1 - (setf (documentation sym 'function) (copy-seq doc)) - (assert (or (null (documentation sym 'function)) - (equal doc (documentation sym 'function))))))) - "FOO9B") - -(deftest documentation.symbol.function.7 - (loop for s in *cl-special-operator-symbols* - for doc = (documentation s 'function) - unless (or (null doc) (stringp doc)) - collect (list s doc)) - nil) - -(deftest documentation.symbol.function.8 - (loop for s in *cl-function-or-accessor-symbols* - for doc = (documentation s 'function) - unless (or (null doc) (stringp doc)) - collect (list s doc)) - nil) - -(deftest documentation.symbol.function.9 - (loop for s in *cl-macro-symbols* - for doc = (documentation s 'function) - unless (or (null doc) (stringp doc)) - collect (list s doc)) - nil) - -;;; documentation (x symbol) (doc-type (eql 'compiler-macro)) - -(deftest documentation.symbol.compiler-macro.1 - (let* ((sym (gensym))) - (eval `(define-compiler-macro ,sym (&rest args) (declare (ignore args)) nil)) - (documentation sym 'compiler-macro)) - nil) - -(deftest documentation.symbol.compiler-macro.2 - (let* ((sym (gensym))) - (eval `(define-compiler-macro ,sym (&rest args) (declare (ignore args)) nil)) - (let ((doc "FOO10")) - (multiple-value-prog1 - (setf (documentation sym 'compiler-macro) (copy-seq doc)) - (assert (or (null (documentation sym 'compiler-macro)) - (equal doc (documentation sym 'compiler-macro))))))) - "FOO10") - -;;; documentation (x symbol) (doc-type (eql 'setf)) - -(deftest documentation.symbol.setf.1 - (let* ((sym (gensym)) - (doc "FOO11")) - (eval `(defun ,sym () (declare (special *x*)) *x*)) - (eval `(define-setf-expander ,sym () - (let ((g (gemsym))) - (values nil nil (list g) `(locally (declare (special *x*)) (setf *x* ,g)) - '(locally (declare (special *x*)) *x*))))) - (multiple-value-prog1 - (values - (documentation sym 'setf) - (setf (documentation sym 'setf) (copy-seq doc))) - (assert (or (null (documentation sym 'setf)) - (equal doc (documentation sym 'setf)))))) - nil "FOO11") - -(deftest documentation.symbol.setf.2 - (let* ((sym (gensym)) - (doc "FOO12")) - (eval `(defmacro ,sym () `(locally (declare (special *x*)) *x*))) - (eval `(define-setf-expander ,sym () - (let ((g (gemsym))) - (values nil nil (list g) `(locally (declare (special *x*)) (setf *x* ,g)) - '(locally (declare (special *x*)) *x*))))) - (multiple-value-prog1 - (values - (documentation sym 'setf) - (setf (documentation sym 'setf) (copy-seq doc))) - (assert (or (null (documentation sym 'setf)) - (equal doc (documentation sym 'setf)))))) - nil "FOO12") - -;;; documentation (x method-combination) (doc-type (eql 't)) -;;; documentation (x method-combination) (doc-type (eql 'method-combination)) -;;; There's no portable way to test those, since there's no portable way to -;;; get a method combination object - -;;; documentation (x symbol) (doc-type (eql 'method-combination)) - -(deftest documentation.symbol.method-combination.1 - (let* ((sym (gensym)) - (doc "FOO13")) - (eval `(define-method-combination ,sym :identity-with-one-argument t)) - (multiple-value-prog1 - (values - (documentation sym 'method-combination) - (setf (documentation sym 'method-combination) (copy-seq doc))) - (assert (or (null (documentation sym 'method-combination)) - (equal doc (documentation sym 'method-combination)))))) - nil "FOO13") - -;;; documentation (x standard-method) (doc-type (eql 't)) - -(deftest documentation.standard-method.t.1 - (let* ((sym (gensym)) - (doc "FOO14")) - (eval `(defgeneric ,sym (x))) - (let ((method (eval `(defmethod ,sym ((x t)) nil)))) - (multiple-value-prog1 - (values - (documentation method t) - (setf (documentation method t) (copy-seq doc))) - (assert (or (null (documentation method 't)) - (equal doc (documentation method 't))))))) - nil "FOO14") - -;;; documentation (x package) (doc-type (eql 't)) - -(deftest documentation.package.t.1 - (let ((package-name "PACKAGE-NAME-FOR-DOCUMENATION-TESTS-1")) - (unwind-protect - (progn - (eval `(defpackage ,package-name (:use))) - (let ((pkg (find-package package-name)) - (doc "FOO15")) - (assert pkg) - (multiple-value-prog1 - (values - (documentation pkg t) - (setf (documentation pkg t) (copy-seq doc))) - (assert (or (null (documentation pkg t)) - (equal doc (documentation pkg t))))))) - (delete-package package-name))) - nil "FOO15") - -;;; documentation (x standard-class) (doc-type (eql 't)) - -(deftest documentation.standard-class.t.1 - (let* ((sym (gensym)) - (class-form `(defclass ,sym () ()))) - (eval class-form) - (let ((class (find-class sym)) - (doc "FOO16")) - (multiple-value-prog1 - (values - (documentation class t) - (setf (documentation class t) (copy-seq doc))) - (assert (or (null (documentation class t)) - (equal doc (documentation class t))))))) - nil "FOO16") - -;;; documentation (x standard-class) (doc-type (eql 'type)) - -(deftest documentation.standard-class.type.1 - (let* ((sym (gensym)) - (class-form `(defclass ,sym () ()))) - (eval class-form) - (let ((class (find-class sym)) - (doc "FOO17")) - (multiple-value-prog1 - (values - (documentation class 'type) - (setf (documentation class 'type) (copy-seq doc))) - (assert (or (null (documentation class 'type)) - (equal doc (documentation class 'type))))))) - nil "FOO17") - - -;;; documentation (x structure-class) (doc-type (eql 't)) - -(deftest documentation.struct-class.t.1 - (let* ((sym (gensym)) - (class-form `(defstruct ,sym a b c))) - (eval class-form) - (let ((class (find-class sym)) - (doc "FOO18")) - (multiple-value-prog1 - (values - (documentation class t) - (setf (documentation class t) (copy-seq doc))) - (assert (or (null (documentation class t)) - (equal doc (documentation class t))))))) - nil "FOO18") - -;;; documentation (x structure-class) (doc-type (eql 'type)) - -(deftest documentation.struct-class.type.1 - (let* ((sym (gensym)) - (class-form `(defstruct ,sym a b c))) - (eval class-form) - (let ((class (find-class sym)) - (doc "FOO19")) - (multiple-value-prog1 - (values - (documentation class 'type) - (setf (documentation class 'type) (copy-seq doc))) - (assert (or (null (documentation class 'type)) - (equal doc (documentation class 'type))))))) - nil "FOO19") - -;;; documentation (x symbol) (doc-type (eql 'type)) - -(deftest documentation.symbol.type.1 - (let* ((sym (gensym)) - (class-form `(defclass ,sym () ())) - (doc "FOO20")) - (eval class-form) - (multiple-value-prog1 - (values - (documentation sym 'type) - (setf (documentation sym 'type) (copy-seq doc))) - (assert (or (null (documentation sym 'type)) - (equal doc (documentation sym 'type)))))) - nil "FOO20") - -(deftest documentation.symbol.type.2 - (let* ((sym (gensym)) - (class-form `(defstruct ,sym a b c)) - (doc "FOO21")) - (eval class-form) - (multiple-value-prog1 - (values - (documentation sym 'type) - (setf (documentation sym 'type) (copy-seq doc))) - (assert (or (null (documentation sym 'type)) - (equal doc (documentation sym 'type)))))) - nil "FOO21") - -(deftest documentation.symbol.type.3 - (let* ((sym (gensym)) - (type-form `(deftype ,sym () t)) - (doc "FOO21A")) - (eval type-form) - (multiple-value-prog1 - (values - (documentation sym 'type) - (setf (documentation sym 'type) (copy-seq doc))) - (assert (or (null (documentation sym 'type)) - (equal doc (documentation sym 'type)))))) - nil "FOO21A") - -(deftest documentation.symbol.type.4 - (loop for s in *cl-all-type-symbols* - for doc = (documentation s 'type) - unless (or (null doc) (stringp doc)) - collect (list doc)) - nil) - - -;;; documentation (x symbol) (doc-type (eql 'structure)) - -(deftest documentation.symbol.structure.1 - (let* ((sym (gensym)) - (class-form `(defstruct ,sym a b c)) - (doc "FOO22")) - (eval class-form) - (multiple-value-prog1 - (values - (documentation sym 'structure) - (setf (documentation sym 'structure) (copy-seq doc))) - (assert (or (null (documentation sym 'structure)) - (equal doc (documentation sym 'structure)))))) - nil "FOO22") - -(deftest documentation.symbol.structure.2 - (let* ((sym (gensym)) - (class-form `(defstruct (,sym (:type list)) a b c)) - (doc "FOO23")) - (eval class-form) - (multiple-value-prog1 - (values - (documentation sym 'structure) - (setf (documentation sym 'structure) (copy-seq doc))) - (assert (or (null (documentation sym 'structure)) - (equal doc (documentation sym 'structure)))))) - nil "FOO23") - -(deftest documentation.symbol.structure.3 - (let* ((sym (gensym)) - (class-form `(defstruct (,sym (:type vector)) a b c)) - (doc "FOO24")) - (eval class-form) - (multiple-value-prog1 - (values - (documentation sym 'structure) - (setf (documentation sym 'structure) (copy-seq doc))) - (assert (or (null (documentation sym 'structure)) - (equal doc (documentation sym 'structure)))))) - nil "FOO24") - -;;; documentation (x symbol) (doc-type (eql 'variable)) - -(deftest documentation.symbol.variable.1 - (let* ((sym (gensym)) - (form `(defvar ,sym)) - (doc "FOO25")) - (eval form) - (multiple-value-prog1 - (values - (documentation sym 'variable) - (setf (documentation sym 'variable) (copy-seq doc))) - (assert (or (null (documentation sym 'variable)) - (equal doc (documentation sym 'variable)))))) - nil "FOO25") - -(deftest documentation.symbol.variable.2 - (let* ((sym (gensym)) - (form `(defvar ,sym t)) - (doc "FOO26")) - (eval form) - (multiple-value-prog1 - (values - (documentation sym 'variable) - (setf (documentation sym 'variable) (copy-seq doc))) - (assert (or (null (documentation sym 'variable)) - (equal doc (documentation sym 'variable)))))) - nil "FOO26") - -(deftest documentation.symbol.variable.3 - (let* ((sym (gensym)) - (form `(defparameter ,sym t)) - (doc "FOO27")) - (eval form) - (multiple-value-prog1 - (values - (documentation sym 'variable) - (setf (documentation sym 'variable) (copy-seq doc))) - (assert (or (null (documentation sym 'variable)) - (equal doc (documentation sym 'variable)))))) - nil "FOO27") - -(deftest documentation.symbol.variable.4 - (let* ((sym (gensym)) - (form `(defconstant ,sym t)) - (doc "FOO27")) - (eval form) - (multiple-value-prog1 - (values - (documentation sym 'variable) - (setf (documentation sym 'variable) (copy-seq doc))) - (assert (or (null (documentation sym 'variable)) - (equal doc (documentation sym 'variable)))))) - nil "FOO27") - -(deftest documentation.symbol.variable.5 - (loop for s in *cl-variable-symbols* - for doc = (documentation s 'variable) - unless (or (null doc) (stringp doc)) - collect (list s doc)) - nil) - -(deftest documentation.symbol.variable.6 - (loop for s in *cl-constant-symbols* - for doc = (documentation s 'variable) - unless (or (null doc) (stringp doc)) - collect (list s doc)) - nil) - -;;; Defining new methods for DOCUMENTATION - -(ignore-errors - (defgeneric documentation-test-class-1-doc-accessor (obj)) - (defgeneric (setf documentation-test-class-1-doc-accessor) (newdoc obj)) - - (defclass documentation-test-class-1 () ((my-doc :accessor documentation-test-class-1-doc-accessor - :type (or null string) - :initform nil))) - - (defmethod documentation-test-class-1-doc-accessor ((obj documentation-test-class-1) ) - (slot-value obj 'my-doc)) - (defmethod (setf documentation-test-class-1-doc-accessor) ((newdoc string) (obj documentation-test-class-1)) - (setf (slot-value obj 'my-doc) newdoc)) - - (defmethod documentation ((obj documentation-test-class-1) (doctype (eql t))) - (documentation-test-class-1-doc-accessor obj)) - - (defmethod (setf documentation) ((newdoc string) (obj documentation-test-class-1) (doctype (eql t))) - (setf (documentation-test-class-1-doc-accessor obj) newdoc))) - -(deftest documentation.new-method.1 - (let ((obj (make-instance 'documentation-test-class-1))) - (values - (documentation obj t) - (setf (documentation obj t) "FOO28") - (documentation obj t))) - nil "FOO28" "FOO28") - diff --git a/t/ansi-test/environment/dribble.lsp b/t/ansi-test/environment/dribble.lsp deleted file mode 100644 index 33737d8..0000000 --- a/t/ansi-test/environment/dribble.lsp +++ /dev/null @@ -1,16 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun May 15 12:56:29 2005 -;;;; Contains: Tests of DRIBBLE - - - -;;; Error tests only -- cannot depend on using it in a program -;;; See the CLHS DRIBBLE and issue DRIBBLE-TECHNIQUE for an explanation - -(deftest dribble.error.1 - (signals-error (dribble "dribble.out" nil) program-error) - t) - - -;;; FIXME -- more error tests here diff --git a/t/ansi-test/environment/ed.lsp b/t/ansi-test/environment/ed.lsp deleted file mode 100644 index 6bad12f..0000000 --- a/t/ansi-test/environment/ed.lsp +++ /dev/null @@ -1,16 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun May 15 13:07:39 2005 -;;;; Contains: Tests of ED - - - -;;; Since the normal behavior of ED is implementation dependent, -;;; test only the error behavior - -(deftest ed.error.1 - (signals-error (ed "ed.lsp" nil) program-error) - t) - -;;; Since the editor may not even be included, no other tests -;;; are possible. diff --git a/t/ansi-test/environment/encode-universal-time.lsp b/t/ansi-test/environment/encode-universal-time.lsp deleted file mode 100644 index 0e66ee4..0000000 --- a/t/ansi-test/environment/encode-universal-time.lsp +++ /dev/null @@ -1,102 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun May 8 12:54:34 2005 -;;;; Contains: Tests of ENCODE-UNIVERSAL-TIME - -;;; See also the tests in decode-universal-time.lsp - - - -(deftest encode-universal-time.1 - (loop with count = 0 - for year = (+ 1900 (random 1000)) - ;; Gregorian leap year algorithm - for leap? = (and (= (mod year 4) 0) - (or (/= (mod year 100) 0) - (= (mod year 400) 0))) - for month = (1+ (random 12)) - for date = (1+ (random (elt (if leap? - #(0 31 29 31 30 31 30 31 31 30 31 30 31) - #(0 31 28 31 30 31 30 31 31 30 31 30 31)) - month))) - for hour = (random 24) - for minute = (random 60) - for second = (random 60) - for tz = (if (and (= year 1900) (= date 0) (= month 0)) - (random 25) - (- (random 49) 24)) - for time = (encode-universal-time second minute hour date month year tz) - for decoded-vals = (multiple-value-list (decode-universal-time time tz)) - for vals = (list second minute hour date month year (elt decoded-vals 6) - nil tz) - repeat 20000 - unless (equal vals decoded-vals) - collect (progn (incf count) (list vals time decoded-vals)) - until (>= count 100)) - nil) - -#| -(deftest encode-universal-time.2 - (loop with count = 0 - for year = (+ 1901 (random 1000)) - ;; Gregorian leap year algorithm - for leap? = (and (= (mod year 4) 0) - (or (/= (mod year 100) 0) - (= (mod year 400) 0))) - for month = (1+ (random 12)) - for date = (1+ (random (elt (if leap? - #(0 31 29 31 30 31 30 31 31 30 31 30 31) - #(0 31 28 31 30 31 30 31 31 30 31 30 31)) - month))) - for hour = (random 24) - for minute = (random 60) - for second = (random 60) - for time = (encode-universal-time second minute hour date month year) - for decoded-vals = (multiple-value-list (decode-universal-time time)) - for vals = (list second minute hour date month year (elt decoded-vals 6) - (elt decoded-vals 7) (elt decoded-vals 8)) - repeat 20000 - unless (equal vals decoded-vals) - collect (progn (incf count) (list vals time decoded-vals)) - until (>= count 100)) - nil) -|# - -(deftest encode-universal-time.3 - (loop with count = 0 - for year = (+ 1900 (random 1000)) - ;; Gregorian leap year algorithm - for leap? = (and (= (mod year 4) 0) - (or (/= (mod year 100) 0) - (= (mod year 400) 0))) - for month = (1+ (random 12)) - for date = (1+ (random (elt (if leap? - #(0 31 29 31 30 31 30 31 31 30 31 30 31) - #(0 31 28 31 30 31 30 31 31 30 31 30 31)) - month))) - for hour = (random 24) - for minute = (random 60) - for second = (random 60) - for tz = (/ (if (and (= year 1900) (= date 0) (= month 0)) - (random (1+ (* 24 3600))) - (- (random (1+ (* 48 3600))) (* 24 3600))) - 3600) - for time = (encode-universal-time second minute hour date month year tz) - for decoded-vals = (multiple-value-list (decode-universal-time time tz)) - for vals = (list second minute hour date month year (elt decoded-vals 6) - nil tz) - repeat 20000 - unless (equal vals decoded-vals) - collect (progn (incf count) (list vals time decoded-vals)) - until (>= count 100)) - nil) - -;;; Error cases - -(deftest encode-universal-time.error.1 - (signals-error (encode-universal-time 0 0 0 1 1) program-error) - t) - -(deftest encode-universal-time.error.2 - (signals-error (encode-universal-time 0 0 0 1 1 1901 0 nil) program-error) - t) diff --git a/t/ansi-test/environment/environment-functions.lsp b/t/ansi-test/environment/environment-functions.lsp deleted file mode 100644 index 0c3f6b6..0000000 --- a/t/ansi-test/environment/environment-functions.lsp +++ /dev/null @@ -1,29 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Dec 11 22:15:54 2004 -;;;; Contains: Tests of various string-returning functions from section 25 - - - -(defmacro def-env-tests (fn-name) - (flet ((%name (suffix) (intern (concatenate 'string (symbol-name fn-name) suffix) - (find-package :cl-test)))) - `(progn - (deftest ,(%name ".1") - (let ((x (,fn-name))) - (or (not x) - (notnot (stringp x)))) - t) - (deftest ,(%name ".ERROR.1") - (signals-error (,fn-name nil) program-error) - t)))) - -(def-env-tests lisp-implementation-type) -(def-env-tests lisp-implementation-version) -(def-env-tests short-site-name) -(def-env-tests long-site-name) -(def-env-tests machine-instance) -(def-env-tests machine-type) -(def-env-tests machine-version) -(def-env-tests software-type) -(def-env-tests software-version) diff --git a/t/ansi-test/environment/get-internal-time.lsp b/t/ansi-test/environment/get-internal-time.lsp deleted file mode 100644 index 5d6d63d..0000000 --- a/t/ansi-test/environment/get-internal-time.lsp +++ /dev/null @@ -1,66 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun May 8 20:28:21 2005 -;;;; Contains: Tests of GET-INTERNAL-REAL-TIME, GET-INTERNAL-RUN-TIME - - - -(deftest get-internal-real-time.1 - (notnot-mv (typep (multiple-value-list (get-internal-real-time)) '(cons unsigned-byte null))) - t) - -(deftest get-internal-real-time.2 - (funcall - (compile - nil - '(lambda () - (let ((prev (get-internal-real-time))) - (loop for next = (get-internal-real-time) - repeat 100000 - do (assert (>= next prev)) - do (setf prev next)))))) - nil) - -(deftest get-internal-real-time.error.1 - (signals-error (get-internal-real-time nil) program-error) - t) - -(deftest get-internal-real-time.error.2 - (signals-error (get-internal-real-time :allow-other-keys t) program-error) - t) - -;;;;; - -(deftest get-internal-run-time.1 - (notnot-mv (typep (multiple-value-list (get-internal-run-time)) '(cons unsigned-byte null))) - t) - -(deftest get-internal-run-time.2 - (funcall - (compile - nil - '(lambda () - (let ((prev (get-internal-run-time))) - (loop for next = (get-internal-run-time) - repeat 100000 - do (assert (>= next prev)) - do (setf prev next)))))) - nil) - -(deftest get-internal-run-time.error.1 - (signals-error (get-internal-run-time nil) program-error) - t) - -(deftest get-internal-run-time.error.2 - (signals-error (get-internal-run-time :allow-other-keys t) program-error) - t) - -;;; - -(deftest internal-time-units-per-second.1 - (notnot-mv (constantp 'internal-time-units-per-second)) - t) - -(deftest internal-time-units-per-second.2 - (notnot-mv (typep internal-time-units-per-second '(integer 1))) - t) diff --git a/t/ansi-test/environment/get-universal-time.lsp b/t/ansi-test/environment/get-universal-time.lsp deleted file mode 100644 index ffa9b4b..0000000 --- a/t/ansi-test/environment/get-universal-time.lsp +++ /dev/null @@ -1,59 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun May 8 19:25:41 2005 -;;;; Contains: Tests of GET-UNIVERSAL-TIME, GET-DECODED-TIME - - - -;;; Note -- this ignores the possibilty that the time cannot -;;; be determined. - -(deftest get-universal-time.1 - (notnot-mv (typep (get-universal-time) 'unsigned-byte)) - t) - -(deftest get-universal-time.2 - (let* ((time1 (get-universal-time)) - (vals (multiple-value-list (get-decoded-time))) - (time2 (get-universal-time))) - (when (= time1 time2) - (let ((vals2 (multiple-value-list (decode-universal-time time1)))) - (assert (= (length vals) 9)) - (assert (= (length vals2) 9)) - (assert (equal (subseq vals 0 7) - (subseq vals2 0 7))) - (assert (if (elt vals 7) (elt vals2 7) (not (elt vals2 7)))) - (assert (= (elt vals 8) (elt vals2 8))))) - (values))) - -(deftest get-universal-time.3 - (let* ((first (get-universal-time)) - (prev first)) - (loop for time = (get-universal-time) - do (assert (>= time prev)) - do (setf prev time) - until (>= time (+ 5 first)))) - nil) - -;;; Error tests - -(deftest get-universal-time.error.1 - (signals-error (get-universal-time nil) program-error) - t) - -(deftest get-universal-time.error.2 - (signals-error (get-universal-time :allow-other-keys t) program-error) - t) - -(deftest get-decoded-time.error.1 - (signals-error (get-decoded-time nil) program-error) - t) - -(deftest get-decoded-time.error.2 - (signals-error (get-decoded-time :allow-other-keys t) program-error) - t) - - - - - diff --git a/t/ansi-test/environment/inspect.lsp b/t/ansi-test/environment/inspect.lsp deleted file mode 100644 index a0ad9cb..0000000 --- a/t/ansi-test/environment/inspect.lsp +++ /dev/null @@ -1,17 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun May 15 12:54:22 2005 -;;;; Contains: Tests of INSPECT - - - -;;; INSPECT's normal behavior is entirely implementation-dependent, -;;; so it cannot be tested here. Only test simple error cases. - -(deftest inspect.error.1 - (signals-error (inspect) program-error) - t) - -(deftest inspect.error.2 - (signals-error (inspect nil nil) program-error) - t) diff --git a/t/ansi-test/environment/load.lsp b/t/ansi-test/environment/load.lsp deleted file mode 100644 index 95d8b2c..0000000 --- a/t/ansi-test/environment/load.lsp +++ /dev/null @@ -1,31 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Dec 12 19:43:17 2004 -;;;; Contains: Load environment tests (section 25) - -(in-package #:cl-test) - -(let ((*default-pathname-defaults* - (make-pathname - :directory (pathname-directory *load-pathname*)))) - (load "apropos.lsp") - (load "apropos-list.lsp") - (load "describe.lsp") - (load "disassemble.lsp") - (load "environment-functions.lsp") - (load "room.lsp") - (load "time.lsp") - (load "trace.lsp") ;; and untrace - (load "user-homedir-pathname.lsp") - - (load "decode-universal-time.lsp") - (load "encode-universal-time.lsp") - (load "get-universal-time.lsp") - (load "sleep.lsp") - (load "get-internal-time.lsp") - - (load "documentation.lsp") - #-lispworks (load "inspect.lsp") - (load "dribble.lsp") - (load "ed.lsp") -) diff --git a/t/ansi-test/environment/room.lsp b/t/ansi-test/environment/room.lsp deleted file mode 100644 index ac7c43d..0000000 --- a/t/ansi-test/environment/room.lsp +++ /dev/null @@ -1,46 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Dec 12 09:20:47 2004 -;;;; Contains: Tests of ROOM - - - -(deftest room.1 - (let ((s (with-output-to-string - (*standard-output*) - (room)))) - (not (zerop (length s)))) - t) - -(deftest room.2 - (let ((s (with-output-to-string - (*standard-output*) - (room nil)))) - (not (zerop (length s)))) - t) - -(deftest room.3 - (let ((s (with-output-to-string - (*standard-output*) - (room :default)))) - (not (zerop (length s)))) - t) - -(deftest room.4 - (let ((s (with-output-to-string - (*standard-output*) - (room t)))) - (not (zerop (length s)))) - t) - -;;; Error tests - -(deftest room.errpr.1 - (signals-error (with-output-to-string (*standard-output*) (room nil nil)) program-error) - t) - - - - - - diff --git a/t/ansi-test/environment/sleep.lsp b/t/ansi-test/environment/sleep.lsp deleted file mode 100644 index d8445b2..0000000 --- a/t/ansi-test/environment/sleep.lsp +++ /dev/null @@ -1,75 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun May 8 19:53:39 2005 -;;;; Contains: Tests of SLEEP - - - -(deftest sleep.1 - (sleep 0) - nil) - -(deftest sleep.2 - (sleep 0.0s0) - nil) - -(deftest sleep.3 - (sleep 0.0f0) - nil) - -(deftest sleep.4 - (sleep 0.0d0) - nil) - -(deftest sleep.5 - (sleep 0.0l0) - nil) - -(deftest sleep.6 - (sleep 1.0f-8) - nil) - -(deftest sleep.7 - (sleep 1/100) - nil) - -(deftest sleep.8 - (sleep (/ internal-time-units-per-second)) - nil) - -(deftest sleep.9 - (sleep (/ 1000000000000000000000000000000)) - nil) - -(deftest sleep.10 - (sleep least-positive-short-float) - nil) - -(deftest sleep.11 - (sleep least-positive-single-float) - nil) - -(deftest sleep.12 - (sleep least-positive-double-float) - nil) - -(deftest sleep.13 - (sleep least-positive-long-float) - nil) - -;;; Error cases - -(deftest sleep.error.1 - (signals-error (sleep) program-error) - t) - -(deftest sleep.error.2 - (signals-error (sleep 100 nil) program-error) - t) - -(deftest sleep.error.3 - (check-type-error #'sleep #'(lambda (x) (and (realp x) (>= x 0)))) - nil) - - - diff --git a/t/ansi-test/environment/time.lsp b/t/ansi-test/environment/time.lsp deleted file mode 100644 index e55ba80..0000000 --- a/t/ansi-test/environment/time.lsp +++ /dev/null @@ -1,84 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Dec 12 09:43:47 2004 -;;;; Contains: Tests of TIME - - - -(deftest time.1 - (let ((s (with-output-to-string - (*trace-output*) - (assert (null (time nil)))))) - (= (length s) 0)) - nil) - -(deftest time.2 - (let ((s (with-output-to-string - (*trace-output*) - (let ((x (cons 'a 'b))) - (assert (eq (time x) x)))))) - (= (length s) 0)) - nil) - -(deftest time.3 - (let ((s (with-output-to-string - (*trace-output*) - (let ((x (cons 'a 'b))) - (flet ((%f () x)) - (assert (eq (time (%f)) x))))))) - (= (length s) 0)) - nil) - -(deftest time.4 - (let ((s (with-output-to-string - (*trace-output*) - (assert (null (multiple-value-list (time (values)))))))) - (= (length s) 0)) - nil) - -(deftest time.5 - (let ((s (with-output-to-string - (*trace-output*) - (assert (equal '(a b c d) - (multiple-value-list (time (values 'a 'b 'c 'd)))))))) - (= (length s) 0)) - nil) - -(deftest time.6 - (let ((fn (compile nil '(lambda () (time nil))))) - (let ((s (with-output-to-string - (*trace-output*) - (assert (null (funcall fn)))))) - (= (length s) 0))) - nil) - -(deftest time.7 - (flet ((%f () (time nil))) - (let ((s (with-output-to-string - (*trace-output*) - (assert (null (%f)))))) - (= (length s) 0))) - nil) - -(deftest time.8 - (let ((s (with-output-to-string - (*trace-output*) - (macrolet ((%m () 1)) - (assert (eql (time (%m)) 1)))))) - (= (length s) 0)) - nil) - -;;; The TIME definition is weasely, so strenuous complaints from -;;; implementors about specific tests lead me to remove them. -;;; Someone didn't like this one at all. -#| -(deftest time.9 - (let ((s (with-output-to-string - (*trace-output*) - (block done - (time (return-from done nil)))))) - (= (length s) 0)) - nil) -|# - - diff --git a/t/ansi-test/environment/trace.lsp b/t/ansi-test/environment/trace.lsp deleted file mode 100644 index e20d92c..0000000 --- a/t/ansi-test/environment/trace.lsp +++ /dev/null @@ -1,187 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Dec 12 19:53:11 2004 -;;;; Contains: Tests of TRACE, UNTRACE - - - -(defun function-to-trace (x) (car x)) -(defun another-function-to-trace (x) (cdr x)) -(defun (setf function-to-trace) (val arg) (setf (car arg) val)) - -(declaim (notinline function-to-trace - another-function-to-trace - (setf function-to-trace))) - -(deftest trace.1 - (progn - (untrace) ;; ensure it's not traced - (with-output-to-string - (*trace-output*) - (assert (eql (function-to-trace '(a)) 'a)))) - "") - -(deftest trace.2 - (progn - (trace function-to-trace) - (equal "" (with-output-to-string - (*trace-output*) - (assert (eql (function-to-trace '(b)) 'b))))) - nil) - -(deftest trace.3 - (progn - (untrace) - (trace function-to-trace) - (prog1 (trace) - (untrace) - (assert (null (trace))))) - (function-to-trace)) - - -(deftest trace.4 - (progn - (untrace) - (trace function-to-trace) - (handler-bind ((warning #'muffle-warning)) - (trace function-to-trace)) - (prog1 (trace) - (untrace) - (assert (null (trace))))) - (function-to-trace)) - -(deftest trace.5 - (progn - (untrace) - (trace (setf function-to-trace)) - (prog1 (trace) - (untrace) - (assert (null (trace))))) - ((setf function-to-trace))) - -(deftest trace.6 - (progn - (untrace) - (trace (setf function-to-trace)) - (handler-bind ((warning #'muffle-warning)) - (trace (setf function-to-trace))) - (prog1 (trace) - (untrace) - (assert (null (trace))))) - ((setf function-to-trace))) - -(deftest trace.7 - (progn - (untrace) - (with-output-to-string - (*trace-output*) - (let ((x (list nil))) - (assert (eql (setf (function-to-trace x) 'a) 'a)) - (assert (equal x '(a)))))) - "") - -(deftest trace.8 - (progn - (untrace) - (trace (setf function-to-trace)) - (equal "" - (with-output-to-string - (*trace-output*) - (let ((x (list nil))) - (assert (eql (setf (function-to-trace x) 'a) 'a)) - (assert (equal x '(a))))))) - nil) - -(deftest trace.9 - (progn - (untrace) - (trace function-to-trace another-function-to-trace) - (assert (not (equal "" (with-output-to-string - (*trace-output*) - (assert (eql (function-to-trace '(b)) 'b)))))) - (assert (not (equal "" (with-output-to-string - (*trace-output*) - (assert (eql (another-function-to-trace '(c . d)) - 'd)))))) - (prog1 - (sort (copy-list (trace)) - #'(lambda (k1 k2) (string< (symbol-name k1) - (symbol-name k2)))) - (untrace))) - (another-function-to-trace function-to-trace)) - -(deftest trace.10 - (progn - (untrace) - (assert (null (trace))) - (trace function-to-trace) - (untrace function-to-trace) - (assert (null (trace))) - (handler-bind ((warning #'muffle-warning)) (untrace function-to-trace)) - (assert (null (trace))) - nil) - nil) - -(deftest trace.11 - (progn - (untrace) - (trace function-to-trace another-function-to-trace) - (untrace function-to-trace another-function-to-trace) - (trace)) - nil) - -;;; Tracing a generic function - -(declaim (notinline generic-function-to-trace)) - -(deftest trace.12 - (progn - (untrace) - (eval '(defgeneric generic-function-to-trace (x y))) - (trace generic-function-to-trace) - (prog1 (trace) (untrace))) - (generic-function-to-trace)) - -(deftest trace.13 - (progn - (untrace) - (eval '(defgeneric generic-function-to-trace (x y))) - (trace generic-function-to-trace) - (eval '(defmethod generic-function-to-trace ((x t)(y t)) nil)) - (prog1 (trace) (untrace))) - (generic-function-to-trace)) - -(deftest trace.14 - (progn - (untrace) - (eval '(defgeneric generic-function-to-trace (x y))) - (trace generic-function-to-trace) - (eval '(defmethod generic-function-to-trace ((x t)(y t)) nil)) - (assert (not (equal (with-output-to-string - (*trace-output*) - (assert (null (generic-function-to-trace 'a 'b)))) - ""))) - (prog1 - (trace) - (untrace generic-function-to-trace) - (assert (null (trace))))) - (generic-function-to-trace)) - -(declaim (notinline generic-function-to-trace2)) - -(deftest trace.15 - (progn - (untrace) - (let* ((gf (eval '(defgeneric generic-function-to-trace2 (x y)))) - (m (eval '(defmethod generic-function-to-trace2 - ((x integer)(y integer)) - :foo)))) - (eval '(defmethod generic-function-to-trace2 - ((x symbol)(y symbol)) :bar)) - (assert (eql (generic-function-to-trace2 1 2) :foo)) - (assert (eql (generic-function-to-trace2 'a 'b) :bar)) - (trace generic-function-to-trace2) - (assert (equal (trace) '(generic-function-to-trace2))) - (remove-method gf m) - (prog1 (trace) (untrace)))) - (generic-function-to-trace2)) diff --git a/t/ansi-test/environment/user-homedir-pathname.lsp b/t/ansi-test/environment/user-homedir-pathname.lsp deleted file mode 100644 index f8e13da..0000000 --- a/t/ansi-test/environment/user-homedir-pathname.lsp +++ /dev/null @@ -1,52 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Dec 11 22:26:24 2004 -;;;; Contains: Tests of USER-HOMEDIR-PATHNAME - - - -(deftest user-homedir-pathname.1 - (let ((pn (user-homedir-pathname))) - (notnot pn)) - t) - -(deftest user-homedir-pathname.2 - (let* ((pn-list (multiple-value-list (user-homedir-pathname))) - (pn (first pn-list))) - (values - (length pn-list) - (notnot-mv (pathnamep pn)))) - 1 t) - -(deftest user-homedir-pathname.3 - (let ((pn (user-homedir-pathname))) - (pathname-name pn)) - nil) - -(deftest user-homedir-pathname.4 - (let ((pn (user-homedir-pathname))) - (pathname-type pn)) - nil) - -(deftest user-homedir-pathname.5 - (let ((pn (user-homedir-pathname))) - (pathname-version pn)) - nil) - -;; (deftest user-homedir-pathname.6 -;; (let* ((pn (user-homedir-pathname)) -;; (host (pathname-host pn))) -;; (or (not host) -;; (equalt pn (user-homedir-pathname host)))) -;; t) - -(deftest user-homedir-pathname.7 - (let* ((pn (user-homedir-pathname :unspecific))) - (or (null pn) - (notnot (pathnamep pn)))) - t) - -(deftest user-homedir-pathname.error.1 - (signals-error (user-homedir-pathname :unspecific nil) program-error) - t) - diff --git a/t/ansi-test/eval-and-compile/compile.lsp b/t/ansi-test/eval-and-compile/compile.lsp deleted file mode 100644 index 9ac60e8..0000000 --- a/t/ansi-test/eval-and-compile/compile.lsp +++ /dev/null @@ -1,94 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Oct 10 20:54:20 2002 -;;;; Contains: Tests for COMPILE, COMPILED-FUNCTION-P, COMPILED-FUNCTION - - - -(deftest compile.1 - (progn - (fmakunbound 'compile.1-fn) - (values - (eval '(defun compile.1-fn (x) x)) - (compiled-function-p 'compile.1-fn) - (let ((x (compile 'compile.1-fn))) - (or (eqt x 'compile.1-fn) - (notnot (compiled-function-p x)))) - (compiled-function-p 'compile.1-fn) - (not (compiled-function-p #'compile.1-fn)) - (fmakunbound 'compile.1-fn))) - compile.1-fn - nil - t - nil - nil - compile.1-fn) - - -;;; COMPILE returns three values (function, warnings-p, failure-p) -(deftest compile.2 - (let* ((results (multiple-value-list - (compile nil '(lambda (x y) (cons y x))))) - (fn (car results))) - (values (length results) - (funcall fn 'a 'b) - (second results) - (third results))) - 3 - (b . a) - nil - nil) - -;;; Compile does not coalesce literal constants -(deftest compile.3 - (let ((x (list 'a 'b)) - (y (list 'a 'b))) - (and (not (eqt x y)) - (funcall (compile nil `(lambda () (eqt ',x ',y)))))) - nil) - -(deftest compile.4 - (let ((x (copy-seq "abc")) - (y (copy-seq "abc"))) - (and (not (eqt x y)) - (funcall (compile nil `(lambda () (eqt ,x ,y)))))) - nil) - -(deftest compile.5 - (let ((x (copy-seq "abc"))) - (funcall (compile nil `(lambda () (eqt ,x ,x))))) - t) - -(deftest compile.6 - (let ((x (copy-seq "abc"))) - (funcall (compile nil `(lambda () (eqt ',x ',x))))) - t) - -(deftest compile.7 - (let ((x (copy-seq "abc"))) - (eqt x (funcall (compile nil `(lambda () ,x))))) - t) - -(deftest compile.8 - (let ((x (list 'a 'b))) - (eqt x (funcall (compile nil `(lambda () ',x))))) - t) - -(deftest compile.9 - (let ((i 0) a b) - (values - (funcall (compile (progn (setf a (incf i)) nil) - (progn (setf b (incf i)) '(lambda () 'z)))) - i a b)) - z 2 1 2) - -;;; Error tests - -(deftest compile.error.1 - (signals-error (compile) program-error) - t) - -(deftest compile.error.2 - (signals-error (compile nil '(lambda () nil) 'garbage) - program-error) - t) diff --git a/t/ansi-test/eval-and-compile/compiler-macros.lsp b/t/ansi-test/eval-and-compile/compiler-macros.lsp deleted file mode 100644 index d3d4267..0000000 --- a/t/ansi-test/eval-and-compile/compiler-macros.lsp +++ /dev/null @@ -1,8 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Jan 13 18:51:30 2003 -;;;; Contains: Tests for compiler macros - - - -;;; Compiler macro tests will go here diff --git a/t/ansi-test/eval-and-compile/constantp.lsp b/t/ansi-test/eval-and-compile/constantp.lsp deleted file mode 100644 index 1e51414..0000000 --- a/t/ansi-test/eval-and-compile/constantp.lsp +++ /dev/null @@ -1,97 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Jan 13 19:12:17 2003 -;;;; Contains: Tests for CONSTANTP - -;;; See also defconstant.lsp - - - -;;; Error tests - -(deftest constantp.error.1 - (signals-error (constantp) program-error) - t) - -(deftest constantp.error.2 - (signals-error (constantp nil nil nil) program-error) - t) - -;;; Non-error tests - -(deftest constantp.1 - (check-predicate #'(lambda (e) (or (symbolp e) (consp e) (constantp e)))) - nil) - -(deftest constantp.2 - (notnot-mv (constantp t)) - t) - -(deftest constantp.3 - (notnot-mv (constantp nil)) - t) - -(deftest constantp.4 - (notnot-mv (constantp :foo)) - t) - -(deftest constantp.5 - (constantp (gensym)) - nil) - -(defconstant constantp-test-symbol 1) - -(defmacro constantp-macro (form &environment env) - (notnot-mv (constantp form env))) - -(deftest constantp.6 - (constantp-macro constantp-test-symbol) - t) - -(deftest constantp.7 - (constantp '(incf x)) - nil) - -(deftest constantp.8 - (notnot-mv (constantp 1 nil)) - t) - -(deftest constantp.9 - (notnot-mv (constantp ''(((foo))))) - t) - -(deftest constantp.10 - (notnot-mv (constantp 'pi)) - t) - -(defmacro macro-for-constantp.11 (x) x) - -(deftest constantp.11 - (macrolet ((macro-for-constantp.11 (y) - (declare (ignore y)) - '*standard-input*)) - (macrolet ((%m (&environment env) - (if (constantp '(macro-for-constantp.11 0) env) - :bad - :good))) - (%m))) - :good) - - -(deftest constantp.order.1 - (let ((i 0)) - (values - (notnot (constantp (progn (incf i) 1))) - i)) - t 1) - -(deftest constantp.order.2 - (let ((i 0) x y) - (values - (notnot (constantp (progn (setf x (incf i)) 1) - (progn (setf y (incf i)) nil))) - i x y)) - t 2 1 2) - - - diff --git a/t/ansi-test/eval-and-compile/declaim.lsp b/t/ansi-test/eval-and-compile/declaim.lsp deleted file mode 100644 index 31612b3..0000000 --- a/t/ansi-test/eval-and-compile/declaim.lsp +++ /dev/null @@ -1,56 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat May 21 07:44:07 2005 -;;;; Contains: Tests of DECLAIM - - - -(deftest declaim.1 - (progn (declaim) nil) - nil) - -(deftest declaim.2 - (progn (eval `(declaim (optimize))) nil) - nil) - -(deftest declaim.3 - (progn (eval `(declaim (inline))) nil) - nil) - -(deftest declaim.4 - (progn (eval `(declaim (notinline))) nil) - nil) - -(deftest declaim.5 - (progn (eval `(declaim (type t))) nil) - nil) - -(deftest declaim.6 - (progn (eval `(declaim (special))) nil) - nil) - -(deftest declaim.7 - (progn (eval `(declaim (integer))) nil) - nil) - -(deftest declaim.8 - (progn (eval `(declaim (declaration))) nil) - nil) - -(deftest declaim.9 - (progn (eval `(declaim (ftype (function (t) t)))) nil) - nil) - -(deftest declaim.10 - (let ((sym (gensym))) - (eval `(declaim (declaration ,sym))) - (eval `(declaim (,sym))) - nil) - nil) - -(deftest declaim.11 - (let ((sym (gensym))) - (eval `(declaim (optimize) (special ,sym) (inline) (special))) - (eval `(flet ((%f () ,sym)) - (let ((,sym :good)) (%f))))) - :good) diff --git a/t/ansi-test/eval-and-compile/declaration.lsp b/t/ansi-test/eval-and-compile/declaration.lsp deleted file mode 100644 index f216e18..0000000 --- a/t/ansi-test/eval-and-compile/declaration.lsp +++ /dev/null @@ -1,96 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun May 29 07:16:15 2005 -;;;; Contains: Tests of the DECLARATION declarations - - - - -(deftest declaration.1 - (progn (declaim (declaration)) nil) - nil) - -(deftest declaration.2 - (progn (proclaim '(declaration)) nil) - nil) - -(deftest declaration.3 - (let ((sym (gensym)) - (sym2 (gensym))) - (proclaim `(declaration ,sym ,sym2)) - nil) - nil) - -;;; For the error tests, see the page in the CLHS for TYPE: -;;; "A symbol cannot be both the name of a type and the name -;;; of a declaration. Defining a symbol as the name of a class, -;;; structure, condition, or type, when the symbol has been -;;; declared as a declaration name, or vice versa, signals an error." - -;;; Declare these only if bad declarations produce warnings. - -(when (block done - (handler-bind ((warning #'(lambda (c) (return-from done t)))) - (eval `(let () (declare (,(gensym))) nil)))) - -(deftest declaration.4 - (let ((sym (gensym))) - (proclaim `(declaration ,sym)) - (eval `(signals-error-always (deftype ,sym () t) error))) - t t) - -(deftest declaration.5 - (let ((sym (gensym))) - (proclaim `(declaration ,sym)) - (eval `(signals-error-always (defstruct ,sym a b c) error))) - t t) - -(deftest declaration.6 - (let ((sym (gensym))) - (proclaim `(declaration ,sym)) - (eval `(signals-error-always (defclass ,sym () (a b c)) error))) - t t) - -(deftest declaration.7 - (let ((sym (gensym))) - (proclaim `(declaration ,sym)) - (eval `(signals-error-always (define-condition ,sym (condition) (a b c)) - error))) - t t) - -(deftest declaration.8 - (let ((sym (gensym))) - (eval `(deftype ,sym () 'error)) - (eval `(signals-error-always (proclaim '(declaration ,sym)) - error))) - t t) - -(deftest declaration.9 - (let ((sym (gensym))) - (eval `(defstruct ,sym a b c)) - (eval `(signals-error-always (proclaim '(declaration ,sym)) - error))) - t t) - -(deftest declaration.10 - (let ((sym (gensym))) - (eval `(defclass ,sym () (a b c))) - (eval `(signals-error-always (proclaim '(declaration ,sym)) - error))) - t t) - -(deftest declaration.11 - (let ((sym (gensym))) - (eval `(define-condition ,sym (condition) (a b c))) - (eval `(signals-error-always (proclaim '(declaration ,sym)) - error))) - t t) - -) - - - - - - - diff --git a/t/ansi-test/eval-and-compile/define-compiler-macro.lsp b/t/ansi-test/eval-and-compile/define-compiler-macro.lsp deleted file mode 100644 index fc0440b..0000000 --- a/t/ansi-test/eval-and-compile/define-compiler-macro.lsp +++ /dev/null @@ -1,175 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Apr 20 12:33:02 2003 -;;;; Contains: Tests of DEFINE-COMPILER-MACRO - - - -;;; Need to add non-error tests - -(deftest define-compiler-macro.error.1 - (signals-error (funcall (macro-function 'define-compiler-macro)) - program-error) - t) - -(deftest define-compiler-macro.error.2 - (signals-error (funcall (macro-function 'define-compiler-macro) - '(definee-compiler-macro nonexistent-function ())) - program-error) - t) - -(deftest define-compiler-macro.error.3 - (signals-error (funcall (macro-function 'define-compiler-macro) - '(definee-compiler-macro nonexistent-function ()) - nil nil) - program-error) - t) - -;;; Non-error tests - -(deftest define-compiler-macro.1 - (let* ((sym (gensym)) - (macro-def-form - `(define-compiler-macro ,sym (x y) - (declare (special *x*)) - (setf *x* t) - `(+ ,x ,y 1))) - (fun-def-form - `(defun ,sym (x y) (+ x y 1)))) - (values - (equalt (list sym) (multiple-value-list (eval fun-def-form))) - (equalt (list sym) (multiple-value-list (eval macro-def-form))) - (notnot (typep (compiler-macro-function sym) 'function)) - (eval `(,sym 6 19)) - (let ((fn (compile nil `(lambda (a b) (,sym a b))))) - (let ((*x* nil)) - (declare (special *x*)) - (list (funcall fn 12 123) *x*))))) - t t t 26 (136 nil)) - -(deftest define-compiler-macro.2 - (let* ((sym (gensym)) - (macro-def-form - `(define-compiler-macro ,sym (&whole form &rest args) - (declare (special *x*) (ignore args)) - (setf *x* t) - (return-from ,sym form))) - (fun-def-form - `(defun ,sym (x) x))) - (values - (equalt (list sym) (multiple-value-list (eval fun-def-form))) - (equalt (list sym) (multiple-value-list (eval macro-def-form))) - (notnot (typep (compiler-macro-function sym) 'function)) - (eval `(,sym 'a)) - (let ((fn (compile nil `(lambda (a) (,sym a))))) - (let ((*x* nil)) - (declare (special *x*)) - (list (funcall fn 'b) *x*))))) - t t t a (b nil)) - -(deftest define-compiler-macro.3 - (let* ((sym (gensym)) - (macro-def-form - `(define-compiler-macro ,sym (&whole form &rest args) - (declare (special *x*) (ignore args)) - (setf *x* t) - (return-from ,sym form))) - (ordinary-macro-def-form - `(defmacro ,sym (x) x))) - (values - (equalt (list sym) (multiple-value-list (eval ordinary-macro-def-form))) - (equalt (list sym) (multiple-value-list (eval macro-def-form))) - (notnot (typep (compiler-macro-function sym) 'function)) - (eval `(,sym 'a)) - (let ((fn (compile nil `(lambda (a) (,sym a))))) - (let ((*x* nil)) - (declare (special *x*)) - (list (funcall fn 'b) *x*))))) - t t t a (b nil)) - -;;; Compiler macros on setf functions - -(deftest define-compiler-macro.4 - (let* ((sym (gensym)) - (fun-def-form `(defun ,sym (x) (car x))) - (setf-fun-def-form `(defun (setf ,sym) (newval x) (setf (car x) newval))) - (setf-compiler-macro-def-form - `(define-compiler-macro (setf ,sym) (newval x) - (declare (special *x*)) - (setf *x* t) - (return-from ,sym `(setf (car ,x) ,newval))))) - (values - (equalt (list sym) (multiple-value-list (eval fun-def-form))) - (equalt `((setf ,sym)) (multiple-value-list (eval setf-fun-def-form))) - (equalt `((setf ,sym)) (multiple-value-list (eval setf-compiler-macro-def-form))) - (notnot (typep (compiler-macro-function `(setf ,sym)) 'function)) - (eval `(,sym (list 'a 'b))) - (eval `(let ((arg (list 1 2))) - (list (setf (,sym arg) 'z) arg))) - (let ((fn (compile nil `(lambda (u v) (setf (,sym u) v))))) - (let ((*x* nil) - (arg (list 1 2))) - (declare (special *x*)) - (list (funcall fn arg 'y) arg))))) - t t t t a (z (z 2)) (y (y 2))) - -;;; Test of documentation - -(deftest define-compiler-macro.5 - (let* ((sym (gensym)) - (form `(define-compiler-macro ,sym (x) "DCM.5" x)) - (form2 `(defun ,sym (x) "DCM.5-WRONG" x))) - (eval form) - (eval form2) - (or (documentation sym 'compiler-macro) "DCM.5")) - "DCM.5") - -(deftest define-compiler-macro.6 - (let* ((sym (gensym)) - (form `(define-compiler-macro ,sym (x) "DCM.6" x)) - (form2 `(defun ,sym (x) "DCM.6-WRONG" x))) - (eval form2) - (eval form) - (or (documentation sym 'compiler-macro) "DCM.6")) - "DCM.6") - -;;; NOTINLINE turns off a compiler macro - -(deftest define-compiler-macro.7 - (let* ((sym (gensym)) - (form `(define-compiler-macro ,sym (x y) - (declare (special *x*)) - (setf *x* :bad) - `(list ,x ,y))) - (form2 `(defun ,sym (x y) (list x y)))) - (eval form) - (eval form2) - (compile sym) - (let ((*x* :good)) - (declare (special *x*)) - (values - (funcall (compile nil `(lambda (a b) - (declare (notinline ,sym)) - (,sym a b))) - 5 11) - *x*))) - (5 11) :good) - -(deftest define-compiler-macro.8 - (let* ((sym (gensym)) - (form `(define-compiler-macro ,sym (x y) - (declare (special *x*)) - (setf *x* :bad) - `(list ,x ,y))) - (form2 `(defmacro ,sym (x y) `(list ,x ,y)))) - (eval form) - (eval form2) - (let ((*x* :good)) - (declare (special *x*)) - (values - (funcall (compile nil `(lambda (a b) - (declare (notinline ,sym)) - (,sym a b))) - 7 23) - *x*))) - (7 23) :good) diff --git a/t/ansi-test/eval-and-compile/define-symbol-macro.lsp b/t/ansi-test/eval-and-compile/define-symbol-macro.lsp deleted file mode 100644 index d29fdda..0000000 --- a/t/ansi-test/eval-and-compile/define-symbol-macro.lsp +++ /dev/null @@ -1,26 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Apr 20 12:55:05 2003 -;;;; Contains: Tests of DEFINE-SYMBOL-MACRO - - - -(deftest define-symbol-macro.error.1 - (signals-error (funcall (macro-function 'define-symbol-macro)) - program-error) - t) - -(deftest define-symbol-macro.error.2 - (signals-error (funcall (macro-function 'define-symbol-macro) - '(define-symbol-macro - nonexistent-symbol-macro nil)) - program-error) - t) - -(deftest define-symbol-macro.error.3 - (signals-error (funcall (macro-function 'define-symbol-macro) - '(define-symbol-macro - nonexistent-symbol-macro nil) - nil nil) - program-error) - t) diff --git a/t/ansi-test/eval-and-compile/defmacro.lsp b/t/ansi-test/eval-and-compile/defmacro.lsp deleted file mode 100644 index f1aa869..0000000 --- a/t/ansi-test/eval-and-compile/defmacro.lsp +++ /dev/null @@ -1,318 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Apr 20 12:35:24 2003 -;;;; Contains: Tests of DEFMACRO - - - -(deftest defmacro.error.1 - (signals-error (funcall (macro-function 'defmacro)) - program-error) - t) - -(deftest defmacro.error.2 - (signals-error (funcall (macro-function 'defmacro) - '(defmacro nonexistent-macro ())) - program-error) - t) - -(deftest defmacro.error.3 - (signals-error (funcall (macro-function 'defmacro) - '(defmacro nonexistent-macro ()) - nil nil) - program-error) - t) - -;;; FIXME -;;; Need to add non-error tests - -(deftest defmacro.1 - (progn - (assert (eq (defmacro defmacro.1-macro (x y) `(list 1 ,x 2 ,y 3)) - 'defmacro.1-macro)) - (assert (macro-function 'defmacro.1-macro)) - (eval `(defmacro.1-macro 'a 'b))) - (1 a 2 b 3)) - -(deftest defmacro.2 - (progn - (assert (eq (defmacro defmacro.2-macro (x y) - (return-from defmacro.2-macro `(cons ,x ,y))) - 'defmacro.2-macro)) - (assert (macro-function 'defmacro.2-macro)) - (eval `(defmacro.2-macro 'a 'b))) - (a . b)) - -;;; The macro function is defined in the lexical environment in which -;;; the defmacro form occurs. -(deftest defmacro.3 - (let (fn) - (let ((x 0)) - (setq fn #'(lambda (n) (setq x n))) - (defmacro defmacro.3-macro () `',x)) - (values - (eval '(defmacro.3-macro)) - (funcall fn 'a) - (eval '(defmacro.3-macro)))) - 0 a a) - -;;; Declarations are allowed. - -;;; Free special declarations do not apply to the forms -;;; in the lambda list -(deftest defmacro.4 - (let ((y :good)) - (assert (eq (defmacro defmacro.4-macro (&optional (x y)) - (declare (special y)) - x) - 'defmacro.4-macro)) - (let ((y :bad)) - (declare (special y)) - (values (macroexpand-1 '(defmacro.4-macro))))) - :good) - -(deftest defmacro.5 - (progn - (assert (eq (defmacro defmacro.5-macro () - (declare) (declare) "a doc string" (declare) - t) - 'defmacro.5-macro)) - (eval `(defmacro.5-macro))) - t) - -;;; &whole argument, top level -(deftest defmacro.6 - (progn - (defmacro defmacro.6-macro (&whole w arg) - `(list ',w ',arg)) - (eval `(defmacro.6-macro x))) - ((defmacro.6-macro x) x)) - -;;; &whole argument in destructuring -(deftest defmacro.7 - (progn - (defmacro defmacro.7-macro (arg1 (&whole w arg2)) - `(list ',w ',arg1 ',arg2)) - (eval `(defmacro.7-macro x (y)))) - ((y) x y)) - -;;; keyword parameters -(deftest defmacro.8 - (progn - (defmacro defmacro.8-macro (&key foo bar) - `(list ',foo ',bar)) - (mapcar #'eval '((defmacro.8-macro :foo x) - (defmacro.8-macro :bar y) - (defmacro.8-macro :bar a :foo b) - (defmacro.8-macro :bar a :foo b :bar c)))) - ((x nil) (nil y) (b a) (b a))) - -;;; keyword parameters with default value -(deftest defmacro.9 - (progn - (defmacro defmacro.9-macro (&key (foo 1) (bar 2)) - `(list ',foo ',bar)) - (mapcar #'eval '((defmacro.9-macro :foo x) - (defmacro.9-macro :bar y) - (defmacro.9-macro :foo nil) - (defmacro.9-macro :bar nil) - (defmacro.9-macro :bar a :foo b) - (defmacro.9-macro :bar a :foo b :bar c)))) - ((x 2) (1 y) (nil 2) (1 nil) (b a) (b a))) - -;;; keyword parameters with supplied-p parameter -(deftest defmacro.10 - (progn - (defmacro defmacro.10-macro (&key (foo 1 foo-p) (bar 2 bar-p)) - `(list ',foo ,(notnot foo-p) ',bar ,(notnot bar-p))) - (mapcar #'eval '((defmacro.10-macro) - (defmacro.10-macro :foo x) - (defmacro.10-macro :bar y) - (defmacro.10-macro :foo nil) - (defmacro.10-macro :bar nil) - (defmacro.10-macro :foo x :bar y) - (defmacro.10-macro :bar y :foo x) - (defmacro.10-macro :bar a :bar b) - (defmacro.10-macro :foo a :foo b)))) - ((1 nil 2 nil) (x t 2 nil) (1 nil y t) - (nil t 2 nil) (1 nil nil t) (x t y t) - (x t y t) (1 nil a t) (a t 2 nil))) - -;;; key arguments in destructuring - -(deftest defmacro.11 - (progn - (defmacro defmacro.11-macro ((&key foo bar)) `(list ',foo ',bar)) - (mapcar #'eval '((defmacro.11-macro nil) - (defmacro.11-macro (:foo x)) - (defmacro.11-macro (:bar y)) - (defmacro.11-macro (:foo x :bar y :foo z)) - (defmacro.11-macro (:bar y :bar z :foo x))))) - ((nil nil) (x nil) (nil y) (x y) (x y))) - -;;; key arguments in destructuring and defaults - -(deftest defmacro.12 - (progn - (let ((foo-default 1) - (bar-default 2)) - (defmacro defmacro.12-macro ((&key (foo foo-default) - (bar bar-default))) - `(list ',foo ',bar))) - (mapcar #'eval '((defmacro.12-macro nil) - (defmacro.12-macro (:foo x)) - (defmacro.12-macro (:bar y)) - (defmacro.12-macro (:foo x :bar y :foo z)) - (defmacro.12-macro (:bar y :bar z :foo x))))) - ((1 2) (x 2) (1 y) (x y) (x y))) - -;;; key arguments in destructuring and supplied-p parameter - -(deftest defmacro.13 - (progn - (let ((foo-default 1) - (bar-default 2)) - (defmacro defmacro.13-macro ((&key (foo foo-default foo-p) - (bar bar-default bar-p))) - `(list ',foo ,(notnot foo-p) ',bar ,(notnot bar-p)))) - (mapcar #'eval '((defmacro.13-macro nil) - (defmacro.13-macro (:foo x)) - (defmacro.13-macro (:bar y)) - (defmacro.13-macro (:foo nil :bar nil :foo 4 :bar 14)) - (defmacro.13-macro (:foo 1 :bar 2)) - (defmacro.13-macro (:foo x :bar y :foo z)) - (defmacro.13-macro (:bar y :bar z :foo x))))) - ((1 nil 2 nil) (x t 2 nil) (1 nil y t) - (nil t nil t) (1 t 2 t) - (x t y t) (x t y t))) - -;;; rest parameter -(deftest defmacro.14 - (progn - (defmacro defmacro.14-macro (foo &rest bar) - `(list ',foo ',bar)) - (mapcar #'eval '((defmacro.14-macro x) - (defmacro.14-macro x y) - (defmacro.14-macro x y z)))) - ((x nil) (x (y)) (x (y z)))) - -;;; rest parameter with destructuring -(deftest defmacro.15 - (progn - (defmacro defmacro.15-macro (foo &rest (bar . baz)) - `(list ',foo ',bar ',baz)) - (eval '(defmacro.15-macro x y z))) - (x y (z))) - -;;; rest parameter w. whole -(deftest defmacro.16 - (progn - (defmacro defmacro.16-macro (&whole w foo &rest bar) - `(list ',w ',foo ',bar)) - (mapcar #'eval '((defmacro.16-macro x) - (defmacro.16-macro x y) - (defmacro.16-macro x y z)))) - (((defmacro.16-macro x) x nil) - ((defmacro.16-macro x y) x (y)) - ((defmacro.16-macro x y z) x (y z)))) - -;;; env parameter -(deftest defmacro.17 - (progn - (defmacro defmacro.17-macro (x &environment env) - `(quote ,(macroexpand x env))) - (eval - `(macrolet ((%m () :good)) - (defmacro.17-macro (%m))))) - :good) - -(deftest defmacro.17a - (progn - (defmacro defmacro.17a-macro (&environment env x) - `(quote ,(macroexpand x env))) - (eval - `(macrolet ((%m () :good)) - (defmacro.17a-macro (%m))))) - :good) - -;;; &optional with supplied-p parameter -;;; Note: this is required to be T if the parameter is present (3.4.4.1.2) -(deftest defmacro.18 - (progn - (defmacro defmacro.18-macro (x &optional (y 'a y-p) (z 'b z-p)) - `(list ',x ',y ',y-p ',z ',z-p)) - (mapcar #'eval '((defmacro.18-macro p) - (defmacro.18-macro p q) - (defmacro.18-macro p q r)))) - ((p a nil b nil) - (p q t b nil) - (p q t r t))) - -;;; Optional with destructuring -(deftest defmacro.19 - (progn - (defmacro defmacro.19-macro (&optional ((x . y) '(a . b))) - `(list ',x ',y)) - (mapcar #'eval '((defmacro.19-macro) - (defmacro.19-macro (c d))))) - ((a b) (c (d)))) - -;;; Allow other keys - -(deftest defmacro.20 - (progn - (defmacro defmacro.20-macro (&key x y z &allow-other-keys) - `(list ',x ',y ',z)) - (mapcar #'eval '((defmacro.20-macro) - (defmacro.20-macro :x a) - (defmacro.20-macro :y b) - (defmacro.20-macro :z c) - (defmacro.20-macro :x a :y b) - (defmacro.20-macro :z c :y b) - (defmacro.20-macro :z c :x a) - (defmacro.20-macro :z c :x a :y b) - (defmacro.20-macro nil nil) - (defmacro.20-macro :allow-other-keys nil) - (defmacro.20-macro :allow-other-keys nil :foo bar) - (defmacro.20-macro :z c :z nil :x a :abc 0 :y b :x t)))) - ((nil nil nil) - (a nil nil) - (nil b nil) - (nil nil c) - (a b nil) - (nil b c) - (a nil c) - (a b c) - (nil nil nil) - (nil nil nil) - (nil nil nil) - (a b c))) - -(deftest defmacro.21 - (progn - (defmacro defmacro.21-macro (&key x y z) - `(list ',x ',y ',z)) - (mapcar #'eval '((defmacro.21-macro) - (defmacro.21-macro :x a) - (defmacro.21-macro :y b) - (defmacro.21-macro :z c) - (defmacro.21-macro :x a :y b) - (defmacro.21-macro :z c :y b) - (defmacro.21-macro :z c :x a) - (defmacro.21-macro :z c :x a :y b) - (defmacro.21-macro :allow-other-keys nil) - (defmacro.21-macro :allow-other-keys t :foo bar)))) - ((nil nil nil) - (a nil nil) - (nil b nil) - (nil nil c) - (a b nil) - (nil b c) - (a nil c) - (a b c) - (nil nil nil) - (nil nil nil))) - - - - diff --git a/t/ansi-test/eval-and-compile/dynamic-extent.lsp b/t/ansi-test/eval-and-compile/dynamic-extent.lsp deleted file mode 100644 index b91b284..0000000 --- a/t/ansi-test/eval-and-compile/dynamic-extent.lsp +++ /dev/null @@ -1,129 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat May 21 09:10:52 2005 -;;;; Contains: Tests of DYNAMIC-EXTENT - - - -(deftest dynamic-extent.1 - (let () (declare (dynamic-extent))) - nil) - -(deftest dynamic-extent.2 - (let ((x 'a)) - (declare (dynamic-extent x) (optimize speed (safety 0))) - x) - a) - -(deftest dynamic-extent.3 - (let ((x (list 'a 'b 'c))) - (declare (dynamic-extent x) (optimize speed (safety 0))) - (length x)) - 3) - -(deftest dynamic-extent.4 - (let ((x (vector 'a 'b 'c))) - (declare (dynamic-extent x) (optimize speed (safety 0))) - (length x)) - 3) - -(deftest dynamic-extent.5 - (flet ((%f (x) (list 'a x))) - (declare (dynamic-extent (function %f)) - (optimize speed (safety 0))) - (mapcar #'%f '(1 2 3))) - ((a 1) (a 2) (a 3))) - -(deftest dynamic-extent.6 - (labels ((%f (x) (list 'a x))) - (declare (dynamic-extent (function %f)) - (optimize speed (safety 0))) - (mapcar #'%f '(1 2 3))) - ((a 1) (a 2) (a 3))) - -(deftest dynamic-extent.7 - (labels ((%f (x) (if (consp x) - (cons (%f (car x)) (%f (cdr x))) - '*))) - (declare (dynamic-extent (function %f)) - (optimize speed (safety 0))) - (mapcar #'%f '((1) 2 (3 4 5)))) - ((* . *) * (* * * . *))) - -(deftest dynamic-extent.8 - (let ((x (+ most-positive-fixnum 2))) - (declare (dynamic-extent x) - (optimize speed (safety 0))) - (1- x)) - #.(1+ most-positive-fixnum)) - -(deftest dynamic-extent.9 - (flet ((f () (list 'a 'b))) - (let ((f (list 'c 'd))) - (declare (dynamic-extent (function f)) - (optimize speed (safety 0))) - f)) - (c d)) - -(deftest dynamic-extent.10 - (let ((x nil)) - (values - x - (locally (declare (dynamic-extent x) (notinline length) - (optimize speed (safety 0))) - (setq x (list 'a 'b 'c 'd 'e)) - (prog1 (length x) (setq x t))) - x)) - nil 5 t) - -(deftest dynamic-extent.11 - (let* ((x (list 'a 'b)) - (y (cons 'c x))) - (declare (dynamic-extent y) - (optimize speed (safety 0))) - (cdr y)) - (a b)) - -(deftest dynamic-extent.12 - (let* ((contents '(1 0 0 1 1 0 1 1 0 1)) - (n (length contents))) - (loop for i from 1 to 32 - for type = `(unsigned-byte ,i) - for form1 = `(make-array '(,n) :initial-contents ',contents - :element-type ',type) - for form2 = `(let ((a ,form1)) - (declare (dynamic-extent a)) - (declare (type (simple-array ,type (,n)))) - (declare (notinline coerce)) - (declare (optimize speed (safety 0))) - (equal (coerce a 'list) ',contents)) - unless (funcall (compile nil `(lambda () ,form2))) - collect i)) - nil) - -(deftest dynamic-extent.13 - (let ((s (make-string 10 :initial-element #\a))) - (declare (dynamic-extent s) (optimize speed (safety 0))) - (notnot (every #'(lambda (c) (eql c #\a)) s))) - t) - -(deftest dynamic-extent.14 - (let ((s (make-string 10 :initial-element #\a - :element-type 'base-char))) - (declare (dynamic-extent s) (notinline every) (optimize speed (safety 0))) - (notnot (every #'(lambda (c) (eql c #\a)) s))) - t) - -(deftest dynamic-extent.15 - (flet (((setf %f) (x y) (setf (car y) x))) - (declare (dynamic-extent #'(setf %f))) - :good) - :good) - -(deftest dynamic-extent.16 - (labels (((setf %f) (x y) (setf (car y) x))) - (declare (dynamic-extent #'(setf %f))) - :good) - :good) - - diff --git a/t/ansi-test/eval-and-compile/eval-and-compile.lsp b/t/ansi-test/eval-and-compile/eval-and-compile.lsp deleted file mode 100644 index fc2758b..0000000 --- a/t/ansi-test/eval-and-compile/eval-and-compile.lsp +++ /dev/null @@ -1,22 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Oct 21 22:52:19 2002 -;;;; Contains: Overall tests for section 3, 'Evaluation and Compilation' - - - -(defparameter *eval-and-compile-fns* - '(compile eval macroexpand macroexpand-1 proclaim special-operator-p - constantp)) - -(deftest eval-and-compile-fns - (remove-if #'fboundp *eval-and-compile-fns*) - nil) - -(defparameter *eval-and-compile-macros* - '(lambda define-compiler-macro defmacro define-symbol-macro declaim)) - -(deftest eval-and-compile-macros - (remove-if #'macro-function *eval-and-compile-macros*) - nil) - diff --git a/t/ansi-test/eval-and-compile/eval-when.lsp b/t/ansi-test/eval-and-compile/eval-when.lsp deleted file mode 100644 index 2b21b6b..0000000 --- a/t/ansi-test/eval-and-compile/eval-when.lsp +++ /dev/null @@ -1,141 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Apr 6 17:00:30 2003 -;;;; Contains: Tests for EVAL-WHEN - -;;; The following test was suggested by Sam Steingold, -;;; so I've created this file to hold it. - - - -(defvar *eval-when.1-collector*) - -(deftest eval-when.1 - - (let ((forms nil) all (ff "generated-eval-when-test-file.lisp")) - (dolist (c '(nil (:compile-toplevel))) - (dolist (l '(nil (:load-toplevel))) - (dolist (x '(nil (:execute))) - (push `(eval-when (,@c ,@l ,@x) - (push '(,@c ,@l ,@x) *eval-when.1-collector*)) - forms)))) - (dolist (c '(nil (:compile-toplevel))) - (dolist (l '(nil (:load-toplevel))) - (dolist (x '(nil (:execute))) - (push `(let () (eval-when (,@c ,@l ,@x) - (push '(let ,@c ,@l ,@x) *eval-when.1-collector*))) - forms)))) - (with-open-file (o ff :direction :output :if-exists :supersede) - (dolist (f forms) - (prin1 f o) - (terpri o))) - (let ((*eval-when.1-collector* nil)) - (load ff) - (push (cons "load source" *eval-when.1-collector*) all)) - (let ((*eval-when.1-collector* nil)) - (compile-file ff) - (push (cons "compile source" *eval-when.1-collector*) all)) - (let ((*eval-when.1-collector* nil)) - (load (compile-file-pathname ff)) - (push (cons "load compiled" *eval-when.1-collector*) all)) - (delete-file ff) - (delete-file (compile-file-pathname ff)) - #+clisp (delete-file (make-pathname :type "lib" :defaults ff)) - (nreverse all)) - - (("load source" - (:execute) (:load-toplevel :execute) (:compile-toplevel :execute) - (:compile-toplevel :load-toplevel :execute) - (let :execute) (let :load-toplevel :execute) - (let :compile-toplevel :execute) - (let :compile-toplevel :load-toplevel :execute)) - ("compile source" - (:compile-toplevel) (:compile-toplevel :execute) - (:compile-toplevel :load-toplevel) - (:compile-toplevel :load-toplevel :execute)) - ("load compiled" - (:load-toplevel) (:load-toplevel :execute) - (:compile-toplevel :load-toplevel) - (:compile-toplevel :load-toplevel :execute) - (let :execute) (let :load-toplevel :execute) - (let :compile-toplevel :execute) - (let :compile-toplevel :load-toplevel :execute)))) - -;;; More EVAL-WHEN tests to go here - -(deftest eval-when.2 - (eval-when () :bad) - nil) - -(deftest eval-when.3 - (eval-when (:execute)) - nil) - -(deftest eval-when.4 - (eval-when (:execute) :good) - :good) - -(deftest eval-when.5 - (eval-when (:compile-toplevel) :bad) - nil) - -(deftest eval-when.6 - (eval-when (:load-toplevel) :bad) - nil) - -(deftest eval-when.7 - (eval-when (:compile-toplevel :execute) :good) - :good) - -(deftest eval-when.8 - (eval-when (:load-toplevel :execute) :good) - :good) - -(deftest eval-when.9 - (eval-when (:load-toplevel :compile-toplevel) :bad) - nil) - -(deftest eval-when.10 - (eval-when (:load-toplevel :compile-toplevel :execute) :good) - :good) - -(deftest eval-when.11 - (eval-when (:execute) (values 'a 'b 'c 'd)) - a b c d) - -(deftest eval-when.12 - (let ((x :good)) - (values (eval-when (:load-toplevel) (setq x :bad)) x)) - nil :good) - -(deftest eval-when.13 - (let ((x :good)) - (values (eval-when (:compile-toplevel) (setq x :bad)) x)) - nil :good) - -(deftest eval-when.14 - (let ((x :bad)) - (values (eval-when (:execute) (setq x :good)) x)) - :good :good) - -(deftest eval-when.15 - (let ((x :good)) - (values (eval-when (load) (setq x :bad)) x)) - nil :good) - -(deftest eval-when.16 - (let ((x :good)) - (values (eval-when (compile) (setq x :bad)) x)) - nil :good) - -(deftest eval-when.17 - (let ((x :bad)) - (values (eval-when (eval) (setq x :good)) x)) - :good :good) - -;;; Macros are expanded in the appropriate environment - -(deftest eval-when.18 - (macrolet ((%m (z) z)) - (eval-when (:execute) (expand-in-current-env (%m :good)))) - :good) diff --git a/t/ansi-test/eval-and-compile/eval.lsp b/t/ansi-test/eval-and-compile/eval.lsp deleted file mode 100644 index 8b6b777..0000000 --- a/t/ansi-test/eval-and-compile/eval.lsp +++ /dev/null @@ -1,58 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Nov 21 10:43:15 2002 -;;;; Contains: Tests of EVAL - - - -(deftest eval.1 - (eval 1) - 1) - -(deftest eval.2 - (loop for x being the symbols of "KEYWORD" - always (eq (eval x) x)) - t) - -(deftest eval.3 - (let ((s "abcd")) - (eqlt (eval s) s)) - t) - -(deftest eval.4 - (eval '(car '(a . b))) - a) - -(deftest eval.5 - (eval '(let ((x 0)) x)) - 0) - -(deftest eval.6 - (funcall #'eval 1) - 1) - -(deftest eval.order.1 - (let ((i 0)) - (values (eval (progn (incf i) 10)) i)) - 10 1) - -;;; Error cases - -(deftest eval.error.1 - (signals-error (eval) program-error) - t) - -(deftest eval.error.2 - (signals-error (eval nil nil) program-error) - t) - -(deftest eval.error.3 - (let ((v (gensym))) - (eval `(signals-error (eval (list ',v)) undefined-function - :name ,v))) - t) - -(deftest eval.error.4 - (let ((v (gensym))) - (eval `(signals-error (eval ',v) unbound-variable :name ,v))) - t) diff --git a/t/ansi-test/eval-and-compile/ignorable.lsp b/t/ansi-test/eval-and-compile/ignorable.lsp deleted file mode 100644 index f5eacad..0000000 --- a/t/ansi-test/eval-and-compile/ignorable.lsp +++ /dev/null @@ -1,56 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat May 21 08:16:27 2005 -;;;; Contains: Tests of the IGNORABLE declaration - - - -(deftest ignorable.1 - (let ((x 'foo)) (declare (ignorable x))) - nil) - -(deftest ignorable.2 - (let ((x 'foo)) (declare (ignorable x)) x) - foo) - -(deftest ignorable.3 - (flet ((%f () 'foo)) - (declare (ignorable (function %f)))) - nil) - -(deftest ignorable.4 - (flet ((%f () 'foo)) - (declare (ignorable (function %f))) - (%f)) - foo) - -;;; TODO: add a test for (function (setf foo)) - -(deftest ignorable.5 - (flet (((setf %f) (x y) nil)) - (declare (ignorable (function (setf %f)))) - :good) - :good) - -(deftest ignorable.6 - (flet (((setf %f) (x y) (setf (car y) x))) - (declare (ignorable (function (setf %f)))) - (let ((z (cons 'a 'b))) - (values (setf (%f z) 'c) z))) - c (c . b)) - -(deftest ignorable.7 - (labels (((setf %f) (x y) nil)) - (declare (ignorable (function (setf %f)))) - :good) - :good) - -(deftest ignorable.8 - (labels (((setf %f) (x y) (setf (car y) x))) - (declare (ignorable (function (setf %f)))) - (let ((z (cons 'a 'b))) - (values (setf (%f z) 'c) z))) - c (c . b)) - - - diff --git a/t/ansi-test/eval-and-compile/ignore.lsp b/t/ansi-test/eval-and-compile/ignore.lsp deleted file mode 100644 index 228f477..0000000 --- a/t/ansi-test/eval-and-compile/ignore.lsp +++ /dev/null @@ -1,37 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat May 21 07:59:24 2005 -;;;; Contains: Tests of the IGNORE declarations - - - -(deftest ignore.1 - (let ((x 'foo)) (declare (ignore x))) - nil) - -(deftest ignore.2 - (let ((x 'foo)) (declare (ignore x)) x) - foo) - -(deftest ignore.3 - (flet ((%f () 'foo)) - (declare (ignore (function %f)))) - nil) - -(deftest ignore.4 - (flet ((%f () 'foo)) - (declare (ignore (function %f))) - (%f)) - foo) - -(deftest ignore.5 - (flet (((setf %f) (x y) (setf (car y) x))) - (declare (ignore (function (setf %f)))) - :good) - :good) - -(deftest ignore.6 - (labels (((setf %f) (x y) (setf (car y) x))) - (declare (ignore (function (setf %f)))) - :good) - :good) diff --git a/t/ansi-test/eval-and-compile/lambda.lsp b/t/ansi-test/eval-and-compile/lambda.lsp deleted file mode 100644 index e4afeda..0000000 --- a/t/ansi-test/eval-and-compile/lambda.lsp +++ /dev/null @@ -1,374 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Nov 27 06:43:21 2002 -;;;; Contains: Tests of LAMBDA forms - - - -(deftest lambda.1 - ((lambda (x) x) 'a) - a) - -(deftest lambda.2 - ((lambda () 'a)) - a) - -(deftest lambda.3 - ((lambda () "documentation" 'a)) - a) - -(deftest lambda.4 - ((lambda (x) (declare (type symbol x)) x) 'z) - z) - -(deftest lambda.5 - ((lambda (&aux (x 'a)) x)) - a) - -(deftest lambda.6 - ((lambda (&aux (x 'a)) (declare (type symbol x)) x)) - a) - -(deftest lambda.7 - ((lambda () "foo")) - "foo") - -(deftest lambda.8 - ((lambda () "foo" "bar")) - "bar") - -(deftest lambda.9 - ((lambda (x y) (declare (ignore x)) "foo" (declare (ignore y)) "bar") 1 2) - "bar") - -(deftest lambda.10 - ((lambda (x) (declare (type symbol x) (ignorable x))) 'z) - nil) - -(deftest lambda.11 - ((lambda (x &optional y z) (list x y z)) 1 2) - (1 2 nil)) - -(deftest lambda.12 - ((lambda (&optional (x 'a) (y 'b) (z 'c)) (list x y z)) 1 nil) - (1 nil c)) - -(deftest lambda.13 - ((lambda (&optional (x 'a x-p) (y 'b y-p) (z 'c z-p)) - (list* x y z (mapcar #'notnot (list x-p y-p z-p)))) 1 nil) - (1 nil c t t nil)) - -(deftest lambda.14 - (let ((x 1)) - ((lambda (&optional (x (1+ x))) x))) - 2) - -(deftest lambda.15 - ((lambda (y &optional (x (1+ y))) (list y x)) 10) - (10 11)) - -(deftest lambda.16 - ((lambda (y &optional (x (1+ y))) (list y x)) 10 14) - (10 14)) - -(deftest lambda.17 - ((lambda (&rest x) x) 1 2 3) - (1 2 3)) - -(deftest lambda.18 - (let ((b 10)) - ((lambda (&optional (a b) (b (1+ a))) (list a b)) 3 7)) - (3 7)) - -(deftest lambda.19 - (let ((b 10)) - ((lambda (&optional (a b) (b (1+ a))) (list a b)) 3)) - (3 4)) - -(deftest lambda.20 - (let ((b 10)) - ((lambda (&optional (a b) (b (1+ a))) (list a b)))) - (10 11)) - -(deftest lambda.21 - (flet ((%f () (locally (declare (special *x*)) (incf *x*)))) - ((lambda (*x*) - (declare (special *x*)) - (%f) - *x*) - 10)) - 11) - -(deftest lambda.22 - (flet ((%f () (locally (declare (special *x*)) (1+ *x*)))) - ((lambda (*x*) - (declare (special *x*)) - (%f)) - 15)) - 16) - -(deftest lambda.23 - ((lambda (&key a) a)) - nil) - -(deftest lambda.24 - ((lambda (&key a b c) (list a b c))) - (nil nil nil)) - -(deftest lambda.25 - ((lambda (&key (a 1) (b 2) (c 3)) (list a b c))) - (1 2 3)) - -(deftest lambda.26 - ((lambda (&key))) - nil) - -(deftest lambda.27 - ((lambda (&key) 'good) :allow-other-keys nil) - good) - -(deftest lambda.28 - ((lambda (&key) 'good) :allow-other-keys t :foo t) - good) - -(deftest lambda.29 - ((lambda (&key) 'good) :allow-other-keys t :allow-other-keys nil :foo t) - good) - -(deftest lambda.30 - ((lambda (&key x) x) :allow-other-keys t :x 10 - :allow-other-keys nil :foo t) - 10) - -(deftest lambda.31 - ((lambda (&rest x &key) x)) - nil) - -(deftest lambda.32 - ((lambda (&rest x &key) x) :allow-other-keys nil) - (:allow-other-keys nil)) - -(deftest lambda.33 - ((lambda (&rest x &key) x) :w 5 :allow-other-keys t :x 10) - (:w 5 :allow-other-keys t :x 10)) - -(deftest lambda.34 - ((lambda (&key (a 1 a-p) (b 2 b-p) (c 3 c-p)) (list a (notnot a-p) - b (notnot b-p) - c (notnot c-p))) - :c 5 :a 0) - (0 t 2 nil 5 t)) - -(deftest lambda.35 - ((lambda (&key (a 1 a-p) (b 2 b-p) (c 3 c-p)) (list a (notnot a-p) - b (notnot b-p) - c (notnot c-p))) - :c 5 :a nil :a 17 :c 100) - (nil t 2 nil 5 t)) - -(deftest lambda.36 - ((lambda (&key (a 1 a-p) (b 2 b-p) (c 3 c-p)) (list a (notnot a-p) - b (notnot b-p) - c (notnot c-p))) - :c 5 :a 0 :allow-other-keys t 'b 100) - (0 t 2 nil 5 t)) - -(deftest lambda.37 - (let ((b 1)) - ((lambda (&key (a b) b) (list a b)) :b 'x)) - (1 x)) - -(deftest lambda.38 - (let ((b 1)) - ((lambda (&key (a b) b) (list a b)) :b 'x :a nil)) - (nil x)) - -(deftest lambda.39 - (let ((a-p :bad)) - (declare (ignorable a-p)) - ((lambda (&key (a nil a-p) (b a-p)) (list a (notnot a-p) (notnot b))))) - (nil nil nil)) - -(deftest lambda.40 - (let ((a-p :bad)) - (declare (ignorable a-p)) - ((lambda (&key (a nil a-p) (b a-p)) (list a (notnot a-p) (notnot b))) - :a 1)) - (1 t t)) - -(deftest lambda.41 - (let ((a-p :bad)) - (declare (ignorable a-p)) - ((lambda (&key (a nil a-p) (b a-p)) (list a (notnot a-p) (notnot b))) - :a nil)) - (nil t t)) - -(deftest lambda.42 - ((lambda (&key a b &allow-other-keys) (list a b)) :a 1 :b 2) - (1 2)) - -(deftest lambda.43 - ((lambda (&key a b &allow-other-keys) (list a b)) :b 2 :a 1) - (1 2)) - -(deftest lambda.44 - ((lambda (&key a b &allow-other-keys) (list a b)) :z 10 :b 2 :b nil :a 1 - :a 2 'x 100) - (1 2)) - -(deftest lambda.45 - ((lambda (&key a b &allow-other-keys) (list a b)) :allow-other-keys nil - :z 10 :b 2 :b nil :a 1 :a 2 'x 100) - (1 2)) - -(deftest lambda.46 - ((lambda (&key a b allow-other-keys) (list allow-other-keys a b)) - :allow-other-keys nil :a 1 :b 2) - (nil 1 2)) - -(deftest lambda.47 - ((lambda (&key a b allow-other-keys) (list allow-other-keys a b)) - :c 10 :allow-other-keys t :a 1 :b 2 :d 20) - (t 1 2)) - -(deftest lambda.48 - ((lambda (&key a b allow-other-keys &allow-other-keys) - (list allow-other-keys a b)) - :d 40 :allow-other-keys nil :a 1 :b 2 :c 20) - (nil 1 2)) - -(deftest lambda.49 - ((lambda (&key a b allow-other-keys &allow-other-keys) - (list allow-other-keys a b)) - :d 40 :a 1 :b 2 :c 20) - (nil 1 2)) - -(deftest lambda.50 - ((lambda (&key a b ((:allow-other-keys aok))) - (list aok a b)) - :d 40 :a 1 :allow-other-keys t :b 2 :c 20) - (t 1 2)) - -(deftest lambda.51 - ((lambda (&key &allow-other-keys)) :a 1 :b 2 :c 3) - nil) - -;;; Free declaration scope - -(deftest lambda.52 - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) - ((lambda (&optional (y x)) (declare (special x)) y)))) - :good) - -(deftest lambda.53 - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) - ((lambda (&key (y x)) (declare (special x)) y)))) - :good) - -(deftest lambda.54 - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) - ((lambda (&aux (y x)) (declare (special x)) y)))) - :good) - -(deftest lambda.55 - (let* ((doc "LMB55") - (fn (eval `#'(lambda () ,doc nil))) - (cfn (compile nil fn))) - (values - (or (documentation fn t) doc) - (or (documentation cfn t) doc))) - "LMB55" - "LMB55") - -(deftest lambda.56 - (let* ((doc "LMB56") - (fn (eval `#'(lambda () ,doc nil))) - (cfn (compile nil fn))) - (values - (or (documentation fn 'function) doc) - (or (documentation cfn 'function) doc))) - "LMB56" - "LMB56") - -;;; Uninterned symbols as lambda variables - -(deftest lambda.57 - ((lambda (#1=#:foo) #1#) 17) - 17) - -(deftest lambda.58 - ((lambda (&rest #1=#:foo) #1#) 'a 'b 'c) - (a b c)) - -(deftest lambda.59 - ((lambda (&optional #1=#:foo) #1#)) - nil) - -(deftest lambda.60 - ((lambda (&optional (#1=#:foo t)) #1#)) - t) - -(deftest lambda.61 - ((lambda (&optional (#1=#:foo t)) #1#) 'bar) - bar) - -(deftest lambda.62 - ((lambda (&key #1=#:foo) #1#) :foo 12) - 12) - -;;; Test that declarations for aux variables are handled properly - -(deftest lambda.63 - (let ((y :bad1)) - (declare (ignore y)) - (let ((y :bad2)) - (declare (special y)) - (flet ((%f () y)) - ((lambda (x &aux (y :good)) - (declare (special y) (ignore x)) - (%f)) - nil)))) - :good) - -(deftest lambda.64 - (let ((x :bad)) - (declare (special x)) - (flet ((%f () x)) - ((lambda (x &aux (y (%f))) - (declare (type t y) (special x)) - y) - :good))) - :good) - -;;; Tests of lambda as a macro - -(deftest lambda.macro.1 - (notnot (macro-function 'lambda)) - t) - -(deftest lambda.macro.2 - (funcall (eval (macroexpand '(lambda () 10)))) - 10) - -;;; Error tests - -(deftest lambda.error.1 - (signals-error (funcall (macro-function 'lambda)) - program-error) - t) - -(deftest lambda.error.2 - (signals-error (funcall (macro-function 'lambda) '(lambda ())) - program-error) - t) - -(deftest lambda.error.3 - (signals-error (funcall (macro-function 'lambda) '(lambda ()) nil nil) - program-error) - t) diff --git a/t/ansi-test/eval-and-compile/load.lsp b/t/ansi-test/eval-and-compile/load.lsp deleted file mode 100644 index 7688a7a..0000000 --- a/t/ansi-test/eval-and-compile/load.lsp +++ /dev/null @@ -1,32 +0,0 @@ -;;; Tests of evaluation and compilation - -(in-package #:cl-test) - -(let ((*default-pathname-defaults* - (make-pathname - :directory (pathname-directory *load-pathname*)))) - (load "eval.lsp") - (load "eval-and-compile.lsp") - (load "compile.lsp") - (load "compiler-macros.lsp") - (load "constantp.lsp") - (load "lambda.lsp") - (load "eval-when.lsp") - (load "define-compiler-macro.lsp") - (load "define-symbol-macro.lsp") - (load "defmacro.lsp") - (load "the.lsp") - (load "symbol-macrolet.lsp") - (load "proclaim.lsp") - (load "declaim.lsp") - (load "locally.lsp") - (load "ignore.lsp") - (load "ignorable.lsp") - (load "dynamic-extent.lsp") - (load "optimize.lsp") - (load "special.lsp") - (load "macroexpand.lsp") - (load "macroexpand-1.lsp") - (load "declaration.lsp") - (load "type.lsp") - (load "macro-function.lsp")) diff --git a/t/ansi-test/eval-and-compile/locally.lsp b/t/ansi-test/eval-and-compile/locally.lsp deleted file mode 100644 index d8658a8..0000000 --- a/t/ansi-test/eval-and-compile/locally.lsp +++ /dev/null @@ -1,46 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Jan 8 06:02:47 2005 -;;;; Contains: Tests of LOCALLY - - - -(deftest locally.1 - (locally) - nil) - -(deftest locally.2 - (locally (values))) - -(deftest locally.3 - (locally (values 1 2 3 4)) - 1 2 3 4) - -(deftest locally.4 - (locally (declare) t) - t) - -(deftest locally.5 - (locally (declare) (declare) (declare) t) - t) - -(deftest locally.6 - (let ((x 'a)) - (declare (special x)) - (let ((x 'b)) - (values - x - (locally (declare (special x)) x) - x))) - b a b) - -(deftest locally.7 - (locally (declare)) - nil) - -;;; Macros are expanded in the appropriate environment - -(deftest locally.8 - (macrolet ((%m (z) z)) - (locally (expand-in-current-env (%m :good)))) - :good) diff --git a/t/ansi-test/eval-and-compile/macro-function.lsp b/t/ansi-test/eval-and-compile/macro-function.lsp deleted file mode 100644 index 4f057bb..0000000 --- a/t/ansi-test/eval-and-compile/macro-function.lsp +++ /dev/null @@ -1,146 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Jun 3 22:17:34 2005 -;;;; Contains: Tests of MACRO-FUNCTION - - - -(deftest macro-function.1 - (loop for n in *cl-macro-symbols* - unless (macro-function n) - collect n) - nil) - -(deftest macro-function.2 - (loop for n in *cl-macro-symbols* - unless (macro-function n nil) - collect n) - nil) - -(deftest macro-function.3 - (loop for n in *cl-macro-symbols* - unless (eval `(macrolet ((%m (s &environment env) - (list 'quote - (macro-function s env)))) - (%m ,n))) - collect n) - nil) - -(deftest macro-function.4 - (macro-function (gensym)) - nil) - -(deftest macro-function.5 - (remove-if-not #'macro-function *cl-function-symbols*) - nil) - -(deftest macro-function.6 - (remove-if-not #'macro-function *cl-accessor-symbols*) - nil) - -(deftest macro-function.7 - (let ((fn - (macrolet ((%m () 16)) - (macrolet ((%n (&environment env) - (list 'quote (macro-function '%m env)))) - (%n))))) - (values - (notnot (functionp fn)) - (funcall fn '(%m) nil))) - t 16) - -(deftest macro-function.8 - (let ((sym (gensym))) - (setf (macro-function sym) (macro-function 'pop)) - (eval `(let ((x '(a b c))) - (values - (,sym x) - x)))) - a (b c)) - -(deftest macro-function.9 - (let ((sym (gensym))) - (setf (macro-function sym nil) (macro-function 'pop)) - (eval `(let ((x '(a b c))) - (values - (,sym x) - x)))) - a (b c)) - -(deftest macro-function.10 - (let ((sym (gensym))) - (eval `(defun ,sym (x) :bad)) - (setf (macro-function sym) (macro-function 'pop)) - (eval `(let ((x '(a b c))) - (values - (,sym x) - x)))) - a (b c)) - -(deftest macro-function.11 - (let ((fn - (flet ((%m () 16)) - (macrolet ((%n (&environment env) - (list 'quote (macro-function '%m env)))) - (%n))))) - fn) - nil) - -(deftest macro-function.12 - (let ((sym (gensym))) - (eval `(defmacro ,sym () t)) - (let ((i 0)) - (values - (funcall (macro-function (progn (incf i) sym)) (list sym) nil) - i))) - t 1) - -(deftest macro-function.13 - (let ((sym (gensym))) - (eval `(defmacro ,sym () t)) - (let ((i 0) a b) - (values - (funcall (macro-function (progn (setf a (incf i)) sym) - (progn (setf b (incf i)) nil)) - (list sym) nil) - i a b))) - t 2 1 2) - -(deftest macro-function.14 - (let ((sym (gensym)) - (i 0)) - (setf (macro-function (progn (incf i) sym)) (macro-function 'pop)) - (values - (eval `(let ((x '(a b c))) - (list - (,sym x) - x))) - i)) - (a (b c)) 1) - -(deftest macro-function.15 - (let ((sym (gensym)) - (i 0) a b) - (setf (macro-function (progn (setf a (incf i)) sym) - (progn (setf b (incf i)) nil)) - (macro-function 'pop)) - (values - (eval `(let ((x '(a b c))) - (list - (,sym x) - x))) - i a b)) - (a (b c)) 2 1 2) - - - -;;; Error tests - -(deftest macro-function.error.1 - (signals-error (macro-function) program-error) - t) - -(deftest macro-function.error.2 - (signals-error (macro-function 'pop nil nil) program-error) - t) - diff --git a/t/ansi-test/eval-and-compile/macroexpand-1.lsp b/t/ansi-test/eval-and-compile/macroexpand-1.lsp deleted file mode 100644 index 8c261d8..0000000 --- a/t/ansi-test/eval-and-compile/macroexpand-1.lsp +++ /dev/null @@ -1,75 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat May 28 13:47:32 2005 -;;;; Contains: Tests of MACROEXPAND-1 - - - -(deftest macroexpand-1.error.1 - (signals-error (macroexpand-1) program-error) - t) - -(deftest macroexpand-1.error.2 - (signals-error (macroexpand-1 'x nil nil) program-error) - t) - -;;; Non-error tests - -(deftest macroexpand-1.1 - (check-predicate - #'(lambda (x) - (or (symbolp x) (consp x) - (let ((vals (multiple-value-list (macroexpand-1 x)))) - (and (= (length vals) 2) - (eql (car vals) x) - (null (cadr vals))))))) - nil) - -(deftest macroexpand-1.2 - (check-predicate - #'(lambda (x) - (or (symbolp x) (consp x) - (let ((vals (multiple-value-list (macroexpand-1 x nil)))) - (and (= (length vals) 2) - (eql (car vals) x) - (null (cadr vals))))))) - nil) - -(deftest macroexpand-1.3 - (macrolet - ((%m (&environment env) - `(quote - ,(check-predicate - #'(lambda (x) - (or (symbolp x) (consp x) - (let ((vals (multiple-value-list (macroexpand-1 x env)))) - (and (= (length vals) 2) - (eql (car vals) x) - (null (cadr vals)))))))))) - (%m)) - nil) - -(deftest macroexpand-1.4 - (macrolet ((%m () ''foo)) - (macrolet ((%m2 (&environment env) - (macroexpand-1 '(%m) env))) - (%m2))) - foo) - -(deftest macroexpand-1.5 - (let ((form (list (gensym))) - (i 0)) - (values - (equalt (macroexpand-1 (progn (incf i) form)) form) - i)) - t 1) - -(deftest macroexpand-1.6 - (let ((form (list (gensym))) - (i 0) a b) - (values - (equalt (macroexpand-1 (progn (setf a (incf i)) form) - (progn (setf b (incf i)) nil)) - form) - i a b)) - t 2 1 2) diff --git a/t/ansi-test/eval-and-compile/macroexpand.lsp b/t/ansi-test/eval-and-compile/macroexpand.lsp deleted file mode 100644 index 9b21474..0000000 --- a/t/ansi-test/eval-and-compile/macroexpand.lsp +++ /dev/null @@ -1,74 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat May 28 13:43:00 2005 -;;;; Contains: Tests of MACROEXPAND - - - -(deftest macroexpand.error.1 - (signals-error (macroexpand) program-error) - t) - -(deftest macroexpand.error.2 - (signals-error (macroexpand 'x nil nil) program-error) - t) - -;;; Non-error tests - -(deftest macroexpand.1 - (check-predicate - #'(lambda (x) - (or (symbolp x) (consp x) - (let ((vals (multiple-value-list (macroexpand x)))) - (and (= (length vals) 2) - (eql (car vals) x) - (null (cadr vals))))))) - nil) - -(deftest macroexpand.2 - (check-predicate - #'(lambda (x) - (or (symbolp x) (consp x) - (let ((vals (multiple-value-list (macroexpand x nil)))) - (and (= (length vals) 2) - (eql (car vals) x) - (null (cadr vals))))))) - nil) - -(deftest macroexpand.3 - (macrolet - ((%m (&environment env) - `(quote - ,(check-predicate - #'(lambda (x) (or (symbolp x) (consp x) - (let ((vals (multiple-value-list (macroexpand x env)))) - (and (= (length vals) 2) - (eql (car vals) x) - (null (cadr vals)))))))))) - (%m)) - nil) - -(deftest macroexpand.4 - (macrolet ((%m () ''foo)) - (macrolet ((%m2 (&environment env) - (macroexpand '(%m) env))) - (%m2))) - foo) - -(deftest macroexpand.5 - (let ((form (list (gensym))) - (i 0)) - (values - (equalt (macroexpand (progn (incf i) form)) form) - i)) - t 1) - -(deftest macroexpand.6 - (let ((form (list (gensym))) - (i 0) a b) - (values - (equalt (macroexpand (progn (setf a (incf i)) form) - (progn (setf b (incf i)) nil)) - form) - i a b)) - t 2 1 2) diff --git a/t/ansi-test/eval-and-compile/optimize.lsp b/t/ansi-test/eval-and-compile/optimize.lsp deleted file mode 100644 index d6caf1c..0000000 --- a/t/ansi-test/eval-and-compile/optimize.lsp +++ /dev/null @@ -1,54 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat May 21 09:31:34 2005 -;;;; Contains: Tests of the OPTIMIZE declaration - - - -(deftest optimize.1 - (locally (declare (optimize)) nil) - nil) - -(deftest optimize.2 - (locally (declare (optimize speed)) nil) - nil) - -(deftest optimize.3 - (locally (declare (optimize space)) nil) - nil) - -(deftest optimize.4 - (locally (declare (optimize safety)) nil) - nil) - -(deftest optimize.5 - (locally (declare (optimize debug)) nil) - nil) - -(deftest optimize.6 - (locally (declare (optimize compilation-speed)) nil) - nil) - -(deftest optimize.7 - (loop for d in '(speed space safety debug compilation-speed) - nconc (loop for n from 0 to 3 - for form = `(locally (declare (optimize (,d ,n))) t) - for val = (eval form) - unless (eql val t) - collect (list d n val))) - nil) - -(deftest optimize.8 - (loop for d in '(speed space safety debug compilation-speed) - nconc (loop for n from 0 to 3 - for form = `(lambda () - (declare (optimize (,d ,n))) - t) - for val = (funcall (compile nil form)) - unless (eql val t) - collect (list d n val))) - nil) - - - - diff --git a/t/ansi-test/eval-and-compile/proclaim.lsp b/t/ansi-test/eval-and-compile/proclaim.lsp deleted file mode 100644 index 803c1a5..0000000 --- a/t/ansi-test/eval-and-compile/proclaim.lsp +++ /dev/null @@ -1,72 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat May 21 07:33:53 2005 -;;;; Contains: Tests of PROCLAIM - - - -(deftest proclaim.1 - (let ((sym (gensym))) - (proclaim `(special ,sym)) - (eval `(flet ((%f () ,sym)) - (let ((,sym :good)) (%f))))) - :good) - -(deftest proclaim.2 - (let ((sym (gensym))) - (proclaim `(declaration ,sym)) - (proclaim `(,sym)) - nil) - nil) - -(deftest proclaim.3 - (let ((i 0)) - (proclaim (progn (incf i) '(optimize))) - i) - 1) - -;;; Error cases - -(deftest proclaim.error.1 - (signals-error (proclaim) program-error) - t) - -(deftest proclaim.error.2 - (signals-error (proclaim '(optimize) nil) program-error) - t) - -(deftest proclaim.error.3 - (signals-error (proclaim `(optimize . foo)) error) - t) - -(deftest proclaim.error.4 - (signals-error (proclaim `(inline . foo)) error) - t) - -(deftest proclaim.error.5 - (signals-error (proclaim `(notinline . foo)) error) - t) - -(deftest proclaim.error.6 - (signals-error (proclaim `(type . foo)) error) - t) - -(deftest proclaim.error.7 - (signals-error (proclaim `(ftype . foo)) type-error) - t) - -(deftest proclaim.error.8 - (signals-error (proclaim '(type integer . foo)) error) - t) - -(deftest proclaim.error.9 - (signals-error (proclaim '(integer . foo)) error) - t) - -(deftest proclaim.error.10 - (signals-error (proclaim '(declaration . foo)) error) - t) - -(deftest proclaim.error.11 - (signals-error (proclaim '(ftype (function (t) t) . foo)) error) - t) diff --git a/t/ansi-test/eval-and-compile/special.lsp b/t/ansi-test/eval-and-compile/special.lsp deleted file mode 100644 index dbb85bf..0000000 --- a/t/ansi-test/eval-and-compile/special.lsp +++ /dev/null @@ -1,33 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat May 21 12:51:59 2005 -;;;; Contains: Tests of the declaration SPECIAL - - - -;;; Many tests for this declaration are in the tests -;;; for specific binding forms. - -(deftest special.1 - (let ((f 1)) - (declare (special f)) - (flet ((f () :good)) - (flet ((g () (f))) - (flet ((f () :bad)) - (g))))) - :good) - -(deftest special.2 - (let ((x 'a)) - (declare (special x)) - (let ((x 'b)) - (values x (locally (declare (special x)) x) x))) - b a b) - -(deftest special.3 - (flet ((%f () (declare (special x10)) x10)) - (let ((x10 'a)) - (declare (special x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12)) - (%f))) - a) - diff --git a/t/ansi-test/eval-and-compile/symbol-macrolet.lsp b/t/ansi-test/eval-and-compile/symbol-macrolet.lsp deleted file mode 100644 index 341d14b..0000000 --- a/t/ansi-test/eval-and-compile/symbol-macrolet.lsp +++ /dev/null @@ -1,85 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Jan 8 05:58:53 2005 -;;;; Contains: Tests of SYMBOL-MACROLET - - - -(deftest symbol-macrolet.1 - (loop for s in *cl-non-variable-constant-symbols* - for form = `(ignore-errors (symbol-macrolet ((,s 17)) ,s)) - unless (eql (eval form) 17) - collect s) - nil) - -(deftest symbol-macrolet.2 - (symbol-macrolet ()) - nil) - -(deftest symbol-macrolet.3 - (symbol-macrolet () (declare (optimize))) - nil) - -(deftest symbol-macrolet.4 - (symbol-macrolet ((x 1)) - (symbol-macrolet ((x 2)) - x)) - 2) - -(deftest symbol-macrolet.5 - (let ((x 10)) - (symbol-macrolet ((y x)) - (list x - y - (let ((x 20)) x) - (let ((y 30)) x) - (let ((y 50)) y) - x - y))) - (10 10 20 10 50 10 10)) - -(deftest symbol-macrolet.6 - (symbol-macrolet () (values))) - -(deftest symbol-macrolet.7 - (symbol-macrolet () (values 'a 'b 'c 'd 'e)) - a b c d e) - -(deftest symbol-macrolet.8 - (let ((x :good)) - (declare (special x)) - (let ((x :bad)) - (symbol-macrolet () (declare (special x)) x))) - :good) - -;;; Error tests - -(deftest symbol-macrolet.error.1 - (signals-error - (symbol-macrolet ((x 10)) - (declare (special x)) - 20) - program-error) - t) - -(defconstant constant-for-symbol-macrolet.error.2 nil) - -(deftest symbol-macrolet.error.2 - (signals-error (symbol-macrolet ((constant-for-symbol-macrolet.error.2 'a)) - constant-for-symbol-macrolet.error.2) - program-error) - t) - -(deftest symbol-macrolet.error.3 - (signals-error (symbol-macrolet ((*pathnames* 19)) *pathnames*) - program-error) - t) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest symbol-macrolet.9 - (macrolet - ((%m (z) z)) - (symbol-macrolet () (expand-in-current-env (%m :good)))) - :good) diff --git a/t/ansi-test/eval-and-compile/the.lsp b/t/ansi-test/eval-and-compile/the.lsp deleted file mode 100644 index 466637c..0000000 --- a/t/ansi-test/eval-and-compile/the.lsp +++ /dev/null @@ -1,143 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue May 6 06:48:48 2003 -;;;; Contains: Tests of THE - - - -(deftest the.1 - (the (values) (values))) - -(deftest the.2 - (the (values) 'a) - a) - -(deftest the.3 - (check-predicate #'(lambda (e) - (let ((x (multiple-value-list (eval `(the (values) (quote ,e)))))) - (and x (not (cdr x)) (eql (car x) e))))) - nil) - -(deftest the.4 - (check-predicate #'(lambda (e) - (let ((x (multiple-value-list (eval `(the ,(type-of e) (quote ,e)))))) - (and x (not (cdr x)) (eql (car x) e))))) - nil) - -(deftest the.5 - (check-predicate #'(lambda (e) - (let ((x (multiple-value-list (eval `(the (values ,(type-of e)) (quote ,e)))))) - (and x (not (cdr x)) (eql (car x) e))))) - nil) - -(deftest the.6 - (check-predicate #'(lambda (e) - (let ((x (multiple-value-list (eval `(the (values ,(type-of e) t) (quote ,e)))))) - (and x (not (cdr x)) (eql (car x) e))))) - nil) - -(deftest the.7 - (check-predicate - #'(lambda (e) - (let ((x (multiple-value-list (eval `(the (values ,(type-of e)) - (values (quote ,e) :ignored)))))) - (and (eql (length x) 2) - (eql (car x) e) - (eql (cadr x) :ignored))))) - nil) - -(deftest the.8 - (check-predicate #'(lambda (e) (or (not (constantp e)) - (eql (eval `(the ,(type-of e) ,e)) e)))) - nil) - -(deftest the.9 - (check-predicate #'(lambda (e) (or (not (constantp e)) - (eql (eval `(the ,(class-of e) ,e)) e)))) - nil) - -(deftest the.10 - (check-predicate #'(lambda (e) (eql (eval `(the ,(class-of e) ',e)) e))) - nil) - -(deftest the.11 - (check-predicate - #'(lambda (e) - (let* ((type (type-of e)) - (x (multiple-value-list (eval `(the ,type (the ,type (quote ,e))))))) - (and x (not (cdr x)) (eql (car x) e))))) - nil) - -(deftest the.12 - (let ((lexpr - `(lambda () - (and - ,@(loop for e in *mini-universe* - for type = (type-of e) - collect `(eqlt (quote ,e) (the ,type (quote ,e)))))))) - (funcall (compile nil lexpr))) - t) - -(deftest the.13 - (let ((x 0)) - (values - (the (or symbol integer) (incf x)) - x)) - 1 1) - -(deftest the.14 - (the (values &rest t) (values 'a 'b)) - a b) - -(deftest the.15 - (the (values &rest symbol) (values 'a 'b)) - a b) - -(deftest the.16 - (the (values &rest null) (values))) - -(deftest the.17 - (the (values symbol integer &rest null) (values 'a 1)) - a 1) - -(deftest the.18 - (the (values symbol integer &rest t) (values 'a 1 'foo '(x y))) - a 1 foo (x y)) - -(deftest the.19 - (let () (list (the (values) (eval '(values))))) - (nil)) - -;;; This is from SBCL bug 261 -(deftest the.20 - (let () (list (the (values &optional fixnum) (eval '(values))))) - (nil)) - -(deftest the.21 - (let () (list (the (values &rest t) (eval '(values))))) - (nil)) - -(deftest the.22 - (the (values symbol integer &rest t) (eval '(values 'a 1 'foo '(x y)))) - a 1 foo (x y)) - -(deftest the.23 - (multiple-value-list - (the (values symbol integer &optional fixnum) (eval '(values 'a 1)))) - (a 1)) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest the.24 - (macrolet - ((%m (z) z)) - (the (integer 0 10) (expand-in-current-env (%m 4)))) - 4) - -(deftest the.25 - (macrolet - ((%m (z) z)) - (the (values t t) (expand-in-current-env (%m (values 1 2))))) - 1 2) - diff --git a/t/ansi-test/eval-and-compile/type.lsp b/t/ansi-test/eval-and-compile/type.lsp deleted file mode 100644 index d4f683b..0000000 --- a/t/ansi-test/eval-and-compile/type.lsp +++ /dev/null @@ -1,71 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun May 29 08:25:46 2005 -;;;; Contains: Tests of TYPE declarations - - - -;;; Also of implicit type declarations - -(deftest type.1 - (let ((x 1)) - (declare (type (integer 0 1) x)) - (values - x - (setq x 0) - (1+ x))) - 1 0 1) - -(deftest type.2 - (let ((x 1)) - (declare (type (integer -1 1) x)) - (locally (declare (type (integer 0 2) x)) - (values - x - (setq x 0) - (1+ x)))) - 1 0 1) - -(deftest type.3 - (loop for x in *mini-universe* - for tp = (type-of x) - for form = `(let ((y ',x)) - (declare (type ,tp y)) - y) - for val = (eval form) - unless (eql val x) - collect (list x tp form val)) - nil) - -(deftest type.4 - (loop for x in *mini-universe* - for tp = (type-of x) - for form = `(let ((y ',x)) - (declare (,tp y)) - y) - for val = (eval form) - unless (eql val x) - collect (list x tp form val)) - nil) - -(deftest type.5 - (loop for x in *mini-universe* - for class = (class-of x) - for form = `(let ((y ',x)) - (declare (,class y)) - y) - for val = (eval form) - unless (eql val x) - collect (list x class form val)) - nil) - -;;; Free TYPE declaration -;;; It should not apply to the occurence of X in the form -;;; whose value is being bound to Y. - -(deftest type.6 - (let ((x 2)) - (let ((y (+ (decf x) 2))) - (declare (type (integer 0 1) x)) - (values x y))) - 1 3) diff --git a/t/ansi-test/files/delete-file.lsp b/t/ansi-test/files/delete-file.lsp deleted file mode 100644 index 7f8a8b3..0000000 --- a/t/ansi-test/files/delete-file.lsp +++ /dev/null @@ -1,95 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Jan 13 18:42:29 2004 -;;;; Contains: Tests for DELETE-FILE - - - -(deftest delete-file.1 - (let ((pn "scratchfile.txt")) - (unless (probe-file pn) - (with-open-file (s pn :direction :output) - (format s "Contents~%"))) - (values - (notnot (probe-file pn)) - (multiple-value-list (delete-file pn)) - (probe-file pn))) - t (t) nil) - -(deftest delete-file.2 - (let ((pn #p"scratchfile.txt")) - (unless (probe-file pn) - (with-open-file (s pn :direction :output) - (format s "Contents~%"))) - (values - (notnot (probe-file pn)) - (multiple-value-list (delete-file pn)) - (probe-file pn))) - t (t) nil) - -(deftest delete-file.3 - (let ((pn "CLTEST:scratchfile.txt")) - (assert (typep (pathname pn) 'logical-pathname)) - (unless (probe-file pn) - (with-open-file (s pn :direction :output) - (format s "Contents~%"))) - (values - (notnot (probe-file pn)) - (multiple-value-list (delete-file pn)) - (probe-file pn))) - t (t) nil) - -(deftest delete-file.4 - (let ((pn "CLTEST:scratchfile.txt")) - (assert (typep (pathname pn) 'logical-pathname)) - (unless (probe-file pn) - (with-open-file (s pn :direction :output) - (format s "Contents~%"))) - (let ((s (open pn :direction :input))) - (close s) - (values - (notnot (probe-file pn)) - (multiple-value-list (delete-file s)) - (probe-file pn)))) - t (t) nil) - -;;; Specialized string tests - -(deftest delete-file.5 - (do-special-strings - (pn "scratchfile.txt" nil) - (unless (probe-file pn) - (with-open-file (s pn :direction :output) - (format s "Contents~%"))) - (assert (probe-file pn)) - (assert (equal (multiple-value-list (delete-file pn)) '(t))) - (assert (not (probe-file pn)))) - nil) - -;;; Error tests - -(deftest delete-file.error.1 - (signals-error (delete-file) program-error) - t) - -(deftest delete-file.error.2 - (let ((pn "scratch.txt")) - (unless (probe-file pn) - (with-open-file (s pn :direction :output) - (format s "Contents~%"))) - (values - (notnot (probe-file pn)) - (signals-error (delete-file "scratch.txt" nil) program-error) - (notnot (probe-file pn)) - (delete-file pn) - (probe-file pn))) - t t t t nil) - -#| -(deftest delete-file.error.3 - (let ((pn "nonexistent.txt")) - (when (probe-file pn) (delete-file pn)) - (signals-error (delete-file "nonexistent.txt") file-error)) - t) -|# - diff --git a/t/ansi-test/files/directory.lsp b/t/ansi-test/files/directory.lsp deleted file mode 100644 index 8976570..0000000 --- a/t/ansi-test/files/directory.lsp +++ /dev/null @@ -1,73 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Jan 1 12:00:18 2004 -;;;; Contains: Tests of DIRECTORY - - - -(deftest directory.1 - (directory "nonexistent") - nil) - -(deftest directory.2 - (directory #p"nonexistent") - nil) - -(deftest directory.3 - (directory "nonexistent" :allow-other-keys nil) - nil) - -(deftest directory.4 - (directory "nonexistent" :allow-other-keys t :foo 'bar) - nil) - -(deftest directory.5 - (directory "nonexistent" :foo 0 :allow-other-keys t) - nil) - -(deftest directory.6 - (let* ((pattern-pathname (make-pathname :name :wild :type :wild - :defaults *default-pathname-defaults*)) - (pathnames (directory pattern-pathname))) - (values - (remove-if #'pathnamep pathnames) - (loop for pn in pathnames - unless (equal pn (truename pn)) - collect pn) -;; (loop for pn in pathnames -;; unless (pathname-match-p pn pattern-pathname) -;; collect pn)) - )) - nil nil ;; nil - ) - -(deftest directory.7 - (let* ((pattern-pathname (make-pathname :name :wild :type :wild - :defaults *default-pathname-defaults*)) - (pathnames (directory pattern-pathname))) - (loop for pn in pathnames - unless (equal pn (probe-file pn)) - collect pn)) - nil) - -(deftest directory.8 - ;; what does this test do? Checks if we have >= then 30 files? - ;; seems bogus to me -- jd - (let* ((pathname-pattern "CLTEST:*.*") - (len (length (directory pathname-pattern)))) - (if (< len 30) len nil)) - nil) - -;;; Specialized string tests - -(deftest directory.9 - (do-special-strings - (s "nonexistent" nil) - (assert (null (directory s)))) - nil) - -;;; Error tests - -(deftest directory.error.1 - (signals-error (directory) program-error) - t) diff --git a/t/ansi-test/files/ensure-directories-exist.lsp b/t/ansi-test/files/ensure-directories-exist.lsp deleted file mode 100644 index bdb67b9..0000000 --- a/t/ansi-test/files/ensure-directories-exist.lsp +++ /dev/null @@ -1,163 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Jan 5 20:53:03 2004 -;;;; Contains: Tests of ENSURE-DIRECTORIES-EXIST - -(deftest ensure-directories-exist.1 - (let* ((pn (make-pathname :name "ensure-directories-exist.txt" - :defaults *default-pathname-defaults*)) - (results nil) - (verbosity - (with-output-to-string - (*standard-output*) - (setq results (multiple-value-list (ensure-directories-exist pn)))))) - (values - (length results) - (equalt (truename pn) (truename (first results))) - (second results) - verbosity)) - 2 t nil "") - -(deftest ensure-directories-exist.2 - (with-open-file - (s "ensure-directories-exist.txt" :direction :input) - (let* ((results (multiple-value-list (ensure-directories-exist s)))) - (values - (length results) - (equalt (truename (first results)) (truename s)) - (second results)))) - 2 t nil) - -(deftest ensure-directories-exist.3 - (let ((s (open "ensure-directories-exist.txt" :direction :input))) - (close s) - (let* ((results (multiple-value-list (ensure-directories-exist s)))) - (values - (length results) - (equalt (truename (first results)) (truename s)) - (second results)))) - 2 t nil) - -(deftest ensure-directories-exist.4 - (let* ((pn (make-pathname :name "ensure-directories-exist.txt" - :defaults *default-pathname-defaults*)) - (results nil) - (verbosity - (with-output-to-string - (*standard-output*) - (setq results (multiple-value-list - (ensure-directories-exist pn :verbose nil)))))) - (values - (length results) - (equalt (truename pn) (truename (first results))) - (second results) - verbosity)) - 2 t nil "") - -(deftest ensure-directories-exist.5 - (let* ((pn (make-pathname :name "ensure-directories-exist.txt" - :defaults *default-pathname-defaults*)) - (results nil) - (verbosity - (with-output-to-string - (*standard-output*) - (setq results (multiple-value-list - (ensure-directories-exist pn :verbose t)))))) - (values - (length results) - (equalt (truename pn) (truename (first results))) - (second results) - verbosity)) - 2 t nil "") - -(deftest ensure-directories-exist.6 - (let* ((pn (make-pathname :name "ensure-directories-exist.txt" - :defaults *default-pathname-defaults*)) - (results nil) - (verbosity - (with-output-to-string - (*standard-output*) - (setq results (multiple-value-list - (ensure-directories-exist - pn :allow-other-keys nil)))))) - (values - (length results) - (equalt (truename pn) (truename (first results))) - (second results) - verbosity)) - 2 t nil "") - -(deftest ensure-directories-exist.7 - (let* ((pn (make-pathname :name "ensure-directories-exist.txt" - :defaults *default-pathname-defaults*)) - (results nil) - (verbosity - (with-output-to-string - (*standard-output*) - (setq results (multiple-value-list - (ensure-directories-exist - pn :allow-other-keys t :nonsense t)))))) - (values - (length results) - (equalt (truename pn) (truename (first results))) - (second results) - verbosity)) - 2 t nil "") - -;;; Case where directory shouldn't exist - -;; The directort ansi-tests/scratch must not exist before this -;; test is run -(deftest ensure-directories-exist.8 - (let* ((subdir (make-pathname :directory '(:relative "scratch") - :defaults *default-pathname-defaults*)) - (pn (make-pathname :name "foo" :type "txt" - :defaults subdir))) - (assert (not (probe-file pn)) () - "Delete subdirectory scratch and its contents!") - (let* ((results nil) - (verbosity - (with-output-to-string - (*standard-output*) - (setq results (multiple-value-list (ensure-directories-exist pn))))) - (result-pn (first results)) - (created (second results))) - ;; Create the file and write to it - (with-open-file (*standard-output* - pn :direction :output :if-exists :error - :if-does-not-exist :create) - (print nil)) - (values - (length results) - (notnot created) - (equalt pn result-pn) - (notnot (probe-file pn)) - verbosity - ))) - 2 t t t "") - -;;; Specialized string tests - -(deftest ensure-directories-exist.9 - (do-special-strings - (str "ensure-directories-exist.txt" nil) - (let* ((results (multiple-value-list (ensure-directories-exist str)))) - (assert (eql (length results) 2)) - (assert (equalt (truename (first results)) (truename str))) - (assert (null (second results))))) - nil) - -;; FIXME -;; Need to add a LPN test - -(deftest ensure-directories-exist.error.1 - (signals-error-always - (ensure-directories-exist - (make-pathname :directory '(:relative :wild) - :defaults *default-pathname-defaults*)) - file-error) - t t) - -(deftest ensure-directories-exist.error.2 - (signals-error (ensure-directories-exist) program-error) - t) diff --git a/t/ansi-test/files/file-author.lsp b/t/ansi-test/files/file-author.lsp deleted file mode 100644 index 0389601..0000000 --- a/t/ansi-test/files/file-author.lsp +++ /dev/null @@ -1,88 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Jan 6 05:41:06 2004 -;;;; Contains: Tests of FILE-AUTHOR - - - -(deftest file-author.1 - (loop for pn in - (directory (make-pathname :name :wild :type :wild - :defaults *default-pathname-defaults*)) - for author = (file-author pn) - unless (or (null author) (stringp author)) - collect (list pn author)) - nil) - -(deftest file-author.2 - (let ((author (file-author "file-author.txt"))) - (if (or (null author) (stringp author)) - nil - author)) - nil) - -(deftest file-author.3 - (let ((author (file-author #p"file-author.txt"))) - (if (or (null author) (stringp author)) - nil - author)) - nil) - -(deftest file-author.4 - (let ((author (file-author (truename "file-author.txt")))) - (if (or (null author) (stringp author)) - nil - author)) - nil) - -(deftest file-author.5 - (let ((author (with-open-file (s "file-author.txt" :direction :input) - (file-author s)))) - (if (or (null author) (stringp author)) - nil - author)) - nil) - -(deftest file-author.6 - (let ((author (let ((s (open "file-author.txt" :direction :input))) - (close s) - (file-author s)))) - (if (or (null author) (stringp author)) - nil - author)) - nil) - -;;; Specialized string tests - -(deftest file-author.7 - (do-special-strings - (s "file-author.txt" nil) - (assert (equal (file-author s) (file-author "file-author.txt")))) - nil) - -;;; FIXME -;;; Add LPN test - -;;; Error tests - -(deftest file-author.error.1 - (signals-error (file-author) program-error) - t) - -(deftest file-author.error.2 - (signals-error (file-author "file-author.txt" nil) program-error) - t) - -(deftest file-author.error.3 - (signals-error-always - (file-author (make-pathname :name :wild :type "lsp" - :defaults *default-pathname-defaults*)) - file-error) - t t) - -(deftest file-author.error.4 - (signals-error-always - (file-author (make-pathname :name "file-author" :type :wild - :defaults *default-pathname-defaults*)) - file-error) - t t) diff --git a/t/ansi-test/files/file-error.lsp b/t/ansi-test/files/file-error.lsp deleted file mode 100644 index 99b4550..0000000 --- a/t/ansi-test/files/file-error.lsp +++ /dev/null @@ -1,84 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Jan 13 19:10:02 2004 -;;;; Contains: Tests of the FILE-ERROR condition, and associated accessor function - -(deftest file-error.1 - (let ((pn (make-pathname :name :wild - :type "txt" - :version :newest - :defaults *default-pathname-defaults*))) - (handler-case - (probe-file pn) - (error (c) - (values - (notnot (typep c 'file-error)) - (if (equalp (file-error-pathname c) pn) - t - (list (file-error-pathname c) pn)))))) - t t) - -(deftest file-error-pathname.1 - (let ((c (make-condition 'file-error :pathname "foo.txt"))) - (values - (notnot (typep c 'file-error)) - (eqlt (class-of c) (find-class 'file-error)) - (file-error-pathname c))) - t t "foo.txt") - -(deftest file-error-pathname.2 - (let ((c (make-condition 'file-error :pathname #p"foo.txt"))) - (values - (notnot (typep c 'file-error)) - (eqlt (class-of c) (find-class 'file-error)) - (equalt #p"foo.txt" (file-error-pathname c)))) - t t t) - -(deftest file-error-pathname.3 - (let ((c (make-condition 'file-error :pathname "CLTEST:foo.txt"))) - (values - (notnot (typep c 'file-error)) - (eqlt (class-of c) (find-class 'file-error)) - (equalpt "CLTEST:foo.txt" - (file-error-pathname c)))) - t t t) - -(deftest file-error-pathname.4 - (let ((c (make-condition - 'file-error :pathname (logical-pathname "CLTEST:foo.txt")))) - (values - (notnot (typep c 'file-error)) - (eqlt (class-of c) (find-class 'file-error)) - (equalpt (logical-pathname "CLTEST:foo.txt") - (file-error-pathname c)))) - t t t) - -(deftest file-error-pathname.5 - (with-open-file (s "file-error.txt" :direction :input) - (let ((c (make-condition 'file-error :pathname s))) - (values - (notnot (typep c 'file-error)) - (eqlt (class-of c) (find-class 'file-error)) - (equalpt s (file-error-pathname c))))) - t t t) - -(deftest file-error-pathname.6 - (let ((s (open "file-error.txt" :direction :input))) - (close s) - (let ((c (make-condition 'file-error :pathname s))) - (values - (notnot (typep c 'file-error)) - (eqlt (class-of c) (find-class 'file-error)) - (equalpt s (file-error-pathname c))))) - t t t) - -(deftest file-error-pathname.error.1 - (signals-error (file-error-pathname) program-error) - t) - -(deftest file-error-pathname.error.2 - (signals-error - (file-error-pathname - (make-condition 'file-error :pathname "foo.txt") - nil) - program-error) t) diff --git a/t/ansi-test/files/file-write-date.lsp b/t/ansi-test/files/file-write-date.lsp deleted file mode 100644 index 060a12f..0000000 --- a/t/ansi-test/files/file-write-date.lsp +++ /dev/null @@ -1,89 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Jan 6 06:01:35 2004 -;;;; Contains: Tests for FILE-WRITE-DATE - - - -(deftest file-write-date.1 - (let* ((pn "file-write-date.txt") - (date (file-write-date pn)) - (time (get-universal-time))) - (or (null date) - (and (integerp date) - (<= 0 date time) - t))) - t) - -(deftest file-write-date.2 - (let* ((pn #p"file-write-date.txt") - (date (file-write-date pn)) - (time (get-universal-time))) - (or (null date) - (and (integerp date) - (<= 0 date time) - t))) - t) - -(deftest file-write-date.3 - (let* ((pn (truename "file-write-date.txt")) - (date (file-write-date pn)) - (time (get-universal-time))) - (or (null date) - (and (integerp date) - (<= 0 date time) - t))) - t) - -(deftest file-write-date.4 - (loop for pn in (directory - (make-pathname :name :wild :type :wild - :defaults *default-pathname-defaults*)) - for date = (file-write-date pn) - for time = (get-universal-time) - unless (or (null date) - (<= 0 date time)) - collect (list pn date time)) - nil) - -(deftest file-write-date.5 - (length (multiple-value-list (file-write-date "file-write-date.txt"))) - 1) - -;;; Specialized string tests - -(deftest file-write-date.6 - (let* ((str "file-write-date.txt") - (date (file-write-date str))) - (do-special-strings - (s str nil) - (assert (equal (file-write-date s) date)))) - nil) - -;;; FIXME -;;; Add LPN test - -;;; Error tests - -(deftest file-write-date.error.1 - (signals-error (file-write-date) program-error) - t) - -(deftest file-write-date.error.2 - (signals-error (file-write-date "file-write-date.txt" nil) - program-error) - t) - -(deftest file-write-date.error.3 - (signals-error-always - (file-write-date (make-pathname :name :wild :type "lsp" - :defaults *default-pathname-defaults*)) - file-error) - t t) - -(deftest file-write-date.error.4 - (signals-error-always - (file-write-date (make-pathname :name "file-write-date" :type :wild - :defaults *default-pathname-defaults*)) - file-error) - t t) diff --git a/t/ansi-test/files/load.lsp b/t/ansi-test/files/load.lsp deleted file mode 100644 index e6758a7..0000000 --- a/t/ansi-test/files/load.lsp +++ /dev/null @@ -1,20 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Jan 1 11:59:35 2004 -;;;; Contains: Load tests of section 20, 'Files' - -(in-package #:cl-test) - -(let ((*default-pathname-defaults* - (make-pathname - :directory (pathname-directory *load-pathname*)))) - (load "directory.lsp") - (load "probe-file.lsp") - (load "ensure-directories-exist.lsp") - (load "truename.lsp") - (load "file-author.lsp") - (load "file-write-date.lsp") - (load "rename-file.lsp") - (load "delete-file.lsp") - (load "file-error.lsp") -) diff --git a/t/ansi-test/files/probe-file.lsp b/t/ansi-test/files/probe-file.lsp deleted file mode 100644 index eedd387..0000000 --- a/t/ansi-test/files/probe-file.lsp +++ /dev/null @@ -1,56 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Jan 5 20:46:29 2004 -;;;; Contains: Tests of PROBE-FILE - -(deftest probe-file.1 - (probe-file #p"nonexistent") - nil) - -(deftest probe-file.2 - (let ((s (open #p"probe-file.txt" :direction :input))) - (prog1 - (equalpt (truename #p"probe-file.txt") - (probe-file s)) - (close s))) - t) - -(deftest probe-file.3 - (let ((s (open #p"probe-file.txt" :direction :input))) - (close s) - (equalpt (truename #p"probe-file.txt") - (probe-file s))) - t) - -(deftest probe-file.4 - (equalpt (truename #p"probe-file.txt") - (probe-file "CLTEST:probe-file.txt")) - t) - -;;; Specialized string tests - -(deftest probe-file.5 - (do-special-strings - (str "probe-file.txt" nil) - (let ((s (open str :direction :input))) - (assert (equalpt (truename #p"probe-file.txt") (probe-file s))) - (close s))) - nil) - -;;; Error tests - -(deftest probe-file.error.1 - (signals-error (probe-file) program-error) - t) - -(deftest probe-file.error.2 - (signals-error (probe-file #p"probe-file.txt" nil) program-error) - t) - -(deftest probe-file.error.3 - (signals-error-always (probe-file (make-pathname :name :wild)) file-error) - t t) - -(deftest probe-file.error.4 - (signals-error-always (probe-file "CLTEST:*.FOO") file-error) - t t) diff --git a/t/ansi-test/files/rename-file.lsp b/t/ansi-test/files/rename-file.lsp deleted file mode 100644 index f8e0d8a..0000000 --- a/t/ansi-test/files/rename-file.lsp +++ /dev/null @@ -1,197 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Jan 8 06:22:53 2004 -;;;; Contains: Tests for RENAME-FILE - -(deftest rename-file.1 - (let ((pn1 #p"file-to-be-renamed.txt") - (pn2 #p"file-that-was-renamed.txt")) - (delete-all-versions pn1) - (delete-all-versions pn2) - (with-open-file (s pn1 :direction :output) (format s "Whatever~%")) - (let ((results (multiple-value-list (rename-file pn1 pn2)))) - (destructuring-bind (defaulted-new-name old-truename new-truename) - results - (values - (=t (length results) 3) - (probe-file pn1) - (notnot (probe-file pn2)) - (list (notnot (pathnamep defaulted-new-name)) - (notnot (pathnamep old-truename)) - (notnot (pathnamep new-truename)) - (typep old-truename 'logical-pathname) - (typep new-truename 'logical-pathname)) - (notnot (probe-file defaulted-new-name)) - (probe-file old-truename) - (notnot (probe-file new-truename)))))) - t nil t (t t t nil nil) t nil t) - -(deftest rename-file.2 - (let ((pn1 "file-to-be-renamed.txt") - (pn2 "file-that-was-renamed.txt")) - (delete-all-versions pn1) - (delete-all-versions pn2) - (with-open-file (s pn1 :direction :output) (format s "Whatever~%")) - (let ((results (multiple-value-list (rename-file pn1 pn2)))) - (destructuring-bind (defaulted-new-name old-truename new-truename) - results - (values - (=t (length results) 3) - (probe-file pn1) - (notnot (probe-file pn2)) - (list (notnot (pathnamep defaulted-new-name)) - (notnot (pathnamep old-truename)) - (notnot (pathnamep new-truename)) - (typep old-truename 'logical-pathname) - (typep new-truename 'logical-pathname)) - (notnot (probe-file defaulted-new-name)) - (probe-file old-truename) - (notnot (probe-file new-truename)))))) - t nil t (t t t nil nil) t nil t) - - (deftest rename-file.3 - (let* ((pn1 (make-pathname :name "file-to-be-renamed" - :type "txt" - :version :newest - :defaults *default-pathname-defaults*)) - (pn2 (make-pathname :name "file-that-was-renamed")) - (pn3 (make-pathname :name "file-that-was-renamed" - :defaults pn1))) - (delete-all-versions pn1) - (delete-all-versions pn3) - (with-open-file (s pn1 :direction :output) (format s "Whatever~%")) - (let ((results (multiple-value-list (rename-file pn1 pn2)))) - (destructuring-bind (defaulted-new-name old-truename new-truename) - results - (values - (equalpt (pathname-type pn1) - (pathname-type defaulted-new-name)) - (=t (length results) 3) - (probe-file pn1) - (notnot (probe-file pn3)) - (list (notnot (pathnamep defaulted-new-name)) - (notnot (pathnamep old-truename)) - (notnot (pathnamep new-truename)) - (typep old-truename 'logical-pathname) - (typep new-truename 'logical-pathname)) - (notnot (probe-file defaulted-new-name)) - (probe-file old-truename) - (notnot (probe-file new-truename)))))) - t t nil t (t t t nil nil) t nil t) - -(deftest rename-file.4 - (let ((pn1 "file-to-be-renamed.txt") - (pn2 "file-that-was-renamed.txt")) - (delete-all-versions pn1) - (delete-all-versions pn2) - (let ((s (open pn1 :direction :output))) - (format s "Whatever~%") - (close s) - (let ((results (multiple-value-list (rename-file s pn2)))) - (destructuring-bind (defaulted-new-name old-truename new-truename) - results - (values - (=t (length results) 3) - (probe-file pn1) - (notnot (probe-file pn2)) - (list (notnot (pathnamep defaulted-new-name)) - (notnot (pathnamep old-truename)) - (notnot (pathnamep new-truename)) - (typep old-truename 'logical-pathname) - (typep new-truename 'logical-pathname)) - (notnot (probe-file defaulted-new-name)) - (probe-file old-truename) - (notnot (probe-file new-truename))))))) - t nil t (t t t nil nil) t nil t) - -(deftest rename-file.5 - (let ((pn1 "CLTEST:file-to-be-renamed.txt") - (pn2 "CLTEST:file-that-was-renamed.txt")) - (delete-all-versions pn1) - (delete-all-versions pn2) - (assert (typep (pathname pn1) 'logical-pathname)) - (assert (typep (pathname pn2) 'logical-pathname)) - (with-open-file (s pn1 :direction :output) (format s "Whatever~%")) - (let ((results (multiple-value-list (rename-file pn1 pn2)))) - (destructuring-bind (defaulted-new-name old-truename new-truename) - results - (values - (=t (length results) 3) - (probe-file pn1) - (notnot (probe-file pn2)) - (list (notnot (pathnamep defaulted-new-name)) - (notnot (pathnamep old-truename)) - (notnot (pathnamep new-truename)) - (typep old-truename 'logical-pathname) - (typep new-truename 'logical-pathname)) - (notnot (probe-file defaulted-new-name)) - (probe-file old-truename) - (notnot (probe-file new-truename)) - (notnot (typep defaulted-new-name 'logical-pathname)) - )))) - t nil t (t t t nil nil) t nil t t) - -;;; Specialized string tests - -(deftest rename-file.6 - (do-special-strings - (s "file-to-be-renamed.txt" nil) - (let ((pn1 s) - (pn2 "file-that-was-renamed.txt")) - (delete-all-versions pn1) - (delete-all-versions pn2) - (with-open-file (s pn1 :direction :output) (format s "Whatever~%")) - (let ((results (multiple-value-list (rename-file pn1 pn2)))) - (destructuring-bind (defaulted-new-name old-truename new-truename) - results - (assert - (equal - (list - (=t (length results) 3) - (probe-file pn1) - (notnot (probe-file pn2)) - (list (notnot (pathnamep defaulted-new-name)) - (notnot (pathnamep old-truename)) - (notnot (pathnamep new-truename)) - (typep old-truename 'logical-pathname) - (typep new-truename 'logical-pathname)) - (notnot (probe-file defaulted-new-name)) - (probe-file old-truename) - (notnot (probe-file new-truename))) - '(t nil t (t t t nil nil) t nil t))))))) - nil) - -(deftest rename-file.7 - (do-special-strings - (s "file-that-was-renamed.txt" nil) - (let ((pn1 "file-to-be-renamed.txt") - (pn2 s)) - (delete-all-versions pn1) - (delete-all-versions pn2) - (with-open-file (s pn1 :direction :output) (format s "Whatever~%")) - (let ((results (multiple-value-list (rename-file pn1 pn2)))) - (destructuring-bind (defaulted-new-name old-truename new-truename) - results - (assert - (equal - (list - (=t (length results) 3) - (probe-file pn1) - (notnot (probe-file pn2)) - (list (notnot (pathnamep defaulted-new-name)) - (notnot (pathnamep old-truename)) - (notnot (pathnamep new-truename)) - (typep old-truename 'logical-pathname) - (typep new-truename 'logical-pathname)) - (notnot (probe-file defaulted-new-name)) - (probe-file old-truename) - (notnot (probe-file new-truename))) - '(t nil t (t t t nil nil) t nil t))))))) - nil) - -;;; Error tests - -(deftest rename-file.error.1 - (signals-error (rename-file) program-error) - t) - diff --git a/t/ansi-test/files/truename.lsp b/t/ansi-test/files/truename.lsp deleted file mode 100644 index a9bb6a1..0000000 --- a/t/ansi-test/files/truename.lsp +++ /dev/null @@ -1,108 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Jan 6 05:32:37 2004 -;;;; Contains: Tests of TRUENAME - -(deftest truename.1 - (let* ((pn #p"truename.txt") - (tn (truename pn))) - (values - (notnot (pathnamep pn)) - (typep pn 'logical-pathname) - (equalt (pathname-name pn) (pathname-name tn)) - (equalt (pathname-type pn) (pathname-type tn)) - )) - t nil t t) - -(deftest truename.2 - (let* ((name "truename.txt") - (pn (pathname name)) - (tn (truename name))) - (values - (notnot (pathnamep pn)) - (typep pn 'logical-pathname) - (equalt (pathname-name pn) (pathname-name tn)) - (equalt (pathname-type pn) (pathname-type tn)) - )) - t nil t t) - -(deftest truename.3 - (let* ((pn #p"truename.txt")) - (with-open-file - (s pn :direction :input) - (let ((tn (truename s))) - (values - (notnot (pathnamep pn)) - (typep pn 'logical-pathname) - (equalt (pathname-name pn) (pathname-name tn)) - (equalt (pathname-type pn) (pathname-type tn)) - )))) - t nil t t) - -(deftest truename.4 - (let* ((pn #p"truename.txt")) - (let ((s (open pn :direction :input))) - (close s) - (let ((tn (truename s))) - (values - (notnot (pathnamep pn)) - (typep pn 'logical-pathname) - (equalt (pathname-name pn) (pathname-name tn)) - (equalt (pathname-type pn) (pathname-type tn)) - )))) - t nil t t) - -(deftest truename.5 - (let* ((lpn "CLTEST:foo.txt") - (pn (translate-logical-pathname lpn))) - (unless (probe-file lpn) - (with-open-file (s lpn :direction :output) (format s "Stuff~%"))) - (let ((tn (truename lpn))) - (values - (notnot (pathnamep pn)) - (if (equalt (pathname-name pn) (pathname-name tn)) - t (list (pathname-name pn) (pathname-name tn))) - (if (equalt (pathname-type pn) (pathname-type tn)) - t (list (pathname-type pn) (pathname-type tn))) - ))) - t t t) - -;;; Specialized string tests - -(deftest truename.6 - (do-special-strings - (s "truename.txt" nil) - (assert (equalp (truename s) (truename "truename.txt")))) - nil) - -;;; Error tests - -(deftest truename.error.1 - (signals-error (truename) program-error) - t) - -(deftest truename.error.2 - (signals-error (truename "truename.txt" nil) program-error) - t) - -(deftest truename.error.3 - (signals-error-always (truename "nonexistent") file-error) - t t) - -(deftest truename.error.4 - (signals-error-always (truename #p"nonexistent") file-error) - t t) - -(deftest truename.error.5 - (signals-error-always - (truename - (logical-pathname "CLTESTROOT:nonexistent")) - file-error) t t) - -(deftest truename.error.6 - (signals-error-always - (let ((pn (make-pathname :name :wild - :defaults *default-pathname-defaults*))) - (truename pn)) - file-error) - t t) diff --git a/t/ansi-test/gclload.lsp b/t/ansi-test/gclload.lsp deleted file mode 100644 index 7ab5388..0000000 --- a/t/ansi-test/gclload.lsp +++ /dev/null @@ -1,38 +0,0 @@ -;;; Uncomment the next line to make MAKE-STRING and MAKE-SEQUENCE -;;; tests require that a missing :initial-element argument defaults -;;; to a single value, rather than leaving the string/sequence filled -;;; with arbitrary legal garbage. -;; (pushnew :ansi-tests-strict-initial-element *features*) - -#+allegro (setq *enclose-printer-errors* nil) - -;;; Remove compiled files -(let* ((fn (compile-file-pathname "doit.lsp")) - (type (pathname-type fn)) - (dir-pathname (make-pathname :name :wild :type type)) - (files (directory dir-pathname))) - (assert type) - (assert (not (string-equal type "lsp"))) - (mapc #'delete-file files)) - -(load "gclload1.lsp") -(load "gclload2.lsp") - -#+allegro -(progn - (rt:disable-note :nil-vectors-are-strings) - (rt:disable-note :standardized-package-nicknames) - (rt:disable-note :type-of/strict-builtins) - (rt:disable-note :assume-no-simple-streams) - (rt:disable-note :assume-no-gray-streams)) - -#+gcl(si::use-fast-links nil) - -(in-package :cl-test) - -;;; These two tests will misbehave if the tests are being -;;; invoked from a file that is being loaded, so remove them -(when *load-pathname* - (mapc #'regression-test:rem-test '(load-pathname.1 load-truename.1))) - -(time (regression-test:do-tests)) diff --git a/t/ansi-test/gclload1.lsp b/t/ansi-test/gclload1.lsp deleted file mode 100644 index 1404afc..0000000 --- a/t/ansi-test/gclload1.lsp +++ /dev/null @@ -1,55 +0,0 @@ -#+ecl (si::package-lock (find-package "COMMON-LISP") nil) -#+ecl (compile nil '(lambda () nil)) -#+ecl (setq c:*suppress-compiler-warnings* t - c:*suppress-compiler-notes* t - c:*suppress-compiler-messages* t) -#+:armedbear (require 'pprint) -#+cmu -(progn - (setq ext:*gc-verbose* nil) - ;; Set *default-pathname-defaults* to include the full path to this - ;; file. This is needed for the tests so that they'll be loaded - ;; correctly from the subdirectories. - (setf *default-pathname-defaults* - (make-pathname :name nil :type nil :defaults *load-truename*))) - -#+gcl (setq compiler:*suppress-compiler-notes* t - compiler:*suppress-compiler-warnings* t - compiler:*compile-verbose* nil - compiler:*compile-print* nil) - -#+lispworks (setq compiler::*compiler-warnings* nil) -#+lispworks (make-echo-stream *standard-input* *standard-output*) -#+clisp (setq custom::*warn-on-floating-point-contagion* nil) - -;;; Configure logical pathnames -(setf (logical-pathname-translations "ANSI-TESTS") - `(("AUX;*.*.*" - ,(merge-pathnames "auxiliary/" - (make-pathname - :directory - (pathname-directory *load-truename*)))))) - -(let (*load-verbose* *load-print* *compile-verbose* *compile-print*) - (load "compile-and-load.lsp")) - -(let (*load-verbose* *load-print* *compile-verbose* *compile-print*) - (load "rt-package.lsp") - (compile-and-load "rt.lsp") - (load "cl-test-package.lsp") - (in-package :cl-test) - (compile-and-load "ANSI-TESTS:AUX;ansi-aux-macros.lsp") - (handler-bind - #-sbcl () - #+sbcl ((sb-ext:code-deletion-note #'muffle-warning)) - (load "universe.lsp")) - (compile-and-load "ANSI-TESTS:AUX;random-aux.lsp") - (compile-and-load "ANSI-TESTS:AUX;ansi-aux.lsp") - - (load "cl-symbol-names.lsp") - (load "notes.lsp")) - -(setq *compile-verbose* nil - *compile-print* nil - *load-verbose* nil) - diff --git a/t/ansi-test/gclload2.lsp b/t/ansi-test/gclload2.lsp deleted file mode 100644 index ef47b63..0000000 --- a/t/ansi-test/gclload2.lsp +++ /dev/null @@ -1,76 +0,0 @@ -;;; Load test files -(in-package :cl-test) - -;;; Tests of symbols -(load "symbols/load.lsp") - -;;; Tests of evaluation and compilation -(load "eval-and-compile/load.lsp") - -;;; Tests of data and control flow -(load "data-and-control-flow/load.lsp") - -;;; Tests of iteration forms -(load "iteration/load.lsp") - -;;; Tests of objects -(load "objects/load.lsp") - -;;; Tests of conditions -(load "conditions/load.lsp") - -;;; Tests of conses -(load "cons/load.lsp") - -;;; Tests on arrays -(load "arrays/load.lsp") - -;;; Tests of hash tables -(load "hash-tables/load.lsp") - -;;; Tests of packages - -(load "packages/load.lsp") - -;;; Tests of numbers (section 12) -(load "numbers/load.lsp") - -;;; Tests of sequences -(load "sequences/load.lsp") - -;;; Tests of structures -(load "structures/load.lsp") - -;;; Tests of types and classes -(load "types-and-classes/load.lsp") - -;;; Tests of strings -(load "strings/load.lsp") - -;;; Tests for character functions -(load "characters/load.lsp") - -;;; Tests of pathnames -(load "pathnames/load.lsp") - -;;; Tests of file operations -(load "files/load.lsp") - -;;; Tests of streams -(load "streams/load.lsp") - -;;; Tests of the printer -(load "printer/load.lsp") - -;;; Tests of the reader -(load "reader/load.lsp") - -;;; Tests of system construction -(load "system-construction/load.lsp") - -;;; Tests of environment -(load "environment/load.lsp") - -;;; Miscellaneous tests, mostly tests that failed in random testing -;;; on various implementations -(load "misc/load.lsp") diff --git a/t/ansi-test/hash-tables/clrhash.lsp b/t/ansi-test/hash-tables/clrhash.lsp deleted file mode 100644 index 90142d3..0000000 --- a/t/ansi-test/hash-tables/clrhash.lsp +++ /dev/null @@ -1,69 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Nov 28 09:33:40 2003 -;;;; Contains: Tests of CLRHASH - - - -(deftest clrhash.1 - (let ((table (make-hash-table))) - (setf (gethash 'a table) 'b) - (values - (hash-table-count table) - (equalt (multiple-value-list (clrhash table)) - (list table)) - (hash-table-count table))) - 1 t 0) - -(deftest clrhash.2 - (let ((table (make-hash-table :test 'eq))) - (setf (gethash 'a table) 'b) - (values - (hash-table-count table) - (equalt (multiple-value-list (clrhash table)) - (list table)) - (hash-table-count table))) - 1 t 0) - -(deftest clrhash.3 - (let ((table (make-hash-table :test 'equal))) - (setf (gethash 'a table) 'b) - (values - (hash-table-count table) - (equalt (multiple-value-list (clrhash table)) - (list table)) - (hash-table-count table))) - 1 t 0) - -(deftest clrhash.4 - (let ((table (make-hash-table :test 'equalp))) - (setf (gethash 'a table) 'b) - (values - (hash-table-count table) - (equalt (multiple-value-list (clrhash table)) - (list table)) - (hash-table-count table))) - 1 t 0) - -(deftest clrhash.5 - (let ((table (make-hash-table :test 'eql))) - (setf (gethash 'a table) 'b) - (values - (hash-table-count table) - (equalt (multiple-value-list (clrhash table)) - (list table)) - (hash-table-count table))) - 1 t 0) - -;;; - -(deftest clrhash.error.1 - (signals-error (clrhash) program-error) - t) - -(deftest clrhash.error.2 - (signals-error (clrhash (make-hash-table) nil) - program-error) - t) - - diff --git a/t/ansi-test/hash-tables/gethash.lsp b/t/ansi-test/hash-tables/gethash.lsp deleted file mode 100644 index 0a6d262..0000000 --- a/t/ansi-test/hash-tables/gethash.lsp +++ /dev/null @@ -1,162 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Nov 28 06:05:21 2003 -;;;; Contains: Tests of GETHASH - - - -;;; Most testing of GETHASH is in test-hash-table-1 in hash-table-aux.lsp - -(deftest gethash.1 - (gethash 'x (make-hash-table) 'y) - y nil) - -(deftest gethash.2 - (gethash nil (make-hash-table) 'a) - a nil) - -(deftest gethash.3 - (gethash nil (make-hash-table) 'a) - a nil) - -(deftest gethash.4 - (multiple-value-bind (value present) - (gethash 'a (let ((table (make-hash-table))) - (setf (gethash 'a table) 'b) - table)) - (values value (notnot present))) - b t) - -(deftest gethash.5 - (let ((table (make-hash-table)) - (i 0)) - (values - (setf (gethash 'x table (incf i)) 'y) - i - (gethash 'x table))) - y 1 y) - -(deftest gethash.order.1 - (let ((i 0) x y - (table (make-hash-table))) - (setf (gethash 'a table) 'b) - (values - (gethash (progn (setf x (incf i)) 'a) - (progn (setf y (incf i)) table)) - i x y)) - b 2 1 2) - -(deftest gethash.order.2 - (let ((i 0) x y z - (table (make-hash-table))) - (setf (gethash 'a table) 'b) - (values - (gethash (progn (setf x (incf i)) 'a) - (progn (setf y (incf i)) table) - (progn (setf z (incf i)) 'missing)) - i x y z)) - b 3 1 2 3) - -(deftest gethash.order.3 - (let ((i 0) x y - (table (make-hash-table))) - (values - (setf (gethash (progn (setf x (incf i)) 'a) - (progn (setf y (incf i)) table)) - 'b) - i x y - (gethash 'a table))) - b 2 1 2 b) - -(deftest gethash.order.4 - (let ((i 0) x y z - (table (make-hash-table))) - (values - (setf (gethash (progn (setf x (incf i)) 'a) - (progn (setf y (incf i)) table) - (setf z (incf i))) - 'b) - i x y z - (gethash 'a table))) - b 3 1 2 3 b) - - -;;; Tests for 0.0, -0.0 in hash tables - -(deftest gethash.zero.1 - (loop for pz in '(0.0s0 0.0f0 0.0d0 0.0l0) - for nz = (- pz) - for result = (let ((table (make-hash-table :test 'eq))) - (list - (setf (gethash pz table) :x) - (gethash pz table) - (gethash nz table) - (setf (gethash nz table) :y) - (gethash pz table) - (gethash nz table))) - unless (or (eql pz nz) - (equal result '(:x :x nil :y :x :y))) - collect (list pz nz result)) - nil) - -(deftest gethash.zero.2 - (loop for pz in '(0.0s0 0.0f0 0.0d0 0.0l0) - for nz = (- pz) - for result = (let ((table (make-hash-table :test 'eql))) - (list - (setf (gethash pz table) :x) - (gethash pz table) - (gethash nz table) - (setf (gethash nz table) :y) - (gethash pz table) - (gethash nz table))) - unless (or (eql pz nz) - (equal result '(:x :x nil :y :x :y))) - collect (list pz nz result)) - nil) - -(deftest gethash.zero.3 - (loop for pz in '(0.0s0 0.0f0 0.0d0 0.0l0) - for nz = (- pz) - for result = (let ((table (make-hash-table :test 'equal))) - (list - (setf (gethash pz table) :x) - (gethash pz table) - (gethash nz table) - (setf (gethash nz table) :y) - (gethash pz table) - (gethash nz table))) - unless (or (eql pz nz) - (equal result '(:x :x nil :y :x :y))) - collect (list pz nz result)) - nil) - -(deftest gethash.zero.4 - (loop for pz in '(0.0s0 0.0f0 0.0d0 0.0l0) - for nz = (- pz) - for result = (let ((table (make-hash-table :test 'equalp))) - (list - (setf (gethash pz table) :x) - (gethash pz table) - (gethash nz table) - (setf (gethash nz table) :y) - (gethash pz table) - (gethash nz table))) - unless (or (eql pz nz) - (equal result '(:x :x :x :y :y :y))) - collect (list pz nz result)) - nil) - -;;;; Error tests - -(deftest gethash.error.1 - (signals-error (gethash) program-error) - t) - -(deftest gethash.error.2 - (signals-error (gethash 'foo) program-error) - t) - -(deftest gethash.error.3 - (signals-error (gethash 'foo (make-hash-table) nil nil) program-error) - t) diff --git a/t/ansi-test/hash-tables/hash-table-count.lsp b/t/ansi-test/hash-tables/hash-table-count.lsp deleted file mode 100644 index 6bc3a9e..0000000 --- a/t/ansi-test/hash-tables/hash-table-count.lsp +++ /dev/null @@ -1,68 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Nov 28 05:14:25 2003 -;;;; Contains: Tests of HASH-TABLE-COUNT - - - -(deftest hash-table-count.1 - (hash-table-count (make-hash-table)) - 0) - -(deftest hash-table-count.2 - (hash-table-count (make-hash-table :test 'eq)) - 0) - -(deftest hash-table-count.3 - (hash-table-count (make-hash-table :test 'eql)) - 0) - -(deftest hash-table-count.4 - (hash-table-count (make-hash-table :test 'equal)) - 0) - -(deftest hash-table-count.5 - (hash-table-count (make-hash-table :test 'equalp)) - 0) - -(deftest hash-table-count.6 - (hash-table-count (make-hash-table :test #'eq)) - 0) - -(deftest hash-table-count.7 - (hash-table-count (make-hash-table :test #'eql)) - 0) - -(deftest hash-table-count.8 - (hash-table-count (make-hash-table :test #'equal)) - 0) - -(deftest hash-table-count.9 - (hash-table-count (make-hash-table :test #'equalp)) - 0) - -(deftest hash-table-count.10 - (hash-table-count (let ((table (make-hash-table))) - (setf (gethash 'x table) 1) - table)) - 1) - -(deftest hash-table-count.11 - (let ((table (make-hash-table))) - (setf (gethash 'x table) 1) - (values (hash-table-count table) - (progn - (remhash 'x table) - (hash-table-count table)))) - 1 0) - -;; This function is mostly tested by calls to test-hash-table-1 - -(deftest hash-table-count.error.1 - (signals-error (hash-table-count) program-error) - t) - -(deftest hash-table-count.error.2 - (signals-error (hash-table-count (make-hash-table) nil) - program-error) - t) diff --git a/t/ansi-test/hash-tables/hash-table-p.lsp b/t/ansi-test/hash-tables/hash-table-p.lsp deleted file mode 100644 index d63e243..0000000 --- a/t/ansi-test/hash-tables/hash-table-p.lsp +++ /dev/null @@ -1,41 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Sep 16 21:58:37 2003 -;;;; Contains: Tests for HASH-TABLE-P - - - -(deftest hash-table-p.1 - (loop for e in '(nil t 1 10.0 (a b c) #(a b c) #*1011 - #0aNIL #2a((a b)(c d)) #p"foo" - "bar" #\a 3/5 #c(1.0 2.0)) - when (hash-table-p e) - collect e) - nil) - -(deftest hash-table-p.2 - (check-type-predicate #'hash-table-p 'hash-table) - nil) - -(deftest hash-table-p.3 - (let ((i 0)) - (values (hash-table-p (incf i)) i)) - nil 1) - -(deftest hash-table-p.4 - (hash-table-p t) - nil) - -(deftest hash-table-p.5 - (notnot-mv (hash-table-p (make-hash-table))) - t) - -(deftest hash-table-p.error.1 - (signals-error (hash-table-p) program-error) - t) - -(deftest hash-table-p.error.2 - (signals-error (let ((h (make-hash-table))) (hash-table-p h nil)) - program-error) - t) - diff --git a/t/ansi-test/hash-tables/hash-table-rehash-size.lsp b/t/ansi-test/hash-tables/hash-table-rehash-size.lsp deleted file mode 100644 index a8c4893..0000000 --- a/t/ansi-test/hash-tables/hash-table-rehash-size.lsp +++ /dev/null @@ -1,39 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Nov 28 05:47:24 2003 -;;;; Contains: Tests for HASH-TABLE-REHASH-SIZE - - - -(deftest hash-table-rehash-size.1 - (typep* (hash-table-rehash-size (make-hash-table)) - '(or (integer 1 *) (float (1.0) *))) - t) - -(deftest hash-table-rehash-size.2 - (loop for test in '(eq eql equal equalp) - unless (typep* (hash-table-rehash-size (make-hash-table :test test)) - '(or (integer 1 *) (float (1.0) *))) - collect test) - nil) - -(deftest hash-table-rehash-size.3 - (loop for test in '(eq eql equal equalp) - for fn = (symbol-function test) - unless (typep* (hash-table-rehash-size (make-hash-table :test fn)) - '(or (integer 1 *) (float (1.0) *))) - collect test) - nil) - -(deftest hash-table-rehash-size.error.1 - (signals-error (hash-table-rehash-size) program-error) - t) - -(deftest hash-table-rehash-size.error.2 - (signals-error (hash-table-rehash-size (make-hash-table) nil) - program-error) - t) - -(deftest hash-table-rehash-size.error.3 - (check-type-error #'hash-table-rehash-size #'hash-table-p) - nil) diff --git a/t/ansi-test/hash-tables/hash-table-rehash-threshold.lsp b/t/ansi-test/hash-tables/hash-table-rehash-threshold.lsp deleted file mode 100644 index d6efd82..0000000 --- a/t/ansi-test/hash-tables/hash-table-rehash-threshold.lsp +++ /dev/null @@ -1,39 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Nov 28 05:52:52 2003 -;;;; Contains: Tests of HASH-TABLE-REHASH-THRESHOLD - - - -(deftest hash-table-rehash-threshold.1 - (typep* (hash-table-rehash-threshold (make-hash-table)) - '(real 0 1)) - t) - -(deftest hash-table-rehash-threshold.2 - (loop for test in '(eq eql equal equalp) - unless (typep* (hash-table-rehash-threshold (make-hash-table :test test)) - '(real 0 1)) - collect test) - nil) - -(deftest hash-table-rehash-threshold.3 - (loop for test in '(eq eql equal equalp) - for fn = (symbol-function test) - unless (typep* (hash-table-rehash-threshold (make-hash-table :test fn)) - '(real 0 1)) - collect test) - nil) - -(deftest hash-table-rehash-threshold.error.1 - (signals-error (hash-table-rehash-threshold) program-error) - t) - -(deftest hash-table-rehash-threshold.error.2 - (signals-error (hash-table-rehash-threshold (make-hash-table) nil) - program-error) - t) - -(deftest hash-table-rehash-threshold.error.3 - (check-type-error #'hash-table-rehash-threshold #'hash-table-p) - nil) diff --git a/t/ansi-test/hash-tables/hash-table-size.lsp b/t/ansi-test/hash-tables/hash-table-size.lsp deleted file mode 100644 index a667b61..0000000 --- a/t/ansi-test/hash-tables/hash-table-size.lsp +++ /dev/null @@ -1,19 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Nov 28 05:23:45 2003 -;;;; Contains: Tests for HASH-TABLE-SIZE - - - -(deftest hash-table-size.error.1 - (signals-error (hash-table-size) program-error) - t) - -(deftest hash-table-size.error.2 - (signals-error (hash-table-size (make-hash-table) nil) - program-error) - t) - -(deftest hash-table-size.error.3 - (check-type-error #'hash-table-size #'hash-table-p) - nil) diff --git a/t/ansi-test/hash-tables/hash-table-test.lsp b/t/ansi-test/hash-tables/hash-table-test.lsp deleted file mode 100644 index 384d8bc..0000000 --- a/t/ansi-test/hash-tables/hash-table-test.lsp +++ /dev/null @@ -1,46 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Nov 28 05:56:22 2003 -;;;; Contains: Tests for HASH-TABLE-TEST - - - -(deftest hash-table-test.1 - (hash-table-test (make-hash-table)) - eql) - -(deftest hash-table-test.2 - (loop for test in '(eq eql equal equalp) - unless (eq (hash-table-test (make-hash-table :test test)) test) - collect test) - nil) - -(deftest hash-table-test.3 - (loop for test in '(eq eql equal equalp) - unless (eq (hash-table-test (make-hash-table - :test (symbol-function test))) - test) - collect test) - nil) - -(deftest hash-table-test.4 - (loop for test in '(eq eql equal equalp) - unless (eq (hash-table-test (make-hash-table - :test (eval `(function ,test)))) - test) - collect test) - nil) - -;;; Error cases - -(deftest hash-table-test.error.1 - (signals-error (hash-table-test) program-error) - t) - -(deftest hash-table-test.error.2 - (signals-error (hash-table-test (make-hash-table) nil) program-error) - t) - -(deftest hash-table-test.error.3 - (check-type-error #'hash-table-test #'hash-table-p) - nil) diff --git a/t/ansi-test/hash-tables/hash-table.lsp b/t/ansi-test/hash-tables/hash-table.lsp deleted file mode 100644 index 4b6ca55..0000000 --- a/t/ansi-test/hash-tables/hash-table.lsp +++ /dev/null @@ -1,41 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jan 26 21:30:42 2003 -;;;; Contains: Tests of HASH-TABLE and related interface - - - -(deftest hash-table.1 - (notnot-mv (find-class 'hash-table)) - t) - -(deftest hash-table.2 - (loop for e in '(nil t 1 10.0 (a b c) #(a b c) #*1011 - #0aNIL #2a((a b)(c d)) #p"foo" - "bar" #\a 3/5 #c(1.0 2.0)) - when (typep e 'hash-table) - collect e) - nil) - -(deftest hash-table.3 - (let ((c (find-class 'hash-table))) - (loop for e in '(nil t 1 10.0 (a b c) #(a b c) #*1011 - #0aNIL #2a((a b)(c d)) #p"foo" - "bar" #\a 3/5 #c(1.0 2.0)) - when (typep e c) - collect e)) - nil) - -(deftest hash-table.4 - (notnot-mv (typep (make-hash-table) 'hash-table)) - t) - -(deftest hash-table.5 - (notnot-mv (typep (make-hash-table) (find-class 'hash-table))) - t) - - - - - - diff --git a/t/ansi-test/hash-tables/load.lsp b/t/ansi-test/hash-tables/load.lsp deleted file mode 100644 index b5780d6..0000000 --- a/t/ansi-test/hash-tables/load.lsp +++ /dev/null @@ -1,22 +0,0 @@ -(compile-and-load "ANSI-TESTS:AUX;hash-table-aux.lsp") - -(in-package #:cl-test) - -(let ((*default-pathname-defaults* - (make-pathname - :directory (pathname-directory *load-pathname*)))) - (load "hash-table.lsp") - (load "make-hash-table.lsp") - (load "hash-table-p.lsp") - (load "hash-table-count.lsp") - (load "hash-table-size.lsp") - (load "hash-table-rehash-size.lsp") - (load "hash-table-rehash-threshold.lsp") - (load "hash-table-test.lsp") - (load "gethash.lsp") - (load "remhash.lsp") - (load "clrhash.lsp") - (load "maphash.lsp") - (load "with-hash-table-iterator.lsp") - (load "sxhash.lsp") -) diff --git a/t/ansi-test/hash-tables/make-hash-table.lsp b/t/ansi-test/hash-tables/make-hash-table.lsp deleted file mode 100644 index d50dcc2..0000000 --- a/t/ansi-test/hash-tables/make-hash-table.lsp +++ /dev/null @@ -1,257 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jan 26 21:36:33 2003 -;;;; Contains: Tests for MAKE-HASH-TABLE - - - -;; (eval-when (:load-toplevel :compile-toplevel :execute) -;; (compile-and-load "hash-table-aux.lsp")) - -(deftest make-hash-table.1 - (let ((ht (make-hash-table))) - (values - (notnot (typep ht 'hash-table)) - (notnot (hash-table-p ht)) - (hash-table-count ht))) - t t 0) - -(deftest make-hash-table.2 - (let ((ht (make-hash-table :size 0))) - (values - (notnot (typep ht 'hash-table)) - (notnot (hash-table-p ht)) - (hash-table-count ht))) - t t 0) - -(deftest make-hash-table.3 - (let ((ht (make-hash-table :size 100))) - (values - (notnot (typep ht 'hash-table)) - (notnot (hash-table-p ht)) - (hash-table-count ht))) - t t 0) - -(deftest make-hash-table.4 - (let ((ht (make-hash-table :test #'eq))) - (values - (notnot (typep ht 'hash-table)) - (notnot (hash-table-p ht)) - (hash-table-count ht))) - t t 0) - -(deftest make-hash-table.5 - (let ((ht (make-hash-table :test 'eq))) - (values - (notnot (typep ht 'hash-table)) - (notnot (hash-table-p ht)) - (hash-table-count ht))) - t t 0) - -(deftest make-hash-table.6 - (let ((ht (make-hash-table :test #'eql))) - (values - (notnot (typep ht 'hash-table)) - (notnot (hash-table-p ht)) - (hash-table-count ht))) - t t 0) - -(deftest make-hash-table.7 - (let ((ht (make-hash-table :test 'eql))) - (values - (notnot (typep ht 'hash-table)) - (notnot (hash-table-p ht)) - (hash-table-count ht))) - t t 0) - -(deftest make-hash-table.8 - (let ((ht (make-hash-table :test #'equal))) - (values - (notnot (typep ht 'hash-table)) - (notnot (hash-table-p ht)) - (hash-table-count ht))) - t t 0) - -(deftest make-hash-table.9 - (let ((ht (make-hash-table :test 'equal))) - (values - (notnot (typep ht 'hash-table)) - (notnot (hash-table-p ht)) - (hash-table-count ht))) - t t 0) - -(deftest make-hash-table.10 - (let ((ht (make-hash-table :test #'equalp))) - (values - (notnot (typep ht 'hash-table)) - (notnot (hash-table-p ht)) - (hash-table-count ht))) - t t 0) - -(deftest make-hash-table.11 - (let ((ht (make-hash-table :test 'equalp))) - (values - (notnot (typep ht 'hash-table)) - (notnot (hash-table-p ht)) - (hash-table-count ht))) - t t 0) - -(deftest make-hash-table.12 - (let ((ht (make-hash-table :rehash-size 1))) - (values - (notnot (typep ht 'hash-table)) - (notnot (hash-table-p ht)) - (hash-table-count ht))) - t t 0) - -(deftest make-hash-table.13 - (let ((ht (make-hash-table :rehash-size 1000))) - (values - (notnot (typep ht 'hash-table)) - (notnot (hash-table-p ht)) - (hash-table-count ht))) - t t 0) - -(deftest make-hash-table.14 - (let ((ht (make-hash-table :rehash-size (+ 1.0f0 single-float-epsilon)))) - (values - (notnot (typep ht 'hash-table)) - (notnot (hash-table-p ht)) - (hash-table-count ht))) - t t 0) - -(deftest make-hash-table.15 - (let ((ht (make-hash-table :rehash-size 2.0))) - (values - (notnot (typep ht 'hash-table)) - (notnot (hash-table-p ht)) - (hash-table-count ht))) - t t 0) - -(deftest make-hash-table.16 - (let ((ht (make-hash-table :rehash-threshold 0))) - (values - (notnot (typep ht 'hash-table)) - (notnot (hash-table-p ht)) - (hash-table-count ht))) - t t 0) - -(deftest make-hash-table.17 - (let ((ht (make-hash-table :rehash-threshold 0.0s0))) - (values - (notnot (typep ht 'hash-table)) - (notnot (hash-table-p ht)) - (hash-table-count ht))) - t t 0) - -(deftest make-hash-table.18 - (let ((ht (make-hash-table :rehash-threshold 0.0f0))) - (values - (notnot (typep ht 'hash-table)) - (notnot (hash-table-p ht)) - (hash-table-count ht))) - t t 0) - -(deftest make-hash-table.19 - (let ((ht (make-hash-table :rehash-threshold 0.0d0))) - (values - (notnot (typep ht 'hash-table)) - (notnot (hash-table-p ht)) - (hash-table-count ht))) - t t 0) - -(deftest make-hash-table.20 - (let ((ht (make-hash-table :rehash-threshold 0.0l0))) - (values - (notnot (typep ht 'hash-table)) - (notnot (hash-table-p ht)) - (hash-table-count ht))) - t t 0) - -(deftest make-hash-table.21 - (let ((ht (make-hash-table :rehash-threshold 1/2))) - (values - (notnot (typep ht 'hash-table)) - (notnot (hash-table-p ht)) - (hash-table-count ht))) - t t 0) - -(deftest make-hash-table.22 - (let ((ht (make-hash-table :rehash-threshold 0.1s0))) - (values - (notnot (typep ht 'hash-table)) - (notnot (hash-table-p ht)) - (hash-table-count ht))) - t t 0) - -(deftest make-hash-table.23 - (let ((ht (make-hash-table :rehash-threshold 0.2f0))) - (values - (notnot (typep ht 'hash-table)) - (notnot (hash-table-p ht)) - (hash-table-count ht))) - t t 0) - -(deftest make-hash-table.24 - (let ((ht (make-hash-table :rehash-threshold 0.8d0))) - (values - (notnot (typep ht 'hash-table)) - (notnot (hash-table-p ht)) - (hash-table-count ht))) - t t 0) - -(deftest make-hash-table.25 - (let ((ht (make-hash-table :rehash-threshold 0.99f0))) - (values - (notnot (typep ht 'hash-table)) - (notnot (hash-table-p ht)) - (hash-table-count ht))) - t t 0) - -(deftest make-hash-table.26 - (let ((ht (make-hash-table :rehash-threshold least-positive-short-float))) - (values - (notnot (typep ht 'hash-table)) - (notnot (hash-table-p ht)) - (hash-table-count ht))) - t t 0) - -(deftest make-hash-table.27 - (let ((ht (make-hash-table :rehash-threshold least-positive-single-float))) - (values - (notnot (typep ht 'hash-table)) - (notnot (hash-table-p ht)) - (hash-table-count ht))) - t t 0) - -(deftest make-hash-table.28 - (let ((ht (make-hash-table :rehash-threshold least-positive-double-float))) - (values - (notnot (typep ht 'hash-table)) - (notnot (hash-table-p ht)) - (hash-table-count ht))) - t t 0) - -(deftest make-hash-table.29 - (let ((ht (make-hash-table :rehash-threshold least-positive-long-float))) - (values - (notnot (typep ht 'hash-table)) - (notnot (hash-table-p ht)) - (hash-table-count ht))) - t t 0) - - - - - - - - - - - - - - - - \ No newline at end of file diff --git a/t/ansi-test/hash-tables/maphash.lsp b/t/ansi-test/hash-tables/maphash.lsp deleted file mode 100644 index a6240b6..0000000 --- a/t/ansi-test/hash-tables/maphash.lsp +++ /dev/null @@ -1,143 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Nov 28 09:36:58 2003 -;;;; Contains: Test of MAPHASH - - - -(deftest maphash.1 - (let ((table (make-hash-table))) - (loop for i from 1 to 1000 do (setf (gethash i table) (+ i i))) - (let ((s1 0) (s2 0)) - (values - (multiple-value-list - (maphash #'(lambda (k v) (incf s1 k) (incf s2 v)) table)) - s1 s2))) - (nil) #.(* 500 1001) #.(* 1000 1001)) - -(deftest maphash.2 - (let ((table (make-hash-table :test 'equal))) - (loop for i from 1 to 1000 do (setf (gethash i table) (+ i i))) - (let ((s1 0) (s2 0)) - (values - (multiple-value-list - (maphash #'(lambda (k v) (incf s1 k) (incf s2 v)) table)) - s1 s2))) - (nil) #.(* 500 1001) #.(* 1000 1001)) - -(deftest maphash.3 - (let ((table (make-hash-table :test 'equalp))) - (loop for i from 1 to 1000 do (setf (gethash i table) (+ i i))) - (let ((s1 0) (s2 0)) - (values - (multiple-value-list - (maphash #'(lambda (k v) (incf s1 k) (incf s2 v)) table)) - s1 s2))) - (nil) #.(* 500 1001) #.(* 1000 1001)) - -;;; Test that REMHASH on the key being traversed is allowed - -(deftest maphash.4 - (let ((table (make-hash-table))) - (loop for i from 1 to 1000 do (setf (gethash i table) (+ i i))) - (let ((s1 0) (s2 0)) - (values - (multiple-value-list - (maphash #'(lambda (k v) - (incf s1 k) (incf s2 v) - (remhash k table)) - table)) - s1 s2 (hash-table-count table)))) - (nil) #.(* 500 1001) #.(* 1000 1001) 0) - -(deftest maphash.5 - (let ((table (make-hash-table :test 'equal))) - (loop for i from 1 to 1000 do (setf (gethash i table) (+ i i))) - (let ((s1 0) (s2 0)) - (values - (multiple-value-list - (maphash #'(lambda (k v) - (incf s1 k) (incf s2 v) - (remhash k table)) - table)) - s1 s2 (hash-table-count table)))) - (nil) #.(* 500 1001) #.(* 1000 1001) 0) - -(deftest maphash.6 - (let ((table (make-hash-table :test 'equalp))) - (loop for i from 1 to 1000 do (setf (gethash i table) (+ i i))) - (let ((s1 0) (s2 0)) - (values - (multiple-value-list - (maphash #'(lambda (k v) - (incf s1 k) (incf s2 v) - (remhash k table)) - table)) - s1 s2 (hash-table-count table)))) - (nil) #.(* 500 1001) #.(* 1000 1001) 0) - - -;;; EQ hash tables - -(deftest maphash.7 - (let ((symbols '(a b c d e f g h i j k l m n o p q r s t u v w x y z)) - (table (make-hash-table :test #'eq))) - (loop for sym in symbols - for i from 1 - do (setf (gethash sym table) i)) - (let ((sum 0)) - (values - (multiple-value-list - (maphash #'(lambda (k v) - (assert (eq (elt symbols (1- v)) k)) - (incf sum v)) - table)) - sum))) - (nil) #.(* 13 27)) - -(deftest maphash.8 - (let ((symbols '(a b c d e f g h i j k l m n o p q r s t u v w x y z)) - (table (make-hash-table :test #'eq))) - (loop for sym in symbols - for i from 1 - do (setf (gethash sym table) i)) - (let ((sum 0)) - (values - (multiple-value-list - (maphash #'(lambda (k v) - (assert (eq (elt symbols (1- v)) k)) - (remhash k table) - (incf sum v)) - table)) - sum - (hash-table-count table)))) - (nil) #.(* 13 27) 0) - -;;; Need to add tests where things are setf'd during traversal - -(deftest maphash.order.1 - (let ((i 0) x y dummy - (table (make-hash-table))) - (values - (multiple-value-list - (maphash (progn (setf x (incf i)) - #'(lambda (k v) (setf dummy (list k v)))) - (progn (setf y (incf i)) - table))) - i x y dummy)) - (nil) 2 1 2 nil) - - -;;; Error tests - -(deftest maphash.error.1 - (signals-error (maphash) program-error) - t) - -(deftest maphash.error.2 - (signals-error (maphash #'list) program-error) - t) - -(deftest maphash.error.3 - (signals-error (maphash #'list (make-hash-table) nil) program-error) - t) diff --git a/t/ansi-test/hash-tables/remhash.lsp b/t/ansi-test/hash-tables/remhash.lsp deleted file mode 100644 index 39c6d2b..0000000 --- a/t/ansi-test/hash-tables/remhash.lsp +++ /dev/null @@ -1,86 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Nov 28 08:58:06 2003 -;;;; Contains: Tests of REMHASH - - - -(deftest remhash.1 - (let ((table (make-hash-table))) - (values (gethash 'a table) - (remhash 'a table) - (setf (gethash 'a table) 'b) - (gethash 'a table) - (notnot (remhash 'a table)) - (gethash 'a table))) - nil nil b b t nil) - -(deftest remhash.2 - (let ((table (make-hash-table :test 'eq))) - (values (gethash 'a table) - (remhash 'a table) - (setf (gethash 'a table) 'b) - (gethash 'a table) - (notnot (remhash 'a table)) - (gethash 'a table))) - nil nil b b t nil) - -(deftest remhash.3 - (let ((table (make-hash-table :test 'equal))) - (values (gethash 'a table) - (remhash 'a table) - (setf (gethash 'a table) 'b) - (gethash 'a table) - (notnot (remhash 'a table)) - (gethash 'a table))) - nil nil b b t nil) - -(deftest remhash.4 - (let ((table (make-hash-table :test 'equalp))) - (values (gethash 'a table) - (remhash 'a table) - (setf (gethash 'a table) 'b) - (gethash 'a table) - (notnot (remhash 'a table)) - (gethash 'a table))) - nil nil b b t nil) - -(deftest remhash.5 - (remhash 'a (make-hash-table)) - nil) - -(deftest remhash.6 - (notnot-mv (remhash nil (let ((table (make-hash-table))) - (setf (gethash nil table) t) - table))) - t) - -(deftest remhash.order.1 - (let ((i 0) x y) - (values - (remhash (progn (setf x (incf i)) 'a) - (progn (setf y (incf i)) (make-hash-table))) - i x y)) - nil 2 1 2) - -;;; Error tests - -(deftest remhash.error.1 - (signals-error (remhash) program-error) - t) - -(deftest remhash.error.2 - (signals-error (remhash 'a) program-error) - t) - -(deftest remhash.error.3 - (signals-error (remhash 'a (make-hash-table) nil) program-error) - t) - - - - - - - - diff --git a/t/ansi-test/hash-tables/sxhash.lsp b/t/ansi-test/hash-tables/sxhash.lsp deleted file mode 100644 index b04aec1..0000000 --- a/t/ansi-test/hash-tables/sxhash.lsp +++ /dev/null @@ -1,288 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Nov 28 21:18:12 2003 -;;;; Contains: Tests of SXHASH - - - -(deftest sxhash.1 - (check-predicate #'(lambda (x) (typep (sxhash x) '(and unsigned-byte fixnum)))) - nil) - -(deftest sxhash.2 - (loop for i from 0 below 256 - for c = (code-char i) - when (and c - (not (= (sxhash (string c)) - (sxhash (string c))))) - collect c) - nil) - -(deftest sxhash.3 - (=t (sxhash "") (sxhash (copy-seq ""))) - t) - -(deftest sxhash.4 - (loop for bv1 in '(#* #*0 #*1 #*01 #*00 #*10 #*11 - #*1100101101100 #*110010101011001011010000111001011) - for bv2 = (copy-seq bv1) - for sx1 = (sxhash bv1) - for sx2 = (sxhash bv2) - always (and (not (eq bv1 bv2)) - (equal bv1 bv2) - (typep sx1 '(and unsigned-byte fixnum)) - (typep sx2 '(and unsigned-byte fixnum)) - (= sx1 sx2))) - t) - -(deftest sxhash.5 - (let ((s1 "abcd") - (s2 (make-array 10 :element-type 'character - :initial-contents "abcdefghij" - :fill-pointer 4))) - (and (equalt s1 s2) - (=t (sxhash s1) (sxhash s2)))) - t) - -(deftest sxhash.6 - (let ((s1 #*01101) - (s2 (make-array 10 :element-type 'bit - :initial-contents #*0110111101 - :fill-pointer 5))) - (and (equalt s1 s2) - (=t (sxhash s1) (sxhash s2)))) - t) - -(deftest sxhash.7 - (let* ((a (make-array 10 :initial-element nil)) - (sx1 (sxhash a))) - (setf (aref a 4) 'x) - (let ((sx2 (sxhash a))) - (and (typep sx1 '(and unsigned-byte fixnum)) - (eqlt sx1 sx2)))) - t) - -(deftest sxhash.8 - :notes (:nil-vectors-are-strings) - (eqlt (sxhash (make-array 0 :element-type nil)) - (sxhash "")) - t) - -(deftest sxhash.9 - (let ((s1 (make-array 5 :element-type 'base-char :initial-contents "abcde")) - (s2 (copy-seq "abcde"))) - (eqlt (sxhash s1) (sxhash s2))) - t) - -(deftest sxhash.10 - (let ((s1 "abcd") - (s2 (make-array 10 :element-type 'base-char - :initial-contents "abcdefghij" - :fill-pointer 4))) - (and (equalt s1 s2) - (=t (sxhash s1) (sxhash s2)))) - t) - -(deftest sxhash.11 - (let* ((x (cons 'a 'b)) - (sx1 (sxhash x)) - (sx2 (sxhash '(a . b)))) - (setf (car x) 'c) - (let* ((sx3 (sxhash x)) - (sx4 (sxhash '(c . b)))) - (and (=t sx1 sx2) - (=t sx3 sx4)))) - t) - -(deftest sxhash.12 - (let ((x (1+ most-positive-fixnum)) - (y (1+ most-positive-fixnum))) - (=t (sxhash x) (sxhash y))) - t) - -(deftest sxhash.13 - (let ((sx1 (sxhash (make-symbol "FOO"))) - (sx2 (sxhash (make-symbol "FOO")))) - (and (typep sx1 '(and unsigned-byte fixnum)) - (eqlt sx1 sx2))) - t) - -;; (deftest sxhash.14 -;; (let ((sx1 (sxhash :foo)) -;; (sx2 (sxhash '#:foo))) -;; (and (typep sx1 '(and unsigned-byte fixnum)) -;; (eqlt sx1 sx2))) -;; t) - -(deftest sxhash.15 - (let* ((package-name - (loop for i from 0 - for name = (format nil "PACKAGE-~A" i) - for package = (find-package name) - unless package do (return name))) - (sx1 - (let* ((package (make-package package-name :nicknames nil :use nil)) - (symbol (intern "FOO" package))) - (prog1 - (sxhash symbol) - (delete-package package)))) - (sx2 - (let* ((package (make-package package-name :nicknames nil :use nil)) - (symbol (intern "FOO" package))) - (prog1 - (sxhash symbol) - (delete-package package))))) - (assert (typep sx1 '(and unsigned-byte fixnum))) - (if (= sx1 sx2) :good (list sx1 sx2))) - :good) - -(deftest sxhash.16 - (let ((c1 (list 'a)) - (c2 (list 'a))) - (setf (cdr c1) c1) - (setf (cdr c2) c2) - (let ((sx1 (sxhash c1)) - (sx2 (sxhash c2))) - (or (eqlt sx1 sx2) (list sx1 sx2)))) - t) - -;;; Since similarity of numbers is 'same type and same mathematical value', -;;; and since sxhash must produce the same value for similar numeric arguments, -;;; (sxhash 0.0) and (sxhash -0.0) must be eql for all float types. -;;; This may be a spec bug, so I've added a note. - -(deftest sxhash.17 - :notes (:negative-zero-is-similar-to-positive-zero) - (loop for c1 in '(0.0s0 0.0f0 0.0d0 0.0l0) - for c2 in '(-0.0s0 -0.0f0 -0.0d0 -0.0l0) - for t1 = (type-of c1) - for t2 = (type-of c2) - for sx1 = (sxhash c1) - for sx2 = (sxhash c2) - unless (or (not (subtypep t1 t2)) - (not (subtypep t2 t1)) - (eql sx1 sx2)) - collect (list c1 c2 sx1 sx2)) - nil) - -(deftest sxhash.18 - :notes (:negative-zero-is-similar-to-positive-zero) - (loop for r1 in '(0.0s0 0.0f0 0.0d0 0.0l0) - for c1 = (complex r1) - for r2 in '(-0.0s0 -0.0f0 -0.0d0 -0.0l0) - for c2 = (complex r2) - for t1 = (type-of c1) - for t2 = (type-of c2) - for sx1 = (sxhash c1) - for sx2 = (sxhash c2) - unless (or (not (subtypep t1 t2)) - (not (subtypep t2 t1)) - (eql sx1 sx2)) - collect (list c1 c2 sx1 sx2)) - nil) - -(deftest sxhash.19 - :notes (:negative-zero-is-similar-to-positive-zero) - (loop for r1 in '(0.0s0 0.0f0 0.0d0 0.0l0) - for c1 = (complex 0 r1) - for r2 in '(-0.0s0 -0.0f0 -0.0d0 -0.0l0) - for c2 = (complex 0 r2) - for t1 = (type-of c1) - for t2 = (type-of c2) - for sx1 = (sxhash c1) - for sx2 = (sxhash c2) - unless (or (not (subtypep t1 t2)) - (not (subtypep t2 t1)) - (eql sx1 sx2)) - collect (list c1 c2 sx1 sx2)) - nil) - -;;; Similar pathnames have the same hash -(deftest sxhash.20 - (let* ((pathspec "sxhash.lsp") - (sx1 (sxhash (pathname (copy-seq pathspec)))) - (sx2 (sxhash (pathname (copy-seq pathspec))))) - (if (and (typep sx1 '(and fixnum unsigned-byte)) - (eql sx1 sx2)) - :good - (list sx1 sx2))) - :good) - -;;; Similarity for strings -(deftest sxhash.21 - (let* ((s1 "abc") - (s2 (make-array '(3) :element-type 'character - :initial-contents s1)) - (s3 (make-array '(3) :element-type 'base-char - :initial-contents s1)) - (s4 (make-array '(3) :element-type 'standard-char - :initial-contents s1)) - (s5 (make-array '(3) :element-type 'character - :adjustable t - :initial-contents "abc")) - (s6 (make-array '(5) :element-type 'character - :fill-pointer 3 - :initial-contents "abcde")) - (s7 (make-array '(3) :element-type 'character - :displaced-to s2 - :displaced-index-offset 0)) - (s8 (make-array '(3) :element-type 'character - :displaced-to (make-array '(7) :element-type 'character - :initial-contents "xxabcyy") - :displaced-index-offset 2)) - (strings (list s1 s2 s3 s4 s5 s6 s7 s8)) - (hashes (mapcar #'sxhash strings))) - (if (and (every #'(lambda (h) (typep h '(and unsigned-byte fixnum))) hashes) - (not (position (car hashes) hashes :test #'/=))) - :good - hashes)) - :good) - -;;; Similarity for bit vectors -(deftest sxhash.22 - (let* ((bv1 #*010) - (bv2 (make-array '(3) :element-type 'bit - :initial-contents bv1)) - (bv5 (make-array '(3) :element-type 'bit - :adjustable t - :initial-contents bv1)) - (bv6 (make-array '(5) :element-type 'bit - :fill-pointer 3 - :initial-contents #*01010)) - (bv7 (make-array '(3) :element-type 'bit - :displaced-to bv2 - :displaced-index-offset 0)) - (bv8 (make-array '(3) :element-type 'bit - :displaced-to (make-array '(7) :element-type 'bit - :initial-contents #*1101001) - :displaced-index-offset 2)) - (bit-vectors (list bv1 bv2 bv5 bv6 bv7 bv8)) - (hashes (mapcar #'sxhash bit-vectors))) - (if (and (every #'(lambda (h) (typep h '(and unsigned-byte fixnum))) hashes) - (not (position (car hashes) hashes :test #'/=))) - :good - hashes)) - :good) - -;;; The hash of a symbol does not change when its package changes -(deftest sxhash.23 - (progn - (safely-delete-package "A") - (defpackage "A" (:use)) - (let* ((pkg (find-package "A")) - (sym (intern "FOO" pkg)) - (hash (sxhash sym))) - (unintern sym pkg) - (let ((hash2 (sxhash sym))) - (if (eql hash hash2) nil (list hash hash2))))) - nil) - -;;; Error cases - -(deftest sxhash.error.1 - (signals-error (sxhash) program-error) - t) - -(deftest sxhash.error.2 - (signals-error (sxhash nil nil) program-error) - t) diff --git a/t/ansi-test/hash-tables/with-hash-table-iterator.lsp b/t/ansi-test/hash-tables/with-hash-table-iterator.lsp deleted file mode 100644 index f2f4b49..0000000 --- a/t/ansi-test/hash-tables/with-hash-table-iterator.lsp +++ /dev/null @@ -1,158 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Nov 28 20:08:43 2003 -;;;; Contains: Tests of WITH-HASH-TABLE-ITERATOR - - - -(deftest with-hash-table-iterator.1 - (with-hash-table-iterator (x (make-hash-table))) - nil) - -(deftest with-hash-table-iterator.2 - (with-hash-table-iterator (x (make-hash-table)) (values))) - -(deftest with-hash-table-iterator.3 - (with-hash-table-iterator (x (make-hash-table)) (values 'a 'b 'c 'd)) - a b c d) - -(deftest with-hash-table-iterator.4 - (with-hash-table-iterator - (%x (make-hash-table)) - (%x)) - nil) - -(deftest with-hash-table-iterator.5 - (let ((table (make-hash-table))) - (setf (gethash 'a table) 'b) - (with-hash-table-iterator - (%x table) - (multiple-value-bind (success-p key val) - (%x) - (values (notnot success-p) key val)))) - t a b) - -(deftest with-hash-table-iterator.6 - (let ((table (make-hash-table))) - (setf (gethash 'a table) 'b) - (with-hash-table-iterator - (%x table) - (length (multiple-value-list (%x))))) - 3) - -(deftest with-hash-table-iterator.7 - (let ((keys '("a" "b" "c" "d" "e"))) - (loop for test in '(eq eql equal equalp) - for test-fn of-type function = (symbol-function test) - collect - (let ((table (make-hash-table :test test))) - (loop for k in keys - for i from 0 - do (setf (gethash k table) i)) - (let ((count 0) (found-keys)) - (with-hash-table-iterator - (%x table) - (block done - (loop - (multiple-value-bind (success key val) - (%x) - (unless success (return-from done nil)) - (incf count) - (push key found-keys) - (assert (= val (position key keys :test test-fn)))))) - (and (= count (length keys)) - (every test-fn - (sort (remove-duplicates found-keys :test test) - #'string<) - keys) - t)))))) - (t t t t)) - -(deftest with-hash-table-iterator.8 - (with-hash-table-iterator - (%x (make-hash-table)) - (declare (optimize))) - nil) - -(deftest with-hash-table-iterator.8a - (with-hash-table-iterator - (%x (make-hash-table)) - (declare (optimize)) - (declare (optimize))) - nil) - -(deftest with-hash-table-iterator.9 - (with-hash-table-iterator - (%x (make-hash-table)) - (macrolet - ((expand-%x - (&environment env) - (let ((expanded-form (macroexpand '(%x) env))) - (if (equal expanded-form '(%x)) nil t)))) - (expand-%x))) - t) - -(deftest with-hash-table-iterator.10 - (let ((table (make-hash-table))) - (loop for key from 1 to 100 - for val from 101 to 200 - do (setf (gethash key table) val)) - (let ((pairs nil)) - (with-hash-table-iterator - (%x table) - (loop - (multiple-value-bind (success key val) - (%x) - (unless success (return nil)) - (remhash key table) - (push (cons key val) pairs)))) - (assert (eql (length pairs) 100)) - (setq pairs (sort pairs #'(lambda (p1 p2) (< (car p1) (car p2))))) - (values - (hash-table-count table) - (loop - for (key . val) in pairs - for expected-key from 1 - for expected-val from 101 - always (and (eql key expected-key) - (eql val expected-val)))))) - 0 t) - -(deftest with-hash-table-iterator.11 - (let ((table (make-hash-table))) - (loop for key from 1 to 100 - for val from 101 to 200 - do (setf (gethash key table) val)) - (let ((pairs nil)) - (with-hash-table-iterator - (%x table) - (loop - (multiple-value-bind (success key val) - (%x) - (unless success (return nil)) - (setf (gethash key table) (+ 1000 val)) - (push (cons key val) pairs)))) - (assert (eql (length pairs) 100)) - (setq pairs (sort pairs #'(lambda (p1 p2) (< (car p1) (car p2))))) - (values - (hash-table-count table) - (loop - for (key . val) in pairs - for expected-key from 1 - for expected-val from 101 - always (and (eql key expected-key) - (eql val expected-val) - (eql (gethash key table) (+ 1000 val)) - ))))) - 100 t) - -;;; Free declaration scope - -(deftest with-hash-table-iterator.12 - (block done - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) - (with-hash-table-iterator (m (return-from done x)) - (declare (special x)))))) - :good) diff --git a/t/ansi-test/iteration/do.lsp b/t/ansi-test/iteration/do.lsp deleted file mode 100644 index eabf5c6..0000000 --- a/t/ansi-test/iteration/do.lsp +++ /dev/null @@ -1,204 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Jan 8 07:25:18 2005 -;;;; Contains: Tests of DO - - - - -(deftest do.1 - (do ((i 0 (1+ i))) - ((>= i 10) i)) - 10) - -(deftest do.2 - (do ((i 0 (1+ j)) - (j 0 (1+ i))) - ((>= i 10) (+ i j))) - 20) - -(deftest do.3 - (let ((x nil)) - (do ((i 0 (1+ i))) - ((>= i 10) x) - (push i x))) - (9 8 7 6 5 4 3 2 1 0)) - -(deftest do.4 - (let ((x nil)) - (do ((i 0 (1+ i))) - ((>= i 10) x) - (declare (fixnum i)) - (push i x))) - (9 8 7 6 5 4 3 2 1 0)) - -(deftest do.5 - (do ((i 0 (1+ i))) - (nil) - (when (> i 10) (return i))) - 11) - -;;; Zero iterations -(deftest do.6 - (do ((i 0 (+ i 10))) - ((> i -1) i) - (return 'bad)) - 0) - -;;; Tests of go tags -(deftest do.7 - (let ((x nil)) - (do ((i 0 (1+ i))) - ((>= i 10) x) - (go around) - small - (push 'a x) - (go done) - big - (push 'b x) - (go done) - around - (if (> i 4) (go big) (go small)) - done)) - (b b b b b a a a a a)) - -;;; No increment form -(deftest do.8 - (do ((i 0 (1+ i)) - (x nil)) - ((>= i 10) x) - (push 'a x)) - (a a a a a a a a a a)) - -;;; No do locals -(deftest do.9 - (let ((i 0)) - (do () - ((>= i 10) i) - (incf i))) - 10) - -;;; Return of no values -(deftest do.10 - (do ((i 0 (1+ i))) - ((> i 10) (values)))) - -;;; Return of two values -(deftest do.11 - (do ((i 0 (1+ i))) - ((> i 10) (values i (1+ i)))) - 11 12) - -;;; The results* list is an implicit progn -(deftest do.12 - (do ((i 0 (1+ i))) - ((> i 10) (incf i) (incf i) i)) - 13) - -(deftest do.13 - (do ((i 0 (1+ i))) - ((> i 10))) - nil) - -;; Special var -(deftest do.14 - (let ((x 0)) - (flet ((%f () (locally (declare (special i)) - (incf x i)))) - (do ((i 0 (1+ i))) - ((>= i 10) x) - (declare (special i)) - (%f)))) - 45) - -;;; Confirm that the variables in succesive iterations are -;;; identical -(deftest do.15 - (mapcar #'funcall - (let ((x nil)) - (do ((i 0 (1+ i))) - ((= i 5) x) - (push #'(lambda () i) x)))) - (5 5 5 5 5)) - -;;; Scope of free declarations - -(deftest do.16 - (block done - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) - (do ((i (return-from done x) 0)) - (t nil) - (declare (special x)))))) - :good) - -(deftest do.17 - (block done - (let ((x :good)) - (declare (special x)) - (let ((x :bad)) - (do ((i 0 (return-from done x))) - (nil nil) - (declare (special x)))))) - :good) - -(deftest do.18 - (block done - (let ((x :good)) - (declare (special x)) - (let ((x :bad)) - (do ((i 0 0)) - ((return-from done x) nil) - (declare (special x)))))) - :good) - -(deftest do.19 - (let ((x :good)) - (declare (special x)) - (let ((x :bad)) - (do () (t x) - (declare (special x))))) - :good) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest do.20 - (let ((result nil)) - (macrolet - ((%m (z) z)) - (do ((x (expand-in-current-env (%m 0)) (+ x 2))) - ((> x 10) result) - (push x result)))) - (10 8 6 4 2 0)) - -(deftest do.21 - (let ((result nil)) - (macrolet - ((%m (z) z)) - (do ((x 0 (expand-in-current-env (%m (+ x 2))))) - ((> x 10) result) - (push x result)))) - (10 8 6 4 2 0)) - -(deftest do.22 - (let ((result nil)) - (macrolet - ((%m (z) z)) - (do ((x 0 (+ x 2))) - ((expand-in-current-env (%m (> x 10))) result) - (push x result)))) - (10 8 6 4 2 0)) - -(deftest do.23 - (let ((result nil)) - (macrolet - ((%m (z) z)) - (do ((x 0 (+ x 2))) - ((> x 10) (expand-in-current-env (%m result))) - (push x result)))) - (10 8 6 4 2 0)) - -(def-macro-test do.error.1 - (do ((i 0 (1+ i))) ((= i 5) 'a))) diff --git a/t/ansi-test/iteration/dolist.lsp b/t/ansi-test/iteration/dolist.lsp deleted file mode 100644 index 733d2a4..0000000 --- a/t/ansi-test/iteration/dolist.lsp +++ /dev/null @@ -1,157 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Jan 8 07:26:48 2005 -;;;; Contains: Tests of DOLIST - - - -(deftest dolist.1 - (let ((count 0)) - (dolist (x '(a b nil d)) (incf count)) - count) - 4) - -(deftest dolist.2 - (let ((count 0)) - (dolist (x '(a nil c d) count) (incf count))) - 4) - -(deftest dolist.3 - (let ((count 0)) - (dolist (x nil count) (incf count))) - 0) - -(deftest dolist.4 - (let ((y nil)) - (flet ((%f () (locally (declare (special e)) - (push e y)))) - (dolist (e '(a b c) (reverse y)) - (declare (special e)) - (%f)))) - (a b c)) - -;;; Tests that it's a tagbody -(deftest dolist.5 - (let ((even nil) - (odd nil)) - (dolist (i '(1 2 3 4 5 6 7 8) (values (reverse even) - (reverse odd))) - (when (evenp i) (go even)) - (push i odd) - (go done) - even - (push i even) - done)) - (2 4 6 8) - (1 3 5 7)) - -;;; Test that bindings are not normally special -(deftest dolist.6 - (let ((i 0) (y nil)) - (declare (special i)) - (flet ((%f () i)) - (dolist (i '(1 2 3 4)) - (push (%f) y))) - y) - (0 0 0 0)) - -;;; Test multiple return values - -(deftest dolist.7 - (dolist (x '(a b) (values)))) - -(deftest dolist.8 - (let ((count 0)) - (dolist (x '(a b c) (values count count)) - (incf count))) - 3 3) - -;;; Test ability to return, and the scope of the implicit -;;; nil block -(deftest dolist.9 - (block nil - (eqlt (dolist (x '(a b c)) - (return 1)) - 1)) - t) - -(deftest dolist.10 - (block nil - (eqlt (dolist (x '(a b c)) - (return-from nil 1)) - 1)) - t) - -(deftest dolist.11 - (block nil - (dolist (x (return 1))) - 2) - 2) - -(deftest dolist.12 - (block nil - (dolist (x '(a b) (return 1))) - 2) - 2) - -;;; Check that binding of element var is visible in the result form -(deftest dolist.13 - (dolist (e '(a b c) e)) - nil) - -(deftest dolist.14 - (let ((e 1)) - (dolist (e '(a b c) (setf e 2))) - e) - 1) - -(deftest dolist.15 - (let ((x nil)) - (dolist (e '(a b c d e f)) - (push e x) - (when (eq e 'c) (return x)))) - (c b a)) - -;;; Scope of free declarations - -(deftest dolist.16 - (block done - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) - (dolist (e (return-from done x)) - (declare (special x)))))) - :good) - -(deftest dolist.17 - (let ((x :good)) - (declare (special x)) - (let ((x :bad)) - (dolist (e nil x) - (declare (special x))))) - :good) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest dolist.18 - (let ((result nil)) - (macrolet - ((%m (z) z)) - (dolist (x (expand-in-current-env (%m '(a b c))) result) - (push x result)))) - (c b a)) - -(deftest dolist.19 - (let ((result nil)) - (macrolet - ((%m (z) z)) - (dolist (x '(a b c) (expand-in-current-env (%m result))) - (push x result)))) - (c b a)) - -;;; Error tests - -(def-macro-test dolist.error.1 - (dolist (x nil))) - diff --git a/t/ansi-test/iteration/dostar.lsp b/t/ansi-test/iteration/dostar.lsp deleted file mode 100644 index 9681ba8..0000000 --- a/t/ansi-test/iteration/dostar.lsp +++ /dev/null @@ -1,204 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Jan 8 07:26:22 2005 -;;;; Contains: Tests of DO* - - - - -(deftest do*.1 - (do* ((i 0 (1+ i))) - ((>= i 10) i)) - 10) - -(deftest do*.2 - (do* ((i 0 (1+ j)) - (j 0 (1+ i))) - ((>= i 10) (+ i j))) - 23) - -(deftest do*.3 - (let ((x nil)) - (do* ((i 0 (1+ i))) - ((>= i 10) x) - (push i x))) - (9 8 7 6 5 4 3 2 1 0)) - -(deftest do*.4 - (let ((x nil)) - (do* ((i 0 (1+ i))) - ((>= i 10) x) - (declare (fixnum i)) - (push i x))) - (9 8 7 6 5 4 3 2 1 0)) - -(deftest do*.5 - (do* ((i 0 (1+ i))) - (nil) - (when (> i 10) (return i))) - 11) - -;;; Zero iterations -(deftest do*.6 - (do* ((i 0 (+ i 10))) - ((> i -1) i) - (return 'bad)) - 0) - -;;; Tests of go tags -(deftest do*.7 - (let ((x nil)) - (do* ((i 0 (1+ i))) - ((>= i 10) x) - (go around) - small - (push 'a x) - (go done) - big - (push 'b x) - (go done) - around - (if (> i 4) (go big) (go small)) - done)) - (b b b b b a a a a a)) - -;;; No increment form -(deftest do*.8 - (do* ((i 0 (1+ i)) - (x nil)) - ((>= i 10) x) - (push 'a x)) - (a a a a a a a a a a)) - -;;; No do* locals -(deftest do*.9 - (let ((i 0)) - (do* () - ((>= i 10) i) - (incf i))) - 10) - -;;; Return of no values -(deftest do*.10 - (do* ((i 0 (1+ i))) - ((> i 10) (values)))) - -;;; Return of two values -(deftest do*.11 - (do* ((i 0 (1+ i))) - ((> i 10) (values i (1+ i)))) - 11 12) - -;;; The results* list is an implicit progn -(deftest do*.12 - (do* ((i 0 (1+ i))) - ((> i 10) (incf i) (incf i) i)) - 13) - -(deftest do*.13 - (do* ((i 0 (1+ i))) - ((> i 10))) - nil) - -;; Special var -(deftest do*.14 - (let ((x 0)) - (flet ((%f () (locally (declare (special i)) - (incf x i)))) - (do* ((i 0 (1+ i))) - ((>= i 10) x) - (declare (special i)) - (%f)))) - 45) - -;;; Confirm that the variables in succesive iterations are -;;; identical -(deftest do*.15 - (mapcar #'funcall - (let ((x nil)) - (do* ((i 0 (1+ i))) - ((= i 5) x) - (push #'(lambda () i) x)))) - (5 5 5 5 5)) - -;;; Scope of free declarations - -(deftest do*.16 - (block done - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) - (do* ((i (return-from done x) 0)) - (t nil) - (declare (special x)))))) - :good) - -(deftest do*.17 - (block done - (let ((x :good)) - (declare (special x)) - (let ((x :bad)) - (do* ((i 0 (return-from done x))) - (nil nil) - (declare (special x)))))) - :good) - -(deftest do*.18 - (block done - (let ((x :good)) - (declare (special x)) - (let ((x :bad)) - (do* ((i 0 0)) - ((return-from done x) nil) - (declare (special x)))))) - :good) - -(deftest do*.19 - (let ((x :good)) - (declare (special x)) - (let ((x :bad)) - (do* () (t x) - (declare (special x))))) - :good) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest do*.20 - (let ((result 0)) - (macrolet - ((%m (z) z)) - (do* ((x (expand-in-current-env (%m 1)) (1+ x))) - ((> x 10) result) - (incf result x)))) - 55) - -(deftest do*.21 - (let ((result 0)) - (macrolet - ((%m (z) z)) - (do* ((x 1 (expand-in-current-env (%m (1+ x))))) - ((> x 10) result) - (incf result x)))) - 55) - -(deftest do*.22 - (let ((result 0)) - (macrolet - ((%m (z) z)) - (do* ((x 1 (1+ x))) - ((expand-in-current-env (%m (> x 10))) result) - (incf result x)))) - 55) - -(deftest do*.23 - (let ((result 0)) - (macrolet - ((%m (z) z)) - (do* ((x 1 (1+ x))) - ((> x 10) (expand-in-current-env (%m result))) - (incf result x)))) - 55) - -(def-macro-test do*.error.1 - (do* ((i 0 (1+ i))) ((= i 5) 'a))) diff --git a/t/ansi-test/iteration/dotimes.lsp b/t/ansi-test/iteration/dotimes.lsp deleted file mode 100644 index d689083..0000000 --- a/t/ansi-test/iteration/dotimes.lsp +++ /dev/null @@ -1,224 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Jan 8 07:27:15 2005 -;;;; Contains: Tests of DOTIMES - - - - -(deftest dotimes.1 - (dotimes (i 10)) - nil) - -(deftest dotimes.2 - (dotimes (i 10 'a)) - a) - -(deftest dotimes.3 - (dotimes (i 10 (values)))) - -(deftest dotimes.3a - (dotimes (i 10 (values 'a 'b 'c))) - a b c) - -(deftest dotimes.4 - (let ((x nil)) - (dotimes (i 5 x) (push i x))) - (4 3 2 1 0)) - -(deftest dotimes.5 - (let ((x nil)) - (dotimes (i 0 x) (push i x))) - nil) - -(deftest dotimes.6 - (block done - (dotimes (i -1 'good) - (return-from done 'bad))) - good) - -(deftest dotimes.7 - (block done - (dotimes (i (1- most-negative-fixnum) 'good) - (return-from done 'bad))) - good) - -;;; Implicit nil block has the right scope -(deftest dotimes.8 - (block nil - (dotimes (i (return 1))) - 2) - 2) - -(deftest dotimes.9 - (block nil - (dotimes (i 10 (return 1))) - 2) - 2) - -(deftest dotimes.10 - (block nil - (dotimes (i 10) (return 1)) - 2) - 2) - -(deftest dotimes.11 - (let ((x nil)) - (dotimes (i 10) - (push i x) - (when (= i 5) (return x)))) - (5 4 3 2 1 0)) - -;;; Check there's an implicit tagbody -(deftest dotimes.12 - (let ((even nil) - (odd nil)) - (dotimes (i 8 (values (reverse even) - (reverse odd))) - (when (evenp i) (go even)) - (push i odd) - (go done) - even - (push i even) - done)) - (0 2 4 6) - (1 3 5 7)) - -;;; Check that at the time the result form is evaluated, -;;; the index variable is set to the number of times the loop -;;; was executed. - -(deftest dotimes.13 - (let ((i 100)) - (dotimes (i 10 i))) - 10) - -(deftest dotimes.14 - (let ((i 100)) - (dotimes (i 0 i))) - 0) - -(deftest dotimes.15 - (let ((i 100)) - (dotimes (i -1 i))) - 0) - -;;; Check that the variable is not bound in the count form -(deftest dotimes.16 - (let ((i nil)) - (values - i - (dotimes (i (progn (setf i 'a) 10) i)) - i)) - nil 10 a) - -;;; Check special variable decls -(deftest dotimes.17 - (let ((i 0) (y nil)) - (declare (special i)) - (flet ((%f () i)) - (dotimes (i 4) - (push (%f) y))) - y) - (0 0 0 0)) - -(deftest dotimes.17a - (let ((i 0) (y nil) (bound 4)) - (declare (special i)) - (flet ((%f () i)) - (dotimes (i bound) - (push (%f) y))) - y) - (0 0 0 0)) - -(deftest dotimes.18 - (let ((i 0) (y nil)) - (declare (special i)) - (flet ((%f () i)) - (dotimes (i 4) - (declare (special i)) - (push (%f) y))) - y) - (3 2 1 0)) - -(deftest dotimes.18a - (let ((i 0) (y nil) (bound 4)) - (declare (special i)) - (flet ((%f () i)) - (dotimes (i bound) - (declare (special i)) - (push (%f) y))) - y) - (3 2 1 0)) - -(deftest dotimes.19 - (dotimes (i 100 i)) - 100) - -(deftest dotimes.20 - (dotimes (i -100 i)) - 0) - -(deftest dotimes.21 - (let ((x 0)) - (dotimes (i (1- most-negative-fixnum) (values i x)) - (declare (type fixnum i)) - (incf x))) - 0 0) - -;;; Scope of free declarations - -(deftest dotimes.22 - (block done - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) - (dotimes (i (return-from done x)) - (declare (special x)))))) - :good) - -(deftest dotimes.23 - (let ((x :good)) - (declare (special x)) - (let ((x :bad)) - (dotimes (i 10 x) - (declare (special x))))) - :good) - -(deftest dotimes.23a - (let ((x :good) (bound 10)) - (declare (special x)) - (let ((x :bad)) - (dotimes (i bound x) - (declare (special x))))) - :good) - -(deftest dotimes.24 - (let ((bound 4) (j 0)) - (values - (dotimes (i bound) - (incf j) (decf bound)) - bound j)) - nil 0 4) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest dotimes.25 - (macrolet - ((%m (z) z)) - (let (result) - (dotimes (i (expand-in-current-env (%m 4)) result) - (push i result)))) - (3 2 1 0)) - -(deftest dotimes.26 - (macrolet - ((%m (z) z)) - (let (result) - (dotimes (i 4 (expand-in-current-env (%m result))) - (push i result)))) - (3 2 1 0)) - -(def-macro-test dotimes.error.1 - (dotimes (i 10))) diff --git a/t/ansi-test/iteration/load.lsp b/t/ansi-test/iteration/load.lsp deleted file mode 100644 index fa303c1..0000000 --- a/t/ansi-test/iteration/load.lsp +++ /dev/null @@ -1,30 +0,0 @@ -;;; Tests of iteration forms - -(in-package #:cl-test) - -(let ((*default-pathname-defaults* - (make-pathname - :directory (pathname-directory *load-pathname*)))) - (load "do.lsp") - (load "dostar.lsp") - (load "dolist.lsp") - (load "dotimes.lsp") - (load "loop.lsp") - (load "loop1.lsp") - (load "loop2.lsp") - (load "loop3.lsp") - (load "loop4.lsp") - (load "loop5.lsp") - (load "loop6.lsp") - (load "loop7.lsp") - (load "loop8.lsp") - (load "loop9.lsp") - (load "loop10.lsp") - (load "loop11.lsp") - (load "loop12.lsp") - (load "loop13.lsp") - (load "loop14.lsp") - (load "loop15.lsp") - (load "loop16.lsp") - (load "loop17.lsp") -) diff --git a/t/ansi-test/iteration/loop.lsp b/t/ansi-test/iteration/loop.lsp deleted file mode 100644 index 0f604a6..0000000 --- a/t/ansi-test/iteration/loop.lsp +++ /dev/null @@ -1,83 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Oct 25 18:48:59 2002 -;;;; Contains: Tests of LOOP - - - -;;; Simple loops -(deftest sloop.1 - (loop (return 'a)) - a) - -(deftest sloop.2 - (loop (return (values)))) - -(deftest sloop.3 - (loop (return (values 'a 'b 'c 'd))) - a b c d) - -(deftest sloop.4 - (block nil - (loop (return 'a)) - 'b) - b) - -(deftest sloop.5 - (let ((i 0) (x nil)) - (loop - (when (>= i 4) (return x)) - (incf i) - (push 'a x))) - (a a a a)) - -(deftest sloop.6 - (let ((i 0) (x nil)) - (block foo - (tagbody - (loop - (when (>= i 4) (go a)) - (incf i) - (push 'a x)) - a - (return-from foo x)))) - (a a a a)) - -(deftest sloop.7 - (catch 'foo - (let ((i 0) (x nil)) - (loop - (when (>= i 4) (throw 'foo x)) - (incf i) - (push 'a x)))) - (a a a a)) - -;;; Loop errors - -(def-macro-test loop.error.1 (loop)) - -(deftest loop-finish.error.1 - (block done - (loop - for i from 1 to 10 - do (macrolet - ((%m (&environment env) - (let ((mfn (macro-function 'loop-finish env))) - (cond - ((not mfn) '(return-from done :fail1)) - ((not (eval `(signals-error (funcall ,mfn) - program-error))) - '(return-from done :fail2)) - ((not (eval `(signals-error (funcall ,mfn - '(loop-finish)) - program-error))) - '(return-from done :fail3)) - - ((not (eval `(signals-error (funcall ,mfn - '(loop-finish) - nil nil) - program-error))) - '(return-from done :fail4)) - (t '(return-from done :good)))))) - (%m)))) - :good) diff --git a/t/ansi-test/iteration/loop1.lsp b/t/ansi-test/iteration/loop1.lsp deleted file mode 100644 index 26457fe..0000000 --- a/t/ansi-test/iteration/loop1.lsp +++ /dev/null @@ -1,359 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Oct 25 19:07:19 2002 -;;;; Contains: Tests of extended loop, part 1 - - - -;;; Tests of variable initialization and stepping clauses - -;;; for-as-arithmetic - -(deftest loop.1.1 - (loop for x from 1 to 10 collect x) - (1 2 3 4 5 6 7 8 9 10)) - -(deftest loop.1.2 - (loop for x from 6 downto 1 collect x) - (6 5 4 3 2 1)) - -(deftest loop.1.3 - (loop for x from 1 to 1 collect x) - (1)) - -(deftest loop.1.4 - (loop for x from 1 to 0 collect x) - nil) - -(deftest loop.1.5 - (loop for x to 5 collect x) - (0 1 2 3 4 5)) - -(deftest loop.1.6 - (loop for x downfrom 5 to 0 collect x) - (5 4 3 2 1 0)) - -(deftest loop.1.7 - (loop for x upfrom 1 to 5 collect x) - (1 2 3 4 5)) - -(deftest loop.1.8 - (loop for x from 1.0 to 5.0 count x) - 5) - -(deftest loop.1.9 - (loop for x from 1 to 9 by 2 collect x) - (1 3 5 7 9)) - -(deftest loop.1.10 - (loop for x from 1 to 10 by 2 collect x) - (1 3 5 7 9)) - -(deftest loop.1.11 - (loop for x to 10 from 1 collect x) - (1 2 3 4 5 6 7 8 9 10)) - -(deftest loop.1.12 - (loop for x to 10 by 2 from 1 collect x) - (1 3 5 7 9)) - -(deftest loop.1.13 - (loop for x by 2 to 10 from 1 collect x) - (1 3 5 7 9)) - -(deftest loop.1.14 - (loop for x by 2 to 10 collect x) - (0 2 4 6 8 10)) - -(deftest loop.1.15 - (loop for x to 10 by 2 collect x) - (0 2 4 6 8 10)) - -(deftest loop.1.16 - (let ((n 0)) - (loop for x from (incf n) to (+ n 5) collect x)) - (1 2 3 4 5 6)) - -(deftest loop.1.17 - (let ((n 0)) - (loop for x to (+ n 5) from (incf n) collect x)) - (1 2 3 4 5)) - -(deftest loop.1.18 - (let ((n 0)) - (loop for x from (incf n) to (+ n 9) by (incf n) collect x)) - (1 3 5 7 9)) - -(deftest loop.1.19 - (let ((n 0)) - (loop for x from (incf n) by (incf n) to (+ n 9) collect x)) - (1 3 5 7 9 11)) - -(deftest loop.1.20 - (let ((a 0) (b 5) (c 1)) - (loop for x from a to b by c - collect (progn (incf a) (incf b 2) (incf c 3) x))) - (0 1 2 3 4 5)) - -(deftest loop.1.21 - (loop for x from 0 to 5 by 1/2 collect x) - (0 1/2 1 3/2 2 5/2 3 7/2 4 9/2 5)) - -(deftest loop.1.22 - (loop for x from 1 below 5 collect x) - (1 2 3 4)) - -(deftest loop.1.23 - (loop for x from 1 below 5.01 collect x) - (1 2 3 4 5)) - -(deftest loop.1.24 - (loop for x below 5 from 2 collect x) - (2 3 4)) - -(deftest loop.1.25 - (loop for x from 10 above 4 collect x) - (10 9 8 7 6 5)) - -(deftest loop.1.26 - (loop for x from 14 above 6 by 2 collect x) - (14 12 10 8)) - -(deftest loop.1.27 - (loop for x above 6 from 14 by 2 collect x) - (14 12 10 8)) - -(deftest loop.1.28 - (loop for x downfrom 16 above 7 by 3 collect x) - (16 13 10)) - -(deftest loop.1.29 - (let (a b c (i 0)) - (values - (loop for x from (progn (setq a (incf i)) 0) - below (progn (setq b (incf i)) 9) - by (progn (setq c (incf i)) 2) - collect x) - a b c i)) - (0 2 4 6 8) - 1 2 3 3) - -(deftest loop.1.30 - (let (a b c (i 0)) - (values - (loop for x from (progn (setq a (incf i)) 0) - by (progn (setq c (incf i)) 2) - below (progn (setq b (incf i)) 9) - collect x) - a b c i)) - (0 2 4 6 8) - 1 3 2 3) - -(deftest loop.1.31 - (let (a b c (i 0)) - (values - (loop for x - below (progn (setq b (incf i)) 9) - by (progn (setq c (incf i)) 2) - from (progn (setq a (incf i)) 0) - collect x) - a b c i)) - (0 2 4 6 8) - 3 1 2 3) - -(deftest loop.1.32 - (let (a b c (i 0)) - (values - (loop for x - by (progn (setq c (incf i)) 2) - below (progn (setq b (incf i)) 9) - from (progn (setq a (incf i)) 0) - collect x) - a b c i)) - (0 2 4 6 8) - 3 2 1 3) - -(deftest loop.1.33 - (loop for x from 1 upto 5 collect x) - (1 2 3 4 5)) - -(deftest loop.1.34 - (loop for x from 1 to 4.0 collect x) - (1 2 3 4)) - -(deftest loop.1.35 - (loop for x below 5 collect x) - (0 1 2 3 4)) - -(deftest loop.1.36 - (loop for x below 20 by 3 collect x) - (0 3 6 9 12 15 18)) - -(deftest loop.1.37 - (loop for x by 3 below 20 collect x) - (0 3 6 9 12 15 18)) - -(deftest loop.1.38 - (loop for x of-type fixnum from 1 to 5 collect x) - (1 2 3 4 5)) - -;;; The following provides an example where an incorrect -;;; implementation will assign X an out-of-range value -;;; at the end. -(deftest loop.1.39 - (loop for x of-type (integer 1 5) from 1 to 5 collect x) - (1 2 3 4 5)) - -;;; Test that the index variable achieves the inclusive -;;; upper bound, but does not exceed it. -(deftest loop.1.40 - (loop for x from 1 to 5 do (progn) finally (return x)) - 5) - -;;; Test that the index variable acheives the exclusive -;;; upper bound, but does not exceed it. -(deftest loop.1.41 - (loop for x from 1 below 5 do (progn) finally (return x)) - 4) - -(deftest loop.1.42 - (loop for x from 10 downto 0 do (progn) finally (return x)) - 0) - -(deftest loop.1.43 - (loop for x from 10 above 0 do (progn) finally (return x)) - 1) - -;;; The arithmetic loop form says the types are numbers, not -;;; reals, so arguably they should work on complexes (which are -;;; numbers.) Comparing these for termination could be problematic, -;;; but a clause without termination should work just fine. - -(deftest loop.1.44 - (loop for i from 1 to 5 for c from #c(0 1) collect c) - (#c(0 1) #c(1 1) #c(2 1) #c(3 1) #c(4 1))) - -(deftest loop.1.45 - (loop for i from 1 to 5 for c from #c(0 1) by 2 collect c) - (#c(0 1) #c(2 1) #c(4 1) #c(6 1) #c(8 1))) - -(deftest loop.1.46 - (loop for i from 1 to 5 for c downfrom #c(5 1) collect c) - (#c(5 1) #c(4 1) #c(3 1) #c(2 1) #c(1 1))) - -(deftest loop.1.47 - (loop for i from 1 to 5 for c downfrom #c(10 1) by 2 collect c) - (#c(10 1) #c(8 1) #c(6 1) #c(4 1) #c(2 1))) - -(deftest loop.1.48 - (loop for i from 1 to 5 for c upfrom #c(0 1) collect c) - (#c(0 1) #c(1 1) #c(2 1) #c(3 1) #c(4 1))) - -(deftest loop.1.49 - (loop for i from 1 to 5 for c upfrom #c(0 1) by 2 collect c) - (#c(0 1) #c(2 1) #c(4 1) #c(6 1) #c(8 1))) - -;;; The variable in the loop for-as-arithmetic clause -;;; can be a d-var-spec, so 'NIL' should mean don't bind anything - -(deftest loop.1.50 - (let ((i 0)) - (loop for nil from 10 to 15 collect (incf i))) - (1 2 3 4 5 6)) - -(deftest loop.1.51 - (let ((i 0)) - (loop for nil from 10 below 15 collect (incf i))) - (1 2 3 4 5)) - -(deftest loop.1.52 - (loop for nil from 10 to 0 collect 'a) - nil) - -(deftest loop.1.53 - (let ((i 0)) - (loop for nil from 0 to 10 by 2 collect (incf i))) - (1 2 3 4 5 6)) - -(deftest loop.1.54 - (let ((i 0)) - (loop for nil from 1 to 4 - for nil from 1 to 10 collect (incf i))) - (1 2 3 4)) - -(deftest loop.1.55 - (let ((i 0)) - (loop for nil from 5 downto 0 collect (incf i))) - (1 2 3 4 5 6)) - -(deftest loop.1.56 - (let ((i 0)) - (loop for nil from 5 above 0 collect (incf i))) - (1 2 3 4 5)) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest loop.1.57 - (macrolet - ((%m (z) z)) - (loop for i from (expand-in-current-env (%m 1)) to 5 collect i)) - (1 2 3 4 5)) - -(deftest loop.1.58 - (macrolet - ((%m (z) z)) - (loop for i from 1 to (expand-in-current-env (%m 5)) collect i)) - (1 2 3 4 5)) - -(deftest loop.1.59 - (macrolet - ((%m (z) z)) - (loop for i from 1 to 5 by (expand-in-current-env (%m 2)) collect i)) - (1 3 5)) - -(deftest loop.1.60 - (macrolet - ((%m (z) z)) - (loop for i downfrom (expand-in-current-env (%m 10)) - to 3 - collect i)) - (10 9 8 7 6 5 4 3)) - -(deftest loop.1.61 - (macrolet - ((%m (z) z)) - (loop for i downfrom 10 - to (expand-in-current-env (%m 3)) - collect i)) - (10 9 8 7 6 5 4 3)) - -(deftest loop.1.62 - (macrolet - ((%m (z) z)) - (loop for i from (expand-in-current-env (%m 10)) - downto 3 - collect i)) - (10 9 8 7 6 5 4 3)) - -(deftest loop.1.63 - (macrolet - ((%m (z) z)) - (loop for i from 10 - downto (expand-in-current-env (%m 3)) - collect i)) - (10 9 8 7 6 5 4 3)) - -(deftest loop.1.64 - (macrolet - ((%m (z) z)) - (loop for i from (expand-in-current-env (%m 1)) below 5 collect i)) - (1 2 3 4)) - -(deftest loop.1.65 - (macrolet - ((%m (z) z)) - (loop for i from 1 below (expand-in-current-env (%m 5)) collect i)) - (1 2 3 4)) - - diff --git a/t/ansi-test/iteration/loop10.lsp b/t/ansi-test/iteration/loop10.lsp deleted file mode 100644 index 06dc369..0000000 --- a/t/ansi-test/iteration/loop10.lsp +++ /dev/null @@ -1,559 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Nov 16 09:07:02 2002 -;;;; Contains: Tests of LOOP numeric value accumulation clauses - - - -;; Tests of COUNT, COUNTING - -(deftest loop.10.1 - (loop for x from 1 to 10 count (< x 5)) - 4) - -(deftest loop.10.2 - (loop for x from 1 to 10 counting (< x 7)) - 6) - -(deftest loop.10.3 - (loop for x from 1 to 10 count (< x 5) fixnum) - 4) - -(deftest loop.10.4 - (loop for x from 1 to 10 count (< x 5) of-type integer) - 4) - -(deftest loop.10.5 - (let (z) - (values - (loop for x from 1 to 10 count (< x 5) into foo - finally (setq z foo)) - z)) - nil - 4) - -(deftest loop.10.6 - (let (z) - (values - (loop for x from 1 to 10 count (< x 5) into foo fixnum - finally (setq z foo)) - z)) - nil - 4) - -(deftest loop.10.7 - (let (z) - (values - (loop for x from 1 to 10 count (< x 5) into foo of-type (integer 0 100) - finally (setq z foo)) - z)) - nil - 4) - -(deftest loop.10.8 - (let (z) - (values - (loop for x from 1 to 10 count (< x 5) into foo float - finally (setq z foo)) - z)) - nil - 4.0) - -(deftest loop.10.9 - (signals-error - (loop with foo = 10 - for x in '(a b c) count x into foo - finally (return foo)) - program-error) - t) - -(deftest loop.10.10 - (signals-error - (loop with foo = 10 - for x in '(a b c) counting x into foo - finally (return foo)) - program-error) - t) - -(declaim (special *loop-count-var*)) - -(deftest loop.10.11 - (let ((*loop-count-var* 100)) - (values - (loop for x in '(a b c d) count x into *loop-count-var* - finally (return *loop-count-var*)) - *loop-count-var*)) - 4 100) - -(deftest loop.10.12 - (loop for x in '(a b nil d nil e) - count x into foo - collect foo) - (1 2 2 3 3 4)) - -(deftest loop.10.13 - (loop for x in '(a b nil d nil e) - counting x into foo - collect foo) - (1 2 2 3 3 4)) - -(deftest loop.10.14 - (loop for x in '(a b c) count (return 10)) - 10) - - -;;; Tests of MAXIMIZE, MAXIMIZING - -(deftest loop.10.20 - (loop for x in '(1 4 10 5 7 9) maximize x) - 10) - -(deftest loop.10.21 - (loop for x in '(1 4 10 5 7 9) maximizing x) - 10) - -(deftest loop.10.22 - (loop for x in '(1000000000000) maximizing x) - 1000000000000) - -(deftest loop.10.23 - (loop for x in '(-1000000000000) maximize x) - -1000000000000) - -(deftest loop.10.24 - (loop for x in '(1.0 2.0 3.0 -1.0) maximize x) - 3.0) - -(deftest loop.10.25 - (loop for x in '(8 20 5 3 24 1 19 4 20 3) maximize x fixnum) - 24) - -(deftest loop.10.26 - (loop for x in '(8 20 5 3 24 1 19 4 20 3) maximize x of-type integer) - 24) - -(deftest loop.10.27 - (loop for x in '(8 20 5 3 24 1 19 4 20 3) maximize x of-type rational) - 24) - -(deftest loop.10.28 - (loop for x in '(1 4 10 5 7 9) maximize x into foo finally (return foo)) - 10) - -(deftest loop.10.29 - (let (z) - (values - (loop for x in '(1 4 10 5 7 9) maximize x into foo finally (setq z foo)) - z)) - nil - 10) - -(deftest loop.10.30 - (loop for x in '(8 20 5 3 24 1 19 4 20 3) maximize x of-type real) - 24) - -(deftest loop.10.31 - (loop for x in '(0.08 0.20 0.05 0.03 0.24 0.01 0.19 0.04 0.20 0.03) maximize x of-type float) - 0.24) - -(deftest loop.10.32 - (loop for x in '(-1/8 -1/20 -1/5 -1/3 -1/24 -1/1 -1/19 -1/4 -1/20 -1/3) maximize x of-type rational) - -1/24) - -(deftest loop.10.33 - (loop for x in '(1 4 10 5 7 9) maximize x into foo fixnum finally (return foo)) - 10) - -(deftest loop.10.34 - (loop for x in '(1 4 10 5 7 9) maximize x into foo of-type integer finally (return foo)) - 10) - -(deftest loop.10.35 - (let ((foo 20)) - (values - (loop for x in '(3 5 8 3 7) maximize x into foo finally (return foo)) - foo)) - 8 20) - -(declaim (special *loop-max-var*)) - -(deftest loop.10.36 - (let ((*loop-max-var* 100)) - (values - (loop for x in '(1 10 4 8) maximize x into *loop-max-var* - finally (return *loop-max-var*)) - *loop-max-var*)) - 10 100) - -(deftest loop.10.37 - (signals-error - (loop with foo = 100 - for i from 1 to 10 maximize i into foo - finally (return foo)) - program-error) - t) - -(deftest loop.10.38 - (signals-error - (loop with foo = 100 - for i from 1 to 10 maximizing i into foo - finally (return foo)) - program-error) - t) - - -(deftest loop.10.39 - (loop for x in '(1 2 3) maximize (return 10)) - 10) - -;;; Tests of MINIMIZE, MINIMIZING - -(deftest loop.10.40 - (loop for x in '(4 10 1 5 7 9) minimize x) - 1) - -(deftest loop.10.41 - (loop for x in '(4 10 5 7 1 9) minimizing x) - 1) - -(deftest loop.10.42 - (loop for x in '(1000000000000) minimizing x) - 1000000000000) - -(deftest loop.10.43 - (loop for x in '(-1000000000000) minimize x) - -1000000000000) - -(deftest loop.10.44 - (loop for x in '(1.0 2.0 -1.0 3.0) minimize x) - -1.0) - -(deftest loop.10.45 - (loop for x in '(8 20 5 3 24 1 19 4 20 3) minimize x fixnum) - 1) - -(deftest loop.10.46 - (loop for x in '(8 20 5 3 24 1 19 4 20 3) minimize x of-type integer) - 1) - -(deftest loop.10.47 - (loop for x in '(8 20 5 3 24 1 19 4 20 3) minimize x of-type rational) - 1) - -(deftest loop.10.48 - (loop for x in '(1 4 10 5 7 9) minimize x into foo finally (return foo)) - 1) - -(deftest loop.10.49 - (let (z) - (values - (loop for x in '(4 1 10 1 5 7 9) minimize x into foo finally (setq z foo)) - z)) - nil - 1) - -(deftest loop.10.50 - (loop for x in '(8 20 5 3 24 1 19 4 20 3) minimize x of-type real) - 1) - -(deftest loop.10.51 - (loop for x in '(0.08 0.40 0.05 0.03 0.44 0.01 0.19 0.04 0.40 0.03) minimize x of-type float) - 0.01) - -(deftest loop.10.52 - (loop for x in '(-1/8 -1/20 -1/5 -1/3 -1/24 -1/1 -1/19 -1/4 -1/20 -1/3) minimize x of-type rational) - -1/1) - -(deftest loop.10.53 - (loop for x in '(4 10 5 1 7 9) minimize x into foo fixnum finally (return foo)) - 1) - -(deftest loop.10.54 - (loop for x in '(1 4 10 5 7 9) minimize x into foo of-type integer finally (return foo)) - 1) - -(deftest loop.10.55 - (let ((foo 20)) - (values - (loop for x in '(4 5 8 3 7) minimize x into foo finally (return foo)) - foo)) - 3 20) - -(declaim (special *loop-min-var*)) - -(deftest loop.10.56 - (let ((*loop-min-var* 100)) - (values - (loop for x in '(10 4 8) minimize x into *loop-min-var* - finally (return *loop-min-var*)) - *loop-min-var*)) - 4 100) - -(deftest loop.10.57 - (signals-error - (loop with foo = 100 - for i from 1 to 10 minimize i into foo - finally (return foo)) - program-error) - t) - -(deftest loop.10.58 - (signals-error - (loop with foo = 100 - for i from 1 to 10 minimizing i into foo - finally (return foo)) - program-error) - t) - -(deftest loop.10.58a - (loop for x in '(1 2 3) minimize (return 10)) - 10) - -;;; Tests combining MINIMIZE, MAXIMIZE - -(deftest loop.10.59 - (loop for i from 1 to 10 - minimize i - maximize (- i)) - 1) - -(deftest loop.10.60 - (loop for i from 1 to 10 - maximize (- i) - minimize i) - -1) - -(deftest loop.10.61 - (loop for i from 5 downto 1 - maximize i - minimize (- i)) - -1) - - -;;; Tests for SUM, SUMMING - -(deftest loop.10.70 - (loop for i from 1 to 4 sum i) - 10) - -(deftest loop.10.71 - (loop for i from 1 to 4 summing i) - 10) - -(deftest loop.10.72 - (loop for i from 1 to 4 sum (float i)) - 10.0) - -(deftest loop.10.73 - (loop for i from 1 to 4 sum (complex i i)) - #c(10 10)) - -(deftest loop.10.74 - (loop for i from 1 to 4 sum i fixnum) - 10) - -(deftest loop.10.75 - (loop for i from 1 to 4 sum i of-type integer) - 10) - -(deftest loop.10.76 - (loop for i from 1 to 4 sum i of-type rational) - 10) - -(deftest loop.10.77 - (loop for i from 1 to 4 sum (float i) float) - 10.0) - -(deftest loop.10.78 - (loop for i from 1 to 4 sum i of-type number) - 10) - -(deftest loop.10.79 - (loop for i from 1 to 4 sum i into foo finally (return foo)) - 10) - -(deftest loop.10.80 - (loop for i from 1 to 4 sum i into foo fixnum finally (return foo)) - 10) - -(deftest loop.10.81 - (let (z) - (values - (loop for i from 1 to 4 sum i into foo of-type (integer 0 10) - finally (setq z foo)) - z)) - nil - 10) - -(deftest loop.10.82 - (loop for i from 1 to 4 - sum i fixnum - count t) - 14) - -(deftest loop.10.83 - (loop for i from 1 to 4 - sum i fixnum - count t fixnum) - 14) - -(deftest loop.10.84 - (let ((foo 100)) - (values - (loop for i from 1 to 4 sum i into foo of-type integer - finally (return foo)) - foo)) - 10 100) - -(deftest loop.10.85 - (signals-error - (loop with foo = 100 - for i from 1 to 4 sum i into foo - finally (return foo)) - program-error) - t) - -(deftest loop.10.86 - (signals-error - (loop with foo = 100 - for i from 1 to 4 summing i into foo - finally (return foo)) - program-error) - t) - -(deftest loop.10.87 - (loop for i from 1 to 4 - sum (complex i (1+ i)) of-type complex) - #c(10 14)) - -(deftest loop.10.88 - (loop for i from 1 to 4 - sum (/ i 17) of-type rational) - 10/17) - -(deftest loop.10.89 - (loop for i from 1 to 4 summing (/ i 17)) - 10/17) - -(deftest loop.10.90 - (loop for i from 1 to 4 - sum i into foo - sum (1+ i) into bar - finally (return (values foo bar))) - 10 14) - -(deftest loop.10.91 - (loop for i from 1 to 4 - sum i into foo fixnum - sum (float (1+ i)) into bar float - finally (return (values foo bar))) - 10 14.0) - -(deftest loop.10.92 - (loop for i from 1 to 4 sum (return 100)) - 100) - -(deftest loop.10.93 - (loop for i from 1 to 4 summing (return 100)) - 100) - -(deftest loop.10.94 - (loop for i in nil sum i of-type integer) - 0) - -(deftest loop.10.95 - (loop for i in nil sum i of-type fixnum) - 0) - -(deftest loop.10.96 - (loop for i in nil sum i of-type bit) - 0) - -(deftest loop.10.97 - (loop for i in nil sum i of-type (integer 0 100)) - 0) - -(deftest loop.10.98 - (loop for i in nil sum i of-type (integer -100 0)) - 0) - -(deftest loop.10.99 - (loop for i in nil sum i of-type (integer -100 100)) - 0) - -(deftest loop.10.100 - (loop for i in nil sum i of-type (and integer (real -100.0 100.0))) - 0) - -(deftest loop.10.101 - (loop for i in nil sum i of-type short-float) - 0.0s0) - -(deftest loop.10.102 - (loop for i in nil sum i of-type single-float) - 0.0f0) - -(deftest loop.10.103 - (loop for i in nil sum i of-type double-float) - 0.0d0) - -(deftest loop.10.104 - (loop for i in nil sum i of-type long-float) - 0.0l0) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest loop.10.105 - (macrolet - ((%m (z) z)) - (loop for x from 1 to 10 count (expand-in-current-env (%m (< x 5))))) - 4) - -(deftest loop.10.106 - (macrolet - ((%m (z) z)) - (loop for x from 1 to 10 counting (expand-in-current-env (%m t)))) - 10) - -(deftest loop.10.107 - (macrolet - ((%m (z) z)) - (loop for x from 1 to 10 count (expand-in-current-env (%m nil)))) - 0) - -(deftest loop.10.108 - (macrolet - ((%m (z) z)) - (loop for x in '(1 4 10 5 7 9) maximize (expand-in-current-env (%m x)))) - 10) - -(deftest loop.10.109 - (macrolet - ((%m (z) z)) - (loop for x in '(1 4 10 5 7 9) maximizing (expand-in-current-env (%m 17)))) - 17) - -(deftest loop.10.110 - (macrolet - ((%m (z) z)) - (loop for x in '(5 4 10 1 7 9) minimize (expand-in-current-env (%m x)))) - 1) - -(deftest loop.10.111 - (macrolet - ((%m (z) z)) - (loop for x in '(5 4 10 1 7 9) minimizing (expand-in-current-env (%m 3)))) - 3) - -(deftest loop.10.112 - (macrolet - ((%m (z) z)) - (loop for x in '(1 4 10 5 7 9) sum (expand-in-current-env (%m x)))) - 36) - -(deftest loop.10.113 - (macrolet - ((%m (z) z)) - (loop for x in '(1 4 10 5 7 9) summing (expand-in-current-env (%m 2)))) - 12) diff --git a/t/ansi-test/iteration/loop11.lsp b/t/ansi-test/iteration/loop11.lsp deleted file mode 100644 index f1b486f..0000000 --- a/t/ansi-test/iteration/loop11.lsp +++ /dev/null @@ -1,220 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Nov 16 21:39:33 2002 -;;;; Contains: Tests for loop termination clauses REPEAT, WHILE and UNTIL - - - -;;; Tests of REPEAT - -(deftest loop.11.1 - (let ((z 0)) - (values - (loop repeat 10 do (incf z)) - z)) - nil - 10) - -(deftest loop.11.2 - (loop repeat 10 collect 'a) - (a a a a a a a a a a)) - -(deftest loop.11.3 - (let ((z 0)) - (loop repeat 0 do (incf z)) - z) - 0) - -(deftest loop.11.4 - (let ((z 0)) - (loop repeat -1 do (incf z)) - z) - 0) - -(deftest loop.11.5 - (let ((z 0)) - (loop repeat -1.5 do (incf z)) - z) - 0) - -(deftest loop.11.6 - (let ((z 0)) - (loop repeat -1000000000000 do (incf z)) - z) - 0) - -(deftest loop.11.7 - (let ((z 0)) - (loop repeat 10 do (incf z) (loop-finish)) - z) - 1) - -;;; This test is wrong because REPEAT is a main clause whereas FOR is -;;; a variable clause, and no main clause can precede a variable -;;; clause. -;;; -;;; (deftest loop.11.8 -;;; (loop repeat 3 for i in '(a b c d e) collect i) -;;; (a b c)) - -;;; Enough implementors have complained about this test that -;;; I'm removing it. The standard is self-contradictory -;;; on whether REPEAT can occur later in a LOOP form. - -;;; (deftest loop.11.9 -;;; (loop for i in '(a b c d e) collect i repeat 3) -;;; (a b c)) - - -;;; Tests of WHILE - -(deftest loop.11.10 - (loop with i = 0 while (< i 10) collect (incf i)) - (1 2 3 4 5 6 7 8 9 10)) - -(deftest loop.11.11 - (loop with i = 0 while (if (< i 10) t (return 'good)) - collect (incf i)) - good) - -(deftest loop.11.12 - (loop with i = 0 - while (< i 10) collect (incf i) - while (< i 10) collect (incf i) - while (< i 10) collect (incf i)) - (1 2 3 4 5 6 7 8 9 10)) - -(deftest loop.11.13 - (loop with i = 0 while (< i 10) collect (incf i) - finally (return 'done)) - done) - -(deftest loop.11.14 - (loop for i in '(a b c) - while nil - collect i) - nil) - -(deftest loop.11.15 - (loop for i in '(a b c) - collect i - while nil) - (a)) - -(deftest loop.11.16 - (loop for i in '(a b c) - while t - collect i) - (a b c)) - -(deftest loop.11.17 - (loop for i in '(a b c) - collect i - while t) - (a b c)) - -(deftest loop.11.18 - (loop for i from 1 to 10 - while (< i 6) - finally (return i)) - 6) - -;;; Tests of UNTIL - -(deftest loop.11.20 - (loop with i = 0 until (>= i 10) collect (incf i)) - (1 2 3 4 5 6 7 8 9 10)) - -(deftest loop.11.21 - (loop with i = 0 while (if (< i 10) t (return 'good)) - collect (incf i)) - good) - -(deftest loop.11.22 - (loop with i = 0 - until (>= i 10) collect (incf i) - until (>= i 10) collect (incf i) - until (>= i 10) collect (incf i)) - (1 2 3 4 5 6 7 8 9 10)) - -(deftest loop.11.23 - (loop with i = 0 until (>= i 10) collect (incf i) - finally (return 'done)) - done) - -(deftest loop.11.24 - (loop for i in '(a b c) - until t - collect i) - nil) - -(deftest loop.11.25 - (loop for i in '(a b c) - collect i - until t) - (a)) - -(deftest loop.11.26 - (loop for i in '(a b c) - until nil - collect i) - (a b c)) - -(deftest loop.11.27 - (loop for i in '(a b c) - collect i - until nil) - (a b c)) - -(deftest loop.11.28 - (loop for i from 1 to 10 - until (>= i 6) - finally (return i)) - 6) - -;;; More tests of a bug that showed up in c.l.l - -(deftest loop.11.29 - (loop for i in '(4 8 9 A 13) - when (eq i 'a) return :good - while (< i 12) collect i) - :good) - -(deftest loop.11.30 - (loop for i in '(4 8 9 A 13) - unless (numberp i) return :good - while (< i 12) collect i) - :good) - -(deftest loop.11.31 - (loop for i in '(4 8 9 A 13) - when (eq i 'a) return :good - until (> i 12) collect i) - :good) - -(deftest loop.11.32 - (loop for i in '(4 8 9 A 13) - unless (numberp i) return :good - until (> i 12) collect i) - :good) - -(deftest loop.11.33 - (loop for i in '(4 8 9 A 13) - if (not (numberp i)) return :good end - while (< i 12) collect i) - :good) - -(deftest loop.11.34 - (loop for i in '(4 8 9 A 13) - if (not (numberp i)) return :good end - until (> i 12) collect i) - :good) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest loop.11.35 - (macrolet - ((%m (z) z)) - (loop repeat (expand-in-current-env (%m 5)) collect 'x)) - (x x x x x)) diff --git a/t/ansi-test/iteration/loop12.lsp b/t/ansi-test/iteration/loop12.lsp deleted file mode 100644 index c07d8cd..0000000 --- a/t/ansi-test/iteration/loop12.lsp +++ /dev/null @@ -1,274 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Nov 17 08:47:43 2002 -;;;; Contains: Tests for ALWAYS, NEVER, THEREIS - - - -;;; Tests of ALWAYS clauses - -(deftest loop.12.1 - (loop for i in '(1 2 3 4) always (< i 10)) - t) - -(deftest loop.12.2 - (loop for i in nil always nil) - t) - -(deftest loop.12.3 - (loop for i in '(a) always nil) - nil) - -(deftest loop.12.4 - (loop for i in '(1 2 3 4 5 6 7) - always t - until (> i 5)) - t) - -(deftest loop.12.5 - (loop for i in '(1 2 3 4 5 6 7) - always (< i 6) - until (>= i 5)) - t) - -(deftest loop.12.6 - (loop for x in '(a b c d e) always x) - t) - -(deftest loop.12.7 - (loop for x in '(1 2 3 4 5 6) - always (< x 20) - never (> x 10)) - t) - -(deftest loop.12.8 - (loop for x in '(1 2 3 4 5 6) - always (< x 20) - never (> x 5)) - nil) - -(deftest loop.12.9 - (loop for x in '(1 2 3 4 5 6) - never (> x 5) - always (< x 20)) - nil) - -(deftest loop.12.10 - (loop for x in '(1 2 3 4 5) - always (< x 10) - finally (return 'good)) - good) - -(deftest loop.12.11 - (loop for x in '(1 2 3 4 5) - always (< x 3) - finally (return 'bad)) - nil) - -(deftest loop.12.12 - (loop for x in '(1 2 3 4 5 6) - always t - when (= x 4) do (loop-finish)) - t) - -(deftest loop.12.13 - (loop for x in '(1 2 3 4 5 6) - do (loop-finish) - always nil) - t) - -;;; Tests of NEVER - -(deftest loop.12.21 - (loop for i in '(1 2 3 4) never (> i 10)) - t) - -(deftest loop.12.22 - (loop for i in nil never t) - t) - -(deftest loop.12.23 - (loop for i in '(a) never t) - nil) - -(deftest loop.12.24 - (loop for i in '(1 2 3 4 5 6 7) - never nil - until (> i 5)) - t) - -(deftest loop.12.25 - (loop for i in '(1 2 3 4 5 6 7) - never (>= i 6) - until (>= i 5)) - t) - -(deftest loop.12.26 - (loop for x in '(a b c d e) never (not x)) - t) - -(deftest loop.12.30 - (loop for x in '(1 2 3 4 5) - never (>= x 10) - finally (return 'good)) - good) - -(deftest loop.12.31 - (loop for x in '(1 2 3 4 5) - never (>= x 3) - finally (return 'bad)) - nil) - -(deftest loop.12.32 - (loop for x in '(1 2 3 4 5 6) - never nil - when (= x 4) do (loop-finish)) - t) - -(deftest loop.12.33 - (loop for x in '(1 2 3 4 5 6) - do (loop-finish) - never t) - t) - -;;; Tests of THEREIS - -(deftest loop.12.41 - (loop for x in '(1 2 3 4 5) - thereis (and (eqlt x 3) 'good)) - good) - -(deftest loop.12.42 - (loop for x in '(nil nil a nil nil) - thereis x) - a) - -(deftest loop.12.43 - (loop for x in '(1 2 3 4 5) - thereis (eql x 4) - when (eql x 2) do (loop-finish)) - nil) - -;;; Error cases - -(deftest loop.12.error.50 - (signals-error - (loop for i from 1 to 10 - collect i - always (< i 20)) - program-error) - t) - -(deftest loop.12.error.50a - (signals-error - (loop for i from 1 to 10 - always (< i 20) - collect i) - program-error) - t) - -(deftest loop.12.error.51 - (signals-error - (loop for i from 1 to 10 - collect i - never (> i 20)) - program-error) - t) - -(deftest loop.12.error.51a - (signals-error - (loop for i from 1 to 10 - never (> i 20) - collect i) - program-error) - t) - -(deftest loop.12.error.52 - (signals-error - (loop for i from 1 to 10 - collect i - thereis (> i 20)) - program-error) - t) - -(deftest loop.12.error.52a - (signals-error - (loop for i from 1 to 10 - thereis (> i 20) - collect i) - program-error) - t) - -;;; Non-error cases - -(deftest loop.12.53 - (loop for i from 1 to 10 - collect i into foo - always (< i 20)) - t) - -(deftest loop.12.53a - (loop for i from 1 to 10 - always (< i 20) - collect i into foo) - t) - -(deftest loop.12.54 - (loop for i from 1 to 10 - collect i into foo - never (> i 20)) - t) - -(deftest loop.12.54a - (loop for i from 1 to 10 - never (> i 20) - collect i into foo) - t) - -(deftest loop.12.55 - (loop for i from 1 to 10 - collect i into foo - thereis i) - 1) - -(deftest loop.12.55a - (loop for i from 1 to 10 - thereis i - collect i into foo) - 1) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest loop.12.56 - (macrolet - ((%m (z) z)) - (loop for i in '(1 2 3 4) always (expand-in-current-env (%m (< i 10))))) - t) - -(deftest loop.12.57 - (macrolet - ((%m (z) z)) - (loop for i in '(1 2 3 4) always (expand-in-current-env (%m t)))) - t) - -(deftest loop.12.58 - (macrolet - ((%m (z) z)) - (loop for i in '(1 2 3 4) never (expand-in-current-env (%m (>= i 10))))) - t) - -(deftest loop.12.59 - (macrolet - ((%m (z) z)) - (loop for i in '(1 2 3 4) never (expand-in-current-env (%m t)))) - nil) - -(deftest loop.12.60 - (macrolet - ((%m (z) z)) - (loop for i in '(1 2 3 4) - thereis (expand-in-current-env (%m (and (>= i 2) (+ i 1)))))) - 3) - - diff --git a/t/ansi-test/iteration/loop13.lsp b/t/ansi-test/iteration/loop13.lsp deleted file mode 100644 index e8fa7fc..0000000 --- a/t/ansi-test/iteration/loop13.lsp +++ /dev/null @@ -1,454 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Nov 17 12:37:45 2002 -;;;; Contains: Tests of DO, DOING, RETURN in LOOP. Tests of NAMED loops - - - -(deftest loop.13.1 - (loop do (return 10)) - 10) - -(deftest loop.13.2 - (loop doing (return 10)) - 10) - -(deftest loop.13.3 - (loop for i from 0 below 100 by 7 - when (> i 50) return i) - 56) - -(deftest loop.13.4 - (let ((x 0)) - (loop do - (incf x) - (when (= x 10) (return x)))) - 10) - -(deftest loop.13.5 - (loop return 'a) - a) - -(deftest loop.13.6 - (loop return (values))) - -(deftest loop.13.7 - (loop return (values 1 2)) - 1 2) - -(deftest loop.13.8 - (let* ((limit (min 1000 (1- (min call-arguments-limit - multiple-values-limit)))) - (vals (make-list limit :initial-element :a)) - (vals2 (multiple-value-list (eval `(loop return (values ,@vals)))))) - (equalt vals vals2)) - t) - -(deftest loop.13.9 - (loop named foo return 'a) - a) - -(deftest loop.13.10 - (block nil - (return (loop named foo return :good)) - :bad) - :good) - -(deftest loop.13.11 - (block nil - (loop named foo do (return :good)) - :bad) - :good) - -(deftest loop.13.12 - (loop named foo with a = (return-from foo :good) return :bad) - :good) - -(deftest loop.13.13 - (loop named foo - with b = 1 - and a = (return-from foo :good) return :bad) - :good) - -(deftest loop.13.14 - (loop named foo - for a = (return-from foo :good) return :bad) - :good) - -(deftest loop.13.15 - (loop named foo for a in (return-from foo :good)) - :good) - -(deftest loop.13.16 - (loop named foo for a from (return-from foo :good) return :bad) - :good) - -(deftest loop.13.17 - (loop named foo for a on (return-from foo :good) return :bad) - :good) - -(deftest loop.13.18 - (loop named foo for a across (return-from foo :good) return :bad) - :good) - -(deftest loop.13.19 - (loop named foo for a being the hash-keys of (return-from foo :good) - return :bad) - :good) - -(deftest loop.13.20 - (loop named foo for a being the symbols of (return-from foo :good) - return :bad) - :good) - -(deftest loop.13.21 - (loop named foo repeat (return-from foo :good) return :bad) - :good) - -(deftest loop.13.22 - (loop named foo for i from 0 to (return-from foo :good) return :bad) - :good) - -(deftest loop.13.23 - (loop named foo for i from 0 to 10 by (return-from foo :good) return :bad) - :good) - -(deftest loop.13.24 - (loop named foo for i from 10 downto (return-from foo :good) return :bad) - :good) - -(deftest loop.13.25 - (loop named foo for i from 10 above (return-from foo :good) return :bad) - :good) - -(deftest loop.13.26 - (loop named foo for i from 10 below (return-from foo :good) return :bad) - :good) - -(deftest loop.13.27 - (loop named foo for i in '(a b c) by (return-from foo :good) return :bad) - :good) - -(deftest loop.13.28 - (loop named foo for i on '(a b c) by (return-from foo :good) return :bad) - :good) - -(deftest loop.13.29 - (loop named foo for i = 1 then (return-from foo :good)) - :good) - -(deftest loop.13.30 - (loop named foo for x in '(a b c) collect (return-from foo :good)) - :good) - -(deftest loop.13.31 - (loop named foo for x in '(a b c) append (return-from foo :good)) - :good) - -(deftest loop.13.32 - (loop named foo for x in '(a b c) nconc (return-from foo :good)) - :good) - -(deftest loop.13.33 - (loop named foo for x in '(a b c) count (return-from foo :good)) - :good) - -(deftest loop.13.34 - (loop named foo for x in '(a b c) sum (return-from foo :good)) - :good) - -(deftest loop.13.35 - (loop named foo for x in '(a b c) maximize (return-from foo :good)) - :good) - -(deftest loop.13.36 - (loop named foo for x in '(a b c) minimize (return-from foo :good)) - :good) - -(deftest loop.13.37 - (loop named foo for x in '(a b c) thereis (return-from foo :good)) - :good) - -(deftest loop.13.38 - (loop named foo for x in '(a b c) always (return-from foo :good)) - :good) - -(deftest loop.13.39 - (loop named foo for x in '(a b c) never (return-from foo :good)) - :good) - -(deftest loop.13.40 - (loop named foo for x in '(a b c) until (return-from foo :good)) - :good) - -(deftest loop.13.41 - (loop named foo for x in '(a b c) while (return-from foo :good)) - :good) - -(deftest loop.13.42 - (loop named foo for x in '(a b c) when (return-from foo :good) return :bad) - :good) - -(deftest loop.13.43 - (loop named foo for x in '(a b c) unless (return-from foo :good) return :bad) - :good) - -(deftest loop.13.44 - (loop named foo for x in '(a b c) if (return-from foo :good) return :bad) - :good) - -(deftest loop.13.45 - (loop named foo for x in '(a b c) return (return-from foo :good)) - :good) - -(deftest loop.13.46 - (loop named foo initially (return-from foo :good) return :bad) - :good) - -(deftest loop.13.47 - (loop named foo do (loop-finish) finally (return-from foo :good)) - :good) - - -(deftest loop.13.52 - (block nil - (loop named foo with a = (return :good) return :bad) - :bad) - :good) - -(deftest loop.13.53 - (block nil - (loop named foo - with b = 1 - and a = (return :good) return :bad) - :bad) - :good) - -(deftest loop.13.54 - (block nil - (loop named foo - for a = (return :good) return :bad) - :bad) - :good) - -(deftest loop.13.55 - (block nil - (loop named foo for a in (return :good)) - :bad) - :good) - -(deftest loop.13.56 - (block nil - (loop named foo for a from (return :good) return :bad) - :bad) - :good) - -(deftest loop.13.57 - (block nil - (loop named foo for a on (return :good) return :bad) - :bad) - :good) - -(deftest loop.13.58 - (block nil - (loop named foo for a across (return :good) return :bad) - :bad) - :good) - -(deftest loop.13.59 - (block nil - (loop named foo for a being the hash-keys of (return :good) - return :bad) - :bad) - :good) - -(deftest loop.13.60 - (block nil - (loop named foo for a being the symbols of (return :good) - return :bad) - :bad) - :good) - -(deftest loop.13.61 - (block nil - (loop named foo repeat (return :good) return :bad) - :bad) - :good) - -(deftest loop.13.62 - (block nil - (loop named foo for i from 0 to (return :good) return :bad) - :bad) - :good) - -(deftest loop.13.63 - (block nil - (loop named foo for i from 0 to 10 by (return :good) return :bad) - :bad) - :good) - -(deftest loop.13.64 - (block nil - (loop named foo for i from 10 downto (return :good) return :bad) - :bad) - :good) - -(deftest loop.13.65 - (block nil - (loop named foo for i from 10 above (return :good) return :bad) - :bad) - :good) - -(deftest loop.13.66 - (block nil - (loop named foo for i from 10 below (return :good) return :bad) - :bad) - :good) - -(deftest loop.13.67 - (block nil - (loop named foo for i in '(a b c) by (return :good) return :bad) - :bad) - :good) - -(deftest loop.13.68 - (block nil - (loop named foo for i on '(a b c) by (return :good) return :bad) - :bad) - :good) - -(deftest loop.13.69 - (block nil - (loop named foo for i = 1 then (return :good)) - :bad) - :good) - -(deftest loop.13.70 - (block nil - (loop named foo for x in '(a b c) collect (return :good)) - :bad) - :good) - -(deftest loop.13.71 - (block nil - (loop named foo for x in '(a b c) append (return :good)) - :bad) - :good) - -(deftest loop.13.72 - (block nil - (loop named foo for x in '(a b c) nconc (return :good)) - :bad) - :good) - -(deftest loop.13.73 - (block nil - (loop named foo for x in '(a b c) count (return :good)) - :bad) - :good) - -(deftest loop.13.74 - (block nil - (loop named foo for x in '(a b c) sum (return :good)) - :bad) - :good) - -(deftest loop.13.75 - (block nil - (loop named foo for x in '(a b c) maximize (return :good)) - :bad) - :good) - -(deftest loop.13.76 - (block nil - (loop named foo for x in '(a b c) minimize (return :good)) - :bad) - :good) - -(deftest loop.13.77 - (block nil - (loop named foo for x in '(a b c) thereis (return :good)) - :bad) - :good) - -(deftest loop.13.78 - (block nil - (loop named foo for x in '(a b c) always (return :good)) - :bad) - :good) - -(deftest loop.13.79 - (block nil - (loop named foo for x in '(a b c) never (return :good)) - :bad) - :good) - -(deftest loop.13.80 - (block nil - (loop named foo for x in '(a b c) until (return :good)) - :bad) - :good) - -(deftest loop.13.81 - (block nil - (loop named foo for x in '(a b c) while (return :good)) - :bad) - :good) - -(deftest loop.13.82 - (block nil - (loop named foo for x in '(a b c) when (return :good) return :bad) - :bad) - :good) - -(deftest loop.13.83 - (block nil - (loop named foo for x in '(a b c) unless (return :good) return :bad) - :bad) - :good) - -(deftest loop.13.84 - (block nil - (loop named foo for x in '(a b c) if (return :good) return :bad) - :bad) - :good) - -(deftest loop.13.85 - (block nil - (loop named foo for x in '(a b c) return (return :good)) - :bad) - :good) - -(deftest loop.13.86 - (block nil - (loop named foo initially (return :good) return :bad) - :bad) - :good) - -(deftest loop.13.87 - (block nil - (loop named foo do (loop-finish) finally (return :good)) - :bad) - :good) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest loop.13.88 - (macrolet - ((%m (z) z)) - (loop do (expand-in-current-env (%m (return 10))))) - 10) - -(deftest loop.13.89 - (macrolet - ((%m (z) z)) - (loop for i from 0 below 100 by 7 - when (> i 50) return (expand-in-current-env (%m i)))) - 56) - -(deftest loop.13.90 - (macrolet - ((%m (z) z)) - (loop return (expand-in-current-env (%m 'a)))) - a) diff --git a/t/ansi-test/iteration/loop14.lsp b/t/ansi-test/iteration/loop14.lsp deleted file mode 100644 index 25c80d7..0000000 --- a/t/ansi-test/iteration/loop14.lsp +++ /dev/null @@ -1,368 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Nov 20 06:33:21 2002 -;;;; Contains: Tests of LOOP conditional execution clauses - - - -(deftest loop.14.1 - (loop for x from 1 to 6 - when (evenp x) - collect x) - (2 4 6)) - -(deftest loop.14.2 - (loop for x from 1 to 6 - unless (evenp x) - collect x) - (1 3 5)) - -(deftest loop.14.3 - (loop for x from 1 to 10 - when (evenp x) - collect x into foo - and count t into bar - finally (return (values foo bar))) - (2 4 6 8 10) - 5) - -(deftest loop.14.4 - (loop for x from 1 to 10 - when (evenp x) collect x end) - (2 4 6 8 10)) - -(deftest loop.14.5 - (loop for x from 1 to 10 - when (evenp x) collect x into evens - else collect x into odds - end - finally (return (values evens odds))) - (2 4 6 8 10) - (1 3 5 7 9)) - -(deftest loop.14.6 - (loop for x from 1 to 10 - unless (oddp x) - collect x into foo - and count t into bar - finally (return (values foo bar))) - (2 4 6 8 10) - 5) - -(deftest loop.14.7 - (loop for x from 1 to 10 - unless (oddp x) collect x end) - (2 4 6 8 10)) - -(deftest loop.14.8 - (loop for x from 1 to 10 - unless (oddp x) collect x into evens - else collect x into odds - end - finally (return (values evens odds))) - (2 4 6 8 10) - (1 3 5 7 9)) - -(deftest loop.14.9 - (loop for x from 1 to 6 - if (evenp x) - collect x) - (2 4 6)) - -(deftest loop.14.10 - (loop for x from 1 to 10 - if (evenp x) - collect x into foo - and count t into bar - finally (return (values foo bar))) - (2 4 6 8 10) - 5) - -(deftest loop.14.11 - (loop for x from 1 to 10 - if (evenp x) collect x end) - (2 4 6 8 10)) - -(deftest loop.14.12 - (loop for x from 1 to 10 - if (evenp x) collect x into evens - else collect x into odds - end - finally (return (values evens odds))) - (2 4 6 8 10) - (1 3 5 7 9)) - -;;; Test that else associates with the nearest conditional unclosed -;;; by end - -(deftest loop.14.13 - (loop for i from 1 to 20 - if (evenp i) - if (= (mod i 3) 0) - collect i into list1 - else collect i into list2 - finally (return (values list1 list2))) - (6 12 18) - (2 4 8 10 14 16 20)) - -(deftest loop.14.14 - (loop for i from 1 to 20 - when (evenp i) - if (= (mod i 3) 0) - collect i into list1 - else collect i into list2 - finally (return (values list1 list2))) - (6 12 18) - (2 4 8 10 14 16 20)) - -(deftest loop.14.15 - (loop for i from 1 to 20 - if (evenp i) - when (= (mod i 3) 0) - collect i into list1 - else collect i into list2 - finally (return (values list1 list2))) - (6 12 18) - (2 4 8 10 14 16 20)) - -(deftest loop.14.16 - (loop for i from 1 to 20 - if (evenp i) - if (= (mod i 3) 0) - collect i into list1 - end - else collect i into list2 - finally (return (values list1 list2))) - (6 12 18) - (1 3 5 7 9 11 13 15 17 19)) - -(deftest loop.14.17 - (loop for i from 1 to 20 - when (evenp i) - if (= (mod i 3) 0) - collect i into list1 - end - else collect i into list2 - finally (return (values list1 list2))) - (6 12 18) - (1 3 5 7 9 11 13 15 17 19)) - -(deftest loop.14.18 - (loop for i from 1 to 20 - if (evenp i) - when (= (mod i 3) 0) - collect i into list1 - end - else collect i into list2 - finally (return (values list1 list2))) - (6 12 18) - (1 3 5 7 9 11 13 15 17 19)) - -(deftest loop.14.19 - (loop for i from 1 to 20 - when (evenp i) - when (= (mod i 3) 0) - collect i into list1 - end - else collect i into list2 - finally (return (values list1 list2))) - (6 12 18) - (1 3 5 7 9 11 13 15 17 19)) - -(deftest loop.14.20 - (loop for i from 1 to 20 - unless (oddp i) - if (= (mod i 3) 0) - collect i into list1 - end - else collect i into list2 - finally (return (values list1 list2))) - (6 12 18) - (1 3 5 7 9 11 13 15 17 19)) - -(deftest loop.14.21 - (loop for i from 1 to 20 - if (evenp i) - unless (/= (mod i 3) 0) - collect i into list1 - end - else collect i into list2 - finally (return (values list1 list2))) - (6 12 18) - (1 3 5 7 9 11 13 15 17 19)) - -(deftest loop.14.22 - (loop for i from 1 to 20 - unless (oddp i) - unless (/= (mod i 3) 0) - collect i into list1 - end - else collect i into list2 - finally (return (values list1 list2))) - (6 12 18) - (1 3 5 7 9 11 13 15 17 19)) - -;;; More tests conditionals - -(deftest loop.14.23 - (loop for i from 1 to 20 - if (evenp i) - collect i into list1 - else if (= (mod i 3) 0) - collect i into list2 - else collect i into list3 - finally (return (values list1 list2 list3))) - (2 4 6 8 10 12 14 16 18 20) - (3 9 15) - (1 5 7 11 13 17 19)) - -;;; Tests of 'IT' - -(deftest loop.14.24 - (loop for x in '((a) nil (b) (c) (nil) (d)) - when (car x) collect it) - (a b c d)) - -(deftest loop.14.25 - (loop for x in '((a) nil (b) (c) (nil) (d)) - if (car x) collect it) - (a b c d)) - -(deftest loop.14.26 - (loop for x in '(nil (a) nil (b) (c) (nil) (d)) - when (car x) return it) - a) - -(deftest loop.14.27 - (loop for x in '(nil (a) nil (b) (c) (nil) (d)) - if (car x) return it) - a) - -(deftest loop.14.28 - (loop for x in '((a) nil (b) (c) (nil) (d)) - when (car x) collect it and collect 'foo) - (a foo b foo c foo d foo)) - -(deftest loop.14.29 - (let ((it 'z)) - (loop for x in '(a b c d) - when x collect it and collect it)) - (a z b z c z d z)) - -(deftest loop.14.30 - (let ((it 'z)) - (loop for x in '(a b c d) - if x collect it end - collect it)) - (a z b z c z d z)) - -(deftest loop.14.31 - (loop for it on '(a b c d) - when (car it) collect it) - (a b c d)) - -(deftest loop.14.32 - (loop for x in '(a b nil c d nil e) - when x collecting it) - (a b c d e)) - -(deftest loop.14.33 - (loop for x in '(a b nil c d nil e) - when x append (list x)) - (a b c d e)) - -(deftest loop.14.34 - (loop for x in '(a b nil c d nil e) - when x appending (list x)) - (a b c d e)) - -(deftest loop.14.35 - (loop for x in '(a b nil c d nil e) - when x nconc (list x)) - (a b c d e)) - -(deftest loop.14.36 - (loop for x in '(a b nil c d nil e) - when x nconcing (list x)) - (a b c d e)) - -(deftest loop.14.37 - (loop for it on '(a b c d) - when (car it) collect it into foo - finally (return foo)) - (a b c d)) - -(deftest loop.14.38 - (loop for x in '(1 2 nil 3 4 nil 5 nil) - when x count it) - 5) - -(deftest loop.14.39 - (loop for x in '(1 2 nil 3 4 nil 5 nil) - when x counting it) - 5) - -(deftest loop.14.40 - (loop for x in '(1 2 nil 3 4 nil 6 nil) - when x maximize it) - 6) - -(deftest loop.14.41 - (loop for x in '(1 2 nil 3 4 nil 6 nil) - when x maximizing it) - 6) - -(deftest loop.14.42 - (loop for x in '(1 2 nil 3 4 nil 6 nil) - when x minimize it) - 1) - -(deftest loop.14.43 - (loop for x in '(1 2 nil 3 4 nil 6 nil) - when x minimizing it) - 1) - -(deftest loop.14.44 - (loop for x in '(1 2 nil 3 4 nil 6 nil) - when x sum it) - 16) - -(deftest loop.14.45 - (loop for x in '(1 2 nil 3 4 nil 6 nil) - when x summing it) - 16) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest loop.14.46 - (macrolet - ((%m (z) z)) - (loop for x from 1 to 6 - when (expand-in-current-env (%m (evenp x))) - collect x)) - (2 4 6)) - -(deftest loop.14.47 - (macrolet - ((%m (z) z)) - (loop for x from 1 to 6 - unless (expand-in-current-env (%m (evenp x))) - collect x)) - (1 3 5)) - -(deftest loop.14.48 - (macrolet - ((%m (z) z)) - (loop for x from 1 to 6 - when (expand-in-current-env (%m t)) - sum x)) - 21) - -(deftest loop.14.49 - (macrolet - ((%m (z) z)) - (loop for x from 1 to 10 - if (expand-in-current-env (%m (evenp x))) - collect x end)) - (2 4 6 8 10)) diff --git a/t/ansi-test/iteration/loop15.lsp b/t/ansi-test/iteration/loop15.lsp deleted file mode 100644 index 96b5f89..0000000 --- a/t/ansi-test/iteration/loop15.lsp +++ /dev/null @@ -1,249 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Nov 21 07:08:21 2002 -;;;; Contains: Tests that keywords can be loop keywords - - - -;;; Tests of loop keywords - -(deftest loop.15.30 - (loop :for i :from 1 :to 10 :collect i) - (1 2 3 4 5 6 7 8 9 10)) - -(deftest loop.15.31 - (loop :for i :upfrom 1 :below 10 :by 2 :collect i) - (1 3 5 7 9)) - -(deftest loop.15.32 - (loop :with x = 1 :and y = 2 :return (values x y)) - 1 2) - -(deftest loop.15.33 - (loop :named foo :doing (return-from foo 1)) - 1) - -(deftest loop.15.34 - (let ((x 0)) - (loop - :initially (setq x 2) - :until t - :finally (return x))) - 2) - -(deftest loop.15.35 - (loop :for x :in '(a b c) :collecting x) - (a b c)) - -(deftest loop.15.36 - (loop :for x :in '(a b c) :append (list x)) - (a b c)) - -(deftest loop.15.37 - (loop :for x :in '(a b c) :appending (list x)) - (a b c)) - -(deftest loop.15.38 - (loop :for x :in '(a b c) :nconc (list x)) - (a b c)) - -(deftest loop.15.39 - (loop :for x :in '(a b c) :nconcing (list x)) - (a b c)) - -(deftest loop.15.40 - (loop :for x :in '(1 2 3) :count x) - 3) - -(deftest loop.15.41 - (loop :for x :in '(1 2 3) :counting x) - 3) - -(deftest loop.15.42 - (loop :for x :in '(1 2 3) :sum x) - 6) - -(deftest loop.15.43 - (loop :for x :in '(1 2 3) :summing x) - 6) - -(deftest loop.15.44 - (loop :for x :in '(10 20 30) :maximize x) - 30) - -(deftest loop.15.45 - (loop :for x :in '(10 20 30) :maximizing x) - 30) - -(deftest loop.15.46 - (loop :for x :in '(10 20 30) :minimize x) - 10) - -(deftest loop.15.47 - (loop :for x :in '(10 20 30) :minimizing x) - 10) - -(deftest loop.15.48 - (loop :for x :in '(1 2 3 4) :sum x :into foo :of-type fixnum - :finally (return foo)) - 10) - -(deftest loop.15.49 - (loop :for x :upfrom 1 :to 10 - :if (evenp x) :sum x :into foo - :else :sum x :into bar - :end - :finally (return (values foo bar))) - 30 25) - -(deftest loop.15.50 - (loop :for x :downfrom 10 :above 0 - :when (evenp x) :sum x :into foo - :else :sum x :into bar - :end - :finally (return (values foo bar))) - 30 25) - -(deftest loop.15.51 - (loop :for x :in '(a b nil c d nil) - :unless x :count t) - 2) - -(deftest loop.15.52 - (loop :for x :in '(a b nil c d nil) - :unless x :collect x :into bar :and :count t :into foo - :end - finally (return (values bar foo))) - (nil nil) - 2) - -(deftest loop.15.53 - (loop :for x :in '(nil nil a b nil c nil) - :collect x - :until x) - (nil nil a)) - -(deftest loop.15.54 - (loop :for x :in '(a b nil c nil) - :while x :collect x) - (a b)) - -(deftest loop.15.55 - (loop :for x :in '(nil nil a b nil c nil) - :thereis x) - a) - -(deftest loop.15.56 - (loop :for x :in '(nil nil a b nil c nil) - :never x) - nil) - -(deftest loop.15.57 - (loop :for x :in '(a b c d e) - :always x) - t) - -(deftest loop.15.58 - (loop :as x :in '(a b c) :count t) - 3) - -(deftest loop.15.59 - (loop :for i :from 10 :downto 5 :collect i) - (10 9 8 7 6 5)) - -(deftest loop.15.60 - (loop :for i :from 0 :upto 5 :collect i) - (0 1 2 3 4 5)) - -(deftest loop.15.61 - (loop :for x :on '(a b c) :collecting (car x)) - (a b c)) - -(deftest loop.15.62 - (loop :for x = '(a b c) :then (cdr x) - :while x - :collect (car x)) - (a b c)) - -(deftest loop.15.63 - (loop :for x :across #(a b c) :collect x) - (a b c)) - -(deftest loop.15.64 - (loop :for x :being :the :hash-keys :of (make-hash-table) - :count t) - 0) - -(deftest loop.15.65 - (loop :for x :being :each :hash-key :in (make-hash-table) - :count t) - 0) - -(deftest loop.15.66 - (loop :for x :being :each :hash-value :of (make-hash-table) - :count t) - 0) - -(deftest loop.15.67 - (loop :for x :being :the :hash-values :in (make-hash-table) - :count t) - 0) - -(deftest loop.15.68 - (loop :for x :being :the :hash-values :in (make-hash-table) - :using (:hash-key k) - :count t) - 0) - -(deftest loop.15.69 - (loop :for x :being :the :hash-keys :in (make-hash-table) - :using (:hash-value v) - :count t) - 0) - -(deftest loop.15.70 - (let () - (ignore-errors (delete-package "LOOP.15.PACKAGE")) - (let ((p (make-package "LOOP.15.PACKAGE" :use nil))) - (loop :for x :being :the :symbols :of p :count t))) - 0) - -(deftest loop.15.71 - (let () - (ignore-errors (delete-package "LOOP.15.PACKAGE")) - (let ((p (make-package "LOOP.15.PACKAGE" :use nil))) - (loop :for x :being :each :symbol :of p :count t))) - 0) - -(deftest loop.15.72 - (let () - (ignore-errors (delete-package "LOOP.15.PACKAGE")) - (let ((p (make-package "LOOP.15.PACKAGE" :use nil))) - (loop :for x :being :the :external-symbols :of p :count t))) - 0) - -(deftest loop.15.73 - (let () - (ignore-errors (delete-package "LOOP.15.PACKAGE")) - (let ((p (make-package "LOOP.15.PACKAGE" :use nil))) - (loop :for x :being :each :external-symbol :of p :count t))) - 0) - -(deftest loop.15.74 - (let () - (ignore-errors (delete-package "LOOP.15.PACKAGE")) - (let ((p (make-package "LOOP.15.PACKAGE" :use nil))) - (loop :for x :being :the :present-symbols :of p :count t))) - 0) - -(deftest loop.15.75 - (let () - (ignore-errors (delete-package "LOOP.15.PACKAGE")) - (let ((p (make-package "LOOP.15.PACKAGE" :use nil))) - (loop :for x :being :each :present-symbol :of p :count t))) - 0) - - - - - diff --git a/t/ansi-test/iteration/loop16.lsp b/t/ansi-test/iteration/loop16.lsp deleted file mode 100644 index bad8eed..0000000 --- a/t/ansi-test/iteration/loop16.lsp +++ /dev/null @@ -1,243 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Nov 21 09:46:27 2002 -;;;; Contains: Tests that uninterned symbols can be loop keywords - - - - -(deftest loop.16.30 - (loop #:for i #:from 1 #:to 10 #:collect i) - (1 2 3 4 5 6 7 8 9 10)) - -(deftest loop.16.31 - (loop #:for i #:upfrom 1 #:below 10 #:by 2 #:collect i) - (1 3 5 7 9)) - -(deftest loop.16.32 - (loop #:with x = 1 #:and y = 2 #:return (values x y)) - 1 2) - -(deftest loop.16.33 - (loop #:named foo #:doing (return-from foo 1)) - 1) - -(deftest loop.16.34 - (let ((x 0)) - (loop - #:initially (setq x 2) - #:until t - #:finally (return x))) - 2) - -(deftest loop.16.35 - (loop #:for x #:in '(a b c) #:collecting x) - (a b c)) - -(deftest loop.16.36 - (loop #:for x #:in '(a b c) #:append (list x)) - (a b c)) - -(deftest loop.16.37 - (loop #:for x #:in '(a b c) #:appending (list x)) - (a b c)) - -(deftest loop.16.38 - (loop #:for x #:in '(a b c) #:nconc (list x)) - (a b c)) - -(deftest loop.16.39 - (loop #:for x #:in '(a b c) #:nconcing (list x)) - (a b c)) - -(deftest loop.16.40 - (loop #:for x #:in '(1 2 3) #:count x) - 3) - -(deftest loop.16.41 - (loop #:for x #:in '(1 2 3) #:counting x) - 3) - -(deftest loop.16.42 - (loop #:for x #:in '(1 2 3) #:sum x) - 6) - -(deftest loop.16.43 - (loop #:for x #:in '(1 2 3) #:summing x) - 6) - -(deftest loop.16.44 - (loop #:for x #:in '(10 20 30) #:maximize x) - 30) - -(deftest loop.16.45 - (loop #:for x #:in '(10 20 30) #:maximizing x) - 30) - -(deftest loop.16.46 - (loop #:for x #:in '(10 20 30) #:minimize x) - 10) - -(deftest loop.16.47 - (loop #:for x #:in '(10 20 30) #:minimizing x) - 10) - -(deftest loop.16.48 - (loop #:for x #:in '(1 2 3 4) #:sum x #:into foo #:of-type fixnum - #:finally (return foo)) - 10) - -(deftest loop.16.49 - (loop #:for x #:upfrom 1 #:to 10 - #:if (evenp x) #:sum x #:into foo - #:else #:sum x #:into bar - #:end - #:finally (return (values foo bar))) - 30 25) - -(deftest loop.16.50 - (loop #:for x #:downfrom 10 #:above 0 - #:when (evenp x) #:sum x #:into foo - #:else #:sum x #:into bar - #:end - #:finally (return (values foo bar))) - 30 25) - -(deftest loop.16.51 - (loop #:for x #:in '(a b nil c d nil) - #:unless x #:count t) - 2) - -(deftest loop.16.52 - (loop #:for x #:in '(a b nil c d nil) - #:unless x #:collect x #:into bar #:and #:count t #:into foo - #:end - finally (return (values bar foo))) - (nil nil) - 2) - -(deftest loop.16.53 - (loop #:for x #:in '(nil nil a b nil c nil) - #:collect x - #:until x) - (nil nil a)) - -(deftest loop.16.54 - (loop #:for x #:in '(a b nil c nil) - #:while x #:collect x) - (a b)) - -(deftest loop.16.55 - (loop #:for x #:in '(nil nil a b nil c nil) - #:thereis x) - a) - -(deftest loop.16.56 - (loop #:for x #:in '(nil nil a b nil c nil) - #:never x) - nil) - -(deftest loop.16.57 - (loop #:for x #:in '(a b c d e) - #:always x) - t) - -(deftest loop.16.58 - (loop #:as x #:in '(a b c) #:count t) - 3) - -(deftest loop.16.59 - (loop #:for i #:from 10 #:downto 5 #:collect i) - (10 9 8 7 6 5)) - -(deftest loop.16.60 - (loop #:for i #:from 0 #:upto 5 #:collect i) - (0 1 2 3 4 5)) - -(deftest loop.16.61 - (loop #:for x #:on '(a b c) #:collecting (car x)) - (a b c)) - -(deftest loop.16.62 - (loop #:for x = '(a b c) #:then (cdr x) - #:while x - #:collect (car x)) - (a b c)) - -(deftest loop.16.63 - (loop #:for x #:across #(a b c) #:collect x) - (a b c)) - -(deftest loop.16.64 - (loop #:for x #:being #:the #:hash-keys #:of (make-hash-table) - #:count t) - 0) - -(deftest loop.16.65 - (loop #:for x #:being #:each #:hash-key #:in (make-hash-table) - #:count t) - 0) - -(deftest loop.16.66 - (loop #:for x #:being #:each #:hash-value #:of (make-hash-table) - #:count t) - 0) - -(deftest loop.16.67 - (loop #:for x #:being #:the #:hash-values #:in (make-hash-table) - #:count t) - 0) - -(deftest loop.16.68 - (loop #:for x #:being #:the #:hash-values #:in (make-hash-table) - #:using (#:hash-key k) - #:count t) - 0) - -(deftest loop.16.69 - (loop #:for x #:being #:the #:hash-keys #:in (make-hash-table) - #:using (#:hash-value v) - #:count t) - 0) - -(deftest loop.16.70 - (let () - (ignore-errors (delete-package "LOOP.16.PACKAGE")) - (let ((p (make-package "LOOP.16.PACKAGE" :use nil))) - (loop #:for x #:being #:the #:symbols #:of p #:count t))) - 0) - -(deftest loop.16.71 - (let () - (ignore-errors (delete-package "LOOP.16.PACKAGE")) - (let ((p (make-package "LOOP.16.PACKAGE" :use nil))) - (loop #:for x #:being #:each #:symbol #:of p #:count t))) - 0) - -(deftest loop.16.72 - (let () - (ignore-errors (delete-package "LOOP.16.PACKAGE")) - (let ((p (make-package "LOOP.16.PACKAGE" :use nil))) - (loop #:for x #:being #:the #:external-symbols #:of p #:count t))) - 0) - -(deftest loop.16.73 - (let () - (ignore-errors (delete-package "LOOP.16.PACKAGE")) - (let ((p (make-package "LOOP.16.PACKAGE" :use nil))) - (loop #:for x #:being #:each #:external-symbol #:of p #:count t))) - 0) - -(deftest loop.16.74 - (let () - (ignore-errors (delete-package "LOOP.16.PACKAGE")) - (let ((p (make-package "LOOP.16.PACKAGE" :use nil))) - (loop #:for x #:being #:the #:present-symbols #:of p #:count t))) - 0) - -(deftest loop.16.75 - (let () - (ignore-errors (delete-package "LOOP.16.PACKAGE")) - (let ((p (make-package "LOOP.16.PACKAGE" :use nil))) - (loop #:for x #:being #:each #:present-symbol #:of p #:count t))) - 0) diff --git a/t/ansi-test/iteration/loop17.lsp b/t/ansi-test/iteration/loop17.lsp deleted file mode 100644 index 782fe04..0000000 --- a/t/ansi-test/iteration/loop17.lsp +++ /dev/null @@ -1,145 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Nov 21 09:48:38 2002 -;;;; Contains: Miscellaneous loop tests - - - -;;; Initially and finally take multiple forms, -;;; and execute them in the right order -(deftest loop.17.1 - (loop - with x = 0 - initially (incf x 1) (incf x (+ x x)) - initially (incf x (+ x x x)) - until t - finally (incf x 100) (incf x (+ x x)) - finally (return x)) - 336) - -(deftest loop.17.2 - (loop - with x = 0 - until t - initially (incf x 1) (incf x (+ x x)) - finally (incf x 100) (incf x (+ x x)) - initially (incf x (+ x x x)) - finally (return x)) - 336) - -(deftest loop.17.3 - (let ((x 0)) - (loop - with y = (incf x 1) - initially (incf x 2) - until t - finally (return (values x y)))) - 3 1) - -(deftest loop.17.4 - (loop - doing (return 'a) - finally (return 'b)) - a) - -(deftest loop.17.5 - (loop - return 'a - finally (return 'b)) - a) - -(deftest loop.17.6 - (let ((x 0)) - (tagbody - (loop - do (go done) - finally (incf x)) - done) - x) - 0) - -(deftest loop.17.7 - (let ((x 0)) - (catch 'done - (loop - do (throw 'done nil) - finally (incf x))) - x) - 0) - -(deftest loop.17.8 - (loop - for x in '(1 2 3) - collect x - finally (return 'good)) - good) - -(deftest loop.17.9 - (loop - for x in '(1 2 3) - append (list x) - finally (return 'good)) - good) - -(deftest loop.17.10 - (loop - for x in '(1 2 3) - nconc (list x) - finally (return 'good)) - good) - -(deftest loop.17.11 - (loop - for x in '(1 2 3) - count (> x 1) - finally (return 'good)) - good) - -(deftest loop.17.12 - (loop - for x in '(1 2 3) - sum x - finally (return 'good)) - good) - -(deftest loop.17.13 - (loop - for x in '(1 2 3) - maximize x - finally (return 'good)) - good) - -(deftest loop.17.14 - (loop - for x in '(1 2 3) - minimize x - finally (return 'good)) - good) - -;;; iteration clause grouping - -(deftest loop.17.20 - (loop - for i from 1 to 5 - for j = 0 then (+ j i) - collect j) - (0 2 5 9 14)) - -(deftest loop.17.21 - (loop - for i from 1 to 5 - and j = 0 then (+ j i) - collect j) - (0 1 3 6 10)) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest loop.17.22 - (macrolet - ((%m (z) z)) - (loop with x = 0 - initially (expand-in-current-env (%m (incf x))) - until t - finally (expand-in-current-env (%m (return x))))) - 1) diff --git a/t/ansi-test/iteration/loop2.lsp b/t/ansi-test/iteration/loop2.lsp deleted file mode 100644 index 795e771..0000000 --- a/t/ansi-test/iteration/loop2.lsp +++ /dev/null @@ -1,163 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Oct 26 13:45:45 2002 -;;;; Contains: Tests of the FOR-AS-IN-LIST loop iteration control form, -;;;; and of destructuring in loop forms - - - -(deftest loop.2.1 - (loop for x in '(1 2 3) sum x) - 6) - -(deftest loop.2.2 - (loop for x in '(1 2 3 4) - do (when (evenp x) (return x))) - 2) - -(deftest loop.2.3 - (signals-error (loop for x in '(a . b) collect x) - type-error) - t) - -(deftest loop.2.4 - (let ((x nil)) - (loop for e in '(a b c d) do (push e x)) - x) - (d c b a)) - -(deftest loop.2.5 - (loop for e in '(a b c d e f) by #'cddr - collect e) - (a c e)) - -(deftest loop.2.6 - (loop for e in '(a b c d e f g) by #'cddr - collect e) - (a c e g)) - -(deftest loop.2.7 - (loop for e in '(a b c d e f) - by #'(lambda (l) (and (cdr l) (cons (car l) (cddr l)))) - collect e) - (a a a a a a)) - -(deftest loop.2.8 - (loop for (x . y) in '((a . b) (c . d) (e . f)) - collect (list x y)) - ((a b) (c d) (e f))) - -(deftest loop.2.9 - (loop for (x nil y) in '((a b c) (d e f) (g h i)) - collect (list x y)) - ((a c) (d f) (g i))) - -(deftest loop.2.10 - (loop for (x y) of-type fixnum in '((1 2) (3 4) (5 6)) - collect (+ x y)) - (3 7 11)) - -(deftest loop.2.11 - (loop for (x y) of-type fixnum in '((1 2) (3 4) (5 6)) - collect (+ x y)) - (3 7 11)) - -(deftest loop.2.12 - (loop for (x y) of-type (fixnum fixnum) in '((1 2) (3 4) (5 6)) - collect (+ x y)) - (3 7 11)) - - -(deftest loop.2.13 - (loop for (x . y) of-type (fixnum . fixnum) in '((1 . 2) (3 . 4) (5 . 6)) - collect (+ x y)) - (3 7 11)) - -(deftest loop.2.14 - (signals-error - (loop for x in '(a b c) - for x in '(d e f) collect x) - program-error) - t) - -(deftest loop.2.15 - (signals-error - (loop for (x . x) in '((a b) (c d)) collect x) - program-error) - t) - -(deftest loop.2.16 - (loop for nil in nil do (return t)) - nil) - -(deftest loop.2.17 - (let ((x '(a b c))) - (values - x - (loop for x in '(d e f) collect (list x)) - x)) - (a b c) - ((d) (e) (f)) - (a b c)) - -(deftest loop.2.18 - (loop for x of-type (integer 0 10) in '(2 4 6 7) sum x) - 19) - -;;; Tests of the 'AS' form - -(deftest loop.2.19 - (loop as x in '(1 2 3) sum x) - 6) - -(deftest loop.2.20 - (loop as x in '(a b c) - as y in '(1 2 3) - collect (list x y)) - ((a 1) (b 2) (c 3))) - -(deftest loop.2.21 - (loop as x in '(a b c) - for y in '(1 2 3) - collect (list x y)) - ((a 1) (b 2) (c 3))) - -(deftest loop.2.22 - (loop for x in '(a b c) - as y in '(1 2 3) - collect (list x y)) - ((a 1) (b 2) (c 3))) - -(deftest loop.2.23 - (let (a b (i 0)) - (values - (loop for e in (progn (setf a (incf i)) - '(a b c d e f g)) - by (progn (setf b (incf i)) #'cddr) - collect e) - a b i)) - (a c e g) - 1 2 2) - - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest loop.2.24 - (macrolet - ((%m (z) z)) - (loop for x in (expand-in-current-env (%m '(1 2 3))) sum x)) - 6) - -(deftest loop.2.25 - (macrolet - ((%m (z) z)) - (loop for (x . y) in (expand-in-current-env (%m '((a . b) (c . d) (e . f)))) - collect (list x y))) - ((a b) (c d) (e f))) - -(deftest loop.2.26 - (macrolet - ((%m (z) z)) - (loop as x in (expand-in-current-env (%m '(1 2 3))) sum x)) - 6) diff --git a/t/ansi-test/iteration/loop3.lsp b/t/ansi-test/iteration/loop3.lsp deleted file mode 100644 index f442dd7..0000000 --- a/t/ansi-test/iteration/loop3.lsp +++ /dev/null @@ -1,167 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Oct 27 08:36:36 2002 -;;;; Contains: Tests of FOR-ON-AS-LIST iteration control in LOOP - - - -(deftest loop.3.1 - (loop for x on '(1 2 3) sum (car x)) - 6) - -(deftest loop.3.2 - (loop for x on '(1 2 3 4) - do (when (evenp (car x)) (return x))) - (2 3 4)) - - -(deftest loop.3.3 - (loop for x on '(a b c . d) collect (car x)) - (a b c)) - -(deftest loop.3.4 - (let ((x nil)) - (loop for e on '(a b c d) do (push (car e) x)) - x) - (d c b a)) - -(deftest loop.3.5 - (loop for e on '(a b c d e f) by #'cddr - collect (car e)) - (a c e)) - -(deftest loop.3.6 - (loop for e on '(a b c d e f g) by #'cddr - collect (car e)) - (a c e g)) - -(deftest loop.3.7 - (loop for e on '(a b c d e f) - by #'(lambda (l) (and (cdr l) (cons (car l) (cddr l)))) - collect (car e)) - (a a a a a a)) - -(deftest loop.3.8 - (loop for ((x . y)) on '((a . b) (c . d) (e . f)) - collect (list x y)) - ((a b) (c d) (e f))) - -(deftest loop.3.9 - (loop for ((x nil y)) on '((a b c) (d e f) (g h i)) - collect (list x y)) - ((a c) (d f) (g i))) - -(deftest loop.3.10 - (loop for ((x y)) of-type (fixnum) on '((1 2) (3 4) (5 6)) - collect (+ x y)) - (3 7 11)) - -(deftest loop.3.11 - (loop for ((x y)) of-type (fixnum) on '((1 2) (3 4) (5 6)) - collect (+ x y)) - (3 7 11)) - -(deftest loop.3.12 - (loop for ((x y)) of-type ((fixnum fixnum)) on '((1 2) (3 4) (5 6)) - collect (+ x y)) - (3 7 11)) - -(deftest loop.3.13 - (loop for ((x . y)) of-type ((fixnum . fixnum)) on '((1 . 2) (3 . 4) (5 . 6)) - collect (+ x y)) - (3 7 11)) - -(deftest loop.3.14 - (signals-error - (loop for x on '(a b c) - for x on '(d e f) collect x) - program-error) - t) - -(deftest loop.3.15 - (signals-error (loop for (x . x) on '((a b) (c d)) collect x) - program-error) - t) - -(deftest loop.3.16 - (loop for nil on nil do (return t)) - nil) - -(deftest loop.3.17 - (let ((x '(a b c))) - (values - x - (loop for x on '(d e f) collect x) - x)) - (a b c) - ((d e f) (e f) (f)) - (a b c)) - -(deftest loop.3.18 - (loop for (x) of-type ((integer 0 10)) on '(2 4 6 7) sum x) - 19) - -;;; Tests of the 'AS' form - -(deftest loop.3.19 - (loop as x on '(1 2 3) sum (car x)) - 6) - -(deftest loop.3.20 - (loop as x on '(a b c) - as y on '(1 2 3) - collect (list (car x) (car y))) - ((a 1) (b 2) (c 3))) - -(deftest loop.3.21 - (loop as x on '(a b c) - for y on '(1 2 3) - collect (list (car x) (car y))) - ((a 1) (b 2) (c 3))) - -(deftest loop.3.22 - (loop for x on '(a b c) - as y on '(1 2 3) - collect (list (car x) (car y))) - ((a 1) (b 2) (c 3))) - -(deftest loop.3.23 - (let (a b (i 0)) - (values - (loop for e on (progn (setf a (incf i)) - '(a b c d e f g)) - by (progn (setf b (incf i)) #'cddr) - collect (car e)) - a b i)) - (a c e g) - 1 2 2) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest loop.3.24 - (macrolet - ((%m (z) z)) - (loop for x on (expand-in-current-env (%m '(1 2 3))) sum (car x))) - 6) - -(deftest loop.3.25 - (macrolet - ((%m (z) z)) - (loop for e on (expand-in-current-env (%m '(a b c d e f))) by #'cddr - collect (car e))) - (a c e)) - -(deftest loop.3.26 - (macrolet - ((%m (z) z)) - (loop for e on '(a b c d e f) - by (expand-in-current-env (%m #'cddr)) - collect (car e))) - (a c e)) - -(deftest loop.3.27 - (macrolet - ((%m (z) z)) - (loop as x on (expand-in-current-env (%m '(1 2 3))) sum (car x))) - 6) diff --git a/t/ansi-test/iteration/loop4.lsp b/t/ansi-test/iteration/loop4.lsp deleted file mode 100644 index 06ce79b..0000000 --- a/t/ansi-test/iteration/loop4.lsp +++ /dev/null @@ -1,108 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Oct 27 22:46:39 2002 -;;;; Contains: Tests for LOOP FOR-AS-EQUAL-THEN - - - -(deftest loop.4.1 - (loop - for x = 1 then (1+ x) - until (> x 5) - collect x) - (1 2 3 4 5)) - -(deftest loop.4.2 - (loop - for i from 1 to 10 - for j = (1+ i) collect j) - (2 3 4 5 6 7 8 9 10 11)) - -(deftest loop.4.3 - (loop - for i from 1 to 10 - for j of-type integer = (1+ i) collect j) - (2 3 4 5 6 7 8 9 10 11)) - -(deftest loop.4.4 - (loop for e on '(a b c d e) - for (x . y) = e - collect x) - (a b c d e)) - -(deftest loop.4.5 - (loop for (x . y) = '(a b c d e) then y - while x - collect x) - (a b c d e)) - -;;; Error cases - -(deftest loop.4.6 - (signals-error - (loop for (x . x) = '(nil nil nil) - until x count t) - program-error) - t) - -(deftest loop.4.7 - (signals-error - (macroexpand '(loop for (x . x) = '(nil nil nil) - until x count t)) - program-error) - t) - -(deftest loop.4.8 - (signals-error - (macroexpand '(loop for x = '(nil nil nil) - for x = 1 count x until t)) - program-error) - t) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest loop.4.9 - (macrolet - ((%m (z) z)) - (loop - for x = (expand-in-current-env (%m 1)) then (1+ x) - until (> x 5) - collect x)) - (1 2 3 4 5)) - -(deftest loop.4.10 - (macrolet - ((%m (z) z)) - (loop - for x = 1 then (expand-in-current-env (%m (1+ x))) - until (> x 5) - collect x)) - (1 2 3 4 5)) - -(deftest loop.4.11 - (macrolet - ((%m (z) z)) - (loop - for x = 1 then (1+ x) - until (expand-in-current-env (%m (> x 5))) - collect x)) - (1 2 3 4 5)) - -(deftest loop.4.12 - (macrolet - ((%m (z) z)) - (loop - for x = 1 then (1+ x) - while (expand-in-current-env (%m (<= x 5))) - collect x)) - (1 2 3 4 5)) - -(deftest loop.4.13 - (macrolet - ((%m (z) z)) - (loop - for x = 1 then (1+ x) - until (> x 5) - collect (expand-in-current-env (%m x)))) - (1 2 3 4 5)) diff --git a/t/ansi-test/iteration/loop5.lsp b/t/ansi-test/iteration/loop5.lsp deleted file mode 100644 index 60c2ee7..0000000 --- a/t/ansi-test/iteration/loop5.lsp +++ /dev/null @@ -1,239 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Nov 2 13:52:50 2002 -;;;; Contains: Tests of LOOP clause FOR-AS-ACROSS - - - -(deftest loop.5.1 - (let ((x "abcd")) (loop for e across x collect e)) - (#\a #\b #\c #\d)) - -(deftest loop.5.2 - (let ((x "abcd")) (loop for e across (the string x) collect e)) - (#\a #\b #\c #\d)) - -(deftest loop.5.3 - (let ((x "abcd")) (loop for e across (the simple-string x) collect e)) - (#\a #\b #\c #\d)) - -(deftest loop.5.4 - (loop for e across "abcd" collect e) - (#\a #\b #\c #\d)) - -(deftest loop.5.5 - (loop for e across "abcd" - for i from 1 to 3 collect e) - (#\a #\b #\c)) - -(deftest loop.5.6 - (loop for e of-type base-char across "abcd" - for i from 1 to 3 collect e) - (#\a #\b #\c)) - -(deftest loop.5.7 - (let ((x (make-array '(4) :initial-contents "abcd" :element-type 'base-char))) - (loop for e across (the base-string x) collect e)) - (#\a #\b #\c #\d)) - -(deftest loop.5.8 - (let ((x "abcd")) (loop for e of-type character across x collect e)) - (#\a #\b #\c #\d)) - -(deftest loop.5.10 - (let ((x #*00010110)) - (loop for e across x collect e)) - (0 0 0 1 0 1 1 0)) - -(deftest loop.5.11 - (let ((x #*00010110)) - (loop for e across (the bit-vector x) collect e)) - (0 0 0 1 0 1 1 0)) - -(deftest loop.5.12 - (let ((x #*00010110)) - (loop for e across (the simple-bit-vector x) collect e)) - (0 0 0 1 0 1 1 0)) - -(deftest loop.5.13 - (let ((x #*00010110)) - (loop for e of-type bit across (the simple-bit-vector x) collect e)) - (0 0 0 1 0 1 1 0)) - -(deftest loop.5.14 - (let ((x #*00010110)) - (loop for e of-type bit across x - for i from 1 to 4 collect e)) - (0 0 0 1)) - - -(deftest loop.5.20 - (let ((x (vector 'a 'b 'c 'd))) - (loop for e across x collect e)) - (a b c d)) - -(deftest loop.5.21 - (let ((x (vector 'a 'b 'c 'd))) - (loop for e across (the vector x) collect e)) - (a b c d)) - -(deftest loop.5.22 - (let ((x (vector 'a 'b 'c 'd))) - (loop for e across (the simple-vector x) collect e)) - (a b c d)) - -(deftest loop.5.23 - (let ((x (vector '(a) '(b) '(c) '(d)))) - (loop for (e) across x collect e)) - (a b c d)) - - -(deftest loop.5.30 - (let ((x (make-array '(5) :initial-contents '(a b c d e) - :adjustable t))) - (loop for e across x collect e)) - (a b c d e)) - -(deftest loop.5.32 - (let* ((x (make-array '(5) :initial-contents '(a b c d e))) - (y (make-array '(3) :displaced-to x - :displaced-index-offset 1))) - (loop for e across y collect e)) - (b c d)) - -;;; tests of 'as' form - -(deftest loop.5.33 - (loop as e across "abc" collect e) - (#\a #\b #\c)) - -(deftest loop.5.34 - (loop as e of-type character across "abc" collect e) - (#\a #\b #\c)) - -(deftest loop.5.35 - (loop as e of-type integer across (the simple-vector (coerce '(1 2 3) 'simple-vector)) - sum e) - 6) - -;;; Loop across displaced vectors - -(deftest loop.5.36 - (let* ((a (make-array '(10) :initial-contents '(a b c d e f g h i j))) - (da (make-array '(5) :displaced-to a - :displaced-index-offset 2))) - (loop for e across da collect e)) - (c d e f g)) - -(deftest loop.5.37 - (let* ((a (make-array '(10) :element-type 'base-char - :initial-contents "abcdefghij")) - (da (make-array '(5) :element-type 'base-char - :displaced-to a - :displaced-index-offset 2))) - (loop for e across da collect e)) - (#\c #\d #\e #\f #\g)) - -(deftest loop.5.38 - (let* ((a (make-array '(10) :element-type 'bit - :initial-contents '(0 1 1 0 0 1 0 1 1 1))) - (da (make-array '(5) :element-type 'bit - :displaced-to a - :displaced-index-offset 2))) - (loop for e across da collect e)) - (1 0 0 1 0)) - -(deftest loop.5.39 - (let ((v (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) - :fill-pointer 6))) - (loop for x across v collect x)) - (1 2 3 4 5 6)) - -(deftest loop.5.40 - (loop for i from 1 to 40 - for type = `(unsigned-byte ,i) - for v = (make-array '(10) :initial-contents '(0 0 1 1 0 1 1 1 0 0) - :element-type type) - for r = (loop for x across v collect x) - unless (equal r '(0 0 1 1 0 1 1 1 0 0)) - collect (list i r)) - nil) - -(deftest loop.5.41 - (loop for i from 1 to 40 - for type = `(signed-byte ,i) - for v = (make-array '(10) :initial-contents '(0 0 -1 -1 0 -1 -1 -1 0 0) - :element-type type) - for r = (loop for x across v collect x) - unless (equal r '(0 0 -1 -1 0 -1 -1 -1 0 0)) - collect (list i r)) - nil) - -(deftest loop.5.42 - (let ((vals '(0 0 1 1 0 1 1 1 0 0))) - (loop for type in '(short-float single-float double-float long-float) - for fvals = (loop for v in vals collect (coerce v type)) - for v = (make-array '(10) :initial-contents fvals :element-type type) - for r = (loop for x across v collect x) - unless (equal r fvals) - collect (list fvals r))) - nil) - -(deftest loop.5.43 - (let ((vals '(0 0 1 1 0 1 1 1 0 0))) - (loop for etype in '(short-float single-float double-float long-float) - for type = `(complex ,etype) - for fvals = (loop for v in vals collect (coerce v type)) - for v = (make-array '(10) :initial-contents fvals :element-type type) - for r = (loop for x across v collect x) - unless (equal r fvals) - collect (list fvals r))) - nil) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest loop.5.44 - (macrolet - ((%m (z) z)) - (loop for x across (expand-in-current-env (%m "148X")) collect x)) - (#\1 #\4 #\8 #\X)) - -(deftest loop.5.45 - (macrolet - ((%m (z) z)) - (loop as x across (expand-in-current-env (%m #*00110110)) collect x)) - (0 0 1 1 0 1 1 0)) - -;;; FIXME -;;; Add tests for other specialized array types (integer types, floats, complex) - -;;; Error cases - -(deftest loop.5.error.1 - (signals-error - (loop for (e . e) across (vector '(x . y) '(u . v)) collect e) - program-error) - t) - -(deftest loop.5.error.2 - (signals-error - (loop for e across (vector '(x . y) '(u . v)) - for e from 1 to 5 collect e) - program-error) - t) - -(deftest loop.5.error.3 - (signals-error - (macroexpand - '(loop for (e . e) across (vector '(x . y) '(u . v)) collect e)) - program-error) - t) - -(deftest loop.5.error.4 - (signals-error - (macroexpand - '(loop for e across (vector '(x . y) '(u . v)) - for e from 1 to 5 collect e)) - program-error) - t) diff --git a/t/ansi-test/iteration/loop6.lsp b/t/ansi-test/iteration/loop6.lsp deleted file mode 100644 index fc14489..0000000 --- a/t/ansi-test/iteration/loop6.lsp +++ /dev/null @@ -1,313 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Nov 10 21:13:04 2002 -;;;; Contains: Tests for LOOP-AS-HASH forms - - - -(defparameter *loop.6.alist* - '((a . 1) (b . 2) (c . 3))) - -(defparameter *loop.6.alist.2* - '(("a" . 1) ("b" . 2) ("c" . 3))) - -(defparameter *loop.6.alist.3* - '(((a1 . a2) . 1) ((b1 . b2) . 2) ((c1 . c2) . 3))) - -(defparameter *loop.6.hash.1* - (let ((table (make-hash-table :test #'eq))) - (loop for (key . val) in *loop.6.alist* - do (setf (gethash key table) val)) - table)) - -(defparameter *loop.6.hash.2* - (let ((table (make-hash-table :test #'eql))) - (loop for (key . val) in *loop.6.alist* - do (setf (gethash key table) val)) - table)) - -(defparameter *loop.6.hash.3* - (let ((table (make-hash-table :test #'equal))) - (loop for (key . val) in *loop.6.alist.3* - do (setf (gethash key table) val)) - table)) - -;;; (defparameter *loop.6.hash.4* -;;; (let ((table (make-hash-table :test #'equalp))) -;;; (loop for (key . val) in *loop.6.alist.2* -;;; do (setf (gethash key table) val)) -;;; table)) - -(defparameter *loop.6.hash.5* - (let ((table (make-hash-table :test #'eql))) - (loop for (val . key) in *loop.6.alist.3* - do (setf (gethash key table) val)) - table)) - -(defparameter *loop.6.hash.6* - (let ((table (make-hash-table :test #'eq))) - (loop for (key . val) in *loop.6.alist* - do (setf (gethash key table) (coerce val 'float))) - table)) - -(defparameter *loop.6.hash.7* - (let ((table (make-hash-table :test #'equal))) - (loop for (val . key) in *loop.6.alist.3* - do (setf (gethash (coerce key 'float) table) val)) - table)) - -(defparameter *loop.6.alist.8* - '(((1 . 2) . 1) ((3 . 4) . b) ((5 . 6) . c))) - -(defparameter *loop.6.hash.8* - (let ((table (make-hash-table :test #'equal))) - (loop for (key . val) in *loop.6.alist.8* - do (setf (gethash key table) val)) - table)) - -(defparameter *loop.6.hash.9* - (let ((table (make-hash-table :test #'equal))) - (loop for (val . key) in *loop.6.alist.8* - do (setf (gethash key table) val)) - table)) - -;;; being {each | the} {hash-value | hash-values | hash-key | hash-keys} {in | of } - -(deftest loop.6.1 - (loop for x being the hash-value of *loop.6.hash.1* sum x) - 6) - -(deftest loop.6.2 - (loop for x being the hash-values of *loop.6.hash.1* sum x) - 6) - -(deftest loop.6.3 - (loop for x being each hash-value of *loop.6.hash.1* sum x) - 6) - -(deftest loop.6.4 - (loop for x being each hash-values of *loop.6.hash.1* sum x) - 6) - -(deftest loop.6.5 - (loop for x being the hash-values in *loop.6.hash.1* sum x) - 6) - -(deftest loop.6.6 - (sort (loop for x being the hash-key of *loop.6.hash.1* collect x) - #'symbol<) - (a b c)) - -(deftest loop.6.7 - (sort (loop for x being the hash-keys of *loop.6.hash.1* collect x) - #'symbol<) - (a b c)) - -(deftest loop.6.8 - (sort (loop for x being each hash-key of *loop.6.hash.1* collect x) - #'symbol<) - (a b c)) - -(deftest loop.6.9 - (sort (loop for x being each hash-keys of *loop.6.hash.1* collect x) - #'symbol<) - (a b c)) - -(deftest loop.6.10 - (sort (loop for x being each hash-keys in *loop.6.hash.1* collect x) - #'symbol<) - (a b c)) - -(deftest loop.6.11 - (sort (loop for (u . v) being the hash-keys of *loop.6.hash.3* collect u) - #'symbol<) - (a1 b1 c1)) - -(deftest loop.6.12 - (sort (loop for (u . v) being the hash-keys of *loop.6.hash.3* collect v) - #'symbol<) - (a2 b2 c2)) - -(deftest loop.6.13 - (sort (loop for (u . v) being the hash-values of *loop.6.hash.5* collect u) - #'symbol<) - (a1 b1 c1)) - -(deftest loop.6.14 - (sort (loop for (u . v) being the hash-values of *loop.6.hash.5* collect v) - #'symbol<) - (a2 b2 c2)) - -(deftest loop.6.15 - (sort (loop for k being the hash-keys of *loop.6.hash.1* using (hash-value v) - collect (list k v)) - #'< :key #'second) - ((a 1) (b 2) (c 3))) - -(deftest loop.6.16 - (sort (loop for v being the hash-values of *loop.6.hash.1* using (hash-key k) - collect (list k v)) - #'< :key #'second) - ((a 1) (b 2) (c 3))) - -(deftest loop.6.17 - (sort (loop for (u . nil) being the hash-values of *loop.6.hash.5* collect u) - #'symbol<) - (a1 b1 c1)) - -(deftest loop.6.18 - (sort (loop for (nil . v) being the hash-values of *loop.6.hash.5* collect v) - #'symbol<) - (a2 b2 c2)) - -(deftest loop.6.19 - (loop for nil being the hash-values of *loop.6.hash.5* count t) - 3) - -(deftest loop.6.20 - (loop for nil being the hash-keys of *loop.6.hash.5* count t) - 3) - -(deftest loop.6.21 - (loop for v being the hash-values of *loop.6.hash.5* using (hash-key nil) count t) - 3) - -(deftest loop.6.22 - (loop for k being the hash-keys of *loop.6.hash.5* using (hash-value nil) count t) - 3) - -(deftest loop.6.23 - (loop for v fixnum being the hash-values of *loop.6.hash.1* sum v) - 6) - -(deftest loop.6.24 - (loop for v of-type fixnum being the hash-values of *loop.6.hash.1* sum v) - 6) - -(deftest loop.6.25 - (loop for k fixnum being the hash-keys of *loop.6.hash.5* sum k) - 6) - -(deftest loop.6.26 - (loop for k of-type fixnum being the hash-keys of *loop.6.hash.5* sum k) - 6) - -(deftest loop.6.27 - (loop for k t being the hash-keys of *loop.6.hash.5* sum k) - 6) - -(deftest loop.6.28 - (loop for k of-type t being the hash-keys of *loop.6.hash.5* sum k) - 6) - -(deftest loop.6.29 - (loop for v t being the hash-values of *loop.6.hash.1* sum v) - 6) - -(deftest loop.6.30 - (loop for v of-type t being the hash-values of *loop.6.hash.1* sum v) - 6) - -(deftest loop.6.31 - (loop for v float being the hash-values of *loop.6.hash.6* sum v) - 6.0) - -(deftest loop.6.32 - (loop for v of-type float being the hash-values of *loop.6.hash.6* sum v) - 6.0) - -(deftest loop.6.33 - (loop for k float being the hash-keys of *loop.6.hash.7* sum k) - 6.0) - -(deftest loop.6.34 - (loop for k of-type float being the hash-keys of *loop.6.hash.7* sum k) - 6.0) - -(deftest loop.6.35 - (loop for (k1 . k2) of-type (integer . integer) being the hash-keys - of *loop.6.hash.8* sum (+ k1 k2)) - 21) - -(deftest loop.6.36 - (loop for (v1 . v2) of-type (integer . integer) being the hash-values - of *loop.6.hash.9* sum (+ v1 v2)) - 21) - -(deftest loop.6.37 - (loop for v being the hash-values of *loop.6.hash.8* - using (hash-key (k1 . k2)) sum (+ k1 k2)) - 21) - -(deftest loop.6.38 - (loop for k being the hash-keys of *loop.6.hash.9* - using (hash-value (v1 . v2)) sum (+ v1 v2)) - 21) - -(deftest loop.6.39 - (loop as x being the hash-value of *loop.6.hash.1* sum x) - 6) - -(deftest loop.6.40 - (sort (loop as x being the hash-key of *loop.6.hash.1* collect x) - #'symbol<) - (a b c)) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest loop.6.41 - (macrolet - ((%m (z) z)) - (loop for x being the hash-value of - (expand-in-current-env (%m *loop.6.hash.1*)) sum x)) - 6) - -(deftest loop.6.42 - (macrolet - ((%m (z) z)) - (sort (loop for x being the hash-key of - (expand-in-current-env (%m *loop.6.hash.1*)) collect x) - #'symbol<)) - (a b c)) - -;;; Error tests - -(deftest loop.6.error.1 - (signals-error - (loop for k from 1 to 10 - for k being the hash-keys of *loop.6.hash.1* - count t) - program-error) - t) - -(deftest loop.6.error.2 - (signals-error - (loop for k being the hash-keys of *loop.6.hash.1* - for k from 1 to 10 - count t) - program-error) - t) - -(deftest loop.6.error.3 - (signals-error - (loop for (k . k) being the hash-keys of *loop.6.hash.3* - count t) - program-error) - t) - -(deftest loop.6.error.4 - (signals-error - (loop for k being the hash-keys of *loop.6.hash.3* - using (hash-value k) - count t) - program-error) - t) - -(deftest loop.6.error.5 - (signals-error - (loop for k being the hash-values of *loop.6.hash.3* - using (hash-key k) - count t) - program-error) - t) diff --git a/t/ansi-test/iteration/loop7.lsp b/t/ansi-test/iteration/loop7.lsp deleted file mode 100644 index 2c0f218..0000000 --- a/t/ansi-test/iteration/loop7.lsp +++ /dev/null @@ -1,244 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Nov 11 21:40:05 2002 -;;;; Contains: Tests for FOR-AS-PACKAGE clause for LOOP - - - -(defpackage "LOOP.CL-TEST.1" - (:use) - (:intern "FOO" "BAR" "BAZ") - (:export "A" "B" "C")) - -(defpackage "LOOP.CL-TEST.2" - (:use "LOOP.CL-TEST.1") - (:intern "X" "Y" "Z")) - -(deftest loop.7.1 - (sort (mapcar #'symbol-name - (loop for x being the symbols of "LOOP.CL-TEST.1" collect x)) - #'string<) - ("A" "B" "BAR" "BAZ" "C" "FOO")) - -(deftest loop.7.2 - (sort (mapcar #'symbol-name - (loop for x being each symbol of "LOOP.CL-TEST.1" collect x)) - #'string<) - ("A" "B" "BAR" "BAZ" "C" "FOO")) - -(deftest loop.7.3 - (sort (mapcar #'symbol-name - (loop for x being the symbol of "LOOP.CL-TEST.1" collect x)) - #'string<) - ("A" "B" "BAR" "BAZ" "C" "FOO")) - -(deftest loop.7.4 - (sort (mapcar #'symbol-name - (loop for x being each symbols of "LOOP.CL-TEST.1" collect x)) - #'string<) - ("A" "B" "BAR" "BAZ" "C" "FOO")) - -(deftest loop.7.5 - (sort (mapcar #'symbol-name - (loop for x being the symbols in "LOOP.CL-TEST.1" collect x)) - #'string<) - ("A" "B" "BAR" "BAZ" "C" "FOO")) - -(deftest loop.7.6 - (sort (mapcar #'symbol-name - (loop for x being each symbol in "LOOP.CL-TEST.1" collect x)) - #'string<) - ("A" "B" "BAR" "BAZ" "C" "FOO")) - -(deftest loop.7.7 - (sort (mapcar #'symbol-name - (loop for x being the symbol in "LOOP.CL-TEST.1" collect x)) - #'string<) - ("A" "B" "BAR" "BAZ" "C" "FOO")) - -(deftest loop.7.8 - (sort (mapcar #'symbol-name - (loop for x being each symbols in "LOOP.CL-TEST.1" collect x)) - #'string<) - ("A" "B" "BAR" "BAZ" "C" "FOO")) - -(deftest loop.7.9 - (sort (mapcar #'symbol-name - (loop for x being the external-symbols of "LOOP.CL-TEST.1" collect x)) - #'string<) - ("A" "B" "C")) - -(deftest loop.7.10 - (sort (mapcar #'symbol-name - (loop for x being each external-symbol in "LOOP.CL-TEST.1" collect x)) - #'string<) - ("A" "B" "C")) - -(deftest loop.7.11 - (sort (mapcar #'symbol-name - (loop for x being each external-symbol in (find-package "LOOP.CL-TEST.1") collect x)) - #'string<) - ("A" "B" "C")) - -(deftest loop.7.12 - (sort (mapcar #'symbol-name - (loop for x being each external-symbol in :LOOP.CL-TEST.1 collect x)) - #'string<) - ("A" "B" "C")) - -(deftest loop.7.13 - (sort (mapcar #'symbol-name - (loop for x being the symbols of "LOOP.CL-TEST.2" collect x)) - #'string<) - ("A" "B" "C" "X" "Y" "Z")) - -(deftest loop.7.14 - (sort (mapcar #'symbol-name - (loop for x being the present-symbols of "LOOP.CL-TEST.2" collect x)) - #'string<) - ("X" "Y" "Z")) - -;;; According to the ANSI CL spec, "If the package for the iteration -;;; is not supplied, the current package is used." Thse next tests -;;; are of the cases that the package is not supplied in the loop -;;; form. - -(deftest loop.7.15 - (let ((*package* (find-package "LOOP.CL-TEST.1"))) - (sort (mapcar #'symbol-name (loop for x being each symbol collect x)) - #'string<)) - ("A" "B" "BAR" "BAZ" "C" "FOO")) - -(deftest loop.7.16 - (let ((*package* (find-package "LOOP.CL-TEST.1"))) - (sort (mapcar #'symbol-name (loop for x being each external-symbol collect x)) - #'string<)) - ("A" "B" "C")) - -(deftest loop.7.17 - (let ((*package* (find-package "LOOP.CL-TEST.2"))) - (sort (mapcar #'symbol-name (loop for x being each present-symbol collect x)) - #'string<)) - ("X" "Y" "Z")) - -;;; Cases where the package doesn't exist. According to the standard, -;;; (section 6.1.2.1.7), this should cause a pacakge-error. - -(deftest loop.7.18 - (let () - (ignore-errors (delete-package "LOOP.MISSING.PACKAGE")) - (signals-error - (loop for x being each symbol of "LOOP.MISSING.PACKAGE" collect x) - package-error)) - t) - -(deftest loop.7.19 - (let () - (ignore-errors (delete-package "LOOP.MISSING.PACKAGE")) - (signals-error - (loop for x being each present-symbol of "LOOP.MISSING.PACKAGE" - collect x) - package-error)) - t) - -(deftest loop.7.20 - (let () - (ignore-errors (delete-package "LOOP.MISSING.PACKAGE")) - (signals-error - (loop for x being each external-symbol of "LOOP.MISSING.PACKAGE" - collect x) - package-error)) - t) - -;;; NIL d-var-specs - -(deftest loop.7.21 - (loop for nil being the symbols of "LOOP.CL-TEST.1" count t) - 6) - -(deftest loop.7.22 - (loop for nil being the external-symbols of "LOOP.CL-TEST.1" count t) - 3) - -(deftest loop.7.23 - (loop for nil being the present-symbols of "LOOP.CL-TEST.2" count t) - 3) - -;;; Type specs - -(deftest loop.7.24 - (loop for x t being the symbols of "LOOP.CL-TEST.1" count x) - 6) - -(deftest loop.7.25 - (loop for x t being the external-symbols of "LOOP.CL-TEST.1" count x) - 3) - -(deftest loop.7.26 - (loop for x t being the present-symbols of "LOOP.CL-TEST.2" count x) - 3) - -(deftest loop.7.27 - (loop for x of-type symbol being the symbols of "LOOP.CL-TEST.1" count x) - 6) - -(deftest loop.7.28 - (loop for x of-type symbol being the external-symbols of "LOOP.CL-TEST.1" count x) - 3) - -(deftest loop.7.29 - (loop for x of-type symbol being the present-symbols of "LOOP.CL-TEST.2" count x) - 3) - -;;; Tests of the 'as' form - -(deftest loop.7.30 - (sort (mapcar #'symbol-name - (loop as x being the symbols of "LOOP.CL-TEST.1" collect x)) - #'string<) - ("A" "B" "BAR" "BAZ" "C" "FOO")) - -(deftest loop.7.31 - (sort (mapcar #'symbol-name - (loop as x being each symbol of "LOOP.CL-TEST.1" collect x)) - #'string<) - ("A" "B" "BAR" "BAZ" "C" "FOO")) - -(deftest loop.7.32 - (sort (mapcar #'symbol-name - (loop as x being the symbol of "LOOP.CL-TEST.1" collect x)) - #'string<) - ("A" "B" "BAR" "BAZ" "C" "FOO")) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest loop.7.33 - (macrolet - ((%m (z) z)) - (sort (mapcar #'symbol-name - (loop for x being the symbols of - (expand-in-current-env (%m "LOOP.CL-TEST.1")) - collect x)) - #'string<)) - ("A" "B" "BAR" "BAZ" "C" "FOO")) - -(deftest loop.7.34 - (macrolet - ((%m (z) z)) - (sort (mapcar #'symbol-name - (loop for x being the external-symbols of - (expand-in-current-env (%m "LOOP.CL-TEST.1")) - collect x)) - #'string<)) - ("A" "B" "C")) - -(deftest loop.7.35 - (macrolet - ((%m (z) z)) - (sort (mapcar #'symbol-name - (loop for x being the present-symbols of - (expand-in-current-env (%m "LOOP.CL-TEST.2")) - collect x)) - #'string<)) - ("X" "Y" "Z")) diff --git a/t/ansi-test/iteration/loop8.lsp b/t/ansi-test/iteration/loop8.lsp deleted file mode 100644 index eb87de1..0000000 --- a/t/ansi-test/iteration/loop8.lsp +++ /dev/null @@ -1,152 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Nov 12 06:30:14 2002 -;;;; Contains: Tests of LOOP local variable initialization - - - -(deftest loop.8.1 - (loop with x = 1 do (return x)) - 1) - -(deftest loop.8.2 - (loop with x = 1 - with y = (1+ x) do (return (list x y))) - (1 2)) - -(deftest loop.8.3 - (let ((y 2)) - (loop with x = y - with y = (1+ x) do (return (list x y)))) - (2 3)) - -(deftest loop.8.4 - (let (a b) - (loop with a = 1 - and b = (list a) - and c = (list b) - return (list a b c))) - (1 (nil) (nil))) - - -;;; type specs - -(deftest loop.8.5 - (loop with a t = 1 return a) - 1) - -(deftest loop.8.6 - (loop with a fixnum = 2 return a) - 2) - -(deftest loop.8.7 - (loop with a float = 3.0 return a) - 3.0) - -(deftest loop.8.8 - (loop with a of-type string = "abc" return a) - "abc") - -(deftest loop.8.9 - (loop with (a b) = '(1 2) return (list b a)) - (2 1)) - -(deftest loop.8.10 - (loop with (a b) of-type (fixnum fixnum) = '(3 4) return (+ a b)) - 7) - -(deftest loop.8.11 - (loop with a of-type fixnum return a) - 0) - -(deftest loop.8.12 - (loop with a of-type float return a) - 0.0) - -(deftest loop.8.13 - (loop with a of-type t return a) - nil) - -(deftest loop.8.14 - (loop with a t return a) - nil) - -(deftest loop.8.15 - (loop with a t and b t return (list a b)) - (nil nil)) - -(deftest loop.8.16 - (loop with (a b c) of-type (fixnum float t) return (list a b c)) - (0 0.0 nil)) - -(deftest loop.8.17 - (loop with nil = nil return nil) - nil) - -;;; The NIL block of a loop encloses the entire loop. - -(deftest loop.8.18 - (loop with nil = (return t) return nil) - t) - -(deftest loop.8.19 - (loop with (nil a) = '(1 2) return a) - 2) - -(deftest loop.8.20 - (loop with (a nil) = '(1 2) return a) - 1) - -(deftest loop.8.21 - (loop with b = 3 - and (a nil) = '(1 2) return (list a b)) - (1 3)) - -(deftest loop.8.22 - (loop with b = 3 - and (nil a) = '(1 2) return (list a b)) - (2 3)) - -;;; The NIL block of a loop encloses the entire loop. - -(deftest loop.8.23 - (loop - with a = 1 - and b = (return 2) - return 3) - 2) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest loop.8.24 - (macrolet - ((%m (z) z)) - (loop with x = (expand-in-current-env (%m 1)) do (return x))) - 1) - -;;; Error cases - -;;; The spec says (in section 6.1.1.7) that: -;;; "An error of type program-error is signaled (at macro expansion time) -;;; if the same variable is bound twice in any variable-binding clause -;;; of a single loop expression. Such variables include local variables, -;;; iteration control variables, and variables found by destructuring." -;;; -;;; This is somewhat ambiguous. Test loop.8.error.1 binds A twice in -;;; the same clause, but loop.8.error.2 binds A in two different clauses. -;;; I am interpreting the spec as ruling out the latter as well. - -(deftest loop.8.error.1 - (signals-error - (loop with a = 1 - and a = 2 return a) - program-error) - t) - -(deftest loop.8.error.2 - (signals-error - (loop with a = 1 - with a = 2 return a) - program-error) - t) diff --git a/t/ansi-test/iteration/loop9.lsp b/t/ansi-test/iteration/loop9.lsp deleted file mode 100644 index 5da18d4..0000000 --- a/t/ansi-test/iteration/loop9.lsp +++ /dev/null @@ -1,265 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Nov 14 06:25:21 2002 -;;;; Contains: Tests for loop list accumulation clauses - - - -;;; Tests of COLLECT, COLLECTING - -(deftest loop.9.1 - (loop for x in '(2 3 4) collect (1+ x)) - (3 4 5)) - -(deftest loop.9.2 - (loop for x in '(2 3 4) collecting (1+ x)) - (3 4 5)) - -(deftest loop.9.3 - (loop for x in '(0 1 2) - when (eql x 2) do (return 'good) - collect x) - good) - -(deftest loop.9.4 - (loop for x in '(a b c) - collect (list x) into foo - finally (return (reverse foo))) - ((c) (b) (a))) - -(deftest loop.9.5 - (loop for x in '(a b c) - collecting (list x) into foo - finally (return (reverse foo))) - ((c) (b) (a))) - -(deftest loop.9.6 - (loop for x from 1 to 10 - when (evenp x) collect x into foo - when (oddp x) collect x into bar - finally (return (list foo bar))) - ((2 4 6 8 10) (1 3 5 7 9))) - -(deftest loop.9.7 - (loop for x from 1 to 10 - collect (if (> x 5) (loop-finish) x)) - (1 2 3 4 5)) - -(deftest loop.9.8 - (loop for x from 1 to 20 - when (eql (mod x 5) 0) collect x into foo - when (eql (mod x 5) 2) collect x into foo - finally (return foo)) - (2 5 7 10 12 15 17 20)) - -(deftest loop.9.9 - (loop for x from 1 to 20 - when (eql (mod x 5) 0) collecting x into foo - when (eql (mod x 5) 2) collecting x into foo - finally (return foo)) - (2 5 7 10 12 15 17 20)) - -(deftest loop.9.10 - (signals-error - (loop with foo = '(a b) - for x in '(c d) collect x into foo - finally (return foo)) - program-error) - t) - -(deftest loop.9.11 - (signals-error - (loop with foo = '(a b) - for x in '(c d) collecting x into foo - finally (return foo)) - program-error) - t) - -(deftest loop.9.12 - (let ((foo '(a b))) - (values - (loop for x in '(c d e) collect x into foo finally (return foo)) - foo)) - (c d e) - (a b)) - -;;; Tests of APPEND, APPENDING - -(deftest loop.9.20 - (loop for x in '((a b) (c d) (e f g) () (i)) append x) - (a b c d e f g i)) - -(deftest loop.9.21 - (loop for x in '((a b) (c d) (e f g) () (i)) appending x) - (a b c d e f g i)) - -(deftest loop.9.22 - (loop for x in '((a) (b) (c . whatever)) append x) - (a b c . whatever)) - -(deftest loop.9.23 - (loop for x in '((a) (b) (c . whatever)) appending x) - (a b c . whatever)) - -(deftest loop.9.24 - (loop for x in '(a b c d) - append (list x) - when (eq x 'b) append '(1 2 3) - when (eq x 'd) appending '(4 5 6)) - (a b 1 2 3 c d 4 5 6)) - -(deftest loop.9.25 - (let (z) - (values - (loop for x in '((a) (b) (c) (d)) - append x into foo - finally (setq z foo)) - z)) - nil - (a b c d)) - -(deftest loop.9.26 - (loop for x in '((a) (b) (c) (d)) - for i from 1 - append x into foo - append x into foo - appending (list i) into foo - finally (return foo)) - (a a 1 b b 2 c c 3 d d 4)) - -(deftest loop.9.27 - (signals-error - (loop with foo = '(a b) - for x in '(c d) append (list x) into foo - finally (return foo)) - program-error) - t) - -(deftest loop.9.28 - (signals-error - (loop with foo = '(a b) - for x in '(c d) appending (list x) into foo - finally (return foo)) - program-error) - t) - - -;;; NCONC, NCONCING - -(deftest loop.9.30 - (loop for x in '((a b) (c d) (e f g) () (i)) nconc (copy-seq x)) - (a b c d e f g i)) - -(deftest loop.9.31 - (loop for x in '((a b) (c d) (e f g) () (i)) nconcing (copy-seq x)) - (a b c d e f g i)) - -(deftest loop.9.32 - (loop for x in '((a) (b) (c . whatever)) nconc (cons (car x) (cdr x))) - (a b c . whatever)) - -(deftest loop.9.33 - (loop for x in '((a) (b) (c . whatever)) nconcing (cons (car x) (cdr x))) - (a b c . whatever)) - -(deftest loop.9.34 - (loop for x in '(a b c d) - nconc (list x) - when (eq x 'b) nconc (copy-seq '(1 2 3)) - when (eq x 'd) nconcing (copy-seq '(4 5 6))) - (a b 1 2 3 c d 4 5 6)) - -(deftest loop.9.35 - (let (z) - (values - (loop for x in '((a) (b) (c) (d)) - nconc (copy-seq x) into foo - finally (setq z foo)) - z)) - nil - (a b c d)) - -(deftest loop.9.36 - (loop for x in '((a) (b) (c) (d)) - for i from 1 - nconc (copy-seq x) into foo - nconc (copy-seq x) into foo - nconcing (list i) into foo - finally (return foo)) - (a a 1 b b 2 c c 3 d d 4)) - -(deftest loop.9.37 - (signals-error - (loop with foo = '(a b) - for x in '(c d) nconc (list x) into foo - finally (return foo)) - program-error) - t) - -(deftest loop.9.38 - (signals-error - (loop with foo = '(a b) - for x in '(c d) nconcing (list x) into foo - finally (return foo)) - program-error) - t) - -;;; Combinations - -(deftest loop.9.40 - (loop for x in '(1 2 3 4 5 6 7) - if (< x 2) append (list x) - else if (< x 5) nconc (list (1+ x)) - else collect (+ x 2)) - (1 3 4 5 7 8 9)) - -(deftest loop.9.41 - (loop for x in '(1 2 3 4 5 6 7) - if (< x 2) append (list x) into foo - else if (< x 5) nconc (list (1+ x)) into foo - else collect (+ x 2) into foo - finally (return foo)) - (1 3 4 5 7 8 9)) - -;;; More nconc tests - -(deftest loop.9.42 - (loop for x in '(a b c d e) nconc (cons x 'foo)) - (a b c d e . foo)) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest loop.9.43 - (macrolet - ((%m (z) z)) - (loop for x in '(1 2 3) collect (expand-in-current-env (%m (- x))))) - (-1 -2 -3)) - -(deftest loop.9.44 - (macrolet - ((%m (z) z)) - (loop for x in '(1 2 3) collecting (expand-in-current-env (%m (list x))))) - ((1) (2) (3))) - -(deftest loop.9.45 - (macrolet - ((%m (z) z)) - (loop for x in '(a b c) - collect (expand-in-current-env (%m (list x))) into foo - finally (return (reverse foo)))) - ((c) (b) (a))) - -(deftest loop.9.46 - (macrolet - ((%m (z) z)) - (loop for x in '((a b) (c d) (e f g) () (i)) - append (expand-in-current-env (%m x)))) - (a b c d e f g i)) - -(deftest loop.9.47 - (macrolet - ((%m (z) z)) - (loop for x in '((a b) (c d) (e f g) () (i)) - nconc (expand-in-current-env (%m (copy-seq x))))) - (a b c d e f g i)) diff --git a/t/ansi-test/make-tar b/t/ansi-test/make-tar deleted file mode 100755 index cb7257b..0000000 --- a/t/ansi-test/make-tar +++ /dev/null @@ -1,2 +0,0 @@ -rm -f binary/* rt/binary/* -tar cvf cltest.tar README *.system *.lsp make-tar binary/ rt/*.system rt/*.lsp rt/*.txt rt/binary/ diff --git a/t/ansi-test/makefile b/t/ansi-test/makefile deleted file mode 100644 index 99cb36f..0000000 --- a/t/ansi-test/makefile +++ /dev/null @@ -1,150 +0,0 @@ -# LISP=gcl -# LISP=../unixport/saved_ansi_gcl -# LISP=sbcl --noinform -# LISP=~/sbcl/src/runtime/sbcl --core ~/sbcl/output/sbcl.core --noinform -# LISP=clisp -ansi -q -# LISP=abcl -LISP=ecl -# LISP=/usr/local/lib/LispWorks/nongraphic-lispworks-4450 -# LISP=acl - -MAKE=make - -test: - @rm -rf sandbox/scratch - cat doit.lsp | $(LISP) | tee test.out - -test-symbols: - (cat doit1.lsp ; echo "(load \"symbols/load.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-symbols.out - -test-eval-and-compile: - (cat doit1.lsp ; echo "(load \"eval-and-compile/load.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-eval-and-compile.out - -test-data-and-control-flow: - (cat doit1.lsp ; echo "(load \"data-and-control-flow/load.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-data-and-control-flow.out - -test-iteration: - (cat doit1.lsp ; echo "(load \"iteration/load.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-iteration.out - -test-objects: - (cat doit1.lsp ; echo "(load \"objects/load.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-objects.out - -test-conditions: - (cat doit1.lsp ; echo "(load \"conditions/load.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-conditions.out - -test-cons: - (cat doit1.lsp ; echo "(load \"cons/load.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-cons.out - -test-arrays: - (cat doit1.lsp ; echo "(load \"arrays/load.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-arrays.out - -test-hash-tables: - (cat doit1.lsp ; echo "(load \"hash-tables/load.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-hash-tables.out - -test-packages: - (cat doit1.lsp ; echo "(load \"packages/load.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-packages.out - -test-numbers: - (cat doit1.lsp ; echo "(load \"numbers/load.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-numbers.out - -test-sequences: - (cat doit1.lsp ; echo "(load \"sequences/load.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-sequences.out - -test-structures: - (cat doit1.lsp ; echo "(load \"structures/load.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-structures.out - -test-types-and-class: - (cat doit1.lsp ; echo "(load \"types-and-class/load.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-types-and-class.out - -test-strings: - (cat doit1.lsp ; echo "(load \"strings/load.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-strings.out - -test-characters: - (cat doit1.lsp ; echo "(load \"characters/load.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-characters.out - -test-pathnames: - (cat doit1.lsp ; echo "(load \"pathnames/load.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-pathnames.out - -test-files: - (cat doit1.lsp ; echo "(load \"files/load.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-files.out - -test-streams: - (cat doit1.lsp ; echo "(load \"streams/load.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-streams.out - -test-printer: - (cat doit1.lsp ; echo "(load \"printer/load.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-printer.out - -test-reader: - (cat doit1.lsp ; echo "(load \"reader/load.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-reader.out - -test-system-construction: - (cat doit1.lsp ; echo "(load \"system-construction/load.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-system-construction.out - -test-environment: - (cat doit1.lsp ; echo "(load \"environment/load.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-environment.out - -test-misc: - (cat doit1.lsp ; echo "(load \"misc/load.lsp\")"; cat doit2.lsp) | $(LISP) | tee test-misc.out - -test-all: test-symbols test-eval-and-compile test-data-and-control-flow test-iteration test-objects \ - test-conditions test-cons test-arrays test-hash-tables test-packages test-numbers \ - test-sequences test-structures test-types-and-class test-strings test-characters test-pathnames \ - test-files test-streams test-printer test-reader test-system-construction test-environment \ - test-misc - -test-compiled: - @rm -rf scratch - echo "(load \"compileit.lsp\")" | $(LISP) | tee test.out - -test-unixport: - echo "(load \"doit.lsp\")" | ../unixport/saved_ansi_gcl | tee test.out - -random-test: - (echo "(progn #+gcl (setq compiler::*cc* \"gcc -c -DVOL=volatile -fsigned-char -pipe \") \ - (setq *load-verbose* nil) \ - (let* ((*standard-output* (make-broadcast-stream)) \ - (*error-output* *standard-output*)) \ - (load \"gclload1.lsp\") \ - (funcall (symbol-function 'compile-and-load) \"random-int-form.lsp\"))) \ - (in-package :cl-test) \ - (let ((x (cl-test::test-random-integer-forms 1000 3 1000 :random-size t :random-nvars t))) \ - (setq x (cl-test::prune-results x)) \ - (with-open-file (*standard-output* \"failures.lsp\" \ - :direction :output \ - :if-exists :append \ - :if-does-not-exist :create) \ - (mapc #'print x))) \ - #+allegro (excl::exit) \ - ; extra quits added to avoid being trapped in debugger in some lisps \ - (cl-user::quit) \ - (cl-user::quit) \ - (cl-user::quit) \ - (cl-user::quit) \ - (cl-user::quit) \ - (cl-user::quit) \ - (cl-user::quit) \ - (cl-user::quit) \ - (cl-user::quit) \ - (cl-user::quit) \ - (cl-user::quit)") | $(LISP) - rm -f gazonk* - -rt_1000_8: - echo "(load \"gclload1.lsp\") \ - (compile-and-load \"random-int-form.lsp\") \ - (in-package :cl-test) (loop-random-int-forms 1000 8)" | $(LISP) - - -clean: - @rm -f */*.{out,fas,cls,fasl,o,so,~,fn,x86f,ufsl,abcl,lib} - @rm -f */*/*.{out,fas,cls,fasl,o,so,~,fn,x86f,ufsl,abcl,lib} - @rm -f test*.out *.cls *.fasl *.o *.so *~ *.fn *.x86f *.fasl *.ufsl *.abcl *.fas *.lib \#*\# - @rm -f *.dfsl *.d64fsl - @(cd beyond-ansi; $(MAKE) clean) - @rm -rf sandbox/scratch/ sandbox/scratch.txt - @rm -f foo.txt foo.lsp foo.dat - @rm -f tmp.txt tmp.dat tmp2.dat temp.dat - @rm -f gazonk* out.class - @rm -rf TMP/ - @rm -f "CLTEST:file-that-was-renamed.txt" file-that-was-renamed.txt - @rm -f compile-file-test-lp.lsp compile-file-test-lp.out ldtest.lsp diff --git a/t/ansi-test/misc/load.lsp b/t/ansi-test/misc/load.lsp deleted file mode 100644 index cea9999..0000000 --- a/t/ansi-test/misc/load.lsp +++ /dev/null @@ -1,17 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Jun 23 20:14:32 2005 -;;;; Contains: Load misc. tests - -;;; Miscellaneous tests, mostly tests that failed in random testing -;;; on various implementations -(in-package #:cl-test) - -(let ((*default-pathname-defaults* - (make-pathname - :directory (pathname-directory *load-pathname*)))) - (load "misc.lsp") - -;;; Misc. tests dealing with type propagation in CMUCL - (load "misc-cmucl-type-prop.lsp") -) diff --git a/t/ansi-test/misc/misc-cmucl-type-prop.lsp b/t/ansi-test/misc/misc-cmucl-type-prop.lsp deleted file mode 100644 index 8b556ef..0000000 --- a/t/ansi-test/misc/misc-cmucl-type-prop.lsp +++ /dev/null @@ -1,403 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Mar 4 06:21:51 2005 -;;;; Contains: CMUCL type prop failures (moved from misc.lsp) - - - -;;; All these are 'strange template failures' -;;; The comment before each is the NAME of the template in the backtrace -;;; These tests seem to all have (space 2) (speed 3) - -; X86::FAST-LOGAND-C/FIXNUM=>FIXNUM -(deftest cmucl-type-prop.1 - (funcall - (compile - nil - '(lambda (p1) - (declare (optimize (speed 2) (safety 2) (debug 2) (space 3)) - (type (member 2 -4 -211907662 -27215198) p1)) - (logand (the (integer * 161212781) p1) 10600829))) - -27215198) - 2129952) - -; X86::FAST-LOGAND/SIGNED-UNSIGNED=>UNSIGNED -(deftest cmucl-type-prop.2 - (funcall - (compile - nil - '(lambda (p1 p2) - (declare (optimize (speed 2) (safety 1) (debug 3) (space 3)) - (type (integer 1619851121 1619868587) p1) (type (integer * 303689) p2)) - (logandc2 (the (integer -5359291650 1619851136) p1) (the unsigned-byte p2)))) - 1619851124 300065) - 1619551060) - -; X86::FAST-LOGIOR-C/FIXNUM=>FIXNUM -(deftest cmucl-type-prop.3 - (funcall - (compile - nil - '(lambda (p1) - (declare (optimize (speed 2) (safety 3) (debug 0) (space 3)) - (type (integer 59087 63964) p1)) - (logior p1 -65887623))) - 59967) - -65869185) - -; X86::FAST-LOGIOR/FIXNUM=>FIXNUM -(deftest cmucl-type-prop.4 - (funcall - (compile - nil - '(lambda (p1 p2) - (declare (optimize (speed 2) (safety 2) (debug 0) (space 3)) - (type (integer 3585942 72924743) p1) (type (integer -70689 *) p2)) - (logorc2 (the (integer * 8514860) p1) (the (integer 1 411) p2)))) - 3586455 4) - -1) - -; X86::FAST-LOGAND-C/SIGNED=>SIGNED -(deftest cmucl-type-prop.5 - (funcall - (compile - nil - '(lambda (p2) - (declare (optimize (speed 2) (safety 1) (debug 2) (space 3)) - (type (integer -257 *) p2)) - (lognand 1020158769 (the (integer -5275217 2381998) p2)))) - 2) - -1) - -; X86::FAST-LOGAND-C/SIGNED-UNSIGNED=>UNSIGNED -(deftest cmucl-type-prop.6 - (funcall - (compile - nil - '(lambda (p1) - (declare (optimize (speed 2) (safety 1) (debug 0) (space 3)) - (type (integer -96413017 -96297711) p1)) - (lognand p1 3472289945))) - -96413016) - -3393245321) - -; X86::FAST-LOGAND/UNSIGNED-SIGNED=>UNSIGNED -(deftest cmucl-type-prop.7 - (funcall - (compile - nil - '(lambda (p1 p2) - (declare (optimize (speed 2) (safety 3) (debug 2) (space 3)) - (type (integer 438294 891242) p1) - (type (member 16317 -15 -541332155 33554427) p2)) - (logand (the (integer -33116139 1759877902) p1) p2))) - 438295 16317) - 12309) - -; X86::FAST-LOGIOR-C/SIGNED=>SIGNED -(deftest cmucl-type-prop.8 - (funcall - (compile - nil - '(lambda (p1) - (declare (optimize (speed 2) (safety 1) (debug 1) (space 3)) - (type (integer -728025757 -727856169) p1)) - (logorc1 (the (integer -734005577 -727855553) p1) -3311))) - -727856176) - -2241) - -; X86::FAST-LOGXOR/FIXNUM=>FIXNUM -(deftest cmucl-type-prop.9 - (funcall - (compile - nil - '(lambda (p1 p2) - (declare (optimize (speed 2) (safety 3) (debug 3) (space 3)) - (type (integer * 1489068) p1) (type (integer -7455 *) p2)) - (logeqv (the (member 9543 -15 32766 -264472) p1) - (the (integer -524303 11182721) p2)))) - 9543 -8) - 9536) - -; X86::FAST-LOGXOR/SIGNED=>SIGNED -(deftest cmucl-type-prop.10 - (funcall - (compile - nil - '(lambda (p1 p2) - (declare (optimize (speed 2) (safety 1) (debug 3) (space 3)) - (type (integer -616605365 -616598658) p1) (type (eql 499113) p2)) - (logeqv (the real p1) p2))) - -616604953 499113) - 617035953) - -; X86::FAST-LOGXOR-C/FIXNUM=>FIXNUM -(deftest cmucl-type-prop.11 - (funcall - (compile - nil - '(lambda (p1) - (declare (optimize (speed 2) (safety 1) (debug 0) (space 3)) - (type (integer -112225610 *) p1)) - (logeqv (the (integer -2822315666 3) p1) 1679389))) - 1) - -1679389) - -; X86::FAST-LOGXOR-C/SIGNED=>SIGNED -(deftest cmucl-type-prop.12 - (funcall - (compile - nil - '(lambda (p2) - (declare (optimize (speed 2) (safety 3) (debug 0) (space 3)) - (type (integer -67 268435455) p2)) - (logeqv 1038360149 (the (integer -3605943309) p2)))) - -1) - 1038360149) - -; X86::-/SINGLE-FLOAT -(deftest cmucl-type-prop.13 - (notnot - (typep - (funcall - (compile - nil - '(lambda (p1) - (declare (optimize (speed 2) (safety 2) (debug 1) (space 3)) - (type (eql 64848.973) p1)) - (- (the (eql 64848.973f0) p1) -2808/1031))) - 64848.973f0) - 'single-float)) - t) - -; X86::-/DOUBLE-FLOAT -(deftest cmucl-type-prop.14 - (notnot - (typep - (funcall - (compile - nil - '(lambda (p2) - (declare (optimize (speed 2) (safety 1) (debug 1) (space 3)) - (type (integer 9297 *) p2)) - (- 54090.82691488265d0 (the (integer * 1263530808) p2)))) - 9590) - 'double-float)) - t) - -; X86::-/SINGLE-FLOAT -(deftest cmucl-type-prop.15 - (notnot - (typep - (funcall - (compile - nil - '(lambda (p1) - (declare (optimize (speed 2) (safety 3) (debug 3) (space 3)) - (type (eql 328536/53893) p1)) - (- p1 59218.633f0))) - 328536/53893) - 'single-float)) - t) - -; X86::FAST--/FIXNUM=>FIXNUM -(deftest cmucl-type-prop.16 - (funcall - (compile nil '(lambda (p2) - (declare (optimize (speed 2) (safety 2) (debug 3) (space 3)) - (type (integer -605782 -28141) p2)) - (- -61118 p2))) - -28225) - -32893) - -; X86::FAST---C/FIXNUM=>FIXNUM -(deftest cmucl-type-prop.17 - (funcall - (compile nil '(lambda (p1) - (declare (optimize (speed 2) (safety 1) (debug 1) (space 3)) - (type (integer 5535202) p1)) - (- (the (integer * 27858177) p1) 405))) - 5535436) - 5535031) - -; X86::FAST--/SIGNED=>SIGNED -(deftest cmucl-type-prop.18 - (funcall - (compile nil '(lambda (p2) - (declare (optimize (speed 2) (safety 2) (debug 2) (space 3)) - (type (integer -1175231414 -3471291) p2)) - (- -440 p2))) - -3536832) - 3536392) - -; X86::FAST-+-C/FIXNUM=>FIXNUM -(deftest cmucl-type-prop.19 - (funcall - (compile nil '(lambda (p2) - (declare (optimize (speed 2) (safety 3) (debug 2) (space 3)) - (type (integer -1015240116 5) p2)) - (+ 491841 (the unsigned-byte p2)))) - 0) - 491841) - -; X86::+/DOUBLE-FLOAT -(deftest cmucl-type-prop.20 - (notnot (typep (funcall (compile nil '(lambda (p1) - (declare (optimize (speed 2) (safety 3) (debug 3) (space 3)) - (type (rational -1255531/68466 4) p1)) - (+ p1 41888.98682005542d0))) - -1255531/68466) - 'double-float)) - t) - -; X86::+/SINGLE-FLOAT -(deftest cmucl-type-prop.21 - (notnot (typep (funcall (compile nil '(lambda (p1) - (declare (optimize (speed 2) (safety 2) (debug 1) (space 3)) - (type (integer -284887911 *) p1)) - (+ (the (integer -50006902 19512639861) p1) 68648.28f0))) - -16452463) - 'single-float)) - t) - -; X86::=0/DOUBLE-FLOAT -(deftest cmucl-type-prop.22 - (funcall (compile nil '(lambda (p1) - (declare (optimize (speed 2) (safety 3) (debug 1) (space 3)) - (type (complex double-float) p1)) - (= p1 -1590311/896933))) - #c(1.0d0 1.0d0)) - nil) - -; X86::=/SINGLE-FLOAT -(deftest cmucl-type-prop.23 - (funcall (compile nil '(lambda (p2) - (declare (optimize (speed 2) (safety 2) (debug 1) (space 3)) - (type (complex single-float) p2)) - (= -976855 (the (eql #c(-57420.04 806984.0)) p2)))) - #c(-57420.04f0 806984.0f0)) - nil) - -; X86::FAST-EQL/FIXNUM -(deftest cmucl-type-prop.24 - (notnot - (funcall (compile nil '(lambda (p1 p2) - (declare (optimize (speed 2) (safety 1) (debug 3) (space 3)) - (type (integer -3705845 488458) p1) (type (integer * 869076010) p2)) - (/= p1 (the (integer -69832764 470) p2)))) - 488456 465)) - t) - -; X86::FAST-EQL-C/FIXNUM -(deftest cmucl-type-prop.25 - (notnot - (funcall (compile nil '(lambda (p1) - (declare (optimize (speed 2) (safety 3) (debug 2) (space 3)) - (type (integer -69741922) p1)) - (/= (the (integer * 216) p1) 182))) - 103)) - t) - -; X86::FAST-IF->-C/FIXNUM -(deftest cmucl-type-prop.26 - (funcall (compile nil '(lambda (p2) - (declare (optimize (speed 2) (safety 2) (debug 3) (space 3)) - (type (integer -451 204073899) p2)) - (< 134799 (the (integer -56 8589934581) p2)))) - -2) - nil) - -; X86::FAST-IF-<-C/FIXNUM -(deftest cmucl-type-prop.27 - (funcall (compile nil '(lambda (p2) - (declare (optimize (speed 2) (safety 2) (debug 2) (space 3)) - (type (integer -93662 *) p2)) - (<= -1 (the (integer -2975848 16770677) p2)))) - -6548) - nil) - -; X86::FAST-+-C/FIXNUM=>FIXNUM -; (simple example) -(deftest cmucl-type-prop.28 - (funcall (compile nil '(lambda (p1) - (declare (optimize (speed 2) (safety 1) (debug 0) (space 3)) - (type (integer -65545 80818) p1)) - (1+ p1))) - -1) - 0) - -; X86::FAST-NEGATE/FIXNUM -(deftest cmucl-type-prop.29 - (funcall (compile nil '(lambda (p1) - (declare (optimize (speed 2) (safety 1) (debug 0) (space 3)) - (type (integer -4194320 11531) p1)) - (- (the (integer -6253866924 34530147) p1)))) - -20) - 20) - -;;; Bug in COPY-SEQ - -(deftest cmucl-type-prop.30 - (let ((a (funcall - (compile nil `(lambda () - (declare (optimize (speed 2) (safety 2) (debug 0) (space 2))) - (copy-seq - ,(make-array '(0) :adjustable t))))))) - (and (not (adjustable-array-p a)) - (= (length a) 0) - t)) - t) - -; Bug for PACKAGEP - -(deftest cmucl-type-prop.31 - (funcall (compile nil '(lambda (x) - (declare (optimize (speed 2) (space 3))) - (packagep x))) - t) - nil) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; There were many failures in string comparison functions -;;; Some are that C::WIN strange template problem, but others -;;; are not. - -;;; 0 is not of type (INTEGER 0 (0)) -(deftest cmucl-type-prop.32 - (funcall - (compile - nil - '(lambda (p4) - (declare (optimize (speed 1) (safety 1) (debug 1) (space 0)) - (type (integer -2040 9) p4)) - (string< "bbaa" "" :start1 p4))) - 2) - nil) - -;;; 2 is not of type (INTEGER 0 (2)) -(deftest cmucl-type-prop.33 - (funcall - (compile - nil - '(lambda (p4) - (declare (optimize (speed 0) (safety 0) (debug 2) (space 0)) - (type (integer -52340 *) p4)) - (string< "baabbb" "bb" :start2 p4))) - 1) - nil) - -;;; Incorrect return value -(deftest cmucl-type-prop.34 - (funcall - (compile - nil - '(lambda (p1 p4) - (declare (optimize (speed 2) (safety 0) (debug 3) (space 0)) - (type (simple-string) p1) (type real p4)) - (string< (the array p1) - "bbbba" - :start1 (the (integer -16382 *) p4) - :end1 7))) - "J4sPI71C3Xn" 5) - 5) diff --git a/t/ansi-test/misc/misc.lsp b/t/ansi-test/misc/misc.lsp deleted file mode 100644 index ed1a5f5..0000000 --- a/t/ansi-test/misc/misc.lsp +++ /dev/null @@ -1,11697 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Sep 20 09:45:15 2003 -;;;; Contains: Miscellaneous tests - -;;; -;;; This file contains odds-and-ends, mostly tests that came up as -;;; bug-stimulators in various implementations. -;;; - - - -(declaim (special *s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8*)) - -(deftest misc.1 - (funcall - (compile nil '(lambda (b) - (declare (type (integer 8 22337) b)) - (+ b 2607688420))) - 100) - 2607688520) - -(deftest misc.2 - (funcall (compile nil - '(lambda (b) (integer-length (dpb b (byte 4 28) -1005)))) - 12800263) - 32) - -(deftest misc.3 - (funcall - (compile - nil - '(lambda (a b) - (declare (optimize (speed 3) (debug 1))) - (let ((v7 - (let ((v2 (block b5 (return-from b5 (if t b -4))))) - a))) - -65667836))) - 1 2) - -65667836) - -(deftest misc.4 - (funcall - (compile - nil - '(lambda (a b c) - (declare (type (integer -629491 -333) a) - (type (integer -142 1) b) - (type (integer 0 12604) c) - (optimize (speed 3) (safety 1) (debug 1))) - (let ((v6 (block b7 (return-from b7 (if (eql b 0) 1358159 a))))) - b))) - -1000 -17 6143) - -17) - -(deftest misc.5 - (funcall - (compile nil - '(lambda () (* 390 (- (signum (logeqv -8005440 -2310)) - -10604863))))) - 4135896180) - -(deftest misc.6 - (funcall - (compile nil - '(lambda (a c) - (declare (optimize (speed 3) (debug 1))) - (flet ((%f14 () (if c a -486826646))) - (let ((v7 (flet ((%f18 () (%f14))) a))) - (let ((v5 (%f14))) - 0))))) - 10 20) - 0) - -(deftest misc.7 - (funcall (compile nil - '(lambda (c) (declare (optimize (speed 3) (debug 1))) - (flet ((%f18 () -36)) - (flet ((%f13 () - (let () (block b8 (return-from b8 c))))) - (%f18))))) - 10) - -36) - -(deftest misc.8 - (funcall - (compile - nil - '(lambda (a b) - (declare (optimize (speed 3) (debug 1))) - (let ((v3 (flet ((%f12 () (min b (block b2 (return-from b2 a))))) - a))) - (block b7 - (flet ((%f5 () (return-from b7 b))) - (%f5)))))) - 10 20) - 20) - -(deftest misc.9 - (funcall - (compile - nil - '(lambda () - (declare (optimize (speed 3) (debug 1))) - (block b6 - (flet ((%f3 () - (ldb (byte 19 23) - (block b1 - (let () - (- (if nil (return-from b6 89627) - 1160) - (return-from b1 22923))))))) - 1))))) - 1) - -(deftest misc.10 - (funcall - (compile - nil - '(lambda (c) - (declare (optimize (speed 3) (debug 1)) - (type (integer -15417757 5816) c)) - (flet ((%f3 () (if nil -3143 c))) - (block b5 - (let ((v7 (if (< 23613642 (%f3)) c -23097977))) - (let ((v5 - (return-from b5 - (if (eql c v7) - (let ((v6 (%f3))) 4650813) - 782)))) - -4362540)))))) - -10000) - 782) - -(deftest misc.11 - (funcall - (compile - nil - '(lambda (a b c) - (declare (optimize (speed 3) (debug 1))) - (block b8 - (logxor - (let ((v3 (return-from b8 120789657))) 3690) - (block b2 - (flet ((%f9 () - (flet ((%f10 () -1)) - c))) - (flet ((%f3 () (let () (return-from b2 b)))) - a))))))) - 1 2 3) - 120789657) - -(deftest misc.12 - (funcall - (compile - nil - '(lambda (c) - (declare (optimize (speed 3) (safety 1) (debug 1)) - (type (integer -171067 -5) c)) - (flet ((%f16 () - (flet ((%f12 () 439)) - 3358))) - (flet ((%f14 () c)) - (if (%f14) -1 (%f14)))))) - -100) - -1) - -(deftest misc.13 - (funcall - (compile - nil - '(lambda (b c) - (declare (optimize (speed 3) (safety 1) (debug 1)) - (type (integer -1554410 36086789) b) - (type (integer -15033876209 126774299) c) - ) - (block b3 - (flet ((%f9 () - (abs - (flet ((%f5 () - (return-from b3 -2))) - (if (if (<= 1 c) b (%f5)) -65 -47895812))))) - (min - (let ((v3 (let ((v8 (%f9))) b))) b) - (if (= 1364001 (%f9)) - (logeqv (block b5 -2713) -247) - -19)))))) - 0 0) - -2) - -(deftest misc.14 - (funcall - (compile - nil - '(lambda (c) - (declare (notinline logandc1)) - (block b6 - (flet ((%f17 () (return-from b6 c))) - (logandc1 (%f17) - (if 1 - 450967818 - (let ((v1 (%f17))) -17))))))) - 10) - 10) - -(deftest misc.15 - (funcall - (compile - nil - '(lambda (a b) - (declare (optimize (speed 3) (safety 1) (debug 1))) - (flet ((%f6 () a)) - (block b5 - (flet ((%f14 () - (min 17593 (block b1 (return-from b1 b))))) - (block b7 (if (%f6) (return-from b7 28182012) - (return-from b5 0)))))))) - 3 5) - 28182012) - -(deftest misc.16 - (funcall - (compile - nil - '(lambda (a c) - (flet ((%f14 () - (block b6 - (flet ((%f7 () (return-from b6 4))) - (if 587793 (if (%f7) c -23086423) (%f7)))))) - (block b1 - (flet ((%f18 () a)) - (logandc1 (return-from b1 -2781) - (if (%f14) 58647578 -396746))))))) - 1 2) - -2781) - -(deftest misc.17 - (funcall - (compile - nil - '(lambda (a b c) - (declare (optimize (speed 3) (safety 1) (debug 1)) - (type (integer 4 23363) b) - (type (integer -32681 41648) c) - ) - (flet ((%f18 () - (if nil c b))) - (if (if (> -71810514 a) 102077 465393) - (block b3 (if (%f18) (return-from b3 c) c)) - (%f18))))) - 0 10 1000) - 1000) - -(deftest misc.18 - (funcall - (compile - nil - '(lambda (a b c) - (declare (optimize (speed 3) (safety 1) (debug 1)) - (type (integer 7 58010860) a) - (type (integer -3573280 -1) b) - (type (integer -920848 -819) c) - ) - (flet ((%f15 () (if (logbitp 5 a) a c))) - (min (if (%f15) b -39) (if (> 0 -14756) b (%f15)))))) - 8 -1000 -10000) - -1000) - -(deftest misc.19 - (funcall - (compile - nil - '(lambda (a b c) - (declare (type (integer 54 3862515) a) (type (integer -961325 1539) b) - (type (integer 6 31455) c) (ignorable a b c) - (optimize (speed 3) (safety 1) (debug 1))) - (lognor - (flet ((%f13 () b)) (%f13)) - (flet ((%f1 () (return-from %f1 a))) - (labels ((%f3 () (%f1))) - -428))))) - 100 0 200) - 427) - -(deftest misc.20 - (funcall - (compile - nil - '(lambda (a b c) - (declare (type (integer -1 31880308) a) - (type (integer -11374222037 5331202966) b) - (type (integer -483 -1) c) - (ignorable a b c) - (optimize (speed 3) (safety 1) (debug 1))) - (labels ((%f6 () a)) - (if (eql (let ((v9 (%f6))) -50072824) c) - 28146341 - (if (< 119937 21304962) 21304962 (%f6)))))) - 0 0 -1) - 21304962) - -(deftest misc.21 - (funcall - (compile - nil - '(lambda (a b c) - (declare (type (integer 398 3955) a) (type (integer 233 464963) b) - (type (integer -124477 16) c) (ignorable a b c) - (optimize (speed 3) (safety 1) (debug 1))) - (logior - (flet ((%f18 () - -3584768)) - (%f18)) - (flet ((%f1 () - (return-from %f1 c))) - (flet ((%f9 () - (if (%f1) 24181 7))) - 56048))))) - 400 300 0) - -3547152) - -(deftest misc.22 - (funcall - (compile - nil - '(lambda (a b c) - (declare (type (integer -126378 -103) a) - (type (integer -1158604975 1) b) - (type (integer 502 28036) c) - (ignorable a b c) - (optimize (speed 3) (safety 1) (debug 1))) - (labels ((%f13 () c)) - (labels ((%f3 () - (logandc1 - c - (block b6 - (max -73100 - (if b (return-from b6 4935) (%f13))))))) - (%f13))))) - -200 0 1000) - 1000) - -(deftest misc.23 - (funcall - (compile - nil - '(lambda (a b c) - (declare (type (integer 1 18911480) a) - (type (integer -1 48333) b) - (type (integer -3881001767 -1937357) c) - (ignorable a b c) - (optimize (speed 3) (safety 1) (debug 1))) - (labels ((%f10 () c)) - (block b7 - (logorc2 - (* (%f10) - (if (ldb-test (byte 27 1) -11337) - (return-from b7 -2) - 246137101)) - (min (%f10) (return-from b7 -76114))))))) - 1 0 -2000000) - -2) - -(deftest misc.24 - (funcall - (compile - nil - '(lambda (a b c) - (declare (type (integer -1477249397 -10697252) a) - (type (integer -7 54591) b) - (type (integer -102559556 15) c) - (ignorable a b c) - (optimize (speed 3) (safety 1) (debug 1))) - (block b8 - (let ((v1 (return-from b8 a))) - (1+ - (block b3 - (flet ((%f10 () - (min a (return-from b3 -1)))) - 16776220))))))) - -11000000 0 0) - -11000000) - -(deftest misc.25 - (funcall - (compile - nil - '(lambda (a b c) - (declare (type (integer -944 111244) a) - (type (integer 100512 3286178) b) - (type (integer -2170236 -107) c) - (ignorable a b c) - (optimize (speed 3) (safety 1) (debug 1))) - (labels ((%f17 () c)) - (labels ((%f16 () a)) - (if (if (logbitp 10 1029643) t 355) - (if (equal (%f17) b) c a) - (if (= 1325844 (%f16)) -50285 (1- (%f17)))))))) - 0 200000 -200) - 0) - -(deftest misc.26 - (funcall - (compile - nil - '(lambda (c) - (declare (optimize speed)) - (block b5 - (if (logbitp 6 -97) - (let ((v2 (block b8 -42484))) c) - (flet ((%f10 () (return-from b5 -785143))) - (let ((v3 (%f10))) - (%f10))))))) - 0) - -785143) - -(deftest misc.27 - (funcall - (compile - nil - '(lambda (a b c) - (declare (optimize (speed 3) (debug 1))) - (labels ((%f14 () c)) - (logand (%f14) - (labels ((%f15 () (logeqv (let ((v1 b)) c) - (return-from %f15 -1740)))) - (labels ((%f8 () (%f15))) - a)))))) - 5 2 3) - 1) - -(deftest misc.28 - (funcall - (compile - nil - '(lambda (a b c) - (declare - (type (integer 1948 12024) b) - (type (integer -104357939 -252) c) - (optimize (speed 3) (debug 1))) - (flet ((%f18 () c)) - (logandc1 (if (eql b (%f18)) 0 a) - (if (ldb-test (byte 30 30) 1) (%f18) 1) - )))) - 0 2000 -300) - 1) - -(deftest misc.29 - (funcall - (compile - nil - '(lambda (a b c) - (declare (type (integer 661607 10451683348) a) - (type (integer -2 -2) b) - (type (integer 5996117 18803237) c) - (optimize (speed 3) (safety 1) (debug 1))) - (labels ((%f16 () -29)) - (flet ((%f7 () - (labels ((%f1 () a)) - (let () - (block b3 - (if 37101207 - (return-from b3 -5322045) - (let ((v5 b)) - 146099574))))))) - (if (%f16) c c))))) - 1000000 -2 6000000) - 6000000) - -(deftest misc.30 - (funcall - (compile - nil - '(lambda (c) - (declare (type (integer -253 -1) c) - (optimize (speed 3) (safety 1) (debug 1))) - (flet ((%f8 () c)) - (if (= (%f8) 481) (%f8) 1779465)))) - -100) - 1779465) - -(deftest misc.31 - (funcall - (compile nil - '(lambda () (let ((v9 (labels ((%f13 () nil)) nil))) - (let ((v3 (logandc2 97 3))) - (* v3 (- 37391897 (logand v3 -66)))))))) - 3589619040) - -(deftest misc.32 - (funcall - (compile - nil - '(lambda (a d) - (declare (type (integer -8507 26755) a) - (type (integer -393314538 2084485) d) - (optimize (speed 3) (safety 1) (debug 1))) - (gcd - (if (= 0 a) 10 (abs -1)) - (logxor -1 - (min -7580 - (max (logand a 31365125) d)))))) - 1 1) - 1) - -(deftest misc.33 - (funcall - (compile - nil - '(lambda (a b c d) - (declare (type (integer 240 100434465) a) - (optimize (speed 3) (safety 1) (debug 1))) - (logxor - (if (ldb-test (byte 27 4) d) - -1 - (max 55546856 -431)) - (logorc2 - (if (>= 0 b) - (if (> b c) (logandc2 c d) (if (> d 224002) 0 d)) - (signum (logior c b))) - (logior a -1))))) - 256 0 0 0) - 55546856) - -(deftest misc.34 - (funcall - (compile nil - `(lambda (b c) - (declare (type (integer -23228343 2) b) - (type (integer -115581022 512244512) c) - (optimize (speed 3) (safety 1) (debug 1))) - (* (* (logorc2 3 (deposit-field 4667947 (byte 14 26) b)) - (deposit-field b (byte 25 27) -30424886)) - (dpb b (byte 23 29) c) - ))) - 0 0) - 0) - -(deftest misc.35 - (funcall - (compile - nil - '(lambda (c) - (declare (type (integer -5945502333 12668542) c) - (optimize (speed 3))) - (let ((v2 (* c 12))) - (- (max (if (/= 109335113 v2) -26479 v2) - (deposit-field 311 - (byte 14 28) - (min (max 521326 c) -51))))))) - 12668542) - 26479) - -(deftest misc.36 - (funcall - (compile nil - '(lambda () - (declare (notinline + logand) - (optimize (speed 0))) - (logand - (block b5 - (flet ((%f1 () - (return-from b5 -220))) - (let ((v7 (%f1))) - (+ 359749 35728422)))) - -24076)))) - -24284) - -(deftest misc.37 - (funcall - (compile - nil - '(lambda (b) - (declare (notinline -) (optimize (speed 0))) - (- (block b4 - (flet ((%f4 () - (return-from b4 b))) - (%f4)))))) - 10) - -10) - -(deftest misc.38 - (funcall - (compile - nil - '(lambda (x) (declare (type (integer 0 100) x) - (optimize (speed 3) (safety 1))) - (logandc1 x x))) - 79) - 0) - -(deftest misc.39 - (funcall - (compile - nil - '(lambda (x) (declare (type (integer 0 100) x) - (optimize (speed 3) (safety 1))) - (logandc2 x x))) - 79) - 0) - -(deftest misc.40 - (funcall - (compile - nil - '(lambda (x) (declare (type (integer 0 100) x) - (optimize (speed 3) (safety 1))) - (logorc1 x x))) - 79) - -1) - -(deftest misc.41 - (funcall - (compile - nil - '(lambda (x) (declare (type (integer 0 100) x) - (optimize (speed 3) (safety 1))) - (logorc2 x x))) - 79) - -1) - -(deftest misc.42 - (funcall - (compile - nil - '(lambda (x) - (declare (type (integer -100 100) x)) - (ldb (byte 1 32) x))) - -1) - 1) - -(deftest misc.43 - (funcall (compile nil - '(lambda () (flet ((%f2 () 288213285)) - (+ (%f2) (* 13 (%f2))))))) - 4034985990) - - -(deftest misc.44 - (funcall - (compile - nil - '(lambda (a) - (declare (type (integer -917858 964754309) a) - (optimize (speed 3))) - (* 25 (min (max a 171625820) 171626138)))) - 861929141) - 4290653450) - -(deftest misc.45 - (funcall - (compile - nil - '(lambda (b) - (declare (type (integer 21 9673) b) - (optimize (speed 3))) - (* (integer-length -198435631) (+ b 137206182)))) - 6027) - 3841941852) - -(deftest misc.46 - (funcall - (compile - nil - '(lambda (b c) - (declare (type (integer 0 1) b) (optimize (speed 3))) - (flet ((%f2 () (lognor (block b5 138) c))) - (if (not (or (= -67399 b) b)) - (deposit-field (%f2) (byte 11 8) -3) - c)))) - 0 0) - 0) - -(deftest misc.47 - (funcall - (compile - nil - '(lambda (a) - (declare (type (integer -4005718822 -50081775) a) - (optimize (speed 3) (safety 1) (debug 1))) - (lognor (ash a (min 0 a)) a))) - -2878148992) - 0) - -(deftest misc.48 - (funcall - (compile - nil - '(lambda (a) (declare (notinline ash min)) (lognor (ash a (min 0 a)) a))) - -2878148992) - 0) - -(deftest misc.49 - (let ((body '(truncate (logorc1 -996082 C) -2)) - (arg 25337234)) - (values - (funcall (compile nil `(lambda (c) ,body)) arg) - (funcall (compile nil `(lambda (c) (declare (notinline truncate)) - ,body)) arg))) - -13099001 - -13099001) - -(deftest misc.50 - (funcall (compile nil `(lambda (c) - (declare (optimize (speed 3)) - (type (integer 23062188 149459656) c)) - (mod c (min -2 0)))) - 95019853) - -1) - -(deftest misc.51 - (funcall (compile nil `(lambda (b) - (declare (optimize (speed 3)) - (type (integer 2 152044363) b)) - (rem b (min -16 0)))) - 108251912) - 8) - -(deftest misc.53 - (funcall - (compile nil '(lambda () - (let (x) - (block nil - (flet ((%f (y z) (if (> y z) (setq x y) (setq x z)))) - (%f 1 2) - (%f (return 14) 2))) - x)))) - 2) - -(deftest misc.54 - (funcall - (compile nil '(lambda (a c) - (declare (type (integer 8 117873977) a) - (type (integer -131828754 234037511) c) - (optimize (speed 3) (safety 1) (debug 1))) - (* (mod (signum a) (max 50 -358301)) - (* -2320445737132 - (* (* a (deposit-field a (byte 32 19) a)) c))))) - 11386 165297671) - -49725654774521915007942373712) - -(deftest misc.55 - (funcall - (compile nil '(lambda (a b c) - (declare (type (integer -5498929 389890) a) - (type (integer -5029571274946 48793670) b) - (type (integer 9221496 260169518304) c) - (ignorable a b c) - (optimize (speed 3) (safety 1) (debug 1))) - (- (mod 1020122 (min -49 -420)) - (logandc1 - (block b2 - (mod c (min -49 (if t (return-from b2 1582) b)))) - (labels ((%f14 () (mod a (max 76 8)))) - b))))) - -1893077 -2965238893954 30902744890) - 2965238894454) - -(deftest misc.56 - (funcall - (compile nil '(lambda (a c) - (declare (type (integer -8691408487404 -9) a) - (type (integer 266003133 2112105962) c) - (optimize (speed 3) (safety 1) (debug 1))) - (truncate (max (round a) c) (* (* a a) a)))) - -10 266003133) - -266003 - 133) - -(deftest misc.57 - (funcall - (compile nil '(lambda (a b c) - (declare (type (integer -1907 58388940297) a) - (type (integer -646968358 294016) b) - (type (integer -708435313 89383896) c) - (optimize (speed 3) (safety 1) (debug 1))) - (let ((v6 (abs (min a (signum c))))) - (if (ceiling v6 (max 77 v6)) b 2)))) - 50005747335 -363030456 17382819) - -363030456) - -(deftest misc.58 - (funcall - (compile nil '(lambda (a) - (declare (type (integer -23 66141285) a) - (optimize (speed 3))) - (logorc2 (setq a 35191330) (* a 107)))) - 4099241) - -3764388885) - -(deftest misc.59 - (funcall - (compile nil '(lambda (a b c) - (declare (type (integer -3966039360 -879349) a) - (type (integer -62642199164 -8993827395) b) - (type (integer -8065934654337 223) c) - (optimize (speed 3) (safety 1) (debug 1))) - (floor (* (ceiling c) c) - (max 78 (* b (* a (* a b))))))) - -1000000 -10000000000 0) - 0 0) - -(deftest misc.60 - (funcall - (compile nil - '(lambda () - (let ((v5 46660)) - (setq v5 (signum (rem v5 (max 53 v5)))))))) - 0) - -(deftest misc.61 - (progn - (compile nil - '(lambda (a b) - (declare (type (integer -1785799651 -2) a) - (type (integer -27 614132331) b) - (optimize (speed 3) (safety 1) (debug 1))) - (ceiling (max (floor -733432 (max 84 -20)) 346) - (min -10 (* 17592186028032 (* (* a b) a)))))) - :good) - :good) - -(deftest misc.62 - (funcall (compile nil '(lambda (a) - (if (and (if a t nil) nil) - a - (min (block b5 -1) a)))) - 100) - -1) - -;;; sbcl bug (probably #233) -(deftest misc.63 - (let* ((form '(flet ((%f12 () (setq c -9868204937))) - (if (<= c (%f12)) -2 (if (= c c) b c)))) - (form1 `(lambda (b c) - (declare (type (integer -80421740610 1395590616) c)) - ,form)) - (form2 `(lambda (b c) ,form)) - (vals '(-696742851945 686256271))) - (eqlt (apply (compile nil form1) vals) - (apply (compile nil form2) vals))) - t) - -;;; sbcl bug (probably #233) -(deftest misc.64 - (let* ((form '(logcount - (if (not (> c (let ((v7 (setq c -246180))) -1))) - (ldb (byte 24 11) c) - c))) - (form1 `(lambda (c) - (declare (type (integer -256128 207636) c)) - ,form)) - (form2 `(lambda (c) ,form)) - (vals '(11292)) - ) - (eqlt (apply (compile nil form1) vals) - (apply (compile nil form2) vals))) - t) - -;;; sbcl bug (probably #233) -(deftest misc.65 - (let ((form1 '(lambda (b c) - (declare (type (integer -350684427436 -255912007) b)) - (logandc2 c (if (< b (setq b -25647585550)) b 0)))) - (form2 '(lambda (b c) - (logandc2 c (if (< b (setq b -25647585550)) b 0)))) - (vals '(-297090677547 -20121092))) - (eqlt (apply (compile nil form1) vals) - (apply (compile nil form2) vals))) - t) - -(deftest misc.66 - (let* ((form '(if (> a (setq a -2198578292)) - (min b (if (<= a -14866) a -128363)) - a)) - (form1 `(lambda (a b) - (declare (type (integer -3709231882 0) a)) - (declare (type (integer -562051054 -1) b)) - ,form)) - (form2 `(lambda (a b) ,form)) - (vals '(-2095414787 -256985442))) - (eqlt (apply (compile nil form1) vals) - (apply (compile nil form2) vals))) - t) - -;;; sbcl/cmucl bug (on sparc) -(deftest misc.67 - (funcall - (compile nil '(lambda (x) - (declare (type (integer 10604862 10604862) x) - (optimize speed)) - (* x 390))) - 10604862) - 4135896180) - -;;; cmucl bug (cvs, 10/10/2003) -(deftest misc.68 - (funcall - (compile nil - '(lambda (b) - (flet ((%f8 () (rem b (identity (return-from %f8 0))))) - (lognor (%f8) 0)))) - 0) - -1) - -(deftest misc.69 - (funcall - (compile nil - '(lambda (b) - (flet ((%f11 () (logorc2 (block b1 (let () (return-from b1 b))) - -1984))) - b))) - 0) - 0) - -(deftest misc.70 - (funcall - (compile nil '(lambda (c) - (declare (type (integer 46156191457 126998564334) c)) - (truncate c (min -16 186196583)))) - 87723029763) - -5482689360 - 3) - -(deftest misc.71 - (funcall - (compile nil - '(lambda () - (block b8 - (if (identity (return-from b8 30)) - 1 - (identity - (block b5 - (labels ((%f10 () (min -52 (return-from b5 10)))) - 20)))))))) - 30) - -(deftest misc.72 - (funcall - (compile nil '(lambda () - (flet ((%f13 () (rem 1 (min 0 (return-from %f13 17))))) - (%f13))))) - 17) - -(deftest misc.73 - (funcall - (compile nil '(lambda (c) - (declare (type (integer 46156191457 126998564334) c)) - (rem c (min -1 0)))) - 87723029763) - 0) - -(deftest misc.74 - (funcall (compile nil '(lambda () - (declare (optimize (safety 3) (speed 0) (debug 0))) - (ash 6916244 (min 42 -185236061640))))) - 0) - -;;; Unwind-protect bug, from sbcl: -;;; "The value NIL is not of type SB-C::NODE." - -(deftest misc.75 - (funcall (compile nil '(lambda () (flet ((%f12 () (unwind-protect 1))) 0)))) - 0) - - -;;; cmucl (2003-10-12), "NIL is not of type C::REF" -(deftest misc.76 - (funcall - (compile nil - '(lambda (a c) - (if nil (unwind-protect (max 521739 (unwind-protect c))) - (logandc2 3942 a)))) - 0 0) - 3942) - -;;; gcl (2003-10-11) Miscomputation of (mod 0 -53) in compiled code -(deftest misc.77 - (funcall (compile nil '(lambda () (mod 0 -53)))) - 0) - - -;;; cmucl (2003-10-12) "NIL is not of type C::BYTE-LAMBDA-INFO" -(deftest misc.78 - (funcall - (compile nil '(lambda () - (declare (optimize (speed 0) (debug 0))) - (let ((v4 - (case 227 - ((-11113 -106126) (unwind-protect 8473)) - (t 43916)))) - -12)))) - -12) - -;;; Same as misc.78, but with no declarations -;;; In cmucl (2003-10-12) "NIL is not of type C::ENVIRONMENT" -(deftest misc.79 - (funcall - (compile nil '(lambda () - (let ((v4 - (case 227 - ((-11113 -106126) (unwind-protect 8473)) - (t 43916)))) - -12)))) - -12) - -(deftest misc.79a - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer 72504 351460) a)) - (declare (type (integer 2383 108330) b)) - (declare (optimize (speed 2) (space 0) (safety 0) - (debug 2) (compilation-speed 1))) - (if (or (or (/= b 0) (logbitp 0 0)) (logbitp 0 a)) - 0 - (funcall (constantly 0) b 0 (catch 'ct4 b))))) - 132318 12238) - 0) - - -;;; cmucl (2003-10-12) "Invalid number of arguments: 2" -(deftest misc.80 - (funcall - (compile nil - '(lambda (b c) - (declare (notinline > logior imagpart)) - (declare (optimize (speed 0) (debug 0))) - (labels ((%f16 () - (imagpart - (block b3 - (logeqv (logior -122516 (if (> -1 0) (return-from b3 c) b)) - (return-from %f16 32186310)))))) - (lognor (%f16) b)))) - -123886 -1656) - 57385) - -;;; cmucl (2003-10-12) "NIL is not of type C::REF" -(deftest misc.81 - (funcall - (compile nil '(lambda (b) - (block b7 - (let ((v3 (return-from b7 b))) - (unwind-protect b))))) - 17) - 17) - -;;; cmucl (2003-10-12) "The assertion C::SUCC failed" -(deftest misc.82 - (funcall - (compile nil '(lambda (c) - (labels ((%f15 () - (* (unwind-protect c) - (max -5726369 - (return-from %f15 3099206))))) - c))) - 0) - 0) - -;;; cmucl (2003-10-13) "The assertion (NOT (C::BLOCK-DELETE-P BLOCK)) failed." -(deftest misc.83 - (funcall - (compile nil '(lambda (a c) - (flet ((%f8 () (min c (min a (return-from %f8 c))))) - c))) - 0 -10) - -10) - -(deftest misc.84 - (funcall - (compile nil '(lambda (a b) - (flet ((%f18 () - (let () - (let () - (if (ldb-test (byte 20 23) b) a - (return-from %f18 431)))))) - -674))) - 0 0) - -674) - -(deftest misc.85 - (funcall - (compile nil - '(lambda (c) - (labels ((%f14 () - (let () - (logandc1 (min -32 (return-from %f14 -69793)) - c)))) - 156))) - 0) - 156) - -;;; Two tests showing bug(s) in clisp (2.31) -(deftest misc.86 - (funcall (compile nil '(lambda (b) - (flet ((%f10 nil :bad)) - (let ((v7 (let ((v2 (%f10))) b))) - (unwind-protect b))))) - :good) - :good) - -(deftest misc.87 - (apply (compile nil '(lambda (a b c) - (let ((v9 a)) - (let ((v2 (setq v9 c))) - (unwind-protect c))))) - '(x y z)) - z) - -;;; cmucl bug (18e+ 10/15/03) -(deftest misc.88 - (eval '(block b3 - (max (return-from b3 1) - (if (unwind-protect (unwind-protect 2)) 3 4)))) - 1) - -;;; -;;; cmucl bug (18e+ 10/15/03) -;;; Also occurs in sbcl (0.8.16.20) -;;; "Too large to be represented as a SINGLE-FLOAT" -;;; (a large bignum is coerced to a single-float in type propagation, -;;; with unfortunate results.) -;;; - -;;; Here, the function were the problem occurs is - -(deftest misc.89 - (funcall - (compile nil - '(lambda (c) - (declare (type (integer 0 130304) c)) - (- (rem -26 (max 25 (load-time-value 505849129))) - (* -15718867961526428520296254978781964 c)))) - 0) - -26) - -;;; Here, it is MAX -(deftest misc.89a - (funcall - (compile - nil - '(lambda (a b c d) - (declare (type (integer -265115792172 -206231862770) a)) - (declare (type (integer 11069 58322510034) b)) - (declare (type (integer -7351 28730) c)) - (declare (type (integer -913299295156 3670905260104) d)) - (declare (ignorable a b c d)) - (declare - (optimize (safety 1) (space 1) (compilation-speed 2) - (debug 0) (speed 2))) - (- (signum (catch 'ct6 0)) (numerator (* -1303 d -20527703 d c))))) - -261283766805 41605749408 5110 1269102278886) - -220139978315039892599545286437019126040) - -;;; Here, it is MOD -(deftest misc.89b - (funcall - (compile - nil - '(lambda (a b c d) - (declare (type (integer -481454219025 239286093202) a)) - (declare (type (integer -1121405368785 213522) b)) - (declare (type (integer -103720347879 -241) c)) - (declare (type (integer -12830115357 3027711346) d)) - (declare (ignorable a b c d)) - (declare (optimize (speed 2) (compilation-speed 1) (space 1) - (safety 3) (debug 2))) - (floor (load-time-value 0) (min -18 (* a c b -12626))))) - -78545446876 -460518205737 -38885914099 1598305189) - 0 0) - -;;; acl bugs (version 6.2, linux x86 trial) -(deftest misc.90 - (let* ((form '(- 0 (ignore-errors 20763) - (logxor b 1 c -7672794) b)) - (fn1 `(lambda (b c) - (declare (type (integer -148895 -46982) b)) - (declare (type (integer 0 1) c)) - (declare (optimize (speed 3))) - (declare (optimize (safety 1))) - ,form)) - (fn2 `(lambda (b c) ,form))) - (let ((v1 (funcall (compile nil fn1) -76071 0)) - (v2 (funcall (compile nil fn2) -76071 0)) - (v3 (funcall (eval `(function ,fn2)) -76071 0))) - (if (= v1 v2 v3) :good - (list v1 v2 v3)))) - :good) - -(deftest misc.91 - (let ((fn1 '(lambda () - (declare (optimize (speed 3) (safety 1))) - (ash -10 (min 8 -481)))) - (fn2 '(lambda () (ash -10 (min 8 -481))))) - (let ((v1 (funcall (compile nil fn1))) - (v2 (funcall (compile nil fn2))) - (v3 (funcall (eval `(function ,fn2))))) - (if (= v1 v2 v3) - :good - (list v1 v2 v3)))) - :good) - -(deftest misc.92 - (let* ((form '(- -16179207 b (lognor (let () 3) (logxor -17567197 c)))) - (fn1 `(lambda (b c) - (declare (type (integer -621 30) c)) - (declare (optimize (speed 3))) - (declare (optimize (safety 1))) - ,form)) - (fn2 `(lambda (b c) ,form)) - (vals '(26291532469 -21))) - (let ((v1 (apply (compile nil fn1) vals)) - (v2 (apply (compile nil fn2) vals)) - (v3 (apply (eval `(function ,fn2)) vals))) - (if (= v1 v2 v3) - :good - (list v1 v2 v3)))) - :good) - -(deftest misc.93 - (let* ((form '(ash (1+ (flet ((%f5 (f5-1) c)) c)) - (min 69 (logxor a b)))) - (fn1 `(lambda (a b c) - (declare (type (integer -128 -109) a) - (type (integer -2 -1) b) - (optimize (speed 3) (safety 1))) - ,form)) - (fn2 `(lambda (a b c) ,form)) - (vals '(-123 -1 2590941967601))) - (eqlt (apply (compile nil fn1) vals) - (apply (compile nil fn2) vals))) - t) - -(deftest misc.94 - (not (funcall - (compile nil '(lambda () - (declare (optimize (speed 3) (safety 1) (debug 1))) - (<= 268435280 - (load-time-value - 39763134374436777607194165739302560271120000)))))) - nil) - -(deftest misc.95 - (let* ((form '(+ 272 c (if (< b a) -49618 -29042) b)) - (fn1 `(lambda (a b c) - (declare (type (integer -1585918 601848636) a)) - (declare (type (integer -4 16544323) b)) - (declare (optimize (speed 3))) - (declare (optimize (safety 1))) - ,form)) - (fn2 `(lambda (a b c) ,form)) - (vals '(601739317 10891850 17452477960))) - (let ((v1 (apply (compile nil fn1) vals)) - (v2 (apply (compile nil fn2) vals))) - (if (eql v1 v2) - :good - (list v1 v2)))) - :good) - -(deftest misc.96 - (let* ((form '(max 26 (ceiling b (min -8 (max -1 c))))) - (fn1 `(lambda (b c) - (declare (type (integer 482134 96074347505) b)) - (declare (type (integer -4036 -50) c)) - (declare (optimize (speed 3))) - (declare (optimize (safety 1))) - ,form)) - (fn2 `(lambda (b c) ,form)) - (vals '(90244278480 -338))) - (let ((v1 (apply (compile nil fn1) vals)) - (v2 (apply (compile nil fn2) vals))) - (if (eql v1 v2) - :good - (list v1 v2)))) - :good) - -(deftest misc.97 - (let* ((form '(- 349708 (gcd c 0) (logand b b (if (> -8543459 c) 83328 1073)))) - (fn1 `(lambda (b c) - (declare (type (integer 301653 329907) b)) - (declare (type (integer 171971491 1073721279) c)) - (declare (optimize (speed 3))) - (declare (optimize (safety 1))) - ,form)) - (fn2 `(lambda (b c) ,form)) - (vals '(321769 1073671227))) - (let ((v1 (apply (compile nil fn1) vals)) - (v2 (apply (compile nil fn2) vals))) - (if (eql v1 v2) - :good - (list v1 v2)))) - :good) - -;;; sbcl bugs (0.8.4.40, x86 linux) - -(deftest misc.98 - (funcall (compile nil '(lambda (x) - (declare (type (integer -1000000 1000000) x)) - (logand x x 0))) - 12345) - 0) - -(deftest misc.99 - (funcall - (compile nil '(lambda (a) - (declare (type (integer 4303063 101130078) a)) - (mask-field (byte 18 2) (ash a 77)))) - 57132532) - 0) - -(deftest misc.100 - (funcall (compile nil '(lambda (c) - (declare (type (integer -3924 1001809828) c)) - (declare (optimize (speed 3))) - (min 47 (if (ldb-test (byte 2 14) c) - -570344431 - (ignore-errors -732893970))))) - 705347625) - -570344431) - -(deftest misc.101 - (funcall - (compile nil '(lambda (a c) - (declare (type (integer 185501219873 303014665162) a)) - (declare (type (integer -160758 255724) c)) - (declare (optimize (speed 3))) - (let ((v8 - (- -554046873252388011622614991634432 - (ignore-errors c) - (unwind-protect 2791485)))) - (max (ignore-errors a) - (let ((v6 (- v8 (restart-case 980)))) - (min v8 v6)))))) - 259448422916 173715) - 259448422916) - -(deftest misc.102 - (funcall - (compile nil '(lambda (b) - (declare (type (integer -1598566306 2941) b)) - (declare (optimize (speed 3))) - (max -148949 (ignore-errors b)))) - 0) - 0) - -(deftest misc.103 - (funcall - (compile nil '(lambda (a b) - (min -80 - (abs - (ignore-errors - (+ - (logeqv b - (block b6 - (return-from b6 - (load-time-value -6876935)))) - (if (logbitp 1 a) b (setq a -1522022182249)))))))) - -1802767029877 -12374959963) - -80) - -(deftest misc.104 - (funcall - (compile nil '(lambda (a) (declare (type (integer 55400028 60748067) a)) - (lognand 1505 (ash a (let () 40))))) - 58194485) - -1) - -(deftest misc.105 - (funcall - (compile nil '(lambda (b c) - (declare (type (integer -4 -3) c)) - (block b7 - (flet ((%f1 (f1-1 f1-2 f1-3) - (if (logbitp 0 (return-from b7 - (- -815145138 f1-2))) - (return-from b7 -2611670) - 99345))) - (let ((v2 (%f1 -2464 (%f1 -1146 c c) -2))) - b))))) - 2950453607 -4) - -815145134) - -;;; Gives the error The value NIL is not of type INTEGER. (in sbcl 0.8.4.40) - -(deftest misc.106 - (progn - (eval '(defun misc.106-fn (a b c) - (declare (optimize speed)) - (block b6 - (flet ((%f8 (f8-1 f8-2) b)) - (%f8 (%f8 c 338) (if t (return-from b6 a) c)))))) - (misc.106-fn -30271 -1 -3043)) - -30271) - - ;;; "The value NIL is not of type SB-C::IR2-LVAR." (sbcl 0.8.4.40) -(deftest misc.107 - (funcall - (compile nil - '(lambda (b c) - (declare (type (integer -29742055786 23602182204) b)) - (declare (type (integer -7409 -2075) c)) - (declare (optimize (speed 3))) - (floor - (labels ((%f2 () - (block b6 - (ignore-errors (return-from b6 - (if (= c 8) b 82674)))))) - (%f2))))) - 22992834060 -5833) - 82674 0) - -;;; "The value NIL is not of type SB-C::IR2-LVAR." (sbcl 0.8.10.15) -(deftest misc.107a - (funcall - (compile - nil - '(lambda () - (declare - (optimize (speed 2) (space 0) (safety 1) - (debug 3) (compilation-speed 0))) - (flet ((%f14 - (f14-1 - &optional (f14-2 (rationalize (catch 'ct4 0))) (f14-3 0) - (f14-4 0)) - (dotimes (iv2 0 0) (progn f14-2)))) - (apply #'%f14 0 0 0 nil))))) - 0) - -;;; "The value NIL is not of type SB-C::IR2-LVAR." (sbcl 0.8.14.18) - -(deftest misc.107b - (funcall - (compile - nil - '(lambda (a b c) - (declare (type (integer 7215 1030625885) a)) - (declare (type (integer -4361 -6) b)) - (declare (type (integer -3798210806 -898) c)) - (declare (ignorable a b c)) - (declare - (optimize (speed 2) - (space 2) - (safety 2) - (debug 3) - (compilation-speed 1))) - (block b4 - (let ((*s7* (cons c 0))) - (declare (special *s7*)) - (return-from b4 - (prog1 0 - (the integer - (integer-length - (1+ - (let () - (gcd (cdr *s7*) - (case b - ((31 38 20 0 5 45) 2) - ((34 35 64 61 47) 39) - ((58) a) - (t 131788))))))))))))) - 734649164 -3343 -2306504518) - 0) - -(deftest misc.107c - (funcall - (compile - nil - '(lambda (c) - (declare (optimize (speed 2) (space 1) (safety 1) (debug 3) - (compilation-speed 0))) - (let* ((*s6* - (unwind-protect 0 (the integer (ash 2914825 (min 8 c)))))) - (declare (special *s6*)) - 0))) - -105) - 0) - -(deftest misc.107d - (funcall - (compile - nil - '(lambda (a b) - (declare (optimize (speed 1) (space 1) (safety 1) (debug 3) - (compilation-speed 1))) - (catch 'ct4 - (logorc1 - (the integer - (case (dotimes (iv2 2 2) (progn 203)) - ((-51) -59598) - ((-31 -150) a) - (t b))) - (throw 'ct4 0))))) - 10 20) - 0) - -(deftest misc.107e - (funcall - (compile - nil - '(lambda (a) - (declare (optimize (speed 1) (space 0) (safety 1) - (debug 3) (compilation-speed 1))) - (flet ((%f11 (&key (key1 (the integer (- a 245241933)))) 0)) - (%f11)))) - 1) - 0) - -;;; cmucl bug (Argument X is not a NUMBER: NIL) - -(deftest misc.108 - (funcall - (compile nil '(lambda (b) - (block b7 (- b (ignore-errors (return-from b7 57876)))))) - 10) - 57876) - -;;; "The assertion (C::CONSTANT-CONTINUATION-P C::CONT) failed." (cmucl) -(deftest misc.109 - (funcall (compile - nil - '(lambda () - (load-time-value - (block b4 - (* (return-from b4 -27) - (block b5 - (return-from b4 - (return-from b5 - (ignore-errors (unwind-protect - (return-from b5 0)))))))))))) - -27) - -;;; This bug was occuring a lot in sbcl, and now occurs in cmucl too -;;; NIL fell through ETYPECASE expression. Wanted one of (C:FIXUP X86::EA C:TN). -(deftest misc.110 - (funcall - (compile nil - '(lambda (c) - (declare (type (integer -1441970837 -427) c)) - (declare (optimize (speed 3))) - (block b7 (abs (min c (ignore-errors (return-from b7 c))))))) - -500) - -500) - -;;; In sbcl 0.8.10.14 -;;; NIL fell through ETYPECASE expression. -;;; Wanted one of (SB-C:FIXUP SB-VM::EA SB-C:TN). - -(deftest misc.110a - (funcall - (compile - nil - '(lambda (a b c d e f) - (declare (type (integer -1294746569 1640996137) a)) - (declare (type (integer 33628514900 90005963619) b)) - (declare (type (integer -807801310 3) c)) - (declare (type (integer 36607 121946) d)) - (declare (type (integer -6669690514043 -1776180885905) e)) - (declare (type (integer -1472 1979) f)) - (declare (ignorable a b c d e f)) - (declare - (optimize (speed 3) - (space 3) - (safety 0) - (debug 0) - (compilation-speed 3))) - (catch 'ct7 - (if - (logbitp 0 - (if (/= 0 a) - c - (ignore-errors - (progn - (if - (ldb-test (byte 0 0) (rational (throw 'ct7 0))) - 0 - 0) - 0)))) - 0 - 0)))) - 391833530 36648101240 -32785211 91893 -4124561581760 1358) - 0) - -;;; CLISP (2.31+) compiler bug - -(deftest misc.111 - (funcall - (compile nil - '(lambda (a c) - (if (or (ldb-test (byte 12 18) a) - (not (and t (not (if (not (and c t)) nil nil))))) - 170 -110730))) - 3035465333 1919088834) - 170) - -;;; sbcl (0.8.5.8) "The value NIL is not of type SB-C::IR2-LVAR." - -(deftest misc.112 - (funcall - (compile nil '(lambda (a) - (declare (type (integer -944 -472) a)) - (declare (optimize (speed 3))) - (round - (block b3 - (return-from b3 - (if (= 55957 a) -117 (ignore-errors - (return-from b3 a)))))))) - -589) - -589 0) - -;;; sbcl (0.8.5.8) "The value NIL is not of type SB-C::CTRAN" - -(deftest misc.113 - (funcall - (compile nil '(lambda (b c) - (if (or (ldb-test (byte 8 10) b) t) - c - (min (if (<= -6467 c) c 6) - (flet ((%f3 (f3-1 f3-2) - f3-1)) - (multiple-value-call #'%f3 (values b 107))))))) - -238 -23658556) - -23658556) - -;;; clisp (1 Oct 2003 cvs HEAD) "*** - CAR: #:G7744659 is not a LIST" - -(deftest misc.114 - (funcall - (compile nil - '(lambda (a b) - (unwind-protect - (block b2 - (flet ((%f1 nil b)) - (logior (if a - (if (ldb-test (byte 23 1) 253966182) - (return-from b2 a) - -103275090) - 62410) - (if (not (not (if (not nil) t (ldb-test (byte 2 27) 253671809)))) - (return-from b2 -22) - (%f1)))))))) - 777595384624 -1510893868) - 777595384624) - -;;; clisp (1 Oct 2003 cvs HEAD) "Compiler bug!! Occurred in OPTIMIZE-LABEL." - -(deftest misc.115 - (funcall - (compile nil - '(lambda (a b c) - (declare (type (integer 0 1000) a b c)) - (if (and (if b (not (and (not (or a t)) nil)) nil) - (logbitp 6 c)) - c b))) - 0 100 600) - 600) - -(deftest misc.116 - (funcall - (compile nil - '(lambda (a c) - (declare (type (integer 0 1000) a c)) - (if (if (and (not (and (not (or a t)) nil)) t) c nil) - 91 -1725615))) - 0 0) - 91) - -(deftest misc.117 - (funcall - (compile nil - '(lambda (a c) - (declare (type (integer 0 1000) a c)) - (if (or c (not (or nil (not (and (not (or a t)) nil))))) - 373146181 115))) - 0 0) - 373146181) - -(deftest misc.118 - (funcall - (compile nil '(lambda (a) - (declare (type (integer 0 10000) a)) - (if (or (or nil (not (or (not (or a nil)) t))) a) a 9376))) - 0) - 0) - -(deftest misc.119 - (funcall - (compile - nil - '(lambda () - (if (and (if (1+ 0) nil (not (and (not (and (<= 3) nil)) nil))) - (if (= -31) -20 -2371)) - 1493 39720)))) - 39720) - -(deftest misc.120 - (funcall - (compile - nil - '(lambda (c) - (declare (type (integer 377036 4184626) c)) - (if (or (and t (not (and (not (and c nil)) nil))) nil) - 3470653 c))) - 1000000) - 3470653) - -(deftest misc.121 - (funcall - (compile - nil - '(lambda (a b c) - (if (and (and -92220 (not (and (not (or c nil)) nil))) a) b b))) - 2000000 150000 -1) - 150000) - -;;; CAR: #:G243 is not a LIST -(deftest misc.122 - (funcall - (compile - nil - '(lambda (a b c) - (declare (type (integer 2872749 5754655) a)) - (declare (type (integer 24114340 89504792) b)) - (declare (type (integer 506491 1412971) c)) - (declare (ignorable a b c)) - (declare (optimize (speed 3))) - (declare (optimize (safety 1))) - (declare (optimize (debug 1))) - (- (let ((v7 (ignore-errors a))) -6) - (logand (if c -13936 c) - (block b3 (if (if (or t b) (not nil) c) - (return-from b3 -3114) - (ignore-errors 7) - )))))) - 3000000 30000000 600000) - 15978) - -;;; gcl bug (30 Oct 2003) -(deftest misc.123 - (let* ((fn1 '(lambda (b) - (declare (optimize (safety 1))) - (labels ((%f7 (f7-1 f7-2) - (let ((v2 (setq b 723149855))) - 25620))) - (max b - (multiple-value-call #'%f7 (values b 2)))))) - (fn2 '(lambda (b) - (labels ((%f7 (f7-1 f7-2) - (let ((v2 (setq b 723149855))) - 25620))) - (max b - (multiple-value-call #'%f7 (values b 2)))))) - (vals '(1439719153)) - (v1 (apply (compile nil fn1) vals)) - (v2 (apply (compile nil fn2) vals))) - (if (eql v1 v2) :good (list v1 v2))) - :good) - -(deftest misc.124 - (let* ((fn1 '(lambda (b) - (declare (optimize (safety 1))) - (labels ((%f7 (f7-1 f7-2) - (let ((v2 (setq b 723149855))) - 25620))) - (max b - (funcall #'%f7 b 2))))) - (fn2 '(lambda (b) - (labels ((%f7 (f7-1 f7-2) - (let ((v2 (setq b 723149855))) - 25620))) - (max b - (funcall #'%f7 b 2))))) - (vals '(1439719153)) - (v1 (apply (compile nil fn1) vals)) - (v2 (apply (compile nil fn2) vals))) - (if (eql v1 v2) :good (list v1 v2))) - :good) - -;;; This passed in gcl, but I added it for completeness. -(deftest misc.125 - (let* ((fn1 '(lambda (b) - (declare (optimize (safety 1))) - (labels ((%f7 (f7-1 f7-2) - (let ((v2 (setq b 723149855))) - 25620))) - (max b - (%f7 b 2))))) - (fn2 '(lambda (b) - (labels ((%f7 (f7-1 f7-2) - (let ((v2 (setq b 723149855))) - 25620))) - (max b - (%f7 b 2))))) - (vals '(1439719153)) - (v1 (apply (compile nil fn1) vals)) - (v2 (apply (compile nil fn2) vals))) - (if (eql v1 v2) :good (list v1 v2))) - :good) - - -;;; clisp optional argument bug: "SYMBOL-VALUE: 1 is not a SYMBOL" - -(deftest misc.126 - (funcall - (compile - nil - '(lambda () - (declare (special *should-always-be-true*)) - (labels ((%f10 (f10-1 &optional - (f10-2 (cl:handler-bind nil - (if *should-always-be-true* - (progn 878) - (should-never-be-called) - ))) - (f10-3 (cl:handler-case 10))) - -15)) - (%f10 -144))))) - -15) - -(deftest misc.127 - (funcall - (compile - nil - '(lambda (a c) - (flet ((%f10 (f10-1 f10-2) 10)) - (flet ((%f4 - (&optional - (f4-1 (ldb (byte 10 6) - (* 828 - (+ 30 (dpb c (byte 9 30) (%f10 1918433 34107))) - ))) - (f4-2 (setq a 0))) - 2)) - (%f4 -5))))) - 0 0) - 2) - -;;; cmucl (22 Oct 2003 build) bug -;;; The assertion (EQ (C::COMPONENT-KIND C:COMPONENT) :INITIAL) failed. - -(deftest misc.128 - (flet ((%f14 - (f14-1 f14-2 - &optional - (f14-3 (unwind-protect 13059412)) - (f14-4 452384) - (f14-5 -6714)) - -1)) - (%f14 -2 1 1279896 589726354 -11)) - -1) - -(deftest misc.129 - (labels ((%f17 (f17-1 f17-2 &optional (f17-3 (unwind-protect 178))) - 483633925)) - -661328075) - -661328075) - -(deftest misc.130 - (let* ((fn1 - '(lambda (a c) - (flet ((%f10 (&optional (f10-1 -6489) (f10-2 (+ c))) - a)) - (multiple-value-call #'%f10 (values -178858 a))))) - (fn2 - '(lambda (a c) - (declare (notinline values +) (optimize (speed 0) (debug 0))) - (flet ((%f10 (&optional (f10-1 -6489) (f10-2 (+ c))) - a)) - (multiple-value-call #'%f10 (values -178858 a))))) - (vals '(-13649921 -1813684177409)) - (v1 (apply (compile nil fn1) vals)) - (v2 (apply (compile nil fn2) vals))) - (if (eql v1 v2) :good (list v1 v2))) - :good) - -(deftest misc.131 - (let* ((fn1 - '(lambda (a b) - (max - (block b7 - (abs - (ignore-errors - (if (ldb-test (byte 33 15) (return-from b7 a)) - b b))))))) - (fn2 - '(lambda (a b) - (declare (notinline abs max)) - (declare (optimize (speed 0))) - (declare (optimize (debug 0))) - (max - (block b7 - (abs - (ignore-errors - (if (ldb-test (byte 33 15) (return-from b7 a)) - b b))))))) - (vals '(-823894140303 -3)) - (v1 (apply (compile nil fn1) vals)) - (v2 (apply (compile nil fn2) vals))) - (if (eql v1 v2) :good (list v1 v2))) - :good) - -;;; cmucl (22 Oct 2003) -;;; The assertion (EQ C::ENV -;;; (C::LAMBDA-ENVIRONMENT -;;; (C::LAMBDA-VAR-HOME C::THING))) failed. - -(deftest misc.132 - (funcall - (compile nil - '(lambda (b c) - (declare (type (integer -3358662 7782429) b)) - (declare (type (integer -513018 12740) c)) - (declare (optimize (speed 3))) - (declare (optimize (safety 1))) - (declare (optimize (debug 1))) - (labels ((%f9 - (&optional - (f9-1 - (labels - ((%f5 (f5-1 f5-2) - (floor (ignore-errors f5-1) - (min -67 (if (equal -56 c) - -11197265 f5-2))))) - c)) - (f9-2 -439518) - (f9-3 -2840573)) - f9-1)) - (%f9 -193644 b 1368)))) - 10 20) - -193644) - -(deftest misc.132a - (funcall - (compile - nil - '(lambda () - (declare (optimize (speed 2) (space 0) (safety 0) (debug 2) (compilation-speed 0))) - (labels ((%f1 () 0)) - (if t 0 (dotimes (iv1 5 (if (%f1) 0 0)) (catch 'ct1 0))))))) - 0) - -;;; cmucl (22 Oct 2003) Default for optional parameter is improperly chosen -(deftest misc.133 - (funcall - (compile nil - '(lambda (a b c) - (declare (notinline values)) - (declare (optimize (speed 0) (debug 0))) - (flet ((%f15 (&optional (f15-5 c)) f15-5)) - (multiple-value-call #'%f15 (values -2688612))))) - 1 2 3) - -2688612) - -;;; ACL 6.2 (x86 linux trial) bugs -;;; With optional flet/labels parameters, there's a very high frequency bug -;;; causing the compiler error "Error: `:INFERRED' is not of the expected -;;; type `NUMBER'". The following tests show this bug. - -(deftest misc.134 - (funcall - (compile nil - '(lambda (b) - (labels ((%f5 (f5-1 f5-2 f5-3 &optional (f5-4 0) - (f5-5 - (flet ((%f13 (f13-1) - (return-from %f13 b))) b))) - 900654472)) - 183301))) - 13775799184) - 183301) - -(deftest misc.135 - (funcall - (compile nil - '(lambda (a b) - (labels ((%f4 (&optional (f4-1 (labels ((%f17 nil a)) b))) - -14806404)) - 190134))) - 1783745644 268410629) - 190134) - -(deftest misc.136 - (funcall - (compile nil - '(lambda (c) - (flet ((%f17 (&optional - (f17-1 (flet ((%f9 nil c)) 73574919))) - 643)) - 1039017546))) - 0) - 1039017546) - -;;; And these caused segfaults - -(deftest misc.137 - (funcall - (compile nil - '(lambda () - (declare (optimize (speed 3))) - (declare (optimize (safety 1))) - (flet ((%f16 (&optional - (f16-2 (lognor -3897747 - (if nil -1 -127228378)))) - 10)) - 20)))) - 20) - -(deftest misc.138 - (funcall - (compile nil - '(lambda (c) - (declare (type (integer 2996 39280) c)) - (declare (optimize (speed 3))) - (declare (optimize (safety 1))) - (if (zerop (labels ((%f8 (&optional - (f8-2 (logorc2 c -161957))) - 2176)) - 3)) - c c))) - 3000) - 3000) - -;;; Lispworks 4.2 (x86 linux personal edition) failures - - -(deftest misc.139 - (let* ((fn1 - '(lambda (c) - (declare (optimize (speed 3))) - (logior (labels ((%f1 (f1-1 &optional (f1-2 (setq c 7))) f1-1)) - (%f1 774 3616592)) c))) - (fn2 - '(lambda (c) - (logior (labels ((%f1 (f1-1 &optional (f1-2 (setq c 7))) f1-1)) - (%f1 774 3616592)) c))) - (vals '(-3)) - (v1 (apply (compile nil fn1) vals)) - (v2 (apply (compile nil fn2) vals))) - (if (eql v1 v2) :good (list v1 v2))) - :good) - -(deftest misc.140 - (funcall - (compile nil - '(lambda (a) - (ldb (byte 24 20) - (labels ((%f12 (&optional (f12-1 149) (f12-2 -3894159)) 34068)) - (let* ((v4 (%f12))) a))))) - -1) - 16777215) - - -;;; In Lispworks 4.2 (x86 linux personal edition) -;;; 'Error: *** Ran out of patterns in (MOVE) for (edi NIL)' - -(deftest misc.141 - (funcall - (compile nil - '(lambda () (labels ((%f11 (&optional (f11-3 (restart-case 0))) f11-3)) - (%f11 1))))) - 1) - -(deftest misc.142 - (funcall - (compile nil - '(lambda () - (labels ((%f15 (&optional (f15-3 (block b1 (+ 1 (return-from b1 -10))))) - f15-3)) - (%f15))))) - -10) - -;;; cmucl (22 Oct 2003): NIL is not of type C::REF -(deftest misc.143 - (block b2 - (max (return-from b2 1) - (let ((v3 - (unwind-protect - (let* ((v1 (ignore-errors -254))) - 1)))) - -2))) - 1) - -;;; (was) The assertion (NOT (C::BLOCK-DELETE-P BLOCK)) failed. -;;; (now) The assertion (NOT (MEMBER C::KIND '(:DELETED :OPTIONAL :TOP-LEVEL))) failed. - -(deftest misc.144 - (funcall - (compile nil - '(lambda (a b c) - (declare (type (integer 9739325 14941321) c)) - (labels ((%f7 (f7-1 f7-2 f7-3 &optional (f7-4 b)) - (return-from %f7 f7-4))) - (if (= -76482 c) - (if (>= c 10986082) (%f7 a b (%f7 -8088 c -147106 2)) -10502) - (%f7 509252 b b))))) - -200 17 10000000) - 17) - -(deftest misc.145 - (funcall - (compile nil - '(lambda (a b c) - (declare (optimize (safety 3))) - (block b5 - (return-from b5 - (logior (if (or c t) b (load-time-value -61)) (return-from b5 -3)))))) - 1 2 3) - -3) - -;;; cmucl: order of evaluation error -(deftest misc.146 - (funcall - (compile nil - '(lambda (b) - (declare (optimize (speed 3))) - (flet ((%f14 (&optional (f14-1 301917227) - (f14-2 (setq b 995196571))) - f14-1)) - (%f14 b (block b3 (%f14 -64)))))) - 10) - 10) - -;;; cmucl (22 Oct 2003): NIL is not of type C::CLEANUP -(deftest misc.147 - (flet ((%f11 () (if nil (ignore-errors -19884254) (unwind-protect -2)))) :good) - :good) - -;;; The assertion (C::CONSTANT-CONTINUATION-P C::CONT) failed. -(deftest misc.148 - (block b2 (logior (return-from b2 484) (restart-case (ignore-errors 1737021)))) - 484) - -;;; Argument X is not a NUMBER: NIL. -(deftest misc.149 - (funcall - (compile nil '(lambda (b) - (block b1 (- (logand 0 -34 1026491) (ignore-errors (return-from b1 b)))))) - 0) - 0) - -(deftest misc.149a - (funcall - (compile nil '(lambda (a) (block b1 (- a (ignore-errors (return-from b1 1)))))) - 0) - 1) - -;;; cmucl (11 2003 image) "NIL is not of type C::CONTINUATION" -(deftest misc.150 - (funcall - (compile - nil - '(lambda (a b c) - (flet ((%f17 - (&optional - (f17-4 - (labels ((%f13 (f13-1 &optional (f13-2 (multiple-value-prog1 b))) - -4)) - (%f13 b (%f13 190))))) - -157596)) - (labels ((%f6 () (%f17))) c)))) - 10 20 30000) - 30000) - -(deftest misc.150a - (funcall - (compile - nil - '(lambda () - (declare (optimize (speed 3) (space 2) (safety 3) - (debug 3) (compilation-speed 2))) - (catch 'ct6 (apply (constantly 0) (list)))))) - 0) - -(deftest misc.150b - (funcall - (compile - nil - '(lambda (a) - (declare (type integer a)) - (declare (optimize (speed 3) (space 0) (safety 3) (debug 2) - (compilation-speed 3))) - (if (= a 0) 0 (truncate a)))) - 0) - 0) - -(deftest misc.150c - (funcall - (compile - nil - '(lambda (a b) - (declare (optimize (speed 1) (space 3) (safety 2) (debug 3) (compilation-speed 3))) - (labels ((%f4 (f4-1) - 0)) - (labels ((%f15 - (f15-1 f15-2 - &optional (f15-3 (apply #'%f4 0 nil)) (f15-4 0) - (f15-5 (%f4 (%f4 (if (/= 0 0) a 0))))) - 0)) - (labels ((%f13 (f13-1) - (%f15 b 0 0 0))) - 0))))) - 1 2) - 0) - -(deftest misc.150d - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer 4146834609223 16403344221223) a)) - (declare (type (integer -35470308180 3523580009) b)) - (declare (optimize (speed 1) (space 3) (safety 3) (debug 0) (compilation-speed 0))) - (catch 'ct1 (logand b a 0)))) - 4146834609223 10) - 0) - -;;; cmucl (11 2003 x86 linux) "NIL is not of type C::ENVIRONMENT" -(deftest misc.151 - (funcall - (compile - nil - '(lambda (b c) - (declare (type (integer -249 97) b)) - (declare (type (integer 3565969 6559088) c)) - (let* ((v7 - (if (not (= 1030 4)) - c - (logand (if (/= b c) b 34945725) (unwind-protect -12443701))))) - 5520737))) - -24 5657943) - 5520737) - -(deftest misc.151a - (funcall - (compile - nil - '(lambda () - (declare - (optimize (speed 3) (space 3) (safety 1) (debug 1) (compilation-speed 0))) - (case 0 ((-12 -9 -12 -2 -5 -2 15) (catch 'ct7 (throw 'ct7 0))) (t 0))))) - 0) - -;;; sbcl bug (0.8.5.19) -;;; "The value NIL is not of type SB-C::REF." - -(deftest misc.152 - (funcall - (compile nil - '(lambda (a) - (block b5 - (let ((v1 (let ((v8 (unwind-protect 9365))) - 8862008))) - (* - (return-from b5 - (labels ((%f11 (f11-1) f11-1)) - (%f11 87246015))) - (return-from b5 - (setq v1 - (labels ((%f6 (f6-1 f6-2 f6-3) v1)) - (dpb (unwind-protect a) - (byte 18 13) - (labels ((%f4 () 27322826)) - (%f6 -2 -108626545 (%f4)))))))))))) - -6) - 87246015) - -(deftest misc.153 - (funcall - (compile nil - '(lambda (a) - (if (logbitp 3 - (case -2 - ((-96879 -1035 -57680 -106404 -94516 -125088) - (unwind-protect 90309179)) - ((-20811 -86901 -9368 -98520 -71594) - (let ((v9 (unwind-protect 136707))) - (block b3 - (setq v9 - (let ((v4 (return-from b3 v9))) - (- (ignore-errors (return-from b3 v4)))))))) - (t -50))) - -20343 - a))) - 0) - -20343) - -;;; Bug in ecl (cvs head, 4 Nov 2003) -;;; "/tmp/ecl04Coiwc0V.c:48: `lex0' undeclared (first use in this function)" - -(deftest misc.154 - (funcall - (compile nil - '(lambda (b) - (labels ((%f8 nil -39011)) - (flet ((%f4 (f4-1 f4-2 &optional (f4-3 (%f8)) (f4-4 b)) - (%f8))) - (%f4 -260093 -75538 -501684 (let ((v9 (%f8))) -3)))))) - 0) - -39011) - -;;; "/tmp/ecl1572CbKzu.c:16: too many arguments to function `APPLY'" - -(deftest misc.155 - (funcall - (compile nil - '(lambda (a b c) - (labels ((%f6 (f6-1 f6-2) c)) - (multiple-value-call #'%f6 (values a c))))) - 0 10 20) - 20) - -;;; "The function C::LDB1 is undefined." - -(deftest misc.156 - (funcall - (compile nil - '(lambda () - (let ((v6 (ldb (byte 30 1) 1473))) (let ((v8 v6)) 2395))))) - 2395) - -;;; "/tmp/ecl9CEiD1RL5.c:36: `lex0' undeclared (first use in this function)" - -(deftest misc.157 - (funcall - (compile nil - ' (lambda (c) - (labels ((%f11 nil 1)) - (flet ((%f9 (f9-1 f9-2) - (case 17466182 ((-12) (%f11)) (t c)))) - (%f9 -9913 c))))) - 17) - 17) - -;;; SBCL (0.8.5.24) bug: "bogus operands to XOR" - -(deftest misc.158 - (funcall - (compile nil - '(lambda (a b c) - (declare (type (integer 79828 2625480458) a)) - (declare (type (integer -4363283 8171697) b)) - (declare (type (integer -301 0) c)) - (if (equal 6392154 (logxor a b)) - 1706 - (let ((v5 (abs c))) - (logand v5 - (logior (logandc2 c v5) - (common-lisp:handler-case - (ash a (min 36 22477))))))))) - 100000 0 0) - 0) - -;;; sbcl (0.8.5.24) The value NIL is not of type SB-C::CTRAN. - -(deftest misc.159 - (funcall - (compile nil - '(lambda () - (let ((v8 70696)) - (if (equal v8 -536145083) - (let ((v2 (setq v8 v8))) - (flet ((%f9 (f9-1 f9-2) - 309257)) - (multiple-value-call #'%f9 (values v2 v2)))) - 100))))) - 100) - -;;; sbcl (0.8.5.37) The value NIL is not of type SB-C::CTRAN. - -(deftest misc.159a - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer -105680 2104974) a)) - (declare (type (integer -1881 -1134) b)) - (declare (ignorable a b)) - (declare (optimize (speed 3))) - (declare (optimize (safety 1))) - (declare (optimize (debug 1))) - (block b5 - (let ((v2 - (if (or (>= 34 a) 108361696) - (return-from b5 -1) - (lognand b -16023672)))) - (flet ((%f10 - (f10-1 - &optional (f10-2 (if (eql -30 v2) v2 -5)) (f10-3 v2) - (f10-4 14)) - (if (equal a f10-2) f10-4 380663047))) - (flet ((%f6 (f6-1 f6-2 f6-3) - f6-1)) - (multiple-value-call #'%f6 - (values a (%f10 -37243) -47691)))))))) - 100 -1200) - -1) - -;;; gcl (9 Nov 2003) bug -;;; Error in FUNCALL [or a callee]: Caught fatal error [memory may be damaged] - -(deftest misc.160 - (funcall - (compile nil - '(lambda (c) - (declare (notinline + funcall)) - (+ (labels ((%f1 () -14)) (funcall #'%f1)) - (flet ((%f2 () (floor c))) (funcall #'%f2))))) - 0) - -14) - -;;; cmucl (9 Nov 2003) -;;; The assertion (NOT (MEMBER C::KIND '(:DELETED :OPTIONAL :TOP-LEVEL))) failed. - -(deftest misc.161 - (funcall - (compile nil - '(lambda (a b c) - (flet ((%f17 (f17-1 f17-2 f17-3) - (flet ((%f2 - (f2-1 f2-2 - &optional (f2-3 (return-from %f17 f17-1)) - (f2-4 (return-from %f17 -57))) - b)) - (multiple-value-call #'%f2 (values c -588 55101157))))) - (if nil - (let* ((v6 (%f17 102136 3096194 a))) - b) - c)))) - -511 -2269809964 250738) - 250738) - -(deftest misc.161a - (funcall - (compile nil - '(lambda (a) - (declare (optimize (speed 3) (space 2) (safety 3) (debug 0) (compilation-speed 0))) - (progn (abs 0) (- a) 0))) - 1) - 0) - -;;; cmucl (9 Nov 2003) Incorrect result at SPEED 0. - -(deftest misc.162 - (let* ((fn `(lambda (a c) - (declare (notinline funcall) - (optimize (speed 0) (debug 0))) - (labels ((%f17 (f17-1 &optional (f17-4 c)) - (return-from %f17 (if f17-4 f17-1 49572640)))) - (funcall #'%f17 15128425 a))))) - (funcall (compile nil fn) 1 3)) - 15128425) - -;;; gcl (12 Nov 2003) -;;; C compiler failure during compilation (duplicate case value) - -(deftest misc.163 - (funcall - (compile nil - '(lambda (b) - (declare (type (integer -15716 3947) b)) - (case b - ((-7 -6 -6) :good) - ((-5 -6) :bad) - ))) - - -6) - :good) - -;;; gcl (13 Nov 2003) -;;; Error in FUNCALL [or a callee]: Caught fatal error [memory may be damaged] - -(deftest misc.164 - (funcall - (compile - nil - '(lambda (a) - (labels ((%f6 (f6-1 f6-2) - (cl:handler-case - (labels ((%f2 nil (logior a))) - (if (eql (%f2) (%f2)) - 2829254 -10723)) - (error (c) (error c)) - ))) - (funcall #'%f6 10 20) - ))) - 0) - 2829254) - -;;; sbcl failures - -;;; The value NIL is not of type SB-C::NODE. -(deftest misc.165 - (funcall - (compile - nil - '(lambda (a b c) - (block b3 - (flet ((%f15 - (f15-1 f15-2 f15-3 - &optional - (f15-4 - (flet ((%f17 - (f17-1 f17-2 f17-3 - &optional (f17-4 185155520) (f17-5 c) - (f17-6 37)) - c)) - (%f17 -1046 a 1115306 (%f17 b -146330 422) -337817))) - (f15-5 a) (f15-6 -40)) - (return-from b3 -16))) - (multiple-value-call #'%f15 (values -519354 a 121 c -1905)))))) - 0 0 -5) - -16) - -;;; failed AVER: -;;; "(NOT -;;; (AND (NULL (BLOCK-SUCC B)) -;;; (NOT (BLOCK-DELETE-P B)) -;;; (NOT (EQ B (COMPONENT-HEAD #)))))" - -(deftest misc.166 - (funcall - (compile - nil - '(lambda (a b c) - (labels ((%f4 - (f4-1 f4-2 &optional (f4-3 b) (f4-4 c) (f4-5 -170)) - (let ((v2 - (flet ((%f3 - (f3-1 - &optional (f3-2 28476586) (f3-3 c) - (f3-4 -9240)) - (return-from %f4 1))) - (multiple-value-call - #'%f3 - (values -479909 19843799 f4-5 -463858))))) - b))) - c))) - 0 0 -223721124) - -223721124) - -(deftest misc.167 - (funcall - (compile - nil - '(lambda (a b c) - (flet ((%f5 (f5-1 f5-2) - (return-from %f5 604245664))) - (flet ((%f12 - (f12-1 f12-2 - &optional (f12-3 c) (f12-4 -579456) - (f12-5 - (labels ((%f9 - (f9-1 - &optional - (f9-2 - (%f5 1 - (let ((v4 (%f5 30732606 a))) - b))) - (f9-3 -29) - (f9-4 - (block b4 - (labels ((%f14 () - (labels ((%f18 - (&optional - (f18-1 - (locally - 592928)) - (f18-2 -3) - (f18-3 - (return-from - b4 a))) - f18-1)) - (%f18 74214190 a)))) - (%f14))))) - -1)) - (flet ((%f17 - (f17-1 f17-2 &optional (f17-3 -136045032)) - -38655)) - (%f17 43873 -138030706 -1372492))))) - (return-from %f12 -15216677))) - (%f12 (%f5 b 2329383) a))))) - 1 2 3) - -15216677) - -(deftest misc.168 - (funcall - (compile - nil - '(lambda (a b c) - (block b3 - (flet ((%f11 - (f11-1 f11-2 - &optional - (f11-3 - (block b6 - (labels ((%f11 - (f11-1 - &optional (f11-2 c) - (f11-3 (return-from b6 -1806))) - (return-from b3 -28432))) - (apply #'%f11 (list -114)))))) - (return-from %f11 f11-2))) - (%f11 b - c - (labels ((%f10 - (f10-1 f10-2 - &optional (f10-3 a) (f10-4 (%f11 -3931 170))) - -1704759)) - c)))))) - 1 2 3) - 3) - -(deftest misc.169 - (funcall - (compile - nil - '(lambda (a b c) - (if t -21705 - (flet ((%f15 (f15-1 f15-2) - b)) - (block b4 - (%f15 -11112264 - (labels ((%f2 - (f2-1 - &optional (f2-2 (if b -5485340 -1534)) - (f2-3 -6)) - (return-from b4 f2-1))) - (return-from b4 - (if b (%f2 c -320813) (%f2 b a a)))))))))) - 1 2 3) - -21705) - -;;; sbcl (0.8.5.26) -;;; failed AVER: "(FUNCTIONAL-LETLIKE-P CLAMBDA)" - -(deftest misc.170 - (funcall - (compile - nil - '(lambda (b) - (flet ((%f14 (f14-1 f14-2) - (if (if (eql b -7) nil nil) - (labels ((%f10 (f10-1 f10-2 f10-3) - 7466)) - (return-from %f14 - (min - (multiple-value-call #'%f10 (values 0 492 f14-1)) - (max 11 f14-1) - (multiple-value-call #'%f10 - (values 439171 f14-2 0))))) - 1))) - (let ((v6 (%f14 (logcount b) -386283))) - 56211)))) - 17) - 56211) - -(deftest misc.170a - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer -281 30570) a)) - (declare (type (integer -4247786 -199821) b)) - (declare - (optimize (speed 3) - (space 0) - (safety 0) - (debug 2) - (compilation-speed 1))) - (flet ((%f14 (f14-1 f14-2) - (coerce 0 'integer))) - (labels ((%f3 (f3-1 f3-2 f3-3) - (if - (if - (typep (%f14 -864 -10620) '(integer -11672107617 -2)) - t - (typep - (imagpart - (lcm 2120258 0 (logandc2 -6222 -1057382553))) - '(integer * -113))) - (dotimes - (iv3 5 - (flet ((%f11 (f11-1 f11-2 f11-3) - b)) - (multiple-value-call #'%f11 - (values a a f3-3)))) - 0) - 0))) - (case (%f3 a a 0) (t 0)))))) - 22087 -1787181) - 0) - -;;; The value NIL is not of type SB-C::NODE. - -(deftest misc.171 - (funcall - (compile - nil - '(lambda (b) - (block b6 - (flet ((%f11 (f11-1 f11-2 &optional (f11-3 -2369157) (f11-4 409468)) - (return-from b6 1))) - (block b2 - (flet ((%f10 (f10-1 f10-2 - &optional (f10-3 (return-from b6 (return-from b6 -3)))) - -8)) - (%f10 - (multiple-value-call #'%f11 (values -5945959 1654846427 -22)) - (return-from b2 b) - (return-from b2 31258361)))))))) - 10) - 1) - - -;;; segmentation violation at #XA4A0B59 - -(deftest misc.172 - (funcall - (compile - nil - '(lambda (a b c) - (declare (notinline list apply)) - (declare (optimize (safety 3))) - (declare (optimize (speed 0))) - (declare (optimize (debug 0))) - (labels ((%f12 (f12-1 f12-2) - (labels ((%f2 (f2-1 f2-2) - (flet ((%f6 () - (flet ((%f18 - (f18-1 - &optional (f18-2 a) - (f18-3 -207465075) - (f18-4 a)) - (return-from %f12 b))) - (%f18 -3489553 - -7 - (%f18 (%f18 150 -64 f12-1) - (%f18 (%f18 -8531) - 11410) - b) - 56362666)))) - (labels ((%f7 - (f7-1 f7-2 - &optional (f7-3 (%f6))) - 7767415)) - f12-1)))) - (%f2 b -36582571)))) - (apply #'%f12 (list 774 -4413))))) - 0 1 2) - 774) - -;;; In sbcl 0.8.5.37 -;;; "Unreachable code is found or flow graph is not properly depth-first ordered." - -(deftest misc.173 - (funcall - (compile - nil - '(lambda (a b c) - (declare (notinline values)) - (declare (optimize (safety 3))) - (declare (optimize (speed 0))) - (declare (optimize (debug 0))) - (flet ((%f11 - (f11-1 f11-2 - &optional (f11-3 c) (f11-4 7947114) - (f11-5 - (flet ((%f3 (f3-1 &optional (f3-2 b) (f3-3 5529)) - 8134)) - (multiple-value-call #'%f3 - (values (%f3 -30637724 b) c))))) - (setq c 555910))) - (if (and nil (%f11 a a)) - (if (%f11 a 421778 4030 1) - (labels ((%f7 - (f7-1 f7-2 - &optional - (f7-3 - (%f11 -79192293 - (%f11 c a c -4 214720) - b - b - (%f11 b 985))) - (f7-4 a)) - b)) - (%f11 c b -25644)) - 54) - -32326608)))) - 1 2 3) - -32326608) - -;;; In sbcl 0.8.5.37 -;;; The value NIL is not of type SB-C:COMPONENT. - -(deftest misc.174 - (funcall - (compile - nil - '(lambda (a b c) - (declare (type (integer 10292971433 14459537906) b)) - (declare (optimize (speed 3))) - (declare (optimize (safety 1))) - (declare (optimize (debug 1))) - (if - (and (and (/= -51885 b) nil) - (case (1+ b) - ((4 4 3 -4) - (let* ((v1 - (flet ((%f16 (f16-1) - -1858366)) - (apply #'%f16 b (list))))) - -1602321)) - (t 3))) - 19 - c))) - 0 11000000000 0) - 0) - -(deftest misc.174a - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer 23 365478242977) a)) - (declare (type (integer -38847 268231) b)) - (declare (optimize (speed 3))) - (declare (optimize (safety 1))) - (declare (optimize (debug 1))) - (if (not (if (/= b 7) t (not (not a)))) - (case (setq b -5880) - ((8382 3401 2058 39167 62228) - (flet ((%f7 (f7-1 f7-2 f7-3) f7-1)) - (multiple-value-call #'%f7 (values -135629 a -410168200)))) - (t a)) - 15173))) - 30 0) - 15173) - -(deftest misc.174b - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer -8688 2170) a)) - (declare (type (integer -9938931470 1964967743) b)) - (declare (optimize (speed 3))) - (declare (optimize (safety 1))) - (declare (optimize (debug 1))) - (if - (and - (if (if (equal b 9) nil t) - nil - (not - (logbitp 5 - (labels ((%f5 (f5-1 f5-2 f5-3) - 4057223)) - (let ((v9 (%f5 -42 -27504 45026809))) - 15011))))) - (if - (or a - (labels ((%f16 (f16-1) - 61)) - (apply #'%f16 275 (list)))) - a - t)) - (setq a -4803) - (rem a (max 47 b))))) - 0 0) - 0) - -;;; In sbcl 0.8.5.37 -;;; "Unreachable code is found or flow graph is not properly depth-first ordered." - -(deftest misc.175 - (funcall - (compile - nil - '(lambda (a b c) - (declare (notinline list apply values signum funcall)) - (declare (optimize (safety 3))) - (declare (optimize (speed 0))) - (declare (optimize (debug 0))) - (labels ((%f4 (f4-1 f4-2 f4-3) - (labels ((%f1 (f1-1 f1-2 f1-3) - 2)) - (labels ((%f11 - (f11-1 - &optional - (f11-2 - (return-from %f4 - (labels ((%f8 - (f8-1 f8-2 f8-3 - &optional (f8-4 -35) - (f8-5 f4-2)) - f4-1)) - (funcall #'%f8 53 b f4-1))))) - (return-from %f4 a))) - (signum - (let ((v4 - (flet ((%f8 - (f8-1 f8-2 f8-3 - &optional (f8-4 b) (f8-5 -560367)) - f8-4)) - (%f8 -27 35395 c -69)))) - (%f11 - (multiple-value-call #'%f11 - (values (%f1 (%f11 b (%f11 v4 f4-3)) f4-3 77936) - 1628490976)) - (return-from %f4 (%f1 -9432 f4-1 f4-1))))))))) - (flet ((%f7 (f7-1 f7-2 f7-3) - (%f4 b f7-3 f7-3))) - (flet ((%f14 (f14-1) - (apply #'%f7 -252 -56169265 -7322946 (list)))) - (%f14 a)))))) - -70313091 577425217 28052774417) - -70313091) - -(deftest misc.175a - (funcall - (compile - nil - '(lambda (a b) - (declare (notinline values list apply logior)) - (declare (optimize (safety 3))) - (declare (optimize (speed 0))) - (declare (optimize (debug 0))) - (if nil - (logior (flet ((%f5 (f5-1) b)) (%f5 56288)) - (flet ((%f17 (f17-1 f17-2 - &optional - (f17-3 (let () 6857)) - (f17-4 - (labels ((%f3 (f3-1 f3-2 f3-3 &optional (f3-4 a) (f3-5 877)) - 139)) - (apply #'%f3 (list -33052082 b a 1572))))) - b)) - (multiple-value-call #'%f17 (values 31 b a b)))) - 392))) - 0 0) - 392) - -(deftest misc.175b - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer -1185422977 2286472818) a)) - (declare (type (integer -211381289038 74868) b)) - (declare (ignorable a b)) - (declare (optimize (speed 3))) - (declare (optimize (safety 1))) - (declare (optimize (debug 1))) - (lognor (unwind-protect -1248) - (flet ((%f7 - (&optional - (f7-1 - (flet ((%f1 (f1-1 f1-2 f1-3) 121426)) - (%f1 b 2337452 (%f1 61767 b a)))) - (f7-2 - (block b8 - (logandc1 - (labels ((%f10 (f10-1 f10-2 f10-3) 323734600)) - (%f10 (%f10 323734600 323734600 -10165) - -607741 (ignore-errors 971588))) - (if (>= b -27) (return-from b8 -2) - (ignore-errors 237138926)))))) - f7-2)) - (apply #'%f7 (list 761316125 b)))))) - 1792769319 -60202244870) - 5) - - -;;; sbcl 0.8.5.37 -;;; failed AVER: "(FUNCTIONAL-LETLIKE-P CLAMBDA)" - -(deftest misc.176 - (funcall - (compile - nil - '(lambda (a b c) - (declare (type (integer 162180298 184143783) a)) - (declare (type (integer 702599480988 725878356286) b)) - (declare (type (integer 168 80719238530) c)) - (declare (optimize (speed 3))) - (declare (optimize (safety 1))) - (declare (optimize (debug 1))) - (block b6 - (flet ((%f10 (f10-1 f10-2) - (labels ((%f6 (f6-1 f6-2) - f6-1)) - (let ((v2 - (flet ((%f1 (f1-1 f1-2 f1-3) - f1-3)) - (let ((v8 - (%f1 -11350578 - (%f6 10414199 13) - -58931837))) - -239755)))) - 323)))) - (labels ((%f4 - (f4-1 - &optional (f4-2 204) (f4-3 -1) - (f4-4 - (flet ((%f2 (f2-1) - (if t (return-from b6 c) a))) - (logorc2 (multiple-value-call #'%f2 (values 1)) - (let* ((v5 (floor (%f2 -1260)))) - (case (abs (logxor 185664 a)) - ((-2 5975) - (if (or (< b v5) nil) - (return-from b6 - (let ((v10 (%f2 c))) - 0)) - (multiple-value-call #'%f10 - (values -3 a)))) - (t b))))))) - 1503938)) - (multiple-value-call #'%f4 (values -1 a 1853966))))))) - 173549795 725346738048 993243799) - 993243799) - -;;; different results (sbcl 0.8.5.37) -;;; May be that setq side effects bug again? - -(deftest misc.177 - (let* ((form '(flet ((%f11 - (f11-1 f11-2) - (labels ((%f4 () (round 200048 (max 99 c)))) - (logand - f11-1 - (labels ((%f3 (f3-1) -162967612)) - (%f3 (let* ((v8 (%f4))) - (setq f11-1 (%f4))))))))) - (%f11 -120429363 (%f11 62362 b)))) - (vars '(a b c)) - (vals '(6714367 9645616 -637681868)) - (fn1 `(lambda ,vars - (declare (type (integer 804561 7640697) a)) - (declare (type (integer -1 10441401) b)) - (declare (type (integer -864634669 55189745) c)) - (declare (ignorable a b c)) - (declare (optimize (speed 3))) - (declare (optimize (safety 1))) - (declare (optimize (debug 1))) - ,form)) - (fn2 `(lambda ,vars - (declare (notinline list apply logand max round)) - (declare (optimize (safety 3))) - (declare (optimize (speed 0))) - (declare (optimize (debug 0))) - ,form)) - (compiled-fn1 (compile nil fn1)) - (compiled-fn2 (compile nil fn2)) - (results1 (multiple-value-list (apply compiled-fn1 vals))) - (results2 (multiple-value-list (apply compiled-fn2 vals)))) - (if (equal results1 results2) - :good - (values results1 results2))) - :good) - -;;; sbcl 0.8.5.37 -;;; The value NIL is not of type INTEGER. - -(deftest misc.178 - (funcall - (compile - nil - '(lambda (a b c) - (declare (ignorable a b c)) - (declare (optimize (speed 3))) - (declare (optimize (safety 1))) - (declare (optimize (debug 1))) - (let ((v9 - (flet ((%f9 - (f9-1 f9-2 f9-3 - &optional (f9-4 -40538) - (f9-5 - (flet ((%f10 (f10-1 f10-2) - (labels ((%f11 (f11-1 f11-2) - (labels ((%f10 (f10-1 f10-2) - -1422)) - (if - (< b - (%f10 - (%f10 28262437 95387) - f10-2)) - -1562 - f10-2)))) - (let* ((v6 (%f11 59 b))) - (return-from %f10 - (apply #'%f11 - f10-1 - (list - (return-from %f10 - 2029647)))))))) - (apply #'%f10 -3067 3854883 (list))))) - 64066)) - (%f9 a 2774 0 c)))) - (flet ((%f18 (f18-1 f18-2 &optional (f18-3 66) (f18-4 b)) - -6939342)) - (%f18 1274880 (%f18 b a 46746370 -1)))))) - 0 0 0) - -6939342) - -;;; sbcl 0.8.5.37 -;;; failed AVER: "(FUNCTIONAL-LETLIKE-P CLAMBDA)" - -(deftest misc.179 - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer 1135 16722) a)) - (declare (type (integer -640723637053 -9049) b)) - (declare (optimize (speed 3))) - (declare (optimize (safety 1))) - (declare (optimize (debug 1))) - (block b3 - (return-from b3 - (flet ((%f17 (f17-1 &optional (f17-2 b) (f17-3 b)) - (+ (if t (return-from b3 -64796) a)))) - (case (%f17 -3908648 -7026139 a) - ((41771 -113272 -48004 -39699 50691 -13222) - (multiple-value-call #'%f17 (values -1963404294 -105))) - (t -7026139))))))) - 2000 -10000) - -64796) - -(deftest misc.180 - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer 41 484) a)) - (declare (type (integer -2546947 1008697961708) b)) - (declare (optimize (speed 3))) - (declare (optimize (safety 1))) - (declare (optimize (debug 1))) - (if (and (ldb-test (byte 30 10) b) nil) - (labels ((%f7 (f7-1 f7-2 &optional (f7-3 -508405733)) - 390004056)) - (let* ((v4 (multiple-value-call #'%f7 (values b (%f7 b b))))) - (multiple-value-call #'%f7 - (values (%f7 80199 a) - (%f7 - (%f7 a - (let* ((v6 (%f7 -226 250))) - a)) - (abs (ceiling v4))))))) - -6001))) - 50 0) - -6001) - -;;; sbcl 0.8.5.37 -;;; The value NIL is not of type SB-C::TAIL-SET. - -(deftest misc.181 - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer -74233251043 -16478648860) a)) - (declare (type (integer 0 960962) b)) - (declare (optimize (speed 3))) - (declare (optimize (safety 1))) - (declare (optimize (debug 1))) - (flet ((%f14 () - (if 1 - (return-from %f14 a) - (labels ((%f10 (f10-1 f10-2 f10-3 - &optional (f10-4 (let* ((v7 a)) 915))) - -1268205049)) - (labels ((%f18 (f18-1) - (multiple-value-call #'%f10 - (values f18-1 - (%f10 - (%f10 -1495 - (%f10 -384 - -84 - (%f10 -1 - 48052 - 58909027 - -35812) - -114) - (%f10 -391646964 - -28131299 - f18-1 - (%f10 b 368193 a))) - (%f10 f18-1 - -1415811 - f18-1 - 267932407) - 174) - -58 - 320)))) - (let* ((v3 (let ((v7 (return-from %f14 (%f18 -418731)))) - (%f10 104871 -1196 -21 a)))) - (labels ((%f1 () (%f18 (%f18 -794761)))) - (return-from %f14 b)))))))) - (if (%f14) b 887481)))) - -51967629256 809047) - 809047) - -(deftest misc.181a - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer -982285129 -90) a)) - (declare (type (integer 1 82987) b)) - (declare (optimize (speed 3))) - (declare (optimize (safety 1))) - (declare (optimize (debug 1))) - (labels ((%f1 (f1-1 &optional (f1-2 -34) (f1-3 3318057) (f1-4 117)) - (let ((v9 (let ((v9 (if t (return-from %f1 f1-2) 606042))) - f1-1))) - (flet ((%f16 (f16-1 f16-2) 292)) - (labels ((%f2 (f2-1 f2-2 f2-3 - &optional (f2-4 f1-3) (f2-5 f1-4) - (f2-6 -418207187)) - (%f16 2099 (%f16 f1-2 1157)))) - (return-from %f1 (%f2 f1-4 -12066040 v9 122107))))))) - (flet ((%f5 - (f5-1 - &optional - (f5-2 (labels ((%f13 (f13-1 f13-2 f13-3 - &optional (f13-4 a) (f13-5 b)) - 1054213657)) - (%f13 b 166441 -3))) - (f5-3 20102220) - (f5-4 (labels ((%f11 (f11-1 f11-2 f11-3) - (%f1 -110148 (%f1 -12336576 f11-1 -61)))) - (let ((v1 (apply #'%f11 -29706 a b (list)))) - a)))) - b)) - (labels ((%f17 (f17-1 f17-2 f17-3 - &optional (f17-4 -107566292) (f17-5 63) (f17-6 -2)) - 105656)) - (%f5 - (%f17 185703492 a a -511 - (%f1 b b -218142 - (%f17 -240978 2923208 22 (%f5 1542 68917407 a) b))) - -2018 - -1)))))) - -100 1) - 1) - -;;; sbcl 0.8.5.40 -;;; Different results from exprs containing ROUND - -(deftest misc.182 - (let* ((form '(labels ((%f14 (f14-1 f14-2) - (labels ((%f16 - (f16-1 f16-2 - &optional - (f16-3 (setq f14-1 (ash f14-1 (min 77 b))))) - (logandc2 c -100))) - (return-from %f14 (* 2 (gcd f14-1 (%f16 c f14-1))))))) - (round (%f14 c c) - (max 83 (%f14 (multiple-value-call #'%f14 (values 0 2)) 0))))) - (fn1 `(lambda (a b c) - (declare (type (integer 5628 8762) a)) - (declare (type (integer 778 33310188747) b)) - (declare (type (integer -6699 4554) c)) - (declare (optimize (speed 3))) - (declare (optimize (safety 1))) - (declare (optimize (debug 1))) - ,form)) - (fn2 `(lambda (a b c) - (declare (notinline values max round gcd * logandc2 min ash)) - (declare (optimize (safety 3))) - (declare (optimize (speed 0))) - (declare (optimize (debug 0))) - ,form)) - (vals '(7395 1602862793 -2384)) - (cfn1 (compile nil fn1)) - (cfn2 (compile nil fn2)) - (result1 (multiple-value-list (apply cfn1 vals))) - (result2 (multiple-value-list (apply cfn2 vals)))) - (if (equal result1 result2) - :good - (values result1 result2))) - :good) - -;;; sbcl 0.8.5.42 -;;; failed AVER: "(NOT POPPING)" -;;; Also occurs in cmucl (11/2003 snapshot) - -(deftest misc.183 - (funcall - (compile - nil - '(lambda (a b c) - (declare (type (integer -368154 377964) a)) - (declare (type (integer 5044 14959) b)) - (declare (type (integer -184859815 -8066427) c)) - (declare (ignorable a b c)) - (declare (optimize (speed 3))) - (declare (optimize (safety 1))) - (declare (optimize (debug 1))) - (block b7 - (flet ((%f3 (f3-1 f3-2 f3-3) 0)) - (apply #'%f3 0 (catch 'foo (return-from b7 (%f3 0 b c))) c nil))))) - 0 6000 -9000000) - 0) - -(deftest misc.183a - (let () (apply #'list 1 (list (catch 'a (throw 'a (block b 2)))))) - (1 2)) - -;;; sbcl 0.8.5.42 -;;; failed AVER: "(FUNCTIONAL-LETLIKE-P CLAMBDA)" - -(deftest misc.184 - (funcall - (compile - nil - '(lambda (a b c) - (declare (type (integer 867934833 3293695878) a)) - (declare (type (integer -82111 1776797) b)) - (declare (type (integer -1432413516 54121964) c)) - (declare (optimize (speed 3))) - (declare (optimize (safety 1))) - (declare (optimize (debug 1))) - (if nil - (flet ((%f15 (f15-1 &optional (f15-2 c)) - (labels ((%f1 (f1-1 f1-2) 0)) - (%f1 a 0)))) - (flet ((%f4 () - (multiple-value-call #'%f15 - (values (%f15 c 0) (%f15 0))))) - (if nil (%f4) - (flet ((%f8 (f8-1 &optional (f8-2 (%f4)) (f8-3 0)) - f8-3)) - 0)))) - 0))) - 3040851270 1664281 -1340106197) - 0) - -;;; sbcl 0.8.5.42 -;;; invalid number of arguments: 1 -;;; ("XEP for LABELS CL-TEST::%F10" ... - -(deftest misc.185 - (funcall - (compile - nil - '(lambda (a b c) - (declare (type (integer 5 155656586618) a)) - (declare (type (integer -15492 196529) b)) - (declare (type (integer 7 10) c)) - (declare (optimize (speed 3))) - (declare (optimize (safety 1))) - (declare (optimize (debug 1))) - (flet ((%f3 - (f3-1 f3-2 f3-3 - &optional (f3-4 a) (f3-5 0) - (f3-6 - (labels ((%f10 (f10-1 f10-2 f10-3) - 0)) - (apply #'%f10 - 0 - a - (- (if (equal a b) b (%f10 c a 0)) - (catch 'ct2 (throw 'ct2 c))) - nil)))) - 0)) - (%f3 (%f3 (%f3 b 0 0 0) a 0) a b b b c)))) - 5 0 7) - 0) - -(deftest misc.185a - (funcall - (compile - nil - '(lambda (a b c) - (declare (type (integer -1304066 1995764) a)) - (declare (type (integer -52262604195 5419515202) b)) - (declare (type (integer -13 94521) c)) - (declare (optimize (speed 3))) - (declare (optimize (safety 1))) - (declare (optimize (debug 1))) - (flet ((%f13 (f13-1 f13-2 f13-3) - 0)) - (apply #'%f13 - (%f13 b 0 0) - (catch 'ct1 0) - (catch 'ct2 (throw 'ct2 c)) - nil)))) - 0 0 0) - 0) - -;;; sbcl 0.8.5.42 -;;; Different results - -(deftest misc.186 - (let* ((form '(labels ((%f3 (f3-1 f3-2) f3-1)) - (apply #'%f3 b (catch 'ct8 (throw 'ct8 (logeqv (%f3 c 0)))) nil))) - (vars '(b c)) - (fn1 `(lambda ,vars - (declare (type (integer -2 19) b) - (type (integer -1520 218978) c) - (optimize (speed 3) (safety 1) (debug 1))) - ,form)) - (fn2 `(lambda ,vars - (declare (notinline logeqv apply) - (optimize (safety 3) (speed 0) (debug 0))) - ,form)) - (cf1 (compile nil fn1)) - (cf2 (compile nil fn2)) - (result1 (multiple-value-list (funcall cf1 2 18886))) - (result2 (multiple-value-list (funcall cf2 2 18886)))) - (if (equal result1 result2) - :good - (values result1 result2))) - :good) - -;;; cmucl (11/2003 snapshot) -;;; The assertion (NOT (EQ (C::FUNCTIONAL-KIND C::LEAF) :ESCAPE)) failed. - -(deftest misc.187 - (apply - (eval '(function - (lambda (a b c) - (declare (notinline)) - (declare (optimize (safety 3))) - (declare (optimize (speed 0))) - (declare (optimize (debug 0))) - (flet ((%f7 (&optional (f7-1 (catch (quote ct7) 0)) (f7-2 0)) - c)) - (let ((v8 - (flet ((%f14 (f14-1 &optional (f14-2 (%f7 b))) - 0)) - 0))) - (%f7 b)))))) - '(2374299 70496 -6321798384)) - -6321798384) - -;;; ecl bug -;;; Segmentation violation - -(deftest misc.188 - (funcall - (compile - nil - '(lambda (a b c) - (declare (notinline floor min funcall)) - (declare (optimize (safety 3) (speed 0) (debug 0))) - (floor (flet ((%f10 (f10-1 f10-2) b)) (%f10 (%f10 0 0) a)) - (min -37 - (labels ((%f6 (f6-1 f6-2 f6-3) b)) - (funcall #'%f6 b b b)))))) - 7187592 -3970792748407 -14760) - 1 0) - -;;; Wrong number of arguments passed to an anonymous function -(deftest misc.189 - (funcall - (compile - nil - '(lambda (a b c) - (declare (optimize (speed 3) (safety 1) (debug 1))) - (let* ((v7 (labels ((%f13 (f13-1 f13-2 f13-3) 0)) - (multiple-value-call #'%f13 (values a a a))))) - (flet ((%f10 nil v7)) (%f10))))) - 1733 3000 1314076) - 0) - -;;; gcl bug -;;; Error in FUNCALL [or a callee]: # is not of type NUMBER. - -(deftest misc.190 - (let* ((form '(flet ((%f15 () - (labels ((%f4 (f4-1) 0)) - (flet ((%f6 (&optional - (f6-2 - (logand (apply #'%f4 (list (%f4 0))) - (round (* a))))) - -284)) - (%f6))))) - (funcall #'%f15))) - (fn `(lambda (a b c) - (declare (notinline values equal abs isqrt < >= byte - mask-field funcall + * logcount logand logior - round list apply min)) - (declare (optimize (safety 3))) - (declare (optimize (speed 0))) - (declare (optimize (debug 0))) - ,form)) - (vals '(538754530150 -199250645748 105109641))) - (apply (compile nil fn) vals)) - -284) - -;;; gcl -;;; Error in COMPILER::CMP-ANON [or a callee]: 0 is not of type FUNCTION. - -(deftest misc.191 - (funcall - (compile - nil - '(lambda (a b c) - (declare (optimize (speed 3) (safety 1))) - (labels ((%f1 nil c)) - (flet ((%f12 (f12-1) - (labels ((%f9 (f9-1 f9-2 f9-3) (%f1))) - (apply #'%f9 (%f9 a b 0) a 0 nil)))) - (apply #'%f12 0 nil))))) - 0 0 0) - 0) - -;;; acl 6.2 (trial, x86) -;;; Returns incorrect value - -(deftest misc.192 - (funcall - (compile - nil - '(lambda (a b) - (declare (optimize (speed 3))) - (declare (optimize (safety 1))) - (declare (optimize (debug 1))) - (flet ((%f8 (f8-1 f8-2 f8-3) f8-2)) - (catch 'ct6 (%f8 0 b (catch 'ct6 (throw 'ct6 a))))))) - 1 2) - 2) - -(deftest misc.193 - (let* ((form '(if (if (<= a (truncate c (min -43 b))) - (logbitp 0 0) (logbitp 0 -1)) - 0 -36223)) - (fn1 `(lambda (a b c) - (declare (type (integer -3 15350342) a)) - (declare (type (integer -4357 -1555) b)) - (declare (type (integer 5389300879793 6422214587951) c)) - (declare (optimize (speed 3))) - (declare (optimize (safety 1))) - (declare (optimize (debug 1))) - ,form)) - (fn2 `(lambda (a b c) - (declare (notinline logbitp min truncate <=)) - (declare (optimize (safety 3))) - (declare (optimize (speed 0))) - (declare (optimize (debug 0))) - ,form)) - (vals '(7792101 -1615 6070931814551)) - (result1 (multiple-value-list (apply (compile nil fn1) vals))) - (result2 (multiple-value-list (apply (compile nil fn2) vals)))) - (if (equal result1 result2) - :good - (values result1 result2))) - :good) - -;;; cmucl (4 Nov 2003 snapshot) -;;; The assertion (EQ (C::TN-ENVIRONMENT C:TN) C::TN-ENV) failed. - -(deftest misc.194 - (funcall - (compile - nil - '(lambda (a b c) - (declare (notinline funcall)) - (declare (optimize (safety 3) (speed 0) (debug 3))) - (flet ((%f14 - (f14-1 f14-2 - &optional (f14-3 0) (f14-4 (catch 'ct8 0)) - (f14-5 (unwind-protect c))) - 0)) - (funcall #'%f14 0 0)))) - 1 2 3) - 0) - -;;; incorrect value (in cmucl) -(deftest misc.195 - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer -5906488825 254936878485) a)) - (declare (type (integer -350857549 -11423) b)) - (declare (ignorable a b)) - (declare (optimize (speed 3) (safety 1) (debug 1))) - (block b8 - (labels ((%f6 (f6-1 &optional (f6-2 0) (f6-3 0) (f6-4 0)) - 0)) - (multiple-value-call #'%f6 (values 0)))))) - 100 -100000) - 0) - -;;; NIL is not of type C::ENVIRONMENT -(deftest misc.196 - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer 1 46794484349) a)) - (declare (type (integer -627 -2) b)) - (declare (ignorable a b)) - (declare (optimize (speed 3) (safety 1) (debug 1))) - (if (not (logbitp 0 0)) - 0 - (labels ((%f9 (f9-1 f9-2 f9-3) - 0)) - (%f9 (catch 'ct6 a) (catch 'ct4 0) 0))))) - 1 -200) - 0) - -;;; The assertion (EQ (C::TN-ENVIRONMENT C:TN) C::TN-ENV) failed. -(deftest misc.197 - (funcall - (compile - nil - '(lambda (a b) - (declare (notinline logcount)) - (declare (optimize (safety 3) (speed 0) (debug 3))) - (labels ((%f5 (&optional (f5-1 b) (f5-2 0) (f5-3 (catch (quote ct2) 0))) - (prog1 (logcount (block b1 f5-1))))) - (if (%f5 0 0 0) (%f5 a) 0)))) - 1 2) - 1) - -;;; gcl bug (30-11-2003) -;;; Different results -;;; These tests appear to be for the same bug. - -(deftest misc.198 - (let* ((form '(min (catch 'ct4 (throw 'ct4 (setq c 29119897960))) c)) - (fn1 `(lambda (c) - (declare (type (integer -70450 39128850560) c)) - (declare (optimize (speed 3) (safety 1))) - ,form))) - (funcall (compile nil fn1) 3512352656)) - 29119897960) - -(deftest misc.199 - (let* ((fn '(lambda (b) - (declare (type (integer 3352138624 13120037248) b)) - (declare (optimize (speed 3) (safety 1) (space 1))) - (progn (catch 'ct1 - (progn (setq b 11159349376) - (throw 'ct1 0))) - b)))) - (funcall (compile nil fn) 4108962100)) - 11159349376) - -;;; sbcl -;;; "The value 0 is not of type REAL." (???) - -(deftest misc.200 - (funcall - (compile nil '(lambda () - (declare (optimize (speed 1) (space 0) (safety 3) (debug 3) (compilation-speed 1))) - (ceiling - (ceiling - (flet ((%f16 () 0)) (%f16))))))) - 0 0) - -;;; ecl 5 Dec 2003 -;;; Wrong number of arguments passed to an anonymous function - -(deftest misc.201 - ;; form to be evaluated - (funcall - (compile - nil - '(lambda (a b) - (declare (optimize (speed 1) (space 0) (safety 0) (debug 2) - (compilation-speed 1))) - (flet ((%f10 (f10-1) (return-from %f10 a))) - (multiple-value-call #'%f10 (values b))))) - 10 -100) - ;; expected return value - 10) - -;;; Does not terminate? -(deftest misc.202 - (funcall - (compile - nil - '(lambda (a b c) - (declare (type (integer -363953100 5324773015552) a)) - (declare (type (integer -5744998440960 59520311) b)) - (declare (type (integer -1864645998 -14608) c)) - (declare (ignorable a b c)) - (declare (optimize (speed 3) (space 0) (safety 2) (debug 0) - (compilation-speed 2))) - (flet ((%f1 (f1-1 f1-2) - (labels ((%f1 (f1-1 f1-2) 0)) (%f1 a f1-2)))) - (%f1 0 c)))) - 10 20 -20000) - 0) - -;;; # -(deftest misc.203 - (funcall - (compile - nil - '(lambda (a) - (declare (optimize (speed 3) (space 1) (safety 2) (debug 0) - (compilation-speed 0))) - (labels ((%f18 (f18-1 f18-2 &optional (f18-3 a) (f18-4 a)) - f18-2)) - (multiple-value-call #'%f18 (values a 0))))) - 100) - 0) - -;;; `env0' undeclared (first use in this function) -(deftest misc.204 - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer -4801373 -50300) a)) - (declare (type (integer -62 -28) b)) - (declare (ignorable a b)) - (declare (optimize (speed 1) (space 3) (safety 3) (debug 2) - (compilation-speed 2))) - (flet ((%f12 (f12-1) 0)) - (labels ((%f3 (f3-1 f3-2 f3-3 &optional (f3-4 b) (f3-5 b) - (f3-6 (labels ((%f9 nil b)) - (apply #'%f12 (%f9) nil)))) - (%f12 0))) - (%f3 b 0 a))))) - -2224841 -54) - 0) - -;;; # is not of type INTEGER. -(deftest misc.205 - (funcall - (compile - nil - '(lambda (a b) - (declare (optimize (speed 3) (space 1) (safety 1) (debug 0) - (compilation-speed 3))) - (labels ((%f1 nil b)) - (flet ((%f11 (f11-1 f11-2 f11-3) 0)) - (apply #'%f11 a (logand (%f1)) - (flet ((%f13 (f13-1 f13-2) b)) - (apply #'%f13 0 0 nil)) - nil))))) - 100 200) - 0) - -;;; # is not of type INTEGER. -(deftest misc.206 - (funcall - #'(lambda (a b) - (declare (notinline mask-field byte)) - (declare (optimize (speed 1) (space 1) (safety 2) (debug 1) - (compilation-speed 2))) - (mask-field (byte 0 0) - (block b3 - (labels ((%f14 nil (return-from b3 a))) (%f14))))) - 1 2) - 0) - -;;; # is not of type INTEGER -(deftest misc.207 - (funcall - (compile - nil - '(lambda (a) - (declare (optimize (speed 3) (space 2) (safety 0) (debug 1) - (compilation-speed 0))) - (labels ((%f3 (f3-1) a)) - (labels ((%f10 (f10-1 f10-2) a)) - (apply #'%f10 0 (logior (%f3 0)) nil))))) - -10000) - -10000) - -;;; `env0' undeclared (first use in this function) -(deftest misc.208 - (funcall - (compile - nil - '(lambda (b) - (declare (optimize (speed 3) (space 2) (safety 3) (debug 3) - (compilation-speed 0))) - (flet ((%f6 (f6-1 f6-2 f6-3) f6-3)) - (labels ((%f8 (f8-1) (let* ((v1 (%f6 0 0 0))) 0))) - (apply #'%f6 b b (%f8 b) nil))))) - 10) - 0) - -;;; Wrong value computed -(deftest misc.209 - (funcall - (compile - nil - '(lambda (b) - (declare (optimize (speed 3) (space 2) (safety 3) (debug 3) - (compilation-speed 3))) - (max (catch 'ct4 (throw 'ct4 (setq b 0))) b))) - 6353) - 0) - -;;; Wrong value computed -(deftest misc.210 - (funcall - (compile - nil - '(lambda (c) - (declare (type (integer 3 65500689) c)) - (declare (optimize (speed 2) (space 1) (safety 3) (debug 3) - (compilation-speed 2))) - (catch 'ct6 - (let ((v10 (truncate (integer-length (throw 'ct6 0))))) c)))) - 100) - 0) - -(deftest misc.210a - (funcall - (compile - nil - '(lambda (a) - (declare (type (integer -55982525 -1) a)) - (declare (optimize (speed 1) (space 2) (safety 1) (debug 2) - (compilation-speed 1))) - (flet ((%f11 (f11-1 f11-2 f11-3) a)) - (let ((v6 0)) - (flet ((%f12 (f12-1) v6)) - (if (<= 0) (%f11 v6 0 0) - (multiple-value-call #'%f11 - (values 0 0 (%f11 0 0 (apply #'%f12 0 nil)))))))))) - -100) - -100) - -;;; Segmentation violation -(deftest misc.211 - (funcall - (compile - nil - '(lambda (a b c) - (declare (type (integer -1439706333184 1191686946816) a)) - (declare (type (integer -28 282229324) b)) - (declare (type (integer -108149896 38889958912) c)) - (declare (optimize (speed 3) (space 1) (safety 2) (debug 1) - (compilation-speed 3))) - (let ((v4 (labels ((%f8 (f8-1 &optional (f8-2 0) (f8-3 b)) 0)) - (logior (%f8 0) (%f8 0 0))))) - (truncate - (labels ((%f4 (&optional (f4-1 (ceiling c))) a)) - (%f4 v4)) - (max 38 - (labels ((%f8 (f8-1 &optional (f8-2 (+ c a))) 0)) - (apply #'%f8 a nil))))))) - -979021452526 138874383 21099308459) - -25763722434 - -34) - -;;; Wrong value returned -(deftest misc.212 - (funcall #'(lambda () - (declare (optimize (speed 2) (space 0) (safety 3) (debug 2) - (compilation-speed 0))) - (let* ((v9 (unwind-protect 0))) v9))) - 0) - -;;; segmentation violation -(deftest misc.213 - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer -2 -1) b)) - (declare (optimize (speed 1) (space 0) (safety 1) (debug 1) - (compilation-speed 3))) - (max (labels ((%f15 (f15-1) b)) (if (< 0 (%f15 a)) 0 0)) - (labels ((%f11 (f11-1 f11-2 f11-3) b)) - (apply #'%f11 0 0 0 nil))))) - 0 -2) - 0) - -(deftest misc.213a - (funcall - (compile - nil - '(lambda (a) - (declare (optimize (speed 3) (space 3) (safety 0) (debug 1) - (compilation-speed 3))) - (max (labels ((%f7 (f7-1) a)) (%f7 0)) - (flet ((%f12 (f12-1 f12-2) (if a f12-2 0))) - (apply #'%f12 0 a nil))))) - 123) - 123) - -;;; Wrong value -(deftest misc.214 - (funcall - (compile - nil - '(lambda (a) - (declare (optimize (speed 3) (space 1) (safety 2) (debug 0) - (compilation-speed 2))) - (flet ((%f8 nil (setq a 0))) (max a (%f8))))) - 100) - 100) - -;;; Wrong value -(deftest misc.215 - (funcall - (compile - nil - '(lambda () - (declare (optimize (speed 3) (space 3) (safety 3) (debug 0) - (compilation-speed 2))) - (ldb (byte 26 6) -1252)))) - 67108844) - -(deftest misc.215a - (funcall - (compile nil '(lambda () - (declare (optimize (speed 3) (space 2) (safety 2) (debug 1) - (compilation-speed 2))) - (ldb (byte 30 0) -407020740)))) - 666721084) - -;;; Floating point exception -(deftest misc.216 - (truncate 0 -2549795210) - 0 0) - -(deftest misc.217 - (ceiling 0 -2549795210) - 0 0) - -(deftest misc.218 - (floor 0 -2549795210) - 0 0) - -;;; Infinite loop -(deftest misc.219 - (funcall - (compile - nil - '(lambda () - (labels ((%f (a b) - (labels ((%f (c d) 0)) - (%f 1 2)))) - (%f 3 4))))) - 0) - -;;; #\^E is not of type NUMBER. -(deftest misc.220 - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer -3218770816 9386121) a)) - (declare (type (integer -1 13) b)) - (declare (ignorable a b)) - (declare (optimize (speed 2) (space 1) (safety 1) (debug 0) - (compilation-speed 1))) - (labels ((%f18 (f18-1 f18-2 f18-3) a)) - (apply #'%f18 0 a - (%f18 b - (- (labels ((%f11 (f11-1 f11-2 f11-3) a)) - (%f11 0 0 0))) - a) - nil)))) - -468614602 3) - -468614602) - -;;; Floating point exception -(deftest misc.221 - (truncate 0 3006819284014656913408) - 0 0) - -(deftest misc.222 - (ceiling 0 3006819284014656913408) - 0 0) - -(deftest misc.223 - (floor 0 3006819284014656913408) - 0 0) - -;;; clisp (10 Dec 2003 cvs head) -;;; *** - SYMBOL-VALUE: 2 is not a SYMBOL - -(deftest misc.224 - (funcall - (compile - nil - '(lambda (a b c) - (declare (optimize (speed 2) (space 3) (safety 0) - (debug 1) (compilation-speed 0))) - (flet ((%f14 (f14-1 f14-2 - &optional (f14-3 c) - (f14-4 (if (not nil) - (labels ((%f9 nil 0)) (%f9)) - a))) - (flet ((%f17 (f17-1 f17-2) f14-1)) (%f17 0 f14-3)))) - (%f14 (%f14 0 a) 0 b a)))) - 248000 5409415 227923) - 0) - -;;; Wrong values -(deftest misc.225 - (funcall (compile nil '(lambda () (values (values 'a 'b))))) - a) - -;;; clisp (12 Dec 2003, 2:30AM CST cvs head) -;;; SYMBOL-VALUE: 1 is not a SYMBOL -(deftest misc.226 - (funcall - (compile nil - '(lambda (a) - (flet ((%f (&optional (x (setq a 1)) - (y (setq a 2))) - 0)) - (%f 0 0)))) - 0) - 0) - -(deftest misc.227 - (funcall - (compile - nil - '(lambda (b) - (flet ((%f (&optional x (y (setq b 1))) x)) - (%f 0)))) - 0) - 0) - -;;; acl (x86 linux 6.2, patched 12 Dec 2003) -;;; No from-creg to move to... -(deftest misc.228 - (funcall - (compile - nil - '(lambda (a b c) - (declare (optimize (speed 1) (space 2) (safety 0) (debug 2) - (compilation-speed 2))) - (catch 'ct2 - (case 0 - ((-56087 86404 -94716) - (signum (labels ((%f7 (f7-1 f7-2 f7-3) f7-2)) 0))) - ((12986) - (let ((v3 (catch 'ct2 (throw 'ct2 0)))) - (labels ((%f14 (f14-1 f14-2) 0)) (%f14 b c)))) - (t 0))))) - -3847091255 -13482 -7577750) - 0) - -(deftest misc.228a - (funcall - (compile - nil - '(lambda (a b c) - (declare (type (integer -249606 2) a)) - (declare (type (integer 125 511) b)) - (declare (type (integer -2 1) c)) - (declare (ignorable a b c)) - (declare (optimize (speed 2) (space 2) (safety 1) (debug 3) - (compilation-speed 3))) - (catch 'ct4 - (rational (case b - ((350 244 1059) (prog2 (numerator c) 0)) - ((1705 493) - (unwind-protect - (throw 'ct4 c) - (loop for lv2 below 2 count (logbitp 0 c)))) - (t a)))))) - 0 200 -1) - 0) - -(deftest misc.228b - (funcall - (compile - nil - '(lambda (c) - (declare (type (integer -1 412413109) c)) - (declare (optimize (speed 1) (space 2) (safety 2) (debug 1) - (compilation-speed 3))) - (catch 'ct2 - (logior (* (progn (if c 0 (throw 'ct2 0)) 0) - (catch 'ct2 (throw 'ct2 0))) - (complex c 0) - )))) - 62151) - 62151) - -;;; Error: `T' is not of the expected type `INTEGER' -(deftest misc.229 - (funcall - (compile - nil - '(lambda nil - (declare (optimize (speed 2) (space 1) (safety 1) (debug 2) - (compilation-speed 3))) - (labels ((%f15 (f15-1) 0)) - (let ((v4 0)) - (catch 'ct5 - (%f15 - (gcd (catch 'ct5 (let* ((v5 (throw 'ct5 0))) 0)) v4)))))))) - 0) - -;;; ecl -;;; Wrong result (order of evaluation problem) - -(deftest misc.230 - (funcall - (compile - nil - '(lambda (a) - (declare (type (integer -6527559920 -247050) a)) - (declare (optimize (speed 1) (space 3) (safety 0) (debug 0) - (compilation-speed 3))) - (labels ((%f10 (&optional (f10-1 0) - (f10-2 (setq a -4456327156))) - 0)) - (logxor a (%f10 a))))) - -3444248334) - -3444248334) - -;;; cmucl -;;; Wrong value - -(deftest misc.231 - (funcall - (compile - nil - '(lambda (b) - (declare (type (integer -5209401 3339878) b)) - (declare (optimize (speed 1) (space 2) (safety 0) (debug 2) - (compilation-speed 3))) - (flet ((%f3 (f3-1 f3-2) - f3-1)) - (apply #'%f3 0 (logxor (catch 'ct2 b) - (catch 'ct5 (throw 'ct5 0))) nil)))) - -2179757) - 0) - -;;; Invalid number of arguments: 1 -(deftest misc.232 - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer 197447754 495807327) a)) - (declare (type (integer -125379462 1863191461) b)) - (declare - (optimize (speed 2) (space 2) (safety 2) (debug 1) (compilation-speed 2))) - (flet ((%f8 - (&optional - (f8-1 - (max (catch (quote ct4) 0) - (catch (quote ct6) (throw (quote ct6) 0))))) - b)) - (flet ((%f16 (f16-1 f16-2 f16-3) - 0)) - (apply #'%f16 a 0 (%f8) nil))))) - 348270365 28780966) - 0) - -;;; The assertion (EQ C::CHECK :SIMPLE) failed. -(deftest misc.233 - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer -2333758327203 -321096206070) a)) - (declare (type (integer -2842843403569 258395684270) b)) - (declare (optimize (speed 2) (space 0) (safety 1) (debug 2) - (compilation-speed 2))) - (flet ((%f18 (f18-1) - (the integer - (labels ((%f9 (f9-1 f9-2) - (* (- -1 -210032251) - (1+ - (floor - (labels ((%f11 (f11-1 f11-2) - -96773966)) - (%f11 b -3440758))))))) - (flet ((%f2 - (f2-1 f2-2 f2-3 - &optional (f2-4 (%f9 -429204 -63)) - (f2-5 (- (%f9 b 17) a)) - (f2-6 - (multiple-value-call #'%f9 - (values - (let () 7127585) - (flet ((%f1 (f1-1 f1-2 f1-3) - (catch 'ct6 -569234))) - (macrolet () 13)))))) - 1027)) - (if nil - (%f2 b a f18-1 69968 4 -217193265) - (catch 'ct1 129548688))))))) - (max (apply #'%f18 (list 0)))))) - -2067244683733 143879071206) - 129548688) - -;;; NIL is not of type C::TAIL-SET -(deftest misc.234 - (funcall - (compile - nil - '(lambda (b) ;; (a b) - (declare (type (integer -13583709 -3876310) b)) - (declare (optimize (speed 1) (space 2) (safety 3) (debug 3) - (compilation-speed 1))) - (flet ((%f14 (f14-1 f14-2 f14-3) - (flet ((%f2 - (f2-1 - &optional (f2-2 0) (f2-3 0) - (f2-4 - (block b8 (if (ldb-test (byte 0 0) 0) (* 0 f14-2) 0)))) - 0)) - (%f2 b f14-2)))) - (%f14 0 0 (%f14 0 0 0))))) - ;; -155589 - -5694124) - 0) - -;;; sbcl 0.8.6.34 -;;; Wrong value -(deftest misc.235 - (funcall - (compile - nil - '(lambda (b) - (declare (notinline not)) - (declare (optimize (speed 1) (space 0) (safety 0) - (debug 2) (compilation-speed 3))) - (multiple-value-prog1 0 (catch 'ct2 (if (not nil) (throw 'ct2 b) 0))))) - :wrong) - 0) - -(deftest misc.236 - (funcall - (compile - nil - '(lambda (a b) - (declare (optimize (speed 1) (space 0) (safety 3) - (debug 0) (compilation-speed 1))) - (flet ((%f8 (f8-1) 0)) - (labels ((%f18 (f18-1 f18-2 &optional (f18-3 0)) - (%f8 (catch 'ct7 (throw 'ct7 f18-1))))) - (multiple-value-prog1 (catch 'ct7 a) - 0 - (multiple-value-call #'%f18 (values 0 (%f8 b)))))))) - :good :bad) - :good) - -(deftest misc.237 - (funcall - (compile - nil - '(lambda () - (declare (optimize (speed 2) (space 2) (safety 3) - (debug 3) (compilation-speed 1))) - (multiple-value-prog1 0 - (catch 'ct7 (logandc1 (block b7 0) - (throw 'ct7 -908543))))))) - 0) - -;;; cmucl (11 2003 snapshot) - -;;; NIL is not of type C::CONTINUATION -(deftest misc.238 - (funcall - (compile - nil - '(lambda (a) - (declare (type (integer -77145797 -1) a)) - (declare (optimize (speed 1) (space 1) (safety 3) (debug 3) (compilation-speed 1))) - (flet ((%f5 (f5-1) a)) - (%f5 (unwind-protect 0 (logand (- (catch 'ct5 0)))))))) - -100) - -100) - -(deftest misc.238a - (funcall - (compile - nil - '(lambda () - (declare (optimize (speed 3) (space 2) (safety 3) - (debug 0) (compilation-speed 0))) - (min (load-time-value 0)) - 0))) - 0) - -;;; (in C::MAYBE-LET-CONVERT) -(deftest misc.239 - (funcall - (compile - nil - '(lambda (a) - (declare (type (integer -2315418108387 111852261677) a)) - (declare (optimize (speed 2) (space 0) (safety 2) (debug 2) (compilation-speed 1))) - (labels ((%f4 () - (labels ((%f16 (f16-1 f16-2) 0)) - (flet ((%f9 () 0)) - (%f16 0 (%f16 (%f9) a)))))) - (flet ((%f10 (f10-1 f10-2 f10-3) - (flet ((%f15 (f15-1 &optional (f15-2 (%f4)) (f15-3 0)) f15-3)) - 0))) - 0)))) - 100) - 0) - -(deftest misc.239a - (funcall - (compile nil '(lambda () (declare (optimize speed safety)) - (LET ((x (PROG1 0 (ROUND 18916)))) (catch 'ct4 0))))) - 0) - -(deftest misc.240 - (funcall - (compile - nil - '(lambda (b) - (declare (type (integer 4 7) b)) - (declare (optimize (speed 2) (space 3) (safety 3) (debug 1) (compilation-speed 3))) - (unwind-protect 0 - (common-lisp:handler-case - (max - (let ((*s1* b)) - (declare (special *s1*)) - (+ 0 *s1*))))))) - 5) - 0) - -;;; clisp (12 Dec 2003 cvs head) -;;; *** - Compiler bug!! Occurred in ASSEMBLE-LAP at ILLEGAL INSTRUCTION. -(deftest misc.241 - (funcall - (compile - nil - '(lambda () - (declare (optimize (speed 3) (space 3) (safety 0) (debug 0) (compilation-speed 2))) - (labels ((%f17 (f17-1 f17-2) (multiple-value-prog1 0 0 0 (return-from %f17 0)))) (%f17 0 0))))) - 0) - -(deftest misc.242 - (funcall (compile nil '(lambda (a) (block b6 (multiple-value-prog1 a (return-from b6 0))))) :wrong) - 0) - -(deftest misc.243 - (funcall (compile nil '(lambda () (block b3 (return-from b3 (multiple-value-prog1 0 (return-from b3 0))))))) - 0) - -;;; lispworks 4.3 (personal edition) -(deftest misc.244 - (funcall - (compile - nil - '(lambda (b) - (declare (optimize (speed 3) (space 1) (safety 2) (debug 3) (compilation-speed 2))) - (catch 'ct8 (labels ((%f4 (&optional (f4-1 0) (f4-2 (throw 'ct8 0))) f4-1)) (%f4 b))))) - :wrong) - 0) - -(deftest misc.245 - (funcall - (compile - nil - '(lambda (a) - (declare (optimize (speed 2) (space 0) (safety 0) (debug 2) (compilation-speed 1))) - (catch 'ct2 (labels ((%f11 (&optional (f11-1 (throw 'ct2 0))) a)) (apply #'%f11 0 nil))))) - 20) - 20) - -;;; ecl (cvs head, 18 Dec 2003) -(deftest misc.246 - (let ((x (unwind-protect 0))) x) - 0) - -(deftest misc.247 - (let ((x (dotimes (i 0 10)))) x) - 10) - -;;; acl 6.2 trial -;;; "Error: Attempt to access the plist field of 0 which is not a symbol." - -(deftest misc.248 - (funcall (compile nil '(lambda () (dotimes (i 0 0) 0)))) - 0) - -;;; sbcl -;;; # -;;; not found in -;;; # - -(deftest misc.249 - (funcall - (compile - nil - '(lambda (a b) - (declare (notinline <=)) - (declare (optimize (speed 2) (space 3) (safety 0) - (debug 1) (compilation-speed 3))) - (if (if (<= 0) nil nil) - (labels ((%f9 (f9-1 f9-2 f9-3) - (ignore-errors 0))) - (dotimes (iv4 5 a) (%f9 0 0 b))) - 0))) - 1 2) - 0) - -;;; cmucl 11/2003 -(deftest misc.250 - (funcall - (compile - nil - '(lambda (a) - (declare (type (integer -12 14) a)) - (declare (optimize (speed 1) (space 2) (safety 1) (debug 1) (compilation-speed 3))) - (let ((v6 0)) - (flet ((%f11 - (f11-1 - &optional - (f11-2 - (case (catch 'ct7 0) - (t - (let* ((v2 (ignore-errors a))) - v6))))) - 0)) - (%f11 0 0))))) - 5) - 0) - -;;; NIL is not of type C::CONTINUATION -;;; (C::MAYBE-CONVERT-TO-ASSIGNMENT -;;; # -;;; WHERE-FROM= :DEFINED -;;; VARS= (F3-1 F3-2 F3-3)>) - -(deftest misc.251 - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer -186585769 -7483) a)) - (declare (type (integer -550 524) b)) - (declare - (optimize (speed 2) (space 1) (safety 1) (debug 2) (compilation-speed 3))) - (flet ((%f3 (f3-1 f3-2 f3-3) - 0)) - (%f3 0 0 - (flet ((%f13 (f13-1 f13-2) - 0)) - (if (/= b a) - b - (deposit-field (%f3 0 b 0) (byte 0 0) (%f3 0 0 (%f13 0 0))))))))) - -10000 0) - 0) - -;;; 8061593093 is not of type (INTEGER -2147483648 4294967295) -(deftest misc.252 - (funcall - (compile - nil - '(lambda (b) - (declare (type (integer -43443 9126488423) b)) - (declare (optimize (speed 3) (space 1) (safety 1) (debug 3) (compilation-speed 0))) - (logand (setq b 8061593093) (min b 0)))) - 0) - 0) - -(deftest misc.252a - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer -30189 -6047) a)) - (declare (type (integer -10 16391481067) b)) - (declare (optimize (speed 3) (space 1) (safety 2) (debug 3) - (compilation-speed 0))) - (if - (<= 0 - (let ((*s1* (setq b 12204309028))) - (declare (special *s1*)) - (truncate b))) - a - 0))) - -12618 16130777867) - -12618) - -;;; # fell through ETYPECASE expression. -;;; Wanted one of (C::BASIC-COMBINATION C::EXIT C::CRETURN C::CSET C::CIF -;;; (OR C::REF C:BIND)). -;;; [Condition of type CONDITIONS::CASE-FAILURE] -;;;[...] -;;; (C::SUBSTITUTE-CONTINUATION # #) - -(deftest misc.253 - (funcall - (compile - nil - '(lambda () - (declare (optimize (speed 2) (space 2) (safety 3) (debug 3) (compilation-speed 2))) - (flet ((%f17 (f17-1) 0)) - (%f17 (logandc1 0 (catch 'ct2 0))))))) - 0) - -(deftest misc.253a - (funcall - (compile - nil - '(lambda (c) - (declare (optimize (speed 1) (space 1) (safety 3) (debug 2) - (compilation-speed 1))) - (labels ((%f1 (f1-1 f1-2) - (isqrt (abs (complex f1-1 0))))) - (progn - (/ - (multiple-value-call #'%f1 - (values (1- (restart-bind nil 1416182210)) - 123337746)) - 1) - (tagbody) - c)))) - -34661) - -34661) - -;;; Wrong return value -(deftest misc.254 - (funcall - (compile - nil - '(lambda (a) - (declare (type (integer -5241 -1159) a)) - (declare (optimize (speed 3) (space 2) (safety 0) (debug 3) (compilation-speed 1))) - (gcd a - (let ((*misc.254* (setq a -4929))) ;; special variable - (declare (special *misc.254*)) - 0)))) - -3000) - 3000) - -(deftest misc.255 - (funcall - (compile - nil - '(lambda (b) - (declare (type (integer -3474321 15089206) b)) - (declare (optimize (speed 3) (space 3) (safety 3) (debug 3) (compilation-speed 0))) - (- b - (block b3 - (setq b 9367613) - 0)))) - 10) - 10) - -;;; clisp (20 Dec 2003) -;;; Bug involving tagbody and go in lexical function - -(deftest misc.256 - (funcall - (compile - nil - '(lambda () - (declare (optimize (speed 3) (space 0) (safety 3) (debug 0) (compilation-speed 0))) - (tagbody (flet ((%f6 () (go 18))) (%f6)) - 18)))) - nil) - -;;; clisp (22 Dec 2003) -;;; *** - Compiler bug!! Occurred in ACCESS-IN-STACK at STACKZ-END. - -(deftest misc.257 - (funcall - (compile - nil - '(lambda () - (declare (optimize (speed 1) (space 2) (safety 3) (debug 3) (compilation-speed 1))) - (declare (special b)) - (tagbody (flet ((%f1 (f1-1) - (flet ((%f9 (&optional (f9-1 b) (f9-2 (go tag2)) (f9-3 0)) 0)) - (%f9 0 0 0)))) - (%f1 0)) - tag2)))) - nil) - -;;; clisp (26 Dec 2003) -;;; PROGV binding is not having the correct effect in compiled code - -(deftest misc.258 - (funcall - (compile - nil - '(lambda () - (declare (optimize (speed 1) (space 2) (safety 1) (debug 1) - (compilation-speed 0))) - (let ((*s4* :right)) - (declare (special *s4*)) - (progv '(*s4*) (list :wrong1) (setq *s4* :wrong2)) - *s4*)))) - :right) - -;;; sbcl 0.8.7.5 -;;; The value 215067723 is not of type (INTEGER 177547470 226026978). - -(deftest misc.259 - (funcall - (compile - nil - '(lambda (a) - (declare (type (integer 177547470 226026978) a)) - (declare (optimize (speed 3) (space 0) (safety 0) (debug 0) - (compilation-speed 1))) - (logand a (* a 438810)))) - 215067723) - 13739018) - -(deftest misc.260 - (funcall - (compile - nil - '(lambda (a) - (declare (type (integer 43369342 45325981) a)) - (declare (optimize (speed 2) (space 0) (safety 2) - (debug 0) (compilation-speed 3))) - (logand 0 (* 5459177 a)))) - 44219966) - 0) - -(deftest misc.261 - (funcall - (compile - nil - '(lambda (b) - (declare (type (integer 379442022 806547932) b)) - (declare (optimize (speed 2) (space 0) (safety 0) - (debug 3) (compilation-speed 2))) - (logand b (* 227 b)))) - 551173513) - 545263625) - -(deftest misc.262 - (funcall - (compile - nil - '(lambda (a) - (declare (type (integer 515644 54674673) a)) - (declare (optimize (speed 3) (space 2) (safety 3) - (debug 0) (compilation-speed 1))) - (mask-field (byte 0 0) (* 613783109 a)))) - 28831407) - 0) - -(deftest misc.263 - (funcall - (compile - nil - '(lambda (a) - (declare (type (integer 862944 60462138) a)) - (declare (optimize (speed 3) (space 3) (safety 0) - (debug 1) (compilation-speed 1))) - (logandc2 0 (* a 18094747)))) - 36157847) - 0) - -(deftest misc.264 - (funcall - (compile - nil - '(lambda (a) - (declare (type (integer 896520522 1249309734) a)) - (declare (optimize (speed 3) (space 3) (safety 1) - (debug 1) (compilation-speed 2))) - (lognand 0 (* a 1381212086)))) - 1202966173) - -1) - -;;; sbcl 0.8.7.6 -;;; Lisp error during constant folding: -;;; The function SB-VM::%LEA-MOD32 is undefined. - -(deftest misc.265 - (funcall - (compile - nil - '(lambda (a) - (declare (type (integer -19621 11895) a)) - (declare (optimize (speed 3) (space 2) (safety 3) - (debug 3) (compilation-speed 3))) - (* 0 a 103754))) - 1) - 0) - -;;; ecl (10 jan 2004) -;;; A bug was found in the compiler. Contact worm@arrakis.es. -;;; Broken at C::C2GO. - -(deftest misc.266 - (funcall - (compile - nil - '(lambda () - (tagbody - (flet ((%f (x) :bad)) (multiple-value-call #'%f (go done))) - done)))) - nil) - -(deftest misc.266a - (funcall - (compile - nil - '(lambda (b) - (declare (type (integer -14356828946432 -24266) b)) - (declare (optimize (speed 3) (space 1) (safety 1) (debug 3) - (compilation-speed 2))) - (progn (tagbody (unwind-protect 0 (go 3)) 3) b))) - -30000) - -30000) - -;;; Broken at C::C2VAR. -(deftest misc.266b - (funcall - (compile - nil - '(lambda (b) - (declare (optimize (speed 2) (space 3) (safety 2) (debug 0) - (compilation-speed 0))) - (unwind-protect 0 (catch 'ct7 (prog1 b 0))))) - 1) - 0) - -;;; Incorrect return value - -(deftest misc.267 - (locally (declare (special *s5*)) - (let ((v8 (progv '(*s5*) (list 0) (if t *s5* *s5*)))) - v8)) - 0) - -(deftest misc.267a - (let ((x (progv nil nil 0))) x) - 0) - -(deftest misc.268 - (funcall - (compile - nil - '(lambda () - (declare (optimize (speed 1) (space 1) (safety 3) (debug 2) - (compilation-speed 2))) - (catch 'ct7 - (rationalize (let ((v9 (1+ (throw 'ct7 0)))) 48955)))))) - 0) - -(deftest misc.269 - (funcall - (compile - nil - '(lambda (a) - (declare (type (integer -1 20) a)) - (declare (optimize (speed 3) (space 1) (safety 2) (debug 2) - (compilation-speed 3))) - (if (if a (logbitp 34 a) nil) 0 -230678))) - 14) - -230678) - -(deftest misc.270 - (let ((*s3* (dotimes (iv4 0 10) (if t iv4 8)))) - (declare (special *s3*)) - *s3*) - 10) - -(deftest misc.271 - (let ((v2 (unwind-protect 0))) v2) - 0) - -;;; wrong number of values passed to anonymous function - -(deftest misc.272 - (funcall - (compile - nil - '(lambda () - (declare (optimize (speed 3) (space 1) (safety 0) (debug 3) - (compilation-speed 2))) - (flet ((%f17 (f17-1) 1)) - (multiple-value-call #'%f17 (values (floor 0))))))) - 1) - -;;; clisp (10 jan 2004) -;;; Improper handling of a jump to an exit point from unwind-protect -;;; (see CLHS section 5.2) - -(deftest misc.273 - (funcall - (compile - nil - '(lambda (d) - (declare (optimize (speed 3) (space 0) (safety 3) - (debug 2) (compilation-speed 0))) - (gcd 39 - (catch 'ct2 - (block b7 - (throw 'ct2 - (unwind-protect - (return-from b7 17) - (return-from b7 - (progv '(*s6*) (list 31) d)) - ))))))) - 65) - 13) - -;;; sbcl 0.8.7.13 -;;; Lexical unwinding of UVL stack is not implemented. - -(deftest misc.274 - (funcall - (compile - nil - '(lambda () - (declare - (optimize (speed 2) - (space 2) - (safety 1) - (debug 2) - (compilation-speed 0))) - (multiple-value-prog1 - (ignore-errors 0) - 0 - (catch 'ct7 0) - (catch 'ct1 - (catch 'ct4 - (complex (throw 'ct4 (dotimes (iv4 0 0) (throw 'ct1 0))) 0))))))) - 0) - -(deftest misc.274a - (funcall - (compile - nil - '(lambda () - (declare (optimize (speed 3) (space 1) (safety 3) - (debug 1) (compilation-speed 3))) - (dotimes (iv4 3 0) - (apply (constantly 0) - 0 - (catch 'ct2 (throw 'ct2 (rem 0 (max 46 0)))) - nil))))) - 0) - - -;;; failed AVER: "SUCC" - -(deftest misc.275 - (funcall - (compile - nil - '(lambda (b) - (declare (notinline funcall min coerce)) - (declare - (optimize (speed 1) - (space 2) - (safety 2) - (debug 1) - (compilation-speed 1))) - (flet ((%f12 (f12-1) - (coerce - (min - (if f12-1 (multiple-value-prog1 - b (return-from %f12 0)) - 0)) - 'integer))) - (funcall #'%f12 0)))) - -33) - 0) - -(deftest misc.275a - (funcall - (compile - nil - '(lambda () - (declare (optimize (speed 2) (space 0) (safety 2) - (debug 1) (compilation-speed 1))) - (block b4 - (coerce - (logcount - (if t 0 (multiple-value-prog1 (identity 0) (return-from b4 0)))) - 'integer))))) - 0) - -;;; clisp (28 Jan 2004) -;;; Different return values - -(deftest misc.276 - (funcall - (compile - nil - `(lambda (b) - (declare (optimize (speed 2) (space 0) (safety 0) - (debug 3) (compilation-speed 3))) - (labels - ((%f2 () - (let ((v10 (progn (dotimes (iv2 0 0) iv2) - b))) - (unwind-protect b (labels ((%f6 ())) (%f6)) - )))) - (%f2)))) - :good) - :good) - -;;; Lispworks 4.3 linux (personal edition) - -;;; Error: In - of (1 NIL) arguments should be of type NUMBER -(deftest misc.277 - (funcall - (compile - nil - '(lambda () - (declare (optimize (speed 3) (space 1) (safety 0) - (debug 3) (compilation-speed 0))) - (labels ((%f15 (&optional (f15-3 - (tagbody (labels ((%f6 () (go tag1))) (%f6)) tag1))) - 0)) - (%f15))))) - 0) - -;;; incorrect return value -(deftest misc.278 - (funcall - (compile - nil - '(lambda () - (declare (optimize (speed 1) (space 0) (safety 2) (debug 3) - (compilation-speed 0))) - (catch 'ct5 (flet ((%f2 (&optional (f2-4 (throw 'ct5 0))) 1)) - (%f2 (%f2 0))))))) - 1) - -;;; incorrect return value -(deftest misc.279 - (funcall - (compile - nil - '(lambda () - (declare (optimize (speed 1) (space 1) (safety 3) (debug 0) (compilation-speed 3))) - (flet ((%f10 () - (if (< 0 (dotimes (iv2 1 -501162))) - 0 -14))) - (%f10))))) - -14) - -;;; incorrect return value (may be same bug as misc.278) -(deftest misc.280 - (funcall - (compile - nil - '(lambda (a) - (declare (optimize (speed 1) (space 3) (safety 1) (debug 3) (compilation-speed 2))) - (catch 'ct6 - (labels ((%f12 () - (labels ((%f14 (&optional (f14-3 (return-from %f12 5))) 4)) - (funcall (constantly 3) - (let ((v2 (%f14))) 2) - (throw 'ct6 1) - )))) - (%f12) - a)))) - :good) - :good) - -;;; incorrect return value -(deftest misc.281 - (funcall - (compile - nil - '(lambda (c) - (declare (optimize (speed 3) (space 3) (safety 3) (debug 2) (compilation-speed 3))) - (ldb (byte 24 0) c))) - -227016367797) - 12919115) - -;;; gcl: Error in COMPILER::CMP-ANON [or a callee]: The function COMPILER::LDB1 is undefined. -(deftest misc.282 - (funcall (compile nil '(lambda () (declare (optimize safety)) - (ldb (byte 13 13) 43710)))) - 5) - -;;; gcl (2/28/2004) -;;; Error in COMPILER::CMP-ANON [or a callee]: T is not of type INTEGER. -(deftest misc.283 - (funcall - (compile - nil - '(lambda (b d) - (declare (optimize (speed 2) (space 2) (safety 1) (compilation-speed 3))) - (expt (logxor (progn - (tagbody - (multiple-value-prog1 0 (go 7)) - 7) - 0) - 0 b - (rational d)) - 0))) - 2 4) - 1) - -;;; Error in COMPILER::CMP-ANON [or a callee]: 3 is not of type FUNCTION. -;;; (possibly the same bug as misc.283) -(deftest misc.284 - (funcall - (compile - nil - '(lambda (c) - (declare (optimize (speed 1) (space 1) (safety 2) (debug 3) - (compilation-speed 2))) - (progn - (tagbody - (multiple-value-prog1 0 (go tag2)) - 0 - tag2) - (funcall (constantly 0) - (apply (constantly 0) (signum c) nil))))) - 3) - 0) - -;;; ecl 29 Feb 2004 -;;; Incorrect constant propagation -(deftest misc.285 - (funcall - (compile - nil - '(lambda (a) - (declare (optimize (speed 2) (space 0) (safety 0) (debug 2) - (compilation-speed 3))) - (block b7 (let* ((v1 (* (return-from b7 0) a))) -4359852)))) - 1) - 0) - -(deftest misc.286 - (let ((v4 (dotimes (iv4 0 18494910) (progn 0)))) v4) - 18494910) - -;;; gcl (found by Camm) -;;; Error in COMPILER::CMP-ANON [or a callee]: The function NIL is undefined. -(deftest misc.287 - (funcall - (compile - nil - '(lambda (e) - (declare (optimize (speed 1) (space 3) (safety 3) (debug 3) - (compilation-speed 1))) - (flet ((%f11 (f11-2) 0)) - (%f11 (unwind-protect - e - (tagbody - (let* ((v4 (unwind-protect (go 0)))) 0) - 0) - (logand (handler-bind () 0))))))) - 10) - 0) - -#| -ecl (6 Mar 2004) -(LAMBDA (C::LOC1 C::LOC2) (IF (AND (CONSP C::LOC1) - (EQ (CAR C::LOC1) 'FIXNUM) - (CONSP (CADR C::LOC1)) - (EQ (CAADR C::LOC1) 'C::FIXNUM-VALUE) - (EQ (CADR (CADR C::LOC1)) 2)) - (PROGN (C::WT1 "(1<<(") - (C::WT1 C::LOC2) (C::WT1 "))")) - (PROGN (C::WT1 "fixnum_expt(") - (C::WT1 C::LOC1) - (C::WT1 #\,) - (C::WT1 C::LOC2) - (C::WT1 #\))))) -is not of type STRING. -Broken at C::WT-C-INLINE-LOC. -|# - -(deftest misc.288 - (funcall - (compile - nil - '(lambda () - (declare (optimize (speed 1) (space 2) (safety 3) (debug 3) - (compilation-speed 2))) - (let ((v2 (integer-length (expt 0 0)))) - (dotimes (iv4 0 0) (logand v2)))))) - 0) - -;;; cmucl -;;; wrong return value - -(deftest misc.289 - (funcall - (compile - nil - '(lambda (b) - (declare (optimize (speed 3) (space 1) (safety 1) (debug 2) - (compilation-speed 2))) - (multiple-value-prog1 (apply (constantly 0) b 0 0 nil) - (catch 'ct8 (throw 'ct8 -2))))) - 1) - 0) - -;;; sbcl (0.8.8.23.stack.1) -;;; failed AVER: "(TAILP BLOCK2-STACK BLOCK1-STACK)" - -(deftest misc.290 - (funcall - (compile - nil - '(lambda () - (declare - (optimize (speed 3) (space 3) (safety 1) - (debug 2) (compilation-speed 0))) - (apply (constantly 0) (catch 'ct2 0) 0 (catch 'ct2 0) nil)))) - 0) - -(deftest misc.290a - (funcall - (compile - nil - '(lambda () - (declare (optimize (speed 2) (space 1) (safety 0) - (debug 0) (compilation-speed 0))) - (boole boole-nor - (expt - (let ((v2 (expt (catch 'ct7 0) 0))) - 0) - 0) - (expt (apply (constantly 0) 0 0 (catch 'ct6 0) nil) 0))))) - -2) - -;; Allegro CL 6.2 (14 Mar 2004) interpreter bug -;; Error: Cannot go to TAG, its body has been exited. - -(deftest misc.291 - (funcall - #'(lambda (a) - (declare (notinline numerator)) - (declare (optimize (speed 2) (space 3) (safety 2) (debug 0) - (compilation-speed 2))) - (tagbody (tagbody (progn a) tag) - (go tag) - tag)) - 17) - nil) - -;;; sbcl 0.8.8.23.stack.2 -;;; The value -1 is not of type (MOD 536870911). - -(deftest misc.292 - (funcall - (compile - nil - '(lambda (a b c) - (declare - (optimize (speed 3) (space 2) (safety 3) (debug 0) - (compilation-speed 1))) - (flet ((%f15 (f15-1 f15-2 f15-3) - (apply (constantly 0) - 0 - 0 - (ignore-errors - (let ((v10 (apply (constantly 0) - b a (max 0 c) nil))) - 0)) - nil))) - (flet ((%f14 (f14-1 &optional (f14-2 b) (f14-3 0) (f14-4 0)) - (%f15 0 0 b))) - (%f14 0 c))))) - 1 2 3) - 0) - -(deftest misc.292a - (funcall - (compile - nil - '(lambda (a b) - (declare (optimize (speed 2) (space 0) (safety 3) (debug 1) - (compilation-speed 2))) - (apply (constantly 0) - a - 0 - (catch 'ct6 - (apply (constantly 0) - 0 - 0 - (let* ((v1 - (let ((*s7* 0)) - b))) - 0) - 0 - nil)) - 0 - nil))) - 1 2) - 0) - -;;; failed AVER: "(NOT (MEMQ PUSH END-STACK))" - -(deftest misc.293 - (funcall - (compile - nil - '(lambda (a) - (declare (optimize (speed 2) (space 1) (safety 3) (debug 3) - (compilation-speed 3))) - (let ((v6 - (labels ((%f9 (f9-1) - (multiple-value-prog1 0 (return-from %f9 0) a))) - (let ((*s4* (%f9 0))) - 0)))) - 0))) - 1) - 0) - -(deftest misc.293a - (funcall - (compile - nil - '(lambda (a b c) - (declare (optimize (speed 2) (space 3) (safety 1) - (debug 2) (compilation-speed 2))) - (block b6 - (multiple-value-prog1 - 0 b 0 - (catch 'ct7 - (return-from b6 - (catch 'ct2 - (complex (cl::handler-bind nil -254932942) 0)))))))) - 1 2 3) - -254932942) - -(deftest misc.293b - (funcall - (compile - nil - '(lambda () - (declare (notinline complex)) - (declare (optimize (speed 1) (space 0) (safety 1) - (debug 3) (compilation-speed 3))) - (flet ((%f () (multiple-value-prog1 0 (return-from %f 0)))) - (complex (%f) 0))))) - 0) - -(deftest misc.293c - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer -6556 -33) a)) - (declare (type (integer -1973908574551 1125) b)) - (declare (ignorable a b)) - (declare - (optimize (compilation-speed 0) - (space 2) - (safety 0) - (debug 2) - (speed 0) - #+sbcl (sb-c:insert-step-conditions 0) - )) - (block b4 - (multiple-value-prog1 0 - (catch 'ct7 (return-from b4 (catch 'ct6 (if a 0 b)))) - 0 - 0)))) - -237 -1365751422718) - 0) - -(deftest misc.293d - (funcall - (compile - nil - '(lambda () - (declare (optimize (debug 3) (safety 0) (space 2) - (compilation-speed 2) (speed 2))) - (block b4 - (multiple-value-prog1 - 0 - (catch 'ct8 - (return-from b4 (catch 'ct2 (progn (tagbody) 0))))))))) - 0) - - -;;; failed AVER: "(SUBSETP START START-STACK)" - -(deftest misc.294 - (funcall - (compile - nil - '(lambda (a b c) - (declare (notinline /=)) - (declare (optimize (speed 2) (space 0) (safety 1) - (debug 0)(compilation-speed 1))) - (catch 'ct1 - (flet ((%f1 (f1-1 f1-2 f1-3) - (throw 'ct1 - (if (/= 0) 0 (multiple-value-prog1 - 0 (throw 'ct1 a) c))))) - (let ((*s3* (%f1 a a 0))) - 0))))) - 1 2 3) - 0) - -(deftest misc.294a - (funcall - (compile - nil - '(lambda (a b c) - (declare (notinline expt)) - (declare (optimize (speed 1) (space 2) (safety 3) - (debug 0) (compilation-speed 0))) - (catch 'ct2 - (expt - (catch 'ct2 - (throw 'ct2 (if a 0 (multiple-value-prog1 0 (throw 'ct2 c) 0)))) - 0)))) - 1 2 3) - 1) - -;;; The value NIL is not of type SB-C::IR2-BLOCK. - -(deftest misc.295 - (funcall - (compile - nil - '(lambda (a b c) - (declare (type (integer -2858 1050811) a)) - (declare (type (integer -419372 1395833) b)) - (declare (type (integer -4717708 795706) c)) - (declare (ignorable a b c)) - (declare - (optimize (speed 1) - (space 0) - (safety 2) - (debug 1) - (compilation-speed 2))) - (multiple-value-prog1 - (the integer - (catch 'ct8 - (catch 'ct5 - (catch 'ct7 - (flet ((%f3 (f3-1 f3-2 &optional (f3-3 a) (f3-4 c)) b)) - (labels ((%f13 (f13-1 f13-2 f13-3) - (let* ((*s4* - (return-from %f13 - (flet ((%f18 (f18-1 f18-2) - (apply #'%f3 - (progv nil nil f13-2) - (list (%f3 -460 f18-1 10095 352819651))))) - (flet ((%f5 () - (funcall #'%f3 - f13-2 - (flet ((%f14 (f14-1 f14-2 &optional (f14-3 f13-2) (f14-4 -15)) - 160080387)) - -196377) - (isqrt - (abs - (if (/= 117 (%f18 -14 -46574)) - (return-from - %f13 - (ignore-errors - (flet ((%f12 (f12-1 f12-2 &optional (f12-3 740148786) - (f12-4 -20) - (f12-5 -35261)) - f12-3)) - (%f3 - (%f3 b (%f12 c b f13-3 f13-1 -1124)) - 0 - -1003264058 - f13-1)))) - (block b3 (labels ((%f15 () f13-2)) -4858377))))) - (%f3 793 f13-2 f13-3 a)))) - f13-3))))) - (* -420793 - (%f3 (%f3 f13-1 f13-3 f13-3 f13-2) 0 8604 f13-1))))) - (lognor - (progv nil nil - (if (< -16 c) - 15867134 - (- - (throw 'ct5 - (prog1 7 - (floor - (max (%f13 -4862 -888 -53824112) a -17974 1540006) - (min -74 -473379))))))) - (progv nil nil (prog1 b 22 c a))))))))) - (catch 'ct1 (throw 'ct1 0)) - 0))) - 794801 211700 -1246335) - 7) - -;;; Tests added by Camm for gcl - -(deftest misc.296 - (funcall - (compile - nil - '(lambda (a b c d e f g h) - (declare (type (integer -2016726144 234357120) a)) - (declare (type (integer -10569521299456 -1307998945280) b)) - (declare (type (integer -45429002240 -17228484608) c)) - (declare (type (integer 228451840 1454976512) d)) - (declare (type (integer -4797 -2609) e)) - (declare (type (integer -21 36300536) f)) - (declare (type (integer -15983530 31646604) g)) - (declare (type (integer -208720272 -357) h)) - (declare (ignorable a b c d e f g h)) - (declare (optimize (speed 1) (space 3) (safety 3) (debug 0) - (compilation-speed 3))) - (expt (labels ((%f14 (f14-1 f14-2) - (progn - (tagbody - (+ - (unwind-protect - (labels ((%f1 (f1-1) (go tag1))) - (let ((*s6* (%f1 d))) 0)))) - tag1 - (+ - (cl::handler-bind () - (if (<= -11215713 -819) - (integer-length - (floor (conjugate f14-1) - (max 12 - (ceiling - (block b2 - (catch 'ct2 - (ignore-errors - (flet - ((%f13 (f13-1) - (logior 87 f14-2))) - f14-1)))))))) - (progv '(*s8*) (list 472865632) - *s8*))))) - 0))) - (%f14 0 0)) - 0))) - -28594854 -3859203606860 -40757449218 894599577 -4163 11621230 - 29558853 -92216802) - 1) - - -(deftest misc.297 - (funcall - (compile - nil - '(lambda (a b c d e f g h) - (declare (type (integer -4354712743936 666241234) a)) - (declare (type (integer -23496787232 13342697120) b)) - (declare (type (integer -6834570 6274788) c)) - (declare (type (integer -1988742 -250650) d)) - (declare (type (integer 10523345 10868247) e)) - (declare (type (integer -489185 -46267) f)) - (declare (type (integer -627627253760 226529) g)) - (declare (type (integer -1039260485 -22498) h)) - (declare (ignorable a b c d e f g h)) - (declare (optimize (speed 1) (space 3) (safety 2) (debug 2) - (compilation-speed 0))) - (labels ((%f7 (f7-1 f7-2 f7-3 &optional (f7-4 0) (f7-5 0) - (f7-6 (labels - ((%f6 (f6-1) - (labels ((%f9 (f9-1) 0)) - (progn - (tagbody - (unwind-protect - (if (%f9 (go tag4)) 0 0)) - tag4 - (cl::handler-case - 0)) - h)))) - (apply #'%f6 0 nil)))) - 0)) - (%f7 0 d 0 f d)))) - -4319330882538 -3195059121 -2799927 -1466395 10630639 -224479 - -502579707077 -985908422) - 0) - -(deftest misc.298 - (funcall - (compile - nil - '(lambda (a b c d e f g h) - (declare (type (integer 1296736620544 1680954654720) a)) - (declare (type (integer -2 -2) b)) - (declare (type (integer 1 42303) c)) - (declare (type (integer -38881008000 1333202563072) d)) - (declare (type (integer -435684 1289298) e)) - (declare (type (integer -164302654464 -10150328832) f)) - (declare (type (integer 30759259904 38429537792) g)) - (declare (type (integer -1628949299200 -47724342) h)) - (declare (ignorable a b c d e f g h)) - (declare (optimize (speed 3) (space 1) (safety 0) (debug 0) - (compilation-speed 1))) - (progn - (tagbody - (let ((v9 (unwind-protect (go 0)))) 0) - 0 - (numerator (funcall (constantly 0) (logorc2 0 0) 0))) - 0))) - 1451922002679 -2 285 1067997670626 1115209 -37445463114 - 36530345360 -80501559891) - 0) - -(deftest misc.299 - (funcall - (compile - nil - '(lambda (a b c d e f g h) - (declare (type (integer -1814 3348) a)) - (declare (type (integer -32239015 12) b)) - (declare (type (integer 128412 101411593) c)) - (declare (type (integer -329076792320 -22) d)) - (declare (type (integer 77651198 86069496) e)) - (declare (type (integer -4616 3453771) f)) - (declare (type (integer -14889981824 53610580608) g)) - (declare (type (integer -1049733788 46605484288) h)) - (declare (ignorable a b c d e f g h)) - (declare (optimize (speed 2) (space 1) (safety 3) (debug 2) - (compilation-speed 2))) - (conjugate - (progn - (tagbody - (flet ((%f3 nil 0)) - (unwind-protect - (flet ((%f10 (f10-1) (let ((*s6* (%f3))) (go 6)))) - (funcall #'%f10 f)))) - 6 - (let ((*s1* (restart-bind () - (labels ((%f1 (f1-1) 3136)) - (let () - (progv '(*s5* *s1*) - (list - (labels - ((%f2 nil (catch 'ct8 -11))) - -70941710) - (if nil (%f1 -1) 87)) - (progn - (tagbody - (%f1 *s1*) - 3 - (block b2 (progn a)) - tag3) - h))))))) - 0)) - 0)))) - 1555 -22062210 85224215 -161218251003 78463284 730073 - 33930166854 37839245921) - 0) - -(deftest misc.300 - (funcall - (compile - nil - '(lambda (a b c d e f g h) - (declare (type (integer -29429 -3320) a)) - (declare (type (integer -407874593 279639852) b)) - (declare (type (integer -542849760256 3344389718016) c)) - (declare (type (integer -2 12012755) d)) - (declare (type (integer -248 -228) e)) - (declare (type (integer 5 15636824592) f)) - (declare (type (integer 21039 21595) g)) - (declare (type (integer -1867743555584 -1621183025152) h)) - (declare (ignorable a b c d e f g h)) - (declare (optimize (speed 1) (space 3) (safety 1) (debug 2) - (compilation-speed 3))) - (labels ((%f12 (f12-1 f12-2 f12-3) 0)) - (labels ((%f17 (f17-1) - (progn - (tagbody - (max (apply (constantly 0) - (list - (%f12 (unwind-protect (go tag1)) - 0 d) - 0 f))) - tag1 - (dpb (realpart - (expt - (round - (return-from %f17 - (restart-bind () - (complex e 0))) - (max 40 0)) - 0)) - (byte 0 0) 0)) - 0))) - (%f12 0 (%f17 0) 0))))) - -6416 -274982013 2946309248013 1724720 -228 5782683458 21484 - -1681168611256) - 0) - - -(deftest misc.301 - (funcall - (compile - nil - '(lambda (a b c d e f g h) - (declare (type (integer -1814 3348) a)) - (declare (type (integer -32239015 12) b)) - (declare (type (integer 128412 101411593) c)) - (declare (type (integer -329076792320 -22) d)) - (declare (type (integer 77651198 86069496) e)) - (declare (type (integer -4616 3453771) f)) - (declare (type (integer -14889981824 53610580608) g)) - (declare (type (integer -1049733788 46605484288) h)) - (declare (ignorable a b c d e f g h)) - (declare (optimize (speed 2) (space 1) (safety 3) (debug 2) - (compilation-speed 2))) - (conjugate - (progn - (tagbody - (flet ((%f3 nil 0)) - (unwind-protect - (flet ((%f10 (f10-1) (let ((*s6* (%f3))) (go 6)))) - (funcall #'%f10 f)))) - 6 - (let ((*s1* (restart-bind () - (labels ((%f1 (f1-1) 3136)) - (let () - (progv '(*s5* *s1*) - (list - (labels - ((%f2 nil (catch 'ct8 -11))) - -70941710) - (if nil (%f1 -1) 87)) - (progn - (tagbody - (%f1 *s1*) - 3 - (block b2 (progn a)) - tag3) - h))))))) - 0)) - 0)))) - 1555 -22062210 85224215 -161218251003 78463284 730073 - 33930166854 37839245921) - 0) - -(deftest misc.302 - (funcall - (compile - nil - '(lambda (a b c d e f g h) - (declare (type (integer -206837809920 -126404559104) a)) - (declare (type (integer -277874608640 -63724432) b)) - (declare (type (integer -2 0) c)) - (declare (type (integer -5992710 9946878) d)) - (declare (type (integer -4345390743552 -76504514048) e)) - (declare (type (integer -330 3826137) f)) - (declare (type (integer -517792898560 -1193868) g)) - (declare (type (integer 2018 98092396) h)) - (declare (ignorable a b c d e f g h)) - (declare (optimize (speed 2) (space 2) (safety 2) (debug 1) - (compilation-speed 1))) - (flet ((%f12 (f12-1 f12-2 &optional (f12-3 0) - (f12-4 (progn - (tagbody - (unwind-protect (go tag6)) - tag6) - (flet ((%f1 (f1-1 f1-2) 0)) - (apply #'%f1 0 0 (list)))))) - 0)) - (%f12 0 e)))) - -195379170409 -30212852077 -1 -2082141 -1686846623470 360505 - -324299330279 37218064) - 0) - -(deftest misc.303 - (funcall - (compile - nil - '(lambda (a b c d e f g h) - (declare (type (integer -55724018 0) a)) - (declare (type (integer -4929718 2777256) b)) - (declare (type (integer 18939493568 24064422528) c)) - (declare (type (integer -13157393 112210531) d)) - (declare (type (integer -75775 -4883) e)) - (declare (type (integer 5071 1584913674240) f)) - (declare (type (integer -1 -1) g)) - (declare (type (integer -100 7017454141440) h)) - (declare (ignorable a b c d e f g h)) - (declare (optimize (speed 1) (space 3) (safety 3) (debug 1) - (compilation-speed 1))) - (labels ((%f7 (f7-1 &optional (f7-2 0) (f7-3 0) (f7-4 0)) 0)) - (progn - (denominator - (progn - (let ((*s6* (progn - (tagbody - (unwind-protect - (%f7 0 0 (go tag6) d)) - tag6 - (restart-case 0)) - 0))) - 0) - 0)) - 0)))) - -23410726 -4342503 20297113275 80145634 -17664 937086103773 -1 - 2923877584757) - 0) - -(deftest misc.304 - (funcall - (compile - nil - '(lambda (a b c d e f g h) - (declare (type (integer -11679 1672) a)) - (declare (type (integer -359757 -216048) b)) - (declare (type (integer -46345706880 -1824) c)) - (declare (type (integer -18 18) d)) - (declare (type (integer -70852138 427028370944) e)) - (declare (type (integer -428904547840 535369082368) f)) - (declare (type (integer -4372225 83) g)) - (declare (type (integer -2 0) h)) - (declare (ignorable a b c d e f g h)) - (declare (optimize (speed 2) (space 1) (safety 3) (debug 0) - (compilation-speed 1))) - (labels ((%f1 (f1-1 f1-2 f1-3) 0)) - (rationalize - (%f1 (progn - (tagbody - (let ((v3 (%f1 (unwind-protect (go tag2)) b 0))) - 0) - tag2) - 0) - h (cl::handler-case 0)))))) - -7209 -223767 -42093806027 -9 132172281069 138363461574 - -3751010 0) - 0) - -(deftest misc.305 - (funcall - (compile - nil - '(lambda (a b c d e f g h) - (declare (type (integer -438 247) a)) - (declare (type (integer -93662232 112841) b)) - (declare (type (integer 8769 2766606) c)) - (declare (type (integer -33007133760 32531429568) d)) - (declare (type (integer 419 3712) e)) - (declare (type (integer 1628 20513914304) f)) - (declare (type (integer -1347290 47) g)) - (declare (type (integer -12 3030073088) h)) - (declare (ignorable a b c d e f g h)) - (declare (optimize (speed 3) (space 3) (safety 0) (debug 3) - (compilation-speed 0))) - (flet ((%f5 (f5-1 f5-2 &optional (f5-3 0) (f5-4 0) (f5-5 0)) - (progn - (tagbody (unwind-protect (go tag1)) tag1) - (coerce (let* ((*s4* - (flet - ((%f1 nil - (let* - ((v7 (dpb 0 (byte 0 0) c))) - a))) - (progv '(*s6* *s7*) - (list (%f1) 0) - g)))) - c) - 'integer)))) - (if (%f5 d 0 e 0 0) h 0)))) - -58 -22237190 2055343 -8144832891 1213 19038103159 -1009345 - 929619162) - 929619162) - -(deftest misc.306 - (funcall - (compile - nil - '(lambda (a b c d e f g h) - (declare (type (integer 261 234565) a)) - (declare (type (integer -1454263719936 -3279802168) b)) - (declare (type (integer -1251120498 -49518770) c)) - (declare (type (integer 0 369) d)) - (declare (type (integer -12465203856 -45) e)) - (declare (type (integer -94321486 -91941853) f)) - (declare (type (integer -16528338864 11322249648) g)) - (declare (type (integer -1230549 -1143976) h)) - (declare (ignorable a b c d e f g h)) - (declare (optimize (speed 2) (space 1) (safety 0) (debug 0) - (compilation-speed 0))) - (denominator - (progn - (tagbody (unwind-protect (go tag7)) tag7) - (logxor f - (multiple-value-bind (*s4*) - (logxor 0 (expt -2 1)) - (truncate 0))))))) - 130724 -736795298357 -1221747467 326 -9775240900 -94105708 - -2273680158 -1156846) - 1) - -(deftest misc.307 - (funcall - (compile - nil - '(lambda (a b c d e f g h) - (declare (type (integer -2903632 1282236) a)) - (declare (type (integer 7 10741) b)) - (declare (type (integer -249635 214804) c)) - (declare (type (integer -50422 10469) d)) - (declare (type (integer -52337314 10771161) e)) - (declare (type (integer 0 5333060) f)) - (declare (type (integer -1 0) g)) - (declare (type (integer 1595835 4577573) h)) - (declare (ignorable a b c d e f g h)) - (declare (optimize (speed 1) (space 3) (safety 3) (debug 3) - (compilation-speed 1))) - (flet ((%f11 (f11-1 f11-2) 0)) - (%f11 0 - (unwind-protect - e - (progn - (tagbody - (let* ((v4 (progn (unwind-protect (go 0)) 0))) - 0) - 0) - (logand (cl::handler-bind () - (logand -15 -2 32578787 10349 e - -24781944 -8))))))))) - 60336 1625 124302 -33193 -8095855 4995857 0 4572381) - 0) - -(deftest misc.308 - (funcall - (compile - nil - '(lambda (a b c d e f g h) - (declare (type (integer -2806612475904 8750665416704) a)) - (declare (type (integer -3 10) b)) - (declare (type (integer -94336824 116591592) c)) - (declare (type (integer 456813135872 903636350976) d)) - (declare (type (integer -2364199833600 -172353318912) e)) - (declare (type (integer 717 1760915) f)) - (declare (type (integer -21 105) g)) - (declare (type (integer -3579048169472 -346272903168) h)) - (declare (ignorable a b c d e f g h)) - (declare (optimize (speed 2) (space 1) (safety 0) (debug 0) - (compilation-speed 0))) - (labels ((%f7 (f7-1) - (multiple-value-prog1 0 - 0 - (return-from %f7 (mask-field (byte 0 0) 0))))) - (unwind-protect (%f7 0))))) - 1951007924893 10 -49879990 614214833752 -1808568999586 1282634 - 99 -2783010573143) - 0) - -(deftest misc.309 - (funcall - (compile - nil - '(lambda (a b c d e f g h) - (declare (type (integer -521338 12) a)) - (declare (type (integer -1787856009216 1182078822400) b)) - (declare (type (integer -3313 28535137344) c)) - (declare (type (integer -38914612 -25121536) d)) - (declare (type (integer 403073126400 2632230309888) e)) - (declare (type (integer -39663606528 -1238304) f)) - (declare (type (integer -103560 -70383) g)) - (declare (type (integer -894 -227) h)) - (declare (ignorable a b c d e f g h)) - (declare (optimize (speed 3) (space 1) (safety 1) (debug 3) - (compilation-speed 2))) - (block b8 - (multiple-value-prog1 - (logand (logior 0 - (if (logbitp 0 0) 0 - (multiple-value-bind (v2) 0 0)))) - (gcd (let* ((*s4* 0)) - (logior 0 - (return-from b8 - (let ((*s8* 0)) (round 0)))))) - 0 - 0)))) - -275760 -565946697213 9650536069 -37585973 1536165173011 - -12895970021 -102192 -534) - 0 0) - - -(deftest misc.310 - (funcall - (compile - nil - '(lambda (a b c d e f g h) - (declare (type (integer -2016726144 234357120) a)) - (declare (type (integer -10569521299456 -1307998945280) b)) - (declare (type (integer -45429002240 -17228484608) c)) - (declare (type (integer 228451840 1454976512) d)) - (declare (type (integer -4797 -2609) e)) - (declare (type (integer -21 36300536) f)) - (declare (type (integer -15983530 31646604) g)) - (declare (type (integer -208720272 -357) h)) - (declare (ignorable a b c d e f g h)) - (declare (optimize (speed 1) (space 3) (safety 3) (debug 0) - (compilation-speed 3))) - (expt (labels ((%f14 (f14-1 f14-2) - (progn - (tagbody - (+ - (unwind-protect - (labels ((%f1 (f1-1) (go tag1))) - (let ((*s6* (%f1 d))) 0)))) - tag1 - (+ - (cl::handler-bind () - (if (<= -11215713 -819) - (integer-length - (floor (conjugate f14-1) - (max 12 - (ceiling - (block b2 - (catch 'ct2 - (ignore-errors - (flet - ((%f13 (f13-1) - (logior 87 f14-2))) - f14-1)))))))) - (progv '(*s8*) (list 472865632) - *s8*))))) - 0))) - (%f14 0 0)) - 0))) - -28594854 -3859203606860 -40757449218 894599577 -4163 11621230 - 29558853 -92216802) - 1) - -(deftest misc.311 - (funcall - (compile - nil - '(lambda (a b c d e f g h) - (declare (type (integer -1203392327680 -3017953) a)) - (declare (type (integer -34222 -1) b)) - (declare (type (integer -871294987 19) c)) - (declare (type (integer 717979131904 3341735845888) d)) - (declare (type (integer -7521858 3) e)) - (declare (type (integer -52 49) f)) - (declare (type (integer 18 43) g)) - (declare (type (integer -503567246 -46) h)) - (declare (ignorable a b c d e f g h)) - (declare (optimize (speed 1) (space 3) (safety 1) (debug 2) - (compilation-speed 2))) - (labels ((%f2 (f2-1 f2-2 f2-3 &optional - (f2-4 (let - ((*s6* - (progn - (tagbody - (flet - ((%f17 (f17-1 f17-2 f17-3) - (go 6))) - (%f17 0 b 0)) - 6) - 0))) - (complex - (progn - (tagbody - (labels - ((%f18 - (f18-1 f18-2 &optional - (f18-3 0) (f18-4 f)) - 0)) - (apply #'%f18 g 0 0 - (list))) - 0) - 0) - 0))) - (f2-5 0) (f2-6 0)) - 0)) - (%f2 0 0 f)))) - -738307241633 -25016 -846570136 2181696281793 -983259 24 36 - -185316211) - 0) - - -(deftest misc.312 - (funcall - (compile - nil - '(lambda (a b c d e f g h) - (declare (type (integer -18334222 14354736) a)) - (declare (type (integer 11163582 6421184978944) b)) - (declare (type (integer -13690431913984 -64765792960) c)) - (declare (type (integer -12750925 31112834) d)) - (declare (type (integer -5188669232 2246825616) e)) - (declare (type (integer -31235593088 -134) f)) - (declare (type (integer -1 -1) g)) - (declare (type (integer -647589424 12392126736) h)) - (declare (ignorable a b c d e f g h)) - (declare (optimize (speed 3) (space 2) (safety 1) (debug 1) - (compilation-speed 1))) - (let ((*s4* (if (progn - (tagbody (unwind-protect (go 2)) 2) - 0) - (numerator - (let* ((v1 - (let ((*s6* 0)) - (logand b - (rationalize - (coerce 0 'integer)))))) - 0)) - 0))) - 0))) - 7112398 3547401482305 -12827294644277 23312291 -444957551 - -5443955020 -1 4998457143) - 0) - -(deftest misc.313 - (funcall - (compile - nil - '(lambda (a b c d e f g h) - (declare (type (integer 55474 401001) a)) - (declare (type (integer -8359558987776 8684176949248) b)) - (declare (type (integer -54332 116292) c)) - (declare (type (integer 0 0) d)) - (declare (type (integer -609311104000 959776553984) e)) - (declare (type (integer -2031580 3834807) f)) - (declare (type (integer -10955 2549) g)) - (declare (type (integer -8362590032 -210369) h)) - (declare (ignorable a b c d e f g h)) - (declare (optimize (speed 1) (space 3) (safety 1) (debug 0) - (compilation-speed 1))) - (dotimes (iv1 3 0) - (labels ((%f6 (f6-1 f6-2 f6-3 &optional - (f6-4 (flet - ((%f3 - (f3-1 f3-2 f3-3 &optional - (f3-4 0)) - (flet ((%f11 nil 0)) - (ash - (progn - (tagbody - (labels - ((%f3 - (f3-1 &optional - (f3-2 (go tag4))) - 0)) - (%f3 0)) - tag4) - 0) - (min 42 - (conjugate - (coerce - (conjugate - (let ((v9 (%f11))) - f3-1)) - 'integer))))))) - (%f3 c 0 a))) - (f6-5 0)) - 0)) - (apply #'%f6 0 0 h nil))))) - 93287 3146418586486 -51786 0 -63479145888 1935918 -10058 -2033798238) - 0) - -(deftest misc.314 - (funcall - (compile - nil - '(lambda (a b c d e f g h) - (declare (type (integer -176150296 698) a)) - (declare (type (integer -62799871488 -56234210816) b)) - (declare (type (integer -1 1) c)) - (declare (type (integer 31 215808) d)) - (declare (type (integer -3 -1) e)) - (declare (type (integer -3 3387651) f)) - (declare (type (integer -14370846720 -56648624) g)) - (declare (type (integer -8316238784 -6221617344) h)) - (declare (ignorable a b c d e f g h)) - (declare (optimize (speed 1) (space 1) (safety 1) (debug 2) - (compilation-speed 2))) - (progn - (tagbody - (unwind-protect - (let ((v10 (let* ((v7 (if (go tag6) 0 0))) 0))) 0)) - tag6 - (let ((v7 (flet ((%f11 nil 0)) - (flet ((%f13 (f13-1 f13-2 f13-3) f13-2)) - (funcall #'%f13 0 a (%f11)))))) - 0)) - 0))) - -90583503 -61289371485 -1 175888 -3 3257970 -3264725617 -6816839328) - 0) - -;;; (misc.315 deleted) - -;;; ACL 6.2 interpreter bugs -;;; Error: `NIL' is not of the expected type `NUMBER' -;;; (in COMP::IA-RESOLVE-REFS) - -(deftest misc.316 - (funcall - (compile - nil - '(lambda (a c) - (declare (optimize (speed 2) (space 3) (safety 2) (debug 2) - (compilation-speed 0))) - (unwind-protect - 0 - (progn (tagbody (bit #*000000111 (min 8 (max 0 a))) - tag5 (flet ((%f17 (f17-1 f17-2 f17-3) - (complex (numerator (go tag4)) 0))) - c) - tag4) - c)))) - 1 2) - 0) - -;;; ecl failures (12 April 2004) - -;;; wrong value returned -(deftest misc.317 - (funcall - (compile - nil - '(lambda () - (declare (optimize (speed 1) (space 1) (safety 3) (debug 0) - (compilation-speed 3))) - (catch 'ct4 - (elt '(40760) - (min 0 (max 0 (let* ((v3 (* (throw 'ct4 0) 0))) 0)))))))) - 0) - -;;; seg fault -(deftest misc.318 - (funcall - (compile - nil - '(lambda (a b c) - (declare (type (integer -2050548150 4917) a)) - (declare (type (integer -4 1) b)) - (declare (type (integer 99335934976 442465125376) c)) - (declare (ignorable a b c)) - (declare (optimize (speed 1) (space 1) (safety 1) (debug 0) - (compilation-speed 0))) - (if (rationalize - (labels ((%f12 (f12-1) - (if c 0 - (bit #*101010011000011 - (min 14 (max 0 0)))))) - (if (> 0 c) 0 (%f12 0)))) - (progn - (expt (flet ((%f18 (f18-1 f18-2 &optional (f18-3 0) - (f18-4 c) (f18-5 b)) - 0)) - (apply #'%f18 b b 0 0 nil)) - 0) - a) - 0))) - 10 1 99335934976) - 10) - -;;; seg fault -(deftest misc.319 - (funcall - (compile - nil - '(lambda (a b c) - (declare (type (integer -626615938 3649977016320) a)) - (declare (type (integer -3615553 6013683) b)) - (declare (type (integer -746719 1431737508) c)) - (declare (ignorable a b c)) - (declare (optimize (speed 3) (space 1) (safety 2) (debug 3) - (compilation-speed 3))) - (if (logbitp 0 - (flet ((%f10 (f10-1 f10-2 f10-3) b)) - (flet ((%f4 (f4-1 f4-2) - (apply #'%f10 (%f10 0 a 0) 0 c nil))) - (complex (%f4 0 0) 0)))) - 0 0))) - 2378435476701 1646880 246794654) - 0) - -;;; sbcl 0.8.9.35 -;;; failed AVER: "(EQL (LAMBDA-COMPONENT FUNCTIONAL) *CURRENT-COMPONENT*)" - -(deftest misc.320 - (funcall - (compile - nil - '(lambda () - (declare (optimize (speed 3) (space 0) (safety 2) - (debug 2) (compilation-speed 0))) - (catch 'ct2 - (elt '(102) - (flet ((%f12 () (rem 0 -43))) - (multiple-value-call #'%f12 (values)))))))) - 102) - -(deftest misc.320a - (funcall - (compile - nil - '(lambda (b) - (declare (optimize (speed 3) (space 0) (safety 2) - (debug 2) (compilation-speed 0))) - (reduce '* - (list (elt '(10 20 30 40 50) b) - (expt (reduce #'(lambda (lmv1 lmv3) (mod lmv3 15)) - (vector 0 0)) - 0) - (rem 0 -71)) - ))) - 2) - 0) - -(deftest misc.320b - (funcall - (compile - nil - '(lambda (a b c) - (declare (type (integer -690191 -454473) a)) - (declare (type (integer -459197 -62) b)) - (declare (type (integer 445621505781 8489194559765) c)) - (declare (ignorable a b c)) - (declare - (optimize (speed 1) - (space 0) - (safety 2) - (debug 3) - (compilation-speed 3))) - (elt '(3327764 3386241) - (min 1 - (max 0 - (reduce #'(lambda (lmv6 lmv5) (mod 0 (min -86 0))) - (list 0 0))))))) - -512398 -156405 1140919327630) - 3327764) - -;;; ecl -;;; Wrong value - -(deftest misc.321 - (funcall - (compile - nil - '(lambda (p) - (declare (optimize (speed 1) (space 3) (safety 2) (debug 1) - (compilation-speed 3))) - (catch 'ct2 - (let* ((v3 (- (if p (throw 'ct2 :good) 0)))) - :bad)))) - t) - :good) - -;;; segfault -(deftest misc.322 - (funcall - (compile - nil - '(lambda (a) - (declare (optimize (speed 2) (space 2) (safety 0) (debug 3) - (compilation-speed 2))) - (logorc2 (labels ((%f14 (f14-1) a)) (%f14 0)) - (reduce #'(lambda (lmv1 lmv2) a) (list 0 0))))) - 3151096069) - -1) - -;; #1# is undefined - -(deftest misc.323 - (let* ((tail '(:from-end t)) - (form - `(lambda () - (declare (optimize (speed 3) (space 1) (safety 2) (debug 2) - (compilation-speed 2))) - (eval '(reduce #'logior - (vector (reduce #'logand (vector 0 0) . ,tail) 0) - . ,tail))))) - (funcall (compile nil form))) - 0) - -;;; Bad value - -(deftest misc.324 - (funcall - (compile - nil - '(lambda (a) - (declare (optimize (speed 2) (space 2) (safety 3) (debug 2) - (compilation-speed 3))) - (labels ((%f6 (f6-1) (multiple-value-setq (a) 0))) - (reduce #'(lambda (lmv4 lmv3) a) - (list (%f6 0) 2))))) - 1) - 0) - -;;; "A bug was found in the compiler. Contact worm@arrakis.es." -;;; Broken at C::C2MULTIPLE-VALUE-SETQ. - -(deftest misc.325 - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer -1659358 3099614928896) a)) - (declare (type (integer -492625 197903) b)) - (declare (ignorable a b)) - (declare (optimize (speed 3) (space 1) (safety 3) (debug 0) - (compilation-speed 1))) - (reduce #'(lambda (lmv5 lmv6) - (multiple-value-setq (a) 2443855591508)) - (vector b a 0 0) :from-end t))) - 1 2) - 2443855591508) - -;;; wrong value -(deftest misc.326 - (funcall - (compile - nil - '(lambda (b) - (declare (type (integer 155 7955) b)) - (declare (optimize (speed 3) (space 3) (safety 3) (debug 1) - (compilation-speed 0))) - (flet ((%f13 (f13-1) (shiftf b 3019))) (+ b (%f13 0))))) - 200) - 400) - -;;; acl 6.2 (x86 linux trial edition, patched, 4/15/04) -;;; Error: `NIL' is not of the expected type `REAL' - -(deftest misc.327 - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer -67668056 -55) a)) - (declare (type (integer -586950907 -10945000) b)) - (declare (ignorable a b)) - (declare (optimize (speed 2) (space 0) (safety 2) (debug 2) - (compilation-speed 1))) - (labels ((%f15 (f15-1) - (elt #(1073730663 1073689230 596123606 1073713997 - 311527378 186184643 1073713230 1316881) - (min 7 - (max 0 - (catch 'ct7 - (reduce - #'min - (list 0 b (catch 'ct7 - (throw 'ct7 f15-1)) - 0) - :start 1 - :from-end t))))))) - (%f15 0)))) - -38276611 -11001852) - 1073730663) - -;;; wrong return value: T -(deftest misc.327a - (funcall - (compile - nil - '(lambda (a b c d e) - (declare (notinline max vector reduce)) - (declare (optimize (speed 1) (space 2) (safety 1) (debug 1) - (compilation-speed 2))) - (reduce #'(lambda (lmv6 lmv3) lmv3) - (vector 0 (max 0) 0 0 - (catch 'ct2 (catch 'ct2 (throw 'ct2 0))) 0 e 0) - - :end 2 - :from-end t))) - 68664683637 328245 881497115 -303855 311427) - 0) - -;;; Bugs from abcl -;;; Debugger invoked on condition of type TYPE-ERROR: -;;; The value org.armedbear.lisp.Symbol@54 is not of type integer. - -(deftest misc.328 - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer -11368047588 14412128900) a)) - (declare (type (integer -10 0) b)) - (declare (ignorable a b)) - (declare (optimize (speed 3) (space 1) (safety 3) (debug 0) - (compilation-speed 0))) - (if (logbitp 0 (if (or t nil) (setf a -2616861879) 0)) 0 0))) - -4836700955 -1) - 0) - -;;; Incorrect value -(deftest misc.329 - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer -725661427 405092) a)) - (declare (type (integer 84176291516 98216856233) b)) - (declare (ignorable a b)) - (declare (optimize (speed 3) (space 3) (safety 0) (debug 0) - (compilation-speed 0))) - (let ((*s2* (case b ((53651 62711 29537 25305 62250) 0) (t 0)))) - (declare (special *s2*)) - (setq a -688292831)))) - -406606203 84436335326) - -688292831) - -(deftest misc.330 - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer -12816761394938 -8706928710678) a)) - (declare (type (integer -3683497948554 427) b)) - (declare (ignorable a b)) - (declare (optimize (speed 3) (space 0) (safety 0) (debug 3) - (compilation-speed 2))) - (lcm (block b8 (signum (return-from b8 a)))))) - -12715609319989 -582329850697) - 12715609319989) - -(deftest misc.331 - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer -777352478 239900) a)) - (declare (type (integer -63500163479 -8671) b)) - (declare (ignorable a b)) - (declare (optimize (speed 3) (space 0) (safety 0) (debug 2) - (compilation-speed 3))) - (if (if (>= 0) t t) (setq b -25319949896) b))) - 0 -10000) - -25319949896) - -;;; Debugger invoked on condition of type TYPE-ERROR: -;;; The value 0 is not of type org.armedbear.lisp.Symbol@80f563d8. -(deftest misc.332 - (funcall - (compile - nil - '(lambda (a b) - (declare (notinline max logorc1 numerator rem)) - (declare (optimize (speed 3) (space 1) (safety 1) (debug 1) - (compilation-speed 2))) - (rem (progn (tagbody (numerator (logorc1 0 (go tag5))) - tag5) - 0) - (max 93 0)))) - -801 17641908) - 0) - -;;; Debugger invoked on condition of type TYPE-ERROR: -;;; The value # is not of type org.armedbear.lisp.Symbol@80f563d8. - -(deftest misc.333 - (funcall - (compile - nil - '(lambda () - (declare (notinline logxor)) - (declare (optimize (speed 3) (space 0) (safety 0) (debug 3) - (compilation-speed 3))) - (logxor (progn (tagbody (let* ((*s4* (progn (go 1) 0))) 0) - 1) - 0))))) - 0) - -;;; Debugger invoked on condition of type PROGRAM-ERROR: -;;; Wrong number of arguments for EXPT. -(deftest misc.334 - (funcall - (compile - nil - '(lambda (a b c) - (declare (type (integer 1892675246514 8763564964618) a)) - (declare (type (integer -1353 -456) b)) - (declare (type (integer 2010840649 2119165101) c)) - (declare (ignorable a b c)) - (declare (optimize (speed 3) (space 2) (safety 0) (debug 2) - (compilation-speed 1))) - (+ (block b6 (expt (return-from b6 b) 0))))) - 3966745735633 -1123 2030094113) - -1123) - -;;; The value NIL is not of type number. -(deftest misc.335 - (let ((c 10)) - (denominator (progn (tagbody (realpart (loop for lv4 below 2 sum (go 0))) - 0) - c))) - 1) - -(deftest misc.336 - (prog2 (progn (tagbody (- (common-lisp:handler-case (go tag2))) - tag2) - 0) - 0) - 0) - -;;; Incorrect return value -(deftest misc.337 - (funcall - (compile - nil - '(lambda () - (declare (optimize (speed 2) (space 2) (safety 2) (debug 0) - (compilation-speed 0))) - (imagpart (block b8 - (logior (block b7 (return-from b8 225480400)))))))) - 0) - -;;; Inconsistent stack height 1 != 2 -(deftest misc.338 - (let #+armedbear ((jvm::*catch-errors* nil)) - nil - (funcall - (compile - nil - '(lambda (c) - (conjugate (block b8 (max (if c (return-from b8 0) 0)))))) - 10)) - 0) - -;;; Inconsistent stack height 4 != 0 -(deftest misc.339 - (let - #+armedbear ((jvm::*catch-errors* nil)) - nil - (funcall - (compile - nil - '(lambda () - (declare (optimize (speed 1) (space 3) (safety 3) (debug 0) - (compilation-speed 0))) - (block b1 - (reduce #'min - (list (return-from b1 0)) - :end 1 - :start 0 - :from-end t - )))))) - 0) - -;;; The value INTEGER is not of type sequence. -(deftest misc.340 - (funcall - (compile - nil - '(lambda (a b c) - (declare (type (integer -4379340 -1962) a)) - (declare (type (integer 1304043 3225940) b)) - (declare (type (integer -3229571579853 -180689150012) c)) - (declare (ignorable a b c)) - (declare (optimize (speed 3) (space 1) (safety 0) (debug 2) - (compilation-speed 2))) - (coerce (rationalize (progn (tagbody (reduce #'logand - (list b 0 (go tag3)) - :from-end - t) - tag3) - 0)) - 'integer))) - -1625211 3052955 -2091182035681) - 0) - -;;; Inconsistent stack height 1 != 2 -(deftest misc.341 - (let - #+armedbear ((jvm::*catch-errors* nil)) - nil - (funcall - (compile - nil - '(lambda (c) - (declare (optimize (speed 2) (space 1) (safety 1) (debug 2) - (compilation-speed 3))) - (logeqv (block b6 - (logeqv (case 0 - ((45293 29462 60403) (return-from b6 0)) - (t c))))))) - 10)) - 10) - -;;; Inconsistent stack height 0 != 1 -(deftest misc.342 - (let - #+armedbear ((jvm::*catch-errors* nil)) - nil - (funcall - (compile - nil - '(lambda (a) - (declare (optimize (speed 1) (space 0) (safety 2) (debug 1) - (compilation-speed 2))) - (progn (tagbody (imagpart (dotimes (iv3 0 a) (go 4))) - 4) - 0))) - 1)) - 0) - -;;; Expecting to find object/array on stack -(deftest misc.343 - (let - #+armedbear ((jvm::*catch-errors* nil)) - nil - (funcall - (compile - nil - '(lambda () - (declare (optimize (speed 2) (space 3) (safety 2) (debug 3) - (compilation-speed 2))) - (mask-field (byte 0 0) - (block b8 - (reduce 'logior - (list (return-from b8 0) 0 0) - :end 3 - :start 0 - :from-end t))))))) - 0) - -;;; Wrong value -(deftest misc.344 - (funcall - (compile - nil - '(lambda (a) - (declare (type (integer -3464434 12316202) a)) - (declare (optimize (speed 1) (space 0) (safety 0) (debug 0) - (compilation-speed 2))) - (progn (tagbody (gcd (expt (setf a -2612809) 0) (go 5)) - 5) - a))) - 1891348) - -2612809) - -;;; Stack size too large -(deftest misc.345 - (let - #+armedbear ((jvm::*catch-errors* nil)) - nil - (funcall - (compile - nil - '(lambda (a b c) - (declare (type (integer -1968 -1759) a)) - (declare (type (integer 91 2293818743282) b)) - (declare (type (integer -843793650839 -2) c)) - (declare (ignorable a b c)) - (declare (optimize (speed 3) (space 2) (safety 3) (debug 0) - (compilation-speed 3))) - (max (block b1 - (conjugate (dotimes (iv3 0 - (bit #*010 - (min 2 - (max 0 - (return-from b1 0))))) - (progn 0)))) - (sbit #*0001011010010 (min 12 (max 0 0)))))) - -1957 523078358699 -634832888815)) - 0) - -(deftest misc.345a - (let - #+armedbear ((jvm::*catch-errors* nil)) - nil - (funcall - (compile - nil - '(lambda (c) - (declare (type (integer -3011346550 1630587670) c)) - (declare (optimize (speed 1) (space 1) (safety 0) (debug 3) - (compilation-speed 1))) - (progn (tagbody (dotimes (iv2 0 (- 0 (go 7))) (progn 0)) - 7 - (progn (mask-field (byte 0 0) 0) c)) - 0))) - 1)) - 0) - -;;; wrong return value -(deftest misc.346 - (funcall - (compile - nil - '(lambda () - (declare (optimize (speed 2) (space 2) (safety 2) (debug 2) - (compilation-speed 2))) - (bit #*011100 - (min 5 - (max 0 - (block b8 - (aref #(122010971004 126555236004) - (min 1 - (max 0 - (progn (return-from b8 191438621) - 0))))))))))) - 0) - -;;; The value 8 is not of type FUNCTION. -(deftest misc.347 - (funcall - (compile - nil - '(lambda () - (declare (optimize (speed 2) (space 2) (safety 3) (debug 2) - (compilation-speed 1))) - (complex (* (block b2 - (boole boole-xor (logxor (return-from b2 0)) 0))) - 0)))) - 0) - -;;; Wrong result -(deftest misc.348 - (funcall - (compile - nil - '(lambda (a c) - (declare (optimize (speed 1) (space 0) (safety 2) (debug 3) - (compilation-speed 1))) - (max (conjugate (setq a -4178265097)) (if (> c 0) 0 a)))) - -2408319173 -4307532101272) - -4178265097) - -(deftest misc.349 - (funcall - (compile - nil - '(lambda () - (declare (optimize (speed 3) (space 1) (safety 1) (debug 1) - (compilation-speed 2))) - (mod (let ((*s7* (block b7 (logandc2 (+ (return-from b7 0)) 0)))) - -10) - (max 26 0))))) - 16) - -;;; Inconsistent stack height 0 != 1 - -(deftest misc.350 - (let - #+armedbear ((jvm::*catch-errors* nil)) - nil - (funcall - (compile - nil - '(lambda () - (declare (optimize (speed 2) (space 3) (safety 1) (debug 2) - (compilation-speed 3))) - (progn (tagbody (complex (- 0 (if (and t) 0 (go tag1))) 0) - tag1) - 0))))) - 0) - -(deftest misc.351 - (let - #+armedbear ((jvm::*catch-errors* nil)) - nil - (funcall - (compile - nil - '(lambda (c) - (declare (type (integer -598962457711 -2902) c)) - (declare (optimize (speed 1) (space 0) (safety 1) (debug 0) - (compilation-speed 3))) - (lognor c - (block b1 - (loop for lv3 below 1 - sum (if (/= 0) (return-from b1 0) c)))))) - -392248104420)) - 392248104419) - -(deftest misc.352 - (let - #+armedbear ((jvm::*catch-errors* nil)) - nil - (funcall - (compile - nil - '(lambda () - (declare (optimize (speed 1) (space 3) (safety 3) (debug 3) - (compilation-speed 1))) - (progn (tagbody (+ 0 (if (< 0) (go 5) 0)) - 5) - 0))))) - 0) - -(deftest misc.353 - (let - #+armedbear ((jvm::*catch-errors* nil)) - nil - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer -8 -2) a)) - (declare (type (integer -67321 14697029362) b)) - (declare (optimize (speed 3) (space 1) (safety 3) (debug 1) - (compilation-speed 2))) - (expt (block b2 - (loop for lv1 below 3 - sum (prog2 b - 0 - (expt (case 0 - ((-13960 -57685 -37843 -34222 - -14273 -40931 -2688) - (return-from b2 0)) - (t a)) - 0)))) - 0))) - -7 772373806)) - 1) - -;;; Incorrect return value -(deftest misc.354 - (funcall - (compile - nil - '(lambda (a b c) - (declare (type (integer -1309 67082465417) a)) - (declare (type (integer -7824641338734 -832606641) b)) - (declare (type (integer 7473698771 3542216118742) c)) - (declare (ignorable a b c)) - (declare (optimize (speed 3) (space 2) (safety 1) (debug 3) - (compilation-speed 2))) - (+ 0 - (progn (tagbody (if (if (>= b (go 3)) nil t) a c) - 3) - 0)))) - 29329060987 -4964942044116 512158612507) - 0) - -(deftest misc.355 - (funcall - (compile - nil - '(lambda (c) - (declare (type (integer -1390043946499 -115168466439) c)) - (declare (optimize (speed 2) (space 0) (safety 0) (debug 1) - (compilation-speed 2))) - (+ 0 - (coerce (progn (tagbody (if (<= -1 (go tag1)) 0 c) - tag1) - 0) - 'integer)))) - -115168466439) - 0) - -(deftest misc.356 - (let - #+armedbear ((jvm::*catch-errors* nil)) - nil - (funcall - (compile - nil - '(lambda () - (declare (optimize (speed 2) (space 2) (safety 1) (debug 0) - (compilation-speed 3))) - (let ((*s7* 0)) - (dotimes (iv2 0 0) - (block b3 - (block b3 (block b3 (setq *s7* (return-from b3 0))))))))))) - 0) - -(deftest misc.357 - (let - #+armedbear ((jvm::*catch-errors* nil)) - nil - (funcall - (compile - nil - '(lambda (b) - (declare (type (integer -1750881587721 -327383867) b)) - (declare (optimize (speed 1) (space 0) (safety 2) (debug 3) - (compilation-speed 3))) - (denominator (block b2 - (let* ((*s8* 0)) - (setq *s8* - (case 0 - ((-26733 -244 -26253 -50028) 0) - (t (return-from b2 b))))))))) - -1153135130306)) - 1) - -(deftest misc.358 - (let - #+armedbear ((jvm::*catch-errors* nil)) - nil - (funcall - (compile - nil - '(lambda () - (declare (optimize (speed 2) (space 0) (safety 0) (debug 3) - (compilation-speed 1))) - (rationalize (let* ((*s1* 0)) - (block b3 - (conjugate (let* ((v10 - (if (ldb-test (byte 0 0) 0) - (return-from b3 *s1*) - 0))) - (setq *s1* (return-from b3 0))))))))))) - 0) - -(deftest misc.359 - (let - #+armedbear ((jvm::*catch-errors* nil)) - nil - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer -477801566869 432060432661) a)) - (declare (type (integer 366578392 525704751) b)) - (declare (optimize (speed 3) (space 3) (safety 1) (debug 1) - (compilation-speed 1))) - (max (case b - ((0 -3 -2 -2 -3) - (progn (tagbody (loop for lv1 below 2 - count (let* ((*s1* a)) - (setq *s1* (go 4)))) - 4) - 0)) - (t 0))))) - 287358622300 400248608)) - 0) - -;;; Wrong return value - -(deftest misc.360 - (let ((c :good)) - (tagbody - (dotimes (j 1 (setf c :bad)) (go done)) - done) - c) - :good) - -;;; sbcl bugs (0.8.10.4) - -;;; failed AVER: "(SUBSETP END END-STACK)" -(deftest misc.361 - (funcall - (compile - nil - '(lambda (a b c) - (declare (notinline boole values denominator list)) - (declare - (optimize (speed 2) - (space 0) - (safety 1) - (debug 0) - (compilation-speed 2))) - (catch 'ct6 - (progv - '(*s8*) - (list 0) - (let ((v9 (ignore-errors (throw 'ct6 0)))) - (denominator - (progv nil nil (values (boole boole-and 0 v9))))))))) - 1 2 3) - 0) - -;;; sbcl (0.8.10.15) -;;; Wrong return value: SB-KERNEL:*HANDLER-CLUSTERS* -(deftest misc.362 - (funcall - (compile - nil - '(lambda (b g h) - (declare (optimize (speed 3) (space 3) (safety 2) - (debug 2) (compilation-speed 3))) - (catch 'ct5 - (unwind-protect - (labels ((%f15 (f15-1 f15-2 f15-3) - (rational (throw 'ct5 0)))) - (%f15 0 - (apply #'%f15 - 0 - h - (progn - (progv '(*s2* *s5*) (list 0 (%f15 0 g 0)) b) - 0) - nil) - 0)) - (common-lisp:handler-case 0))))) - 1 2 3) - 0) - -;;; Wrong value: NIL -(deftest misc.363 - (funcall - (compile - nil - '(lambda (a) - (declare (type (integer -17286401550789 15753784105886) a)) - (declare (optimize (speed 2) (space 2) (safety 2) - (debug 0) (compilation-speed 3))) - (if (not (>= 0 (shiftf a 110236462073))) - 0 - (elt '(30 101 13 2 10 52 89 57) (min 7 (max 0 a)))))) - -3647332298473) - 57) - -;;; "full call to SB-KERNEL:DATA-VECTOR-REF" -(deftest misc.364 - (dotimes (iv1 2 0) - (if (> iv1 iv1) - (svref #(2002 3778 1998 3466 530 3279 2033 521 4085) - (min 8 (max 0 iv1))) - 0)) - 0) - -;;; OpenMCL/darwin bug (12 May 2004) -(deftest misc.365 - (let* ((fn1 - '(lambda (a b c) - (declare (type (integer -2 21) a)) - (declare (type (integer -5651364356 4324101092) b)) - (declare (type (integer -30766087 28182568) c)) - (declare (ignorable a b c)) - (declare (optimize (speed 3) (space 1) (safety 3) (debug 0) (compilation-speed 1))) - (coerce (logxor b -1) 'integer))) - (fn2 - '(lambda (a b c) - (declare (notinline logxor coerce)) - (declare (optimize (speed 3) (space 0) (safety 3) (debug 2) (compilation-speed 2))) - (coerce (logxor b -1) 'integer))) - (vals '(9 -328421075 -6406890)) - (v1 (apply (compile nil fn1) vals)) - (v2 (apply (compile nil fn2) vals))) - (if (eql v1 v2) :good (list v1 v2))) - :good) - -;;; sbcl 0.8.10.24 -;;; Argument X is not a REAL: # - -(deftest misc.366 - (funcall - (compile - nil - '(lambda (a b c d e f g h i) - (declare (type (integer 10 65866342) a)) - (declare (type (integer 151 702748905609) b)) - (declare (type (integer -60442925 167939283) c)) - (declare (type (integer 7706 10562) d)) - (declare (type (integer -97180326158 17496) e)) - (declare (type (integer -73249 -51989) f)) - (declare (type (integer -12 2718) g)) - (declare (type (integer -37832 591244) h)) - (declare (type (integer -2579781276 2108461452) i)) - (declare (ignorable a b c d e f g h i)) - (declare - (optimize (speed 3) - (space 0) - (safety 0) - (debug 2) - (compilation-speed 2))) - (elt '(11751 8554 7393 1924 3418) - (min 4 - (max 0 - (block b4 - (numerator - (flet ((%f5 - (f5-1 f5-2 f5-3 - &optional - (f5-4 (prog1 0 (return-from b4 0) 0)) - (f5-5 d) (f5-6 0)) - 0)) - (numerator - (apply (constantly 0) - 0 - 0 - (rationalize - (unwind-protect - (%f5 0 - c - (%f5 0 - c - (%f5 0 - 0 - 0 - h - (%f5 0 0 0) - i) - a)) - (ignore-errors 0))) - 0 - nil)))))))))) - 21956127 524275646496 101890987 8762 -88607922426 -55959 2177 147174 - 38469170) - 11751) - -;;; The value # -;;; is not of type RATIONAL. - -(deftest misc.367 - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer 11557968 115977463) a)) - (declare (type (integer -89510 -20616) b)) - (declare (optimize (speed 2) (space 3) (safety 1) - (debug 0) (compilation-speed 1))) - (rational - (flet ((%f17 (f17-1 f17-2) 0)) - (%f17 - (numerator - (%f17 - (denominator - (catch 'ct5 - (apply (constantly 0) - 0 - (unwind-protect - (catch 'ct2 (throw 'ct5 (progn (%f17 a b) a)))) - nil))) - 0)) - (%f17 0 a)))))) - 112475717 -25829) - 0) - -;;; sbcl 0.8.10.25 -;;; "The value -3 is not of type (INTEGER -5 -2)." -(deftest misc.368 - (funcall - (compile - nil - '(lambda (a) - (declare (type (integer -5 -2) a)) - (declare (ignorable a)) - (declare - (optimize (speed 2) (space 3) (safety 1) - (debug 1) (compilation-speed 1))) - (if - (and (not (not (> a (numerator (setf a -4))))) - (logbitp 0 (conjugate a))) - 0 - 0))) - -3) - 0) - -;;; acl 6.2 (x86 linux trial edition, patched, 4/15/04) -;;; Error: `T' is not of the expected type `NUMBER' -(deftest misc.369 - (funcall - (compile - nil - '(lambda (a b c d e) - (declare (type (integer -15256078323 33828721319) a)) - (declare (type (integer -44368 22872) b)) - (declare (type (integer -7623 -7522) c)) - (declare (type (integer -53 289) d)) - (declare (type (integer -1853649832248 2196352552304) e)) - (declare (ignorable a b c d e)) - (declare (optimize (speed 1) (space 2) (safety 0) (debug 0) - (compilation-speed 3))) - (flet ((%f2 (f2-1 &optional &key (key1 0) (key2 e)) - (labels ((%f5 (f5-1 f5-2 f5-3 &optional &key - (key1 - (aref #(397) - (min - 0 - (max - 0 - (let ((v7 (make-array nil :initial-element d))) - (reduce - #'(lambda (lmv5 lmv6) key1) - (vector f2-1 0) - :start 0)))))) - &allow-other-keys) - 0)) - 0))) - b))) - -2821485338 -35420 -7622 135 9592294022) - -35420) - -;;; Lispworks personal edition 4.3 (x86 linux) -;;; Inconsistent return value -(deftest misc.370 - (funcall - (compile - nil - '(lambda (a b c) - (declare (type (integer -3070433 6) a)) - (declare (type (integer -5 -3) b)) - (declare (type (integer -4433759745778 -1) c)) - (declare (ignorable a b c)) - (declare - (optimize (speed 3) - (space 1) - (safety 0) - (debug 2) - (compilation-speed 3))) - (flet ((%f15 - (f15-1 f15-2 - &optional (f15-3 0) - (f15-4 (denominator (setq c -4214677583716))) (f15-5 0) - &key (key1 c) &allow-other-keys) - (progv '(*s1* *s5* *s7*) (list f15-2 0 f15-1) key1))) - (%f15 0 (%f15 c 0) 0)))) - -1233959 -4 -2643533316361) - -4214677583716) - -;;; Armed Bear CL - -;;; inconsistent stack height -(deftest misc.371 - (let - #+armedbear ((jvm::*catch-errors* nil)) - nil - (funcall - (compile - nil - '(lambda (a b c) - (declare (type (integer -7288 10764) a)) - (declare (type (integer -7 24) b)) - (declare (type (integer 7951930344 11209871544) c)) - (declare (ignorable a b c)) - (declare (optimize (speed 2) (space 2) (safety 0) (debug 0) - (compilation-speed 0))) - (rationalize (block b1 - (if b - (return-from b1 - (progn (tagbody (return-from b1 - (let* ((*s1* - (cons (go tag3) - 0))) - (declare (dynamic-extent - *s1*)) - 0)) - tag3) - 0)) - 0))))) - -5566 9 10557204445)) - 0) - -;;; 0 is not of type LIST -(deftest misc.372 - (funcall - (compile - nil - '(lambda (a b c) - (declare (type (integer -738508 627) a)) - (declare (type (integer -100241328874 104421) b)) - (declare (type (integer -71651668566 4932238952300) c)) - (declare (ignorable a b c)) - (declare (optimize (speed 3) (space 2) (safety 1) (debug 3) - (compilation-speed 2))) - (sbit #*0 - (min 0 - (max 0 - (multiple-value-bind (v1) - (cons c - (truncate 0 - (min -42 0))) - (cdr v1))))))) - -657195 -10801112339 -4291316763) - 0) - -;;; inconsistent stack height -(deftest misc.373 - (let - #+armedbear ((jvm::*catch-errors* nil)) - nil - (funcall - (compile - nil - '(lambda (a b c) - (declare (type (integer 0 179061) a)) - (declare (type (integer -15793 42532) b)) - (declare (type (integer -2 0) c)) - (declare (ignorable a b c)) - (declare (optimize (speed 3) (space 0) (safety 2) (debug 1) - (compilation-speed 0))) - (reduce 'logxor - (list 0 b 0 0 - a 0 0 0 - (block b6 - (let* ((v6 (cons (if c (return-from b6 0) 0) b))) - 0)) - 0) - :end 6 - :from-end t))) - 141814 1445 -2)) - 142419) - -(deftest misc.374 - (let - #+armedbear ((jvm::*catch-errors* nil)) - nil - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer -99 4) a)) - (declare (type (integer 35621436 36172433) b)) - (declare (ignorable a b)) - (declare (optimize (speed 2) (space 1) (safety 3) (debug 1) - (compilation-speed 0))) - (lognand (let ((v6 0)) (declare (dynamic-extent v6)) v6) - (block b6 - (let* ((v10 - (cons (expt (case 0 - ((30207) (return-from b6 0)) - (t b)) - 0) - 0))) - (declare (dynamic-extent v10)) - 0))))) - -57 35725118)) - -1) - -;;; abcl (23 May 2004) -;;; 0 is not of type LIST -(deftest misc.375 - (funcall - (compile - nil - '(lambda (a b c d e f) - (declare (type (integer -3172868 25583841) a)) - (declare (type (integer -8176159 1565888775976) b)) - (declare (type (integer -2601325109 147819602) c)) - (declare (type (integer -502316251909 515874281072) d)) - (declare (type (integer 174 2604648) e)) - (declare (type (integer 1627646459 3124243119) f)) - (declare (ignorable a b c d e f)) - (declare (optimize (speed 3) (space 0) (safety 3) (debug 2) - (compilation-speed 2))) - (let* ((*s6* (make-array nil :initial-element 0 :adjustable t))) - (if (logbitp 0 - (denominator (prog2 (truncate (dotimes (iv3 0 0) - (progn 0))) - (multiple-value-bind (*s7*) - (cons d 0) - (cdr *s7*))))) - 0 - 0)))) - 12851164 182468232812 -2243976802 309299185674 2538150 1855615980) - 0) - -;;; abcl (25 May 2004) -;;; 0 is not of type LIST -(deftest misc.376 - (funcall - (compile - nil - '(lambda () - (declare (optimize (speed 1) (space 1) (safety 2) (debug 1) - (compilation-speed 0))) - (dotimes (iv4 3 - (multiple-value-bind (*s6*) (cons 0 0) - (progn (cdr *s6*) 0))) - (floor (rational (let ((*s2* - (rational (common-lisp:handler-case 0)))) - 0))))))) - 0) - -(deftest misc.377 - (funcall - (compile - nil - '(lambda (e) ; (a b c d e) - (declare (type (integer -46778182694 512) e)) - (declare (optimize (speed 3) (space 3) (safety 2) (debug 2) - (compilation-speed 3))) - (if (block b3 - (numerator (progn (tagbody (truncate (dotimes (iv3 0 0) - (block b3 0))) - (multiple-value-bind (*s5*) - (cons 0 e) - (rationalize (cdr *s5*)))) - 0))) - 0 - 0))) - 10) - 0) - -(deftest misc.378 - (funcall - (compile - nil - '(lambda (c) - (declare (optimize (speed 1) (space 0) (safety 1) (debug 3) - (compilation-speed 2))) - (dotimes (iv4 3 0) - (restart-case (round (multiple-value-bind (*s6*) (cons c 0) - (car *s6*))))))) - 1) - 0) - -(deftest misc.379 - (funcall - (compile - nil - '(lambda () - (declare (optimize (speed 2) (space 0) (safety 2) (debug 2) - (compilation-speed 1))) - (values (floor 0) (multiple-value-bind (v3) (cons 0 0) (car v3)))))) - 0 0) - -;;; gcl (31 May 2004, cvs head) -;;; Error in APPLY [or a callee]: Expected a FIXNUM -;;; Also fails in cmucl 1/2003 -(deftest misc.380 - (funcall - (compile - nil - '(lambda (a) - (declare (type (integer -1397457 1846252) a)) - (declare (optimize (speed 2) (space 2) (safety 1) - (debug 3) (compilation-speed 3))) - (let ((v9 (make-array nil :initial-element 0))) - (declare (dynamic-extent v9)) - (block b8 - (let ((*s1* 0)) - (let ((*s4* (let - ((*s1* - (return-from b8 - (rational - (setf (aref v9) - (deposit-field -5 - (byte 20 30) a)))))) - 0))) - (let ((*s8* (cons 0 0))) 0))))))) - 399997) - 1125898833500797) - -;; This also fails in cmucl (11/2003 image). This case has not been fully -;; pruned for cmucl. -;; -;; Error in function LISP::ASSERT-ERROR: The assertion (NOT C::WIN) failed. -(deftest misc.381 - (funcall - (compile - nil - '(lambda (a) - (declare (type (integer -1397457 1846252) a)) - (declare (optimize (speed 2) (space 2) (safety 1) - (debug 3) (compilation-speed 3))) - (let ((v9 (make-array nil :initial-element 0))) - (declare (dynamic-extent v9)) - (block b8 - (let ((s1 0)) - (let ((s4 (let - ((s1 - (return-from b8 - (rational - (setf (aref v9) - (deposit-field -5 - (byte 20 30) a)))))) - 0))) - (let ((s8 (cons 0 0))) 0))))))) - 399997) - 1125898833500797) - - -;;; gcl (31 May 2004, cvs head) -;;; Error in SYSTEM:ASET [or a callee]: Expected a FIXNUM - -(deftest misc.382 - (funcall - (compile - nil - '(lambda (b) - (declare (type (integer -65822755520 31689335872) b)) - (declare (optimize (speed 2) (space 2) (safety 3) - (debug 0) (compilation-speed 1))) - (let ((s8 (make-array nil :initial-element - (catch 'ct4 - (complex - (dotimes (iv1 1 0) - (rational (throw 'ct4 b))) - 0))))) - (elt '(13423701584) - (min 0 - (max 0 - (rational - (let ((s3 (make-array nil :initial-element 0))) - (if (ldb-test (byte 0 0) - (shiftf (aref s8) - (aref s8))) - 0 0))))))))) - -38169486910) - 13423701584) - -;;; cmucl 11/2003 -;;; Wrong value -(deftest misc.383 - (funcall - (compile - nil - '(lambda (a b c) - (declare (type (integer -93650 118967004056) a)) - (declare (type (integer -429173946 -3892) b)) - (declare (type (integer -229669685 -50537386) c)) - (declare (ignorable a b c)) - #+cmu (declare (optimize (extensions:inhibit-warnings 3))) - (declare - (optimize (speed 3) (space 1) (safety 0) (debug 3) (compilation-speed 2))) - (logorc2 - (let* ((*s3* (cons 0 a))) - (declare (dynamic-extent *s3*)) - (shiftf c -124766263)) - 411942919))) - 79909316946 -347537841 -210771963) - -142606339) - -;;; abcl 7 Jun 2004 -;;; catch-throw now enabled in the abcl compiler - -;;; Inconsistent stack height -(deftest misc.384 - (let - #+armedbear ((jvm::*catch-errors* nil)) - nil - (funcall - (compile - nil - '(lambda () - (catch 'ct8 (throw 'ct8 (catch 'ct7 0))))))) - 0) - -(deftest misc.385 - (let - #+armedbear ((jvm::*catch-errors* nil)) - nil - (funcall - (compile nil '(lambda () (values 1 (catch 'ct2 2)))))) - 1 2) - -(deftest misc.386 - (let - #+armedbear ((jvm::*catch-errors* nil)) - nil - (funcall - (compile nil '(lambda () (values (rationalize (catch 'ct1 1)) 2))))) - 1 2) - -(deftest misc.387 - (let - #+armedbear ((jvm::*catch-errors* nil)) - nil - (funcall - (compile nil '(lambda () (block b1 (catch 'ct1 (throw 'ct1 (return-from b1 0)))))))) - 0) - -;;; ecl (cvs head, 13 June 2004) -;;; Problems with multiple-value-setq - -; NIL cannot be coerced to a C int. - -(deftest misc.388 - (funcall - (compile - nil - '(lambda (a b c) - (declare (type (integer 200077 60836768) a)) - (declare (type (integer 339831915 371006999) b)) - (declare (type (integer -13 5553) c)) - (declare (ignorable a b c)) - (declare (optimize (speed 2) (space 1) (safety 0) (debug 0) - (compilation-speed 0))) - (dotimes (iv4 2 0) (multiple-value-setq (c) 4212)))) - 8959928 366395687 5048) - 0) - -;;; wrong return value - -(deftest misc.389 - (funcall - (compile - nil - '(lambda (a b c) - (declare (type (integer -49972981888 -48068810368) a)) - (declare (type (integer -452283089 -27620701) b)) - (declare (type (integer -24815 15089) c)) - (declare (ignorable a b c)) - (declare (optimize (speed 2) (space 1) (safety 2) (debug 1) - (compilation-speed 0))) - (multiple-value-setq (c) 8015))) - -49966124671 -68547159 12944) - 8015) - -;;; Evaluation order bug -(deftest misc.390 - (funcall - (compile - nil - '(lambda (a b c) - (declare (type (integer -257 -140) a)) - (declare (type (integer -1 1069496658) b)) - (declare (type (integer -4 2001960914944) c)) - (declare (ignorable a b c)) - (declare (optimize (speed 2) (space 0) (safety 1) (debug 0) - (compilation-speed 1))) - (labels ((%f12 (f12-1 &optional (f12-2 (setq b 63838027)) &key - (key1 0) (key2 0)) - b)) - (boole boole-orc2 b (let ((*s3* (%f12 0))) -14))))) - -173 1028908375 1289968133290) - 1028908383) - -;;; sbcl 0.8.14.14 -;;; "The value NIL is not of type SB-C::LVAR" - -(deftest misc.391 - (funcall - (compile - nil - '(lambda (a b) - (declare (optimize (speed 2) (space 0) (safety 0) - (debug 1) (compilation-speed 3))) - (let* ((v5 (cons b b))) - (declare (dynamic-extent v5)) - a))) - 'x 'y) - x) - -;;; sbcl 0.8.14.18 -;;; "The value # -;;; is not of type SB-C::REF." - -(deftest misc.392 - (funcall - (compile - nil - '(lambda (a b) - (declare (notinline /=)) - (declare (optimize (speed 1) (space 2) (safety 1) - (debug 3) (compilation-speed 3))) - (prog2 0 0 (loop for lv4 below 3 count (or b (/= b)))))) - 1 2) - 0) - -;;; cmucl (2004-09 snapshot) -;;; "Error in function C::CORE-CALL-TOP-LEVEL-LAMBDA: -;;; Unresolved forward reference." -;;; (in C::CORE-CALL-TOP-LEVEL-LAMBDA) - -(deftest misc.393 - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer -995205 1035654) a)) - (declare (type (integer 473 114804994247) b)) - (declare (ignorable a b)) - #+cmu (declare (optimize (extensions:inhibit-warnings 3))) - (declare - (optimize (debug 3) (speed 2) (compilation-speed 0) (space 3) - (safety 3))) - (labels ((%f7 - (f7-1 f7-2 f7-3 - &optional (f7-4 (lcm (if (>= b a) 0 a))) (f7-5 0) - &key) - 0)) - (progn (%f7 (%f7 b a a b) b 0) 0)))) - 447930 66120263479) - 0) - -(deftest misc.393a - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer -76 86) a)) - (declare (type (integer -13771285280 109) b)) - (declare (ignorable a b)) - #+cmu (declare (optimize (extensions:inhibit-warnings 3))) - (declare - (optimize (safety 3) (space 1) (debug 2) (compilation-speed 3) - (speed 3))) - (dotimes (iv1 2 0) - (case (min -3693810 a iv1) ((26 -4) (ldb (byte 13 0) a)) (t b))))) - 56 -1579426331) - 0) - -;;; cmucl (2004-09 snapshot) -;;; Wrong values - -(deftest misc.394 - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer -76645001 98715919) a)) - (declare (type (integer 0 856472753903) b)) - (declare (ignorable a b)) - #+cmu (declare (optimize (extensions:inhibit-warnings 3))) - (declare - (optimize (speed 2) (space 0) (debug 3) (compilation-speed 0) - (safety 3))) - (logeqv 0 b))) - -34528661 843541658238) - -843541658239) - -(deftest misc.395 - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer 6429252570156 8761983588786) a)) - (declare (type (integer -400378288 4971722) b)) - (declare (ignorable a b)) - #+cmu (declare (optimize (extensions:inhibit-warnings 3))) - (declare - (optimize (debug 3) (speed 3) (space 2) (safety 0) - (compilation-speed 3))) - (+ (shiftf a 8496033756259) (min 0 b)))) - 8369430915156 -369704905) - 8369061210251) - -;;; "The assertion (EQ (CAR C::STACK) C::CONT) failed." -(deftest misc.396 - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer -1601 485) a)) - (declare (type (integer -190428560464 -1444494) b)) - (declare (ignorable a b)) - #+cmu (declare (optimize (extensions:inhibit-warnings 3))) - (declare - (optimize (debug 0) (space 2) (speed 0) (safety 3) - (compilation-speed 2))) - (apply (constantly 0) 0 (list (signum b))))) - -1365 -46960621335) - 0) - -;;; "The assertion (EQ (C::FUNCTIONAL-KIND (C::LAMBDA-HOME C::FUN)) -;;; :TOP-LEVEL) failed." -(deftest misc.397 - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer -168258525920 -2044) a)) - (declare (type (integer -522 54) b)) - (declare (ignorable a b)) - #+cmu (declare (optimize (extensions:inhibit-warnings 3))) - (declare - (optimize (speed 0) (safety 3) (compilation-speed 1) (space 0) - (debug 2))) - (labels ((%f4 (f4-1 f4-2 &key) - (flet ((%f7 (f7-1 f7-2 f7-3 &optional &key (key1 a)) - (progv '(*s1* *s6* *s2*) (list a 0 key1) f4-1))) - f4-2))) - (apply #'%f4 (list a 0))))) - -156882103995 -38) - 0) - -;;; "Error in function C::CLOSURE-POSITION: -;;; Can't find #>" -(deftest misc.398 - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer -319 7353) a)) - (declare (type (integer 31751 4233916489) b)) - (declare (ignorable a b)) - #+cmu (declare (optimize (extensions:inhibit-warnings 3))) - (declare - (optimize (safety 3) (compilation-speed 1) (debug 1) (speed 0) - (space 0))) - (conjugate - (if t - (labels ((%f12 (f12-1 f12-2 f12-3) - 0)) - (%f12 0 b 0)) - (dotimes (iv1 2 0) (catch 'ct2 a)))))) - 4430 3476635674) - 0) - -;;; "NIL is not of type C::CONTINUATION" -;;; in C::FIND-PUSHED-CONTINUATIONS -(deftest misc.399 - (funcall - (compile - nil - '(lambda (a) - (declare (type (integer -3 1) a)) - (declare (ignorable a)) - #+cmu (declare (optimize (extensions:inhibit-warnings 3))) - (declare - (optimize (space 0) (debug 0) (speed 3) (compilation-speed 2) - (safety 3))) - (catch 'ct8 (logior a -457019 -1)))) - 0) - -1) - -;;; Wrong value -(deftest misc.400 - (funcall - (compile - nil - '(lambda (a) - (declare (type (integer 3376 4762) a)) - (declare (ignorable a)) - #+cmu (declare (optimize (extensions:inhibit-warnings 3))) - (declare - (optimize (debug 0) (safety 0) (space 0) (compilation-speed 3) - (speed 3))) - (case (lognand 775 a) ((-7) 0) (t 4)))) - 4182) - 0) - -;;; Invalid number of arguments: 1 -(deftest misc.401 - (funcall - (compile - nil - '(lambda (a) - (declare (type (integer 7299 257071514003) a)) - (declare (ignorable a)) - #+cmu (declare (optimize (extensions:inhibit-warnings 3))) - (declare - (optimize (compilation-speed 2) (space 1) (safety 2) (speed 1) - (debug 2))) - (logeqv (setq a 220250126156) 0))) - 157474319912) - -220250126157) - -;;; "The assertion (EQ (CAR C::NEW-STACK) C::CONT) failed." -(deftest misc.402 - (funcall - (compile - nil - '(lambda (a) - (declare (type (integer -19116544 21344004) a)) - (declare (ignorable a)) - #+cmu (declare (optimize (extensions:inhibit-warnings 3))) - (declare - (optimize (space 1) (safety 3) (debug 1) (compilation-speed 0) - (speed 0))) - (dotimes (iv3 2 0) - (progn - (apply (constantly 0) - (list - (let* ((*s1* 0)) - *s1*))) - 0)))) - 10) - 0) - -;;; "The assertion C::INDIRECT failed." -(deftest misc.403 - (funcall - (compile - nil - '(lambda (a) - (declare (type (integer -6456 -32) a)) - (declare (ignorable a)) - #+cmu (declare (optimize (extensions:inhibit-warnings 3))) - (declare - (optimize (space 3) (safety 1) (compilation-speed 1) (speed 0) - (debug 0))) - (dotimes (iv1 0 a) (loop for lv4 below 3 sum (catch 'ct8 0))))) - -1648) - -1648) - -;;; From abcl (cvs, 15 Sept 2004) -;;; Inconsistent stack height - -(deftest misc.404 - (let #+armedbear ((jvm::*catch-errors* nil)) - nil - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer -77007578505 7500480849) a)) - (declare (type (integer 211464 53140083) b)) - (declare (ignorable a b)) - (declare (optimize (compilation-speed 0) (speed 2) (debug 3) - (safety 1) (space 3))) - (progn (tagbody (let ((v3 - (cons (case a - ((13 5 -9 2 -13) (go tag8)) - (t 0)) - 0))) - 0) - tag8) - a))) - -1068524571 20786758)) - -1068524571) - -(deftest misc.405 - (let #+armedbear ((jvm::*catch-errors* nil)) - nil - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer -82196 13938) a)) - (declare (type (integer -44152792 -15846835) b)) - (declare (ignorable a b)) - (declare (optimize (compilation-speed 3) (safety 2) (speed 3) - (space 0) (debug 0))) - (block b5 - (let ((*s7* - (cons (if (position (if (eql 0 0) - (return-from b5 - (return-from b5 - (let ((*s6* (cons b a))) 0))) - b) - #(23) - :test-not - 'eql) - 0 - 0) - b))) - 0)))) - -10305 -26691848)) - 0) - -(deftest misc.406 - (let #+armedbear ((jvm::*catch-errors* nil)) - nil - (funcall - (compile - nil - '(lambda (a) - (declare (type (integer -1 1412366903315) a)) - (declare (ignorable a)) - (declare (optimize (debug 3) (safety 3) (space 3) - (compilation-speed 1) (speed 2))) - (progn (tagbody (case 0 ((1 0 4) (values (go 1) 0)) (t 0)) - 1) - 0))) - 251841706892)) - 0) - -;;; Incorrect binding -(deftest misc.407 - (funcall - (compile - nil - '(lambda (a) - (declare (type (integer -324 175) a)) - (declare (ignorable a)) - (declare (optimize (safety 0) (space 0) (speed 2) (debug 0) - (compilation-speed 0))) - (multiple-value-bind (v5) (cons (truncate 0) a) (cdr v5)))) - -279) - -279) - -;;; Stack size too large - -(deftest misc.408 - (let #+armedbear ((jvm::*catch-errors* nil)) - nil - (funcall - (compile - nil - '(lambda (a) - (declare (type (integer 0 0) a)) - (declare (ignorable a)) - (declare (optimize (compilation-speed 0) (safety 3) (speed 0) - (debug 1) (space 0))) - (progn (tagbody (dotimes (iv4 0 - (let ((v5 (cons 0 (if (go 3) 0 0)))) 0)) - (progn 0)) - 3) - (ash 0 (min 16 0))))) - 0)) - 0) - -;;; ecl (07 Oct 2004) -;;; (0 . 0) is not of type REAL - -(deftest misc.409 - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer -40524 53538) a)) - (declare (type (integer -5967075 -235) b)) - (declare (ignorable a b)) - (declare (optimize (speed 2) (safety 1) (space 2) - (compilation-speed 3) (debug 0))) - (labels ((%f2 (f2-1 f2-2 &optional (f2-3 0) (f2-4 a)) 0)) - (apply #'%f2 a - (%f2 b - (flet ((%f12 (f12-1 f12-2 f12-3 &optional &key - (key1 0) (key2 0)) - (%f2 0 0))) - (reduce #'(lambda (lmv2 lmv1) (%f2 0 0 a)) - (list 0 0 a 0 0 0 a) :end 7)) - 0) - nil)))) - -7465 -3590953) - 0) - -#| -;;; A bug was found in the compiler. Contact worm@arrakis.es. - -Broken at C::WT-MAKE-CLOSURE. -|# -(deftest misc.410 - (funcall - (compile - nil - '(lambda () - (declare (optimize (safety 0) (space 1) (compilation-speed 0) - (speed 2) (debug 0))) - (let ((*s2* 0)) - (declare (special *s2*)) - (reduce #'(lambda (lmv1 lmv2) *s2*) (vector 0) :end 1 - :start 0))))) - 0) - -;;; THROW: The catch CT2 is undefined. -(deftest misc.411 - (funcall - (compile - nil - '(lambda () - (declare (optimize (safety 2) (debug 0) (space 0) - (compilation-speed 2) (speed 0))) - (catch 'ct2 (values 0 (throw 'ct2 0))) - 0))) - 0) - -;;; /tmp/eclDD7aumXi8.c: In function `LC3': -;;; /tmp/eclDD7aumXi8.c:9: `env0' undeclared (first use in this function) -(deftest misc.412 - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer -25409 1946) a)) - (declare (type (integer -215956065 223815244) b)) - (declare (ignorable a b)) - (declare (optimize (compilation-speed 2) (space 3) (debug 2) - (safety 1) (speed 3))) - (complex (flet ((%f15 (f15-1 &optional &key (key1 0)) 0)) - (reduce #'(lambda (lmv6 lmv1) (%f15 lmv1)) - (list b 0))) - 0))) - -21802 -105983932) - 0) - -;;; Different resutls: #, 0 -(deftest misc.413 - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer -120206733 37762378) a)) - (declare (type (integer 2777758072 5675328792) b)) - (declare (ignorable a b)) - (declare (optimize (compilation-speed 3) (space 3) (debug 3) - (safety 0) (speed 1))) - (labels ((%f8 (f8-1 f8-2 &optional &key (key1 0)) - (let* ((v2 (ash f8-1 (min 63 a)))) 0))) - (ignore-errors - (logand (apply #'%f8 0 b nil) - (unwind-protect - 0 - (ash (%f8 0 0) - (min 48 - (flet - ((%f12 - (f12-1 f12-2 &optional &key - (key1 a) (key2 b) - &allow-other-keys) - 0)) - b))))))))) - -4794909 4095236669) - 0) - -;;; sbcl 0.8.14.28 -;;; Wrong value computed - -(deftest misc.414 - (funcall - (compile - nil - '(lambda (c) - (declare (optimize (speed 1) (space 3) (compilation-speed 3) - (debug 3) (safety 1))) - (if (setq c 2) - (case (shiftf c 1) ((2) c) (t 0)) - 0))) - 0) - 1) - -;;; cmucl -;;; Sept. 2004 snapshot -;;; Wrong return value - -(deftest misc.415 - (funcall - #'(lambda (a c) - (catch 'ct2 - (flet ((%f17 (&optional x &key) - (let* ((y (cons (dotimes (iv3 0)) 0))) - a))) - c))) - :bad :good) - :good) - -;;; Wrong value -(deftest misc.416 - (funcall - (compile - nil - '(lambda (b) - (declare (type (integer 12052668 22838464) b)) - (declare (ignorable a b c)) - (declare (optimize (compilation-speed 3) (debug 2) (speed 1) (space 0) - (safety 3))) - (min (mask-field (byte 2 18) b) 89582))) - 13891743) - 0) - -;;; Invalid number of arguments: 3 -(deftest misc.417 - (funcall - (compile - nil - '(lambda (c) - (declare (type (integer 995 22565094) c)) - (declare (optimize (safety 2) (debug 1) (space 0) (compilation-speed 2) - (speed 1))) - (numerator (floor (numerator (deposit-field 0 (byte 0 0) c)))))) - 17190042) - 17190042) - -;;; Invalid number of arguments: # -(deftest misc.418 - (funcall - (compile - nil - '(lambda (a b c) - (declare (type (integer 1670923021 2536883848) a)) - (declare (ignorable a b c)) - (declare (optimize (safety 3) (compilation-speed 3) (speed 1) (debug 1) - (space 2))) - (if (logior (setf c 67) 0 a) a 0))) - 2161404325 -1968715305 83) - 2161404325) - -;;; nil is not of type c::continuation -;;; (c::convert-type-check # -;;; ((nil # #))) - -(deftest misc.419 - (funcall - (compile - nil - '(lambda () - (declare (optimize (safety 3) (speed 3) (compilation-speed 1) (space 1) - (debug 2))) - (boole boole-set 0 (case 2 ((0) 0) (t (numerator (catch 'ct2 0)))))))) - -1) - -;;; nil is not of type c::continuation -;;; (c::convert-type-check # -;;; ((nil # #))) - -(deftest misc.420 - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer -65954801 6519292634236) a)) - (declare (type (integer 5721249203 36508717226) b)) - (declare (ignorable a b)) - (declare - (optimize (space 3) (compilation-speed 2) (safety 3) (speed 0) - (debug 2))) - (flet ((%f14 (f14-1 f14-2 &key) - (prog2 0 f14-2 (min (catch 'ct4 (floor 120378948 (max 22 a))))))) - (reduce #'(lambda (lmv6 lmv5) (%f14 0 0)) - (vector 0 0 0) - :start - 0 - :from-end - t)))) - 6313133774518 10840050742) - 0) - -;;; Invalid number of arguments: 1 -(deftest misc.421 - (funcall - (compile - nil - '(lambda (a) - (declare (optimize (debug 0) (space 2) (compilation-speed 1) (safety 0) - (speed 0))) - (imagpart (block b8 (logior (catch 'ct7 (return-from b8 a)) -1123785))))) - -1021899) - 0) - -;;; Invalid number of arguments: 2 -(deftest misc.422 - (funcall - (compile - nil - '(lambda (a) - (declare (type (integer -13 -3) a)) - (declare (optimize (space 2) (debug 1) (safety 1) (speed 2) - (compilation-speed 1))) - (logorc2 (sbit #*0010000011101010 (min 15 (max 0 0))) a))) - -7) - 6) - -;;; nil is not of type c::continuation -;;; (c::convert-type-check # -;;; ((t # #))) -(deftest misc.423 - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer 0 1) a)) - (declare (type (integer -8031148528 5509023941) b)) - #+cmu (declare (optimize (extensions:inhibit-warnings 3))) - (declare (optimize (space 2) (safety 3) (debug 1) (compilation-speed 3) (speed 2))) - (min 0 (ignore-errors (logand 0 b 388))))) - 0 4604112015) - 0) - -;;; Argument x is not a real: nil. -;;; (kernel:two-arg-> nil 0) - -(deftest misc.424 - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer -24 15) a)) - (declare (type (integer -99661829155 16) b)) - (declare (ignorable a b)) - #+cmu (declare (optimize (extensions:inhibit-warnings 3))) - (declare (optimize (safety 3) (debug 1) (compilation-speed 1) (space 3) - (speed 3))) - (catch 'ct4 - (logandc1 a - (ignore-errors - (let* ((v8 (complex (throw 'ct4 0) 0))) - 0)))))) - -18 -47519360453) - 0) - -;;; Different results -(deftest misc.425 - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer -394128 80657) a)) - (declare (type (integer 13729431 14852298) b)) - (declare (optimize (space 2) (compilation-speed 1) (safety 0) (debug 0) - (speed 2))) - (logorc1 (* a (logior b 0)) 0))) - -80334 14527920) - 1167085925279) - -;;; Unable to display error condition -(deftest misc.426 - (funcall - (compile - nil - '(lambda () - #+cmu (declare (optimize (extensions:inhibit-warnings 3))) - (declare (optimize (safety 3) (space 3) (speed 3) (debug 1) - (compilation-speed 3))) - (dotimes (iv3 1 0) (logxor iv3 1285775))))) - 0) - -;;; sbcl 0.8.15.13 -;;; NIL is not of type REAL -;;; (This appears to be related to DYNAMIC-EXTENT) - -(deftest misc.427 - (funcall - (compile - nil - '(lambda (a) - (declare (notinline list reduce logior)) - (declare (optimize (safety 2) (compilation-speed 1) - ; #+sbcl (sb-c:insert-step-conditions 0) - (speed 3) (space 2) (debug 2))) - (logior - (let* ((v5 (reduce #'+ (list 0 a)))) - (declare (dynamic-extent v5)) - (1- v5))))) - 17) - 16) - -(deftest misc.428 - (funcall - (compile - nil - '(lambda () - (declare (notinline -)) - (declare (optimize (compilation-speed 0) (safety 1) (speed 0) - (debug 2) (space 3))) - (let ((v10 (catch 'ct2 1))) - (declare (dynamic-extent v10)) - (- v10))))) - -1) - -(deftest misc.429 - (funcall - (compile - nil - '(lambda () - (declare (optimize (safety 1) (debug 1) (space 2) - (speed 2) (compilation-speed 1))) - (let ((v8 (let ((*s3* 0)) *s3*))) - (declare (dynamic-extent v8)) - (logandc1 v8 28))))) - 28) - -;;; poplog 15.53 -;;; Excess type specifier(s) in THE special form - -(deftest misc.430 - (unwind-protect 0 (the integer 1)) - 0) - -;;; Wrong return values: T, 0 -(deftest misc.431 - (funcall - (compile - nil - '(lambda (a) (declare (notinline > *)) - (declare (optimize (compilation-speed 0) (safety 2) (speed 2) (debug 0) (space 3))) - (catch 'ct1 (* a (throw 'ct1 (if (> 0) a 0)))))) - 5445205692802) - 5445205692802) - -;;; Ste: stack empty (missing argument? missing result?) -(deftest misc.432 - (loop for x below 2 count (not (not (typep x t)))) - 2) - -(deftest misc.433 - (let ((a 1)) (if (not (/= a 0)) a 0)) - 0) - -;;; sbcl 0.8.16.13 -;;; # is not valid as the first argument to VOP: -;;; SB-VM::FAST-ASH-LEFT-MOD32/UNSIGNED=>UNSIGNED -;;; Primitive type: T -;;; SC restrictions: -;;; (SB-VM::UNSIGNED-REG) -;;; The primitive type disallows these loadable SCs: -;;; (SB-VM::UNSIGNED-REG) - -(deftest misc.434 - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer -8431780939320 1571817471932) a)) - (declare (type (integer -4085 0) b)) - (declare (ignorable a b)) - (declare - (optimize (space 2) - (compilation-speed 0) - #+sbcl (sb-c:insert-step-conditions 0) - (debug 2) - (safety 0) - (speed 3))) - (let ((*s5* 0)) - (dotimes (iv1 2 0) - (let ((*s5* - (elt '(1954479092053) - (min 0 - (max 0 - (if (< iv1 iv1) - (lognand iv1 (ash iv1 (min 53 iv1))) - iv1)))))) - 0))))) - -7639589303599 -1368) - 0) - -;;; failed AVER: -;;; "(AND (EQ (CTRAN-KIND START) INSIDE-BLOCK) (NOT (BLOCK-DELETE-P BLOCK)))" -(deftest misc.435 - (funcall - (compile - nil - '(lambda (a b c d) - (declare (notinline aref logandc2 gcd make-array)) - (declare - (optimize (space 0) - (safety 0) - (compilation-speed 3) - (speed 3) - (debug 1) - )) - (progn - (tagbody - (let* ((v2 - (make-array nil :initial-element (catch 'ct1 (go tag2))))) - (declare (dynamic-extent v2)) - (gcd (go tag2) (logandc2 (catch 'ct2 c) (aref v2)))) - tag2) - 0))) - 3021871717588 -866608 -2 -17194) - 0) - -;;; In sbcl 0.8.16.18 -;;; # is not valid as the first argument to VOP: -;;; SB-VM::FAST-ASH-LEFT-MOD32/UNSIGNED=>UNSIGNED -;;; Primitive type: T -;;; SC restrictions: -;;; (SB-VM::UNSIGNED-REG) -;;; The primitive type disallows these loadable SCs: -;;; (SB-VM::UNSIGNED-REG) - -(deftest misc.436 - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer -2917822 2783884) a)) - (declare (type (integer 0 160159) b)) - (declare (ignorable a b)) - (declare - (optimize (compilation-speed 1) - (speed 3) - (safety 3) - (space 0) - ; #+sbcl (sb-c:insert-step-conditions 0) - (debug 0))) - (if - (oddp - (loop for - lv1 - below - 2 - count - (logbitp 0 - (1- - (ash b - (min 8 - (count 0 - '(-10197561 486 430631291 - 9674068)))))))) - b - 0))) - 1265797 110757) - 0) - -;;; The value NIL is not of type INTEGER. -;;; (in (SB-C::TN-SC-OFFSET 1 #)) - -(deftest misc.437 - (funcall - (compile - nil - '(lambda (a b c d e) - (declare (notinline values complex eql)) - (declare - (optimize (compilation-speed 3) - (speed 3) - ; #+sbcl (sb-c:insert-step-conditions 0) - (debug 1) - (safety 1) - (space 0))) - (flet ((%f10 - (f10-1 f10-2 f10-3 - &optional (f10-4 (ignore-errors 0)) (f10-5 0) - &key &allow-other-keys) - (if (or (eql 0 0) t) 0 (if f10-1 0 0)))) - (complex (multiple-value-call #'%f10 (values a c b 0 0)) 0)))) - 80043 74953652306 33658947 -63099937105 -27842393) - 0) - -;;; # is not valid as the second argument to VOP: -;;; SB-VM::FAST-ASH-LEFT-MOD32/UNSIGNED=>UNSIGNED -;;; Primitive type: T -;;; SC restrictions: -;;; (SB-VM::UNSIGNED-REG) -;;; The primitive type disallows these loadable SCs: -;;; (SB-VM::UNSIGNED-REG) - -(deftest misc.438 - (funcall - (compile - nil - ' (lambda (a) - (declare (type (integer 0 1696) a)) - ; (declare (ignorable a)) - (declare (optimize (space 2) (debug 0) (safety 1) - (compilation-speed 0) (speed 1))) - (if (logbitp 0 (ash (1- a) (min 11 a))) 0 0))) - 805) - 0) - -;;; "The value -13589 is not of type (INTEGER -15205 18871)" -(deftest misc.439 - (funcall - (compile - nil - '(lambda (a) - (declare (type (integer -15205 18871) a)) - (declare (ignorable a)) - (declare - (optimize (space 2) - ; (sb-c:insert-step-conditions 0) - (speed 1) - (safety 1) - (debug 1) - (compilation-speed 3))) - (if (<= a (- (setf a 10305))) a 0))) - -13589) - 10305) - -;;; In ACL 7.0 (sparc, Solaris 8, 11 Nov 2004) -;;; Error: the value of (CAR EXCL::INTEGERS) is NIL, which is not of type INTEGER. - -(deftest misc.440 - (funcall - (compile - nil - '(lambda (a b c) - (declare (notinline logior)) - (declare (optimize (safety 3) (debug 1) (speed 0) (space 1) - (compilation-speed 3))) - (flet ((%f10 (&optional &key - (key1 - (logior (flet ((%f4 (f4-1 - &optional - &key - (key1 0) - (key2 b) - &allow-other-keys) - c)) - (%f4 0)))) - &allow-other-keys) - 0)) - (let ((*s8* (%f10))) - (declare (special *s8*)) - *s8*)))) - 13524 4484529434427 8109510572804) - 0) - -;;; Error: the value of realpart is nil, which is not of type (or rational float). -(deftest misc.441 - (funcall - (compile - nil - '(lambda (a b) - (declare (notinline complex)) - (declare (optimize (compilation-speed 1) (space 1) (speed 3) (safety 2) (debug 3))) - (flet ((%f8 (f8-1 f8-2 &optional - &key (key1 (labels ((%f9 nil a)) (complex (%f9) 0))) - (key2 0) &allow-other-keys) - 0)) - (%f8 0 a)))) - 1 2) - 0) - -;;; Error: the value of excl::x is nil, which is not of type integer. -(deftest misc.442 - (funcall - (compile - nil - '(lambda (a b) - (declare (notinline apply evenp)) - (declare (optimize (speed 1) (space 1) (safety 1) (compilation-speed 0) (debug 0))) - (labels ((%f18 (f18-1 &optional - &key - (key1 (flet ((%f8 nil b)) (if (evenp (%f8)) 0 a))) - (key2 0)) - 0)) - (apply #'%f18 b nil)))) - 505808341634 -39752189) - 0) - -;;; Error: No from-creg to move to <3:iparam2@(:iparam 2){4=c{s:<3>}}> before (move-throw-tag nil nil -> ({18}) ([18>>:frame :dfr])) - -(deftest misc.443 - (funcall - (compile - nil - '(lambda (a b c d e) - (declare (type (integer -2310674 2) a)) - (declare (type (integer -492505702625 -147091001460) b)) - (declare (type (integer -27638568 52971156) c)) - (declare (type (integer -151 203) d)) - (declare (type (integer -1400301 8173230) e)) - (declare (ignorable a b c d e)) - (declare (optimize (compilation-speed 3) (debug 0) (space 0) (safety 1) (speed 1))) - (catch 'ct7 (lcm (case 0 - ((-4557) (let ((*s7* (max d))) 0)) - ((-15387) c) - (t 0)) - (unwind-protect (throw 'ct7 b) 0))))) - -1748290 -244489705763 38969920 -90 341977) - -244489705763) - -;;; misc.444 -;;; misc.445 - -;;; gcl 25 Nov 2004 -;;; Incorrect return value -(deftest misc.446 - (funcall - (compile - nil - '(lambda (a b c d) - (declare (type (integer -1254 1868060) a)) - (declare (type (integer -1 0) b)) - (declare (type (integer -424707253248 -82453721088) c)) - (declare (type (integer -252962 3018671) d)) - (declare (ignorable a b c d)) - (declare (optimize (safety 3) (space 3) (speed 3) - (compilation-speed 3) (debug 3))) - (* (labels ((%f8 (&optional (f8-1 0)) (setq b 0))) - (if (> d 1668249724 (%f8)) 0 (complex a 0))) - (if (oddp b) 0 c)))) - 796131 -1 -338008808923 530637) - -269099291056676913) - -(deftest misc.447 - (funcall - (compile - nil - '(lambda (a) - (declare (type (integer 38632397 46632460288) a)) - (declare (optimize (space 0) (safety 0) (debug 1) - (compilation-speed 1) (speed 0))) - (catch 'ct2 (if (= a 0 (throw 'ct2 0)) 1 2289596)))) - 18160383912) - 0) - -(deftest misc.448 - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer -3716 1269) a)) - (declare (type (integer -1976579 2312) b)) - (declare (optimize (compilation-speed 1) (safety 0) - (speed 0) (space 0) (debug 3))) - (if (<= 0 b (setq a 117)) 0 a))) - -1147 -44004) - 117) - -;;; gcl 27 Nov 2004 -;;; Incorrect return value - -(deftest misc.449 - (funcall (compile nil '(lambda (a) (* 10 a (setq a 1000)))) 1) - 10000) - -;;; Error in COMPILER::CMP-ANON [or a callee]: The variable MIN is unbound. -(deftest misc.450 - (funcall - (compile nil '(lambda (a b) (min 0 (reduce #'min (vector a b 0)) 0))) - -10 -1) - -10) - -;;; gcl 28 Nov 2004 -;;; Incorrect return value - -(deftest misc.451 - (funcall (compile nil '(lambda (a b) (flet ((%f3 () (setq a -2210))) - (logxor a b (%f3))))) - -22650 20595) - 171) - -(deftest misc.452 - (funcall (compile nil '(lambda (d) (labels ((%f3 () (setf d -1135) -983)) - (+ d (%f3) 11267)))) - -2914) - 7370) - -(deftest misc.453 - (funcall (compile nil '(lambda (a) (* a (setf a 2) a (identity 5)))) - 3) - 60) - -(deftest misc.454 - (let* ((form '(let ((v1 0)) (decf v1 (setq v1 -1)))) - (val1 (eval form)) - (val2 (funcall (compile nil `(lambda () ,form))))) - (if (eql val1 val2) :good - (list val1 val2))) - :good) - -;;; sbcl 0.8.17.24 -;;; Bugs in the just-introduced fixnum arithmetic transforms - -;;; LOGAND (?) bug - -(deftest misc.455 - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer -4079701634499 2272876436845) b)) - (declare (optimize (space 0) (compilation-speed 1) - (safety 3) (speed 2) (debug 0))) - (logand (* -775 b) a 37284))) - -18465060867 832909434173) - 32772) - -(deftest misc.456 - (funcall - (compile - nil - '(lambda (b c) - (declare (type (integer -30606350847 35078064098) b)) - (declare (type (integer -6652 6638) c)) - (declare (optimize (space 3) (safety 0) - (speed 0) (compilation-speed 2) (debug 1))) - (logand (* -9964236 (setq c 6206) 2600) b c))) - 17296668225 -6574) - 4096) - -;;; DEPOSIT-FIELD (?) bug - -(deftest misc.457 - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer -455461 343063) a)) - (declare (type (integer -1020097 -12430) b)) - (declare (optimize (speed 3) (space 0) (compilation-speed 3) - (debug 0) (safety 3))) - (deposit-field (* (logeqv a a) b) (byte 6 24) 0))) - -212811 -985078) - 0) - -;;; LDB, * - -(deftest misc.458 - (funcall - (compile - nil - ' (lambda (a) - (declare (type (integer -8175 27760966190) a)) - (declare (optimize - ;; The next optimize declaration is necessary - ;; for the bug to occur in sbcl 0.8.17.24 - #+sbcl (sb-c:insert-step-conditions 0) - (space 2) (speed 0) (compilation-speed 1) - (safety 0) (debug 3))) - (ldb (byte 29 0) (* a a)))) - 14774118941) - 101418825) - -;;; LOGAND, + - -(deftest misc.459 - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer -32933298905 -168011) a)) - (declare (type (integer -190015111797 16) b)) - (declare (optimize (speed 2) (compilation-speed 0) (space 0) - (safety 1) (debug 0))) - (logand (+ b -9255) a 63))) - -8166030199 -45872222127) - 8) - -;;; In sbcl 0.8.17.28-signed-modular-arithmetic.3 -;;; Unreachable code is found or flow graph is not properly depth-first ordered. -;;; (This is apparently a different bug from the previous ones that -;;; were causing this message to be printed.) - -(deftest misc.460 - (funcall - (compile - nil - '(lambda (a) - (declare (type (integer 50354997 50514623) a)) - (declare (ignorable a)) - (declare - (optimize (speed 0) - (safety 0) - (compilation-speed 3) - #+sbcl (sb-c:insert-step-conditions 0) - (debug 1) - (space 1))) - (loop for lv3 below 2 - sum (if (find 0 - '(-17604051 126613572 -795198 12037855 127043241 -2 -59 - -3458890 1505 -1 -2 107498637 -977489 172087 421813 - 543299114 12 4311490 569 -3509 -4051770 -1 1 1 - 216399387 -2482 143297 2 304550 -61 -195904988 - 57682175 2344 1294831 -247 -2 25779388 -296 -12115 - -158487 -15) - :test 'eql) - (if (find 0 #(4193594) :test '<) - (min (catch 'ct6 0) (catch 'ct8 0) 0) - (let ((*s1* (cons a 0))) - (car *s1*))) - 0)))) - 50395193) - 0) - -;;; gcl 16 Dec 2004 -;;; Error possibly related to type propagation - -(deftest misc.461 - (funcall - (compile nil '(lambda (a) - (declare (type (integer -26657952320 0) a)) - (declare (optimize (compilation-speed 0) (space 3) (speed 3) - (safety 0) (debug 2))) - (- a - (ash -1 (min 31 (- a))) - -26715477))) - -26179151369) - -24004952244) - -;;; gcl 18 Dec 2004 -;;; Doesn't cause an error, unless -Werror is added to gcc flags -;;; gazonk0.c: In function `L1': -;;; gazonk0.c:5257: warning: assignment makes integer from pointer without a cast - -(deftest misc.462 - (funcall - (compile nil '(lambda (a b) - (declare (type (integer -2726808666112 -26532) a)) - (declare (type (integer 182701814 171137312256) b)) - (declare (ignorable a b)) - (declare (optimize (compilation-speed 3) (safety 0) - (speed 3) (space 3) (debug 3))) - (ash (let* ((v8 (cons 0 0))) 0) (min 15 a)))) - -1982565461868 46279989780) - 0) - -;;; gazonk0.c: In function `L1': -;;; gazonk0.c:5262: warning: assignment makes integer from pointer without a cast -(deftest misc.463 - (funcall - (compile nil '(lambda (a b) - (declare (type (integer 0 0) a)) - (declare (type (integer -160364747008 264742845184) b)) - (declare (ignorable a b)) - (declare (optimize (debug 0) (safety 0) - (compilation-speed 2) (space 0) - (speed 1))) - (ash (multiple-value-setq (a) 0) (min 97 13027666096)))) - 0 34670845086) - 0) - -;;; gcl 21 Dec 2004 -;;; Compiler error on ash, rem - -(deftest misc.464 - (funcall - (compile nil '(lambda () - (declare (optimize (debug 1) (safety 2) (compilation-speed 0) - (space 1) (speed 1))) - (count (ash (the integer - (macrolet () (rem -197 (min -72 215)))) - (min 98 442719)) - #(0 96) :test '=)))) - 0) - -(deftest misc.465 - (funcall - (compile nil '(lambda (a) - (declare (type (integer -18822 -1280) a)) - (declare (optimize (debug 0) (speed 1) - (compilation-speed 3) (safety 0) - (space 0))) - (ash (the integer - (logand a (if t a (imagpart -2607360)))) - (min 79 (catch 'ct7 0))))) - -17635) - -17635) - -;;; ACL 6.2 (x86 linux) -;;; Bug in type propagation for ISQRT -;;; Found with the special purpose random tester for type propagation - -;;; While compiling (:ANONYMOUS-LAMBDA 22203): -;;; Error: -1 is illegal argument to isqrt - -(deftest misc.466 - (funcall (compile nil '(lambda (x) - (declare (type (member 4 -1) x) - (optimize speed (safety 1))) - (isqrt x))) - 4) - 2) - -;;; gcl 24 Dec 2004 -;;; Incorrect results (these may all be related) -;;; These are also produced by the special purpose tester in random-type-prop.lsp - -(deftest misc.467 - (funcall - (compile nil '(lambda (p2 p3) - (declare (optimize speed (safety 1)) - (type (integer -990888631320) p2) - (type (integer -20346 -19755) p3)) - (+ -77 (the (integer * -990888630255) p2) p3))) - -990888630272 -19756) - -990888650105) - -(deftest misc.468 - (funcall - (compile nil '(lambda (p2 p3) - (declare (optimize speed (safety 1)) - (type (integer * 151075404030) p2) - (type (integer 6515518 *) p3)) - (- 12967657127936 (the (eql 151075403520) p2) - (the (member 6515658 -14) p3)))) - 151075403520 6515658) - 12816575208758) - -(deftest misc.469 - (funcall - (compile nil '(lambda (p2) - (declare (optimize speed (safety 1)) (type integer p2)) - (+ 30926 (the (integer -4025987543018 *) p2)))) - -4025817763840) - -4025817732914) - -(deftest misc.470 - (funcall - (compile nil '(lambda (p2) - (declare (optimize speed (safety 1)) - (type (integer 3689224658939 *) p2)) - (+ -1071 (the (integer * 3689229115390) p2)))) - 3689228853248) - 3689228852177) - -(deftest misc.471 - (funcall - (compile nil '(lambda (p1 p2) - (declare (optimize speed (safety 1)) - (type (integer -9024844 230253450) p1) - (type (eql 35716681856) p2)) - (* p1 (the (integer * 35716681856) p2)))) - -9024809 35716681856) - -322336231864165504) - -(deftest misc.472 - (funcall - (compile nil '(lambda (p1 p2) - (declare (optimize speed (safety 1)) - (type (integer -785238 -80) p1) - (type (eql -523213622272) p2)) - (min p1 (the integer p2)))) - -259 -523213622272) - -523213622272) - -(deftest misc.473 - (funcall - (compile nil '(lambda (p2) - (declare (optimize speed (safety 1)) - (type (integer * 65861934352) p2)) - (max 23939 (the (integer 64863825609 65878336765) p2)))) - 65861912512) - 65861912512) - -(deftest misc.474 - (funcall - (compile nil '(lambda (p1) - (declare (optimize speed (safety 1)) - (type (integer -6750156308) p1)) - (logand (the signed-byte p1) -540165229))) - -6750156304) - -7289140848) - -;;; abcl 25 Dec 2005 -;;; Debugger invoked on condition of type UNDEFINED-FUNCTION: -;;; The function %FAILED-AVER is undefined. - -(deftest misc.475 - (let #+armedbear ((jvm::*catch-errors* nil)) - nil - (funcall - (compile nil '(lambda (p1 p2 p3 p4 p6) - (declare (optimize speed (safety 1)) - (type (integer -785238 61564048) p1) - (type (integer * 65861934352) p2)) - (+ P1 (THE (INTEGER -485480 -7019) P2) P3 P4 - 463666373060 - P6))) - 61564048 -7457 24939545512 51 730)) - 488667475944) - -(deftest misc.476 - (let #+armedbear ((jvm::*catch-errors* nil)) - nil - (funcall - (compile nil '(lambda (p4) - (declare (optimize speed (safety 1)) - (type (integer -115781893486) p4)) - (- 1 -35 0 (the (integer -115778245122) p4) -2))) - -115778114900)) - 115778114938) - -(deftest misc.477 - (let #+armedbear ((jvm::*catch-errors* nil)) - nil - (funcall - (compile nil '(lambda (p4 p5) - (declare (optimize speed (safety 1)) - (type (integer -126908726190 -126906628448) p4) - (type (integer * 2202) p5)) - (* -1950 -33610502463 2 p4 p5))) - -126906629040 1839)) - -30591843552678654213361992000) - -(deftest misc.478 - (let #+armedbear ((jvm::*catch-errors* nil)) - nil - (funcall - (compile nil '(lambda (p2) - (declare (optimize speed (safety 1)) - (type (integer * 2343679) p2)) - (logand 12050257282405 p2 117775123 505354693 -415679150084))) - -6189)) - 33816832) - -;;; Bug in CMUCL Snapshot 2004-10 -;;; Invalid number of arguments: 370632372 - -(deftest misc.479 - (let ((r (make-array nil :element-type '(unsigned-byte 32))) - (fn (compile nil '(lambda (r p2) - (declare (optimize speed (safety 1)) - (type (simple-array (unsigned-byte 32) nil) r) - (type integer p2)) - (setf (aref r) (logxor 0 (the (integer 2797513123 2798027357) p2))) - (values))))) - (funcall fn r 2797674503) - (aref r)) - 2797674503) - -(deftest misc.480 - (let ((r (make-array nil :element-type 'integer)) - (fn (compile nil '(lambda (r p1) - (declare (optimize speed (safety 1)) - (type (simple-array integer nil) r) - (type (integer -797971 -797511) p1)) - (setf (aref r) (logeqv p1 15 1078254884158 -12564176924 0 15096591909)) - (values))))) - (funcall fn r -797965) - (aref r)) - -1075415510532) - -(deftest misc.481 - (let ((r (make-array nil :element-type '(unsigned-byte 16))) - (fn (compile nil '(lambda (r p1) - (declare (optimize speed (safety 1)) - (type (simple-array (unsigned-byte 16) nil) r) - (type (member 4194309 -123 1692 -4432 -760653 -1741 37) p1)) - (setf (aref r) (logorc1 (the (eql -4432) p1) 0)) - (values))))) - (funcall fn r -4432) - (aref r)) - 4431) - -;; Various incorrect results - -(deftest misc.482 - (let ((r (make-array nil :element-type '(unsigned-byte 4))) - (fn (compile nil '(lambda (r p2) - (declare (optimize speed (safety 1)) - (type (simple-array (unsigned-byte 4) nil) r) - (type (eql -4) p2)) - (setf (aref r) (logorc2 13 p2)) - (values))))) - (funcall fn r -4) - (aref r)) - 15) - -(deftest misc.483 - (let ((r (make-array nil :element-type '(unsigned-byte 4))) - (fn (compile nil '(lambda (r p1 p2) - (declare (optimize speed (safety 1)) - (type (simple-array (unsigned-byte 4) nil) r) - (type (integer * 28306533) p1) - (type (integer * 1245601) p2)) - (setf (aref r) (logandc1 p1 (the (integer -3308174) p2))) - (values))))) - (funcall fn r -519 -28180) - (aref r)) - 4) - -(deftest misc.484 - (let ((r (make-array nil :element-type '(unsigned-byte 4))) - (fn (compile nil '(lambda (r p2) - (declare (optimize speed (safety 1)) - (type (simple-array (unsigned-byte 4) nil) r) - (type (member 260646 -348969 34359738370 -110167) p2)) - (setf (aref r) (logandc2 9 (the (eql -348969) p2))) - (values))))) - (funcall fn r -348969) - (aref r)) - 8) - -(deftest misc.485 - (let ((r (make-array nil :element-type 'bit)) - (fn (compile nil '(lambda (r p2) - (declare (optimize speed (safety 1)) - (type (simple-array bit nil) r) - (type (integer -108220 256178) p2)) - (setf (aref r) (logand 1 (the (member -1 2147483652 1 -5 3802) p2))) - (values))))) - (funcall fn r -5) - (aref r)) - 1) - -(deftest misc.486 - (let ((r (make-array nil :element-type '(unsigned-byte 4))) - (fn (compile nil '(lambda (r p1 p2) - (declare (optimize speed (safety 1)) - (type (simple-array (unsigned-byte 4) nil) r) - (type (integer -9) p1) - (type (integer * 1234117) p2)) - (setf (aref r) (logior (the (integer -295 *) p1) (the (integer -90 *) p2))) - (values))))) - (funcall fn r 6 6) - (aref r)) - 6) - -(deftest misc.487 - (let ((r (make-array nil :element-type '(unsigned-byte 16))) - (fn (compile nil '(lambda (r p1) - (declare (optimize speed (safety 1)) - (type (simple-array (unsigned-byte 16) nil) r) - (type (integer 1583040351 1587341394) p1)) - (setf (aref r) (logandc2 (the (integer 1587211196 1587341392) p1) -166174)) - (values))))) - (funcall fn r 1587341392) - (aref r)) - 34832) - -(deftest misc.488 - (let ((r (make-array nil :element-type '(unsigned-byte 32))) - (fn (compile nil '(lambda (r p2) - (declare (optimize speed (safety 1)) - (type (simple-array (unsigned-byte 32) nil) r) - (type (integer 1960409798 1960426181) p2)) - (setf (aref r) (logorc1 -1 p2)) - (values))))) - (funcall fn r 1960409801) - (aref r)) - 1960409801) - -(deftest misc.489 - (let ((r (make-array nil :element-type '(unsigned-byte 32))) - (fn (compile nil '(lambda (r p2) - (declare (optimize speed (safety 1)) - (type (simple-array (unsigned-byte 32) nil) r) - (type (integer -55) p2)) - (setf (aref r) (logorc2 0 (the (member -51) p2))) - (values))))) - (funcall fn r -51) - (aref r)) - 50) - -(deftest misc.490 - (let ((r (make-array nil :element-type '(unsigned-byte 32))) - (fn (compile nil '(lambda (r p1) - (declare (optimize speed (safety 1)) - (type (simple-array (unsigned-byte 32) nil) r) - (type (integer 761639858 1030075825) p1)) - (setf (aref r) (logior (the (integer * 35389813668) p1) 0)) - (values))))) - (funcall fn r 1030075308) - (aref r)) - 1030075308) - -(deftest misc.491 - (let ((r (make-array nil :element-type '(signed-byte 16))) - (fn (compile nil '(lambda (r p2) - (declare (optimize speed (safety 1)) - (type (simple-array (signed-byte 16) nil) r) - (type (integer 505774114 573717424) p2)) - (setf (aref r) (lognand 58539 (the (integer * 910674467) p2))) - (values))))) - (funcall fn r 506608551) - (aref r)) - -8356) - -(deftest misc.492 - (let ((r (make-array nil :element-type '(signed-byte 8))) - (fn (compile nil '(lambda (r p1) - (declare (optimize speed (safety 1)) - (type (simple-array (signed-byte 8) nil) r) (type (integer * 22050378) p1)) - (setf (aref r) (lognand (the (integer 19464371) p1) 2257)) - (values))))) - (funcall fn r 19469591) - (aref r)) - -18) - -;;; ABCL (25 Dec 2004) -;;; Class verification failed: (class: org/armedbear/lisp/out, method: execute signature: (Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;) Expecting to find integer on stack - -(deftest misc.493 - (let #+abcl ((jvm::*catch-errors* nil)) - nil - (funcall - (compile nil '(lambda (b) - (declare (optimize (speed 2) (debug 1) (safety 3) - (compilation-speed 3) (space 1))) - (aref #(41397376227 18660605846 49244777443) (min 2 (max 0 b))))) - - -71)) - 41397376227) - -;;; ABCL (26 Dec 2004) -;;; Class verification failed: [...] Illegal exception table range - -(deftest misc.494 - (let #+abcl ((jvm::*catch-errors* nil)) - nil - (funcall - (compile nil '(lambda () - (declare (optimize (safety 0) (space 2) (debug 3) (speed 0) - (compilation-speed 2))) - (conjugate (progn (catch 'ct5 (if t 0 0)) 0)))))) - 0) - -;;; The value 5085 is not of type FUNCTION. - -(deftest misc.495 - (funcall - (compile nil '(lambda (a b) - (declare (type (integer -4197 284380207) a)) - (declare (type (integer -23 5088) b)) - (declare (ignorable a b)) - (declare (optimize (speed 1) (space 2) (debug 0) - (compilation-speed 0) (safety 2))) - (if (position (progn (1+ b) 0) - '(169496 -726 -13623 53307916 128 -258391 156 - 7432659 30 20 -11)) - 0 - a))) - 72179019 5084) - 72179019) - -;;; Inconsistent stack height 1 != 2 - -(deftest misc.496 - (let #+abcl ((jvm::*catch-errors* nil)) - nil - (funcall - (compile nil - '(lambda (a) - (declare (type (integer -54915 -3396) a)) - (declare (optimize (debug 3) (space 0) (safety 2) (speed 2) - (compilation-speed 3))) - (progn (1+ a) (catch 'ct6 (progn 0))))) - -25986)) - 0) - -(deftest misc.497 - (let #+abcl ((jvm::*catch-errors* nil)) - nil - (funcall - (compile nil - '(lambda (b) - (declare (type (integer -1 0) b)) - (declare (optimize (space 3) (compilation-speed 1) - (safety 0) (debug 1) (speed 0))) - (if 0 (prog2 0 0 (1+ b)) 0))) - 0)) - 0) - -;;; Inconsistent stack height 1 != 0 - -(deftest misc.498 - (let #+abcl ((jvm::*catch-errors* nil)) - nil - (funcall - (compile nil - '(lambda (a) - (declare (type (integer -16191 4) a)) - (declare (optimize (compilation-speed 2) (space 1) (debug 0) - (safety 0) (speed 2))) - (conjugate (dotimes (iv1 0 0) - (let ((v2 (dotimes (iv3 0 0) (1+ a)))) - 0))))) - -2840)) - 0) - -;;; Incompatible object argument for function call - -(deftest misc.499 - (let #+abcl ((jvm::*catch-errors* nil)) - nil - (funcall - (compile nil - '(lambda (a b) - (declare (type (integer -31415 133871) a)) - (declare (type (integer -993 6448) b)) - (declare (ignorable a b)) - (declare (optimize (space 0) (debug 2) (safety 0) (speed 0) - (compilation-speed 0))) - (progn (ceiling (progn (1+ b) a)) a))) - -16435 2620)) - -16435) - -;;; Stack overflow during compilation - -(deftest misc.500 - (funcall - (compile nil '(lambda nil - (declare (optimize (space 2) (debug 2) (compilation-speed 2) - (speed 1) (safety 3))) - (the integer (integer-length (dotimes (iv4 2 15790955))))))) - 24) - -;;; Inconsistent stack height 1 != 0 - -(deftest misc.501 - (let #+abcl ((jvm::*catch-errors* nil)) - nil - (funcall - (compile nil '(lambda (a) - (declare (type (integer -437165353 179983908) a)) - (declare (optimize (compilation-speed 0) (debug 1) (space 1) - (safety 2) (speed 1))) - (dotimes (iv1 0 0) (1+ a)))) - 1)) - 0) - -;;; Ordering problems - -(deftest misc.502 - (funcall - (compile nil '(lambda (a) - (declare (type (integer -7 84717795) a)) - (declare (ignorable a)) - (declare (optimize (speed 1) (space 1) (debug 1) (safety 2) - (compilation-speed 0))) - (+ a (setq a 35035201)))) - 29207264) - 64242465) - -;;; ABCL 27 Dec 2004 -;;; Different results - -(deftest misc.503 - (funcall - (compile nil '(lambda (a) - (declare (optimize (space 3) (debug 1) (speed 2) (safety 0) - (compilation-speed 1))) - (catch 'ct1 - (throw 'ct1 - (catch 'ct5 - (reduce 'min - (vector 0 0 0 a a 0 0 (values 0 0) (throw 'ct5 -6)) - :end 8 :start 6 :from-end t)))))) - 17) - -6) - -;;; Inconsistent stack height - -(deftest misc.504 - (let #+abcl ((jvm::*catch-errors* nil)) - nil - (funcall - (compile nil '(lambda (a) - (declare (type (integer 196060 241373941) a)) - (declare (ignorable a)) - (declare (optimize (speed 3) (debug 0) (safety 2) - (compilation-speed 3) (space 2))) - (prog2 (if 0 (+ a a) 0) 0))) - 200000)) - 0) - -(deftest misc.505 - (let #+abcl ((jvm::*catch-errors* nil)) - nil - (funcall - (compile nil '(lambda (a) - (declare (type (integer -6 5) a)) - (declare (optimize (speed 3) (space 0) (safety 2) - (compilation-speed 2) (debug 3))) - (dotimes (iv1 0 0) (+ a a)))) - 1)) - 0) - -(deftest misc.506 - (let #+abcl ((jvm::*catch-errors* nil)) - nil - (funcall - (compile nil '(lambda (a) - (declare (type (integer -53 49) a)) - (declare (optimize (debug 0) (compilation-speed 1) (space 2) - (safety 0) (speed 0))) - (unwind-protect (+ a a) 0))) - -38)) - -76) - -;;; The value 15390 is not of type FUNCTION. -(deftest misc.507 - (funcall - (compile nil '(lambda (a) - (declare (type (integer 2697 13005) a)) - (declare (optimize (debug 0) (space 2) (speed 2) - (compilation-speed 3) (safety 3))) - (truncate (prog1 0 a (+ a a))))) - 7695) - 0 0) - -;;; COMPILE-FORM: unsupported special operator LET* -;;; Associated with 'THE' operator - -(deftest misc.508 - (let #+abcl ((jvm::*catch-errors* nil)) - nil - (funcall - (compile nil '(lambda (a) - (declare (type (integer -57853147 -2) a)) - (declare (ignorable a)) - (declare (optimize (debug 2) (space 1) (compilation-speed 3) - (safety 1) (speed 2))) - (the integer - (mask-field (byte 2 29) - (ash (multiple-value-setq (a) -51781613) - (min 1 a)))))) - -29324754)) - 1610612736) - -(deftest misc.509 - (let #+abcl ((jvm::*catch-errors* nil)) - nil - (funcall - (compile nil '(lambda (a) - (declare (type (integer -38984312 657) a)) - (declare (ignorable a)) - (declare (optimize (debug 1) (compilation-speed 1) (speed 1) - (safety 2) (space 3))) - (the integer - (if (> a -27907941364) - 116871 - (cl:handler-case - (multiple-value-setq (a) - -34832621)))))) - -26788929)) - 116871) - -(deftest misc.510 - (let #+abcl ((jvm::*catch-errors* nil)) - nil - (funcall - (compile nil '(lambda (a) - (declare (type (integer -2827 3400) a)) - (declare (optimize (compilation-speed 1) (space 3) (debug 1) - (safety 0) (speed 1))) - (logand (the integer (dotimes (iv4 2 a) (progn iv4)))))) - 155)) - 155) - -(deftest misc.511 - (let #+abcl ((jvm::*catch-errors* nil)) - nil - (funcall - (compile nil '(lambda (a) - (declare (type (integer 18967 23584) a)) - (declare (ignorable a)) - (declare (optimize (space 1) (speed 1) (debug 1) - (compilation-speed 3) (safety 1))) - (the integer - (values (loop for lv4 below 2 count (find a '(16389))))))) - 21352)) - 0) - -;;; Inconsistent stack height - -(deftest misc.512 - (let #+abcl ((jvm::*catch-errors* nil)) - nil - (funcall - (compile nil '(lambda (a) - (declare (type (integer 1 188902468) a)) - (declare (ignorable a)) - (declare (optimize (space 2) (speed 3) (safety 3) - (compilation-speed 0) (debug 2))) - (catch 'ct6 - (the integer - (let* ((v3 (signum (ignore-errors a)))) - (declare (dynamic-extent v3)) - (throw 'ct6 - (round (case (prog2 - (lognor 290171664 v3) - -3512003993 - -550842867) - ((4) (* 1 4092)) - ((21 220 225) - (block b1 - (setf v3 - (let* ((v9 v3)) - a)))) - (t -639367819))))))))) - 49008586)) - -639367819 - 0) - -;;; COMPILE-FORM: unsupported special operator LET* -;;; Associated with 'THE' operator - -(deftest misc.513 - (let #+abcl ((jvm::*catch-errors* nil)) - nil - (funcall - (compile nil '(lambda (a) - (declare (type (integer -2 75025568) a)) - (declare (ignorable a)) - (declare (optimize (space 0) (compilation-speed 0) (safety 0) - (speed 2) (debug 2))) - (let* ((v8 - (cons (the integer - (prog2 a - -1558460 - a - (ignore-errors (progn (tagbody) -49510826)) - a)) - 0))) - 0))) - 68043554)) - 0) - -(deftest misc.514 - (let #+abcl ((jvm::*catch-errors* nil)) - nil - (funcall - (compile nil '(lambda (a) - (declare (type (integer -6844832476 188341751) a)) - (declare (optimize (speed 3) (debug 1) (safety 0) (space 3) - (compilation-speed 1))) - (the integer (multiple-value-setq (a) -96073358)))) - -3792864899)) - -96073358) - -;;; gcl 27 Dec 2004 -;;; Issue with dynamic extent - -(deftest misc.515 - (funcall - (compile nil '(lambda (a) - (declare (type (integer -1337016312 832159784) a)) - (declare (optimize speed (safety 1))) - (let* ((y 0) - (v9 0)) - (declare (dynamic-extent v9)) - (setq v9 (+ a a)) - (setq y (1+ v9))))) - -1209913207) - -2419826413) - -(deftest misc.516 - (funcall - (compile nil '(lambda () - (declare (optimize (space 0) (debug 0) (safety 2) - (compilation-speed 3) (speed 1))) - (let ((*s2* (* -507991378 14))) - (declare (dynamic-extent *s2*)) - (declare (special *s2*)) - (1+ *s2*))))) - -7111879291) - -;;; gcl 29 Dec 2004 -;;; Interference of special variable bindings? - -(deftest misc.517 - (funcall - (compile nil '(lambda () - (declare (optimize (safety 3) (space 3) (debug 1) (speed 1) - (compilation-speed 0))) - (let* ((*s8* (let ((*s8* (make-array nil :initial-element 0))) - (declare (special *s8*)) - (progn (shiftf (aref *s8*) 31508066) 0)) - )) - (declare (special *s8*)) - 0)))) - 0) - -;;; Incorrect return value - -(deftest misc.518 - (funcall - (compile nil '(lambda () - (declare (optimize (compilation-speed 0) (safety 1) - (debug 1) (space 0) (speed 3))) - (flet ((%f10 (&optional (f10-1 0) (f10-2 0) &key) - (progn - (tagbody - (decf f10-2) - (return-from %f10 - (complex (unwind-protect (go tag7)) - 0)) - tag7) - f10-2))) - (if (evenp (%f10 0 0)) 0 2140390))))) - 2140390) - -;;; Error in APPLY [or a callee]: fixnum or bignum expected -;;; Broken at COMPILER::CMP-ANON. - -(deftest misc.519 - (funcall - (compile - nil - '(lambda () - (declare (optimize (compilation-speed 0) (speed 1) (debug 1) - (space 1) (safety 3))) - (let ((*s3* - (* (the integer - (expt (rationalize - (multiple-value-bind (*s3*) - (make-array nil :initial-element 0) - (shiftf (aref *s3*) 0))) - 2))))) - 1)))) - 1) - -;;; sbcl 0.8.18 (sparc solaris) -;;; identity ASH not transformed away - -(deftest misc.520 - (funcall - (compile - nil - '(lambda (a c e) - (declare (type (integer -44330 64753) c)) - (declare (type (integer -301534047 4291509) e)) - (declare (optimize (safety 3) (debug 2) (speed 3) - (space 2) (compilation-speed 2))) - (if (oddp - (ash (logorc2 c e) - (min 2 (mask-field (byte 0 0) (mod 0 (max 69 0)))))) - a - 0))) - 1 -8156 -229264929) - 0) - -;;; ecl (25 Jan 2005) -;;; Error: In a call to AREF, the type of the form *S6* is FIXNUM, not (ARRAY *). - -(deftest misc.521 - (funcall - (compile - nil - '(lambda (b) - (declare (optimize (speed 0) (safety 1) (debug 1) (compilation-speed 3) - (space 0))) - (if b - (let ((*s6* 0)) - 0) - (let* ((*s6* (make-array nil :initial-element 0))) - (aref *s6*))))) - nil) - 0) - -;;; nil is not of type number. - -(deftest misc.522 - (funcall - (compile - nil - '(lambda (a) - (declare (type (integer -25 38) a)) - (declare (optimize (compilation-speed 3) (safety 3) (debug 1) (space 2) (speed 1))) - (flet ((%f2 (f2-1 f2-2 - &optional - (f2-3 (labels ((%f6 (&optional (f6-1 0) (f6-2 0)) (max a))) - (%f6 0))) - (f2-4 0) (f2-5 0)) - (flet ((%f4 (f4-1 f4-2 f4-3) - (flet ((%f15 () f2-3)) a))) - 0))) - (reduce #'(lambda (lmv1 lmv6) a) - (vector 0 0 0 (%f2 a a) 0 a 0 a 0) - :start 4 :from-end t)))) - 35) - 35) - -;;; Incorrect return value - -(deftest misc.523 - (funcall - (compile - nil - '(lambda (a) - (declare (type (integer -1011 978) a)) - (declare (optimize (compilation-speed 1) (safety 3) (debug 0) (speed 2) (space 1))) - (let ((*s5* - (cons 0 - (catch 'ct8 - (ash - (flet ((%f15 (f15-1) - (return-from %f15 a))) - 0) - (min 57 - (lognor (throw 'ct8 (shiftf a 332)) - (let ((v1 (setf a 371))) - a)))))))) - a))) - 99) - 332) - -;;; Seg fault - -(deftest misc.524 - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer -2432551 871) a)) - (declare (type (integer -6390 -1) b)) - (declare (ignorable b)) - (declare (optimize (compilation-speed 0) (safety 0) (space 2) (speed 0) (debug 3))) - (flet ((%f18 (f18-1 f18-2 f18-3 &optional &key (key1 0) &allow-other-keys) - (labels ((%f12 - (f12-1 - &optional (f12-2 0) - &key (key1 (catch 'ct7 (conjugate key1))) (key2 0) - &allow-other-keys) - 0)) - (%f12 a)))) - (%f18 a 0 0)))) - -925293 -1603) - 0) - -;;; Internal error: tried to advance stack. - -(deftest misc.525 - (funcall - (compile - nil - '(lambda (a) - (declare (type (integer -17179869184 -2147483648) a)) - (declare (ignorable a)) - (declare - (optimize (space 2) (debug 3) (speed 3) (compilation-speed 3) (safety 1))) - (catch 'ct4 - (max (conjugate (unwind-protect 0 (catch 'ct4 (values 0)))) - (throw 'ct4 0))))) - -17179869184) - 0) - -;;; integer does not specify a sequence type - -(deftest misc.526 - (funcall - (compile - nil - '(lambda (a) - (declare (type (integer -4 3025867) a)) - (declare (ignorable a)) - (declare - (optimize (space 1) (safety 0) (debug 0) (speed 3) (compilation-speed 0))) - (flet ((%f14 (f14-1 f14-2 f14-3 &key) - (let ((v4 - (return-from %f14 - (flet ((%f11 - (&optional (f11-1 0) (f11-2 0) - (f11-3 - (coerce - (reduce (function (lambda (lmv2 lmv5) a)) - (vector f14-1 f14-1 0 f14-3 a f14-3 a f14-1 - 0 f14-2)) - (quote integer))) - &key (key1 f14-3) (key2 a)) - (flet ((%f8 - (f8-1 - &optional - (f8-2 - (flet ((%f16 - (f16-1 f16-2 f16-3 - &optional - &key (key1 0) - (key2 f11-3)) - key1)) - 0)) - &key (key1 0)) - f14-3)) - 0))) - (if (%f11 f14-1 (%f11 0 f14-3) f14-1) 0 0))))) - 0))) - (%f14 0 a a)))) - 857304) - 0) - -;;; sbcl 0.8.19.32 -;;; Type propagation problem with BIT-AND - -(deftest misc.527 - (let ((v1 (make-array 1 :element-type 'bit - :initial-contents '(1) - :fill-pointer 0)) - (v2 (make-array 1 :element-type 'bit - :initial-contents '(1) - :fill-pointer 1)) - (r (make-array nil))) - (funcall - (compile - nil - `(lambda (r p2) - (declare (optimize speed (safety 1)) - (type (simple-array t nil) r) - (type (array *) p2)) - (setf (aref r) (bit-and ,v1 (the (bit-vector *) p2))) - (values))) - r v2) - (let ((result (aref r))) - (values - (notnot (simple-bit-vector-p result)) - (=t (array-dimension result 0) 1) - (=t (aref result 0) 1)))) - t t t) - -;;; The value 22717067 is not of type (INTEGER 22717067 22717067) - -(deftest misc.528 - (let* ((x 296.3066f0) - (y 22717067) - (form `(lambda (r p2) - (declare (optimize speed (safety 1)) - (type (simple-array single-float nil) r) - (type (integer -9369756340 22717335) p2)) - (setf (aref r) (* ,x (the (eql 22717067) p2))) - (values))) - (r (make-array nil :element-type 'single-float)) - (expected (* x y))) - (funcall (compile nil form) r y) - (let ((actual (aref r))) - (unless (eql expected actual) - (list expected actual)))) - nil) - -;;; The value 46790178 is not of type (INTEGER 46790178 46790178). - -(deftest misc.529 - (let* ((x -2367.3296f0) - (y 46790178) - (form `(lambda (r p2) - (declare (optimize speed (safety 1)) - (type (simple-array single-float nil) r) - (type (eql 46790178) p2)) - (setf (aref r) (+ ,x (the (integer 45893897) p2))) - (values))) - (r (make-array nil :element-type 'single-float)) - (expected (+ x y))) - (funcall (compile nil form) r y) - (let ((actual (aref r))) - (unless (eql expected actual) - (list expected actual)))) - nil) - -;;; cmucl (Jan 2005 snapshot) - -;;; Segmentation fault - -(deftest misc.530 - (let* ((v (make-array - '(11) :element-type 'double-float - :initial-contents - '(56826.586316245484d0 -57680.53641925701d0 68651.27735979737d0 - 30934.627728043164d0 47252.736017400945d0 35129.46986219467d0 - -57804.412938803005d0 13000.374416975968d0 50263.681826551256d0 - 89386.08276072948d0 -89508.77479231959d0))) - (form - `(lambda (r) - (declare (optimize speed (safety 1)) - (type (simple-array t nil) r)) - (setf (aref r) - (array-has-fill-pointer-p ,v)))) - (r (make-array nil))) - (funcall (compile nil form) r) - (eqlt (aref r) (array-has-fill-pointer-p v))) - t) - -;;; gcl -;;; Problem with 0-dim char arrays -;;; Produces wrong return value (#\\320). - -(deftest misc.532 - (let ((r (make-array nil :element-type 'base-char))) - (funcall - (compile - nil - '(lambda (r c) - (declare (optimize speed (safety 1)) - (type (simple-array base-char nil) r) - (type base-char c)) - (setf (aref r) c) - (values))) - r #\Z) - (aref r)) - #\Z) - -;;; sbcl 0.8.19.32 -;;; Bound is not *, a INTEGER or a list of a INTEGER: -51494/29889 - -(deftest misc.533 - (let* ((r (make-array nil)) - (c #c(208 -51494/29889)) - (form `(lambda (r p1) - (declare (optimize speed (safety 1)) - (type (simple-array t nil) r) - (type number p1)) - (setf (aref r) (+ (the (eql ,c) p1) -319284)) - (values))) - (fn (compile nil form))) - (funcall fn r c) - (eqlt (aref r) (+ -319284 c))) - t) - -;;; sbcl 0.8.19.35 -;;; Incorrect return value from conditional - -(deftest misc.534 - (let ((r0 (make-array nil))) - (funcall - (compile - nil - '(lambda (r p1 p2 p3) - (declare (optimize speed (safety 1)) - (type (eql 4134713351/6105637898) p2) - (type (eql 2685) p3)) - (setf (aref r) - (if p1 - (the (eql 4134713351/6105637898) p2) - (the (integer * 8391301) p3))))) - r0 t 4134713351/6105637898 2685) - (aref r0)) - 4134713351/6105637898) - -#| - The value - # - :ASSERTED-TYPE # - :TYPE-TO-CHECK # {DECFF19}> - is not of type - SB-C::REF. -|# - -(deftest misc.535 - (let ((c0 #c(4196.088977268509d0 -15943.3603515625d0))) - (funcall - (compile - nil - `(lambda (p1 p2) - (declare (optimize speed (safety 1)) - (type (simple-array t nil) r) - (type (eql ,c0) p1) - (type number p2)) - (eql (the (complex double-float) p1) p2))) - c0 #c(12 612/979))) - nil) - -;;; Similar to misc.535 -(deftest misc.536 - (funcall - (compile - nil - '(lambda (p1 p2) - (declare (optimize speed (safety 1)) - (type (eql #c(11963908204 1/6)) p1) - (type (complex rational) p2)) - (eql p1 (the complex p2)))) - #c(11963908204 1/6) #c(2343315619 5252231066)) - nil) - -;;; Comparison of bit vectors in compiled code -(deftest misc.537 - (let ((p1 (make-array '(0) :element-type 'bit - :adjustable t))) - (notnot - (funcall - (compile - nil - `(lambda (p2) - (declare (optimize speed (safety 1)) - (type (simple-array t nil) r) - (type (simple-bit-vector 0) p2)) - (equal ,p1 (the (bit-vector 0) p2)))) - #*))) - t) - -;;; abcl (23 Feb 2005) -;;; The value #C(3 4) is not of type number. - -(deftest misc.538 - (notnot (typep (* 2/5 #c(3 4)) 'number)) - t) - -;;; Allegro CL (6.2 trial edition, x86) -;;; Error: `#c(0 -8)' is not of the expected type `REAL' - -(deftest misc.539 - (notnot-mv - (complexp - (funcall - (compile nil '(lambda (x) - (declare (OPTIMIZE SPEED (SAFETY 1)) - (type (eql #c(0 -8)) x)) - (sqrt x))) - #c(0 -8)))) - t) - -;;; Illegal instruction - -(deftest misc.540 - (let* ((d0 #(a b c d e f g h)) - (d1 (make-array 5 - :fill-pointer 1 - :displaced-to d0 - :displaced-index-offset 2))) - (find #c(1.0 2.0) d1)) - nil) - -;;; A crasher bug of REMOVE on non-simple nibble arrays - -(deftest misc.541 - (dotimes (i 1000) - (let* ((init '(12 11 8 8 11 10 9 1 3 9 6 12 4 3 6 4 7 10 12 6 11 12 4 15 8 10 7 0 0 - 0 12 9 6 1 0 14 2 14 6 4 2 2 11 7 13 11 3 9 0 2 3 4 2 11 8 7 9 0 0 3 - 8 3 10 8 2 8 9 4 9 0 11 4 9 8 12 8 5 2 10 10 1 14 7 8 5 5 7 8 1 13 2 - 13 12 2 5 11 1 12 12 0 2 5 15 2 14 2 3 10 1 0 7 7 11 3 7 6 1 13 8 4 2 - 7 14 9 9 7 3 8 1 15 6 11 15 0 11 9 7 15 12 10 6 4 5 6 10 4 4 4 15 5 1 - 8 9 3 12 11 8 4 10 8 3 15 12 3 4 10 8 12 8 14 2 12 12 14 14 5 14 6 10 - 13 9 6 4 14 9 6 8 4 11 1 6 0 7 7 5 4 12 15 7 4 4 10 7 3 0 11 10 11 1 - 8 9 0 12 14 6 2 15 2 5 11 8 3 4 2 9 9 7 0 7 11 13 5 7 12 8 6 12 11 15 - 3 6 11 0 1 2 7 2 13 14 15 4)) - (d0 (make-array - '(251) :element-type '(integer 0 15) - :initial-contents init - :adjustable t))) - (assert - (equalp - (remove 7 d0) - (coerce (remove 7 init) '(vector (integer 0 15))))))) - nil) - -;;; Object identity for bit vectors - -(deftest misc.542 - (funcall - (compile - nil - (let ((bv1 (copy-seq #*1)) - (bv2 (copy-seq #*1))) - `(lambda () (eq ,bv1 ,bv2))))) - nil) - -;;; Lispworks personal edition 4.3 (x86 linux) -;;; Error: In PLUSP of (#C(1123113 -260528)) arguments should be of type REAL. - -(deftest misc.543 - (funcall - (compile - nil - '(lambda (p1) - (declare (optimize speed (safety 1)) - ; (type (simple-array t nil) r) - (type (integer 2493220 2495515) p1)) - (* p1 #c(1123113 -260528)))) - 2493726) - #C(2800736089038 -649685447328)) - -;;; gcl - -(deftest misc.544 - (let ((n -1.0l0)) - (notnot-mv - (complexp - (funcall - (compile - nil - `(lambda (p1) - (declare (optimize speed (safety 1)) - (type (long-float ,n 0.0l0) p1)) - (sqrt p1))) - n)))) - t) - -;;; OpenMCL -;;; 1/2 is not of type integer - -(deftest misc.545 - (let ((x #c(-1 1/2))) - (declare (type (eql #c(-1 1/2)) x)) - x) - #c(-1 1/2)) - -;;; SBCL -;;; 0.8.19.39 -;;; The function SB-KERNEL:CHARACTER-STRING-P is undefined. - -(deftest misc.546 - (funcall - (compile - nil - '(lambda (p1) - (declare (optimize (speed 0) (safety 1) (debug 2) (space 3)) - (type (eql a) p1)) - (typep p1 (type-of "")))) - 'a) - nil) - -;;; The function SB-KERNEL:SIMPLE-CHARACTER-STRING-P is undefined. - -(deftest misc.547 - (funcall - (compile - nil - '(lambda (p1) - (declare (optimize (speed 3) (safety 3) (debug 0) (space 3)) - (type symbol p1)) - (typep (the (eql :c1) p1) (type-of "b")))) - :c1) - nil) - -;;; The value NIL is not of type SB-KERNEL:CTYPE. - -(deftest misc.548 - (notnot - (funcall - (compile - nil - '(lambda (p1) - (declare (optimize (speed 2) (safety 1) (debug 3) (space 2))) - (atom (the (member f assoc-if write-line t w) p1)))) - t)) - t) - -;;; IR2 type checking of unused values in [sic] not implemented. - -(deftest misc.549 - (funcall - (compile - nil - '(lambda (p2) - (declare (optimize (speed 1) (safety 1) (debug 0) (space 3)) - (type symbol p2)) - (and :a (the (eql t) p2)))) - t) - t) - -(deftest misc.550 - (funcall - (compile - nil - '(lambda (p1 p2) - (declare (optimize (speed 3) (safety 2) (debug 3) (space 3)) - (type atom p1) - (type symbol p2)) - (or p1 (the (eql t) p2)))) - nil t) - t) - -(deftest misc.551 - (funcall - (compile - nil - '(lambda (p1 p2) - (declare (optimize (speed 1) (safety 1) (debug 3) (space 3)) - (type symbol p1) - (type (integer * 55687) p2)) - (funcall (the (eql +) p1) (the (integer -93015310 16215) p2) 2952))) - '+ 823) - 3775) - -(deftest misc.551a - (funcall - (compile nil '(lambda (x) (declare (optimize (speed 2)) - (type symbol x)) - (the (eql t) x))) - t) - t) - -;;; cmucl (mar 2005 snapshot) - -(deftest misc.552 - (funcall - (compile - nil - '(lambda (p1) - (declare (optimize (speed 3) (safety 1) (debug 2) (space 2)) - (type unsigned-byte p1)) - (logbitp (the (integer -780969457 *) p1) 9))) - 26) - nil) - -;;; ecls -;;; REAL is not of type REAL. - -(deftest misc.553 - (funcall (compile nil '(lambda (x) (declare (type (eql #c(1.0 2.0)) x)) x)) - #c(1.0 2.0)) - #c(1.0 2.0)) - -;;; 1 is not of type SEQUENCE -(deftest misc.554 - (funcall (compile nil '(lambda (x) (declare (type (array t 1) x)) x)) #(a)) - #(a)) - -;;; sbcl 5 Mar 2005 -;;; failed AVER: "(EQ CHECK SIMPLE)" - -(deftest misc.555 - (notnot - (funcall - (compile nil '(lambda (p1) - (declare (optimize (speed 1) (safety 2) (debug 2) (space 0)) - (type keyword p1)) - (keywordp p1))) - :c)) - t) - -; Problem with FLOOR -; Wrong return value -(deftest misc.556 - (values - (funcall - (compile nil '(lambda (p1 p2) - (declare - (optimize (speed 1) (safety 0) - (debug 0) (space 0)) - (type (member 8174.8604) p1) - (type (member -95195347) p2)) - (floor p1 p2))) - 8174.8604 -95195347)) - -1) - -; invalid number of arguments: 1 -; (possible removal of code due to type fumble) -(deftest misc.557 - (values - (funcall - (compile - nil - '(lambda (p1) - (declare (optimize (speed 3) (safety 0) (debug 3) (space 1)) - (type (member -94430.086f0) p1)) - (floor (the single-float p1) 19311235))) - -94430.086f0)) - -1) - -; FFLOOR -; Wrong return value -(deftest misc.558 - (values - (funcall - (compile - nil - '(lambda (p1) - (declare (optimize (speed 1) (safety 2) - (debug 2) (space 3)) - (type (eql -39466.56f0) p1)) - (ffloor p1 305598613))) - -39466.56f0)) - -1.0f0) - -; CEILING -; invalid number of arguments: 1 -(deftest misc.559 - (values - (funcall - (compile - nil - '(lambda (p1) - (declare (optimize (speed 1) (safety 1) (debug 1) (space 2)) - (type (eql -83232.09f0) p1)) - (ceiling p1 -83381228))) - -83232.09f0)) - 1) - -; wrong return value -(deftest misc.560 - (values - (funcall - (compile - nil - '(lambda (p1) - (declare (optimize (speed 1) (safety 1) - (debug 1) (space 0)) - (type (member -66414.414f0) p1)) - (ceiling p1 -63019173f0))) - -66414.414f0)) - 1) - -; FCEILING -; wrong return value -(deftest misc.561 - (values - (funcall - (compile - nil - '(lambda (p1) - (declare (optimize (speed 0) (safety 1) - (debug 0) (space 1)) - (type (eql 20851.398f0) p1)) - (fceiling p1 80839863))) - 20851.398f0)) - 1.0f0) - -;;; LOG -;;; The value #C(-215549 39/40) is not of type (COMPLEX RATIONAL). - -(deftest misc.562 - (let ((fn '(lambda (p1) - (declare (optimize (speed 0) (safety 0) (debug 0) (space 2)) - (type (complex rational) p1)) - (log p1)))) - (notnot (complexp (funcall (compile nil fn) #C(-215549 39/40))))) - t) - -;;; CONJUGATE -;;; Wrong result (#c(1 2)) - -(deftest misc.563 - (funcall (compile nil '(lambda (x) - (declare (optimize (speed 1) (safety 0) (debug 3) (space 1)) - (type (complex rational) x)) - (conjugate (the (eql #c(1 2)) x)))) - #c(1 2)) - #c(1 -2)) - -;;; PHASE -;;; The function SB-KERNEL:%ATAN2 is undefined. - -(deftest misc.564 - (notnot - (typep - (funcall - (compile - nil - '(lambda (p1) - (declare (optimize (speed 3) (safety 2) (debug 3) (space 0)) - (type complex p1)) - (phase (the (eql #c(1.0d0 2.0d0)) p1)))) - #c(1.0d0 2.0d0)) - 'double-float)) - t) - -;;; ACL 6.2 (trial, x86 linux) -;;; Incorrect return value (t instead of nil) - -(deftest misc.565 - (funcall - (compile - nil - '(lambda (x) - (declare (optimize (speed 2) (safety 1) (debug 3) (space 0)) - (type double-float x)) - (not (the (eql 1.0d0) x)))) - 1.0d0) - nil) - -;;; ASH -;;; Incorrect value (59 == (ash p1 -3)) - -(deftest misc.566 - (funcall - (compile - nil - '(lambda (p1) - (declare (optimize (speed 3) (safety 2) (debug 2) (space 0)) - (type (integer 465 127871) p1)) - (ash p1 -35))) - 477) - 0) - -;;; sbcl -;;; The value -4 is not of type (INTEGER -26794287907 505600792). - -(deftest misc.567 - (eqlt - (funcall - (compile - nil - '(lambda (p2) - (declare (optimize (speed 3) (safety 1) (debug 0) (space 1)) - (type (integer -26794287907 505600792) p2)) - (scale-float -15193.341216130497d0 (the (integer * 25) p2)))) - -4) - (scale-float -15193.341216130497d0 -4)) - t) - -;;; ACL 7.0 (x86 linux) -;;; Found by random type prop tests - -;;; Error: Attempt to divide 13026.059 by zero. -(deftest misc.568 - (values - (funcall - (compile nil '(lambda (p2) - (declare (optimize (speed 1) (safety 3) (debug 3) (space 1)) - (type (rational * 5325/3112) p2)) - (floor 13026.059 (the (member 5325/3112 0 -2316/167 -449/460) p2)))) - 5325/3112)) - 7612) - -;;; Error: Attempt to take the car of #2\%b which is not listp. -(deftest misc.569 - (funcall - (compile - nil - '(lambda (p2) - (declare (optimize (speed 3) (safety 2) (debug 1) (space 2)) - (type t p2)) - (ash -2609443 (the (integer -3 0) p2)))) - -1) - -1304722) - -;;; Incorrect return value -(deftest misc.570 - (funcall (compile nil '(lambda () - (declare (optimize (speed 3) (safety 1))) - (char-equal #\: #\: #\;)))) - nil) - -;;; CODE-CHAR returns incorrect result -;;; (ACL7.0, 8 bit character image) - -(deftest misc.571 - (and (< 1000 char-code-limit) - (let ((c1 (code-char 1000)) - (c2 - (funcall (compile nil '(lambda (x) - (declare (optimize speed (safety 1))) - (code-char x))) - 1000))) - (if (not (eql c1 c2)) - (list c1 c2) - nil))) - nil) - -;;; sbcl 0.8.20.19 -;;; The value 22 is not of type (MOD 22). - -(deftest misc.572 - (funcall - (compile - nil - '(lambda (p4) - (declare (optimize (speed 1) (safety 2) (debug 1) (space 1)) - (type (integer -59 65558) p4)) - (string<= #.(coerce "1yapt1l7eeenz72u6xqhdfimcyk" 'base-string) - #.(coerce "bababababbbabbabbababb" 'base-string) - :start2 - (the (integer -3735 *) p4)))) - 22) - nil) - -;;; The value 0 is not of type NIL. - -(deftest misc.573 - (funcall - (compile - nil - '(lambda (p4) - (declare (optimize (speed 2) (safety 1) (debug 2) (space 2)) - (type unsigned-byte p4)) - (string<= (coerce "pdhd5oeynvqlthz3xrrdycotf" 'base-string) - (coerce "" 'base-string) - :start1 (the (integer * 81) p4)))) - 10) - nil) - -;;; incorrect return value - -(deftest misc.574 - (funcall - (compile - nil - '(lambda (p4) - (declare (optimize (speed 3) (safety 1) - (debug 1) (space 2)) - (type (integer * 397079023) p4)) - (string<= (coerce "e99mo7yAJ6oU4" 'base-string) - (coerce "aaABAAbaa" 'base-string) - :start1 - (the - (member -34 - 131074 - 67108872 - 9 - -3305367300 - 335) - p4)))) - 9) - 9) - -;;; In abcl (14 Mar 2005) -;;; The value T is not of type number. - -(deftest misc.575 - (equalp #c(1269346.0 47870.12254712875) t) - nil) - -;;; The value #C(435422075/240892576 373) is not of type NUMBER. - -(deftest misc.576 - (* -7023900320 #C(435422075/240892576 373)) - #C(-95573789122736375/7527893 -2619914819360)) - -;;; The value #C(-555014/122849 -6641556271) is not of type NUMBER. - -(deftest misc.577 - (/ -3185994774 #C(-555014/122849 -6641556271)) - #C(217230410502882805764/665706755984253572883257634437 - -319343563321640207257301634954/665706755984253572883257634437)) - -;;; The value "" is not of type (STRING 1). - -(deftest misc.578 - (funcall (compile nil '(lambda (p1) (declare (optimize safety)) (the (string 1) p1))) - (make-array '(1) :element-type 'base-char :initial-element #\x - :fill-pointer 0)) - "") - -;;; clisp (11 Jan 2005) - -;;; *** - SYSTEM::%RPLACA: NIL is not a pair - -(deftest misc.579 - (funcall - (compile nil '(lambda () - (declare (optimize (speed 3) (safety 3) (debug 3) (space 0))) - (member 61 '(432445) :allow-other-keys t :foo t)))) - nil) - -;;; sbcl 0.8.20.19 -;;; The component type for COMPLEX is not numeric: (OR RATIO FIXNUM) - -(deftest misc.580 - (notnot-mv (typep #c(1 2) '(complex (or ratio fixnum)))) - t) - -;;; The value -5067.2056 is not of type (SINGLE-FLOAT -5067.2056 -5067.2056). - -(deftest misc.581 - (notnot - (floatp - (funcall - (compile nil '(lambda (x) - (declare (type (eql -5067.2056) x)) - (+ 213734822 x))) - -5067.2056))) - t) - -(deftest misc.581a - (notnot - (typep - (funcall - (compile nil '(lambda (x) (declare (type (eql -1.0) x)) - ;;; Note! #x1000001 is the least positive integer - ;;; for which this fails on x86 - (+ #x1000001 x))) - -1.0f0) - 'single-float)) - t) - -;;; Incorrect result - -(deftest misc.582 - (let ((result - (funcall - (compile - nil - ' (lambda (p1) - (declare (optimize (speed 0) (safety 1) (debug 1) (space 1)) - (type (eql -39887.645) p1)) - (mod p1 382352925))) - -39887.645))) - (if (plusp result) - t - result)) - t) - -;;; Argument X is not a REAL: # - -(deftest misc.583 - (notnot-mv - (complexp - (funcall - (compile - nil - '(lambda (p1) - (declare (optimize (speed 0) (safety 0) (debug 2) (space 3)) - (type (complex rational) p1)) - (sqrt p1))) - #c(-9003 -121)))) - t) - -;;; The value -27 is not of type (INTEGER -34359738403 -24). - -(deftest misc.584 - (approx= - (funcall - (compile - nil - '(lambda (p1 p2) - (declare (optimize (speed 1) (safety 1) (debug 0) (space 1)) - (type (member -3712.8447) p1) - (type (integer -34359738403 -24) p2)) - (scale-float p1 p2))) - -3712.8447 -27) - (scale-float -3712.8447 -27)) - t) - -;;; IR2 type checking of unused values in not implemented. -;;; (note that this test has no THE form) - -(deftest misc.585 - (funcall - (compile nil '(lambda (p1) - (declare (optimize (speed 0) (safety 0) (debug 3) (space 3)) - (type symbol p1)) - (copy-list p1))) - nil) - nil) - -;;; The value 4 is not of type (UNSIGNED-BYTE 2). - -(deftest misc.586 - (funcall - (compile - nil - '(lambda (p6) - (declare (optimize (speed 0) (safety 2) (debug 0) (space 0)) - (type (integer -2 3009181) p6)) - (string> (coerce "ababaaabb" 'base-string) - (coerce "ubbm" 'base-string) - :start1 2 :start2 p6 :end1 8))) - 4) - 2) - -;;; sbcl 0.8.20.27 -;;; Control stack exhausted - -(deftest misc.587 - (let ((result (funcall - (compile - nil - '(lambda (p2) - (declare (optimize (speed 0) (safety 3) (debug 1) (space 0)) - (type (eql 33558541) p2)) - (- 92215.266 p2))) - 33558541))) - (notnot (typep result 'single-float))) - t) - -;;; Lispworks 4.3 Personal Edition -;;; Incorrect return value (T instead of NIL) - -(deftest misc.588 - (funcall (compile nil '(lambda nil (declare (optimize (speed 2) (safety 1) (debug 1) (space 1))) - (functionp 3502843)))) - nil) - -;;; (ARRAY NIL) is an illegal type specifier. - -(deftest misc.589 - (typep 1 '(array nil)) - nil) - -;;; Segmentation violation - -(deftest misc.590 - (funcall (compile nil '(lambda nil (declare (optimize debug)) (symbolp -86755)))) - nil) - -;;; parse-integer fails on displaced base strings - -(deftest misc.591 - (let* ((s1 (coerce "708553218828630100500" 'base-string)) - (s2 (make-array '(13) :element-type 'base-char - :displaced-to s1 - :displaced-index-offset 5))) - (parse-integer s2)) - 3218828630100 - 13) - -;;; abcl, 19 Mar 2005 -;;; Stack overflow - -(deftest misc.592 - (equalp #*0 "0") - nil) - -;;; clisp 21 Mar 2005 (-ansi -q, x86 Linux, gcc 3.2.2) -;;; *** - Compiler bug!! Occurred in SP-DEPTH at <0. - -(deftest misc.593 - (funcall - (compile - nil - '(lambda (a b) - (declare (ignorable a b)) - (declare (optimize (space 3) (debug 0) (safety 1) - (compilation-speed 3) (speed 1))) - (prog2 - (catch 'ct1 (if (or (and t (not (and (and (or a t) nil) nil))) nil) - a - (reduce #'(lambda (lmv5 lmv2) 0) (vector b 0 a)))) - 0))) - 2212755 3154856) - 0) - -;;; OpenMCL 0.14.3 -;;; 28192897: value doesn't match constraint :U8CONST in template for CCL::MATCH-VREG - -(deftest misc.594 - (funcall - (compile - nil - '(lambda (a b c) - (declare (ignorable a b c)) - (declare (type (integer -1 0) a) - (type (integer -1065019672 -181184465) b) - (type (integer 30074 1948824693) c)) - (declare (optimize (safety 2) (compilation-speed 1) (speed 2) - (space 0) (debug 0))) - (ash c (min 82 -28192897)))) - 0 -714979492 1474663829) - 0) - -;;; ecl -;;; 10000000.0d0 is not of type INTEGER. - -(deftest misc.595 - (floor 1/2 1.0d0) - 0 #.(float 1/2 1.0d0)) - -;;; sbcl 0.8.21.45 (x86) -;;; The function SB-KERNEL:VECTOR-NIL-P is undefined. - -(deftest misc.596 - (notnot - (let ((s (coerce "a" 'base-string))) - (funcall - (compile - nil - `(lambda () - (declare (optimize (speed 0) (safety 3) (debug 2) (space 1))) - (typep ,s '(string 1))))))) - t) - - -;;; OpenMCL -;;; Incorrect value - -(deftest misc.597 - (funcall (compile nil '(lambda (c) - (declare (optimize (speed 1) (compilation-speed 2) - (space 1) (debug 1) (safety 2))) - (declare (type (integer 1 41) c)) - (logxor -1 c))) - 8) - -9) - -;;; SBCL 0.9.1.19 -;;; Failure of IMAGPART in compiled code - -(deftest misc.598 - (funcall (compile nil '(lambda (p1) - (declare (optimize (speed 2) (safety 0) (debug 3) - (space 1)) - (type short-float p1)) - (imagpart (the short-float p1)))) - -79916.61s0) - -0.0s0) - -;;; The value 20408096470 is not of type (INTEGER 19856842407 20640917103) - -(deftest misc.599 - (funcall - (compile - nil - '(lambda (b) - (declare (type (integer 19856842407 20640917103) b)) - (declare (optimize (debug 1) (speed 3) (compilation-speed 2) - (safety 3) (space 3))) - (lognand b (deposit-field b (byte 0 0) 3762528061)))) - 20408096470) - -3225589269) - -;;; SBCL 0.9.1.21 -;;; The function SB-C::SPECIFER-TYPE is undefined. - -(deftest misc.600 - (funcall - (compile - nil - '(lambda () - (declare (notinline min ash)) - (declare (optimize (speed 0) (debug 1) (safety 1) - (space 1) (compilation-speed 3))) - (logxor (ash 0 (min 90 0)) 0)))) - 0) - -(deftest misc.601 - (funcall - (compile - nil - '(lambda () - (declare (notinline gcd)) - (declare - (optimize (debug 3) (space 3) (safety 3) - (compilation-speed 2) (speed 3))) - (logeqv 0 (gcd 0))))) - -1) - -;;; Lispworks 4450 -;;; Show sporadic bugs in compiled code - -(deftest misc.602 - (let ((form '(lambda () (if (oddp (progn (vector) 3747237)) 'a nil)))) - (loop repeat 10 collect (funcall (compile nil form)))) - (a a a a a a a a a a)) - -;;; gcl 2.7.0 (12 Jul 2005) -;;; Error in WHEN [or a callee]: The GO tag #:G3614 is missing. - -(deftest misc.603 - (funcall (compile nil '(lambda () (let ((x (values 0))) 0)))) - 0) - -;;; gcl 2.7.0 (23 Jul 2005, experimental cvs HEAD) -;;; Error in COMPILER::T1EXPR [or a callee]: -;;; LOAD-TIME-VALUE is not of type (OR RATIONAL FLOAT). - -(deftest misc.604 - (let ((form '(lambda (p1 p2) - (declare (optimize (speed 2) (safety 1) (debug 3) (space 3)) - (type real p1) (type t p2)) - (eql (the (rational -55253767/37931089) p1) (the atom p2))))) - (funcall (compile nil form) -55253767/37931089 'a)) - nil) - -;;; Error in FUNCALL [or a callee]: LOAD-TIME-VALUE is not of type NUMBER. - -(deftest misc.605 - (let ((form '(lambda (p1 p2) - (declare (optimize (speed 3) (safety 1) (debug 0) (space 0)) - (type number p1) (type (float 0.0 3579.314s0) p2)) - (eql (the real p1) p2)))) - (not (funcall (compile nil form) 3579.314s0 3579.314s0))) - nil) - -;;; Error in COMPILER::CMP-ANON [or a callee]: #\a is not of type FIXNUM. - -(deftest misc.606 - (let ((form '(lambda () - (declare (optimize (speed 3) (safety 2) (debug 3) (space 2))) - (equal #\a #c(-1775806.0s0 88367.29s0))))) - (funcall (compile nil form))) - nil) - -;;; Error in COMPILER::CMP-ANON [or a callee]: #*1 is not of type FIXNUM. - -(deftest misc.607 - (funcall (compile nil '(lambda () - (declare (optimize (speed 0) (safety 2) (debug 2) (space 2))) - (equal #*1 1)))) - nil) - -;;; Error in COMPILER::CMP-ANON [or a callee]: #\& is not of type FIXNUM. - -(deftest misc.608 - (funcall (compile nil '(lambda (p1) - (declare (optimize (speed 3) (safety 2) (debug 3) (space 3)) - (type (integer -62603278 -31187) p1)) - (equal p1 #\&))) - -31228) - nil) - -;;; Wrong return value (was returning T) - -(deftest misc.609 - (funcall (compile nil '(lambda () - (declare (optimize (speed 0) (safety 0) (debug 0) (space 3))) - (equalp "b" #*)))) - nil) - -;;; Error in COMPILER::CMP-ANON [or a callee]: 7933992 is not of type SYMBOL. - -(deftest misc.610 - (not (funcall (compile nil '(lambda (p2) - (declare (optimize (speed 1) (safety 1) (debug 3) (space 2)) - (type (cons symbol) p2)) - (typep -32 p2))) - '(eql -32))) - nil) - -;;; Error in CAR [or a callee]: -757161859 is not of type LIST. - -(deftest misc.611 - (funcall (compile nil '(lambda (p1) - (declare (optimize (speed 1) (safety 3) (debug 0) (space 2)) - (type (cons atom) p1)) - (car p1))) - '(48144509 . a)) - 48144509) - -;;; gcl (09 Aug 2005) -;;; Error in COMPILER::POSSIBLE-EQ-LIST-SEARCH [or a callee]: COMPILER::POSSIBLE-EQ-LIST-SEARCH does not allow the keyword :B. - -(deftest misc.612 - (funcall - (compile nil '(lambda (p1 p2) - ((lambda (x y) (typep x (type-of y))) p1 - (the (member "foo" #\- :b "bar") p2)))) - #*1 :b) - nil) - -;;; Error in APPLY [or a callee]: The tag CT1 is undefined. - -(deftest misc.613 - (funcall - (compile - nil - '(lambda (a) - (declare (optimize (space 3) (safety 1) (debug 3) - (speed 1) (compilation-speed 3))) - (catch 'ct1 - (reduce #'(lambda (lmv6 lmv5) (throw 'ct1 0)) - (list a 0 0) :end 2)))) - 1) - 0) - -;;; Error in MULTIPLE-VALUE-BIND [or a callee]: Cannot get relocated section contents - -(deftest misc.614 - (funcall - (compile - nil - '(lambda (a) - (declare (type (integer -3873004182 -3717314779) a)) - (declare (ignorable a)) - (declare (optimize (debug 0) (safety 1) (speed 3) - (space 0) (compilation-speed 0))) - (let* ((v1 (make-array nil :initial-element - (reduce #'logand (list a 0 a))))) - (declare (dynamic-extent v1)) - 0))) - -3755148485) - 0) - -;;; gcl type-prop test failures (10/30/2005) - -(deftest misc.615 - (let* ((x -8183.7625s0) - (form `(lambda (p1) (eql p1 ,x)))) - (not (not (funcall (compile nil form) x)))) - t) - -;;; cmucl 19c -;;; Wrong return value - -(deftest misc.616 - (funcall - (compile - nil - '(lambda (a b c) - (declare (type (integer -153105 -36629) a)) - (declare (type (integer -7811721705 3704985368) b)) - (declare (type (integer 0 15) c)) - (declare (ignorable a b c)) - (declare (optimize (safety 1) (space 0) (compilation-speed 0) (speed 3) - (debug 3))) - (catch 'ct7 - (labels ((%f12 - (f12-1 f12-2 - &optional - &key (key1 0) - (key2 - (reduce #'(lambda (lmv2 lmv1) 0) - (vector 0 0) - :end 2 - :start 0 - :from-end t)) - &allow-other-keys) - a)) - c)))) - -134217 -3699719058 10) - 10) - -;;; sbcl 0.9.7.33 (x86) -;;; The value 16561216769 is not of type (INTEGER -2147483648 4294967295). -;;; On sparc solaris, the error message is: -;;; debugger invoked on a SB-KERNEL:CASE-FAILURE: -;;; 16561216769 fell through ETYPECASE expression. -;;; Wanted one of (SB-C:FIXUP (OR (SIGNED-BYTE 32) (UNSIGNED-BYTE 32)) -;;; (SIGNED-BYTE 13)). - -(deftest misc.617 - (funcall - (compile - nil - '(lambda (b) - (declare (optimize (space 3) (safety 2) (debug 1) (speed 3) - (compilation-speed 2))) - (let* ((v2 16561216769)) - (lognand (loop for lv3 below 0 sum (setf v2 lv3)) - (if (typep v2 '(integer -39 7)) - b - 0))))) - -10298) - -1) - -;;; failed AVER: "(EQ POP (CAR END-STACK))" -;;; (same on sparc solaris) - -(deftest misc.618 - (funcall - (compile - nil - '(lambda (c) - (declare (optimize (space 0) (compilation-speed 2) (debug 0) - (speed 3) (safety 0))) - (block b1 - (ignore-errors - (multiple-value-prog1 0 - (apply (constantly 0) - c - (catch 'ct2 (return-from b1 0)) - nil)))))) - -4951) - 0) - -;;; sbcl 0.9.7.33 (sparc solaris) -;;; Incorrect return value - -(deftest misc.619 - (funcall - (compile - nil - '(lambda (b) - (declare (type (integer 75 206) b)) - (declare (optimize (speed 0) (compilation-speed 2) (debug 2) - (space 2) (safety 2))) - (mask-field (byte 4 28) (ash b 70)))) - 79) - 0) - -;;; The value 64 is not of type (OR SB-C:TN (UNSIGNED-BYTE 6) NULL). - -(deftest misc.620 - (funcall (compile nil '(lambda () - (declare (optimize (safety 3) (compilation-speed 3) - (debug 1) (space 3) (speed 1))) - (loop for lv2 below 1 sum (ash lv2 64))))) - 0) - -;;; sbcl 0.9.8.17, x86 linux -;;; The value 32 is not of type (OR (INTEGER -67 -67) (INTEGER -63 -63)). - -(deftest misc.621 - (funcall - (compile - nil - '(lambda () - (declare (optimize (debug 1) (space 0) (compilation-speed 3) - (speed 1) (safety 3))) - (loop for lv1 below 2 sum - (dotimes (iv2 2 0) - (mod (dotimes (iv4 2 0) (progn (count lv1 #*0) 0)) - (min -63 (rem 0 (min -67 0))))))))) - - 0) - -;;; sbcl 0.9.9.8, x86 linux -;;; TYPE-ERROR: The value 17549.955 is not of type REAL. - -(deftest misc.622 - (funcall - (compile - nil - '(lambda (p2) - (declare (optimize (speed 3) (safety 2) (debug 3) (space 0)) - (type real p2)) - (+ 81535869 (the (member 17549.955 #:g35917) p2)))) - 17549.955) - #.(+ 81535869 17549.955)) - -;;; sbcl 0.9.9.19 -;;; The function SB-VM::%LOGBITP is undefined. - -(deftest misc.623 - (funcall - (compile - nil - '(lambda () - (declare (optimize (space 2) (speed 0) (debug 2) - (compilation-speed 3) (safety 0))) - (loop for lv3 below 1 - count (minusp - (loop for lv2 below 2 - count (logbitp 0 - (bit #*1001101001001 - (min 12 (max 0 lv3)))))))))) - 0) - -;;; failed AVER: "(< Y 29)" - -(deftest misc.624 - (funcall - (compile - nil - '(lambda (a) - (declare (type (integer 21 28) a)) - (declare (optimize (compilation-speed 1) (safety 2) - (speed 0) (debug 0) (space 1))) - (let* ((v7 (flet ((%f3 (f3-1 f3-2) - (loop for lv2 below 1 - count - (logbitp 29 - (sbit #*10101111 - (min 7 (max 0 (eval '0)))))))) - (%f3 0 a)))) - 0))) - 22) - 0) - -;;; sbcl 0.9.9.22 (x86 linux) - -;;; The following two errors appear to require the presence -;;; of two ELT forms. Somehow, the type check for one is -;;; misplaced into the other. - -;;; TYPE-ERROR: The value 0 is not of type (INTEGER 3 3). - -(deftest misc.625 - (funcall - (compile - nil - '(lambda (a) - (declare (type (integer -2 -1) a)) - (declare (optimize (speed 0) (space 0) (safety 1) - #+sbcl (sb-c:insert-step-conditions 0) - (debug 3) (compilation-speed 1))) - (elt '(47119 39679 57498 35248 23784 40597 53473 29454) - (min 7 - (max 0 - (flet ((%f7 - (f7-1 f7-2 - &optional - &key - (key1 - (elt '(0 25 30 12 27 5) - (min 5 (max 0 3))))) - 0)) - (flet ((%f6 - (&optional - &key (key1 (progn (%f7 0 a) a)) - (key2 0)) - 0)) - (%f7 a a)))))))) - -2) - 47119) - -;;; TYPE-ERROR: The value 2 is not of type (INTEGER 12 12) - -(deftest misc.625a - (funcall - (compile - nil - '(lambda (a b) - (declare (type (integer 1 5) b)) - (declare (optimize (safety 2) (speed 2) - (space 0) (compilation-speed 3) (debug 3))) - (progn - (flet ((%f3 - (f3-1 f3-2 &optional (f3-3 b) f3-4 - (f3-5 (prog1 0 (elt '(a b c d e f g h i j k l m) 12)))) - f3-1)) - (%f3 0 (%f3 0 a 0 a) a 0 a)) - (elt '(a b c d) (min 3 b)) - ))) - 0 2) - c) - -;;; failed AVER: "(<= Y 29)" - -(deftest misc.626 - (funcall - (compile - nil - '(lambda (a) - (declare (type (integer -902970 2) a)) - (declare (optimize (space 2) (debug 0) (compilation-speed 1) - (speed 0) (safety 3))) - (prog2 (if (logbitp 30 a) 0 (block b3 0)) a))) - -829253) - -829253) - -;;; The value -93368855 is not of type UNSIGNED-BYTE. -;;; [...] -;;; (LOGBITP -93368855 0) - -(deftest misc.628 - (funcall - (compile - nil - '(lambda () - (declare (optimize (safety 3) (space 3) (compilation-speed 3) - (speed 0) (debug 1))) - (not (not (logbitp 0 (floor 2147483651 (min -23 0)))))))) - t) - -;;; sbcl 0.9.9.35 -;;; The value #S(MISC-629 :A 1 :B 3) is not of type SB-KERNEL:INSTANCE. - -(defstruct misc-629 a b) - -(deftest misc.629 - (let* ((s (make-misc-629 :a 1 :b 3)) - (form `(lambda (x) - (declare (optimize (speed 1) (safety 3) (debug 0) (space 2)) - (type (member 0 2 ,s) x)) - (misc-629-a x)))) - (funcall (compile nil form) s)) - 1) - -;;; sbcl 0.9.10.11 -;;; Failures associated with MULTIPLE-VALUE-PROG1 -;;; Argument X is not a NUMBER: NIL -;;; (SB-KERNEL:TWO-ARG-/ NIL 1) - -(deftest misc.630 - (funcall - (compile - nil - '(lambda () - (declare (optimize (speed 1) (debug 0) - (space 2) (safety 0) (compilation-speed 0))) - (unwind-protect 0 - (* (/ (multiple-value-prog1 -29457482 -5602513511) 1)))))) - 0) - -;;; Argument X is not a INTEGER: NIL -;;; (SB-KERNEL:TWO-ARG-AND NIL 1) - -(deftest misc.631 - (if (flet ((%f17 (&key (key2 (if (evenp (multiple-value-prog1 0)) 0 0))) - 0)) - 0) - :a :b) - :a) - - -;;; gcl 2.7.0 (7 Mar 2006) -;;; Wrong value -- NIL - -(deftest misc.632 - (funcall (compile nil '(lambda () (let (b) (multiple-value-setq (b) 10))))) - 10) - -;;; sbcl (x86 linux) 0.9.10.43 -;;; The value -17045.0 -;;; is not of type -;;; (OR (MEMBER #:|u4m7k0jz6o| 1+) -;;; (MEMBER #\b) -;;; (SINGLE-FLOAT -17045.0 -17045.0)). - -(deftest misc.633 - (let* ((x -17045.0) - (form `(lambda (p3 p4) - (declare (optimize (speed 1) (safety 3) (debug 0) (space 1)) - (type number p3) - (type (member -1451.1257 47889 #:|3| ,x #:|aabbaaaaaababa|) - p4)) - (min 1 - -251.2455 - (the number p3) - (the (member 1+ ,x #\b #:|u4m7k0jz6o|) p4) - -1506/1283 - 65681158/19740963)))) - (funcall (compile nil form) 1861 x)) - -17045.0) - -;;; sbcl (x86 linux) 0.9.10.48 -;;; The value 35182846 is not of type (INTEGER 35182846 35182846). - -(deftest misc.634 - (let ((form '(lambda (p2) - (declare (optimize (speed 0) (safety 3) (debug 3) (space 2)) - (type number p2)) - (- -83659.0 (the (member 35182846) p2))))) - (funcall (compile nil form) 35182846)) - #.(- -83659.0 35182846)) - -;;; sbcl (x86 linux) 0.9.11.4 -;;; Different results - -(deftest misc.635 - (let* ((form '(lambda (p2) - (declare (optimize (speed 0) (safety 1) - (debug 2) (space 2)) - (type (member -19261719) p2)) - (ceiling -46022.094 p2)))) - (values (funcall (compile nil form) -19261719))) - 1) - -;;; TYPE-ERROR: The value 26899.875 is not of type NUMBER. - -(deftest misc.636 - (let* ((x 26899.875) - (form `(lambda (p2) - (declare (optimize (speed 3) (safety 1) (debug 3) (space 1)) - (type (member ,x #:g5437 char-code #:g5438) p2)) - (* 104102267 p2)))) - (not (not (floatp (funcall (compile nil form) x))))) - t) - -;;; attempt to THROW to a tag that does not exist: SB-C::LOCALL-ALREADY-LET-CONVERTED - -(deftest misc.637 - (labels ((%f11 (f11-2 &key key1) - (labels ((%f8 (f8-2 &optional (f8-5 (if nil (return-from %f11 0) 0))) - :bad1)) - (%f8 (%f8 0))) - :bad2)) - :good) - :good) - -;;; full call to SB-KERNEL:DATA-VECTOR-REF - -(deftest misc.638 - (let* ((codes '(32779 60674 33150 60033 41146 23916 28908 58886 12776 21282 37346 25537 56184 - 40736 4845 41954 6663 44378 23466 46903 13661 36445 18784 6114 6266)) - (chars (loop for code in codes collect (or (code-char code) #\x))) - (c (elt chars 21)) - (s (make-array '(25) :element-type 'character - :initial-contents chars))) - (let ((form `(lambda (p1) - (declare (optimize (speed 2) (safety 0) (debug 3) (space 1)) - (type (simple-string 25) p1)) - (char - (the - (member ,(let ((s2 "abbbabbaaabbaba")) - (make-array (length s2) :element-type 'base-char - :initial-contents s2)) - ,s) - p1) - 21)))) - (not (not (eql c (funcall (compile nil form) s)))))) - t) - -;;; sbcl 0.9.11.24 (x86 linux) -;;; failed AVER: "(EQ PHYSENV (LAMBDA-PHYSENV (LAMBDA-VAR-HOME THING)))" - -(deftest misc.639 - (let ((form '(lambda (a b d) - (declare (notinline >= eql)) - (declare (optimize (debug 2) (speed 3) (safety 0) - (compilation-speed 3) (space 0))) - (labels ((%f8 (f8-1 &optional (f8-4 (if (if (eql 0 -16) (>= d) nil) 0 0))) - a)) - (%f8 b))))) - (funcall (compile nil form) :good 18 0)) - :good) - -;;; sbcl 0.9.11.45 (x86 linux) -;;; Incorrect value: -32377322164 - -(deftest misc.640 - (let ((form '(lambda (b g) - (declare (type (integer 303184 791836) b)) - (declare (optimize (compilation-speed 2) (debug 0) (space 1) - (speed 1) (safety 2))) - (loop for lv1 below 2 - sum (if (<= g lv1) - (labels ((%f7 () (prog1 b 0))) (%f7)) - (setf g -16188661082)))))) - (funcall (compile nil form) 335562 4655131896)) - -16188325520) - -;;; sbcl 0.9.12.27 (x86 linux) -;;; The value NIL is not of type SB-C::IR2-NLX-INFO. - -(deftest misc.641 - (let ((form '(lambda () - (declare (optimize (speed 1) (space 0) (debug 2) - (compilation-speed 0) (safety 1))) - (flet ((%f3 (f3-1 &key (key1 (count (floor 0 (min -74 0)) #()))) - 0)) - (apply #'%f3 0 nil))))) - (funcall (compile nil form))) - 0) - -;;; cmucl 19c (x86 linux) -;;; The assertion (NOT (MEMBER C::KIND '(:DELETED :OPTIONAL))) failed. - -(deftest misc.642 - (let ((form ' (lambda (a b c d e f g h i j) - (declare (type (integer 174130 60165950) a)) - (declare (type (integer -4076 6783) b)) - (declare (type (integer -178481569 -1) c)) - (declare (type (integer 236 954963169) d)) - (declare (type (integer -1334 407047) e)) - (declare (type (integer -507 -426) f)) - (declare (type (integer -1164301 148213922) g)) - (declare (type (integer -184324 14515) h)) - (declare (type (integer 258 323) i)) - (declare (type (integer -11825 109247) j)) - (declare (ignorable a b c d e f g h i j)) - #+cmu (declare (optimize (extensions:inhibit-warnings 3))) - (declare (optimize (compilation-speed 2) (debug 0) (space 1) (speed 3) - (safety 2))) - (labels ((%f4 (f4-1) - (flet ((%f2 (f2-1 f2-2 f2-3 &key) - (progn - (return-from %f4 0) - f2-2))) - (common-lisp:handler-bind nil - (/ - (coerce - (unwind-protect - (reduce - #'(lambda (lmv2 lmv4) - (reduce #'* - (vector - (let () - h) - c - (reduce - #'(lambda (lmv4 lmv3) - (return-from %f4 - (deposit-field lmv4 - (byte 23 16) - (mask-field - (byte 3 27) - (elt '(5309746) - (min 0 - (max 0 - j))))))) - (vector - (%f2 (%f2 12762 f4-1 6646240924) 1501 - -15) - 277 - (multiple-value-call #'%f2 - (values -1486981 - i - (%f2 a 16777222 j))) - 1033) - :end 4 - :start 3) - (/ 823 -1)) - :end 3 - :start 1)) - (vector - (common-lisp:handler-bind nil - (- 0 h j b -2539837 28596 d 8161548 h -61)) - -183768642 - -1 - 31404552 - 81593) - :start 3) - (dpb i (byte 14 16) e) - (dpb - (count f4-1 - #(524279 8388596 1021351 101986) - :test '/=) - (byte 4 4) - 131064) - (if (= 524287 f) - (prog2 - (denominator - (elt '(1663 120) (min 1 (max 0 -17745)))) - f - (deposit-field e (byte 31 31) 0) - (labels ((%f7 - (f7-1 f7-2 f7-3 - &optional - (f7-4 - (coerce - (coerce - (the integer (+ -11045 114)) - 'integer) - 'integer)) - (f7-5 h)) - -2286515)) - j)) - (macrolet () - (prog2 -2195 1921675 h -183085 a)))) - 'integer) - 1))))) - 0)))) - (funcall (compile nil form) 58162926 -3652 -63561386 935157597 63716 -504 108893677 -146677 308 99009)) - 0) - -;;; Wrong return value - -(deftest misc.643 - (let ((form '(lambda (a) - (declare (type (integer 6 1273) a)) - (declare (optimize (space 0) (safety 0) (debug 3) (compilation-speed 2) (speed 3))) - (logorc2 0 (restart-bind nil (shiftf a 522)))))) - (funcall (compile nil form) 807)) - -808) - -;;; -1520586839 is not of type INTEGER - -(deftest misc.644 - (let ((form '(lambda (a) - (declare (type (integer -6568333536 -12667) a)) - (declare (ignorable a)) - #+cmu (declare (optimize (extensions:inhibit-warnings 3))) - (declare (optimize (compilation-speed 1) (safety 3) (speed 1) (debug 1) - (space 3))) - (unwind-protect 0 - (the integer - (locally - (declare (special *s3* *s4*)) - (progv '(*s4* *s3*) (list a a) (expt *s3* 0)))))))) - (let ((*s3* 0)) - (declare (special *s3*)) - (funcall (compile nil form) -1520586839))) - 0) - -;;; NIL is not of type C::CBLOCK - -(deftest misc.645 - (let ((form '(lambda (a) - (declare (notinline abs isqrt)) - #+cmu (declare (optimize (extensions:inhibit-warnings 3))) - (declare (optimize (debug 3) (safety 1) (space 2) (compilation-speed 1) - (speed 0))) - (progn - (tagbody - (prog2 - a - 0 - (labels ((%f9 (&key &allow-other-keys) - (go 3))) - (%f9))) - (isqrt (abs (unwind-protect 0))) - 3) - a)))) - (eval `(,form 0))) - 0) - -;;; Segmentation violation - -(deftest misc.646 - (let ((form '(lambda (a) - (declare (type (integer -125 -44) a)) - (declare (ignorable a)) - #+cmu (declare (optimize (extensions:inhibit-warnings 3))) - (declare (optimize (speed 0) (debug 0) (space 2) (compilation-speed 3) - (safety 3))) - (mask-field (byte 0 0) - (block b3 (isqrt (abs (catch 'ct2 (return-from b3 0))))))))) - (funcall (compile nil form) -50)) - 0) - -;;; 1928431123 is not of type (MOD 536870911) - -(deftest misc.647 - (let ((form '(lambda (a) - (declare (type (integer -2494 534) a)) - (declare (ignorable a)) - #+cmu (declare (optimize (extensions:inhibit-warnings 3))) - (declare (optimize (speed 0) (space 0) (compilation-speed 3) (safety 1) - (debug 1))) - (dotimes (iv3 1 0) - (block b1 - (loop for lv1 below 1 - count (logbitp 0 - (reduce - #'(lambda (lmv6 lmv2) - (if (> 2208446653 lmv6) - (return-from b1 lmv2) - lv1)) - (list 0 0 0 1928431123 iv3 iv3 a a) - :end 5 - :from-end t)))))))) - (funcall (compile nil form) 1)) - 0) - -;;; The assertion (AND C::SUCC (NULL (CDR C::SUCC))) failed. - -(deftest misc.648 - (let ((form '(lambda (a) - (declare (type (integer -8 11754838336) a)) - (declare (ignorable a)) - #+cmu (declare (optimize (extensions:inhibit-warnings 3))) - (declare (optimize (space 0) (compilation-speed 0) (speed 3) (debug 3) - (safety 0))) - (labels ((%f13 () - (logorc1 (unwind-protect 0) - (prog1 0 - (prog2 - (max 0 a) - 0 - (progn - (return-from %f13 a) - a)))))) - 0)))) - (funcall (compile nil form) 2582756596)) - 0) - -;;; sbcl 0.9.13.8 (x86 linux) -;;; VALUES type illegal in this context: * - -(deftest misc.649 - (let ((form '(lambda (p2) - (declare (optimize (speed 0) (safety 0) (debug 2) (space 2)) - (type (member integer *) p2)) - (coerce 523242 p2)))) - (funcall (compile nil form) 'integer)) - 523242) - -;;; The symbol AND is not valid as a type specifier - -(deftest misc.650 - (let ((form '(lambda (p2) - (declare (optimize (speed 0) (safety 2) (debug 0) (space 2)) - (type (member integer and) p2)) - (coerce -12 p2)))) - (funcall (compile nil form) 'integer)) - -12) - -;;; The symbol OR is not valid as a type specifier - -(deftest misc.651 - (let ((form '(lambda (p2) - (declare (optimize (speed 0) (safety 2) (debug 0) (space 2)) - (type (member integer or) p2)) - (coerce 1 p2)))) - (funcall (compile nil form) 'integer)) - 1) - -;;; The symbol NOT is not valid as a type specifier. - -(deftest misc.652 - (let ((form '(lambda (p2) - (declare (optimize (speed 0) (safety 2) (debug 0) (space 2)) - (type (member integer not) p2)) - (coerce 2 p2)))) - (funcall (compile nil form) 'integer)) - 2) - -;;; The symbol SATISFIES is not valid as a type specifier. - -(deftest misc.653 - (let ((form '(lambda (p2) - (declare (optimize (speed 0) (safety 2) (debug 0) (space 2)) - (type (member integer satisfies) p2)) - (coerce 2 p2)))) - (funcall (compile nil form) 'integer)) - 2) - -;;; error while parsing arguments to DEFTYPE EQL: -;;; invalid number of elements in -;;; () -;;; to satisfy lambda list -;;; (SB-KERNEL::N): -;;; exactly 1 expected, but 0 found - -(deftest misc.654 - (let ((form '(lambda (p2) - (declare (optimize (speed 0) (safety 2) (debug 0) (space 2)) - (type (member integer eql) p2)) - (coerce 2 p2)))) - (funcall (compile nil form) 'integer)) - 2) - -;;; The symbol MEMBER is not valid as a type specifier. - -(deftest misc.655 - (let ((form '(lambda (p2) - (declare (optimize (speed 0) (safety 2) (debug 0) (space 2)) - (type (member integer member) p2)) - (coerce 2 p2)))) - (funcall (compile nil form) 'integer)) - 2) - -;;; error while parsing arguments to DEFTYPE MOD: -;;; invalid number of elements in -;;; () -;;; to satisfy lambda list -;;; (SB-KERNEL::N): -;;; exactly 1 expected, but 0 found - -(deftest misc.656 - (let ((form '(lambda (p2) - (declare (optimize (speed 0) (safety 2) (debug 0) (space 2)) - (type (member integer mod) p2)) - (coerce 2 p2)))) - (funcall (compile nil form) 'integer)) - 2) - -;;; The symbol VALUES is not valid as a type specifier. - -(deftest misc.657 - (let ((form '(lambda (p2) - (declare (optimize (speed 0) (safety 2) (debug 0) (space 2)) - (type (member integer values) p2)) - (coerce 2 p2)))) - (funcall (compile nil form) 'integer)) - 2) - diff --git a/t/ansi-test/notes.lsp b/t/ansi-test/notes.lsp deleted file mode 100644 index d5e457d..0000000 --- a/t/ansi-test/notes.lsp +++ /dev/null @@ -1,52 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Jun 30 21:43:23 2003 -;;;; Contains: Notes concerning various parts of the ANSI spec. - -(in-package :cl-test) - -(defnote :allow-nil-arrays - "Allow specialized arrays of type (array nil).") - -(defnote :allow-nonzero-nil-vectors - "Allow specialized vectors of type (vector nil) of nonzero size.") - -(defnote :nil-vectors-are-strings - "Assume that (VECTOR NIL) objects are strings.") - -(defnote :standardized-package-nicknames - "The standardized package nicknames specified in section 11 of ANSI CL are exclusive (disputed).") - -(defnote :type-of/strict-builtins - "Interpret requirement 1.a on the TYPE-OF page to apply to all built-in types that -contain the object, not just to some builtin type that contains the object.") - -(defnote :assume-no-gray-streams - "Disable the test if gray streams are present.") - -(defnote :assume-no-simple-streams - "Disable the test if simple streams are present.") - -(defnote :open-if-exists-new-version-no-error - "Assume that OPEN, when called with :if-exists :new-version, does not fail.") - -#+sbcl (rt::disable-note :open-if-exists-new-version-no-error) - -(defnote :make-condition-with-compound-name - "The spec says MAKE-CONDITION should work on any subtype of CONDITION, but this causes all sorts of problems. They probably meant only non-compound names.") - -(defnote :ansi-spec-problem - "A catch-all for tests that illustrate problems in the ANSI spec.") - -(defnote :negative-zero-is-similar-to-positive-zero - "The definition of similarity implies that -0.0 and 0.0 are similar (for each float type.) -If negative zeros are distinct this is probably not good, since it makes (defconstant x 0.0) be nonportable.") - -(defnote :result-type-element-type-by-subtype - "Assume that (for sequence functions MAP, etc.) the element type of a vector result type - is defined to be the type X such that result-type is a subtype of (vector X).") - -;;; Haible disagrees with :result-type-element-type-by-subtype -#+clisp (rt::disable-note :result-type-element-type-by-subtype) -#+(or openmcl gcl ecl) (rt::disable-note :nil-vectors-are-strings) -#+gcl (rt::disable-note :allow-nil-arrays) diff --git a/t/ansi-test/numbers/abs.lsp b/t/ansi-test/numbers/abs.lsp deleted file mode 100644 index 4e2b0fb..0000000 --- a/t/ansi-test/numbers/abs.lsp +++ /dev/null @@ -1,179 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Sep 1 20:16:42 2003 -;;;; Contains: Tests of ABS - - - - - -(deftest abs.error.1 - (signals-error (abs) program-error) - t) - -(deftest abs.error.2 - (signals-error (abs 0 0) program-error) - t) - -(deftest abs.error.3 - (signals-error (abs 0 nil nil) program-error) - t) - -(deftest abs.1 - (loop for x in *numbers* - for a = (abs x) - always (and (realp a) (not (minusp a)))) - t) - -(deftest abs.2 - (loop for x = (random-fixnum) - for a = (abs x) - repeat 10000 - unless (if (plusp x) (eql x a) (eql (- x) a)) - collect (list x a)) - nil) - -(deftest abs.3 - (let ((bound (ash 1 300))) - (loop for x = (random-from-interval bound) - for a = (abs x) - repeat 10000 - unless (if (plusp x) (eql x a) (eql (- x) a)) - collect (list x a))) - nil) - -(deftest abs.4 - (loop for num = (random-fixnum) - for den = (random-fixnum) - for den2 = (if (zerop den) 1 den) - for r = (/ num den) - for a = (abs r) - repeat 10000 - unless (if (>= r 0) (eql r a) (eql (- r) a)) - collect (list num den2 r a)) - nil) - -(deftest abs.5 - (let ((bound (ash 1 210))) - (loop - for num = (random-from-interval bound) - for den = (random-from-interval bound) - for den2 = (if (zerop den) 1 den) - for r = (/ num den) - for a = (abs r) - repeat 10000 - unless (if (>= r 0) (eql r a) (eql (- r) a)) - collect (list num den2 r a))) - nil) - -(deftest abs.6 - (let ((bound (float (ash 1 11) 1.0s0))) - (loop - for x = (random-from-interval bound) - for a = (abs x) - repeat 10000 - unless (if (minusp x) - (eql (- x) a) - (eql x a)) - collect (list x a))) - nil) - -(deftest abs.7 - (let ((bound (float (ash 1 22) 1.0f0))) - (loop - for x = (random-from-interval bound) - for a = (abs x) - repeat 10000 - unless (if (minusp x) - (eql (- x) a) - (eql x a)) - collect (list x a))) - nil) - -(deftest abs.8 - (let ((bound (float (ash 1 48) 1.0d0))) - (loop - for x = (random-from-interval bound) - for a = (abs x) - repeat 10000 - unless (if (minusp x) - (eql (- x) a) - (eql x a)) - collect (list x a))) - nil) - -(deftest abs.9 - (let ((bound (float (ash 1 48) 1.0l0))) - (loop - for x = (random-from-interval bound) - for a = (abs x) - repeat 10000 - unless (if (minusp x) - (eql (- x) a) - (eql x a)) - collect (list x a))) - nil) - -;;; The example on the abs page says that (abs -0.0) should be -0,0. -;;; However, FABS on the x86 returns 0.0 for that. Since the examples -;;; in the hyperspec are not normative, the following four tests -;;; have been commented out. - -;;; (deftest abs.10 -;;; (abs -0.0s0) -;;; -0.0s0) -;;; -;;; (deftest abs.11 -;;; (abs -0.0f0) -;;; -0.0f0) -;;; -;;; (deftest abs.12 -;;; (abs -0.0d0) -;;; -0.0d0) -;;; -;;; (deftest abs.13 -;;; (abs -0.0l0) -;;; -0.0l0) - -;;; Complex numbers - -(deftest abs.14 - (let ((result (abs #c(3 4)))) - (=t result 5)) - t) - -(deftest abs.15 - (let ((result (abs #c(-3 4)))) - (=t result 5)) - t) - -(deftest abs.16 - (let ((result (abs #c(3 -4)))) - (=t result 5)) - t) - -(deftest abs.17 - (let ((result (abs #c(-3 -4)))) - (=t result 5)) - t) - -(deftest abs.18 - (abs #c(3.0s0 4.0s0)) - 5.0s0) - -(deftest abs.19 - (abs #c(3.0f0 -4.0f0)) - 5.0f0) - -(deftest abs.20 - (abs #c(-3.0d0 4.0d0)) - 5.0d0) - -(deftest abs.21 - (abs #c(-3.0l0 4.0l0)) - 5.0l0) - -(deftest abs.22 - (macrolet ((%m (z) z)) - (abs (expand-in-current-env (%m -4)))) - 4) diff --git a/t/ansi-test/numbers/acos.lsp b/t/ansi-test/numbers/acos.lsp deleted file mode 100644 index bcbf896..0000000 --- a/t/ansi-test/numbers/acos.lsp +++ /dev/null @@ -1,100 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Feb 10 05:39:24 2004 -;;;; Contains: Tess of ACOS - - - -(deftest acos.1 - (loop for i from -1000 to 1000 - for rlist = (multiple-value-list (acos i)) - for y = (car rlist) - always (and (null (cdr rlist)) - (numberp y))) - t) - -(deftest acos.2 - (loop for type in '(short-float single-float double-float long-float) - collect - (let ((a (coerce 2000 type)) - (b (coerce -1000 type))) - (loop for x = (- (random a) b) - for rlist = (multiple-value-list (acos x)) - for y = (car rlist) - repeat 1000 - always (and (null (cdr rlist)) - (numberp y))))) - (t t t t)) - -(deftest acos.3 - (loop for type in '(integer short-float single-float double-float long-float) - collect - (let ((a (coerce 2000 type)) - (b (coerce -1000 type))) - (loop for x = (- (random a) b) - for rlist = (multiple-value-list (acos (complex 0 x))) - for y = (car rlist) - repeat 1000 - always (and (null (cdr rlist)) - (numberp y))))) - (t t t t t)) - -(deftest acos.4 - (loop for type in '(integer short-float single-float double-float long-float) - collect - (let ((a (coerce 2000 type)) - (b (coerce -1000 type))) - (loop for x1 = (- (random a) b) - for x2 = (- (random a) b) - for rlist = (multiple-value-list (acos (complex x1 x2))) - for y = (car rlist) - repeat 1000 - always (and (null (cdr rlist)) - (numberp y))))) - (t t t t t)) - -(deftest acos.5 - (approx= (acos 0) (coerce (/ pi 2) 'single-float)) - t) - -(deftest acos.6 - (loop for type in '(single-float short-float double-float long-float) - unless (approx= (acos (coerce 0 type)) - (coerce (/ pi 2) type)) - collect type) - nil) - -(deftest acos.7 - (loop for type in '(single-float short-float double-float long-float) - unless (approx= (acos (coerce 1 type)) - (coerce 0 type)) - collect type) - nil) - -(deftest acos.8 - (loop for type in '(single-float short-float double-float long-float) - unless (approx= (acos (coerce -1 type)) - (coerce pi type)) - collect type) - nil) - -(deftest acos.9 - (macrolet ((%m (z) z)) (not (not (> (acos (expand-in-current-env (%m 0))) 0)))) - t) - -;;; FIXME -;;; Add accuracy tests - -;;; Error tests - -(deftest acos.error.1 - (signals-error (acos) program-error) - t) - -(deftest acos.error.2 - (signals-error (acos 0.0 0.0) program-error) - t) - -(deftest acos.error.3 - (check-type-error #'acos #'numberp) - nil) diff --git a/t/ansi-test/numbers/acosh.lsp b/t/ansi-test/numbers/acosh.lsp deleted file mode 100644 index 7d21615..0000000 --- a/t/ansi-test/numbers/acosh.lsp +++ /dev/null @@ -1,100 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Feb 11 19:20:53 2004 -;;;; Contains: Tests of ACOSH - - - -(deftest acosh.1 - (let ((result (acosh 1))) - (or (eqlt result 0) - (eqlt result 0.0))) - t) - -(deftest acosh.2 - (loop for type in '(short-float single-float double-float long-float) - for zero = (coerce 0 type) - for one = (coerce 1 type) - unless (equal (multiple-value-list (acosh one)) - (list zero)) - collect type) - nil) - -(deftest acosh.3 - (loop for type in '(short-float single-float double-float long-float) - for zero = (coerce 0 `(complex ,type)) - for one = (coerce 1 `(complex ,type)) - unless (equal (multiple-value-list (acosh one)) - (list zero)) - collect type) - nil) - -(deftest acosh.4 - (loop for den = (1+ (random 10000)) - for num = (random (* 10 den)) - for x = (/ num den) - for rlist = (multiple-value-list (acosh x)) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (numberp y)) - collect (list x rlist)) - nil) - -(deftest acosh.5 - (loop for type in '(short-float single-float double-float long-float) - nconc - (loop - for x = (1+ (random (coerce 1000 type))) - for rlist = (multiple-value-list (acosh x)) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (typep y type)) - collect (list x rlist))) - nil) - -(deftest acosh.6 - (loop for type in '(short-float single-float double-float long-float) - nconc - (loop - for x1 = (- (random (coerce 20 type)) 10) - for x2 = (- (random (coerce 20 type)) 10) - for rlist = (multiple-value-list (acosh (complex x1 x2))) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (typep y `(complex ,type))) - collect (list x1 x2 rlist))) - nil) - -(deftest acosh.7 - (macrolet ((%m (z) z)) (not (not (complexp (acosh (expand-in-current-env (%m 0))))))) - t) - -;;; FIXME -;;; Add accuracy tests here - -;;; Error tests - -(deftest acosh.error.1 - (signals-error (acosh) program-error) - t) - -(deftest acosh.error.2 - (signals-error (acosh 1.0 1.0) program-error) - t) - -(deftest acosh.error.3 - (check-type-error #'acosh #'numberp) - nil) - - - - - - - - - - diff --git a/t/ansi-test/numbers/arithmetic-error.lsp b/t/ansi-test/numbers/arithmetic-error.lsp deleted file mode 100644 index b9d0134..0000000 --- a/t/ansi-test/numbers/arithmetic-error.lsp +++ /dev/null @@ -1,68 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Contains: Tests of ARITHMETIC-ERROR condition and associated accessors - - - -(deftest arithmethic-error.1 - (let ((a (make-condition 'arithmetic-error - :operation '/ - :operands '(0 0)))) - (values - (notnot (typep a 'arithmetic-error)) - (notnot (typep a (find-class 'arithmetic-error))) - (multiple-value-list (arithmetic-error-operation a)) - (multiple-value-list (arithmetic-error-operands a)))) - t t (/) ((0 0))) - -(deftest arithmethic-error.2 - (let ((a (make-condition 'arithmetic-error - :operation #'/ - :operands '(0 0)))) - (values - (notnot (typep a 'arithmetic-error)) - (notnot (typep a 'error)) - (notnot (typep a 'serious-condition)) - (notnot (typep a 'condition)) - (notnot (typep a (find-class 'arithmetic-error))) - (notnot (typep (arithmetic-error-operation a) 'function)) - (funcall (arithmetic-error-operation a) 1 2) - (multiple-value-list (arithmetic-error-operands a)))) - t t t t t t 1/2 ((0 0))) - -(deftest arithmetic-error.3 - (let ((a (make-condition 'arithmetic-error - :operation '/ - :operands '(0 0)))) - (macrolet - ((%m (z) z)) - (values - (arithmetic-error-operation (expand-in-current-env (%m a))) - (arithmetic-error-operands (expand-in-current-env (%m a)))))) - / (0 0)) - -;;; Error tests - -(deftest arithmetic-error-operation.error.1 - (signals-error (arithmetic-error-operation) program-error) - t) - -(deftest arithmetic-error-operation.error.2 - (signals-error (arithmetic-error-operation - (make-condition 'arithmetic-error :operation '/ - :operands '(1 0)) - nil) - program-error) - t) - -(deftest arithmetic-error-operands.error.1 - (signals-error (arithmetic-error-operands) program-error) - t) - -(deftest arithmetic-error-operands.error.2 - (signals-error (arithmetic-error-operands - (make-condition 'arithmetic-error :operation '/ - :operands '(1 0)) - nil) - program-error) - t) diff --git a/t/ansi-test/numbers/ash.lsp b/t/ansi-test/numbers/ash.lsp deleted file mode 100644 index 92e3fe0..0000000 --- a/t/ansi-test/numbers/ash.lsp +++ /dev/null @@ -1,79 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Sep 7 08:43:03 2003 -;;;; Contains: Tests of ASH - - - -;;; Error tests - -(deftest ash.error.1 - (signals-error (ash) program-error) - t) - -(deftest ash.error.2 - (signals-error (ash 1 1 1) program-error) - t) - -(deftest ash.error.3 - (signals-error (ash 1 1 nil) program-error) - t) - -(deftest ash.error.4 - (check-type-error #'(lambda (x) (ash x 0)) #'integerp) - nil) - -(deftest ash.error.5 - (check-type-error #'(lambda (x) (ash 0 x)) #'integerp) - nil) - -;;; Non-error tests - -(deftest ash.1 - (loop for x in *integers* - always (eql (ash x 0) x)) - t) - -(deftest ash.2 - (loop for i = (random-fixnum) - for s = (random-from-interval 40) - for ishifted = (ash i s) - repeat 1000 - always (eql (floor (* i (expt 2 s))) ishifted)) - t) - -(deftest ash.3 - (let* ((nbits 100) - (bound (expt 2 nbits))) - (loop for i = (random-from-interval bound) - for s = (random-from-interval (+ nbits 20)) - for ishifted = (ash i s) - repeat 1000 - always (eql (floor (* i (expt 2 s))) ishifted))) - t) - -(deftest ash.4 - (loop for i from -1 downto -1000 - always (eql (ash i i) -1)) - t) - -(deftest ash.5 - (loop for i from 1 to 100 - for j = (- (ash 1 i)) - always (eql (ash j j) -1)) - t) - -(deftest ash.6 - (macrolet - ((%m (z) z)) - (values - (ash (expand-in-current-env (%m 3)) 1) - (ash 1 (expand-in-current-env (%m 3))))) - 6 8) - -(deftest ash.order.1 - (let ((i 0) x y) - (values (ash (progn (setf x (incf i)) 1) - (progn (setf y (incf i)) 2)) - i x y)) - 4 2 1 2) diff --git a/t/ansi-test/numbers/asin.lsp b/t/ansi-test/numbers/asin.lsp deleted file mode 100644 index 01a0255..0000000 --- a/t/ansi-test/numbers/asin.lsp +++ /dev/null @@ -1,105 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Feb 11 05:59:43 2004 -;;;; Contains: Tests for ASIN - - - -(deftest asin.1 - (loop for i from -1000 to 1000 - for rlist = (multiple-value-list (asin i)) - for y = (car rlist) - always (and (null (cdr rlist)) - (numberp y))) - t) - -(deftest asin.2 - (loop for type in '(short-float single-float double-float long-float) - collect - (let ((a (coerce 2000 type)) - (b (coerce -1000 type))) - (loop for x = (- (random a) b) - for rlist = (multiple-value-list (asin x)) - for y = (car rlist) - repeat 1000 - always (and (null (cdr rlist)) - (numberp y))))) - (t t t t)) - -(deftest asin.3 - (loop for type in '(integer short-float single-float double-float long-float) - collect - (let ((a (coerce 2000 type)) - (b (coerce -1000 type))) - (loop for x = (- (random a) b) - for rlist = (multiple-value-list (asin (complex 0 x))) - for y = (car rlist) - repeat 1000 - always (and (null (cdr rlist)) - (numberp y))))) - (t t t t t)) - -(deftest asin.4 - (loop for type in '(integer short-float single-float double-float long-float) - collect - (let ((a (coerce 2000 type)) - (b (coerce -1000 type))) - (loop for x1 = (- (random a) b) - for x2 = (- (random a) b) - for rlist = (multiple-value-list (asin (complex x1 x2))) - for y = (car rlist) - repeat 1000 - always (and (null (cdr rlist)) - (numberp y))))) - (t t t t t)) - -(deftest asin.5 - (approx= (asin 1) (coerce (/ pi 2) 'single-float)) - t) - -(deftest asin.6 - (loop for type in '(single-float short-float double-float long-float) - unless (approx= (asin (coerce 1 type)) - (coerce (/ pi 2) type)) - collect type) - nil) - -(deftest asin.7 - (loop for type in '(single-float short-float double-float long-float) - unless (approx= (asin (coerce 0 type)) - (coerce 0 type)) - collect type) - nil) - -(deftest asin.8 - (loop for type in '(single-float short-float double-float long-float) - unless (approx= (asin (coerce -1 type)) - (coerce (/ pi -2) type)) - collect type) - nil) - -(deftest asin.9 - (macrolet ((%m (z) z)) (asin (expand-in-current-env (%m 0.0)))) - 0.0) - -;;; FIXME -;;; Add accuracy tests - -;;; Error tests - -(deftest asin.error.1 - (signals-error (asin) program-error) - t) - -(deftest asin.error.2 - (signals-error (asin 0.0 0.0) program-error) - t) - -(deftest asin.error.3 - (check-type-error #'asin #'numberp) - nil) - - - - - diff --git a/t/ansi-test/numbers/asinh.lsp b/t/ansi-test/numbers/asinh.lsp deleted file mode 100644 index 5759203..0000000 --- a/t/ansi-test/numbers/asinh.lsp +++ /dev/null @@ -1,97 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Feb 11 19:19:02 2004 -;;;; Contains: Tests of ASINH - - - -(deftest asinh.1 - (let ((result (asinh 0))) - (or (eqlt result 0) - (eqlt result 0.0))) - t) - -(deftest asinh.2 - (loop for type in '(short-float single-float double-float long-float) - for zero = (coerce 0 type) - unless (equal (multiple-value-list (asinh zero)) - (list zero)) - collect type) - nil) - -(deftest asinh.3 - (loop for type in '(short-float single-float double-float long-float) - for zero = (coerce 0 `(complex ,type)) - unless (equal (multiple-value-list (asinh zero)) - (list zero)) - collect type) - nil) - -(deftest asinh.4 - (loop for den = (1+ (random 10000)) - for num = (random (* 10 den)) - for x = (/ num den) - for rlist = (multiple-value-list (asinh x)) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (numberp y)) - collect (list x rlist)) - nil) - -(deftest asinh.5 - (loop for type in '(short-float single-float double-float long-float) - nconc - (loop - for x = (- (random (coerce 20 type)) 10) - for rlist = (multiple-value-list (asinh x)) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (typep y type)) - collect (list x rlist))) - nil) - -(deftest asinh.6 - (loop for type in '(short-float single-float double-float long-float) - nconc - (loop - for x1 = (- (random (coerce 20 type)) 10) - for x2 = (- (random (coerce 20 type)) 10) - for rlist = (multiple-value-list (asinh (complex x1 x2))) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (typep y `(complex ,type))) - collect (list x1 x2 rlist))) - nil) - -(deftest asinh.7 - (macrolet ((%m (z) z)) (asinh (expand-in-current-env (%m 0.0)))) - 0.0) - -;;; FIXME -;;; Add accuracy tests here - -;;; Error tests - -(deftest asinh.error.1 - (signals-error (asinh) program-error) - t) - -(deftest asinh.error.2 - (signals-error (asinh 1.0 1.0) program-error) - t) - -(deftest asinh.error.3 - (check-type-error #'asinh #'numberp) - nil) - - - - - - - - - diff --git a/t/ansi-test/numbers/atan.lsp b/t/ansi-test/numbers/atan.lsp deleted file mode 100644 index 8bce4ff..0000000 --- a/t/ansi-test/numbers/atan.lsp +++ /dev/null @@ -1,210 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Feb 11 06:01:55 2004 -;;;; Contains: Tests of ATAN - - - -(deftest atan.1 - (let ((result (atan 0))) - (or (eqlt result 0) - (eqlt result 0.0))) - t) - -(deftest atan.2 - (loop for type in '(short-float single-float double-float long-float) - for zero = (coerce 0 type) - unless (eql (atan zero) zero) - collect type) - nil) - -(deftest atan.3 - (loop for type in '(short-float single-float double-float long-float) - for zero = (coerce 0 type) - unless (eql (atan zero 1) zero) - collect type) - nil) - -(deftest atan.4 - (loop for type in '(short-float single-float double-float long-float) - for zero = (coerce 0 type) - for one = (coerce 1 type) - unless (eql (atan 0 one) zero) - collect type) - nil) - -(deftest atan.5 - (loop for type in '(short-float single-float double-float long-float) - for zero = (coerce 0 type) - for one = (coerce 1 type) - unless (eql (atan zero one) zero) - collect type) - nil) - -(deftest atan.6 - (loop for type in '(short-float single-float double-float long-float) - for a = (coerce 2000 type) - for b = (coerce -1000 type) - collect - (loop for x = (- (random a) b) - for rlist = (multiple-value-list (atan x)) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (typep y type)) - collect (list x rlist))) - (nil nil nil nil)) - -(deftest atan.7 - (loop for type in '(short-float single-float double-float long-float) - for a = (coerce 2000 type) - for b = (coerce -1000 type) - for zero = (coerce 0 type) - collect - (loop for x = (- (random a) b) - for rlist = (multiple-value-list (atan (complex x zero))) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (typep y `(complex ,type))) - collect (list x rlist))) - (nil nil nil nil)) - -(deftest atan.8 - (loop for type in '(short-float single-float double-float long-float) - for a = (coerce 2000 type) - for b = (coerce -1000 type) - for zero = (coerce 0 type) - collect - (loop for x = (- (random a) b) - for rlist = (multiple-value-list (atan (complex zero x))) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (typep y `(complex ,type))) - collect (list x rlist))) - (nil nil nil nil)) - -(deftest atan.9 - (loop for type in '(short-float single-float double-float long-float) - for a = (coerce 2000 type) - for b = (coerce -1000 type) - for zero = (coerce 0 type) - collect - (loop for x1 = (- (random a) b) - for x2 = (- (random a) b) - for rlist = (multiple-value-list (atan (complex x1 x2))) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (typep y `(complex ,type))) - collect (list x1 x2 rlist))) - (nil nil nil nil)) - -(deftest atan.10 - (approx= (atan 1) (coerce (/ pi 4) 'single-float)) - t) - -(deftest atan.11 - (loop for type in '(short-float single-float double-float long-float) - collect (approx= (atan (coerce 1 type)) (coerce (/ pi 4) type))) - (t t t t)) - -(deftest atan.12 - (approx= (atan -1) (coerce (/ pi -4) 'single-float)) - t) - -(deftest atan.13 - (loop for type in '(short-float single-float double-float long-float) - collect (approx= (atan (coerce -1 type)) (coerce (/ pi -4) type))) - (t t t t)) - -(deftest atan.14 - (macrolet ((%m (z) z)) (atan (expand-in-current-env (%m 0.0)))) - 0.0) - -;;; FIXME -;;; More accuracy tests here - -;;; ieee-fp tests -(deftest atan.ieee.1 :description "Verify if atan handles 0.0 correctly" - (flet ((+pi-p (elt) (= (coerce pi (type-of elt)) elt)) - (+pi/2-p (elt) (approx= (coerce (/ pi +2) (type-of elt)) elt)) - (-pi/2-p (elt) (approx= (coerce (/ pi -2) (type-of elt)) elt))) - ;; (atan +-0 +(anything-but-nan)) -> +-0 - ;; (atan +-0 -(anything-but-nan)) -> +-pi - ;; (atan +-(anything-but-0/nan) 0) -> +-pi/2 - (every (lambda (n) - ;; notice, that we don't test a case, where - ;; both arguments are 0.0, because if - ;; implementation doesn't support signed 0 - ;; result is undefined. - (and (zerop (atan 0.0 n)) - (+pi-p (atan 0.0 (- n))) - (+pi/2-p (atan n 0.0)) - (-pi/2-p (atan (- n) 0.0)))) - (remove-if-not #'plusp *floats*))) - T) - -(deftest atan.ieee.2 :description "Verify ATAN handling signed zero" - (or (plusp (float-sign -0.0)) - (flet ((+zerop (elt) - (and (zerop elt) - (plusp (float-sign elt)))) - (-zerop (elt) - (and (zerop elt) - (minusp (float-sign elt)))) - (+pi-p (elt) (= (coerce pi (type-of elt)) elt)) - (-pi-p (elt) (= (coerce pi (type-of elt)) (- elt)))) - (and - (+zerop (atan +0.0 +0.0)) - (-zerop (atan -0.0 +0.0)) - (+pi-p (atan +0.0 -0.0)) - (-pi-p (atan -0.0 -0.0)) - (every (lambda (n) - (and (-zerop (atan -0.0 n)) - (+zerop (atan +0.0 n)) - (+pi-p (atan +0.0 (- n))) - (-pi-p (atan -0.0 (- n))))) - (remove-if-not #'plusp *floats*))))) - T) - -;;; We could have tested also for infinities and nan's, but there is -;;; no portable ieee-fp, we could put it in ansi-beyond test suite -;;; though: -;;; -;;; (atan (anything) nan) -> nan -;;; (atan nan (anything)) -> nan -;;; (atan +inf +inf) -> +pi/4 -;;; (atan -inf +inf) -> -pi/4 -;;; (atan +inf -inf) -> +3pi/4 -;;; (atan -inf -inf) -> -3pi/4 -;;; (atan -(anything-but/inf+nan), +inf) -> -0 -;;; (atan +(anything-but/inf+nan), +inf) -> +0 -;;; (atan +(anything-but/inf+nan), -inf) -> +pi -;;; (atan -(anything-but/inf+nan), -inf) -> -pi -;;; (atan +inf (anything-but/0+inf+nan)) -> +pi/2 -;;; (atan -inf (anything-but/0+inf+nan)) -> -pi/2 -;;; - -;;; Error tests - -(deftest atan.error.1 - (signals-error (atan) program-error) - t) - -(deftest atan.error.2 - (signals-error (atan 1 1 1) program-error) - t) - -(deftest atan.error.3 - (check-type-error #'atan #'numberp) - nil) - -(deftest atan.error.4 - (check-type-error #'(lambda (x) (atan x 1)) #'realp) - nil) - -(deftest atan.error.5 - (check-type-error #'(lambda (x) (atan 1 x)) #'realp) - nil) diff --git a/t/ansi-test/numbers/atanh.lsp b/t/ansi-test/numbers/atanh.lsp deleted file mode 100644 index bd61e45..0000000 --- a/t/ansi-test/numbers/atanh.lsp +++ /dev/null @@ -1,116 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Feb 11 19:26:25 2004 -;;;; Contains: Tests of ATANH - - - -(deftest atanh.1 - (let ((result (atanh 0))) - (or (eqlt result 0) - (eqlt result 0.0))) - t) - -(deftest atanh.2 - (loop for type in '(short-float single-float double-float long-float) - for zero = (coerce 0 type) - unless (equal (multiple-value-list (atanh zero)) - (list zero)) - collect type) - nil) - -(deftest atanh.3 - (loop for type in '(short-float single-float double-float long-float) - for zero = (coerce 0 `(complex ,type)) - unless (equal (multiple-value-list (atanh zero)) - (list zero)) - collect type) - nil) - -(deftest atanh.4 - (loop for den = (1+ (random 10000)) - for num = (random den) - for x = (/ num den) - for rlist = (multiple-value-list (atanh x)) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (numberp y)) - collect (list x rlist)) - nil) - -(deftest atanh.5 - (loop for type in '(short-float single-float double-float long-float) - nconc - (loop - for x = (if (eql (random 2) 0) - (+ 2 (random (coerce 1000 type))) - (- -2 (random (coerce 1000 type)))) - for rlist = (multiple-value-list (atanh x)) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (typep y `(complex ,type))) - collect (list x rlist))) - nil) - -(deftest atanh.5a - (loop for type in '(short-float single-float double-float long-float) - nconc - (loop - for x = (- (random (coerce 1.9998s0 type)) 0.9999s0) - for rlist = (multiple-value-list (atanh x)) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (typep y type)) - collect (list x rlist))) - nil) - -(deftest atanh.6 - (loop for type in '(short-float single-float double-float long-float) - nconc - (loop - for x1 = (- (random (coerce 1.9998s0 type)) 0.9999s0) - for rlist = (multiple-value-list (atanh (complex x1 0.0s0))) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (typep y `(complex ,type))) - collect (list x1 rlist))) - nil) - -(deftest atanh.7 - (loop for type in '(short-float single-float double-float long-float) - nconc - (loop - for x1 = (- (random (coerce 1.9998s0 type)) 0.9999s0) - for rlist = (multiple-value-list (atanh (complex 0.0s0 x1))) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (typep y `(complex ,type))) - collect (list x1 rlist))) - nil) - -(deftest atanh.8 - (macrolet ((%m (z) z)) (atanh (expand-in-current-env (%m 0.0)))) - 0.0) - - -;;; FIXME -;;; Add accuracy tests here - -;;; Error tests - -(deftest atanh.error.1 - (signals-error (atanh) program-error) - t) - -(deftest atanh.error.2 - (signals-error (atanh 1.0 1.0) program-error) - t) - -(deftest atanh.error.3 - (check-type-error #'atanh #'numberp) - nil) diff --git a/t/ansi-test/numbers/boole.lsp b/t/ansi-test/numbers/boole.lsp deleted file mode 100644 index 8c67331..0000000 --- a/t/ansi-test/numbers/boole.lsp +++ /dev/null @@ -1,150 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Sep 8 20:21:19 2003 -;;;; Contains: Tests of BOOLE and associated constants - - - - - -(defparameter *boole-val-names* - '(boole-1 boole-2 boole-and boole-andc1 boole-andc2 - boole-c1 boole-c2 boole-clr boole-eqv boole-ior - boole-nand boole-nor boole-orc1 boole-orc2 boole-set boole-xor)) - -(defparameter *boole-vals* - (list boole-1 boole-2 boole-and boole-andc1 boole-andc2 - boole-c1 boole-c2 boole-clr boole-eqv boole-ior boole-nand - boole-nor boole-orc1 boole-orc2 boole-set boole-xor)) - -(defparameter *boole-fns* - (list #'(lambda (x y) (declare (ignore y)) x) - #'(lambda (x y) (declare (ignore x)) y) - #'logand - #'logandc1 - #'logandc2 - #'(lambda (x y) (declare (ignore y)) (lognot x)) - #'(lambda (x y) (declare (ignore x)) (lognot y)) - (constantly 0) - #'logeqv - #'logior - #'lognand - #'lognor - #'logorc1 - #'logorc2 - (constantly -1) - #'logxor)) - -(deftest boole.error.1 - (signals-error (boole) program-error) - t) - -(deftest boole.error.2 - (signals-error (boole boole-1) program-error) - t) - -(deftest boole.error.3 - (signals-error (boole boole-1 1) program-error) - t) - -(deftest boole.error.4 - (signals-error (boole boole-1 1 2 nil) program-error) - t) - -(deftest boole.error.5 - (let ((bad (loop for i from 1 until (not (member i *boole-vals*))))) - (eval `(signals-type-error x ',bad (boole x 1 1)))) - t) - -(deftest boole.error.6 - (loop for n in *boole-val-names* - unless (eval `(signals-type-error x nil (boole ,n nil 1))) - collect n) - nil) - -(deftest boole.error.7 - (loop for n in *boole-val-names* - unless (eval `(signals-type-error x nil (boole ,n 1 nil))) - collect n) - nil) - -(deftest boole.1 - (loop for v in *boole-vals* - for fn of-type function in *boole-fns* - for n in *boole-val-names* - nconc - (loop for x = (random-fixnum) - for y = (random-fixnum) - for result1 = (funcall (the function fn) x y) - for vals = (multiple-value-list (boole v x y)) - for result2 = (car vals) - repeat 100 - unless (and (= (length vals) 1) (eql result1 result2)) - collect (list n x y result1 result2))) - nil) - -(deftest boole.2 - (loop for v in *boole-vals* - for fn of-type function in *boole-fns* - for n in *boole-val-names* - nconc - (loop for x = (random-from-interval 1000000000000000) - for y = (random-from-interval 1000000000000000) - for result1 = (funcall (the function fn) x y) - for vals = (multiple-value-list (boole v x y)) - for result2 = (car vals) - repeat 100 - unless (and (= (length vals) 1) (eql result1 result2)) - collect (list n x y result1 result2))) - nil) - -(deftest boole.3 - (loop for n in *boole-val-names* - for fn of-type function in *boole-fns* - for fn2 = (compile nil `(lambda (x y) (declare (type fixnum x y)) - (boole ,n x y))) - nconc - (loop for x = (random-fixnum) - for y = (random-fixnum) - for result1 = (funcall (the function fn) x y) - for vals = (multiple-value-list (funcall fn2 x y)) - for result2 = (car vals) - repeat 100 - unless (and (= (length vals) 1) (eql result1 result2)) - collect (list n x y result1 result2))) - nil) - -(deftest boole.4 - (macrolet ((%m (z) z)) - (values (boole (expand-in-current-env (%m boole-and)) #b11001100 #b01011010) - (boole boole-and (expand-in-current-env (%m #b11001100)) #b01011010) - (boole boole-and #b11001100 (expand-in-current-env (%m #b01011010))))) - #b01001000 - #b01001000 - #b01001000) - -;;; Order of evaluation -(deftest boole.order.1 - (let ((i 0) a b c) - (values - (boole - (progn (setf a (incf i)) boole-and) - (progn (setf b (incf i)) #b1101) - (progn (setf c (incf i)) #b11001)) - i a b c)) - #b1001 3 1 2 3) - -;;; Constants are constants - -(deftest boole.constants.1 - (eqlt (length *boole-vals*) - (length (remove-duplicates *boole-vals*))) - t) - -(deftest boole.constants.2 - (remove-if #'constantp *boole-val-names*) - nil) - -(deftest boole.constants.3 - (remove-if #'boundp *boole-val-names*) - nil) diff --git a/t/ansi-test/numbers/byte.lsp b/t/ansi-test/numbers/byte.lsp deleted file mode 100644 index 5881528..0000000 --- a/t/ansi-test/numbers/byte.lsp +++ /dev/null @@ -1,75 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Sep 11 20:13:22 2003 -;;;; Contains: Tests of BYTE, BYTE-SIZE, and BYTE-POSITION - - - -(deftest byte.error.1 - (signals-error (byte) program-error) - t) - -(deftest byte.error.2 - (signals-error (byte 1) program-error) - t) - -(deftest byte.error.3 - (signals-error (byte 1 1 nil) program-error) - t) - -(deftest byte.1 - (progn (byte 0 0) :good) - :good) - -(deftest byte.2 - (progn (byte 1 1) :good) - :good) - -(deftest byte.3 - (loop for i from 0 to 100 - always - (loop for j from 0 to 100 - always - (let ((bspec (byte i j))) - (and (eql i (byte-size bspec)) - (eql j (byte-position bspec)))))) - t) - -(deftest byte.4 - (macrolet - ((%m (z) z)) - (let ((b (byte (expand-in-current-env (%m 2)) 5))) - (values (byte-size b) (byte-position b)))) - 2 5) - -(deftest byte.5 - (macrolet - ((%m (z) z)) - (let ((b (byte 31 (expand-in-current-env (%m 7))))) - (values (byte-size b) (byte-position b)))) - 31 7) - -(deftest byte-size.1 - (macrolet ((%m (z) z)) (byte-size (expand-in-current-env (%m (byte 3 7))))) - 3) - -(deftest byte-position.1 - (macrolet ((%m (z) z)) (byte-position (expand-in-current-env (%m (byte 3 7))))) - 7) - -(deftest byte-position.error.1 - (signals-error (byte-position) program-error) - t) - -(deftest byte-position.error.2 - (signals-error (byte-position (byte 1 1) nil) - program-error) - t) - -(deftest byte-size.error.1 - (signals-error (byte-size) program-error) - t) - -(deftest byte-size.error.2 - (signals-error (byte-size (byte 1 1) nil) program-error) - t) diff --git a/t/ansi-test/numbers/ceiling.lsp b/t/ansi-test/numbers/ceiling.lsp deleted file mode 100644 index e13c6f7..0000000 --- a/t/ansi-test/numbers/ceiling.lsp +++ /dev/null @@ -1,176 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Aug 19 06:50:44 2003 -;;;; Contains: Tests of CEILING - - - - - - -(deftest ceiling.error.1 - (signals-error (ceiling) program-error) - t) - -(deftest ceiling.error.2 - (signals-error (ceiling 1.0 1 nil) program-error) - t) - -;;; - -(deftest ceiling.1 - (ceiling.1-fn) - nil) - -(deftest ceiling.2 - (ceiling.2-fn) - nil) - -(deftest ceiling.3 - (ceiling.3-fn 2.0s4) - nil) - -(deftest ceiling.4 - (ceiling.3-fn 2.0f4) - nil) - -(deftest ceiling.5 - (ceiling.3-fn 2.0d4) - nil) - -(deftest ceiling.6 - (ceiling.3-fn 2.0l4) - nil) - -(deftest ceiling.7 - (ceiling.7-fn) - nil) - -(deftest ceiling.8 - (ceiling.8-fn) - nil) - -(deftest ceiling.9 - (ceiling.9-fn) - nil) - -(deftest ceiling.10 - (loop for x in (remove-if #'zerop *reals*) - for (q r) = (multiple-value-list (ceiling x x)) - unless (and (eql q 1) - (zerop r) - (if (rationalp x) (eql r 0) - (eql r (float 0 x)))) - collect x) - nil) - -(deftest ceiling.11 - (loop for x in (remove-if #'zerop *reals*) - for (q r) = (multiple-value-list (ceiling (- x) x)) - unless (and (eql q -1) - (zerop r) - (if (rationalp x) (eql r 0) - (eql r (float 0 x)))) - collect x) - nil) - -(deftest ceiling.12 - (let* ((radix (float-radix 1.0s0)) - (rad (float radix 1.0s0)) - (rrad (/ 1.0s0 rad))) - (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (ceiling x)) - unless (and (eql q (1+ i)) - (eql r (- rrad 1))) - collect (list i x q r))) - nil) - -(deftest ceiling.13 - (let* ((radix (float-radix 1.0s0)) - (rad (float radix 1.0s0)) - (rrad (/ 1.0s0 rad))) - (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (ceiling x)) - unless (and (eql q i) - (eql r (- rrad 1))) - collect (list i x q r))) - nil) - -(deftest ceiling.14 - (let* ((radix (float-radix 1.0f0)) - (rad (float radix 1.0f0)) - (rrad (/ 1.0f0 rad))) - (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (ceiling x)) - unless (and (eql q (1+ i)) - (eql r (- rrad 1))) - collect (list i x q r))) - nil) - -(deftest ceiling.15 - (let* ((radix (float-radix 1.0f0)) - (rad (float radix 1.0f0)) - (rrad (/ 1.0f0 rad))) - (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (ceiling x)) - unless (and (eql q i) - (eql r (- rrad 1))) - collect (list i x q r))) - nil) - -(deftest ceiling.16 - (let* ((radix (float-radix 1.0d0)) - (rad (float radix 1.0d0)) - (rrad (/ 1.0d0 rad))) - (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (ceiling x)) - unless (and (eql q (1+ i)) - (eql r (- rrad 1))) - collect (list i x q r))) - nil) - -(deftest ceiling.17 - (let* ((radix (float-radix 1.0d0)) - (rad (float radix 1.0d0)) - (rrad (/ 1.0d0 rad))) - (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (ceiling x)) - unless (and (eql q i) - (eql r (- rrad 1))) - collect (list i x q r))) - nil) - -(deftest ceiling.18 - (let* ((radix (float-radix 1.0l0)) - (rad (float radix 1.0l0)) - (rrad (/ 1.0l0 rad))) - (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (ceiling x)) - unless (and (eql q (1+ i)) - (eql r (- rrad 1))) - collect (list i x q r))) - nil) - -(deftest ceiling.19 - (let* ((radix (float-radix 1.0l0)) - (rad (float radix 1.0l0)) - (rrad (/ 1.0l0 rad))) - (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (ceiling x)) - unless (and (eql q i) - (eql r (- rrad 1))) - collect (list i x q r))) - nil) - -;;; To add: tests that involve adding/subtracting EPSILON constants -;;; (suitably scaled) to floated integers. - - diff --git a/t/ansi-test/numbers/cis.lsp b/t/ansi-test/numbers/cis.lsp deleted file mode 100644 index 0ddcbc5..0000000 --- a/t/ansi-test/numbers/cis.lsp +++ /dev/null @@ -1,51 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Sep 6 18:42:15 2003 -;;;; Contains: Tests of CIS - - - - - -(deftest cis.error.1 - (signals-error (cis) program-error) - t) - -(deftest cis.error.2 - (signals-error (cis 0 nil) program-error) - t) - -(deftest cis.1 - (let ((result (cis 0))) - (or (=t result 1) - (eqlt #c(1.0 0.0)))) - t) - -(deftest cis.2 - (loop for x in '(0.0s0 0.0f0 0.0d0 0.0l0) - for vals = (multiple-value-list (cis x)) - for c = (car vals) - unless (and (= (length vals) 1) - (eql c (complex (float 1 x) x))) - collect (cons x vals)) - nil) - -(deftest cis.3 - (loop for x = (random (* 2 pi)) - for c = (cis x) - repeat 1000 - unless (and (complexp c) - (approx= (imagpart c) (sin x)) - (approx= (realpart c) (cos x))) - collect (list x c (cos x) (sin x))) - nil) - -(deftest cis.4 - (loop for x = (random (coerce (* 2 pi) 'single-float)) - for c = (cis x) - repeat 1000 - unless (and (complexp c) - (approx= (imagpart c) (sin x)) - (approx= (realpart c) (cos x))) - collect (list x c (cos x) (sin x))) - nil) diff --git a/t/ansi-test/numbers/complex.lsp b/t/ansi-test/numbers/complex.lsp deleted file mode 100644 index 277e02a..0000000 --- a/t/ansi-test/numbers/complex.lsp +++ /dev/null @@ -1,61 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Sep 6 19:56:29 2003 -;;;; Contains: Tests of COMPLEX - - - -;;; Error tests - -(deftest complex.error.1 - (signals-error (complex) program-error) - t) - -(deftest complex.error.2 - (signals-error (complex 1 1 nil) program-error) - t) - -;;; Non-error tests - -(deftest complex.1 - (loop for x in *rationals* - for c = (complex x) - always (eql c x)) - t) - -(deftest complex.2 - (loop for x in *floats* - for c = (complex x) - always (and (complexp c) - (eql x (realpart c)) - (eql (float 0 x) (imagpart c)))) - t) - -(deftest complex.3 - (loop for x in *rationals* - for c = (complex 0 x) - unless (or (zerop x) - (and (complexp c) - (eql (realpart c) 0) - (eql (imagpart c) x))) - collect (list c x)) - nil) - -(deftest complex.4 - (loop for x in *floats* - for c = (complex 0 x) - always (and (complexp c) - (eql (float 0 x) (realpart c)) - (eql x (imagpart c)))) - t) - -;;; Tests of some properties of complex numbers - -(deftest complex.5 - (loop for c in *complexes* - unless (loop for type in '(short-float single-float double-float long-float) - always (if (typep (realpart c) type) - (typep (imagpart c) type) - (not (typep (imagpart c) type)))) - collect c) - nil) diff --git a/t/ansi-test/numbers/complexp.lsp b/t/ansi-test/numbers/complexp.lsp deleted file mode 100644 index 0bea7c4..0000000 --- a/t/ansi-test/numbers/complexp.lsp +++ /dev/null @@ -1,22 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Sep 6 21:03:18 2003 -;;;; Contains: Tests for COMPLEXP - - - -(deftest complexp.error.1 - (signals-error (complexp) program-error) - t) - -(deftest complexp.error.2 - (signals-error (complexp 0 0) program-error) - t) - -(deftest complexp.error.3 - (signals-error (complexp #C(1 1) nil) program-error) - t) - -(deftest complexp.1 - (check-type-predicate #'complexp 'complex) - nil) diff --git a/t/ansi-test/numbers/conjugate.lsp b/t/ansi-test/numbers/conjugate.lsp deleted file mode 100644 index f63dad0..0000000 --- a/t/ansi-test/numbers/conjugate.lsp +++ /dev/null @@ -1,67 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Sep 6 21:07:36 2003 -;;;; Contains: Tests of CONJUGATE - - - -;;; Error tests - -(deftest conjugate.error.1 - (signals-error (conjugate) program-error) - t) - -(deftest conjugate.error.2 - (signals-error (conjugate 0 0) program-error) - t) - -;;; Non-error tests - -(deftest conjugate.1 - (loop for x in *reals* - for vals = (multiple-value-list (conjugate x)) - for xc = (car vals) - always (and (= (length vals) 1) - (eql x xc))) - t) - -(deftest conjugate.2 - (loop for x in *complexes* - for vals = (multiple-value-list (conjugate x)) - for xc = (car vals) - always (and (= (length vals) 1) - (eql (realpart x) (realpart xc)) - (eql (- (imagpart x)) (imagpart xc)))) - t) - -(deftest conjugate.3 - (eqlt (conjugate #c(0.0s0 0.0s0)) #c(0.0s0 -0.0s0)) - t) - -(deftest conjugate.4 - (eqlt (conjugate #c(1.0s0 0.0s0)) #c(1.0s0 -0.0s0)) - t) - -(deftest conjugate.5 - (eqlt (conjugate #c(0.0f0 0.0f0)) #c(0.0f0 -0.0f0)) - t) - -(deftest conjugate.6 - (eqlt (conjugate #c(1.0f0 0.0f0)) #c(1.0f0 -0.0f0)) - t) - -(deftest conjugate.7 - (eqlt (conjugate #c(0.0d0 0.0d0)) #c(0.0d0 -0.0d0)) - t) - -(deftest conjugate.8 - (eqlt (conjugate #c(1.0d0 0.0d0)) #c(1.0d0 -0.0d0)) - t) - -(deftest conjugate.9 - (eqlt (conjugate #c(0.0l0 0.0l0)) #c(0.0l0 -0.0l0)) - t) - -(deftest conjugate.10 - (eqlt (conjugate #c(1.0l0 0.0l0)) #c(1.0l0 -0.0l0)) - t) diff --git a/t/ansi-test/numbers/cos.lsp b/t/ansi-test/numbers/cos.lsp deleted file mode 100644 index 823f1cc..0000000 --- a/t/ansi-test/numbers/cos.lsp +++ /dev/null @@ -1,172 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Feb 9 20:53:42 2004 -;;;; Contains: Tests of COS - - - -(deftest cos.1 - (loop for i from -1000 to 1000 - for rlist = (multiple-value-list (cos i)) - for y = (car rlist) - always (and (null (cdr rlist)) - (<= -1 y 1) - (or (rationalp y) (typep y 'single-float)))) - t) - -(deftest cos.2 - (loop for x = (- (random 2000.0s0) 1000.0s0) - for rlist = (multiple-value-list (cos x)) - for y = (car rlist) - repeat 1000 - always (and (null (cdr rlist)) - (<= -1 y 1) - (typep y 'short-float))) - t) - -(deftest cos.3 - (loop for x = (- (random 2000.0f0) 1000.0f0) - for rlist = (multiple-value-list (cos x)) - for y = (car rlist) - repeat 1000 - always (and (null (cdr rlist)) - (<= -1 y 1) - (typep y 'single-float))) - t) - -(deftest cos.4 - (loop for x = (- (random 2000.0d0) 1000.0d0) - for rlist = (multiple-value-list (cos x)) - for y = (car rlist) - repeat 1000 - always (and (null (cdr rlist)) - (<= -1 y 1) - (typep y 'double-float))) - t) - -(deftest cos.5 - (loop for x = (- (random 2000.0l0) 1000.0l0) - for rlist = (multiple-value-list (cos x)) - for y = (car rlist) - repeat 1000 - always (and (null (cdr rlist)) - (<= -1 y 1) - (typep y 'long-float))) - t) - -(deftest cos.6 - (let ((r (cos 0))) - (or (eqlt r 1) (eqlt r 1.0))) - t) - -(deftest cos.7 - (cos 0.0s0) - 1.0s0) - -(deftest cos.8 - (cos 0.0) - 1.0) - -(deftest cos.9 - (cos 0.0d0) - 1.0d0) - -(deftest cos.10 - (cos 0.0l0) - 1.0l0) - -(deftest cos.11 - (loop for i from 1 to 100 - unless (approx= (cos i) (cos (coerce i 'single-float))) - collect i) - nil) - -(deftest cos.12 - (approx= (cos (coerce (/ pi 2) 'single-float)) 0.0) - t) - -(deftest cos.13 - (approx= (cos (coerce (/ pi -2) 'single-float)) 0.0) - t) - -(deftest cos.14 - (approx= (cos (coerce (/ pi 2) 'short-float)) 0s0) - t) - -(deftest cos.15 - (approx= (cos (coerce (/ pi -2) 'short-float)) 0s0) - t) - -(deftest cos.16 - (approx= (cos (coerce (/ pi 2) 'double-float)) 0d0) - t) - -(deftest cos.17 - (approx= (cos (coerce (/ pi -2) 'double-float)) 0d0) - t) - -(deftest cos.18 - (approx= (cos (coerce (/ pi 2) 'long-float)) 0l0) - t) - -(deftest cos.19 - (approx= (cos (coerce (/ pi -2) 'long-float)) 0l0) - t) - -(deftest cos.20 - (loop for r = (- (random 2000) 1000) - for i = (- (random 20) 10) - for y = (cos (complex r i)) - repeat 1000 - always (numberp y)) - t) - -(deftest cos.21 - (loop for r = (- (random 2000.0s0) 1000.0s0) - for i = (- (random 20.0s0) 10.0s0) - for y = (cos (complex r i)) - repeat 1000 - always (numberp y)) - t) - -(deftest cos.22 - (loop for r = (- (random 2000.0f0) 1000.0f0) - for i = (- (random 20.0f0) 10.0f0) - for y = (cos (complex r i)) - repeat 1000 - always (numberp y)) - t) - -(deftest cos.23 - (loop for r = (- (random 2000.0d0) 1000.0d0) - for i = (- (random 20.0d0) 10.0d0) - for y = (cos (complex r i)) - repeat 1000 - always (numberp y)) - t) - -(deftest cos.24 - (loop for r = (- (random 2000.0l0) 1000.0l0) - for i = (- (random 20.0l0) 10.0l0) - for y = (cos (complex r i)) - repeat 1000 - always (numberp y)) - t) - -;;; FIXME -;;; More accuracy tests here - -;;; Error tests - -(deftest cos.error.1 - (signals-error (cos) program-error) - t) - -(deftest cos.error.2 - (signals-error (cos 0.0 0.0) program-error) - t) - -(deftest cos.error.3 - (check-type-error #'cos #'numberp) - nil) - diff --git a/t/ansi-test/numbers/cosh.lsp b/t/ansi-test/numbers/cosh.lsp deleted file mode 100644 index 515dba4..0000000 --- a/t/ansi-test/numbers/cosh.lsp +++ /dev/null @@ -1,95 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Feb 11 06:54:15 2004 -;;;; Contains: Tests of COSH - - - -(deftest cosh.1 - (let ((result (cosh 0))) - (or (eqlt result 1) - (eqlt result 1.0))) - t) - -(deftest cosh.2 - (loop for type in '(short-float single-float double-float long-float) - for zero = (coerce 0 type) - for one = (coerce 1 type) - unless (equal (multiple-value-list (cosh zero)) - (list one)) - collect type) - nil) - -(deftest cosh.3 - (loop for type in '(short-float single-float double-float long-float) - for zero = (coerce 0 `(complex ,type)) - for one = (coerce 1 `(complex ,type)) - unless (equal (multiple-value-list (cosh zero)) - (list one)) - collect type) - nil) - -(deftest cosh.4 - (loop for den = (1+ (random 10000)) - for num = (random (* 10 den)) - for x = (/ num den) - for rlist = (multiple-value-list (cosh x)) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (numberp y)) - collect (list x rlist)) - nil) - -(deftest cosh.5 - (loop for type in '(short-float single-float double-float long-float) - nconc - (loop - for x = (- (random (coerce 20 type)) 10) - for rlist = (multiple-value-list (cosh x)) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (typep y type)) - collect (list x rlist))) - nil) - -(deftest cosh.6 - (loop for type in '(short-float single-float double-float long-float) - nconc - (loop - for x1 = (- (random (coerce 20 type)) 10) - for x2 = (- (random (coerce 20 type)) 10) - for rlist = (multiple-value-list (cosh (complex x1 x2))) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (typep y `(complex ,type))) - collect (list x1 x2 rlist))) - nil) - -;;; FIXME -;;; Add accuracy tests here - -;;; Error tests - -(deftest cosh.error.1 - (signals-error (cosh) program-error) - t) - -(deftest cosh.error.2 - (signals-error (cosh 1.0 1.0) program-error) - t) - -(deftest cosh.error.3 - (check-type-error #'cosh #'numberp) - nil) - - - - - - - - - diff --git a/t/ansi-test/numbers/decf.lsp b/t/ansi-test/numbers/decf.lsp deleted file mode 100644 index 27523a8..0000000 --- a/t/ansi-test/numbers/decf.lsp +++ /dev/null @@ -1,192 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Sep 4 20:50:54 2003 -;;;; Contains: Tests of DECF - - - - - -(deftest decf.1 - (let ((x 12)) - (values - (decf x) - x)) - 11 11) - -(deftest decf.2 - (let ((x 3.0s0)) - (values - (decf x) - x)) - 2.0s0 2.0s0) - -(deftest decf.3 - (let ((x 19.0f0)) - (values - (decf x) - x)) - 18.0f0 18.0f0) - -(deftest decf.4 - (let ((x 813.0d0)) - (values - (decf x) - x)) - 812.0d0 812.0d0) - -(deftest decf.5 - (let ((x -17.0l0)) - (values - (decf x) - x)) - -18.0l0 -18.0l0) - -(deftest decf.6 - (loop for x from 1 to 5 - collect (let ((y x)) - (list (decf y) y))) - ((0 0) (1 1) (2 2) (3 3) (4 4))) - -(deftest decf.7 - (loop for x in '(3.0s0 3.0f0 3.0d0 3.0l0) - collect (let ((y x)) - (list (decf y) y))) - ((2.0s0 2.0s0) (2.0f0 2.0f0) (2.0d0 2.0d0) (2.0l0 2.0l0))) - -(deftest decf.8 - (loop for x in '(3.0s0 3.0f0 3.0d0 3.0f0) - for y = (complex x 0) - for z = (decf y) - for x1c = (complex (1- x) 0) - unless (and (eql y z) (eql x1c y)) - collect (list x y z x1c)) - nil) - -(deftest decf.9 - (let ((x most-negative-fixnum)) - (values (decf x) x)) - #.(1- most-negative-fixnum) #.(1- most-negative-fixnum)) - -(deftest decf.10 - (let ((x (1- most-negative-fixnum))) - (values (decf x) x)) - #.(- most-negative-fixnum 2) #.(- most-negative-fixnum 2)) - -(deftest decf.11 - (loop for x in *numbers* - unless (let* ((y x) - (z (decf y))) - (and (eql y (1- x)) - (eql y z))) - collect x) - nil) - -;;; Increment by other than 1 - -(deftest decf.12 - (loop for x in *numbers* - unless (let* ((y x) (z (decf y 0))) - (and (eql x y) (eql y z))) - collect x) - nil) - -(deftest decf.13 - (loop for x in *numbers* - nconc - (loop for r = (random-from-interval 1000000) - repeat 100 - when (let* ((y x) (z (decf y r))) - (and (not (and (eql (- x r) y) (eql y z))) - (list x y r))) - collect it)) - nil) - -(deftest decf.14 - (let ((x 1)) - (values (decf x 0.0s0) x)) - 1.0s0 1.0s0) - -(deftest decf.15 - (let ((x 1)) - (values (decf x 0.0f0) x)) - 1.0f0 1.0f0) - -(deftest decf.16 - (let ((x 2)) - (values (decf x 0.0d0) x)) - 2.0d0 2.0d0) - -(deftest decf.17 - (let ((x 10)) - (values (decf x 0.0l0) x)) - 10.0l0 10.0l0) - -(deftest decf.18 - (let ((x 1)) - (values (decf x #c(0.0s0 10.0s0)) x)) - #c(1.0s0 -10.0s0) #c(1.0s0 -10.0s0)) - -(deftest decf.19 - (let ((x 1)) - (values (decf x #c(0.0f0 2.0f0)) x)) - #c(1.0f0 -2.0f0) #c(1.0f0 -2.0f0)) - -(deftest decf.20 - (let ((x 1)) - (values (decf x #c(0.0d0 2.0d0)) x)) - #c(1.0d0 -2.0d0) #c(1.0d0 -2.0d0)) - -(deftest decf.21 - (let ((x 1)) - (values (decf x #c(0.0l0 -2.0l0)) x)) - #c(1.0l0 2.0l0) #c(1.0l0 2.0l0)) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest decf.22 - (macrolet - ((%m (z) z)) - (let ((x 10)) - (values - (decf (expand-in-current-env (%m x))) - x))) - 9 9) - -(deftest decf.23 - (macrolet - ((%m (z) z)) - (let ((x 5)) - (values - (decf x (expand-in-current-env (%m 3))) - x))) - 2 2) - -(deftest decf.order.2 - (let ((a (vector 1 2 3 4)) - (i 0) x y z) - (values - (decf (aref (progn (setf x (incf i)) a) - (progn (setf y (incf i)) 0)) - (progn (setf z (incf i)) 17)) - i x y z a)) - -16 3 1 2 3 #(-16 2 3 4)) - -(deftest decf.order.3 - (let ((a (vector 10 2 3 4)) - (i 0) x y) - (values - (decf (aref (progn (setf x (incf i)) a) - (progn (setf y (incf i)) 0))) - i x y a)) - 9 2 1 2 #(9 2 3 4)) - -(deftest decf.order.4 - (let ((x 0)) - (progn - "See CLtS 5.1.3" - (values - (decf x (setf x 1)) - x))) - 0 0) diff --git a/t/ansi-test/numbers/deposit-field.lsp b/t/ansi-test/numbers/deposit-field.lsp deleted file mode 100644 index 7335f00..0000000 --- a/t/ansi-test/numbers/deposit-field.lsp +++ /dev/null @@ -1,84 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Sep 11 20:23:15 2003 -;;;; Contains: Tests of DEPOSIT-FIELD - - - -;;; Error tests - -(deftest deposit-field.error.1 - (signals-error (deposit-field) program-error) - t) - -(deftest deposit-field.error.2 - (signals-error (deposit-field 1) program-error) - t) - -(deftest deposit-field.error.3 - (signals-error (deposit-field 1 (byte 1 0)) program-error) - t) - -(deftest deposit-field.error.4 - (signals-error (deposit-field 1 (byte 1 0) 0 nil) program-error) - t) - -;;; Non-error tests - -(deftest deposit-field.1 - (loop for pos = (random 32) - for size = (random 32) - for newbyte = (random (ash 1 (+ pos size))) - for val = (random (1+ (random (ash 1 (+ pos size))))) - for result = (deposit-field newbyte (byte size pos) val) - repeat 100 - unless - (loop for i from 0 to (+ pos size) - always (if (or (< i pos) - (>= i (+ pos size))) - (if (logbitp i val) (logbitp i result) - (not (logbitp i result))) - (if (logbitp i newbyte) (logbitp i result) - (not (logbitp i result))))) - collect (list pos size newbyte val result)) - nil) - -(deftest deposit-field.2 - (loop for pos = (random 1000) - for size = (random 1000) - for newbyte = (random (ash 1 (+ pos size))) - for val = (random (1+ (random (ash 1 (+ pos size))))) - for result = (deposit-field newbyte (byte size pos) val) - repeat 100 - unless - (loop for i from 0 to (+ pos size) - always (if (or (< i pos) - (>= i (+ pos size))) - (if (logbitp i val) (logbitp i result) - (not (logbitp i result))) - (if (logbitp i newbyte) (logbitp i result) - (not (logbitp i result))))) - collect (list pos size newbyte val result)) - nil) - -(deftest deposit-field.3 - (loop for x = (random-fixnum) - for y = (random-fixnum) - for pos = (random 32) - repeat 100 - always (= (deposit-field x (byte 0 pos) y) y)) - t) - -(deftest deposit-field.4 - (let ((bound (ash 1 200))) - (loop for x = (random-from-interval bound) - for y = (random-from-interval bound) - for pos = (random 200) - repeat 100 - always (= (deposit-field x (byte 0 pos) y) y))) - t) - -(deftest deposit-field.5 - (loop for i of-type fixnum from -1000 to 1000 - always (eql (deposit-field -1 (byte 0 0) i) i)) - t) diff --git a/t/ansi-test/numbers/divide.lsp b/t/ansi-test/numbers/divide.lsp deleted file mode 100644 index 0058553..0000000 --- a/t/ansi-test/numbers/divide.lsp +++ /dev/null @@ -1,217 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Aug 31 20:20:15 2003 -;;;; Contains: Tests of the / function - - - - - - -(deftest /.error.1 - (signals-error (/) program-error) - t) - -(deftest /.error.2 - (divide-by-zero-test 0)) - -(deftest /.error.3 - (divide-by-zero-test 1 0)) - -(deftest /.error.4 - (divide-by-zero-test 17 10 0 11)) - -(deftest /.error.5 - (divide-by-zero-test 0.0s0)) - -(deftest /.error.6 - (divide-by-zero-test 0.0f0)) - -(deftest /.error.7 - (divide-by-zero-test 0.0d0)) - -(deftest /.error.8 - (divide-by-zero-test 0.0l0)) - -;;;;;;;;;; - -(deftest /.1 - (/ 1) - 1) - -(deftest /.2 - (/ -1) - -1) - -(deftest /.3 - (loop for i = (random-fixnum) - repeat 1000 - unless (or (zerop i) - (let ((q1 (/ i)) - (q2 (/ 1 i))) - (and (rationalp q1) - (eql (denominator q1) (abs i)) - (eql (numerator q1) (signum i)) - (eql q1 q2) - (eql (* q1 i) 1)))) - collect i) - nil) - -(deftest /.4 - (loop for i = (random-from-interval 1000000 1) - for j = (random-from-interval 1000000 1) - for g = (gcd i j) - for q = (/ i j) - for q2 = (/ j) - repeat 1000 - unless (and (integerp g) - (zerop (mod i g)) - (zerop (mod j g)) - (eql (numerator q) (/ i g)) - (eql (denominator q) (/ j g)) - (eql (/ q) (/ j i)) - (eql q (* i q2))) - collect (list i j q)) - nil) - -(deftest /.5 - (loop for bound in (list 1.0s5 1.0f10 1.0d20 1.0l20) - nconc - (loop for i = (1+ (random bound)) - for r1 = (/ i) - for r2 = (/ 1 i) - repeat 1000 - unless (eql r1 r2) - collect (list i r1 r2))) - nil) - -;; Complex division -(deftest /.6 - (loop for i1 = (random-fixnum) - for i = (if (zerop i1) 1 i1) - for c = (complex 0 i) - for r = (/ c) - repeat 1000 - unless (eql r (complex 0 (- (/ i)))) - collect (list i c r)) - nil) - -#| -(deftest /.7 - (loop for bound in (list 1.0s5 1.0f10 1.0d20 1.0l20) - nconc - (loop for i = (1+ (random bound)) - for c = (complex 0 i) - for r = (/ c) - repeat 1000 - unless (= r (complex 0 (- (/ i)))) - collect (list i c r (complex 0 (- (/ i)))))) - nil) -|# - -(deftest /.8 - (loop for bound in (list 1.0s5 1.0f10 1.0d20 1.0l20) - for one = (float 1.0 bound) - for zero = (float 0.0 bound) - nconc - (loop for i = (1+ (random bound)) - for c = (complex i zero) - for q = (/ c c) - repeat 100 - unless (eql q (complex one zero)) - collect (list i c q (complex one zero)))) - nil) - - -(deftest /.9 - (loop for a = (random-fixnum) - for b = (random-fixnum) - for m = (+ (* a a) (* b b)) - repeat 1000 - unless - (or (zerop m) - (let* ((q (/ (complex a b))) - (c (/ a m)) - (d (/ (- b) m)) - (expected (complex c d))) - (eql q expected))) - collect (list a b (/ (complex a b)))) - nil) - -(deftest /.10 - (let ((bound 1000000000000000000)) - (loop for a = (random-from-interval bound) - for b = (random-from-interval bound) - for m = (+ (* a a) (* b b)) - repeat 1000 - unless - (or (zerop m) - (let* ((q (/ (complex a b))) - (c (/ a m)) - (d (/ (- b) m)) - (expected (complex c d))) - (eql q expected))) - collect (list a b (/ (complex a b))))) - nil) - -(deftest /.11 - (loop for a = (random-fixnum) - for b = (random-fixnum) - for n = (complex (random-fixnum) (random-fixnum)) - for m = (+ (* a a) (* b b)) - repeat 1000 - unless - (or (zerop m) - (let* ((q (/ n (complex a b))) - (c (/ a m)) - (d (/ (- b) m)) - (expected (* n (complex c d)))) - (eql q expected))) - collect (list a b (/ n (complex a b)))) - nil) - -;;; More floating point tests - -(deftest /.12 - (loop for type in '(short-float single-float double-float long-float) - for lower in (mapcar - #'rational-safely - (list - least-positive-short-float least-positive-single-float - least-positive-double-float least-positive-long-float)) - for upper in (mapcar - #'rational-safely - (list - most-positive-short-float most-positive-single-float - most-positive-double-float most-positive-long-float)) - for one = (coerce 1 type) - for radix = (float-radix one) - nconc - (loop - for i from 1 - for rpos = radix then (* rpos radix) - for rneg = (/ radix) then (/ rneg radix) - while (<= lower rneg rpos upper) - unless - (let ((frpos (float rpos one)) - (frneg (float rneg one))) - (and (eql (/ frpos) (/ one frpos)) - (eql (/ frpos) (/ 1.0s0 frpos)) - (eql (/ frpos) (/ 1 frpos)) - (eql (/ frpos) frneg) - (eql (/ frneg) (/ 1.0s0 frneg)) - (eql (/ frneg) (/ 1 frneg)) - (eql (/ frneg) frpos))) - collect (list i rpos rneg (float rpos one) (float rneg one)))) - nil) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest /.13 - (macrolet ((%m (z) z)) - (values - (/ (expand-in-current-env (%m 1/2))) - (/ (expand-in-current-env (%m 2)) 3) - (/ 5 (expand-in-current-env (%m 7))))) - 2 2/3 5/7) diff --git a/t/ansi-test/numbers/dpb.lsp b/t/ansi-test/numbers/dpb.lsp deleted file mode 100644 index de56802..0000000 --- a/t/ansi-test/numbers/dpb.lsp +++ /dev/null @@ -1,84 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Sep 11 20:43:54 2003 -;;;; Contains: Tests of DPB - - - -;;; Error tests - -(deftest dpb.error.1 - (signals-error (dpb) program-error) - t) - -(deftest dpb.error.2 - (signals-error (dpb 1) program-error) - t) - -(deftest dpb.error.3 - (signals-error (dpb 1 (byte 1 0)) program-error) - t) - -(deftest dpb.error.4 - (signals-error (dpb 1 (byte 1 0) 0 nil) program-error) - t) - -;;; Non-error tests - -(deftest dpb.1 - (loop for pos = (random 32) - for size = (random 32) - for newbyte = (random (ash 1 (+ pos size))) - for val = (random (1+ (random (ash 1 (+ pos size))))) - for result = (dpb newbyte (byte size pos) val) - repeat 100 - unless - (loop for i from 0 to (+ pos size) - always (if (or (< i pos) - (>= i (+ pos size))) - (if (logbitp i val) (logbitp i result) - (not (logbitp i result))) - (if (logbitp (- i pos) newbyte) (logbitp i result) - (not (logbitp i result))))) - collect (list pos size newbyte val result)) - nil) - -(deftest dpb.2 - (loop for pos = (random 1000) - for size = (random 1000) - for newbyte = (random (ash 1 (+ pos size))) - for val = (random (1+ (random (ash 1 (+ pos size))))) - for result = (dpb newbyte (byte size pos) val) - repeat 100 - unless - (loop for i from 0 to (+ pos size) - always (if (or (< i pos) - (>= i (+ pos size))) - (if (logbitp i val) (logbitp i result) - (not (logbitp i result))) - (if (logbitp (- i pos) newbyte) (logbitp i result) - (not (logbitp i result))))) - collect (list pos size newbyte val result)) - nil) - -(deftest dpb.3 - (loop for x = (random-fixnum) - for y = (random-fixnum) - for pos = (random 32) - repeat 100 - always (= (dpb x (byte 0 pos) y) y)) - t) - -(deftest dpb.4 - (let ((bound (ash 1 200))) - (loop for x = (random-from-interval bound) - for y = (random-from-interval bound) - for pos = (random 200) - repeat 100 - always (= (dpb x (byte 0 pos) y) y))) - t) - -(deftest dpb.5 - (loop for i of-type fixnum from -1000 to 1000 - always (eql (dpb -1 (byte 0 0) i) i)) - t) diff --git a/t/ansi-test/numbers/epsilons.lsp b/t/ansi-test/numbers/epsilons.lsp deleted file mode 100644 index 9f4a766..0000000 --- a/t/ansi-test/numbers/epsilons.lsp +++ /dev/null @@ -1,126 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Aug 20 22:05:20 2003 -;;;; Contains: Tests of the EPSILON constants - - - - - -(deftest epsilons.1 - (loop for e in (list short-float-epsilon single-float-epsilon - double-float-epsilon long-float-epsilon) - when (= (float 1 e) (+ (float 1 e) e)) - collect e) - nil) - -(deftest epsilons.2 - (loop for e in (list short-float-negative-epsilon - single-float-negative-epsilon - double-float-negative-epsilon - long-float-negative-epsilon) - when (= (float 1 e) (- (float 1 e) e)) - collect e) - nil) - -(deftest epsilons.3 - (loop for e in (list short-float-epsilon single-float-epsilon - double-float-epsilon long-float-epsilon) - unless (= (float 1 e) (+ (float 1 e) (/ e 2))) - collect e) - nil) - -(deftest epsilons.4 - (loop for e in (list short-float-negative-epsilon - single-float-negative-epsilon - double-float-negative-epsilon - long-float-negative-epsilon) - unless (= (float 1 e) (- (float 1 e) (/ e 2))) - collect e) - nil) - -(deftest epsilons.5 - (loop for (type var) in - '( - (short-float short-float-epsilon) - (short-float short-float-negative-epsilon) - (single-float single-float-epsilon) - (single-float single-float-negative-epsilon) - (double-float double-float-epsilon) - (double-float double-float-negative-epsilon) - (long-float long-float-epsilon) - (long-float long-float-negative-epsilon)) - for val = (symbol-value var) - unless (typep val type) - collect (list type var val)) - nil) - -(deftest epsilons.6 - (flet ((%check (x) (/= 1.0s0 (+ 1.0s0 x)))) - (let ((eps (float-binary-search #'%check 0.0s0 1.0s0))) - (if (= eps short-float-epsilon) - :good - (list eps short-float-epsilon)))) - :good) - -(deftest epsilons.7 - (flet ((%check (x) (/= 1.0f0 (+ 1.0f0 x)))) - (let ((eps (float-binary-search #'%check 0.0f0 1.0f0))) - (if (= eps single-float-epsilon) - :good - (list eps single-float-epsilon)))) - :good) - -(deftest epsilons.8 - (flet ((%check (x) (/= 1.0d0 (+ 1.0d0 x)))) - (let ((eps (float-binary-search #'%check 0.0d0 1.0d0))) - (if (= eps double-float-epsilon) - :good - (list eps double-float-epsilon)))) - :good) - -(deftest epsilons.9 - (flet ((%check (x) (/= 1.0l0 (+ 1.0l0 x)))) - (let ((eps (float-binary-search #'%check 0.0l0 1.0l0))) - (if (= eps long-float-epsilon) - :good - (list eps long-float-epsilon)))) - :good) - -(deftest epsilons.10 - (flet ((%check (x) (/= 1.0s0 (- 1.0s0 x)))) - (let ((eps (float-binary-search #'%check 0.0s0 1.0s0))) - (if (= eps short-float-negative-epsilon) - :good - (list eps short-float-negative-epsilon)))) - :good) - -(deftest epsilons.11 - (flet ((%check (x) (/= 1.0f0 (- 1.0f0 x)))) - (let ((eps (float-binary-search #'%check 0.0f0 1.0f0))) - (if (= eps single-float-negative-epsilon) - :good - (list eps single-float-negative-epsilon)))) - :good) - -(deftest epsilons.12 - (flet ((%check (x) (/= 1.0d0 (- 1.0d0 x)))) - (let ((eps (float-binary-search #'%check 0.0d0 1.0d0))) - (if (= eps double-float-negative-epsilon) - :good - (list eps double-float-negative-epsilon)))) - :good) - -(deftest epsilons.13 - (flet ((%check (x) (/= 1.0l0 (- 1.0l0 x)))) - (let ((eps (float-binary-search #'%check 0.0l0 1.0l0))) - (if (= eps long-float-negative-epsilon) - :good - (list eps long-float-negative-epsilon)))) - :good) - - - - - - diff --git a/t/ansi-test/numbers/evenp.lsp b/t/ansi-test/numbers/evenp.lsp deleted file mode 100644 index 62e835e..0000000 --- a/t/ansi-test/numbers/evenp.lsp +++ /dev/null @@ -1,76 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Aug 31 10:39:01 2003 -;;;; Contains: Tests of EVENP - - - - - -(deftest evenp.error.1 - (signals-error (evenp) program-error) - t) - -(deftest evenp.error.2 - (signals-error (evenp 0 nil) program-error) - t) - -(deftest evenp.error.3 - (check-type-error #'evenp #'integerp) - nil) - -(deftest evenp.1 - (loop for x in *numbers* - when (integerp x) - do (evenp x)) - nil) - -(deftest evenp.3 - (loop for x = (random-fixnum) - repeat 10000 - when (or - (not (evenp (+ x x))) - (evenp (+ x x 1)) - (if (evenp x) - (or (evenp (1+ x)) - (evenp (1- x)) - (/= (mod x 2) 0)) - (or (not (evenp (1+ x))) - (not (evenp (1- x))) - (= (mod x 2) 0)))) - collect x) - nil) - -(deftest evenp.4 - (let ((upper-bound 1000000000000000) - (lower-bound -1000000000000000)) - (loop for x = (random-from-interval upper-bound lower-bound) - repeat 10000 - when (or - (not (evenp (+ x x))) - (evenp (+ x x 1)) - (if (evenp x) - (or (evenp (1+ x)) - (evenp (1- x)) - (/= (mod x 2) 0)) - (or (not (evenp (1+ x))) - (not (evenp (1- x))) - (= (mod x 2) 0)))) - collect x)) - nil) - -(deftest evenp.5 - (notnot-mv (evenp 0)) - t) - -(deftest evenp.6 - (evenp 1) - nil) - -(deftest evenp.7 - (notnot-mv (evenp 100000000000000000000000000000000)) - t) - -(deftest evenp.8 - (evenp 100000000000000000000000000000001) - nil) diff --git a/t/ansi-test/numbers/exp.lsp b/t/ansi-test/numbers/exp.lsp deleted file mode 100644 index 83ed956..0000000 --- a/t/ansi-test/numbers/exp.lsp +++ /dev/null @@ -1,82 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Sep 1 21:24:44 2003 -;;;; Contains: Tests of EXP - - - - - - -;;; Error tests - -(deftest exp.error.1 - (signals-error (exp) program-error) - t) - -(deftest exp.error.2 - (signals-error (exp 0 nil) program-error) - t) - -(deftest exp.error.3 - (signals-error (exp 0 0 0) program-error) - t) - -;;; Other tests - -(deftest exp.1 - (let ((result (exp 0))) - (or (eqlt result 1) - (eqlt result 1.0f0))) - t) - -(deftest exp.2 - (mapcar #'exp '(0.0s0 0.0f0 0.0d0 0.0l0)) - (1.0s0 1.0f0 1.0d0 1.0l0)) - -(deftest exp.3 - (mapcar #'exp '(-0.0s0 -0.0f0 -0.0d0 -0.0l0)) - (1.0s0 1.0f0 1.0d0 1.0l0)) - -;;; FIXME -;;; Add more tests here for floating point accuracy - -(deftest exp.error.4 - (signals-error (exp (+ (log most-positive-short-float) 100)) - floating-point-overflow) - t) - -(deftest exp.error.5 - (signals-error (exp (+ (log most-positive-single-float) 100)) - floating-point-overflow) - t) - -(deftest exp.error.6 - (signals-error (exp (+ (log most-positive-double-float) 100)) - floating-point-overflow) - t) - -(deftest exp.error.7 - (signals-error (exp (+ (log most-positive-long-float) 100)) - floating-point-overflow) - t) - -(deftest exp.error.8 - (signals-error (exp (- (log least-positive-short-float) 100)) - floating-point-underflow) - t) - -(deftest exp.error.9 - (signals-error (exp (- (log least-positive-single-float) 100)) - floating-point-underflow) - t) - -(deftest exp.error.10 - (signals-error (exp (- (log least-positive-double-float) 100)) - floating-point-underflow) - t) - -(deftest exp.error.11 - (signals-error (exp (- (log least-positive-double-float) 100)) - floating-point-underflow) - t) diff --git a/t/ansi-test/numbers/expt.lsp b/t/ansi-test/numbers/expt.lsp deleted file mode 100644 index 50ddde8..0000000 --- a/t/ansi-test/numbers/expt.lsp +++ /dev/null @@ -1,255 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Sep 2 19:36:22 2003 -;;;; Contains: Tests of EXPT - - - -;;; Error tests - -(deftest expt.error.1 - (signals-error (expt) program-error) - t) - -(deftest expt.error.2 - (signals-error (expt 1 1 1) program-error) - t) - -(deftest expt.error.3 - (signals-error (expt 1 1 nil nil) program-error) - t) - -(deftest expt.error.4 - (signals-error (expt most-positive-short-float 2) floating-point-overflow) - t) - -(deftest expt.error.5 - (signals-error (expt most-positive-single-float 2) floating-point-overflow) - t) - -(deftest expt.error.6 - (signals-error (expt most-positive-double-float 2) floating-point-overflow) - t) - -(deftest expt.error.7 - (signals-error (expt most-positive-long-float 2) floating-point-overflow) - t) - -(deftest expt.error.8 - (signals-error (expt least-positive-short-float 2) floating-point-underflow) - t) - -(deftest expt.error.9 - (signals-error (expt least-positive-single-float 2) floating-point-underflow) - t) - -(deftest expt.error.10 - (signals-error (expt least-positive-double-float 2) floating-point-underflow) - t) - -(deftest expt.error.11 - (signals-error (expt least-positive-long-float 2) floating-point-underflow) - t) - - - - -;;; Non-error tests - -(deftest expt.1 - (expt 0 0) - 1) - -(deftest expt.2 - (loop for i from -1000 to 1000 - always (eql (expt i 0) 1)) - t) - -(deftest expt.3 - (loop for i = (random 1.0s3) - repeat 1000 - always (eql (expt i 0) 1.0s0)) - t) - -(deftest expt.4 - (loop for i = (random 1.0f6) - repeat 1000 - always (eql (expt i 0) 1.0f0)) - t) - -(deftest expt.5 - (loop for i = (random 1.0d10) - repeat 1000 - always (eql (expt i 0) 1.0d0)) - t) - -(deftest expt.6 - (loop for i = (random 1.0l10) - repeat 1000 - always (eql (expt i 0) 1.0l0)) - t) - -(deftest expt.7 - (loop for i from -1000 to 1000 - for c = (complex i i) - always (eql (expt c 0) 1)) - t) - -(deftest expt.8 - (loop for i = (random 1.0s3) - for c = (complex i i) - repeat 1000 - always (eql (expt c 0) #c(1.0s0 0.0s0))) - t) - -(deftest expt.9 - (loop for i = (random 1.0f6) - for c = (complex i i) - repeat 1000 - always (eql (expt c 0) #c(1.0f0 0.0f0))) - t) - -(deftest expt.10 - (loop for i = (random 1.0d10) - for c = (complex i i) - repeat 1000 - always (eql (expt c 0) #c(1.0d0 0.0d0))) - t) - -(deftest expt.11 - (loop for i = (random 1.0l10) - for c = (complex i i) - repeat 1000 - always (eql (expt c 0) #c(1.0l0 0.0l0))) - t) - -(deftest expt.12 - (loop for x in *numbers* - unless (or (floatp (realpart x)) - (eql (expt x 1) x)) - collect x) - nil) - -(deftest expt.13 - (loop for x in *rationals* - unless (and (eql (expt x 2) (* x x)) - (or (zerop x) - (eql (expt x -1) (/ x)))) - collect x) - nil) - -(deftest expt.14 - (expt #c(0 2) 2) - -4) - -(deftest expt.15 - (expt #c(1 1) 2) - #c(0 2)) - -(deftest expt.16 - (expt #c(1/2 1/3) 3) - #c(-1/24 23/108)) - -(deftest expt.17 - (expt #c(1 1) -2) - #c(0 -1/2)) - -(deftest expt.18 - (loop - for zero in '(0.0s0 0.0f0 0.0d0 0.0l0) - always - (loop for i from -1000 to 1000 - always (or (zerop i) - (eql (expt i zero) (float 1 zero))))) - t) - -(deftest expt.19 - (loop - for zero in '(0.0s0 0.0f0 0.0d0 0.0l0) - always - (loop for i from -1000 to 1000 - always (or (zerop i) - (eql (expt (float i 0.0s0) zero) (float 1 zero))))) - t) - -(deftest expt.20 - (loop - for zero in '(0.0f0 0.0d0 0.0l0) - always - (loop for i from -1000 to 1000 - always (or (zerop i) - (eql (expt (float i 0.0f0) zero) (float 1 zero))))) - t) - -(deftest expt.21 - (loop - for zero in '(0.0d0 0.0l0) - always - (loop for i from -1000 to 1000 - always (or (zerop i) - (eql (expt (float i 0.0d0) zero) (float 1 zero))))) - t) - -(deftest expt.22 - (expt 2.0f0 0.0s0) - 1.0f0) - -(deftest expt.23 - (expt 2.0d0 0.0s0) - 1.0d0) - -(deftest expt.24 - (expt 2.0l0 0.0s0) - 1.0l0) - -(deftest expt.25 - (expt 2.0d0 0.0f0) - 1.0d0) - -(deftest expt.26 - (expt 2.0l0 0.0f0) - 1.0l0) - -(deftest expt.27 - (expt 2.0l0 0.0d0) - 1.0l0) - -(deftest expt.28 - (<= (realpart (expt -8 1/3)) 0.0) - nil) - -#| -;;; FIXME -;;; I need to think more about how to do approximate float -;;; equality in a principled way. - -(deftest expt.29 - (loop for bound in '(1.0s4 1.0f6 1.0d8 1.0l8) - for ebound in (list short-float-epsilon single-float-epsilon - double-float-epsilon long-float-epsilon) - for ebound2 = (max (* 2 ebound) (/ bound)) - nconc - (loop for x = (1+ (random 1.0f6)) - for s1 = (sqrt x) - for s2 = (expt x 1/2) - for error = (/ (abs (- s2 s2)) x) - repeat 1000 - unless (< error ebound2) - collect (list x s1 s2))) - nil) - -(deftest expt.30 - (loop for bound in '(1.0s4 1.0f6 1.0d8 1.0l8) - for ebound in (list short-float-epsilon single-float-epsilon - double-float-epsilon long-float-epsilon) - for ebound2 = (max (* 2 ebound) (/ bound)) - nconc - (loop for x = (- (1+ (random 1.0f6))) - for s1 = (sqrt x) - for s2 = (expt x 1/2) - for error = (/ (abs (- s2 s2)) x) - repeat 1000 - unless (< error ebound2) - collect (list x s1 s2))) - nil) -|# diff --git a/t/ansi-test/numbers/fceiling.lsp b/t/ansi-test/numbers/fceiling.lsp deleted file mode 100644 index 1a7303f..0000000 --- a/t/ansi-test/numbers/fceiling.lsp +++ /dev/null @@ -1,147 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Aug 20 06:22:23 2003 -;;;; Contains: Tests of FCEILING - - - - - - -(deftest fceiling.error.1 - (signals-error (fceiling) program-error) - t) - -(deftest fceiling.error.2 - (signals-error (fceiling 1.0 1 nil) program-error) - t) - -;;; - -(deftest fceiling.1 - (fceiling.1-fn) - nil) - -(deftest fceiling.10 - (loop for x in (remove-if #'zerop *reals*) - for (q r) = (multiple-value-list (fceiling x x)) - unless (and (floatp q) - (if (floatp x) - (eql q (float 1 x)) - (= q 1)) - (zerop r) - (if (floatp x) - (eql r (float 0 x)) - (= r 0))) - collect x) - nil) - -(deftest fceiling.11 - (loop for x in (remove-if-not #'floatp (remove-if #'zerop *reals*)) - for (q r) = (multiple-value-list (fceiling (- x) x)) - unless (and (floatp q) - (if (floatp x) - (eql q (float -1 x)) - (= q -1)) - (zerop r) - (if (floatp x) - (eql r (float 0 x)) - (= r 0))) - collect x) - nil) - -(deftest fceiling.12 - (let* ((radix (float-radix 1.0s0)) - (rad (float radix 1.0s0)) - (rrad (/ 1.0s0 rad))) - (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (fceiling x)) - unless (and (eql q (coerce (1+ i) 'short-float)) - (eql r (- rrad 1))) - collect (list i x q r))) - nil) - -(deftest fceiling.13 - (let* ((radix (float-radix 1.0s0)) - (rad (float radix 1.0s0)) - (rrad (/ 1.0s0 rad))) - (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (fceiling x)) - unless (and (eql q (coerce i 'short-float)) - (eql r (- rrad 1))) - collect (list i x q r))) - nil) - -(deftest fceiling.14 - (let* ((radix (float-radix 1.0f0)) - (rad (float radix 1.0f0)) - (rrad (/ 1.0f0 rad))) - (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (fceiling x)) - unless (and (eql q (coerce (1+ i) 'single-float)) - (eql r (- rrad 1))) - collect (list i x q r))) - nil) - -(deftest fceiling.15 - (let* ((radix (float-radix 1.0f0)) - (rad (float radix 1.0f0)) - (rrad (/ 1.0f0 rad))) - (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (fceiling x)) - unless (and (eql q (coerce i 'single-float)) - (eql r (- rrad 1))) - collect (list i x q r))) - nil) - -(deftest fceiling.16 - (let* ((radix (float-radix 1.0d0)) - (rad (float radix 1.0d0)) - (rrad (/ 1.0d0 rad))) - (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (fceiling x)) - unless (and (eql q (coerce (1+ i) 'double-float)) - (eql r (- rrad 1))) - collect (list i x q r))) - nil) - -(deftest fceiling.17 - (let* ((radix (float-radix 1.0d0)) - (rad (float radix 1.0d0)) - (rrad (/ 1.0d0 rad))) - (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (fceiling x)) - unless (and (eql q (coerce i 'double-float)) - (eql r (- rrad 1))) - collect (list i x q r))) - nil) - -(deftest fceiling.18 - (let* ((radix (float-radix 1.0l0)) - (rad (float radix 1.0l0)) - (rrad (/ 1.0l0 rad))) - (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (fceiling x)) - unless (and (eql q (coerce (1+ i) 'long-float)) - (eql r (- rrad 1))) - collect (list i x q r))) - nil) - -(deftest fceiling.19 - (let* ((radix (float-radix 1.0l0)) - (rad (float radix 1.0l0)) - (rrad (/ 1.0l0 rad))) - (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (fceiling x)) - unless (and (eql q (coerce i 'long-float)) - (eql r (- rrad 1))) - collect (list i x q r))) - nil) diff --git a/t/ansi-test/numbers/ffloor.lsp b/t/ansi-test/numbers/ffloor.lsp deleted file mode 100644 index c07cfac..0000000 --- a/t/ansi-test/numbers/ffloor.lsp +++ /dev/null @@ -1,150 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Aug 12 06:59:54 2003 -;;;; Contains: Tests of FFLOOR - - - - - - -(deftest ffloor.error.1 - (signals-error (ffloor) program-error) - t) - -(deftest ffloor.error.2 - (signals-error (ffloor 1.0 1 nil) program-error) - t) - -;;; - -(deftest ffloor.1 - (ffloor.1-fn) - nil) - -(deftest ffloor.10 - (loop for x in (remove-if #'zerop *reals*) - for (q r) = (multiple-value-list (ffloor x x)) - unless (and (floatp q) - (if (floatp x) - (eql q (float 1 x)) - (= q 1)) - (zerop r) - (if (floatp x) - (eql r (float 0 x)) - (= r 0))) - collect x) - nil) - -(deftest ffloor.11 - (loop for x in (remove-if-not #'floatp (remove-if #'zerop *reals*)) - for (q r) = (multiple-value-list (ffloor (- x) x)) - unless (and (floatp q) - (if (floatp x) - (eql q (float -1 x)) - (= q -1)) - (zerop r) - (if (floatp x) - (eql r (float 0 x)) - (= r 0))) - collect x) - nil) - -(deftest ffloor.12 - (let* ((radix (float-radix 1.0s0)) - (rad (float radix 1.0s0)) - (rrad (/ 1.0s0 rad))) - (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (ffloor x)) - unless (and (eql q (coerce i 'short-float)) - (eql r rrad)) - collect (list i x q r))) - nil) - -(deftest ffloor.13 - (let* ((radix (float-radix 1.0s0)) - (rad (float radix 1.0s0)) - (rrad (/ 1.0s0 rad))) - (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (ffloor x)) - unless (and (eql q (coerce (1- i) 'short-float)) - (eql r rrad)) - collect (list i x q r))) - nil) - -(deftest ffloor.14 - (let* ((radix (float-radix 1.0f0)) - (rad (float radix 1.0f0)) - (rrad (/ 1.0f0 rad))) - (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (ffloor x)) - unless (and (eql q (coerce i 'single-float)) - (eql r rrad)) - collect (list i x q r))) - nil) - -(deftest ffloor.15 - (let* ((radix (float-radix 1.0f0)) - (rad (float radix 1.0f0)) - (rrad (/ 1.0f0 rad))) - (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (ffloor x)) - unless (and (eql q (coerce (1- i) 'single-float)) - (eql r rrad)) - collect (list i x q r))) - nil) - -(deftest ffloor.16 - (let* ((radix (float-radix 1.0d0)) - (rad (float radix 1.0d0)) - (rrad (/ 1.0d0 rad))) - (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (ffloor x)) - unless (and (eql q (coerce i 'double-float)) - (eql r rrad)) - collect (list i x q r))) - nil) - -(deftest ffloor.17 - (let* ((radix (float-radix 1.0d0)) - (rad (float radix 1.0d0)) - (rrad (/ 1.0d0 rad))) - (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (ffloor x)) - unless (and (eql q (coerce (1- i) 'double-float)) - (eql r rrad)) - collect (list i x q r))) - nil) - -(deftest ffloor.18 - (let* ((radix (float-radix 1.0l0)) - (rad (float radix 1.0l0)) - (rrad (/ 1.0l0 rad))) - (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (ffloor x)) - unless (and (eql q (coerce i 'long-float)) - (eql r rrad)) - collect (list i x q r))) - nil) - -(deftest ffloor.19 - (let* ((radix (float-radix 1.0l0)) - (rad (float radix 1.0l0)) - (rrad (/ 1.0l0 rad))) - (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (ffloor x)) - unless (and (eql q (coerce (1- i) 'long-float)) - (eql r rrad)) - collect (list i x q r))) - nil) - -;;; To add: tests that involve adding/subtracting EPSILON constants -;;; (suitably scaled) to floated integers. diff --git a/t/ansi-test/numbers/float.lsp b/t/ansi-test/numbers/float.lsp deleted file mode 100644 index 58108dd..0000000 --- a/t/ansi-test/numbers/float.lsp +++ /dev/null @@ -1,103 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Sep 11 21:53:51 2003 -;;;; Contains: Tests of FLOAT - - - -(deftest float.error.1 - (signals-error (float) program-error) - t) - -(deftest float.error.2 - (signals-error (float 0 0.0 nil) program-error) - t) - -;;; - -(deftest float.1 - (notnot (member (float 0) '(0.0f0 -0.0f0))) - t) - -(deftest float.2 - (float 1) - 1.0f0) - -(deftest float.3 - (float -1) - -1.0f0) - -(deftest float.4 - (loop for i from -1000 to 1000 - always - (loop for x in '(0.0s0 0.0f0 0.0d0 0.0l0) - for tp in '(short-float single-float double-float long-float) - for y = (float i x) - always (and (= i y) (typep y tp)))) - t) - -(deftest float.5 - (loop for x in *reals* - always (or (not (floatp x)) - (eql (float x) x))) - t) - -(deftest float.6 - (loop for x in *reals* - unless (handler-case - (or (not (typep x 'short-float)) - (let ((y (float x 0.0f0))) - (and (typep y 'single-float) - (= x y)))) - (arithmetic-error () t)) - collect x) - nil) - -(deftest float.7 - (loop for x in *reals* - unless (or (not (typep x 'short-float)) - (let ((y (float x 0.0d0))) - (and (typep y 'double-float) - (= x y)))) - collect x) - nil) - -(deftest float.8 - (loop for x in *reals* - unless (or (not (typep x 'short-float)) - (let ((y (float x 0.0l0))) - (and (typep y 'long-float) - (= x y)))) - collect x) - nil) - -(deftest float.9 - (loop for x in *reals* - unless (or (not (typep x 'single-float)) - (let ((y (float x 0.0d0))) - (and (typep y 'double-float) - (= x y)))) - collect x) - nil) - -(deftest float.10 - (loop for x in *reals* - unless (or (not (typep x 'single-float)) - (let ((y (float x 0.0l0))) - (and (typep y 'long-float) - (= x y)))) - collect x) - nil) - -(deftest float.11 - (loop for x in *reals* - unless (or (not (typep x 'double-float)) - (let ((y (float x 0.0l0))) - (and (typep y 'long-float) - (= x y)))) - collect x) - nil) - - - - diff --git a/t/ansi-test/numbers/floatp.lsp b/t/ansi-test/numbers/floatp.lsp deleted file mode 100644 index 0417643..0000000 --- a/t/ansi-test/numbers/floatp.lsp +++ /dev/null @@ -1,31 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Sep 11 23:07:33 2003 -;;;; Contains: Tests of FLOATP - - - -;;; Error tests - -(deftest floatp.error.1 - (signals-error (floatp) program-error) - t) - -(deftest floatp.error.2 - (signals-error (floatp 1.0 nil) program-error) - t) - -;;; Non-error tests - -(deftest floatp.1 - (notnot-mv (floatp 1.0)) - t) - -(deftest floatp.2 - (floatp nil) - nil) - -(deftest floatp.3 - (check-type-predicate #'floatp 'float) - nil) - diff --git a/t/ansi-test/numbers/floor.lsp b/t/ansi-test/numbers/floor.lsp deleted file mode 100644 index 145c82a..0000000 --- a/t/ansi-test/numbers/floor.lsp +++ /dev/null @@ -1,177 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Aug 4 22:16:00 2003 -;;;; Contains: Tests of FLOOR - - - - - - -;;; Error tests - -(deftest floor.error.1 - (signals-error (floor) program-error) - t) - -(deftest floor.error.2 - (signals-error (floor 1.0 1 nil) program-error) - t) - -;;; Non-error tests - -(deftest floor.1 - (floor.1-fn) - nil) - -(deftest floor.2 - (floor.2-fn) - nil) - -(deftest floor.3 - (floor.3-fn 2.0s4) - nil) - -(deftest floor.4 - (floor.3-fn 2.0f4) - nil) - -(deftest floor.5 - (floor.3-fn 2.0d4) - nil) - -(deftest floor.6 - (floor.3-fn 2.0l4) - nil) - -(deftest floor.7 - (floor.7-fn) - nil) - -(deftest floor.8 - (floor.8-fn) - nil) - -(deftest floor.9 - (floor.9-fn) - nil) - -(deftest floor.10 - (loop for x in (remove-if #'zerop *reals*) - for (q r) = (multiple-value-list (floor x x)) - unless (and (eql q 1) - (zerop r) - (if (rationalp x) (eql r 0) - (eql r (float 0 x)))) - collect x) - nil) - -(deftest floor.11 - (loop for x in (remove-if #'zerop *reals*) - for (q r) = (multiple-value-list (floor (- x) x)) - unless (and (eql q -1) - (zerop r) - (if (rationalp x) (eql r 0) - (eql r (float 0 x)))) - collect x) - nil) - -(deftest floor.12 - (let* ((radix (float-radix 1.0s0)) - (rad (float radix 1.0s0)) - (rrad (/ 1.0s0 rad))) - (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (floor x)) - unless (and (eql q i) - (eql r rrad)) - collect (list i x q r))) - nil) - -(deftest floor.13 - (let* ((radix (float-radix 1.0s0)) - (rad (float radix 1.0s0)) - (rrad (/ 1.0s0 rad))) - (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (floor x)) - unless (and (eql q (1- i)) - (eql r rrad)) - collect (list i x q r))) - nil) - -(deftest floor.14 - (let* ((radix (float-radix 1.0f0)) - (rad (float radix 1.0f0)) - (rrad (/ 1.0f0 rad))) - (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (floor x)) - unless (and (eql q i) - (eql r rrad)) - collect (list i x q r))) - nil) - -(deftest floor.15 - (let* ((radix (float-radix 1.0f0)) - (rad (float radix 1.0f0)) - (rrad (/ 1.0f0 rad))) - (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (floor x)) - unless (and (eql q (1- i)) - (eql r rrad)) - collect (list i x q r))) - nil) - -(deftest floor.16 - (let* ((radix (float-radix 1.0d0)) - (rad (float radix 1.0d0)) - (rrad (/ 1.0d0 rad))) - (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (floor x)) - unless (and (eql q i) - (eql r rrad)) - collect (list i x q r))) - nil) - -(deftest floor.17 - (let* ((radix (float-radix 1.0d0)) - (rad (float radix 1.0d0)) - (rrad (/ 1.0d0 rad))) - (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (floor x)) - unless (and (eql q (1- i)) - (eql r rrad)) - collect (list i x q r))) - nil) - -(deftest floor.18 - (let* ((radix (float-radix 1.0l0)) - (rad (float radix 1.0l0)) - (rrad (/ 1.0l0 rad))) - (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (floor x)) - unless (and (eql q i) - (eql r rrad)) - collect (list i x q r))) - nil) - -(deftest floor.19 - (let* ((radix (float-radix 1.0l0)) - (rad (float radix 1.0l0)) - (rrad (/ 1.0l0 rad))) - (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (floor x)) - unless (and (eql q (1- i)) - (eql r rrad)) - collect (list i x q r))) - nil) - -;;; To add: tests that involve adding/subtracting EPSILON constants -;;; (suitably scaled) to floated integers. - diff --git a/t/ansi-test/numbers/fround.lsp b/t/ansi-test/numbers/fround.lsp deleted file mode 100644 index a2d84f2..0000000 --- a/t/ansi-test/numbers/fround.lsp +++ /dev/null @@ -1,149 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Aug 21 16:07:59 2003 -;;;; Contains: Tests of FROUND - - - - - - -;;; Error tests - -(deftest fround.error.1 - (signals-error (fround) program-error) - t) - -(deftest fround.error.2 - (signals-error (fround 1.0 1 nil) program-error) - t) - -;;; Non-error tests - -(deftest fround.1 - (fround.1-fn) - nil) - -(deftest fround.10 - (loop for x in (remove-if #'zerop *reals*) - for (q r) = (multiple-value-list (fround x x)) - unless (and (floatp q) - (if (floatp x) - (eql q (float 1 x)) - (= q 1)) - (zerop r) - (if (floatp x) - (eql r (float 0 x)) - (= r 0))) - collect x) - nil) - -(deftest fround.11 - (loop for x in (remove-if-not #'floatp (remove-if #'zerop *reals*)) - for (q r) = (multiple-value-list (fround (- x) x)) - unless (and (floatp q) - (if (floatp x) - (eql q (float -1 x)) - (= q -1)) - (zerop r) - (if (floatp x) - (eql r (float 0 x)) - (= r 0))) - collect x) - nil) - -(deftest fround.12 - (let* ((radix (float-radix 1.0s0)) - (rad (float radix 1.0s0)) - (rrad (/ 0.5s0 rad))) - (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (fround x)) - unless (and (eql q (coerce i 'short-float)) - (eql r rrad)) - collect (list i x q r))) - nil) - -(deftest fround.13 - (let* ((radix (float-radix 1.0s0)) - (rad (float radix 1.0s0)) - (rrad (/ 0.5s0 rad))) - (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (fround x)) - unless (and (eql q (coerce i 'short-float)) - (eql r (- rrad))) - collect (list i x q r))) - nil) - -(deftest fround.14 - (let* ((radix (float-radix 1.0f0)) - (rad (float radix 1.0f0)) - (rrad (/ 0.5f0 rad))) - (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (fround x)) - unless (and (eql q (coerce i 'single-float)) - (eql r rrad)) - collect (list i x q r))) - nil) - -(deftest fround.15 - (let* ((radix (float-radix 1.0f0)) - (rad (float radix 1.0f0)) - (rrad (/ 0.5f0 rad))) - (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (fround x)) - unless (and (eql q (coerce i 'single-float)) - (eql r (- rrad))) - collect (list i x q r))) - nil) - -(deftest fround.16 - (let* ((radix (float-radix 1.0d0)) - (rad (float radix 1.0d0)) - (rrad (/ 0.5d0 rad))) - (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (fround x)) - unless (and (eql q (coerce i 'double-float)) - (eql r rrad)) - collect (list i x q r))) - nil) - -(deftest fround.17 - (let* ((radix (float-radix 1.0d0)) - (rad (float radix 1.0d0)) - (rrad (/ 0.5d0 rad))) - (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (fround x)) - unless (and (eql q (coerce i 'double-float)) - (eql r (- rrad))) - collect (list i x q r))) - nil) - -(deftest fround.18 - (let* ((radix (float-radix 1.0l0)) - (rad (float radix 1.0l0)) - (rrad (/ 0.5l0 rad))) - (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (fround x)) - unless (and (eql q (coerce i 'long-float)) - (eql r rrad)) - collect (list i x q r))) - nil) - -(deftest fround.19 - (let* ((radix (float-radix 1.0l0)) - (rad (float radix 1.0l0)) - (rrad (/ 0.5l0 rad))) - (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (fround x)) - unless (and (eql q (coerce i 'long-float)) - (eql r (- rrad))) - collect (list i x q r))) - nil) diff --git a/t/ansi-test/numbers/ftruncate.lsp b/t/ansi-test/numbers/ftruncate.lsp deleted file mode 100644 index 5272df8..0000000 --- a/t/ansi-test/numbers/ftruncate.lsp +++ /dev/null @@ -1,152 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Aug 20 06:36:35 2003 -;;;; Contains: Tests of FTRUNCATE - - - - - - -;;; Error tests - -(deftest ftruncate.error.1 - (signals-error (ftruncate) program-error) - t) - -(deftest ftruncate.error.2 - (signals-error (ftruncate 1.0 1 nil) program-error) - t) - -;;; Non-error tests - -(deftest ftruncate.1 - (ftruncate.1-fn) - nil) - -(deftest ftruncate.10 - (loop for x in (remove-if #'zerop *reals*) - for (q r) = (multiple-value-list (ftruncate x x)) - unless (and (floatp q) - (if (floatp x) - (eql q (float 1 x)) - (= q 1)) - (zerop r) - (if (floatp x) - (eql r (float 0 x)) - (= r 0))) - collect x) - nil) - -(deftest ftruncate.11 - (loop for x in (remove-if-not #'floatp (remove-if #'zerop *reals*)) - for (q r) = (multiple-value-list (ftruncate (- x) x)) - unless (and (floatp q) - (if (floatp x) - (eql q (float -1 x)) - (= q -1)) - (zerop r) - (if (floatp x) - (eql r (float 0 x)) - (= r 0))) - collect x) - nil) - -(deftest ftruncate.12 - (let* ((radix (float-radix 1.0s0)) - (rad (float radix 1.0s0)) - (rrad (/ 1.0s0 rad))) - (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (ftruncate x)) - unless (and (eql q (coerce i 'short-float)) - (eql r rrad)) - collect (list i x q r))) - nil) - -(deftest ftruncate.13 - (let* ((radix (float-radix 1.0s0)) - (rad (float radix 1.0s0)) - (rrad (/ 1.0s0 rad))) - (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (ftruncate x)) - unless (and (eql q (coerce (1- i) 'short-float)) - (eql r rrad)) - collect (list i x q r))) - nil) - -(deftest ftruncate.14 - (let* ((radix (float-radix 1.0f0)) - (rad (float radix 1.0f0)) - (rrad (/ 1.0f0 rad))) - (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (ftruncate x)) - unless (and (eql q (coerce i 'single-float)) - (eql r rrad)) - collect (list i x q r))) - nil) - -(deftest ftruncate.15 - (let* ((radix (float-radix 1.0f0)) - (rad (float radix 1.0f0)) - (rrad (/ 1.0f0 rad))) - (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (ftruncate x)) - unless (and (eql q (coerce (1- i) 'single-float)) - (eql r rrad)) - collect (list i x q r))) - nil) - -(deftest ftruncate.16 - (let* ((radix (float-radix 1.0d0)) - (rad (float radix 1.0d0)) - (rrad (/ 1.0d0 rad))) - (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (ftruncate x)) - unless (and (eql q (coerce i 'double-float)) - (eql r rrad)) - collect (list i x q r))) - nil) - -(deftest ftruncate.17 - (let* ((radix (float-radix 1.0d0)) - (rad (float radix 1.0d0)) - (rrad (/ 1.0d0 rad))) - (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (ftruncate x)) - unless (and (eql q (coerce (1- i) 'double-float)) - (eql r rrad)) - collect (list i x q r))) - nil) - -(deftest ftruncate.18 - (let* ((radix (float-radix 1.0l0)) - (rad (float radix 1.0l0)) - (rrad (/ 1.0l0 rad))) - (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (ftruncate x)) - unless (and (eql q (coerce i 'long-float)) - (eql r rrad)) - collect (list i x q r))) - nil) - -(deftest ftruncate.19 - (let* ((radix (float-radix 1.0l0)) - (rad (float radix 1.0l0)) - (rrad (/ 1.0l0 rad))) - (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (ftruncate x)) - unless (and (eql q (coerce (1- i) 'long-float)) - (eql r rrad)) - collect (list i x q r))) - nil) - -;;; To add: tests that involve adding/subtracting EPSILON constants -;;; (suitably scaled) to floated integers. diff --git a/t/ansi-test/numbers/gcd.lsp b/t/ansi-test/numbers/gcd.lsp deleted file mode 100644 index 846a33e..0000000 --- a/t/ansi-test/numbers/gcd.lsp +++ /dev/null @@ -1,105 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Sep 3 06:51:03 2003 -;;;; Contains: Tests of GCD - - - - - - -;;; Error tests - -(deftest gcd.error.1 - (check-type-error #'gcd #'integerp) - nil) - -;;; Non-error tests - -(deftest gcd.1 - (gcd) - 0) - -(deftest gcd.2 - (loop for i = (random-fixnum) - for a = (abs i) - repeat 10000 - unless (and (eql a (gcd i)) - (eql a (gcd 0 i))) - collect i) - nil) - -(deftest gcd.3 - (loop for i = (random-from-interval 10000000000000000) - for a = (abs i) - repeat 10000 - unless (and (eql a (gcd i)) - (eql a (gcd i 0))) - collect i) - nil) - -(deftest gcd.4 - (loop for i = (random-fixnum) - for j = (random-fixnum) - repeat 1000 - unless (eql (my-gcd i j) (gcd i j)) - collect (list i j)) - nil) - -(deftest gcd.5 - (let ((bound (ash 1 200))) - (loop for i = (random-from-interval bound) - for j = (random-from-interval bound) - repeat 1000 - unless (eql (my-gcd i j) (gcd i j)) - collect (list i j))) - nil) - -(deftest gcd.6 - (loop for i = (random-fixnum) - for j = (random-fixnum) - for k = (random-fixnum) - repeat 1000 - unless (eql (my-gcd i (my-gcd j k)) (gcd i j k)) - collect (list i j k)) - nil) - -(deftest gcd.7 - (loop for i = (random-fixnum) - for j = (random-fixnum) - for k = (random-fixnum) - for n = (random-fixnum) - repeat 1000 - unless (eql (my-gcd (my-gcd i j) (my-gcd k n)) (gcd i j k n)) - collect (list i j k)) - nil) - -(deftest gcd.8 - (loop for i from 1 to (min 256 (1- call-arguments-limit)) - always (eql (apply #'gcd (make-list i :initial-element 1)) 1)) - t) - -(deftest gcd.order.1 - (let ((i 0) x y) - (values - (gcd (progn (setf x (incf i)) 15) - (progn (setf y (incf i)) 25)) - i x y)) - 5 2 1 2) - -(deftest gcd.order.2 - (let ((i 0) x y) - (values - (gcd (progn (setf x (incf i)) 0) - (progn (setf y (incf i)) 10)) - i x y)) - 10 2 1 2) - -(deftest gcd.order.3 - (let ((i 0)) - (values - (gcd (progn (incf i) 0)) - i)) - 0 1) - - diff --git a/t/ansi-test/numbers/imagpart.lsp b/t/ansi-test/numbers/imagpart.lsp deleted file mode 100644 index 0f6aa2c..0000000 --- a/t/ansi-test/numbers/imagpart.lsp +++ /dev/null @@ -1,51 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Sep 7 07:47:43 2003 -;;;; Contains: Tests of IMAGPART - - - -(deftest imagpart.error.1 - (signals-error (imagpart) program-error) - t) - -(deftest imagpart.error.2 - (signals-error (imagpart #c(1.0 2.0) nil) program-error) - t) - -(deftest imagpart.error.3 - (check-type-error #'imagpart #'numberp) - nil) - -(deftest imagpart.1 - (loop for x in *reals* - for c = (complex 0 x) - for ip = (imagpart c) - unless (eql x ip) - collect (list x c ip)) - nil) - -(deftest imagpart.2 - (loop for x in *reals* - for c = (complex 1 x) - for ip = (imagpart c) - unless (eql x ip) - collect (list x c ip)) - nil) - -(deftest imagpart.3 - (loop for x in *reals* - for c = (complex x x) - for ip = (imagpart c) - unless (eql x ip) - collect (list x c ip)) - nil) - -(deftest imagpart.4 - (loop for x in *reals* - for ip = (imagpart x) - unless (eql (* 0 x) ip) - collect (list x ip (* 0 x))) - nil) - - diff --git a/t/ansi-test/numbers/incf.lsp b/t/ansi-test/numbers/incf.lsp deleted file mode 100644 index 28bc305..0000000 --- a/t/ansi-test/numbers/incf.lsp +++ /dev/null @@ -1,193 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Sep 4 20:01:15 2003 -;;;; Contains: Tests of INCF - - - - - -(deftest incf.1 - (let ((x 12)) - (values - (incf x) - x)) - 13 13) - -(deftest incf.2 - (let ((x 3.0s0)) - (values - (incf x) - x)) - 4.0s0 4.0s0) - -(deftest incf.3 - (let ((x 19.0f0)) - (values - (incf x) - x)) - 20.0f0 20.0f0) - -(deftest incf.4 - (let ((x 813.0d0)) - (values - (incf x) - x)) - 814.0d0 814.0d0) - -(deftest incf.5 - (let ((x -17.0l0)) - (values - (incf x) - x)) - -16.0l0 -16.0l0) - -(deftest incf.6 - (loop for x from 1 to 5 - collect (let ((y x)) - (list (incf y) y))) - ((2 2) (3 3) (4 4) (5 5) (6 6))) - -(deftest incf.7 - (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) - collect (let ((y x)) - (list (incf y) y))) - ((2.0s0 2.0s0) (2.0f0 2.0f0) (2.0d0 2.0d0) (2.0l0 2.0l0))) - -(deftest incf.8 - (loop for x in '(1.0s0 1.0f0 1.0d0 1.0f0) - for y = (complex x 0) - for z = (incf y) - for x1c = (complex (1+ x) 0) - unless (and (eql y z) (eql x1c y)) - collect (list x y z x1c)) - nil) - -(deftest incf.9 - (let ((x most-positive-fixnum)) - (values (incf x) x)) - #.(1+ most-positive-fixnum) #.(1+ most-positive-fixnum)) - -(deftest incf.10 - (let ((x (1+ most-positive-fixnum))) - (values (incf x) x)) - #.(+ 2 most-positive-fixnum) #.(+ 2 most-positive-fixnum)) - -(deftest incf.11 - (loop for x in *numbers* - unless (let* ((y x) - (z (incf y))) - (and (eql y (1+ x)) - (eql y z))) - collect x) - nil) - -;;; Increment by other than 1 - -(deftest incf.12 - (loop for x in *numbers* - unless (let* ((y x) (z (incf y 0))) - (and (eql x y) (eql y z))) - collect x) - nil) - -(deftest incf.13 - (loop for x in *numbers* - nconc - (loop for r = (random-from-interval 1000000) - repeat 100 - when (let* ((y x) (z (incf y r))) - (and (not (and (eql (+ x r) y) (eql y z))) - (list x y r))) - collect it)) - nil) - -(deftest incf.14 - (let ((x 1)) - (values (incf x 0.0s0) x)) - 1.0s0 1.0s0) - -(deftest incf.15 - (let ((x 1)) - (values (incf x 0.0f0) x)) - 1.0f0 1.0f0) - -(deftest incf.16 - (let ((x 2)) - (values (incf x 0.0d0) x)) - 2.0d0 2.0d0) - -(deftest incf.17 - (let ((x 10)) - (values (incf x 0.0l0) x)) - 10.0l0 10.0l0) - -(deftest incf.18 - (let ((x 1)) - (values (incf x #c(0.0s0 0.0s0)) x)) - #c(1.0s0 0.0s0) #c(1.0s0 0.0s0)) - -(deftest incf.19 - (let ((x 1)) - (values (incf x #c(0.0f0 2.0f0)) x)) - #c(1.0f0 2.0f0) #c(1.0f0 2.0f0)) - -(deftest incf.20 - (let ((x 1)) - (values (incf x #c(0.0d0 2.0d0)) x)) - #c(1.0d0 2.0d0) #c(1.0d0 2.0d0)) - -(deftest incf.21 - (let ((x 1)) - (values (incf x #c(0.0l0 -2.0l0)) x)) - #c(1.0l0 -2.0l0) #c(1.0l0 -2.0l0)) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest incf.22 - (macrolet - ((%m (z) z)) - (let ((x 2)) - (values - (incf (expand-in-current-env (%m x))) - x))) - 3 3) - -(deftest incf.23 - (macrolet - ((%m (z) z)) - (let ((x 2)) - (values - (incf x (expand-in-current-env (%m 4))) - x))) - 6 6) - -(deftest incf.order.2 - (let ((a (vector 1 2 3 4)) - (i 0) x y z) - (values - (incf (aref (progn (setf x (incf i)) a) - (progn (setf y (incf i)) 0)) - (progn (setf z (incf i)) 17)) - i x y z a)) - 18 3 1 2 3 #(18 2 3 4)) - -(deftest incf.order.3 - (let ((a (vector 10 2 3 4)) - (i 0) x y) - (values - (incf (aref (progn (setf x (incf i)) a) - (progn (setf y (incf i)) 0))) - i x y a)) - 11 2 1 2 #(11 2 3 4)) - -(deftest incf.order.4 - (let ((x 0)) - (progn - "See CLtS 5.1.3" - (values - (incf x (setf x 1)) - x))) - 2 2) - diff --git a/t/ansi-test/numbers/integer-length.lsp b/t/ansi-test/numbers/integer-length.lsp deleted file mode 100644 index ca0a237..0000000 --- a/t/ansi-test/numbers/integer-length.lsp +++ /dev/null @@ -1,58 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Sep 7 10:10:10 2003 -;;;; Contains: Tests for INTEGER-LENGTH - - - -(deftest integer-length.error.1 - (signals-error (integer-length) program-error) - t) - -(deftest integer-length.error.2 - (signals-error (integer-length 1 1) program-error) - t) - -(deftest integer-length.error.3 - (signals-error (integer-length 1 nil) program-error) - t) - -(deftest integer-length.error.4 - (check-type-error #'integer-length #'integerp) - nil) - -(deftest integer-length.1 - (loop for len from 0 to 100 - for i = (1- (ash 1 len)) - for vals = (multiple-value-list (integer-length i)) - for len2 = (car vals) - always (and (= (length vals) 1) - (eql len len2))) - t) - -(deftest integer-length.2 - (loop for len from 0 to 100 - for i = (ash 1 len) - for vals = (multiple-value-list (integer-length i)) - for len2 = (car vals) - always (and (= (length vals) 1) - (eql (1+ len) len2))) - t) - -(deftest integer-length.3 - (loop for len from 0 to 100 - for i = (- (ash 1 len)) - for vals = (multiple-value-list (integer-length i)) - for len2 = (car vals) - always (and (= (length vals) 1) - (eql len len2))) - t) - -(deftest integer-length.4 - (loop for len from 0 to 100 - for i = (- -1 (ash 1 len)) - for vals = (multiple-value-list (integer-length i)) - for len2 = (car vals) - always (and (= (length vals) 1) - (eql (1+ len) len2))) - t) diff --git a/t/ansi-test/numbers/integerp.lsp b/t/ansi-test/numbers/integerp.lsp deleted file mode 100644 index 0d59107..0000000 --- a/t/ansi-test/numbers/integerp.lsp +++ /dev/null @@ -1,35 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Sep 7 10:18:34 2003 -;;;; Contains: Tests for INTEGERP - - - -(deftest integerp.error.1 - (signals-error (integerp) program-error) - t) - -(deftest integerp.error.2 - (signals-error (integerp 0 0) program-error) - t) - -(deftest integerp.error.3 - (signals-error (integerp nil nil) program-error) - t) - -(deftest integerp.1 - (loop for i in *integers* - for vals = (multiple-value-list (integerp i)) - unless (and (= (length vals) 1) - (first vals)) - collect (cons i vals)) - nil) - -(deftest integerp.2 - (check-type-predicate #'integerp 'integer) - nil) - - - - - diff --git a/t/ansi-test/numbers/isqrt.lsp b/t/ansi-test/numbers/isqrt.lsp deleted file mode 100644 index f0afefa..0000000 --- a/t/ansi-test/numbers/isqrt.lsp +++ /dev/null @@ -1,65 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Sep 6 15:40:09 2003 -;;;; Contains: Tests of ISQRT - - - - - -;;; Error tests - -(deftest isqrt.error.1 - (signals-error (isqrt) program-error) - t) - -(deftest isqrt.error.2 - (signals-error (isqrt 0 0) program-error) - t) - -(deftest isqrt.error.3 - (signals-error (isqrt 0 nil) program-error) - t) - -(deftest isqrt.error.4 - (signals-error (isqrt 0 0 0) program-error) - t) - -(deftest isqrt.error.5 - (loop for x in *mini-universe* - unless (or (and (integerp x) (>= x 0)) - (eval `(signals-type-error x ',x (isqrt x)))) - collect x) - nil) - -;;; Non-error tests - -(deftest isqrt.1 - (loop for i from 0 to 10000 - for i2 = (* i i) - for s = (isqrt i2) - unless (eql s i) - collect i) - nil) - -(deftest isqrt.2 - (loop for i = (random-from-interval most-positive-fixnum 0) - for s = (isqrt i) - repeat 1000 - unless (and (integerp s) - (>= s 0) - (<= (* s s) i) - (> (* (1+ s) (1+ s)) i)) - collect (list i s)) - nil) - -(deftest isqrt.3 - (loop for i = (random-from-interval 1000000000000000 0) - for s = (isqrt i) - repeat 1000 - unless (and (integerp s) - (>= s 0) - (<= (* s s) i) - (> (* (1+ s) (1+ s)) i)) - collect (list i s)) - nil) diff --git a/t/ansi-test/numbers/lcm.lsp b/t/ansi-test/numbers/lcm.lsp deleted file mode 100644 index 7812ce5..0000000 --- a/t/ansi-test/numbers/lcm.lsp +++ /dev/null @@ -1,118 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Sep 4 22:03:21 2003 -;;;; Contains: Tests of LCM - - - - - - -(deftest lcm.error.1 - (check-type-error #'lcm #'integerp) - nil) - -(deftest lcm.1 - (lcm) - 1) - -(deftest lcm.2 - (loop for i = (random-fixnum) - for a = (abs i) - repeat 1000 - unless (and (eql a (lcm i)) - (eql a (lcm 1 i))) - collect i) - nil) - -(deftest lcm.3 - (loop for i = (random-from-interval 10000000000000000) - for a = (abs i) - repeat 1000 - unless (and (eql a (lcm i)) - (eql a (lcm i 1))) - collect i) - nil) - -(deftest lcm.4 - (loop for i = (random-fixnum) - for j = (random-fixnum) - repeat 1000 - unless (eql (my-lcm i j) (lcm i j)) - collect (list i j)) - nil) - -(deftest lcm.5 - (let ((bound (ash 1 200))) - (loop for i = (random-from-interval bound) - for j = (random-from-interval bound) - repeat 1000 - unless (eql (my-lcm i j) (lcm i j)) - collect (list i j))) - nil) - -(deftest lcm.6 - (loop for i = (random-fixnum) - for j = (random-fixnum) - for k = (random-fixnum) - repeat 1000 - unless (eql (my-lcm i (my-lcm j k)) (lcm i j k)) - collect (list i j k)) - nil) - -(deftest lcm.7 - (loop for i = (random-fixnum) - for j = (random-fixnum) - for k = (random-fixnum) - for n = (random-fixnum) - repeat 1000 - unless (eql (my-lcm (my-lcm i j) (my-lcm k n)) (lcm i j k n)) - collect (list i j k n)) - nil) - -(deftest lcm.8 - (loop for i from 1 to (min 256 (1- call-arguments-limit)) - always (eql (apply #'lcm (make-list i :initial-element 1)) 1)) - t) - -(deftest lcm.9 - (lcm 0 0) - 0) - -(deftest lcm.10 - (lcm 1 0 0) - 0) - -(deftest lcm.11 - (lcm 0 1 0) - 0) - -(deftest lcm.12 - (lcm 0 0 1) - 0) - - -(deftest lcm.order.1 - (let ((i 0) x y) - (values - (lcm (progn (setf x (incf i)) 15) - (progn (setf y (incf i)) 25)) - i x y)) - 75 2 1 2) - -(deftest lcm.order.2 - (let ((i 0) x y) - (values - (lcm (progn (setf x (incf i)) 0) - (progn (setf y (incf i)) 10)) - i x y)) - 0 2 1 2) - -(deftest lcm.order.3 - (let ((i 0)) - (values - (lcm (progn (incf i) 0)) - i)) - 0 1) - - diff --git a/t/ansi-test/numbers/ldb.lsp b/t/ansi-test/numbers/ldb.lsp deleted file mode 100644 index e6f5b4e..0000000 --- a/t/ansi-test/numbers/ldb.lsp +++ /dev/null @@ -1,93 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Sep 11 20:45:17 2003 -;;;; Contains: Tests of LDB - - - -;;; Error tests - -(deftest ldb.error.1 - (signals-error (ldb) program-error) - t) - -(deftest ldb.error.2 - (signals-error (ldb (byte 1 1)) program-error) - t) - -(deftest ldb.error.3 - (signals-error (ldb (byte 1 1) -1 0) program-error) - t) - -;;; Non-error tests - -(deftest ldb.1 - (loop for x = (random-fixnum) - for pos = (random 30) - for size = (random 30) - repeat 10000 - unless (eql (ldb (byte size pos) x) - (logand (1- (ash 1 size)) - (ash x (- pos)))) - collect (list x pos size)) - nil) - - -(deftest ldb.2 - (let ((bound (ash 1 300))) - (loop for x = (random-from-interval bound) - for pos = (random 300) - for size = (random 300) - repeat 1000 - unless (eql (ldb (byte size pos) x) - (logand (1- (ash 1 size)) - (ash x (- pos)))) - collect (list x pos size))) - nil) - -(deftest ldb.3 - (loop for i of-type fixnum from -1000 to 1000 - always (eql (ldb (byte 0 0) i) 0)) - t) - -(deftest ldb.order.1 - (let ((i 0) a b c d) - (values - (ldb (progn (setf a (incf i)) - (byte (progn (setf b (incf i)) 3) - (progn (setf c (incf i)) 1))) - (progn (setf d (incf i)) -1)) - i a b c d)) - 7 4 1 2 3 4) - -;;; ldb on places - -(deftest ldb.place.1 - (let ((x 0)) - (values - (setf (ldb (byte 4 1) x) -1) - x)) - -1 30) - -(deftest ldb.place.2 - (loop for pos from 0 to 100 - always - (loop for size from 0 to 100 - always - (let ((x 0)) - (and (eql (setf (ldb (byte size pos) x) -1) -1) - (eql x (ash (1- (ash 1 size)) pos)))))) - t) - -(deftest ldb.place.order.1 - (let ((i 0) a b c d e f (x (copy-seq #(63)))) - (values - (setf (ldb (progn (setf a (incf i)) - (byte (progn (setf b (incf i)) 3) - (progn (setf c (incf i)) 1))) - (aref (progn (setf d (incf i)) x) - (progn (setf e (incf i)) 0))) - (progn (setf f (incf i)) 0)) - x - i a b c d e f)) - 0 #(49) 6 1 2 3 4 5 6) diff --git a/t/ansi-test/numbers/load.lsp b/t/ansi-test/numbers/load.lsp deleted file mode 100644 index 619e465..0000000 --- a/t/ansi-test/numbers/load.lsp +++ /dev/null @@ -1,132 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Apr 7 07:16:44 2003 -;;;; Contains: Forms to load files containing tests of number concepts - -(compile-and-load "ANSI-TESTS:AUX;numbers-aux.lsp") -(compile-and-load "ANSI-TESTS:AUX;random-aux.lsp") -(compile-and-load "ANSI-TESTS:AUX;floor-aux.lsp") -(compile-and-load "ANSI-TESTS:AUX;ffloor-aux.lsp") -(compile-and-load "ANSI-TESTS:AUX;ceiling-aux.lsp") -(compile-and-load "ANSI-TESTS:AUX;fceiling-aux.lsp") -(compile-and-load "ANSI-TESTS:AUX;truncate-aux.lsp") -(compile-and-load "ANSI-TESTS:AUX;ftruncate-aux.lsp") -(compile-and-load "ANSI-TESTS:AUX;round-aux.lsp") -(compile-and-load "ANSI-TESTS:AUX;fround-aux.lsp") -(compile-and-load "ANSI-TESTS:AUX;times-aux.lsp") -(compile-and-load "ANSI-TESTS:AUX;division-aux.lsp") -(compile-and-load "ANSI-TESTS:AUX;exp-aux.lsp") -(compile-and-load "ANSI-TESTS:AUX;gcd-aux.lsp") -(compile-and-load "ANSI-TESTS:AUX;types-aux.lsp") - -(in-package #:cl-test) - -(let ((*default-pathname-defaults* - (make-pathname - :directory (pathname-directory *load-pathname*)))) - (load "number-comparison.lsp") - (load "max.lsp") - (load "min.lsp") - (load "minusp.lsp") - (load "plusp.lsp") - (load "zerop.lsp") - (load "floor.lsp") - (load "ffloor.lsp") - (load "ceiling.lsp") - (load "fceiling.lsp") - (load "truncate.lsp") - (load "ftruncate.lsp") - (load "round.lsp") - (load "fround.lsp") - -;;; transcendental functions go here - (load "sin.lsp") - (load "cos.lsp") - (load "tan.lsp") - (load "asin.lsp") - (load "acos.lsp") - (load "atan.lsp") - - (load "sinh.lsp") - (load "cosh.lsp") - (load "tanh.lsp") - (load "asinh.lsp") - (load "acosh.lsp") - (load "atanh.lsp") - - (load "times.lsp") - (load "plus.lsp") - (load "minus.lsp") - (load "divide.lsp") - (load "oneplus.lsp") - (load "oneminus.lsp") - (load "abs.lsp") - (load "exp.lsp") - (load "expt.lsp") - (load "gcd.lsp") - (load "incf.lsp") - (load "decf.lsp") - (load "lcm.lsp") - (load "log.lsp") - (load "signum.lsp") - (load "sqrt.lsp") - (load "isqrt.lsp") - (load "random.lsp") - (load "random-state-p.lsp") - (load "make-random-state.lsp") - (load "numberp.lsp") - (load "cis.lsp") - (load "complex.lsp") - (load "complexp.lsp") - (load "conjugate.lsp") - (load "phase.lsp") - (load "realpart.lsp") - (load "imagpart.lsp") - (load "realp.lsp") - (load "numerator-denominator.lsp") - (load "rationalp.lsp") - - (load "ash.lsp") - (load "integer-length.lsp") - (load "integerp.lsp") - - (load "parse-integer.lsp") - (load "boole.lsp") - - (load "logand.lsp") - (load "logandc1.lsp") - (load "logandc2.lsp") - (load "logeqv.lsp") - (load "logior.lsp") - (load "lognand.lsp") - (load "lognor.lsp") - (load "logorc1.lsp") - (load "logorc2.lsp") - (load "lognot.lsp") - (load "logxor.lsp") - (load "logbitp.lsp") - (load "logcount.lsp") - (load "logtest.lsp") - - (load "byte.lsp") - (load "deposit-field.lsp") - (load "dpb.lsp") - (load "ldb.lsp") - (load "mask-field.lsp") - - (load "float.lsp") - (load "floatp.lsp") - - (load "rational.lsp") - (load "rationalize.lsp") - - (load "evenp.lsp") - (load "oddp.lsp") - - (load "epsilons.lsp") - (load "real.lsp") - - (load "upgraded-complex-part-type.lsp") - - (load "arithmetic-error.lsp") -) diff --git a/t/ansi-test/numbers/log.lsp b/t/ansi-test/numbers/log.lsp deleted file mode 100644 index 578c6e0..0000000 --- a/t/ansi-test/numbers/log.lsp +++ /dev/null @@ -1,123 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Feb 11 19:53:33 2004 -;;;; Contains: Tests of LOG - - - -(deftest log.1 - (let ((result (log 1))) - (or (eqlt result 0) - (eqlt result 0.0))) - t) - -(deftest log.2 - (mapcar #'log '(1.0s0 1.0f0 1.0d0 1.0l0)) - (0.0s0 0.0f0 0.0d0 0.0l0)) - -(deftest log.3 - (loop for type in '(short-float single-float double-float long-float) - nconc - (loop - for x = (+ (random (coerce 1 type)) (/ 1 1000)) - for rlist = (multiple-value-list (log x)) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (typep y type)) - collect (list x rlist))) - nil) - -(deftest log.4 - (loop for type in '(short-float single-float double-float long-float) - nconc - (loop - for x = (1+ (random (coerce 1000000 type))) - for rlist = (multiple-value-list (log x)) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (typep y type)) - collect (list x rlist))) - nil) - -(deftest log.5 - (loop for type in '(short-float single-float double-float long-float) - for zero = (coerce 0 type) - nconc - (loop - for x = (- (random (coerce 1 type))) - for rlist = (and (/= x zero) (multiple-value-list (log x))) - for y = (car rlist) - repeat 1000 - unless (or (= x zero) - (and (null (cdr rlist)) - (typep y `(complex ,type)))) - collect (list x rlist))) - nil) - -(deftest log.6 - (loop for type in '(short-float single-float double-float long-float) - for zero = (coerce 0 type) - nconc - (loop - for x = (- (random (coerce 1000000 type))) - for rlist = (and (/= x zero) (multiple-value-list (log x))) - for y = (car rlist) - repeat 1000 - unless (or (= x zero) - (and (null (cdr rlist)) - (typep y `(complex ,type)))) - collect (list x rlist))) - nil) - -(deftest log.7 - (loop for type in '(short-float single-float double-float long-float) - for zero = (coerce 0 type) - nconc - (loop - for x1 = (- (random (coerce 2000 type)) 1000) - for x2 = (1+ (random (coerce 1000 type))) - for rlist = (and (/= x1 zero) - (multiple-value-list (log (complex x1 x2)))) - for y = (car rlist) - repeat 1000 - unless (or (= x1 zero) - (and (null (cdr rlist)) - (typep y `(complex ,type)))) - collect (list x1 x2 rlist))) - nil) - -(deftest log.8 - (loop for type in '(short-float single-float double-float long-float) - for zero = (coerce 0 type) - nconc - (loop - for x1 = (- (random (coerce 2000 type)) 1000) - for x2 = (- -1 (random (coerce 1000 type))) - for rlist = (and (/= x1 zero) - (multiple-value-list (log (complex x1 x2)))) - for y = (car rlist) - repeat 1000 - unless (or (= x1 zero) - (and (null (cdr rlist)) - (typep y `(complex ,type)))) - collect (list x1 x2 rlist))) - nil) - -;;; FIXME -;;; Add tests for two-arg calls - -;;; FIXME -;;; More accuracy tests here - -;;; Error tests - -(deftest log.error.1 - (signals-error (log) program-error) - t) - -(deftest log.error.2 - (signals-error (log 1.0 2.0 3.0) program-error) - t) - diff --git a/t/ansi-test/numbers/logand.lsp b/t/ansi-test/numbers/logand.lsp deleted file mode 100644 index 5373894..0000000 --- a/t/ansi-test/numbers/logand.lsp +++ /dev/null @@ -1,101 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Sep 8 21:23:22 2003 -;;;; Contains: Tests of LOGAND - - - - - -;;; Error tests - -(deftest logand.error.1 - (check-type-error #'logand #'integerp) - nil) - -(deftest logand.error.2 - (check-type-error #'(lambda (x) (logand 0 x)) #'integerp) - nil) - -(deftest logand.error.3 - (check-type-error #'(lambda (x) (logand x 1)) #'integerp) - nil) - -;;; Non-error tests - -(deftest logand.1 - (logand) - -1) - -(deftest logand.2 - (logand 1231) - 1231) - -(deftest logand.3 - (logand -198) - -198) - -(deftest logand.4 - (loop for x in *integers* - always (eql x (logand x))) - t) - -(deftest logand.5 - (loop for x in *integers* - always (eql 0 (logand x (lognot x)))) - t) - -(deftest logand.6 - (loop for x = (random-fixnum) - for xc = (lognot x) - repeat 1000 - unless (eql 0 (logand x xc)) - collect x) - nil) - -(deftest logand.7 - (loop for x = (random-from-interval (ash 1 (random 200))) - for y = (random-from-interval (ash 1 (random 200))) - for z = (logand x y) - repeat 1000 - unless (and (if (and (< x 0) (< y 0)) - (< z 0) - (>= z 0)) - (loop for i from 1 to 210 - always (if (and (logbitp i x) - (logbitp i y)) - (logbitp i z) - (not (logbitp i z))))) - collect (list x y z)) - nil) - -(deftest logand.8 - (loop for i from 1 to (min 256 (1- call-arguments-limit)) - for args = (nconc (make-list (1- i) :initial-element -1) - (list 183)) - always (eql (apply #'logand args) 183)) - t) - -(deftest logand.9 - (loop for i from -1 to 0 always - (loop for j from -1 to 0 always - (locally (declare (type (integer -1 0) i j)) - (eql (logand i j) (if (or (zerop i) (zerop j)) 0 -1))))) - t) - -(deftest logand.order.1 - (let ((i 0) a b) - (values - (logand (progn (setf a (incf i)) #b11011) - (progn (setf b (incf i)) #b10110)) - i a b)) - #b10010 2 1 2) - -(deftest logand.order.2 - (let ((i 0) a b c) - (values - (logand (progn (setf a (incf i)) #b11011) - (progn (setf b (incf i)) #b10110) - (progn (setf c (incf i)) #b110101)) - i a b c)) - #b10000 3 1 2 3) diff --git a/t/ansi-test/numbers/logandc1.lsp b/t/ansi-test/numbers/logandc1.lsp deleted file mode 100644 index 4ebc099..0000000 --- a/t/ansi-test/numbers/logandc1.lsp +++ /dev/null @@ -1,84 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Sep 8 21:47:22 2003 -;;;; Contains: Tests of LOGANDC1 - - - - - -;;; Error tests - -(deftest logandc1.error.1 - (check-type-error #'(lambda (x) (logandc1 x 0)) #'integerp) - nil) - -(deftest logandc1.error.2 - (check-type-error #'(lambda (x) (logandc1 0 x)) #'integerp) - nil) - -(deftest logandc1.error.3 - (signals-error (logandc1) program-error) - t) - -(deftest logandc1.error.4 - (signals-error (logandc1 0) program-error) - t) - -(deftest logandc1.error.5 - (signals-error (logandc1 1 2 3) program-error) - t) - -;;; Non-error tests - -(deftest logandc1.1 - (logandc1 0 0) - 0) - -(deftest logandc1.2 - (logandc1 0 -1) - -1) - -(deftest logandc1.3 - (logandc1 0 123) - 123) - -(deftest logandc1.4 - (loop for x in *integers* - always (and (eql x (logandc1 0 x)) - (eql 0 (logandc1 x x)) - (eql x (logandc1 (lognot x) x)) - (eql (lognot x) (logandc1 x (lognot x))))) - t) - -(deftest logandc1.5 - (loop for x = (random-fixnum) - for xc = (lognot x) - repeat 1000 - unless (eql x (logandc1 xc x)) - collect x) - nil) - -(deftest logandc1.6 - (loop for x = (random-from-interval (ash 1 (random 200))) - for y = (random-from-interval (ash 1 (random 200))) - for z = (logandc1 x y) - repeat 1000 - unless (and (if (and (>= x 0) (< y 0)) - (< z 0) - (>= z 0)) - (loop for i from 1 to 210 - always (if (and (not (logbitp i x)) - (logbitp i y)) - (logbitp i z) - (not (logbitp i z))))) - collect (list x y z)) - nil) - -(deftest logandc1.order.1 - (let ((i 0) a b) - (values - (logandc1 (progn (setf a (incf i)) 0) - (progn (setf b (incf i)) -1)) - i a b)) - -1 2 1 2) diff --git a/t/ansi-test/numbers/logandc2.lsp b/t/ansi-test/numbers/logandc2.lsp deleted file mode 100644 index 4ab506e..0000000 --- a/t/ansi-test/numbers/logandc2.lsp +++ /dev/null @@ -1,84 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Sep 9 05:52:31 2003 -;;;; Contains: Tests of LOGANDC2 - - - - - -;;; Error tests - -(deftest logandc2.error.1 - (check-type-error #'(lambda (x) (logandc2 x 0)) #'integerp) - nil) - -(deftest logandc2.error.2 - (check-type-error #'(lambda (x) (logandc2 0 x)) #'integerp) - nil) - -(deftest logandc2.error.3 - (signals-error (logandc2) program-error) - t) - -(deftest logandc2.error.4 - (signals-error (logandc2 0) program-error) - t) - -(deftest logandc2.error.5 - (signals-error (logandc2 1 2 3) program-error) - t) - -;;; Non-error tests - -(deftest logandc2.1 - (logandc2 0 0) - 0) - -(deftest logandc2.2 - (logandc2 -1 0) - -1) - -(deftest logandc2.3 - (logandc2 (1+ most-positive-fixnum) 0) - #.(1+ most-positive-fixnum)) - -(deftest logandc2.4 - (loop for x in *integers* - always (and (eql x (logandc2 x 0)) - (eql 0 (logandc2 x x)) - (eql x (logandc2 x (lognot x))) - (eql (lognot x) (logandc2 (lognot x) x)))) - t) - -(deftest logandc2.5 - (loop for x = (random-fixnum) - for xc = (lognot x) - repeat 1000 - unless (eql x (logandc2 x xc)) - collect x) - nil) - -(deftest logandc2.6 - (loop for x = (random-from-interval (ash 1 (random 200))) - for y = (random-from-interval (ash 1 (random 200))) - for z = (logandc2 x y) - repeat 1000 - unless (and (if (and (< x 0) (>= y 0)) - (< z 0) - (>= z 0)) - (loop for i from 1 to 210 - always (if (and (not (logbitp i y)) - (logbitp i x)) - (logbitp i z) - (not (logbitp i z))))) - collect (list x y z)) - nil) - -(deftest logandc2.order.1 - (let ((i 0) a b) - (values - (logandc2 (progn (setf a (incf i)) -1) - (progn (setf b (incf i)) 0)) - i a b)) - -1 2 1 2) diff --git a/t/ansi-test/numbers/logbitp.lsp b/t/ansi-test/numbers/logbitp.lsp deleted file mode 100644 index b1def1e..0000000 --- a/t/ansi-test/numbers/logbitp.lsp +++ /dev/null @@ -1,93 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Sep 9 07:02:00 2003 -;;;; Contains: Tests of LOGBITP - - - - - -;;; Error tests - -(deftest logbitp.error.1 - (signals-error (logbitp) program-error) - t) - -(deftest logbitp.error.2 - (signals-error (logbitp 0) program-error) - t) - -(deftest logbitp.error.3 - (signals-error (logbitp 0 0 0) program-error) - t) - -(deftest logbitp.error.4 - (check-type-error #'(lambda (x) (logbitp x 0)) (typef 'unsigned-byte)) - nil) - -(deftest logbitp.error.5 - (check-type-error #'(lambda (x) (logbitp 0 x)) #'integerp) - nil) - -;;; Non-error tests - -(deftest logbitp.1 - (loop for x in *integers* - unless (if (logbitp 0 x) (oddp x) (evenp x)) - collect x) - nil) - -(deftest logbitp.2 - (loop for len from 0 to 300 - for i = (ash 1 len) - always (and (logbitp len i) - (loop for j from 0 to 300 - always (or (eql j len) - (not (logbitp j i)))))) - t) - -(deftest logbitp.3 - (logbitp most-positive-fixnum 0) - nil) - -(deftest logbitp.4 - (notnot-mv (logbitp most-positive-fixnum -1)) - t) - -(deftest logbitp.5 - (logbitp (1+ most-positive-fixnum) 0) - nil) - -(deftest logbitp.6 - (notnot-mv (logbitp (1+ most-positive-fixnum) -1)) - t) - -(deftest logbitp.7 - (loop for len = (random 100) - for i = (random-from-interval (ash 1 len)) - for k = (random (1+ len)) - repeat 1000 - unless (if (ldb-test (byte 1 k) i) - (logbitp k i) - (not (logbitp k i))) - collect (list i k)) - nil) - -(deftest logbitp.8 - (loop for k from 1 to 1000 - always (logbitp k -1)) - t) - -(deftest logbitp.order.1 - (let ((i 0) a b) - (values - (logbitp (progn (setf a (incf i)) 2) - (progn (setf b (incf i)) #b111010)) - i a b)) - nil 2 1 2) - - - - - - diff --git a/t/ansi-test/numbers/logcount.lsp b/t/ansi-test/numbers/logcount.lsp deleted file mode 100644 index c571635..0000000 --- a/t/ansi-test/numbers/logcount.lsp +++ /dev/null @@ -1,71 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Sep 11 23:12:56 2003 -;;;; Contains: Tests of LOGCOUNT - - - -;;; Error tests - -(deftest logcount.error.1 - (signals-error (logcount) program-error) - t) - -(deftest logcount.error.2 - (signals-error (logcount 0 nil) program-error) - t) - -(deftest logcount.error.3 - (check-type-error #'logcount #'integerp) - nil) - -;;; Non-error tests - -(deftest logcount.1 - (logcount 0) - 0) - -(deftest logcount.2 - (logcount 1) - 1) - -(deftest logcount.3 - (logcount 2) - 1) - -(deftest logcount.4 - (logcount 3) - 2) - -(deftest logcount.5 - (logcount -1) - 0) - -(deftest logcount.6 - (loop for x = (random-fixnum) - repeat 100 - always (eql (logcount x) (logcount (lognot x)))) - t) - -(deftest logcount.7 - (let ((bound (ash 1 300))) - (loop for x = (random-from-interval bound) - repeat 100 - always (eql (logcount x) (logcount (lognot x))))) - t) - -(deftest logcount.8 - (loop for y = (random (1+ most-positive-fixnum)) - repeat 100 - unless - (let ((cnt 0) - (x y)) - (loop while (> x 0) - do - (when (oddp x) (incf cnt)) - (setf x (ash x -1))) - (eql cnt (logcount y))) - collect y) - nil) - - diff --git a/t/ansi-test/numbers/logeqv.lsp b/t/ansi-test/numbers/logeqv.lsp deleted file mode 100644 index eeeef55..0000000 --- a/t/ansi-test/numbers/logeqv.lsp +++ /dev/null @@ -1,94 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Sep 9 05:55:23 2003 -;;;; Contains: Tests of LOGEQV - - - - - -;;; Error tests - -(deftest logeqv.error.1 - (check-type-error #'logeqv #'integerp) - nil) - -(deftest logeqv.error.2 - (check-type-error #'(lambda (x) (logeqv 0 x)) #'integerp) - nil) - -;;; Non-error tests - -(deftest logeqv.1 - (logeqv) - -1) - -(deftest logeqv.2 - (logeqv 1231) - 1231) - -(deftest logeqv.3 - (logeqv -198) - -198) - -(deftest logeqv.4 - (loop for x in *integers* - always (eql x (logeqv x))) - t) - -(deftest logeqv.5 - (loop for x in *integers* - always (eql 0 (logeqv x (lognot x)))) - t) - -(deftest logeqv.6 - (loop for x = (random-fixnum) - for xc = (lognot x) - repeat 1000 - unless (eql 0 (logeqv x xc)) - collect x) - nil) - -(deftest logeqv.7 - (loop for x = (random-from-interval (ash 1 (random 200))) - for y = (random-from-interval (ash 1 (random 200))) - for z = (logeqv x y) - repeat 1000 - unless (and (if (or (and (< x 0) (< y 0)) - (and (>= x 0) (>= y 0))) - (< z 0) - (>= z 0)) - (loop for i from 1 to 210 - always (if (or (and (logbitp i x) - (logbitp i y)) - (and (not (logbitp i x)) - (not (logbitp i y)))) - (logbitp i z) - (not (logbitp i z))))) - collect (list x y z)) - nil) - -(deftest logeqv.8 - (loop for i from 1 to (min 256 (1- call-arguments-limit)) - for args = (nconc (make-list (1- i) :initial-element -1) - (list 7131)) - always (eql (apply #'logeqv args) 7131)) - t) - -(deftest logeqv.order.1 - (let ((i 0) a b) - (values - (logeqv (progn (setf a (incf i)) #b11011) - (progn (setf b (incf i)) (lognot #b10110))) - i a b)) - #b1101 2 1 2) - - -(deftest logeqv.order.2 - (let ((i 0) a b c) - (values - (logeqv (progn (setf a (incf i)) #b11011) - (progn (setf b (incf i)) #b10110) - (progn (setf c (incf i)) #b110101)) - i a b c)) - #b111000 3 1 2 3) diff --git a/t/ansi-test/numbers/logior.lsp b/t/ansi-test/numbers/logior.lsp deleted file mode 100644 index b4732ab..0000000 --- a/t/ansi-test/numbers/logior.lsp +++ /dev/null @@ -1,92 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Sep 9 06:08:21 2003 -;;;; Contains: Tests of LOGIOR - - - - - -;;; Error tests - -(deftest logior.error.1 - (check-type-error #'logior #'integerp) - nil) - -(deftest logior.error.2 - (check-type-error #'(lambda (x) (logior 0 x)) #'integerp) - nil) - -;;; Non-error tests - -(deftest logior.1 - (logior) - 0) - -(deftest logior.2 - (logior 1231) - 1231) - -(deftest logior.3 - (logior -198) - -198) - -(deftest logior.4 - (loop for x in *integers* - always (eql x (logior x))) - t) - -(deftest logior.5 - (loop for x in *integers* - always (eql -1 (logior x (lognot x)))) - t) - -(deftest logior.6 - (loop for x = (random-fixnum) - for xc = (lognot x) - repeat 1000 - unless (eql -1 (logior x xc)) - collect x) - nil) - -(deftest logior.7 - (loop for x = (random-from-interval (ash 1 (random 200))) - for y = (random-from-interval (ash 1 (random 200))) - for z = (logior x y) - repeat 1000 - unless (and (if (or (< x 0) (< y 0)) - (< z 0) - (>= z 0)) - (loop for i from 1 to 210 - always (if (or (logbitp i x) - (logbitp i y)) - (logbitp i z) - (not (logbitp i z))))) - collect (list x y z)) - nil) - -(deftest logior.8 - (loop for i from 1 to (min 256 (1- call-arguments-limit)) - for args = (nconc (make-list (1- i) :initial-element 0) - (list -21231)) - always (eql (apply #'logior args) -21231)) - t) - -(deftest logior.order.1 - (let ((i 0) a b) - (values - (logior (progn (setf a (incf i)) #b11010) - (progn (setf b (incf i)) #b10110)) - i a b)) - #b11110 2 1 2) - -(deftest logior.order.2 - (let ((i 0) a b c) - (values - (logior (progn (setf a (incf i)) #b10011) - (progn (setf b (incf i)) #b10110) - (progn (setf c (incf i)) #b110101)) - i a b c)) - #b110111 3 1 2 3) - - diff --git a/t/ansi-test/numbers/lognand.lsp b/t/ansi-test/numbers/lognand.lsp deleted file mode 100644 index cecebf1..0000000 --- a/t/ansi-test/numbers/lognand.lsp +++ /dev/null @@ -1,85 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Sep 9 06:11:12 2003 -;;;; Contains: Tests of LOGNAND - - - - - -;;; Error tests - -(deftest lognand.error.1 - (check-type-error #'(lambda (x) (lognand x 0)) #'integerp) - nil) - -(deftest lognand.error.2 - (check-type-error #'(lambda (x) (lognand 0 x)) #'integerp) - nil) - -(deftest lognand.error.3 - (signals-error (lognand) program-error) - t) - -(deftest lognand.error.4 - (signals-error (lognand 0) program-error) - t) - -(deftest lognand.error.5 - (signals-error (lognand 1 2 3) program-error) - t) - -;;; Non-error tests - -(deftest lognand.1 - (lognand 0 0) - -1) - -(deftest lognand.2 - (lognand 0 -1) - -1) - -(deftest lognand.3 - (lognand -1 123) - -124) - -(deftest lognand.4 - (loop for x in *integers* - always (and (eql -1 (lognand 0 x)) - (eql (lognot x) (lognand x x)) - (eql -1 (lognand (lognot x) x)) - (eql -1 (lognand x (lognot x))))) - t) - -(deftest lognand.5 - (loop for x = (random-fixnum) - for xc = (lognot x) - repeat 1000 - unless (eql -1 (lognand xc x)) - collect x) - nil) - -(deftest lognand.6 - (loop for x = (random-from-interval (ash 1 (random 200))) - for y = (random-from-interval (ash 1 (random 200))) - for z = (lognand x y) - repeat 1000 - unless (and (if (or (>= x 0) (>= y 0)) - (< z 0) - (>= z 0)) - (loop for i from 1 to 210 - always (if (not (and (logbitp i x) - (logbitp i y))) - (logbitp i z) - (not (logbitp i z))))) - collect (list x y z)) - nil) - -(deftest lognand.order.1 - (let ((i 0) a b) - (values - (lognand (progn (setf a (incf i)) -2) - (progn (setf b (incf i)) -3)) - i a b)) - 3 2 1 2) - diff --git a/t/ansi-test/numbers/lognor.lsp b/t/ansi-test/numbers/lognor.lsp deleted file mode 100644 index a081abb..0000000 --- a/t/ansi-test/numbers/lognor.lsp +++ /dev/null @@ -1,86 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Sep 9 06:14:35 2003 -;;;; Contains: Tests of LOGNOR - - - - - -;;; Error tests - -(deftest lognor.error.1 - (check-type-error #'(lambda (x) (lognor x 0)) #'integerp) - nil) - -(deftest lognor.error.2 - (check-type-error #'(lambda (x) (lognor 0 x)) #'integerp) - nil) - -(deftest lognor.error.3 - (signals-error (lognor) program-error) - t) - -(deftest lognor.error.4 - (signals-error (lognor 0) program-error) - t) - -(deftest lognor.error.5 - (signals-error (lognor 1 2 3) program-error) - t) - -;;; Non-error tests - -(deftest lognor.1 - (lognor 0 0) - -1) - -(deftest lognor.2 - (lognor 0 -1) - 0) - -(deftest lognor.3 - (lognor -1 123) - 0) - -(deftest lognor.4 - (loop for x in *integers* - always (and (eql (lognot x) (lognor 0 x)) - (eql (lognot x) (lognor x x)) - (eql 0 (lognor (lognot x) x)) - (eql 0 (lognor x (lognot x))))) - t) - -(deftest lognor.5 - (loop for x = (random-fixnum) - for xc = (lognot x) - repeat 1000 - unless (eql 0 (lognor xc x)) - collect x) - nil) - -(deftest lognor.6 - (loop for x = (random-from-interval (ash 1 (random 200))) - for y = (random-from-interval (ash 1 (random 200))) - for z = (lognor x y) - repeat 1000 - unless (and (if (and (>= x 0) (>= y 0)) - (< z 0) - (>= z 0)) - (loop for i from 1 to 210 - always (if (not (or (logbitp i x) - (logbitp i y))) - (logbitp i z) - (not (logbitp i z))))) - collect (list x y z)) - nil) - -(deftest lognor.order.1 - (let ((i 0) a b) - (values - (lognor (progn (setf a (incf i)) -2) - (progn (setf b (incf i)) -3)) - i a b)) - 0 2 1 2) - - diff --git a/t/ansi-test/numbers/lognot.lsp b/t/ansi-test/numbers/lognot.lsp deleted file mode 100644 index 6247f6c..0000000 --- a/t/ansi-test/numbers/lognot.lsp +++ /dev/null @@ -1,48 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Sep 9 06:16:20 2003 -;;;; Contains: Tests of LOGNOT - - - - - -;;; Error tests - -(deftest lognot.error.1 - (check-type-error #'lognot #'integerp) - nil) - -(deftest lognot.error.2 - (signals-error (lognot) program-error) - t) - -(deftest lognot.error.3 - (signals-error (lognot 0 0) program-error) - t) - -;;; Non-error tests - -(deftest lognot.1 - (lognot 0) - -1) - -(deftest lognot.2 - (lognot -1) - 0) - -(deftest lognot.3 - (lognot 123) - -124) - -(deftest lognot.4 - (loop for x = (random-from-interval (ash 1 (random 200))) - for z = (lognot x) - repeat 1000 - unless (and (if (>= x 0) (< z 0) (>= z 0)) - (loop for i from 1 to 210 - always (if (not (logbitp i x)) - (logbitp i z) - (not (logbitp i z))))) - collect (list x z)) - nil) diff --git a/t/ansi-test/numbers/logorc1.lsp b/t/ansi-test/numbers/logorc1.lsp deleted file mode 100644 index 69de8b9..0000000 --- a/t/ansi-test/numbers/logorc1.lsp +++ /dev/null @@ -1,89 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Sep 9 06:23:43 2003 -;;;; Contains: Tests of LOGORC1 - - - - - -;;; Error tests - -(deftest logorc1.error.1 - (check-type-error #'(lambda (x) (logorc1 x 0)) #'integerp) - nil) - -(deftest logorc1.error.2 - (check-type-error #'(lambda (x) (logorc1 0 x)) #'integerp) - nil) - -(deftest logorc1.error.3 - (signals-error (logorc1) program-error) - t) - -(deftest logorc1.error.4 - (signals-error (logorc1 0) program-error) - t) - -(deftest logorc1.error.5 - (signals-error (logorc1 1 2 3) program-error) - t) - -;;; Non-error tests - -(deftest logorc1.1 - (logorc1 0 0) - -1) - -(deftest logorc1.2 - (logorc1 0 -1) - -1) - -(deftest logorc1.2a - (logorc1 -1 0) - 0) - -(deftest logorc1.3 - (logorc1 123 0) - -124) - -(deftest logorc1.4 - (loop for x in *integers* - always (and (eql -1 (logorc1 0 x)) - (eql x (logorc1 -1 x)) - (eql -1 (logorc1 x x)) - (eql x (logorc1 (lognot x) x)) - (eql (lognot x) (logorc1 x (lognot x))))) - t) - -(deftest logorc1.5 - (loop for x = (random-fixnum) - for xc = (lognot x) - repeat 1000 - unless (eql x (logorc1 xc x)) - collect x) - nil) - -(deftest logorc1.6 - (loop for x = (random-from-interval (ash 1 (random 200))) - for y = (random-from-interval (ash 1 (random 200))) - for z = (logorc1 x y) - repeat 1000 - unless (and (if (or (>= x 0) (< y 0)) - (< z 0) - (>= z 0)) - (loop for i from 1 to 210 - always (if (or (not (logbitp i x)) - (logbitp i y)) - (logbitp i z) - (not (logbitp i z))))) - collect (list x y z)) - nil) - -(deftest logorc1.order.1 - (let ((i 0) a b) - (values - (logorc1 (progn (setf a (incf i)) -3) - (progn (setf b (incf i)) 17)) - i a b)) - 19 2 1 2) diff --git a/t/ansi-test/numbers/logorc2.lsp b/t/ansi-test/numbers/logorc2.lsp deleted file mode 100644 index d6365ee..0000000 --- a/t/ansi-test/numbers/logorc2.lsp +++ /dev/null @@ -1,90 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Sep 9 06:27:45 2003 -;;;; Contains: Tests of LOGORC2 - - - - - -;;; Error tests - -(deftest logorc2.error.1 - (check-type-error #'(lambda (x) (logorc2 x 0)) #'integerp) - nil) - -(deftest logorc2.error.2 - (check-type-error #'(lambda (x) (logorc2 0 x)) #'integerp) - nil) - -(deftest logorc2.error.3 - (signals-error (logorc2) program-error) - t) - -(deftest logorc2.error.4 - (signals-error (logorc2 0) program-error) - t) - -(deftest logorc2.error.5 - (signals-error (logorc2 1 2 3) program-error) - t) - -;;; Non-error tests - -(deftest logorc2.1 - (logorc2 0 0) - -1) - -(deftest logorc2.2 - (logorc2 -1 0) - -1) - -(deftest logorc2.2a - (logorc2 0 -1) - 0) - -(deftest logorc2.3 - (logorc2 0 123) - -124) - -(deftest logorc2.4 - (loop for x in *integers* - always (and (eql -1 (logorc2 x 0)) - (eql x (logorc2 x -1)) - (eql -1 (logorc2 x x)) - (eql x (logorc2 x (lognot x))) - (eql (lognot x) (logorc2 (lognot x) x)))) - t) - -(deftest logorc2.5 - (loop for x = (random-fixnum) - for xc = (lognot x) - repeat 1000 - unless (eql x (logorc2 x xc)) - collect x) - nil) - -(deftest logorc2.6 - (loop for x = (random-from-interval (ash 1 (random 200))) - for y = (random-from-interval (ash 1 (random 200))) - for z = (logorc2 x y) - repeat 1000 - unless (and (if (or (< x 0) (>= y 0)) - (< z 0) - (>= z 0)) - (loop for i from 1 to 210 - always (if (or (not (logbitp i y)) - (logbitp i x)) - (logbitp i z) - (not (logbitp i z))))) - collect (list x y z)) - nil) - -(deftest logorc2.order.1 - (let ((i 0) a b) - (values - (logorc2 (progn (setf a (incf i)) 27) - (progn (setf b (incf i)) -1)) - i a b)) - 27 2 1 2) - diff --git a/t/ansi-test/numbers/logtest.lsp b/t/ansi-test/numbers/logtest.lsp deleted file mode 100644 index 2ba24eb..0000000 --- a/t/ansi-test/numbers/logtest.lsp +++ /dev/null @@ -1,51 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Sep 11 23:22:46 2003 -;;;; Contains: Tests for LOGTEST - - - -;;; Error tests - -(deftest logtest.error.1 - (signals-error (logtest) program-error) - t) - -(deftest logtest.error.2 - (signals-error (logtest 0) program-error) - t) - -(deftest logtest.error.3 - (signals-error (logtest 0 0 nil) program-error) - t) - -(deftest logtest.error.4 - (check-type-error #'(lambda (x) (logtest x -1)) #'integerp) - nil) - -(deftest logtest.error.5 - (check-type-error #'(lambda (x) (logtest -1 x)) #'integerp) - nil) - -;;; Non-error tests - -(deftest logtest.1 - (loop for x = (logand (random-fixnum) (random-fixnum)) - for y = (logand (random-fixnum) (random-fixnum)) - repeat 10000 - unless (if (logtest x y) - (not (zerop (logand x y))) - (zerop (logand x y))) - collect (list x y)) - nil) - -(deftest logtest.2 - (logtest 1 2) - nil) - -(deftest logtest.3 - (notnot-mv (logtest 8 (logior 8 4))) - t) - - - diff --git a/t/ansi-test/numbers/logxor.lsp b/t/ansi-test/numbers/logxor.lsp deleted file mode 100644 index dc23a50..0000000 --- a/t/ansi-test/numbers/logxor.lsp +++ /dev/null @@ -1,99 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Sep 9 06:30:57 2003 -;;;; Contains: Tests of LOGXOR - - - - - -;;; Error tests - -(deftest logxor.error.1 - (check-type-error #'logxor #'integerp) - nil) - -(deftest logxor.error.2 - (check-type-error #'(lambda (x) (logxor 0 x)) #'integerp) - nil) - - -;;; Non-error tests - -(deftest logxor.1 - (logxor) - 0) - -(deftest logxor.2 - (logxor 1231) - 1231) - -(deftest logxor.3 - (logxor -198) - -198) - -(deftest logxor.4 - (loop for x in *integers* - always (eql x (logxor x))) - t) - -(deftest logxor.5 - (loop for x in *integers* - always (and (eql -1 (logxor x (lognot x))) - (eql 0 (logxor x x)) - (eql x (logxor x x x)))) - t) - -(deftest logxor.6 - (loop for x = (random-fixnum) - for xc = (lognot x) - repeat 1000 - unless (eql -1 (logxor x xc)) - collect x) - nil) - -(deftest logxor.7 - (loop for x = (random-from-interval (ash 1 (random 200))) - for y = (random-from-interval (ash 1 (random 200))) - for z = (logxor x y) - repeat 1000 - unless (and (if (or (and (< x 0) (>= y 0)) - (and (>= x 0) (< y 0))) - (< z 0) - (>= z 0)) - (loop for i from 1 to 210 - always (if (or (and (logbitp i x) - (not (logbitp i y))) - (and (not (logbitp i x)) - (logbitp i y))) - (logbitp i z) - (not (logbitp i z))))) - collect (list x y z)) - nil) - -(deftest logxor.8 - (loop for i from 1 to (min 256 (1- call-arguments-limit)) - for args = (nconc (make-list (1- i) :initial-element 0) - (list 7131)) - always (eql (apply #'logxor args) 7131)) - t) - -(deftest logxor.order.1 - (let ((i 0) a b) - (values - (logxor (progn (setf a (incf i)) #b11011) - (progn (setf b (incf i)) #b10110)) - i a b)) - #b1101 2 1 2) - - -(deftest logxor.order.2 - (let ((i 0) a b c) - (values - (logxor (progn (setf a (incf i)) #b11011) - (progn (setf b (incf i)) #b10110) - (progn (setf c (incf i)) #b110101)) - i a b c)) - #b111000 3 1 2 3) - - diff --git a/t/ansi-test/numbers/make-random-state.lsp b/t/ansi-test/numbers/make-random-state.lsp deleted file mode 100644 index f405c3f..0000000 --- a/t/ansi-test/numbers/make-random-state.lsp +++ /dev/null @@ -1,67 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Sep 6 17:53:30 2003 -;;;; Contains: Tests of MAKE-RANDOM-STATE - - - -;;; Error tests - -(deftest make-random-state.error.1 - (signals-error (make-random-state nil nil) program-error) - t) - -(deftest make-random-state.error.2 - (signals-error (make-random-state t nil) program-error) - t) - -(deftest make-random-state.error.3 - (signals-error (make-random-state *random-state* nil) program-error) - t) - -(deftest make-random-state.error.4 - (check-type-error #'make-random-state (typef '(or (member nil t) random-state))) - nil) - -;;; Non-error tests - -(deftest make-random-state.1 - (let ((rs (make-random-state))) - (and (not (eq rs *random-state*)) - (random-state-p rs) - (eqlt (random 1000000) (random 1000000 rs)))) - t) - -(deftest make-random-state.2 - (let ((rs (make-random-state *random-state*))) - (and (not (eq rs *random-state*)) - (random-state-p rs) - (eqlt (random 1000000) (random 1000000 rs)))) - t) - -(deftest make-random-state.3 - (let ((rs (make-random-state))) - (random 10) - (let ((rs2 (make-random-state rs))) - (and (not (eq rs *random-state*)) - (not (eq rs rs2)) - (not (eq rs2 *random-state*)) - (random-state-p rs) - (random-state-p rs2) - (eqlt (random 1.0 rs) (random 1.0 rs2))))) - t) - -(deftest make-random-state.4 - (let ((rs (make-random-state t)) - (rs2 (make-random-state t))) - (and (random-state-p rs) - (not (eq rs *random-state*)) - (random-state-p rs2) - (not (eq rs2 *random-state*)) - (not (eq rs rs2)) - (integerp (random 10 rs)) - (floatp (random 1.0 rs2)) - t)) - t) - - diff --git a/t/ansi-test/numbers/mask-field.lsp b/t/ansi-test/numbers/mask-field.lsp deleted file mode 100644 index 7d2a244..0000000 --- a/t/ansi-test/numbers/mask-field.lsp +++ /dev/null @@ -1,93 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Sep 11 21:27:13 2003 -;;;; Contains: Tests of MASK-FIELD - - - -;;; Error tests - -(deftest mask-field.error.1 - (signals-error (mask-field) program-error) - t) - -(deftest mask-field.error.2 - (signals-error (mask-field (byte 1 1)) program-error) - t) - -(deftest mask-field.error.3 - (signals-error (mask-field (byte 1 1) -1 0) program-error) - t) - -;;; Non-error tests - -(deftest mask-field.1 - (loop for x = (random-fixnum) - for pos = (random 30) - for size = (random 30) - repeat 10000 - unless (eql (mask-field (byte size pos) x) - (logand (ash (1- (ash 1 size)) pos) x)) - collect (list x pos size)) - nil) - - -(deftest mask-field.2 - (let ((bound (ash 1 300))) - (loop for x = (random-from-interval bound) - for pos = (random 300) - for size = (random 300) - repeat 1000 - unless (eql (mask-field (byte size pos) x) - (logand (ash (1- (ash 1 size)) pos) x)) - collect (list x pos size))) - nil) - -(deftest mask-field.3 - (loop for i of-type fixnum from -1000 to 1000 - always (eql (mask-field (byte 0 0) i) 0)) - t) - -(deftest mask-field.order.1 - (let ((i 0) a b c d) - (values - (mask-field (progn (setf a (incf i)) - (byte (progn (setf b (incf i)) 3) - (progn (setf c (incf i)) 1))) - (progn (setf d (incf i)) -1)) - i a b c d)) - 14 4 1 2 3 4) - -;;; mask-field on places - -(deftest mask-field.place.1 - (let ((x 0)) - (values - (setf (mask-field (byte 4 1) x) -1) - x)) - -1 30) - -(deftest mask-field.place.2 - (loop for pos from 0 to 100 - always - (loop for size from 0 to 100 - always - (let ((x 0) - (field (ash 1 pos))) - (and (eql (setf (mask-field (byte size pos) x) field) field) - (if (> size 0) (eql x field) (eql x 0)) - )))) - t) - -(deftest mask-field.place.order.1 - (let ((i 0) a b c d e f (x (copy-seq #(63)))) - (values - (setf (mask-field (progn (setf a (incf i)) - (byte (progn (setf b (incf i)) 3) - (progn (setf c (incf i)) 1))) - (aref (progn (setf d (incf i)) x) - (progn (setf e (incf i)) 0))) - (progn (setf f (incf i)) (lognot 14))) - x - i a b c d e f)) - -15 #(49) 6 1 2 3 4 5 6) diff --git a/t/ansi-test/numbers/max.lsp b/t/ansi-test/numbers/max.lsp deleted file mode 100644 index 8d82470..0000000 --- a/t/ansi-test/numbers/max.lsp +++ /dev/null @@ -1,249 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Aug 3 15:55:17 2003 -;;;; Contains: Tests of MAX - - - - - -;;; Error tests - -(deftest max.error.1 - (signals-error (max) program-error) - t) - -(deftest max.error.2 - (check-type-error #'max #'realp) - nil) - -(deftest max.error.3 - (check-type-error #'(lambda (x) (max 0 x)) #'realp) - nil) - -;;; Non-error tests - -(deftest max.1 - (loop for n in *reals* - when (or (not (eql (max n) n)) - (not (eql (max n n) n)) - (not (eql (max n n n) n)) - (not (eql (apply #'max (make-list - (min 256 (1- call-arguments-limit)) - :initial-element n)) - n))) - collect n) - nil) - -(deftest max.2 - (max.2-fn) - nil) - -(deftest max.3 - (loop for x = (- (random 60000) 30000) - for y = (- (random 60000) 30000) - for m = (max x y) - for m2 = (if (>= x y) x y) - repeat 1000 - unless (eql m m2) - collect (list x y m m2)) - nil) - -(deftest max.4 - (loop for x = (- (random 6000000) 3000000) - for y = (- (random 6000000) 3000000) - for m = (max x y) - for m2 = (if (>= x y) x y) - repeat 1000 - unless (eql m m2) - collect (list x y m m2)) - nil) - -(deftest max.5 - (loop for x = (- (random 1000000000000) 500000000000) - for y = (- (random 1000000000000) 500000000000) - for m = (max x y) - for m2 = (if (>= x y) x y) - repeat 1000 - unless (eql m m2) - collect (list x y m m2)) - nil) - -(deftest max.6 - (let ((m (max 2 1.0s0))) - (or (eqlt m 2) - (eqlt m 2.0s0))) - t) - -(deftest max.7 - (max 0 1.0s0) - 1.0s0) - -(deftest max.8 - (let ((m (max 2 1.0f0))) - (or (eqlt m 2) - (eqlt m 2.0f0))) - t) - -(deftest max.9 - (max 0 1.0f0) - 1.0f0) - -(deftest max.10 - (let ((m (max 2 1.0d0))) - (or (eqlt m 2) - (eqlt m 2.0d0))) - t) - -(deftest max.11 - (max 0 1.0d0) - 1.0d0) - -(deftest max.12 - (let ((m (max 2 1.0l0))) - (or (eqlt m 2) - (eqlt m 2.0l0))) - t) - -(deftest max.13 - (max 0 1.0l0) - 1.0l0) - -(deftest max.15 - (let ((m (max 1.0s0 0.0f0))) - (or (eqlt m 1.0s0) - (eqlt m 1.0f0))) - t) - -(deftest max.16 - (max 0.0s0 1.0f0) - 1.0f0) - -(deftest max.17 - (let ((m (max 1.0s0 0.0d0))) - (or (eqlt m 1.0s0) - (eqlt m 1.0d0))) - t) - -(deftest max.18 - (max 0.0s0 1.0d0) - 1.0d0) - -(deftest max.19 - (let ((m (max 1.0s0 0.0l0))) - (or (eqlt m 1.0s0) - (eqlt m 1.0l0))) - t) - -(deftest max.20 - (max 0.0s0 1.0l0) - 1.0l0) - -(deftest max.21 - (let ((m (max 1.0f0 0.0d0))) - (or (eqlt m 1.0f0) - (eqlt m 1.0d0))) - t) - -(deftest max.22 - (max 0.0f0 1.0d0) - 1.0d0) - -(deftest max.23 - (let ((m (max 1.0f0 0.0l0))) - (or (eqlt m 1.0f0) - (eqlt m 1.0l0))) - t) - -(deftest max.24 - (max 0.0f0 1.0l0) - 1.0l0) - -(deftest max.25 - (let ((m (max 1.0d0 0.0l0))) - (or (eqlt m 1.0d0) - (eqlt m 1.0l0))) - t) - -(deftest max.26 - (max 0.0d0 1.0l0) - 1.0l0) - -(deftest max.27 - (loop for i from 1 to (min 256 (1- call-arguments-limit)) - for x = (make-list i :initial-element 0) - do (setf (elt x (random i)) 1) - unless (eql (apply #'max x) 1) - collect x) - nil) - -(deftest max.28 - (let ((m (max 1/3 0.2s0))) - (or (eqlt m 1/3) - (eqlt m (float 1/3 0.2s0)))) - t) - -(deftest max.29 - (let ((m (max 1.0s0 3 2.0f0))) - (or (eqlt m 3) - (eqlt m 3.0f0))) - t) - -(deftest max.30 - (let ((m (max 1.0d0 3 2.0f0))) - (or (eqlt m 3) - (eqlt m 3.0d0))) - t) - -(deftest max.31 - (let ((m (max 1.0s0 3 2.0l0))) - (or (eqlt m 3) - (eqlt m 3.0l0))) - t) - -(deftest max.32 - (let ((m (max 1.0l0 3 2.0s0))) - (or (eqlt m 3) - (eqlt m 3.0l0))) - t) - -(deftest max.33 - (let ((m (max 1.0d0 3 2.0l0))) - (or (eqlt m 3) - (eqlt m 3.0l0))) - t) - -(deftest max.34 - (let ((m (max 1.0l0 3 2.0d0))) - (or (eqlt m 3) - (eqlt m 3.0l0))) - t) - -(deftest max.order.1 - (let ((i 0) x y) - (values - (max (progn (setf x (incf i)) 10) - (progn (setf y (incf i)) 20)) - i x y)) - 20 2 1 2) - -(deftest max.order.2 - (let ((i 0) x y z) - (values - (max (progn (setf x (incf i)) 10) - (progn (setf y (incf i)) 20) - (progn (setf z (incf i)) 30)) - i x y z)) - 30 3 1 2 3) - -(deftest max.order.3 - (let ((i 0) u v w x y z) - (values - (max (progn (setf u (incf i)) 10) - (progn (setf v (incf i)) 20) - (progn (setf w (incf i)) 30) - (progn (setf x (incf i)) 10) - (progn (setf y (incf i)) 20) - (progn (setf z (incf i)) 30)) - i u v w x y z)) - 30 6 1 2 3 4 5 6) diff --git a/t/ansi-test/numbers/min.lsp b/t/ansi-test/numbers/min.lsp deleted file mode 100644 index e6107ff..0000000 --- a/t/ansi-test/numbers/min.lsp +++ /dev/null @@ -1,245 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Aug 4 21:24:45 2003 -;;;; Contains: Tests of MIN - - - - - -(deftest min.error.1 - (signals-error (min) program-error) - t) - -(deftest min.error.2 - (check-type-error #'min #'realp) - nil) - -(deftest min.error.3 - (check-type-error #'(lambda (x) (min 0 x)) #'realp) - nil) - -(deftest min.1 - (loop for n in *reals* - when (or (not (eql (min n) n)) - (not (eql (min n n) n)) - (not (eql (min n n n) n)) - (not (eql (apply #'min (make-list - (min 256 (1- call-arguments-limit)) - :initial-element n)) - n))) - collect n) - nil) - -(deftest min.2 - (min.2-fn) - nil) - -(deftest min.3 - (loop for x = (- (random 60000) 30000) - for y = (- (random 60000) 30000) - for m = (min x y) - for m2 = (if (<= x y) x y) - repeat 1000 - unless (eql m m2) - collect (list x y m m2)) - nil) - -(deftest min.4 - (loop for x = (- (random 6000000) 3000000) - for y = (- (random 6000000) 3000000) - for m = (min x y) - for m2 = (if (<= x y) x y) - repeat 1000 - unless (eql m m2) - collect (list x y m m2)) - nil) - -(deftest min.5 - (loop for x = (- (random 1000000000000) 500000000000) - for y = (- (random 1000000000000) 500000000000) - for m = (min x y) - for m2 = (if (<= x y) x y) - repeat 1000 - unless (eql m m2) - collect (list x y m m2)) - nil) - -(deftest min.6 - (let ((m (min 0 1.0s0))) - (or (eqlt m 0) - (eqlt m 0.0s0))) - t) - -(deftest min.7 - (min 2 1.0s0) - 1.0s0) - -(deftest min.8 - (let ((m (min 2 3.0f0))) - (or (eqlt m 2) - (eqlt m 2.0f0))) - t) - -(deftest min.9 - (min 2 1.0f0) - 1.0f0) - -(deftest min.10 - (let ((m (min 2 10.0d0))) - (or (eqlt m 2) - (eqlt m 2.0d0))) - t) - -(deftest min.11 - (min 100 1.0d0) - 1.0d0) - -(deftest min.12 - (let ((m (min 2 17.25l0))) - (or (eqlt m 2) - (eqlt m 2.0l0))) - t) - -(deftest min.13 - (min 2 1.0l0) - 1.0l0) - -(deftest min.15 - (let ((m (min 1.0s0 2.0f0))) - (or (eqlt m 1.0s0) - (eqlt m 1.0f0))) - t) - -(deftest min.16 - (min 3.0s0 1.0f0) - 1.0f0) - -(deftest min.17 - (let ((m (min 1.0s0 2.0d0))) - (or (eqlt m 1.0s0) - (eqlt m 1.0d0))) - t) - -(deftest min.18 - (min 5.0s0 1.0d0) - 1.0d0) - -(deftest min.19 - (let ((m (min 1.0s0 2.0l0))) - (or (eqlt m 1.0s0) - (eqlt m 1.0l0))) - t) - -(deftest min.20 - (min 2.0s0 1.0l0) - 1.0l0) - -(deftest min.21 - (let ((m (min 1.0f0 2.0d0))) - (or (eqlt m 1.0f0) - (eqlt m 1.0d0))) - t) - -(deftest min.22 - (min 18.0f0 1.0d0) - 1.0d0) - -(deftest min.23 - (let ((m (min 1.0f0 100.0l0))) - (or (eqlt m 1.0f0) - (eqlt m 1.0l0))) - t) - -(deftest min.24 - (min 19.0f0 1.0l0) - 1.0l0) - -(deftest min.25 - (let ((m (min 1.0d0 12.0l0))) - (or (eqlt m 1.0d0) - (eqlt m 1.0l0))) - t) - -(deftest min.26 - (min 15.0d0 1.0l0) - 1.0l0) - -(deftest min.27 - (loop for i from 1 to (min 256 (1- call-arguments-limit)) - for x = (make-list i :initial-element 1) - do (setf (elt x (random i)) 0) - unless (eql (apply #'min x) 0) - collect x) - nil) - -(deftest min.28 - (let ((m (min 1/3 0.8s0))) - (or (eqlt m 1/3) - (eqlt m (float 1/3 0.8s0)))) - t) - -(deftest min.29 - (let ((m (min 1.0s0 -3 2.0f0))) - (or (eqlt m -3) - (eqlt m -3.0f0))) - t) - -(deftest min.30 - (let ((m (min 1.0d0 -3 2.0f0))) - (or (eqlt m -3) - (eqlt m -3.0d0))) - t) - -(deftest min.31 - (let ((m (min 1.0s0 -3 2.0l0))) - (or (eqlt m -3) - (eqlt m -3.0l0))) - t) - -(deftest min.32 - (let ((m (min 1.0l0 -3 2.0s0))) - (or (eqlt m -3) - (eqlt m -3.0l0))) - t) - -(deftest min.33 - (let ((m (min 1.0d0 -3 2.0l0))) - (or (eqlt m -3) - (eqlt m -3.0l0))) - t) - -(deftest min.34 - (let ((m (min 1.0l0 -3 2.0d0))) - (or (eqlt m -3) - (eqlt m -3.0l0))) - t) - -(deftest min.order.1 - (let ((i 0) x y) - (values - (min (progn (setf x (incf i)) 10) - (progn (setf y (incf i)) 20)) - i x y)) - 10 2 1 2) - -(deftest min.order.2 - (let ((i 0) x y z) - (values - (min (progn (setf x (incf i)) 10) - (progn (setf y (incf i)) 20) - (progn (setf z (incf i)) 30)) - i x y z)) - 10 3 1 2 3) - -(deftest min.order.3 - (let ((i 0) u v w x y z) - (values - (min (progn (setf u (incf i)) 10) - (progn (setf v (incf i)) 20) - (progn (setf w (incf i)) 30) - (progn (setf x (incf i)) 10) - (progn (setf y (incf i)) 20) - (progn (setf z (incf i)) 30)) - i u v w x y z)) - 10 6 1 2 3 4 5 6) diff --git a/t/ansi-test/numbers/minus.lsp b/t/ansi-test/numbers/minus.lsp deleted file mode 100644 index b0514b3..0000000 --- a/t/ansi-test/numbers/minus.lsp +++ /dev/null @@ -1,194 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Aug 31 11:15:14 2003 -;;;; Contains: Tests of the - function - - - - - -(deftest minus.error.1 - (signals-error (-) program-error) - t) - -;;; Unary minus tests -(deftest minus.1 - (loop for x in *numbers* - unless (eql (- (- x)) x) - collect x) - nil) - -(deftest minus.2 - (locally - (declare (notinline -)) - (loop for x in *numbers* - unless (eql (- (- x)) x) - collect x)) - nil) - -(deftest minus.3 - (loop for x in *reals* - when (and (integerp x) - (not (eql (- x) (- 0 x)))) - collect x) - nil) - -(deftest minus.4 - (loop for x in *reals* - for neg = (- x) - when (and (floatp x) - (not (zerop x)) - (not (eql neg (- 0.0s0 x))) - (eql (float 1.0s0 x) - (float 1.0s0 neg))) - collect x) - nil) - -(deftest minus.5 - (loop for x in *numbers* - when (and (complexp x) - (rationalp (realpart x)) - (not (eql (- x) (- 0 x)))) - collect x) - nil) - -(deftest minus.6 - (loop for x in *numbers* - for neg = (- x) - when (and (complexp x) - (floatp (realpart x)) - (eql (float 1.0s0 (realpart x)) - (float 1.0s0 (realpart neg))) - (or (/= neg (- 0 x)) - (and (not (zerop (realpart x))) - (not (eqlzt neg (- 0 x)))))) - collect x) - nil) - -(deftest minus.7 - (let ((upper-bound most-positive-fixnum) - (lower-bound most-negative-fixnum)) - (loop - for x = (+ (random (- upper-bound lower-bound)) lower-bound) - for neg = (- x) - repeat 1000 - unless (and (integerp neg) - (eql (abs x) (abs neg)) - (if (> x 0) (< neg 0) (>= neg 0)) - (zerop (+ x neg)) - (eql x (- neg))) - collect x)) - nil) - -(deftest minus.8 - (let ((upper-bound (ash 1 1000)) - (lower-bound (- (ash 1 1000)))) - (loop - for x = (+ (random (- upper-bound lower-bound)) lower-bound) - for neg = (- x) - repeat 1000 - unless (and (integerp neg) - (eql (abs x) (abs neg)) - (if (> x 0) (< neg 0) (>= neg 0)) - (zerop (+ x neg)) - (eql x (- neg))) - collect x)) - nil) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest minus.9 - (macrolet ((%m (z) z)) (- (expand-in-current-env (%m 1)))) - -1) - -;;; Binary minus tests - -(deftest subtract.1 - (loop - for x = (random-fixnum) - for y = (random-fixnum) - repeat 1000 - unless (and (eql (+ x (- y)) (- x y)) - (eql (+ 1 x (- y)) (- x (1- y))) - (eql (+ -1 x (- y)) (- x (1+ y)))) - collect (list x y)) - nil) - -(deftest subtract.2 - (let ((bound (ash 1 1000))) - (loop - for x = (random-from-interval bound (- bound)) - for y = (random-from-interval bound (- bound)) - repeat 1000 - unless (and (eql (+ x (- y)) (- x y)) - (eql (+ 1 x (- y)) (- x (1- y))) - (eql (+ -1 x (- y)) (- x (1+ y)))) - collect (list x y))) - nil) - -(deftest subtract.3 - (let ((args nil)) - (loop for i from 1 below (min 256 (1- call-arguments-limit)) - do (push 1 args) - always (eql (apply #'- 1000 args) (- 1000 i)))) - t) - -;;; Float contagion - -(deftest subtract.4 - (loop - for type1 in '(short-float single-float double-float long-float) - for bits1 in '(13 24 50 50) - for bound1 = (ash 1 (- bits1 2)) - for c1 from 1 - nconc - (loop for type2 in '(short-float single-float double-float long-float) - for bits2 in '(13 24 50 50) - for bound2 = (ash 1 (- bits2 2)) - for c2 from 1 - nconc - (loop - for i = (random-from-interval bound1) - for x = (coerce i type1) - for j = (random-from-interval bound2) - for y = (coerce j type2) - for idiff1 = (- i j) - for idiff2 = (- j i) - for diff1 = (- x y) - for diff2 = (- y x) - repeat 1000 - unless (or (zerop idiff1) - (and (eql idiff1 (- idiff2)) - (eql diff1 (- diff2)) - (if (<= c1 c2) - (eql (float diff1 y) diff1) - (eql (float diff1 x) diff1)) - (eql (float idiff1 diff1) diff1))) - collect (list i x j y idiff1 idiff2 diff1 diff2)))) - nil) - -;;; Complex subtraction - -(deftest subtract.5 - (loop for i = (random-fixnum) - for ci = (complex i (+ i 100)) - for j = (random-fixnum) - for cj = (complex j (- j 200)) - for diff = (- ci cj) - repeat 1000 - unless (eql diff (complex (- i j) (+ (- i j) 300))) - collect (list i ci j cj (- ci cj))) - nil) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest subtract.6 - (macrolet ((%m (z) z)) - (values - (- (expand-in-current-env (%m 2)) 1) - (- 17 (expand-in-current-env (%m 5))) - (- 1/2 (expand-in-current-env (%m 1/6)) - (expand-in-current-env (%m 0))))) - 1 12 1/3) diff --git a/t/ansi-test/numbers/minusp.lsp b/t/ansi-test/numbers/minusp.lsp deleted file mode 100644 index dd58a39..0000000 --- a/t/ansi-test/numbers/minusp.lsp +++ /dev/null @@ -1,60 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Aug 4 21:33:44 2003 -;;;; Contains: Tests of MINUSP - - - -(deftest minusp.error.1 - (signals-error (minusp) program-error) - t) - -(deftest minusp.error.2 - (signals-error (minusp 0 0) program-error) - t) - -(deftest minusp.error.3 - (signals-error (minusp 0 nil) program-error) - t) - -(deftest minusp.error.4 - (check-type-error #'minusp #'realp) - nil) - -(deftest minusp.1 - (minusp 0) - nil) - -(deftest minusp.2 - (notnot-mv (minusp -1)) - t) - -(deftest minusp.3 - (minusp 1) - nil) - -(deftest minusp.4 - (loop for x in *reals* - when (if (minusp x) (>= x 0) (< x 0)) - collect x) - nil) - -(deftest minusp.5 - (some #'minusp '(-0.0s0 -0.0f0 -0.0d0 -0.0l0)) - nil) - -(deftest minusp.6 - (remove-if #'minusp - (list least-negative-short-float - least-negative-normalized-short-float - least-negative-single-float - least-negative-normalized-single-float - least-negative-double-float - least-negative-normalized-double-float - least-negative-long-float - least-negative-normalized-long-float - most-negative-short-float - most-negative-single-float - most-negative-double-float - most-negative-long-float)) - nil) diff --git a/t/ansi-test/numbers/number-comparison.lsp b/t/ansi-test/numbers/number-comparison.lsp deleted file mode 100644 index 6142b3b..0000000 --- a/t/ansi-test/numbers/number-comparison.lsp +++ /dev/null @@ -1,1763 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Apr 7 07:17:42 2003 -;;;; Contains: Tests of =, /=, <, <=, >, >= - - - - - -;;; Errors tests on comparison functions - -(deftest =.error.1 - (signals-error (=) program-error) - t) - -(deftest /=.error.1 - (signals-error (/=) program-error) - t) - -(deftest <.error.1 - (signals-error (<) program-error) - t) - -(deftest <=.error.1 - (signals-error (<=) program-error) - t) - -(deftest >.error.1 - (signals-error (>) program-error) - t) - -(deftest >=.error.1 - (signals-error (>=) program-error) - t) - -;;; Tests of = - -(deftest =.1 - (loop for x in *numbers* - unless (= x) - collect x) - nil) - -(deftest =.2 - (loop for x in *numbers* - unless (= x x) - collect x) - nil) - -(deftest =.3 - (loop for x in *numbers* - unless (= x x x) - collect x) - nil) - -(deftest =.4 - (=.4-fn) - nil) - -(deftest =.5 - (loop for i from 1 to 10000 - for i2 = (1+ i) - never (or (= i i2) (= i2 i))) - t) - -(deftest =.6 - (loop for i from 5 to 10000 by 17 - for j from 2 to i by 19 - for r = (/ i j) - unless (and (not (= r (1+ r))) - (not (= r 0)) - (not (= r (- r))) - (= r r)) - collect r) - nil) - -(deftest =.7 - (let ((args nil)) - (loop for i from 1 to (min 256 (1- call-arguments-limit)) - do (push 17 args) - always (apply #'= args))) - t) - -(deftest =.8 - (loop for i from 2 to (min 256 (1- call-arguments-limit)) - for args = (append (make-list (1- i) :initial-element 7) - (list 23)) - when (apply #'= args) - collect args) - nil) - - -(deftest =.9 - (=t 0 0.0) - t) - -(deftest =.10 - (=t 0 #c(0 0)) - t) - -(deftest =.11 - (=t 1 #c(1.0 0.0)) - t) - -(deftest =.12 - (=t -0.0 0.0) - t) - -(deftest =.13 - (let ((nums '(0 0.0s0 0.0f0 0.0d0 0.0l0 - #c(0.0s0 0.0s0) #c(0.0f0 0.0f0) - #c(0.0d0 0.0d0) #c(0.0l0 0.0l0)))) - (loop for x in nums - append - (loop for y in nums - unless (= x y) - collect (list x y)))) - nil) - -(deftest =.14 - (let ((nums '(17 17.0s0 17.0f0 17.0d0 17.0l0 - #c(17.0s0 0.0s0) #c(17.0f0 0.0f0) - #c(17.0d0 0.0d0) #c(17.0l0 0.0l0)))) - (loop for x in nums - append - (loop for y in nums - unless (= x y) - collect (list x y)))) - nil) - -(deftest =.15 - (let ((nums '(-17 -17.0s0 -17.0f0 -17.0d0 -17.0l0 - #c(-17.0s0 0.0s0) #c(-17.0f0 0.0f0) - #c(-17.0d0 0.0d0) #c(-17.0l0 0.0l0)))) - (loop for x in nums - append - (loop for y in nums - unless (= x y) - collect (list x y)))) - nil) - -(deftest =.16 - (let ((n 60000) (m 30000)) - (loop for x = (- (random n) m) - for y = (- (random n) m) - for z = (- (random n) m) - for w = (- (random n) m) - for a = (* x y) - for b = (* x w) - for c = (* y z) - for d = (* w z) - repeat 10000 - when (and (/= b 0) - (/= d 0) - (or (not (= (/ a b) (/ c d))) - (/= (/ a b) (/ c d)))) - collect (list a b c d))) - nil) - -;;; Comparison of a rational with a float - -(deftest =.17 - (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) - for eps in (list short-float-epsilon single-float-epsilon - double-float-epsilon long-float-epsilon) - for exp = (nth-value 1 (decode-float eps)) - for radix = (float-radix eps) - when (< (* (log radix 2) exp) 1000) - nconc - (let* ((rat (rational eps)) - (xrat (rational x))) - (loop for i from 2 to 100 - for rat/i = (/ rat i) - for xrat+rat/i = (+ xrat rat/i) - nconc - (if (= x xrat+rat/i) - (list (list x i xrat+rat/i)) - nil)))) - nil) - -(deftest =.18 - (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) - for eps in (list short-float-negative-epsilon single-float-negative-epsilon - double-float-negative-epsilon long-float-negative-epsilon) - for exp = (nth-value 1 (decode-float eps)) - for radix = (float-radix eps) - when (< (* (log radix 2) exp) 1000) - nconc - (let* ((rat (rational eps)) - (xrat (rational x))) - (loop for i from 2 to 100 - for rat/i = (/ rat i) - for xrat-rat/i = (- xrat rat/i) - nconc - (if (= x xrat-rat/i) - (list (list x i xrat-rat/i)) - nil)))) - nil) - -(deftest =.19 - (let ((bound (expt 10 1000))) - (loop for x in (list most-positive-short-float most-positive-single-float - most-positive-double-float most-positive-long-float) - for d = (and (<= x bound) (truncate x)) - when (and d (or (= (* 3/2 d) x) - (= x (* 5/4 d)))) - collect (list x d (* 3/2 d) (* 5/4 d)))) - nil) - -(deftest =.order.1 - (let ((i 0) x y) - (values - (= (progn (setf x (incf i)) 1) - (progn (setf y (incf i)) 2)) - i x y)) - nil 2 1 2) - -(deftest =.order.2 - (let ((i 0) x y z) - (values - (= (progn (setf x (incf i)) 1) - (progn (setf y (incf i)) 2) - (progn (setf z (incf i)) 3)) - i x y z)) - nil 3 1 2 3) - -(deftest =.order.3 - (let ((i 0) u v w x y z) - (values - (= - (progn (setf u (incf i)) 1) - (progn (setf v (incf i)) 2) - (progn (setf w (incf i)) 3) - (progn (setf x (incf i)) 4) - (progn (setf y (incf i)) 5) - (progn (setf z (incf i)) 6)) - i u v w x y z)) - nil 6 1 2 3 4 5 6) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(deftest /=.1 - (loop for x in *numbers* - unless (/= x) - collect x) - nil) - -(deftest /=.2 - (loop for x in *numbers* - when (/= x x) - collect x) - nil) - -(deftest /=.3 - (loop for x in *numbers* - when (/= x x x) - collect x) - nil) - -(deftest /=.4 - (/=.4-fn) - nil) - -(deftest /=.4a - (/=.4a-fn) - nil) - -(deftest /=.5 - (loop for i from 1 to 10000 - for i2 = (1+ i) - always (and (/= i i2) (/= i2 i))) - t) - -(deftest /=.6 - (loop for i from 5 to 10000 by 17 - for j from 2 to i by 19 - for r = (/ i j) - when (or (not (/= r (1+ r))) - (not (/= r 0)) - (not (/= r (- r))) - (/= r r)) - collect r) - nil) - -(deftest /=.7 - (let ((args (list 17)) - (args2 nil)) - (loop for i from 2 to (min 256 (1- call-arguments-limit)) - do (push 17 args) - do (push i args2) - always (and (not (apply #'/= args)) - (apply #'/= args2)))) - t) - -(deftest /=.8 - (loop for i from 2 to (min 256 (1- call-arguments-limit)) - for args = (append (make-list (1- i) :initial-element 7) - (list 7)) - when (apply #'/= args) - collect args) - nil) - - -(deftest /=.9 - (/= 0 0.0) - nil) - -(deftest /=.10 - (/= 0 #c(0 0)) - nil) - -(deftest /=.11 - (/= 1 #c(1.0 0.0)) - nil) - -(deftest /=.12 - (/= -0.0 0.0) - nil) - -(deftest /=.13 - (let ((nums '(0 0.0s0 0.0f0 0.0d0 0.0l0 - #c(0.0s0 0.0s0) #c(0.0f0 0.0f0) - #c(0.0d0 0.0d0) #c(0.0l0 0.0l0)))) - (loop for x in nums - append - (loop for y in nums - when (/= x y) - collect (list x y)))) - nil) - -(deftest /=.14 - (let ((nums '(17 17.0s0 17.0f0 17.0d0 17.0l0 - #c(17.0s0 0.0s0) #c(17.0f0 0.0f0) - #c(17.0d0 0.0d0) #c(17.0l0 0.0l0)))) - (loop for x in nums - append - (loop for y in nums - when (/= x y) - collect (list x y)))) - nil) - -(deftest /=.15 - (let ((nums '(-17 -17.0s0 -17.0f0 -17.0d0 -17.0l0 - #c(-17.0s0 0.0s0) #c(-17.0f0 0.0f0) - #c(-17.0d0 0.0d0) #c(-17.0l0 0.0l0)))) - (loop for x in nums - append - (loop for y in nums - when (/= x y) - collect (list x y)))) - nil) - -(deftest /=.17 - (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) - for eps in (list short-float-epsilon single-float-epsilon - double-float-epsilon long-float-epsilon) - for exp = (nth-value 1 (decode-float eps)) - for radix = (float-radix eps) - when (< (* (log radix 2) exp) 1000) - nconc - (let* ((rat (rational eps)) - (xrat (rational x))) - (loop for i from 2 to 100 - for rat/i = (/ rat i) - for xrat+rat/i = (+ xrat rat/i) - nconc - (if (/= x xrat+rat/i) - nil - (list (list x i xrat+rat/i)))))) - nil) - -(deftest /=.18 - (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) - for eps in (list short-float-negative-epsilon single-float-negative-epsilon - double-float-negative-epsilon long-float-negative-epsilon) - for exp = (nth-value 1 (decode-float eps)) - for radix = (float-radix eps) - when (< (* (log radix 2) exp) 1000) - nconc - (let* ((rat (rational eps)) - (xrat (rational x))) - (loop for i from 2 to 100 - for rat/i = (/ rat i) - for xrat-rat/i = (- xrat rat/i) - nconc - (if (/= x xrat-rat/i) - nil - (list (list x i xrat-rat/i)))))) - nil) - -(deftest /=.19 - (let ((bound (expt 10 1000))) - (loop for x in (list most-positive-short-float most-positive-single-float - most-positive-double-float most-positive-long-float) - for d = (and (<= x bound) (truncate x)) - unless (or (null d) (and (/= (* 3/2 d) x) - (/= x (* 5/4 d)))) - collect (list x d (* 3/2 d) (* 5/4 d)))) - nil) - -(deftest /=.order.1 - (let ((i 0) x y) - (values - (notnot (/= (progn (setf x (incf i)) 1) - (progn (setf y (incf i)) 2))) - i x y)) - t 2 1 2) - -(deftest /=.order.2 - (let ((i 0) x y z) - (values - (notnot (/= (progn (setf x (incf i)) 1) - (progn (setf y (incf i)) 2) - (progn (setf z (incf i)) 3))) - i x y z)) - t 3 1 2 3) - -(deftest /=.order.3 - (let ((i 0) u v w x y z) - (values - (notnot - (/= - (progn (setf u (incf i)) 1) - (progn (setf v (incf i)) 2) - (progn (setf w (incf i)) 3) - (progn (setf x (incf i)) 4) - (progn (setf y (incf i)) 5) - (progn (setf z (incf i)) 6))) - i u v w x y z)) - t 6 1 2 3 4 5 6) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(deftest <.1 - (let ((a 0) (b 1)) (notnot-mv (< a b))) - t) - -(deftest <.2 - (let ((a 0) (b 0)) (notnot-mv (< a b))) - nil) - -(deftest <.3 - (let ((a 1) (b 0)) (notnot-mv (< a b))) - nil) - -(defparameter *number-less-tests* - (let* ((n (- most-positive-fixnum most-negative-fixnum)) - (n2 (* 1000 n))) - (nconc - (loop for i = (+ (random n) most-negative-fixnum) - for i2 = (+ i (random most-positive-fixnum)) - repeat 1000 - nconc - (list (list i i2 t) (list i2 i nil))) - (loop for i = (random n2) - for i2 = (+ (random n2) i) - repeat 1000 - nconc - (list (list i i2 t) (list i2 i nil))) - (loop for x in *universe* - when (integerp x) - nconc (list (list x (1+ x) t) - (list (1+ x) x nil))) - (loop for x in *universe* - when (realp x) - collect (list x x nil)) - - (loop for x in *universe* - when (and (realp x) (>= x 1)) - nconc - (loop for epsilon in (list short-float-epsilon - single-float-epsilon - double-float-epsilon - long-float-epsilon) - for bound in (list most-positive-short-float - most-positive-single-float - most-positive-double-float - most-positive-long-float) - for lower-bound in (list most-negative-short-float - most-negative-single-float - most-negative-double-float - most-negative-long-float) - for one in '(1.0s0 1.0f0 1.0d0 1.0l0) - when (and (<= (abs (float-exponent lower-bound)) 500) - (<= (abs (float-exponent x)) 500) - (<= (abs (float-exponent bound)) 500)) - when (<= (rational lower-bound) - (rational x) - (rational bound)) - nconc - (let* ((y (float x one)) - (z (* y (- one (* 2 epsilon))))) - (list (list y z nil) - (list z y t))))) - - (loop for x in *universe* - when (and (realp x) (<= x -1)) - nconc - (loop for epsilon in (list short-float-epsilon - single-float-epsilon - double-float-epsilon - long-float-epsilon) - for bound in (list most-negative-short-float - most-negative-single-float - most-negative-double-float - most-negative-long-float) - for upper-bound in (list most-positive-short-float - most-positive-single-float - most-positive-double-float - most-positive-long-float) - for one in '(1.0s0 1.0f0 1.0d0 1.0l0) - when (and (<= (abs (float-exponent bound)) 500) - (<= (abs (float-exponent x)) 500) - (<= (abs (float-exponent upper-bound)) 500)) - when (<= (rational bound) - (rational x) - (rational upper-bound)) - nconc - (let* ((y (float x one))) - (let ((z (* y (- one (* 2 epsilon))))) - (list (list y z t) - (list z y nil)))))) - - (loop for x in *universe* - when (and (realp x) (< -1 x 1)) - nconc - (loop for epsilon in (list short-float-epsilon - single-float-epsilon - double-float-epsilon - long-float-epsilon) - for lower-bound in (list most-negative-short-float - most-negative-single-float - most-negative-double-float - most-negative-long-float) - for upper-bound in (list most-positive-short-float - most-positive-single-float - most-positive-double-float - most-positive-long-float) - for one in '(1.0s0 1.0f0 1.0d0 1.0l0) - when (and (<= (abs (float-exponent lower-bound)) 500) - (<= (abs (float-exponent x)) 500) - (<= (abs (float-exponent upper-bound)) 500)) - when (<= (rational lower-bound) - (rational x) - (rational upper-bound)) - nconc - (handler-case - (let* ((y (float x one)) - (z1 (+ y epsilon)) - (z2 (- y epsilon))) - (list (list y z1 t) - (list z1 y nil) - (list y z2 nil) - (list z2 y t))) - (arithmetic-error () nil))) - )))) - -(deftest <.4 - (loop for (x y result . rest) in *number-less-tests* - unless (if (< x y) result (not result)) - collect (list* x y result rest)) - nil) - -(deftest <.5 - (loop for x in *universe* - when (and (typep x 'real) - (not (< x))) - collect x) - nil) - -(deftest <.6 - (let ((args (list 17)) - (args2 nil)) - (loop for i from 2 to (min 256 (1- call-arguments-limit)) - do (push 17 args) - do (push (- i) args2) - unless (and (not (apply #'< args)) - (apply #'< args2)) - collect (list args args2))) - nil) - -(deftest <.7 - (let* ((len (min 256 (1- call-arguments-limit))) - (args-proto (loop for i from 1 to len collect i))) - (loop for i from 1 below len - for args = (copy-list args-proto) - do (setf (elt args i) 0) - never (apply #'< args))) - t) - -;;; Check that < is antisymmetric -(deftest <.8 - (<.8-fn) - nil) - -;;; < is symmetric with > -(deftest <.9 - (<.9-fn) - nil) - -;;; < is negation of >= -(deftest <.10 - (<.10-fn) - nil) - -(deftest <.11 - (loop for x in '(0.0s0 0.0f0 0.0d0 0.0l0) - never (or (< (- x) x) - (< x (- x)))) - t) - -(deftest <.17 - (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) - for eps in (list short-float-epsilon single-float-epsilon - double-float-epsilon long-float-epsilon) - for exp = (nth-value 1 (decode-float eps)) - for radix = (float-radix eps) - when (< (* (log radix 2) exp) 1000) - nconc - (let* ((rat (rational eps)) - (xrat (rational x))) - (loop for i from 2 to 100 - for rat/i = (/ rat i) - for xrat+rat/i = (+ xrat rat/i) - nconc - (if (< x xrat+rat/i) - nil - (list (list x i xrat+rat/i)))))) - nil) - -(deftest <.18 - (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) - for eps in (list short-float-negative-epsilon single-float-negative-epsilon - double-float-negative-epsilon long-float-negative-epsilon) - for exp = (nth-value 1 (decode-float eps)) - for radix = (float-radix eps) - when (< (* (log radix 2) exp) 1000) - nconc - (let* ((rat (rational eps)) - (xrat (rational x))) - (loop for i from 2 to 100 - for rat/i = (/ rat i) - for xrat-rat/i = (- xrat rat/i) - nconc - (if (< x xrat-rat/i) - (list (list x i xrat-rat/i)) - nil)))) - nil) - -(deftest <.19 - (let ((bound (expt 10 1000))) - (loop for x in (list most-positive-short-float most-positive-single-float - most-positive-double-float most-positive-long-float) - for d = (and (<= x bound) (truncate x)) - unless (or (null d) (and (< x (* 3/2 d)) - (not (< (* 17/16 d) x)))) - collect (list x d (* 3/2 d) (* 17/16 d)))) - nil) - -(deftest <.order.1 - (let ((i 0) x y) - (values - (notnot (< (progn (setf x (incf i)) 1) - (progn (setf y (incf i)) 2))) - i x y)) - t 2 1 2) - -(deftest <.order.2 - (let ((i 0) x y z) - (values - (notnot (< (progn (setf x (incf i)) 1) - (progn (setf y (incf i)) 2) - (progn (setf z (incf i)) 3))) - i x y z)) - t 3 1 2 3) - -(deftest <.order.3 - (let ((i 0) u v w x y z) - (values - (notnot - (< - (progn (setf u (incf i)) 1) - (progn (setf v (incf i)) 2) - (progn (setf w (incf i)) 3) - (progn (setf x (incf i)) 4) - (progn (setf y (incf i)) 5) - (progn (setf z (incf i)) 6))) - i u v w x y z)) - t 6 1 2 3 4 5 6) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(deftest <=.1 - (let ((a 0) (b 1)) (notnot-mv (<= a b))) - t) - -(deftest <=.2 - (let ((a 0) (b 0)) (notnot-mv (<= a b))) - t) - -(deftest <=.3 - (let ((a 1) (b 0)) (notnot-mv (<= a b))) - nil) - -(defparameter *number-less-or-equal-tests* - (let* ((n (- most-positive-fixnum most-negative-fixnum)) - (n2 (* 1000 n))) - (nconc - (loop for i = (+ (random n) most-negative-fixnum) - for i2 = (+ i (random most-positive-fixnum)) - repeat 1000 - nconc - (list (list i i2 t) (list i2 i nil))) - (loop for i = (random n2) - for i2 = (+ (random n2) i) - repeat 1000 - nconc - (list (list i i2 t) (list i2 i nil))) - (loop for x in *universe* - when (integerp x) - nconc (list (list x (1+ x) t) - (list (1+ x) x nil))) - (loop for x in *universe* - when (realp x) - collect (list x x t)) - - (loop for x in *universe* - when (and (realp x) (>= x 1)) - nconc - (loop for epsilon in (list short-float-epsilon - single-float-epsilon - double-float-epsilon - long-float-epsilon) - for bound in (list most-positive-short-float - most-positive-single-float - most-positive-double-float - most-positive-long-float) - for lower-bound in (list most-negative-short-float - most-negative-single-float - most-negative-double-float - most-negative-long-float) - for one in '(1.0s0 1.0f0 1.0d0 1.0l0) - when (and (<= (abs (float-exponent lower-bound)) 500) - (<= (abs (float-exponent x)) 500) - (<= (abs (float-exponent bound)) 500)) - when (<= (rational lower-bound) - (rational x) - (rational bound)) - nconc - (let* ((y (float x one)) - (z (* y (- one (* 2 epsilon))))) - (list (list y z nil) - (list z y t))))) - (loop for x in *universe* - when (and (realp x) (<= x -1)) - nconc - (loop for epsilon in (list short-float-epsilon - single-float-epsilon - double-float-epsilon - long-float-epsilon) - for bound in (list most-negative-short-float - most-negative-single-float - most-negative-double-float - most-negative-long-float) - for upper-bound in (list most-positive-short-float - most-positive-single-float - most-positive-double-float - most-positive-long-float) - for one in '(1.0s0 1.0f0 1.0d0 1.0l0) - when (and (<= (abs (float-exponent bound)) 500) - (<= (abs (float-exponent x)) 500) - (<= (abs (float-exponent upper-bound)) 500)) - when (<= (rational bound) - (rational x) - (rational upper-bound)) - nconc - (let* ((y (float x one)) - (z (* y (- one (* 2 epsilon))))) - (list (list y z t) - (list z y nil))))) - (loop for x in *universe* - when (and (realp x) (< -1 x 1)) - nconc - (loop for epsilon in (list short-float-epsilon - single-float-epsilon - double-float-epsilon - long-float-epsilon) - for lower-bound in (list most-negative-short-float - most-negative-single-float - most-negative-double-float - most-negative-long-float) - for upper-bound in (list most-positive-short-float - most-positive-single-float - most-positive-double-float - most-positive-long-float) - for one in '(1.0s0 1.0f0 1.0d0 1.0l0) - when (and (<= (abs (float-exponent lower-bound)) 500) - (<= (abs (float-exponent x)) 500) - (<= (abs (float-exponent upper-bound)) 500)) - when (<= (rational lower-bound) - (rational x) - (rational upper-bound)) - nconc - (handler-case - (let* ((y (float x one)) - (z1 (+ y epsilon)) - (z2 (- y epsilon))) - (list (list y z1 t) - (list z1 y nil) - (list y z2 nil) - (list z2 y t))) - (floating-point-underflow () nil)))) - ))) - -(deftest <=.4 - (loop for (x y result . rest) in *number-less-or-equal-tests* - unless (if (<= x y) result (not result)) - collect (list* x y result rest)) - nil) - -(deftest <=.5 - (loop for x in *universe* - when (and (typep x 'real) - (not (<= x))) - collect x) - nil) - -(deftest <=.6 - (let ((args (list 17)) - (args2 nil) - (args3 (list 0))) - (loop for i from 2 to (min 256 (1- call-arguments-limit)) - do (push 17 args) - do (push (- i) args2) - do (push i args3) - unless (and (apply #'<= args) - (apply #'<= args2) - (not (apply #'<= args3))) - collect (list args args2 args3))) - nil) - -(deftest <=.7 - (let* ((len (min 256 (1- call-arguments-limit))) - (args-proto (loop for i from 1 to len collect i))) - (loop for i from 1 below len - for args = (copy-list args-proto) - do (setf (elt args i) 0) - never (apply #'<= args))) - t) - -;;; Check that <= is symmetric with >= -(deftest <=.8 - (<=.8-fn) - nil) - -;;; Check that <= is equivalent to (or < =) -(deftest <=.9 - (<=.9-fn) - nil) - -(deftest <=.10 - (loop for x in '(0.0s0 0.0f0 0.0d0 0.0l0) - always (and (<= (- x) x) - (<= x (- x)))) - t) - -(deftest <=.17 - (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) - for eps in (list short-float-epsilon single-float-epsilon - double-float-epsilon long-float-epsilon) - for exp = (nth-value 1 (decode-float eps)) - for radix = (float-radix eps) - when (< (* (log radix 2) exp) 1000) - nconc - (let* ((rat (rational eps)) - (xrat (rational x))) - (loop for i from 2 to 100 - for rat/i = (/ rat i) - for xrat+rat/i = (+ xrat rat/i) - nconc - (if (<= x xrat+rat/i) - nil - (list (list x i xrat+rat/i)))))) - nil) - -(deftest <=.18 - (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) - for eps in (list short-float-negative-epsilon single-float-negative-epsilon - double-float-negative-epsilon long-float-negative-epsilon) - for exp = (nth-value 1 (decode-float eps)) - for radix = (float-radix eps) - when (< (* (log radix 2) exp) 1000) - nconc - (let* ((rat (rational eps)) - (xrat (rational x))) - (loop for i from 2 to 100 - for rat/i = (/ rat i) - for xrat-rat/i = (- xrat rat/i) - nconc - (if (<= x xrat-rat/i) - (list (list x i xrat-rat/i)) - nil)))) - nil) - -(deftest <=.19 - (let ((bound (expt 10 1000))) - (loop for x in (list most-positive-short-float most-positive-single-float - most-positive-double-float most-positive-long-float) - for d = (and (<= x bound) (truncate x)) - unless (or (null d) (and (<= x (* 3/2 d)) - (not (<= (* 5/4 d) x)))) - collect (list x d (* 3/2 d) (* 5/4 d)))) - nil) - -(deftest <=.order.1 - (let ((i 0) x y) - (values - (notnot (<= (progn (setf x (incf i)) 1) - (progn (setf y (incf i)) 2))) - i x y)) - t 2 1 2) - -(deftest <=.order.2 - (let ((i 0) x y z) - (values - (notnot (<= (progn (setf x (incf i)) 1) - (progn (setf y (incf i)) 2) - (progn (setf z (incf i)) 3))) - i x y z)) - t 3 1 2 3) - -(deftest <=.order.3 - (let ((i 0) u v w x y z) - (values - (notnot - (<= - (progn (setf u (incf i)) 1) - (progn (setf v (incf i)) 2) - (progn (setf w (incf i)) 3) - (progn (setf x (incf i)) 4) - (progn (setf y (incf i)) 5) - (progn (setf z (incf i)) 6))) - i u v w x y z)) - t 6 1 2 3 4 5 6) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(deftest >.1 - (let ((a 0) (b 1)) (notnot-mv (> a b))) - nil) - -(deftest >.2 - (let ((a 0) (b 0)) (notnot-mv (> a b))) - nil) - -(deftest >.3 - (let ((a 1) (b 0)) (notnot-mv (> a b))) - t) - -(deftest >.4 - (loop for (x y result . rest) in *number-less-tests* - unless (if (> y x) result (not result)) - collect (list* y x result rest)) - nil) - -(deftest >.5 - (loop for x in *universe* - when (and (typep x 'real) - (not (> x))) - collect x) - nil) - -(deftest >.6 - (let ((args (list 17)) - (args2 nil)) - (loop for i from 2 to (min 256 (1- call-arguments-limit)) - do (push 17 args) - do (push i args2) - unless (and (not (apply #'> args)) - (apply #'> args2)) - collect (list args args2))) - nil) - -(deftest >.7 - (let* ((len (min 256 (1- call-arguments-limit))) - (args-proto (loop for i from 1 to len collect i))) - (loop for i from 1 below len - for args = (copy-list args-proto) - do (setf (elt args i) 0) - never (apply #'> args))) - t) - -;;; > is negation of <= -(deftest >.8 - (>.8-fn) - nil) - -(deftest >.9 - (loop for x in '(0.0s0 0.0f0 0.0d0 0.0l0) - never (or (> (- x) x) - (> x (- x)))) - t) - -(deftest >.17 - (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) - for eps in (list short-float-epsilon single-float-epsilon - double-float-epsilon long-float-epsilon) - for exp = (nth-value 1 (decode-float eps)) - for radix = (float-radix eps) - when (< (* (log radix 2) exp) 1000) - nconc - (let* ((rat (rational eps)) - (xrat (rational x))) - (loop for i from 2 to 100 - for rat/i = (/ rat i) - for xrat+rat/i = (+ xrat rat/i) - nconc - (if (> x xrat+rat/i) - (list (list x i xrat+rat/i)) - nil)))) - nil) - -(deftest >.18 - (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) - for eps in (list short-float-negative-epsilon single-float-negative-epsilon - double-float-negative-epsilon long-float-negative-epsilon) - for exp = (nth-value 1 (decode-float eps)) - for radix = (float-radix eps) - when (< (* (log radix 2) exp) 1000) - nconc - (let* ((rat (rational eps)) - (xrat (rational x))) - (loop for i from 2 to 100 - for rat/i = (/ rat i) - for xrat-rat/i = (- xrat rat/i) - nconc - (if (> x xrat-rat/i) - nil - (list (list x i xrat-rat/i)))))) - nil) - -(deftest >.19 - (let ((bound (expt 10 1000))) - (loop for x in (list most-positive-short-float most-positive-single-float - most-positive-double-float most-positive-long-float) - for d = (and (<= x bound) (truncate x)) - unless (or (null d) (and (> (* 3/2 d) x) - (not (> x (* 17/16 d))))) - collect (list x d (* 3/2 d) (* 17/16 d)))) - nil) - -(deftest >.order.1 - (let ((i 0) x y) - (values - (notnot (> (progn (setf x (incf i)) 2) - (progn (setf y (incf i)) 1))) - i x y)) - t 2 1 2) - -(deftest >.order.2 - (let ((i 0) x y z) - (values - (notnot (> (progn (setf x (incf i)) 3) - (progn (setf y (incf i)) 2) - (progn (setf z (incf i)) 1))) - i x y z)) - t 3 1 2 3) - -(deftest >.order.3 - (let ((i 0) u v w x y z) - (values - (notnot - (> - (progn (setf u (incf i)) 6) - (progn (setf v (incf i)) 5) - (progn (setf w (incf i)) 4) - (progn (setf x (incf i)) 3) - (progn (setf y (incf i)) 2) - (progn (setf z (incf i)) 1))) - i u v w x y z)) - t 6 1 2 3 4 5 6) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(deftest >=.1 - (let ((a 0) (b 1)) (notnot-mv (>= a b))) - nil) - -(deftest >=.2 - (let ((a 0) (b 0)) (notnot-mv (>= a b))) - t) - -(deftest >=.3 - (let ((a 1) (b 0)) (notnot-mv (>= a b))) - t) - -(deftest >=.4 - (loop for (x y result . rest) in *number-less-or-equal-tests* - unless (if (>= y x) result (not result)) - collect (list* y x result rest)) - nil) - -(deftest >=.5 - (loop for x in *universe* - when (and (typep x 'real) - (not (>= x))) - collect x) - nil) - -(deftest >=.6 - (let ((args (list 17)) - (args2 (list 0)) - (args3 nil)) - (loop for i from 2 to (min 256 (1- call-arguments-limit)) - do (push 17 args) - do (push (- i) args2) - do (push i args3) - unless (and (apply #'>= args) - (not (apply #'>= args2)) - (apply #'>= args3)) - collect (list args args2 args3))) - nil) - -(deftest >=.7 - (let* ((len (min 256 (1- call-arguments-limit))) - (args-proto (loop for i from 1 to len collect i))) - (loop for i from 1 below len - for args = (copy-list args-proto) - do (setf (elt args i) 0) - never (apply #'>= args))) - t) - -;;; Check that >= is equivalent to (or > =) -(deftest >=.8 - (>=.8-fn) - nil) - -(deftest >=.9 - (loop for x in '(0.0s0 0.0f0 0.0d0 0.0l0) - always (and (>= (- x) x) - (>= x (- x)))) - t) - - -(deftest >=.17 - (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) - for eps in (list short-float-epsilon single-float-epsilon - double-float-epsilon long-float-epsilon) - for exp = (nth-value 1 (decode-float eps)) - for radix = (float-radix eps) - when (< (* (log radix 2) exp) 1000) - nconc - (let* ((rat (rational eps)) - (xrat (rational x))) - (loop for i from 2 to 100 - for rat/i = (/ rat i) - for xrat+rat/i = (+ xrat rat/i) - nconc - (if (>= x xrat+rat/i) - (list (list x i xrat+rat/i)) - nil)))) - nil) - -(deftest >=.18 - (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) - for eps in (list short-float-negative-epsilon single-float-negative-epsilon - double-float-negative-epsilon long-float-negative-epsilon) - for exp = (nth-value 1 (decode-float eps)) - for radix = (float-radix eps) - when (< (* (log radix 2) exp) 1000) - nconc - (let* ((rat (rational eps)) - (xrat (rational x))) - (loop for i from 2 to 100 - for rat/i = (/ rat i) - for xrat-rat/i = (- xrat rat/i) - nconc - (if (>= x xrat-rat/i) - nil - (list (list x i xrat-rat/i)))))) - nil) - -(deftest >=.19 - (let ((bound (expt 10 1000))) - (loop for x in (list most-positive-short-float most-positive-single-float - most-positive-double-float most-positive-long-float) - for d = (and (<= x bound) (truncate x)) - unless (or (null d) (and (>= (* 3/2 d) x) - (not (>= x(* 17/16 d))))) - collect (list x d (* 3/2 d) (* 17/16 d)))) - nil) - -(deftest >=.order.1 - (let ((i 0) x y) - (values - (notnot (>= (progn (setf x (incf i)) 2) - (progn (setf y (incf i)) 1))) - i x y)) - t 2 1 2) - -(deftest >=.order.2 - (let ((i 0) x y z) - (values - (notnot (>= (progn (setf x (incf i)) 3) - (progn (setf y (incf i)) 2) - (progn (setf z (incf i)) 1))) - i x y z)) - t 3 1 2 3) - -(deftest >=.order.3 - (let ((i 0) u v w x y z) - (values - (notnot - (>= - (progn (setf u (incf i)) 6) - (progn (setf v (incf i)) 5) - (progn (setf w (incf i)) 4) - (progn (setf x (incf i)) 3) - (progn (setf y (incf i)) 2) - (progn (setf z (incf i)) 1))) - i u v w x y z)) - t 6 1 2 3 4 5 6) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Comparison of rationals - -(deftest compare-rationals.1 - (compare-random-rationals 60000 30000 10000) - nil) - -(deftest compare-rationals.2 - (compare-random-rationals 600000 300000 10000) - nil) - -(deftest compare-rationals.3 - (compare-random-rationals 6000000 3000000 10000) - nil) - -(deftest compare-rationals.4 - (compare-random-rationals 6000000000 3000000000 10000) - nil) - -;;;; Comparison of bignums with floats - -(deftest bignum.float.compare.1a - (loop for x in *floats* - when (or (zerop x) - (< (abs (log (abs x))) 10000)) - nconc - (loop for r = (1+ (random (ash 1 (random 32)))) - repeat 200 - nconc - (let ((i (+ r (ceiling (rational x))))) - (unless (< x i) - (list (list r x i)))))) - nil) - -(deftest bignum.float.compare.1b - (loop for x in *floats* - when (or (zerop x) - (< (abs (log (abs x))) 10000)) - nconc - (loop for r = (1+ (random (ash 1 (random 32)))) - repeat 200 - nconc - (let ((i (- (floor (rational x)) r))) - (unless (< i x) - (list (list r x i)))))) - nil) - -(deftest bignum.float.compare.2a - (loop for x in *floats* - when (or (zerop x) - (< (abs (log (abs x))) 10000)) - nconc - (loop for r = (1+ (random (ash 1 (random 32)))) - repeat 200 - nconc - (let ((i (+ r (ceiling (rational x))))) - (unless (> i x) - (list (list r x i)))))) - nil) - -(deftest bignum.float.compare.2b - (loop for x in *floats* - when (or (zerop x) - (< (abs (log (abs x))) 10000)) - nconc - (loop for r = (1+ (random (ash 1 (random 32)))) - repeat 200 - nconc - (let ((i (- (floor (rational x)) r))) - (unless (> x i) - (list (list r x i)))))) - nil) - -(deftest bignum.float.compare.3a - (loop for x in *floats* - when (or (zerop x) - (< (abs (log (abs x))) 10000)) - nconc - (loop for r = (1+ (random (ash 1 (random 32)))) - repeat 200 - nconc - (let ((i (+ r (ceiling (rational x))))) - (when (or (= x i) (= i x)) - (list (list r x i)))))) - nil) - -(deftest bignum.float.compare.3b - (loop for x in *floats* - when (or (zerop x) - (< (abs (log (abs x))) 10000)) - nconc - (loop for r = (1+ (random (ash 1 (random 32)))) - repeat 200 - nconc - (let ((i (- (floor (rational x)) r))) - (when (or (= x i) (= i x)) - (list (list r x i)))))) - nil) - -(deftest bignum.float.compare.4a - (loop for x in *floats* - when (or (zerop x) - (< (abs (log (abs x))) 10000)) - nconc - (loop for r = (1+ (random (ash 1 (random 32)))) - repeat 200 - nconc - (let ((i (+ r (ceiling (rational x))))) - (unless (and (/= i x) (/= x i)) - (list (list r x i)))))) - nil) - -(deftest bignum.float.compare.4b - (loop for x in *floats* - when (or (zerop x) - (< (abs (log (abs x))) 10000)) - nconc - (loop for r = (1+ (random (ash 1 (random 32)))) - repeat 200 - nconc - (let ((i (- (floor (rational x)) r))) - (unless (and (/= i x) (/= x i)) - (list (list r x i)))))) - nil) - -(deftest bignum.float.compare.5a - (loop for x in *floats* - when (or (zerop x) - (< (abs (log (abs x))) 10000)) - nconc - (loop for r = (1+ (random (ash 1 (random 32)))) - repeat 200 - nconc - (let ((i (+ r (ceiling (rational x))))) - (unless (<= x i) - (list (list r x i)))))) - nil) - -(deftest bignum.float.compare.5b - (loop for x in *floats* - when (or (zerop x) - (< (abs (log (abs x))) 10000)) - nconc - (loop for r = (1+ (random (ash 1 (random 32)))) - repeat 200 - nconc - (let ((i (- (floor (rational x)) r))) - (unless (<= i x) - (list (list r x i)))))) - nil) - -(deftest bignum.float.compare.6a - (loop for x in *floats* - when (or (zerop x) - (< (abs (log (abs x))) 10000)) - nconc - (loop for r = (1+ (random (ash 1 (random 32)))) - repeat 200 - nconc - (let ((i (+ r (ceiling (rational x))))) - (unless (>= i x) - (list (list r x i)))))) - nil) - -(deftest bignum.float.compare.6b - (loop for x in *floats* - when (or (zerop x) - (< (abs (log (abs x))) 10000)) - nconc - (loop for r = (1+ (random (ash 1 (random 32)))) - repeat 200 - nconc - (let ((i (- (floor (rational x)) r))) - (unless (>= x i) - (list (list r x i)))))) - nil) - -(deftest bignum.float.compare.7 - (let ((toobig (loop for x in *reals* - collect (and (> (abs x) 1.0) - (> (abs (log (abs x))) 10000))))) - (loop for x in *reals* - for xtoobig in toobig - nconc - (unless xtoobig - (let ((fx (floor x))) - (loop for y in *reals* - for ytoobig in toobig - when (and (not ytoobig) - (< x y) - (or (not (< fx y)) - (<= y fx) - (not (> y fx)) - (>= fx y))) - collect (list x y)))))) - nil) - -(deftest bignum.float.compare.8 - (let ((toobig (loop for x in *reals* - collect (and (> (abs x) 1.0) - (> (abs (log (abs x))) 10000))))) - (loop for x in *reals* - for xtoobig in toobig - nconc - (unless xtoobig - (let ((fx (floor x))) - (loop for y in *reals* - for ytoobig in toobig - when (and (not ytoobig) - (<= x y) - (or (not (<= fx y)) - (> fx y) - (not (>= y fx)) - (< y fx))) - collect (list x y)))))) - nil) - -;;; More randomized comparisons - -(deftest bignum.short-float.random.compare.1 - (let* ((integer-bound (ash 1 1000)) - (upper-bound (if (< (/ most-positive-short-float 2) integer-bound) - (/ most-positive-short-float 2) - (coerce integer-bound 'short-float)))) - (loop for bound = 1.0s0 then (* bound 2) - while (<= bound upper-bound) - nconc - (loop for r = (random bound) - for fr = (floor r) - for cr = (ceiling r) - repeat 20 - unless (and (<= fr r cr) - (if (= r fr) - (= r cr) - (/= r cr)) - (>= cr r fr)) - collect (list r fr cr)))) - nil) - -(deftest bignum.single-float.random.compare.1 - (let* ((integer-bound (ash 1 100)) - (upper-bound (if (< (/ most-positive-single-float 2) integer-bound) - (/ most-positive-single-float 2) - (coerce integer-bound 'single-float)))) - (loop for bound = 1.0f0 then (* bound 2) - while (<= bound upper-bound) - nconc - (loop for r = (random bound) - for fr = (floor r) - for cr = (ceiling r) - repeat 20 - unless (and (<= fr r cr) - (if (= r fr) - (= r cr) - (/= r cr)) - (>= cr r fr)) - collect (list r fr cr)))) - nil) - -(deftest bignum.double-float.random.compare.1 - (let* ((integer-bound (ash 1 100)) - (upper-bound (if (< (/ most-positive-double-float 2) integer-bound) - (/ most-positive-double-float 2) - (coerce integer-bound 'double-float)))) - (loop for bound = 1.0d0 then (* bound 2) - while (<= bound upper-bound) - nconc - (loop for r = (random bound) - for fr = (floor r) - for cr = (ceiling r) - repeat 20 - unless (and (<= fr r cr) - (if (= r fr) - (= r cr) - (/= r cr)) - (>= cr r fr)) - collect (list r fr cr)))) - nil) - -(deftest bignum.long-float.random.compare.1 - (let* ((integer-bound (ash 1 100)) - (upper-bound (if (< (/ most-positive-long-float 2) integer-bound) - (/ most-positive-long-float 2) - (coerce integer-bound 'long-float)))) - (loop for bound = 1.0l0 then (* bound 2) - while (< bound upper-bound) - nconc - (loop for r = (random bound) - for fr = (floor r) - for cr = (ceiling r) - repeat 20 - unless (and (<= fr r cr) - (if (= r fr) - (= r cr) - (/= r cr)) - (>= cr r fr)) - collect - (list r fr cr)))) - nil) - -;;; Rational/float comparisons - -(deftest rational.short-float.random.compare.1 - (let* ((integer-bound (ash 1 1000)) - (upper-bound (if (< (/ most-positive-short-float 2) integer-bound) - (/ most-positive-short-float 2) - (coerce integer-bound 'short-float)))) - (loop for bound = 1.0s0 then (* bound 2) - while (<= bound upper-bound) - nconc - (loop for r = (+ 1.s0 (random bound)) - for fr = (floor r) - for cr = (ceiling r) - for m = (ash 1 (1+ (random 30))) - for p = (1+ (random m)) - for q = (1+ (random m)) - for x = 0 - repeat 50 - when (<= p q) do (psetf p (1+ q) q p) - do (setf x (/ p q)) - unless (let ((fr/x (/ fr x)) - (cr*x (* cr x))) - (and (<= fr/x r cr*x) - (< fr/x r cr*x) - (> cr*x r fr/x) - (>= cr*x r fr/x))) - collect (list r p q x fr cr)))) - nil) - -(deftest rational.single-float.random.compare.1 - (let* ((integer-bound (ash 1 1000)) - (upper-bound (if (< (/ most-positive-single-float 2) integer-bound) - (/ most-positive-single-float 2) - (coerce integer-bound 'single-float)))) - (loop for bound = 1.0f0 then (* bound 2) - while (<= bound upper-bound) - nconc - (loop for r = (+ 1.s0 (random bound)) - for fr = (floor r) - for cr = (ceiling r) - for m = (ash 1 (1+ (random 30))) - for p = (1+ (random m)) - for q = (1+ (random m)) - for x = 0 - repeat 50 - when (<= p q) do (psetf p (1+ q) q p) - do (setf x (/ p q)) - unless (let ((fr/x (/ fr x)) - (cr*x (* cr x))) - (and (<= fr/x r cr*x) - (< fr/x r cr*x) - (> cr*x r fr/x) - (>= cr*x r fr/x))) - collect (list r p q x fr cr)))) - nil) - -(deftest rational.double-float.random.compare.1 - (let* ((integer-bound (ash 1 1000)) - (upper-bound (if (< (/ most-positive-double-float 4) integer-bound) - (/ most-positive-double-float 4) - (coerce integer-bound 'double-float)))) - (loop for bound = 1.0d0 then (* bound 4) - while (<= bound upper-bound) - nconc - (loop for r = (+ 1.s0 (random bound)) - for fr = (floor r) - for cr = (ceiling r) - for m = (ash 1 (1+ (random 30))) - for p = (1+ (random m)) - for q = (1+ (random m)) - for x = 0 - repeat 50 - when (<= p q) do (psetf p (1+ q) q p) - do (setf x (/ p q)) - unless (let ((fr/x (/ fr x)) - (cr*x (* cr x))) - (and (<= fr/x r cr*x) - (< fr/x r cr*x) - (> cr*x r fr/x) - (>= cr*x r fr/x))) - collect (list r p q x fr cr)))) - nil) - -(deftest rational.long-float.random.compare.1 - (let* ((integer-bound (ash 1 1000)) - (upper-bound (if (< (/ most-positive-long-float 4) integer-bound) - (/ most-positive-long-float 4) - (coerce integer-bound 'long-float)))) - (loop for bound = 1.0d0 then (* bound 4) - while (<= bound upper-bound) - nconc - (loop for r = (+ 1.s0 (random bound)) - for fr = (floor r) - for cr = (ceiling r) - for m = (ash 1 (1+ (random 30))) - for p = (1+ (random m)) - for q = (1+ (random m)) - for x = 0 - repeat 50 - when (<= p q) do (psetf p (1+ q) q p) - do (setf x (/ p q)) - unless (let ((fr/x (/ fr x)) - (cr*x (* cr x))) - (and (<= fr/x r cr*x) - (< fr/x r cr*x) - (> cr*x r fr/x) - (>= cr*x r fr/x))) - collect (list r p q x fr cr)))) - nil) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest =.env.1 - (macrolet ((%m (z) z)) - (mapcar 'notnot - (list (= (expand-in-current-env (%m 0))) - (= 1 (expand-in-current-env (%m 1))) - (= (expand-in-current-env (%m 2)) 2) - (= (expand-in-current-env (%m 3)) - (expand-in-current-env (%m 3))) - (= (expand-in-current-env (%m #c(1 2))) - (expand-in-current-env (%m #c(1 2)))) - - (= 1 (expand-in-current-env (%m 2.0))) - (= (expand-in-current-env (%m 2)) 2/3) - (= (expand-in-current-env (%m 4)) - (expand-in-current-env (%m 5))) - - (= (expand-in-current-env (%m 0)) 0 0) - (= 0 (expand-in-current-env (%m 0)) 0) - (= 0 0 (expand-in-current-env (%m 0))) - ))) - (t t t t t nil nil nil t t t)) - - -(deftest /=.env.1 - (macrolet ((%m (z) z)) - (mapcar 'notnot - (list (/= (expand-in-current-env (%m 0))) - (/= 1 (expand-in-current-env (%m 1))) - (/= (expand-in-current-env (%m 2)) 2) - (/= (expand-in-current-env (%m 3)) - (expand-in-current-env (%m 3))) - (/= (expand-in-current-env (%m #c(1 2))) - (expand-in-current-env (%m #c(1 2)))) - - (/= 1 (expand-in-current-env (%m 2.0))) - (/= (expand-in-current-env (%m 2)) 2/3) - (/= (expand-in-current-env (%m 4)) - (expand-in-current-env (%m 5))) - - (/= (expand-in-current-env (%m 2)) 0 1) - (/= 0 (expand-in-current-env (%m 2)) 1) - (/= 0 1 (expand-in-current-env (%m 2))) - ))) - (t nil nil nil nil t t t t t t)) - -(deftest <.env.1 - (macrolet ((%m (z) z)) - (mapcar 'notnot - (list (< (expand-in-current-env (%m 0))) - (< 0 (expand-in-current-env (%m 1))) - (< (expand-in-current-env (%m 2)) 3) - (< (expand-in-current-env (%m 5)) - (expand-in-current-env (%m 7))) - - (< 3 (expand-in-current-env (%m 2.0))) - (< (expand-in-current-env (%m 2)) 2/3) - (< (expand-in-current-env (%m 6)) - (expand-in-current-env (%m 5))) - - (< (expand-in-current-env (%m 1)) 2 3) - (< 1 (expand-in-current-env (%m 2)) 3) - (< 1 2 (expand-in-current-env (%m 3))) - ))) - (t t t t nil nil nil t t t)) - -(deftest <=.env.1 - (macrolet ((%m (z) z)) - (mapcar 'notnot - (list (<= (expand-in-current-env (%m 0))) - (<= 0 (expand-in-current-env (%m 1))) - (<= (expand-in-current-env (%m 2)) 3) - (<= (expand-in-current-env (%m 5)) - (expand-in-current-env (%m 7))) - - (<= 3 (expand-in-current-env (%m 2.0))) - (<= (expand-in-current-env (%m 2)) 2/3) - (<= (expand-in-current-env (%m 6)) - (expand-in-current-env (%m 5))) - - (<= (expand-in-current-env (%m 2)) 2 3) - (<= 1 (expand-in-current-env (%m 1)) 3) - (<= 1 2 (expand-in-current-env (%m 2))) - ))) - (t t t t nil nil nil t t t)) - -(deftest >.env.1 - (macrolet ((%m (z) z)) - (mapcar 'notnot - (list (> (expand-in-current-env (%m 0))) - (> 2 (expand-in-current-env (%m 1))) - (> (expand-in-current-env (%m 4)) 3) - (> (expand-in-current-env (%m 10)) - (expand-in-current-env (%m 7))) - - (> 1 (expand-in-current-env (%m 2.0))) - (> (expand-in-current-env (%m -1)) 2/3) - (> (expand-in-current-env (%m 4)) - (expand-in-current-env (%m 5))) - - (> (expand-in-current-env (%m 2)) 1 0) - (> 2 (expand-in-current-env (%m 1)) 0) - (> 2 1 (expand-in-current-env (%m 0))) - ))) - (t t t t nil nil nil t t t)) - - -(deftest >=.env.1 - (macrolet ((%m (z) z)) - (mapcar 'notnot - (list (>= (expand-in-current-env (%m 0))) - (>= 2 (expand-in-current-env (%m 1))) - (>= (expand-in-current-env (%m 4)) 3) - (>= (expand-in-current-env (%m 7)) - (expand-in-current-env (%m 7))) - - (>= 1 (expand-in-current-env (%m 2.0))) - (>= (expand-in-current-env (%m -1)) 2/3) - (>= (expand-in-current-env (%m 4)) - (expand-in-current-env (%m 5))) - - (>= (expand-in-current-env (%m 2)) 1 1) - (>= 1 (expand-in-current-env (%m 1)) 0) - (>= 2 2 (expand-in-current-env (%m 0))) - ))) - (t t t t nil nil nil t t t)) diff --git a/t/ansi-test/numbers/numberp.lsp b/t/ansi-test/numbers/numberp.lsp deleted file mode 100644 index 625b0b3..0000000 --- a/t/ansi-test/numbers/numberp.lsp +++ /dev/null @@ -1,22 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Sep 6 18:20:36 2003 -;;;; Contains: Tests of NUMBERP - - - -(deftest numberp.error.1 - (signals-error (numberp) program-error) - t) - -(deftest numberp.error.2 - (signals-error (numberp 0 nil) program-error) - t) - -(deftest numberp.error.3 - (signals-error (numberp 'a nil nil) program-error) - t) - -(deftest numberp.1 - (check-type-predicate #'numberp 'number) - nil) diff --git a/t/ansi-test/numbers/numerator-denominator.lsp b/t/ansi-test/numbers/numerator-denominator.lsp deleted file mode 100644 index a9dab65..0000000 --- a/t/ansi-test/numbers/numerator-denominator.lsp +++ /dev/null @@ -1,112 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Sep 7 08:24:57 2003 -;;;; Contains: Tests of NUMERATOR, DENOMINATOR - - - - - -(deftest numerator.error.1 - (signals-error (numerator) program-error) - t) - -(deftest numerator.error.2 - (signals-error (numerator 1/2 nil) program-error) - t) - -(deftest denominator.error.1 - (signals-error (denominator) program-error) - t) - -(deftest denominator.error.2 - (signals-error (denominator 1/2 nil) program-error) - t) - -(deftest numerator-denominator.1 - (loop for n = (abs (random-fixnum)) - for d = (1+ (abs (random-fixnum))) - for g = (gcd n d) - for n1 = (/ n g) - for d1 = (/ d g) - for r = (/ n d) - for n2 = (numerator r) - for d2 = (denominator r) - repeat 1000 - unless (and (eql (gcd n1 d1) 1) - (>= n1 0) - (>= d1 1) - (eql n1 n2) - (eql d1 d2)) - collect (list n1 d1 r n2 d2)) - nil) - -(deftest numerator-denominator.2 - (let ((bound (expt 10 20))) - (loop - for n = (random-from-interval bound 0) - for d = (random-from-interval bound 1) - for g = (gcd n d) - for n1 = (/ n g) - for d1 = (/ d g) - for r = (/ n d) - for n2 = (numerator r) - for d2 = (denominator r) - repeat 1000 - unless (and (eql (gcd n1 d1) 1) - (>= n1 0) - (>= d1 1) - (eql n1 n2) - (eql d1 d2)) - collect (list n1 d1 r n2 d2))) - nil) - -(deftest numerator-denominator.3 - (loop for n = (abs (random-fixnum)) - for d = (1+ (abs (random-fixnum))) - for g = (gcd n d) - for n1 = (/ n g) - for d1 = (/ d g) - for r = (/ n (- d)) - for n2 = (numerator r) - for d2 = (denominator r) - repeat 1000 - unless (and (eql (gcd n1 d1) 1) - (>= n1 0) - (>= d1 1) - (eql n1 (- n2)) - (eql d1 d2)) - collect (list n1 d1 r n2 d2)) - nil) - -(deftest numerator-denominator.4 - (let ((bound (expt 10 20))) - (loop - for n = (random-from-interval bound 0) - for d = (random-from-interval bound 1) - for g = (gcd n d) - for n1 = (/ n g) - for d1 = (/ d g) - for r = (/ n (- d)) - for n2 = (numerator r) - for d2 = (denominator r) - repeat 1000 - unless (and (eql (gcd n1 d1) 1) - (>= n1 0) - (>= d1 1) - (eql n1 (- n2)) - (eql d1 d2)) - collect (list n1 d1 r n2 d2))) - nil) - -(deftest numerator-denominator.5 - (loop for r in *rationals* - for n = (numerator r) - for d = (denominator r) - unless (and (integerp n) - (integerp d) - (eql (gcd n d) 1) - (>= d 1) - (eql (/ n d) r)) - collect (list r n d)) - nil) diff --git a/t/ansi-test/numbers/oddp.lsp b/t/ansi-test/numbers/oddp.lsp deleted file mode 100644 index ce43020..0000000 --- a/t/ansi-test/numbers/oddp.lsp +++ /dev/null @@ -1,82 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Aug 31 10:48:25 2003 -;;;; Contains: Tests of ODDP - - - - - -;;; Error tests - -(deftest oddp.error.1 - (signals-error (oddp) program-error) - t) - -(deftest oddp.error.2 - (signals-error (oddp 0 nil) program-error) - t) - -(deftest oddp.error.3 - (check-type-error #'oddp #'integerp) - nil) - -;;; Non-error tests - -(deftest oddp.1 - (loop for x in *numbers* - when (integerp x) - do (oddp x)) - nil) - -(deftest oddp.3 - (loop for x = (random-fixnum) - repeat 10000 - when (or - (oddp (+ x x)) - (not (oddp (+ x x 1))) - (if (oddp x) - (or (oddp (1+ x)) - (oddp (1- x)) - (/= (mod x 2) 1)) - (or (not (oddp (1+ x))) - (not (oddp (1- x))) - (/= (mod x 2) 0)))) - collect x) - nil) - -(deftest oddp.4 - (let ((upper-bound 1000000000000000) - (lower-bound -1000000000000000)) - (loop for x = (random-from-interval upper-bound lower-bound) - repeat 10000 - when (or - (oddp (+ x x)) - (not (oddp (+ x x 1))) - (if (oddp x) - (or (oddp (1+ x)) - (oddp (1- x)) - (/= (mod x 2) 1)) - (or (not (oddp (1+ x))) - (not (oddp (1- x))) - (/= (mod x 2) 0)))) - collect x)) - nil) - -(deftest oddp.5 - (notnot-mv (oddp 1)) - t) - -(deftest oddp.6 - (oddp 0) - nil) - -(deftest oddp.7 - (notnot-mv (oddp 100000000000000000000000000000001)) - t) - -(deftest oddp.8 - (oddp 100000000000000000000000000000000) - nil) - - diff --git a/t/ansi-test/numbers/oneminus.lsp b/t/ansi-test/numbers/oneminus.lsp deleted file mode 100644 index 61d5719..0000000 --- a/t/ansi-test/numbers/oneminus.lsp +++ /dev/null @@ -1,174 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Sep 1 20:14:34 2003 -;;;; Contains: Tests of 1- - - - - - -;;; Error tests - -(deftest 1-.error.1 - (signals-error (1-) program-error) - t) - -(deftest 1-.error.2 - (signals-error (1- 0 0) program-error) - t) - -(deftest 1-.error.3 - (signals-error (1- 0 nil nil) program-error) - t) - -;;; Non-error tests - -(deftest 1-.1 - (loop for x = (random-fixnum) - for y = (1- x) - for z = (- x 1) - repeat 1000 - unless (eql y z) - collect (list x y z)) - nil) - -(deftest 1-.2 - (loop for x = (random-from-interval (ash 1 1000)) - for y = (1- x) - for z = (- x 1) - repeat 1000 - unless (eql y z) - collect (list x y z)) - nil) - -(deftest 1-.3 - (loop for x = (random (1- most-positive-short-float)) - for y = (1- x) - for z = (- x 1.0s0) - repeat 1000 - unless (eql y z) - collect (list x y z)) - nil) - -(deftest 1-.4 - (loop for x = (random (1- most-positive-single-float)) - for y = (1- x) - for z = (- x 1.0f0) - repeat 1000 - unless (eql y z) - collect (list x y z)) - nil) - -(deftest 1-.5 - (loop for x = (random (1- most-positive-double-float)) - for y = (1- x) - for z = (- x 1.0d0) - repeat 1000 - unless (eql y z) - collect (list x y z)) - nil) - -(deftest 1-.6 - (loop for x = (random (1- most-positive-long-float)) - for y = (1- x) - for z = (- x 1.0l0) - repeat 1000 - unless (eql y z) - collect (list x y z)) - nil) - -(deftest 1-.7 - (loop for x = (random-fixnum) - for y = (random-fixnum) - for y2 = (if (zerop y) 1 y) - for r = (/ x y2) - for r1 = (1- r) - for r2 = (- r 1) - repeat 1000 - unless (eql r1 r2) - collect (list x y2 r1 r2)) - nil) - -(deftest 1-.8 - (let ((bound (ash 1 200))) - (loop for x = (random-from-interval bound) - for y = (random-from-interval bound) - for y2 = (if (zerop y) 1 y) - for r = (/ x y2) - for r1 = (1- r) - for r2 = (- r 1) - repeat 1000 - unless (eql r1 r2) - collect (list x y2 r1 r2))) - nil) - -;;; Complex numbers -(deftest 1-.9 - (loop for xr = (random-fixnum) - for xi = (random-fixnum) - for xc = (complex xr xi) - for xc1 = (1- xc) - repeat 1000 - unless (eql xc1 (complex (- xr 1) xi)) - collect (list xr xi xc xc1)) - nil) - - -(deftest 1-.10 - (let ((bound (ash 1 100))) - (loop for xr = (random-from-interval bound) - for xi = (random-from-interval bound) - for xc = (complex xr xi) - for xc1 = (1- xc) - repeat 1000 - unless (eql xc1 (complex (- xr 1) xi)) - collect (list xr xi xc xc1))) - nil) - -(deftest 1-.11 - (let ((bound (1- most-positive-short-float))) - (loop for xr = (random bound) - for xi = (random bound) - for xc = (complex xr xi) - for xc1 = (1- xc) - repeat 1000 - unless (eql xc1 (complex (- xr 1) xi)) - collect (list xr xi xc xc1))) - nil) - -(deftest 1-.12 - (let ((bound (1- most-positive-single-float))) - (loop for xr = (random bound) - for xi = (random bound) - for xc = (complex xr xi) - for xc1 = (1- xc) - repeat 1000 - unless (eql xc1 (complex (- xr 1) xi)) - collect (list xr xi xc xc1))) - nil) - -(deftest 1-.13 - (let ((bound (1- most-positive-double-float))) - (loop for xr = (random bound) - for xi = (random bound) - for xc = (complex xr xi) - for xc1 = (1- xc) - repeat 1000 - unless (eql xc1 (complex (- xr 1) xi)) - collect (list xr xi xc xc1))) - nil) - -(deftest 1-.14 - (let ((bound (1- most-positive-long-float))) - (loop for xr = (random bound) - for xi = (random bound) - for xc = (complex xr xi) - for xc1 = (1- xc) - repeat 1000 - unless (eql xc1 (complex (- xr 1) xi)) - collect (list xr xi xc xc1))) - nil) - -(deftest 1-.15 - (macrolet ((%m (z) z)) (1- (expand-in-current-env (%m 2)))) - 1) diff --git a/t/ansi-test/numbers/oneplus.lsp b/t/ansi-test/numbers/oneplus.lsp deleted file mode 100644 index 80a6830..0000000 --- a/t/ansi-test/numbers/oneplus.lsp +++ /dev/null @@ -1,170 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Sep 1 19:53:34 2003 -;;;; Contains: Tests of 1+ - - - - - -(deftest 1+.error.1 - (signals-error (1+) program-error) - t) - -(deftest 1+.error.2 - (signals-error (1+ 0 0) program-error) - t) - -(deftest 1+.error.3 - (signals-error (1+ 0 nil nil) program-error) - t) - -(deftest 1+.1 - (loop for x = (random-fixnum) - for y = (1+ x) - for z = (+ x 1) - repeat 1000 - unless (eql y z) - collect (list x y z)) - nil) - -(deftest 1+.2 - (loop for x = (random-from-interval (ash 1 1000)) - for y = (1+ x) - for z = (+ x 1) - repeat 1000 - unless (eql y z) - collect (list x y z)) - nil) - -(deftest 1+.3 - (loop for x = (random (1- most-positive-short-float)) - for y = (1+ x) - for z = (+ x 1.0s0) - repeat 1000 - unless (eql y z) - collect (list x y z)) - nil) - -(deftest 1+.4 - (loop for x = (random (1- most-positive-single-float)) - for y = (1+ x) - for z = (+ x 1.0f0) - repeat 1000 - unless (eql y z) - collect (list x y z)) - nil) - -(deftest 1+.5 - (loop for x = (random (1- most-positive-double-float)) - for y = (1+ x) - for z = (+ x 1.0d0) - repeat 1000 - unless (eql y z) - collect (list x y z)) - nil) - -(deftest 1+.6 - (loop for x = (random (1- most-positive-long-float)) - for y = (1+ x) - for z = (+ x 1.0l0) - repeat 1000 - unless (eql y z) - collect (list x y z)) - nil) - -(deftest 1+.7 - (loop for x = (random-fixnum) - for y = (random-fixnum) - for y2 = (if (zerop y) 1 y) - for r = (/ x y2) - for r1 = (1+ r) - for r2 = (+ r 1) - repeat 1000 - unless (eql r1 r2) - collect (list x y2 r1 r2)) - nil) - -(deftest 1+.8 - (let ((bound (ash 1 200))) - (loop for x = (random-from-interval bound) - for y = (random-from-interval bound) - for y2 = (if (zerop y) 1 y) - for r = (/ x y2) - for r1 = (1+ r) - for r2 = (+ r 1) - repeat 1000 - unless (eql r1 r2) - collect (list x y2 r1 r2))) - nil) - -;;; Complex numbers -(deftest 1+.9 - (loop for xr = (random-fixnum) - for xi = (random-fixnum) - for xc = (complex xr xi) - for xc1 = (1+ xc) - repeat 1000 - unless (eql xc1 (complex (+ xr 1) xi)) - collect (list xr xi xc xc1)) - nil) - - -(deftest 1+.10 - (let ((bound (ash 1 100))) - (loop for xr = (random-from-interval bound) - for xi = (random-from-interval bound) - for xc = (complex xr xi) - for xc1 = (1+ xc) - repeat 1000 - unless (eql xc1 (complex (+ xr 1) xi)) - collect (list xr xi xc xc1))) - nil) - -(deftest 1+.11 - (let ((bound (1- most-positive-short-float))) - (loop for xr = (random bound) - for xi = (random bound) - for xc = (complex xr xi) - for xc1 = (1+ xc) - repeat 1000 - unless (eql xc1 (complex (+ xr 1) xi)) - collect (list xr xi xc xc1))) - nil) - -(deftest 1+.12 - (let ((bound (1- most-positive-single-float))) - (loop for xr = (random bound) - for xi = (random bound) - for xc = (complex xr xi) - for xc1 = (1+ xc) - repeat 1000 - unless (eql xc1 (complex (+ xr 1) xi)) - collect (list xr xi xc xc1))) - nil) - -(deftest 1+.13 - (let ((bound (1- most-positive-double-float))) - (loop for xr = (random bound) - for xi = (random bound) - for xc = (complex xr xi) - for xc1 = (1+ xc) - repeat 1000 - unless (eql xc1 (complex (+ xr 1) xi)) - collect (list xr xi xc xc1))) - nil) - -(deftest 1+.14 - (let ((bound (1- most-positive-long-float))) - (loop for xr = (random bound) - for xi = (random bound) - for xc = (complex xr xi) - for xc1 = (1+ xc) - repeat 1000 - unless (eql xc1 (complex (+ xr 1) xi)) - collect (list xr xi xc xc1))) - nil) - -(deftest 1+.15 - (macrolet ((%m (z) z)) (1+ (expand-in-current-env (%m 1)))) - 2) diff --git a/t/ansi-test/numbers/parse-integer.lsp b/t/ansi-test/numbers/parse-integer.lsp deleted file mode 100644 index 61ee379..0000000 --- a/t/ansi-test/numbers/parse-integer.lsp +++ /dev/null @@ -1,322 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Sep 7 10:24:13 2003 -;;;; Contains: Tests of PARSE-INTEGER - - - -(deftest parse-integer.error.1 - (signals-error (parse-integer) program-error) - t) - -(deftest parse-integer.error.2 - (signals-error (parse-integer "123" :bogus) program-error) - t) - -(deftest parse-integer.error.3 - (signals-error (parse-integer "123" :bogus 'foo) program-error) - t) - -(deftest parse-integer.error.4 - (signals-error (parse-integer "") parse-error) - t) - -(deftest parse-integer.error.5 - (loop for x across +standard-chars+ - unless (or (digit-char-p x) - (eval `(signals-error (parse-integer ,(string x)) - parse-error))) - collect x) - nil) - -(deftest parse-integer.error.5a - (signals-error (parse-integer "") parse-error) - t) - -(deftest parse-integer.error.6 - (signals-error (parse-integer "1234a") parse-error) - t) - -(deftest parse-integer.error.7 - (signals-error (parse-integer "-") parse-error) - t) - -(deftest parse-integer.error.8 - (signals-error (parse-integer "+") parse-error) - t) - -(deftest parse-integer.error.9 - (signals-error (parse-integer "--10") parse-error) - t) - -(deftest parse-integer.error.10 - (signals-error (parse-integer "++10") parse-error) - t) - -(deftest parse-integer.error.11 - (signals-error (parse-integer "10.") parse-error) - t) - -(deftest parse-integer.error.12 - (signals-error (parse-integer "#O123") parse-error) - t) - -(deftest parse-integer.error.13 - (signals-error (parse-integer "#B0100") parse-error) - t) - -(deftest parse-integer.error.14 - (signals-error (parse-integer "#X0100") parse-error) - t) - -(deftest parse-integer.error.15 - (signals-error (parse-integer "#3R0100") parse-error) - t) - -;;; - -(deftest parse-integer.1 - (parse-integer "123") - 123 3) - -(deftest parse-integer.2 - (parse-integer " 123") - 123 4) - -(deftest parse-integer.3 - (parse-integer " 12345678901234567890 ") - 12345678901234567890 27) - -(deftest parse-integer.4 - (parse-integer (concatenate 'string (string #\Newline) "17" - (string #\Newline))) - 17 4) - -(deftest parse-integer.5 - (let ((c (name-char "Tab"))) - (if c - (parse-integer (concatenate 'string (string c) "6381" (string c))) - (values 6381 6))) - 6381 6) - -(deftest parse-integer.6 - (let ((c (name-char "Linefeed"))) - (if c - (parse-integer (concatenate 'string (string c) "-123712" (string c))) - (values -123712 9))) - -123712 9) - -(deftest parse-integer.7 - (let ((c (name-char "Page"))) - (if c - (parse-integer (concatenate 'string (string c) "0" (string c))) - (values 0 3))) - 0 3) - -(deftest parse-integer.8 - (let ((c (name-char "Return"))) - (if c - (parse-integer (concatenate 'string (string c) "999" (string c))) - (values 999 5))) - 999 5) - -(deftest parse-integer.9 - (parse-integer "-0") - 0 2) - -(deftest parse-integer.10 - (parse-integer "+0") - 0 2) - -(deftest parse-integer.11 - (parse-integer "-00") - 0 3) - -(deftest parse-integer.12 - (parse-integer "+000") - 0 4) - -(deftest parse-integer.13 - (parse-integer "00010") - 10 5) - -(deftest parse-integer.14 - (parse-integer "10110" :radix 2) - 22 5) - -(deftest parse-integer.15 - (parse-integer "1021" :radix 3) - 34 4) - -(deftest parse-integer.16 - (loop for radix from 2 to 36 - for c across "123456789abcdefghijklmnopqrstuvwxyz" - for s = (concatenate 'string (string c) "0") - for vals = (multiple-value-list (parse-integer s :radix radix)) - for (val pos) = vals - always (and (= (length vals) 2) - (= pos 2) - (= val (* radix (1- radix))))) - t) - -(deftest parse-integer.17 - (parse-integer "10A" :junk-allowed t) - 10 2) - -(deftest parse-integer.18 - (parse-integer "10" :junk-allowed t) - 10 2) - -(deftest parse-integer.19 - (parse-integer "ABCDE" :junk-allowed t) - nil 0) - -(deftest parse-integer.20 - (parse-integer "" :junk-allowed t) - nil 0) - -(deftest parse-integer.21 - :notes (:nil-vectors-are-strings) - (parse-integer (make-array 0 :element-type nil) :junk-allowed t) - nil 0) - -(deftest parse-integer.22 - (parse-integer "a1234b" :start 2 :end 4) - 23 4) - -(deftest parse-integer.23 - (parse-integer "a1234b" :start 2 :end 4 :end nil) - 23 4) - -(deftest parse-integer.24 - (parse-integer "a1234b" :start 2 :end 4 :start 1) - 23 4) - - -(deftest parse-integer.25 - (parse-integer "a1234b" :start 2 :end 4 :allow-other-keys nil) - 23 4) - -(deftest parse-integer.26 - (parse-integer "a1234b" :start 2 :end 4 :allow-other-keys t :foo nil) - 23 4) - -(deftest parse-integer.27 - (parse-integer "a1234b" :start 2 :end 4 :allow-other-keys t - :allow-other-keys nil :foo nil) - 23 4) - -(deftest parse-integer.28 - (let* ((s (make-array 5 :initial-contents "a123b" :element-type 'base-char)) - (s2 (make-array 3 :displaced-to s :displaced-index-offset 1 - :element-type 'base-char))) - (values - s2 - (length s2) - (equalpt "123" s2) - (multiple-value-list (parse-integer s2)))) - "123" 3 t (123 3)) - -(deftest parse-integer.28a - (let* ((s (make-array 5 :initial-contents "a123b" :element-type 'character)) - (s2 (make-array 3 :displaced-to s :displaced-index-offset 1 - :element-type 'character))) - (values - s2 - (length s2) - (equalpt "123" s2) - (multiple-value-list (parse-integer s2)))) - "123" 3 t (123 3)) - -(deftest parse-integer.29 - (let ((s (make-array 10 :initial-contents "1234567890" - :fill-pointer 3 - :element-type 'base-char))) - (values - (length s) - (multiple-value-list (parse-integer s)))) - 3 (123 3)) - -(deftest parse-integer.29a - (let ((s (make-array 10 :initial-contents "1234567890" - :fill-pointer 3 - :element-type 'character))) - (values - (length s) - (multiple-value-list (parse-integer s)))) - 3 (123 3)) - -(deftest parse-integer.30 - (let ((s (make-array 10 :initial-contents "1234567890" - :adjustable t - :element-type 'base-char))) - (values - (length s) - (multiple-value-list (parse-integer s)) - (progn - (adjust-array s 3 :element-type 'base-char) - (multiple-value-list (parse-integer s))))) - 10 - (1234567890 10) - (123 3)) - -(deftest parse-integer.30a - (let ((s (make-array 10 :initial-contents "1234567890" - :adjustable t - :element-type 'character))) - (values - (length s) - (multiple-value-list (parse-integer s)) - (progn - (adjust-array s 3 :element-type 'character) - (multiple-value-list (parse-integer s))))) - 10 - (1234567890 10) - (123 3)) - -(deftest parse-integer.31 - (parse-integer "1234" :start 1) - 234 4) - -(deftest parse-integer.32 - (parse-integer "1234" :start 1 :end nil) - 234 4) - -(deftest parse-integer.33 - (let* ((s (make-array 5 :initial-contents "a123b" :element-type 'base-char)) - (s2 (make-array 3 :displaced-to s :displaced-index-offset 1 - :element-type 'base-char)) - (s3 (make-array 2 :displaced-to s2 :displaced-index-offset 1 - :element-type 'base-char))) - (values - s3 - (length s3) - (equalpt "23" s3) - (multiple-value-list (parse-integer s3)))) - "23" 2 t (23 2)) - -(deftest parse-integer.34 - (parse-integer "1234" :end 3) - 123 3) - -(deftest parse-integer.35 - (parse-integer "1234" :end 3 :end 1) - 123 3) - -(deftest parse-integer.36 - (parse-integer "1234" :end nil :end 3) - 1234 4) - -;;; Order of evaluation tests - -(deftest parse-integer.order.1 - (let ((i 0) a b c d e) - (values - (multiple-value-list - (parse-integer (progn (setf a (incf i)) "10001") - :radix (progn (setf b (incf i)) 2) - :start (progn (setf c (incf i)) 0) - :end (progn (setf d (incf i)) 5) - :junk-allowed (progn (setf e (incf i)) nil))) - i a b c d e)) - (17 5) 5 1 2 3 4 5) diff --git a/t/ansi-test/numbers/phase.lsp b/t/ansi-test/numbers/phase.lsp deleted file mode 100644 index 40c4cee..0000000 --- a/t/ansi-test/numbers/phase.lsp +++ /dev/null @@ -1,122 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Sep 6 21:15:54 2003 -;;;; Contains: Tests of PHASE - - - -(deftest phase.error.1 - (signals-error (phase) program-error) - t) - -(deftest phase.error.2 - (signals-error (phase 0 0) program-error) - t) - -(deftest phase.error.3 - (check-type-error #'phase #'numberp) - nil) - -(deftest phase.1 - (eqlt (phase 0) 0.0f0) - t) - -(deftest phase.2 - (eqlt (phase 1) 0.0f0) - t) - -(deftest phase.3 - (eqlt (phase 1/2) 0.0f0) - t) - -(deftest phase.4 - (eqlt (phase 100.0f0) 0.0f0) - t) - -(deftest phase.5 - (eqlt (phase 100.0s0) 0.0s0) - t) - -(deftest phase.6 - (eqlt (phase 100.0d0) 0.0d0) - t) - -(deftest phase.7 - (eqlt (phase 100.0l0) 0.0l0) - t) - -(deftest phase.8 - (eqlt (phase -1) (coerce pi 'single-float)) - t) - -(deftest phase.9 - (eqlt (phase -1/2) (coerce pi 'single-float)) - t) - -(deftest phase.10 - (let ((p1 (phase #c(0 1))) - (p2 (phase #c(0.0f0 1.0f0)))) - (and (eql p1 p2) - (approx= p1 (coerce (/ pi 2) 'single-float)))) - t) - -(deftest phase.11 - (let ((p (phase #c(0.0d0 1.0d0)))) - (approx= p (coerce (/ pi 2) 'double-float))) - t) - -(deftest phase.12 - (let ((p (phase #c(0.0s0 1.0s0)))) - (approx= p (coerce (/ pi 2) 'single-float))) - t) - -(deftest phase.13 - (let ((p (phase #c(0.0l0 1.0l0)))) - (approx= p (/ pi 2))) - t) - -(deftest phase.14 - (let ((p1 (phase #c(1 1))) - (p2 (phase #c(1.0f0 1.0f0)))) - (and (eql p1 p2) - (approx= p1 (coerce (/ pi 4) 'single-float) - (* 2 single-float-epsilon)))) - t) - -(deftest phase.15 - (let ((p (phase #c(1.0d0 1.0d0)))) - (approx= p (coerce (/ pi 4) 'double-float) - (* 2 double-float-epsilon))) - t) - -(deftest phase.16 - (let ((p (phase #c(1.0s0 1.0s0)))) - (approx= p (coerce (/ pi 4) 'single-float) - (* 2 short-float-epsilon))) - t) - -(deftest phase.17 - (let ((p (phase #c(1.0l0 1.0l0)))) - (approx= p (/ pi 4) (* 2 long-float-epsilon))) - t) - -;;; Negative zeros -(deftest phase.18 - (or (eqlt -0.0s0 0.0s0) - (approx= (phase #c(-1.0 -0.0)) (coerce (- pi) 'short-float))) - t) - -(deftest phase.19 - (or (eqlt -0.0f0 0.0f0) - (approx= (phase #c(-1.0 -0.0)) (coerce (- pi) 'single-float))) - t) - -(deftest phase.20 - (or (eqlt -0.0d0 0.0d0) - (approx= (phase #c(-1.0 -0.0)) (coerce (- pi) 'double-float))) - t) - -(deftest phase.21 - (or (eqlt -0.0l0 0.0l0) - (approx= (phase #c(-1.0 -0.0)) (coerce (- pi) 'long-float))) - t) diff --git a/t/ansi-test/numbers/plus.lsp b/t/ansi-test/numbers/plus.lsp deleted file mode 100644 index 5915459..0000000 --- a/t/ansi-test/numbers/plus.lsp +++ /dev/null @@ -1,434 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Aug 31 04:34:17 2003 -;;;; Contains: Tests of the function + - - - - -;;; (compile-and-load "plus-aux.lsp") - -(deftest plus.1 - (+) - 0) - -(deftest plus.2 - (loop for x in *numbers* - unless (eql x (+ x)) - collect x) - nil) - -(deftest plus.3 - (loop for x in *numbers* - for x1 = (+ x 0) - for x2 = (+ 0 x) - unless (and (eql x x1) (eql x x2) (eql x1 x2)) - collect (list x x1 x2)) - nil) - -(deftest plus.4 - (loop for x in *numbers* - for x1 = (- x x) - unless (= x1 0) - collect (list x x1)) - nil) - -(deftest plus.5 - (let* ((upper-bound most-positive-fixnum) - (lower-bound most-negative-fixnum) - (spread (- upper-bound lower-bound))) - (flet ((%r () (+ (random spread) lower-bound))) - (loop for x = (%r) - for y = (%r) - for z = (%r) - for s1 = (+ x y z) - for s2 = (+ z y x) - for s3 = (+ y x z) - for s4 = (+ x z y) - for s5 = (+ z x y) - for s6 = (+ y z x) - repeat 1000 - unless (and (eql s1 s2) (eql s1 s3) (eql s1 s4) - (eql s1 s5) (eql s1 s6)) - collect (list x y z s1 s2 s3 s4 s5 s6)))) - nil) - -(deftest plus.6 - (let* ((upper-bound 1000000000000000) - (lower-bound -1000000000000000) - (spread (- upper-bound lower-bound))) - (flet ((%r () (+ (random spread) lower-bound))) - (loop for x = (%r) - for y = (%r) - for z = (%r) - for s1 = (+ x y z) - for s2 = (+ z y x) - for s3 = (+ y x z) - for s4 = (+ x z y) - for s5 = (+ z x y) - for s6 = (+ y z x) - repeat 1000 - unless (and (eql s1 s2) (eql s1 s3) (eql s1 s4) - (eql s1 s5) (eql s1 s6)) - collect (list x y z s1 s2 s3 s4 s5 s6)))) - nil) - -(deftest plus.7 - (let* ((upper-bound most-positive-fixnum) - (lower-bound most-negative-fixnum) - (spread (- upper-bound lower-bound))) - (flet ((%r () (+ (random spread) lower-bound))) - (loop for x = (/ (%r) (max 1 (%r))) - for y = (/ (%r) (max 1 (%r))) - for z = (/ (%r) (max 1 (%r))) - for s1 = (+ x y z) - for s2 = (+ z y x) - for s3 = (+ y x z) - for s4 = (+ x z y) - for s5 = (+ z x y) - for s6 = (+ y z x) - repeat 1000 - unless (and (eql s1 s2) (eql s1 s3) (eql s1 s4) - (eql s1 s5) (eql s1 s6)) - collect (list x y z s1 s2 s3 s4 s5 s6) - unless (= (+ x y) - (let ((xn (numerator x)) - (xd (denominator x)) - (yn (numerator y)) - (yd (denominator y))) - (/ (+ (* xn yd) (* xd yn)) - (* xd yd)))) - collect (list x y)))) - nil) - -(deftest plus.8 - (let (args) - (loop for i from 0 to (min 256 (1- call-arguments-limit)) - unless (eql (apply #'+ args) (/ (* i (1+ i)) 2)) - collect i - do (push (1+ i) args))) - nil) - -(deftest plus.9 - (let* ((upper-bound most-positive-fixnum) - (lower-bound most-negative-fixnum) - (spread (- upper-bound lower-bound))) - (flet ((%r () (+ (random spread) lower-bound))) - (loop - for xr = (%r) - for xi = (%r) - for yr = (%r) - for yi = (%r) - for x = (complex xr xi) - for y = (complex yr yi) - for s = (+ x y) - repeat 1000 - unless (eql s (complex (+ xr yr) (+ xi yi))) - collect (list x y s)))) - nil) - -(deftest plus.10 - (loop - for x in '(0.0s0 0.0f0 0.0d0 0.0l0) - for radix = (float-radix x) - for (k eps-r eps-f) = (multiple-value-list (find-epsilon x)) - nconc - (loop for i from 1 to k - for e1 = (expt radix (- i)) - for y = (+ x e1) - nconc - (loop for j from 1 to (- k i) - for e2 = (expt radix (- j)) - for z = (+ x e2) - unless (eql (+ y z) (+ x e1 e2)) - collect (list x i j)))) - nil) - -(deftest plus.11 - (flet ((%r () (- (random most-positive-short-float) (/ most-positive-short-float 2)))) - (loop for x = (%r) - for y = (%r) - for s = (+ x y) - repeat 1000 - unless (and (eql s (+ y x)) - (typep s 'short-float)) - collect (list x y s))) - nil) - -(deftest plus.12 - (flet ((%r () (- (random most-positive-single-float) (/ most-positive-single-float 2)))) - (loop for x = (%r) - for y = (%r) - for s = (+ x y) - repeat 1000 - unless (and (eql s (+ y x)) - (typep s 'single-float)) - collect (list x y s))) - nil) - -(deftest plus.13 - (flet ((%r () (- (random most-positive-double-float) (/ most-positive-double-float 2)))) - (loop for x = (%r) - for y = (%r) - for s = (+ x y) - repeat 1000 - unless (and (eql s (+ y x)) - (typep s 'double-float)) - collect (list x y s))) - nil) - -(deftest plus.14 - (flet ((%r () (- (random most-positive-long-float) (/ most-positive-long-float 2)))) - (loop for x = (%r) - for y = (%r) - for s = (+ x y) - repeat 1000 - unless (and (eql s (+ y x)) - (typep s 'long-float)) - collect (list x y s))) - nil) - -(deftest plus.15 - (let ((bound most-positive-short-float) - (bound2 most-positive-single-float)) - (loop for x = (- (random bound) (/ bound 2)) - for y = (- (random bound2)(/ bound2 2)) - for p = (+ x y) - repeat 1000 - unless (and (eql p (+ y x)) - (typep p 'single-float)) - collect (list x y p))) - nil) - -(deftest plus.16 - (let ((bound most-positive-short-float) - (bound2 most-positive-double-float)) - (loop for x = (- (random bound) (/ bound 2)) - for y = (- (random bound2)(/ bound2 2)) - for p = (+ x y) - repeat 1000 - unless (and (eql p (+ y x)) - (typep p 'double-float)) - collect (list x y p))) - nil) - -(deftest plus.17 - (let ((bound most-positive-short-float) - (bound2 most-positive-long-float)) - (loop for x = (- (random bound) (/ bound 2)) - for y = (- (random bound2)(/ bound2 2)) - for p = (+ x y) - repeat 1000 - unless (and (eql p (+ y x)) - (typep p 'long-float)) - collect (list x y p))) - nil) - -(deftest plus.18 - (let ((bound most-positive-single-float) - (bound2 most-positive-double-float)) - (loop for x = (- (random bound) (/ bound 2)) - for y = (- (random bound2)(/ bound2 2)) - for p = (+ x y) - repeat 1000 - unless (and (eql p (+ y x)) - (typep p 'double-float)) - collect (list x y p))) - nil) - -(deftest plus.19 - (let ((bound most-positive-single-float) - (bound2 most-positive-long-float)) - (loop for x = (- (random bound) (/ bound 2)) - for y = (- (random bound2)(/ bound2 2)) - for p = (+ x y) - repeat 1000 - unless (and (eql p (+ y x)) - (typep p 'long-float)) - collect (list x y p))) - nil) - -(deftest plus.20 - (let ((bound most-positive-double-float) - (bound2 most-positive-long-float)) - (loop for x = (- (random bound) (/ bound 2)) - for y = (- (random bound2)(/ bound2 2)) - for p = (+ x y) - repeat 1000 - unless (and (eql p (+ y x)) - (typep p 'long-float)) - collect (list x y p))) - nil) - -(deftest plus.21 - (loop - for type in '(short-float single-float double-float long-float) - for bits in '(13 24 50 50) - for bound = (ash 1 (1- bits)) - nconc - (loop for i = (random bound) - for x = (coerce i type) - for j = (random bound) - for y = (coerce j type) - for sum = (+ x y) - repeat 1000 - unless (and (eql sum (coerce (+ i j) type)) - (eql sum (+ y x))) - collect (list i j x y sum (coerce (+ i j) type)))) - nil) - -(deftest plus.22 - (loop - for type in '(short-float single-float double-float long-float) - for bits in '(13 24 50 50) - for bound = (ash 1 (1- bits)) - nconc - (loop - for one = (coerce 1 type) - for i = (random bound) - for x = (complex (coerce i type) one) - for j = (random bound) - for y = (complex (coerce j type) one) - for sum = (+ x y) - repeat 1000 - unless (and (eql sum (complex (coerce (+ i j) type) - (coerce 2 type))) - (eql sum (+ y x))) - collect (list i j x y sum))) - nil) - -(deftest plus.23 - (loop - for type in '(short-float single-float double-float long-float) - for bits in '(13 24 50 50) - for bound = (ash 1 (1- bits)) - nconc - (loop - for one = (coerce 1 type) - for i = (random bound) - for x = (complex one (coerce i type)) - for j = (random bound) - for y = (complex one (coerce j type)) - for sum = (+ x y) - repeat 1000 - unless (and (eql sum (complex (coerce 2 type) - (coerce (+ i j) type))) - (eql sum (+ y x))) - collect (list i j x y sum))) - nil) - -;;; Negative zero tests (suggested by R. Toy) - -(deftest plus.24 - (funcall - (compile nil '(lambda (x) (declare (type short-float x) (optimize (speed 3) (safety 0) (debug 0))) - (+ 0.0s0 x))) - -0.0s0) - 0.0s0) - -(deftest plus.25 - (funcall - (compile nil '(lambda (x) (declare (type single-float x) (optimize (speed 3) (safety 0) (debug 0))) - (+ 0.0f0 x))) - -0.0f0) - 0.0f0) - -(deftest plus.26 - (funcall - (compile nil '(lambda (x) (declare (type double-float x) (optimize (speed 3) (safety 0) (debug 0))) - (+ 0.0d0 x))) - -0.0d0) - 0.0d0) - -(deftest plus.27 - (funcall - (compile nil '(lambda (x) (declare (type long-float x) (optimize (speed 3) (safety 0) (debug 0))) - (+ 0.0l0 x))) - -0.0l0) - 0.0l0) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest plus.28 - (macrolet ((%m (z) z)) - (values - (+ (expand-in-current-env (%m 1))) - (+ (expand-in-current-env (%m 2)) 3) - (+ 4 (expand-in-current-env (%m 5))) - (+ 1/2 (expand-in-current-env (%m 6)) 2/3))) - 1 5 9 43/6) - -;;; Must test combinations of reals and complex arguments. - -;;; Order of evaluation tests - -(deftest plus.order.1 - (let ((i 0) x y) - (values - (+ (progn (setf x (incf i)) '8) - (progn (setf y (incf i)) '11)) - i x y)) - 19 2 1 2) - -(deftest plus.order.2 - (let ((i 0) x y z) - (values - (+ (progn (setf x (incf i)) '8) - (progn (setf y (incf i)) '11) - (progn (setf z (incf i)) '100)) - i x y z)) - 119 3 1 2 3) - -;;; Test that compilation does not reassociate float additions - -(deftest plus.reassociation.1 - (loop - for x in '(1.0s0 1.0f0 1.0d0 1.0l0) - for eps in (list short-float-epsilon single-float-epsilon - double-float-epsilon long-float-epsilon) - for eps2 = (* eps 9/10) - when (eql - (funcall (compile nil `(lambda () (+ ,x (+ ,eps2 ,eps2))))) - x) - collect (list x eps eps2)) - nil) - -(deftest plus.reassociation.2 - (loop - for x in '(1.0s0 1.0f0 1.0d0 1.0l0) - for eps in (list short-float-epsilon single-float-epsilon - double-float-epsilon long-float-epsilon) - for eps2 = (* eps 9/10) - unless (equal - (funcall (compile nil `(lambda () (list (+ (+ ,x ,eps2) ,eps2) - (+ ,eps2 (+ ,eps2 ,x)))))) - (list x x)) - collect (list x eps eps2)) - nil) - -(deftest plus.reassociation.3 - (loop - for x in '(1.0s0 1.0f0 1.0d0 1.0l0) - for eps in (list short-float-epsilon single-float-epsilon - double-float-epsilon long-float-epsilon) - for eps2 = (* eps 9/10) - when (eql - (funcall (compile nil `(lambda (y e) (+ y (+ e e)))) x eps2) - x) - collect (list x eps eps2)) - nil) - -(deftest plus.reassociation.4 - (loop - for x in '(1.0s0 1.0f0 1.0d0 1.0l0) - for eps in (list short-float-epsilon single-float-epsilon - double-float-epsilon long-float-epsilon) - for eps2 = (* eps 9/10) - unless (equal - (funcall (compile nil `(lambda (y e) (list (+ (+ y e) e) - (+ e (+ e y))))) - x eps2) - (list x x)) - collect (list x eps eps2)) - nil) diff --git a/t/ansi-test/numbers/plusp.lsp b/t/ansi-test/numbers/plusp.lsp deleted file mode 100644 index 7b5060b..0000000 --- a/t/ansi-test/numbers/plusp.lsp +++ /dev/null @@ -1,69 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Aug 4 21:42:14 2003 -;;;; Contains: Tests for PLUSP - - - -;;; Error tests - -(deftest plusp.error.1 - (signals-error (plusp) program-error) - t) - -(deftest plusp.error.2 - (signals-error (plusp 0 0) program-error) - t) - -(deftest plusp.error.3 - (signals-error (plusp 0 nil) program-error) - t) - -(deftest plusp.error.4 - (check-type-error #'plusp #'realp) - nil) - -;;; Non-error tests - -(deftest plusp.1 - (plusp 0) - nil) - -(deftest plusp.2 - (plusp -1) - nil) - -(deftest plusp.3 - (notnot-mv (plusp 1)) - t) - -(deftest plusp.4 - (loop for x in *reals* - when (if (plusp x) (<= x 0) (> x 0)) - collect x) - nil) - -(deftest plusp.5 - (some #'plusp '(-0.0s0 -0.0f0 -0.0d0 -0.0l0)) - nil) - -(deftest plusp.6 - (some #'plusp '(0.0s0 0.0f0 0.0d0 0.0l0)) - nil) - -(deftest plusp.7 - (remove-if #'plusp - (list least-positive-short-float - least-positive-normalized-short-float - least-positive-single-float - least-positive-normalized-single-float - least-positive-double-float - least-positive-normalized-double-float - least-positive-long-float - least-positive-normalized-long-float - most-positive-short-float - most-positive-single-float - most-positive-double-float - most-positive-long-float)) - nil) - diff --git a/t/ansi-test/numbers/random-state-p.lsp b/t/ansi-test/numbers/random-state-p.lsp deleted file mode 100644 index 7be6577..0000000 --- a/t/ansi-test/numbers/random-state-p.lsp +++ /dev/null @@ -1,26 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Sep 6 17:50:04 2003 -;;;; Contains: Tests of RANDOM-STATE-P - - - -(deftest random-state-p.error.1 - (signals-error (random-state-p) program-error) - t) - -(deftest random-state-p.error.2 - (signals-error (random-state-p nil nil) program-error) - t) - -(deftest random-state-p.1 - (check-type-predicate #'random-state-p 'random-state) - nil) - -(deftest random-state-p.2 - (notnot-mv (random-state-p *random-state*)) - t) - -(deftest random-state-p.3 - (notnot-mv (random-state-p (make-random-state))) - t) diff --git a/t/ansi-test/numbers/random.lsp b/t/ansi-test/numbers/random.lsp deleted file mode 100644 index a6ab34c..0000000 --- a/t/ansi-test/numbers/random.lsp +++ /dev/null @@ -1,93 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Sep 6 15:47:42 2003 -;;;; Contains: Tests of RANDOM - - - - - - -(deftest random.error.1 - (signals-error (random) program-error) - t) - -(deftest random.error.2 - (signals-error (random 10 *random-state* nil) program-error) - t) - -(deftest random.error.3 - (check-type-error #'random (typef '(real (0)))) - nil) - -(deftest random.1 - (loop for i from 2 to 30 - for n = (ash 1 i) - nconc - (loop for j = (1+ (random n)) - repeat 20 - nconc - (loop for r = (random j) - repeat i - unless (and (integerp r) - (<= 0 r) - (< r j)) - collect (list j r)))) - nil) - - -(deftest random.2 - (loop for i from 2 to 20 - for n = (ash 1 i) - nconc - (loop for j = (random (float n)) - repeat 20 - unless (zerop j) - nconc - (loop for r = (random j) - repeat 20 - unless (and (eql (float r j) r) - (<= 0 r) - (< r j)) - collect (list j r)))) - nil) - -(deftest random.3 - (binomial-distribution-test 10000 - #'(lambda () (eql (random 2) 0))) - t) - -(deftest random.4 - (binomial-distribution-test 10000 - #'(lambda () (< (random 1.0s0) 0.5s0))) - t) - -(deftest random.5 - (binomial-distribution-test 10000 - #'(lambda () (< (random 1.0d0) 0.5d0))) - t) - -(deftest random.6 - (binomial-distribution-test 10000 - #'(lambda () (evenp (random 1024)))) - t) - -(deftest random.7 - (loop for x in '(10.0s0 20.0f0 30.0d0 40.0l0) - for r = (random x) - unless (eql (float r x) r) - collect (list x r)) - nil) - -(deftest random.8 - (let* ((f1 '(lambda (x) (random (if x 10 20)))) - (f2 (compile nil f1))) - (values - (loop repeat 100 always (<= 0 (funcall f2 t) 9)) - (loop repeat 100 always (<= 0 (funcall f2 nil) 19)))) - t t) - - -;;; Do more statistical tests here - - diff --git a/t/ansi-test/numbers/rational.lsp b/t/ansi-test/numbers/rational.lsp deleted file mode 100644 index 7e0d3b7..0000000 --- a/t/ansi-test/numbers/rational.lsp +++ /dev/null @@ -1,56 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Sep 1 13:49:18 2003 -;;;; Contains: Tests of RATIONAL - - - -(deftest rational.error.1 - (signals-error (rational) program-error) - t) - -(deftest rational.error.2 - (signals-error (rational 0 nil) program-error) - t) - -(deftest rational.error.3 - (signals-error (rational 0 0) program-error) - t) - -(deftest rational.error.4 - (check-type-error #'rational #'realp) - nil) - -(deftest rational.1 - (loop for x in (loop for r in *reals* - when (or (not (floatp r)) - (<= -1000 (nth-value 1 (integer-decode-float r)) 1000)) - collect r) - for r = (rational x) - unless (and (rationalp r) - (if (floatp x) - (= (float r x) x) - (eql x r))) - collect (list x r)) - nil) - -(deftest rational.2 - (loop for type in '(short-float single-float double-float long-float) - collect - (loop for i from -10000 to 10000 - for x = (coerce i type) - for r = (rational x) - count (not (eql r i)))) - (0 0 0 0)) - -(deftest rational.3 - (loop for type in '(short-float single-float double-float long-float) - for bound in '(1.0s5 1.0f10 1.0d20 1.0l30) - nconc - (loop for x = (random-from-interval bound) - for r = (rational x) - for x2 = (float r x) - repeat 1000 - unless (and (rationalp r) (= x x2)) - collect (list x r x2))) - nil) diff --git a/t/ansi-test/numbers/rationalize.lsp b/t/ansi-test/numbers/rationalize.lsp deleted file mode 100644 index 11418f5..0000000 --- a/t/ansi-test/numbers/rationalize.lsp +++ /dev/null @@ -1,56 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Sep 1 14:00:45 2003 -;;;; Contains: Tests of RATIONALIZE - - - -(deftest rationalize.error.1 - (signals-error (rationalize) program-error) - t) - -(deftest rationalize.error.2 - (signals-error (rationalize 0 nil) program-error) - t) - -(deftest rationalize.error.3 - (signals-error (rationalize 0 0) program-error) - t) - -(deftest rationalize.error.4 - (check-type-error #'rationalize #'realp) - nil) - -(deftest rationalize.1 - (loop for x in (loop for r in *reals* - when (or (not (floatp r)) - (<= -1000 (nth-value 1 (integer-decode-float r)) 1000)) - collect r) - for r = (rationalize x) - unless (and (rationalp r) - (if (floatp x) - (= (float r x) x) - (eql x r))) - collect (list x r)) - nil) - -(deftest rationalize.2 - (loop for type in '(short-float single-float double-float long-float) - collect - (loop for i from -10000 to 10000 - for x = (coerce i type) - for r = (rationalize x) - count (not (eql r i)))) - (0 0 0 0)) - -(deftest rationalize.3 - (loop for type in '(short-float single-float double-float long-float) - for bound in '(1.0s5 1.0f10 1.0d20 1.0l30) - nconc - (loop for x = (random-from-interval bound) - for r = (rationalize x) - for x2 = (float r x) - repeat 1000 - unless (and (rationalp r) (= x x2)) - collect (list x r x2))) - nil) diff --git a/t/ansi-test/numbers/rationalp.lsp b/t/ansi-test/numbers/rationalp.lsp deleted file mode 100644 index e43c53c..0000000 --- a/t/ansi-test/numbers/rationalp.lsp +++ /dev/null @@ -1,40 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Sep 7 08:36:31 2003 -;;;; Contains: Tests of RATIONALP - - - -(deftest rationalp.error.1 - (signals-error (rationalp) program-error) - t) - -(deftest rationalp.error.2 - (signals-error (rationalp 0 nil) program-error) - t) - -(deftest rationalp.error.3 - (signals-error (rationalp 'a 0) program-error) - t) - -(deftest rationalp.1 - (loop for x in *rationals* - for vals = (multiple-value-list (rationalp x)) - unless (and (= (length vals) 1) - (first vals)) - collect (cons x vals)) - nil) - -(deftest rationalp.2 - (loop for x in (set-difference *universe* *rationals*) - for vals = (multiple-value-list (rationalp x)) - unless (and (= (length vals) 1) - (null (first vals))) - collect (cons x vals)) - nil) - -(deftest rationalp.3 - (check-type-predicate #'rationalp 'rational) - nil) - - diff --git a/t/ansi-test/numbers/real.lsp b/t/ansi-test/numbers/real.lsp deleted file mode 100644 index fc9941b..0000000 --- a/t/ansi-test/numbers/real.lsp +++ /dev/null @@ -1,62 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Oct 31 21:41:49 2004 -;;;; Contains: Additional tests of the REAL type specifier - - - -(deftest real.1 - (loop for i = 1 then (ash i 1) - for tp = `(real 0 ,i) - repeat 200 - unless (and (not (typep -1 tp)) - (not (typep -0.0001 tp)) - (typep 0 tp) - (typep 0.0001 tp) - (typep 1 tp) - (typep i tp) - (not (typep (1+ i) tp))) - collect (list i tp)) - nil) - -(deftest real.2 - (loop for i = 1 then (ash i 1) - for tp = `(real ,(- i) 0) - repeat 200 - unless (and (not (typep (- -1 i) tp)) - (typep (- i) tp) - (typep -1 tp) - (typep 0 tp) - (not (typep 1 tp)) - (not (typep i tp)) - (not (typep (1+ i) tp))) - collect (list i tp)) - nil) - -(deftest real.3 - (loop for i = 4 then (ash i 1) - for tp = `(real 0 ,(/ i 3)) - repeat 200 - unless (and (not (typep -1 tp)) - (not (typep -0.0001 tp)) - (typep 0 tp) - (typep 0.0001 tp) - (typep 1 tp) - (typep (/ i 3) tp) - (not (typep (/ (1+ i) 3) tp))) - collect (list i tp)) - nil) - -(deftest real.4 - (loop for i = 4 then (ash i 1) - for tp = `(real ,(- (/ i 3)) 0) - repeat 200 - unless (and (not (typep (- -1 (/ i 3)) tp)) - (typep (- (/ i 3)) tp) - (typep -1 tp) - (typep 0 tp) - (not (typep 1 tp)) - (not (typep (/ i 3) tp)) - (not (typep (1+ (/ i 3)) tp))) - collect (list i tp)) - nil) diff --git a/t/ansi-test/numbers/realp.lsp b/t/ansi-test/numbers/realp.lsp deleted file mode 100644 index affb15b..0000000 --- a/t/ansi-test/numbers/realp.lsp +++ /dev/null @@ -1,45 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Sep 7 08:22:06 2003 -;;;; Contains: Tests of REALP - - - -(deftest realp.error.1 - (signals-error (realp) program-error) - t) - -(deftest realp.error.2 - (signals-error (realp 0 nil) program-error) - t) - -(deftest realp.error.3 - (signals-error (realp nil nil) program-error) - t) - -(deftest realp.1 - (notnot-mv (realp 0)) - t) - -(deftest realp.2 - (notnot-mv (realp 0.0)) - t) - -(deftest realp.3 - (realp #c(1 2)) - nil) - -(deftest realp.4 - (notnot-mv (realp 17/13)) - t) - -(deftest realp.5 - (realp 'a) - nil) - -(deftest realp.6 - (check-type-predicate #'realp 'real) - nil) - - - diff --git a/t/ansi-test/numbers/realpart.lsp b/t/ansi-test/numbers/realpart.lsp deleted file mode 100644 index cac22d6..0000000 --- a/t/ansi-test/numbers/realpart.lsp +++ /dev/null @@ -1,52 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Sep 7 07:41:15 2003 -;;;; Contains: Tests of REALPART - - - -(deftest realpart.error.1 - (signals-error (realpart) program-error) - t) - -(deftest realpart.error.2 - (signals-error (realpart #c(1.0 2.0) nil) program-error) - t) - -(deftest realpart.error.3 - (check-type-error #'realpart #'numberp) - nil) - -(deftest realpart.1 - (loop for x in *reals* - for c = (complex x 0) - for rp = (realpart c) - unless (eql x rp) - collect (list x c rp)) - nil) - -(deftest realpart.2 - (loop for x in *reals* - for c = (complex x 1) - for rp = (realpart c) - unless (eql x rp) - collect (list x c rp)) - nil) - -(deftest realpart.3 - (loop for x in *reals* - for c = (complex x x) - for rp = (realpart c) - unless (eql x rp) - collect (list x c rp)) - nil) - -;;; Should move this to complex.lsp -(deftest realpart.4 - (loop for c in *complexes* - for rp = (realpart c) - for ip = (imagpart c) - for c2 = (complex rp ip) - unless (eql c c2) - collect (list c rp ip c2)) - nil) diff --git a/t/ansi-test/numbers/round.lsp b/t/ansi-test/numbers/round.lsp deleted file mode 100644 index 4516113..0000000 --- a/t/ansi-test/numbers/round.lsp +++ /dev/null @@ -1,179 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Aug 21 13:39:56 2003 -;;;; Contains: Tests of ROUND - - - - - - -(deftest round.error.1 - (signals-error (round) program-error) - t) - -(deftest round.error.2 - (signals-error (round 1.0 1 nil) program-error) - t) - -;;; - -(deftest round.1 - (round.1-fn) - nil) - -(deftest round.2 - (round.2-fn) - nil) - -(deftest round.3 - (round.3-fn 2.0s4) - nil) - -(deftest round.4 - (round.3-fn 2.0f4) - nil) - -(deftest round.5 - (round.3-fn 2.0d4) - nil) - -(deftest round.6 - (round.3-fn 2.0l4) - nil) - -(deftest round.7 - (round.7-fn) - nil) - -(deftest round.8 - (round.8-fn) - nil) - -(deftest round.9 - (round.9-fn) - nil) - -(deftest round.10 - (loop for x in (remove-if #'zerop *reals*) - for (q r) = (multiple-value-list (round x x)) - unless (and (eql q 1) - (zerop r) - (if (rationalp x) (eql r 0) - (eql r (float 0 x)))) - collect x) - nil) - -(deftest round.11 - (loop for x in (remove-if #'zerop *reals*) - for (q r) = (multiple-value-list (round (- x) x)) - unless (and (eql q -1) - (zerop r) - (if (rationalp x) (eql r 0) - (eql r (float 0 x)))) - collect x) - nil) - -(deftest round.12 - (let* ((radix (float-radix 1.0s0)) - (rad (float radix 1.0s0)) - (rrad (/ 0.5s0 rad))) - (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (round x)) - unless (and (eql q i) - (eql r rrad)) - collect (list i x q r))) - nil) - -(deftest round.13 - (let* ((radix (float-radix 1.0s0)) - (rad (float radix 1.0s0)) - (rrad (/ 0.5s0 rad))) - (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (round x)) - unless (and (eql q i) - (eql r (- rrad))) - collect (list i x q r))) - nil) - -(deftest round.14 - (let* ((radix (float-radix 1.0f0)) - (rad (float radix 1.0f0)) - (rrad (/ 0.5f0 rad))) - (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (round x)) - unless (and (eql q i) - (eql r rrad)) - collect (list i x q r))) - nil) - -(deftest round.15 - (let* ((radix (float-radix 1.0f0)) - (rad (float radix 1.0f0)) - (rrad (/ 0.5f0 rad))) - (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (round x)) - unless (and (eql q i) - (eql r (- rrad))) - collect (list i x q r))) - nil) - -(deftest round.16 - (let* ((radix (float-radix 1.0d0)) - (rad (float radix 1.0d0)) - (rrad (/ 0.5d0 rad))) - (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (round x)) - unless (and (eql q i) - (eql r rrad)) - collect (list i x q r))) - nil) - -(deftest round.17 - (let* ((radix (float-radix 1.0d0)) - (rad (float radix 1.0d0)) - (rrad (/ 0.5d0 rad))) - (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (round x)) - unless (and (eql q i) - (eql r (- rrad))) - collect (list i x q r))) - nil) - -(deftest round.18 - (let* ((radix (float-radix 1.0l0)) - (rad (float radix 1.0l0)) - (rrad (/ 0.5l0 rad))) - (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (round x)) - unless (and (eql q i) - (eql r rrad)) - collect (list i x q r))) - nil) - -(deftest round.19 - (let* ((radix (float-radix 1.0l0)) - (rad (float radix 1.0l0)) - (rrad (/ 0.5l0 rad))) - (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (round x)) - unless (and (eql q i) - (eql r (- rrad))) - collect (list i x q r))) - nil) - -(deftest round.20 - (round 1/2) - 0 1/2) - -(deftest round.21 - (round 3/2) - 2 -1/2) diff --git a/t/ansi-test/numbers/signum.lsp b/t/ansi-test/numbers/signum.lsp deleted file mode 100644 index 39edf51..0000000 --- a/t/ansi-test/numbers/signum.lsp +++ /dev/null @@ -1,114 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Sep 4 22:29:09 2003 -;;;; Contains: Tests of SIGNUM - - - -(deftest signum.error.1 - (signals-error (signum) program-error) - t) - -(deftest signum.error.2 - (signals-error (signum 1 1) program-error) - t) - -(deftest signum.error.3 - (signals-error (signum 1 nil) program-error) - t) - -(deftest signum.1 - (signum 0) - 0) - -(deftest signum.2 - (signum 123) - 1) - -(deftest signum.3 - (signum -123123) - -1) - -(deftest signum.4 - (loop for i in *rationals* - for s = (signum i) - unless (cond - ((zerop i) (eql s 0)) - ((plusp i) (eql s 1)) - (t (eql s -1))) - collect (list i s)) - nil) - -(deftest signum.5 - (loop for x in '(0.0s0 0.0f0 0.0d0 0.0l0) - for one = (float 1 x) - for y = (float 13122 x) - for s1 = (signum x) - for s2 = (signum y) - for s3 = (signum (- y)) - unless (and (eql s1 x) - (eql s2 one) - (eql s3 (- one))) - collect (list x one y s1 s2 s3)) - nil) - -(deftest signum.6 - (loop - for tp in '(short-float single-float double-float long-float) - for z = (coerce 0 tp) - for mz = (- z) - nconc - (loop for x in (list z mz) - nconc - (loop for y in (list z mz) - for c = (complex z mz) - for s = (signum c) - unless (eql c s) - collect (list c s)))) - nil) - -(deftest signum.7 - (loop - for tp in '(short-float single-float double-float long-float) - for z = (coerce 0 tp) - for one = (coerce 1 tp) - for onem = (coerce -1 tp) - for c1 = (complex one z) - for c2 = (complex onem z) - for c3 = (complex z one) - for c4 = (complex z onem) - unless (eql c1 (signum c1)) - collect (list c1 (signum c1)) - unless (eql c2 (signum c2)) - collect (list c2 (signum c2)) - unless (eql c3 (signum c3)) - collect (list c3 (signum c3)) - unless (eql c4 (signum c4)) - collect (list c4 (signum c4))) - nil) - -(deftest signum.8 - (let* ((c (complex 0 1)) - (s (signum c))) - (or (eqlt c s) - (eqlt s #c(0.0 1.0)))) - t) - -(deftest signum.9 - (let* ((c (complex 0 -1)) - (s (signum c))) - (or (eqlt c s) - (eqlt s #c(0.0 -1.0)))) - t) - -(deftest signum.10 - (let* ((c (complex 3/5 4/5)) - (s (signum c))) - (or (eqlt c s) - (eqlt s (complex (float 3/5) (float 4/5))))) - t) - -(deftest signum.11 - (let ((i 0)) (values (signum (the (integer 1 1) (incf i))) i)) - 1 1) - diff --git a/t/ansi-test/numbers/sin.lsp b/t/ansi-test/numbers/sin.lsp deleted file mode 100644 index 17c08e5..0000000 --- a/t/ansi-test/numbers/sin.lsp +++ /dev/null @@ -1,171 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Feb 9 20:20:46 2004 -;;;; Contains: Tests for SIN - - - -(deftest sin.1 - (loop for i from -1000 to 1000 - for rlist = (multiple-value-list (sin i)) - for y = (car rlist) - always (and (null (cdr rlist)) - (<= -1 y 1) - (or (rationalp y) (typep y 'single-float)))) - t) - -(deftest sin.2 - (loop for x = (- (random 2000.0s0) 1000.0s0) - for rlist = (multiple-value-list (sin x)) - for y = (car rlist) - repeat 1000 - always (and (null (cdr rlist)) - (<= -1 y 1) - (typep y 'short-float))) - t) - -(deftest sin.3 - (loop for x = (- (random 2000.0f0) 1000.0f0) - for rlist = (multiple-value-list (sin x)) - for y = (car rlist) - repeat 1000 - always (and (null (cdr rlist)) - (<= -1 y 1) - (typep y 'single-float))) - t) - -(deftest sin.4 - (loop for x = (- (random 2000.0d0) 1000.0d0) - for rlist = (multiple-value-list (sin x)) - for y = (car rlist) - repeat 1000 - always (and (null (cdr rlist)) - (<= -1 y 1) - (typep y 'double-float))) - t) - -(deftest sin.5 - (loop for x = (- (random 2000.0l0) 1000.0l0) - for rlist = (multiple-value-list (sin x)) - for y = (car rlist) - repeat 1000 - always (and (null (cdr rlist)) - (<= -1 y 1) - (typep y 'long-float))) - t) - -(deftest sin.6 - (let ((r (sin 0))) - (or (eqlt r 0) (eqlt r 0.0))) - t) - -(deftest sin.7 - (sin 0.0s0) - 0.0s0) - -(deftest sin.8 - (sin 0.0) - 0.0) - -(deftest sin.9 - (sin 0.0d0) - 0.0d0) - -(deftest sin.10 - (sin 0.0l0) - 0.0l0) - -(deftest sin.11 - (loop for i from 1 to 100 - unless (approx= (sin i) (sin (coerce i 'single-float))) - collect i) - nil) - -(deftest sin.12 - (approx= (sin (coerce (/ pi 2) 'single-float)) 1.0) - t) - -(deftest sin.13 - (approx= (sin (coerce (/ pi -2) 'single-float)) -1.0) - t) - -(deftest sin.14 - (approx= (sin (coerce (/ pi 2) 'short-float)) 1.0s0) - t) - -(deftest sin.15 - (approx= (sin (coerce (/ pi -2) 'short-float)) -1.0s0) - t) - -(deftest sin.16 - (approx= (sin (coerce (/ pi 2) 'double-float)) 1.0d0) - t) - -(deftest sin.17 - (approx= (sin (coerce (/ pi -2) 'double-float)) -1.0d0) - t) - -(deftest sin.18 - (approx= (sin (coerce (/ pi 2) 'long-float)) 1.0l0) - t) - -(deftest sin.19 - (approx= (sin (coerce (/ pi -2) 'long-float)) -1.0l0) - t) - -(deftest sin.20 - (loop for r = (- (random 2000) 1000) - for i = (- (random 20) 10) - for y = (sin (complex r i)) - repeat 1000 - always (numberp y)) - t) - -(deftest sin.21 - (loop for r = (- (random 2000.0s0) 1000.0s0) - for i = (- (random 20.0s0) 10.0s0) - for y = (sin (complex r i)) - repeat 1000 - always (numberp y)) - t) - -(deftest sin.22 - (loop for r = (- (random 2000.0f0) 1000.0f0) - for i = (- (random 20.0f0) 10.0f0) - for y = (sin (complex r i)) - repeat 1000 - always (numberp y)) - t) - -(deftest sin.23 - (loop for r = (- (random 2000.0d0) 1000.0d0) - for i = (- (random 20.0d0) 10.0d0) - for y = (sin (complex r i)) - repeat 1000 - always (numberp y)) - t) - -(deftest sin.24 - (loop for r = (- (random 2000.0l0) 1000.0l0) - for i = (- (random 20.0l0) 10.0l0) - for y = (sin (complex r i)) - repeat 1000 - always (numberp y)) - t) - -;;; FIXME -;;; More accuracy tests here - -;;; Error tests - -(deftest sin.error.1 - (signals-error (sin) program-error) - t) - -(deftest sin.error.2 - (signals-error (sin 0.0 0.0) program-error) - t) - -(deftest sin.error.3 - (check-type-error #'sin #'numberp) - nil) diff --git a/t/ansi-test/numbers/sinh.lsp b/t/ansi-test/numbers/sinh.lsp deleted file mode 100644 index 1832431..0000000 --- a/t/ansi-test/numbers/sinh.lsp +++ /dev/null @@ -1,92 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Feb 11 06:29:51 2004 -;;;; Contains: Tests for SINH - - - -(deftest sinh.1 - (let ((result (sinh 0))) - (or (eqlt result 0) - (eqlt result 0.0))) - t) - -(deftest sinh.2 - (loop for type in '(short-float single-float double-float long-float) - for zero = (coerce 0 type) - unless (equal (multiple-value-list (sinh zero)) - (list zero)) - collect type) - nil) - -(deftest sinh.3 - (loop for type in '(short-float single-float double-float long-float) - for zero = (coerce 0 `(complex ,type)) - unless (equal (multiple-value-list (sinh zero)) - (list zero)) - collect type) - nil) - -(deftest sinh.4 - (loop for den = (1+ (random 10000)) - for num = (random (* 10 den)) - for x = (/ num den) - for rlist = (multiple-value-list (sinh x)) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (numberp y)) - collect (list x rlist)) - nil) - -(deftest sinh.5 - (loop for type in '(short-float single-float double-float long-float) - nconc - (loop - for x = (- (random (coerce 20 type)) 10) - for rlist = (multiple-value-list (sinh x)) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (typep y type)) - collect (list x rlist))) - nil) - -(deftest sinh.6 - (loop for type in '(short-float single-float double-float long-float) - nconc - (loop - for x1 = (- (random (coerce 20 type)) 10) - for x2 = (- (random (coerce 20 type)) 10) - for rlist = (multiple-value-list (sinh (complex x1 x2))) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (typep y `(complex ,type))) - collect (list x1 x2 rlist))) - nil) - -;;; FIXME -;;; Add accuracy tests here - -;;; Error tests - -(deftest sinh.error.1 - (signals-error (sinh) program-error) - t) - -(deftest sinh.error.2 - (signals-error (sinh 1.0 1.0) program-error) - t) - -(deftest sinh.error.3 - (check-type-error #'sinh #'numberp) - nil) - - - - - - - - diff --git a/t/ansi-test/numbers/sqrt.lsp b/t/ansi-test/numbers/sqrt.lsp deleted file mode 100644 index 067adad..0000000 --- a/t/ansi-test/numbers/sqrt.lsp +++ /dev/null @@ -1,204 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Sep 6 10:54:17 2003 -;;;; Contains: Tests of SQRT - - - - - -(deftest sqrt.error.1 - (signals-error (sqrt) program-error) - t) - -(deftest sqrt.error.2 - (signals-error (sqrt 0 nil) program-error) - t) - -(deftest sqrt.error.3 - (check-type-error #'sqrt #'numberp) - nil) - -(deftest sqrt.1 - (let ((s (sqrt 0))) - (and (realp s) - (=t s 0))) - t) - -(deftest sqrt.2 - (let ((s (sqrt 1))) - (and (realp s) - (=t s 1))) - t) - -(deftest sqrt.3 - (loop for x in '(0.0s0 1.0s0 0.0f0 1.0f0 0.0d0 1.0d0 0.0l0 1.0l0) - for s = (sqrt x) - unless (eql s x) - collect (list x s)) - nil) - -(deftest sqrt.4 - (loop for x in '(0.0s0 1.0s0 0.0f0 1.0f0 0.0d0 1.0d0 0.0l0 1.0l0) - for c = (complex x 0) - for s = (sqrt c) - unless (eql s c) - collect (list x c s)) - nil) - -(deftest sqrt.5 - (loop for x in '(-1.0s0 -1.0f0 -1.0d0 -1.0l0) - for s = (sqrt x) - unless (eql s (complex 0 (- x))) - collect (list x s)) - nil) - -;;; (deftest sqrt.6 -;;; (let ((result (sqrt (ash 1 10000)))) -;;; (if (integerp result) -;;; (=t result (ash 1 5000)) -;;; (=t result (float (ash 1 5000) result)))) -;;; t) - -(deftest sqrt.7 - (let ((result (sqrt -1))) - (or (eqlt result #c(0 1)) - (eqlt result #c(0.0 1.0)))) - t) - -(deftest sqrt.8 - (loop for x in *floats* - for s = (sqrt x) - unless (cond - ((zerop x) (=t x 0)) - ((plusp x) (and (eqlt (float s x) s) - (eqlt (float x s) x))) - (t (complexp s))) - collect (list x s)) - nil) - -(deftest sqrt.9 - (let ((upper (rational most-positive-double-float)) - (lower (rational most-negative-double-float))) - (loop for x = (random-fixnum) - repeat 1000 - unless (or (< x lower) - (> x upper) - (let ((s (sqrt x))) - (or (and (rationalp s) - (>= s 0) - (eql (* s s) x)) - (and (floatp s) (>= x 0)) - (and (complexp s) - (zerop (realpart s)) - (> (imagpart s) 0) - (< x 0))))) - collect (list x (sqrt x)))) - nil) - -(deftest sqrt.10 - (loop for x from 1 to 1000 - for x2 = (* x x) - for s = (sqrt x2) - unless (if (rationalp s) (eql x s) - (and (typep s 'single-float) - (= x s))) - collect (list x s)) - nil) - -(deftest sqrt.11 - (loop for x from 1 to 1000 - for x2 = (* x x) - for s = (sqrt (- x2)) - unless (and (complexp s) - (zerop (realpart s)) - (let ((i (imagpart s))) - (if (rationalp i) - (eql i x) - (= i x)))) - collect (list x s)) - nil) - -;;; Tests of the branch cut -(deftest sqrt.12 - (loop for xr = (random-fixnum) - for xi = (random-fixnum) - for c = (complex xr xi) - for s = (sqrt c) - repeat 1000 - unless (or (> (realpart s) 0) - (and (= (realpart s) 0) - (>= (imagpart s) 0))) - collect (list c s)) - nil) - -(deftest sqrt.13 - (loop for xr = (random-from-interval 1.0f6 -1.0f6) - for xi = (random-from-interval 1.0f6 -1.0f6) - for c = (complex xr xi) - for s = (sqrt c) - repeat 1000 - unless (or (> (realpart s) 0) - (and (= (realpart s) 0) - (>= (imagpart s) 0))) - collect (list c s)) - nil) - -(deftest sqrt.14 - (loop for xr = (random-from-interval 1.0s3 -1.0s3) - for xi = (random-from-interval 1.0s3 -1.0s3) - for c = (complex xr xi) - for s = (sqrt c) - repeat 1000 - unless (or (> (realpart s) 0) - (and (= (realpart s) 0) - (>= (imagpart s) 0))) - collect (list c s)) - nil) - -(deftest sqrt.15 - (loop for xr = (random-from-interval 1.0d7 -1.0d7) - for xi = (random-from-interval 1.0d7 -1.0d7) - for c = (complex xr xi) - for s = (sqrt c) - repeat 1000 - unless (or (> (realpart s) 0) - (and (= (realpart s) 0) - (>= (imagpart s) 0))) - collect (list c s)) - nil) - -(deftest sqrt.16 - (loop for xr = (random-from-interval 1.0l9 -1.0l9) - for xi = (random-from-interval 1.0l9 -1.0l9) - for c = (complex xr xi) - for s = (sqrt c) - repeat 1000 - unless (or (> (realpart s) 0) - (and (= (realpart s) 0) - (>= (imagpart s) 0))) - collect (list c s)) - nil) - -(deftest sqrt.17 - (let ((b1 (find-largest-exactly-floatable-integer most-positive-fixnum))) - (loop for i = (random-from-interval (* b1 b1) 0) - repeat 1000 - unless (>= (sqrt i) (isqrt i)) - collect i)) - nil) - -(deftest sqrt.18 - (loop for x = (random-from-interval 1.0f6 0.0f0) - repeat 1000 - unless (>= (sqrt x) (isqrt (floor x))) - collect x) - nil) - -(deftest sqrt.19 - (loop for x in '(0.0s0 0.0f0 0.0d0 0.0l0) - for s = (sqrt x) - unless (= s x) - collect (list x s)) - nil) - diff --git a/t/ansi-test/numbers/tan.lsp b/t/ansi-test/numbers/tan.lsp deleted file mode 100644 index 56ed024..0000000 --- a/t/ansi-test/numbers/tan.lsp +++ /dev/null @@ -1,158 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Feb 9 20:55:40 2004 -;;;; Contains: Tests of TAN - - - -(deftest tan.1 - (loop for i from -1000 to 1000 - for rlist = (multiple-value-list (tan i)) - for y = (car rlist) - always (and (null (cdr rlist)) - (or (rationalp y) (typep y 'single-float)))) - t) - -(deftest tan.2 - (loop for x = (- (random 2000.0s0) 1000.0s0) - for y = (safe-tan x 0.0s0) - repeat 1000 - always (typep y 'short-float)) - t) - -(deftest tan.3 - (loop for x = (- (random 2000.0f0) 1000.0f0) - for y = (safe-tan x 0.0) - repeat 1000 - always (typep y 'single-float)) - t) - -(deftest tan.4 - (loop for x = (- (random 2000.0d0) 1000.0d0) - for y = (safe-tan x 0.0d0) - repeat 1000 - always (typep y 'double-float)) - t) - -(deftest tan.5 - (loop for x = (- (random 2000.0l0) 1000.0l0) - for y = (safe-tan 0.0l0) - repeat 1000 - always (typep y 'long-float)) - t) - -(deftest tan.6 - (let ((r (tan 0))) - (or (eqlt r 0) (eqlt r 0.0))) - t) - -(deftest tan.7 - (tan 0.0s0) - 0.0s0) - -(deftest tan.8 - (tan 0.0) - 0.0) - -(deftest tan.9 - (tan 0.0d0) - 0.0d0) - -(deftest tan.10 - (tan 0.0l0) - 0.0l0) - -(deftest tan.11 - (loop for i from 1 to 100 - unless (approx= (tan i) (tan (coerce i 'single-float))) - collect i) - nil) - -(deftest tan.12 - (approx= (tan (coerce (/ pi 4) 'single-float)) 1.0) - t) - -(deftest tan.13 - (approx= (tan (coerce (/ pi -4) 'single-float)) -1.0) - t) - -(deftest tan.14 - (approx= (tan (coerce (/ pi 4) 'short-float)) 1s0) - t) - -(deftest tan.15 - (approx= (tan (coerce (/ pi -4) 'short-float)) -1s0) - t) - -(deftest tan.16 - (approx= (tan (coerce (/ pi 4) 'double-float)) 1d0) - t) - -(deftest tan.17 - (approx= (tan (coerce (/ pi -4) 'double-float)) -1d0) - t) - -(deftest tan.18 - (approx= (tan (coerce (/ pi 4) 'long-float)) 1l0) - t) - -(deftest tan.19 - (approx= (tan (coerce (/ pi -4) 'long-float)) -1l0) - t) - -(deftest tan.20 - (loop for r = (- (random 2000) 1000) - for i = (- (random 20) 10) - for y = (safe-tan (complex r i)) - repeat 1000 - always (numberp y)) - t) - -(deftest tan.21 - (loop for r = (- (random 2000.0s0) 1000.0s0) - for i = (- (random 20.0s0) 10.0s0) - for y = (safe-tan (complex r i)) - repeat 1000 - always (numberp y)) - t) - -(deftest tan.22 - (loop for r = (- (random 2000.0f0) 1000.0f0) - for i = (- (random 20.0f0) 10.0f0) - for y = (safe-tan (complex r i)) - repeat 1000 - always (numberp y)) - t) - -(deftest tan.23 - (loop for r = (- (random 2000.0d0) 1000.0d0) - for i = (- (random 20.0d0) 10.0d0) - for y = (safe-tan (complex r i)) - repeat 1000 - always (numberp y)) - t) - -(deftest tan.24 - (loop for r = (- (random 2000.0l0) 1000.0l0) - for i = (- (random 20.0l0) 10.0l0) - for y = (safe-tan (complex r i)) - repeat 1000 - always (numberp y)) - t) - -;;; FIXME -;;; More accuracy tests here - -;;; Error tests - -(deftest tan.error.1 - (signals-error (tan) program-error) - t) - -(deftest tan.error.2 - (signals-error (tan 0.0 0.0) program-error) - t) - -(deftest tan.error.3 - (check-type-error #'tan #'numberp) - nil) diff --git a/t/ansi-test/numbers/tanh.lsp b/t/ansi-test/numbers/tanh.lsp deleted file mode 100644 index bbbc6a1..0000000 --- a/t/ansi-test/numbers/tanh.lsp +++ /dev/null @@ -1,84 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Feb 11 19:16:35 2004 -;;;; Contains: Tests of TANH - - - -(deftest tanh.1 - (let ((result (tanh 0))) - (or (eqlt result 0) - (eqlt result 0.0))) - t) - -(deftest tanh.2 - (loop for type in '(short-float single-float double-float long-float) - for zero = (coerce 0 type) - unless (equal (multiple-value-list (tanh zero)) - (list zero)) - collect type) - nil) - -(deftest tanh.3 - (loop for type in '(short-float single-float double-float long-float) - for zero = (coerce 0 `(complex ,type)) - unless (equal (multiple-value-list (tanh zero)) - (list zero)) - collect type) - nil) - -(deftest tanh.4 - (loop for den = (1+ (random 10000)) - for num = (random (* 10 den)) - for x = (/ num den) - for rlist = (multiple-value-list (tanh x)) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (numberp y)) - collect (list x rlist)) - nil) - -(deftest tanh.5 - (loop for type in '(short-float single-float double-float long-float) - nconc - (loop - for x = (- (random (coerce 20 type)) 10) - for rlist = (multiple-value-list (tanh x)) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (typep y type)) - collect (list x rlist))) - nil) - -(deftest tanh.6 - (loop for type in '(short-float single-float double-float long-float) - nconc - (loop - for x1 = (- (random (coerce 20 type)) 10) - for x2 = (- (random (coerce 20 type)) 10) - for rlist = (multiple-value-list (tanh (complex x1 x2))) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (typep y `(complex ,type))) - collect (list x1 x2 rlist))) - nil) - -;;; FIXME -;;; Add accuracy tests here - -;;; Error tests - -(deftest tanh.error.1 - (signals-error (tanh) program-error) - t) - -(deftest tanh.error.2 - (signals-error (tanh 1.0 1.0) program-error) - t) - -(deftest tanh.error.3 - (check-type-error #'tanh #'numberp) - nil) diff --git a/t/ansi-test/numbers/times.lsp b/t/ansi-test/numbers/times.lsp deleted file mode 100644 index 89b7026..0000000 --- a/t/ansi-test/numbers/times.lsp +++ /dev/null @@ -1,390 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Aug 28 10:41:34 2003 -;;;; Contains: Tests of the multiplication function * - - - - - - -(deftest *.1 - (*) - 1) - -(deftest *.2 - (loop for x in *numbers* - unless (eql x (* x)) - collect x) - nil) - -(deftest *.3 - (loop for x in *numbers* - for x1 = (* x 1) - for x2 = (* 1 x) - unless (and (eql x x1) (eql x x2) (eql x1 x2)) - collect (list x x1 x2)) - nil) - -(deftest *.4 - (loop for x in *numbers* - for x1 = (* x 0) - for x2 = (* 0 x) - unless (and (= x1 0) (= x2 0)) - collect (list x x1 x2)) - nil) - -(deftest *.5 - (loop for bound in '(1.0s0 1.0f0 1.0d0 1.0l0) - nconc - (loop for x = (random bound) - for x1 = (* x -1) - for x2 = (* -1 x) - for x3 = (* x bound) - for x4 = (* bound x) - repeat 1000 - unless (and (eql (- x) x1) (eql (- x) x2) - (eql x x3) (eql x x4)) - collect (list x x1 x2 x3 x4))) - nil) - -(deftest *.6 - (let* ((upper-bound (* 1000 1000 1000 1000)) - (lower-bound (- upper-bound)) - (spread (1+ (- upper-bound lower-bound)))) - (loop for x = (random-from-interval upper-bound) - for y = (random-from-interval upper-bound) - for prod = (* x y) - for prod2 = (integer-times x y) - repeat 1000 - unless (eql prod prod2) - collect (list x y prod prod2))) - nil) - -(deftest *.7 - (let* ((upper-bound (* 1000 1000 1000)) - (lower-bound (- upper-bound)) - (spread (1+ (- upper-bound lower-bound)))) - (loop for x = (+ (rational (random (float spread 1.0f0))) lower-bound) - for y = (+ (rational (random (float spread 1.0f0))) lower-bound) - for prod = (* x y) - for prod2 = (rat-times x y) - repeat 1000 - unless (eql prod prod2) - collect (list x y prod prod2))) - nil) - -;; Testing of multiplication by integer constants -(deftest *.8 - (let ((bound (isqrt most-positive-fixnum))) - (loop - for x = (random bound) - for y = (random bound) - for f = (eval `(function (lambda (z) - (declare (optimize (speed 3) (safety 0))) - (declare (type (integer 0 (,bound)) z)) - (* ,x z)))) - for prod = (funcall f y) - repeat 100 - unless (and (eql prod (* x y)) - (eql prod (integer-times x y))) - collect (progn (format t "Failed on ~A~%" (list x y prod)) - (list x y prod (* x y) (integer-times x y))))) - nil) - -(deftest *.9 - (let* ((upper-bound (* 1000 1000 1000 1000))) - (flet ((%r () (random-from-interval upper-bound))) - (loop for xr = (%r) - for xc = (%r) - for x = (complex xr xc) - for yr = (%r) - for yc = (%r) - for y = (complex yr yc) - for prod = (* x y) - repeat 1000 - unless (and (eql (realpart prod) (- (integer-times xr yr) - (integer-times xc yc))) - (eql (imagpart prod) (+ (integer-times xr yc) - (integer-times xc yr)))) - collect (list x y prod)))) - nil) - -(deftest *.10 - (let* ((upper-bound (* 1000 1000 1000 1000)) - (lower-bound (- upper-bound)) - (spread (1+ (- upper-bound lower-bound)))) - (flet ((%r () (+ (rational (random (float spread 1.0f0))) lower-bound))) - (loop for xr = (%r) - for xc = (%r) - for x = (complex xr xc) - for yr = (%r) - for yc = (%r) - for y = (complex yr yc) - for prod = (* x y) - repeat 1000 - unless (and (eql (realpart prod) (- (rat-times xr yr) - (rat-times xc yc))) - (eql (imagpart prod) (+ (rat-times xr yc) - (rat-times xc yr)))) - collect (list x y prod)))) - nil) - -(deftest *.11 - (let ((prod 1) (args nil)) - (loop for i from 1 to (min 256 (1- call-arguments-limit)) - do (push i args) - do (setq prod (* prod i)) - always (eql (apply #'* args) prod))) - t) - -(deftest *.12 - (loop - for x in '(1.0s0 1.0f0 1.0d0 1.0l0) - for radix = (float-radix x) - for (k eps-r eps-f) = (multiple-value-list (find-epsilon x)) - nconc - (loop for i from 1 to k - for y = (+ x (expt radix (- i))) - nconc - (loop for j from 1 to (- k i) - for z = (+ x (expt radix (- j))) - unless (eql (* y z) - (+ x - (expt radix (- i)) - (expt radix (- j)) - (expt radix (- (+ i j))))) - collect (list x i j)))) - nil) - -(deftest *.13 - (loop - for x in '(1.0s0 1.0f0 1.0d0 1.0l0) - for radix = (float-radix x) - for (k eps-r eps-f) = (multiple-value-list (find-epsilon x)) - nconc - (loop for i from 1 to k - for y = (- x (expt radix (- i))) - nconc - (loop for j from 1 to (- k i) - for z = (- x (expt radix (- j))) - unless (eql (* y z) - (+ x - (- (expt radix (- i))) - (- (expt radix (- j))) - (expt radix (- (+ i j))))) - collect (list x i j)))) - nil) - -;;; Float contagion - -(deftest *.14 - (let ((bound (- (sqrt most-positive-short-float) 1))) - (loop for x = (random-from-interval bound) - for y = (random-from-interval bound) - for p = (* x y) - repeat 1000 - unless (and (eql p (* y x)) - (typep p 'short-float)) - collect (list x y p))) - nil) - -(deftest *.15 - (let ((bound (- (sqrt most-positive-single-float) 1))) - (loop for x = (random-from-interval bound) - for y = (random-from-interval bound) - for p = (* x y) - repeat 1000 - unless (and (eql p (* y x)) - (typep p 'single-float)) - collect (list x y p))) - nil) - -(deftest *.16 - (let ((bound (- (sqrt most-positive-double-float) 1))) - (loop for x = (random-from-interval bound) - for y = (random-from-interval bound) - for p = (* x y) - repeat 1000 - unless (and (eql p (* y x)) - (typep p 'double-float)) - collect (list x y p))) - nil) - -(deftest *.17 - (let ((bound (- (sqrt most-positive-long-float) 1))) - (loop for x = (random-from-interval bound) - for y = (random-from-interval bound) - for p = (* x y) - repeat 1000 - unless (and (eql p (* y x)) - (typep p 'long-float)) - collect (list x y p))) - nil) - -(deftest *.18 - (let ((bound (- (sqrt most-positive-short-float) 1)) - (bound2 (- (sqrt most-positive-single-float) 1))) - (loop for x = (random-from-interval bound) - for y = (random-from-interval bound2) - for p = (* x y) - repeat 1000 - unless (and (eql p (* y x)) - (typep p 'single-float)) - collect (list x y p))) - nil) - -(deftest *.19 - (let ((bound (- (sqrt most-positive-short-float) 1)) - (bound2 (- (sqrt most-positive-double-float) 1))) - (loop for x = (random-from-interval bound) - for y = (random-from-interval bound2) - for p = (* x y) - repeat 1000 - unless (and (eql p (* y x)) - (typep p 'double-float)) - collect (list x y p))) - nil) - -(deftest *.20 - (let ((bound (- (sqrt most-positive-short-float) 1)) - (bound2 (- (sqrt most-positive-long-float) 1))) - (loop for x = (random-from-interval bound) - for y = (random-from-interval bound2) - for p = (* x y) - repeat 1000 - unless (and (eql p (* y x)) - (typep p 'long-float)) - collect (list x y p))) - nil) - -(deftest *.21 - (let ((bound (- (sqrt most-positive-single-float) 1)) - (bound2 (- (sqrt most-positive-double-float) 1))) - (loop for x = (random-from-interval bound) - for y = (random-from-interval bound2) - for p = (* x y) - repeat 1000 - unless (and (eql p (* y x)) - (typep p 'double-float)) - collect (list x y p))) - nil) - -(deftest *.22 - (let ((bound (- (sqrt most-positive-single-float) 1)) - (bound2 (- (sqrt most-positive-long-float) 1))) - (loop for x = (random-from-interval bound) - for y = (random-from-interval bound2) - for p = (* x y) - repeat 1000 - unless (and (eql p (* y x)) - (typep p 'long-float)) - collect (list x y p))) - nil) - -(deftest *.23 - (let ((bound (- (sqrt most-positive-double-float) 1)) - (bound2 (- (sqrt most-positive-long-float) 1))) - (loop for x = (random-from-interval bound) - for y = (random-from-interval bound2) - for p = (* x y) - repeat 1000 - unless (and (eql p (* y x)) - (typep p 'long-float)) - collect (list x y p))) - nil) - -(deftest *.24 - (loop - for type in '(short-float single-float double-float long-float) - for bits in '(13 24 50 50) - for bound = (ash 1 (floor bits 2)) - nconc - (loop for i = (random bound) - for x = (coerce i type) - for j = (random bound) - for y = (coerce j type) - for prod = (* x y) - repeat 1000 - unless (and (eql prod (coerce (* i j) type)) - (eql prod (* y x))) - collect (list i j x y (* x y) (coerce (* i j) type)))) - nil) - -(deftest *.25 - (loop - for type in '(short-float single-float double-float long-float) - for bits in '(13 24 50 50) - for bound = (ash 1 (- bits 2)) - when (= (float-radix (coerce 1.0 type)) 2) - nconc - (loop for i = (random bound) - for x = (coerce i type) - for j = (* i 2) - for y = (coerce j type) - repeat 1000 - unless (eql (* 2 x) y) - collect (list i j x (* 2 x) y))) - nil) - -;;; Shows a compiler bug in sbcl/cmucl -(deftest *.26 - (eqlt (funcall (compile nil - '(lambda (x y) - (declare (type (single-float -10.0 10.0) x) - (type (double-float -1.0d100 1.0d100) y)) - (* x y))) - 1.0f0 1.0d0) - 1.0d0) - t) - -(deftest *.27 - (loop - for type in '(short-float single-float double-float long-float) - for bits in '(13 24 50 50) - for bound = (ash 1 (floor bits 2)) - nconc - (loop for i = (random bound) - for x = (coerce i type) - for j = (random bound) - for y = (coerce j type) - for one = (coerce 1.0 type) - for cx = (complex one x) - for cy = (complex one y) - for prod = (* cx cy) - repeat 1000 - unless (and (eql prod (complex (coerce (- 1 (* i j)) type) - (coerce (+ i j) type))) - (eql prod (* cy cx))) - collect (list type i j x y (* cx cy)))) - nil) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest *.28 - (macrolet ((%m (z) z)) - (values - (* (expand-in-current-env (%m 2))) - (* (expand-in-current-env (%m 3)) 4) - (* 5 (expand-in-current-env (%m 3))))) - 2 12 15) - -;;; Order of evaluation tests - -(deftest times.order.1 - (let ((i 0) x y) - (values - (* (progn (setf x (incf i)) 2) - (progn (setf y (incf i)) 3)) - i x y)) - 6 2 1 2) - -(deftest times.order.2 - (let ((i 0) x y z) - (values - (* (progn (setf x (incf i)) 2) - (progn (setf y (incf i)) 3) - (progn (setf z (incf i)) 5)) - i x y z)) - 30 3 1 2 3) diff --git a/t/ansi-test/numbers/truncate.lsp b/t/ansi-test/numbers/truncate.lsp deleted file mode 100644 index 0188e4f..0000000 --- a/t/ansi-test/numbers/truncate.lsp +++ /dev/null @@ -1,171 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Aug 20 05:13:26 2003 -;;;; Contains: Tests of TRUNCATE - - - - - - -(deftest truncate.error.1 - (signals-error (truncate) program-error) - t) - -(deftest truncate.error.2 - (signals-error (truncate 1.0 1 nil) program-error) - t) - -;;; - -(deftest truncate.1 - (truncate.1-fn) - nil) - -(deftest truncate.2 - (truncate.2-fn) - nil) - -(deftest truncate.3 - (truncate.3-fn 2.0s4) - nil) - -(deftest truncate.4 - (truncate.3-fn 2.0f4) - nil) - -(deftest truncate.5 - (truncate.3-fn 2.0d4) - nil) - -(deftest truncate.6 - (truncate.3-fn 2.0l4) - nil) - -(deftest truncate.7 - (truncate.7-fn) - nil) - -(deftest truncate.8 - (truncate.8-fn) - nil) - -(deftest truncate.9 - (truncate.9-fn) - nil) - -(deftest truncate.10 - (loop for x in (remove-if #'zerop *reals*) - for (q r) = (multiple-value-list (truncate x x)) - unless (and (eql q 1) - (zerop r) - (if (rationalp x) (eql r 0) - (eql r (float 0 x)))) - collect x) - nil) - -(deftest truncate.11 - (loop for x in (remove-if #'zerop *reals*) - for (q r) = (multiple-value-list (truncate (- x) x)) - unless (and (eql q -1) - (zerop r) - (if (rationalp x) (eql r 0) - (eql r (float 0 x)))) - collect x) - nil) - -(deftest truncate.12 - (let* ((radix (float-radix 1.0s0)) - (rad (float radix 1.0s0)) - (rrad (/ 1.0s0 rad))) - (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (truncate x)) - unless (and (eql q i) - (eql r rrad)) - collect (list i x q r))) - nil) - -(deftest truncate.13 - (let* ((radix (float-radix 1.0s0)) - (rad (float radix 1.0s0)) - (rrad (/ 1.0s0 rad))) - (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (truncate x)) - unless (and (eql q (1- i)) - (eql r rrad)) - collect (list i x q r))) - nil) - -(deftest truncate.14 - (let* ((radix (float-radix 1.0f0)) - (rad (float radix 1.0f0)) - (rrad (/ 1.0f0 rad))) - (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (truncate x)) - unless (and (eql q i) - (eql r rrad)) - collect (list i x q r))) - nil) - -(deftest truncate.15 - (let* ((radix (float-radix 1.0f0)) - (rad (float radix 1.0f0)) - (rrad (/ 1.0f0 rad))) - (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (truncate x)) - unless (and (eql q (1- i)) - (eql r rrad)) - collect (list i x q r))) - nil) - -(deftest truncate.16 - (let* ((radix (float-radix 1.0d0)) - (rad (float radix 1.0d0)) - (rrad (/ 1.0d0 rad))) - (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (truncate x)) - unless (and (eql q i) - (eql r rrad)) - collect (list i x q r))) - nil) - -(deftest truncate.17 - (let* ((radix (float-radix 1.0d0)) - (rad (float radix 1.0d0)) - (rrad (/ 1.0d0 rad))) - (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (truncate x)) - unless (and (eql q (1- i)) - (eql r rrad)) - collect (list i x q r))) - nil) - -(deftest truncate.18 - (let* ((radix (float-radix 1.0l0)) - (rad (float radix 1.0l0)) - (rrad (/ 1.0l0 rad))) - (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (truncate x)) - unless (and (eql q i) - (eql r rrad)) - collect (list i x q r))) - nil) - -(deftest truncate.19 - (let* ((radix (float-radix 1.0l0)) - (rad (float radix 1.0l0)) - (rrad (/ 1.0l0 rad))) - (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (truncate x)) - unless (and (eql q (1- i)) - (eql r rrad)) - collect (list i x q r))) - nil) diff --git a/t/ansi-test/numbers/upgraded-complex-part-type.lsp b/t/ansi-test/numbers/upgraded-complex-part-type.lsp deleted file mode 100644 index a520480..0000000 --- a/t/ansi-test/numbers/upgraded-complex-part-type.lsp +++ /dev/null @@ -1,106 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Nov 27 21:15:46 2004 -;;;; Contains: Tests of UPGRADE-COMPLEX-PART-TYPE - - - - - -(defmacro def-ucpt-test (name types) - `(deftest ,name - (loop for type in (remove-duplicates ,types) - for upgraded-type = (upgraded-complex-part-type type) - for result = (append (check-all-subtypep type upgraded-type) - (check-all-subtypep type 'real) - (check-all-subtypep `(complex ,type) 'complex) - (check-all-subtypep `(complex ,upgraded-type) - 'complex) - (check-all-subtypep `(complex ,type) - `(complex ,upgraded-type))) - when result - collect result) - nil)) - -(def-ucpt-test upgraded-complex-part-type.1 - '(real integer rational ratio float short-float single-float - double-float long-float fixnum bignum bit unsigned-byte signed-byte)) - -(def-ucpt-test upgraded-complex-part-type.2 - (mapcar #'find-class '(real float integer rational ratio))) - -(def-ucpt-test upgraded-complex-part-type.3 - (mapcar #'class-of '(1.0s0 1.0f0 1.0d0 1.0l0))) - -(def-ucpt-test upgraded-complex-part-type.4 - (loop for i from 1 to 100 collect `(unsigned-byte ,i))) - -(def-ucpt-test upgraded-complex-part-type.5 - (loop for i from 1 to 100 collect `(signed-byte ,i))) - -(def-ucpt-test upgraded-complex-part-type.6 - (loop for i = 1 then (* i 2) - repeat 100 - collect (class-of i))) - -;;; environment argument - -(deftest upgraded-complex-part-type.7 - (loop for type in '(real integer rational float short-float - single-float double-float long-float fixnum - bignum bit unsigned-byte signed-byte) - for ut1 = (upgraded-complex-part-type type) - for ut2 = (upgraded-complex-part-type type nil) - unless (equal ut1 ut2) - collect (list type ut1 ut2)) - nil) - -(deftest upgraded-complex-part-type.8 - (loop for type in '(real integer rational float short-float - single-float double-float long-float fixnum - bignum bit unsigned-byte signed-byte) - for ut1 = (upgraded-complex-part-type type) - for ut2 = (eval `(macrolet ((%m (&environment env) - (list 'quote - (upgraded-complex-part-type ',type env)))) - (%m))) - unless (equal ut1 ut2) - collect (list type ut1 ut2)) - nil) - -;;; Subtype constraint - -(deftest upgraded-complex-part-type.9 - (let* ((types `(nil integer fixnum bignum float - short-float single-float double-float long-float - rational #-sbcl ratio real - ,@(remove-duplicates - (mapcar #'class-of '(0.0s0 0.0f0 0.0d0 0.0l0 0 100000000000000000))) - ,@(mapcar #'(lambda (x) `(eql ,x)) - (remove-duplicates - '(0.0s0 0.0f0 0.0d0 0.0l0 0 - 1.0s0 1.0f0 1.0d0 1.0l0 1 - 100000000000000000))))) - (utypes (mapcar #'upgraded-complex-part-type types))) - (loop for sublist on types - for usublist on utypes - for tp1 = (car sublist) - for utp1 = (car usublist) - nconc (loop for tp2 in (cdr sublist) - for utp2 in (cdr usublist) - nconc - (and (subtypep tp1 tp2) - (let ((result (check-all-subtypep utp1 utp2))) - (and result - (list (list tp1 tp2 result)))))))) - nil) - -;;; Error tests - -(deftest upgraded-complex-part-type.error.1 - (signals-error (upgraded-complex-part-type) program-error) - t) - -(deftest upgraded-complex-part-type.error.2 - (signals-error (upgraded-complex-part-type 'real nil nil) program-error) - t) diff --git a/t/ansi-test/numbers/zerop.lsp b/t/ansi-test/numbers/zerop.lsp deleted file mode 100644 index 17fe400..0000000 --- a/t/ansi-test/numbers/zerop.lsp +++ /dev/null @@ -1,93 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Aug 4 21:47:34 2003 -;;;; Contains: Tests of ZEROP - - - -(deftest zerop.error.1 - (signals-error (zerop) program-error) - t) - -(deftest zerop.error.2 - (signals-error (zerop 0 1) program-error) - t) - -(deftest zerop.error.3 - (signals-error (zerop 1 0) program-error) - t) - -(deftest zerop.error.4 - (check-type-error #'zerop #'numberp) - nil) - -(deftest zerop.1 - (loop for x in *numbers* - when (if (zerop x) (/= x 0) (= x 0)) - collect x) - nil) - -(deftest zerop.2 - (zerop 1) - nil) - -(deftest zerop.3 - (zerop -1) - nil) - -(deftest zerop.4 - (notnot-mv (zerop 0)) - t) - -(deftest zerop.5 - (notnot-mv (zerop 0.0s0)) - t) - -(deftest zerop.6 - (notnot-mv (zerop 0.0f0)) - t) - -(deftest zerop.7 - (notnot-mv (zerop 0.0d0)) - t) - -(deftest zerop.7a - (notnot-mv (zerop 0.0l0)) - t) - -(deftest zerop.8 - (remove-if-not #'zerop - (list least-negative-short-float - least-negative-normalized-short-float - least-negative-single-float - least-negative-normalized-single-float - least-negative-double-float - least-negative-normalized-double-float - least-negative-long-float - least-negative-normalized-long-float - most-negative-short-float - most-negative-single-float - most-negative-double-float - most-negative-long-float)) - nil) - -(deftest zerop.9 - (remove-if-not #'zerop - (list least-positive-short-float - least-positive-normalized-short-float - least-positive-single-float - least-positive-normalized-single-float - least-positive-double-float - least-positive-normalized-double-float - least-positive-long-float - least-positive-normalized-long-float - most-positive-short-float - most-positive-single-float - most-positive-double-float - most-positive-long-float)) - nil) - -(deftest zerop.10 - (notevery #'zerop (list -0.0s0 -0.0f0 -0.0d0 -0.0l0)) - nil) - diff --git a/t/ansi-test/objects/add-method.lsp b/t/ansi-test/objects/add-method.lsp deleted file mode 100644 index 3557a65..0000000 --- a/t/ansi-test/objects/add-method.lsp +++ /dev/null @@ -1,136 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Jun 4 19:12:25 2003 -;;;; Contains: Tests for ADD-METHOD - - - -(defgeneric add-method-gf-01 (x) - (:method ((x t)) 'a)) - -(defgeneric add-method-gf-02 (x)) - -;;; Cannot add a method that's already in another method - -(deftest add-method.error.1 - (let ((method (find-method #'add-method-gf-01 nil (list (find-class t))))) - (handler-case - (add-method #'add-method-gf-02 method) - (error () :error))) - :error) - -;;; The lambda lists must be congruent - -(deftest add-method.error.2 - (let* ((gf (eval '(defgeneric add-method-gf-03 (x) - (:method ((x t)) 'a)))) - (method (find-method #'add-method-gf-03 nil (list (find-class t)))) - (gf2 (eval '(defgeneric add-method-gf-04 (x y))))) - (handler-case - (add-method gf2 method) - (error () :error))) - :error) - -(deftest add-method.error.3 - (let* ((gf (eval '(defgeneric add-method-gf-05 (x &optional y) - (:method ((x t) &optional y) 'a)))) - (method (find-method #'add-method-gf-05 nil (list (find-class t)))) - (gf2 (eval '(defgeneric add-method-gf-06 (x y))))) - (handler-case - (add-method gf2 method) - (error () :error))) - :error) - -(deftest add-method.error.4 - (signals-error (add-method) program-error) - t) - -(deftest add-method.error.5 - (signals-error (add-method #'add-method-gf-01) program-error) - t) - -(deftest add-method.error.6 - (signals-error - (let* ((gf (eval '(defgeneric add-method-gf-07 (x) - (:method ((x t)) 'a)))) - (method (find-method #'add-method-gf-07 nil (list (find-class t)))) - (gf2 (eval '(defgeneric add-method-gf-08 (x))))) - (remove-method gf method) - (add-method gf2 method nil)) - program-error) - t) - -(deftest add-method.error.7 - (let* ((gf (eval '(defgeneric add-method-gf-09 (x y) - (:method ((x t) (y t)) 'a)))) - (method (find-method #'add-method-gf-09 nil (list (find-class t) - (find-class t)))) - (gf2 (eval '(defgeneric add-method-gf-10 (x &optional y))))) - (remove-method gf method) - (handler-case - (add-method gf2 method) - (error () :error))) - :error) - -(deftest add-method.error.8 - (let* ((gf (eval '(defgeneric add-method-gf-11 (x &key y) - (:method ((x t) &key y) 'a)))) - (method (find-method #'add-method-gf-11 nil (list (find-class t)))) - (gf2 (eval '(defgeneric add-method-gf-12 (x))))) - (remove-method gf method) - (handler-case - (add-method gf2 method) - (error () :error))) - :error) - - -;;; Non-error tests - -(deftest add-method.1 - (let* ((gf (eval '(defgeneric add-method-gf-13 (x) - (:method ((x integer)) 'a) - (:method ((x t)) 'b)))) - (method (find-method #'add-method-gf-13 - nil (list (find-class 'integer)))) - (gf2 (eval '(defgeneric add-method-gf-14 (x))))) - (declare (type generic-function gf gf2)) - (values - (funcall gf 0) - (funcall gf 'x) - (eqt gf (remove-method gf method)) - (eqt gf2 (add-method gf2 method)) - (funcall gf 0) - (funcall gf 'x) - (funcall gf2 0))) - a b t t b b a) - -;;; An existing method is replaced. - -(deftest add-method.2 - (let* ((specializers (list (find-class 'integer))) - (gf (eval '(defgeneric add-method-gf-15 (x) - (:method ((x integer)) 'a) - (:method ((x t)) 'b)))) - (method (find-method gf nil specializers)) - (gf2 (eval '(defgeneric add-method-gf-16 (x) - (:method ((x integer)) 'c) - (:method ((x t)) 'd)))) - (method2 (find-method gf2 nil specializers))) - (declare (type generic-function gf gf2)) - (values - (funcall gf 0) - (funcall gf 'x) - (funcall gf2 0) - (funcall gf2 'x) - (eqt gf (remove-method gf method)) - (eqt gf2 (add-method gf2 method)) - (eqt method (find-method gf2 nil specializers)) - (eqt method2 (find-method gf2 nil specializers)) - (funcall gf 0) - (funcall gf 'x) - (funcall gf2 0) - (funcall gf2 'x))) - a b c d t t t nil b b a d) - -;;; Must add tests for: :around methods, :before methods, :after methods, -;;; nonstandard method combinations diff --git a/t/ansi-test/objects/allocate-instance.lsp b/t/ansi-test/objects/allocate-instance.lsp deleted file mode 100644 index 7aa665d..0000000 --- a/t/ansi-test/objects/allocate-instance.lsp +++ /dev/null @@ -1,130 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Apr 28 21:06:58 2003 -;;;; Contains: Tests of ALLOCATE-INSTANCE - - - -;;; According to the CLHS, the meaning of adding methods to -;;; ALLOCATE-INSTANCE is unspecified, so this will not be tested -;;; here. - -(defclass allocate-instance-class-01 () - ((a :initform 'x) (b :initarg :b) - (c :type float) (d :allocation :class) - (e :initarg :e) (f :documentation "foo")) - (:default-initargs :b 'y)) - -(deftest allocate-instance.1 - (let* ((class (find-class 'allocate-instance-class-01)) - (obj (allocate-instance class))) - (values - (eqt (class-of obj) class) - (typep* obj 'allocate-instance-class-01) - (typep* obj class) - (map-slot-boundp* obj '(a b c d e f)))) - t t t - (nil nil nil nil nil nil)) - -(deftest allocate-instance.2 - (let* ((class (find-class 'allocate-instance-class-01)) - (obj (allocate-instance class - :foo t :a 10 :b 12 :c 1.0 :d 'a :e 17 - :f nil :bar t))) - (values - (eqt (class-of obj) class) - (typep* obj 'allocate-instance-class-01) - (typep* obj class) - (map-slot-boundp* obj '(a b c d e f)))) - t t t - (nil nil nil nil nil nil)) - -(deftest allocate-instance.3 - (let* ((class (find-class 'allocate-instance-class-01)) - (obj (allocate-instance class :allow-other-keys nil :xyzzy t))) - (values - (eqt (class-of obj) class) - (typep* obj 'allocate-instance-class-01) - (typep* obj class) - (map-slot-boundp* obj '(a b c d e f)))) - t t t - (nil nil nil nil nil nil)) - -(defclass allocate-instance-class-02 () - (a (b :allocation :class))) - -(deftest allocate-instance.4 - (let ((class (find-class 'allocate-instance-class-02))) - (setf (slot-value (allocate-instance class) 'b) 'x) - (let ((obj (allocate-instance class))) - (values - (eqt (class-of obj) class) - (typep* obj 'allocate-instance-class-02) - (typep* obj class) - (slot-boundp* obj 'a) - (slot-value obj 'b)))) - t t t nil x) - -(defstruct allocate-instance-struct-01 - a - (b 0 :type integer) - (c #\a :type character) - (d 'a :type symbol)) - -(deftest allocate-instance.5 - (let* ((class (find-class 'allocate-instance-struct-01)) - (obj (allocate-instance class))) - (setf (allocate-instance-struct-01-a obj) 'x - (allocate-instance-struct-01-b obj) 1234567890 - (allocate-instance-struct-01-c obj) #\Z - (allocate-instance-struct-01-d obj) 'foo) - (values - (eqt (class-of obj) class) - (typep* obj 'allocate-instance-struct-01) - (typep* obj class) - (allocate-instance-struct-01-a obj) - (allocate-instance-struct-01-b obj) - (allocate-instance-struct-01-c obj) - (allocate-instance-struct-01-d obj))) - t t t - x 1234567890 #\Z foo) - -;;; Order of evaluation tests - -(deftest allocate-instance.order.1 - (let* ((class (find-class 'allocate-instance-class-01)) - (i 0) x y z w - (obj (allocate-instance (progn (setf x (incf i)) class) - :e (setf y (incf i)) - :b (setf z (incf i)) - :e (setf w (incf i))))) - (values - (eqt (class-of obj) class) - (typep* obj 'allocate-instance-class-01) - (typep* obj class) - i x y z w)) - t t t 4 1 2 3 4) - -;;; Error tests - -(deftest allocate-instance.error.1 - (signals-error (allocate-instance) program-error) - t) - -;;; Duane Rettig made a convincing argument that the next two -;;; tests are bad, since the caller of allocate-instance -;;; is supposed to have checked that the initargs are valid - -#| -(deftest allocate-instance.error.2 - (signals-error (allocate-instance (find-class 'allocate-instance-class-01) - :b) - program-error) - t) - -(deftest allocate-instance.error.3 - (signals-error (allocate-instance (find-class 'allocate-instance-class-01) - '(a b c) nil) - program-error) - t) -|# diff --git a/t/ansi-test/objects/call-next-method.lsp b/t/ansi-test/objects/call-next-method.lsp deleted file mode 100644 index 528eb9b..0000000 --- a/t/ansi-test/objects/call-next-method.lsp +++ /dev/null @@ -1,213 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat May 31 11:18:15 2003 -;;;; Contains: Tests of CALL-NEXT-METHOD - - - -;;; Tests where there is no next method are in no-next-method.lsp - -(defgeneric cnm-gf-01 (x) - (:method ((x integer)) (cons 'a (call-next-method))) - (:method ((x rational)) (cons 'b (call-next-method))) - (:method ((x real)) (cons 'c (call-next-method))) - (:method ((x number)) (cons 'd (call-next-method))) - (:method ((x t)) nil)) - -(deftest call-next-method.1 - (mapcar #'cnm-gf-01 '(0 2/3 1.3 #c(1 1) a)) - ((a b c d) (b c d) (c d) (d) nil)) - -;; Check that call-next-method passes along multiple values correctly - -(defgeneric cnm-gf-02 (x) - (:method ((x integer)) (call-next-method)) - (:method ((x number)) (values)) - (:method ((x (eql 'a))) (call-next-method)) - (:method ((x symbol)) (values 1 2 3 4 5 6))) - -(deftest call-next-method.2 - (cnm-gf-02 0)) - -(deftest call-next-method.3 - (cnm-gf-02 'a) - 1 2 3 4 5 6) - -;;; Call next method has indefinite extent - -(defgeneric cnm-gf-03 (x) - (:method ((x integer)) #'call-next-method) - (:method ((x t)) t)) - -(deftest call-next-method.4 - (funcall (cnm-gf-03 0)) - t) - -;;; The arguments to c-n-m can be changed - -(defgeneric cnm-gf-04 (x) - (:method ((x integer)) (call-next-method (+ x 10))) - (:method ((x number)) (1+ x))) - -(deftest call-next-method.5 - (mapcar #'cnm-gf-04 '(0 1 2 5/3 9/2 1.0 #c(1 1))) - (11 12 13 8/3 11/2 2.0 #c(2 1))) - -;;; call-next-method goes up the list of applicable methods -;;; which may be to a method with specializers incomparable to -;;; the current method - -(defgeneric cnm-gf-05 (x y) - (:method ((x integer) (y integer)) (cons 'a (call-next-method))) - (:method ((x integer) (y t)) (cons 'b (call-next-method))) - (:method ((x t) (y integer)) (cons 'c (call-next-method))) - (:method ((x t) (y t)) (list 'd))) - -(deftest call-next-method.6 - (mapcar #'cnm-gf-05 '(0 0 t t) '(0 t 0 t)) - ((a b c d) - (b d) - (c d) - (d))) - -(defclass cnm-class-01a () ()) -(defclass cnm-class-01b (cnm-class-01a) ()) -(defclass cnm-class-01c (cnm-class-01a) ()) -(defclass cnm-class-01d (cnm-class-01c cnm-class-01b) ()) - -(defgeneric cnm-gf-06 (x) - (:method ((x cnm-class-01d)) (cons 1 (call-next-method))) - (:method ((x cnm-class-01c)) (cons 2 (call-next-method))) - (:method ((x cnm-class-01b)) (cons 3 (call-next-method))) - (:method ((x cnm-class-01a)) (cons 4 (call-next-method))) - (:method ((x t)) nil)) - -(deftest call-next-method.7 - (values - (cnm-gf-06 (make-instance 'cnm-class-01d)) - (cnm-gf-06 (make-instance 'cnm-class-01c)) - (cnm-gf-06 (make-instance 'cnm-class-01b)) - (cnm-gf-06 (make-instance 'cnm-class-01a)) - (cnm-gf-06 nil)) - (1 2 3 4) - (2 4) - (3 4) - (4) - nil) - -;;; Neither rebinding nor setq affects the arguments passed by -;;; (call-next-method) - -(defgeneric cnm-gf-07 (x) - (:method ((x integer)) (list (incf x) (call-next-method))) - (:method ((x symbol)) (list (setq x 'a) x (call-next-method))) - (:method ((x cons)) (list x (let ((x :bad)) - (declare (ignorable x)) - (call-next-method)))) - (:method ((x t)) x)) - -(deftest call-next-method.8 - (mapcar #'cnm-gf-07 '(0 z (x) #\a)) - ((1 0) (a a z) ((x) (x)) #\a)) - -;; Nor does argument defaulting - -(defgeneric cnm-gf-08 (x &optional y) - (:method ((x integer) &optional y) (list* x y (call-next-method))) - (:method ((x t) &optional y) (list x y))) - -(deftest call-next-method.9 - (values - (cnm-gf-08 0) - (cnm-gf-08 0 t) - (cnm-gf-08 'a) - (cnm-gf-08 'a 'b)) - (0 nil 0 nil) - (0 t 0 t) - (a nil) - (a b)) - -;;; When c-n-m is called with arguments but omits optionals, those -;;; optionals are defaulted - -(defgeneric cnm-gf-09 (x &optional y) - (:method ((x integer) &optional y) (list* x y (call-next-method (1+ x)))) - (:method ((x t) &optional y) (list x y))) - -(deftest call-next-method.10 - (values - (cnm-gf-09 5) - (cnm-gf-09 8 'a) - (cnm-gf-09 'x) - (cnm-gf-09 'x 'y)) - (5 nil 6 nil) - (8 a 9 nil) - (x nil) - (x y)) - -(defgeneric cnm-gf-10 (x &optional y z) - (:method ((x integer) &optional (y 'a y-p) (z 'b z-p)) - (list* x y (notnot y-p) z (notnot z-p) (call-next-method (1+ x)))) - (:method ((x t) &optional (y 'c y-p) (z 'd z-p)) - (list x y (notnot y-p) z (notnot z-p)))) - -(deftest call-next-method.11 - (values - (cnm-gf-10 5) - (cnm-gf-10 8 'p) - (cnm-gf-10 8 'p 'q) - (cnm-gf-10 'x) - (cnm-gf-10 'x 'u) - (cnm-gf-10 'x 'u 'v)) - (5 a nil b nil 6 c nil d nil) - (8 p t b nil 9 c nil d nil) - (8 p t q t 9 c nil d nil) - (x c nil d nil) - (x u t d nil) - (x u t v t)) - -;;; "When providing arguments to call-next-method, the following -;;; rule must be satisfied or an error of type error should be signaled: -;;; the ordered set of applicable methods for a changed set of arguments -;;; for call-next-method must be the same as the ordered set of applicable -;;; methods for the original arguments to the generic function." - -(defgeneric cnm-order-error-gf-01 (x) - (declare (optimize (safety 3))) - (:method ((x (eql 0))) - (declare (optimize (safety 3))) - (call-next-method 1)) ;; no longer EQL to 0 - (:method ((x t)) nil)) - -(deftest call-next-method.error.1 - (locally - (declare (optimize (safety 3))) - (handler-case - (eval '(locally (declare (optimize (safety 3))) - (cnm-order-error-gf-01 0))) - (error () :error))) - :error) - -(defgeneric cnm-order-error-gf-02 (x) - (declare (optimize (safety 3))) - (:method ((x integer)) - (declare (optimize (safety 3))) - (call-next-method :bad)) - (:method ((x t)) x)) - -(deftest call-next-method.error.2 - (locally - (declare (optimize (safety 3))) - (handler-case - (eval '(locally (declare (optimize (safety 3))) - (cnm-order-error-gf-02 0))) - (error () :error))) - :error) - - - - - - - - diff --git a/t/ansi-test/objects/change-class.lsp b/t/ansi-test/objects/change-class.lsp deleted file mode 100644 index e344e88..0000000 --- a/t/ansi-test/objects/change-class.lsp +++ /dev/null @@ -1,649 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat May 3 14:23:29 2003 -;;;; Contains: Tests of CHANGE-CLASS - - - -(defclass change-class-class-01a () - ((a :initarg :a) (b :initarg :b) (c :initarg :c))) - -(defclass change-class-class-01b () - ((c :initarg :c2) (d :initarg :d2) (b :initarg :b2))) - -(deftest change-class.1.1 - (let ((obj (make-instance 'change-class-class-01a)) - (new-class (find-class 'change-class-class-01b))) - (values - (typep* obj 'change-class-class-01a) - (typep* obj 'change-class-class-01b) - (map-slot-boundp* obj '(a b c)) - (slot-exists-p obj 'd) - (eqt obj (change-class obj new-class)) - (typep* obj 'change-class-class-01a) - (typep* obj 'change-class-class-01b) - (slot-exists-p obj 'a) - (map-slot-boundp* obj '(b c d)))) - t nil (nil nil nil) - nil t nil t nil (nil nil nil)) - -(deftest change-class.1.2 - (let ((obj (make-instance 'change-class-class-01a :a 1)) - (new-class (find-class 'change-class-class-01b))) - (values - (typep* obj 'change-class-class-01a) - (typep* obj 'change-class-class-01b) - (map-slot-boundp* obj '(a b c)) - (slot-exists-p obj 'd) - (eqt obj (change-class obj new-class)) - (typep* obj 'change-class-class-01a) - (typep* obj 'change-class-class-01b) - (slot-exists-p obj 'a) - (map-slot-boundp* obj '(b c d)))) - t nil (t nil nil) - nil t nil t nil (nil nil nil)) - -(deftest change-class.1.3 - (let ((obj (make-instance 'change-class-class-01a :b 2)) - (new-class (find-class 'change-class-class-01b))) - (values - (typep* obj 'change-class-class-01a) - (typep* obj 'change-class-class-01b) - (map-slot-boundp* obj '(a b c)) - (slot-exists-p obj 'd) - (eqt obj (change-class obj new-class)) - (typep* obj 'change-class-class-01a) - (typep* obj 'change-class-class-01b) - (slot-exists-p obj 'a) - (map-slot-boundp* obj '(b c d)) - (slot-value obj 'b))) - t nil (nil t nil) - nil t nil t nil (t nil nil) 2) - -(deftest change-class.1.4 - (let ((obj (make-instance 'change-class-class-01a :a 1 :b 2 :c 5)) - (new-class (find-class 'change-class-class-01b))) - (values - (typep* obj 'change-class-class-01a) - (typep* obj 'change-class-class-01b) - (map-slot-boundp* obj '(a b c)) - (slot-exists-p obj 'd) - (eqt obj (change-class obj new-class)) - (typep* obj 'change-class-class-01a) - (typep* obj 'change-class-class-01b) - (slot-exists-p obj 'a) - (map-slot-boundp* obj '(b c d)) - (map-slot-value obj '(b c)))) - t nil (t t t) - nil t nil t nil (t t nil) (2 5)) - -(deftest change-class.1.5 - (let ((obj (make-instance 'change-class-class-01a :a 1 :b 2 :c 5)) - (new-class (find-class 'change-class-class-01b))) - (values - (eqt obj (change-class obj new-class :b2 8 :c2 76)) - (typep* obj 'change-class-class-01a) - (typep* obj 'change-class-class-01b) - (slot-exists-p obj 'a) - (map-slot-boundp* obj '(b c d)) - (map-slot-value obj '(b c)))) - t nil t nil (t t nil) (8 76)) - -(deftest change-class.1.6 - (let ((obj (make-instance 'change-class-class-01a :a 1 :b 2 :c 5)) - (new-class (find-class 'change-class-class-01b))) - (values - (eqt obj (change-class obj new-class :b2 19 :b2 34)) - (typep* obj 'change-class-class-01a) - (typep* obj 'change-class-class-01b) - (slot-exists-p obj 'a) - (map-slot-boundp* obj '(b c d)) - (map-slot-value obj '(b c)))) - t nil t nil (t t nil) (19 5)) - -(deftest change-class.1.7 - (let ((obj (make-instance 'change-class-class-01a :a 1 :b 2 :c 5)) - (new-class (find-class 'change-class-class-01b))) - (values - (eqt obj (change-class obj new-class :allow-other-keys nil)) - (typep* obj 'change-class-class-01a) - (typep* obj 'change-class-class-01b) - (slot-exists-p obj 'a) - (map-slot-boundp* obj '(b c d)) - (map-slot-value obj '(b c)))) - t nil t nil (t t nil) (2 5)) - -(deftest change-class.1.8 - (let ((obj (make-instance 'change-class-class-01a :a 1 :b 2 :c 5)) - (new-class (find-class 'change-class-class-01b))) - (values - (eqt obj (change-class obj new-class :allow-other-keys t)) - (typep* obj 'change-class-class-01a) - (typep* obj 'change-class-class-01b) - (slot-exists-p obj 'a) - (map-slot-boundp* obj '(b c d)) - (map-slot-value obj '(b c)))) - t nil t nil (t t nil) (2 5)) - -(deftest change-class.1.9 - (let ((obj (make-instance 'change-class-class-01a :a 1 :b 2 :c 5)) - (new-class (find-class 'change-class-class-01b))) - (values - (eqt obj (change-class obj new-class :allow-other-keys t - :nonsense t)) - (typep* obj 'change-class-class-01a) - (typep* obj 'change-class-class-01b) - (slot-exists-p obj 'a) - (map-slot-boundp* obj '(b c d)) - (map-slot-value obj '(b c)))) - t nil t nil (t t nil) (2 5)) - -(deftest change-class.1.10 - (let ((obj (make-instance 'change-class-class-01a :a 1 :b 2 :c 5)) - (new-class (find-class 'change-class-class-01b))) - (values - (eqt obj (change-class obj new-class :bad 0 :allow-other-keys t - :allow-other-keys nil :nonsense t)) - (typep* obj 'change-class-class-01a) - (typep* obj 'change-class-class-01b) - (slot-exists-p obj 'a) - (map-slot-boundp* obj '(b c d)) - (map-slot-value obj '(b c)))) - t nil t nil (t t nil) (2 5)) - -(deftest change-class.1.11 - (handler-case - (eval - '(let ((obj (make-instance 'change-class-class-01a)) - (new-class (find-class 'change-class-class-01b))) - (declare (optimize (safety 3))) - (eqt obj (change-class obj new-class :nonsense t)))) - (error () :expected-error)) - :expected-error) - -;; test of class name as second argument -(deftest change-class.1.12 - (let ((obj (make-instance 'change-class-class-01a :b 1)) - ;; (new-class (find-class 'change-class-class-01b)) - ) - (values - (eqt obj (change-class obj 'change-class-class-01b :c2 3)) - (typep* obj 'change-class-class-01a) - (typep* obj 'change-class-class-01b) - (slot-exists-p obj 'a) - (map-slot-boundp* obj '(b c d)) - (map-slot-value obj '(b c)))) - t nil t nil (t t nil) (1 3)) - - -;;; Shared slots - -(defclass change-class-class-02a () - ((a :initarg :a :allocation :class) - (b :initarg :b :allocation :class))) - -(defclass change-class-class-02b () - ((a :initarg :a2) - (b :initarg :b2))) - -(deftest change-class.2.1 - (let ((obj (make-instance 'change-class-class-02a)) - (new-class (find-class 'change-class-class-02b))) - (slot-makunbound obj 'a) - (slot-makunbound obj 'b) - (values - (map-slot-boundp* obj '(a b)) - (eqt obj (change-class obj new-class)) - (typep* obj 'change-class-class-02a) - (typep* obj 'change-class-class-02b) - (map-slot-boundp* (make-instance 'change-class-class-02a) '(a b)) - (map-slot-boundp* obj '(a b)))) - (nil nil) - t nil t - (nil nil) - (nil nil)) - -(deftest change-class.2.2 - (let ((obj (make-instance 'change-class-class-02a)) - (obj2 (make-instance 'change-class-class-02a)) - obj3 - (new-class (find-class 'change-class-class-02b))) - (setf (slot-value obj 'a) 'foo) - (slot-makunbound obj 'b) - (values - (map-slot-boundp* obj '(a b)) - (slot-value obj 'a) - (slot-value obj2 'a) - (eqt obj (change-class obj new-class)) - (typep* obj 'change-class-class-02a) - (typep* obj 'change-class-class-02b) - (map-slot-boundp* (setf obj3 (make-instance 'change-class-class-02a)) - '(a b)) - (map-slot-boundp* obj '(a b)) - (slot-value obj 'a) - (slot-value obj2 'a) - (slot-value obj3 'a) - (eqt obj obj2) (eqt obj obj3) (eqt obj2 obj3) - )) - (t nil) - foo foo - t nil t - (t nil) - (t nil) - foo foo foo - nil nil nil) - -(deftest change-class.2.3 - (let ((obj (make-instance 'change-class-class-02a)) - (obj2 (make-instance 'change-class-class-02a)) - (new-class (find-class 'change-class-class-02b))) - (setf (slot-value obj 'a) 1 - (slot-value obj 'b) 16) - (values - (map-slot-boundp* obj '(a b)) - (eqt obj (change-class obj new-class)) - (typep* obj 'change-class-class-02a) - (typep* obj 'change-class-class-02b) - (map-slot-boundp* obj2 '(a b)) - (map-slot-boundp* (make-instance 'change-class-class-02a) '(a b)) - (map-slot-boundp* obj '(a b)) - (progn (slot-makunbound obj2 'a) - (slot-makunbound obj2 'b) - (map-slot-boundp* obj '(a b))))) - - (t t) - t nil t - (t t) - (t t) - (t t) - (t t)) - -;;; Destination slots are shared - -(defclass change-class-class-03a () - ((a :initarg :a) (b :initarg :b))) - -(defclass change-class-class-03b () - ((a :allocation :class :initarg :a2) - (b :allocation :class :initarg :b2))) - -(deftest change-class.3.1 - (let* ((obj (make-instance 'change-class-class-03a)) - (new-class (find-class 'change-class-class-03b)) - (obj2 (make-instance new-class)) - obj3) - (slot-makunbound obj2 'a) - (slot-makunbound obj2 'b) - (values - (eqt obj (change-class obj new-class)) - (typep* obj 'change-class-class-03a) - (typep* obj 'change-class-class-03b) - (typep* obj new-class) - (eqt (setq obj3 (make-instance new-class)) obj) - (map-slot-boundp* obj '(a b)) - (map-slot-boundp* obj2 '(a b)) - (map-slot-boundp* obj3 '(a b)) - )) - t nil t t nil (nil nil) (nil nil) (nil nil)) - -(deftest change-class.3.2 - (let* ((obj (make-instance 'change-class-class-03a :a 1)) - (new-class (find-class 'change-class-class-03b)) - (obj2 (make-instance new-class)) - obj3) - (slot-makunbound obj2 'a) - (setf (slot-value obj2 'b) 17) - (values - (map-slot-boundp* obj2 '(a b)) - (eqt obj (change-class obj new-class)) - (typep* obj 'change-class-class-03a) - (typep* obj 'change-class-class-03b) - (typep* obj new-class) - (eqt (setq obj3 (make-instance new-class)) obj) - (map-slot-boundp* obj '(a b)) - (map-slot-boundp* obj2 '(a b)) - (map-slot-boundp* obj3 '(a b)) - (slot-value obj 'b) - (slot-value obj2 'b) - (slot-value obj3 'b) - )) - (nil t) t nil t t nil (nil t) (nil t) (nil t) 17 17 17) - -;;; Destination class has slot initforms - -(defclass change-class-class-04a () - ((a :initarg :a) (b :initarg :b))) - -(defclass change-class-class-04b () - ((a :initform 'x :initarg :a2) - (c :initform 'y :initarg :c2))) - -(deftest change-class.4.1 - (let ((obj (make-instance 'change-class-class-04a)) - (new-class (find-class 'change-class-class-04b))) - (values - (eqt obj (change-class obj new-class)) - (map-slot-boundp* obj '(a c)) - (slot-value obj 'c))) - t - (nil t) - y) - -(deftest change-class.4.2 - (let ((obj (make-instance 'change-class-class-04a)) - (new-class (find-class 'change-class-class-04b))) - (values - (eqt obj (change-class obj new-class :a2 'z)) - (map-slot-value obj '(a c)))) - t - (z y)) - -(deftest change-class.4.3 - (let ((obj (make-instance 'change-class-class-04a :a 'p :b 'q)) - (new-class (find-class 'change-class-class-04b))) - (values - (eqt obj (change-class obj new-class)) - (map-slot-value obj '(a c)))) - t - (p y)) - -(deftest change-class.4.4 - (let ((obj (make-instance 'change-class-class-04a)) - (new-class (find-class 'change-class-class-04b))) - (values - (eqt obj (change-class obj new-class :c2 'k)) - (map-slot-boundp* obj '(a c)) - (slot-value obj 'c))) - t - (nil t) - k) - -(deftest change-class.4.5 - (let* ((class (find-class 'change-class-class-04b)) - (obj (allocate-instance class))) - (values - (map-slot-boundp* obj '(a c)) - (eqt obj (change-class obj class)) - (map-slot-boundp* obj '(a c)))) - (nil nil) - t - (nil nil)) - - -;;; Custom methods for change-class - -(declaim (special *changed-class-on-class-05*)) - -(defclass change-class-class-05 () - (a b c)) - -(report-and-ignore-errors - (defmethod change-class - ((obj change-class-class-05) - (new-class (eql (find-class 'change-class-class-05))) - &rest initargs &key &allow-other-keys) - (declare (ignore initargs new-class)) - (setq *changed-class-on-class-05* t) - obj)) - -(deftest change-class.5 - (let ((*changed-class-on-class-05* nil) - (obj (make-instance 'change-class-class-05))) - (values - (eqt obj (change-class obj (find-class 'change-class-class-05))) - *changed-class-on-class-05*)) - t t) - -;;; Method that invokes the standard method with call-next-method - -(defclass change-class-class-06 () - ((a :initarg :a) (b :initarg :b) (c :initarg :c))) - -(report-and-ignore-errors - (defmethod change-class - ((obj change-class-class-06) - (new-class standard-class) - &rest initargs &key &allow-other-keys) - (declare (ignore initargs)) - (setf (slot-value obj 'a) 123) - (call-next-method))) - -(deftest change-class.6.1 - (let* ((class (find-class 'change-class-class-06)) - (obj (make-instance class))) - (values - (map-slot-boundp* obj '(a b c)) - (eqt obj (change-class obj class)) - (map-slot-boundp* obj '(a b c)) - (slot-value obj 'a) - )) - (nil nil nil) - t - (t nil nil) - 123) - -(deftest change-class.6.2 - (let* ((class (find-class 'change-class-class-06)) - (obj (make-instance class :a 'bad))) - (values - (map-slot-boundp* obj '(a b c)) - (eqt obj (change-class obj class)) - (map-slot-boundp* obj '(a b c)) - (slot-value obj 'a) - )) - (t nil nil) - t - (t nil nil) - 123) - -;;; Before method - -(defclass change-class-class-07 () - ((a :initform 'x :initarg :a) - (b :initform 'y :initarg :b) - (c :initarg :c))) - -(defclass change-class-class-07b () - ((a :initform 'aa :initarg :a) - (d :initform 'dd :initarg :d))) - -(report-and-ignore-errors - (defmethod change-class :before - ((obj change-class-class-07) - (new-class standard-class) - &rest initargs &key &allow-other-keys) - (declare (ignore initargs)) - (setf (slot-value obj 'a) 'z) - obj)) - -(deftest change-class.7.1 - (let* ((class (find-class 'change-class-class-07)) - (obj (allocate-instance class))) - (values - (map-slot-boundp* obj '(a b c)) - (eqt obj (change-class obj class)) - (map-slot-boundp* obj '(a b c)) - (slot-value obj 'a))) - (nil nil nil) - t - (t nil nil) - z) - -(deftest change-class.7.2 - (let* ((class (find-class 'change-class-class-07)) - (obj (allocate-instance class))) - (values - (map-slot-boundp* obj '(a b c)) - (eqt obj (change-class obj class :a 10)) - (map-slot-boundp* obj '(a b c)) - (slot-value obj 'a))) - (nil nil nil) - t - (t nil nil) - 10) - -(deftest change-class.7.3 - (let* ((class (find-class 'change-class-class-07)) - (obj (allocate-instance class))) - (values - (map-slot-boundp* obj '(a b c)) - (eqt obj (change-class obj class :b 10)) - (map-slot-boundp* obj '(a b c)) - (slot-value obj 'a) - (slot-value obj 'b))) - (nil nil nil) - t - (t t nil) - z 10) - -(deftest change-class.7.4 - (let* ((class (find-class 'change-class-class-07)) - (new-class (find-class 'change-class-class-07b)) - (obj (allocate-instance class))) - (values - (eqt obj (change-class obj new-class)) - (map-slot-boundp* obj '(a d)) - (slot-value obj 'a) - (slot-value obj 'd))) - t (t t) z dd) - -(deftest change-class.7.5 - (let* ((class (find-class 'change-class-class-07)) - (new-class (find-class 'change-class-class-07b)) - (obj (allocate-instance class))) - (values - (eqt obj (change-class obj new-class :allow-other-keys nil)) - (map-slot-boundp* obj '(a d)) - (slot-value obj 'a) - (slot-value obj 'd))) - t (t t) z dd) - -(deftest change-class.7.6 - (let* ((class (find-class 'change-class-class-07)) - (new-class (find-class 'change-class-class-07b)) - (obj (allocate-instance class))) - (values - (eqt obj (change-class obj new-class :allow-other-keys t)) - (map-slot-boundp* obj '(a d)) - (slot-value obj 'a) - (slot-value obj 'd))) - t (t t) z dd) - - -;;; After method - -(report-and-ignore-errors - (defclass change-class-class-08 () - ((a :initarg :a) (b :initarg :b)))) - -(report-and-ignore-errors - (defmethod change-class :after - ((obj change-class-class-08) - (class (eql (find-class 'change-class-class-08))) - &rest initargs &key &allow-other-keys) - (declare (ignore initargs)) - (setf (slot-value obj 'a) 'z) - obj)) - -(deftest change-class.8.1 - (let* ((class (find-class 'change-class-class-08)) - (obj (make-instance class))) - (values - (map-slot-boundp* obj '(a b)) - (eqt obj (change-class obj class)) - (map-slot-boundp* obj '(a b)) - (slot-value obj 'a))) - (nil nil) - t - (t nil) - z) - -(deftest change-class.8.2 - (let* ((class (find-class 'change-class-class-08)) - (obj (make-instance class :a 1 :b 2))) - (values - (map-slot-boundp* obj '(a b)) - (eqt obj (change-class obj class)) - (map-slot-boundp* obj '(a b)) - (slot-value obj 'a) - (slot-value obj 'b))) - (t t) - t - (t t) - z 2) - -(deftest change-class.8.3 - (let* ((class (find-class 'change-class-class-08)) - (obj (make-instance class))) - (values - (map-slot-boundp* obj '(a b)) - (eqt obj (change-class obj class :a 12 :b 17)) - (map-slot-boundp* obj '(a b)) - (slot-value obj 'a) - (slot-value obj 'b))) - (nil nil) - t - (t t) - z 17) - -;;; Put around method test here - -;;; Put more inheritance tests here - -;;; Error tests - -(deftest change-class.error.1 - (signals-error (change-class) program-error) - t) - -(deftest change-class.error.2 - (signals-error (change-class (make-instance 'change-class-class-01a)) - program-error) - t) - -(deftest change-class.error.3 - (signals-error - (let ((obj (make-instance 'change-class-class-01a)) - (new-class (find-class 'change-class-class-01b))) - (change-class obj new-class :c2)) - program-error) - t) - -(deftest change-class.error.4 - (signals-error - (let ((obj (make-instance 'change-class-class-01a)) - (new-class (find-class 'change-class-class-01b))) - (change-class obj new-class '(nonsense) 'a)) - program-error) - t) - -;;; According to the page for BUILT-IN-CLASS, using CHANGE-CLASS -;;; to change the class to/from a builtin class should raise a -;;; signal of type ERROR. - -(deftest change-class.error.5 - (let ((built-in-class (find-class 'built-in-class))) - (loop for e in *mini-universe* - for class = (class-of e) - when (and (eq (class-of class) built-in-class) - (handler-case - (progn - (change-class (make-instance 'change-class-class-01a) - class) - t) - (error () nil))) - collect e)) - nil) - -(deftest change-class.error.6 - (let ((built-in-class (find-class 'built-in-class))) - (loop for e in *mini-universe* - for class = (class-of e) - when (and (eq (class-of class) built-in-class) - (handler-case - (progn - (change-class e (find-class 'change-class-class-01a)) - t) - (error () nil))) - collect e)) - nil) diff --git a/t/ansi-test/objects/class-name.lsp b/t/ansi-test/objects/class-name.lsp deleted file mode 100644 index fb4854f..0000000 --- a/t/ansi-test/objects/class-name.lsp +++ /dev/null @@ -1,52 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jun 15 12:05:47 2003 -;;;; Contains: Tests of CLASS-NAME - - - -;;; This is mostly tested elsewhere. - -(deftest class-name.1 - (class-name (find-class 'symbol)) - symbol) - -(defclass class-name-class-01 () (a b c)) - -(report-and-ignore-errors - (eval '(defmethod class-name ((x class-name-class-01)) 'silly))) - -(deftest class-name.2 - (class-name (make-instance 'class-name-class-01)) - silly) - -;; Tests of (setf class-name) - -(deftest setf-class-name.1 - (typep* #'(setf class-name) 'standard-generic-function) - t) - -(deftest setf-class-name.2 - (let ((sym (gensym)) - (newsym (gensym))) - (eval `(defclass ,sym () (a b c))) - (let ((class (find-class sym))) - (values - (eqlt (class-name class) sym) - (equalt - (multiple-value-list (setf (class-name (find-class sym)) newsym)) - (list newsym)) - (eqlt newsym (class-name class))))) - t t t) - - -;;; Error tests - -(deftest class-name.error.1 - (signals-error (class-name) program-error) - t) - -(deftest class-name.error.2 - (signals-error (class-name (find-class 'symbol) nil) - program-error) - t) diff --git a/t/ansi-test/objects/class-of.lsp b/t/ansi-test/objects/class-of.lsp deleted file mode 100644 index f585ef6..0000000 --- a/t/ansi-test/objects/class-of.lsp +++ /dev/null @@ -1,16 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Jun 16 19:40:32 2003 -;;;; Contains: Tests of CLASS-OF - - - -;;; Most tests of CLASS-OF are in other files - -(deftest class-of.error.1 - (signals-error (class-of) program-error) - t) - -(deftest class-of.error.2 - (signals-error (class-of nil nil) program-error) - t) diff --git a/t/ansi-test/objects/compute-applicable-methods.lsp b/t/ansi-test/objects/compute-applicable-methods.lsp deleted file mode 100644 index 3400dfc..0000000 --- a/t/ansi-test/objects/compute-applicable-methods.lsp +++ /dev/null @@ -1,122 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Jun 2 06:40:41 2003 -;;;; Contains: Tests for COMPUTE-APPLICABLE-METHODS - - - -(defgeneric cam-gf-01 (x y)) - -(defparameter *cam-gf-01-method1* - (defmethod cam-gf-01 ((x integer) (y integer)) 1)) - -(defparameter *cam-gf-01-method2* - (defmethod cam-gf-01 ((x integer) (y t)) 2)) - -(defparameter *cam-gf-01-method3* - (defmethod cam-gf-01 ((x t) (y integer)) 3)) - -(defparameter *cam-gf-01-method4* - (defmethod cam-gf-01 ((x t) (y t)) 4)) - -(deftest compute-applicable-methods.1 - (let ((methods (compute-applicable-methods #'cam-gf-01 (list 1 2)))) - (equalt methods - (list *cam-gf-01-method1* *cam-gf-01-method2* - *cam-gf-01-method3* *cam-gf-01-method4*))) - t) - -(deftest compute-applicable-methods.2 - (let ((methods (compute-applicable-methods #'cam-gf-01 (list 1 'x)))) - (equalt methods - (list *cam-gf-01-method2* *cam-gf-01-method4*))) - t) - -(deftest compute-applicable-methods.3 - (let ((methods (compute-applicable-methods #'cam-gf-01 (list 'x 10)))) - (equalt methods - (list *cam-gf-01-method3* *cam-gf-01-method4*))) - t) - -(deftest compute-applicable-methods.4 - (let ((methods (compute-applicable-methods #'cam-gf-01 (list 'x 'y)))) - (equalt methods (list *cam-gf-01-method4*))) - t) - -(defgeneric cam-gf-02 (x)) - -(deftest compute-applicable-methods.5 - (compute-applicable-methods #'cam-gf-02 '(1)) - nil) - -(eval-when (:load-toplevel :compile-toplevel :execute) - (report-and-ignore-errors - (defgeneric cam-gf-03 (x) - (:method-combination + :most-specific-first)) - - (defparameter *cam-gf-03-method1* - (defmethod cam-gf-03 + ((x integer)) 1)) - - (defparameter *cam-gf-03-method2* - (defmethod cam-gf-03 + ((x rational)) 2)) - - (defparameter *cam-gf-03-method3* - (defmethod cam-gf-03 + ((x real)) 4)) - - (defparameter *cam-gf-03-method4* - (defmethod cam-gf-03 + ((x number)) 8)) - - (defparameter *cam-gf-03-method5* - (defmethod cam-gf-03 + ((x t)) 16)))) - -(deftest compute-applicable-methods.6 - (equalt (compute-applicable-methods #'cam-gf-03 (list 0)) - (list *cam-gf-03-method1* *cam-gf-03-method2* *cam-gf-03-method3* - *cam-gf-03-method4* *cam-gf-03-method5*)) - t) - -(eval-when (:load-toplevel :compile-toplevel :execute) - (report-and-ignore-errors - (defgeneric cam-gf-04 (x) - (:method-combination + :most-specific-last)) - - (defparameter *cam-gf-04-method1* - (defmethod cam-gf-04 + ((x integer)) 1)) - - (defparameter *cam-gf-04-method2* - (defmethod cam-gf-04 + ((x rational)) 2)) - - (defparameter *cam-gf-04-method3* - (defmethod cam-gf-04 + ((x real)) 4)) - - (defparameter *cam-gf-04-method4* - (defmethod cam-gf-04 + ((x number)) 8)) - - (defparameter *cam-gf-04-method5* - (defmethod cam-gf-04 + ((x t)) 16)) - )) - -(deftest compute-applicable-methods.7 - (equalt (compute-applicable-methods #'cam-gf-04 (list 0)) - (list *cam-gf-04-method1* *cam-gf-04-method2* *cam-gf-04-method3* - *cam-gf-04-method4* *cam-gf-04-method5*)) - t) - -;;; Need tests with :around, :before, :after methods - -;;; Error tests - -(deftest compute-applicable-methods.error.1 - (signals-error (compute-applicable-methods) - program-error) - t) - -(deftest compute-applicable-methods.error.2 - (signals-error (compute-applicable-methods #'cam-gf-01) - program-error) - t) - -(deftest compute-applicable-methods.error.3 - (signals-error (compute-applicable-methods #'cam-gf-01 '(1 2) nil) - program-error) - t) diff --git a/t/ansi-test/objects/defclass-01.lsp b/t/ansi-test/objects/defclass-01.lsp deleted file mode 100644 index 76ba329..0000000 --- a/t/ansi-test/objects/defclass-01.lsp +++ /dev/null @@ -1,893 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Apr 20 20:58:54 2003 -;;;; Contains: Tests for DEFCLASS, part 01 - -;;; I've decided to write some 'manual' tests, then refactor these back -;;; to the automatic mechanisms I'll put into defclass-aux.lsp after -;;; I have a better understanding of the object system - -(defclass class-01 () (s1 s2 s3)) - -(deftest class-01.1 - (notnot-mv (typep (make-instance 'class-01) 'class-01)) - t) - -(deftest class-01.2 - (notnot-mv (typep (make-instance (find-class 'class-01)) 'class-01)) - t) - -(deftest class-01.3 - (let ((c (make-instance 'class-01))) - (values - (setf (slot-value c 's1) 12) - (setf (slot-value c 's2) 18) - (setf (slot-value c 's3) 27) - (loop for s in '(s1 s2 s3) collect (slot-value c s)))) - 12 18 27 - (12 18 27)) - -;;;; - -(defclass class-02 () ((s1) (s2) (s3))) - -(deftest class-02.1 - (notnot-mv (typep (make-instance 'class-02) 'class-02)) - t) - -(deftest class-02.2 - (notnot-mv (typep (make-instance (find-class 'class-02)) 'class-02)) - t) - -(deftest class-02.3 - (let ((c (make-instance 'class-02))) - (values - (setf (slot-value c 's1) 12) - (setf (slot-value c 's2) 18) - (setf (slot-value c 's3) 27) - (loop for s in '(s1 s2 s3) collect (slot-value c s)))) - 12 18 27 - (12 18 27)) - -;;;; - -(defclass class-03 () ((s1 :type integer) (s2 :type t) (s3 :type fixnum))) - -(deftest class-03.1 - (notnot-mv (typep (make-instance 'class-03) 'class-03)) - t) - -(deftest class-03.2 - (notnot-mv (typep (make-instance (find-class 'class-03)) 'class-03)) - t) - -(deftest class-03.3 - (let ((c (make-instance 'class-03))) - (values - (setf (slot-value c 's1) 12) - (setf (slot-value c 's2) 'a) - (setf (slot-value c 's3) 27) - (loop for s in '(s1 s2 s3) collect (slot-value c s)))) - 12 a 27 - (12 a 27)) - -;;;; - -(defclass class-04 () - ((s1 :reader s1-r) (s2 :writer s2-w) (s3 :accessor s3-a))) - -;;; Readers, writers, and accessors -(deftest class-04.1 - (let ((c (make-instance 'class-04))) - (values - (setf (slot-value c 's1) 'a) - (setf (slot-value c 's2) 'b) - (setf (slot-value c 's3) 'c) - (s1-r c) - (slot-value c 's2) - (s2-w 'd c) - (slot-value c 's2) - (s3-a c) - (setf (s3-a c) 'e) - (slot-value c 's3) - (s3-a c))) - a b c a b d d c e e e) - -(deftest class-04.2 - (notnot-mv (typep #'s1-r 'generic-function)) - t) - -(deftest class-04.3 - (notnot-mv (typep #'s2-w 'generic-function)) - t) - -(deftest class-04.4 - (notnot-mv (typep #'s3-a 'generic-function)) - t) - -(deftest class-04.5 - (notnot-mv (typep #'(setf s3-a) 'generic-function)) - t) - -;;;; - -(defclass class-05 () (s1 (s2 :allocation :instance) (s3 :allocation :class))) - -(deftest class-05.1 - (let ((c1 (make-instance 'class-05)) - (c2 (make-instance 'class-05))) - (values - (not (eql c1 c2)) - (list - (setf (slot-value c1 's1) 12) - (setf (slot-value c2 's1) 17) - (slot-value c1 's1) - (slot-value c2 's1)) - (list - (setf (slot-value c1 's2) 'a) - (setf (slot-value c2 's2) 'b) - (slot-value c1 's2) - (slot-value c2 's2)) - (list - (setf (slot-value c1 's3) 'x) - (slot-value c1 's3) - (slot-value c2 's3) - (setf (slot-value c2 's3) 'y) - (slot-value c1 's3) - (slot-value c2 's3) - (setf (slot-value c1 's3) 'z) - (slot-value c1 's3) - (slot-value c2 's3)) - (slot-value (make-instance 'class-05) 's3))) - t - (12 17 12 17) - (a b a b) - (x x x y y y z z z) - z) - -;;;; - -(defclass class-06 () ((s1 :reader s1-r1 :reader s1-r2 :writer s1-w1 :writer s1-w2))) -(defclass class-06a () ((s1 :reader s1-r1) s3)) - -(deftest class-06.1 - (let ((c (make-instance 'class-06))) - (values - (setf (slot-value c 's1) 'x) - (slot-value c 's1) - (s1-r1 c) - (s1-r2 c) - (s1-w1 'y c) - (slot-value c 's1) - (s1-r1 c) - (s1-r2 c) - (s1-w2 'z c) - (slot-value c 's1) - (s1-r1 c) - (s1-r2 c))) - x x x x y y y y z z z z) - -(deftest class-06.2 - (let ((c1 (make-instance 'class-06)) - (c2 (make-instance 'class-06a))) - (values - (setf (slot-value c1 's1) 'x) - (setf (slot-value c2 's1) 'y) - (mapcar #'s1-r1 (list c1 c2)))) - x y (x y)) - -;;;; - -(defclass class-07 () ((s1 :initarg :s1a :initarg :s1b :reader s1) - (s2 :initarg :s2 :reader s2))) - -(deftest class-07.1 - (let ((c (make-instance 'class-07))) - (values - (slot-boundp c 's1) - (slot-boundp c 's2))) - nil nil) - -(deftest class-07.2 - (let ((c (make-instance 'class-07 :s1a 'x))) - (values - (notnot (slot-boundp c 's1)) - (s1 c) - (slot-boundp c 's2))) - t x nil) - -(deftest class-07.3 - (let ((c (make-instance 'class-07 :s1b 'x))) - (values - (notnot (slot-boundp c 's1)) - (s1 c) - (slot-boundp c 's2))) - t x nil) - -(deftest class-07.4 - (let ((c (make-instance 'class-07 :s1a 'y :s1b 'x))) - (values - (notnot (slot-boundp c 's1)) - (s1 c) - (slot-boundp c 's2))) - t y nil) - - -(deftest class-07.5 - (let ((c (make-instance 'class-07 :s1b 'y :s1a 'x))) - (values - (notnot (slot-boundp c 's1)) - (s1 c) - (slot-boundp c 's2))) - t y nil) - -(deftest class-07.6 - (let ((c (make-instance 'class-07 :s1a 'y :s1a 'x))) - (values - (notnot (slot-boundp c 's1)) - (s1 c) - (slot-boundp c 's2))) - t y nil) - -(deftest class-07.7 - (let ((c (make-instance 'class-07 :s2 'a :s1a 'b))) - (values - (notnot (slot-boundp c 's1)) - (notnot (slot-boundp c 's2)) - (s1 c) - (s2 c))) - t t b a) - -(deftest class-07.8 - (let ((c (make-instance 'class-07 :s2 'a :s1a 'b :s2 'x :s1a 'y :s1b 'z))) - (values - (notnot (slot-boundp c 's1)) - (notnot (slot-boundp c 's2)) - (s1 c) - (s2 c))) - t t b a) - -(deftest class-07.9 - (let ((c (make-instance 'class-07 :s1b 'x :s1a 'y))) - (values - (notnot (slot-boundp c 's1)) - (slot-boundp c 's2) - (s1 c))) - t nil x) - -(deftest class-07.10 - (let ((c (make-instance 'class-07 :s1a 'x :s2 'y :allow-other-keys nil))) - (values (s1 c) (s2 c))) - x y) - -(deftest class-07.11 - (let ((c (make-instance 'class-07 :s1a 'a :s2 'b :garbage 'z - :allow-other-keys t))) - (values (s1 c) (s2 c))) - a b) - -(deftest class-07.12 - (let ((c (make-instance 'class-07 :s1a 'd :s2 'c :garbage 'z - :allow-other-keys t - :allow-other-keys nil))) - (values (s1 c) (s2 c))) - d c) - - -;;;; - -(declaim (special *class-08-s2-initvar*)) - -(defclass class-08 () - ((s1 :initform 0) (s2 :initform *class-08-s2-initvar*))) - -(deftest class-08.1 - (let* ((*class-08-s2-initvar* 'x) - (c (make-instance 'class-08))) - (values - (slot-value c 's1) - (slot-value c 's2))) - 0 x) - -;;;; - -(declaim (special *class-09-s2-initvar*)) - -(defclass class-09 () - ((s1 :initform 0 :initarg :s1) - (s2 :initform *class-09-s2-initvar* :initarg :s2))) - -(deftest class-09.1 - (let* ((*class-09-s2-initvar* 'x) - (c (make-instance 'class-09))) - (values - (slot-value c 's1) - (slot-value c 's2))) - 0 x) - -(deftest class-09.2 - (let* ((*class-09-s2-initvar* 'x) - (c (make-instance 'class-09 :s1 1))) - (values - (slot-value c 's1) - (slot-value c 's2))) - 1 x) - -(deftest class-09.3 - (let* ((c (make-instance 'class-09 :s2 'a))) - (values - (slot-value c 's1) - (slot-value c 's2))) - 0 a) - -(deftest class-09.4 - (let* ((c (make-instance 'class-09 :s2 'a :s1 10 :s1 'bad :s2 'bad))) - (values - (slot-value c 's1) - (slot-value c 's2))) - 10 a) - -;;;; - -(declaim (special *class-10-s1-initvar*)) - -(defclass class-10 () - ((s1 :initform (incf *class-10-s1-initvar*) :initarg :s1))) - -(deftest class-10.1 - (let* ((*class-10-s1-initvar* 0) - (c (make-instance 'class-10))) - (values - *class-10-s1-initvar* - (slot-value c 's1))) - 1 1) - -(deftest class-10.2 - (let* ((*class-10-s1-initvar* 0) - (c (make-instance 'class-10 :s1 10))) - (values - *class-10-s1-initvar* - (slot-value c 's1))) - 0 10) - -;;;; - -(let ((x 7)) - (defclass class-11 () - ((s1 :initform x :initarg :s1)))) - -(deftest class-11.1 - (slot-value (make-instance 'class-11) 's1) - 7) - -(deftest class-11.2 - (slot-value (make-instance 'class-11 :s1 100) 's1) - 100) - -;;; - -(flet ((%f () 'x)) - (defclass class-12 () - ((s1 :initform (%f) :initarg :s1)))) - -(deftest class-12.1 - (slot-value (make-instance 'class-12) 's1) - x) - -(deftest class-12.2 - (slot-value (make-instance 'class-12 :s1 'y) 's1) - y) - -;;; - -(defclass class-13 () - ((s1 :allocation :class :initarg :s1))) - -(deftest class-13.1 - (let ((c1 (make-instance 'class-13)) - (c2 (make-instance 'class-13 :s1 'foo))) - (values - (slot-value c1 's1) - (slot-value c2 's1))) - foo foo) - -;;; - -(defclass class-14 () - ((s1 :initarg nil :reader s1))) - -(deftest class-14.1 - (let ((c (make-instance 'class-14 nil 'x))) - (s1 c)) - x) - -;;; - -(defclass class-15 () - ((s1 :initarg :allow-other-keys :reader s1))) - -;;; Dicussion on comp.lang.lisp convinced me this test was bogus. -;;; The default value of :allow-other-keys specified in 7.1.2 is not -;;; the same as the default value forms, specified by :default-initargs, -;;; that are used to produce the defaulted initialization argument list. - -;;; (deftest class-15.1 -;;; (let ((c (make-instance 'class-15))) -;;; (s1 c)) -;;; nil) - -(deftest class-15.2 - (let ((c (make-instance 'class-15 :allow-other-keys nil))) - (s1 c)) - nil) - -(deftest class-15.3 - (let ((c (make-instance 'class-15 :allow-other-keys t))) - (s1 c)) - t) - -(deftest class-15.4 - (let ((c (make-instance 'class-15 :allow-other-keys t - :allow-other-keys nil))) - (s1 c)) - t) - -(deftest class-15.5 - (let ((c (make-instance 'class-15 :allow-other-keys nil - :allow-other-keys t))) - (s1 c)) - nil) - -(deftest class-15.6 - (let ((c (make-instance 'class-15 :allow-other-keys t - :foo 'bar))) - (s1 c)) - t) - -(deftest class-15.7 - (let ((c (make-instance 'class-15 :allow-other-keys t - :allow-other-keys nil - :foo 'bar))) - (s1 c)) - t) - -;;; Tests of :default-initargs - -(defclass class-16 () - ((s1 :initarg :s1)) - (:default-initargs :s1 'x)) - -(deftest class-16.1 - (let ((c (make-instance 'class-16))) - (slot-value c 's1)) - x) - -(deftest class-16.2 - (let ((c (make-instance 'class-16 :s1 'y))) - (slot-value c 's1)) - y) - -(deftest class-16.3 - (let ((c (make-instance 'class-16 :s1 nil))) - (slot-value c 's1)) - nil) - -;;; - -(defclass class-17 () - ((s1 :initarg :s1 :initform 'foo)) - (:default-initargs :s1 'bar)) - -(deftest class-17.1 - (let ((c (make-instance 'class-17))) - (slot-value c 's1)) - bar) - -(deftest class-17.2 - (let ((c (make-instance 'class-17 :s1 'z))) - (slot-value c 's1)) - z) - -(deftest class-17.3 - (let ((c (make-instance 'class-17 :s1 nil))) - (slot-value c 's1)) - nil) - -;;; - -(defclass class-18 () - ((s1 :initarg :s1 :initarg :s1b)) - (:default-initargs :s1 'x :s1b 'y)) - -(deftest class-18.1 - (let ((c (make-instance 'class-18))) - (slot-value c 's1)) - x) - -(deftest class-18.2 - (let ((c (make-instance 'class-18 :s1 'z))) - (slot-value c 's1)) - z) - -(deftest class-18.3 - (let ((c (make-instance 'class-18 :s1 nil))) - (slot-value c 's1)) - nil) - -(deftest class-18.4 - (let ((c (make-instance 'class-18 :s1b 'z))) - (slot-value c 's1)) - z) - -(deftest class-18.5 - (let ((c (make-instance 'class-18 :s1b nil))) - (slot-value c 's1)) - nil) - -;;; - -(declaim (special *class-19-s1-initvar*)) - -(defclass class-19 () - ((s1 :initarg :s1)) - (:default-initargs :s1 (setf *class-19-s1-initvar* 'a))) - -(deftest class-19.1 - (let* ((*class-19-s1-initvar* nil) - (c (make-instance 'class-19))) - (declare (special *class-19-s1-initvar*)) - (values - (slot-value c 's1) - *class-19-s1-initvar*)) - a a) - -(deftest class-19.2 - (let* ((*class-19-s1-initvar* nil) - (c (make-instance 'class-19 :s1 nil))) - (declare (special *class-19-s1-initvar*)) - (values - (slot-value c 's1) - *class-19-s1-initvar*)) - nil nil) - -(deftest class-19.3 - (let* ((*class-19-s1-initvar* nil) - (c (make-instance 'class-19 :s1 'x))) - (declare (special *class-19-s1-initvar*)) - (values - (slot-value c 's1) - *class-19-s1-initvar*)) - x nil) - -;;; - -(declaim (special *class-20-s1-initvar-1* *class-20-s1-initvar-2*)) - -(defclass class-20 () - ((s1 :initarg :s1 :initarg :s1b)) - (:default-initargs :s1 (setf *class-20-s1-initvar-1* 'a) - :s1b (setf *class-20-s1-initvar-2* 'b))) - -(deftest class-20.1 - (let* (*class-20-s1-initvar-1* - *class-20-s1-initvar-2* - (c (make-instance 'class-20))) - (declare (special *class-20-s1-initvar-1* - *class-20-s1-initvar-2*)) - (values - (slot-value c 's1) - *class-20-s1-initvar-1* - *class-20-s1-initvar-2*)) - a a b) - -(deftest class-20.2 - (let* (*class-20-s1-initvar-1* - *class-20-s1-initvar-2* - (c (make-instance 'class-20 :s1 'x))) - (declare (special *class-20-s1-initvar-1* - *class-20-s1-initvar-2*)) - (values - (slot-value c 's1) - *class-20-s1-initvar-1* - *class-20-s1-initvar-2*)) - x nil b) - -(deftest class-20.3 - (let* (*class-20-s1-initvar-1* - *class-20-s1-initvar-2* - (c (make-instance 'class-20 :s1b 'y))) - (declare (special *class-20-s1-initvar-1* - *class-20-s1-initvar-2*)) - (values - (slot-value c 's1) - *class-20-s1-initvar-1* - *class-20-s1-initvar-2*)) - y a nil) - -;;; - -(declaim (special *class-21-s1-initvar-1* *class-21-s1-initvar-2*)) - -(let ((*class-21-s1-initvar-1* 0) - (*class-21-s1-initvar-2* 0)) - (defclass class-21 () - ((s1 :initarg :s1 :initarg :s1b) - (s2 :initarg :s1b :initarg :s2)) - (:default-initargs :s1 (incf *class-21-s1-initvar-1*) - :s1b (incf *class-21-s1-initvar-2*)))) - -(deftest class-21.1 - (let* ((*class-21-s1-initvar-1* 10) - (*class-21-s1-initvar-2* 20) - (c (make-instance 'class-21))) - (declare (special *class-21-s1-initvar-1* - *class-21-s1-initvar-2*)) - (values - (slot-value c 's1) - (slot-value c 's2) - *class-21-s1-initvar-1* - *class-21-s1-initvar-2*)) - 11 21 11 21) - -(deftest class-21.2 - (let* ((*class-21-s1-initvar-1* 10) - (*class-21-s1-initvar-2* 20) - (c (make-instance 'class-21 :s1 'x))) - (declare (special *class-21-s1-initvar-1* - *class-21-s1-initvar-2*)) - (values - (slot-value c 's1) - (slot-value c 's2) - *class-21-s1-initvar-1* - *class-21-s1-initvar-2*)) - x 21 10 21) - -(deftest class-21.3 - (let* ((*class-21-s1-initvar-1* 10) - (*class-21-s1-initvar-2* 20) - (c (make-instance 'class-21 :s1 'x :s1b 'y))) - (declare (special *class-21-s1-initvar-1* - *class-21-s1-initvar-2*)) - (values - (slot-value c 's1) - (slot-value c 's2) - *class-21-s1-initvar-1* - *class-21-s1-initvar-2*)) - x y 10 20) - -(deftest class-21.4 - (let* ((*class-21-s1-initvar-1* 10) - (*class-21-s1-initvar-2* 20) - (c (make-instance 'class-21 :s1b 'y))) - (declare (special *class-21-s1-initvar-1* - *class-21-s1-initvar-2*)) - (values - (slot-value c 's1) - (slot-value c 's2) - *class-21-s1-initvar-1* - *class-21-s1-initvar-2*)) - y y 11 20) - -(deftest class-21.5 - (let* ((*class-21-s1-initvar-1* 10) - (*class-21-s1-initvar-2* 20) - (c (make-instance 'class-21 :s2 'y))) - (declare (special *class-21-s1-initvar-1* - *class-21-s1-initvar-2*)) - (values - (slot-value c 's1) - (slot-value c 's2) - *class-21-s1-initvar-1* - *class-21-s1-initvar-2*)) - 11 y 11 21) - -;;; Documentation strings - -(defclass class-22 () - ((s1 :documentation "This is slot s1 in class class-22"))) - -(deftest class-22.1 - (notnot-mv (typep (make-instance 'class-22) 'class-22)) - t) - -;;; We can't portably get at the docstring of slots - -;;; - -(defclass class-23 () - (s1 s2 s3) - (:documentation "This is class-23 in ansi-tests")) - -(deftest class-23.1 - (notnot-mv (typep (make-instance 'class-23) 'class-23)) - t) - -(deftest class-23.2 - (let ((doc (documentation 'class-23 'type))) - (or (null doc) - (equalt doc "This is class-23 in ansi-tests"))) - t) - -(deftest class-23.3 - (let ((doc (documentation (find-class 'class-23) 'type))) - (or (null doc) - (equalt doc "This is class-23 in ansi-tests"))) - t) - -(deftest class-23.4 - (let ((doc (documentation (find-class 'class-23) t))) - (or (null doc) - (equalt doc "This is class-23 in ansi-tests"))) - t) - -;;; - -(defclass class-24 () - ((s1 :initarg :allow-other-keys :reader s1)) - (:default-initargs :allow-other-keys t)) - -(deftest class-24.1 - (s1 (make-instance 'class-24)) - t) - -(deftest class-24.2 - (s1 (make-instance 'class-24 :nonsense t)) - t) - -(deftest class-24.3 - (s1 (make-instance 'class-24 :allow-other-keys nil)) - nil) - -(deftest class-24.4 - (s1 (make-instance 'class-24 :allow-other-keys 'a :foo t)) - a) - -;;; - -(defclass class-25 () - ((s1 :initarg :allow-other-keys :reader s1)) - (:default-initargs :allow-other-keys nil)) - -(deftest class-25.1 - (s1 (make-instance 'class-25)) - nil) - -(deftest class-25.2 - (s1 (make-instance 'class-25 :allow-other-keys t)) - t) - -(deftest class-25.3 - (s1 (make-instance 'class-25 :allow-other-keys t :foo nil)) - t) - -(deftest class-25.4 - (s1 (make-instance 'class-25 :allow-other-keys t :allow-other-keys nil)) - t) - -(deftest class-25.5 - (s1 (make-instance 'class-25 :allow-other-keys t :allow-other-keys nil - :foo t)) - t) - -(deftest class-25.6 - (s1 (make-instance 'class-25 :allow-other-keys 'foo :allow-other-keys 'bar)) - foo) - -;;; - -(defclass class-26 () - ((s1-26 :writer (setf s1-26)))) - -(deftest class-26.1 - (let ((c (make-instance 'class-26))) - (values - (slot-boundp c 's1-26) - (setf (s1-26 c) 'x) - (slot-value c 's1-26) - (typep* #'(setf s1-26) 'generic-function))) - nil x x t) - -;;; - -(defclass class-27 () - (a (b :initform 10) (c :initarg :c) (d :initarg :d)) - (:metaclass standard-class) - (:default-initargs :d 17)) - -(deftest class-27.1 - (let ((class (find-class 'class-27))) - (values - (subtypep* 'class-27 'standard-object) - (subtypep* 'class-27 t) - (subtypep* 'class-27 (find-class 'standard-object)) - (subtypep* 'class-27 (find-class t)) - (subtypep* class 'standard-object) - (subtypep* class t) - (subtypep* class (find-class 'standard-object)) - (subtypep* class (find-class t)))) - t t t t t t t t) - -(deftest class-27.2 - (let ((c (make-instance 'class-27))) - (values - (slot-boundp* c 'a) - (slot-value c 'b) - (slot-boundp* c 'c) - (slot-value c 'd))) - nil 10 nil 17) - -(deftest class-27.3 - (let ((c (make-instance 'class-27 :c 26 :d 43))) - (values - (slot-boundp* c 'a) - (slot-value c 'b) - (slot-value c 'c) - (slot-value c 'd))) - nil 10 26 43) - -;;; - -(declaim (special *class-28-reset-fn* - *class-28-query-fn*)) - -(declaim (type function *class-28-reset-fn* *class-28-query-fn*)) - -(let ((x 0) (y 0)) - (flet ((%reset (a b) (setf x a y b)) - (%query () (list x y))) - (setf *class-28-reset-fn* #'%reset - *class-28-query-fn* #'%query) - (defclass class-28 () - ((s1 :initform (incf x) :initarg :s1) - (s2 :initarg :s2)) - (:default-initargs :s2 (incf y))))) - -(deftest class-28.1 - (let ((class (find-class 'class-28))) - (funcall *class-28-reset-fn* 5 10) - (list - (funcall *class-28-query-fn*) - (let ((obj (make-instance 'class-28))) - (list - (typep* obj 'class-28) - (typep* obj class) - (eqt (class-of obj) class) - (map-slot-value obj '(s1 s2)) - (funcall *class-28-query-fn*))))) - ((5 10) - (t t t (6 11) (6 11)))) - -(deftest class-28.2 - (let ((class (find-class 'class-28))) - (funcall *class-28-reset-fn* 5 10) - (list - (funcall *class-28-query-fn*) - (let ((obj (make-instance 'class-28 :s1 17))) - (list - (typep* obj 'class-28) - (typep* obj class) - (eqt (class-of obj) class) - (map-slot-value obj '(s1 s2)) - (funcall *class-28-query-fn*))))) - ((5 10) - (t t t (17 11) (5 11)))) - - -(deftest class-28.3 - (let ((class (find-class 'class-28))) - (funcall *class-28-reset-fn* 5 10) - (list - (funcall *class-28-query-fn*) - (let ((obj (make-instance 'class-28 :s2 17))) - (list - (typep* obj 'class-28) - (typep* obj class) - (eqt (class-of obj) class) - (map-slot-value obj '(s1 s2)) - (funcall *class-28-query-fn*))))) - ((5 10) - (t t t (6 17) (6 10)))) - - - - diff --git a/t/ansi-test/objects/defclass-02.lsp b/t/ansi-test/objects/defclass-02.lsp deleted file mode 100644 index 9f3c2ff..0000000 --- a/t/ansi-test/objects/defclass-02.lsp +++ /dev/null @@ -1,715 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Apr 25 07:16:57 2003 -;;;; Contains: Tests of DEFCLASS with simple inheritance - - - -;;; - -(defclass class-0201 () - ((a :initform 'x) (b :allocation :instance) (c :reader class-0201-c))) - -(defclass class-0202 (class-0201) - (d (e :initform 'y) (f :allocation :instance))) - -(deftest class-0201.1 - (let ((c (make-instance 'class-0201))) - (values (map-slot-boundp* c '(a b c)) - (map-slot-exists-p* c '(a b c)) - (slot-value c 'a) - (map-typep* c (list 'class-0201 'class-0202 - (find-class 'class-0201) - (find-class 'class-0202))) - (class-name (class-of c)) - )) - (t nil nil) - (t t t) - x - (t nil t nil) - class-0201) - -(deftest class-0202.1 - (let ((c (make-instance 'class-0202))) - (values (map-slot-boundp* c '(a b c d e f)) - (map-slot-value c '(a e)) - (map-typep* c (list 'class-0201 'class-0202 - (find-class 'class-0201) - (find-class 'class-0202))) - (class-name (class-of c)) - )) - (t nil nil nil t nil) - (x y) - (t t t t) - class-0202) - -;;; - - -(defclass class-0203 () - ((a :allocation :class) (b :allocation :instance))) - -(defclass class-0204 (class-0203) - (c d)) - -(deftest class-0203.1 - (let ((c1 (make-instance 'class-0203)) - (c2 (make-instance 'class-0204))) - (values - (map-slot-boundp* c1 '(a b)) - (map-slot-boundp* c2 '(a b c d)) - (setf (slot-value c1 'a) 'x) - (map-slot-boundp* c1 '(a b)) - (map-slot-boundp* c2 '(a b c d)) - (slot-value c1 'a) - (slot-value c2 'a) - (eqt (slot-makunbound c1 'a) c1) - (map-slot-boundp* c1 '(a b)) - (map-slot-boundp* c2 '(a b c d)))) - (nil nil) - (nil nil nil nil) - x - (t nil) - (t nil nil nil) - x x - t - (nil nil) - (nil nil nil nil)) - - -(deftest class-0203.2 - (let ((c1 (make-instance 'class-0203)) - (c2 (make-instance 'class-0204))) - (values - (map-slot-boundp* c1 '(a b)) - (map-slot-boundp* c2 '(a b c d)) - (setf (slot-value c1 'a) 'x) - (map-slot-boundp* c1 '(a b)) - (map-slot-boundp* c2 '(a b c d)) - (slot-value c1 'a) - (slot-value c2 'a) - (eqt (slot-makunbound c2 'a) c2) - (map-slot-boundp* c1 '(a b)) - (map-slot-boundp* c2 '(a b c d)))) - (nil nil) - (nil nil nil nil) - x - (t nil) - (t nil nil nil) - x x - t - (nil nil) - (nil nil nil nil)) - -;;; - -(defclass class-0205a () - ((a :initform 'x) - (b :initform 'y) - c)) - -(defclass class-0205b (class-0205a) - ((a :initform 'z) - b - (c :initform 'w))) - -(deftest class-0205a.1 - (let ((c (make-instance 'class-0205a))) - (values - (slot-value c 'a) - (slot-value c 'b) - (slot-boundp c 'c))) - x y nil) - -(deftest class-0205b.1 - (let ((c (make-instance 'class-0205b))) - (map-slot-value c '(a b c))) - (z y w)) - -;;; - -(defclass class-0206a () - ((a :allocation :instance) - (b :allocation :class))) - -(defclass class-0206b (class-0206a) - ((a :allocation :class) - (b :allocation :instance))) - -(deftest class-0206.1 - (let ((c1 (make-instance 'class-0206a)) - (c2 (make-instance 'class-0206b))) - (values - (map-slot-boundp* c1 '(a b)) - (map-slot-boundp* c2 '(a b)) - (setf (slot-value c1 'a) 'x) - (setf (slot-value c1 'b) 'y) - (map-slot-boundp* c1 '(a b)) - (map-slot-boundp* c2 '(a b)) - (map-slot-value c1 '(a b)) - (progn (slot-makunbound c1 'a) - (slot-makunbound c1 'b) - (setf (slot-value c2 'a) 'x)) - (setf (slot-value c2 'b) 'y) - (map-slot-boundp* c1 '(a b)) - (map-slot-boundp* c2 '(a b)) - (map-slot-value c2 '(a b)) - (progn (slot-makunbound c2 'a) - (slot-makunbound c2 'b) - nil))) - (nil nil) (nil nil) - x y - (t t) (nil nil) - (x y) - x y - (nil nil) (t t) - (x y) - nil) - -;;; - -;;; Show shadowing of slots by :allocation - -(defclass class-0207a () - ((a :allocation :class))) - -(defclass class-0207b (class-0207a) - ((a :allocation :instance))) - -(defclass class-0207c (class-0207b) - ((a :allocation :class))) - -(deftest class-0207.1 - (let ((c1 (make-instance 'class-0207a)) - (c2 (make-instance 'class-0207b)) - (c3 (make-instance 'class-0207c))) - (slot-makunbound c1 'a) - (slot-makunbound c2 'a) - (slot-makunbound c3 'a) - (values - (setf (slot-value c1 'a) 'x) - (slot-boundp* c1 'a) - (slot-boundp* c2 'a) - (slot-boundp* c3 'a) - (slot-value c1 'a) - (setf (slot-value c2 'a) 'y) - (slot-boundp* c1 'a) - (slot-boundp* c2 'a) - (slot-boundp* c3 'a) - (slot-value c1 'a) - (slot-value c2 'a) - (setf (slot-value c3 'a) 'z) - (slot-boundp* c1 'a) - (slot-boundp* c2 'a) - (slot-boundp* c3 'a) - (slot-value c1 'a) - (slot-value c2 'a) - (slot-value c3 'a))) - x - t nil nil - x - y - t t nil - x y - z - t t t - x y z) - -;;; - -;;; Initforms are inherited even if :allocation changes - -(defclass class-0208a () - ((a :allocation :class :initform 'x))) - -(defclass class-0208b (class-0208a) - ((a :allocation :instance))) - -(deftest class-0208.1 - (values - (slot-value (make-instance 'class-0208a) 'a) - (slot-value (make-instance 'class-0208b) 'a)) - x x) - -;;; - -;;; That was failing when things were reloaded. -;;; Try a test that redefines it - -(deftest class-redefinition.1 - (let* - ((cobj1 (eval '(defclass class-0209a () - ((a :allocation :class :initform 'x))))) - (cobj2 (eval '(defclass class-0209b (class-0209a) - ((a :allocation :instance))))) - (cobj3 (eval '(defclass class-0209a () - ((a :allocation :class :initform 'x))))) - (cobj4 (eval '(defclass class-0209b (class-0209a) - ((a :allocation :instance)))))) - (values - (eqt cobj1 cobj3) - (eqt cobj2 cobj4) - (class-name cobj1) - (class-name cobj2) - (slot-value (make-instance 'class-0209a) 'a) - (slot-value (make-instance 'class-0209b) 'a))) - t t - class-0209a - class-0209b - x x) - -(deftest class-redefinition.2 - (let* - ( - (cobj1 (eval '(defclass class-0210a () - ((a :allocation :class))))) - (cobj2 (eval '(defclass class-0210b (class-0210a) - ((a :allocation :instance))))) - (cobj3 (eval '(defclass class-0210c (class-0210b) - ((a :allocation :class))))) - (dummy (progn - (setf (slot-value (make-instance 'class-0210a) 'a) :bad1) - (make-instance 'class-0210b) - (make-instance 'class-0210c) - nil)) - (cobj4 (eval '(defclass class-0210a () - ((a :allocation :class))))) - (cobj5 (eval '(defclass class-0210b (class-0210a) - ((a :allocation :instance))))) - (cobj6 (eval '(defclass class-0210c (class-0210b) - ((a :allocation :class)))))) - (list - (eqt cobj1 cobj4) - (eqt cobj2 cobj5) - (eqt cobj3 cobj6) - (class-name cobj1) - (class-name cobj2) - (class-name cobj3) - (let ((c1 (make-instance 'class-0210a)) - (c2 (make-instance 'class-0210b)) - (c3 (make-instance 'class-0210c))) - (slot-makunbound c1 'a) - (slot-makunbound c2 'a) - (slot-makunbound c3 'a) - (list - (setf (slot-value c1 'a) 'x) - (and (slot-boundp* c1 'a) (slot-value c1 'a)) - (slot-boundp* c2 'a) - (slot-boundp* c3 'a) - (setf (slot-value c2 'a) 'y) - (and (slot-boundp* c1 'a) (slot-value c1 'a)) - (and (slot-boundp* c2 'a) (slot-value c2 'a)) - (slot-boundp* c3 'a) - (setf (slot-value c3 'a) 'z) - (and (slot-boundp* c1 'a) (slot-value c1 'a)) - (and (slot-boundp* c2 'a) (slot-value c2 'a)) - (and (slot-boundp* c3 'a) (slot-value c3 'a)))))) - (t t t - class-0210a - class-0210b - class-0210c - (x - x nil nil - y - x y nil - z - x y z))) - -;;; Same as class-redefinition.1, but reverse the order in which -;;; the classes are redefined. -(deftest class-redefinition.3 - (let* - ((cobj1 (eval '(defclass class-redef-03a () - ((a :allocation :class :initform 'x))))) - (cobj2 (eval '(defclass class-redef-03b (class-redef-03a) - ((a :allocation :instance))))) - (cobj4 (eval '(defclass class-redef-03b (class-redef-03a) - ((a :allocation :instance))))) - (cobj3 (eval '(defclass class-redef-03a () - ((a :allocation :class :initform 'x)))))) - (values - (eqt cobj1 cobj3) - (eqt cobj2 cobj4) - (class-name cobj1) - (class-name cobj2) - (slot-value (make-instance 'class-redef-03a) 'a) - (slot-value (make-instance 'class-redef-03b) 'a))) - t t - class-redef-03a - class-redef-03b - x x) - -;;; Initforms are inherited even if :allocation changes - -(defclass class-0211a () - ((a :allocation :instance :initform 'x))) - -(defclass class-0211b (class-0211a) - ((a :allocation :class))) - -(deftest class-0211.1 - (values - (slot-value (make-instance 'class-0211a) 'a) - (slot-value (make-instance 'class-0211b) 'a)) - x x) - -;;; - -;;; Inheritance of :initargs - -(defclass class-0212a () - ((a :initarg :a1))) - -(defclass class-0212b (class-0212a) - ((a :initarg :a2) - (b :initarg :b))) - -(deftest class-0212.1 - (let ((c (make-instance 'class-0212a :a1 'x))) - (values - (typep* c 'class-0212a) - (typep* c 'class-0212b) - (slot-value c 'a) - (slot-exists-p c 'b))) - t nil x nil) - -(deftest class-0212.2 - (let ((c (make-instance 'class-0212b :a1 'x))) - (values - (typep* c 'class-0212a) - (typep* c 'class-0212b) - (slot-value c 'a) - (slot-boundp* c 'b))) - t t x nil) - -(deftest class-0212.3 - (let ((c (make-instance 'class-0212b :a2 'x :b 'y))) - (values - (typep* c 'class-0212a) - (typep* c 'class-0212b) - (slot-value c 'a) - (slot-value c 'b))) - t t x y) - -(deftest class-0212.4 - (let ((c (make-instance 'class-0212b :a1 'z :a2 'x :b 'y))) - (values - (typep* c 'class-0212a) - (typep* c 'class-0212b) - (slot-value c 'a) - (slot-value c 'b))) - t t z y) - -(deftest class-0212.5 - (let ((c (make-instance 'class-0212b :a2 'x :b 'y :a1 'z))) - (values - (typep* c 'class-0212a) - (typep* c 'class-0212b) - (slot-value c 'a) - (slot-value c 'b))) - t t x y) - -;;; - -(defclass class-0213a () - ((a :initarg :a1))) - -(defclass class-0213b (class-0213a) - (b)) - -(deftest class-0213.1 - (let ((c (make-instance 'class-0213a :a1 'x))) - (values - (typep* c 'class-0213a) - (typep* c 'class-0213b) - (slot-value c 'a) - (slot-exists-p c 'b))) - t nil x nil) - -(deftest class-0213.2 - (let ((c (make-instance 'class-0213b :a1 'x))) - (values - (typep* c 'class-0213a) - (typep* c 'class-0213b) - (slot-value c 'a) - (slot-boundp* c 'b))) - t t x nil) - -;;; - -(defclass class-0214a () - ((a :initarg :a1 :allocation :class))) - -(defclass class-0214b (class-0214a) - (b)) - -(deftest class-0214.1 - (let ((c (make-instance 'class-0214a :a1 'x))) - (values - (typep* c 'class-0214a) - (typep* c 'class-0214b) - (slot-value c 'a) - (slot-exists-p c 'b))) - t nil x nil) - -(deftest class-0214.2 - (let ((c (make-instance 'class-0214b :a1 'y))) - (values - (typep* c 'class-0214a) - (typep* c 'class-0214b) - (slot-value c 'a) - (slot-boundp* c 'b))) - t t y nil) - -;;; - -(defclass class-0215a () - ((a :initarg :a1 :allocation :instance))) - -(defclass class-0215b (class-0215a) - ((a :allocation :class))) - -(deftest class-0215.1 - (let ((c (make-instance 'class-0215a :a1 'x))) - (values - (typep* c 'class-0215a) - (typep* c 'class-0215b) - (slot-value c 'a))) - t nil x) - -(deftest class-0215.2 - (let ((c (make-instance 'class-0215b :a1 'y))) - (values - (typep* c 'class-0215a) - (typep* c 'class-0215b) - (slot-value c 'a))) - t t y) - - -;;; Tests of defaulted initargs - -(defclass class-0216a () - ((a :initarg :a1) - (b :initarg :b1))) - -(defclass class-0216b (class-0216a) - () - (:default-initargs :a1 'x)) - -(deftest class-0216.1 - (let ((c (make-instance 'class-0216a))) - (values - (typep* c 'class-0216a) - (typep* c 'class-0216b) - (slot-boundp c 'a) - (slot-boundp c 'b))) - t nil nil nil) - -(deftest class-0216.2 - (let ((c (make-instance 'class-0216b))) - (values - (typep* c 'class-0216a) - (typep* c 'class-0216b) - (slot-value c 'a) - (slot-boundp c 'b))) - t t x nil) - -;;; - -(defclass class-0217a () - ((a :initarg :a1) - (b :initarg :b1) - (c :initarg :c1) - (d :initarg :d1)) - (:default-initargs :a1 10 :b1 20)) - -(defclass class-0217b (class-0217a) - () - (:default-initargs :a1 30 :c1 40)) - -(deftest class-0217.1 - (let ((c (make-instance 'class-0217a))) - (values - (map-slot-boundp* c '(a b c d)) - (map-slot-value c '(a b)))) - (t t nil nil) - (10 20)) - -(deftest class-0217.2 - (let ((c (make-instance 'class-0217a :a1 'x :c1 'y))) - (values - (map-slot-boundp* c '(a b c d)) - (map-slot-value c '(a b c)))) - (t t t nil) - (x 20 y)) - -(deftest class-0217.3 - (let ((c (make-instance 'class-0217b))) - (values - (map-slot-boundp* c '(a b c d)) - (map-slot-value c '(a b c)))) - (t t t nil) - (30 20 40)) - -(deftest class-0217.4 - (let ((c (make-instance 'class-0217b :a1 'x :d1 'y))) - (values - (map-slot-boundp* c '(a b c d)) - (map-slot-value c '(a b c d)))) - (t t t t) - (x 20 40 y)) - -;;; - -(defclass class-0218a () - ((a :initarg :a1)) - (:default-initargs :a1 'x)) - -(defclass class-0218b (class-0218a) - ((a :initform 'y))) - -(deftest class-0218.1 - (let ((c (make-instance 'class-0218a))) - (slot-value c 'a)) - x) - -(deftest class-0218.2 - (let ((c (make-instance 'class-0218b))) - (slot-value c 'a)) - x) - -;;; - -(declaim (special *class-0219-a-1* *class-0219-a-2*)) - -(defclass class-0219a () - ((a :initarg :a1)) - (:default-initargs :a1 (setf *class-0219-a-1* 'x))) - -(defclass class-0219b () - ((a :initarg :a1)) - (:default-initargs :a1 (setf *class-0219-a-2* 'y))) - -(deftest class-0219.1 - (let ((*class-0219-a-1* nil)) - (values - (slot-value (make-instance 'class-0219a) 'a) - *class-0219-a-1*)) - x x) - -(deftest class-0219.2 - (let ((*class-0219-a-1* nil) - (*class-0219-a-2* nil)) - (values - (slot-value (make-instance 'class-0219b) 'a) - *class-0219-a-1* - *class-0219-a-2*)) - y nil y) - -;;; - -(defclass class-0220a () - ((a :type (integer 0 10) :initarg :a))) - -(defclass class-0220b (class-0220a) - ((a :type (integer -5 5)))) - -(deftest class-0220.1 - (slot-value (make-instance 'class-0220a :a 10) 'a) - 10) - -(deftest class-0220.2 - (slot-value (make-instance 'class-0220a :a 0) 'a) - 0) - -(deftest class-0220.3 - (slot-value (make-instance 'class-0220b :a 0) 'a) - 0) - -(deftest class-0220.4 - (slot-value (make-instance 'class-0220b :a 5) 'a) - 5) - -;;; - -(defclass class-0221a () - (a b c) - (:documentation "This is class class-0221a")) - -(defclass class-0221b (class-0221a) - ()) - -(defclass class-0221c (class-0221a) - () - (:documentation "This is class class-0221c")) - -(deftest class-0221.1 - (let* ((cl (find-class 'class-0221a)) - (doc (documentation cl t))) - (or (null doc) - (equalt doc "This is class class-0221a"))) - t) - -(deftest class-0221.2 - (let* ((cl (find-class 'class-0221b)) - (doc (documentation cl t))) - doc) - nil) - -(deftest class-0221.3 - (let* ((cl (find-class 'class-0221c)) - (doc (documentation cl t))) - (or (null doc) - (equalt doc "This is class class-0221c"))) - t) - -;;; - -(defclass class-0222a () - ((s1 :reader s1-r :writer s1-w :accessor s1-acc))) - -(defclass class-0222b (class-0222a) - ()) - -(deftest class-0222.1 - (let ((c (make-instance 'class-0222a))) - (values - (s1-w 'x c) - (s1-r c) - (s1-acc c) - (setf (s1-acc c) 'y) - (s1-r c))) - x x x y y) - -(deftest class-0222.2 - (let ((c (make-instance 'class-0222b))) - (values - (s1-w 'x c) - (s1-r c) - (s1-acc c) - (setf (s1-acc c) 'y) - (s1-r c))) - x x x y y) - -;;; - -(defclass class-0223a () - ((s1 :reader s-r :writer s-w :accessor s-acc))) - -(defclass class-0223b (class-0223a) - ((s2 :reader s-r :writer s-w :accessor s-acc))) - -(deftest class-0223.1 - (let ((c (make-instance 'class-0223b))) - (values - (setf (slot-value c 's1) 'x) - (setf (slot-value c 's2) 'y) - (s-r c) - (s-acc c) - (s-w 'z c) - (slot-value c 's1) - (slot-value c 's2) - (s-r c) - (s-acc c))) - x y y y z x z z z) - diff --git a/t/ansi-test/objects/defclass-03.lsp b/t/ansi-test/objects/defclass-03.lsp deleted file mode 100644 index da4c319..0000000 --- a/t/ansi-test/objects/defclass-03.lsp +++ /dev/null @@ -1,254 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Apr 27 16:23:59 2003 -;;;; Contains: Tests of DEFCLASS with more involved inheritance - - - -;;; - -(defclass class-0301a () - (a b)) - -(defclass class-0301b () - (a c)) - -(defclass class-0301c (class-0301a class-0301b) - (d)) - -(deftest class-0301.1 - (let ((c (make-instance 'class-0301c))) - (values - (typep* c 'class-0301a) - (typep* c 'class-0301b) - (typep* c 'class-0301c) - (typep* c (find-class 'class-0301a)) - (typep* c (find-class 'class-0301b)) - (typep* c (find-class 'class-0301c)) - (map-slot-boundp* c '(a b c d)) - (setf (slot-value c 'a) 'w) - (setf (slot-value c 'b) 'x) - (setf (slot-value c 'c) 'y) - (setf (slot-value c 'd) 'z) - (map-slot-boundp* c '(a b c d)) - (map-slot-value c '(a b c d)))) - t t t - t t t - (nil nil nil nil) - w x y z - (t t t t) - (w x y z)) - -;;; - -(defclass class-0302a () - ((a :initform 'x) b (c :initform 'w))) - -(defclass class-0302b () - ((a :initform 'y) (b :initform 'z))) - -(defclass class-0302c (class-0302a class-0302b) - (a b (c :initform 'v) d)) - -(deftest class-0302.1 - (let ((c (make-instance 'class-0302c))) - (values - (map-slot-boundp* c '(a b c d)) - (map-slot-value c '(a b c)))) - (t t t nil) - (x z v)) - -;;; - -(defclass class-0303a () - ((a :allocation :class) b)) - -(defclass class-0303b () - (a (b :allocation :class))) - -(defclass class-0303c (class-0303a class-0303b) ()) - -(deftest class-0303.1 - (let ((c1 (make-instance 'class-0303a)) - (c2 (make-instance 'class-0303b)) - (c3 (make-instance 'class-0303c))) - (slot-makunbound c1 'a) - (slot-makunbound c2 'b) - (values - (loop for c in (list c1 c2 c3) - collect (map-slot-boundp* c '(a b))) - (list (setf (slot-value c1 'a) 'x1) - (slot-boundp* c2 'a) - (slot-value c3 'a)) - (list (setf (slot-value c2 'a) 'x2) - (slot-value c1 'a) - (slot-value c2 'a) - (slot-value c3 'a)) - (list (setf (slot-value c3 'a) 'x3) - (slot-value c1 'a) - (slot-value c2 'a) - (slot-value c3 'a)) - ;;; - (list (setf (slot-value c1 'b) 'y1) - (slot-value c1 'b) - (slot-boundp* c2 'b) - (slot-boundp* c3 'b)) - (list (setf (slot-value c2 'b) 'y2) - (slot-value c1 'b) - (slot-value c2 'b) - (slot-boundp c3 'b)) - (list (setf (slot-value c3 'b) 'y3) - (slot-value c1 'b) - (slot-value c2 'b) - (slot-value c3 'b)))) - ((nil nil) (nil nil) (nil nil)) - (x1 nil x1) - (x2 x1 x2 x1) - (x3 x3 x2 x3) - ;; - (y1 y1 nil nil) - (y2 y1 y2 nil) - (y3 y1 y2 y3)) - -;;; - -(defclass class-0304a () - ((a :initform 'x))) - -(defclass class-0304b (class-0304a) ()) - -(defclass class-0304c (class-0304a) - ((a :initform 'y))) - -(defclass class-0304d (class-0304b class-0304c) - ()) - -(deftest class-0304.1 - (slot-value (make-instance 'class-0304d) 'a) - y) - -;;; - -(defclass class-0305a () - ((a :initarg :a)) - (:default-initargs :a 'x)) - -(defclass class-0305b (class-0305a) ()) - -(defclass class-0305c (class-0305a) - () - (:default-initargs :a 'y)) - -(defclass class-0305d (class-0305b class-0305c) - ()) - -(deftest class-0305.1 - (slot-value (make-instance 'class-0305d) 'a) - y) - - -;;; A test showing nonmonotonicity in the CLOS CPL algorithm - -(defclass class-0306a () ((a :initform nil :reader a-slot))) -(defclass class-0306b (class-0306a) ((a :initform 'x))) -(defclass class-0306c (class-0306a) ((a :initform 'y))) -(defclass class-0306d (class-0306b) ()) -(defclass class-0306e (class-0306b) ()) -(defclass class-0306f (class-0306d class-0306c) ()) -(defclass class-0306g (class-0306e) ()) -(defclass class-0306h (class-0306f class-0306g) ()) - -;;; Class class-0306c should precede class-0306b in the -;;; CPL for class-0306h, even though it follows it in the CPLs -;;; for the direct superclasses of class-0306h. - -(deftest class-0306.1 - (loop for obj in - (mapcar #'make-instance - '(class-0306a class-0306b class-0306c class-0306d - class-0306e class-0306f class-0306g class-0306h)) - collect (slot-value obj 'a)) - (nil x y x x x x y)) - -(deftest class-0306.2 - (loop for obj in - (mapcar #'make-instance - '(class-0306a class-0306b class-0306c class-0306d - class-0306e class-0306f class-0306g class-0306h)) - collect (a-slot obj)) - (nil x y x x x x y)) - -;;; A class redefinition test that came up in cmucl - -(deftest class-0307.1 - (progn - (setf (find-class 'class-0307a) nil - (find-class 'class-0307b) nil) - (eval '(defclass class-0307a () ())) - (eval '(defclass class-0307b (class-0307a) (a))) - (eval '(defclass class-0307a () ((a :initform nil)))) - (eval '(defclass class-0307b (class-0307a) ((a :initform 'x)))) - (slot-value (make-instance 'class-0307b) 'a)) - x) - -(deftest class-0308.1 - (progn - (setf (find-class 'class-0308a) nil - (find-class 'class-0308b) nil) - (eval '(defclass class-0308a () ())) - (eval '(defclass class-0308b (class-0308a) (a))) - (eval '(defclass class-0308a () ((a :initarg :a)))) - (eval '(defclass class-0308b (class-0308a) ())) - (slot-value (make-instance 'class-0308b :a 'x) 'a)) - x) - -;;; More class redefinition tests - -(deftest class-0309.1 - (progn - (setf (find-class 'class-0309) nil) - (let* ((class1 (eval '(defclass class-0309 () ((a) (b) (c))))) - (obj1 (make-instance 'class-0309))) - (setf (class-name class1) nil) - (let ((class2 (eval '(defclass class-0309 () ((a) (b) (c)))))) - (values - (eqt (class-of obj1) class1) - (eqt class1 class2) - (typep* obj1 class1) - (typep* obj1 class2))))) - t nil t nil) - -(deftest class-0310.1 - (progn - (setf (find-class 'class-0310a) nil - (find-class 'class-0310b) nil) - (let* ((class1 (eval '(defclass class-0310a () ((a) (b) (c))))) - (obj1 (make-instance 'class-0310a))) - (setf (class-name class1) 'class-0310b) - (let ((class2 (eval '(defclass class-0310a () ((a) (b) (c)))))) - (values - (eqt (class-of obj1) class1) - (eqt class1 class2) - (typep* obj1 class1) - (typep* obj1 class2) - (class-name class1) - (class-name class2))))) - t nil t nil class-0310b class-0310a) - -(deftest class-0311.1 - (progn - (setf (find-class 'class-0311) nil) - (let* ((class1 (eval '(defclass class-0311 () ((a) (b) (c))))) - (obj1 (make-instance 'class-0311))) - (setf (find-class 'class-0311) nil) - (let ((class2 (eval '(defclass class-0311 () ((a) (b) (c)))))) - (values - (eqt (class-of obj1) class1) - (eqt class1 class2) - (typep* obj1 class1) - (typep* obj1 class2) - (class-name class1) - (class-name class2) - (eqt (find-class 'class-0311) class1) - (eqt (find-class 'class-0311) class2))))) - t nil t nil class-0311 class-0311 nil t) diff --git a/t/ansi-test/objects/defclass-errors.lsp b/t/ansi-test/objects/defclass-errors.lsp deleted file mode 100644 index 209a20e..0000000 --- a/t/ansi-test/objects/defclass-errors.lsp +++ /dev/null @@ -1,191 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Apr 25 06:59:22 2003 -;;;; Contains: Error case tests for DEFCLASS - - - -;;; I created some redundant tests by accident. This list of -;;; tests could be reduced in size. - -(deftest defclass.error.1 - (signals-error - (defclass erroneous-class.1 () - (a b c d b e)) - program-error) - t) - -(deftest defclass.error.2 - (signals-error - (defclass erroneous-class.2 () - ((s1 :initarg :foo)) - (:default-initargs :foo 1 :foo 2)) - program-error) - t) - -(deftest defclass.error.3 - (signals-error - (defclass erroneous-class.3 () - ((s1 :initform 0 :initform 2))) - program-error) - t) - -(deftest defclass.error.4 - (signals-error - (defclass erroneous-class.4 () - ((s1 :initform 0 :initform 0))) - program-error) - t) - -(deftest defclass.error.5 - (signals-error - (defclass erroneous-class.5 () - ((s1 :type fixnum :type character))) - program-error) - t) - -(deftest defclass.error.6 - (signals-error - (defclass erroneous-class.6 () - ((s1 :type t :type t))) - program-error) - t) - -(deftest defclass.error.7 - (signals-error - (defclass erroneous-class.7 () - ((s1 :documentation "foo" :documentation "bar"))) - program-error) - t) - -(deftest defclass.error.8 - (signals-error - (defclass erroneous-class.8 () - ((s1 :documentation #1="foo" :documentation #1#))) - program-error) - t) - -(deftest defclass.error.9 - (signals-error - (defclass erroneous-class.9 () - ((s1 :allocation :class :allocation :instance))) - program-error) - t) - -(deftest defclass.error.10 - (signals-error - (defclass erroneous-class.10 () - ((s1 :allocation :class :allocation :class))) - program-error) - t) - -(deftest defclass.error.11 - (signals-error - (defclass erroneous-class.11 () - ((s1 :allocation :instance :allocation :instance))) - program-error) - t) - -(deftest defclass.error.12 - (signals-error - (defclass erroneous-class.12 () - ((s1 #.(gensym) nil))) - program-error) - t) - -(deftest defclass.error.13 - (signals-error - (defclass erroneous-class.13 () - (a b c) - (#.(gensym))) - program-error) - t) - -(deftest defclass.error.14 - (signals-error - (defclass defclass-error-14 nil - (foo foo)) - program-error) - t) - -(deftest defclass.error.15 - (signals-error - (defclass defclass-error-15 nil - (foo (foo))) - program-error) - t) - -(deftest defclass.error.16 - (signals-error - (defclass defclass-error-16 nil - ((foo :initarg f1)) - (:default-initargs :f1 10 :f1 20)) - program-error) - t) - -(deftest defclass.error.17 - (signals-error - (defclass defclass-error-17 nil - ((foo :initform 10 :initform 20 :reader defclass-error-4/foo))) - program-error) - t) - -(deftest defclass.error.18 - (signals-error - (defclass defclass-error-18 nil - ((foo :initform 10 :initform 10 :reader defclass-error-5/foo))) - program-error) - t) - -(deftest defclass.error.19 - (signals-error - (defclass defclass-error-19 nil - ((foo :initarg f1 :type t :type t :reader defclass-error-6/foo))) - program-error) - t) - -(deftest defclass.error.20 - (signals-error - (defclass defclass-error-20 nil - ((foo :initarg f1 :documentation "x" :reader defclass-error-7/foo - :documentation "x"))) - program-error) - t) - -(deftest defclass.error.21 - (signals-error - (defclass defclass-error-21 () - ((foo #:unknown-slot-option nil))) - program-error) - t) - -(deftest defclass.error.22 - (let ((option (gentemp "UNKNOWN-OPTION" (symbol-package :foo)))) - (eval - `(signals-error - (defclass defclass-error-22 () - (foo bar) - (,option nil)) - program-error))) - t) - -(deftest defclass.error.23 - (loop for cl in *built-in-classes* - for name = (class-name cl) - unless (or (not name) - (handler-case - (progn (eval `(defclass ,(gensym) (,name))) nil) - (error (c) c))) - collect (list cl name)) - nil) - -(deftest defclass.error.24 - (loop for cl in *built-in-classes* - for name = (class-name cl) - unless (or (not name) - (handler-case - (progn (eval `(defclass ,name ())) nil) - (error (c) c))) - collect (list cl name)) - nil) - diff --git a/t/ansi-test/objects/defclass-forward-reference.lsp b/t/ansi-test/objects/defclass-forward-reference.lsp deleted file mode 100644 index 20af04a..0000000 --- a/t/ansi-test/objects/defclass-forward-reference.lsp +++ /dev/null @@ -1,127 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Apr 2 22:53:27 2003 -;;;; Contains: Tests for definitions of classes with forward references - - - -(deftest defclass.forward-ref.1 - (let ((c1 (gensym)) - (c2 (gensym))) - (let ((class1 (eval `(defclass ,c1 (,c2) nil)))) - (if (not (typep class1 'class)) - 1 - (let ((class2 (eval `(defclass ,c2 nil nil)))) - (if (not (typep class2 'class)) - 2 - (let ((i1 (make-instance c1)) - (i2 (make-instance c2))) - (cond - ((not (typep i1 c1)) 3) - ((not (typep i1 class1)) 4) - ((not (typep i1 c2)) 5) - ((not (typep i1 class2)) 6) - ((typep i2 c1) 7) - ((typep i2 class1) 8) - ((not (typep i2 c2)) 9) - ((not (typep i2 class2)) 10) - (t 'good)))))))) - good) - -(deftest defclass.forward-ref.2 - (let ((c1 (gensym)) - (c2 (gensym)) - (c3 (gensym))) - (let ((class1 (eval `(defclass ,c1 (,c2 ,c3) nil)))) - (if (not (typep class1 'class)) - 1 - (let ((class2 (eval `(defclass ,c2 nil nil)))) - (if (not (typep class2 'class)) - 2 - (let ((class3 (eval `(defclass ,c3 nil nil)))) - (if (not (typep class3 'class)) - 3 - (let ((i1 (make-instance c1)) - (i2 (make-instance c2)) - (i3 (make-instance c3))) - (cond - ((not (typep i1 c1)) 4) - ((not (typep i1 class1)) 5) - ((not (typep i1 c2)) 6) - ((not (typep i1 class2)) 7) - ((not (typep i1 c3)) 8) - ((not (typep i1 class3)) 9) - ((typep i2 c1) 10) - ((typep i2 class1) 11) - ((typep i3 c1) 12) - ((typep i3 class1) 13) - ((not (typep i2 c2)) 14) - ((not (typep i2 class2)) 15) - ((not (typep i3 c3)) 16) - ((not (typep i3 class3)) 17) - ((typep i2 c3) 18) - ((typep i2 class3) 19) - ((typep i3 c2) 20) - ((typep i3 class2) 21) - (t 'good)))))))))) - good) - -(deftest defclass.forward-ref.3 - (let ((c1 (gensym)) - (c2 (gensym)) - (c3 (gensym))) - (let ((class1 (eval `(defclass ,c1 (,c2) nil)))) - (if (not (typep class1 'class)) - 1 - (let ((class2 (eval `(defclass ,c2 (,c3) nil)))) - (if (not (typep class2 'class)) - 2 - (let ((class3 (eval `(defclass ,c3 nil nil)))) - (if (not (typep class3 'class)) - 3 - (let ((i1 (make-instance c1)) - (i2 (make-instance c2)) - (i3 (make-instance c3))) - (cond - ((not (typep i1 c1)) 4) - ((not (typep i1 class1)) 5) - ((not (typep i1 c2)) 6) - ((not (typep i1 class2)) 7) - ((not (typep i1 c3)) 8) - ((not (typep i1 class3)) 9) - ((typep i2 c1) 10) - ((typep i2 class1) 11) - ((typep i3 c1) 12) - ((typep i3 class1) 13) - ((not (typep i2 c2)) 14) - ((not (typep i2 class2)) 15) - ((not (typep i3 c3)) 16) - ((not (typep i3 class3)) 17) - ((not (typep i2 c3)) 18) - ((not (typep i2 class3)) 19) - ((typep i3 c2) 20) - ((typep i3 class2) 21) - (t 'good)))))))))) - good) - -(deftest defclass.forward-ref.4 - (block nil - (let ((c1 (gensym)) - (c2 (gensym)) - (c3 (gensym)) - (c4 (gensym)) - (c5 (gensym))) - (unless (typep (eval `(defclass ,c4 nil nil)) 'class) - (return 1)) - (unless (typep (eval `(defclass ,c5 nil nil)) 'class) - (return 2)) - (unless (typep (eval `(defclass ,c1 (,c2 ,c3) nil)) 'class) - (return 3)) - (unless (typep (eval `(defclass ,c2 (,c4 ,c5) nil)) 'class) - (return 4)) - (handler-case - (eval `(progn - (defclass ,c3 (,c5 ,c4) nil) - (make-instance ',c1))) - (error () :good)))) - :good) diff --git a/t/ansi-test/objects/defclass.lsp b/t/ansi-test/objects/defclass.lsp deleted file mode 100644 index 594e66e..0000000 --- a/t/ansi-test/objects/defclass.lsp +++ /dev/null @@ -1,18 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Mar 24 03:39:54 2003 -;;;; Contains: Tests of DEFCLASS - - - -(defclass-with-tests defclass-1 nil nil) -(defclass-with-tests defclass-2 nil (slot1 slot2 slot3)) - -(defclass-with-tests defclass-3 (defclass-1) nil) -(defclass-with-tests defclass-4 (defclass-1 defclass-2) (slot1 slot4)) - -;;; At end, generate slot tests - -(generate-slot-tests) ;; a macro - - diff --git a/t/ansi-test/objects/defgeneric-method-combination-and.lsp b/t/ansi-test/objects/defgeneric-method-combination-and.lsp deleted file mode 100644 index 8b21d7a..0000000 --- a/t/ansi-test/objects/defgeneric-method-combination-and.lsp +++ /dev/null @@ -1,199 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat May 24 21:31:55 2003 -;;;; Contains: Tests of DEFGENERIC with :method-combination AND - - - -(declaim (special *x*)) - -(compile-and-load "defgeneric-method-combination-aux.lsp") - -(deftest defgeneric-method-combination.and.1 - (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.and.1 (x) - (:method-combination and) - (:method and ((x integer)) (push 4 *x*) t) - (:method and ((x rational)) (push 3 *x*) nil) - (:method and ((x number)) (push 2 *x*) t) - (:method and ((x t)) (push 1 *x*) 'a))))) - (declare (type generic-function fn)) - (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) - (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) - (nil (3 4)) - (nil (3)) - (a (1 2)) - (a (1))) - -(deftest defgeneric-method-combination.and.2 - (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.and.2 (x) - (:method-combination and :most-specific-first) - (:method and ((x integer)) (push 4 *x*) t) - (:method and ((x rational)) (push 3 *x*) nil) - (:method and ((x number)) (push 2 *x*) t) - (:method and ((x t)) (push 1 *x*) 'a))))) - (declare (type generic-function fn)) - (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) - (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) - (nil (3 4)) - (nil (3)) - (a (1 2)) - (a (1))) - -(deftest defgeneric-method-combination.and.3 - (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.and.3 (x) - (:method-combination and :most-specific-last) - (:method and ((x integer)) (push 4 *x*) t) - (:method and ((x rational)) (push 3 *x*) nil) - (:method and ((x number)) (push 2 *x*) 'a) - (:method and ((x t)) (push 1 *x*) t))))) - (declare (type generic-function fn)) - (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) - (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) - (nil (3 2 1)) - (nil (3 2 1)) - (a (2 1)) - (t (1))) - -(deftest defgeneric-method-combination.and.4 - (let ((fn - (eval '(defgeneric dg-mc.and.4 (x) - (:method-combination and) - (:method and ((x integer)) t) - (:method :around ((x rational)) 'foo) - (:method and ((x number)) nil) - (:method and ((x symbol)) t) - (:method and ((x t)) 'a))))) - (declare (type generic-function fn)) - (values - (funcall fn 0) - (funcall fn 4/3) - (funcall fn 1.54) - (funcall fn 'x) - (funcall fn '(a b c)))) - foo foo nil a a) - -(deftest defgeneric-method-combination.and.5 - (let ((fn - (eval '(defgeneric dg-mc.and.5 (x) - (:method-combination and) - (:method and ((x integer)) nil) - (:method :around ((x rational)) - (list 'foo (call-next-method))) - (:method and ((x number)) 'a) - (:method and ((x symbol)) 'b) - (:method and ((x t)) 'c))))) - (declare (type generic-function fn)) - (values - (funcall fn 0) - (funcall fn 4/3) - (funcall fn 1.54) - (funcall fn 'x) - (funcall fn '(a b c)))) - (foo nil) (foo c) c c c) - -(deftest defgeneric-method-combination.and.6 - (let ((fn - (eval '(defgeneric dg-mc.and.6 (x) - (:method-combination and) - (:method and ((x integer)) 'a) - (:method :around ((x rational)) - (list 'foo (call-next-method))) - (:method :around ((x real)) - (list 'bar (call-next-method))) - (:method and ((x number)) nil) - (:method and ((x symbol)) 'c) - (:method and ((x t)) 'd))))) - (declare (type generic-function fn)) - (values - (funcall fn 0) - (funcall fn 4/3) - (funcall fn 1.54) - (funcall fn #c(1.0 2.0)) - (funcall fn 'x) - (funcall fn '(a b c)))) - (foo (bar nil)) (foo (bar nil)) (bar nil) nil d d) - -(deftest defgeneric-method-combination.and.7 - (let ((fn - (eval '(defgeneric dg-mc.and.7 (x) - (:method-combination and) - (:method and ((x dgmc-class-04)) 'c) - (:method and ((x dgmc-class-03)) 'b) - (:method and ((x dgmc-class-02)) nil) - (:method and ((x dgmc-class-01)) 'a))))) - (declare (type generic-function fn)) - (values - (funcall fn (make-instance 'dgmc-class-01)) - (funcall fn (make-instance 'dgmc-class-02)) - (funcall fn (make-instance 'dgmc-class-03)) - (funcall fn (make-instance 'dgmc-class-04)))) - a nil a nil) - -(deftest defgeneric-method-combination.and.8 - (let ((fn - (eval '(defgeneric dg-mc.and.8 (x) - (:method-combination and) - (:method and ((x (eql 1000))) 'a) - (:method :around ((x symbol)) (values)) - (:method :around ((x integer)) (values 'a 'b 'c)) - (:method :around ((x complex)) (call-next-method)) - (:method :around ((x number)) (values 1 2 3 4 5 6)) - (:method and ((x t)) 'b))))) - (declare (type generic-function fn)) - (values - (multiple-value-list (funcall fn 'a)) - (multiple-value-list (funcall fn 10)) - (multiple-value-list (funcall fn #c(9 8))) - (multiple-value-list (funcall fn '(a b c))))) - () (a b c) (1 2 3 4 5 6) (b)) - -(deftest defgeneric-method-combination.and.9 - (handler-case - (let ((fn (eval '(defgeneric dg-mc.and.9 (x) - (:method-combination and))))) - (declare (type generic-function fn)) - (funcall fn 'x)) - (error () :error)) - :error) - -(deftest defgeneric-method-combination.and.10 - (progn - (eval '(defgeneric dg-mc.and.10 (x) - (:method-combination and) - (:method ((x t)) t))) - (handler-case - (dg-mc.and.10 'a) - (error () :error))) - :error) - -(deftest defgeneric-method-combination.and.11 - (progn - (eval '(defgeneric dg-mc.and.11 (x) - (:method-combination and) - (:method nonsense ((x t)) t))) - (handler-case - (dg-mc.and.11 0) - (error () :error))) - :error) - -(deftest defgeneric-method-combination.and.12 - (let ((fn (eval '(defgeneric dg-mc.and.12 (x) - (:method-combination and) - (:method :around ((x t)) t) - (:method and ((x integer)) x))))) - (declare (type generic-function fn)) - (handler-case (funcall fn 'x) - (error () :error))) - :error) diff --git a/t/ansi-test/objects/defgeneric-method-combination-append.lsp b/t/ansi-test/objects/defgeneric-method-combination-append.lsp deleted file mode 100644 index 97032e5..0000000 --- a/t/ansi-test/objects/defgeneric-method-combination-append.lsp +++ /dev/null @@ -1,227 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat May 24 21:31:55 2003 -;;;; Contains: Tests of DEFGENERIC with :method-combination APPEND - - - -(declaim (special *x*)) - -(compile-and-load "defgeneric-method-combination-aux.lsp") - -(deftest defgeneric-method-combination.append.1 - (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.append.1 (x) - (:method-combination append) - (:method append ((x integer)) (car (push '(d) *x*))) - (:method append ((x rational)) (car (push '(c) *x*))) - (:method append ((x number)) (car (push '(b) *x*))) - (:method append ((x t)) (car (push '(a) *x*))))))) - (declare (type generic-function fn)) - (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) - (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) - ((d c b a) ((a) (b) (c) (d))) - ((c b a) ((a) (b) (c))) - ((b a) ((a) (b))) - ((a) ((a)))) - -(deftest defgeneric-method-combination.append.2 - (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.append.2 (x) - (:method-combination append :most-specific-first) - (:method append ((x integer)) (car (push '(d) *x*))) - (:method append ((x rational)) (car (push '(c) *x*))) - (:method append ((x number)) (car (push '(b) *x*))) - (:method append ((x t)) (car (push '(a) *x*))))))) - (declare (type generic-function fn)) - (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) - (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) - ((d c b a) ((a) (b) (c) (d))) - ((c b a) ((a) (b) (c))) - ((b a) ((a) (b))) - ((a) ((a)))) - -(deftest defgeneric-method-combination.append.3 - (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.append.3 (x) - (:method-combination append :most-specific-last) - (:method append ((x integer)) (car (push '(d) *x*))) - (:method append ((x rational)) (car (push '(c) *x*))) - (:method append ((x number)) (car (push '(b) *x*))) - (:method append ((x t)) (car (push '(a) *x*))))))) - (declare (type generic-function fn)) - (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) - (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) - ((a b c d) ((d) (c) (b) (a))) - ((a b c) ((c) (b) (a))) - ((a b) ((b) (a))) - ((a) ((a)))) - -(deftest defgeneric-method-combination.append.4 - (let ((fn - (eval '(defgeneric dg-mc.fun.append.4 (x) - (:method-combination append) - (:method append ((x integer)) '(a b)) - (:method :around ((x rational)) 'foo) - (:method append ((x number)) '(c d)) - (:method append ((x symbol)) '(e f)) - (:method append ((x t)) '(g h)))))) - (declare (type generic-function fn)) - (values - (funcall fn 0) - (funcall fn 4/3) - (funcall fn 1.54) - (funcall fn 'x) - (funcall fn '(a b c)))) - foo foo (c d g h) (e f g h) (g h)) - -(deftest defgeneric-method-combination.append.5 - (let ((fn - (eval '(defgeneric dg-mc.fun.append.5 (x) - (:method-combination append) - (:method append ((x integer)) '(a)) - (:method :around ((x rational)) - (list 'foo (call-next-method))) - (:method append ((x number)) '(b)) - (:method append ((x symbol)) '(c)) - (:method append ((x t)) 'd))))) - (declare (type generic-function fn)) - (values - (funcall fn 0) - (funcall fn 4/3) - (funcall fn 1.54) - (funcall fn 'x) - (funcall fn '(a b c)))) - (foo (a b . d)) (foo (b . d)) (b . d) (c . d) d) - -(deftest defgeneric-method-combination.append.6 - (let ((fn - (eval '(defgeneric dg-mc.fun.append.6 (x) - (:method-combination append) - (:method append ((x integer)) '(a)) - (:method :around ((x rational)) - (list 'foo (call-next-method))) - (:method :around ((x real)) - (list 'bar (call-next-method))) - (:method append ((x number)) '(b)) - (:method append ((x symbol)) '(c)) - (:method append ((x t)) '(d)))))) - (declare (type generic-function fn)) - (values - (funcall fn 0) - (funcall fn 4/3) - (funcall fn 1.54) - (funcall fn #c(1.0 2.0)) - (funcall fn 'x) - (funcall fn '(a b c)))) - (foo (bar (a b d))) (foo (bar (b d))) (bar (b d)) (b d) (c d) (d)) - -(deftest defgeneric-method-combination.append.7 - (let ((fn - (eval '(defgeneric dg-mc.fun.append.7 (x) - (:method-combination append) - (:method append ((x dgmc-class-04)) '(a)) - (:method append ((x dgmc-class-03)) '(b)) - (:method append ((x dgmc-class-02)) '(c)) - (:method append ((x dgmc-class-01)) '(d)))))) - (declare (type generic-function fn)) - (values - (funcall fn (make-instance 'dgmc-class-01)) - (funcall fn (make-instance 'dgmc-class-02)) - (funcall fn (make-instance 'dgmc-class-03)) - (funcall fn (make-instance 'dgmc-class-04)))) - (d) - (c d) - (b d) - (a c b d)) - -(deftest defgeneric-method-combination.append.8 - (let ((fn - (eval '(defgeneric dg-mc.append.8 (x) - (:method-combination append) - (:method append ((x (eql 1000))) '(a)) - (:method :around ((x symbol)) (values)) - (:method :around ((x integer)) (values 'a 'b 'c)) - (:method :around ((x complex)) (call-next-method)) - (:method :around ((x number)) (values 1 2 3 4 5 6)) - (:method append ((x t)) '(b)))))) - (declare (type generic-function fn)) - (values - (multiple-value-list (funcall fn 'a)) - (multiple-value-list (funcall fn 10)) - (multiple-value-list (funcall fn #c(9 8))) - (multiple-value-list (funcall fn '(a b c))))) - () (a b c) (1 2 3 4 5 6) ((b))) - -(deftest defgeneric-method-combination.append.9 - (handler-case - (let ((fn (eval '(defgeneric dg-mc.append.9 (x) - (:method-combination append))))) - (declare (type generic-function fn)) - (funcall fn '(a))) - (error () :error)) - :error) - -(deftest defgeneric-method-combination.append.10 - (progn - (eval '(defgeneric dg-mc.append.10 (x) - (:method-combination append) - (:method ((x t)) '(a)))) - (handler-case - (dg-mc.append.10 'x) - (error () :error))) - :error) - -(deftest defgeneric-method-combination.append.11 - (progn - (eval '(defgeneric dg-mc.append.11 (x) - (:method-combination append) - (:method nonsense ((x t)) '(a)))) - (handler-case - (dg-mc.append.11 0) - (error () :error))) - :error) - -(deftest defgeneric-method-combination.append.12 - (let ((fn (eval '(defgeneric dg-mc.append.12 (x) - (:method-combination append) - (:method :around ((x t)) '(a)) - (:method append ((x integer)) x))))) - (declare (type generic-function fn)) - (handler-case (funcall fn '(b)) - (error () :error))) - :error) - -(deftest defgeneric-method-combination.append.13 - (progn - (eval '(defgeneric dg-mc.append.13 (x) - (:method-combination append) - (:method append ((x dgmc-class-01)) (list 'foo)) - (:method append ((x dgmc-class-02)) (list 'bar)) - (:method nonsense ((x dgmc-class-03)) (list 'bad)))) - (values - (dg-mc.append.13 (make-instance 'dgmc-class-01)) - (dg-mc.append.13 (make-instance 'dgmc-class-02)) - (handler-case - (dg-mc.append.13 (make-instance 'dgmc-class-03)) - (error () :caught)) - (handler-case - (dg-mc.append.13 (make-instance 'dgmc-class-04)) - (error () :caught)) - (handler-case - (dg-mc.append.13 (make-instance 'dgmc-class-07)) - (error () :caught)))) - (foo) - (bar foo) - :caught - :caught - :caught) diff --git a/t/ansi-test/objects/defgeneric-method-combination-aux.lsp b/t/ansi-test/objects/defgeneric-method-combination-aux.lsp deleted file mode 100644 index f0d7503..0000000 --- a/t/ansi-test/objects/defgeneric-method-combination-aux.lsp +++ /dev/null @@ -1,14 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed May 28 14:02:42 2003 -;;;; Contains: Class definitions for defgeneric-method-combination-*.lsp - - - -(defclass dgmc-class-01 () ()) -(defclass dgmc-class-02 (dgmc-class-01) ()) -(defclass dgmc-class-03 (dgmc-class-01) ()) -(defclass dgmc-class-04 (dgmc-class-02 dgmc-class-03) ()) -(defclass dgmc-class-05 (dgmc-class-04) ()) -(defclass dgmc-class-06 (dgmc-class-04) ()) -(defclass dgmc-class-07 (dgmc-class-05 dgmc-class-06) ()) diff --git a/t/ansi-test/objects/defgeneric-method-combination-list.lsp b/t/ansi-test/objects/defgeneric-method-combination-list.lsp deleted file mode 100644 index 8ad8755..0000000 --- a/t/ansi-test/objects/defgeneric-method-combination-list.lsp +++ /dev/null @@ -1,202 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat May 24 21:31:55 2003 -;;;; Contains: Tests of DEFGENERIC with :method-combination LIST - - - -(declaim (special *x*)) - -(compile-and-load "defgeneric-method-combination-aux.lsp") - -(deftest defgeneric-method-combination.list.1 - (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.list.1 (x) - (:method-combination list) - (:method list ((x integer)) (car (push 'd *x*))) - (:method list ((x rational)) (car (push 'c *x*))) - (:method list ((x number)) (car (push 'b *x*))) - (:method list ((x t)) (car (push 'a *x*))))))) - (declare (type generic-function fn)) - (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) - (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) - ((d c b a) (a b c d)) - ((c b a) (a b c)) - ((b a) (a b)) - ((a) (a))) - -(deftest defgeneric-method-combination.list.2 - (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.list.2 (x) - (:method-combination list :most-specific-first) - (:method list ((x integer)) (car (push 'd *x*))) - (:method list ((x rational)) (car (push 'c *x*))) - (:method list ((x number)) (car (push 'b *x*))) - (:method list ((x t)) (car (push 'a *x*))))))) - (declare (type generic-function fn)) - (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) - (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) - ((d c b a) (a b c d)) - ((c b a) (a b c)) - ((b a) (a b)) - ((a) (a))) - -(deftest defgeneric-method-combination.list.3 - (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.list.3 (x) - (:method-combination list :most-specific-last) - (:method list ((x integer)) (car (push 'd *x*))) - (:method list ((x rational)) (car (push 'c *x*))) - (:method list ((x number)) (car (push 'b *x*))) - (:method list ((x t)) (car (push 'a *x*))))))) - (declare (type generic-function fn)) - (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) - (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) - ((a b c d) (d c b a)) - ((a b c) (c b a)) - ((a b) (b a)) - ((a) (a))) - -(deftest defgeneric-method-combination.list.4 - (let ((fn - (eval '(defgeneric dg-mc.fun.list.4 (x) - (:method-combination list) - (:method list ((x integer)) '(a b)) - (:method :around ((x rational)) 'foo) - (:method list ((x number)) '(c d)) - (:method list ((x symbol)) '(e f)) - (:method list ((x t)) '(g h)))))) - (declare (type generic-function fn)) - (values - (funcall fn 0) - (funcall fn 4/3) - (funcall fn 1.54) - (funcall fn 'x) - (funcall fn '(a b c)))) - foo foo ((c d) (g h)) ((e f) (g h)) ((g h))) - -(deftest defgeneric-method-combination.list.5 - (let ((fn - (eval '(defgeneric dg-mc.fun.list.5 (x) - (:method-combination list) - (:method list ((x integer)) 'a) - (:method :around ((x rational)) - (list 'foo (call-next-method))) - (:method list ((x number)) 'b) - (:method list ((x symbol)) 'c) - (:method list ((x t)) 'd))))) - (declare (type generic-function fn)) - (values - (funcall fn 0) - (funcall fn 4/3) - (funcall fn 1.54) - (funcall fn 'x) - (funcall fn '(a b c)))) - (foo (a b d)) (foo (b d)) (b d) (c d) (d)) - -(deftest defgeneric-method-combination.list.6 - (let ((fn - (eval '(defgeneric dg-mc.fun.list.6 (x) - (:method-combination list) - (:method list ((x integer)) 'a) - (:method :around ((x rational)) - (list 'foo (call-next-method))) - (:method :around ((x real)) - (list 'bar (call-next-method))) - (:method list ((x number)) 'b) - (:method list ((x symbol)) 'c) - (:method list ((x t)) 'd))))) - (declare (type generic-function fn)) - (values - (funcall fn 0) - (funcall fn 4/3) - (funcall fn 1.54) - (funcall fn #c(1.0 2.0)) - (funcall fn 'x) - (funcall fn '(a b c)))) - (foo (bar (a b d))) (foo (bar (b d))) (bar (b d)) (b d) (c d) (d)) - -(deftest defgeneric-method-combination.list.7 - (let ((fn - (eval '(defgeneric dg-mc.fun.list.7 (x) - (:method-combination list) - (:method list ((x dgmc-class-04)) 'a) - (:method list ((x dgmc-class-03)) 'b) - (:method list ((x dgmc-class-02)) 'c) - (:method list ((x dgmc-class-01)) 'd))))) - (declare (type generic-function fn)) - (values - (funcall fn (make-instance 'dgmc-class-01)) - (funcall fn (make-instance 'dgmc-class-02)) - (funcall fn (make-instance 'dgmc-class-03)) - (funcall fn (make-instance 'dgmc-class-04)))) - (d) - (c d) - (b d) - (a c b d)) - -(deftest defgeneric-method-combination.list.8 - (let ((fn - (eval '(defgeneric dg-mc.list.8 (x) - (:method-combination list) - (:method list ((x (eql 1000))) 'a) - (:method :around ((x symbol)) (values)) - (:method :around ((x integer)) (values 'a 'b 'c)) - (:method :around ((x complex)) (call-next-method)) - (:method :around ((x number)) (values 1 2 3 4 5 6)) - (:method list ((x t)) 'b))))) - (declare (type generic-function fn)) - (values - (multiple-value-list (funcall fn 'a)) - (multiple-value-list (funcall fn 10)) - (multiple-value-list (funcall fn #c(9 8))) - (multiple-value-list (funcall fn '(a b c))))) - () (a b c) (1 2 3 4 5 6) ((b))) - -(deftest defgeneric-method-combination.list.9 - (handler-case - (let ((fn (eval '(defgeneric dg-mc.list.9 (x) - (:method-combination list))))) - (declare (type generic-function fn)) - (funcall fn (list 'a))) - (error () :error)) - :error) - -(deftest defgeneric-method-combination.list.10 - (progn - (eval '(defgeneric dg-mc.list.10 (x) - (:method-combination list) - (:method ((x t)) (list 'a)))) - (handler-case - (dg-mc.list.10 'a) - (error () :error))) - :error) - -(deftest defgeneric-method-combination.list.11 - (progn - (eval '(defgeneric dg-mc.list.11 (x) - (:method-combination list) - (:method nonsense ((x t)) (list 'a)))) - (handler-case - (dg-mc.list.11 0) - (error () :error))) - :error) - -(deftest defgeneric-method-combination.list.12 - (let ((fn (eval '(defgeneric dg-mc.list.12 (x) - (:method-combination list) - (:method :around ((x t)) (list 'a)) - (:method list ((x integer)) x))))) - (declare (type generic-function fn)) - (handler-case (funcall fn (list 'b)) - (error () :error))) - :error) diff --git a/t/ansi-test/objects/defgeneric-method-combination-max.lsp b/t/ansi-test/objects/defgeneric-method-combination-max.lsp deleted file mode 100644 index 3275234..0000000 --- a/t/ansi-test/objects/defgeneric-method-combination-max.lsp +++ /dev/null @@ -1,190 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat May 24 21:31:55 2003 -;;;; Contains: Tests of DEFGENERIC with :method-combination MAX - - - -(declaim (special *x*)) - -(compile-and-load "defgeneric-method-combination-aux.lsp") - -(deftest defgeneric-method-combination.max.1 - (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.max.1 (x) - (:method-combination max) - (:method max ((x integer)) (car (push 8 *x*))) - (:method max ((x rational)) (car (push 4 *x*))) - (:method max ((x number)) (car (push 2 *x*))) - (:method max ((x t)) (car (push 1 *x*))))))) - (declare (type generic-function fn)) - (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) - (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) - (8 (1 2 4 8)) (4 (1 2 4)) (2 (1 2)) (1 (1))) - -(deftest defgeneric-method-combination.max.2 - (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.max.2 (x) - (:method-combination max :most-specific-first) - (:method max ((x integer)) (car (push 8 *x*))) - (:method max ((x rational)) (car (push 4 *x*))) - (:method max ((x number)) (car (push 2 *x*))) - (:method max ((x t)) (car (push 1 *x*))))))) - (declare (type generic-function fn)) - (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) - (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) - (8 (1 2 4 8)) (4 (1 2 4)) (2 (1 2)) (1 (1))) - -(deftest defgeneric-method-combination.max.3 - (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.max.3 (x) - (:method-combination max :most-specific-last) - (:method max ((x integer)) (car (push 8 *x*))) - (:method max ((x rational)) (car (push 4 *x*))) - (:method max ((x number)) (car (push 2 *x*))) - (:method max ((x t)) (car (push 1 *x*))))))) - (declare (type generic-function fn)) - (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) - (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) - (8 (8 4 2 1)) (4 (4 2 1)) (2 (2 1)) (1 (1))) - -(deftest defgeneric-method-combination.max.4 - (let ((fn - (eval '(defgeneric dg-mc.max.4 (x) - (:method-combination max) - (:method max ((x integer)) 4) - (:method :around ((x rational)) 'foo) - (:method max ((x number)) 3) - (:method max ((x symbol)) 5) - (:method max ((x t)) 1))))) - (declare (type generic-function fn)) - (values - (funcall fn 0) - (funcall fn 4/3) - (funcall fn 1.54) - (funcall fn 'x) - (funcall fn '(a b c)))) - foo foo 3 5 1) - -(deftest defgeneric-method-combination.max.5 - (let ((fn - (eval '(defgeneric dg-mc.max.5 (x) - (:method-combination max) - (:method max ((x integer)) 5) - (:method :around ((x rational)) - (list 'foo (call-next-method))) - (:method max ((x number)) 5/2) - (:method max ((x symbol)) 4) - (:method max ((x t)) 1.0))))) - (declare (type generic-function fn)) - (values - (funcall fn 0) - (funcall fn 4/3) - (funcall fn 1.54) - (funcall fn 'x) - (funcall fn '(a b c)))) - (foo 5) (foo 5/2) 5/2 4 1.0) - -(deftest defgeneric-method-combination.max.6 - (let ((fn - (eval '(defgeneric dg-mc.max.6 (x) - (:method-combination max) - (:method max ((x integer)) 9) - (:method :around ((x rational)) - (list 'foo (call-next-method))) - (:method :around ((x real)) - (list 'bar (call-next-method))) - (:method max ((x number)) 4) - (:method max ((x symbol)) 6) - (:method max ((x t)) 1))))) - (declare (type generic-function fn)) - (values - (funcall fn 0) - (funcall fn 4/3) - (funcall fn 1.54) - (funcall fn #c(1.0 2.0)) - (funcall fn 'x) - (funcall fn '(a b c)))) - (foo (bar 9)) (foo (bar 4)) (bar 4) 4 6 1) - -(deftest defgeneric-method-combination.max.7 - (let ((fn - (eval '(defgeneric dg-mc.max.7 (x) - (:method-combination max) - (:method max ((x dgmc-class-04)) 4) - (:method max ((x dgmc-class-03)) 3) - (:method max ((x dgmc-class-02)) 5) - (:method max ((x dgmc-class-01)) 1))))) - (declare (type generic-function fn)) - (values - (funcall fn (make-instance 'dgmc-class-01)) - (funcall fn (make-instance 'dgmc-class-02)) - (funcall fn (make-instance 'dgmc-class-03)) - (funcall fn (make-instance 'dgmc-class-04)))) - 1 5 3 5) - -(deftest defgeneric-method-combination.max.8 - (let ((fn - (eval '(defgeneric dg-mc.max.8 (x) - (:method-combination max) - (:method max ((x (eql 1000))) 4) - (:method :around ((x symbol)) (values)) - (:method :around ((x integer)) (values 'a 'b 'c)) - (:method :around ((x complex)) (call-next-method)) - (:method :around ((x number)) (values 1 2 3 4 5 6)) - (:method max ((x t)) 1))))) - (declare (type generic-function fn)) - (values - (multiple-value-list (funcall fn 'a)) - (multiple-value-list (funcall fn 10)) - (multiple-value-list (funcall fn #c(9 8))) - (multiple-value-list (funcall fn '(a b c))))) - () (a b c) (1 2 3 4 5 6) (1)) - -(deftest defgeneric-method-combination.max.9 - (handler-case - (let ((fn (eval '(defgeneric dg-mc.max.9 (x) - (:method-combination max))))) - (declare (type generic-function fn)) - (funcall fn (list 'a))) - (error () :error)) - :error) - -(deftest defgeneric-method-combination.max.10 - (progn - (eval '(defgeneric dg-mc.max.10 (x) - (:method-combination max) - (:method ((x t)) 0))) - (handler-case - (dg-mc.max.10 'a) - (error () :error))) - :error) - -(deftest defgeneric-method-combination.max.11 - (progn - (eval '(defgeneric dg-mc.max.11 (x) - (:method-combination max) - (:method nonsense ((x t)) 0))) - (handler-case - (dg-mc.max.11 0) - (error () :error))) - :error) - -(deftest defgeneric-method-combination.max.12 - (let ((fn (eval '(defgeneric dg-mc.max.12 (x) - (:method-combination max) - (:method :around ((x t)) 1) - (:method max ((x integer)) x))))) - (declare (type generic-function fn)) - (handler-case (funcall fn 'a) - (error () :error))) - :error) diff --git a/t/ansi-test/objects/defgeneric-method-combination-min.lsp b/t/ansi-test/objects/defgeneric-method-combination-min.lsp deleted file mode 100644 index 41b9e38..0000000 --- a/t/ansi-test/objects/defgeneric-method-combination-min.lsp +++ /dev/null @@ -1,191 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat May 24 21:31:55 2003 -;;;; Contains: Tests of DEFGENERIC with :method-combination MIN - - - -(declaim (special *x*)) - -(compile-and-load "defgeneric-method-combination-aux.lsp") - -(deftest defgeneric-method-combination.min.1 - (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.min.1 (x) - (:method-combination min) - (:method min ((x integer)) (car (push 1 *x*))) - (:method min ((x rational)) (car (push 2 *x*))) - (:method min ((x number)) (car (push 3 *x*))) - (:method min ((x t)) (car (push 4 *x*))))))) - (declare (type generic-function fn)) - (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) - (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) - (1 (4 3 2 1)) (2 (4 3 2)) (3 (4 3)) (4 (4))) - -(deftest defgeneric-method-combination.min.2 - (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.min.2 (x) - (:method-combination min :most-specific-first) - (:method min ((x integer)) (car (push 1 *x*))) - (:method min ((x rational)) (car (push 2 *x*))) - (:method min ((x number)) (car (push 3 *x*))) - (:method min ((x t)) (car (push 4 *x*))))))) - (declare (type generic-function fn)) - (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) - (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) - (1 (4 3 2 1)) (2 (4 3 2)) (3 (4 3)) (4 (4))) - -(deftest defgeneric-method-combination.min.3 - (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.min.3 (x) - (:method-combination min :most-specific-last) - (:method min ((x integer)) (car (push 1 *x*))) - (:method min ((x rational)) (car (push 2 *x*))) - (:method min ((x number)) (car (push 3 *x*))) - (:method min ((x t)) (car (push 4 *x*))))))) - (declare (type generic-function fn)) - (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) - (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) - (1 (1 2 3 4)) (2 (2 3 4)) (3 (3 4)) (4 (4))) - -(deftest defgeneric-method-combination.min.4 - (let ((fn - (eval '(defgeneric dg-mc.min.4 (x) - (:method-combination min) - (:method min ((x integer)) 1) - (:method :around ((x rational)) 'foo) - (:method min ((x number)) 2) - (:method min ((x symbol)) 3) - (:method min ((x t)) 4))))) - (declare (type generic-function fn)) - (values - (funcall fn 0) - (funcall fn 4/3) - (funcall fn 1.54) - (funcall fn 'x) - (funcall fn '(a b c)))) - foo foo 2 3 4) - -(deftest defgeneric-method-combination.min.5 - (let ((fn - (eval '(defgeneric dg-mc.min.5 (x) - (:method-combination min) - (:method min ((x integer)) 1) - (:method :around ((x rational)) - (list 'foo (call-next-method))) - (:method min ((x number)) 2) - (:method min ((x symbol)) 4) - (:method min ((x t)) 8))))) - (declare (type generic-function fn)) - (values - (funcall fn 0) - (funcall fn 4/3) - (funcall fn 1.54) - (funcall fn 'x) - (funcall fn '(a b c)))) - (foo 1) (foo 2) 2 4 8) - -(deftest defgeneric-method-combination.min.6 - (let ((fn - (eval '(defgeneric dg-mc.min.6 (x) - (:method-combination min) - (:method min ((x integer)) 1) - (:method :around ((x rational)) - (list 'foo (call-next-method))) - (:method :around ((x real)) - (list 'bar (call-next-method))) - (:method min ((x number)) 2) - (:method min ((x symbol)) 4) - (:method min ((x t)) 8))))) - (declare (type generic-function fn)) - (values - (funcall fn 0) - (funcall fn 4/3) - (funcall fn 1.54) - (funcall fn #c(1.0 2.0)) - (funcall fn 'x) - (funcall fn '(a b c)))) - (foo (bar 1)) (foo (bar 2)) (bar 2) 2 4 8) - -(deftest defgeneric-method-combination.min.7 - (let ((fn - (eval '(defgeneric dg-mc.min.7 (x) - (:method-combination min) - (:method min ((x dgmc-class-04)) 1) - (:method min ((x dgmc-class-03)) 2) - (:method min ((x dgmc-class-02)) 4) - (:method min ((x dgmc-class-01)) 8))))) - (declare (type generic-function fn)) - (values - (funcall fn (make-instance 'dgmc-class-01)) - (funcall fn (make-instance 'dgmc-class-02)) - (funcall fn (make-instance 'dgmc-class-03)) - (funcall fn (make-instance 'dgmc-class-04)))) - 8 4 2 1) - -(deftest defgeneric-method-combination.min.8 - (let ((fn - (eval '(defgeneric dg-mc.min.8 (x) - (:method-combination min) - (:method min ((x (eql 1000))) 0) - (:method :around ((x symbol)) (values)) - (:method :around ((x integer)) (values 'a 'b 'c)) - (:method :around ((x complex)) (call-next-method)) - (:method :around ((x number)) (values 1 2 3 4 5 6)) - (:method min ((x t)) 1))))) - (declare (type generic-function fn)) - (values - (multiple-value-list (funcall fn 'a)) - (multiple-value-list (funcall fn 10)) - (multiple-value-list (funcall fn #c(9 8))) - (multiple-value-list (funcall fn '(a b c))))) - () (a b c) (1 2 3 4 5 6) (1)) - -(deftest defgeneric-method-combination.min.9 - (handler-case - (let ((fn (eval '(defgeneric dg-mc.min.9 (x) - (:method-combination min))))) - (declare (type generic-function fn)) - (funcall fn (list 'a))) - (error () :error)) - :error) - -(deftest defgeneric-method-combination.min.10 - (progn - (eval '(defgeneric dg-mc.min.10 (x) - (:method-combination min) - (:method ((x t)) 0))) - (handler-case - (dg-mc.min.10 'a) - (error () :error))) - :error) - -(deftest defgeneric-method-combination.min.11 - (progn - (eval '(defgeneric dg-mc.min.11 (x) - (:method-combination min) - (:method nonsense ((x t)) 0))) - (handler-case - (dg-mc.min.11 0) - (error () :error))) - :error) - -(deftest defgeneric-method-combination.min.12 - (let ((fn (eval '(defgeneric dg-mc.min.12 (x) - (:method-combination min) - (:method :around ((x t)) 1) - (:method min ((x integer)) x))))) - (declare (type generic-function fn)) - (handler-case (funcall fn 'a) - (error () :error))) - :error) - diff --git a/t/ansi-test/objects/defgeneric-method-combination-nconc.lsp b/t/ansi-test/objects/defgeneric-method-combination-nconc.lsp deleted file mode 100644 index f9a7d34..0000000 --- a/t/ansi-test/objects/defgeneric-method-combination-nconc.lsp +++ /dev/null @@ -1,214 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat May 24 21:31:55 2003 -;;;; Contains: Tests of DEFGENERIC with :method-combination NCONC - - - -(declaim (special *x*)) - -(compile-and-load "defgeneric-method-combination-aux.lsp") - -(deftest defgeneric-method-combination.nconc.1 - (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.nconc.1 (x) - (:method-combination nconc) - (:method nconc ((x integer)) - (copy-list (car (push '(d) *x*)))) - (:method nconc ((x rational)) - (copy-list (car (push '(c) *x*)))) - (:method nconc ((x number)) - (copy-list (car (push '(b) *x*)))) - (:method nconc ((x t)) - (copy-list (car (push '(a) *x*)))))))) - (declare (type generic-function fn)) - (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) - (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) - ((d c b a) ((a) (b) (c) (d))) - ((c b a) ((a) (b) (c))) - ((b a) ((a) (b))) - ((a) ((a)))) - -(deftest defgeneric-method-combination.nconc.2 - (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.nconc.2 (x) - (:method-combination nconc :most-specific-first) - (:method nconc ((x integer)) - (copy-list (car (push '(d) *x*)))) - (:method nconc ((x rational)) - (copy-list (car (push '(c) *x*)))) - (:method nconc ((x number)) - (copy-list (car (push '(b) *x*)))) - (:method nconc ((x t)) - (copy-list (car (push '(a) *x*)))))))) - (declare (type generic-function fn)) - (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) - (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) - ((d c b a) ((a) (b) (c) (d))) - ((c b a) ((a) (b) (c))) - ((b a) ((a) (b))) - ((a) ((a)))) - -(deftest defgeneric-method-combination.nconc.3 - (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.nconc.3 (x) - (:method-combination nconc :most-specific-last) - (:method nconc ((x integer)) - (copy-list (car (push '(d) *x*)))) - (:method nconc ((x rational)) - (copy-list (car (push '(c) *x*)))) - (:method nconc ((x number)) - (copy-list (car (push '(b) *x*)))) - (:method nconc ((x t)) - (copy-list (car (push '(a) *x*)))))))) - (declare (type generic-function fn)) - (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) - (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) - ((a b c d) ((d) (c) (b) (a))) - ((a b c) ((c) (b) (a))) - ((a b) ((b) (a))) - ((a) ((a)))) - -(deftest defgeneric-method-combination.nconc.4 - (let ((fn - (eval '(defgeneric dg-mc.fun.nconc.4 (x) - (:method-combination nconc) - (:method nconc ((x integer)) (list 'a 'b)) - (:method :around ((x rational)) 'foo) - (:method nconc ((x number)) (list 'c 'd)) - (:method nconc ((x symbol)) (list 'e 'f)) - (:method nconc ((x t)) (list 'g 'h)))))) - (declare (type generic-function fn)) - (values - (funcall fn 0) - (funcall fn 4/3) - (funcall fn 1.54) - (funcall fn 'x) - (funcall fn '(a b c)))) - foo foo (c d g h) (e f g h) (g h)) - -(deftest defgeneric-method-combination.nconc.5 - (let ((fn - (eval '(defgeneric dg-mc.fun.nconc.5 (x) - (:method-combination nconc) - (:method nconc ((x integer)) (list 'a)) - (:method :around ((x rational)) - (list 'foo (call-next-method))) - (:method nconc ((x number)) (list 'b)) - (:method nconc ((x symbol)) (list 'c)) - (:method nconc ((x t)) (cons 'd 'e)))))) - (declare (type generic-function fn)) - (values - (funcall fn 0) - (funcall fn 4/3) - (funcall fn 1.54) - (funcall fn 'x) - (funcall fn '(a b c)))) - (foo (a b d . e)) (foo (b d . e)) (b d . e) (c d . e) (d . e)) - -(deftest defgeneric-method-combination.nconc.6 - (let ((fn - (eval '(defgeneric dg-mc.fun.nconc.6 (x) - (:method-combination nconc) - (:method nconc ((x integer)) (list 'a)) - (:method :around ((x rational)) - (list 'foo (call-next-method))) - (:method :around ((x real)) - (list 'bar (call-next-method))) - (:method nconc ((x number)) (list 'b)) - (:method nconc ((x symbol)) (list 'c)) - (:method nconc ((x t)) (list 'd)))))) - (declare (type generic-function fn)) - (values - (funcall fn 0) - (funcall fn 4/3) - (funcall fn 1.54) - (funcall fn #c(1.0 2.0)) - (funcall fn 'x) - (funcall fn '(a b c)))) - (foo (bar (a b d))) (foo (bar (b d))) (bar (b d)) (b d) (c d) (d)) - -(deftest defgeneric-method-combination.nconc.7 - (let ((fn - (eval '(defgeneric dg-mc.fun.nconc.7 (x) - (:method-combination nconc) - (:method nconc ((x dgmc-class-04)) (list 'a)) - (:method nconc ((x dgmc-class-03)) (list 'b)) - (:method nconc ((x dgmc-class-02)) (list 'c)) - (:method nconc ((x dgmc-class-01)) (list 'd)))))) - (declare (type generic-function fn)) - (values - (funcall fn (make-instance 'dgmc-class-01)) - (funcall fn (make-instance 'dgmc-class-02)) - (funcall fn (make-instance 'dgmc-class-03)) - (funcall fn (make-instance 'dgmc-class-04)))) - (d) - (c d) - (b d) - (a c b d)) - -(deftest defgeneric-method-combination.nconc.8 - (let ((fn - (eval '(defgeneric dg-mc.nconc.8 (x) - (:method-combination nconc) - (:method nconc ((x (eql 1000))) (list 'a)) - (:method :around ((x symbol)) (values)) - (:method :around ((x integer)) (values 'a 'b 'c)) - (:method :around ((x complex)) (call-next-method)) - (:method :around ((x number)) (values 1 2 3 4 5 6)) - (:method nconc ((x t)) (list 'b)))))) - (declare (type generic-function fn)) - (values - (multiple-value-list (funcall fn 'a)) - (multiple-value-list (funcall fn 10)) - (multiple-value-list (funcall fn #c(9 8))) - (multiple-value-list (funcall fn '(a b c))))) - () (a b c) (1 2 3 4 5 6) ((b))) - -(deftest defgeneric-method-combination.nconc.9 - (handler-case - (let ((fn (eval '(defgeneric dg-mc.nconc.9 (x) - (:method-combination nconc))))) - (declare (type generic-function fn)) - (funcall fn (list 'a))) - (error () :error)) - :error) - -(deftest defgeneric-method-combination.nconc.10 - (progn - (eval '(defgeneric dg-mc.nconc.10 (x) - (:method-combination nconc) - (:method ((x t)) (list 'a)))) - (handler-case - (dg-mc.nconc.10 'a) - (error () :error))) - :error) - -(deftest defgeneric-method-combination.nconc.11 - (progn - (eval '(defgeneric dg-mc.nconc.11 (x) - (:method-combination nconc) - (:method nonsense ((x t)) (list 'a)))) - (handler-case - (dg-mc.nconc.11 0) - (error () :error))) - :error) - -(deftest defgeneric-method-combination.nconc.12 - (let ((fn (eval '(defgeneric dg-mc.nconc.12 (x) - (:method-combination nconc) - (:method :around ((x t)) (list 'a)) - (:method nconc ((x integer)) x))))) - (declare (type generic-function fn)) - (handler-case (funcall fn (list 'b)) - (error () :error))) - :error) diff --git a/t/ansi-test/objects/defgeneric-method-combination-or.lsp b/t/ansi-test/objects/defgeneric-method-combination-or.lsp deleted file mode 100644 index 839bd03..0000000 --- a/t/ansi-test/objects/defgeneric-method-combination-or.lsp +++ /dev/null @@ -1,193 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat May 24 21:31:55 2003 -;;;; Contains: Tests of DEFGENERIC with :method-combination OR - - - -(declaim (special *x*)) - -(compile-and-load "defgeneric-method-combination-aux.lsp") - -(deftest defgeneric-method-combination.or.1 - (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.or.1 (x) - (:method-combination or) - (:method or ((x integer)) (push 4 *x*) nil) - (:method or ((x rational)) (push 3 *x*) nil) - (:method or ((x number)) (push 2 *x*) nil) - (:method or ((x t)) (push 1 *x*) 'a))))) - (declare (type generic-function fn)) - (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) - (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) - (a (1 2 3 4)) - (a (1 2 3)) - (a (1 2)) - (a (1))) - -(deftest defgeneric-method-combination.or.2 - (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.or.2 (x) - (:method-combination or :most-specific-first) - (:method or ((x integer)) (push 4 *x*) nil) - (:method or ((x rational)) (push 3 *x*) 'a) - (:method or ((x number)) (push 2 *x*) nil) - (:method or ((x t)) (push 1 *x*) 'b))))) - (declare (type generic-function fn)) - (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) - (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) - (a (3 4)) (a (3)) (b (1 2)) (b (1))) - -(deftest defgeneric-method-combination.or.3 - (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.or.3 (x) - (:method-combination or :most-specific-last) - (:method or ((x integer)) (push 4 *x*) 'a) - (:method or ((x rational)) (push 3 *x*) nil) - (:method or ((x number)) (push 2 *x*) nil) - (:method or ((x t)) (push 1 *x*) nil))))) - (declare (type generic-function fn)) - (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) - (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) - (a (4 3 2 1)) (nil (3 2 1)) (nil (2 1)) (nil (1))) - -(deftest defgeneric-method-combination.or.4 - (let ((fn - (eval '(defgeneric dg-mc.or.4 (x) - (:method-combination or) - (:method or ((x integer)) nil) - (:method :around ((x rational)) 'foo) - (:method or ((x number)) 'b) - (:method or ((x symbol)) nil) - (:method or ((x t)) 'a))))) - (declare (type generic-function fn)) - (values - (funcall fn 0) - (funcall fn 4/3) - (funcall fn 1.54) - (funcall fn 'x) - (funcall fn '(a b c)))) - foo foo b a a) - -(deftest defgeneric-method-combination.or.5 - (let ((fn - (eval '(defgeneric dg-mc.or.5 (x) - (:method-combination or) - (:method or ((x integer)) 'a) - (:method :around ((x rational)) - (list 'foo (call-next-method))) - (:method or ((x number)) nil) - (:method or ((x symbol)) 'b) - (:method or ((x t)) 'c))))) - (declare (type generic-function fn)) - (values - (funcall fn 0) - (funcall fn 4/3) - (funcall fn 1.54) - (funcall fn 'x) - (funcall fn '(a b c)))) - (foo a) (foo c) c b c) - -(deftest defgeneric-method-combination.or.6 - (let ((fn - (eval '(defgeneric dg-mc.or.6 (x) - (:method-combination or) - (:method or ((x integer)) 'a) - (:method :around ((x rational)) - (list 'foo (call-next-method))) - (:method :around ((x real)) - (list 'bar (call-next-method))) - (:method or ((x number)) 'b) - (:method or ((x symbol)) 'c) - (:method or ((x t)) 'd))))) - (declare (type generic-function fn)) - (values - (funcall fn 0) - (funcall fn 4/3) - (funcall fn 1.54) - (funcall fn #c(1.0 2.0)) - (funcall fn 'x) - (funcall fn '(a b c)))) - (foo (bar a)) (foo (bar b)) (bar b) b c d) - -(deftest defgeneric-method-combination.or.7 - (let ((fn - (eval '(defgeneric dg-mc.or.7 (x) - (:method-combination or) - (:method or ((x dgmc-class-04)) nil) - (:method or ((x dgmc-class-03)) nil) - (:method or ((x dgmc-class-02)) 'b) - (:method or ((x dgmc-class-01)) 'c))))) - (declare (type generic-function fn)) - (values - (funcall fn (make-instance 'dgmc-class-01)) - (funcall fn (make-instance 'dgmc-class-02)) - (funcall fn (make-instance 'dgmc-class-03)) - (funcall fn (make-instance 'dgmc-class-04)))) - c b c b) - -(deftest defgeneric-method-combination.or.8 - (let ((fn - (eval '(defgeneric dg-mc.or.8 (x) - (:method-combination or) - (:method or ((x (eql 1000))) 'a) - (:method :around ((x symbol)) (values)) - (:method :around ((x integer)) (values 'a 'b 'c)) - (:method :around ((x complex)) (call-next-method)) - (:method :around ((x number)) (values 1 2 3 4 5 6)) - (:method or ((x t)) 'b))))) - (declare (type generic-function fn)) - (values - (multiple-value-list (funcall fn 'a)) - (multiple-value-list (funcall fn 10)) - (multiple-value-list (funcall fn #c(9 8))) - (multiple-value-list (funcall fn '(a b c))))) - () (a b c) (1 2 3 4 5 6) (b)) - -(deftest defgeneric-method-combination.or.9 - (handler-case - (let ((fn (eval '(defgeneric dg-mc.or.9 (x) - (:method-combination or))))) - (declare (type generic-function fn)) - (funcall fn (list 'a))) - (error () :error)) - :error) - -(deftest defgeneric-method-combination.or.10 - (progn - (eval '(defgeneric dg-mc.or.10 (x) - (:method-combination or) - (:method ((x t)) 0))) - (handler-case - (dg-mc.or.10 'a) - (error () :error))) - :error) - -(deftest defgeneric-method-combination.or.11 - (progn - (eval '(defgeneric dg-mc.or.11 (x) - (:method-combination or) - (:method nonsense ((x t)) 0))) - (handler-case - (dg-mc.or.11 0) - (error () :error))) - :error) - -(deftest defgeneric-method-combination.or.12 - (let ((fn (eval '(defgeneric dg-mc.or.12 (x) - (:method-combination or) - (:method :around ((x t)) t) - (:method or ((x integer)) x))))) - (declare (type generic-function fn)) - (handler-case (funcall fn 'a) - (error () :error))) - :error) diff --git a/t/ansi-test/objects/defgeneric-method-combination-plus.lsp b/t/ansi-test/objects/defgeneric-method-combination-plus.lsp deleted file mode 100644 index 74b68f6..0000000 --- a/t/ansi-test/objects/defgeneric-method-combination-plus.lsp +++ /dev/null @@ -1,191 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat May 24 21:31:55 2003 -;;;; Contains: Tests of DEFGENERIC with :method-combination + - - - -(declaim (special *x*)) - -(compile-and-load "defgeneric-method-combination-aux.lsp") - -(deftest defgeneric-method-combination.+.1 - (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.plus.1 (x) - (:method-combination +) - (:method + ((x integer)) (car (push 8 *x*))) - (:method + ((x rational)) (car (push 4 *x*))) - (:method + ((x number)) (car (push 2 *x*))) - (:method + ((x t)) (car (push 1 *x*))))))) - (declare (type generic-function fn)) - (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) - (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) - (15 (1 2 4 8)) (7 (1 2 4)) (3 (1 2)) (1 (1))) - -(deftest defgeneric-method-combination.+.2 - (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.plus.2 (x) - (:method-combination + :most-specific-first) - (:method + ((x integer)) (car (push 8 *x*))) - (:method + ((x rational)) (car (push 4 *x*))) - (:method + ((x number)) (car (push 2 *x*))) - (:method + ((x t)) (car (push 1 *x*))))))) - (declare (type generic-function fn)) - (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) - (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) - (15 (1 2 4 8)) (7 (1 2 4)) (3 (1 2)) (1 (1))) - -(deftest defgeneric-method-combination.+.3 - (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.plus.3 (x) - (:method-combination + :most-specific-last) - (:method + ((x integer)) (car (push 8 *x*))) - (:method + ((x rational)) (car (push 4 *x*))) - (:method + ((x number)) (car (push 2 *x*))) - (:method + ((x t)) (car (push 1 *x*))))))) - (declare (type generic-function fn)) - (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) - (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) - (15 (8 4 2 1)) (7 (4 2 1)) (3 (2 1)) (1 (1))) - -(deftest defgeneric-method-combination.+.4 - (let ((fn - (eval '(defgeneric dg-mc.plus.4 (x) - (:method-combination +) - (:method + ((x integer)) 1) - (:method :around ((x rational)) 'foo) - (:method + ((x number)) 1) - (:method + ((x symbol)) 2) - (:method + ((x t)) 4))))) - (declare (type generic-function fn)) - (values - (funcall fn 0) - (funcall fn 4/3) - (funcall fn 1.54) - (funcall fn 'x) - (funcall fn '(a b c)))) - foo foo 5 6 4) - -(deftest defgeneric-method-combination.+.5 - (let ((fn - (eval '(defgeneric dg-mc.plus.5 (x) - (:method-combination +) - (:method + ((x integer)) 1) - (:method :around ((x rational)) - (list 'foo (call-next-method))) - (:method + ((x number)) 2) - (:method + ((x symbol)) 4) - (:method + ((x t)) 8))))) - (declare (type generic-function fn)) - (values - (funcall fn 0) - (funcall fn 4/3) - (funcall fn 1.54) - (funcall fn 'x) - (funcall fn '(a b c)))) - (foo 11) (foo 10) 10 12 8) - -(deftest defgeneric-method-combination.+.6 - (let ((fn - (eval '(defgeneric dg-mc.plus.6 (x) - (:method-combination +) - (:method + ((x integer)) 1) - (:method :around ((x rational)) - (list 'foo (call-next-method))) - (:method :around ((x real)) - (list 'bar (call-next-method))) - (:method + ((x number)) 2) - (:method + ((x symbol)) 4) - (:method + ((x t)) 8))))) - (declare (type generic-function fn)) - (values - (funcall fn 0) - (funcall fn 4/3) - (funcall fn 1.54) - (funcall fn #c(1.0 2.0)) - (funcall fn 'x) - (funcall fn '(a b c)))) - (foo (bar 11)) (foo (bar 10)) (bar 10) 10 12 8) - -(deftest defgeneric-method-combination.+.7 - (let ((fn - (eval '(defgeneric dg-mc.plus.7 (x) - (:method-combination +) - (:method + ((x dgmc-class-04)) 1) - (:method + ((x dgmc-class-03)) 2) - (:method + ((x dgmc-class-02)) 4) - (:method + ((x dgmc-class-01)) 8))))) - (declare (type generic-function fn)) - (values - (funcall fn (make-instance 'dgmc-class-01)) - (funcall fn (make-instance 'dgmc-class-02)) - (funcall fn (make-instance 'dgmc-class-03)) - (funcall fn (make-instance 'dgmc-class-04)))) - 8 12 10 15) - -(deftest defgeneric-method-combination.+.8 - (let ((fn - (eval '(defgeneric dg-mc.plus.8 (x) - (:method-combination +) - (:method + ((x (eql 1000))) 1) - (:method :around ((x symbol)) (values)) - (:method :around ((x integer)) (values 'a 'b 'c)) - (:method :around ((x complex)) (call-next-method)) - (:method :around ((x number)) (values 1 2 3 4 5 6)) - (:method + ((x t)) 1))))) - (declare (type generic-function fn)) - (values - (multiple-value-list (funcall fn 'a)) - (multiple-value-list (funcall fn 10)) - (multiple-value-list (funcall fn #c(9 8))) - (multiple-value-list (funcall fn '(a b c))))) - () (a b c) (1 2 3 4 5 6) (1)) - -(deftest defgeneric-method-combination.+.9 - (handler-case - (let ((fn (eval '(defgeneric dg-mc.+.9 (x) - (:method-combination +))))) - (declare (type generic-function fn)) - (funcall fn (list 'a))) - (error () :error)) - :error) - -(deftest defgeneric-method-combination.+.10 - (progn - (eval '(defgeneric dg-mc.+.10 (x) - (:method-combination +) - (:method ((x t)) 0))) - (handler-case - (dg-mc.+.10 'a) - (error () :error))) - :error) - -(deftest defgeneric-method-combination.+.11 - (progn - (eval '(defgeneric dg-mc.+.11 (x) - (:method-combination +) - (:method nonsense ((x t)) 0))) - (handler-case - (dg-mc.+.11 0) - (error () :error))) - :error) - -(deftest defgeneric-method-combination.+.12 - (let ((fn (eval '(defgeneric dg-mc.+.12 (x) - (:method-combination +) - (:method :around ((x t)) 1) - (:method + ((x integer)) x))))) - (declare (type generic-function fn)) - (handler-case (funcall fn 'a) - (error () :error))) - :error) - diff --git a/t/ansi-test/objects/defgeneric-method-combination-progn.lsp b/t/ansi-test/objects/defgeneric-method-combination-progn.lsp deleted file mode 100644 index 64293ea..0000000 --- a/t/ansi-test/objects/defgeneric-method-combination-progn.lsp +++ /dev/null @@ -1,276 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat May 24 21:31:55 2003 -;;;; Contains: Tests of DEFGENERIC with :method-combination OR - - - -(declaim (special *x*)) - -(compile-and-load "defgeneric-method-combination-aux.lsp") - -(deftest defgeneric-method-combination.progn.1 - (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.progn.1 (x) - (:method-combination progn) - (:method progn ((x integer)) (push 4 *x*) nil) - (:method progn ((x rational)) (push 3 *x*) nil) - (:method progn ((x number)) (push 2 *x*) nil) - (:method progn ((x t)) (push 1 *x*) 'a))))) - (declare (type generic-function fn)) - (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) - (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) - (a (1 2 3 4)) - (a (1 2 3)) - (a (1 2)) - (a (1))) - -(deftest defgeneric-method-combination.progn.2 - (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.progn.2 (x) - (:method-combination progn :most-specific-first) - (:method progn ((x integer)) (push 4 *x*) 'a) - (:method progn ((x rational)) (push 3 *x*) 'b) - (:method progn ((x number)) (push 2 *x*) 'c) - (:method progn ((x t)) (push 1 *x*) 'd))))) - (declare (type generic-function fn)) - (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) - (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) - (d (1 2 3 4)) - (d (1 2 3)) - (d (1 2)) - (d (1))) - -(deftest defgeneric-method-combination.progn.3 - (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.progn.3 (x) - (:method-combination progn :most-specific-last) - (:method progn ((x integer)) (push 4 *x*) 'a) - (:method progn ((x rational)) (push 3 *x*) 'b) - (:method progn ((x number)) (push 2 *x*) 'c) - (:method progn ((x t)) (push 1 *x*) 'd))))) - (declare (type generic-function fn)) - (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) - (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) - (a (4 3 2 1)) - (b (3 2 1)) - (c (2 1)) - (d (1))) - -(deftest defgeneric-method-combination.progn.4 - (let ((fn - (eval '(defgeneric dg-mc.progn.4 (x) - (:method-combination progn) - (:method progn ((x integer)) 'd) - (:method :around ((x rational)) 'foo) - (:method progn ((x number)) 'b) - (:method progn ((x symbol)) 'c) - (:method progn ((x t)) 'a))))) - (declare (type generic-function fn)) - (values - (funcall fn 0) - (funcall fn 4/3) - (funcall fn 1.54) - (funcall fn 'x) - (funcall fn '(a b c)))) - foo foo a a a) - -(deftest defgeneric-method-combination.progn.4a - (let ((fn - (eval '(defgeneric dg-mc.progn.4a (x) - (:method-combination progn :most-specific-last) - (:method progn ((x integer)) 'd) - (:method :around ((x rational)) 'foo) - (:method progn ((x number)) 'b) - (:method progn ((x symbol)) 'c) - (:method progn ((x t)) 'a))))) - (declare (type generic-function fn)) - (values - (funcall fn 0) - (funcall fn 4/3) - (funcall fn 1.54) - (funcall fn 'x) - (funcall fn '(a b c)))) - foo foo b c a) - -(deftest defgeneric-method-combination.progn.5 - (let ((fn - (eval '(defgeneric dg-mc.progn.5 (x) - (:method-combination progn) - (:method progn ((x integer)) 'a) - (:method :around ((x rational)) - (list 'foo (call-next-method))) - (:method progn ((x number)) nil) - (:method progn ((x symbol)) 'b) - (:method progn ((x t)) 'c))))) - (declare (type generic-function fn)) - (values - (funcall fn 0) - (funcall fn 4/3) - (funcall fn 1.54) - (funcall fn 'x) - (funcall fn '(a b c)))) - (foo c) (foo c) c c c) - -(deftest defgeneric-method-combination.progn.5a - (let ((fn - (eval '(defgeneric dg-mc.progn.5a (x) - (:method-combination progn :most-specific-last) - (:method progn ((x integer)) 'a) - (:method :around ((x rational)) - (list 'foo (call-next-method))) - (:method progn ((x number)) 'e) - (:method progn ((x symbol)) 'b) - (:method progn ((x t)) 'c))))) - (declare (type generic-function fn)) - (values - (funcall fn 0) - (funcall fn 4/3) - (funcall fn 1.54) - (funcall fn 'x) - (funcall fn '(a b c)))) - (foo a) (foo e) e b c) - - -(deftest defgeneric-method-combination.progn.6 - (let ((fn - (eval '(defgeneric dg-mc.progn.6 (x) - (:method-combination progn) - (:method progn ((x integer)) 'a) - (:method :around ((x rational)) - (list 'foo (call-next-method))) - (:method :around ((x real)) - (list 'bar (call-next-method))) - (:method progn ((x number)) 'b) - (:method progn ((x symbol)) 'c) - (:method progn ((x t)) 'd))))) - (declare (type generic-function fn)) - (values - (funcall fn 0) - (funcall fn 4/3) - (funcall fn 1.54) - (funcall fn #c(1.0 2.0)) - (funcall fn 'x) - (funcall fn '(a b c)))) - (foo (bar d)) (foo (bar d)) (bar d) d d d) - -(deftest defgeneric-method-combination.progn.6a - (let ((fn - (eval '(defgeneric dg-mc.progn.6a (x) - (:method-combination progn :most-specific-last) - (:method progn ((x integer)) 'a) - (:method :around ((x rational)) - (list 'foo (call-next-method))) - (:method :around ((x real)) - (list 'bar (call-next-method))) - (:method progn ((x number)) 'b) - (:method progn ((x symbol)) 'c) - (:method progn ((x t)) 'd))))) - (declare (type generic-function fn)) - (values - (funcall fn 0) - (funcall fn 4/3) - (funcall fn 1.54) - (funcall fn #c(1.0 2.0)) - (funcall fn 'x) - (funcall fn '(a b c)))) - (foo (bar a)) (foo (bar b)) (bar b) b c d) - - -(deftest defgeneric-method-combination.progn.7 - (let ((fn - (eval '(defgeneric dg-mc.progn.7 (x) - (:method-combination progn) - (:method progn ((x dgmc-class-04)) 'a) - (:method progn ((x dgmc-class-03)) 'b) - (:method progn ((x dgmc-class-02)) 'c) - (:method progn ((x dgmc-class-01)) 'd))))) - (declare (type generic-function fn)) - (values - (funcall fn (make-instance 'dgmc-class-01)) - (funcall fn (make-instance 'dgmc-class-02)) - (funcall fn (make-instance 'dgmc-class-03)) - (funcall fn (make-instance 'dgmc-class-04)))) - d d d d) - -(deftest defgeneric-method-combination.progn.7a - (let ((fn - (eval '(defgeneric dg-mc.progn.7a (x) - (:method-combination progn :most-specific-last) - (:method progn ((x dgmc-class-04)) 'a) - (:method progn ((x dgmc-class-03)) 'b) - (:method progn ((x dgmc-class-02)) 'c) - (:method progn ((x dgmc-class-01)) 'd))))) - (declare (type generic-function fn)) - (values - (funcall fn (make-instance 'dgmc-class-01)) - (funcall fn (make-instance 'dgmc-class-02)) - (funcall fn (make-instance 'dgmc-class-03)) - (funcall fn (make-instance 'dgmc-class-04)))) - d c b a) - -(deftest defgeneric-method-combination.progn.8 - (let ((fn - (eval '(defgeneric dg-mc.progn.8 (x) - (:method-combination progn) - (:method progn ((x (eql 1000))) 'a) - (:method :around ((x symbol)) (values)) - (:method :around ((x integer)) (values 'a 'b 'c)) - (:method :around ((x complex)) (call-next-method)) - (:method :around ((x number)) (values 1 2 3 4 5 6)) - (:method progn ((x t)) 'b))))) - (declare (type generic-function fn)) - (values - (multiple-value-list (funcall fn 'a)) - (multiple-value-list (funcall fn 10)) - (multiple-value-list (funcall fn #c(9 8))) - (multiple-value-list (funcall fn '(a b c))))) - () (a b c) (1 2 3 4 5 6) (b)) - -(deftest defgeneric-method-combination.progn.9 - (handler-case - (let ((fn (eval '(defgeneric dg-mc.progn.9 (x) - (:method-combination progn))))) - (declare (type generic-function fn)) - (funcall fn (list 'a))) - (error () :error)) - :error) - -(deftest defgeneric-method-combination.progn.10 - (progn - (eval '(defgeneric dg-mc.progn.10 (x) - (:method-combination progn) - (:method ((x t)) 0))) - (handler-case - (dg-mc.progn.10 'a) - (error () :error))) - :error) - -(deftest defgeneric-method-combination.progn.11 - (progn - (eval '(defgeneric dg-mc.progn.11 (x) - (:method-combination progn) - (:method nonsense ((x t)) 0))) - (handler-case - (dg-mc.progn.11 0) - (error () :error))) - :error) - -(deftest defgeneric-method-combination.progn.12 - (let ((fn (eval '(defgeneric dg-mc.progn.12 (x) - (:method-combination progn) - (:method :around ((x t)) 'a) - (:method progn ((x integer)) x))))) - (declare (type generic-function fn)) - (handler-case (funcall fn 'b) - (error () :error))) - :error) diff --git a/t/ansi-test/objects/defgeneric.lsp b/t/ansi-test/objects/defgeneric.lsp deleted file mode 100644 index 4faf5c1..0000000 --- a/t/ansi-test/objects/defgeneric.lsp +++ /dev/null @@ -1,854 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat May 17 20:55:50 2003 -;;;; Contains: Tests of DEFGENERIC - - - -;;; Various error cases - -(defun defgeneric-testfn-01 (x) x) - -(deftest defgeneric.error.1 - ;; Cannot make ordinary functions generic - (let* ((name 'defgeneric-testfn-01) - (fn (symbol-function name))) - (if (not (typep fn 'generic-function)) - (handler-case - (progn (eval `(defgeneric ,name ())) :bad) - (program-error () :good)) - :good)) - :good) - -(defmacro defgeneric-testmacro-02 (x) x) - -(deftest defgeneric.error.2 - ;; Cannot make macros generic - (let* ((name 'defgeneric-testmacro-02)) - (handler-case - (progn (eval `(defgeneric ,name ())) :bad) - (program-error () :good))) - :good) - -(deftest defgeneric.error.3 - ;; Cannot make special operators generic - (loop for name in *cl-special-operator-symbols* - for result = - (handler-case - (progn (eval `(defgeneric ,name ())) t) - (program-error () nil)) - when result collect name) - nil) - -(deftest defgeneric.error.4 - (signals-error (defgeneric defgeneric-error-fn.4 (x y) - (:argument-precedence-order x y x)) - program-error) - t) - -(deftest defgeneric.error.5 - (signals-error (defgeneric defgeneric-error-fn.5 (x) - (:documentation "some documentation") - (:documentation "illegally repeated documentation")) - program-error) - t) - -(deftest defgeneric.error.6 - (signals-error (defgeneric defgeneric-error-fn.6 (x) - (unknown-option nil)) - program-error) - t) - -(deftest defgeneric.error.7 - (handler-case - (progn - (eval '(defgeneric defgeneric-error-fn.7 (x y) - (:method ((x t)) x))) - :bad) - (error () :good)) - :good) - -(deftest defgeneric.error.8 - (signals-error (defgeneric defgeneric-error-fn.8 (x y) - (:argument-precedence-order x)) - program-error) - t) - - -;;; Non-congruent methods cause defgeneric to signal an error - -(deftest defgeneric.error.9 - (handler-case - (progn - (eval '(defgeneric defgeneric-error-fn.9 (x) - (:method ((x t)(y t)) t))) - :bad) - (error () :good)) - :good) - - -(deftest defgeneric.error.10 - (handler-case - (progn - (eval '(defgeneric defgeneric-error-fn.10 (x &optional y) - (:method ((x t)) t))) - :bad) - (error () :good)) - :good) - -(deftest defgeneric.error.11 - (handler-case - (progn - (eval '(defgeneric defgeneric-error-fn.11 (x &optional y) - (:method (x &optional y z) t))) - :bad) - (error () :good)) - :good) - -(deftest defgeneric.error.12 - (handler-case - (progn - (eval '(defgeneric defgeneric-error-fn.12 (x &rest y) - (:method (x) t))) - :bad) - (error () :good)) - :good) - -(deftest defgeneric.error.13 - (handler-case - (progn - (eval '(defgeneric defgeneric-error-fn.13 (x) - (:method (x &rest y) t))) - :bad) - (error () :good)) - :good) - -(deftest defgeneric.error.14 - (handler-case - (progn - (eval '(defgeneric defgeneric-error-fn.14 (x &key) - (:method (x) t))) - :bad) - (error () :good)) - :good) - -(deftest defgeneric.error.15 - (handler-case - (progn - (eval '(defgeneric defgeneric-error-fn.15 (x &key y) - (:method (x) t))) - :bad) - (error () :good)) - :good) - -(deftest defgeneric.error.16 - (handler-case - (progn - (eval '(defgeneric defgeneric-error-fn.16 (x) - (:method (x &key) t))) - :bad) - (error () :good)) - :good) - -(deftest defgeneric.error.17 - (handler-case - (progn - (eval '(defgeneric defgeneric-error-fn.17 (x) - (:method (x &key foo) t))) - :bad) - (error () :good)) - :good) - -(deftest defgeneric.error.18 - (handler-case - (progn - (eval '(defgeneric defgeneric-error-fn.18 (x &key foo) - (:method (x &key) t))) - :bad) - (error () :good)) - :good) - -(deftest defgeneric.error.19 - (handler-case - (progn - (eval '(defgeneric defgeneric-error-fn.19 (x &key foo) - (:method (x &key bar) t))) - :bad) - (error () :good)) - :good) - -;;; A close reading of the rules for keyword arguments to -;;; generic functions convinced me that the following two -;;; error tests are necessary. See sections 7.6.5 of the CLHS. - -(deftest defgeneric.error.20 - (signals-error - (let ((fn (defgeneric defgeneric-error-fn.20 (x &key) - (:method ((x number) &key foo) (list x foo)) - (:method ((x symbol) &key bar) (list x bar))))) - (funcall fn 1 :bar 'a)) - program-error) - t) - -(deftest defgeneric.error.21 - (signals-error - (let ((fn (defgeneric defgeneric-error-fn.21 (x &key) - (:method ((x number) &key foo &allow-other-keys) (list x foo)) - (:method ((x symbol) &key bar) (list x bar))))) - (funcall fn 'x :foo 'a)) - program-error) - t) - -;;; - -(deftest defgeneric.error.22 - (progn - (defgeneric defgeneric-error-fn.22 (x)) - (defmethod defgeneric-error-fn.22 ((x t)) nil) - (handler-case - (eval '(defgeneric defgeneric-error-fn.22 (x y))) - (error () :good))) - :good) - - -;;; Non error cases - -(deftest defgeneric.1 - (let ((fn (eval '(defgeneric defgeneric.fun.1 (x y z) - (:method ((x t) (y t) (z t)) (list x y z)))))) - (declare (type function fn)) - (values - (typep* fn 'generic-function) - (typep* fn 'standard-generic-function) - (funcall fn 'a 'b 'c) - (apply fn 1 2 3 nil) - (apply fn (list 4 5 6)) - (mapcar fn '(1 2) '(3 4) '(5 6)) - (defgeneric.fun.1 'd 'e 'f))) - t t (a b c) (1 2 3) (4 5 6) ((1 3 5) (2 4 6)) (d e f)) - -(deftest defgeneric.2 - (let ((fn (eval '(defgeneric defgeneric.fun.2 (x y z) - (:documentation "boo!") - (:method ((x t) (y t) (z t)) (vector x y z)))))) - (declare (type function fn)) - (values - (typep* fn 'generic-function) - (typep* fn 'standard-generic-function) - (funcall fn 'a 'b 'c) - (defgeneric.fun.2 'd 'e 'f) - (let ((doc (documentation fn t))) - (or (not doc) - (and (stringp doc) (string=t doc "boo!")))) - (let ((doc (documentation fn 'function))) - (or (not doc) - (and (stringp doc) (string=t doc "boo!")))) - (setf (documentation fn t) "foo") - (let ((doc (documentation fn t))) - (or (not doc) - (and (stringp doc) (string=t doc "foo")))) - (setf (documentation fn 'function) "bar") - (let ((doc (documentation fn t))) - (or (not doc) - (and (stringp doc) (string=t doc "bar")))))) - - t t #(a b c) #(d e f) t t "foo" t "bar" t) - -(deftest defgeneric.3 - (let ((fn (eval '(defgeneric defgeneric.fun.3 (x y) - (:method ((x t) (y symbol)) (list x y)) - (:method ((x symbol) (y t)) (list y x)))))) - (declare (type function fn)) - (values - (typep* fn 'generic-function) - (typep* fn 'standard-generic-function) - (funcall fn 1 'a) - (funcall fn 'b 2) - (funcall fn 'a 'b))) - t t - (1 a) - (2 b) - (b a)) - -(deftest defgeneric.4 - (let ((fn (eval '(defgeneric defgeneric.fun.4 (x y) - (:argument-precedence-order y x) - (:method ((x t) (y symbol)) (list x y)) - (:method ((x symbol) (y t)) (list y x)))))) - (declare (type function fn)) - (values - (typep* fn 'generic-function) - (typep* fn 'standard-generic-function) - (funcall fn 1 'a) - (funcall fn 'b 2) - (funcall fn 'a 'b))) - t t - (1 a) - (2 b) - (a b)) - -(deftest defgeneric.5 - (let ((fn (eval '(defgeneric defgeneric.fun.5 () - (:method () (values)))))) - (declare (type function fn)) - (values - (typep* fn 'generic-function) - (typep* fn 'standard-generic-function) - (multiple-value-list (funcall fn)) - (multiple-value-list (defgeneric.fun.5)) - (multiple-value-list (apply fn nil)))) - t t nil nil nil) - -(deftest defgeneric.6 - (let ((fn (eval '(defgeneric defgeneric.fun.6 () - (:method () (values 'a 'b 'c)))))) - (declare (type function fn)) - (values - (typep* fn 'generic-function) - (typep* fn 'standard-generic-function) - (multiple-value-list (funcall fn)) - (multiple-value-list (defgeneric.fun.6)) - (multiple-value-list (apply fn nil)))) - t t (a b c) (a b c) (a b c)) - -(deftest defgeneric.7 - (let ((fn (eval '(defgeneric defgeneric.fun.7 () - (:method () (return-from defgeneric.fun.7 'a) 'b))))) - (declare (type function fn)) - (values - (typep* fn 'generic-function) - (typep* fn 'standard-generic-function) - (multiple-value-list (funcall fn)) - (multiple-value-list (defgeneric.fun.7)) - (multiple-value-list (apply fn nil)))) - t t (a) (a) (a)) - -(deftest defgeneric.8 - (let ((fn (eval '(defgeneric defgeneric.fun.8 (x &optional y z) - (:method ((x number) &optional y z) - (list x y z)) - (:method ((p symbol) &optional q r) - (list r q p)))))) - (declare (type function fn)) - (values - (typep* fn 'generic-function) - (typep* fn 'standard-generic-function) - (multiple-value-list (funcall fn 1)) - (multiple-value-list (funcall fn 1 2)) - (multiple-value-list (funcall fn 1 2 3)) - (multiple-value-list (defgeneric.fun.8 'a)) - (multiple-value-list (defgeneric.fun.8 'a 'b)) - (multiple-value-list (defgeneric.fun.8 'a 'b 'c)) - (multiple-value-list (apply fn '(x y z))))) - t t - ((1 nil nil)) - ((1 2 nil)) - ((1 2 3)) - ((nil nil a)) - ((nil b a)) - ((c b a)) - ((z y x))) - -(deftest defgeneric.9 - (let ((fn (eval '(defgeneric defgeneric.fun.9 (x &optional y z) - (:method ((x number) &optional (y 10) (z 20)) - (list x y z)) - (:method ((p symbol) &optional (q 's) (r 't)) - (list r q p)))))) - (declare (type function fn)) - (values - (funcall fn 1) - (funcall fn 1 2) - (funcall fn 1 2 3) - (funcall fn 'a) - (funcall fn 'a 'b) - (funcall fn 'a 'b 'c))) - (1 10 20) - (1 2 20) - (1 2 3) - (t s a) - (t b a) - (c b a)) - - (deftest defgeneric.10 - (let ((fn (eval '(defgeneric defgeneric.fun.10 (x &rest y) - (:method ((x number) &key foo) (list x foo)))))) - (declare (type function fn)) - (values - (funcall fn 1) - (funcall fn 1 :foo 'a) - (defgeneric.fun.10 5/3 :foo 'x :foo 'y) - (defgeneric.fun.10 10 :bar t :allow-other-keys t) - (defgeneric.fun.10 20 :allow-other-keys nil :foo 'x))) - (1 nil) - (1 a) - (5/3 x) - (10 nil) - (20 x)) - - (deftest defgeneric.11 - (let ((fn (eval '(defgeneric defgeneric.fun.11 (x &key) - (:method ((x number) &key foo) (list x foo)))))) - (declare (type function fn)) - (values - (funcall fn 1) - (funcall fn 1 :foo 'a) - (defgeneric.fun.11 5/3 :foo 'x :foo 'y) - (defgeneric.fun.11 11 :bar t :allow-other-keys t) - (defgeneric.fun.11 20 :allow-other-keys nil :foo 'x))) - (1 nil) - (1 a) - (5/3 x) - (11 nil) - (20 x)) - - (deftest defgeneric.12 - (let ((fn (eval '(defgeneric defgeneric.fun.12 (x &key foo bar baz) - (:method ((x number) &rest y) (list x y)))))) - (declare (type function fn)) - (values - (funcall fn 1) - (funcall fn 1 :foo 'a) - (defgeneric.fun.12 5/3 :foo 'x :foo 'y :bar 'z) - (defgeneric.fun.12 11 :zzz t :allow-other-keys t) - (defgeneric.fun.12 20 :allow-other-keys nil :foo 'x))) - (1 nil) - (1 (:foo a)) - (5/3 (:foo x :foo y :bar z)) - (11 (:zzz t :allow-other-keys t)) - (20 (:allow-other-keys nil :foo x))) - - (deftest defgeneric.13 - (let ((fn (eval '(defgeneric defgeneric.fun.13 (x &key) - (:method ((x number) &key foo) (list x foo)) - (:method ((x symbol) &key bar) (list x bar)))))) - (declare (type function fn)) - (values - (funcall fn 1) - (funcall fn 'a) - (funcall fn 1 :foo 2) - ;; (funcall fn 1 :foo 2 :bar 3) - ;; (funcall fn 1 :bar 4) - ;; (funcall fn 'a :foo 'b) - (funcall fn 'a :bar 'b) - ;; (funcall fn 'a :foo 'c :bar 'b) - )) - (1 nil) - (a nil) - (1 2) - ;; (1 2) - ;; (1 nil) - ;; (a nil) - (a b) - ;; (a b) - ) - - (deftest defgeneric.14 - (let ((fn (eval '(defgeneric defgeneric.fun.14 (x &key &allow-other-keys) - (:method ((x number) &key foo) (list x foo)) - (:method ((x symbol) &key bar) (list x bar)))))) - (declare (type function fn)) - (values - (funcall fn 1) - (funcall fn 'a) - (funcall fn 1 :foo 2) - (funcall fn 1 :foo 2 :bar 3) - (funcall fn 1 :bar 4) - (funcall fn 'a :foo 'b) - (funcall fn 'a :bar 'b) - (funcall fn 'a :foo 'c :bar 'b) - (funcall fn 1 :baz 10) - (funcall fn 'a :baz 10) - (funcall fn 1 :allow-other-keys nil :baz 'a) - (funcall fn 'a :allow-other-keys nil :baz 'b) - )) - (1 nil) - (a nil) - (1 2) - (1 2) - (1 nil) - (a nil) - (a b) - (a b) - (1 nil) - (a nil) - (1 nil) - (a nil)) - - (deftest defgeneric.15 - (let ((fn (eval '(defgeneric defgeneric.fun.15 (x &key) - (:method ((x number) &key foo &allow-other-keys) - (list x foo)) - (:method ((x symbol) &key bar) (list x bar)))))) - (declare (type function fn)) - (values - (funcall fn 1) - (funcall fn 'a) - (funcall fn 1 :foo 2) - (funcall fn 1 :foo 2 :bar 3) - (funcall fn 1 :bar 4) - (funcall fn 'a :allow-other-keys t :foo 'b) - (funcall fn 'a :bar 'b) - (funcall fn 'a :foo 'c :bar 'b :allow-other-keys t) - (funcall fn 1 :baz 10) - ;; (funcall fn 'a :baz 10) - (funcall fn 1 :allow-other-keys nil :baz 'a) - ;; (funcall fn 'a :allow-other-keys nil :baz 'b) - )) - (1 nil) - (a nil) - (1 2) - (1 2) - (1 nil) - (a nil) - (a b) - (a b) - (1 nil) - ;; (a nil) - (1 nil) - ;; (a nil) - ) - - (deftest defgeneric.16 - (let ((fn (eval '(defgeneric defgeneric.fun.16 (x &key) - (:method ((x number) &key (foo 'a)) - (list x foo)) - (:method ((x symbol) &key foo) - (list x foo)))))) - (declare (type function fn)) - (values - (funcall fn 1) - (funcall fn 1 :foo nil) - (funcall fn 1 :foo 2) - (funcall fn 'x) - (funcall fn 'x :foo nil) - (funcall fn 'x :foo 'y))) - (1 a) - (1 nil) - (1 2) - (x nil) - (x nil) - (x y)) - - (deftest defgeneric.17 - (let ((fn (eval '(defgeneric defgeneric.fun.17 (x &key) - (:method ((x number) &key (foo 'a foo-p)) - (list x foo (notnot foo-p))) - (:method ((x symbol) &key foo) - (list x foo)))))) - (declare (type function fn)) - (values - (funcall fn 1) - (funcall fn 1 :foo nil) - (funcall fn 1 :foo 2) - (funcall fn 'x) - (funcall fn 'x :foo nil) - (funcall fn 'x :foo 'y))) - (1 a nil) - (1 nil t) - (1 2 t) - (x nil) - (x nil) - (x y)) - -(deftest defgeneric.18 - (let ((fn (eval '(defgeneric defgeneric.fun.18 (x &optional y) - (:method ((x number) &optional (y 'a)) - (list x y)) - (:method ((x symbol) &optional (z nil z-p)) - (list x z (notnot z-p))))))) - (declare (type function fn)) - (values - (funcall fn 1) - (funcall fn 1 nil) - (funcall fn 1 2) - (funcall fn 'x) - (funcall fn 'x nil) - (funcall fn 'x 'y))) - (1 a) - (1 nil) - (1 2) - (x nil nil) - (x nil t) - (x y t)) - - (deftest defgeneric.19 - (let ((fn (eval '(defgeneric defgeneric.fun.19 (x &key) - (:method ((x number) &key ((:bar foo) 'a foo-p)) - (list x foo (notnot foo-p))))))) - (declare (type function fn)) - (values - (funcall fn 1) - (funcall fn 1 :bar nil) - (funcall fn 1 :bar 2))) - (1 a nil) - (1 nil t) - (1 2 t)) - -(deftest defgeneric.20 - (let ((fn (eval '(defgeneric defgeneric.fun.20 (x &optional y z) - (:method ((x number) - &optional (y (1+ x) y-p) - (z (if y-p (1+ y) (+ x 10)) - z-p)) - (list x y (notnot y-p) z (notnot z-p))))))) - (declare (type function fn)) - (values - (funcall fn 1) - (funcall fn 1 5) - (funcall fn 1 5 9))) - (1 2 nil 11 nil) - (1 5 t 6 nil) - (1 5 t 9 t)) - -(deftest defgeneric.21 - (let ((fn (eval '(defgeneric defgeneric.fun.21 (x &key) - (:method ((x number) - &key (y (1+ x) y-p) - (z (if y-p (1+ y) (+ x 10)) - z-p)) - (list x y (notnot y-p) z (notnot z-p))))))) - (declare (type function fn)) - (values - (funcall fn 1) - (funcall fn 1 :y 5) - (funcall fn 1 :y 5 :z 9) - (funcall fn 1 :z 8) - (funcall fn 1 :z 8 :y 4))) - (1 2 nil 11 nil) - (1 5 t 6 nil) - (1 5 t 9 t) - (1 2 nil 8 t) - (1 4 t 8 t)) - -(deftest defgeneric.22 - (let ((fn (eval '(defgeneric defgeneric.fun.22 (x &key) - (:method ((x number) &key ((:allow-other-keys y))) - (list x y)))))) - (declare (type function fn)) - (values - (funcall fn 1) - (funcall fn 1 :allow-other-keys nil) - (funcall fn 1 :allow-other-keys t) - (funcall fn 1 :foo 'x :allow-other-keys t :bar 'y) - (funcall fn 1 :allow-other-keys t :foo 'x) - (funcall fn 1 :allow-other-keys nil :allow-other-keys t) - (funcall fn 1 :foo 'x :allow-other-keys t :allow-other-keys nil) - (funcall fn 1 :allow-other-keys t 'foo 'y :allow-other-keys nil) - (funcall fn 1 :allow-other-keys t :allow-other-keys nil '#:foo 'z))) - (1 nil) - (1 nil) - (1 t) - (1 t) - (1 t) - (1 nil) - (1 t) - (1 t) - (1 t)) - -(deftest defgeneric.23 - (let ((fn (eval '(defgeneric defgeneric.fun.23 (x) - (:method ((x number) &aux (y (1+ x))) (list x y)) - (:method ((x symbol) &aux (z (list x))) (list x z)))))) - (declare (type function fn)) - (values - (funcall fn 1) - (funcall fn 'a))) - (1 2) (a (a))) - - -(deftest defgeneric.24 - (let ((fn (eval '(defgeneric defgeneric.fun.24 (x) - (:method ((x number) &aux (y (1+ x)) (z (1+ y))) - (list x y z)) - (:method ((x symbol) &aux (y (list x)) (z (list x y))) - (list x y z)))))) - (values - (funcall fn 1) - (funcall fn 'a))) - (1 2 3) - (a (a) (a (a)))) - -(deftest defgeneric.25 - (let ((fn (eval '(defgeneric defgeneric.fun.25 (x &optional y &key) - (:method ((x symbol) &optional (y 'd y-p) - &key ((:foo bar) (list x y) bar-p) - &aux (z (list x y (notnot y-p) - bar (notnot bar-p)))) - z))))) - (declare (type function fn)) - (values - (funcall fn 'a) - (funcall fn 'a 'b) - (funcall fn 'a 'b :foo 'c))) - (a d nil (a d) nil) - (a b t (a b) nil) - (a b t c t)) - -(deftest defgeneric.26 - (let ((fn (eval '(defgeneric defgeneric.fun.26 (x) - (declare (optimize (safety 3))) - (:method ((x symbol)) x) - (declare (optimize (debug 3))))))) - (declare (type function fn)) - (funcall fn 'a)) - a) - -#| -(when (subtypep (class-of (find-class 'standard-method)) - 'standard-class) - (defclass substandard-method (standard-method) ()) - (deftest defgeneric.27 - (let ((fn (eval '(defgeneric defgeneric.fun.27 (x y) - (:method-class substandard-method) - (:method ((x number) (y number)) (+ x y)) - (:method ((x string) (y string)) - (concatenate 'string x y)))))) - (declare (type function fn)) - (values - (funcall fn 1 2) - (funcall fn "1" "2"))) - 3 "12")) -|# - -(deftest defgeneric.28 - (let ((fn (eval '(defgeneric defgeneric.fun.28 (x &key) - (:method ((x integer) &key foo) (list x foo)) - (:method ((x number) &key bar) (list x bar)) - (:method ((x t) &key baz) (list x baz)))))) - (declare (type function fn)) - (values - - (funcall fn 1) - (funcall fn 1 :foo 'a) - (funcall fn 1 :bar 'b) - (funcall fn 1 :baz 'c) - (funcall fn 1 :bar 'b :baz 'c) - (funcall fn 1 :foo 'a :bar 'b) - (funcall fn 1 :foo 'a :baz 'c) - (funcall fn 1 :foo 'a :bar 'b :baz 'c) - - (funcall fn 5/3) - (funcall fn 5/3 :bar 'b) - (funcall fn 5/3 :baz 'c) - (funcall fn 5/3 :bar 'b :baz 'c) - - (funcall fn 'x) - (funcall fn 'x :baz 'c) - - )) - - (1 nil) (1 a) (1 nil) (1 nil) - (1 nil) (1 a) (1 a) (1 a) - - (5/3 nil) (5/3 b) (5/3 nil) (5/3 b) - - (x nil) (x c)) - -(defclass defgeneric.29.class.1 () ()) -(defclass defgeneric.29.class.2 () ()) -(defclass defgeneric.29.class.3 - (defgeneric.29.class.1 defgeneric.29.class.2) - ()) - -(deftest defgeneric.29 - (let ((fn - (eval '(defgeneric defgeneric.fun.29 (x &key) - (:method ((x defgeneric.29.class.1) &key foo) foo) - (:method ((x defgeneric.29.class.2) &key bar) bar))))) - (declare (type function fn)) - (let ((x (make-instance 'defgeneric.29.class.3))) - (values - (funcall fn x) - (funcall fn x :foo 'a) - (funcall fn x :bar 'b) - (funcall fn x :foo 'a :bar 'b) - (funcall fn x :bar 'b :foo 'a)))) - nil a nil a a) - -;;; I'm not sure this one is proper -;;; Added :metaclass at prompting of Martin Simmons -(when (subtypep (class-of (find-class 'standard-generic-function)) - 'standard-class) - (defclass substandard-generic-function (standard-generic-function) () - (:metaclass #.(class-name (class-of - (find-class 'standard-generic-function))))) - (deftest defgeneric.30 - (let ((fn - (eval '(defgeneric defgeneric.fun.29 (x) - (:generic-function-class substandard-generic-function) - (:method ((x symbol)) 1) - (:method ((x integer)) 2))))) - (declare (type function fn)) - (values - (typep* fn 'substandard-generic-function) - (typep* fn 'standard-generic-function) - (typep* fn 'generic-function) - (typep* fn 'function) - (funcall fn 'a) - (funcall fn 1) - (defgeneric.fun.29 'x) - (defgeneric.fun.29 12345678901234567890))) - t t t t 1 2 1 2)) - -(deftest defgeneric.31 - (progn - (defgeneric defgeneric.fun.31 (x) (:method ((x t)) t)) - (defgeneric defgeneric.fun.31 (x y) (:method ((x t) (y t)) (list x y))) - (defgeneric.fun.31 'a 'b)) - (a b)) - -(deftest defgeneric.32 - (progn - (defgeneric defgeneric.fun.32 (x) (:method ((x symbol)) :bad)) - (defgeneric defgeneric.fun.32 (x) (:method ((x t)) :good)) - (defgeneric.fun.32 'x)) - :good) - -(deftest defgeneric.33 - (let ((fn - (eval - '(defgeneric (setf defgeneric.fun.33) (x y &rest args) - (:method (x (y cons) &rest args) - (assert (null args)) (setf (car y) x)) - (:method (x (y array) &rest args) - (setf (apply #'aref y args) x)))))) - (declare (type function fn)) - (values - (let ((z (list 'a 'b))) - (list - (setf (defgeneric.fun.33 z) 'c) - z)) - (let ((a (make-array '(10) :initial-element nil))) - (list - (setf (defgeneric.fun.33 a 5) 'd) - a)))) - (c (c b)) - (d #(nil nil nil nil nil d nil nil nil nil))) - -(deftest defgeneric.34 - (let ((fn (eval '(defgeneric #:defgeneric.fun.34 (x) - (:method ((x t)) (list x :good)))))) - (funcall fn 10)) - (10 :good)) - -(deftest defgeneric.35 - (let ((fn (eval '(defgeneric defgeneric.fun.35 (x) - (:method ((x (eql 'a))) - (declare (optimize (speed 0))) - "FOO" - (declare (optimize (safety 3))) - x))))) - (declare (type function fn)) - (values - (funcall fn 'a) - (let ((method (first (compute-applicable-methods fn '(a))))) - (and method - (let ((doc (documentation method t))) - (list - (or (null doc) (equalt doc "FOO")) - (setf (documentation method t) "BAR") - (let ((doc (documentation method t))) - (or (null doc) (equalt doc "BAR"))) - )))))) - a (t "BAR" t)) diff --git a/t/ansi-test/objects/define-method-combination-long-form.lsp b/t/ansi-test/objects/define-method-combination-long-form.lsp deleted file mode 100644 index a5c3e8c..0000000 --- a/t/ansi-test/objects/define-method-combination-long-form.lsp +++ /dev/null @@ -1,311 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jul 13 08:26:41 2003 -;;;; Contains: Tests of DEFINE-METHOD-COMBINATION (long form) - - - -(eval-when (:load-toplevel :compile-toplevel :execute) - (report-and-ignore-errors - (defparameter *dmc-long-01* - (define-method-combination mc-long-01 nil nil))) - (report-and-ignore-errors - (defgeneric dmc-long-gf-01 (x y) (:method-combination mc-long-01))) - ) - -(deftest define-method-combination-long.01.1 - (eqt *dmc-long-01* 'mc-long-01) - t) - -;;; The list of method groups specifiers for this method combination -;;; is empty, so no methods are valid. -(deftest define-method-combination-long.01.2 - (progn - (eval '(defmethod dmc-long-gf-01 ((x t) (y t)) :foo)) - (handler-case - (eval '(dmc-long-gf-01 'a 'b)) - (error () :caught))) - :caught) - -;;; A single method group with the * method group specifier - -(eval-when (:load-toplevel :compile-toplevel :execute) - (report-and-ignore-errors - (defparameter *dmc-long-02* - (define-method-combination mc-long-02 nil ((method-list *)) - `(vector ,@(mapcar #'(lambda (m) `(call-method ,m)) method-list))))) - (report-and-ignore-errors - (defgeneric dmc-long-gf-02 (x y) (:method-combination mc-long-02))) - ) - -(deftest define-method-combination-long.02.1 - (eqt *dmc-long-02* 'mc-long-02) - t) - -(deftest define-method-combination-long.02.2 - (progn - (eval '(defmethod dmc-long-gf-02 ((x (eql 1)) (y integer)) 'a)) - (eval '(defmethod dmc-long-gf-02 ((x integer) (y (eql 2))) 'b)) - (eval '(defmethod dmc-long-gf-02 ((x integer) (y integer)) 'z)) - (values - (dmc-long-gf-02 0 0) - (dmc-long-gf-02 1 0) - (dmc-long-gf-02 0 2) - (dmc-long-gf-02 1 2))) - #(z) #(a z) #(b z) #(a b z)) - -(deftest define-method-combination-long.02.3 - (signals-error (dmc-long-gf-02 nil nil) error) - t) - -;;; Same, but with :order parameter. -;;; Also, :description with a format string - -(eval-when (:load-toplevel :compile-toplevel :execute) - (report-and-ignore-errors - (defparameter *dmc-long-03* - (define-method-combination mc-long-03 nil ((method-list * :order :most-specific-first - :description "This method has qualifiers ~A" - )) - `(vector ,@(mapcar #'(lambda (m) `(call-method ,m)) method-list))))) - (report-and-ignore-errors - (defgeneric dmc-long-gf-03 (x y) (:method-combination mc-long-03))) - ) - -(deftest define-method-combination-long.03.1 - (eqt *dmc-long-03* 'mc-long-03) - t) - -(deftest define-method-combination-long.03.2 - (progn - (eval '(defmethod dmc-long-gf-03 ((x (eql 1)) (y integer)) 'a)) - (eval '(defmethod dmc-long-gf-03 ((x integer) (y (eql 2))) 'b)) - (eval '(defmethod dmc-long-gf-03 ((x integer) (y integer)) 'z)) - (values - (dmc-long-gf-03 0 0) - (dmc-long-gf-03 1 0) - (dmc-long-gf-03 0 2) - (dmc-long-gf-03 1 2))) - #(z) #(a z) #(b z) #(a b z)) - -(deftest define-method-combination-long.03.3 - (signals-error (dmc-long-gf-03 nil nil) error) - t) - -;;; Same, but with :order parameter :most-specific-last -;;; (and testing that the :order parameter is evaluated) - -(eval-when (:load-toplevel :compile-toplevel :execute) - (report-and-ignore-errors - (defparameter *dmc-long-04* - (let ((order :most-specific-last)) - (define-method-combination mc-long-04 nil ((method-list * :order order)) - `(vector ,@(mapcar #'(lambda (m) `(call-method ,m)) method-list)))))) - (report-and-ignore-errors - (defgeneric dmc-long-gf-04 (x y) (:method-combination mc-long-04))) - ) - -(deftest define-method-combination-long.04.1 - (eqt *dmc-long-04* 'mc-long-04) - t) - -(deftest define-method-combination-long.04.2 - (progn - (eval '(defmethod dmc-long-gf-04 ((x (eql 1)) (y integer)) 'a)) - (eval '(defmethod dmc-long-gf-04 ((x integer) (y (eql 2))) 'b)) - (eval '(defmethod dmc-long-gf-04 ((x integer) (y integer)) 'z)) - (values - (dmc-long-gf-04 0 0) - (dmc-long-gf-04 1 0) - (dmc-long-gf-04 0 2) - (dmc-long-gf-04 1 2))) - #(z) #(z a) #(z b) #(z b a)) - -(deftest define-method-combination-long.04.3 - (signals-error (dmc-long-gf-04 nil nil) error) - t) - -;;; Empty qualifier list - -(eval-when (:load-toplevel :compile-toplevel :execute) - (report-and-ignore-errors - (defparameter *dmc-long-05* - (define-method-combination mc-long-05 nil ((method-list nil) - (ignored-methods *)) - (declare (ignorable ignored-methods)) - `(vector ,@(mapcar #'(lambda (m) `(call-method ,m)) method-list))))) - (report-and-ignore-errors - (defgeneric dmc-long-gf-05 (x y) (:method-combination mc-long-05))) - ) - -(deftest define-method-combination-long.05.1 - (eqt *dmc-long-05* 'mc-long-05) - t) - -(deftest define-method-combination-long.05.2 - (progn - (eval '(defmethod dmc-long-gf-05 ((x (eql 1)) (y integer)) 'a)) - (eval '(defmethod dmc-long-gf-05 ((x integer) (y (eql 2))) 'b)) - (eval '(defmethod dmc-long-gf-05 ((x integer) (y integer)) 'z)) - (eval '(defmethod dmc-long-gf-05 foo ((x t) (y t)) 'bad)) - (values - (dmc-long-gf-05 nil nil) - (dmc-long-gf-05 0 0) - (dmc-long-gf-05 1 0) - (dmc-long-gf-05 0 2) - (dmc-long-gf-05 1 2))) - #() #(z) #(a z) #(b z) #(a b z)) - -;;; :required - -(eval-when (:load-toplevel :compile-toplevel :execute) - (report-and-ignore-errors - (defparameter *dmc-long-06* - (define-method-combination mc-long-06 nil ((method-list nil :required t) - (ignored-methods *)) - (declare (ignorable ignored-methods)) - `(vector ,@(mapcar #'(lambda (m) `(call-method ,m)) method-list))))) - (report-and-ignore-errors - (defgeneric dmc-long-gf-06 (x y) (:method-combination mc-long-06))) - ) - -(deftest define-method-combination-long.06.1 - (eqt *dmc-long-06* 'mc-long-06) - t) - -(deftest define-method-combination-long.06.2 - (progn - (eval '(defmethod dmc-long-gf-06 ((x (eql 1)) (y integer)) 'a)) - (eval '(defmethod dmc-long-gf-06 ((x integer) (y (eql 2))) 'b)) - (eval '(defmethod dmc-long-gf-06 ((x integer) (y integer)) 'z)) - (eval '(defmethod dmc-long-gf-06 foo ((x t) (y t)) 'bad)) - (values - (dmc-long-gf-06 0 0) - (dmc-long-gf-06 1 0) - (dmc-long-gf-06 0 2) - (dmc-long-gf-06 1 2))) - #(z) #(a z) #(b z) #(a b z)) - -(deftest define-method-combination-long.06.3 - (signals-error-always (dmc-long-gf-06 nil nil) error) - t t) - - -;;; Non-empty lambda lists - -(eval-when (:load-toplevel :compile-toplevel :execute) - (report-and-ignore-errors - (defparameter *dmc-long-07* - (define-method-combination mc-long-07 (p1 p2) ((method-list *)) - `(vector ',p1 ',p2 ,@(mapcar #'(lambda (m) `(call-method ,m)) method-list))))) - (report-and-ignore-errors - (defgeneric dmc-long-gf-07 (x y) (:method-combination mc-long-07 1 2))) - ) - -(deftest define-method-combination-long.07.1 - (eqt *dmc-long-07* 'mc-long-07) - t) - -(deftest define-method-combination-long.07.2 - (progn - (eval '(defmethod dmc-long-gf-07 ((x (eql 1)) (y integer)) 'a)) - (eval '(defmethod dmc-long-gf-07 ((x integer) (y (eql 2))) 'b)) - (eval '(defmethod dmc-long-gf-07 ((x integer) (y integer)) 'z)) - (values - (dmc-long-gf-07 0 0) - (dmc-long-gf-07 1 0) - (dmc-long-gf-07 0 2) - (dmc-long-gf-07 1 2))) - #(1 2 z) #(1 2 a z) #(1 2 b z) #(1 2 a b z)) - -(deftest define-method-combination-long.07.3 - (signals-error (dmc-long-gf-07 nil) error) - t) - -(eval-when (:load-toplevel :compile-toplevel :execute) - (report-and-ignore-errors - (defparameter *dmc-long-08* - (define-method-combination mc-long-08 (p1 &optional p2 p3) ((method-list *)) - `(vector ',p1 ',p2 ',p3 ,@(mapcar #'(lambda (m) `(call-method ,m)) method-list))))) - (report-and-ignore-errors - (defgeneric dmc-long-gf-08 (x y) (:method-combination mc-long-08 1 2))) - ) - -(deftest define-method-combination-long.08.1 - (eqt *dmc-long-08* 'mc-long-08) - t) - -(deftest define-method-combination-long.08.2 - (progn - (eval '(defmethod dmc-long-gf-08 ((x (eql 1)) (y integer)) 'a)) - (eval '(defmethod dmc-long-gf-08 ((x integer) (y (eql 2))) 'b)) - (eval '(defmethod dmc-long-gf-08 ((x integer) (y integer)) 'z)) - (values - (dmc-long-gf-08 0 0) - (dmc-long-gf-08 1 0) - (dmc-long-gf-08 0 2) - (dmc-long-gf-08 1 2))) - #(1 2 nil z) #(1 2 nil a z) #(1 2 nil b z) #(1 2 nil a b z)) - -(deftest define-method-combination-long.08.3 - (signals-error (dmc-long-gf-08 nil) error) - t) - -(eval-when (:load-toplevel :compile-toplevel :execute) - (report-and-ignore-errors - (defparameter *dmc-long-09* - (define-method-combination mc-long-09 (p1 &key p2 p3) ((method-list *)) - `(vector ',p1 ',p2 ',p3 ,@(mapcar #'(lambda (m) `(call-method ,m)) method-list))))) - (report-and-ignore-errors - (defgeneric dmc-long-gf-09 (x y) (:method-combination mc-long-09 1 :p3 3))) - ) - -(deftest define-method-combination-long.09.1 - (eqt *dmc-long-09* 'mc-long-09) - t) - -(deftest define-method-combination-long.09.2 - (progn - (eval '(defmethod dmc-long-gf-09 ((x (eql 1)) (y integer)) 'a)) - (eval '(defmethod dmc-long-gf-09 ((x integer) (y (eql 2))) 'b)) - (eval '(defmethod dmc-long-gf-09 ((x integer) (y integer)) 'z)) - (values - (dmc-long-gf-09 0 0) - (dmc-long-gf-09 1 0) - (dmc-long-gf-09 0 2) - (dmc-long-gf-09 1 2))) - #(1 nil 3 z) #(1 nil 3 a z) #(1 nil 3 b z) #(1 nil 3 a b z)) - -(deftest define-method-combination-long.09.3 - (signals-error (dmc-long-gf-09 nil) error) - t) - -(eval-when (:load-toplevel :compile-toplevel :execute) - (report-and-ignore-errors - (defparameter *dmc-long-10* - (define-method-combination mc-long-10 (p1 &rest p2) ((method-list *)) - `(vector ',p1 ',p2 ,@(mapcar #'(lambda (m) `(call-method ,m)) method-list))))) - (report-and-ignore-errors - (defgeneric dmc-long-gf-10 (x y) (:method-combination mc-long-10 1 2 3 4))) - ) - -(deftest define-method-combination-long.10.1 - (eqt *dmc-long-10* 'mc-long-10) - t) - -(deftest define-method-combination-long.10.2 - (progn - (eval '(defmethod dmc-long-gf-10 ((x (eql 1)) (y integer)) 'a)) - (eval '(defmethod dmc-long-gf-10 ((x integer) (y (eql 2))) 'b)) - (eval '(defmethod dmc-long-gf-10 ((x integer) (y integer)) 'z)) - (values - (dmc-long-gf-10 0 0) - (dmc-long-gf-10 1 0) - (dmc-long-gf-10 0 2) - (dmc-long-gf-10 1 2))) - #(1 (2 3 4) z) #(1 (2 3 4) a z) #(1 (2 3 4) b z) #(1 (2 3 4) a b z)) - -(deftest define-method-combination-long.10.3 - (signals-error (dmc-long-gf-10 nil) error) - t) - diff --git a/t/ansi-test/objects/define-method-combination.lsp b/t/ansi-test/objects/define-method-combination.lsp deleted file mode 100644 index fa6c67f..0000000 --- a/t/ansi-test/objects/define-method-combination.lsp +++ /dev/null @@ -1,181 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jun 15 10:49:39 2003 -;;;; Contains: Tests of DEFINE-METHOD-COMBINATION - - - -(defclass dmc-class-01a () ()) -(defclass dmc-class-01b (dmc-class-01a) ()) -(defclass dmc-class-01c (dmc-class-01a) ()) -(defclass dmc-class-01d (dmc-class-01b dmc-class-01c) ()) -(defclass dmc-class-01e (dmc-class-01c dmc-class-01b) ()) -(defclass dmc-class-01f (dmc-class-01d) ()) -(defclass dmc-class-01g (dmc-class-01a) ()) -(defclass dmc-class-01h (dmc-class-01f dmc-class-01g) ()) - -(eval-when (:load-toplevel :compile-toplevel :execute) - (report-and-ignore-errors - (defvar *dmc-times* - (define-method-combination times - :documentation "Multiplicative method combination, version 1" - :operator *)) - - (defgeneric dmc-gf-01 (x) (:method-combination times)) - - (defmethod dmc-gf-01 times ((x integer)) 2) - (defmethod dmc-gf-01 times ((x rational)) 3) - (defmethod dmc-gf-01 times ((x real)) 5) - (defmethod dmc-gf-01 times ((x number)) 7) - (defmethod dmc-gf-01 times ((x complex)) 11) - )) - -(deftest define-method-combination-01.1 - (values - (dmc-gf-01 1) - (dmc-gf-01 1/2) - (dmc-gf-01 1.0) - (dmc-gf-01 #c(1 2))) - 210 105 35 77) - -(deftest define-method-combination-01.2 - (handler-case - (eval '(locally (declare (optimize (safety 3))) - (dmc-gf-01 'x))) - (error () :good)) - :good) - -(deftest define-method-combination-01.3 - *dmc-times* - times) - -(deftest define-method-combination-01.4 - (let ((doc (documentation *dmc-times* 'method-combination))) - (or (null doc) - (equalt doc "Multiplicative method combination, version 1"))) - t) - -(eval-when (:load-toplevel :compile-toplevel :execute) - (report-and-ignore-errors - (defgeneric dmc-gf-02 (x) (:method-combination times)) - - (defmethod dmc-gf-02 times ((x integer)) 2) - (defmethod dmc-gf-02 :around ((x rational)) (1- (call-next-method))) - (defmethod dmc-gf-02 times ((x real)) 3) - (defmethod dmc-gf-02 times ((x number)) 5) - (defmethod dmc-gf-02 :around ((x (eql 1.0s0))) 1) - )) - -(deftest define-method-combination-02.1 - (values - (dmc-gf-02 1) - (dmc-gf-02 1/3) - (dmc-gf-02 1.0s0) - (dmc-gf-02 13.0) - (dmc-gf-02 #c(1 2))) - 29 14 1 15 5) - -(eval-when (:load-toplevel :compile-toplevel :execute) - (report-and-ignore-errors - (defgeneric dmc-gf-03 (x) (:method-combination times)))) - -(deftest define-method-combination-03.1 - (prog1 - (handler-case - (progn - (eval '(defmethod dmc-gf-03 ((x integer)) t)) - (eval '(dmc-gf-03 1)) - :bad) - (error () :good)) - (dolist (meth (compute-applicable-methods #'dmc-gf-03 (list 1))) - (remove-method #'dmc-gf-03 meth))) - :good) - -(deftest define-method-combination-03.2 - (prog1 - (handler-case - (progn - (eval '(defmethod dmc-gf-03 :before ((x cons)) t)) - (eval '(dmc-gf-03 (cons 'a 'b))) - :bad) - (error () :good)) - (dolist (meth (compute-applicable-methods #'dmc-gf-03 (list '(a)))) - (remove-method #'dmc-gf-03 meth))) - :good) - -(deftest define-method-combination-03.3 - (prog1 - (handler-case - (progn - (eval '(defmethod dmc-gf-03 :after ((x symbol)) t)) - (eval '(dmc-gf-03 'a)) - :bad) - (error () :good)) - (dolist (meth (compute-applicable-methods #'dmc-gf-03 (list 'a))) - (remove-method #'dmc-gf-03 meth))) - :good) - -(eval-when (:load-toplevel :compile-toplevel :execute) - (report-and-ignore-errors - (define-method-combination times2 - :operator * - :identity-with-one-argument t) - - (defgeneric dmc-gf-04 (x) (:method-combination times2)) - - (defmethod dmc-gf-04 times2 ((x dmc-class-01b)) 2) - (defmethod dmc-gf-04 times2 ((x dmc-class-01c)) 3) - (defmethod dmc-gf-04 times2 ((x dmc-class-01d)) 5) - (defmethod dmc-gf-04 times2 ((x symbol)) nil) - )) - -(deftest define-method-combination-04.1 - (dmc-gf-04 (make-instance 'dmc-class-01h)) - 30) - -(deftest define-method-combination-04.2 - (dmc-gf-04 (make-instance 'dmc-class-01e)) - 6) - -(deftest define-method-combination-04.3 - (dmc-gf-04 'a) - nil) - -(eval-when (:load-toplevel :compile-toplevel :execute) - (report-and-ignore-errors - (defvar *dmc-times-5* - (define-method-combination times-5 :operator *)))) - -(deftest define-method-combination-05.1 - (let* ((doc1 (setf (documentation *dmc-times-5* 'method-combination) - "foo")) - (doc2 (documentation *dmc-times-5* 'method-combination))) - (values - doc1 - (or (null doc2) - (equalt doc2 "foo")))) - "foo" t) - -;; Operator name defaults to the method combination name. - -(eval-when (:load-toplevel :compile-toplevel :execute) - (defun times-7 (&rest args) (apply #'* args)) - (report-and-ignore-errors - (defvar *dmc-times-7* - (define-method-combination times-7)) - (defgeneric dmc-gf-07 (x) (:method-combination times)) - - (defmethod dmc-gf-07 times ((x integer)) 2) - (defmethod dmc-gf-07 times ((x rational)) 3) - (defmethod dmc-gf-07 times ((x real)) 5) - (defmethod dmc-gf-07 times ((x number)) 7) - (defmethod dmc-gf-07 times ((x complex)) 11) - )) - -(deftest define-method-combination-07.1 - (values - (dmc-gf-07 1) - (dmc-gf-07 1/2) - (dmc-gf-07 1.0) - (dmc-gf-07 #c(1 2))) - 210 105 35 77) diff --git a/t/ansi-test/objects/defmethod.lsp b/t/ansi-test/objects/defmethod.lsp deleted file mode 100644 index afde883..0000000 --- a/t/ansi-test/objects/defmethod.lsp +++ /dev/null @@ -1,230 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Jun 9 07:02:53 2005 -;;;; Contains: Separate tests for DEFMETHOD - - - -(deftest defmethod.1 - (let ((sym (gensym))) - (values - (typep* (eval `(defmethod ,sym (x) (list x))) 'standard-method) - (typep* (fdefinition sym) 'standard-generic-function) - (funcall sym 1))) - t t (1)) - -(deftest defmethod.2 - (let* ((sym (gensym)) - (method - (eval `(defmethod ,sym ((x integer)) (list x))))) - (values - (typep* method 'standard-method) - (typep* (fdefinition sym) 'standard-generic-function) - (funcall sym 1))) - t t (1)) - -(deftest defmethod.3 - (let* ((sym (gensym)) - (method - (eval `(let ((x 0)) (defmethod ,sym ((x (eql (incf x)))) (list x)))))) - (values - (typep* method 'standard-method) - (typep* (fdefinition sym) 'standard-generic-function) - (funcall sym 1) - (funcall sym 1))) - t t (1) (1)) - -(deftest defmethod.4 - (let* ((sym (gensym)) - (method - (eval `(defmethod (setf ,sym) ((x t) (y cons)) (setf (car y) x))))) - (values - (typep* method 'standard-method) - (fboundp sym) - (typep* (fdefinition `(setf ,sym)) 'standard-generic-function) - (let ((x (cons 1 2))) (list (funcall (fdefinition `(setf ,sym)) 3 x) x)))) - t nil t (3 (3 . 2))) - -(deftest defmethod.5 - (let* ((sym (gensym)) - (method - (eval `(defmethod ,sym ((x integer)) (return-from ,sym (list x)))))) - (values - (typep* method 'standard-method) - (typep* (fdefinition sym) 'standard-generic-function) - (funcall sym 1))) - t t (1)) - -(deftest defmethod.6 - (let* ((sym (gensym)) - (method - (eval `(defmethod (setf ,sym) ((x t) (y cons)) (return-from ,sym (setf (car y) x)))))) - (values - (typep* method 'standard-method) - (fboundp sym) - (typep* (fdefinition `(setf ,sym)) 'standard-generic-function) - (let ((x (cons 1 2))) (list (funcall (fdefinition `(setf ,sym)) 3 x) x)))) - t nil t (3 (3 . 2))) - -(deftest defmethod.7 - (let* ((sym (gensym)) - (method - (eval `(defmethod ,sym ((x integer) &aux (y (list x))) y)))) - (values - (typep* method 'standard-method) - (typep* (fdefinition sym) 'standard-generic-function) - (funcall sym 1))) - t t (1)) - -(deftest defmethod.8 - (let* ((sym (gensym)) - (method (eval `(defmethod ,sym ((x integer) &key z) (list x z))))) - (values - (typep* method 'standard-method) - (typep* (fdefinition sym) 'standard-generic-function) - (funcall sym 1) - (funcall sym 2 :z 3) - (funcall sym 4 :allow-other-keys nil) - (funcall sym 5 :allow-other-keys t :bogus 17) - (funcall sym 6 :allow-other-keys t :allow-other-keys nil :bogus 17) - )) - t t (1 nil) (2 3) (4 nil) (5 nil) (6 nil)) - -(deftest defmethod.9 - (let* ((sym (gensym)) - (method (eval `(defmethod ,sym ((x integer) &key (z :missing)) (list x z))))) - (values - (typep* method 'standard-method) - (typep* (fdefinition sym) 'standard-generic-function) - (funcall sym 1) - (funcall sym 2 :z 3) - (funcall sym 4 :allow-other-keys nil) - )) - t t (1 :missing) (2 3) (4 :missing)) - -(deftest defmethod.10 - (let* ((sym (gensym)) - (method (eval `(defmethod ,sym ((x integer) &key (z :missing z-p)) (list x z (notnot z-p)))))) - (values - (typep* method 'standard-method) - (typep* (fdefinition sym) 'standard-generic-function) - (funcall sym 1) - (funcall sym 2 :z 3) - (funcall sym 4 :allow-other-keys nil) - )) - t t (1 :missing nil) (2 3 t) (4 :missing nil)) - -(deftest defmethod.11 - (let* ((sym (gensym)) - (method (eval `(defmethod ,sym ((x integer) &rest z) (list x z))))) - (values - (typep* method 'standard-method) - (typep* (fdefinition sym) 'standard-generic-function) - (funcall sym 1) - (funcall sym 2 3) - )) - t t (1 nil) (2 (3))) - -;;; Error cases - -;;; Lambda liss not congruent - -(deftest defmethod.error.1 - (let ((sym (gensym))) - (eval `(defgeneric ,sym (x y))) - (eval `(signals-error (defmethod ,sym ((x t)) x) error))) - t) - -(deftest defmethod.error.2 - (let ((sym (gensym))) - (eval `(defgeneric ,sym (x y))) - (eval `(signals-error (defmethod ,sym ((x t) (y t) (z t)) (list x y z)) error))) - t) - -(deftest defmethod.error.3 - (let ((sym (gensym))) - (eval `(defgeneric ,sym (x y &optional z))) - (eval `(signals-error (defmethod ,sym ((x t) (y t) (z t)) (list x y z)) error))) - t) - -(deftest defmethod.error.4 - (let ((sym (gensym))) - (eval `(defgeneric ,sym (x y &optional z))) - (eval `(signals-error (defmethod ,sym ((x t) (y t) &optional) (list x y)) error))) - t) - -(deftest defmethod.error.5 - (let ((sym (gensym))) - (eval `(defgeneric ,sym (x y &optional z))) - (eval `(signals-error (defmethod ,sym ((x t) (y t) &optional z w) (list x y z w)) error))) - t) - -(deftest defmethod.error.6 - (let ((sym (gensym))) - (eval `(defgeneric ,sym (x &rest z))) - (eval `(signals-error (defmethod ,sym ((x t)) (list x)) error))) - t) - -(deftest defmethod.error.7 - (let ((sym (gensym))) - (eval `(defgeneric ,sym (x))) - (eval `(signals-error (defmethod ,sym ((x t) &rest z) (list x z)) error))) - t) - -(deftest defmethod.error.8 - (let ((sym (gensym))) - (eval `(defgeneric ,sym (x &key z))) - (eval `(signals-error (defmethod ,sym ((x t)) (list x)) error))) - t) - -(deftest defmethod.error.9 - (let ((sym (gensym))) - (eval `(defgeneric ,sym (x))) - (eval `(signals-error (defmethod ,sym ((x t) &key z) (list x z)) error))) - t) - -(deftest defmethod.error.10 - (let ((sym (gensym))) - (eval `(defgeneric ,sym (x &key z))) - (eval `(signals-error (defmethod ,sym ((x t) &key) x) error))) - t) - -(deftest defmethod.error.11 - (let ((sym (gensym))) - (eval `(defgeneric ,sym (x &key))) - (eval `(signals-error (defmethod ,sym ((x t)) x) error))) - t) - -(deftest defmethod.error.12 - (let ((sym (gensym))) - (eval `(defgeneric ,sym (x))) - (eval `(signals-error (defmethod ,sym ((x t) &key) x) error))) - t) - -;;; Calling the implicitly defined generic function - -(deftest defmethod.error.13 - (let ((sym (gensym))) - (eval `(locally (declare (optimize safety)) (defmethod ,sym ((x t)) x))) - (values (eval `(signals-error (,sym) program-error)) - (eval `(signals-error (,sym 1 2) program-error)))) - t t) - -(deftest defmethod.error.14 - (let ((sym (gensym))) - (eval `(locally (declare (optimize safety)) (defmethod ,sym ((x t) &key) x))) - (values (eval `(signals-error (,sym) program-error)) - (eval `(signals-error (,sym 1 2) program-error)) - (eval `(signals-error (,sym 1 :bogus t) program-error)) - (eval `(signals-error (,sym 1 :allow-other-keys nil :allow-other-keys t :bogus t) program-error)))) - t t t t) - -(deftest defmethod.error.15 - (let ((sym (gensym))) - (eval `(locally (declare (optimize safety)) (defmethod ,sym ((x t) &key y) x))) - (values (eval `(signals-error (,sym 1 :bogus t) program-error)) - (eval `(signals-error (,sym 1 :y) program-error)) - (eval `(signals-error (,sym 1 3 nil) program-error)))) - t t t) - - diff --git a/t/ansi-test/objects/ensure-generic-function.lsp b/t/ansi-test/objects/ensure-generic-function.lsp deleted file mode 100644 index 0c21da7..0000000 --- a/t/ansi-test/objects/ensure-generic-function.lsp +++ /dev/null @@ -1,195 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Mar 27 21:29:53 2003 -;;;; Contains: Tests for ENSURE-GENERIC-FUNCTION - - - -(deftest ensure-generic-function.1 - (if (typep #'car 'generic-function) - t - (signals-error (ensure-generic-function 'car) error)) - t) - -(deftest ensure-generic-function.2 - (signals-error (ensure-generic-function 'defclass) error) - t) - -(deftest ensure-generic-function.3 - (signals-error (ensure-generic-function 'tagbody) error) - t) - -(deftest ensure-generic-function.4 - (let ((f 'egf-fun-4)) - (when (fboundp f) (fmakunbound f)) - (values - (fboundp f) - (notnot-mv (typep (ensure-generic-function f) 'generic-function)) - (notnot-mv (typep (ensure-generic-function f) 'generic-function)) - (notnot-mv (typep (symbol-function f) 'generic-function)))) - nil t t t) - -(deftest ensure-generic-function.5 - (let ((f 'egf-fun-5)) - (when (fboundp f) (fmakunbound f)) - (values - (fboundp f) - (notnot-mv (typep (ensure-generic-function f :lambda-list '(a b c)) - 'generic-function)) - ;; Test of incongruent generic function lambda list when no - ;; methods exist - (notnot-mv (typep (ensure-generic-function f :lambda-list '(x y)) - 'generic-function)) - (notnot-mv (typep (symbol-function f) 'generic-function)))) - nil t t t) - -(deftest ensure-generic-function.6 - (let ((f 'egf-fun-6)) - (when (fboundp f) (fmakunbound f)) - (values - (fboundp f) - (notnot-mv (typep (ensure-generic-function f :lambda-list '(a b c)) - 'generic-function)) - (notnot-mv (eval `(defmethod ,f ((a t)(b t)(c t)) (list a b c)))) - ;; Test of incongruent generic function lambda list when no - ;; methods exist - (eval - `(signals-error (ensure-generic-function ',f :lambda-list '(x y)) - error)))) - nil t t t) - -(deftest ensure-generic-function.7 - (let ((f 'egf-fun-7)) - (when (fboundp f) (fmakunbound f)) - (let ((fn (eval `(defgeneric ,f (x) - (:method ((x symbol)) (list x :a)) - (:method ((x integer)) (list x :b)) - (:method ((x t)) (list x :c)))))) - (values - (mapcar fn '(x 2 3/2)) - (eqlt fn (ensure-generic-function f :lambda-list '(x))) - (mapcar fn '(x 2 3/2))))) - ((x :a) (2 :b) (3/2 :c)) - t - ((x :a) (2 :b) (3/2 :c))) - -(deftest ensure-generic-function.8 - (let ((f 'egf-fun-8)) - (when (fboundp f) (fmakunbound f)) - (let ((fn (eval `(defgeneric ,f (x y) - (:method ((x t) (y symbol)) 1) - (:method ((x symbol) (y t)) 2))))) - (values - (mapcar fn '(a a 3) '(b 4 b)) - (eqlt fn (ensure-generic-function f :lambda-list '(x y) - :argument-precedence-order '(y x))) - (mapcar fn '(a a 3) '(b 4 b))))) - (2 2 1) - t - (1 2 1)) - -(deftest ensure-generic-function.9 - (let ((f 'egf-fun-9)) - (when (fboundp f) (fmakunbound f)) - (let ((fn (eval `(defgeneric ,f (x) - (:method-combination +) - (:method + ((x t)) 1) - (:method + ((x symbol)) 2) - (:method + ((x (eql nil))) 4))))) - (values - (mapcar fn '(3/2 a nil)) - (eqlt fn (ensure-generic-function f :lambda-list '(x) - :method-class 'standard-method)) - (mapcar fn '(3/2 a nil)) - (eqlt fn (ensure-generic-function f :lambda-list '(x) - :method-class - (find-class 'standard-method))) - (mapcar fn '(3/2 a nil))))) - - - (1 3 7) - t - (1 3 7) - t - (1 3 7)) - -(deftest ensure-generic-function.10 - (let ((f 'egf-fun-10)) - (when (fboundp f) (fmakunbound f)) - (let ((fn (eval `(defgeneric ,f (x) - (:method ((x t)) 1))))) - (values - (funcall fn 'a) - (eqlt fn (ensure-generic-function f :lambda-list '(x) - :generic-function-class - 'standard-generic-function)) - (funcall fn 'a) - (eqlt fn (ensure-generic-function f :lambda-list '(x) - :generic-function-class - (find-class 'standard-generic-function))) - (funcall fn 'a)))) - 1 t 1 t 1) - -(deftest ensure-generic-function.11 - (let ((f 'egf-fun-11)) - (when (fboundp f) (fmakunbound f)) - (let ((fn (eval `(defgeneric ,f (x) - (:method ((x t)) 1))))) - (values - (funcall fn 'a) - (eqlt fn (eval `(macrolet ((%m (&environment env) - (ensure-generic-function ',f :lambda-list '(x) - :environment env))) - (%m)))) - (funcall fn 'a)))) - 1 t 1) - -(deftest ensure-generic-function.12 - (let ((f 'egf-fun-12)) - (when (fboundp f) (fmakunbound f)) - (let ((fn (eval `(defgeneric ,f (x) - (:documentation "foo") - (:method ((x t)) 1))))) - (values - (funcall fn 'a) - (or (documentation f 'function) "foo") - (eqlt fn (ensure-generic-function f :lambda-list '(x) :documentation "bar")) - (or (documentation f 'function) "bar") - (funcall fn 'a)))) - 1 "foo" t "bar" 1) - -(deftest ensure-generic-function.13 - (let ((f 'egf-fun-13)) - (when (fboundp f) (fmakunbound f)) - (let ((fn (eval `(defgeneric ,f (x y) - (declare (optimize safety (speed 0) (debug 0) (space 0))) - (:method ((x t) (y t)) (list x y)))))) - (values - (funcall fn 'a 'b) - (eqlt fn (ensure-generic-function f :lambda-list '(x y) - :declare '((optimize (safety 0) (debug 2) speed (space 1))))) - (funcall fn 'a 1)))) - (a b) t (a 1)) - -(deftest ensure-generic-function.14 - (let ((f '(setf egf-fun-14))) - (when (fboundp f) (fmakunbound f)) - (let ((fn (eval `(defgeneric ,f (val x) - (:method ((val t) (x cons)) (setf (car x) val)))))) - (values - (let ((z (cons 'a 'b))) - (list (setf (egf-fun-14 z) 'c) z)) - (eqlt fn (ensure-generic-function f :lambda-list '(val x))) - (let ((z (cons 'a 'b))) - (list (setf (egf-fun-14 z) 'c) z))))) - (c (c . b)) t (c (c . b))) - -;;; Many more tests are needed for other combinations of keyword parameters - -(deftest ensure-generic-function.error.1 - (signals-error (ensure-generic-function) program-error) - t) - -(deftest ensure-generic-function.error.2 - (signals-error (ensure-generic-function (gensym) :lambda-list) program-error) - t) diff --git a/t/ansi-test/objects/find-class.lsp b/t/ansi-test/objects/find-class.lsp deleted file mode 100644 index 5196571..0000000 --- a/t/ansi-test/objects/find-class.lsp +++ /dev/null @@ -1,286 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu May 29 07:15:06 2003 -;;;; Contains: Tests of FIND-CLASS - -;; find-class is also tested in numerous other places. - - - -(deftest find-class.1 - (loop for name in *cl-types-that-are-classes-symbols* - unless (eq (find-class name) (find-class name)) - collect name) - nil) - -(deftest find-class.2 - (loop for name in *cl-types-that-are-classes-symbols* - unless (eq (find-class name t) (find-class name)) - collect name) - nil) - -(deftest find-class.3 - (loop for name in *cl-types-that-are-classes-symbols* - unless (eq (find-class name nil) (find-class name)) - collect name) - nil) - -(deftest find-class.4 - (handler-case - (progn (eval '(find-class (gensym))) :bad) - (error () :good)) - :good) - -(deftest find-class.5 - (handler-case - (progn (eval '(find-class (gensym) t)) :bad) - (error () :good)) - :good) - -(deftest find-class.6 - (find-class (gensym) nil) - nil) - -(deftest find-class.7 - (loop for name in *cl-types-that-are-classes-symbols* - unless (eq (find-class name t nil) (find-class name)) - collect name) - nil) - -(deftest find-class.8 - (loop for name in *cl-types-that-are-classes-symbols* - unless (eq (find-class name nil nil) (find-class name)) - collect name) - nil) - -(deftest find-class.9 - (macrolet - ((%m (&environment env) - (let ((result - (loop for name in *cl-types-that-are-classes-symbols* - unless (eq (find-class name nil env) - (find-class name)) - collect name))) - `',result))) - (%m)) - nil) - -(deftest find-class.10 - (macrolet - ((%m (&environment env) - (let ((result - (loop for name in *cl-types-that-are-classes-symbols* - unless (eq (find-class name t env) - (find-class name)) - collect name))) - `',result))) - (%m)) - nil) - -(deftest find-class.11 - (handler-case - (progn (eval '(find-class (gensym) 'a nil)) :bad) - (error () :good)) - :good) - -(deftest find-class.12 - (find-class (gensym) nil nil) - nil) - -(deftest find-class.13 - (macrolet - ((%m (&environment env) - `',(find-class (gensym) nil env))) - (%m)) - nil) - -(deftest find-class.14 - (handler-case - (progn - (eval '(macrolet - ((%m (&environment env) - `',(find-class (gensym) 17 env))) - (%m))) - :bad) - (error () :good)) - :good) - -;;; Need tests of assignment to (FIND-CLASS ...) -;;; Add tests of: -;;; Setting class to itself -;;; Changing class to a different class -;;; Changing to NIL (and that the class object stays around) -;;; Check that find-class is affected by the assignment, and -;;; class-name is not. - -(deftest find-class.15 - (progn - (setf (find-class 'find-class-class-01) nil) - (let* ((class (eval '(defclass find-class-class-01 () ()))) - (class1 (find-class 'find-class-class-01)) - (class2 (setf (find-class 'find-class-class-01) class1))) - (values - (eqt class class1) - (eqt class class2) - (class-name class) - ))) - t t find-class-class-01) - -(deftest find-class.16 - (progn - (setf (find-class 'find-class-class-01 nil) nil) - (setf (find-class 'find-class-class-01 t) nil) ;; should not throw error - (let* ((i 0) - (class (eval '(defclass find-class-class-01 () ()))) - (class1 (find-class 'find-class-class-01)) - (class2 (setf (find-class 'find-class-class-01 (incf i)) class1))) - (values - i - (eqt class class1) - (eqt class class2)))) - 1 t t) - -(deftest find-class.17 - (macrolet - ((%m (&environment env) - `',(progn - (setf (find-class 'find-class-class-01) nil) - (let* - ((i 0) - x y z - (class (eval '(defclass find-class-class-01 () ()))) - (class1 (find-class (progn (setf x (incf i)) - 'find-class-class-01) - (setf y (incf i)) - (progn (setf z (incf i)) env))) - (class2 (setf (find-class 'find-class-class-01) class1))) - (list - (eqt class class1) - (eqt class class2) - i x y z - ))))) - (%m)) - (t t 3 1 2 3)) - -(deftest find-class.18 - (progn - (setf (find-class 'find-class-class-01) nil) - (let* ((class (eval '(defclass find-class-class-01 () ()))) - (class1 (find-class 'find-class-class-01)) - (class2 (setf (find-class 'find-class-class-01) nil)) - (class3 (find-class 'find-class-class-01 nil))) - (values - (eqt class class1) - (eqt class class2) - class2 - (class-name class) - class3))) - t nil nil find-class-class-01 nil) - -(deftest find-class.19 - (progn - (setf (find-class 'find-class-class-01 nil) nil) - (setf (find-class 'find-class-class-01 t) nil) ;; should not throw error - (let* ((class (eval '(defclass find-class-class-01 () ()))) - (class1 (find-class 'find-class-class-01)) - (class2 (setf (find-class 'find-class-class-01 t nil) - class1))) - (values - (eqt class class1) - (eqt class class2)))) - t t) - -;; Change to a different class - -(deftest find-class.20 - (progn - (setf (find-class 'find-class-class-01) nil) - (setf (find-class 'find-class-class-02) nil) - (let* ((class1 (eval '(defclass find-class-class-01 () ()))) - (class2 (eval '(defclass find-class-class-02 () ())))) - (setf (find-class 'find-class-class-01) class2) - (let* ((new-class1 (find-class 'find-class-class-01 nil)) - (new-class2 (find-class 'find-class-class-02))) - (values - (eqt class1 class2) - (eqt class2 new-class1) - (eqt class2 new-class2) - (class-name class2))))) - nil t t find-class-class-02) - -(deftest find-class.21 - (progn - (setf (find-class 'find-class-class-01) nil) - (setf (find-class 'find-class-class-02) nil) - (let* ((class1 (eval '(defclass find-class-class-01 () ()))) - (class2 (eval '(defclass find-class-class-02 () ())))) - (psetf (find-class 'find-class-class-01) class2 - (find-class 'find-class-class-02) class1) - (let* ((new-class1 (find-class 'find-class-class-01 nil)) - (new-class2 (find-class 'find-class-class-02))) - (values - (eqt class1 class2) - (eqt class2 new-class1) - (eqt class1 new-class2) - (class-name new-class1) - (class-name new-class2) - )))) - nil t t find-class-class-02 find-class-class-01) - -;;; Effect on method dispatch - -(deftest find-class.22 - (progn - (setf (find-class 'find-class-class-01) nil) - (let* ((class1 (eval - '(defclass find-class-class-01 () ()))) - (fn (eval '(defgeneric find-class-gf-01 (x) - (:method ((x find-class-class-01)) :good) - (:method ((x t)) nil)))) - (obj (make-instance class1))) - (assert (typep fn 'function)) - (locally - (declare (type function fn)) - (values - (funcall fn nil) - (funcall fn obj) - (setf (find-class 'find-class-class-01) nil) - (funcall fn nil) - (funcall fn obj))))) - nil :good nil nil :good) - -(deftest find-class.23 - (progn - (setf (find-class 'find-class-class-01) nil) - (setf (find-class 'find-class-class-02) nil) - (let* ((class1 (eval '(defclass find-class-class-01 () ()))) - (class2 (eval '(defclass find-class-class-02 - (find-class-class-01) ()))) - (fn (eval '(defgeneric find-class-gf-02 (x) - (:method ((x find-class-class-01)) 1) - (:method ((x find-class-class-02)) 2) - (:method ((x t)) t)))) - (obj1 (make-instance class1)) - (obj2 (make-instance class2))) - (assert (typep fn 'function)) - (locally - (declare (type function fn)) - (values - (funcall fn nil) - (funcall fn obj1) - (funcall fn obj2) - (setf (find-class 'find-class-class-01) nil) - (funcall fn nil) - (funcall fn obj1) - (funcall fn obj2))))) - t 1 2 nil t 1 2) - -;;; Error tests - -(deftest find-class.error.1 - (signals-error (find-class) program-error) - t) - -(deftest find-class.error.2 - (signals-error (find-class 'symbol nil nil nil) program-error) - t) diff --git a/t/ansi-test/objects/find-method.lsp b/t/ansi-test/objects/find-method.lsp deleted file mode 100644 index 41abcf0..0000000 --- a/t/ansi-test/objects/find-method.lsp +++ /dev/null @@ -1,150 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Jun 3 21:12:03 2003 -;;;; Contains: Tests for FIND-METHOD - - - -(eval-when (:load-toplevel :compile-toplevel :execute) - (report-and-ignore-errors - (defgeneric find-method-gf-01 (x))) - (report-and-ignore-errors - (defparameter *find-method-gf-01-method1* - (defmethod find-method-gf-01 ((x integer)) 'a))) - (report-and-ignore-errors - (defparameter *find-method-gf-01-method2* - (defmethod find-method-gf-01 ((x rational)) 'b))) - (report-and-ignore-errors - (defparameter *find-method-gf-01-method3* - (defmethod find-method-gf-01 ((x real)) 'c))) - (report-and-ignore-errors - (defparameter *find-method-gf-01-method4* - (defmethod find-method-gf-01 ((x t)) 'd))) - ) - -(deftest find-method.1 - (eqt (find-method #'find-method-gf-01 nil (list (find-class 'integer))) - *find-method-gf-01-method1*) - t) - -(deftest find-method.2 - (eqt (find-method #'find-method-gf-01 nil (list (find-class 'rational))) - *find-method-gf-01-method2*) - t) - -(deftest find-method.3 - (eqt (find-method #'find-method-gf-01 nil (list (find-class 'real))) - *find-method-gf-01-method3*) - t) - -(deftest find-method.4 - (eqt (find-method #'find-method-gf-01 nil (list (find-class t))) - *find-method-gf-01-method4*) - t) - -(deftest find-method.5 - (find-method #'find-method-gf-01 (list :around) (list (find-class t)) - nil) - nil) - -(deftest find-method.6 - (find-method #'find-method-gf-01 (list :after) - (list (find-class 'integer)) nil) - nil) - -(deftest find-method.7 - (find-method #'find-method-gf-01 (list :before) (list (find-class 'real)) - nil) - nil) - -;;; EQL specializers - -(defgeneric find-method-gf-02 (x)) - -(defparameter *find-method-gf-02-method1* - (defmethod find-method-gf-02 ((x (eql 1234567890))) 'a)) - -(defparameter *find-method-02-method2-value* (list 'a)) - -(defparameter *find-method-gf-02-method2* - (defmethod find-method-gf-02 ((x (eql *find-method-02-method2-value*))) - 'b)) - -(deftest find-method.8 - (eqt (find-method #'find-method-gf-02 nil (list '(eql 1234567890))) - *find-method-gf-02-method1*) - t) - -(deftest find-method.9 - (eqt (find-method #'find-method-gf-02 nil - (list (list 'eql *find-method-02-method2-value*))) - *find-method-gf-02-method2*) - t) - -;;; Error tests - -(deftest find-method.error.1 - (signals-error (find-method) program-error) - t) - -(deftest find-method.error.2 - (signals-error (find-method #'find-method-gf-01) program-error) - t) - -(deftest find-method.error.3 - (signals-error (find-method #'find-method-gf-01 nil) program-error) - t) - -(deftest find-method.error.4 - (signals-error - (find-method #'find-method-gf-01 nil (list (find-class 'integer)) nil nil) - program-error) - t) - -(deftest find-method.error.5 - (handler-case - (find-method #'find-method-gf-01 nil (list (find-class 'symbol))) - (error () :error)) - :error) - -(deftest find-method.error.6 - (handler-case - (find-method #'find-method-gf-01 nil (list (find-class 'symbol)) 'x) - (error () :error)) - :error) - -(deftest find-method.error.7 - (handler-case - (find-method #'find-method-gf-01 nil nil) - (error () :error)) - :error) - -(deftest find-method.error.8 - (handler-case - (find-method #'find-method-gf-01 nil (list (find-class 'integer) - (find-class t))) - (error () :error)) - :error) - -(deftest find-method.error.9 - (handler-case - (find-method #'find-method-gf-01 nil nil nil) - (error () :error)) - :error) - -(deftest find-method.error.10 - (handler-case - (find-method #'find-method-gf-01 nil (list (find-class 'integer) - (find-class t)) - nil) - (error () :error)) - :error) - - - - - - - - - diff --git a/t/ansi-test/objects/load.lsp b/t/ansi-test/objects/load.lsp deleted file mode 100644 index 8c7692c..0000000 --- a/t/ansi-test/objects/load.lsp +++ /dev/null @@ -1,64 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Mar 24 03:39:09 2003 -;;;; Contains: Loader for CLOS-related test files - -(compile-and-load "ANSI-TESTS:AUX;defclass-aux.lsp") - -(in-package #:cl-test) - -(let ((*default-pathname-defaults* - (make-pathname - :directory (pathname-directory *load-pathname*)))) - (load "defclass.lsp") - (load "defclass-01.lsp") - (load "defclass-02.lsp") - (load "defclass-03.lsp") - (load "defclass-errors.lsp") - (load "defclass-forward-reference.lsp") - (load "ensure-generic-function.lsp") - (load "allocate-instance.lsp") - (load "reinitialize-instance.lsp") - (load "shared-initialize.lsp") - (load "change-class.lsp") - (load "update-instance-for-different-class.lsp") - (load "slot-boundp.lsp") - (load "slot-exists-p.lsp") - (load "slot-makunbound.lsp") - (load "slot-missing.lsp") - (load "slot-unbound.lsp") - (load "slot-value.lsp") - (load "method-qualifiers.lsp") - (load "no-applicable-method.lsp") - (load "no-next-method.lsp") - (load "remove-method.lsp") - (load "make-instance.lsp") - (load "make-instances-obsolete.lsp") - (load "make-load-form.lsp") - (load "make-load-form-saving-slots.lsp") - (load "with-accessors.lsp") - (load "with-slots.lsp") - (load "defgeneric.lsp") - (load "defgeneric-method-combination-aux.lsp") - (load "defgeneric-method-combination-plus.lsp") - (load "defgeneric-method-combination-append.lsp") - (load "defgeneric-method-combination-nconc.lsp") - (load "defgeneric-method-combination-list.lsp") - (load "defgeneric-method-combination-max.lsp") - (load "defgeneric-method-combination-min.lsp") - (load "defgeneric-method-combination-and.lsp") - (load "defgeneric-method-combination-or.lsp") - (load "defgeneric-method-combination-progn.lsp") - ;; (load "defgeneric-method-combination-standard.lsp") - (load "find-class.lsp") - (load "next-method-p.lsp") - (load "call-next-method.lsp") - (load "compute-applicable-methods.lsp") - (load "define-method-combination.lsp") - ;; (load "define-method-combination-long-form.lsp") - (load "find-method.lsp") - (load "add-method.lsp") - (load "class-name.lsp") - (load "class-of.lsp") - (load "unbound-slot.lsp") - (load "defmethod.lsp")) diff --git a/t/ansi-test/objects/make-instance.lsp b/t/ansi-test/objects/make-instance.lsp deleted file mode 100644 index e71e82e..0000000 --- a/t/ansi-test/objects/make-instance.lsp +++ /dev/null @@ -1,234 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon May 12 21:19:36 2003 -;;;; Contains: Tests of MAKE-INSTANCE - - - -;;; MAKE-INSTANCE is used in many other tests as well - -(deftest make-instance.error.1 - (signals-error (make-instance) program-error) - t) - -(defclass make-instance-class-01 () - ((a :initarg :a) (b :initarg :b))) - -(deftest make-instance.error.2 - (signals-error (make-instance 'make-instance-class-01 :a) - program-error) - t) - -(deftest make-instance.error.3 - (handler-case (progn (eval '(make-instance 'make-instance-class-01 :z 1)) - t) - (error () :good)) - :good) - -(deftest make-instance.error.4 - (handler-case (progn (eval '(make-instance - (find-class 'make-instance-class-01) - :z 1)) - t) - (error () :good)) - :good) - -(deftest make-instance.error.5 - (signals-error (let () (make-instance) nil) - program-error) - t) - -(deftest make-instance.error.6 - (loop for cl in *built-in-classes* - unless (eval `(signals-error (make-instance ',cl) error)) - collect cl) - nil) - -;; Definitions of methods - -(defmethod make-instance ((x make-instance-class-01) - &rest initargs &key &allow-other-keys) - initargs) - -(deftest make-instance.1 - (make-instance (make-instance 'make-instance-class-01)) - nil) - -(deftest make-instance.2 - (make-instance (make-instance 'make-instance-class-01) :a 1 :b 2) - (:a 1 :b 2)) - -#| -(when *can-define-metaclasses* - - (defclass make-instance-class-02 () - (a b c) - (:metaclass substandard-class)) - - (defmethod make-instance ((class (eql (find-class 'make-instance-class-02))) - &rest initargs &key (x nil) (y nil) (z nil) - &allow-other-keys) - (declare (ignore initargs)) - (let ((obj (allocate-instance class))) - (setf (slot-value obj 'a) x - (slot-value obj 'b) y - (slot-value obj 'c) z) - obj)) - - (deftest make-instance.3 - (let ((obj (make-instance 'make-instance-class-02))) - (values - (eqt (class-of obj) (find-class 'make-instance-class-02)) - (slot-value obj 'a) - (slot-value obj 'b) - (slot-value obj 'c))) - t nil nil nil) - - (deftest make-instance.4 - (let ((obj (make-instance 'make-instance-class-02 :z 10 :y 45 :x 'd))) - (values - (eqt (class-of obj) (find-class 'make-instance-class-02)) - (slot-value obj 'a) - (slot-value obj 'b) - (slot-value obj 'c))) - t d 45 10) - - - (deftest make-instance.5 - (let ((obj (make-instance (find-class 'make-instance-class-02) :y 'g))) - (values - (eqt (class-of obj) (find-class 'make-instance-class-02)) - (slot-value obj 'a) - (slot-value obj 'b) - (slot-value obj 'c))) - t nil g nil) - - (deftest make-instance.6 - (eq (make-instance 'make-instance-class-02) - (make-instance 'make-instance-class-02)) - nil) - - ;; Customization of make-instance - - (defclass make-instance-class-03 () - ((a :initform 1) (b :initarg :b) c) - (:metaclass substandard-class)) - - (defmethod make-instance ((class (eql (find-class 'make-instance-class-03))) - &rest initargs - &key (x nil x-p) (y nil y-p) (z nil z-p) - &allow-other-keys) - (declare (ignore initargs)) - (let ((obj (allocate-instance (find-class 'make-instance-class-03)))) - (when x-p (setf (slot-value obj 'a) x)) - (when y-p (setf (slot-value obj 'b) y)) - (when z-p (setf (slot-value obj 'c) z)) - obj)) - - (deftest make-instance.7 - (let ((obj (make-instance 'make-instance-class-03))) - (values - (eqt (class-of obj) - (find-class 'make-instance-class-03)) - (map-slot-boundp* obj '(a b c)))) - t (nil nil nil)) - - (deftest make-instance.8 - (let* ((class (find-class 'make-instance-class-03)) - (obj (make-instance class :b 10))) - (values - (eqt (class-of obj) class) - (map-slot-boundp* obj '(a b c)))) - t (nil nil nil)) - - (deftest make-instance.9 - (let* ((class (find-class 'make-instance-class-03)) - (obj (make-instance class :x 'g :z 'i :y 'k :foo t :x 'bad))) - (values - (eqt (class-of obj) class) - (map-slot-boundp* obj '(a b c)) - (map-slot-value obj '(a b c)))) - t (t t t) (g k i)) - - ;; After method combination - - (defparameter *make-instance-class-04-var* 0) - - (defclass make-instance-class-04 () - ((a :initform *make-instance-class-04-var*)) - (:metaclass substandard-class)) - - (defmethod make-instance :after - ((class (eql (find-class 'make-instance-class-04))) - &rest initargs &key &allow-other-keys) - (declare (ignore initargs)) - (incf *make-instance-class-04-var* 10)) - - (deftest make-instance.10 - (let* ((*make-instance-class-04-var* 0) - (obj (make-instance 'make-instance-class-04))) - (values - (slot-value obj 'a) - *make-instance-class-04-var*)) - 0 10) - - ;; Around method combination - - (defclass make-instance-class-05 () - ((a :initarg :a) (b :initarg :b :initform 'foo) c) - (:metaclass substandard-class)) - - (defmethod make-instance :around - ((class (eql (find-class 'make-instance-class-05))) - &rest initargs &key &allow-other-keys) - (declare (ignore initargs)) - (let ((obj (call-next-method))) - (setf (slot-value obj 'c) 'bar) - obj)) - - (deftest make-instance.11 - (let ((obj (make-instance 'make-instance-class-05))) - (values - (map-slot-boundp* obj '(a b c)) - (map-slot-value obj '(b c)))) - (nil t t) - (foo bar)) - ) -|# - -;;; Order of argument evaluation - -(deftest make-instance.order.1 - (let* ((i 0) x y - (obj (make-instance 'make-instance-class-01 - :a (setf x (incf i)) - :b (setf y (incf i))))) - (values - (map-slot-value obj '(a b)) - i x y)) - (1 2) 2 1 2) - -(deftest make-instance.order.2 - (let* ((i 0) x y z w - (obj (make-instance 'make-instance-class-01 - :a (setf x (incf i)) - :b (setf y (incf i)) - :b (setf z (incf i)) - :a (setf w (incf i))))) - (values - (map-slot-value obj '(a b)) - i x y z w)) - (1 2) 4 1 2 3 4) - -(deftest make-instance.order.3 - (let* ((i 0) u x y z w - (obj (make-instance (prog1 'make-instance-class-01 - (setf u (incf i))) - :a (setf x (incf i)) - :b (setf y (incf i)) - :b (setf z (incf i)) - :a (setf w (incf i))))) - (values - (map-slot-value obj '(a b)) - i u x y z w)) - (2 3) 5 1 2 3 4 5) diff --git a/t/ansi-test/objects/make-instances-obsolete.lsp b/t/ansi-test/objects/make-instances-obsolete.lsp deleted file mode 100644 index 81d0e25..0000000 --- a/t/ansi-test/objects/make-instances-obsolete.lsp +++ /dev/null @@ -1,51 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat May 17 08:12:35 2003 -;;;; Contains: Tests of MAKE-INSTANCES-OBSOLETE - - - -(defclass make-instances-obsolete-class-01 () - ((a :initarg :a) - (b :initarg :b :allocation :class) - (c :initarg :c :initform 'abc) - (d :initarg :d :type fixnum :initform 0))) - -(deftest make-instances-obsolete.1 - (let* ((class-designator 'make-instances-obsolete-class-01) - (class (find-class class-designator)) - (obj (make-instance class :a 'x :b 'y :c 'z :d 17))) - (values - (eqt (class-of obj) class) - (map-slot-value obj '(a b c d)) - (let ((val (make-instances-obsolete class))) - (or (eqt val class-designator) - (eqt val class))) - (map-slot-value obj '(a b c d)))) - t (x y z 17) t (x y z 17)) - -(deftest make-instances-obsolete.2 - (let* ((class-designator 'make-instances-obsolete-class-01) - (class (find-class class-designator)) - (obj (make-instance class :a 'x :b 'y :c 'z :d 17))) - (values - (eqt (class-of obj) class) - (map-slot-value obj '(a b c d)) - (let ((val (make-instances-obsolete class-designator))) - (or (eqt val class-designator) - (eqt val class))) - (map-slot-value obj '(a b c d)))) - t (x y z 17) t (x y z 17)) - -;;; Error cases - -(deftest make-instances-obsolete.error.1 - (signals-error (make-instances-obsolete) program-error) - t) - -(deftest make-instances-obsolete.error.2 - (signals-error (make-instances-obsolete - (find-class 'make-instances-obsolete-class-01) - nil) - program-error) - t) diff --git a/t/ansi-test/objects/make-load-form-saving-slots.lsp b/t/ansi-test/objects/make-load-form-saving-slots.lsp deleted file mode 100644 index 008405a..0000000 --- a/t/ansi-test/objects/make-load-form-saving-slots.lsp +++ /dev/null @@ -1,195 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat May 17 11:54:54 2003 -;;;; Contains: Tests of MAKE-LOAD-FORM-SAVING-SLOTS - - - -;;; These are tests of MAKE-LOAD-FORM-SAVING-SLOTS proper; tests involving -;;; file compilation will be located elsewhere. - - -(defstruct mlfss-01 a b c) - -(deftest make-load-form-saving-slots.1 - (let* ((obj (make-mlfss-01)) - (forms (multiple-value-list - (make-load-form-saving-slots obj)))) - (values - (length forms) - (let ((newobj (eval (first forms)))) - (eval (subst newobj obj (second forms))) - (eqt (class-of obj) (class-of newobj))))) - 2 t) - -(deftest make-load-form-saving-slots.2 - (let* ((obj (make-mlfss-01)) - (forms (multiple-value-list - (make-load-form-saving-slots obj :slot-names '(a b))))) - (values - (length forms) - (let ((newobj (eval (first forms)))) - (eval (subst newobj obj (second forms))) - (eqt (class-of obj) (class-of newobj))))) - 2 t) - -(defclass mlfss-02 () ((a :initarg :a) (b :initarg :b) (c :initarg :c))) - -(deftest make-load-form-saving-slots.3 - (let* ((obj (make-instance 'mlfss-02)) - (forms (multiple-value-list - (make-load-form-saving-slots obj)))) - (let ((newobj (eval (first forms)))) - (eval (subst newobj obj (second forms))) - (values - (length forms) - (eqt (class-of obj) (class-of newobj)) - (map-slot-boundp* newobj '(a b c))))) - 2 t (nil nil nil)) - -(deftest make-load-form-saving-slots.4 - (let* ((obj (make-instance 'mlfss-02 :a 1 :b 'a :c '(x y z))) - (forms (multiple-value-list - (make-load-form-saving-slots obj :slot-names '(a b c))))) - (let ((newobj (eval (first forms)))) - (eval (subst newobj obj (second forms))) - (values - (length forms) - (eqt (class-of obj) (class-of newobj)) - (map-slot-boundp* newobj '(a b c)) - (map-slot-value newobj '(a b c))))) - 2 t (t t t) (1 a (x y z))) - - -(deftest make-load-form-saving-slots.5 - (let* ((obj (make-instance 'mlfss-02 :a #(x y z))) - (forms (multiple-value-list - (make-load-form-saving-slots obj :slot-names '(a b))))) - (let ((newobj (eval (first forms)))) - (eval (subst newobj obj (second forms))) - (values - (length forms) - (eqt (class-of obj) (class-of newobj)) - (map-slot-boundp* newobj '(a b c)) - (slot-value newobj 'a)))) - 2 t (t nil nil) #(x y z)) - -(deftest make-load-form-saving-slots.6 - (let* ((obj (make-instance 'mlfss-02)) - (forms (multiple-value-list - (make-load-form-saving-slots obj :allow-other-keys nil)))) - (let ((newobj (eval (first forms)))) - (eval (subst newobj obj (second forms))) - (values - (length forms) - (eqt (class-of obj) (class-of newobj)) - (map-slot-boundp* newobj '(a b c))))) - 2 t (nil nil nil)) - -;;; If :slot-names is missing, all initialized slots are retained -(deftest make-load-form-saving-slots.7 - (let* ((obj (make-instance 'mlfss-02 :a (list 'x) :c 6/5)) - (forms (multiple-value-list - (make-load-form-saving-slots obj)))) - (let ((newobj (eval (first forms)))) - (eval (subst newobj obj (second forms))) - (values - (length forms) - (eqt (class-of obj) (class-of newobj)) - (map-slot-boundp* newobj '(a b c)) - (map-slot-value newobj '(a c))))) - 2 t (t nil t) ((x) 6/5)) - -;;; If :slot-names is present, all initialized slots in the list are retained -(deftest make-load-form-saving-slots.8 - (let* ((obj (make-instance 'mlfss-02 :a (list 'x) :c 6/5)) - (forms (multiple-value-list - (make-load-form-saving-slots obj :slot-names '(c))))) - (let ((newobj (eval (first forms)))) - (eval (subst newobj obj (second forms))) - (values - (length forms) - (eqt (class-of obj) (class-of newobj)) - (map-slot-boundp* newobj '(a b c)) - (slot-value newobj 'c)))) - 2 t (nil nil t) 6/5) - -;; It takes an :environment parameter -(deftest make-load-form-saving-slots.9 - (let* ((obj (make-instance 'mlfss-02 :a 7 :c 64 :b 100)) - (forms (multiple-value-list - (make-load-form-saving-slots obj :environment nil)))) - (let ((newobj (eval (first forms)))) - (eval (subst newobj obj (second forms))) - (values - (length forms) - (eqt (class-of obj) (class-of newobj)) - (map-slot-boundp* newobj '(a b c)) - (map-slot-value newobj '(a b c))))) - 2 t (t t t) (7 100 64)) - -(defpackage "CL-TEST-MLFSS-PACKAGE" (:use) (:export #:a)) -(defstruct mlfss-03 cl-test-mlfss-package:a) - -(deftest make-load-form-savings-slots.10 - (let* ((obj (make-mlfss-03 :a 17)) - (forms (multiple-value-list - (make-load-form-saving-slots obj)))) - (let ((newobj (eval (first forms)))) - (eval (subst newobj obj (second forms))) - (values - (mlfss-03-a obj) - (length forms) - (eqt (class-of obj) (class-of newobj)) - (mlfss-03-a newobj)))) - 17 2 t 17) - -(deftest make-load-form-savings-slots.11 - (let* ((obj (make-mlfss-03 :a 17)) - (forms (multiple-value-list - (make-load-form-saving-slots - obj - :slot-names '(cl-test-mlfss-package:a))))) - (let ((newobj (eval (first forms)))) - (eval (subst newobj obj (second forms))) - (values - (mlfss-03-a obj) - (length forms) - (eqt (class-of obj) (class-of newobj)) - (mlfss-03-a newobj)))) - 17 2 t 17) - - -(defstruct mlfss-04 (a 0 :read-only t)) - -(deftest make-load-form-savings-slots.12 - (let* ((obj (make-mlfss-04 :a 123)) - (forms (multiple-value-list - (make-load-form-saving-slots obj)))) - (let ((newobj (eval (first forms)))) - (eval (subst newobj obj (second forms))) - (values - (mlfss-04-a obj) - (length forms) - (eqt (class-of obj) (class-of newobj)) - (mlfss-04-a newobj)))) - 123 2 t 123) - - -;;; General error tests - -(deftest make-load-form-saving-slots.error.1 - (signals-error (make-load-form-saving-slots) program-error) - t) - -(deftest make-load-form-saving-slots.error.2 - (signals-error (make-load-form-saving-slots (make-instance 'mlfss-02) - :slot-names) - program-error) - t) - -(deftest make-load-form-saving-slots.error.3 - (signals-error (make-load-form-saving-slots (make-instance 'mlfss-02) - (gensym) t) - program-error) - t) diff --git a/t/ansi-test/objects/make-load-form.lsp b/t/ansi-test/objects/make-load-form.lsp deleted file mode 100644 index a1c881b..0000000 --- a/t/ansi-test/objects/make-load-form.lsp +++ /dev/null @@ -1,219 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat May 17 09:16:20 2003 -;;;; Contains: Tests of MAKE-LOAD-FORM - - - -;;; These tests are just of MAKE-LOAD-FORM itself; tests of file compilation -;;; that depend on MAKE-LOAD-FORM will be found elsewhere. - -(defclass make-load-form-class-01 () (a b c)) - -(deftest make-load-form.1 - (let* ((fun #'make-load-form) - (obj (make-instance 'make-load-form-class-01))) - (if (eql (or (find-method fun nil '(standard-object) nil) - (find-method fun nil (list (find-class t)) nil) - :none) - (car (compute-applicable-methods fun (list obj)))) - ;; The default method applies - (handler-case - (progn (make-load-form obj) :bad) - (error () :good)) - :good)) - :good) - -(defstruct make-load-form-struct-02 a b c) - -(deftest make-load-form.2 - (let* ((fun #'make-load-form) - (obj (make-make-load-form-struct-02))) - (if (eql (or (find-method fun nil '(structure-object) nil) - (find-method fun nil (list (find-class t)) nil) - :none) - (car (compute-applicable-methods fun (list obj)))) - ;; The default method applies - (handler-case - (progn (make-load-form obj) :bad) - (error () :good)) - :good)) - :good) - -(define-condition make-load-form-condition-03 () ((a) (b) (c))) - -(deftest make-load-form.3 - (let* ((fun #'make-load-form) - (obj (make-condition 'make-load-form-condition-03))) - (if (eql (or (find-method fun nil '(condition) nil) - (find-method fun nil (list (find-class t)) nil) - :none) - (car (compute-applicable-methods fun (list obj)))) - ;; The default method applies - (handler-case - (progn (make-load-form obj :bad)) - (error () :good)) - :good)) - :good) - -;;; Make sure these errors are due to the method, not due to lack of -;;; methods - -(deftest make-load-form.4 - (let* ((obj (make-instance 'make-load-form-class-01)) - (fun #'make-load-form) - (methods (compute-applicable-methods fun (list obj)))) - (notnot-mv methods)) - t) - -(deftest make-load-form.5 - (let* ((obj (make-make-load-form-struct-02)) - (fun #'make-load-form) - (methods (compute-applicable-methods fun (list obj)))) - (notnot-mv methods)) - t) - -(deftest make-load-form.6 - (let* ((obj (make-condition 'make-load-form-condition-03)) - (fun #'make-load-form) - (methods (compute-applicable-methods fun (list obj)))) - (notnot-mv methods)) - t) - -(deftest make-load-form.7 - (let* ((obj (make-instance 'make-load-form-class-01)) - (fun #'make-load-form) - (methods (compute-applicable-methods fun (list obj nil)))) - (notnot-mv methods)) - t) - -(deftest make-load-form.8 - (let* ((obj (make-make-load-form-struct-02)) - (fun #'make-load-form) - (methods (compute-applicable-methods fun (list obj nil)))) - (notnot-mv methods)) - t) - -(deftest make-load-form.9 - (let* ((obj (make-condition 'make-load-form-condition-03)) - (fun #'make-load-form) - (methods (compute-applicable-methods fun (list obj nil)))) - (notnot-mv methods)) - t) - -(deftest make-load-form.10 - (macrolet - ((%m (&environment env) - (let* ((obj (make-instance 'make-load-form-class-01)) - (fun #'make-load-form) - (methods (compute-applicable-methods fun (list obj env)))) - (notnot-mv methods)))) - (%m)) - t) - -(deftest make-load-form.11 - (macrolet - ((%m (&environment env) - (let* ((obj (make-make-load-form-struct-02)) - (fun #'make-load-form) - (methods (compute-applicable-methods fun (list obj env)))) - (notnot-mv methods)))) - (%m)) - t) - -(deftest make-load-form.12 - (macrolet - ((%m (&environment env) - (let* ((obj (make-condition 'make-load-form-condition-03)) - (fun #'make-load-form) - (methods (compute-applicable-methods fun (list obj env)))) - (notnot-mv methods)))) - (%m)) - t) - -;;; User-defined methods - -(defclass make-load-form-class-04 () - ((a :initarg :a) (b :initarg :b) (c :initarg :c))) - -(defmethod make-load-form ((obj make-load-form-class-04) - &optional (env t)) - (declare (ignore env)) - (let ((newobj (gensym))) - `(let ((,newobj (allocate-instance (find-class 'make-load-form-class-04)))) - ,@(loop for slot-name in '(a b c) - when (slot-boundp obj slot-name) - collect `(setf (slot-value ,newobj ',slot-name) - ',(slot-value obj slot-name))) - ,newobj))) - -(deftest make-load-form.13 - (let* ((obj (make-instance 'make-load-form-class-04)) - (obj2 (eval (make-load-form obj)))) - (values - (eqt (class-of obj2) (class-of obj)) - (map-slot-boundp* obj2 '(a b c)))) - t (nil nil nil)) - -(deftest make-load-form.14 - (let* ((obj (make-instance 'make-load-form-class-04 :a 1 :b '(a b c) :c 'a)) - (obj2 (eval (make-load-form obj)))) - (values - (eqt (class-of obj2) (class-of obj)) - (map-slot-boundp* obj2 '(a b c)) - (map-slot-value obj2 '(a b c)))) - t - (t t t) - (1 (a b c) a)) - -(deftest make-load-form.15 - (let* ((obj (make-instance 'make-load-form-class-04 :b '(a b c) :c 'a)) - (obj2 (eval (make-load-form obj nil)))) - (values - (eqt (class-of obj2) (class-of obj)) - (map-slot-boundp* obj2 '(a b c)) - (map-slot-value obj2 '(b c)))) - t - (nil t t) - ((a b c) a)) - -#| -(defclass make-load-form-class-05a () - ((a :initarg :a))) - -(defclass make-load-form-class-05b (make-load-form-class-05a) - ((b :initarg :b))) - -(defmethod make-load-form ((obj make-load-form-class-05a) - &optional (env t)) - (declare (ignore env)) - (let ((newobj (gensym))) - `(let ((,newobj (allocate-instance (find-class 'make-load-form-class-04)))) - ,@(when (slot-boundp obj 'a) - `((setf (slot-value ,newobj 'a) ',(slot-value obj 'a)))) - ,newobj))) - -(defmethod make-load-form :around ((obj make-load-form-class-05b) - &optional (env t)) - (declare (ignore env)) - (let ((newobj (gensym))) - `(let ((,newobj (allocate-instance (find-class 'make-load-form-class-04)))) - ,@(when (slot-boundp obj 'a) - `((setf (slot-value ,newobj 'a) ',(slot-value obj 'a)))) - ,newobj))) -|# - - - -;;; Other error tests - -(deftest make-load-form.error.1 - (signals-error (make-load-form) program-error) - t) - -(deftest make-load-form.error.2 - (signals-error - (let ((obj (make-instance 'make-load-form-class-04 :b '(a b c) :c 'a))) - (make-load-form obj nil nil)) - program-error) - t) diff --git a/t/ansi-test/objects/method-qualifiers.lsp b/t/ansi-test/objects/method-qualifiers.lsp deleted file mode 100644 index dbe7488..0000000 --- a/t/ansi-test/objects/method-qualifiers.lsp +++ /dev/null @@ -1,58 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun May 11 07:14:12 2003 -;;;; Contains: Tests of METHOD-QUALIFIERS - - - -(defgeneric mq-generic-function (x)) - -(defparameter *mq-method-1* - (defmethod mq-generic-function ((x integer)) (1+ x))) - -(deftest method-qualifiers.1 - (method-qualifiers *mq-method-1*) - nil) - -(defclass mq-class-01 () - (a b c)) - -(defparameter *mq-method-2* - (defmethod mq-generic-function :before ((x mq-class-01)) - 'foo)) - -(deftest method-qualifiers.2 - (method-qualifiers *mq-method-2*) - (:before)) - -(defclass mq-class-02 () - (e f g)) - -(defparameter *mq-method-3* - (defmethod mq-generic-function :after ((x mq-class-02)) - 'foo)) - -(deftest method-qualifiers.3 - (method-qualifiers *mq-method-3*) - (:after)) - -(defclass mq-class-03 () - (h i j)) - -(defparameter *mq-method-4* - (defmethod mq-generic-function :around ((x mq-class-03)) - 'foo)) - -(deftest method-qualifiers.4 - (method-qualifiers *mq-method-4*) - (:around)) - -;;; Need tests on user-defined method combinations - -(deftest method-qualifiers.error.1 - (signals-error (method-qualifiers) program-error) - t) - -(deftest method-qualifiers.error.2 - (signals-error (method-qualifiers *mq-method-4* nil) program-error) - t) diff --git a/t/ansi-test/objects/next-method-p.lsp b/t/ansi-test/objects/next-method-p.lsp deleted file mode 100644 index 113d936..0000000 --- a/t/ansi-test/objects/next-method-p.lsp +++ /dev/null @@ -1,81 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat May 31 08:04:45 2003 -;;;; Contains: Tests of NEXT-METHOD-P - - - -(defgeneric nmp-gf-01 (x) - (:method ((x integer)) (notnot-mv (next-method-p))) - (:method ((x number)) 'foo) - (:method ((x symbol)) (next-method-p))) - -(deftest next-method-p.1 - (nmp-gf-01 10) - t) - -(deftest next-method-p.2 - (nmp-gf-01 1.2) - foo) - -(deftest next-method-p.3 - (nmp-gf-01 'a) - nil) - -(defgeneric nmp-gf-02 (x y) - (:method ((x integer) (y symbol)) (notnot-mv (next-method-p))) - (:method ((x number) (y (eql nil))) 'foo)) - -(deftest next-method-p.4 - (nmp-gf-02 10 nil) - t) - -(deftest next-method-p.5 - (nmp-gf-02 10 'a) - nil) - -(defgeneric nmp-gf-03 (x y) - (:method ((x integer) (y symbol)) #'next-method-p) - (:method ((x t) (y (eql nil))) (constantly 1))) - -(deftest next-method-p.6 - (notnot-mv (funcall (the function (nmp-gf-03 10 nil)))) - t) - -(deftest next-method-p.7 - (funcall (nmp-gf-03 10 'a)) - nil) - -(defgeneric nmp-gf-04 (x y)) -(defmethod nmp-gf-04 ((x integer) (y symbol)) #'next-method-p) -(defmethod nmp-gf-04 ((x t) (y (eql nil))) (constantly 2)) - -(deftest next-method-p.8 - (notnot-mv (funcall (the function (nmp-gf-04 10 nil)))) - t) - -(deftest next-method-p.9 - (funcall (nmp-gf-04 10 'a)) - nil) - -;; With AROUND methods - -(defgeneric nmp-gf-05 (x)) -(defmethod nmp-gf-05 :around ((x number)) (notnot-mv (next-method-p))) -(defmethod nmp-gf-05 ((x integer)) 'foo) - -(deftest next-method-p.10 - (nmp-gf-05 10) - t) - -;; Need to also test next-method-p in builtin method combinations - -;;; Error tests - -(deftest next-method-p.error.1 - (signals-error - (progn - (eval '(defmethod nmp-gf-06 ((x t)) (next-method-p nil))) - (nmp-gf-06 nil)) - program-error) - t) diff --git a/t/ansi-test/objects/no-applicable-method.lsp b/t/ansi-test/objects/no-applicable-method.lsp deleted file mode 100644 index d0f09d8..0000000 --- a/t/ansi-test/objects/no-applicable-method.lsp +++ /dev/null @@ -1,18 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun May 11 13:46:44 2003 -;;;; Contains: Tests of NO-APPLICABLE-METHOD - - - -(defgeneric no-app-meth-gf-01 (x)) - -(deftest no-applicable-method.1 - (handler-case - (progn (no-app-meth-gf-01 'x) :bad) - (error () :good)) - :good) - -;;; I can't conformantly define useful methods for no-applicable-method -;;; without defining new generic function classes, and there's -;;; no standard way to do that. Grrr. \ No newline at end of file diff --git a/t/ansi-test/objects/no-next-method.lsp b/t/ansi-test/objects/no-next-method.lsp deleted file mode 100644 index a70098f..0000000 --- a/t/ansi-test/objects/no-next-method.lsp +++ /dev/null @@ -1,46 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun May 11 14:41:50 2003 -;;;; Contains: Tests of NO-NEXT-METHOD - - - -(defgeneric no-next-meth-gf-01 (x)) - -(defmethod no-next-meth-gf-01 ((x integer)) - (call-next-method)) - -(defmethod no-next-meth-gf-01 :around ((x character)) - (call-next-method)) - -(deftest no-next-method.1 - (handler-case (progn (no-next-meth-gf-01 10) :bad) - (error () :good)) - :good) - -(deftest no-next-method.2 - (handler-case (progn (no-next-meth-gf-01 ) :bad) - (error () :good)) - :good) - -;;; (defparameter *no-next-meth-gf-02* -;;; (defgeneric no-next-meth-gf-02 (x))) -;;; -;;; (defmethod no-next-meth-gf-02 ((x integer)) -;;; (call-next-method)) -;;; -;;; (defmethod no-next-meth-gf-02 :around ((x character)) -;;; (call-next-method)) -;;; -;;; (defmethod no-next-method ((gf (eql *no-next-meth-gf-02*)) -;;; (method standard-method) -;;; &rest args) -;;; (values (copy-list args) :aborted)) -;;; -;;; (deftest no-next-method.3 -;;; (no-next-meth-gf-02 10) -;;; (10) :aborted) -;;; -;;; (deftest no-next-method.4 -;;; (no-next-meth-gf-02 #\a) -;;; (#\a) :aborted) diff --git a/t/ansi-test/objects/reinitialize-instance.lsp b/t/ansi-test/objects/reinitialize-instance.lsp deleted file mode 100644 index 6c486f7..0000000 --- a/t/ansi-test/objects/reinitialize-instance.lsp +++ /dev/null @@ -1,134 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Apr 28 21:56:47 2003 -;;;; Contains: Tests for REINITIALIZE-INSTANCE - - - -;;; Many of the classes used here are defined in defclass-??.lsp - -(deftest reinitialize-instance.1 - (let* ((obj (make-instance 'class-01)) - (obj2 (reinitialize-instance obj))) - (values - (eqt obj obj2) - (map-slot-boundp* obj '(s1 s2 s3)))) - t (nil nil nil)) - - -(deftest reinitialize-instance.2 - (let* ((obj (make-instance 'class-01)) - (obj2 (reinitialize-instance obj :allow-other-keys nil))) - (values - (eqt obj obj2) - (map-slot-boundp* obj '(s1 s2 s3)))) - t (nil nil nil)) - -(deftest reinitialize-instance.3 - (let* ((obj (make-instance 'class-01)) - (obj2 (reinitialize-instance obj :allow-other-keys t))) - (values - (eqt obj obj2) - (map-slot-boundp* obj '(s1 s2 s3)))) - t (nil nil nil)) - -(deftest reinitialize-instance.4 - (let* ((obj (make-instance 'class-01)) - (obj2 (reinitialize-instance obj :allow-other-keys t - :allow-other-keys nil))) - (values - (eqt obj obj2) - (map-slot-boundp* obj '(s1 s2 s3)))) - t (nil nil nil)) - -(deftest reinitialize-instance.5 - (let* ((obj (make-instance 'class-07)) - (obj2 (reinitialize-instance obj :s1a 'a :s2 'b :s1a 'bad - :s2 'bad2 :s1b 'bad3))) - (values - (eqt obj obj2) - (map-slot-value obj '(s1 s2)))) - t (a b)) - -(deftest reinitialize-instance.6 - (let* ((obj (make-instance 'class-07 :s1a 'a)) - (obj2 (reinitialize-instance obj :s1b 'b))) - (values - (eqt obj obj2) - (slot-value obj 's1) - (slot-boundp* obj 's2))) - t b nil) - -(deftest reinitialize-instance.7 - (let* ((obj (make-instance 'class-07 :s1a 'a)) - (obj2 (reinitialize-instance obj :s2 'b))) - (values - (eqt obj obj2) - (slot-value obj 's1) - (slot-value obj 's2))) - t a b) - - -;;; Tests of user-defined methods - -(defclass reinit-class-01 () - ((a :initarg :a) (b :initarg :b))) - -(defmethod reinitialize-instance :after ((instance reinit-class-01) - &rest initargs - &key (x nil x-p)) - (declare (ignore initargs)) - (when x-p (setf (slot-value instance 'a) x)) - instance) - -(deftest reinitialize-instance.8 - (let* ((obj (make-instance 'reinit-class-01)) - (obj2 (reinitialize-instance obj :a 1 :b 3))) - (values - (eqt obj obj2) - (map-slot-value obj2 '(a b)))) - t (1 3)) - -(deftest reinitialize-instance.9 - (let* ((obj (make-instance 'reinit-class-01 :a 10 :b 20)) - (obj2 (reinitialize-instance obj :x 3))) - (values - (eqt obj obj2) - (map-slot-value obj2 '(a b)))) - t (3 20)) - -(deftest reinitialize-instance.10 - (let* ((obj (make-instance 'reinit-class-01 :a 10 :b 20)) - (obj2 (reinitialize-instance obj :x 3 :x 100))) - (values - (eqt obj obj2) - (map-slot-value obj2 '(a b)))) - t (3 20)) - -;;; Order of evaluation tests - -(deftest reinitialize-instance.order.1 - (let* ((obj (make-instance 'reinit-class-01)) - (i 0) x y z w - (obj2 (reinitialize-instance - (progn (setf x (incf i)) obj) - :b (setf y (incf i)) - :a (setf z (incf i)) - :b (setf w (incf i))))) - (values - (eqt obj obj2) - (map-slot-value obj2 '(a b)) - i x y z w)) - t (3 2) 4 1 2 3 4) - -;;; Error cases - -(deftest reinitialize-instance.error.1 - (handler-case - (eval '(reinitialize-instance (make-instance 'class-01) :garbage t)) - (error () :good)) - :good) - -(deftest reinitialize-instance.error.2 - (signals-error (reinitialize-instance) program-error) - t) diff --git a/t/ansi-test/objects/remove-method.lsp b/t/ansi-test/objects/remove-method.lsp deleted file mode 100644 index 5a7e31f..0000000 --- a/t/ansi-test/objects/remove-method.lsp +++ /dev/null @@ -1,228 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun May 11 19:53:37 2003 -;;;; Contains: Tests of REMOVE-METHOD - - - -(defparameter *remove-meth-gf-01* - (defgeneric remove-meth-gf-01 (x))) - -(defparameter *remove-meth-gf-01-method-t* - (defmethod remove-meth-gf-01 ((x t)) x)) - -(defparameter *remove-meth-gf-02* - (defgeneric remove-meth-gf-02 (x))) - -(defparameter *remove-meth-gf-02-method-t* - (defmethod remove-meth-gf-02 ((x t)) x)) - -;;; remove method must not signal an error if the method -;;; does not belong to the generic function - -(deftest remove-method.1 - (and - (eqt (remove-method *remove-meth-gf-01* *remove-meth-gf-02-method-t*) - *remove-meth-gf-01*) - (remove-meth-gf-01 :good)) - :good) - -;;; Add, then remove, a method - -(deftest remove-method.2 - (let (meth) - (values - (remove-meth-gf-01 10) - (progn (setf meth (eval '(defmethod remove-meth-gf-01 ((x integer)) - (1+ x)))) - nil) - (remove-meth-gf-01 10) - (eqt *remove-meth-gf-01* - (remove-method *remove-meth-gf-01* meth)) - (remove-meth-gf-01 10))) - 10 nil 11 t 10) - -;;; Add two disjoint methods, then remove - -(deftest remove-method.3 - (let (meth1 meth2) - (values - (mapcar #'remove-meth-gf-01 '(19 a)) - (progn - (setf meth1 (eval '(defmethod remove-meth-gf-01 ((x symbol)) - (list x)))) - - (mapcar #'remove-meth-gf-01 '(19 a))) - (progn - (setf meth2 (eval '(defmethod remove-meth-gf-01 ((x number)) - (1+ x)))) - - (mapcar #'remove-meth-gf-01 '(19 a))) - (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth1)) - (mapcar #'remove-meth-gf-01 '(19 a)) - (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth2)) - (mapcar #'remove-meth-gf-01 '(19 a)))) - (19 a) (19 (a)) (20 (a)) t (20 a) t (19 a)) - -;;; Remove in the other order - -(deftest remove-method.4 - (let (meth1 meth2) - (values - (mapcar #'remove-meth-gf-01 '(19 a)) - (progn - (setf meth1 (eval '(defmethod remove-meth-gf-01 ((x symbol)) - (list x)))) - - (mapcar #'remove-meth-gf-01 '(19 a))) - (progn - (setf meth2 (eval '(defmethod remove-meth-gf-01 ((x number)) - (1+ x)))) - - (mapcar #'remove-meth-gf-01 '(19 a))) - (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth2)) - (mapcar #'remove-meth-gf-01 '(19 a)) - (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth1)) - (mapcar #'remove-meth-gf-01 '(19 a)))) - (19 a) (19 (a)) (20 (a)) t (19 (a)) t (19 a)) - -;;; Now methods that shadow one another - -(deftest remove-method.5 - (let (meth1 meth2) - (values - (mapcar #'remove-meth-gf-01 '(10 20.0)) - (progn - (setf meth1 (eval '(defmethod remove-meth-gf-01 ((x integer)) - (1- x)))) - - (mapcar #'remove-meth-gf-01 '(10 20.0))) - (progn - (setf meth2 (eval '(defmethod remove-meth-gf-01 ((x number)) - (1+ x)))) - - (mapcar #'remove-meth-gf-01 '(10 20.0))) - (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth1)) - (mapcar #'remove-meth-gf-01 '(10 20.0)) - (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth2)) - (mapcar #'remove-meth-gf-01 '(10 20.0)))) - (10 20.0) (9 20.0) (9 21.0) t (11 21.0) t (10 20.0)) - -(deftest remove-method.6 - (let (meth1 meth2) - (values - (mapcar #'remove-meth-gf-01 '(10 20.0)) - (progn - (setf meth1 (eval '(defmethod remove-meth-gf-01 ((x integer)) - (1- x)))) - - (mapcar #'remove-meth-gf-01 '(10 20.0))) - (progn - (setf meth2 (eval '(defmethod remove-meth-gf-01 ((x number)) - (1+ x)))) - - (mapcar #'remove-meth-gf-01 '(10 20.0))) - (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth2)) - (mapcar #'remove-meth-gf-01 '(10 20.0)) - (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth1)) - (mapcar #'remove-meth-gf-01 '(10 20.0)))) - (10 20.0) (9 20.0) (9 21.0) t (9 20.0) t (10 20.0)) - -(deftest remove-method.7 - (let (meth1 meth2) - (values - (mapcar #'remove-meth-gf-01 '(10 20.0)) - (progn - (setf meth1 (eval '(defmethod remove-meth-gf-01 ((x number)) - (1+ x)))) - - (mapcar #'remove-meth-gf-01 '(10 20.0))) - (progn - (setf meth2 (eval '(defmethod remove-meth-gf-01 ((x integer)) - (1- x)))) - - (mapcar #'remove-meth-gf-01 '(10 20.0))) - (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth1)) - (mapcar #'remove-meth-gf-01 '(10 20.0)) - (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth2)) - (mapcar #'remove-meth-gf-01 '(10 20.0)))) - (10 20.0) (11 21.0) (9 21.0) t (9 20.0) t (10 20.0)) - -(deftest remove-method.8 - (let (meth1 meth2) - (values - (mapcar #'remove-meth-gf-01 '(10 20.0)) - (progn - (setf meth1 (eval '(defmethod remove-meth-gf-01 ((x number)) - (1+ x)))) - - (mapcar #'remove-meth-gf-01 '(10 20.0))) - (progn - (setf meth2 (eval '(defmethod remove-meth-gf-01 ((x integer)) - (1- x)))) - - (mapcar #'remove-meth-gf-01 '(10 20.0))) - (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth2)) - (mapcar #'remove-meth-gf-01 '(10 20.0)) - (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth1)) - (mapcar #'remove-meth-gf-01 '(10 20.0)))) - (10 20.0) (11 21.0) (9 21.0) t (11 21.0) t (10 20.0)) - -;;; Adding and removing auxiliary methods - -(declaim (special *rmgf-03-var*)) - -(defparameter *remove-meth-gf-03* - (defgeneric remove-meth-gf-03 (x))) - -(defparameter *remove-meth-gf-03-method-t* - (defmethod remove-meth-gf-03 ((x t)) (list *rmgf-03-var* x))) - -(deftest remove-method.9 - (let (meth (*rmgf-03-var* 0)) - (values - (mapcar #'remove-meth-gf-03 '(5 a)) - (progn - (setf meth (eval '(defmethod remove-meth-gf-03 :before ((x number)) - (incf *rmgf-03-var*)))) - (mapcar #'remove-meth-gf-03 '(5 a))) - (eqt *remove-meth-gf-03* (remove-method *remove-meth-gf-03* meth)) - (mapcar #'remove-meth-gf-03 '(5 a)))) - ((0 5) (0 a)) - ((1 5) (1 a)) - t - ((1 5) (1 a))) - -(deftest remove-method.10 - (let (meth (*rmgf-03-var* 0)) - (values - (mapcar #'remove-meth-gf-03 '(5 a)) - (progn - (setf meth (eval '(defmethod remove-meth-gf-03 :after ((x number)) - (incf *rmgf-03-var*)))) - (mapcar #'remove-meth-gf-03 '(5 a))) - (eqt *remove-meth-gf-03* (remove-method *remove-meth-gf-03* meth)) - (mapcar #'remove-meth-gf-03 '(5 a)))) - ((0 5) (0 a)) - ((0 5) (1 a)) - t - ((1 5) (1 a))) - -(deftest remove-method.11 - (let (meth (*rmgf-03-var* 0)) - (values - (mapcar #'remove-meth-gf-03 '(5 a)) - (progn - (setf meth (eval '(defmethod remove-meth-gf-03 :around ((x number)) - (incf *rmgf-03-var*) - (prog1 (call-next-method) - (decf *rmgf-03-var*))))) - (mapcar #'remove-meth-gf-03 '(5 a))) - (eqt *remove-meth-gf-03* (remove-method *remove-meth-gf-03* meth)) - (mapcar #'remove-meth-gf-03 '(5 a)))) - ((0 5) (0 a)) - ((1 5) (0 a)) - t - ((0 5) (0 a))) - -;;; Must add tests for nonstandard method combinations diff --git a/t/ansi-test/objects/shared-initialize.lsp b/t/ansi-test/objects/shared-initialize.lsp deleted file mode 100644 index db16232..0000000 --- a/t/ansi-test/objects/shared-initialize.lsp +++ /dev/null @@ -1,705 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Apr 29 04:09:06 2003 -;;;; Contains: Tests of SHARED-INITIALIZE - - - -(defclass shared-init-class-01 () - ((a :initform 'x :initarg :a) - (b :initform 'y :initarg :b) - (c :initarg :c) - d)) - -(deftest shared-initialize.1.1 - (let ((obj (allocate-instance (find-class 'shared-init-class-01)))) - (values - (map-slot-boundp* obj '(a b c d)) - (eqt obj (shared-initialize obj nil :a 1 :b 3 :c 14)) - (map-slot-boundp* obj '(a b c d)) - (map-slot-value obj '(a b c)))) - (nil nil nil nil) - t - (t t t nil) - (1 3 14)) - -(deftest shared-initialize.1.2 - (let ((obj (allocate-instance (find-class 'shared-init-class-01)))) - (values - (map-slot-boundp* obj '(a b c d)) - (eqt obj (shared-initialize obj nil)) - (map-slot-boundp* obj '(a b c d)))) - (nil nil nil nil) - t - (nil nil nil nil)) - -(deftest shared-initialize.1.3 - (let ((obj (allocate-instance (find-class 'shared-init-class-01)))) - (values - (map-slot-boundp* obj '(a b c d)) - (eqt obj (shared-initialize obj nil :a 1 :a 2)) - (map-slot-boundp* obj '(a b c d)) - (slot-value obj 'a))) - (nil nil nil nil) - t - (t nil nil nil) - 1) - -(deftest shared-initialize.1.4 - (let ((obj (allocate-instance (find-class 'shared-init-class-01)))) - (values - (map-slot-boundp* obj '(a b c d)) - (eqt obj (shared-initialize obj nil :a 1 :a 2 :allow-other-keys nil)) - (map-slot-boundp* obj '(a b c d)) - (slot-value obj 'a))) - (nil nil nil nil) - t - (t nil nil nil) - 1) - -(deftest shared-initialize.1.5 - (let ((obj (allocate-instance (find-class 'shared-init-class-01)))) - (values - (map-slot-boundp* obj '(a b c d)) - (eqt obj (shared-initialize obj '(a) :a 1)) - (map-slot-boundp* obj '(a b c d)) - (slot-value obj 'a))) - (nil nil nil nil) - t - (t nil nil nil) - 1) - -(deftest shared-initialize.1.6 - (let ((obj (allocate-instance (find-class 'shared-init-class-01)))) - (values - (map-slot-boundp* obj '(a b c d)) - (eqt obj (shared-initialize obj '(a))) - (map-slot-boundp* obj '(a b c d)) - (slot-value obj 'a))) - (nil nil nil nil) - t - (t nil nil nil) - x) - -(deftest shared-initialize.1.7 - (let ((obj (allocate-instance (find-class 'shared-init-class-01)))) - (values - (map-slot-boundp* obj '(a b c d)) - (eqt obj (shared-initialize obj t)) - (map-slot-boundp* obj '(a b c d)) - (slot-value obj 'a) - (slot-value obj 'b))) - (nil nil nil nil) - t - (t t nil nil) - x y) - -(deftest shared-initialize.1.8 - (let ((obj (allocate-instance (find-class 'shared-init-class-01)))) - (values - (map-slot-boundp* obj '(a b c d)) - (eqt obj (shared-initialize obj t :b 10 :c 100)) - (map-slot-boundp* obj '(a b c d)) - (slot-value obj 'a) - (slot-value obj 'b) - (slot-value obj 'c))) - (nil nil nil nil) - t - (t t t nil) - x 10 100) - -(deftest shared-initialize.1.9 - (let ((obj (allocate-instance (find-class 'shared-init-class-01)))) - (values - (map-slot-boundp* obj '(a b c d)) - (eqt obj (shared-initialize obj nil :a 1 :b 10 :c 100)) - (eqt obj (shared-initialize obj nil :a 5 :b 37 :c 213)) - (map-slot-boundp* obj '(a b c d)) - (slot-value obj 'a) - (slot-value obj 'b) - (slot-value obj 'c))) - (nil nil nil nil) - t t - (t t t nil) - 5 37 213) - -(deftest shared-initialize.1.10 - (let ((obj (allocate-instance (find-class 'shared-init-class-01)))) - (setf (slot-value obj 'a) 1000) - (values - (map-slot-boundp* obj '(a b c d)) - (eqt obj (shared-initialize obj '(a))) - (map-slot-boundp* obj '(a b c d)) - (slot-value obj 'a))) - (t nil nil nil) - t - (t nil nil nil) - 1000) - -;;; Initforms in the lexical environment of the defclass - -(declaim (special *shared-init-var-02-init* - *shared-init-var-02-query*)) - -(declaim (type function *shared-init-var-02-init* *shared-init-var-02-query*)) - -(let ((ainit 0) (binit 0)) - (flet ((%init (a b) (setf ainit a binit b)) - (%query () (list ainit binit))) - (setf *shared-init-var-02-init* #'%init - *shared-init-var-02-query* #'%query) - (defclass shared-init-class-02 () - ((a :initform (incf ainit) :initarg :a) - (b :initform (incf binit) :initarg :b) - (c :initarg :c) - (d)) - (:default-initargs :c 100)))) - -(deftest shared-initialize.2.1 - (progn - (funcall *shared-init-var-02-init* 5 10) - (let ((obj (allocate-instance (find-class 'shared-init-class-02)))) - (values - (funcall *shared-init-var-02-query*) - (eqt obj (shared-initialize obj t)) - (slot-value obj 'a) - (slot-value obj 'b) - (map-slot-boundp* obj '(a b c d)) - (funcall *shared-init-var-02-query*)))) - (5 10) - t - 6 11 - (t t nil nil) - (6 11)) - -(deftest shared-initialize.2.2 - (progn - (funcall *shared-init-var-02-init* 5 10) - (let ((obj (allocate-instance (find-class 'shared-init-class-02)))) - (values - (funcall *shared-init-var-02-query*) - (eqt obj (shared-initialize obj nil)) - (map-slot-boundp* obj '(a b c d)) - (funcall *shared-init-var-02-query*)))) - (5 10) - t - (nil nil nil nil) - (5 10)) - -(deftest shared-initialize.2.3 - (progn - (funcall *shared-init-var-02-init* 5 10) - (let ((obj (allocate-instance (find-class 'shared-init-class-02)))) - (values - (funcall *shared-init-var-02-query*) - (eqt obj (shared-initialize obj '(a))) - (slot-value obj 'a) - (map-slot-boundp* obj '(a b c d)) - (funcall *shared-init-var-02-query*)))) - (5 10) - t - 6 - (t nil nil nil) - (6 10)) - -(deftest shared-initialize.2.4 - (progn - (funcall *shared-init-var-02-init* 5 10) - (let ((obj (allocate-instance (find-class 'shared-init-class-02)))) - (values - (funcall *shared-init-var-02-query*) - (eqt obj (shared-initialize obj '(b))) - (slot-value obj 'b) - (map-slot-boundp* obj '(a b c d)) - (funcall *shared-init-var-02-query*)))) - (5 10) - t - 11 - (nil t nil nil) - (5 11)) - -(deftest shared-initialize.2.5 - (progn - (funcall *shared-init-var-02-init* 5 10) - (let ((obj (allocate-instance (find-class 'shared-init-class-02)))) - (values - (funcall *shared-init-var-02-query*) - (eqt obj (shared-initialize obj t :a 34 :b 49)) - (map-slot-value obj '(a b)) - (map-slot-boundp* obj '(a b c d)) - (funcall *shared-init-var-02-query*)))) - (5 10) - t - (34 49) - (t t nil nil) - (5 10)) - -(deftest shared-initialize.2.6 - (progn - (funcall *shared-init-var-02-init* 5 10) - (let ((obj (allocate-instance (find-class 'shared-init-class-02)))) - (values - (funcall *shared-init-var-02-query*) - (eqt obj (shared-initialize obj '(a b c d) :a 34 :b 49)) - (map-slot-value obj '(a b)) - (map-slot-boundp* obj '(a b c d)) - (funcall *shared-init-var-02-query*)))) - (5 10) - t - (34 49) - (t t nil nil) - (5 10)) - -;;; Defining new methods on shared-initialize - -(defstruct shared-init-class-03 - a b c) - -(defmethod shared-initialize ((obj shared-init-class-03) - slots-to-init - &key - (a nil a-p) - (b nil b-p) - (c nil c-p) - &allow-other-keys) - (declare (ignore slots-to-init)) -;; (when a-p (setf (slot-value obj 'a) a)) -;; (when b-p (setf (slot-value obj 'b) b)) -;; (when c-p (setf (slot-value obj 'c) c)) - (when a-p (setf (shared-init-class-03-a obj) a)) - (when b-p (setf (shared-init-class-03-b obj) b)) - (when c-p (setf (shared-init-class-03-c obj) c)) - obj) - -(deftest shared-initialize.3.1 - (let ((obj (make-shared-init-class-03))) - (values - (eqt obj (shared-initialize obj nil :a 1 :b 5 :c 19)) - (shared-init-class-03-a obj) - (shared-init-class-03-b obj) - (shared-init-class-03-c obj))) - t 1 5 19) - - -;;; Inheritance - -(defclass shared-init-class-04a () - ((a :initform 4 :initarg :a) - (b :initform 8 :initarg :b))) - -(defclass shared-init-class-04b (shared-init-class-04a) - ((c :initform 17 :initarg :c) d) - (:default-initargs :a 1)) - -(deftest shared-initialize.4.1 - (let ((obj (allocate-instance (find-class 'shared-init-class-04b)))) - (values - (eqt obj (shared-initialize obj nil :a 'x)) - (map-slot-boundp* obj '(a b c d)) - (slot-value obj 'a))) - t - (t nil nil nil) - x) - -(deftest shared-initialize.4.2 - (let ((obj (allocate-instance (find-class 'shared-init-class-04b)))) - (values - (eqt obj (shared-initialize obj nil)) - (map-slot-boundp* obj '(a b c d)))) - t - (nil nil nil nil)) - -(deftest shared-initialize.4.3 - (let ((obj (allocate-instance (find-class 'shared-init-class-04b)))) - (values - (eqt obj (shared-initialize obj t)) - (map-slot-boundp* obj '(a b c d)) - (map-slot-value obj '(a b c)))) - t - (t t t nil) - (4 8 17)) - -(deftest shared-initialize.4.4 - (let ((obj (allocate-instance (find-class 'shared-init-class-04b)))) - (values - (eqt obj (shared-initialize obj '(a c))) - (map-slot-boundp* obj '(a b c d)) - (map-slot-value obj '(a c)))) - t - (t nil t nil) - (4 17)) - -(deftest shared-initialize.4.5 - (let ((obj (allocate-instance (find-class 'shared-init-class-04b)))) - (values - (eqt obj (shared-initialize obj '(a c) :c 81)) - (map-slot-boundp* obj '(a b c d)) - (map-slot-value obj '(a c)))) - t - (t nil t nil) - (4 81)) - -(deftest shared-initialize.4.6 - (let ((obj (allocate-instance (find-class 'shared-init-class-04b)))) - (values - (eqt obj (shared-initialize obj '(a c) :a 91)) - (map-slot-boundp* obj '(a b c d)) - (map-slot-value obj '(a c)))) - t - (t nil t nil) - (91 17)) - -(deftest shared-initialize.4.7 - (let ((obj (allocate-instance (find-class 'shared-init-class-04b)))) - (values - (eqt obj (shared-initialize obj '(c))) - (map-slot-boundp* obj '(a b c d)) - (slot-value obj 'c))) - t - (nil nil t nil) - 17) - -;;; shared-initialize and class slots - -(defclass shared-init-class-05 () - ((a :initarg :a :allocation :class) - (b :initarg :b :initform 'foo :allocation :class))) - -(deftest shared-initialize.5.1 - (let* ((class (find-class 'shared-init-class-05)) - (obj (allocate-instance class))) - (slot-makunbound obj 'a) - (slot-makunbound obj 'b) - (values - (eqt obj (shared-initialize obj t)) - (map-slot-boundp* obj '(a b)) - (slot-value obj 'b))) - t - (nil t) - foo) - -(deftest shared-initialize.5.2 - (let* ((class (find-class 'shared-init-class-05)) - (obj (allocate-instance class))) - (slot-makunbound obj 'a) - (slot-makunbound obj 'b) - (values - (eqt obj (shared-initialize obj '(b))) - (map-slot-boundp* obj '(a b)) - (slot-value obj 'b))) - t - (nil t) - foo) - -(deftest shared-initialize.5.3 - (let* ((class (find-class 'shared-init-class-05)) - (obj (allocate-instance class)) - (obj2 (allocate-instance class))) - (slot-makunbound obj 'a) - (slot-makunbound obj 'b) - (values - (eqt obj (shared-initialize obj t :a 117)) - (map-slot-boundp* obj '(a b)) - (map-slot-value obj '(a b)) - (map-slot-value obj2 '(a b)))) - t - (t t) - (117 foo) - (117 foo)) - -(deftest shared-initialize.5.4 - (let* ((class (find-class 'shared-init-class-05)) - (obj (allocate-instance class)) - (obj2 (allocate-instance class))) - (slot-makunbound obj 'a) - (values - (setf (slot-value obj 'b) 'bar) - (eqt obj (shared-initialize obj t :a 117)) - (map-slot-boundp* obj '(a b)) - (map-slot-value obj '(a b)) - (map-slot-value obj2 '(a b)))) - bar - t - (t t) - (117 bar) - (117 bar)) - -;;; Shared initargs - -(defclass shared-init-class-06 () - ((a :initarg :i1 :initarg :i2 :initform 'x) - (b :initarg :i2 :initarg :i3 :initform 'y))) - -(deftest shared-initialize.6.1 - (let* ((class (find-class 'shared-init-class-06)) - (obj (allocate-instance class))) - (values - (map-slot-boundp* obj '(a b)) - (eqt obj (shared-initialize obj nil)) - (map-slot-boundp* obj '(a b)))) - (nil nil) - t - (nil nil)) - -(deftest shared-initialize.6.2 - (let* ((class (find-class 'shared-init-class-06)) - (obj (allocate-instance class))) - (values - (map-slot-boundp* obj '(a b)) - (eqt obj (shared-initialize obj t)) - (map-slot-boundp* obj '(a b)) - (slot-value obj 'a) - (slot-value obj 'b))) - (nil nil) - t - (t t) - x y) - -(deftest shared-initialize.6.3 - (let* ((class (find-class 'shared-init-class-06)) - (obj (allocate-instance class))) - (values - (map-slot-boundp* obj '(a b)) - (eqt obj (shared-initialize obj nil :i1 'z)) - (map-slot-boundp* obj '(a b)) - (slot-value obj 'a))) - (nil nil) - t - (t nil) - z) - -(deftest shared-initialize.6.4 - (let* ((class (find-class 'shared-init-class-06)) - (obj (allocate-instance class))) - (values - (map-slot-boundp* obj '(a b)) - (eqt obj (shared-initialize obj nil :i2 'z)) - (map-slot-boundp* obj '(a b)) - (slot-value obj 'a) - (slot-value obj 'b))) - (nil nil) - t - (t t) - z z) - -(deftest shared-initialize.6.5 - (let* ((class (find-class 'shared-init-class-06)) - (obj (allocate-instance class))) - (values - (map-slot-boundp* obj '(a b)) - (eqt obj (shared-initialize obj nil :i1 'w :i2 'z)) - (map-slot-boundp* obj '(a b)) - (slot-value obj 'a) - (slot-value obj 'b))) - (nil nil) - t - (t t) - w z) - -(deftest shared-initialize.6.6 - (let* ((class (find-class 'shared-init-class-06)) - (obj (allocate-instance class))) - (values - (map-slot-boundp* obj '(a b)) - (eqt obj (shared-initialize obj nil :i2 'z :i1 'w)) - (map-slot-boundp* obj '(a b)) - (slot-value obj 'a) - (slot-value obj 'b))) - (nil nil) - t - (t t) - z z) - -(deftest shared-initialize.6.7 - (let* ((class (find-class 'shared-init-class-06)) - (obj (allocate-instance class))) - (values - (map-slot-boundp* obj '(a b)) - (eqt obj (shared-initialize obj nil :i2 'z :i2 'w)) - (map-slot-boundp* obj '(a b)) - (slot-value obj 'a) - (slot-value obj 'b))) - (nil nil) - t - (t t) - z z) - - -(deftest shared-initialize.6.8 - (let* ((class (find-class 'shared-init-class-06)) - (obj (allocate-instance class))) - (values - (map-slot-boundp* obj '(a b)) - (eqt obj (shared-initialize obj nil :i2 'z :i2 'w :foo t)) - (map-slot-boundp* obj '(a b)) - (slot-value obj 'a) - (slot-value obj 'b))) - (nil nil) - t - (t t) - z z) - - -(deftest shared-initialize.6.9 - (let* ((class (find-class 'shared-init-class-06)) - (obj (allocate-instance class))) - (values - (map-slot-boundp* obj '(a b)) - (eqt obj (shared-initialize obj nil :allow-other-keys nil - :i2 'z :i2 'w :foo t)) - (map-slot-boundp* obj '(a b)) - (slot-value obj 'a) - (slot-value obj 'b))) - (nil nil) - t - (t t) - z z) - -;;; Before methods fill in slots before the default system method - -(defclass shared-init-class-07 () - ((a :initform 'x) - (b :initform 'y))) - -(defmethod shared-initialize :before ((obj shared-init-class-07) slot-names &rest args) - (declare (ignore args slot-names)) - (setf (slot-value obj 'a) 'foo) - obj) - -(deftest shared-initialize.7.1 - (let* ((class (find-class 'shared-init-class-07)) - (obj (allocate-instance class))) - (values - (map-slot-boundp* obj '(a b)) - (eqt obj (shared-initialize obj nil)) - (map-slot-boundp* obj '(a b)) - (slot-value obj 'a))) - (nil nil) t (t nil) foo) - -(deftest shared-initialize.7.2 - (let* ((class (find-class 'shared-init-class-07)) - (obj (allocate-instance class))) - (values - (map-slot-boundp* obj '(a b)) - (eqt obj (shared-initialize obj t)) - (map-slot-boundp* obj '(a b)) - (slot-value obj 'a) - (slot-value obj 'b))) - (nil nil) t (t t) foo y) - -;;; :around method tests - -(defclass shared-init-class-08 () - ((a :initform 'x) - (b :initform 'y))) - -(defmethod shared-initialize :around ((obj shared-init-class-08) slot-names - &rest args &key only &allow-other-keys) - (declare (ignore slot-names args)) - (setf (slot-value obj 'a) 'foo) - (if only obj (call-next-method))) - -(deftest shared-initialize.8.1 - (let* ((class (find-class 'shared-init-class-08)) - (obj (allocate-instance class))) - (values - (map-slot-boundp* obj '(a b)) - (eqt obj (shared-initialize obj nil)) - (map-slot-boundp* obj '(a b)) - (slot-value obj 'a))) - (nil nil) - t - (t nil) - foo) - -(deftest shared-initialize.8.2 - (let* ((class (find-class 'shared-init-class-08)) - (obj (allocate-instance class))) - (values - (map-slot-boundp* obj '(a b)) - (eqt obj (shared-initialize obj t)) - (map-slot-boundp* obj '(a b)) - (slot-value obj 'a) - (slot-value obj 'b))) - (nil nil) - t - (t t) - foo y) - -(deftest shared-initialize.8.3 - (let* ((class (find-class 'shared-init-class-08)) - (obj (allocate-instance class))) - (values - (map-slot-boundp* obj '(a b)) - (eqt obj (shared-initialize obj t :only t)) - (map-slot-boundp* obj '(a b)) - (slot-value obj 'a))) - (nil nil) - t - (t nil) - foo) - -;;; - -(defclass shared-init-class-09 () - ((a :allocation :class :initform 'x) - (b :initform 'y))) - -(deftest shared-initialize.9.1 - (let* ((class (find-class 'shared-init-class-09)) - (obj (allocate-instance class))) - (slot-makunbound obj 'a) - (values - (map-slot-boundp* obj '(a b)) - (eqt obj (shared-initialize obj '(b))) - (map-slot-boundp* obj '(a b)) - (slot-value obj 'b))) - (nil nil) - t - (nil t) - y) - -;;; Order of evaluation tests - -(deftest shared-initialize.order.1 - (let ((obj (allocate-instance (find-class 'shared-init-class-01))) - (i 0) x r y z w q) - (values - (eqt obj - (shared-initialize (progn (setf x (incf i)) obj) - (progn (setf r (incf i)) nil) - :b (setf y (incf i)) - :a (setf z (incf i)) - :b (setf w (incf i)) - :c (setf q (incf i)))) - (map-slot-value obj '(a b c)) - i x r y z w q)) - t (4 3 6) - 6 1 2 3 4 5 6) - -;;; Error tests - -(deftest shared-initialize.error.1 - (signals-error (shared-initialize) program-error) - t) - -(deftest shared-initialize.error.2 - (signals-error (let ((obj (allocate-instance - (find-class 'shared-init-class-01)))) - (shared-initialize obj)) - program-error) - t) - -(deftest shared-initialize.error.3 - (signals-error (let ((obj (allocate-instance - (find-class 'shared-init-class-01)))) - (shared-initialize obj nil :a)) - program-error) - t) - -(deftest shared-initialize.error.4 - (signals-error (let ((obj (allocate-instance - (find-class 'shared-init-class-01)))) - (shared-initialize obj nil '(a b c) nil)) - program-error) - t) diff --git a/t/ansi-test/objects/slot-boundp.lsp b/t/ansi-test/objects/slot-boundp.lsp deleted file mode 100644 index fd39509..0000000 --- a/t/ansi-test/objects/slot-boundp.lsp +++ /dev/null @@ -1,85 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue May 6 05:53:32 2003 -;;;; Contains: Tests of SLOT-BOUNDP - - - -;;; SLOT-BOUNDP is extensively tested in other files as well - -(defclass slot-boundp-class-01 () - (a (b :initarg :b) (c :initform 'x))) - -(deftest slot-boundp.1 - (let ((obj (make-instance 'slot-boundp-class-01))) - (slot-boundp obj 'a)) - nil) - -(deftest slot-boundp.2 - (let ((obj (make-instance 'slot-boundp-class-01))) - (setf (slot-value obj 'a) nil) - (notnot-mv (slot-boundp obj 'a))) - t) - -(deftest slot-boundp.3 - (let ((obj (make-instance 'slot-boundp-class-01 :b nil))) - (notnot-mv (slot-boundp obj 'b))) - t) - -(deftest slot-boundp.4 - (let ((obj (make-instance 'slot-boundp-class-01))) - (notnot-mv (slot-boundp obj 'c))) - t) - -(deftest slot-boundp.5 - (let ((obj (make-instance 'slot-boundp-class-01))) - (slot-makunbound obj 'c) - (slot-boundp obj 'c)) - nil) - -;;; Argument order test(s) - -(deftest slot-boundp.order.1 - (let ((obj (make-instance 'slot-boundp-class-01)) - (i 0) x y) - (values - (slot-boundp (progn (setf x (incf i)) obj) - (progn (setf y (incf i)) 'a)) - i x y)) - nil 2 1 2) - -;;; Error tests - -(deftest slot-boundp.error.1 - (signals-error (slot-boundp) program-error) - t) - -(deftest slot-boundp.error.2 - (signals-error (let ((obj (make-instance 'slot-boundp-class-01))) - (slot-boundp obj)) - program-error) - t) - -(deftest slot-boundp.error.3 - (signals-error (let ((obj (make-instance 'slot-boundp-class-01))) - (slot-boundp obj 'a nil)) - program-error) - t) - -(deftest slot-boundp.error.4 - (signals-error - (let ((obj (make-instance 'slot-boundp-class-01))) - (slot-boundp obj 'nonexistent-slot)) - error) - t) - -;;; SLOT-BOUNDP should signal an error on elements of built-in-classes -(deftest slot-boundp.error.5 - (let ((built-in-class (find-class 'built-in-class))) - (loop for e in *mini-universe* - for class = (class-of e) - when (and (eq (class-of class) built-in-class) - (handler-case (progn (slot-boundp e 'foo) t) - (error () nil))) - collect e)) - nil) diff --git a/t/ansi-test/objects/slot-exists-p.lsp b/t/ansi-test/objects/slot-exists-p.lsp deleted file mode 100644 index e64d86a..0000000 --- a/t/ansi-test/objects/slot-exists-p.lsp +++ /dev/null @@ -1,181 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat May 10 09:39:01 2003 -;;;; Contains: Tests of SLOT-EXISTS-P - - - -;;; This function is also tested incidentally in many other files - -(defclass slot-exists-p-class-01 () - (a (b :allocation :class) (c :allocation :instance))) - -(deftest slot-exists-p.1 - (let ((obj (allocate-instance (find-class 'slot-exists-p-class-01)))) - (notnot-mv (slot-exists-p obj 'a))) - t) - -(deftest slot-exists-p.2 - (let ((obj (allocate-instance (find-class 'slot-exists-p-class-01)))) - (notnot-mv (slot-exists-p obj 'b))) - t) - -(deftest slot-exists-p.3 - (let ((obj (allocate-instance (find-class 'slot-exists-p-class-01)))) - (notnot-mv (slot-exists-p obj 'c))) - t) - -(deftest slot-exists-p.4 - (let ((obj (allocate-instance (find-class 'slot-exists-p-class-01)))) - (slot-exists-p obj 'd)) - nil) - -(deftest slot-exists-p.5 - (let ((obj (allocate-instance (find-class 'slot-exists-p-class-01)))) - (slot-exists-p obj (gensym))) - nil) - -(deftest slot-exists-p.6 - (let ((obj (allocate-instance (find-class 'slot-exists-p-class-01)))) - (slot-exists-p obj nil)) - nil) - -(deftest slot-exists-p.7 - (let ((obj (allocate-instance (find-class 'slot-exists-p-class-01)))) - (slot-exists-p obj t)) - nil) - -;;; SLOT-EXISTS-P may be called on any object, not just on standard objects - -(deftest slot-exists-p.8 - (let ((slot-name (gensym))) - (check-predicate #'(lambda (x) (not (slot-exists-p x slot-name))))) - nil) - -;;; With various types - -(defclass slot-exists-p-class-02 () - ((a :type t) (b :type nil) (c :type symbol) (d :type cons) - (e :type float) (f :type single-float) (g :type short-float) - (h :type double-float) (i :type long-float) (j :type character) - (k :type base-char) (l :type rational) (m :type ratio) (n :type integer) - (o :type fixnum) (p :type complex) (q :type condition))) - -(deftest slot-exists-p.9 - (let ((obj (allocate-instance (find-class 'slot-exists-p-class-02)))) - (map-slot-exists-p* obj '(a b c d e f g h i j k l m n o p q))) - (t t t t t t t t t t t t t t t t t)) - -;;; Inheritance - -(defclass slot-exists-p-class-03a () - (a b)) - -(defclass slot-exists-p-class-03b () - (a c)) - -(defclass slot-exists-p-class-03c (slot-exists-p-class-03a slot-exists-p-class-03b) - (d e)) - -(deftest slot-exists-p.10 - (let ((obj (allocate-instance (find-class 'slot-exists-p-class-03c)))) - (map-slot-exists-p* obj '(a b c d e f g))) - (t t t t t nil nil)) - -;;; SLOT-EXISTS-P is supposed to work on structure objects and condition objects - -(defstruct slot-exists-p-struct-01 - a b c) - -(deftest slot-exists-p.11 - (let ((obj (make-slot-exists-p-struct-01))) - (map-slot-exists-p* obj '(a b c z nil))) - (t t t nil nil)) - -(deftest slot-exists-p.12 - (let ((obj (make-slot-exists-p-struct-01 :a 1 :b 2 :c 3))) - (map-slot-exists-p* obj '(a b c z nil))) - (t t t nil nil)) - -(defstruct (slot-exists-p-struct-02 (:include slot-exists-p-struct-01)) - d e) - -(deftest slot-exists-p.13 - (let ((obj (make-slot-exists-p-struct-02))) - (map-slot-exists-p* obj '(a b c d e f z nil))) - (t t t t t nil nil nil)) - -(deftest slot-exists-p.14 - (let ((obj (make-slot-exists-p-struct-02 :a 1 :b 3 :e 5))) - (map-slot-exists-p* obj '(a b c d e f z nil))) - (t t t t t nil nil nil)) - - -;;; SLOT-EXISTS-P is supposed to work on condition objects, too -;;; (after all, they are objects, and they have slots) - -(define-condition slot-exists-p-condition-01 () - ((a) (b) (c))) - -(deftest slot-exists-p.15 - (let ((obj (make-condition 'slot-exists-p-condition-01))) - (map-slot-exists-p* obj (list 'a 'b 'c (gensym)))) - (t t t nil)) - -(define-condition slot-exists-p-condition-02 (slot-exists-p-condition-01) - ((a) (d) (e))) - -(deftest slot-exists-p.16 - (let ((obj (make-condition 'slot-exists-p-condition-02))) - (map-slot-exists-p* obj (list 'a 'b 'c 'd 'e (gensym)))) - (t t t t t nil)) - -;;; Order of evaluation tests - -(deftest slot-exists-p.order.1 - (let ((i 0) x y) - (values - (slot-exists-p (progn (setf x (incf i)) 'a) - (progn (setf y (incf i)) (gensym))) - i x y)) - nil 2 1 2) - -(deftest slot-exists-p.order.2 - (let ((obj (allocate-instance (find-class 'slot-exists-p-class-01))) - (i 0) x y) - (values - (notnot (slot-exists-p (progn (setf x (incf i)) obj) - (progn (setf y (incf i)) 'a))) - i x y)) - t 2 1 2) - -(deftest slot-exists-p.order.3 - (let ((obj (allocate-instance (find-class 'slot-exists-p-class-01))) - (i 0) x y) - (values - (notnot (slot-exists-p (progn (setf x (incf i)) obj) - (progn (setf y (incf i)) 'b))) - i x y)) - t 2 1 2) - -;;; Errors tests - -(deftest slot-exists-p.error.1 - (signals-error (slot-exists-p) program-error) - t) - -(deftest slot-exists-p.error.2 - (signals-error (slot-exists-p 'a) program-error) - t) - -(deftest slot-exists-p.error.3 - (signals-error (slot-exists-p (make-instance 'slot-exists-p-class-01)) - program-error) - t) - -(deftest slot-exists-p.error.4 - (signals-error (slot-exists-p (make-instance 'slot-exists-p-class-01) 'a nil) - program-error) - t) - - diff --git a/t/ansi-test/objects/slot-makunbound.lsp b/t/ansi-test/objects/slot-makunbound.lsp deleted file mode 100644 index 40cb38a..0000000 --- a/t/ansi-test/objects/slot-makunbound.lsp +++ /dev/null @@ -1,91 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat May 10 14:39:01 2003 -;;;; Contains: Tests for SLOT-MAKUNBOUND - - - -;;; This function is heavily tested in other files as well - -(defclass slot-makunbound-class-01 () - (a - (b :allocation :instance) - (c :allocation :class) - (d :type fixnum) - (e :type t) - (f :type cons))) - -(deftest slot-makunbound.1 - (loop for slot-name in '(a b c d e) - unless - (let ((obj (allocate-instance (find-class 'slot-makunbound-class-01)))) - (and - (equalt (multiple-value-list (slot-makunbound obj slot-name)) - (list obj)) - (not (slot-boundp obj slot-name)))) - collect slot-name) - nil) - -(deftest slot-makunbound.2 - (loop for slot-name in '(a b c d e) - for slot-value in '(t t t 10 t '(a)) - unless - (let ((obj (allocate-instance (find-class 'slot-makunbound-class-01)))) - (setf (slot-value obj slot-name) slot-value) - (and - (equalt (multiple-value-list (slot-makunbound obj slot-name)) - (list obj)) - (not (slot-boundp obj slot-name)))) - collect slot-name) - nil) - -;;; Order of evaluation test(s) - -(deftest slot-makunbound.order.1 - (let ((obj (make-instance 'slot-makunbound-class-01)) - (i 0) x y) - (values - (eqt (slot-makunbound (progn (setf x (incf i)) obj) - (progn (setf y (incf i)) 'a)) - obj) - i x y)) - t 2 1 2) - -(deftest slot-makunbound.order.2 - (let ((obj (make-instance 'slot-makunbound-class-01)) - (i 0) x y) - (setf (slot-value obj 'a) t) - (values - (eqt (slot-makunbound (progn (setf x (incf i)) obj) - (progn (setf y (incf i)) 'a)) - obj) - i x y)) - t 2 1 2) - -;;; Error cases - -(deftest slot-makunbound.error.1 - (signals-error (slot-makunbound) program-error) - t) - -(deftest slot-makunbound.error.2 - (signals-error (slot-makunbound (make-instance 'slot-makunbound-class-01)) - program-error) - t) - -(deftest slot-makunbound.error.3 - (signals-error (slot-makunbound (make-instance 'slot-makunbound-class-01) - 'a nil) - program-error) - t) - -(deftest slot-makunbound.error.4 - (let ((built-in-class (find-class 'built-in-class))) - (loop for e in *mini-universe* - for class = (class-of e) - when (and (eq (class-of class) built-in-class) - (handler-case (progn (slot-makunbound e 'foo) t) - (error () nil))) - collect e)) - nil) - diff --git a/t/ansi-test/objects/slot-missing.lsp b/t/ansi-test/objects/slot-missing.lsp deleted file mode 100644 index c780277..0000000 --- a/t/ansi-test/objects/slot-missing.lsp +++ /dev/null @@ -1,78 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jun 15 06:03:58 2003 -;;;; Contains: Tests of SLOT-MISSING - - - -(defparameter *slot-missing-class-01-var* nil) - -(defclass slot-missing-class-01 () (a b c)) - -(defmethod slot-missing ((class t) (obj slot-missing-class-01) - (slot-name t) (operation t) - &optional (new-value nil new-value-p)) - (setf *slot-missing-class-01-var* - (list slot-name operation new-value (notnot new-value-p)))) - -(deftest slot-missing.1 - (let ((obj (make-instance 'slot-missing-class-01))) - (values - (slot-value obj 'foo) - *slot-missing-class-01-var*)) - (foo slot-value nil nil) - (foo slot-value nil nil)) - -(deftest slot-missing.2 - (let ((obj (make-instance 'slot-missing-class-01))) - (values - (setf (slot-value obj 'foo) 'bar) - *slot-missing-class-01-var*)) - bar - (foo setf bar t)) - -(deftest slot-missing.3 - (let ((obj (make-instance 'slot-missing-class-01))) - (values - (eqt obj (slot-makunbound obj 'xyz)) - *slot-missing-class-01-var*)) - t - (xyz slot-makunbound nil nil)) - -(deftest slot-missing.4 - (let ((obj (make-instance 'slot-missing-class-01))) - (values - (notnot (slot-boundp obj 'abc)) - *slot-missing-class-01-var*)) - t - (abc slot-boundp nil nil)) - -(deftest slot-missing.5 - (let ((obj (make-instance 'slot-missing-class-01))) - (slot-value obj 'd)) - (d slot-value nil nil)) - -(deftest slot-missing.6 - (let ((obj (make-instance 'slot-missing-class-01))) - (setf (slot-value obj 'd) 'bar)) - bar) - -(deftest slot-missing.7 - (let* ((obj (make-instance 'slot-missing-class-01)) - (val (slot-makunbound obj 'd))) - (if (eq val obj) - :good - val)) - :good) - -(defmethod slot-missing ((class t) (obj slot-missing-class-01) - (slot-name (eql 'not-there)) - (operation (eql 'slot-boundp)) - &optional new-value) - (declare (ignore new-value)) - (values nil :ignore-this)) - -(deftest slot-missing.8 - (let* ((obj (make-instance 'slot-missing-class-01))) - (slot-boundp obj 'not-there)) - nil) diff --git a/t/ansi-test/objects/slot-unbound.lsp b/t/ansi-test/objects/slot-unbound.lsp deleted file mode 100644 index e7dcadc..0000000 --- a/t/ansi-test/objects/slot-unbound.lsp +++ /dev/null @@ -1,58 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jun 15 06:57:23 2003 -;;;; Contains: Tests for SLOT-UNBOUND - - - -(defclass slot-unbound-class-01 () - ((a :reader sunb-a) - (b :accessor sunb-b) - (c :writer sunb-c) - (e :reader sunb-e) - (f :reader sunb-f))) - -(defmethod slot-unbound ((class t) (obj slot-unbound-class-01) (slot-name t)) - (list (class-name class) slot-name)) - -(deftest slot-unbound.1 - (let ((obj (make-instance 'slot-unbound-class-01))) - (values - (slot-value obj 'a) - (slot-value obj 'b) - (slot-value obj 'c))) - (slot-unbound-class-01 a) - (slot-unbound-class-01 b) - (slot-unbound-class-01 c)) - -(deftest slot-unbound.2 - (let ((obj (make-instance 'slot-unbound-class-01))) - (values - (sunb-a obj) - (sunb-b obj))) - (slot-unbound-class-01 a) - (slot-unbound-class-01 b)) - -(defmethod slot-unbound ((class t) (obj slot-unbound-class-01) - (slot-name (eql 'e))) - (values)) - -(defmethod slot-unbound ((class t) (obj slot-unbound-class-01) - (slot-name (eql 'f))) - (values 1 2 3)) - -(deftest slot-unbound.3 - (slot-value (make-instance 'slot-unbound-class-01) 'e) - nil) - -(deftest slot-unbound.4 - (slot-value (make-instance 'slot-unbound-class-01) 'f) - 1) - -(deftest slot-unbound.5 - (sunb-e (make-instance 'slot-unbound-class-01)) - nil) - -(deftest slot-unbound.6 - (sunb-f (make-instance 'slot-unbound-class-01)) - 1) diff --git a/t/ansi-test/objects/slot-value.lsp b/t/ansi-test/objects/slot-value.lsp deleted file mode 100644 index 13568dc..0000000 --- a/t/ansi-test/objects/slot-value.lsp +++ /dev/null @@ -1,151 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat May 10 16:16:59 2003 -;;;; Contains: Tests of SLOT-VALUE - - - -;;; SLOT-VALUE is used extensively elsewhere. - -(defclass slot-value-class-01 () - (a - (b :type t) - (c :type fixnum) - (d :type float) - (e :type symbol) - (f :type short-float) - (g :type single-float) - (h :type double-float) - (i :type long-float) - (j :type rational) - (k :type ratio) - (l :type cons) - (m :type string) - (n :type vector) - (o :type bit) - )) - -(defparameter *slot-value-test-slot-names* - '(a b c d e f g h i j k l m n o)) - -(defparameter *slot-value-test-slot-values* - '(t nil 10 4.0 a 1.0s0 2.0f0 3.0d0 4.0l0 - 5/4 2/3 (a . b) "abcd" #(1 2 3 4) 1)) - -(deftest slot-value.1 - (let ((obj (make-instance 'slot-value-class-01)) - (slot-names *slot-value-test-slot-names*) - (slot-values *slot-value-test-slot-values*)) - (loop for name in slot-names - for val in slot-values - unless (and (equal (multiple-value-list - (setf (slot-value obj name) val)) - (list val)) - (equal (multiple-value-list - (slot-value obj name)) - (list val))) - collect name)) - nil) - -(defclass slot-value-class-02 (slot-value-class-01) - ((a :allocation :class) - (b :allocation :class) - (c :allocation :class) - (d :allocation :class) - (e :allocation :class) - (f :allocation :class) - (g :allocation :class) - (h :allocation :class) - (i :allocation :class) - (j :allocation :class) - (k :allocation :class) - (l :allocation :class) - (m :allocation :class) - (n :allocation :class) - (o :allocation :class))) - -(deftest slot-value.2 - (let ((obj (make-instance 'slot-value-class-02)) - (slot-names *slot-value-test-slot-names*) - (slot-values *slot-value-test-slot-values*)) - (loop for name in slot-names - for val in slot-values - unless (and (equal (multiple-value-list - (setf (slot-value obj name) val)) - (list val)) - (equal (multiple-value-list - (slot-value obj name)) - (list val))) - collect name)) - nil) - -;;; Order of evaluation test(s) - -(deftest slot-value.order.1 - (let ((obj (make-instance 'slot-value-class-01)) - (i 0) x y) - (values - (setf (slot-value obj 'a) t) - (slot-value (progn (setf x (incf i)) obj) - (progn (setf y (incf i)) 'a)) - i x y)) - t t 2 1 2) - -(deftest slot-value.order.2 - (let ((obj (make-instance 'slot-value-class-01)) - (i 0) x y) - (values - (setf (slot-value (progn (setf x (incf i)) obj) - (progn (setf y (incf i)) 'b)) - t) - (slot-value obj 'b) - i x y)) - t t 2 1 2) - -;;; Error tests - -(deftest slot-value.error.1 - (signals-error (slot-value) program-error) - t) - -(deftest slot-value.error.2 - (signals-error (slot-value (make-instance 'slot-value-class-01)) - program-error) - t) - -(deftest slot-value.error.3 - (signals-error - (let ((obj (make-instance 'slot-value-class-01))) - (setf (slot-value obj 'a) t) - (slot-value obj 'a nil)) - program-error) - t) - -(deftest slot-value.error.4 - (handler-case - (progn (slot-value (make-instance 'slot-value-class-01) (gensym)) - :bad) - (error () :good)) - :good) - -(deftest slot-value.error.5 - (let ((built-in-class (find-class 'built-in-class)) - (slot-name (gensym))) - (check-predicate - #'(lambda (e) - (let ((class (class-of e))) - (or (not (eq (class-of class) built-in-class)) - (handler-case (progn (slot-value e slot-name) nil) - (error () t))))))) - nil) - -(deftest slot-value.error.6 - (let ((built-in-class (find-class 'built-in-class)) - (slot-name (gensym))) - (check-predicate - #'(lambda (e) - (let ((class (class-of e))) - (or (not (eq (class-of class) built-in-class)) - (handler-case (setf (slot-value e slot-name) nil) - (error () t))))))) - nil) diff --git a/t/ansi-test/objects/unbound-slot.lsp b/t/ansi-test/objects/unbound-slot.lsp deleted file mode 100644 index 4d91159..0000000 --- a/t/ansi-test/objects/unbound-slot.lsp +++ /dev/null @@ -1,36 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Jun 4 20:14:26 2003 -;;;; Contains: Tests for UNBOUND-SLOT, UNBOUND-SLOT-INSTANCE - - - -(defclass ubs-class-01 () - ((a :initarg :a))) - -(deftest unbound-slot.1 - (let ((obj (make-instance 'ubs-class-01))) - (handler-case - (slot-value obj 'a) - (unbound-slot (c) - (values - (typep* c 'cell-error) - (eqt (unbound-slot-instance c) obj) - (cell-error-name c))))) - t t a) - -(defclass ubs-class-02 () - ((b :allocation :class))) - -(deftest unbound-slot.2 - (let ((obj (make-instance 'ubs-class-02))) - (handler-case - (slot-value obj 'b) - (unbound-slot (c) - (values - (typep* c 'cell-error) - (eqt (unbound-slot-instance c) obj) - (cell-error-name c))))) - t t b) - - diff --git a/t/ansi-test/objects/update-instance-for-different-class.lsp b/t/ansi-test/objects/update-instance-for-different-class.lsp deleted file mode 100644 index 58b1089..0000000 --- a/t/ansi-test/objects/update-instance-for-different-class.lsp +++ /dev/null @@ -1,143 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon May 5 19:32:56 2003 -;;;; Contains: Tests for UPDATE-INSTANCE-FOR-DIFFERENT-CLASS - - - -(defclass uifdc-class-01a () ((a :initarg :a) (b :initarg :b))) -(defclass uifdc-class-01b () (a b)) - -(declaim (special *uifdc-01-obj*)) - -(defmethod update-instance-for-different-class - ((from-obj uifdc-class-01a) - (to-obj uifdc-class-01b) - &rest initargs &key &allow-other-keys) - (declare (ignore initargs)) - (assert (not (eq *uifdc-01-obj* from-obj))) - (assert (eq *uifdc-01-obj* to-obj)) - (if (slot-boundp from-obj 'a) - (setf (slot-value to-obj 'b) - (slot-value from-obj 'a)) - (slot-makunbound to-obj 'b)) - (if (slot-boundp from-obj 'b) - (setf (slot-value to-obj 'a) - (slot-value from-obj 'b)) - (slot-makunbound to-obj 'a)) - to-obj) - -(deftest update-instance-for-different-class.1 - (let* ((obj (make-instance 'uifdc-class-01a)) - (new-class (find-class 'uifdc-class-01b)) - (*uifdc-01-obj* obj)) - (values - (map-slot-boundp* obj '(a b)) - (eqt obj (change-class obj new-class)) - (typep* obj new-class) - (map-slot-boundp* obj '(a b)))) - (nil nil) - t t - (nil nil)) - -(deftest update-instance-for-different-class.2 - (let* ((obj (make-instance 'uifdc-class-01a :a 1)) - (new-class (find-class 'uifdc-class-01b)) - (*uifdc-01-obj* obj)) - (values - (map-slot-boundp* obj '(a b)) - (eqt obj (change-class obj new-class)) - (typep* obj new-class) - (map-slot-boundp* obj '(a b)) - (slot-value obj 'b))) - (t nil) - t t - (nil t) - 1) - -(deftest update-instance-for-different-class.3 - (let* ((obj (make-instance 'uifdc-class-01a :b 1)) - (new-class (find-class 'uifdc-class-01b)) - (*uifdc-01-obj* obj)) - (values - (map-slot-boundp* obj '(a b)) - (eqt obj (change-class obj new-class)) - (typep* obj new-class) - (map-slot-boundp* obj '(a b)) - (slot-value obj 'a))) - (nil t) - t t - (t nil) - 1) - -(deftest update-instance-for-different-class.4 - (let* ((obj (make-instance 'uifdc-class-01a :a 1 :b 2)) - (new-class (find-class 'uifdc-class-01b)) - (*uifdc-01-obj* obj)) - (values - (map-slot-boundp* obj '(a b)) - (eqt obj (change-class obj new-class)) - (typep* obj new-class) - (map-slot-boundp* obj '(a b)) - (slot-value obj 'a) - (slot-value obj 'b))) - (t t) - t t - (t t) - 2 1) - - -;;; after method - -(defclass uifdc-class-02 () ((a :initform 'x :initarg :a) - (b :initarg :b))) - -(defmethod update-instance-for-different-class :after - ((from-obj uifdc-class-01a) - (to-obj uifdc-class-02) - &rest initargs &key &allow-other-keys) - (declare (ignore initargs)) - (setf (slot-value to-obj 'a) 100) - to-obj) - -(deftest update-instance-for-different-class.5 - (let* ((obj (make-instance 'uifdc-class-01a)) - (class (find-class 'uifdc-class-02))) - (values - (eqt obj (change-class obj class)) - (map-slot-boundp* obj '(a b)) - (slot-value obj 'a))) - t (t nil) 100) - -(deftest update-instance-for-different-class.6 - (let* ((obj (make-instance 'uifdc-class-01a :a 1)) - (class (find-class 'uifdc-class-02))) - (values - (eqt obj (change-class obj class)) - (map-slot-boundp* obj '(a b)) - (slot-value obj 'a))) - t (t nil) 100) - -(deftest update-instance-for-different-class.7 - (let* ((obj (make-instance 'uifdc-class-01a :b 17)) - (class (find-class 'uifdc-class-02))) - (values - (eqt obj (change-class obj class)) - (map-slot-boundp* obj '(a b)) - (slot-value obj 'a) - (slot-value obj 'b))) - t (t t) 100 17) - -(deftest update-instance-for-different-class.8 - (let* ((obj (make-instance 'uifdc-class-01a :b 17 :a 4)) - (class (find-class 'uifdc-class-02))) - (values - (eqt obj (change-class obj class)) - (map-slot-boundp* obj '(a b)) - (slot-value obj 'a) - (slot-value obj 'b))) - t (t t) 100 17) - - - - diff --git a/t/ansi-test/objects/with-accessors.lsp b/t/ansi-test/objects/with-accessors.lsp deleted file mode 100644 index 858f5ef..0000000 --- a/t/ansi-test/objects/with-accessors.lsp +++ /dev/null @@ -1,138 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat May 17 17:07:29 2003 -;;;; Contains: Tests of WITH-ACCESSORS - - - -(deftest with-accessors.1 - (with-accessors () nil) - nil) - -(deftest with-accessors.2 - (with-accessors () nil (values))) - -(deftest with-accessors.3 - (with-accessors () nil (values 'a 'b 'c 'd 'e 'f)) - a b c d e f) - -(deftest with-accessors.4 - (let (x y z) - (with-accessors () (setf x 1) (setf y 5) (setf z 12) (values x y z))) - 1 5 12) - -;; with-accessors defines an implicit progn, not a tagbody -(deftest with-accessors.5 - (block done - (tagbody - (with-accessors - nil nil - (go 10) - 10 - (return-from done :bad)) - 10 - (return-from done :good))) - :good) - -(defclass with-accessors-class-01 () - ((a :initarg :a :accessor wa-a) - (b :initarg :b :accessor wa-b) - (c :initarg :c :accessor wa-c))) - -(deftest with-accessors.6 - (let ((obj (make-instance 'with-accessors-class-01 :a 'x :b 'y :c 'z))) - (with-accessors - ((a wa-a) (b wa-b) (c wa-c)) - obj - (values a b c))) - x y z) - -(deftest with-accessors.7 - (let ((obj (make-instance 'with-accessors-class-01))) - (with-accessors - ((a wa-a) (b wa-b) (c wa-c)) - obj - (values (setf a 'x) (setf b 'y) (setf c 'z) - (map-slot-value obj '(a b c))))) - x y z (x y z)) - -(deftest with-accessors.8 - (let ((obj (make-instance 'with-accessors-class-01))) - (with-accessors - ((a wa-a) (b wa-b) (c wa-c)) - obj - (values (setq a 'x) (setq b 'y) (setq c 'z) - (map-slot-value obj '(a b c))))) - x y z (x y z)) - -(deftest with-accessors.9 - (let ((obj (make-instance 'with-accessors-class-01 :a 5 :b 19 :c 312))) - (with-accessors - ((a wa-a) (b wa-b) (c wa-c)) - obj - (values (incf a 4) (incf b 412) (incf c 75) - (map-slot-value obj '(a b c))))) - 9 431 387 (9 431 387)) - -(deftest with-accessors.10 - (let ((obj (make-instance 'with-accessors-class-01 :a 5 :b 19 :c 312))) - (with-accessors - ((a wa-a) (b wa-b) (c wa-c)) - obj - (declare (optimize (speed 3) (safety 3))) - (values a b c))) - 5 19 312) - -(deftest with-accessors.11 - (let ((obj (make-instance 'with-accessors-class-01 :a 5 :b 19 :c 312))) - (with-accessors - ((a wa-a) (b wa-b) (c wa-c)) - obj - (declare (optimize (speed 3) (safety 3))) - (declare (special *x*)) ;; not used - (values a b c))) - 5 19 312) - -;;; with-accessors on structure accessors - -(defstruct (with-accessors-struct-02 (:conc-name "WA-2-")) a b c) - -(deftest with-accessors.12 - (let ((obj (make-with-accessors-struct-02 :a 'x :b 'y :c 'z))) - (with-accessors ((a wa-2-a) (b wa-2-b) (c wa-2-c)) - obj - (values a b c))) - x y z) - -(deftest with-accessors.13 - (let ((obj (make-with-accessors-struct-02))) - (with-accessors - ((a wa-2-a) (b wa-2-b) (c wa-2-c)) - obj - (values (setf a 'x) (setf b 'y) (setf c 'z) - (wa-2-a obj) (wa-2-b obj) (wa-2-c obj)))) - x y z x y z) - -;;; Free declaration scope test - -(deftest with-accessors.14 - (block done - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) - (with-accessors nil (return-from done x) - (declare (special x)))))) - :good) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest with-accessors.15 - (macrolet - ((%m (z) z)) - (let ((obj (make-with-accessors-struct-02 :a 'x :b 'y :c 'z))) - (with-accessors ((a wa-2-a) (b wa-2-b) (c wa-2-c)) - (expand-in-current-env (%m obj)) - (values a b c)))) - x y z) - diff --git a/t/ansi-test/objects/with-slots.lsp b/t/ansi-test/objects/with-slots.lsp deleted file mode 100644 index d86deab..0000000 --- a/t/ansi-test/objects/with-slots.lsp +++ /dev/null @@ -1,180 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat May 17 18:04:10 2003 -;;;; Contains: Tests of WITH-SLOTS - - - -(deftest with-slots.1 - (with-slots () nil) - nil) - -(deftest with-slots.2 - (with-slots () nil (values))) - -(deftest with-slots.3 - (with-slots () nil (values 'a 'b 'c 'd 'e 'f)) - a b c d e f) - -(deftest with-slots.4 - (let ((x 0) (y 10) (z 20)) - (values - x y z - (with-slots () (incf x) (incf y 3) (incf z 100)) - x y z)) - 0 10 20 - 120 - 1 13 120) - -;;; with-slots is an implicit progn, not a tagbody - -(deftest with-slots.5 - (block done - (tagbody - (with-slots () nil - (go 10) - 10 - (return-from done :bad)) - 10 - (return-from done :good))) - :good) - -;;; with-slots has no implicit block -(deftest with-slots.6 - (block nil - (with-slots () nil (return :good)) - (return :bad)) - :good) - - -;;; Tests on standard objects - -(defclass with-slots-class-01 () ((a :initarg :a) - (b :initarg :b) - (c :initarg :c))) - -(deftest with-slots.7 - (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z))) - (with-slots (a b c) obj (values a b c))) - x y z) - -(deftest with-slots.8 - (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z))) - (with-slots - (a b c) obj - (values (setf a 'p) (setf b 'q) (setf c 'r) - (map-slot-value obj '(a b c))))) - p q r (p q r)) - -(deftest with-slots.9 - (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z))) - (with-slots - (a b c) obj - (values (setq a 'p) (setq b 'q) (setq c 'r) - (map-slot-value obj '(a b c))))) - p q r (p q r)) - -(deftest with-slots.10 - (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z))) - (with-slots ((a2 a) (b2 b) (c2 c)) obj (values a2 b2 c2))) - x y z) - -(deftest with-slots.11 - (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z))) - (with-slots - ((a2 a) (b2 b) (c2 c)) obj - (values (setf a2 'p) (setf b2 'q) (setf c2 'r) - (map-slot-value obj '(a b c))))) - p q r (p q r)) - -(deftest with-slots.12 - (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z))) - (with-slots - ((a2 a) (b2 b) (c2 c)) obj - (values (setq a2 'p) (setq b2 'q) (setq c2 'r) - (map-slot-value obj '(a b c))))) - p q r (p q r)) - -(deftest with-slots.13 - (let ((obj (make-instance 'with-slots-class-01))) - (with-slots - (a b c) obj - (values (setf a 'p) (setf b 'q) (setf c 'r) - (map-slot-value obj '(a b c))))) - p q r (p q r)) - -(deftest with-slots.14 - (let ((obj (make-instance 'with-slots-class-01 :a 1 :b 2 :c 3))) - (with-slots (a b c) obj - (let ((obj (make-instance 'with-slots-class-01 - :a 'bad :b 'bad :c 'bad))) - (values a b c)))) - 1 2 3) - - -(deftest with-slots.15 - (let ((obj (make-instance 'with-slots-class-01 :a 1 :b 2 :c 3))) - (with-slots (a b c) obj - (with-slots - ((a2 a) (b2 b) (c2 c)) - (make-instance 'with-slots-class-01 - :a 'bad :b 'bad :c 'bad) - (values a b c)))) - 1 2 3) - -(deftest with-slots.16 - (let ((obj (make-instance 'with-slots-class-01 :a 'bad :b 'bad :c 'bad))) - (with-slots (a b c) obj - (with-slots - (a b c) - (make-instance 'with-slots-class-01 :a 1 :b 2 :c 3) - (values a b c)))) - 1 2 3) - - -(deftest with-slots.17 - (let ((obj (make-instance 'with-slots-class-01 :a 1 :b 2 :c 'bad))) - (with-slots (a b) obj - (with-slots - (c) - (make-instance 'with-slots-class-01 :a 'bad :b 'bad :c 3) - (values a b c)))) - 1 2 3) - -;;; If slot is unbound, act as if slot-value had been called - -(defmethod slot-unbound ((class t) - (instance with-slots-class-01) - slot-name) - 'missing) - -(deftest with-slots.18 - (let ((obj (make-instance 'with-slots-class-01))) - (with-slots (a b c) obj (values a b c))) - missing missing missing) - -(deftest with-slots.19 - (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z))) - (with-slots (a b c) obj - (declare (optimize (speed 3) (safety 3))) - (values a b c))) - x y z) - -(deftest with-slots.20 - (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z))) - (with-slots (a b c) obj - (declare (optimize (speed 3) (safety 3))) - (declare (special *x*)) - (values a b c))) - x y z) - -;;; Free declaration scope test - -(deftest with-slots.21 - (block done - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) - (with-slots nil (return-from done x) - (declare (special x)))))) - :good) diff --git a/t/ansi-test/packages.lisp b/t/ansi-test/packages.lisp deleted file mode 100644 index b0095b0..0000000 --- a/t/ansi-test/packages.lisp +++ /dev/null @@ -1,4 +0,0 @@ -(cl:in-package #:common-lisp-user) - -(defpackage #:cl-test - (:use #:common-lisp #:regression-test)) diff --git a/t/ansi-test/packages/defpackage.lsp b/t/ansi-test/packages/defpackage.lsp deleted file mode 100644 index 893a52e..0000000 --- a/t/ansi-test/packages/defpackage.lsp +++ /dev/null @@ -1,659 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 25 08:09:18 1998 -;;;; Contains: Tests of DEFPACKAGE - - - - - -(declaim (optimize (safety 3))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; defpackage - -;; Test basic defpackage call, with no options -;; The use-list is implementation dependent, so -;; we don't examine it here. -;; Try several ways of specifying the package name. -(deftest defpackage.1 - (loop - for n in '("H" #:|H| #\H) count - (not - (progn - (safely-delete-package "H") - (let ((p (ignore-errors (eval `(defpackage ,n))))) - (and - (packagep p) - (equal (package-name p) "H") - ;; (equal (package-use-list p) nil) - (equal (package-used-by-list p) nil) - (equal (package-nicknames p) nil) - (equal (package-shadowing-symbols p) nil) - (null (documentation p t)) - ))))) - 0) - -;; Test :nicknames option -;; Do not check use-list, because it is implementation dependent -;; Try several ways of specifying a nickname. -(deftest defpackage.2 - (loop - for n in '("I" #:|I| #\I) count - (not - (ignore-errors - (progn - (safely-delete-package "H") - (let ((p (ignore-errors - (eval `(defpackage "H" (:nicknames ,n "J")))))) - (and - (packagep p) - (equal (package-name p) "H") - ;; (equal (package-use-list p) nil) - (equal (package-used-by-list p) nil) - (equal (sort (copy-list (package-nicknames p)) - #'string<) - '("I" "J")) - (equal (package-shadowing-symbols p) nil) - (null (documentation p t)) - )))))) - 0) - -;;; Test :nicknames option with more than one occurrence. -;;; Do not check use-list, because it is implementation dependent -;;; Try several ways of specifying a nickname. -(deftest defpackage.2b - (loop - for n in '("I" #:|I| #\I) count - (not - (ignore-errors - (progn - (safely-delete-package "H") - (let ((p (ignore-errors - (eval `(defpackage "H" - (:nicknames ,n) - (:nicknames "J")))))) - (and - (packagep p) - (equal (package-name p) "H") - (equal (package-used-by-list p) nil) - (equal (sort (copy-list (package-nicknames p)) - #'string<) - '("I" "J")) - (equal (package-shadowing-symbols p) nil) - (null (documentation p t)))))))) - 0) - -;; Test defpackage with documentation option -;; Do not check use-list, because it is implementation dependent -(deftest defpackage.3 - (let () - (safely-delete-package "H") - (ignore-errors - (let ((p (eval '(defpackage "H" (:documentation "This is a doc string"))))) - (and - (packagep p) - (equal (package-name p) "H") - ;; (equal (package-use-list p) nil) - (equal (package-used-by-list p) nil) - (equal (package-nicknames p) nil) - (equal (package-shadowing-symbols p) nil) - ;; The spec says implementations are free to discard - ;; documentations, so this next form was wrong. - ;; Instead, we'll just computation DOCUMENTATION - ;; and throw away the value. - ;; (equal (documentation p t) "This is a doc string") - (progn (documentation p t) t) - )))) - t) - -;; Check use argument -;; Try several ways of specifying the package to be used -(deftest defpackage.4 - (progn - (set-up-packages) - (loop - for n in '("A" :|A| #\A) count - (not - (ignore-errors - (progn - (safely-delete-package "H") - (let ((p (ignore-errors (eval `(defpackage "H" (:use ,n)))))) - (and - (packagep p) - (equal (package-name p) "H") - (equal (package-use-list p) (list (find-package "A"))) - (equal (package-used-by-list p) nil) - (equal (package-nicknames p) nil) - (equal (package-shadowing-symbols p) nil) - (eql (num-symbols-in-package p) - (num-external-symbols-in-package "A")) - (equal (documentation p t) nil) - ))))))) - 0) - -;; Test defpackage shadow option, and null use -(deftest defpackage.5 - (let () - (safely-delete-package "H") - (ignore-errors - (let ((p (ignore-errors (eval `(defpackage "H" (:use) - (:shadow "foo")))))) - (mapcar - #'notnot - (list - (packagep p) - (equal (package-name p) "H") - (equal (package-use-list p) nil) - (equal (package-used-by-list p) nil) - (equal (package-nicknames p) nil) - (eql (num-symbols-in-package p) 1) - (multiple-value-bind* (sym access) - (find-symbol "foo" p) - (and (eqt access :internal) - (equal (symbol-name sym) "foo") - (equal (symbol-package sym) p) - (equal (package-shadowing-symbols p) - (list sym)))) - (equal (documentation p t) nil) - ))))) - (t t t t t t t t)) - -;; Test defpackage shadow and null use, with several ways -;; of specifying the name of the shadowed symbol -(deftest defpackage.6 - (loop - for s in '(:|f| #\f) - collect - (ignore-errors - (safely-delete-package "H") - (let ((p (ignore-errors (eval `(defpackage "H" - (:use) - (:shadow ,s)))))) - (mapcar - #'notnot - (list - (packagep p) - (equal (package-name p) "H") - (equal (package-use-list p) nil) - (equal (package-used-by-list p) nil) - (equal (package-nicknames p) nil) - (eql (num-symbols-in-package p) 1) - (multiple-value-bind* (sym access) - (find-symbol "f" p) - (and (eqt access :internal) - (equal (symbol-name sym) "f") - (equal (symbol-package sym) p) - (equal (package-shadowing-symbols p) - (list sym)))) - (equal (documentation p t) nil) - ))))) - ((t t t t t t t t) - (t t t t t t t t))) - - -;; Testing defpackage with shadowing-import-from. -;; Test several ways of specifying the symbol name -(deftest defpackage.7 - (progn - (safely-delete-package "H") - (safely-delete-package "G") - (let ((pg (make-package "G" :use nil))) - ;; Populate package G with several symbols - (export (intern "A" pg) pg) - (export (intern "foo" pg) pg) - (intern "bar" pg) - ;; Do test with several ways of specifying the - ;; shadowing-imported symbol - (loop - for n in '("A" :|A| #\A) - collect - (ignore-errors - (safely-delete-package "H") - (let ((p (ignore-errors - (eval - `(defpackage "H" - (:use) - (:shadowing-import-from "G" ,n)))))) - (mapcar - #'notnot - (list - (packagep p) - (equal (package-name p) "H") - (equal (package-use-list p) nil) - (equal (package-used-by-list p) nil) - (equal (package-nicknames p) nil) - (eql (num-symbols-in-package p) 1) - (multiple-value-bind* (sym access) - (find-symbol "A" p) - (and (eqt access :internal) - (equal (symbol-name sym) "A") - (equal (symbol-package sym) pg) - (equal (package-shadowing-symbols p) - (list sym)))) - (equal (documentation p t) nil) - ))))))) - ((t t t t t t t t) - (t t t t t t t t) - (t t t t t t t t))) - -;; Test import-from option -;; Test for each way of specifying the imported symbol name, -;; and for each way of specifying the package name from which -;; the symbol is imported -(deftest defpackage.8 - (progn - (safely-delete-package "H") - (safely-delete-package "G") - (let ((pg (eval '(defpackage "G" (:use) (:intern "A" "B" "C"))))) - (loop - for pn in '("G" #:|G| #\G) - collect - (loop - for n in '("B" #:|B| #\B) - collect - (ignore-errors - (safely-delete-package "H") - (let ((p (ignore-errors - (eval `(defpackage - "H" (:use) - (:import-from ,pn ,n "A")))))) - (mapcar - #'notnot - (list - (packagep p) - (equal (package-name p) "H") - (equal (package-use-list p) nil) - (equal (package-used-by-list p) nil) - (equal (package-nicknames p) nil) - (equal (package-shadowing-symbols p) nil) - (eql (num-symbols-in-package p) 2) - (multiple-value-bind* (sym access) - (find-symbol "A" p) - (and (eqt access :internal) - (equal (symbol-name sym) "A") - (equal (symbol-package sym) pg))) - (multiple-value-bind* (sym access) - (find-symbol "B" p) - (and (eqt access :internal) - (equal (symbol-name sym) "B") - (equal (symbol-package sym) pg))) - (equal (documentation p t) nil) - )))))))) - (((t t t t t t t t t t) (t t t t t t t t t t) (t t t t t t t t t t)) - ((t t t t t t t t t t) (t t t t t t t t t t) (t t t t t t t t t t)) - ((t t t t t t t t t t) (t t t t t t t t t t) (t t t t t t t t t t)))) - -;; Test defpackage with export option - -(deftest defpackage.9 - (progn - (loop - for n in '("Z" #:|Z| #\Z) - collect - (ignore-errors - (safely-delete-package "H") - (let ((p (ignore-errors - (eval `(defpackage - "H" - (:export "Q" ,n "R") (:use)))))) - (mapcar - #'notnot - (list - (packagep p) - (equal (package-name p) "H") - (equal (package-use-list p) nil) - (equal (package-used-by-list p) nil) - (equal (package-nicknames p) nil) - (equal (package-shadowing-symbols p) nil) - (eql (num-symbols-in-package p) 3) - (loop - for s in '("Q" "Z" "R") do - (unless - (multiple-value-bind* (sym access) - (find-symbol s p) - (and (eqt access :external) - (equal (symbol-name sym) s) - (equal (symbol-package sym) p))) - (return nil)) - finally (return t)) - )))))) - ((t t t t t t t t)(t t t t t t t t)(t t t t t t t t))) - -;; Test defpackage with the intern option - -(deftest defpackage.10 - (progn - (loop - for n in '("Z" #:|Z| #\Z) - collect - (ignore-errors - (safely-delete-package "H") - (let ((p (ignore-errors - (eval `(defpackage - "H" - (:intern "Q" ,n "R") (:use)))))) - (mapcar - #'notnot - (list - (packagep p) - (equal (package-name p) "H") - (equal (package-use-list p) nil) - (equal (package-used-by-list p) nil) - (equal (package-nicknames p) nil) - (equal (package-shadowing-symbols p) nil) - (eql (num-symbols-in-package p) 3) - (loop - for s in '("Q" "Z" "R") do - (unless - (multiple-value-bind* (sym access) - (find-symbol s p) - (and (eqt access :internal) - (equal (symbol-name sym) s) - (equal (symbol-package sym) p))) - (return nil)) - finally (return t)) - )))))) - ((t t t t t t t t) (t t t t t t t t) (t t t t t t t t))) - -;; Test defpackage with size - -(deftest defpackage.11 - (let () - (ignore-errors - (safely-delete-package "H") - (let ((p (ignore-errors - (eval '(defpackage "H" (:use) (:size 0)))))) - (mapcar - #'notnot - (list - (packagep p) - (equal (package-name p) "H") - (equal (package-use-list p) nil) - (equal (package-used-by-list p) nil) - (equal (package-nicknames p) nil) - (equal (package-shadowing-symbols p) nil) - (zerop (num-symbols-in-package p))))))) - (t t t t t t t)) - -(deftest defpackage.12 - (let () - (ignore-errors - (safely-delete-package "H") - (let ((p (ignore-errors - (eval '(defpackage "H" (:use) (:size 10000)))))) - (mapcar - #'notnot - (list - (packagep p) - (equal (package-name p) "H") - (equal (package-use-list p) nil) - (equal (package-used-by-list p) nil) - (equal (package-nicknames p) nil) - (equal (package-shadowing-symbols p) nil) - (zerop (num-symbols-in-package p))))))) - (t t t t t t t)) - -;; defpackage error handling - -;; Repeated size field should cause a program-error -(deftest defpackage.13 - (progn - (safely-delete-package "H") - (signals-error - (defpackage "H" (:use) (:size 10) (:size 20)) - program-error)) - t) - -;; Repeated documentation field should cause a program-error -(deftest defpackage.14 - (progn - (safely-delete-package "H") - (signals-error - (defpackage "H" (:use) - (:documentation "foo") - (:documentation "bar")) - program-error)) - t) - -;; When a nickname refers to an existing package or nickname, -;; signal a package-error - -(deftest defpackage.15 - (progn - (safely-delete-package "H") - (signals-error - (defpackage "H" (:use) (:nicknames "A")) - package-error)) - t) - -(deftest defpackage.16 - (progn - (safely-delete-package "H") - (signals-error - (defpackage "H" (:use) (:nicknames "Q")) - package-error)) - t) - -;; Names in :shadow, :shadowing-import-from, :import-from, and :intern -;; must be disjoint, or a package-error is signalled. - -;; :shadow and :shadowing-import-from -(deftest defpackage.17 - (progn - (safely-delete-package "H") - (safely-delete-package "G") - (eval '(defpackage "G" (:use) (:export "A"))) - (signals-error - (defpackage "H" (:use) - (:shadow "A") - (:shadowing-import-from "G" "A")) - program-error)) - t) - -;; :shadow and :import-from -(deftest defpackage.18 - (progn - (safely-delete-package "H") - (safely-delete-package "G") - (eval '(defpackage "G" (:use) (:export "A"))) - (signals-error - (defpackage "H" (:use) - (:shadow "A") - (:import-from "G" "A")) - program-error)) - t) - -;; :shadow and :intern -(deftest defpackage.19 - (progn - (safely-delete-package "H") - (signals-error - (defpackage "H" (:use) - (:shadow "A") - (:intern "A")) - program-error)) - t) - -;; :shadowing-import-from and :import-from -(deftest defpackage.20 - (progn - (safely-delete-package "H") - (safely-delete-package "G") - (eval '(defpackage "G" (:use) (:export "A"))) - (signals-error - (defpackage "H" (:use) - (:shadowing-import-from "G" "A") - (:import-from "G" "A")) - program-error)) - t) - -;; :shadowing-import-from and :intern -(deftest defpackage.21 - (progn - (safely-delete-package "H") - (safely-delete-package "G") - (eval '(defpackage "G" (:use) (:export "A"))) - (signals-error - (defpackage "H" (:use) - (:shadowing-import-from "G" "A") - (:intern "A")) - program-error)) - t) - -;; :import-from and :intern -(deftest defpackage.22 - (progn - (safely-delete-package "H") - (safely-delete-package "G") - (eval '(defpackage "G" (:use) (:export "A"))) - (signals-error - (defpackage "H" (:use) - (:import-from "G" "A") - (:intern "A")) - program-error)) - t) - -;; Names given to :export and :intern must be disjoint, -;; otherwise signal a program-error -(deftest defpackage.23 - (progn - (safely-delete-package "H") - (signals-error - (defpackage "H" (:use) - (:export "A") - (:intern "A")) - program-error)) - t) - -;; :shadowing-import-from signals a correctable package-error -;; if the symbol is not accessible in the named package -(deftest defpackage.24 - (progn - (safely-delete-package "H") - (safely-delete-package "G") - (eval '(defpackage "G" (:use))) - (handle-non-abort-restart - (eval '(defpackage "H" (:shadowing-import-from - "G" "NOT-THERE"))))) - success) - -;; :import-from signals a correctable package-error if a symbol with -;; the indicated name is not accessible in the package indicated - -(deftest defpackage.25 - (progn - (safely-delete-package "H") - (safely-delete-package "G") - (eval '(defpackage "G" (:use))) - (handle-non-abort-restart - (eval '(defpackage "H" (:import-from "G" "NOT-THERE"))))) - success) - -;; A big test that combines all the options to defpackage - -(deftest defpackage.26 - (let () - (ignore-errors - (flet - ((%do-it% - (args) - (safely-delete-package "H") - (safely-delete-package "G1") - (safely-delete-package "G2") - (safely-delete-package "G3") - (let ((pg1 - (progn - (format t "Making G1...~%") - (eval '(defpackage "G1" - (:use) - (:export "A" "B" "C") - (:intern "D" "E" "F"))))) - (pg2 - (progn - (format t "Making G2...~%") - (eval '(defpackage "G2" - (:use) - (:export "A" "D" "G") - (:intern "E" "H" "I"))))) - (pg3 - (progn - (format t "Making G3...~%") - (eval '(defpackage "G3" - (:use) - (:export "J" "K" "L") - (:intern "M" "N" "O")))))) - (let ((p (eval (list* 'defpackage "H" (copy-tree args))))) - (prog - () - (unless (packagep p) (return 1)) - (unless (equal (package-name p) "H") (return 2)) - (unless (equal (package-name pg1) "G1") (return 3)) - (unless (equal (package-name pg2) "G2") (return 4)) - (unless (equal (package-name pg3) "G3") (return 5)) - (unless - (equal (sort (copy-list (package-nicknames p)) #'string<) - '("H1" "H2")) - (return 6)) - (unless - (or - (equal (package-use-list p) (list pg1 pg2)) - (equal (package-use-list p) (list pg2 pg1))) - (return 7)) - (unless (equal (package-used-by-list pg1) (list p)) - (return 8)) - (unless (equal (package-used-by-list pg2) (list p)) - (return 9)) - (when (package-used-by-list pg3) (return 10)) - (unless (equal (sort (mapcar #'symbol-name - (package-shadowing-symbols p)) - #'string<) - '("A" "B")) - (return 10)) - (let ((num 11)) - (unless - (every - #'(lambda (str acc pkg) - (multiple-value-bind* - (sym access) - (find-symbol str p) - (or - (and (or (not acc) (equal (symbol-name sym) str)) - (or (not acc) (equal (symbol-package sym) pkg)) - (equal access acc) - (incf num)) - (progn - (format t - "Failed on str = ~S, acc = ~S, pkg = ~S, sym = ~S, access = ~S~%" - str acc pkg sym access) - nil)))) - (list "A" "B" "C" "D" "E" "F" "G" - "H" "I" "J" "K" "L" "M" "N" "O") - (list :internal :internal - :external :inherited - nil nil - :inherited :internal - nil nil - nil :external - nil nil - :internal) - (list pg2 p pg1 pg2 nil nil - pg2 p nil nil nil pg3 - nil nil pg3)) - (return num))) - (return 'success)))))) - (let ((args '((:nicknames "H1" "H2") - (:use "G1" "G2") - (:shadow "B") - (:shadowing-import-from "G2" "A") - (:import-from "G3" "L" "O") - (:intern "D" "H") - (:export "L" "C") - (:size 20) - (:documentation "A test package")))) - (list (%do-it% args) - (%do-it% (reverse args))))))) - (success success)) - -(def-macro-test defpackage.error.1 - (defpackage :nonexistent-package (:use))) diff --git a/t/ansi-test/packages/delete-package.lsp b/t/ansi-test/packages/delete-package.lsp deleted file mode 100644 index 0999067..0000000 --- a/t/ansi-test/packages/delete-package.lsp +++ /dev/null @@ -1,211 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 25 08:01:58 1998 -;;;; Contains: Tests of DELETE-PACKAGE - - -(declaim (optimize (safety 3))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; delete-package - -;; check return value of delete-package, and check -;; that package-name is nil on the deleted package object -(deftest delete-package.1 - (progn - (safely-delete-package :test1) - (let ((p (make-package :test1 :use nil))) - (list - (notnot (delete-package :test1)) - (notnot (packagep p)) - (package-name p)))) - (t t nil)) - -(deftest delete-package.2 - (progn - (safely-delete-package :test1) - (let ((p (make-package :test1 :use nil))) - (list - (notnot (delete-package :test1)) - (notnot (packagep p)) - (delete-package p)))) - (t t nil)) - -;; Check that deletion of different package designators works -(deftest delete-package.3 - (progn - (safely-delete-package "X") - (make-package "X") - (handler-case - (notnot (delete-package "X")) - (error (c) c))) - t) - -(deftest delete-package.4 - (progn - (safely-delete-package "X") - (make-package "X") - (handler-case - (notnot (delete-package #\X)) - (error (c) c))) - t) - -;;; PFD 10/14/02 -- These tests are broken again. I suspect -;;; some sort of interaction with the test harness. - -;;; PFD 01.18.03 This test is working, but suspicious. - -(deftest delete-package.5 - (prog (p1 s1 p2 s2 p3) - (declare (ignorable p1 p2 p3 s1 s2)) - (safely-delete-package "P3") - (safely-delete-package "P2") - (safely-delete-package "P1") - - (setq p1 (make-package "P1" :use ())) - (setq s1 (intern "S1" P1)) - (export s1 "P1") - - (setq p2 (make-package "P2" :use '("P1"))) - (setq s2 (intern "S2" p2)) - (export s1 p2) - (export s2 "P2") - - (setf p3 (make-package "P3" :use '("P2"))) - - ;; Delete the P2 package, catching the continuable - ;; error and deleting the package - - (let ((outer-restarts (compute-restarts))) - (handler-bind ((package-error - #'(lambda (c) - ;; (let ((r (find-restart 'continue c))) (and r (invoke-restart r))) - (let ((my-restarts - (remove 'abort - (set-difference (compute-restarts c) - outer-restarts) - :key #'restart-name))) - (assert my-restarts) - (when (find 'continue my-restarts :key #'restart-name) - (continue c)) - (return t) - )))) - (delete-package p2))) - - (unless (and (equal (package-name P1) "P1") - (null (package-name P2)) - (equal (package-name P3) "P3")) - (return 'fail1)) - - (unless (eqt (symbol-package S1) P1) - (return 'fail2)) - (unless (equal (prin1-to-string S1) "P1:S1") - (return 'fail3)) - - (unless (equal (multiple-value-list (find-symbol "S1" P3)) - '(nil nil)) - (return 'fail4)) - - (unless (equal (multiple-value-list (find-symbol "S2" P3)) - '(nil nil)) - (return 'fail5)) - - (unless (and (null (package-used-by-list P1)) - (null (package-used-by-list P3))) - (return 'fail6)) - - (unless (and (packagep P1) - (packagep P2) - (packagep P3)) (return 'fail7)) - - (unless (and (null (package-use-list P1)) - (null (package-use-list P3))) - (return 'fail8)) - - (safely-delete-package P3) - (safely-delete-package P1) - (return t) - ) - t) - -;; deletion of a nonexistent package should cause a continuable -;; package-error (same comments for delete-package.5 apply -;; here as well) - -(deftest delete-package.6 - (block done - (let ((outer-restarts (compute-restarts))) - (safely-delete-package "TEST-20") - (handler-bind ((package-error - #'(lambda (c) - (assert (set-difference (compute-restarts c) - outer-restarts)) - (return-from done :good)))) - (delete-package "TEST-20")))) - :good) - -;;; Specialized sequences - -(defmacro def-delete-package-test (test-name name-form) - `(deftest ,test-name - (let ((name ,name-form)) - (safely-delete-package name) - (let ((p (make-package name :use nil))) - (list - (notnot (delete-package :test1)) - (notnot (packagep p)) - (package-name p)))) - (t t nil))) - -(def-delete-package-test delete-package.7 - (make-array '(5) :initial-contents "TEST1" - :element-type 'base-char)) - -(def-delete-package-test delete-package.8 - (make-array '(10) :initial-contents "TEST1XXXXX" - :fill-pointer 5 - :element-type 'base-char)) - -(def-delete-package-test delete-package.9 - (make-array '(10) :initial-contents "TEST1XXXXX" - :fill-pointer 5 - :element-type 'character)) - -(def-delete-package-test delete-package.10 - (make-array '(5) :initial-contents "TEST1" - :adjustable t - :element-type 'base-char)) - -(def-delete-package-test delete-package.11 - (make-array '(5) :initial-contents "TEST1" - :adjustable t - :element-type 'character)) - -(def-delete-package-test delete-package.12 - (let* ((etype 'character) - (name2 (make-array '(10) :initial-contents "XXXTEST1YY" - :element-type etype))) - (make-array '(5) :displaced-to name2 - :displaced-index-offset 3 - :element-type etype))) - -(def-delete-package-test delete-package.13 - (let* ((etype 'base-char) - (name2 (make-array '(10) :initial-contents "XXXTEST1YY" - :element-type etype))) - (make-array '(5) :displaced-to name2 - :displaced-index-offset 3 - :element-type etype))) - -;;; Error tests - -(deftest delete-package.error.1 - (signals-error (delete-package) program-error) - t) - -(deftest delete-package.error.2 - (progn - (unless (find-package "TEST-DPE2") - (make-package "TEST-DPE2" :use nil)) - (signals-error (delete-package "TEST-DPE2" nil) - program-error)) - t) diff --git a/t/ansi-test/packages/do-all-symbols.lsp b/t/ansi-test/packages/do-all-symbols.lsp deleted file mode 100644 index baa0c8e..0000000 --- a/t/ansi-test/packages/do-all-symbols.lsp +++ /dev/null @@ -1,133 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Feb 21 18:27:22 2004 -;;;; Contains: Tests of DO-ALL-SYMBOLS - - - -(def-macro-test do-all-symbols.error.1 - (do-all-symbols (x))) - -;;; FIXME Add tests for non-error cases - -(deftest do-all-symbols.1 - (let ((symbols nil)) - (do-all-symbols (sym) (push sym symbols)) - (let ((hash (make-hash-table :test 'eq))) - (with-package-iterator - (f (list-all-packages) :internal :external :inherited) - (loop - (multiple-value-bind (found sym) (f) - (unless found (return)) - (setf (gethash sym hash) t)))) - ;; hash now contains all symbols accessible in any package - ;; Check that all symbols from DO-ALL-SYMBOLS are in this - ;; package - (loop for s in symbols unless (gethash s hash) collect s))) - nil) - -;; This is the converse of do-all-symbols.1 -(deftest do-all-symbols.2 - (let ((symbols nil)) - (with-package-iterator - (f (list-all-packages) :internal :external :inherited) - (loop - (multiple-value-bind (found sym) (f) - (unless found (return))` - (push sym symbols)))) - (let ((hash (make-hash-table :test 'eq))) - (do-all-symbols (s) (setf (gethash s hash) t)) - (loop for s in symbols unless (gethash s hash) collect s))) - nil) - -(deftest do-all-symbols.3 - (let ((sym (gensym))) - (do-all-symbols (s t) (assert (not (eq s sym))))) - t) - -(deftest do-all-symbols.4 - (let ((x :bad)) - (do-all-symbols (x x))) - nil) - -(deftest do-all-symbols.5 - (block nil - (do-all-symbols (x (return :bad))) - :good) - :good) - -(deftest do-all-symbols.6 - (do-all-symbols (x :bad) (return :good)) - :good) - -(deftest do-all-symbols.7 - (block done - (tagbody - (do-all-symbols (x (return-from done :good)) - (go 1) - (return-from done :bad1) - 1) - 1 - (return-from done :bad2))) - :good) - -(deftest do-all-symbols.8 - (block done - (tagbody - (do-all-symbols (x (return-from done :good)) - (go tag) - (return-from done :bad1) - tag) - tag - (return-from done :bad2))) - :good) - -;;; Test that do-all-symbols accepts declarations - -(deftest do-all-symbols.9 - (let ((x 0) - (y 1)) - (do-all-symbols (z nil) - (declare (type (integer * 0) x)) - (declare (type (integer 1 *) y)) - (declare (ignore z)) - (when (< x y) (return :good)))) - :good) - - -;;; Default return is NIL - -(deftest do-all-symbols.10 - (do-all-symbols (s) (declare (ignore s))) - nil) - -;;; Free declaration scope tests - -(deftest do-all-symbols.11 - (let ((x :good)) - (declare (special x)) - (let ((x :bad)) - (do-all-symbols (s x) - (declare (special x))))) - :good) - -;;; Executing a return actually terminates the loop - -(deftest do-all-symbols.12 - (let ((should-have-returned nil)) - (block done - (do-all-symbols (s :bad1) - (when should-have-returned - (return-from done :bad2)) - (setq should-have-returned t) - (return :good)))) - :good) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest do-all-symbols.13 - (macrolet - ((%m (z) z)) - (do-all-symbols (s (expand-in-current-env (%m :good))))) - :good) diff --git a/t/ansi-test/packages/do-external-symbols.lsp b/t/ansi-test/packages/do-external-symbols.lsp deleted file mode 100644 index af45442..0000000 --- a/t/ansi-test/packages/do-external-symbols.lsp +++ /dev/null @@ -1,151 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Feb 21 18:26:08 2004 -;;;; Contains: Tests of DO-EXTERNAL-SYMBOLS - - - - - -(declaim (optimize (safety 3))) - -(defun collect-external-symbols (pkg) - (remove-duplicates - (sort-symbols - (let ((all nil)) - (do-external-symbols (x pkg all) (push x all)))))) - -(deftest do-external-symbols.1 - (collect-external-symbols "DS1") - (DS1:A DS1:B)) - -(deftest do-external-symbols.2 - (collect-external-symbols "DS2") - (DS2:A DS2:G DS2:H)) - -(deftest do-external-symbols.3 - (collect-external-symbols "DS3") - (DS1:A DS3:B DS2:G DS3:I DS3:J DS3:K)) - -(deftest do-external-symbols.4 - (collect-external-symbols "DS4") - ()) - -(deftest do-external-symbols.5 - (equalt (collect-external-symbols "KEYWORD") - (collect-symbols "KEYWORD")) - t) - -;; Test that do-external-symbols works without -;; a return value (and that the default return value is nil) - -(deftest do-external-symbols.6 - (do-external-symbols (s "DS1") (declare (ignore s)) t) - nil) - -;; Test that do-external-symbols works without -;; a package being specified - -(deftest do-external-symbols.7 - (let ((x nil) - (*package* (find-package "DS1"))) - (list - (do-external-symbols (s) (push s x)) - (sort-symbols x))) - (nil (DS1:A DS1:B))) - -;; Test that the tags work in the tagbody, -;; and that multiple statements work - -(deftest do-external-symbols.8 - (handler-case - (let ((x nil)) - (list - (do-external-symbols - (s "DS1") - (when (equalt (symbol-name s) "A") (go bar)) - (push s x) - (go foo) - bar - (push t x) - foo) - (sort-symbols x))) - (error (c) c)) - (NIL (DS1:B T))) - -;;; Specialized sequence tests - -(defmacro def-do-external-symbols-test (test-name name-form) - `(deftest ,test-name - (collect-external-symbols ,name-form) - (DS1:A DS1:B))) - -(def-do-external-symbols-test do-external-symbols.9 - (make-array 3 :element-type 'base-char :initial-contents "DS1")) - -(def-do-external-symbols-test do-external-symbols.10 - (make-array 6 :element-type 'base-char :initial-contents "DS1XXX" - :fill-pointer 3)) - -(def-do-external-symbols-test do-external-symbols.11 - (make-array 6 :element-type 'character :initial-contents "DS1XXX" - :fill-pointer 3)) - -(def-do-external-symbols-test do-external-symbols.12 - (make-array 3 :element-type 'base-char :initial-contents "DS1" - :adjustable t)) - -(def-do-external-symbols-test do-external-symbols.13 - (make-array 3 :element-type 'character :initial-contents "DS1" - :adjustable t)) - -(def-do-external-symbols-test do-external-symbols.14 - (let* ((etype 'base-char) - (name0 (make-array 6 :element-type etype :initial-contents "XDS1XX"))) - (make-array 3 :element-type etype - :displaced-to name0 :displaced-index-offset 1))) - -(def-do-external-symbols-test do-external-symbols.15 - (let* ((etype 'character) - (name0 (make-array 6 :element-type etype :initial-contents "XDS1XX"))) - (make-array 3 :element-type etype - :displaced-to name0 :displaced-index-offset 1))) - -;;; Free declaration scope tests - -(deftest do-external-symbols.16 - (block done - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) - (do-external-symbols (s (return-from done x)) - (declare (special x)))))) - :good) - -(deftest do-external-symbols.17 - (let ((x :good)) - (declare (special x)) - (let ((x :bad)) - (do-external-symbols (s "CL-TEST" x) - (declare (special x))))) - :good) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest do-external-symbols.18 - (macrolet - ((%m (z) z)) - (do-external-symbols (s (expand-in-current-env (%m "CL-TEST")) :good))) - :good) - -(deftest do-external-symbols.19 - (macrolet - ((%m (z) z)) - (do-external-symbols (s "CL-TEST" (expand-in-current-env (%m :good))))) - :good) - -;;; Error tests - -(def-macro-test do-external-symbols.error.1 - (do-external-symbols (x "CL"))) diff --git a/t/ansi-test/packages/do-symbols.lsp b/t/ansi-test/packages/do-symbols.lsp deleted file mode 100644 index 0b484d4..0000000 --- a/t/ansi-test/packages/do-symbols.lsp +++ /dev/null @@ -1,173 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Feb 21 18:24:59 2004 -;;;; Contains: Tests of DO-SYMBOLS - - - - - -(declaim (optimize (safety 3))) - -(deftest do-symbols.1 - (progn - (set-up-packages) - (equalt - (remove-duplicates - (sort-symbols (let ((all nil)) - (do-symbols (x "B" all) (push x all))))) - (list (find-symbol "BAR" "B") - (find-symbol "FOO" "A")))) - t) - -;; -;; Test up some test packages -;; - -(defun collect-symbols (pkg) - (remove-duplicates - (sort-symbols - (let ((all nil)) - (do-symbols (x pkg all) (push x all)))))) - -(deftest do-symbols.2 - (collect-symbols "DS1") - (DS1:A DS1:B DS1::C DS1::D)) - -(deftest do-symbols.3 - (collect-symbols "DS2") - (DS2:A DS2::E DS2::F DS2:G DS2:H)) - -(deftest do-symbols.4 - (collect-symbols "DS3") - (DS1:A DS3:B DS2:G DS2:H DS3:I DS3:J DS3:K DS3::L DS3::M)) - -(deftest do-symbols.5 - (remove-duplicates - (collect-symbols "DS4") - :test #'(lambda (x y) - (and (eqt x y) - (not (eqt x 'DS4::B))))) - (DS1:A DS1:B DS2::F DS3:G DS3:I DS3:J DS3:K DS4::X DS4::Y DS4::Z)) - - -;; Test that do-symbols works without -;; a return value (and that the default return value is nil) - -(deftest do-symbols.6 - (do-symbols (s "DS1") (declare (ignore s)) t) - nil) - -;; Test that do-symbols works without a package being specified - -(deftest do-symbols.7 - (let ((x nil) - (*package* (find-package "DS1"))) - (list - (do-symbols (s) (push s x)) - (sort-symbols x))) - (nil (DS1:A DS1:B DS1::C DS1::D))) - -;; Test that the tags work in the tagbody, -;; and that multiple statements work - -(deftest do-symbols.8 - (handler-case - (let ((x nil)) - (list - (do-symbols - (s "DS1") - (when (equalt (symbol-name s) "C") (go bar)) - (push s x) - (go foo) - bar - (push t x) - foo) - (sort-symbols x))) - (error (c) c)) - (NIL (DS1:A DS1:B DS1::D T))) - -;;; Specialized sequences - -(defmacro def-do-symbols-test (test-name name-form) - `(deftest ,test-name - (let ((name ,name-form)) - (assert (string= name "B")) - (set-up-packages) - (equalt - (remove-duplicates - (sort-symbols (let ((all nil)) - (do-symbols (x name all) (push x all))))) - (list (find-symbol "BAR" "B") - (find-symbol "FOO" "A")))) - t)) - -(def-do-symbols-test do-symbols.9 - (make-array 1 :element-type 'base-char :initial-contents "B")) - -(def-do-symbols-test do-symbols.10 - (make-array 5 :element-type 'character - :fill-pointer 1 - :initial-contents "BXXXX")) - -(def-do-symbols-test do-symbols.11 - (make-array 5 :element-type 'base-char - :fill-pointer 1 - :initial-contents "BXXXX")) - -(def-do-symbols-test do-symbols.12 - (make-array 1 :element-type 'base-char - :adjustable t :initial-contents "B")) - -(def-do-symbols-test do-symbols.13 - (make-array 1 :element-type 'character - :adjustable t :initial-contents "B")) - -(def-do-symbols-test do-symbols.14 - (let* ((etype 'base-char) - (name0 (make-array 4 :element-type etype :initial-contents "XBYZ"))) - (make-array 1 :element-type etype - :displaced-to name0 :displaced-index-offset 1))) - -(def-do-symbols-test do-symbols.15 - (let* ((etype 'character) - (name0 (make-array 4 :element-type etype :initial-contents "XBYZ"))) - (make-array 1 :element-type etype - :displaced-to name0 :displaced-index-offset 1))) - -;;; Free declaration scope tests - -(deftest do-symbols.16 - (block done - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) - (do-symbols (s (return-from done x)) - (declare (special x)))))) - :good) - -(deftest do-symbols.17 - (let ((x :good)) - (declare (special x)) - (let ((x :bad)) - (do-symbols (s "CL-TEST" x) - (declare (special x))))) - :good) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest do-symbols.18 - (macrolet - ((%m (z) z)) - (do-symbols (s (expand-in-current-env (%m "CL-TEST")) :good))) - :good) - -(deftest do-symbols.19 - (macrolet - ((%m (z) z)) - (do-symbols (s "CL-TEST" (expand-in-current-env (%m :good))))) - :good) - -(def-macro-test do-symbols.error.1 - (do-symbols (x "CL"))) diff --git a/t/ansi-test/packages/export.lsp b/t/ansi-test/packages/export.lsp deleted file mode 100644 index 12730af..0000000 --- a/t/ansi-test/packages/export.lsp +++ /dev/null @@ -1,109 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 25 07:59:45 1998 -;;;; Contains: Tests of EXPORT - - -(declaim (optimize (safety 3))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; export - -(deftest export.1 - (let ((return-value nil)) - (safely-delete-package "TEST1") - (let ((p (make-package "TEST1"))) - (let ((sym (intern "FOO" p)) - (i 0) x y) - (setf return-value (export (progn (setf x (incf i)) sym) - (progn (setf y (incf i)) p))) - (multiple-value-bind* (sym2 status) - (find-symbol "FOO" p) - (prog1 - (and sym2 - (eql i 2) - (eql x 1) - (eql y 2) - (eqt (symbol-package sym2) p) - (string= (symbol-name sym2) "FOO") - (eqt sym sym2) - (eqt status :external)) - (delete-package p))))) - return-value) - t) - -(deftest export.2 - (progn - (safely-delete-package "TEST1") - (let ((p (make-package "TEST1"))) - (let ((sym (intern "FOO" p))) - (export (list sym) p) - (multiple-value-bind* (sym2 status) - (find-symbol "FOO" p) - (prog1 - (and sym2 - (eqt (symbol-package sym2) p) - (string= (symbol-name sym2) "FOO") - (eqt sym sym2) - (eqt status :external)) - (delete-package p)))))) - t) - -(deftest export.3 - (handler-case - (progn - (safely-delete-package "F") - (make-package "F") - (let ((sym (intern "FOO" "F"))) - (export sym #\F) - (delete-package "F") - t)) - (error (c) (safely-delete-package "F") c)) - t) - -;; -;; When a symbol not in a package is exported, export -;; should signal a correctable package-error asking the -;; user whether the symbol should be imported. -;; -(deftest export.4 - (progn - (set-up-packages) - (handler-case - (export 'b::bar "A") - (package-error () 'package-error) - (error (c) c))) - package-error) - -;; -;; Test that it catches an attempt to export a symbol -;; from a package that is used by another package that -;; is exporting a symbol with the same name. -;; -(deftest export.5 - (progn - (safely-delete-package "TEST1") - (safely-delete-package "TEST2") - (make-package "TEST1") - (make-package "TEST2" :use '("TEST1")) - (export (intern "X" "TEST2") "TEST2") - (prog1 - (handler-case - (let ((sym (intern "X" "TEST1"))) - (handler-case - (export sym "TEST1") - (error (c) - (format t "Caught error in EXPORT.5: ~A~%" c) - 'caught))) - (error (c) c)) - (delete-package "TEST2") - (delete-package "TEST1"))) - caught) - -(deftest export.error.1 - (signals-error (export) program-error) - t) - -(deftest export.error.2 - (signals-error (export 'X "CL-TEST" NIL) program-error) - t) diff --git a/t/ansi-test/packages/find-all-symbols.lsp b/t/ansi-test/packages/find-all-symbols.lsp deleted file mode 100644 index 07af26f..0000000 --- a/t/ansi-test/packages/find-all-symbols.lsp +++ /dev/null @@ -1,126 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Feb 22 07:10:22 2004 -;;;; Contains: Tests for FIND-ALL-SYMBOLS - - - -(deftest find-all-symbols.1 - (let ((all-packages (list-all-packages))) - (loop - for package in all-packages - append - (let ((failures nil)) - (do-symbols (sym package failures) - (when (eql (symbol-package sym) package) - (let* ((name (symbol-name sym)) - (similar (find-all-symbols name)) - (similar2 (find-all-symbols sym))) - (unless (and (member sym similar) - (subsetp similar similar2) - (subsetp similar2 similar) - (loop for sym2 in similar - always (string= name (symbol-name sym2)))) - (push sym failures)))))))) - nil) - -;;; FIXME -- test that each symbol found is accessible in some package - -(deftest find-all-symbols.2 - (loop for i from 0 to 255 - for c = (code-char i) - when (and (characterp c) - (loop for sym in (find-all-symbols c) - thereis (not (string= (symbol-name sym) - (string c))))) - collect c) - nil) - -;;; Unusual strings - -(deftest find-all-symbols.3 - (let* ((name (make-array '(3) :initial-contents "NIL" - :element-type 'base-char)) - (symbols (find-all-symbols name))) - (values - (notnot (every #'(lambda (s) (string= (symbol-name s) "NIL")) symbols)) - (some #'not symbols))) - t t) - -(deftest find-all-symbols.4 - (let* ((name (make-array '(5) :initial-contents "NILXY" - :fill-pointer 3 - :element-type 'character)) - (symbols (find-all-symbols name))) - (values - (notnot (every #'(lambda (s) (string= (symbol-name s) "NIL")) symbols)) - (some #'not symbols))) - t t) - -(deftest find-all-symbols.5 - (let* ((name (make-array '(5) :initial-contents "NILXY" - :fill-pointer 3 - :element-type 'base-char)) - (symbols (find-all-symbols name))) - (values - (notnot (every #'(lambda (s) (string= (symbol-name s) "NIL")) symbols)) - (some #'not symbols))) - t t) - -(deftest find-all-symbols.6 - (let* ((name (make-array '(3) :initial-contents "NIL" - :adjustable t - :element-type 'base-char)) - (symbols (find-all-symbols name))) - (values - (notnot (every #'(lambda (s) (string= (symbol-name s) "NIL")) symbols)) - (some #'not symbols))) - t t) - -(deftest find-all-symbols.7 - (let* ((name (make-array '(3) :initial-contents "NIL" - :adjustable t - :element-type 'character)) - (symbols (find-all-symbols name))) - (values - (notnot (every #'(lambda (s) (string= (symbol-name s) "NIL")) symbols)) - (some #'not symbols))) - t t) - -(deftest find-all-symbols.8 - (let* ((type 'character) - (name0 (make-array '(9) :initial-contents "XYZNILABC" - :element-type type)) - (name (make-array '(3) :element-type type - :displaced-to name0 - :displaced-index-offset 3)) - (symbols (find-all-symbols name))) - (values - (notnot (every #'(lambda (s) (string= (symbol-name s) "NIL")) symbols)) - (some #'not symbols))) - t t) - -(deftest find-all-symbols.9 - (let* ((type 'base-char) - (name0 (make-array '(9) :initial-contents "XYZNILABC" - :element-type type)) - (name (make-array '(3) :element-type type - :displaced-to name0 - :displaced-index-offset 3)) - (symbols (find-all-symbols name))) - (values - (notnot (every #'(lambda (s) (string= (symbol-name s) "NIL")) symbols)) - (some #'not symbols))) - t t) - -;;; Error tests - -(deftest find-all-symbols.error.1 - (signals-error (find-all-symbols) program-error) - t) - -(deftest find-all-symbols.error.2 - (signals-error (find-all-symbols "CAR" nil) program-error) - t) - - diff --git a/t/ansi-test/packages/find-package.lsp b/t/ansi-test/packages/find-package.lsp deleted file mode 100644 index 55cb4da..0000000 --- a/t/ansi-test/packages/find-package.lsp +++ /dev/null @@ -1,155 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 25 07:50:39 1998 -;;;; Contains: Tests for FIND-PACKAGE - - -(declaim (optimize (safety 3))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; find-package - -(deftest find-package.1 - (let ((p (find-package "CL")) - (p2 (find-package "COMMON-LISP"))) - (and p p2 (eqt p p2))) - t) - -(deftest find-package.2 - (let ((p (find-package "CL-USER")) - (p2 (find-package "COMMON-LISP-USER"))) - (and p p2 (eqt p p2))) - t) - -(deftest find-package.3 - (let ((p (find-package "KEYWORD"))) - (and p (eqt p (symbol-package :test)))) - t) - -(deftest find-package.4 - (progn - (set-up-packages) - (let ((p (ignore-errors (find-package "A")))) - (if (packagep p) - t - p))) - t) - -(deftest find-package.5 - (progn - (set-up-packages) - (let ((p (ignore-errors (find-package #\A)))) - (if (packagep p) - t - p))) - t) - -(deftest find-package.6 - (progn - (set-up-packages) - (let ((p (ignore-errors (find-package "B")))) - (if (packagep p) - t - p))) - t) - -(deftest find-package.7 - (progn - (set-up-packages) - (let ((p (ignore-errors (find-package #\B)))) - (if (packagep p) - t - p))) - t) - -(deftest find-package.8 - (progn - (set-up-packages) - (let ((p (ignore-errors (find-package "Q"))) - (p2 (ignore-errors (find-package "A")))) - (and (packagep p) - (packagep p2) - (eqt p p2)))) - t) - -(deftest find-package.9 - (progn - (set-up-packages) - (let ((p (ignore-errors (find-package "A"))) - (p2 (ignore-errors (find-package "B")))) - (eqt p p2))) - nil) - -(deftest find-package.10 - (progn - (set-up-packages) - (let ((p (ignore-errors (find-package #\Q))) - (p2 (ignore-errors (find-package "Q")))) - (and (packagep p) - (eqt p p2)))) - t) - -(deftest find-package.11 - (let* ((cl (find-package "CL")) - (cl2 (find-package cl))) - (and (packagep cl) - (eqt cl cl2))) - t) - -(deftest find-package.12 - (let* ((name (make-array '(7) :initial-contents "KEYWORD" - :element-type 'base-char)) - (p (find-package name))) - (and p (eqt p (symbol-package :test)))) - t) - -(deftest find-package.13 - (let* ((name (make-array '(10) :initial-contents "KEYWORDXYZ" - :fill-pointer 7 - :element-type 'base-char)) - (p (find-package name))) - (and p (eqt p (symbol-package :test)))) - t) - -(deftest find-package.14 - (let* ((name (make-array '(10) :initial-contents "KEYWORDXYZ" - :fill-pointer 7 - :element-type 'character)) - (p (find-package name))) - (and p (eqt p (symbol-package :test)))) - t) - -(deftest find-package.15 - (let* ((name0 (make-array '(10) :initial-contents "XYKEYWORDZ" - :element-type 'character)) - (name (make-array '(7) :displaced-to name0 :displaced-index-offset 2 - :element-type 'character)) - (p (find-package name))) - (and p (eqt p (symbol-package :test)))) - t) - -(deftest find-package.16 - (let* ((name (make-array '(7) :initial-contents "KEYWORD" - :adjustable t - :element-type 'base-char)) - (p (find-package name))) - (and p (eqt p (symbol-package :test)))) - t) - -(deftest find-package.17 - (let* ((name (make-array '(7) :initial-contents "KEYWORD" - :adjustable t - :element-type 'character)) - (p (find-package name))) - (and p (eqt p (symbol-package :test)))) - t) - -;;; Error tests - -(deftest find-package.error.1 - (signals-error (find-package) program-error) - t) - -(deftest find-package.error.2 - (signals-error (find-package "CL" nil) program-error) - t) diff --git a/t/ansi-test/packages/find-symbol.lsp b/t/ansi-test/packages/find-symbol.lsp deleted file mode 100644 index 7aff94b..0000000 --- a/t/ansi-test/packages/find-symbol.lsp +++ /dev/null @@ -1,160 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 25 07:49:34 1998 -;;;; Contains: Tests for FIND-SYMBOL - - - -;;(declaim (optimize (safety 3))) - -;; Test find-symbol, with the various combinations of -;; package designators - -(deftest find-symbol.1 - (find-symbol "aBmAchb1c") - nil nil) - -(deftest find-symbol.2 - (find-symbol "aBmAchb1c" "CL") - nil nil) - -(deftest find-symbol.3 - (find-symbol "aBmAchb1c" "COMMON-LISP") - nil nil) - -(deftest find-symbol.4 - (find-symbol "aBmAchb1c" "KEYWORD") - nil nil) - -(deftest find-symbol.5 - (find-symbol "aBmAchb1c" "COMMON-LISP-USER") - nil nil) - -(deftest find-symbol.6 - (find-symbol (string '#:car) "CL") - car :external) - -(deftest find-symbol.7 - (find-symbol (string '#:car) "COMMON-LISP") - car :external) - -(deftest find-symbol.8 - (values (find-symbol (string '#:car) "COMMON-LISP-USER")) - car #| :inherited |# ) - -(deftest find-symbol.9 - (find-symbol (string '#:car) "CL-TEST") - car :inherited) - -(deftest find-symbol.10 - (find-symbol (string '#:test) "KEYWORD") - :test :external) - -(deftest find-symbol.11 - (find-symbol (string '#:find-symbol.11) "CL-TEST") - find-symbol.11 :internal) - -(deftest find-symbol.12 - (progn - (set-up-packages) - (let ((vals (multiple-value-list (find-symbol "FOO" #\A)))) - (values (length vals) - (package-name (symbol-package (first vals))) - (symbol-name (first vals)) - (second vals)))) - 2 "A" "FOO" :external) - -(deftest find-symbol.13 - (progn - (set-up-packages) - (intern "X" (find-package "A")) - (let ((vals (multiple-value-list (find-symbol "X" #\A)))) - (values (length vals) - (package-name (symbol-package (first vals))) - (symbol-name (first vals)) - (second vals)))) - 2 "A" "X" :internal) - -(deftest find-symbol.14 - (progn - (set-up-packages) - (let ((vals (multiple-value-list (find-symbol "FOO" #\B)))) - (values (length vals) - (package-name (symbol-package (first vals))) - (symbol-name (first vals)) - (second vals)))) - 2 "A" "FOO" :inherited) - -(deftest find-symbol.15 - (find-symbol "FOO" "FS-B") - FS-A::FOO :inherited) - -(deftest find-symbol.16 - (find-symbol "FOO" (find-package "FS-B")) - FS-A::FOO :inherited) - -(deftest find-symbol.17 - (let ((name (make-array '(3) :initial-contents "FOO" - :element-type 'base-char))) - (find-symbol name "FS-B")) - FS-A::FOO :inherited) - -(deftest find-symbol.18 - (let ((name (make-array '(4) :initial-contents "FOOD" - :element-type 'character - :fill-pointer 3))) - (find-symbol name "FS-B")) - FS-A::FOO :inherited) - -(deftest find-symbol.19 - (let ((name (make-array '(4) :initial-contents "FOOD" - :element-type 'base-char - :fill-pointer 3))) - (find-symbol name "FS-B")) - FS-A::FOO :inherited) - -(deftest find-symbol.20 - (let* ((name0 (make-array '(5) :initial-contents "XFOOY" - :element-type 'character)) - (name (make-array '(3) :element-type 'character - :displaced-to name0 - :displaced-index-offset 1))) - (find-symbol name "FS-B")) - FS-A::FOO :inherited) - -(deftest find-symbol.21 - (let* ((name0 (make-array '(5) :initial-contents "XFOOY" - :element-type 'base-char)) - (name (make-array '(3) :element-type 'base-char - :displaced-to name0 - :displaced-index-offset 1))) - (find-symbol name "FS-B")) - FS-A::FOO :inherited) - -(deftest find-symbol.22 - (find-symbol "FOO" (make-array '(4) :initial-contents "FS-B" :element-type 'base-char)) - FS-A::FOO :inherited) - -(deftest find-symbol.23 - (find-symbol "FOO" (make-array '(5) :initial-contents "FS-BX" - :fill-pointer 4 - :element-type 'base-char)) - FS-A::FOO :inherited) - - - -(deftest find-symbol.order.1 - (let ((i 0) x y) - (values - (find-symbol (progn (setf x (incf i)) (string '#:car)) - (progn (setf y (incf i)) "COMMON-LISP")) - i x y)) - car 2 1 2) - -(deftest find-symbol.error.1 - (signals-error (find-symbol) program-error) - t) - -(deftest find-symbol.error.2 - (signals-error (find-symbol "CAR" "CL" nil) program-error) - t) diff --git a/t/ansi-test/packages/import.lsp b/t/ansi-test/packages/import.lsp deleted file mode 100644 index c0c03cc..0000000 --- a/t/ansi-test/packages/import.lsp +++ /dev/null @@ -1,274 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Feb 19 07:06:48 2004 -;;;; Contains: Tests of IMPORT - - - - - -;;; Create a package name that does not collide with an existing package -;;; name or nickname -(defvar *import-package-test-name* - (loop for i from 1 - for name = (format nil "ITP-~A" i) - unless (find-package name) return name)) - -(deftest import.1 - (let ((pkg-name *import-package-test-name*)) - (safely-delete-package pkg-name) - (let ((pkg (eval `(defpackage ,pkg-name (:use)))) - (sym 'foo)) - (values - (multiple-value-list (import sym pkg)) - (eqlt (find-symbol (symbol-name sym) pkg) sym) - (eqlt (symbol-package sym) (find-package :cl-test)) - (external-symbols-in-package pkg) - ))) - (t) t t nil) - -(deftest import.2 - (let ((pkg-name *import-package-test-name*)) - (safely-delete-package pkg-name) - (let ((pkg (eval `(defpackage ,pkg-name (:use)))) - (sym 'foo)) - (values - (multiple-value-list (import (list sym) pkg)) - (eqlt (find-symbol (symbol-name sym) pkg) sym) - (eqlt (symbol-package sym) (find-package :cl-test)) - (external-symbols-in-package pkg) - ))) - (t) t t nil) - -(deftest import.3 - (let ((pkg-name *import-package-test-name*)) - (safely-delete-package pkg-name) - (let ((*package* (eval `(defpackage ,pkg-name (:use)))) - (sym 'foo)) - (values - (multiple-value-list (import sym)) - (eqlt (find-symbol (symbol-name sym)) sym) - (eqlt (symbol-package sym) (find-package :cl-test)) - (external-symbols-in-package *package*) - ))) - (t) t t nil) - -(deftest import.4 - (let ((pkg-name *import-package-test-name*)) - (safely-delete-package pkg-name) - (let ((pkg (eval `(defpackage ,pkg-name (:use)))) - (syms '(foo bar baz))) - (values - (multiple-value-list (import syms pkg)) - (loop for sym in syms always - (eqlt (find-symbol (symbol-name sym) pkg) sym)) - (loop for sym in syms always - (eqlt (symbol-package sym) (find-package :cl-test))) - (external-symbols-in-package pkg) - ))) - (t) t t nil) - -(deftest import.5 - (let ((pkg-name *import-package-test-name*)) - (safely-delete-package pkg-name) - (let ((pkg (eval `(defpackage ,pkg-name (:use)))) - (sym (make-symbol (symbol-name :foo)))) - (values - (multiple-value-list (import sym pkg)) - (eqlt (symbol-package sym) pkg) - (eqlt (find-symbol (symbol-name sym) pkg) sym) - (external-symbols-in-package pkg) - ))) - (t) t t nil) - -(deftest import.6 - (let ((pkg-name *import-package-test-name*)) - (safely-delete-package pkg-name) - (let* ((pkg (eval `(defpackage ,pkg-name (:use)))) - (sym (intern (symbol-name :foo) pkg))) - (values - (multiple-value-list (import sym pkg)) - (eqlt (symbol-package sym) pkg) - (eqlt (find-symbol (symbol-name sym) pkg) sym) - (external-symbols-in-package pkg) - ))) - (t) t t nil) - -(deftest import.7 - (let ((pkg-name *import-package-test-name*)) - (safely-delete-package pkg-name) - (let* ((pkg (eval `(defpackage ,pkg-name (:use) (:export #:foo)))) - (sym (intern (symbol-name :foo) pkg))) - (values - (multiple-value-list (import sym pkg)) - (eqlt (symbol-package sym) pkg) - (eqlt (find-symbol (symbol-name sym) pkg) sym) - (length (external-symbols-in-package pkg)) - (eqlt (car (external-symbols-in-package pkg)) sym) - ))) - (t) t t 1 t) - -(deftest import.8 - (let ((pkg-name *import-package-test-name*)) - (safely-delete-package pkg-name) - (let ((pkg (eval `(defpackage ,pkg-name (:use)))) - (sym 'foo)) - (values - (multiple-value-list (import sym pkg-name)) - (eqlt (find-symbol (symbol-name sym) pkg) sym) - (eqlt (symbol-package sym) (find-package :cl-test)) - (external-symbols-in-package pkg) - ))) - (t) t t nil) - -(deftest import.9 - (let ((pkg-name "Z")) - (safely-delete-package pkg-name) - (let ((pkg (eval `(defpackage ,pkg-name (:use)))) - (sym 'foo)) - (values - (multiple-value-list (import sym #\Z)) - (eqlt (find-symbol (symbol-name sym) pkg) sym) - (eqlt (symbol-package sym) (find-package :cl-test)) - (external-symbols-in-package pkg) - ))) - (t) t t nil) - -(deftest import.10 - (let ((pkg-name *import-package-test-name*)) - (safely-delete-package pkg-name) - (let ((pkg (eval `(defpackage ,pkg-name (:use)))) - (sym 'foo)) - (values - (let ((pname (make-array (length pkg-name) :element-type 'base-char - :initial-contents pkg-name))) - (multiple-value-list (import sym pname))) - (eqlt (find-symbol (symbol-name sym) pkg) sym) - (eqlt (symbol-package sym) (find-package :cl-test)) - (external-symbols-in-package pkg) - ))) - (t) t t nil) - -(deftest import.11 - (let ((pkg-name *import-package-test-name*)) - (safely-delete-package pkg-name) - (let ((pkg (eval `(defpackage ,pkg-name (:use)))) - (sym 'foo)) - (values - (let ((pname (make-array (+ 3 (length pkg-name)) - :element-type 'base-char - :fill-pointer (length pkg-name) - :initial-contents (concatenate 'string pkg-name "XYZ")))) - (multiple-value-list (import sym pname))) - (eqlt (find-symbol (symbol-name sym) pkg) sym) - (eqlt (symbol-package sym) (find-package :cl-test)) - (external-symbols-in-package pkg) - ))) - (t) t t nil) - -(deftest import.12 - (let ((pkg-name *import-package-test-name*)) - (safely-delete-package pkg-name) - (let ((pkg (eval `(defpackage ,pkg-name (:use)))) - (sym 'foo)) - (values - (let* ((pname0 (make-array (+ 4 (length pkg-name)) - :element-type 'base-char - :fill-pointer (length pkg-name) - :initial-contents (concatenate 'string " " pkg-name "XY"))) - (pname (make-array (length pkg-name) :element-type 'base-char - :displaced-to pname0 - :displaced-index-offset 2))) - (multiple-value-list (import sym pname))) - (eqlt (find-symbol (symbol-name sym) pkg) sym) - (eqlt (symbol-package sym) (find-package :cl-test)) - (external-symbols-in-package pkg) - ))) - (t) t t nil) - - - -;;; Error tests - -(deftest import.error.1 - (signals-error (import) program-error) - t) - -(deftest import.error.2 - (signals-error (import 'nil (find-package :cl-test) nil) program-error) - t) - -(deftest import.error.3 - (signals-error - (let ((pkg-name *import-package-test-name*)) - (safely-delete-package pkg-name) - (let* ((pkg (eval `(defpackage ,pkg-name (:use)))) - (sym 'foo) - (name (symbol-name sym))) - (intern name pkg) - (import sym pkg))) - package-error) - t) - -(deftest import.error.4 - (let ((pkg-name *import-package-test-name*)) - (safely-delete-package pkg-name) - (let* ((pkg (eval `(defpackage ,pkg-name (:use)))) - (sym 'foo) - (name (symbol-name sym)) - (isym (intern name pkg)) - (outer-restarts (compute-restarts))) - (block done - (and - (handler-bind - ((package-error - #'(lambda (c) - ;; There should be at least one restart - ;; associated with this condition that was - ;; not a preexisting restart - (let ((my-restarts - (remove 'abort - (set-difference (compute-restarts c) - outer-restarts) - :key #'restart-name))) - (assert my-restarts) - ; (unintern isym pkg) - ; (when (find 'continue my-restarts :key #'restart-name) (continue c)) - (return-from done :good))))) - (import sym pkg)) - (eqlt (find-symbol name pkg) sym) - (eqlt (symbol-package sym) (find-package "CL-TEST")) - :good)))) - :good) - - -(deftest import.error.5 - (let ((pkg-name *import-package-test-name*)) - (safely-delete-package pkg-name) - (let* ((pkg (eval `(defpackage ,pkg-name (:use)))) - (sym 'foo) - (name (symbol-name sym)) - (isym (shadow name pkg)) ;; shadow instead of intern - (outer-restarts (compute-restarts))) - (block done - (and - (handler-bind - ((package-error - #'(lambda (c) - ;; There should be at least one restart - ;; associated with this condition that was - ;; not a preexisting restart - (let ((my-restarts - (remove 'abort - (set-difference (compute-restarts c) - outer-restarts) - :key #'restart-name))) - (assert my-restarts) - ; (unintern isym pkg) - ; (when (find 'continue my-restarts :key #'restart-name) (continue c)) - (return-from done :good))))) - (import sym pkg)) - (eqlt (find-symbol name pkg) sym) - (eqlt (symbol-package sym) (find-package "CL-TEST")) - :good)))) - :good) diff --git a/t/ansi-test/packages/in-package.lsp b/t/ansi-test/packages/in-package.lsp deleted file mode 100644 index 67b9c46..0000000 --- a/t/ansi-test/packages/in-package.lsp +++ /dev/null @@ -1,106 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 25 08:06:03 1998 -;;;; Contains: Tests of IN-PACKAGE - - -(declaim (optimize (safety 3))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; in-package - -(deftest in-package.1 - (let ((*package* *package*)) - (safely-delete-package "H") - (make-package "H" :use ()) - (let ((p2 (in-package "H"))) - (and (eqt p2 (find-package "H")) - (eqt *package* p2)))) - t) - -(deftest in-package.2 - (let ((*package* *package*)) - (safely-delete-package "H") - (make-package "H" :use ()) - (let ((p2 (in-package |H|))) - (and (eqt p2 (find-package "H")) - (eqt *package* p2)))) - t) - -(deftest in-package.3 - (let ((*package* *package*)) - (safely-delete-package "H") - (make-package "H" :use ()) - (let ((p2 (in-package :|H|))) - (and (eqt p2 (find-package "H")) - (eqt *package* p2)))) - t) - -(deftest in-package.4 - (let ((*package* *package*)) - (safely-delete-package "H") - (make-package "H" :use ()) - (let ((p2 (in-package #\H))) - (and (eqt p2 (find-package "H")) - (eqt *package* p2)))) - t) - -(deftest in-package.5 - (let ((*package* *package*)) - (safely-delete-package "H") - (handler-case - (eval '(in-package "H")) - (package-error () 'package-error) - (error (c) c))) - package-error) - -(def-macro-test in-package.error.1 - (in-package :cl-test)) - -(defmacro def-in-package-test (test-name name-form) - `(deftest ,test-name - (let ((name ,name-form)) - (safely-delete-package name) - (prog1 - (let* ((p (make-package name :use nil)) - (*package* *package*) - (p2 (eval `(in-package ,name)))) - (list (eqt p p2) - (eqt p *package*))) - (safely-delete-package name))) - (t t))) - -(def-in-package-test in-package.7 - (make-array 5 :initial-contents "TEST1" :element-type 'base-char)) - -(def-in-package-test in-package.8 - (make-array 10 :initial-contents "TEST1ABCDE" - :fill-pointer 5 :element-type 'base-char)) - -(def-in-package-test in-package.9 - (make-array 10 :initial-contents "TEST1ABCDE" - :fill-pointer 5 :element-type 'character)) - -(def-in-package-test in-package.10 - (make-array 5 :initial-contents "TEST1" - :adjustable t :element-type 'base-char)) - -(def-in-package-test in-package.11 - (make-array 5 :initial-contents "TEST1" - :adjustable t :element-type 'character)) - -(def-in-package-test in-package.12 - (let* ((etype 'base-char) - (name0 (make-array 10 :element-type etype - :initial-contents "xxxxxTEST1"))) - (make-array 5 :element-type etype - :displaced-to name0 - :displaced-index-offset 5))) - -(def-in-package-test in-package.13 - (let* ((etype 'character) - (name0 (make-array 10 :element-type etype - :initial-contents "xxxxxTEST1"))) - (make-array 5 :element-type etype - :displaced-to name0 - :displaced-index-offset 5))) diff --git a/t/ansi-test/packages/intern.lsp b/t/ansi-test/packages/intern.lsp deleted file mode 100644 index 930307e..0000000 --- a/t/ansi-test/packages/intern.lsp +++ /dev/null @@ -1,178 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 25 07:59:10 1998 -;;;; Contains: Tests of INTERN - - -(declaim (optimize (safety 3))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; intern - -(deftest intern.1 - (progn - (safely-delete-package "TEMP1") - (let ((p (make-package "TEMP1" :use nil)) - (i 0) x y) - (multiple-value-bind* (sym1 status1) - (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)))))) - t) - -(deftest intern.2 - (progn - (safely-delete-package "TEMP1") - (let ((p (make-package "TEMP1" :use nil))) - (multiple-value-bind* (sym1 status1) - (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)))))) - t) - -(deftest intern.3 - :notes (:nil-vectors-are-strings) - (let ((cl-user-package (find-package "CL-USER"))) - (eqt (intern "" cl-user-package) - (intern (make-array 0 :element-type nil) cl-user-package))) - t) - -(deftest intern.4 - (let ((cl-user-package (find-package "CL-USER"))) - (eqt (intern (make-array 5 :element-type 'character - :initial-contents "XYZZY") cl-user-package) - (intern (make-array 5 :element-type 'base-char - :initial-contents "XYZZY") cl-user-package))) - t) - -;;; String is a specialized sequence type - -(defmacro def-intern-test (test-name &key (symbol-name "FOO") - (package-name "TEMP1")) - `(deftest ,test-name - (let ((sname ,symbol-name) - (pname ,package-name)) - (safely-delete-package pname) - (let ((p (make-package pname :use nil))) - (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)))))) - t)) - -(def-intern-test intern.5 - :symbol-name (make-array 3 :element-type 'base-char - :initial-contents "BAR")) - -(def-intern-test intern.6 - :symbol-name (make-array 13 :element-type 'base-char - :fill-pointer 3 - :initial-contents "BAR1234567890")) - -(def-intern-test intern.7 - :symbol-name (make-array 13 :element-type 'character - :fill-pointer 3 - :initial-contents "BAR1234567890")) - -(def-intern-test intern.8 - :symbol-name (make-array 3 :element-type 'base-char - :adjustable t - :initial-contents "BAR")) - -(def-intern-test intern.9 - :symbol-name (make-array 3 :element-type 'character - :adjustable t - :initial-contents "BAR")) - -(def-intern-test intern.10 - :symbol-name - (let* ((etype 'base-char) - (name0 (make-array 8 :element-type etype - :initial-contents "XBARYYYY"))) - (make-array 3 :element-type etype :displaced-to name0 - :displaced-index-offset 1))) - -(def-intern-test intern.11 - :symbol-name - (let* ((etype 'character) - (name0 (make-array 8 :element-type etype - :initial-contents "XBARYYYY"))) - (make-array 3 :element-type etype :displaced-to name0 - :displaced-index-offset 1))) - -(def-intern-test intern.12 - :package-name (make-array 3 :element-type 'base-char - :initial-contents "BAR")) - -(def-intern-test intern.13 - :package-name (make-array 13 :element-type 'base-char - :fill-pointer 3 - :initial-contents "BAR1234567890")) - -(def-intern-test intern.14 - :package-name (make-array 13 :element-type 'character - :fill-pointer 3 - :initial-contents "BAR1234567890")) - -(def-intern-test intern.15 - :package-name (make-array 3 :element-type 'base-char - :adjustable t - :initial-contents "BAR")) - -(def-intern-test intern.16 - :package-name (make-array 3 :element-type 'character - :adjustable t - :initial-contents "BAR")) - -(def-intern-test intern.17 - :package-name - (let* ((etype 'base-char) - (name0 (make-array 8 :element-type etype - :initial-contents "XBARYYYY"))) - (make-array 3 :element-type etype :displaced-to name0 - :displaced-index-offset 1))) - -(def-intern-test intern.18 - :package-name - (let* ((etype 'character) - (name0 (make-array 8 :element-type etype - :initial-contents "XBARYYYY"))) - (make-array 3 :element-type etype :displaced-to name0 - :displaced-index-offset 1))) - -;;; Error tests - -(deftest intern.error.1 - (signals-error (intern) program-error) - t) - -(deftest intern.error.2 - (signals-error (intern "X" "CL" nil) program-error) - t) diff --git a/t/ansi-test/packages/keyword.lsp b/t/ansi-test/packages/keyword.lsp deleted file mode 100644 index 38c503f..0000000 --- a/t/ansi-test/packages/keyword.lsp +++ /dev/null @@ -1,127 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Feb 22 06:53:55 2004 -;;;; Contains: Tests of the KEYWORD package - - - -;; Check that each keyword satisfies keywordp - -(deftest keyword.1 - (do-symbols (s "KEYWORD" t) - (unless (keywordp s) - (return (list s nil)))) - t) - -;; Check that symbols that are interned in the KEYWORD -;; package, but do not have KEYWORD as their home package, -;; are in fact keywords. -;; -;; This came up on the #lisp irc channel - -;;; -;;; The following two tests are improper, since (see the page for SYMBOL) -;;; "The consequences are undefined if an attempt is made to alter the home -;;; package of a symbol external in the COMMON-LISP package or the KEYWORD package." -;;; -;;; They could be rewritten to search for a name that is not interned in KEYWORD. -;;; - -#| -(deftest keyword.4 - (let ((name "SYMBOL-NAME-FOR-KEYWORD.4") - (kwp (find-package "KEYWORD"))) - (let ((s (find-symbol name kwp))) - (when s (unintern s kwp)) - ;; Now, create a symbol with this name - ;; and import it into the keyword package - (setq s (make-symbol name)) - (import s kwp) - ;; Check that it's a keyword - (values - (eqlt (symbol-package s) kwp) - (eqlt (find-symbol name kwp) s) - (nth-value 1 (find-symbol name kwp)) - (notnot (typep s 'keyword)) - (if (boundp s) (eqlt s (symbol-value s)) :not-bound) - (notnot (constantp s))))) - t t :external t t t) - -(deftest keyword.5 - (let* ((name "SYMBOL-NAME-FOR-KEYWORD.5") - (pkg-name "PACKAGE-FOR-KEYWORD.5") - (kwp (find-package "KEYWORD"))) - (safely-delete-package pkg-name) - (let* ((pkg (make-package pkg-name :use nil)) - (s (find-symbol name kwp))) - (when s (unintern s kwp)) - ;; Now, create a symbol with this name - ;; and import it into the keyword package - (setq s (intern name pkg)) - (import s kwp) - ;; Check that it's a keyword - (values - (eqlt (symbol-package s) pkg) - (eqlt (find-symbol name kwp) s) - (nth-value 1 (find-symbol name kwp)) - (notnot (typep s 'keyword)) - (if (boundp s) (eqlt s (symbol-value s)) :not-bound) - (notnot (constantp s))))) - t t :external t t t) - -(deftest keyword.6 - (let* ((name "SYMBOL-NAME-FOR-KEYWORD.6") - (pkg-name "PACKAGE-FOR-KEYWORD.6") - (kwp (find-package "KEYWORD"))) - (safely-delete-package pkg-name) - (let* ((pkg (make-package pkg-name :use nil)) - (s (find-symbol name kwp)) - s2) - (when s (unintern s kwp)) - ;; Recreate a symbol with this name in the keyword package - ;; shadowing-import will displace this symbol - (setq s2 (intern name kwp)) - ;; Now, create a symbol with this name - ;; and shadowing-import it into the keyword package - (setq s (intern name pkg)) - (shadowing-import s kwp) - ;; Check that it's a keyword - (values - (eqt s s2) - (symbol-package s2) - (eqlt (symbol-package s) pkg) - (eqlt (find-symbol name kwp) s) - (nth-value 1 (find-symbol name kwp)) - (notnot (typep s 'keyword)) - (if (boundp s) (eqlt s (symbol-value s)) :not-bound) - (notnot (constantp s))))) - nil nil t t :external t t t) -|# - - -;;; Note that the case of a symbol inherited into KEYWORD cannot arise -;;; standardly from user actions, since USE-PACKAGE disallows KEYWORD -;;; as the package designated by its second argument. - -;; Every keyword is external -(deftest keyword.2 - (do-symbols (s "KEYWORD" t) - (multiple-value-bind (s2 access) - (find-symbol (symbol-name s) "KEYWORD") - (unless (and (eqt s s2) - (eqt access :external)) - (return (list s2 access))))) - t) - -;; Every keyword evaluates to itself -(deftest keyword.3 - (do-symbols (s "KEYWORD" t) - (cond - ((not (boundp s)) - (return (list s "NOT-BOUND"))) - ((not (eqt s (eval s))) - (return (list s (eval s)))))) - t) - - - diff --git a/t/ansi-test/packages/list-all-packages.lsp b/t/ansi-test/packages/list-all-packages.lsp deleted file mode 100644 index 3b9a07a..0000000 --- a/t/ansi-test/packages/list-all-packages.lsp +++ /dev/null @@ -1,48 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Feb 21 17:47:37 2004 -;;;; Contains: Tests of LIST-ALL-PACKAGES - - -(declaim (optimize (safety 3))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; list-all-packages - -;; list-all-packages returns a list -(deftest list-all-packages.1 - (numberp (ignore-errors (list-length (list-all-packages)))) - t) - -;; The required packages are present -(deftest list-all-packages.2 - (progn - (set-up-packages) - (notnot - (subsetp - (list (find-package "CL") - (find-package "CL-USER") - (find-package "KEYWORD") - (find-package "A") - (find-package "REGRESSION-TEST") - (find-package "CL-TEST") - (find-package "B")) - (list-all-packages)))) - t) - -;; The list returned has only packages in it -(deftest list-all-packages.3 - (notnot-mv (every #'packagep (list-all-packages))) - t) - -;; It returns a list of the same packages each time it is called -(deftest list-all-packages.4 - (let ((p1 (list-all-packages)) - (p2 (list-all-packages))) - (and (subsetp p1 p2) - (subsetp p2 p1))) - t) - -(deftest list-all-packages.error.1 - (signals-error (list-all-packages nil) program-error) - t) diff --git a/t/ansi-test/packages/load.lsp b/t/ansi-test/packages/load.lsp deleted file mode 100644 index 9245c97..0000000 --- a/t/ansi-test/packages/load.lsp +++ /dev/null @@ -1,45 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Oct 6 00:32:56 2002 -;;;; Contains: Loader for files containing package tests - -(compile-and-load "ANSI-TESTS:AUX;packages00-aux.lsp") -(compile-and-load "ANSI-TESTS:AUX;package-aux.lsp") - -(in-package #:cl-test) - -(let ((*default-pathname-defaults* - (make-pathname - :directory (pathname-directory *load-pathname*)))) - (load "find-symbol.lsp") - (load "find-all-symbols.lsp") - (load "find-package.lsp") - (load "list-all-packages.lsp") - (load "package-name.lsp") - (load "package-nicknames.lsp") - (load "intern.lsp") - (load "export.lsp") - (load "rename-package.lsp") - (load "shadow.lsp") - (load "shadowing-import.lsp") - (load "delete-package.lsp") - (load "make-package.lsp") - (load "with-package-iterator.lsp") - (load "unexport.lsp") - (load "unintern.lsp") - (load "in-package.lsp") - (load "unuse-package.lsp") - (load "use-package.lsp") - (load "defpackage.lsp") - (load "do-symbols.lsp") - (load "do-external-symbols.lsp") - (load "do-all-symbols.lsp") - (load "packagep.lsp") - (load "package-error.lsp") - (load "package-error-package.lsp") - (load "keyword.lsp") - (load "package-shadowing-symbols.lsp") - (load "package-use-list.lsp") - (load "package-used-by-list.lsp") - (load "import.lsp") -) diff --git a/t/ansi-test/packages/make-package.lsp b/t/ansi-test/packages/make-package.lsp deleted file mode 100644 index da51bda..0000000 --- a/t/ansi-test/packages/make-package.lsp +++ /dev/null @@ -1,513 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 25 08:02:43 1998 -;;;; Contains: Tests of MAKE-PACKAGE - - -(declaim (optimize (safety 3))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; make-package - -;; Test basic make-package, using string, symbol and character -;; package-designators - -(deftest make-package.1 - (progn - (safely-delete-package "TEST1") - (let ((p (ignore-errors (make-package "TEST1")))) - (prog1 - (and (packagep p) - (equalt (package-name p) "TEST1") - (equalt (package-nicknames p) nil) - (equalt (package-used-by-list p) nil)) - (safely-delete-package p)))) - t) - -(deftest make-package.2 - (progn - (safely-delete-package '#:|TEST1|) - (let ((p (ignore-errors (make-package '#:|TEST1|)))) - (prog1 - (and (packagep p) - (equalt (package-name p) "TEST1") - (equalt (package-nicknames p) nil) - (equalt (package-used-by-list p) nil)) - (safely-delete-package p)))) - t) - -(deftest make-package.3 - (progn - (safely-delete-package #\X) - (let ((p (ignore-errors (make-package #\X)))) - (prog1 - (and (packagep p) - (equalt (package-name p) "X") - (equalt (package-nicknames p) nil) - (equalt (package-used-by-list p) nil)) - (safely-delete-package p)))) - t) - -;; Same, but with a null :use list - -(deftest make-package.4 - (progn - (safely-delete-package "TEST1") - (let ((p (ignore-errors (make-package "TEST1" :use nil)))) - (prog1 - (and (packagep p) - (equalt (package-name p) "TEST1") - (equalt (package-nicknames p) nil) - (equalt (package-use-list p) nil) - (equalt (package-used-by-list p) nil)) - (safely-delete-package p)))) - t) - -(deftest make-package.5 - (progn - (safely-delete-package '#:|TEST1|) - (let ((p (ignore-errors (make-package '#:|TEST1| :use nil)))) - (prog1 - (and (packagep p) - (equalt (package-name p) "TEST1") - (equalt (package-nicknames p) nil) - (equalt (package-use-list p) nil) - (equalt (package-used-by-list p) nil)) - (safely-delete-package p)))) - t) - -(deftest make-package.6 - (progn - (safely-delete-package #\X) - (let ((p (make-package #\X))) - (prog1 - (and (packagep p) - (equalt (package-name p) "X") - (equalt (package-nicknames p) nil) - ;; (equalt (package-use-list p) nil) - (equalt (package-used-by-list p) nil)) - (safely-delete-package p)))) - t) - -;; Same, but use the A package - -(deftest make-package.7 - (progn - (set-up-packages) - (safely-delete-package "TEST1") - (let ((p (ignore-errors (make-package "TEST1" :use '("A"))))) - (prog1 - (and (packagep p) - (equalt (package-name p) "TEST1") - (equalt (package-nicknames p) nil) - (equalt (package-use-list p) (list (find-package "A"))) - (equalt (package-used-by-list p) nil)) - (safely-delete-package p)))) - t) - -(deftest make-package.7a - (progn - (set-up-packages) - (safely-delete-package "TEST1") - (let ((p (ignore-errors (make-package "TEST1" :use '(#:|A|))))) - (prog1 - (and (packagep p) - (equalt (package-name p) "TEST1") - (equalt (package-nicknames p) nil) - (equalt (package-use-list p) (list (find-package "A"))) - (equalt (package-used-by-list p) nil)) - (safely-delete-package p)))) - t) - -(deftest make-package.7b - (progn - (set-up-packages) - (safely-delete-package "TEST1") - (let ((p (ignore-errors (make-package "TEST1" :use '(#\A))))) - (prog1 - (and (packagep p) - (equalt (package-name p) "TEST1") - (equalt (package-nicknames p) nil) - (equalt (package-use-list p) (list (find-package "A"))) - (equalt (package-used-by-list p) nil)) - (safely-delete-package p)))) - t) - -(deftest make-package.8 - (progn - (set-up-packages) - (safely-delete-package '#:|TEST1|) - (let ((p (ignore-errors (make-package '#:|TEST1| :use '("A"))))) - (multiple-value-prog1 - (values (notnot (packagep p)) - (equalt (package-name p) "TEST1") - (equalt (package-nicknames p) nil) - (equalt (package-use-list p) (list (find-package "A"))) - (equalt (package-used-by-list p) nil)) - (safely-delete-package p)))) - t t t t t) - -(deftest make-package.8a - (progn - (set-up-packages) - (safely-delete-package '#:|TEST1|) - (let ((p (ignore-errors (make-package '#:|TEST1| :use '(#:|A|))))) - (multiple-value-prog1 - (values (notnot (packagep p)) - (equalt (package-name p) "TEST1") - (equalt (package-nicknames p) nil) - (equalt (package-use-list p) (list (find-package "A"))) - (equalt (package-used-by-list p) nil)) - (safely-delete-package p)))) - t t t t t) - -(deftest make-package.8b - (progn - (set-up-packages) - (safely-delete-package '#:|TEST1|) - (let ((p (ignore-errors (make-package '#:|TEST1| :use '(#\A))))) - (multiple-value-prog1 - (values (packagep p) - (equalt (package-name p) "TEST1") - (equalt (package-nicknames p) nil) - (equalt (package-use-list p) (list (find-package "A"))) - (equalt (package-used-by-list p) nil)) - (safely-delete-package p)))) - t t t t t) - -(deftest make-package.9 - (progn - (set-up-packages) - (safely-delete-package #\X) - (let ((p (ignore-errors (make-package #\X :use '("A"))))) - (multiple-value-prog1 - (values (notnot (packagep p)) - (equalt (package-name p) "X") - (equalt (package-nicknames p) nil) - (equalt (package-use-list p) (list (find-package "A"))) - (equalt (package-used-by-list p) nil)) - (safely-delete-package p)))) - t t t t t) - -(deftest make-package.9a - (progn - (set-up-packages) - (safely-delete-package #\X) - (let ((p (ignore-errors (make-package #\X :use '(#:|A|))))) - (multiple-value-prog1 - (values (notnot (packagep p)) - (equalt (package-name p) "X") - (equalt (package-nicknames p) nil) - (equalt (package-use-list p) (list (find-package "A"))) - (equalt (package-used-by-list p) nil)) - (safely-delete-package p)))) - t t t t t) - -(deftest make-package.9b - (progn - (set-up-packages) - (safely-delete-package #\X) - (let ((p (ignore-errors (make-package #\X :use '(#\A))))) - (multiple-value-prog1 - (values (notnot (packagep p)) - (equalt (package-name p) "X") - (equalt (package-nicknames p) nil) - (equalt (package-use-list p) (list (find-package "A"))) - (equalt (package-used-by-list p) nil)) - (safely-delete-package p)))) - t t t t t) - -;; make-package with nicknames - -(deftest make-package.10 - (progn - (mapc #'safely-delete-package '("TEST1" "F")) - (let ((p (make-package "TEST1" :nicknames '("F")))) - (multiple-value-prog1 - (values (notnot (packagep p)) - (equalt (package-name p) "TEST1") - (equalt (package-nicknames p) '("F")) - (equalt (package-used-by-list p) nil)) - (safely-delete-package p)))) - t t t t) - -(deftest make-package.11 - (progn - (mapc #'safely-delete-package '("TEST1" "G")) - (let ((p (make-package '#:|TEST1| :nicknames '(#:|G|)))) - (multiple-value-prog1 - (values (notnot (packagep p)) - (equalt (package-name p) "TEST1") - (equalt (package-nicknames p) '("G")) - (equalt (package-used-by-list p) nil)) - (safely-delete-package p)))) - t t t t) - -(deftest make-package.12 - (progn - (mapc #'safely-delete-package '("TEST1" "G")) - (let ((p (make-package '#:|TEST1| :nicknames '(#\G)))) - (multiple-value-prog1 - (values (notnot (packagep p)) - (equalt (package-name p) "TEST1") - (equalt (package-nicknames p) '("G")) - (equalt (package-used-by-list p) nil)) - (safely-delete-package p)))) - t t t t) - -(deftest make-package.13 - (progn - (mapc #'safely-delete-package '(#\X #\F #\G #\H)) - (let ((p (make-package #\X :nicknames '("F" #\G #:|H|)))) - (multiple-value-prog1 - (values (notnot (packagep p)) - (equalt (package-name p) "X") - (set-exclusive-or (package-nicknames p) - '("F" "G" "H") - :test #'equal) - (equalt (package-used-by-list p) nil)) - (safely-delete-package p)))) - t t nil t) - -;;; Specialized sequences as designators - -;;; The package name being a specialized sequence - -(defmacro def-make-package-test1 (test-name name-form) - `(deftest ,test-name - (let ((name ,name-form)) - (assert (string= name "TEST1")) - (safely-delete-package "TEST1") - (let ((p (ignore-errors (make-package name)))) - (multiple-value-prog1 - (values (notnot (packagep p)) - (equalt (package-name p) "TEST1") - (equalt (package-nicknames p) nil) - (equalt (package-used-by-list p) nil)) - (safely-delete-package p)))) - t t t t)) - -(def-make-package-test1 make-package.14 - (make-array 5 :initial-contents "TEST1" - :element-type 'base-char)) - -(def-make-package-test1 make-package.15 - (make-array 12 :initial-contents "TEST1xxxyyyz" - :fill-pointer 5 - :element-type 'base-char)) - -(def-make-package-test1 make-package.16 - (make-array 12 :initial-contents "TEST1xxxyyyz" - :fill-pointer 5 - :element-type 'character)) - -(def-make-package-test1 make-package.17 - (make-array 5 :initial-contents "TEST1" - :adjustable t - :element-type 'base-char)) - -(def-make-package-test1 make-package.18 - (make-array 5 :initial-contents "TEST1" - :adjustable t - :element-type 'character)) - -(def-make-package-test1 make-package.19 - (let* ((etype 'base-char) - (name0 (make-array 10 :initial-contents "xxTEST1yyy" - :element-type etype))) - (make-array 5 :element-type etype - :displaced-to name0 - :displaced-index-offset 2))) - -(def-make-package-test1 make-package.20 - (let* ((etype 'character) - (name0 (make-array 10 :initial-contents "xxTEST1yyy" - :element-type etype))) - (make-array 5 :element-type etype - :displaced-to name0 - :displaced-index-offset 2))) - -;;; Nicknames being specialized sequences - -(defmacro def-make-package-test2 (test-name name-form) - `(deftest ,test-name - (let ((name ,name-form) - (nickname "TEST1-NICKNAME")) - (safely-delete-package "TEST1") - (safely-delete-package nickname) - (let ((p (make-package name :nicknames (list nickname)))) - (multiple-value-prog1 - (values (notnot (packagep p)) - (equalt (package-name p) "TEST1") - (equalt (package-nicknames p) (list nickname)) - (equalt (package-used-by-list p) nil)) - (safely-delete-package p)))) - t t t t)) - -(def-make-package-test2 make-package.21 - (make-array 5 :initial-contents "TEST1" - :element-type 'base-char)) - -(def-make-package-test2 make-package.22 - (make-array 12 :initial-contents "TEST1xxxyyyz" - :fill-pointer 5 - :element-type 'base-char)) - -(def-make-package-test2 make-package.23 - (make-array 12 :initial-contents "TEST1xxxyyyz" - :fill-pointer 5 - :element-type 'character)) - -(def-make-package-test2 make-package.24 - (make-array 5 :initial-contents "TEST1" - :adjustable t - :element-type 'base-char)) - -(def-make-package-test2 make-package.25 - (make-array 5 :initial-contents "TEST1" - :adjustable t - :element-type 'character)) - -(def-make-package-test2 make-package.26 - (let* ((etype 'base-char) - (name0 (make-array 10 :initial-contents "xxTEST1yyy" - :element-type etype))) - (make-array 5 :element-type etype - :displaced-to name0 - :displaced-index-offset 2))) - -(def-make-package-test2 make-package.27 - (let* ((etype 'character) - (name0 (make-array 10 :initial-contents "xxTEST1yyy" - :element-type etype))) - (make-array 5 :element-type etype - :displaced-to name0 - :displaced-index-offset 2))) - -;;; USE names being specialized sequences - -(defmacro def-make-package-test3 (test-name name-form) - `(deftest ,test-name - (let ((name ,name-form)) - (set-up-packages) - (safely-delete-package "TEST1") - (assert (find-package name)) - (let ((p (ignore-errors (make-package "TEST1" :use (list name))))) - (multiple-value-prog1 - (values (notnot (packagep p)) - (equalt (package-name p) "TEST1") - (equalt (package-nicknames p) nil) - (equalt (package-use-list p) (list (find-package name))) - (equalt (package-used-by-list p) nil)) - (safely-delete-package p)))) - t t t t t)) - -(def-make-package-test3 make-package.28 - (make-array 1 :initial-contents "A" :element-type 'base-char)) - -(def-make-package-test3 make-package.29 - (make-array 8 :initial-contents "Axxxyyyz" - :fill-pointer 1 - :element-type 'base-char)) - -(def-make-package-test3 make-package.30 - (make-array 8 :initial-contents "Axxxyyyz" - :fill-pointer 1 - :element-type 'character)) - -(def-make-package-test3 make-package.31 - (make-array 1 :initial-contents "A" - :adjustable t - :element-type 'base-char)) - -(def-make-package-test3 make-package.32 - (make-array 1 :initial-contents "A" - :adjustable t - :element-type 'character)) - -(def-make-package-test3 make-package.33 - (let* ((etype 'base-char) - (name0 (make-array 10 :initial-contents "xxAyyy0123" - :element-type etype))) - (make-array 1 :element-type etype - :displaced-to name0 - :displaced-index-offset 2))) - -(def-make-package-test3 make-package.34 - (let* ((etype 'character) - (name0 (make-array 10 :initial-contents "xxAzzzzyyy" - :element-type etype))) - (make-array 1 :element-type etype - :displaced-to name0 - :displaced-index-offset 2))) - -;; Signal a continuable error if the package or any nicknames -;; exist as packages or nicknames of packages - -(deftest make-package.error.1 - (progn - (set-up-packages) - (handle-non-abort-restart (make-package "A"))) - success) - -(deftest make-package.error.2 - (progn - (set-up-packages) - (handle-non-abort-restart (make-package "Q"))) - success) - -(deftest make-package.error.3 - (progn - (set-up-packages) - (handle-non-abort-restart - (safely-delete-package "TEST1") - (make-package "TEST1" :nicknames '("A")))) - success) - -(deftest make-package.error.4 - (handle-non-abort-restart - (safely-delete-package "TEST1") - (set-up-packages) - (make-package "TEST1" :nicknames '("Q"))) - success) - -(deftest make-package.error.5 - (signals-error (make-package) program-error) - t) - -(deftest make-package.error.6 - (progn - (safely-delete-package "MPE6") - (signals-error (make-package "MPE6" :bad t) program-error)) - t) - -(deftest make-package.error.7 - (progn - (safely-delete-package "MPE7") - (signals-error (make-package "MPE7" :nicknames) program-error)) - t) - -(deftest make-package.error.8 - (progn - (safely-delete-package "MPE8") - (signals-error (make-package "MPE8" :use) program-error)) - t) - -(deftest make-package.error.9 - (progn - (safely-delete-package "MPE9") - (signals-error (make-package "MPE9" 'bad t) program-error)) - t) - -(deftest make-package.error.10 - (progn - (safely-delete-package "MPE10") - (signals-error (make-package "MPE10" 1 2) program-error)) - t) - -(deftest make-package.error.11 - (progn - (safely-delete-package "MPE11") - (signals-error (make-package "MPE11" 'bad t :allow-other-keys nil) - program-error)) - t) diff --git a/t/ansi-test/packages/package-error-package.lsp b/t/ansi-test/packages/package-error-package.lsp deleted file mode 100644 index 8c9a1ac..0000000 --- a/t/ansi-test/packages/package-error-package.lsp +++ /dev/null @@ -1,47 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Feb 22 06:52:56 2004 -;;;; Contains: Tests of PACKAGE-ERROR-PACKAGE - - - -(deftest package-error-package.1 - (eqt (find-package (package-error-package - (make-condition 'package-error - :package "CL"))) - (find-package "CL")) - t) - -(deftest package-error-package.2 - (eqt (find-package (package-error-package - (make-condition 'package-error - :package (find-package "CL")))) - (find-package "CL")) - t) - -(deftest package-error-package.3 - (eqt (find-package (package-error-package - (make-condition 'package-error - :package '#:|CL|))) - (find-package "CL")) - t) - -(deftest package-error-package.4 - (eqt (find-package (package-error-package - (make-condition 'package-error - :package #\A))) - (find-package "A")) - t) - -(deftest package-error-package.error.1 - (signals-error (package-error-package) program-error) - t) - -(deftest package-error-package.error.2 - (signals-error - (package-error-package - (make-condition 'package-error :package #\A) - nil) - program-error) - t) - diff --git a/t/ansi-test/packages/package-error.lsp b/t/ansi-test/packages/package-error.lsp deleted file mode 100644 index a364c1b..0000000 --- a/t/ansi-test/packages/package-error.lsp +++ /dev/null @@ -1,31 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Feb 22 06:52:21 2004 -;;;; Contains: Tests of the condition PACKAGE-ERROR - - - -(deftest package-error.1 - (not - (typep (make-condition 'package-error :package "CL") - 'package-error)) - nil) - -(deftest package-error.2 - (not - (typep (make-condition 'package-error - :package (find-package "CL")) - 'package-error)) - nil) - -(deftest package-error.3 - (subtypep* 'package-error 'error) - t t) - -(deftest package-error.4 - (not - (typep (make-condition 'package-error - :package (find-package '#:|CL|)) - 'package-error)) - nil) - diff --git a/t/ansi-test/packages/package-name.lsp b/t/ansi-test/packages/package-name.lsp deleted file mode 100644 index fd486e3..0000000 --- a/t/ansi-test/packages/package-name.lsp +++ /dev/null @@ -1,180 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Feb 21 17:48:05 2004 -;;;; Contains: Tests of PACKAGE-NAME - - -(declaim (optimize (safety 3))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; package-name - -(deftest package-name.1 - (progn - (set-up-packages) - (package-name "A")) - "A") - -(deftest package-name.2 - (progn - (set-up-packages) - (package-name #\A)) - "A") - -(deftest package-name.3 - (progn - (set-up-packages) - (package-name "Q")) - "A") - -(deftest package-name.4 - (progn - (set-up-packages) - (package-name #\Q)) - "A") - -(deftest package-name.5 - (handler-case - (locally (declare (optimize safety)) - (eval '(package-name "NOT-THERE")) - nil) - (type-error () t) - (package-error () t)) - t) - -(deftest package-name.6 - (handler-case - (locally (declare (optimize safety)) - (eval '(package-name #\*)) - nil) - (type-error () t) - (package-error () t)) - t) - -(deftest package-name.6a - (handler-case - (locally (declare (optimize safety)) - (eval '(locally (package-name #\*) t)) - nil) - (type-error () t) - (package-error () t)) - t) - -(deftest package-name.7 - (package-name "CL") - #.(string '#:common-lisp)) - -(deftest package-name.8 - (package-name "COMMON-LISP") - #.(string '#:common-lisp)) - -(deftest package-name.9 - (package-name "COMMON-LISP-USER") - #.(string '#:common-lisp-user)) - -(deftest package-name.10 - (package-name "CL-USER") - #.(string '#:common-lisp-user)) - -(deftest package-name.11 - (package-name "KEYWORD") - #.(string '#:keyword)) - -(deftest package-name.12 - (package-name (find-package "CL")) - #.(string '#:common-lisp)) - -(deftest package-name.13 - (let* ((p (make-package "TEMP1")) - (pname1 (package-name p))) - (rename-package "TEMP1" "TEMP2") - (let ((pname2 (package-name p))) - (safely-delete-package p) - (list pname1 pname2 (package-name p)))) - ("TEMP1" "TEMP2" nil)) - -;; (find-package (package-name p)) == p for any package p -(deftest package-name.14 - (loop - for p in (list-all-packages) count - (not - (let ((name (package-name p))) - (and (stringp name) - (eqt (find-package name) p))))) - 0) - -;; package-name applied to a package's name -;; should return an equal string -(deftest package-name.15 - (loop - for p in (list-all-packages) count - (not (equal (package-name p) - (package-name (package-name p))))) - 0) - -;;; Specialized sequence tests - -(defmacro def-package-name-test (test-name name-form expected-name-form) - `(deftest ,test-name - (let ((name ,name-form) - (expected-name ,expected-name-form)) - (assert (string= name expected-name)) - (safely-delete-package name) - (let ((p (make-package name :use nil))) - (equalt (package-name p) expected-name))) - t)) - -(def-package-name-test package-name.16 - (make-array 5 :element-type 'base-char :initial-contents "TEST1") - "TEST1") - -(def-package-name-test package-name.17 - (make-array 10 :element-type 'base-char - :fill-pointer 5 - :initial-contents "TEST1?????") - "TEST1") - -(def-package-name-test package-name.18 - (make-array 10 :element-type 'character - :fill-pointer 5 - :initial-contents "TEST1?????") - "TEST1") - -(def-package-name-test package-name.19 - (make-array 5 :element-type 'base-char :adjustable t - :initial-contents "TEST1") - "TEST1") - -(def-package-name-test package-name.20 - (make-array 5 :element-type 'character :adjustable t - :initial-contents "TEST1") - "TEST1") - -(def-package-name-test package-name.21 - (let* ((etype 'base-char) - (name0 (make-array 10 :element-type etype - :initial-contents "XXTEST1XXX"))) - (make-array 5 :element-type etype :displaced-to name0 - :displaced-index-offset 2)) - "TEST1") - -(def-package-name-test package-name.22 - (let* ((etype 'character) - (name0 (make-array 10 :element-type etype - :initial-contents "XXTEST1XXX"))) - (make-array 5 :element-type etype :displaced-to name0 - :displaced-index-offset 2)) - "TEST1") - - -(deftest package-name.error.1 - (signals-error (package-name) program-error) - t) - -(deftest package-name.error.2 - (signals-error (package-name "CL" nil) program-error) - t) - -(deftest package-name.error.3 - (check-type-error #'package-name #'package-designator-p) - nil) diff --git a/t/ansi-test/packages/package-nicknames.lsp b/t/ansi-test/packages/package-nicknames.lsp deleted file mode 100644 index f951162..0000000 --- a/t/ansi-test/packages/package-nicknames.lsp +++ /dev/null @@ -1,154 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 25 07:51:26 1998 -;;;; Contains: Tests of PACKAGE-NICKNAMES - - -(declaim (optimize (safety 3))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; package-nicknames - -(deftest package-nicknames.1 - (progn - (set-up-packages) - (package-nicknames "A")) - ("Q")) - -(deftest package-nicknames.2 - (progn - (set-up-packages) - (package-nicknames #\A)) - ("Q")) - -(deftest package-nicknames.3 - (progn - (set-up-packages) - (package-nicknames ':|A|)) - ("Q")) - -(deftest package-nicknames.4 - (progn - (set-up-packages) - (package-nicknames "B")) - nil) - -(deftest package-nicknames.5 - (progn - (set-up-packages) - (package-nicknames #\B)) - nil) - -(deftest package-nicknames.6 - (progn - (set-up-packages) - (package-nicknames '#:|B|)) - nil) - -(deftest package-nicknames.7 - (subsetp '(#.(string '#:cl)) - (package-nicknames "COMMON-LISP") - :test #'string=) - t) - -(deftest package-nicknames.8 - (notnot - (subsetp '(#.(string '#:cl-user)) - (package-nicknames "COMMON-LISP-USER") - :test #'string=)) - t) - -(deftest package-nicknames.9 - (signals-error (package-nicknames 10) type-error) - t) - -(deftest package-nicknames.9a - (signals-error (locally (package-nicknames 10) t) type-error) - t) - -(deftest package-nicknames.10 - (progn - (set-up-packages) - (package-nicknames (find-package "A"))) - ("Q")) - -(deftest package-nicknames.11 - (handler-case - (locally (declare (optimize safety)) - (eval '(package-nicknames "NOT-A-PACKAGE-NAME")) - nil) - (type-error () t) - (package-error () t)) - t) - -;; (find-package n) == p for each n in (package-nicknames p), -;; for any package p -(deftest package-nicknames.12 - (loop - for p in (list-all-packages) sum - (loop - for nk in (package-nicknames p) count - (not - (and (stringp nk) - (eqt p (find-package nk)))))) - 0) - -;;; Specialized sequence names tests - -(defmacro def-package-nicknames-test (test-name name-form) - `(deftest ,test-name - (let ((name ,name-form)) - (safely-delete-package name) - (let ((p (make-package name :use nil))) - (package-nicknames p))) - nil)) - -(def-package-nicknames-test package-nicknames.16 - (make-array 5 :element-type 'base-char :initial-contents "TEST1")) - -(def-package-nicknames-test package-nicknames.17 - (make-array 10 :element-type 'base-char - :fill-pointer 5 - :initial-contents "TEST1?????")) - -(def-package-nicknames-test package-nicknames.18 - (make-array 10 :element-type 'character - :fill-pointer 5 - :initial-contents "TEST1?????")) - -(def-package-nicknames-test package-nicknames.19 - (make-array 5 :element-type 'base-char :adjustable t - :initial-contents "TEST1")) - -(def-package-nicknames-test package-nicknames.20 - (make-array 5 :element-type 'character :adjustable t - :initial-contents "TEST1")) - -(def-package-nicknames-test package-nicknames.21 - (let* ((etype 'base-char) - (name0 (make-array 10 :element-type etype - :initial-contents "XXTEST1XXX"))) - (make-array 5 :element-type etype :displaced-to name0 - :displaced-index-offset 2))) - -(def-package-nicknames-test package-nicknames.22 - (let* ((etype 'character) - (name0 (make-array 10 :element-type etype - :initial-contents "XXTEST1XXX"))) - (make-array 5 :element-type etype :displaced-to name0 - :displaced-index-offset 2))) - -;;; Error tests - -(deftest package-nicknames.error.1 - (signals-error (package-nicknames) program-error) - t) - -(deftest package-nicknames.error.2 - (signals-error (package-nicknames "CL" nil) program-error) - t) - -(deftest package-nicknames.error.3 - (check-type-error #'package-nicknames #'package-designator-p) - nil) - diff --git a/t/ansi-test/packages/package-shadowing-symbols.lsp b/t/ansi-test/packages/package-shadowing-symbols.lsp deleted file mode 100644 index df62396..0000000 --- a/t/ansi-test/packages/package-shadowing-symbols.lsp +++ /dev/null @@ -1,64 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Feb 22 06:55:17 2004 -;;;; Contains: Tests of PACKAGE-SHADOWING-SYMBOLS - - - -;;; Most tests of this function are in files for other package-related operators - -;;; Specialized sequence tests - -(defmacro def-package-shadowing-symbols-test (test-name name-form) - `(deftest ,test-name - (let ((name ,name-form)) - (safely-delete-package name) - (let ((p (make-package name :use nil))) - (package-shadowing-symbols p))) - nil)) - -(def-package-shadowing-symbols-test package-shadowing-symbols.1 - (make-array 5 :element-type 'base-char :initial-contents "TEST1")) - -(def-package-shadowing-symbols-test package-shadowing-symbols.2 - (make-array 10 :element-type 'base-char - :fill-pointer 5 - :initial-contents "TEST1?????")) - -(def-package-shadowing-symbols-test package-shadowing-symbols.3 - (make-array 10 :element-type 'character - :fill-pointer 5 - :initial-contents "TEST1?????")) - -(def-package-shadowing-symbols-test package-shadowing-symbols.4 - (make-array 5 :element-type 'base-char :adjustable t - :initial-contents "TEST1")) - -(def-package-shadowing-symbols-test package-shadowing-symbols.5 - (make-array 5 :element-type 'character :adjustable t - :initial-contents "TEST1")) - -(def-package-shadowing-symbols-test package-shadowing-symbols.6 - (let* ((etype 'base-char) - (name0 (make-array 10 :element-type etype - :initial-contents "XXTEST1XXX"))) - (make-array 5 :element-type etype :displaced-to name0 - :displaced-index-offset 2))) - -(def-package-shadowing-symbols-test package-shadowing-symbols.7 - (let* ((etype 'character) - (name0 (make-array 10 :element-type etype - :initial-contents "XXTEST1XXX"))) - (make-array 5 :element-type etype :displaced-to name0 - :displaced-index-offset 2))) - -;;; Error tests - -(deftest package-shadowing-symbols.error.1 - (signals-error (package-shadowing-symbols) program-error) - t) - -(deftest package-shadowing-symbols.error.2 - (signals-error (package-shadowing-symbols "CL" nil) program-error) - t) - diff --git a/t/ansi-test/packages/package-use-list.lsp b/t/ansi-test/packages/package-use-list.lsp deleted file mode 100644 index e77f92f..0000000 --- a/t/ansi-test/packages/package-use-list.lsp +++ /dev/null @@ -1,63 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Feb 22 06:55:56 2004 -;;;; Contains: Tests of PACKAGE-USE-LIST - - - -;;; Most tests of this function are in files for other package-related operators - -;;; Specialized sequence tests - -(defmacro def-package-use-list-test (test-name name-form) - `(deftest ,test-name - (let ((name ,name-form)) - (safely-delete-package name) - (let ((p (make-package name :use nil))) - (package-use-list p))) - nil)) - -(def-package-use-list-test package-use-list.1 - (make-array 5 :element-type 'base-char :initial-contents "TEST1")) - -(def-package-use-list-test package-use-list.2 - (make-array 10 :element-type 'base-char - :fill-pointer 5 - :initial-contents "TEST1?????")) - -(def-package-use-list-test package-use-list.3 - (make-array 10 :element-type 'character - :fill-pointer 5 - :initial-contents "TEST1?????")) - -(def-package-use-list-test package-use-list.4 - (make-array 5 :element-type 'base-char :adjustable t - :initial-contents "TEST1")) - -(def-package-use-list-test package-use-list.5 - (make-array 5 :element-type 'character :adjustable t - :initial-contents "TEST1")) - -(def-package-use-list-test package-use-list.6 - (let* ((etype 'base-char) - (name0 (make-array 10 :element-type etype - :initial-contents "XXTEST1XXX"))) - (make-array 5 :element-type etype :displaced-to name0 - :displaced-index-offset 2))) - -(def-package-use-list-test package-use-list.7 - (let* ((etype 'character) - (name0 (make-array 10 :element-type etype - :initial-contents "XXTEST1XXX"))) - (make-array 5 :element-type etype :displaced-to name0 - :displaced-index-offset 2))) - -;;; Error tests - -(deftest package-use-list.error.1 - (signals-error (package-use-list) program-error) - t) - -(deftest package-use-list.error.2 - (signals-error (package-use-list "CL" nil) program-error) - t) diff --git a/t/ansi-test/packages/package-used-by-list.lsp b/t/ansi-test/packages/package-used-by-list.lsp deleted file mode 100644 index 26f27b1..0000000 --- a/t/ansi-test/packages/package-used-by-list.lsp +++ /dev/null @@ -1,64 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Feb 22 06:56:28 2004 -;;;; Contains: Tests of PACKAGE-USED-BY-LIST - - - -;;; Most tests of this function are in files for other package-related operators - -;;; Specialized sequence tests - -(defmacro def-package-used-by-list-test (test-name name-form) - `(deftest ,test-name - (let ((name ,name-form)) - (safely-delete-package name) - (let ((p (make-package name :use nil))) - (package-used-by-list p))) - nil)) - -(def-package-used-by-list-test package-used-by-list.1 - (make-array 5 :element-type 'base-char :initial-contents "TEST1")) - -(def-package-used-by-list-test package-used-by-list.2 - (make-array 10 :element-type 'base-char - :fill-pointer 5 - :initial-contents "TEST1?????")) - -(def-package-used-by-list-test package-used-by-list.3 - (make-array 10 :element-type 'character - :fill-pointer 5 - :initial-contents "TEST1?????")) - -(def-package-used-by-list-test package-used-by-list.4 - (make-array 5 :element-type 'base-char :adjustable t - :initial-contents "TEST1")) - -(def-package-used-by-list-test package-used-by-list.5 - (make-array 5 :element-type 'character :adjustable t - :initial-contents "TEST1")) - -(def-package-used-by-list-test package-used-by-list.6 - (let* ((etype 'base-char) - (name0 (make-array 10 :element-type etype - :initial-contents "XXTEST1XXX"))) - (make-array 5 :element-type etype :displaced-to name0 - :displaced-index-offset 2))) - -(def-package-used-by-list-test package-used-by-list.7 - (let* ((etype 'character) - (name0 (make-array 10 :element-type etype - :initial-contents "XXTEST1XXX"))) - (make-array 5 :element-type etype :displaced-to name0 - :displaced-index-offset 2))) - -;;; Error tests - -(deftest package-used-by-list.error.1 - (signals-error (package-used-by-list) program-error) - t) - -(deftest package-used-by-list.error.2 - (signals-error (package-used-by-list "CL" nil) program-error) - t) - diff --git a/t/ansi-test/packages/packagep.lsp b/t/ansi-test/packages/packagep.lsp deleted file mode 100644 index 7fa6487..0000000 --- a/t/ansi-test/packages/packagep.lsp +++ /dev/null @@ -1,24 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Feb 22 06:51:38 2004 -;;;; Contains: Tests of PACKAGEP - - - -(deftest packagep.1 - (check-type-predicate #'packagep 'package) - nil) - -;;; *package* is always a package - -(deftest packagep.2 - (not-mv (packagep *package*)) - nil) - -(deftest packagep.error.1 - (signals-error (packagep) program-error) - t) - -(deftest packagep.error.2 - (signals-error (packagep nil nil) program-error) - t) diff --git a/t/ansi-test/packages/rename-package.lsp b/t/ansi-test/packages/rename-package.lsp deleted file mode 100644 index 982e86d..0000000 --- a/t/ansi-test/packages/rename-package.lsp +++ /dev/null @@ -1,248 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 25 08:00:28 1998 -;;;; Contains: Tests of RENAME-PACKAGE - - -(declaim (optimize (safety 3))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; rename-package - -(deftest rename-package.1 - (block nil - (safely-delete-package "TEST1") - (safely-delete-package "TEST2") - (let ((p (make-package "TEST1")) - (i 0) x y) - (unless (packagep p) (return nil)) - (let ((p2 (rename-package (progn (setf x (incf i)) "TEST1") - (progn (setf y (incf i)) "TEST2")))) - (unless (packagep p2) - (safely-delete-package p) - (return p2)) - (unless (and (eqt p p2) - (eql i 2) - (eql x 1) - (eql y 2) - (equal (package-name p2) "TEST2")) - (safely-delete-package p) - (safely-delete-package p2) - (return nil)) - (safely-delete-package p2) - t))) - t) - -(deftest rename-package.2 - (block nil - (safely-delete-package "TEST1") - (safely-delete-package "TEST2") - (safely-delete-package "TEST3") - (safely-delete-package "TEST4") - (safely-delete-package "TEST5") - (let ((p (make-package "TEST1")) - (nicknames (copy-list '("TEST3" "TEST4" "TEST5")))) - (unless (packagep p) (return nil)) - (let ((p2 (rename-package "TEST1" "TEST2" nicknames))) - (unless (packagep p2) - (safely-delete-package p) - (return p2)) - (unless (and (eqt p p2) - (equal (package-name p2) "TEST2") - (null (set-exclusive-or nicknames - (package-nicknames p2) - :test #'equal))) - (safely-delete-package p) - (safely-delete-package p2) - (return nil)) - (safely-delete-package p2) - t))) - t) - -(deftest rename-package.3 - (block nil - (safely-delete-package "TEST1") - (safely-delete-package "TEST2") - (let ((p (make-package "TEST1")) - (nicknames (copy-list '(#\M #\N)))) - (unless (packagep p) (return nil)) - (let ((p2 (ignore-errors (rename-package "TEST1" "TEST2" nicknames)))) - (unless (packagep p2) - (safely-delete-package p) - (return p2)) - (unless (and (eqt p p2) - (equal (package-name p2) "TEST2") - (equal - (sort (copy-list (package-nicknames p2)) - #'string<) - (sort (mapcar #'(lambda (c) - (make-string 1 :initial-element c)) - nicknames) - #'string<))) - (safely-delete-package p) - (safely-delete-package p2) - (return nil)) - (safely-delete-package p2) - t))) - t) - -(deftest rename-package.4 - (block nil - (safely-delete-package "G") - (safely-delete-package "TEST2") - (let ((p (make-package "G")) - (nicknames nil)) - (unless (packagep p) (return nil)) - (let ((p2 (ignore-errors (rename-package #\G "TEST2" nicknames)))) - (unless (packagep p2) - (safely-delete-package p) - (return p2)) - (unless (and (eqt p p2) - (equal (package-name p2) "TEST2") - (null (set-exclusive-or nicknames - (package-nicknames p2) - :test #'equal))) - (safely-delete-package p) - (safely-delete-package p2) - (return nil)) - (ignore-errors (safely-delete-package p2)) - t))) - t) - -(deftest rename-package.5 - (block nil - (safely-delete-package "TEST1") - (safely-delete-package "G") - (let ((p (make-package "TEST1")) - (nicknames nil)) - (unless (packagep p) (return nil)) - (let ((p2 (ignore-errors (rename-package "TEST1" #\G nicknames)))) - (unless (packagep p2) - (safely-delete-package p) - (return p2)) - (unless (and (eqt p p2) - (equal (package-name p2) "G") - (null (set-exclusive-or nicknames - (package-nicknames p2) - :test #'equal))) - (safely-delete-package p) - (safely-delete-package p2) - (return nil)) - (safely-delete-package p2) - t))) - t) - -(deftest rename-package.6 - (block nil - (safely-delete-package '|TEST1|) - (safely-delete-package '|TEST2|) - (safely-delete-package '|M|) - (safely-delete-package '|N|) - (let ((p (make-package '|TEST1|)) - (nicknames (copy-list '(|M| |N|)))) - (unless (packagep p) (return nil)) - (let ((p2 (ignore-errors (rename-package - '|TEST1| '|TEST2| nicknames)))) - (unless (packagep p2) - (safely-delete-package p) - (return p2)) - (unless (and (eqt p p2) - (equal (package-name p2) "TEST2") - (equal - (sort (copy-list (package-nicknames p2)) - #'string<) - (sort (mapcar #'symbol-name nicknames) - #'string<))) - (safely-delete-package p) - (safely-delete-package p2) - (return nil)) - (safely-delete-package p2) - t))) - t) - -(deftest rename-package.7 - (block nil - (let ((name1 (make-array '(5) :element-type 'base-char - :initial-contents "TEST1")) - (name2 (make-array '(5) :element-type 'base-char - :initial-contents "TEST2"))) - (safely-delete-package name1) - (safely-delete-package name2) - (let ((p (make-package name1))) - (unless (packagep p) (return nil)) - (let ((p2 (rename-package name1 name2))) - (unless (packagep p2) - (safely-delete-package p) - (return p2)) - (unless (and (eqt p p2) - (equal (package-name p2) name2)) - (safely-delete-package p) - (safely-delete-package p2) - (return nil)) - (safely-delete-package p2) - t)))) - t) - -(deftest rename-package.8 - (block nil - (let ((name1 (make-array '(10) :element-type 'base-char - :fill-pointer 5 - :initial-contents "TEST1 ")) - (name2 (make-array '(9) :element-type 'character - :fill-pointer 5 - :initial-contents "TEST2XXXX"))) - (safely-delete-package name1) - (safely-delete-package name2) - (let ((p (make-package "TEST1"))) - (unless (packagep p) (return nil)) - (let ((p2 (rename-package name1 name2))) - (unless (packagep p2) - (safely-delete-package p) - (return p2)) - (unless (and (eqt p p2) - (string= (package-name p2) "TEST2")) - (safely-delete-package p) - (safely-delete-package p2) - (return nil)) - (safely-delete-package p2) - t)))) - t) - -(deftest rename-package.9 - (block nil - (let ((name1 (make-array '(5) :element-type 'character - :adjustable t - :initial-contents "TEST1")) - (name2 (make-array '(5) :element-type 'base-char - :adjustable t - :initial-contents "TEST2"))) - (safely-delete-package name1) - (safely-delete-package name2) - (let ((p (make-package "TEST1"))) - (unless (packagep p) (return nil)) - (let ((p2 (rename-package name1 name2))) - (unless (packagep p2) - (safely-delete-package p) - (return p2)) - (unless (and (eqt p p2) - (string= (package-name p2) "TEST2")) - (safely-delete-package p) - (safely-delete-package p2) - (return nil)) - (safely-delete-package p2) - t)))) - t) - - - -(deftest rename-package.error.1 - (signals-error (rename-package) program-error) - t) - -(deftest rename-package.error.2 - (signals-error (rename-package "CL") program-error) - t) - -(deftest rename-package.error.3 - (signals-error (rename-package "A" "XXXXX" NIL NIL) program-error) - t) diff --git a/t/ansi-test/packages/shadow.lsp b/t/ansi-test/packages/shadow.lsp deleted file mode 100644 index 6392b93..0000000 --- a/t/ansi-test/packages/shadow.lsp +++ /dev/null @@ -1,298 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 25 08:01:20 1998 -;;;; Contains: Tests of SHADOW - - -(declaim (optimize (safety 3))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; shadow - -(deftest shadow.1 - (prog1 - (progn - (safely-delete-package "TEST5") - (safely-delete-package "TEST4") - (handler-case - (let* ((p1 (prog1 - (make-package "TEST4" :use nil) - (export (intern "A" "TEST4") "TEST4"))) - (p2 (make-package "TEST5" :use '("TEST4"))) - (r1 (package-shadowing-symbols "TEST4")) - (r2 (package-shadowing-symbols "TEST5"))) - (multiple-value-bind* (s1 kind1) - (find-symbol "A" p1) - (multiple-value-bind* (s2 kind2) - (find-symbol "A" p2) - (let ((r3 (shadow "A" p2))) - (multiple-value-bind* (s3 kind3) - (find-symbol "A" p2) - (list - (package-name p1) - (package-name p2) - r1 r2 - (symbol-name s1) - (package-name (symbol-package s1)) - kind1 - (symbol-name s2) - (package-name (symbol-package s2)) - kind2 - r3 - (symbol-name s3) - (package-name (symbol-package s3)) - kind3)))))) - (error (c) c))) - (safely-delete-package "TEST5") - (safely-delete-package "TEST4")) - ("TEST4" "TEST5" nil nil "A" "TEST4" :external - "A" "TEST4" :inherited - t - "A" "TEST5" :internal)) - -(deftest shadow.2 - (progn - (safely-delete-package "H") - (safely-delete-package "G") - (handler-case - (let* ((p1 (prog1 - (make-package "G" :use nil) - (export (intern "A" "G") "G"))) - (p2 (make-package "H" :use '("G"))) - (r1 (package-shadowing-symbols "G")) - (r2 (package-shadowing-symbols "H"))) - (multiple-value-bind* (s1 kind1) - (find-symbol "A" p1) - (multiple-value-bind* (s2 kind2) - (find-symbol "A" p2) - (let ((r3 (shadow "A" "H"))) - (multiple-value-bind* (s3 kind3) - (find-symbol "A" p2) - (prog1 - (list (package-name p1) (package-name p2) - r1 r2 (symbol-name s1) (package-name (symbol-package s1)) - kind1 (symbol-name s2) (package-name (symbol-package s2)) - kind2 r3 (symbol-name s3) (package-name (symbol-package s3)) - kind3) - (safely-delete-package p2) - (safely-delete-package p1) - )))))) - (error (c) - (safely-delete-package "H") - (safely-delete-package "G") - c))) - ("G" "H" nil nil "A" "G" :external - "A" "G" :inherited - t - "A" "H" :internal)) - -;; shadow in which the package is given -;; by a character -(deftest shadow.3 - (progn - (safely-delete-package "H") - (safely-delete-package "G") - (handler-case - (let* ((p1 (prog1 - (make-package "G" :use nil) - (export (intern "A" "G") "G"))) - (p2 (make-package "H" :use '("G"))) - (r1 (package-shadowing-symbols "G")) - (r2 (package-shadowing-symbols "H"))) - (multiple-value-bind* (s1 kind1) - (find-symbol "A" p1) - (multiple-value-bind* (s2 kind2) - (find-symbol "A" p2) - (let ((r3 (shadow "A" #\H))) - (multiple-value-bind* (s3 kind3) - (find-symbol "A" p2) - (prog1 - (list (package-name p1) (package-name p2) - r1 r2 (symbol-name s1) (package-name (symbol-package s1)) - kind1 (symbol-name s2) (package-name (symbol-package s2)) - kind2 r3 (symbol-name s3) (package-name (symbol-package s3)) - kind3) - (safely-delete-package p2) - (safely-delete-package p1) - )))))) - (error (c) - (safely-delete-package "H") - (safely-delete-package "G") - c))) - ("G" "H" nil nil "A" "G" :external - "A" "G" :inherited - t - "A" "H" :internal)) - - -;; shadow on an existing internal symbol returns the existing symbol -(deftest shadow.4 - (prog1 - (handler-case - (progn - (safely-delete-package :G) - (make-package :G :use nil) - (let ((s1 (intern "X" :G))) - (shadow "X" :G) - (multiple-value-bind* (s2 kind) - (find-symbol "X" :G) - (list (eqt s1 s2) - (symbol-name s2) - (package-name (symbol-package s2)) - kind)))) - (error (c) c)) - (safely-delete-package "G")) - (t "X" "G" :internal)) - - -;; shadow of an existing shadowed symbol returns the symbol -(deftest shadow.5 - (prog1 - (handler-case - (progn - (safely-delete-package :H) - (safely-delete-package :G) - (make-package :G :use nil) - (export (intern "X" :G) :G) - (make-package :H :use '("G")) - (shadow "X" :H) - (multiple-value-bind* (s1 kind1) - (find-symbol "X" :H) - (shadow "X" :H) - (multiple-value-bind* (s2 kind2) - (find-symbol "X" :H) - (list (eqt s1 s2) kind1 kind2)))) - (error (c) c)) - (safely-delete-package :H) - (safely-delete-package :G)) - (t :internal :internal)) - -;; Shadow several names simultaneously - -(deftest shadow.6 - (prog1 - (handler-case - (progn - (safely-delete-package :G) - (make-package :G :use nil) - (shadow '("X" "Y" |Z|) :G) - (let ((results - (append (multiple-value-list - (find-symbol "X" :G)) - (multiple-value-list - (find-symbol "Y" :G)) - (multiple-value-list - (find-symbol "Z" :G)) - nil))) - (list - (symbol-name (first results)) - (second results) - (symbol-name (third results)) - (fourth results) - (symbol-name (fifth results)) - (sixth results) - (length (package-shadowing-symbols :G))))) - (error (c) c)) - (safely-delete-package :G)) - ("X" :internal "Y" :internal "Z" :internal 3)) - -;; Same, but shadow character string designators -(deftest shadow.7 - (prog1 - (handler-case - (let ((i 0) x y) - (safely-delete-package :G) - (make-package :G :use nil) - (shadow (progn (setf x (incf i)) '(#\X #\Y)) - (progn (setf y (incf i)) :G)) - (let ((results - (append (multiple-value-list - (find-symbol "X" :G)) - (multiple-value-list - (find-symbol "Y" :G)) - nil))) - (list - i x y - (symbol-name (first results)) - (second results) - (symbol-name (third results)) - (fourth results) - (length (package-shadowing-symbols :G))))) - (error (c) c)) - (safely-delete-package :G)) - (2 1 2 "X" :internal "Y" :internal 2)) - -;;; Specialized string tests - -(deftest shadow.8 - (prog1 - (handler-case - (progn - (safely-delete-package :G) - (make-package :G :use nil) - (let* ((name (make-array '(1) :initial-contents "X" - :element-type 'base-char)) - (s1 (intern name :G))) - (shadow name :G) - (multiple-value-bind* (s2 kind) - (find-symbol "X" :G) - (list (eqt s1 s2) - (symbol-name s2) - (package-name (symbol-package s2)) - kind)))) - (error (c) c)) - (safely-delete-package "G")) - (t "X" "G" :internal)) - -(deftest shadow.9 - (prog1 - (handler-case - (progn - (safely-delete-package :G) - (make-package :G :use nil) - (let* ((name (make-array '(3) :initial-contents "XYZ" - :fill-pointer 1 - :element-type 'character)) - (s1 (intern name :G))) - (shadow name :G) - (multiple-value-bind* (s2 kind) - (find-symbol "X" :G) - (list (eqt s1 s2) - (symbol-name s2) - (package-name (symbol-package s2)) - kind)))) - (error (c) c)) - (safely-delete-package "G")) - (t "X" "G" :internal)) - -(deftest shadow.10 - (prog1 - (handler-case - (progn - (safely-delete-package :G) - (make-package :G :use nil) - (let* ((name (make-array '(1) :initial-contents "X" - :adjustable t - :element-type 'base-char)) - (s1 (intern name :G))) - (shadow name :G) - (multiple-value-bind* (s2 kind) - (find-symbol "X" :G) - (list (eqt s1 s2) - (symbol-name s2) - (package-name (symbol-package s2)) - kind)))) - (error (c) c)) - (safely-delete-package "G")) - (t "X" "G" :internal)) - - - - -(deftest shadow.error.1 - (signals-error (shadow) program-error) - t) - -(deftest shadow.error.2 - (signals-error (shadow "X" "CL-USER" nil) program-error) - t) diff --git a/t/ansi-test/packages/shadowing-import.lsp b/t/ansi-test/packages/shadowing-import.lsp deleted file mode 100644 index 4e10d4e..0000000 --- a/t/ansi-test/packages/shadowing-import.lsp +++ /dev/null @@ -1,157 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Aug 29 07:42:18 2004 -;;;; Contains: Tests for SHADOWING-IMPORT - - - -(deftest shadowing-import.1 - (let ((name1 "TEST1") - (name2 "TEST2")) - (safely-delete-package name1) - (safely-delete-package name2) - (prog1 - (let* ((p1 (make-package name1 :use nil)) - (p2 (make-package name2)) - (s1 (intern "X" p1)) - (s2 (intern "X" p2))) - (list - (eqt s1 s2) - (eqt (find-symbol "X" p2) s2) - (shadowing-import s1 p2) - (equalt (package-shadowing-symbols p2) (list s1)) - (eqt (find-symbol "X" p2) s1))) - (safely-delete-package name1) - (safely-delete-package name2))) - (nil t t t t)) - -(deftest shadowing-import.2 - (let ((name1 "TEST1") - (name2 "TEST2")) - (safely-delete-package name1) - (safely-delete-package name2) - (prog1 - (let* ((p1 (make-package name1 :use nil)) - (p2 (make-package name2)) - (s1 (intern "X" p1))) - (list - (find-symbol "X" p2) - (shadowing-import s1 p2) - (equalt (package-shadowing-symbols p2) (list s1)) - (eqt (find-symbol "X" p2) s1))) - (safely-delete-package name1) - (safely-delete-package name2))) - (nil t t t)) - -(deftest shadowing-import.3 - (let ((name1 "TEST1") - (name2 "TEST2")) - (safely-delete-package name1) - (safely-delete-package name2) - (prog1 - (let* ((p1 (make-package name1 :use nil)) - (p2 (make-package name2 :use nil)) - (s1 (intern "X" p1)) - (s2 (intern "X" p2))) - (list - (eqt s1 s2) - (eqt (find-symbol "X" p2) s2) - (let ((*package* p2)) - (shadowing-import s1)) - (equalt (package-shadowing-symbols p2) (list s1)) - (eqt (find-symbol "X" p2) s1))) - (safely-delete-package name1) - (safely-delete-package name2))) - (nil t t t t)) - -(deftest shadowing-import.4 - (let ((name1 "TEST1") - (name2 "TEST2") - (name3 "TEST3")) - (safely-delete-package name1) - (safely-delete-package name2) - (safely-delete-package name3) - (prog1 - (let* ((p1 (make-package name1 :use nil)) - (p3 (make-package name2 :use nil)) - (p2 (make-package name3 :use (list p3))) - (s1 (intern "X" p1)) - (s2 (intern "X" p3))) - (export s2 p3) - (list - (eqt s1 s2) - (eqt (find-symbol "X" p2) s2) - (shadowing-import s1 p2) - (equalt (package-shadowing-symbols p2) (list s1)) - (eqt (find-symbol "X" p2) s1))) - (safely-delete-package name1) - (safely-delete-package name3) - (safely-delete-package name2))) - (nil t t t t)) - -;;; Specialized sequence tests - -(defmacro def-shadowing-import-test (test-name name-form) - `(deftest ,test-name - (let ((name1 ,name-form)) - (safely-delete-package name1) - (prog1 - (let* ((p1 (make-package name1 :use nil))) - (list - (find-symbol "T" p1) - (shadowing-import t name1) - (package-shadowing-symbols p1) - (find-symbol "T" p1))) - (safely-delete-package name1))) - (nil t (t) t))) - -(def-shadowing-import-test shadowing-import.5 - (make-array '(5) :initial-contents "TEST1" - :element-type 'base-char)) - -(def-shadowing-import-test shadowing-import.6 - (make-array '(7) :initial-contents "TEST1XX" - :fill-pointer 7 - :element-type 'character)) - -(def-shadowing-import-test shadowing-import.7 - (make-array '(7) :initial-contents "TEST1XX" - :fill-pointer 7 - :element-type 'base-char)) - -(def-shadowing-import-test shadowing-import.8 - (make-array '(5) :initial-contents "TEST1" - :adjustable t - :element-type 'base-char)) - -(def-shadowing-import-test shadowing-import.9 - (make-array '(5) :initial-contents "TEST1" - :adjustable t - :element-type 'character)) - -(def-shadowing-import-test shadowing-import.10 - (let* ((etype 'character) - (name2 (make-array '(10) :initial-contents "ABTEST1CDE" - :element-type etype))) - (make-array '(5) :element-type etype - :displaced-to name2 - :displaced-index-offset 2))) - -(def-shadowing-import-test shadowing-import.11 - (let* ((etype 'base-char) - (name2 (make-array '(10) :initial-contents "ABTEST1CDE" - :element-type etype))) - (make-array '(5) :element-type etype - :displaced-to name2 - :displaced-index-offset 2))) - -;;; Error tests - -(deftest shadowing-import.error.1 - (signals-error (shadowing-import) program-error) - t) - -(deftest shadowing-import.error.2 - (signals-error (shadowing-import nil *package* nil) - program-error) - t) diff --git a/t/ansi-test/packages/unexport.lsp b/t/ansi-test/packages/unexport.lsp deleted file mode 100644 index 4b74089..0000000 --- a/t/ansi-test/packages/unexport.lsp +++ /dev/null @@ -1,203 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 25 08:04:19 1998 -;;;; Contains: Tests of UNEXPORT - - -(declaim (optimize (safety 3))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; unexport - -(deftest unexport.1 - (progn - (safely-delete-package "X") - (let* ((p (make-package "X" :use nil)) - (r (export (intern "X" p) p)) - (i 0) x y) - (multiple-value-bind* - (sym1 access1) - (find-symbol "X" p) - (unexport (progn (setf x (incf i)) sym1) - (progn (setf y (incf i)) p)) - (multiple-value-bind* - (sym2 access2) - (find-symbol "X" p) - (and (eqt r t) - (eql i 2) (eql x 1) (eql y 2) - (eqt sym1 sym2) - (eqt access1 :external) - (eqt access2 :internal) - (equal (symbol-name sym1) "X") - t))))) - t) - -(deftest unexport.2 - (progn - (safely-delete-package "X") - (let* ((p (make-package "X" :use nil)) - (r (export (intern "X" p) p))) - (multiple-value-bind* - (sym1 access1) - (find-symbol "X" p) - (unexport (list sym1) "X") - (multiple-value-bind* - (sym2 access2) - (find-symbol "X" p) - (and (eqt sym1 sym2) - (eqt r t) - (eqt access1 :external) - (eqt access2 :internal) - (equal (symbol-name sym1) "X") - t))))) - t) - -(deftest unexport.3 - (progn - (safely-delete-package "X") - (let* ((p (make-package "X" :use nil)) - (r1 (export (intern "X" p) p)) - (r2 (export (intern "Y" p) p))) - (multiple-value-bind* - (sym1 access1) - (find-symbol "X" p) - (multiple-value-bind* - (sym1a access1a) - (find-symbol "Y" p) - (unexport (list sym1 sym1a) '#:|X|) - (multiple-value-bind* - (sym2 access2) - (find-symbol "X" p) - (multiple-value-bind* - (sym2a access2a) - (find-symbol "Y" p) - (and (eqt sym1 sym2) - (eqt sym1a sym2a) - (eqt r1 t) - (eqt r2 t) - (eqt access1 :external) - (eqt access2 :internal) - (eqt access1a :external) - (eqt access2a :internal) - (equal (symbol-name sym1) "X") - (equal (symbol-name sym1a) "Y") - t))))))) - t) - -(deftest unexport.4 - (progn - (safely-delete-package "X") - (let* ((p (make-package "X" :use nil)) - (r (export (intern "X" p) p))) - (multiple-value-bind* - (sym1 access1) - (find-symbol "X" p) - (unexport (list sym1) #\X) - (multiple-value-bind* - (sym2 access2) - (find-symbol "X" p) - (and (eqt sym1 sym2) - (eqt r t) - (eqt access1 :external) - (eqt access2 :internal) - (equal (symbol-name sym1) "X") - t))))) - t) - -;; Check that it signals a package error when unexporting -;; an inaccessible symbol - -(deftest unexport.5 - (signals-error - (progn - (when (find-package "X") (delete-package "X")) - (unexport 'a (make-package "X" :use nil)) - nil) - package-error) - t) - -;; Check that internal symbols are left alone - -(deftest unexport.6 - (progn - (when (find-package "X") (delete-package "X")) - (let ((p (make-package "X" :use nil))) - (let* ((sym (intern "FOO" p)) - (r (unexport sym p))) - (multiple-value-bind* - (sym2 access) - (find-symbol "FOO" p) - (and (eqt r t) - (eqt access :internal) - (eqt sym sym2) - (equal (symbol-name sym) "FOO") - t))))) - t) - -;;; Specialized sequence tests - -(defmacro def-unexport-test (test-name name-form) - `(deftest ,test-name - (let ((name ,name-form)) - (safely-delete-package name) - (let* ((p (make-package name :use nil)) - (r (export (intern "X" p) p))) - (multiple-value-bind* - (sym1 access1) - (find-symbol "X" p) - (unexport (list sym1) name) - (multiple-value-bind* - (sym2 access2) - (find-symbol "X" p) - (and (eqt sym1 sym2) - (eqt r t) - (eqt access1 :external) - (eqt access2 :internal) - (equal (symbol-name sym1) "X") - t))))) - t)) - -(def-unexport-test unexport.7 - (make-array 5 :initial-contents "TEST1" :element-type 'base-char)) - -(def-unexport-test unexport.8 - (make-array 10 :initial-contents "TEST1ABCDE" - :fill-pointer 5 :element-type 'base-char)) - -(def-unexport-test unexport.9 - (make-array 10 :initial-contents "TEST1ABCDE" - :fill-pointer 5 :element-type 'character)) - -(def-unexport-test unexport.10 - (make-array 5 :initial-contents "TEST1" - :adjustable t :element-type 'base-char)) - -(def-unexport-test unexport.11 - (make-array 5 :initial-contents "TEST1" - :adjustable t :element-type 'character)) - -(def-unexport-test unexport.12 - (let* ((etype 'base-char) - (name0 (make-array 10 :element-type etype - :initial-contents "xxxxxTEST1"))) - (make-array 5 :element-type etype - :displaced-to name0 - :displaced-index-offset 5))) - -(def-unexport-test unexport.13 - (let* ((etype 'character) - (name0 (make-array 10 :element-type etype - :initial-contents "xxxxxTEST1"))) - (make-array 5 :element-type etype - :displaced-to name0 - :displaced-index-offset 5))) - -;;; Error tests - -(deftest unexport.error.1 - (signals-error (unexport) program-error) - t) - -(deftest unexport.error.2 - (signals-error (unexport 'xyz "CL-TEST" nil) program-error) - t) diff --git a/t/ansi-test/packages/unintern.lsp b/t/ansi-test/packages/unintern.lsp deleted file mode 100644 index 7dd37c2..0000000 --- a/t/ansi-test/packages/unintern.lsp +++ /dev/null @@ -1,301 +0,0 @@ -();-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 25 08:04:56 1998 -;;;; Contains: Tests of UNINTERN - - -(declaim (optimize (safety 3))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; unintern - -;; Simple unintern of an internal symbol, package explicitly -;; given as a package object -(deftest unintern.1 - (progn - (safely-delete-package "H") - (prog1 - (let ((p (make-package "H" :use nil)) - (i 0) x y) - (intern "FOO" p) - (multiple-value-bind* - (sym access) - (find-symbol "FOO" p) - (and - (eqt access :internal) - (unintern (progn (setf x (incf i)) sym) - (progn (setf y (incf i)) p)) - (eql i 2) (eql x 1) (eql y 2) - (null (symbol-package sym)) - (not (find-symbol "FOO" p))))) - (safely-delete-package "H"))) - t) - -;; Simple unintern, package taken from the *PACKAGES* -;; special variable (should this have unwind protect?) -(deftest unintern.2 - (progn - (safely-delete-package "H") - (prog1 - (let ((*PACKAGE* (make-package "H" :use nil))) - (intern "FOO") - (multiple-value-bind* (sym access) - (find-symbol "FOO") - (and - (eqt access :internal) - (unintern sym) - (null (symbol-package sym)) - (not (find-symbol "FOO"))))) - (safely-delete-package "H"))) - t) - -;; Simple unintern, package given as string -(deftest unintern.3 - (progn - (safely-delete-package "H") - (prog1 - (let ((p (make-package "H" :use nil))) - (intern "FOO" p) - (multiple-value-bind* (sym access) - (find-symbol "FOO" p) - (and - (eqt access :internal) - (unintern sym "H") - (null (symbol-package sym)) - (not (find-symbol "FOO" p))))) - (safely-delete-package "H"))) - t) - -;; Simple unintern, package given as symbol -(deftest unintern.4 - (progn - (safely-delete-package "H") - (prog1 - (let ((p (make-package "H" :use nil))) - (intern "FOO" p) - (multiple-value-bind* (sym access) - (find-symbol "FOO" p) - (and - (eqt access :internal) - (unintern sym '#:|H|) - (null (symbol-package sym)) - (not (find-symbol "FOO" p))))) - (safely-delete-package "H"))) - t) - -;; Simple unintern, package given as character -(deftest unintern.5 - (handler-case - (progn - (safely-delete-package "H") - (prog1 - (let ((p (make-package "H" :use nil))) - (intern "FOO" p) - (multiple-value-bind* (sym access) - (find-symbol "FOO" p) - (and - (eqt access :internal) - (unintern sym #\H) - (null (symbol-package sym)) - (not (find-symbol "FOO" p))))) - (safely-delete-package "H"))) - (error (c) c)) - t) - - -;; Test more complex examples of unintern - -;; Unintern an external symbol that is also inherited - -(deftest unintern.6 - (handler-case - (progn - (safely-delete-package "H") - (safely-delete-package "G") - (make-package "G" :use nil) - (export (intern "FOO" "G") "G") - (make-package "H" :use '("G")) - (export (intern "FOO" "H") "H") - ;; At this point, G:FOO is also an external - ;; symbol of H. - (multiple-value-bind* (sym1 access1) - (find-symbol "FOO" "H") - (and sym1 - (eqt access1 :external) - (equal "FOO" (symbol-name sym1)) - (eqt (find-package "G") - (symbol-package sym1)) - (unintern sym1 "H") - (multiple-value-bind* (sym2 access2) - (find-symbol "FOO" "H") - (and (eqt sym1 sym2) - (eqt (symbol-package sym1) - (find-package "G")) - (eqt access2 :inherited)))))) - (error (c) c)) - t) - -;; unintern a symbol that is shadowing another symbol - -(deftest unintern.7 - (block failed - (safely-delete-package "H") - (safely-delete-package "G") - (let* ((pg (make-package "G" :use nil)) - (ph (make-package "H" :use (list pg)))) - (handler-case - (shadow "FOO" ph) - (error (c) (return-from failed (list :shadow-error c)))) - (export (intern "FOO" pg) pg) - ;; At this point, H::FOO shadows G:FOO - (multiple-value-bind* (sym1 access1) - (find-symbol "FOO" ph) - (and - sym1 - (eqt (symbol-package sym1) ph) - (eqt access1 :internal) - (equal (list sym1) (package-shadowing-symbols ph)) - (unintern sym1 ph) - (multiple-value-bind* (sym2 access2) - (find-symbol "FOO" ph) - (and (not (eqt sym1 sym2)) - (eqt access2 :inherited) - (null (symbol-package sym1)) - (eqt (symbol-package sym2) pg))))))) - t) - -;; Error situation: when the symbol is uninterned, creates -;; a name conflict from two used packages -(deftest unintern.8 - (block failed - (safely-delete-package "H") - (safely-delete-package "G1") - (safely-delete-package "G2") - (let* ((pg1 (make-package "G1" :use nil)) - (pg2 (make-package "G2" :use nil)) - (ph (make-package "H" :use (list pg1 pg2)))) - (handler-case - (shadow "FOO" ph) - (error (c) (return-from failed (list :shadow-error c)))) - (let ((gsym1 (intern "FOO" pg1)) - (gsym2 (intern "FOO" pg2))) - (export gsym1 pg1) - (export gsym2 pg2) - (multiple-value-bind* (sym1 access1) - (find-symbol "FOO" ph) - (and - (equal (list sym1) (package-shadowing-symbols ph)) - (not (eqt sym1 gsym1)) - (not (eqt sym1 gsym2)) - (eqt (symbol-package sym1) ph) - (eqt access1 :internal) - (equal (symbol-name sym1) "FOO") - (handler-case - (progn - (unintern sym1 ph) - nil) - (error (c) - (format t "Properly threw an error: ~S~%" c) - t))))))) - t) - -;; Now, inherit the same symbol through two intermediate -;; packages. No error should occur when the shadowing -;; is removed -(deftest unintern.9 - (block failed - (safely-delete-package "H") - (safely-delete-package "G1") - (safely-delete-package "G2") - (safely-delete-package "G3") - (let* ((pg3 (make-package "G3" :use nil)) - (pg1 (make-package "G1" :use (list pg3))) - (pg2 (make-package "G2" :use (list pg3))) - (ph (make-package "H" :use (list pg1 pg2)))) - (handler-case - (shadow "FOO" ph) - (error (c) (return-from failed (list :shadow-error c)))) - (let ((gsym (intern "FOO" pg3))) - (export gsym pg3) - (export gsym pg1) - (export gsym pg2) - (multiple-value-bind* (sym access) - (find-symbol "FOO" ph) - (and - (equal (list sym) (package-shadowing-symbols ph)) - (not (eqt sym gsym)) - (equal (symbol-name sym) "FOO") - (equal (symbol-package sym) ph) - (eqt access :internal) - (handler-case - (and (unintern sym ph) - (multiple-value-bind* (sym2 access2) - (find-symbol "FOO" ph) - (and (eqt gsym sym2) - (eqt access2 :inherited)))) - (error (c) c))))))) - t) - -;;; Specialized sequence tests - -(defmacro def-unintern-test (test-name name-form) - `(deftest ,test-name - (let ((name ,name-form)) - (safely-delete-package name) - (prog1 - (let ((p (make-package name :use nil))) - (intern "FOO" p) - (multiple-value-bind* - (sym access) - (find-symbol "FOO" p) - (and - (eqt access :internal) - (unintern sym name) - (null (symbol-package sym)) - (not (find-symbol "FOO" p))))) - (safely-delete-package name))) - t)) - -(def-unintern-test unintern.10 - (make-array 5 :initial-contents "TEST1" :element-type 'base-char)) - -(def-unintern-test unintern.11 - (make-array 10 :initial-contents "TEST1ABCDE" - :fill-pointer 5 :element-type 'base-char)) - -(def-unintern-test unintern.12 - (make-array 10 :initial-contents "TEST1ABCDE" - :fill-pointer 5 :element-type 'character)) - -(def-unintern-test unintern.13 - (make-array 5 :initial-contents "TEST1" - :adjustable t :element-type 'base-char)) - -(def-unintern-test unintern.14 - (make-array 5 :initial-contents "TEST1" - :adjustable t :element-type 'character)) - -(def-unintern-test unintern.15 - (let* ((etype 'base-char) - (name0 (make-array 10 :element-type etype - :initial-contents "xxxxxTEST1"))) - (make-array 5 :element-type etype - :displaced-to name0 - :displaced-index-offset 5))) - -(def-unintern-test unintern.16 - (let* ((etype 'character) - (name0 (make-array 10 :element-type etype - :initial-contents "xxxxxTEST1"))) - (make-array 5 :element-type etype - :displaced-to name0 - :displaced-index-offset 5))) - - -(deftest unintern.error.1 - (signals-error (unintern) program-error) - t) - -(deftest unintern.error.2 - (signals-error (unintern '#:x "CL-TEST" nil) program-error) - t) diff --git a/t/ansi-test/packages/unuse-package.lsp b/t/ansi-test/packages/unuse-package.lsp deleted file mode 100644 index 3c4c2fd..0000000 --- a/t/ansi-test/packages/unuse-package.lsp +++ /dev/null @@ -1,304 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 25 08:06:48 1998 -;;;; Contains: Tests of UNUSE-PACKAGE - - - - - -(declaim (optimize (safety 3))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; unuse-package - -(deftest unuse-package.1 - (progn - (safely-delete-package "H") - (safely-delete-package "G") - (let* ((pg (make-package "G" :use nil)) - (ph (make-package "H" :use '("G"))) - (i 0) x y) - (prog1 - (and - (equal (package-use-list ph) (list pg)) - (equal (package-used-by-list pg) (list ph)) - (unuse-package (progn (setf x (incf i)) pg) - (progn (setf y (incf i)) ph)) - (eql i 2) (eql x 1) (eql y 2) - (equal (package-use-list ph) nil) - (null (package-used-by-list pg))) - (safely-delete-package "H") - (safely-delete-package "G")))) - t) - -(deftest unuse-package.2 - (progn - (safely-delete-package "H") - (safely-delete-package "G") - (let* ((pg (make-package "G" :use nil)) - (ph (make-package "H" :use '("G")))) - (prog1 - (and - (equal (package-use-list ph) (list pg)) - (equal (package-used-by-list pg) (list ph)) - (unuse-package "G" ph) - (equal (package-use-list ph) nil) - (null (package-used-by-list pg))) - (safely-delete-package "H") - (safely-delete-package "G")))) - t) - -(deftest unuse-package.3 - (progn - (safely-delete-package "H") - (safely-delete-package "G") - (let* ((pg (make-package "G" :use nil)) - (ph (make-package "H" :use '("G")))) - (prog1 - (and - (equal (package-use-list ph) (list pg)) - (equal (package-used-by-list pg) (list ph)) - (unuse-package :|G| ph) - (equal (package-use-list ph) nil) - (null (package-used-by-list pg))) - (safely-delete-package "H") - (safely-delete-package "G")))) - t) - -(deftest unuse-package.4 - (progn - (safely-delete-package "H") - (safely-delete-package "G") - (let* ((pg (make-package "G" :use nil)) - (ph (make-package "H" :use '("G")))) - (prog1 - (and - (equal (package-use-list ph) (list pg)) - (equal (package-used-by-list pg) (list ph)) - (ignore-errors (unuse-package #\G ph)) - (equal (package-use-list ph) nil) - (null (package-used-by-list pg))) - (safely-delete-package "H") - (safely-delete-package "G")))) - t) - -(deftest unuse-package.5 - (progn - (safely-delete-package "H") - (safely-delete-package "G") - (let* ((pg (make-package "G" :use nil)) - (ph (make-package "H" :use '("G")))) - (prog1 - (and - (equal (package-use-list ph) (list pg)) - (equal (package-used-by-list pg) (list ph)) - (unuse-package (list pg) ph) - (equal (package-use-list ph) nil) - (null (package-used-by-list pg))) - (safely-delete-package "H") - (safely-delete-package "G")))) - t) - -(deftest unuse-package.6 - (progn - (safely-delete-package "H") - (safely-delete-package "G") - (let* ((pg (make-package "G" :use nil)) - (ph (make-package "H" :use '("G")))) - (prog1 - (and - (equal (package-use-list ph) (list pg)) - (equal (package-used-by-list pg) (list ph)) - (unuse-package (list "G") ph) - (equal (package-use-list ph) nil) - (null (package-used-by-list pg))) - (safely-delete-package "H") - (safely-delete-package "G")))) - t) - -(deftest unuse-package.7 - (progn - (safely-delete-package "H") - (safely-delete-package "G") - (let* ((pg (make-package "G" :use nil)) - (ph (make-package "H" :use '("G")))) - (prog1 - (and - (equal (package-use-list ph) (list pg)) - (equal (package-used-by-list pg) (list ph)) - (unuse-package (list :|G|) ph) - (equal (package-use-list ph) nil) - (null (package-used-by-list pg))) - (safely-delete-package "H") - (safely-delete-package "G")))) - t) - -(deftest unuse-package.8 - (progn - (safely-delete-package "H") - (safely-delete-package "G") - (let* ((pg (make-package "G" :use nil)) - (ph (make-package "H" :use '("G")))) - (prog1 - (and - (equal (package-use-list ph) (list pg)) - (equal (package-used-by-list pg) (list ph)) - (ignore-errors (unuse-package (list #\G) ph)) - (equal (package-use-list ph) nil) - (null (package-used-by-list pg))) - (safely-delete-package "H") - (safely-delete-package "G")))) - t) - -;; Now test with multiple packages - -(deftest unuse-package.9 - (progn - (dolist (p '("H1" "H2" "G1" "G2" "G3")) - (safely-delete-package p)) - (let* ((pg1 (make-package "G1" :use nil)) - (pg2 (make-package "G2" :use nil)) - (pg3 (make-package "G3" :use nil)) - (ph1 (make-package "H1" :use (list pg1 pg2 pg3))) - (ph2 (make-package "H2" :use (list pg1 pg2 pg3)))) - (let ((pubg1 (sort-package-list (package-used-by-list pg1))) - (pubg2 (sort-package-list (package-used-by-list pg2))) - (pubg3 (sort-package-list (package-used-by-list pg3))) - (puh1 (sort-package-list (package-use-list ph1))) - (puh2 (sort-package-list (package-use-list ph2)))) - (prog1 - (and - (= (length (remove-duplicates (list pg1 pg2 pg3 ph1 ph2))) - 5) - (equal (list ph1 ph2) pubg1) - (equal (list ph1 ph2) pubg2) - (equal (list ph1 ph2) pubg3) - (equal (list pg1 pg2 pg3) puh1) - (equal (list pg1 pg2 pg3) puh2) - (unuse-package (list pg1 pg3) ph1) - (equal (package-use-list ph1) (list pg2)) - (equal (package-used-by-list pg1) (list ph2)) - (equal (package-used-by-list pg3) (list ph2)) - (equal (sort-package-list (package-use-list ph2)) - (list pg1 pg2 pg3)) - (equal (sort-package-list (package-used-by-list pg2)) - (list ph1 ph2)) - t) - (dolist (p '("H1" "H2" "G1" "G2" "G3")) - (safely-delete-package p)))))) - t) - -;;; Specialized sequences - -(defmacro def-unuse-package-test (test-name &key - (user "H") - (used "G")) - `(deftest ,test-name - (let ((user-name ,user) - (used-name ,used)) - (safely-delete-package user-name) - (safely-delete-package used-name) - (let* ((pused (make-package used-name :use nil)) - (puser (make-package user-name :use (list used-name)))) - (prog1 - (and - (equal (package-use-list puser) (list pused)) - (equal (package-used-by-list pused) (list puser)) - (unuse-package (list used-name) user-name) - (equal (package-use-list puser) nil) - (null (package-used-by-list pused))) - (safely-delete-package user-name) - (safely-delete-package used-name)))) - t)) - -;;; Specialized user package designator - -(def-unuse-package-test unuse-package.10 - :user (make-array 5 :initial-contents "TEST1" :element-type 'base-char)) - -(def-unuse-package-test unuse-package.11 - :user (make-array 10 :initial-contents "TEST1ABCDE" - :fill-pointer 5 :element-type 'base-char)) - -(def-unuse-package-test unuse-package.12 - :user (make-array 10 :initial-contents "TEST1ABCDE" - :fill-pointer 5 :element-type 'character)) - -(def-unuse-package-test unuse-package.13 - :user (make-array 5 :initial-contents "TEST1" - :adjustable t :element-type 'base-char)) - -(def-unuse-package-test unuse-package.14 - :user (make-array 5 :initial-contents "TEST1" - :adjustable t :element-type 'character)) - -(def-unuse-package-test unuse-package.15 - :user (let* ((etype 'base-char) - (name0 (make-array 10 :element-type etype - :initial-contents "xxxxxTEST1"))) - (make-array 5 :element-type etype - :displaced-to name0 - :displaced-index-offset 5))) - -(def-unuse-package-test unuse-package.16 - :user - (let* ((etype 'character) - (name0 (make-array 10 :element-type etype - :initial-contents "xxxxxTEST1"))) - (make-array 5 :element-type etype - :displaced-to name0 - :displaced-index-offset 5))) - -;;; Specialed used package designator - -(def-unuse-package-test unuse-package.17 - :used (make-array 5 :initial-contents "TEST1" :element-type 'base-char)) - -(def-unuse-package-test unuse-package.18 - :used (make-array 10 :initial-contents "TEST1ABCDE" - :fill-pointer 5 :element-type 'base-char)) - -(def-unuse-package-test unuse-package.19 - :used (make-array 10 :initial-contents "TEST1ABCDE" - :fill-pointer 5 :element-type 'character)) - -(def-unuse-package-test unuse-package.20 - :used (make-array 5 :initial-contents "TEST1" - :adjustable t :element-type 'base-char)) - -(def-unuse-package-test unuse-package.21 - :used (make-array 5 :initial-contents "TEST1" - :adjustable t :element-type 'character)) - -(def-unuse-package-test unuse-package.22 - :used (let* ((etype 'base-char) - (name0 (make-array 10 :element-type etype - :initial-contents "xxxxxTEST1"))) - (make-array 5 :element-type etype - :displaced-to name0 - :displaced-index-offset 5))) - -(def-unuse-package-test unuse-package.23 - :used - (let* ((etype 'character) - (name0 (make-array 10 :element-type etype - :initial-contents "xxxxxTEST1"))) - (make-array 5 :element-type etype - :displaced-to name0 - :displaced-index-offset 5))) - -;;; Error tests - -(deftest unuse-package.error.1 - (signals-error (unuse-package) program-error) - t) - -(deftest unuse-package.error.2 - (progn - (safely-delete-package "UPE2A") - (safely-delete-package "UPE2") - (make-package "UPE2" :use ()) - (make-package "UPE2A" :use '("UPE2")) - (signals-error (unuse-package "UPE2" "UPE2A" nil) program-error)) - t) diff --git a/t/ansi-test/packages/use-package.lsp b/t/ansi-test/packages/use-package.lsp deleted file mode 100644 index 95be739..0000000 --- a/t/ansi-test/packages/use-package.lsp +++ /dev/null @@ -1,348 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 25 08:08:41 1998 -;;;; Contains: Tests of USE-PACKAGE - - - - - -(declaim (optimize (safety 3))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; use-package - -(deftest use-package.1 - (progn - (safely-delete-package "H") - (safely-delete-package "G") - (let* ((pg (make-package "G" :use nil)) - (ph (make-package "H" :use nil)) - (sym1 (intern "FOO" pg)) - (i 0) x y) - (and - (eqt (export sym1 pg) t) - (null (package-used-by-list pg)) - (null (package-used-by-list ph)) - (null (package-use-list pg)) - (null (package-use-list ph)) - (eqt (use-package (progn (setf x (incf i)) pg) - (progn (setf y (incf i)) ph)) - t) ;; "H" will use "G" - (eql i 2) (eql x 1) (eql y 2) - (multiple-value-bind (sym2 access) - (find-symbol "FOO" ph) - (and - (eqt access :inherited) - (eqt sym1 sym2))) - (equal (package-use-list ph) (list pg)) - (equal (package-used-by-list pg) (list ph)) - (null (package-use-list pg)) - (null (package-used-by-list ph)) - (eqt (unuse-package pg ph) t) - (null (find-symbol "FOO" ph))))) - t) - -(deftest use-package.2 - (progn - (safely-delete-package "H") - (safely-delete-package "G") - (let* ((pg (make-package "G" :use nil)) - (ph (make-package "H" :use nil)) - (sym1 (intern "FOO" pg))) - (and - (eqt (export sym1 pg) t) - (null (package-used-by-list pg)) - (null (package-used-by-list ph)) - (null (package-use-list pg)) - (null (package-use-list ph)) - (eqt (use-package "G" "H") t) ;; "H" will use "G" - (multiple-value-bind (sym2 access) - (find-symbol "FOO" ph) - (and - (eqt access :inherited) - (eqt sym1 sym2))) - (equal (package-use-list ph) (list pg)) - (equal (package-used-by-list pg) (list ph)) - (null (package-use-list pg)) - (null (package-used-by-list ph)) - (eqt (unuse-package pg ph) t) - (null (find-symbol "FOO" ph))))) - t) - -(deftest use-package.3 - (progn - (safely-delete-package "H") - (safely-delete-package "G") - (let* ((pg (make-package "G" :use nil)) - (ph (make-package "H" :use nil)) - (sym1 (intern "FOO" pg))) - (and - (eqt (export sym1 pg) t) - (null (package-used-by-list pg)) - (null (package-used-by-list ph)) - (null (package-use-list pg)) - (null (package-use-list ph)) - (eqt (use-package '#:|G| '#:|H|) t) ;; "H" will use "G" - (multiple-value-bind (sym2 access) - (find-symbol "FOO" ph) - (and - (eqt access :inherited) - (eqt sym1 sym2))) - (equal (package-use-list ph) (list pg)) - (equal (package-used-by-list pg) (list ph)) - (null (package-use-list pg)) - (null (package-used-by-list ph)) - (eqt (unuse-package pg ph) t) - (null (find-symbol "FOO" ph))))) - t) - -(deftest use-package.4 - (progn - (safely-delete-package "H") - (safely-delete-package "G") - (let* ((pg (make-package "G" :use nil)) - (ph (make-package "H" :use nil)) - (sym1 (intern "FOO" pg))) - (and - (eqt (export sym1 pg) t) - (null (package-used-by-list pg)) - (null (package-used-by-list ph)) - (null (package-use-list pg)) - (null (package-use-list ph)) - (eqt (ignore-errors (use-package #\G #\H)) - t) ;; "H" will use "G" - (multiple-value-bind (sym2 access) - (find-symbol "FOO" ph) - (and - (eqt access :inherited) - (eqt sym1 sym2))) - (equal (package-use-list ph) (list pg)) - (equal (package-used-by-list pg) (list ph)) - (null (package-use-list pg)) - (null (package-used-by-list ph)) - (eqt (unuse-package pg ph) t) - (null (find-symbol "FOO" ph))))) - t) - -;; use lists of packages - -(deftest use-package.5 - (let ((pkgs '("H" "G1" "G2" "G3")) - (vars '("FOO1" "FOO2" "FOO3"))) - (dolist (p pkgs) - (safely-delete-package p) - (make-package p :use nil)) - (and - (every (complement #'package-use-list) pkgs) - (every (complement #'package-used-by-list) pkgs) - (every #'(lambda (v p) - (export (intern v p) p)) - vars (cdr pkgs)) - (progn - (dolist (p (cdr pkgs)) (intern "MINE" p)) - (eqt (use-package (cdr pkgs) (car pkgs)) t)) - (every #'(lambda (v p) - (eqt (find-symbol v p) - (find-symbol v (car pkgs)))) - vars (cdr pkgs)) - (null (find-symbol "MINE" (car pkgs))) - (every #'(lambda (p) - (equal (package-used-by-list p) - (list (find-package (car pkgs))))) - (cdr pkgs)) - (equal (sort-package-list (package-use-list (car pkgs))) - (mapcar #'find-package (cdr pkgs))) - (every (complement #'package-use-list) (cdr pkgs)) - (null (package-used-by-list (car pkgs))))) - t) - -;; Circular package use - -(deftest use-package.6 - (progn - (safely-delete-package "H") - (safely-delete-package "G") - (let ((pg (make-package "G")) - (ph (make-package "H")) - sym1 sym2 sym3 sym4 - a1 a2 a3 a4) - (prog1 - (and - (export (intern "X" pg) pg) - (export (intern "Y" ph) ph) - (use-package pg ph) - (use-package ph pg) - (progn - (multiple-value-setq - (sym1 a1) (find-symbol "X" pg)) - (multiple-value-setq - (sym2 a2) (find-symbol "Y" ph)) - (multiple-value-setq - (sym3 a3) (find-symbol "Y" pg)) - (multiple-value-setq - (sym4 a4) (find-symbol "X" ph)) - (and - (eqt a1 :external) - (eqt a2 :external) - (eqt a3 :inherited) - (eqt a4 :inherited) - (eqt sym1 sym4) - (eqt sym2 sym3) - (eqt (symbol-package sym1) pg) - (eqt (symbol-package sym2) ph) - (unuse-package pg ph) - (unuse-package ph pg)))) - (safely-delete-package pg) - (safely-delete-package ph)))) - t) - -;; Check that *PACKAGE* is used as a default - -(deftest use-package.7 - (let ((user-name "H") - (used-name "G")) - (safely-delete-package user-name) - (safely-delete-package used-name) - (let* ((pused (make-package used-name :use nil)) - (puser (make-package user-name :use nil)) - (sym1 (intern "FOO" pused))) - (and - (eqt (export sym1 pused) t) - (null (package-used-by-list pused)) - (null (package-used-by-list puser)) - (null (package-use-list pused)) - (null (package-use-list puser)) - (eqt (let ((*package* puser)) (use-package pused)) t) ;; user will use used - (multiple-value-bind (sym2 access) - (find-symbol "FOO" puser) - (and - (eqt access :inherited) - (eqt sym1 sym2))) - (equal (package-use-list puser) (list pused)) - (equal (package-used-by-list pused) (list puser)) - (null (package-use-list pused)) - (null (package-used-by-list puser)) - (eqt (unuse-package pused puser) t) - (null (find-symbol "FOO" puser))))) - t) - -;;; Tests for specialized sequence arguments - -(defmacro def-use-package-test (test-name &key (user "H") (used "G")) - `(deftest ,test-name - (let ((user-name ,user) - (used-name ,used)) - (safely-delete-package user-name) - (safely-delete-package used-name) - (let* ((pused (make-package used-name :use nil)) - (puser (make-package user-name :use nil)) - (sym1 (intern "FOO" pused))) - (and - (eqt (export sym1 pused) t) - (null (package-used-by-list pused)) - (null (package-used-by-list puser)) - (null (package-use-list pused)) - (null (package-use-list puser)) - (eqt (let ((*package* puser)) (use-package pused)) t) ;; user will use used - (multiple-value-bind (sym2 access) - (find-symbol "FOO" puser) - (and - (eqt access :inherited) - (eqt sym1 sym2))) - (equal (package-use-list puser) (list pused)) - (equal (package-used-by-list pused) (list puser)) - (null (package-use-list pused)) - (null (package-used-by-list puser)) - (eqt (unuse-package pused puser) t) - (null (find-symbol "FOO" puser))))) - t)) - -;;; Specialized user package designator - -(def-use-package-test use-package.10 - :user (make-array 5 :initial-contents "TEST1" :element-type 'base-char)) - -(def-use-package-test use-package.11 - :user (make-array 10 :initial-contents "TEST1ABCDE" - :fill-pointer 5 :element-type 'base-char)) - -(def-use-package-test use-package.12 - :user (make-array 10 :initial-contents "TEST1ABCDE" - :fill-pointer 5 :element-type 'character)) - -(def-use-package-test use-package.13 - :user (make-array 5 :initial-contents "TEST1" - :adjustable t :element-type 'base-char)) - -(def-use-package-test use-package.14 - :user (make-array 5 :initial-contents "TEST1" - :adjustable t :element-type 'character)) - -(def-use-package-test use-package.15 - :user (let* ((etype 'base-char) - (name0 (make-array 10 :element-type etype - :initial-contents "xxxxxTEST1"))) - (make-array 5 :element-type etype - :displaced-to name0 - :displaced-index-offset 5))) - -(def-use-package-test use-package.16 - :user - (let* ((etype 'character) - (name0 (make-array 10 :element-type etype - :initial-contents "xxxxxTEST1"))) - (make-array 5 :element-type etype - :displaced-to name0 - :displaced-index-offset 5))) - -;;; Specialed used package designator - -(def-use-package-test use-package.17 - :used (make-array 5 :initial-contents "TEST1" :element-type 'base-char)) - -(def-use-package-test use-package.18 - :used (make-array 10 :initial-contents "TEST1ABCDE" - :fill-pointer 5 :element-type 'base-char)) - -(def-use-package-test use-package.19 - :used (make-array 10 :initial-contents "TEST1ABCDE" - :fill-pointer 5 :element-type 'character)) - -(def-use-package-test use-package.20 - :used (make-array 5 :initial-contents "TEST1" - :adjustable t :element-type 'base-char)) - -(def-use-package-test use-package.21 - :used (make-array 5 :initial-contents "TEST1" - :adjustable t :element-type 'character)) - -(def-use-package-test use-package.22 - :used (let* ((etype 'base-char) - (name0 (make-array 10 :element-type etype - :initial-contents "xxxxxTEST1"))) - (make-array 5 :element-type etype - :displaced-to name0 - :displaced-index-offset 5))) - -(def-use-package-test use-package.23 - :used - (let* ((etype 'character) - (name0 (make-array 10 :element-type etype - :initial-contents "xxxxxTEST1"))) - (make-array 5 :element-type etype - :displaced-to name0 - :displaced-index-offset 5))) - -(deftest use-package.error.1 - (signals-error (use-package) program-error) - t) - -(deftest use-package.error.2 - (progn - (safely-delete-package "UPE2A") - (safely-delete-package "UPE2") - (make-package "UPE2" :use ()) - (make-package "UPE2A" :use ()) - (signals-error (use-package "UPE2" "UPE2A" nil) program-error)) - t) diff --git a/t/ansi-test/packages/with-package-iterator.lsp b/t/ansi-test/packages/with-package-iterator.lsp deleted file mode 100644 index 6ec1905..0000000 --- a/t/ansi-test/packages/with-package-iterator.lsp +++ /dev/null @@ -1,186 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 25 08:03:36 1998 -;;;; Contains: Tests of WITH-PACKAGE-ITERATOR - - -(declaim (optimize (safety 3))) - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; with-package-iterator - -(deftest with-package-iterator.1 - (with-package-iterator-internal (list (find-package "COMMON-LISP-USER"))) - t) - -(deftest with-package-iterator.2 - (with-package-iterator-external (list (find-package "COMMON-LISP-USER"))) - t) - -(deftest with-package-iterator.3 - (with-package-iterator-inherited (list (find-package "COMMON-LISP-USER"))) - t) - -(deftest with-package-iterator.4 - (with-package-iterator-all (list (find-package "COMMON-LISP-USER"))) - t) - -;;; Should test on some packages containing shadowed symbols, -;;; multiple inheritance - -(deftest with-package-iterator.5 - (progn - (set-up-packages) - (with-package-iterator-all '("A"))) - t) - -(deftest with-package-iterator.6 - (progn - (set-up-packages) - (with-package-iterator-all '(#:|A|))) - t) - -(deftest with-package-iterator.7 - (progn - (set-up-packages) - (with-package-iterator-all '(#\A))) - t) - -(deftest with-package-iterator.8 - (progn - (set-up-packages) - (with-package-iterator-internal (list (find-package "A")))) - t) - -(deftest with-package-iterator.9 - (progn - (set-up-packages) - (with-package-iterator-external (list (find-package "A")))) - t) - -(deftest with-package-iterator.10 - (progn - (set-up-packages) - (with-package-iterator-inherited (list (find-package "A")))) - t) - -(deftest with-package-iterator.11 - (signals-error - (with-package-iterator (x "COMMON-LISP-USER")) - program-error) - t) - -;;; Apply to all packages -(deftest with-package-iterator.12 - (loop - for p in (list-all-packages) count - (handler-case - (progn - (format t "Package ~S~%" p) - (not (with-package-iterator-internal (list p)))) - (error (c) - (format "Error ~S on package ~A~%" c p) - t))) - 0) - -(deftest with-package-iterator.13 - (loop - for p in (list-all-packages) count - (handler-case - (progn - (format t "Package ~S~%" p) - (not (with-package-iterator-external (list p)))) - (error (c) - (format "Error ~S on package ~A~%" c p) - t))) - 0) - -(deftest with-package-iterator.14 - (loop - for p in (list-all-packages) count - (handler-case - (progn - (format t "Package ~S~%" p) - (not (with-package-iterator-inherited (list p)))) - (error (c) - (format t "Error ~S on package ~S~%" c p) - t))) - 0) - -(def-macro-test with-package-iterator.error.1 - (with-package-iterator (x "CL" :external) nil)) - - -;;; Specialized sequence tests - -(defmacro def-with-package-iterator-test (test-name name-form) - `(deftest ,test-name - (let ((name ,name-form)) - (safely-delete-package name) - (let* ((p (make-package name :use nil)) - (result nil) - (s (intern "X" p))) - (with-package-iterator - (x name :internal) - (loop - (multiple-value-bind - (good? sym) - (x) - (unless good? - (safely-delete-package name) - (return (equalt (list s) result))) - (push sym result)))))) - t)) - -(def-with-package-iterator-test with-package-iterator.15 - (make-array 5 :initial-contents "TEST1" - :element-type 'base-char)) - -(def-with-package-iterator-test with-package-iterator.16 - (make-array 8 :initial-contents "TEST1XXX" - :fill-pointer 5 - :element-type 'base-char)) - -(def-with-package-iterator-test with-package-iterator.17 - (make-array 8 :initial-contents "TEST1XXX" - :fill-pointer 5 - :element-type 'character)) - -(def-with-package-iterator-test with-package-iterator.18 - (make-array 5 :initial-contents "TEST1" - :adjustable t - :element-type 'base-char)) - -(def-with-package-iterator-test with-package-iterator.19 - (make-array 5 :initial-contents "TEST1" - :adjustable t - :element-type 'character)) - -(def-with-package-iterator-test with-package-iterator.20 - (let* ((etype 'base-char) - (name0 (make-array 10 :initial-contents "XTEST1YzYY" - :element-type etype))) - (make-array 5 :element-type etype - :displaced-to name0 - :displaced-index-offset 1))) - -(def-with-package-iterator-test with-package-iterator.21 - (let* ((etype 'character) - (name0 (make-array 10 :initial-contents "XTEST1YzYY" - :element-type etype))) - (make-array 5 :element-type etype - :displaced-to name0 - :displaced-index-offset 1))) - -;;; Free declaration scope - -(deftest with-package-iterator.22 - (block done - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) - (with-package-iterator (s (return-from done x) :internal) - (declare (special x)))))) - :good) diff --git a/t/ansi-test/pathnames/directory-namestring.lsp b/t/ansi-test/pathnames/directory-namestring.lsp deleted file mode 100644 index f744622..0000000 --- a/t/ansi-test/pathnames/directory-namestring.lsp +++ /dev/null @@ -1,52 +0,0 @@ - ;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Sep 12 06:21:42 2004 -;;;; Contains: Tests for DIRECTORY-NAMESTRING - - - -(deftest directory-namestring.1 - (let* ((vals (multiple-value-list - (directory-namestring "directory-namestring.txt"))) - (s (first vals))) - (if (and (null (cdr vals)) - (stringp s) - (equal (directory-namestring s) s)) - :good - vals)) - :good) - -(deftest directory-namestring.2 - (do-special-strings - (s "directory-namestring.txt" nil) - (let ((ns (directory-namestring s))) - (assert (stringp ns)) - (assert (string= (directory-namestring ns) ns)))) - nil) - -;;; Lispworks makes another assumption about filename normalization -;;; when using file streams as pathname designators, so this test -;;; doesn't work there. -;;; (This is another example of the difficulty of testing a feature -;;; in which so much is left up to the implementation.) -#-lispworks -(deftest directory-namestring.3 - (let* ((name "directory-namestring.txt") - (pn (merge-pathnames (pathname name))) - (name2 (with-open-file (s pn :direction :input) - (directory-namestring s))) - (name3 (directory-namestring pn))) - (or (equalt name2 name3) (list name2 name3))) - t) - -;;; Error tests - -(deftest directory-namestring.error.1 - (signals-error (directory-namestring) program-error) - t) - -(deftest directory-namestring.error.2 - (signals-error - (directory-namestring "directory-namestring.txt" nil) - program-error) - t) diff --git a/t/ansi-test/pathnames/enough-namestring.lsp b/t/ansi-test/pathnames/enough-namestring.lsp deleted file mode 100644 index 3cdbd07..0000000 --- a/t/ansi-test/pathnames/enough-namestring.lsp +++ /dev/null @@ -1,89 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Sep 12 06:23:50 2004 -;;;; Contains: Tests of ENOUGH-NAMESTRING - - - -(deftest enough-namestring.1 - (let* ((vals (multiple-value-list - (enough-namestring "enough-namestring.txt"))) - (s (first vals))) - (if (and (null (cdr vals)) - (stringp s) - (equal (enough-namestring s) s)) - :good - vals)) - :good) - -(deftest enough-namestring.2 - (do-special-strings - (s "enough-namestring.txt" nil) - (let ((ns (enough-namestring s))) - (assert (stringp ns)) - (assert (string= (enough-namestring ns) ns)))) - nil) - -(deftest enough-namestring.3 - (let* ((name "enough-namestring.txt") - (pn (merge-pathnames (pathname name))) - (name2 (enough-namestring pn)) - (name3 (enough-namestring name))) - (or (equalt name2 name3) (list name2 name3))) - t) - -(deftest enough-namestring.4 - (let* ((name "enough-namestring.txt") - (pn (merge-pathnames (pathname name))) - (name2 (with-open-file (s pn :direction :input) (enough-namestring s))) - (name3 (enough-namestring name))) - (or (equalt name2 name3) (list name2 name3))) - t) - -(deftest enough-namestring.5 - (let* ((vals (multiple-value-list - (enough-namestring "enough-namestring.txt" - *default-pathname-defaults*))) - (s (first vals))) - (if (and (null (cdr vals)) - (stringp s) - (equal (enough-namestring s) s)) - :good - vals)) - :good) - -(deftest enough-namestring.6 - (let* ((vals (multiple-value-list - (enough-namestring "enough-namestring.txt" - (namestring *default-pathname-defaults*)))) - (s (first vals))) - (if (and (null (cdr vals)) - (stringp s) - (equal (enough-namestring s) s)) - :good - vals)) - :good) - -(deftest enough-namestring.7 - (do-special-strings - (s (namestring *default-pathname-defaults*) nil) - (let* ((vals (multiple-value-list - (enough-namestring "enough-namestring.txt" s))) - (s2 (first vals))) - (assert (null (cdr vals))) - (assert (stringp s2)) - (assert (equal (enough-namestring s2) s2)))) - nil) - -;;; Error tests - -(deftest enough-namestring.error.1 - (signals-error (enough-namestring) program-error) - t) - -(deftest enough-namestring.error.2 - (signals-error - (enough-namestring "enough-namestring.txt" - *default-pathname-defaults* nil) - program-error) - t) diff --git a/t/ansi-test/pathnames/file-namestring.lsp b/t/ansi-test/pathnames/file-namestring.lsp deleted file mode 100644 index aa5eabd..0000000 --- a/t/ansi-test/pathnames/file-namestring.lsp +++ /dev/null @@ -1,43 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Sep 11 07:40:47 2004 -;;;; Contains: Tests for FILE-NAMESTRING - -(deftest file-namestring.1 - (let* ((vals (multiple-value-list - (file-namestring "file-namestring.txt"))) - (s (first vals))) - (if (and (null (cdr vals)) - (stringp s) - (equal (file-namestring s) s)) - :good - vals)) - :good) - -(deftest file-namestring.2 - (do-special-strings - (s "file-namestring.txt" nil) - (let ((ns (file-namestring s))) - (assert (stringp ns)) - (assert (string= (file-namestring ns) ns)))) - nil) - -(deftest file-namestring.3 - (let* ((name "file-namestring.txt") - (pn (merge-pathnames (pathname name))) - (name2 (with-open-file (s pn :direction :input) - (file-namestring s))) - (name3 (file-namestring pn))) - (or (equalt name2 name3) (list name2 name3))) - t) - -;;; Error tests - -(deftest file-namestring.error.1 - (signals-error (file-namestring) program-error) - t) - -(deftest file-namestring.error.2 - (signals-error (file-namestring "file-namestring.txt" nil) - program-error) - t) diff --git a/t/ansi-test/pathnames/host-namestring.lsp b/t/ansi-test/pathnames/host-namestring.lsp deleted file mode 100644 index 2218ba0..0000000 --- a/t/ansi-test/pathnames/host-namestring.lsp +++ /dev/null @@ -1,49 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Sep 12 06:22:40 2004 -;;;; Contains: Tests of HOST-NAMESTRING - - - -(deftest host-namestring.1 - (let* ((vals (multiple-value-list - (host-namestring "host-namestring.txt"))) - (s (first vals))) - (if (and (null (cdr vals)) - (or (null s) - (stringp s) - ;; (equal (host-namestring s) s) - )) - :good - vals)) - :good) - -(deftest host-namestring.2 - (do-special-strings - (s "host-namestring.txt" nil) - (let ((ns (host-namestring s))) - (when ns - (assert (stringp ns)) - ;; (assert (string= (host-namestring ns) ns)) - ))) - nil) - -(deftest host-namestring.3 - (let* ((name "host-namestring.txt") - (pn (merge-pathnames (pathname name))) - (name2 (with-open-file (s pn :direction :input) - (host-namestring s))) - (name3 (host-namestring pn))) - (or (equalt name2 name3) (list name2 name3))) - t) - -;;; Error tests - -(deftest host-namestring.error.1 - (signals-error (host-namestring) program-error) - t) - -(deftest host-namestring.error.2 - (signals-error (host-namestring "host-namestring.txt" nil) - program-error) - t) diff --git a/t/ansi-test/pathnames/load-logical-pathname-translations.lsp b/t/ansi-test/pathnames/load-logical-pathname-translations.lsp deleted file mode 100644 index 29f2651..0000000 --- a/t/ansi-test/pathnames/load-logical-pathname-translations.lsp +++ /dev/null @@ -1,34 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Dec 31 09:31:33 2003 -;;;; Contains: Tests (such as they are) for LOAD-LOGICAL-PATHNAME-TRANSLATIONS - - - -;;; The function LOAD-LOGICAL-PATHNAME-TRANSLATIONS is almost entirely -;;; untestable, since the basic behavior is implementation defined. - -(deftest load-logical-pathname-translations.1 - (load-logical-pathname-translations "CLTESTROOT") - nil) - -;;; Error cases - -(deftest load-logical-pathname-translations.error.1 - (handler-case - (progn (load-logical-pathname-translations - "THEREHADBETTERNOTBEAHOSTCALLEDTHIS") - nil) - (error () :good)) - :good) - -(deftest load-logical-pathname-translations.error.2 - (signals-error (load-logical-pathname-translations) - program-error) - t) - -(deftest load-logical-pathname-translations.error.3 - (signals-error (load-logical-pathname-translations "CLTESTROOT" nil) - program-error) - t) - diff --git a/t/ansi-test/pathnames/load.lsp b/t/ansi-test/pathnames/load.lsp deleted file mode 100644 index 0bd8aa8..0000000 --- a/t/ansi-test/pathnames/load.lsp +++ /dev/null @@ -1,35 +0,0 @@ -;;;; Tests for pathnames and logical pathnames -(compile-and-load "ANSI-TESTS:AUX;pathnames-aux.lsp") - -(in-package #:cl-test) - -(let ((*default-pathname-defaults* - (make-pathname - :directory (pathname-directory *load-pathname*)))) - (load "pathnames.lsp") - (load "pathname.lsp") - (load "pathnamep.lsp") - (load "make-pathname.lsp") - (load "pathname-host.lsp") - (load "pathname-device.lsp") - (load "pathname-directory.lsp") - (load "pathname-name.lsp") - (load "pathname-type.lsp") - (load "pathname-version.lsp") - - (load "load-logical-pathname-translations.lsp") - (load "logical-pathname.lsp") - (load "logical-pathname-translations.lsp") - (load "translate-logical-pathname.lsp") - - (load "namestring.lsp") - (load "file-namestring.lsp") - (load "directory-namestring.lsp") - (load "host-namestring.lsp") - (load "enough-namestring.lsp") - - (load "wild-pathname-p.lsp") - (load "merge-pathnames.lsp") - (load "pathname-match-p.lsp") - - (load "parse-namestring.lsp")) diff --git a/t/ansi-test/pathnames/logical-pathname-translations.lsp b/t/ansi-test/pathnames/logical-pathname-translations.lsp deleted file mode 100644 index 1da2bdc..0000000 --- a/t/ansi-test/pathnames/logical-pathname-translations.lsp +++ /dev/null @@ -1,8 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Dec 31 09:46:08 2003 -;;;; Contains: Tests of LOGICAL-PATHNAME-TRANSLATIONS - - - - diff --git a/t/ansi-test/pathnames/logical-pathname.lsp b/t/ansi-test/pathnames/logical-pathname.lsp deleted file mode 100644 index d320498..0000000 --- a/t/ansi-test/pathnames/logical-pathname.lsp +++ /dev/null @@ -1,91 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Dec 30 19:05:01 2003 -;;;; Contains: Tests of LOGICAL-PATHNAME - -(deftest logical-pathname.1 - (loop for x in *logical-pathnames* - always (eql x (logical-pathname x))) - t) - -(deftest logical-pathname.2 - (notnot-mv (typep (logical-pathname "CLTEST:FOO") 'logical-pathname)) - t) - -(deftest logical-pathname.3 - (let ((name "CLTEST:TEMP.DAT.NEWEST")) - (with-open-file - (s (logical-pathname name) - :direction :output - :if-exists :supersede - :if-does-not-exist :create) - (or (equalt (logical-pathname s) (logical-pathname name)) - (list (logical-pathname s) (logical-pathname name))))) - t) - - -;;; Error tests - -(deftest logical-pathname.error.1 - (check-type-error #'logical-pathname - (typef '(or string stream logical-pathname))) - nil) - -(deftest logical-pathname.error.2 - ;; Doesn't specify a host - (signals-error (logical-pathname "FOO.TXT") type-error) - t) - -(deftest logical-pathname.error.3 - (signals-error - (with-open-file (s #p"logical-pathname.txt" :direction :input) - (logical-pathname s)) - type-error) - t) - -(deftest logical-pathname.error.4 - (signals-error - (with-open-stream - (is (make-concatenated-stream)) - (with-open-stream - (os (make-broadcast-stream)) - (with-open-stream - (s (make-two-way-stream is os)) - (logical-pathname s)))) - type-error) - t) - -(deftest logical-pathname.error.5 - (signals-error - (with-open-stream - (is (make-concatenated-stream)) - (with-open-stream - (os (make-broadcast-stream)) - (with-open-stream - (s (make-echo-stream is os)) - (logical-pathname s)))) - type-error) - t) - -(deftest logical-pathname.error.6 - (signals-error (with-open-stream (s (make-broadcast-stream)) (logical-pathname s)) type-error) - t) - -(deftest logical-pathname.error.7 - (signals-error (with-open-stream (s (make-concatenated-stream)) (logical-pathname s)) type-error) - t) - -(deftest logical-pathname.error.8 - (signals-error (with-open-stream (s (make-string-input-stream "foo")) - (logical-pathname s)) type-error) - t) - -(deftest logical-pathname.error.9 - (signals-error (with-output-to-string (s) (logical-pathname s)) type-error) - t) - -(deftest logical-pathname.error.10 - (handler-case - (progn (eval '(locally (declare (optimize safety)) (logical-pathname "CLROOT:%"))) t) - (type-error () t)) - t) diff --git a/t/ansi-test/pathnames/make-pathname.lsp b/t/ansi-test/pathnames/make-pathname.lsp deleted file mode 100644 index 82f362b..0000000 --- a/t/ansi-test/pathnames/make-pathname.lsp +++ /dev/null @@ -1,171 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Nov 29 05:54:30 2003 -;;;; Contains: Tests of MAKE-PATHNAME - - - -(defvar *null-pathname* - (make-pathname)) - -(defun make-pathname-test - (&rest args &key (defaults nil) - (host (if defaults (pathname-host defaults) - (pathname-host *default-pathname-defaults*))) - (device (if defaults (pathname-device defaults) - (pathname-device *null-pathname*))) - (directory (if defaults (pathname-directory defaults) - (pathname-directory *null-pathname*))) - (name (if defaults (pathname-name defaults) - (pathname-name *null-pathname*))) - (type (if defaults (pathname-type defaults) - (pathname-type *null-pathname*))) - (version (if defaults (pathname-version defaults) - (pathname-version *null-pathname*))) - case) - (declare (ignorable case)) - (let* ((vals (multiple-value-list (apply #'make-pathname args))) - (pn (first vals))) - (and (= (length vals) 1) - (typep pn 'pathname) - (equalp (pathname-host pn) host) - (equalp (pathname-device pn) device) - ;; (equalp (pathname-directory pn) directory) - (let ((pnd (pathname-directory pn))) - (if (eq directory :wild) - (member pnd '((:absolute :wild-inferiors) - (:absolute :wild)) - :test #'equal) - (equalp pnd directory))) - (equalp (pathname-name pn) name) - (equalp (pathname-type pn) type) - (equalp (pathname-version pn) version) - t))) - - - -(deftest make-pathname.1 - (make-pathname-test) - t) - -(deftest make-pathname.2 - (make-pathname-test :name "foo") - t) - -(deftest make-pathname.2a - (do-special-strings - (s "foo") - (assert (make-pathname-test :name s))) - nil) - -(deftest make-pathname.3 - (make-pathname-test :name "foo" :type "txt") - t) - -(deftest make-pathname.3a - (do-special-strings - (s "txt") - (assert (make-pathname-test :name "foo" :type s))) - nil) - -(deftest make-pathname.4 - (make-pathname-test :type "lsp") - t) - -(deftest make-pathname.5 - (make-pathname-test :directory :wild) - t) - -(deftest make-pathname.6 - (make-pathname-test :name :wild) - t) - -(deftest make-pathname.7 - (make-pathname-test :type :wild) - t) - -(deftest make-pathname.8 - (make-pathname-test :version :wild) - t) - -(deftest make-pathname.9 - (make-pathname-test :defaults *default-pathname-defaults*) - t) - -(deftest make-pathname.10 - (make-pathname-test :defaults (make-pathname :name "foo" :type "bar")) - t) - -(deftest make-pathname.11 - (make-pathname-test :version :newest) - t) - -(deftest make-pathname.12 - (make-pathname-test :case :local) - t) - -(deftest make-pathname.13 - (make-pathname-test :case :common) - t) - -(deftest make-pathname.14 - (let ((*default-pathname-defaults* - (make-pathname :name "foo" :type "lsp" :version :newest))) - (make-pathname-test)) - t) - -;;; Works on the components of actual pathnames -(deftest make-pathname.rebuild - (loop for p in *pathnames* - for host = (pathname-host p) - for device = (pathname-device p) - for directory = (pathname-directory p) - for name = (pathname-name p) - for type = (pathname-type p) - for version = (pathname-version p) - for p2 = (make-pathname - :host host - :device device - :directory directory - :name name - :type type - :version version) - unless (equal p p2) - collect (list p p2)) - nil) - -;;; Various constraints on :directory - -(deftest make-pathname-error-absolute-up - (signals-error (directory (make-pathname :directory '(:absolute :up))) - file-error) - t) - -(deftest make-pathname-error-absolute-back - (signals-error (directory (make-pathname :directory '(:absolute :back))) - file-error) - t) - -;; The next test is correct, but was causing very large amounts of time to be spent -;; in buggy implementations -#| -(deftest make-pathname-error-absolute-wild-inferiors-up - (signals-error (directory (make-pathname :directory '(:absolute :wild-inferiors :up))) - file-error) - t) -|# - -(deftest make-pathname-error-relative-wild-inferiors-up - (signals-error (length (directory (make-pathname :directory '(:relative :wild-inferiors :up)))) - file-error) - t) - -(deftest make-pathname-error-absolute-wild-inferiors-back - (signals-error (directory (make-pathname :directory '(:absolute :wild-inferiors :back))) - file-error) - t) - -(deftest make-pathname-error-relative-wild-inferiors-back - (signals-error (directory (make-pathname :directory '(:relative :wild-inferiors :back))) - file-error) - t) diff --git a/t/ansi-test/pathnames/merge-pathnames.lsp b/t/ansi-test/pathnames/merge-pathnames.lsp deleted file mode 100644 index 35d9eb2..0000000 --- a/t/ansi-test/pathnames/merge-pathnames.lsp +++ /dev/null @@ -1,124 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Dec 31 11:25:55 2003 -;;;; Contains: Tests of MERGE-PATHNAMES - - - -#| -(defun merge-pathnames-test (&rest args) - (assert (<= 1 (length args) 3)) - (let* ((p1 (car args)) - (p2 (if (cdr args) (cadr args) *default-pathname-defaults*)) - (default-version (if (cddr args) (caddr args) :newest)) - (results (multiple-value-list (apply #'merge-pathnames args)))) - (assert (= (length results) 1)) - (let ((p3 (first results))) - -|# - -(deftest merge-pathnames.1 - (let* ((p1 (make-pathname :name "foo")) - (p2 (merge-pathnames p1 p1 nil))) - (values - (equalpt (pathname-name p1) "foo") - (if (equalpt p1 p2) t - (list p1 p2)))) - t t) - -(deftest merge-pathnames.2 - (let* ((p1 (make-pathname :name "foo")) - (p2 (merge-pathnames p1 p1))) - (values - (equalpt (pathname-host p1) (pathname-host p2)) - (equalpt (pathname-device p1) (pathname-device p2)) - (equalpt (pathname-directory p1) (pathname-directory p2)) - (pathname-name p1) - (pathname-name p2) - (equalpt (pathname-type p1) (pathname-type p2)) - (if (pathname-version p1) - (equalpt (pathname-version p1) (pathname-version p2)) - (equalpt (pathname-version p2) :newest)))) - t t t "foo" "foo" t t) - -(deftest merge-pathnames.3 - (let* ((p1 (make-pathname :name "foo")) - (p2 (make-pathname :name "bar")) - (p3 (merge-pathnames p1 p2))) - (values - (equalpt (pathname-host p1) (pathname-host p3)) - (equalpt (pathname-device p1) (pathname-device p3)) - (equalpt (pathname-directory p1) (pathname-directory p3)) - (pathname-name p1) - (pathname-name p3) - (equalpt (pathname-type p1) (pathname-type p3)) - (if (pathname-version p1) - (equalpt (pathname-version p1) (pathname-version p3)) - (equalpt (pathname-version p3) :newest)))) - t t t "foo" "foo" t t) - -(deftest merge-pathnames.4 - (let* ((p1 (make-pathname :name "foo")) - (p2 (make-pathname :type "lsp")) - (p3 (merge-pathnames p1 p2))) - (values - (equalpt (pathname-host p1) (pathname-host p3)) - (equalpt (pathname-device p1) (pathname-device p3)) - (equalpt (pathname-directory p1) (pathname-directory p3)) - (pathname-name p1) - (pathname-type p2) - (pathname-type p3) - (equalpt (pathname-type p2) (pathname-type p3)) - (if (pathname-version p1) - (equalpt (pathname-version p1) (pathname-version p3)) - (equalpt (pathname-version p3) :newest)))) - t t t "foo" "lsp" "lsp" t t) - -(deftest merge-pathnames.5 - (let* ((p1 (make-pathname :name "foo")) - (p2 (make-pathname :type "lsp" :version :newest)) - (p3 (merge-pathnames p1 p2 nil))) - (values - (equalpt (pathname-host p1) (pathname-host p3)) - (equalpt (pathname-device p1) (pathname-device p3)) - (equalpt (pathname-directory p1) (pathname-directory p3)) - (pathname-name p1) - (pathname-name p3) - (pathname-type p2) - (pathname-type p3) - (equalpt (pathname-version p1) (pathname-version p3)))) - t t t "foo" "foo" "lsp" "lsp" t) - -(deftest merge-pathnames.6 - (let* ((p1 (make-pathname)) - (p2 (make-pathname :name "foo" :version :newest)) - (p3 (merge-pathnames p1 p2 nil))) - (values - (equalpt (pathname-host p1) (pathname-host p3)) - (equalpt (pathname-device p1) (pathname-device p3)) - (equalpt (pathname-directory p1) (pathname-directory p3)) - (pathname-name p2) - (pathname-name p3) - (equalpt (pathname-type p2) (pathname-type p3)) - (pathname-version p2) - (pathname-version p3))) - t t t "foo" "foo" t :newest :newest) - -(deftest merge-pathnames.7 - (let* ((p1 (make-pathname)) - (p2 *default-pathname-defaults*) - (p3 (merge-pathnames p1))) - (values - (equalpt (pathname-host p1) (pathname-host p3)) - (equalpt (pathname-host p2) (pathname-host p3)) - (equalpt (pathname-device p2) (pathname-device p3)) - (equalpt (pathname-directory p2) (pathname-directory p3)) - (equalpt (pathname-name p2) (pathname-name p3)) - (equalpt (pathname-type p2) (pathname-type p3)) - (cond - ((pathname-version p1) (equalpt (pathname-version p1) - (pathname-version p3))) - ((pathname-version p2) (equalpt (pathname-version p2) - (pathname-version p3))) - (t (equalpt (pathname-version p3) :newest))))) - t t t t t t t) diff --git a/t/ansi-test/pathnames/namestring.lsp b/t/ansi-test/pathnames/namestring.lsp deleted file mode 100644 index ef1bffe..0000000 --- a/t/ansi-test/pathnames/namestring.lsp +++ /dev/null @@ -1,64 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Sep 2 07:24:42 2004 -;;;; Contains: Tests for NAMESTRING - - - -(deftest namestring.1 - (let* ((vals (multiple-value-list (namestring "namestring.lsp"))) - (s (first vals))) - (if (and (null (cdr vals)) - (stringp s) - (equal (namestring s) s)) - :good - vals)) - :good) - -(deftest namestring.2 - (do-special-strings - (s "namestring.lsp" nil) - (let ((ns (namestring s))) - (assert (stringp ns)) - (assert (string= (namestring ns) ns)))) - nil) - -;;; I'm not convinced these tested required behavior, so I'm commenting -;;; them out for now. FIXME: determine if they are bogus -#| -(deftest namestring.3 - (let* ((name "namestring.lsp") - (pn (merge-pathnames (pathname name))) - (name2 (namestring pn)) - (pn2 (pathname name2))) - (or (equalt pn pn2) (list (list pn (pathname-host pn) (pathname-device pn) - (pathname-directory pn) (pathname-name pn) - (pathname-type pn) (pathname-version pn)) - (list pn2 (pathname-host pn2) (pathname-device pn2) - (pathname-directory pn2) (pathname-name pn2) - (pathname-type pn2) (pathname-version pn2))))) - t) - -(deftest namestring.4 - (let* ((name "namestring.lsp") - (pn (merge-pathnames (pathname name))) - (name2 (with-open-file (s pn :direction :input) (namestring s))) - (pn2 (pathname name2))) - (or (equalt pn pn2) (list (list pn (pathname-host pn) (pathname-device pn) - (pathname-directory pn) (pathname-name pn) - (pathname-type pn) (pathname-version pn)) - (list pn2 (pathname-host pn2) (pathname-device pn2) - (pathname-directory pn2) (pathname-name pn2) - (pathname-type pn2) (pathname-version pn2))))) - t) -|# - -;;; Error tests - -(deftest namestring.error.1 - (signals-error (namestring) program-error) - t) - -(deftest namestring.error.2 - (signals-error (namestring "namestring.lsp" nil) program-error) - t) diff --git a/t/ansi-test/pathnames/parse-namestring.lsp b/t/ansi-test/pathnames/parse-namestring.lsp deleted file mode 100644 index 496527d..0000000 --- a/t/ansi-test/pathnames/parse-namestring.lsp +++ /dev/null @@ -1,89 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Aug 14 13:59:18 2004 -;;;; Contains: Tests of PARSE-NAMESTRING - - - -;;; "Parsing a null string always succeeds, producing a pathname -;;; with all components (except the host) equal to nil." - -(deftest parse-namestring.1 - (let ((vals (multiple-value-list (parse-namestring "")))) - (assert (= (length vals) 2)) - (let ((pn (first vals)) - (pos (second vals))) - (values - (pathname-directory pn) - (pathname-device pn) - (pathname-name pn) - (pathname-type pn) - (pathname-version pn) - pos))) - nil nil nil nil nil 0) - -(deftest parse-namestring.2 - (let ((vals (multiple-value-list (parse-namestring (make-array 0 :element-type 'base-char))))) - (assert (= (length vals) 2)) - (let ((pn (first vals)) - (pos (second vals))) - (values - (pathname-directory pn) - (pathname-device pn) - (pathname-name pn) - (pathname-type pn) - (pathname-version pn) - pos))) - nil nil nil nil nil 0) - -(deftest parse-namestring.3 - (let ((vals (multiple-value-list (parse-namestring (make-array 4 :element-type 'base-char - :initial-element #\X - :fill-pointer 0))))) - (assert (= (length vals) 2)) - (let ((pn (first vals)) - (pos (second vals))) - (values - (pathname-directory pn) - (pathname-device pn) - (pathname-name pn) - (pathname-type pn) - (pathname-version pn) - pos))) - nil nil nil nil nil 0) - -(deftest parse-namestring.4 - (loop for etype in '(standard-char base-char character) - for s0 = (make-array 4 :element-type etype :initial-element #\X) - for s = (make-array 0 :element-type etype :displaced-to s0 - :displaced-index-offset 1) - for vals = (multiple-value-list (parse-namestring s)) - for pn = (first vals) - for pos = (second vals) - do (assert (= (length vals) 2)) - nconc - (let ((result (list (pathname-directory pn) - (pathname-device pn) - (pathname-name pn) - (pathname-type pn) - (pathname-version pn) - pos))) - (unless (equal result '(nil nil nil nil nil 0)) - (list (list etype result))))) - nil) - -;;; Error tests - -(deftest parse-namestring.error.1 - (signals-error (parse-namestring) program-error) - t) - -(deftest parse-name-string.error.2 - (signals-error (parse-namestring "" nil *default-pathname-defaults* :foo nil) program-error) - t) - -(deftest parse-name-string.error.3 - (signals-error (parse-namestring "" nil *default-pathname-defaults* :start) program-error) - t) - - diff --git a/t/ansi-test/pathnames/pathname-device.lsp b/t/ansi-test/pathnames/pathname-device.lsp deleted file mode 100644 index 0082ba8..0000000 --- a/t/ansi-test/pathnames/pathname-device.lsp +++ /dev/null @@ -1,74 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Dec 6 14:23:54 2003 -;;;; Contains: Tests for PATHNAME-DEVICE - - - - - -(deftest pathname-device.1 - (loop for p in *pathnames* - for device = (pathname-device p) - unless (or (stringp device) - (member device '(nil :wild :unspecific))) - collect (list p device)) - nil) - -(deftest pathname-device.2 - (loop for p in *pathnames* - for device = (pathname-device p :case :local) - unless (or (stringp device) - (member device '(nil :wild :unspecific))) - collect (list p device)) - nil) - -(deftest pathname-device.3 - (loop for p in *pathnames* - for device = (pathname-device p :case :common) - unless (or (stringp device) - (member device '(nil :wild :unspecific))) - collect (list p device)) - nil) - -(deftest pathname-device.4 - (loop for p in *pathnames* - for device = (pathname-device p :allow-other-keys nil) - unless (or (stringp device) - (member device '(nil :wild :unspecific))) - collect (list p device)) - nil) - -(deftest pathname-device.5 - (loop for p in *pathnames* - for device = (pathname-device p :foo 'bar :allow-other-keys t) - unless (or (stringp device) - (member device '(nil :wild :unspecific))) - collect (list p device)) - nil) - -(deftest pathname-device.6 - (loop for p in *pathnames* - for device = (pathname-device p :allow-other-keys t :allow-other-keys nil :foo 'bar) - unless (or (stringp device) - (member device '(nil :wild :unspecific))) - collect (list p device)) - nil) - -;;; section 19.3.2.1 -(deftest pathname-device.7 - (loop for p in *logical-pathnames* - always (eq (pathname-device p) :unspecific)) - t) - -(deftest pathname-device.8 - (do-special-strings (s "" nil) (pathname-device s)) - nil) - -(deftest pathname-device.error.1 - (signals-error (pathname-device) program-error) - t) - -(deftest pathname-device.error.2 - (check-type-error #'pathname-device #'could-be-pathname-designator) - nil) diff --git a/t/ansi-test/pathnames/pathname-directory.lsp b/t/ansi-test/pathnames/pathname-directory.lsp deleted file mode 100644 index 6e5a772..0000000 --- a/t/ansi-test/pathnames/pathname-directory.lsp +++ /dev/null @@ -1,89 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Dec 6 14:24:39 2003 -;;;; Contains: Tests for PATHNAME-DIRECTORY - - - - - -(deftest pathname-directory.1 - (loop for p in *pathnames* - for directory = (pathname-directory p) - unless (or (stringp directory) - (member directory '(nil :wild :unspecific)) - (and (consp directory) - (member (car directory) '(:absolute :relative)))) - collect (list p directory)) - nil) - -(deftest pathname-directory.2 - (loop for p in *pathnames* - for directory = (pathname-directory p :case :local) - unless (or (stringp directory) - (member directory '(nil :wild :unspecific)) - (and (consp directory) - (member (car directory) '(:absolute :relative)))) - collect (list p directory)) - nil) - -(deftest pathname-directory.3 - (loop for p in *pathnames* - for directory = (pathname-directory p :case :common) - unless (or (stringp directory) - (member directory '(nil :wild :unspecific)) - (and (consp directory) - (member (car directory) '(:absolute :relative)))) - collect (list p directory)) - nil) - -(deftest pathname-directory.4 - (loop for p in *pathnames* - for directory = (pathname-directory p :allow-other-keys nil) - unless (or (stringp directory) - (member directory '(nil :wild :unspecific)) - (and (consp directory) - (member (car directory) '(:absolute :relative)))) - collect (list p directory)) - nil) - -(deftest pathname-directory.5 - (loop for p in *pathnames* - for directory = (pathname-directory p :foo 'bar :allow-other-keys t) - unless (or (stringp directory) - (member directory '(nil :wild :unspecific)) - (and (consp directory) - (member (car directory) '(:absolute :relative)))) - collect (list p directory)) - nil) - -(deftest pathname-directory.6 - (loop for p in *pathnames* - for directory = (pathname-directory p :allow-other-keys t - :allow-other-keys nil - 'foo 'bar) - unless (or (stringp directory) - (member directory '(nil :wild :unspecific)) - (and (consp directory) - (member (car directory) '(:absolute :relative)))) - collect (list p directory)) - nil) - -;;; section 19.3.2.1 -(deftest pathname-directory.7 - (loop for p in *logical-pathnames* - when (eq (pathname-directory p) :unspecific) - collect p) - nil) - -(deftest pathname-directory.8 - (do-special-strings (s "" nil) (pathname-directory s)) - nil) - -(deftest pathname-directory.error.1 - (signals-error (pathname-directory) program-error) - t) - -(deftest pathname-directory.error.2 - (check-type-error #'pathname-directory #'could-be-pathname-designator) - nil) diff --git a/t/ansi-test/pathnames/pathname-host.lsp b/t/ansi-test/pathnames/pathname-host.lsp deleted file mode 100644 index c47df27..0000000 --- a/t/ansi-test/pathnames/pathname-host.lsp +++ /dev/null @@ -1,79 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Dec 6 14:23:22 2003 -;;;; Contains: Tests for PATHNAME-HOST - - - - - -(deftest pathname-host.1 - (loop for p in *pathnames* - always (eql (length (multiple-value-list (pathname-host p))) 1)) - t) - -(deftest pathname-host.2 - (loop for p in *pathnames* - always (eql (length (multiple-value-list (pathname-host p :case :local))) 1)) - t) - -(deftest pathname-host.3 - (loop for p in *pathnames* - always (eql (length (multiple-value-list (pathname-host p :case :common))) 1)) - t) - -(deftest pathname-host.4 - (loop for p in *pathnames* - always (eql (length (multiple-value-list (pathname-host p :allow-other-keys nil))) 1)) - t) - -(deftest pathname-host.5 - (loop for p in *pathnames* - always (eql (length (multiple-value-list - (pathname-host p :foo t :allow-other-keys t))) 1)) - t) - -(deftest pathname-host.6 - (loop for p in *pathnames* - always (eql (length (multiple-value-list - (pathname-host p :allow-other-keys t - :allow-other-keys nil - 'foo t))) 1)) - t) - -;;; section 19.3.2.1 -(deftest pathname-host.7 - (loop for p in *logical-pathnames* - when (eq (pathname-host p) :unspecific) - collect p) - nil) - -(deftest pathname-host.8 - (do-special-strings (s "" nil) (pathname-host s)) - nil) - -#| -(deftest pathname-host.9 - (loop for p in *pathnames* - for host = (pathname-host p) - unless (or (stringp host) - (and (listp host) (every #'stringp host)) - (eql host :unspecific)) - collect (list p host)) - nil) -|# - -;;; Error cases - -(deftest pathname-host.error.1 - (signals-error (pathname-host) program-error) - t) - -(deftest pathname-host.error.2 - (check-type-error #'pathname-host #'could-be-pathname-designator) - nil) - -(deftest pathname-host.error.3 - (signals-error (pathname-host *default-pathname-defaults* '#:bogus t) - program-error) - t) diff --git a/t/ansi-test/pathnames/pathname-match-p.lsp b/t/ansi-test/pathnames/pathname-match-p.lsp deleted file mode 100644 index da49144..0000000 --- a/t/ansi-test/pathnames/pathname-match-p.lsp +++ /dev/null @@ -1,103 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Aug 15 07:46:22 2004 -;;;; Contains: Tests for PATHNAME-MATCH-P - - - - - -;;; Much of the behavior cannot be tested portably. - -(deftest pathname-match-p.1 - (let ((pn1 (make-pathname :name :wild)) - (pn2 (make-pathname :name "foo"))) - (pathname-match-p pn1 pn2)) - nil) - -(deftest pathname-match-p.2 - (let ((pn1 (make-pathname :type :wild)) - (pn2 (make-pathname :type "txt"))) - (pathname-match-p pn1 pn2)) - nil) - -(deftest pathname-match-p.3 - (let ((pn1 (make-pathname :directory '(:absolute :wild))) - (pn2 (make-pathname :directory '(:absolute)))) - (pathname-match-p pn1 pn2)) - nil) - -(deftest pathname-match-p.4 - (let ((pn1 (make-pathname :directory '(:relative :wild))) - (pn2 (make-pathname :directory '(:relative)))) - (pathname-match-p pn1 pn2)) - nil) - -(deftest pathname-match-p.5 - (let ((pn1 (make-pathname :directory '(:relative :wild))) - (pn2 (make-pathname :directory nil))) - (and (wild-pathname-p pn1) - (not (pathname-directory pn2)) - (not (pathname-match-p pn1 pn2)))) - nil) - -(deftest pathname-match-p.6 - (let ((pn1 (make-pathname :version :wild)) - (pn2 (make-pathname))) - (and (wild-pathname-p pn1) - (not (pathname-version pn2)) - (not (pathname-match-p pn1 pn2)))) - nil) - -;;; Specialized string tests - -(deftest pathname-match-p.7 - (let ((wpn (parse-namestring "CLTEST:*.LSP"))) - (assert (wild-pathname-p wpn)) - (do-special-strings - (s "CLTEST:FOO.LSP" nil) - (assert (pathname-match-p s wpn)))) - nil) - -(deftest pathname-match-p.8 - (do-special-strings - (s "CLTEST:*.LSP" nil) - (assert (pathname-match-p "CLTEST:FOO.LSP" s))) - nil) - - -;;; Add more tests here - -;;; Here are error tests - -(deftest pathname-match-p.error.1 - (signals-error (pathname-match-p) program-error) - t) - -(deftest pathname-match-p.error.2 - (signals-error (pathname-match-p #p"") program-error) - t) - -(deftest pathname-match-p.error.3 - (signals-error (pathname-match-p #p"" #p"" nil) program-error) - t) - -(deftest pathname-match-p.error.4 - (check-type-error #'(lambda (x) (pathname-match-p x #p"")) - #'could-be-pathname-designator) - nil) - -(deftest pathname-match-p.error.5 - (check-type-error #'(lambda (x) (declare (optimize (safety 0))) (pathname-match-p x #p"")) - #'could-be-pathname-designator) - nil) - -(deftest pathname-match-p.error.6 - (check-type-error #'(lambda (x) (pathname-match-p #p"" x)) - #'could-be-pathname-designator) - nil) - -(deftest pathname-match-p.error.7 - (check-type-error #'(lambda (x) (declare (optimize (safety 0))) (pathname-match-p #p"" x)) - #'could-be-pathname-designator) - nil) diff --git a/t/ansi-test/pathnames/pathname-name.lsp b/t/ansi-test/pathnames/pathname-name.lsp deleted file mode 100644 index db53400..0000000 --- a/t/ansi-test/pathnames/pathname-name.lsp +++ /dev/null @@ -1,75 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Dec 6 14:45:16 2003 -;;;; Contains: Tests for PATHNAME-NAME - - - - - -(deftest pathname-name.1 - (loop for p in *pathnames* - for name = (pathname-name p) - unless (or (stringp name) - (member name '(nil :wild :unspecific))) - collect (list p name)) - nil) - -(deftest pathname-name.2 - (loop for p in *pathnames* - for name = (pathname-name p :case :local) - unless (or (stringp name) - (member name '(nil :wild :unspecific))) - collect (list p name)) - nil) - -(deftest pathname-name.3 - (loop for p in *pathnames* - for name = (pathname-name p :case :common) - unless (or (stringp name) - (member name '(nil :wild :unspecific))) - collect (list p name)) - nil) - -(deftest pathname-name.4 - (loop for p in *pathnames* - for name = (pathname-name p :allow-other-keys nil) - unless (or (stringp name) - (member name '(nil :wild :unspecific))) - collect (list p name)) - nil) - -(deftest pathname-name.5 - (loop for p in *pathnames* - for name = (pathname-name p :foo 'bar :allow-other-keys t) - unless (or (stringp name) - (member name '(nil :wild :unspecific))) - collect (list p name)) - nil) - -(deftest pathname-name.6 - (loop for p in *pathnames* - for name = (pathname-name p :allow-other-keys t :allow-other-keys nil :foo 'bar) - unless (or (stringp name) - (member name '(nil :wild :unspecific))) - collect (list p name)) - nil) - -;;; section 19.3.2.1 -(deftest pathname-name.7 - (loop for p in *logical-pathnames* - when (eq (pathname-name p) :unspecific) - collect p) - nil) - -(deftest pathname-name.8 - (do-special-strings (s "" nil) (pathname-name s)) - nil) - -(deftest pathname-name.error.1 - (signals-error (pathname-name) program-error) - t) - -(deftest pathname-name.error.2 - (check-type-error #'pathname-name #'could-be-pathname-designator) - nil) diff --git a/t/ansi-test/pathnames/pathname-type.lsp b/t/ansi-test/pathnames/pathname-type.lsp deleted file mode 100644 index 2c23bbb..0000000 --- a/t/ansi-test/pathnames/pathname-type.lsp +++ /dev/null @@ -1,75 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Dec 6 14:45:16 2003 -;;;; Contains: Tests for PATHNAME-TYPE - - - - - -(deftest pathname-type.1 - (loop for p in *pathnames* - for type = (pathname-type p) - unless (or (stringp type) - (member type '(nil :wild :unspecific))) - collect (list p type)) - nil) - -(deftest pathname-type.2 - (loop for p in *pathnames* - for type = (pathname-type p :case :local) - unless (or (stringp type) - (member type '(nil :wild :unspecific))) - collect (list p type)) - nil) - -(deftest pathname-type.3 - (loop for p in *pathnames* - for type = (pathname-type p :case :common) - unless (or (stringp type) - (member type '(nil :wild :unspecific))) - collect (list p type)) - nil) - -(deftest pathname-type.4 - (loop for p in *pathnames* - for type = (pathname-type p :allow-other-keys nil) - unless (or (stringp type) - (member type '(nil :wild :unspecific))) - collect (list p type)) - nil) - -(deftest pathname-type.5 - (loop for p in *pathnames* - for type = (pathname-type p :foo 'bar :allow-other-keys t) - unless (or (stringp type) - (member type '(nil :wild :unspecific))) - collect (list p type)) - nil) - -(deftest pathname-type.6 - (loop for p in *pathnames* - for type = (pathname-type p :allow-other-keys t :allow-other-keys nil :foo 'bar) - unless (or (stringp type) - (member type '(nil :wild :unspecific))) - collect (list p type)) - nil) - -;;; section 19.3.2.1 -(deftest pathname-type.7 - (loop for p in *logical-pathnames* - when (eq (pathname-type p) :unspecific) - collect p) - nil) - -(deftest pathname-type.8 - (do-special-strings (s "" nil) (pathname-type s)) - nil) - -(deftest pathname-type.error.1 - (signals-error (pathname-type) program-error) - t) - -(deftest pathname-type.error.2 - (check-type-error #'pathname-type #'could-be-pathname-designator) - nil) diff --git a/t/ansi-test/pathnames/pathname-version.lsp b/t/ansi-test/pathnames/pathname-version.lsp deleted file mode 100644 index 25b89e4..0000000 --- a/t/ansi-test/pathnames/pathname-version.lsp +++ /dev/null @@ -1,40 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Dec 6 14:45:16 2003 -;;;; Contains: Tests for PATHNAME-VERSION - - - - - -(deftest pathname-version.1 - (loop for p in *pathnames* - for version = (pathname-version p) - unless (or (integerp version) (symbolp version)) - collect (list p version)) - nil) - -;;; section 19.3.2.1 -(deftest pathname-version.2 - (loop for p in *logical-pathnames* - when (eq (pathname-version p) :unspecific) - collect p) - nil) - -(deftest pathname-version.3 - (do-special-strings (s "" nil) (pathname-version s)) - nil) - -(deftest pathname-version.error.1 - (signals-error (pathname-version) program-error) - t) - -(deftest pathname-version.error.2 - (signals-error (pathname-version *default-pathname-defaults* nil) - program-error) - t) - -(deftest pathname-version.error.3 - (check-type-error #'pathname-version #'could-be-pathname-designator) - nil) - diff --git a/t/ansi-test/pathnames/pathname.lsp b/t/ansi-test/pathnames/pathname.lsp deleted file mode 100644 index 8d97238..0000000 --- a/t/ansi-test/pathnames/pathname.lsp +++ /dev/null @@ -1,98 +0,0 @@ - ;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Nov 29 05:06:57 2003 -;;;; Contains: Tests of the function PATHNAME - - -(deftest pathname.1 - (loop for x in *pathnames* - always (eq x (pathname x))) - t) - -(deftest pathname.2 - (equalt #p"pathname.txt" (pathname "pathname.txt")) - t) - -(deftest pathname.3 - (let ((s (open "pathname.txt" :direction :input))) - (prog1 (equalt (truename (pathname s)) - (truename #p"pathname.txt")) - (close s))) - t) - -(deftest pathname.4 - (let ((s (open "pathname.txt" :direction :input))) - (close s) - (equalt (truename (pathname s)) - (truename #p"pathname.txt"))) - t) - -(deftest pathname.5 - (loop for x in *logical-pathnames* - always (eq x (pathname x))) - t) - -(deftest pathname.6 - (equalt #p"pathname.txt" - (pathname - (make-array 12 - :initial-contents "pathname.txt" - :element-type 'base-char))) - t) - -(deftest pathname.7 - (equalt #p"pathname.txt" - (pathname (make-array 15 - :initial-contents "pathname.txtXXX" - :element-type 'base-char - :fill-pointer 12))) - t) - -(deftest pathname.8 - (equalt #p"pathname.txt" - (pathname (make-array 12 - :initial-contents "pathname.txt" - :element-type 'base-char - :adjustable t))) - t) - -(deftest pathname.9 - (equalt #p"pathname.txt" - (pathname (make-array 15 - :initial-contents "pathname.txtXXX" - :element-type 'character - :fill-pointer 12))) - t) - -(deftest pathname.10 - (equalt #p"pathname.txt" - (pathname (make-array 12 - :initial-contents "pathname.txt" - :element-type 'character - :adjustable t))) - t) - -(deftest pathname.11 - (loop for etype in '(standard-char base-char character) - collect - (equalt #p"pathname.txt" - (pathname - (let* ((s (make-array 15 - :initial-contents - "XXpathname.txtX" - :element-type etype))) - (make-array 12 - :element-type etype - :displaced-to s - :displaced-index-offset 2))))) - (t t t)) - -;;; Error tests - -(deftest pathname.error.1 - (signals-error (pathname) program-error) - t) - -(deftest pathname.error.2 - (signals-error (pathname (first *pathnames*) nil) program-error) - t) diff --git a/t/ansi-test/pathnames/pathnamep.lsp b/t/ansi-test/pathnames/pathnamep.lsp deleted file mode 100644 index d985cad..0000000 --- a/t/ansi-test/pathnames/pathnamep.lsp +++ /dev/null @@ -1,31 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Dec 6 10:26:45 2003 -;;;; Contains: Tests of PATHNAMEP - - - -(deftest pathnamep.1 - (check-type-predicate #'pathnamep 'pathname) - nil) - -(deftest pathnamep.2 - (check-predicate #'(lambda (x) (eql (length (multiple-value-list (pathnamep x))) 1))) - nil) - -(deftest pathnamep.3 - (check-predicate (typef '(not logical-pathname)) #'pathnamep) - nil) - -(deftest pathnamep.error.1 - (signals-error (pathnamep) program-error) - t) - -(deftest pathnamep.error.2 - (signals-error (pathnamep nil nil) program-error) - t) - -(deftest pathnamep.error.3 - (signals-error (pathnamep *default-pathname-defaults* nil) - program-error) - t) diff --git a/t/ansi-test/pathnames/pathnames.lsp b/t/ansi-test/pathnames/pathnames.lsp deleted file mode 100644 index b25bb3b..0000000 --- a/t/ansi-test/pathnames/pathnames.lsp +++ /dev/null @@ -1,19 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Nov 29 04:21:53 2003 -;;;; Contains: Various tests on pathnames - - - -(deftest pathnames-print-and-read-properly - (with-standard-io-syntax - (loop - for p1 in *pathnames* - for s = (handler-case (write-to-string p1 :readably t) - (print-not-readable () :unreadable-error)) - unless (eql s :unreadable-error) - append - (let ((p2 (read-from-string s))) - (unless (equal p1 p2) - (list (list p1 s p2)))))) - nil) diff --git a/t/ansi-test/pathnames/translate-logical-pathname.lsp b/t/ansi-test/pathnames/translate-logical-pathname.lsp deleted file mode 100644 index 8e7b294..0000000 --- a/t/ansi-test/pathnames/translate-logical-pathname.lsp +++ /dev/null @@ -1,48 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Dec 29 14:45:50 2003 -;;;; Contains: Tests for TRANSLATE-LOGICAL-PATHNAME - - - -;; On physical pathnames, t-l-p returns the pathname itself - -;;; Every physical pathname is converted to itself -(deftest translate-logical-pathname.1 - (loop for p in *pathnames* - unless (or (typep p 'logical-pathname) - (eq p (translate-logical-pathname p))) - collect p) - nil) - -;;; &key arguments are allowed -(deftest translate-logical-pathname.2 - (loop for p in *pathnames* - unless (or (typep p 'logical-pathname) - (eq p (translate-logical-pathname - p :allow-other-keys t))) - collect p) - nil) - -(deftest translate-logical-pathname.3 - (loop for p in *pathnames* - unless (or (typep p 'logical-pathname) - (eq p (translate-logical-pathname - p :allow-other-keys nil))) - collect p) - nil) - -(deftest translate-logical-pathname.4 - (loop for p in *pathnames* - unless (or (typep p 'logical-pathname) - (eq p (translate-logical-pathname - p :foo 1 :allow-other-keys t :bar 2))) - collect p) - nil) - - -;;; errors - -(deftest translate-logical-pathname.error.1 - (signals-error (translate-logical-pathname) program-error) - t) diff --git a/t/ansi-test/pathnames/wild-pathname-p.lsp b/t/ansi-test/pathnames/wild-pathname-p.lsp deleted file mode 100644 index 47300a0..0000000 --- a/t/ansi-test/pathnames/wild-pathname-p.lsp +++ /dev/null @@ -1,234 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Dec 31 16:54:55 2003 -;;;; Contains: Tests of WILD-PATHNAME-P - - - - - -(deftest wild-pathname-p.1 - (wild-pathname-p (make-pathname)) - nil) - -(deftest wild-pathname-p.2 - (loop for key in '(:host :device :directory :name :type :version nil) - when (wild-pathname-p (make-pathname) key) - collect key) - nil) - -(deftest wild-pathname-p.3 - (let ((p (make-pathname :directory :wild))) - (notnot-mv (wild-pathname-p p))) - t) - -(deftest wild-pathname-p.4 - (let ((p (make-pathname :directory :wild))) - (notnot-mv (wild-pathname-p p nil))) - t) - -(deftest wild-pathname-p.5 - (let ((p (make-pathname :directory :wild))) - (notnot-mv (wild-pathname-p p :directory))) - t) - -(deftest wild-pathname-p.6 - (let ((p (make-pathname :directory :wild))) - (loop for key in '(:host :device :name :type :version) - when (wild-pathname-p p key) - collect key)) - nil) - - -(deftest wild-pathname-p.7 - (let ((p (make-pathname :directory '(:absolute :wild)))) - (notnot-mv (wild-pathname-p p))) - t) - -(deftest wild-pathname-p.8 - (let ((p (make-pathname :directory '(:absolute :wild)))) - (notnot-mv (wild-pathname-p p nil))) - t) - -(deftest wild-pathname-p.9 - (let ((p (make-pathname :directory '(:absolute :wild)))) - (notnot-mv (wild-pathname-p p :directory))) - t) - -(deftest wild-pathname-p.10 - (let ((p (make-pathname :directory '(:absolute :wild)))) - (loop for key in '(:host :device :name :type :version) - when (wild-pathname-p p key) - collect key)) - nil) - - -(deftest wild-pathname-p.11 - (let ((p (make-pathname :directory '(:relative :wild)))) - (notnot-mv (wild-pathname-p p))) - t) - -(deftest wild-pathname-p.12 - (let ((p (make-pathname :directory '(:relative :wild)))) - (notnot-mv (wild-pathname-p p nil))) - t) - -(deftest wild-pathname-p.13 - (let ((p (make-pathname :directory '(:relative :wild)))) - (notnot-mv (wild-pathname-p p :directory))) - t) - -(deftest wild-pathname-p.14 - (let ((p (make-pathname :directory '(:relative :wild)))) - (loop for key in '(:host :device :name :type :version) - when (wild-pathname-p p key) - collect key)) - nil) - -;;; - -(deftest wild-pathname-p.15 - (let ((p (make-pathname :name :wild))) - (notnot-mv (wild-pathname-p p))) - t) - -(deftest wild-pathname-p.16 - (let ((p (make-pathname :name :wild))) - (notnot-mv (wild-pathname-p p nil))) - t) - -(deftest wild-pathname-p.17 - (let ((p (make-pathname :name :wild))) - (notnot-mv (wild-pathname-p p :name))) - t) - -(deftest wild-pathname-p.18 - (let ((p (make-pathname :name :wild))) - (loop for key in '(:host :device :directory :type :version) - when (wild-pathname-p p key) - collect key)) - nil) - -;;; - -(deftest wild-pathname-p.19 - (let ((p (make-pathname :type :wild))) - (notnot-mv (wild-pathname-p p))) - t) - -(deftest wild-pathname-p.20 - (let ((p (make-pathname :type :wild))) - (notnot-mv (wild-pathname-p p nil))) - t) - -(deftest wild-pathname-p.21 - (let ((p (make-pathname :type :wild))) - (notnot-mv (wild-pathname-p p :type))) - t) - -(deftest wild-pathname-p.22 - (let ((p (make-pathname :type :wild))) - (loop for key in '(:host :device :directory :name :version) - when (wild-pathname-p p key) - collect key)) - nil) - -;;; - - (deftest wild-pathname-p.23 - (let ((p (make-pathname :version :wild))) - (notnot-mv (wild-pathname-p p))) - t) - -(deftest wild-pathname-p.24 - (let ((p (make-pathname :version :wild))) - (notnot-mv (wild-pathname-p p nil))) - t) - -(deftest wild-pathname-p.25 - (let ((p (make-pathname :version :wild))) - (notnot-mv (wild-pathname-p p :version))) - t) - -(deftest wild-pathname-p.26 - (let ((p (make-pathname :version :wild))) - (loop for key in '(:host :device :directory :name :type) - when (wild-pathname-p p key) - collect key)) - nil) - -;;; - -(deftest wild-pathname-p.27 - (loop for p in (append *pathnames* *logical-pathnames*) - unless (if (wild-pathname-p p) (wild-pathname-p p nil) - (not (wild-pathname-p p nil))) - collect p) - nil) - -(deftest wild-pathname-p.28 - (loop for p in (append *pathnames* *logical-pathnames*) - when (and (loop for key in '(:host :device :directory - :name :type :version) - thereis (wild-pathname-p p key)) - (not (wild-pathname-p p))) - collect p) - nil) - -;;; On streams associated with files - -(deftest wild-pathname-p.29 - (with-open-file (s "foo.lsp" - :direction :output - :if-exists :append - :if-does-not-exist :create) - (wild-pathname-p s)) - nil) - -(deftest wild-pathname-p.30 - (let ((s (open "foo.lsp" - :direction :output - :if-exists :append - :if-does-not-exist :create))) - (close s) - (wild-pathname-p s)) - nil) - -;;; logical pathname designators - -(deftest wild-pathname-p.31 - (wild-pathname-p "CLTEST:FOO.LISP") - nil) - -;;; Odd strings - -(deftest wild-pathname-p.32 - (do-special-strings - (s "CLTEST:FOO.LISP" nil) - (let ((vals (multiple-value-list (wild-pathname-p s)))) - (assert (equal vals '(nil))))) - nil) - -;;; - -(deftest wild-pathname-p.error.1 - (signals-error (wild-pathname-p) program-error) - t) - -(deftest wild-pathname-p.error.2 - (signals-error (wild-pathname-p *default-pathname-defaults* nil nil) - program-error) - t) - -(deftest wild-pathname-p.error.3 - (check-type-error #'wild-pathname-p - (typef '(or pathname string file-stream - synonym-stream))) - nil) - -(deftest wild-pathname-p.error.4 - (check-type-error #'(lambda (x) (declare (optimize (safety 0))) - (wild-pathname-p x)) - (typef '(or pathname string file-stream - synonym-stream))) - nil) diff --git a/t/ansi-test/pattern-match.lsp b/t/ansi-test/pattern-match.lsp deleted file mode 100644 index 6660716..0000000 --- a/t/ansi-test/pattern-match.lsp +++ /dev/null @@ -1,68 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Dec 4 18:59:27 2004 -;;;; Contains: Macro for pattern matching on S-exprs - -(in-package :cl-test) - -(defmacro pmatch (pattern form) - (cond - ((consp pattern) - (let ((pcar (car pattern)) - (pcdr (cdr pattern)) - (v (gensym))) - (case pcar - ((:or) - `(let ((,v ,form)) (or ,@(mapcar (lambda (sub) `(pmatch ,sub ,v)) - pcdr)))) - ((:and) - `(let ((,v ,form)) (and ,@(mapcar (lambda (sub) `(pmatch ,sub ,v)) - pcdr)))) - ((:not) - (assert (eql (length pcdr) 1)) - `(not (pmatch ,(car pcdr) ,form))) - (t - `(let ((,v ,form)) - (and (pmatch ,pcar (car ,v)) - (pmatch ,pcdr (cdr ,v)))))))) - ((eql pattern '_) t) - ((null pattern) - `(null ,form)) - ((symbolp pattern) - `(eql (quote ,pattern) ,form)) - (t - `(eql ,pattern ,form)))) - -(defmacro matchcase (form &body cases) - (let* ((v (gensym)) - (cond-cases - (mapcar - #'(lambda (case) - (assert (consp case)) - (let ((pattern (car case)) - (body (cdr case))) - `((pmatch ,pattern ,v) ,@body))) - cases))) - `(let ((,v ,form)) - (cond ,@cond-cases)))) - -(defmacro matchcase* (form &body cases) - (let* ((block-name (gensym "DONE")) - (v (gensym))) - `(block ,block-name - (let ((,v ,form)) - (cond - ,@(mapcar - #'(lambda (case) - (assert (consp case)) - (let ((pat (car case)) - (forms (cdr case)) - (fail-name (gensym "FAIL"))) - `((block ,fail-name - (and (pmatch ,pat ,v) - (macrolet ((fail () '(return-from ,fail-name nil))) - (return-from ,block-name - (progn ,@forms)))))))) - cases)))))) - - diff --git a/t/ansi-test/printer/copy-pprint-dispatch.lsp b/t/ansi-test/printer/copy-pprint-dispatch.lsp deleted file mode 100644 index 74f10db..0000000 --- a/t/ansi-test/printer/copy-pprint-dispatch.lsp +++ /dev/null @@ -1,124 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Feb 23 04:41:29 2004 -;;;; Contains: Tests of COPY-PPRINT-DISPATCH - - - -(deftest copy-pprint-dispatch.1 - (with-standard-io-syntax - (let ((obj '(foo bar)) - (*package* (find-package :cl-test)) - (*print-readably* nil) - (*print-pretty* t)) - (values - (prin1-to-string obj) - (let ((*print-pprint-dispatch* (copy-pprint-dispatch))) - (set-pprint-dispatch - `(eql ,obj) - #'(lambda (s obj2) (let ((*print-pretty* nil)) - (format s "#.'~S" obj2)))) - (prin1-to-string obj)) - (prin1-to-string obj)))) - "(FOO BAR)" - "#.'(FOO BAR)" - "(FOO BAR)") - -(deftest copy-pprint-dispatch.2 - (with-standard-io-syntax - (let ((obj '(foo bar)) - (*package* (find-package :cl-test)) - (*print-readably* nil) - (*print-pretty* t)) - (values - (prin1-to-string obj) - (let ((*print-pprint-dispatch* (copy-pprint-dispatch - *print-pprint-dispatch*))) - (set-pprint-dispatch - `(eql ,obj) - #'(lambda (s obj2) (let ((*print-pretty* nil)) - (format s "#.'~S" obj2)))) - (prin1-to-string obj)) - (prin1-to-string obj)))) - "(FOO BAR)" - "#.'(FOO BAR)" - "(FOO BAR)") - -(deftest copy-pprint-dispatch.3 - (with-standard-io-syntax - (let ((obj '(foo bar)) - (*package* (find-package :cl-test)) - (*print-readably* nil) - (*print-pretty* t)) - (values - (prin1-to-string obj) - (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil))) - (set-pprint-dispatch - `(eql ,obj) - #'(lambda (s obj2) (let ((*print-pretty* nil)) - (format s "#.'~S" obj2)))) - (prin1-to-string obj)) - (prin1-to-string obj)))) - "(FOO BAR)" - "#.'(FOO BAR)" - "(FOO BAR)") - -(deftest copy-pprint-dispatch.4 - (with-standard-io-syntax - (let ((obj '(foo bar)) - (*package* (find-package :cl-test)) - (*print-readably* nil) - (*print-pretty* t)) - (values - (prin1-to-string obj) - (let ((table (copy-pprint-dispatch))) - (set-pprint-dispatch - `(eql ,obj) - #'(lambda (s obj2) (let ((*print-pretty* nil)) - (format s "#.'~S" obj2))) - 0 - table) - (let ((*print-pprint-dispatch* (copy-pprint-dispatch table))) - (prin1-to-string obj))) - (prin1-to-string obj)))) - "(FOO BAR)" - "#.'(FOO BAR)" - "(FOO BAR)") - -(deftest copy-pprint-dispatch.5 - (let ((new-table (copy-pprint-dispatch))) - (values - (eql new-table *print-pprint-dispatch*) - (member new-table *universe*))) - nil nil) - -(deftest copy-pprint-dispatch.6 - (let ((new-table (copy-pprint-dispatch *print-pprint-dispatch*))) - (values - (eql new-table *print-pprint-dispatch*) - (member new-table *universe*))) - nil nil) - -(deftest copy-pprint-dispatch.7 - (let ((new-table (copy-pprint-dispatch nil))) - (values - (eql new-table *print-pprint-dispatch*) - (member new-table *universe*))) - nil nil) - - -(deftest copy-pprint-dispatch.8 - (let* ((table1 (copy-pprint-dispatch)) - (table2 (copy-pprint-dispatch table1))) - (eql table1 table2)) - nil) - -;;; Error tests - -(deftest copy-pprint-dispatch.error.1 - (signals-error (copy-pprint-dispatch nil nil) program-error) - t) - -(deftest copy-pprint-dispatch.error.2 - (check-type-error #'copy-pprint-dispatch #'null) - nil) diff --git a/t/ansi-test/printer/format/format-a.lsp b/t/ansi-test/printer/format/format-a.lsp deleted file mode 100644 index 42a2022..0000000 --- a/t/ansi-test/printer/format/format-a.lsp +++ /dev/null @@ -1,385 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Aug 2 01:42:35 2004 -;;;; Contains: Tests of printing using the ~A directive - - - - -(def-format-test format.a.1 - "~a" (nil) "NIL") - -(deftest format.a.2 - (with-standard-io-syntax - (let ((*print-case* :downcase)) - (format nil "~A" nil))) - "nil") - -(deftest formatter.a.2 - (with-standard-io-syntax - (let ((*print-case* :downcase)) - (formatter-call-to-string (formatter "~A") nil))) - "nil") - -(deftest format.a.3 - (with-standard-io-syntax - (let ((*print-case* :capitalize)) - (format nil "~a" nil))) - "Nil") - -(deftest formatter.a.3 - (with-standard-io-syntax - (let ((*print-case* :capitalize)) - (formatter-call-to-string (formatter "~a") nil))) - "Nil") - -(def-format-test format.a.4 - "~:a" (nil) "()") - -(def-format-test format.a.5 - "~:A" ('(nil)) "(NIL)") - -(def-format-test format.a.6 - "~:A" (#(nil)) "#(NIL)") - -(deftest format.a.7 - (let ((fn (formatter "~a"))) - (loop for c across +standard-chars+ - for s1 = (string c) - for s2 = (format nil "~a" s1) - for s3 = (formatter-call-to-string fn s1) - unless (and (string= s1 s2) (string= s2 s3)) - collect (list c s1 s2 s3))) - nil) - -(deftest format.a.8 - (let ((fn (formatter "~A"))) - (loop with count = 0 - for i from 0 below (min #x10000 char-code-limit) - for c = (code-char i) - for s1 = (and c (string c)) - for s2 = (and c (format nil "~A" s1)) - for s3 = (and c (formatter-call-to-string fn s1)) - unless (or (null c) (string= s1 s2) (string= s2 s3)) - do (incf count) and collect (list c s1 s2 s3) - when (> count 100) collect "count limit exceeded" and do (loop-finish))) - nil) - -(deftest format.a.9 - (with-standard-io-syntax - (apply - #'values - (loop for i from 1 to 10 - for fmt = (format nil "~~~d@a" i) - for s = (format nil fmt nil) - for fn = (eval `(formatter ,fmt)) - for s2 = (formatter-call-to-string fn nil) - do (assert (string= s s2)) - collect s))) - "NIL" - "NIL" - "NIL" - " NIL" - " NIL" - " NIL" - " NIL" - " NIL" - " NIL" - " NIL") - -(deftest format.a.10 - (with-standard-io-syntax - (apply - #'values - (loop for i from 1 to 10 - for fmt = (format nil "~~~da" i) - for s = (format nil fmt nil) - for fn = (eval `(formatter ,fmt)) - for s2 = (formatter-call-to-string fn nil) - do (assert (string= s s2)) - collect s))) - "NIL" - "NIL" - "NIL" - "NIL " - "NIL " - "NIL " - "NIL " - "NIL " - "NIL " - "NIL ") - -(deftest format.a.11 - (with-standard-io-syntax - (apply - #'values - (loop for i from 1 to 10 - for fmt = (format nil "~~~d@:A" i) - for s = (format nil fmt nil) - for fn = (eval `(formatter ,fmt)) - for s2 = (formatter-call-to-string fn nil) - do (assert (string= s s2)) - collect s))) - "()" - "()" - " ()" - " ()" - " ()" - " ()" - " ()" - " ()" - " ()" - " ()") - -(deftest format.a.12 - (with-standard-io-syntax - (apply - #'values - (loop for i from 1 to 10 - for fmt = (format nil "~~~d:a" i) - for s = (format nil fmt nil) - for fn = (eval `(formatter ,fmt)) - for s2 = (formatter-call-to-string fn nil) - do (assert (string= s s2)) - collect s))) - "()" - "()" - "() " - "() " - "() " - "() " - "() " - "() " - "() " - "() ") - -(deftest format.a.13 - (with-standard-io-syntax - (apply - #'values - (let ((fn (formatter "~V:a"))) - (loop for i from 1 to 10 - for s = (format nil "~v:A" i nil) - for s2 = (formatter-call-to-string fn i nil) - do (assert (string= s s2)) - collect s)))) - "()" - "()" - "() " - "() " - "() " - "() " - "() " - "() " - "() " - "() ") - -(deftest format.a.14 - (with-standard-io-syntax - (apply - #'values - (let ((fn (formatter "~V@:A"))) - (loop for i from 1 to 10 - for s = (format nil "~v:@a" i nil) - for s2 = (formatter-call-to-string fn i nil) - do (assert (string= s s2)) - collect s)))) - "()" - "()" - " ()" - " ()" - " ()" - " ()" - " ()" - " ()" - " ()" - " ()") - -(def-format-test format.a.15 - "~vA" (nil nil) "NIL") - -(def-format-test format.a.16 - "~v:A" (nil nil) "()") - -(def-format-test format.a.17 - "~@A" (nil) "NIL") - -(def-format-test format.a.18 - "~v@A" (nil nil) "NIL") - -(def-format-test format.a.19 - "~v:@a" (nil nil) "()") - -(def-format-test format.a.20 - "~v@:a" (nil nil) "()") - -;;; With colinc specified - -(def-format-test format.a.21 - "~3,1a" (nil) "NIL") - -(def-format-test format.a.22 - "~4,3a" (nil) "NIL ") - -(def-format-test format.a.23 - "~3,3@a" (nil) "NIL") - -(def-format-test format.a.24 - "~4,4@a" (nil) " NIL") - -(def-format-test format.a.25 - "~5,3@a" (nil) " NIL") - -(def-format-test format.a.26 - "~5,3A" (nil) "NIL ") - -(def-format-test format.a.27 - "~7,3@a" (nil) " NIL") - -(def-format-test format.a.28 - "~7,3A" (nil) "NIL ") - -;;; With minpad - -(deftest format.a.29 - (let ((fn (formatter "~v,,2A"))) - (loop for i from -4 to 10 - for s = (format nil "~v,,2A" i "ABC") - for s2 = (formatter-call-to-string fn i "ABC") - do (assert (string= s s2)) - collect s)) - ("ABC " - "ABC " - "ABC " - "ABC " - "ABC " - "ABC " - "ABC " - "ABC " - "ABC " - "ABC " - "ABC " - "ABC " - "ABC " - "ABC " - "ABC ")) - -(def-format-test format.a.30 - "~3,,+2A" ("ABC") "ABC ") - -(def-format-test format.a.31 - "~3,,0A" ("ABC") "ABC") - -(def-format-test format.a.32 - "~3,,-1A" ("ABC") "ABC") - -(def-format-test format.a.33 - "~3,,0A" ("ABCD") "ABCD") - -(def-format-test format.a.34 - "~3,,-1A" ("ABCD") "ABCD") - -;;; With padchar - -(def-format-test format.a.35 - "~4,,,'XA" ("AB") "ABXX") - -(def-format-test format.a.36 - "~4,,,a" ("AB") "AB ") - -(def-format-test format.a.37 - "~4,,,'X@a" ("AB") "XXAB") - -(def-format-test format.a.38 - "~4,,,@A" ("AB") " AB") - -(def-format-test format.a.39 - "~10,,,vA" (nil "abcde") "abcde ") - -(def-format-test format.a.40 - "~10,,,v@A" (nil "abcde") " abcde") - -(def-format-test format.a.41 - "~10,,,va" (#\* "abcde") "abcde*****") - -(def-format-test format.a.42 - "~10,,,v@a" (#\* "abcde") "*****abcde") - -;;; Other tests - -(def-format-test format.a.43 - "~3,,vA" (nil "ABC") "ABC") - -(deftest format.a.44 - (let ((fn (formatter "~3,,vA"))) - (loop for i from 0 to 6 - for s =(format nil "~3,,vA" i "ABC") - for s2 = (formatter-call-to-string fn i "ABC") - do (assert (string= s s2)) - collect s)) - ("ABC" - "ABC " - "ABC " - "ABC " - "ABC " - "ABC " - "ABC ")) - -(deftest format.a.44a - (let ((fn (formatter "~3,,v@A"))) - (loop for i from 0 to 6 - for s = (format nil "~3,,v@A" i "ABC") - for s2 = (formatter-call-to-string fn i "ABC") - do (assert (string= s s2)) - collect s)) - ("ABC" - " ABC" - " ABC" - " ABC" - " ABC" - " ABC" - " ABC")) - -(def-format-test format.a.45 - "~4,,va" (-1 "abcd") "abcd") - -(def-format-test format.a.46 - "~5,vA" (nil "abc") "abc ") - -(def-format-test format.a.47 - "~5,vA" (3 "abc") "abc ") - -(def-format-test format.a.48 - "~5,v@A" (3 "abc") " abc") - -;;; # parameters - -(def-format-test format.a.49 - "~#A" ("abc" nil nil nil) "abc " 3) - -(def-format-test format.a.50 - "~#@a" ("abc" nil nil nil nil nil) " abc" 5) - -(def-format-test format.a.51 - "~5,#a" ("abc" nil nil nil) "abc " 3) - -(def-format-test format.a.52 - "~5,#@A" ("abc" nil nil nil) " abc" 3) - -(def-format-test format.a.53 - "~4,#A" ("abc" nil nil) "abc " 2) - -(def-format-test format.a.54 - "~4,#@A" ("abc" nil nil) " abc" 2) - -(def-format-test format.a.55 - "~#,#A" ("abc" nil nil nil) "abc " 3) - -(def-format-test format.a.56 - "~#,#@A" ("abc" nil nil nil) " abc" 3) - -(def-format-test format.a.57 - "~-100A" ("xyz") "xyz") - -(def-format-test format.a.58 - "~-100000000000000000000a" ("xyz") "xyz") diff --git a/t/ansi-test/printer/format/format-ampersand.lsp b/t/ansi-test/printer/format/format-ampersand.lsp deleted file mode 100644 index be520b9..0000000 --- a/t/ansi-test/printer/format/format-ampersand.lsp +++ /dev/null @@ -1,116 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Jul 27 23:52:20 2004 -;;;; Contains: Tests of format with ~& directive - - - - -(def-format-test format.&.1 - "~0&" nil "") - -(def-format-test format.&.2 - "~&" nil "") - -(def-format-test format.&.3 - "X~&" nil #.(concatenate 'string "X" (string #\Newline))) - -(def-format-test format.&.4 - "X~%~&" nil #.(concatenate 'string "X" (string #\Newline))) - -(deftest format.&.5 - (loop for i from 1 to 100 - for s1 = (make-string (1- i) :initial-element #\Newline) - for format-string = (format nil "~~~D&" i) - for s2 = (format nil format-string) - unless (string= s1 s2) - collect i) - nil) - -(deftest formatter.&.5 - (loop for i from 1 to 100 - for s1 = (make-string (1- i) :initial-element #\Newline) - for format-string = (format nil "~~~D&" i) - for fn = (eval `(formatter ,format-string)) - for s2 = (formatter-call-to-string fn) - unless (string= s1 s2) - collect i) - nil) - -(deftest format.&.6 - (loop for i from 1 to 100 - for s1 = (concatenate 'string - "X" - (make-string i :initial-element #\Newline)) - for format-string = (format nil "X~~~D&" i) - for s2 = (format nil format-string) - unless (string= s1 s2) - collect i) - nil) - -(deftest formatter.&.6 - (loop for i from 1 to 100 - for s1 = (concatenate 'string - "X" - (make-string i :initial-element #\Newline)) - for format-string = (format nil "X~~~D&" i) - for fn = (eval `(formatter ,format-string)) - for s2 = (formatter-call-to-string fn) - unless (string= s1 s2) - collect i) - nil) - -(def-format-test format.&.7 - "~v&" (nil) "") - -(def-format-test format.&.8 - "X~v&" (nil) #.(concatenate 'string "X" (string #\Newline))) - -(deftest format.&.9 - (loop for i from 1 to 100 - for s1 = (make-string (1- i) :initial-element #\Newline) - for s2 = (format nil "~V&" i) - unless (string= s1 s2) - collect i) - nil) - -(deftest formatter.&.9 - (let ((fn (formatter "~V&"))) - (loop for i from 1 to 100 - for s1 = (make-string (1- i) :initial-element #\Newline) - for s2 = (formatter-call-to-string fn i) - unless (string= s1 s2) - collect i)) - nil) - -(deftest format.&.10 - (loop for i from 1 to (min (- call-arguments-limit 3) 100) - for s1 = (make-string (1- i) :initial-element #\Newline) - for args = (make-list i) - for s2 = (apply #'format nil "~#&" args) - unless (string= s1 s2) - collect i) - nil) - -(deftest formatter.&.10 - (let ((fn (formatter "~#&"))) - (loop for i from 1 to (min (- call-arguments-limit 3) 100) - for s1 = (make-string (1- i) :initial-element #\Newline) - for args = (loop for j below i collect j) - for s2 = (with-output-to-string - (stream) - (assert (equal (apply fn stream args) args))) - unless (string= s1 s2) - collect i)) - nil) - -(def-format-test format.&.11 - "X~V%" (0) "X") - -(def-format-test format.&.12 - "X~#%" nil "X") - -(def-format-test format.&.13 - "X~#%" ('a 'b 'c) #.(let ((nl (string #\Newline))) - (concatenate 'string "X" nl nl nl)) - 3) diff --git a/t/ansi-test/printer/format/format-b.lsp b/t/ansi-test/printer/format/format-b.lsp deleted file mode 100644 index 112681e..0000000 --- a/t/ansi-test/printer/format/format-b.lsp +++ /dev/null @@ -1,535 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Aug 1 05:10:10 2004 -;;;; Contains: Tests of the ~B format directive - - - - - -(deftest format.b.1 - (let ((fn (formatter "~b"))) - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~B" i) - for s2 = (formatter-call-to-string fn i) - for j = (let ((*read-base* 2)) (read-from-string s1)) - repeat 1000 - when (or (not (string= s1 s2)) - (/= i j) - (find #\+ s1) - (loop for c across s1 thereis (not (find c "-01")))) - collect (list i s1 j s2)))) - nil) - -(deftest format.b.2 - (let ((fn (formatter "~@b"))) - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~@b" i) - for s2 = (formatter-call-to-string fn i) - for j = (let ((*read-base* 2)) (read-from-string s1)) - repeat 1000 - when (or (/= i j) - (not (string= s1 s2)) - (loop for c across s1 thereis (not (find c "-+01")))) - collect (list i s1 j s2)))) - nil) - -(deftest format.b.3 - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~b" i) - for fmt = (format nil "~~~db" mincol) - for s2 = (format nil fmt i) - for pos = (search s1 s2) - repeat 1000 - when (or (null pos) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (not (eql (position #\Space s2 :test-not #'eql) - (- (length s2) (length s1))))))) - collect (list i mincol s1 s2 pos))) - nil) - -(deftest formatter.b.3 - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~b" i) - for fmt = (format nil "~~~db" mincol) - for fn = (eval `(formatter ,fmt)) - for s2 = (formatter-call-to-string fn i) - for pos = (search s1 s2) - repeat 100 - when (or (null pos) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (not (eql (position #\Space s2 :test-not #'eql) - (- (length s2) (length s1))))))) - collect (list i mincol s1 s2 pos))) - nil) - -(deftest format.b.4 - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~@B" i) - for fmt = (format nil "~~~d@b" mincol) - for s2 = (format nil fmt i) - for pos = (search s1 s2) - repeat 1000 - when (or (null pos) - (and (>= i 0) (not (eql (elt s1 0) #\+))) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (not (eql (position #\Space s2 :test-not #'eql) - (- (length s2) (length s1))))))) - collect (list i mincol s1 s2 pos))) - nil) - -(deftest formatter.b.4 - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~@B" i) - for fmt = (format nil "~~~d@b" mincol) - for fn = (eval `(formatter ,fmt)) - for s2 = (formatter-call-to-string fn i) - for pos = (search s1 s2) - repeat 100 - when (or (null pos) - (and (>= i 0) (not (eql (elt s1 0) #\+))) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (not (eql (position #\Space s2 :test-not #'eql) - (- (length s2) (length s1))))))) - collect (list i mincol s1 s2 pos))) - nil) - -(deftest format.b.5 - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for padchar = (random-from-seq +standard-chars+) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~b" i) - for fmt = (format nil "~~~d,'~c~c" mincol padchar - (random-from-seq "bB")) - for s2 = (format nil fmt i) - for pos = (search s1 s2) - repeat 1000 - when (or (null pos) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (find padchar s2 :end (- (length s2) (length s1)) - :test-not #'eql)))) - collect (list i mincol s1 s2 pos))) - nil) - -(deftest formatter.b.5 - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for padchar = (random-from-seq +standard-chars+) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~b" i) - for fmt = (format nil "~~~d,'~c~c" mincol padchar - (random-from-seq "bB")) - for fn = (eval `(formatter ,fmt)) - for s2 = (formatter-call-to-string fn i) - for pos = (search s1 s2) - repeat 100 - when (or (null pos) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (find padchar s2 :end (- (length s2) (length s1)) - :test-not #'eql)))) - collect (list i mincol s1 s2 pos))) - nil) - -(deftest format.b.6 - (let ((fn (formatter "~v,vB"))) - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for padchar = (random-from-seq +standard-chars+) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~b" i) - for s2 = (format nil "~v,vb" mincol padchar i) - for s3 = (formatter-call-to-string fn mincol padchar i) - for pos = (search s1 s2) - repeat 1000 - when (or (null pos) - (not (string= s2 s3)) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (find padchar s2 :end (- (length s2) (length s1)) - :test-not #'eql)))) - collect (list i mincol s1 s2 s3 pos)))) - nil) - -(deftest format.b.7 - (let ((fn (formatter "~v,v@B"))) - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for padchar = (random-from-seq +standard-chars+) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~@B" i) - for s2 = (format nil "~v,v@b" mincol padchar i) - for s3 = (formatter-call-to-string fn mincol padchar i) - for pos = (search s1 s2) - repeat 1000 - when (or (null pos) - (not (string= s2 s3)) - (and (>= i 0) (not (eql (elt s1 0) #\+))) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (find padchar s2 :end (- (length s2) (length s1)) - :test-not #'eql)))) - collect (list i mincol s1 s2 s3 pos)))) - nil) - -;;; Comma tests - -(deftest format.b.8 - (let ((fn (formatter "~:B"))) - (loop for i from -7 to 7 - for s1 = (format nil "~b" i) - for s2 = (format nil "~:b" i) - for s3 = (formatter-call-to-string fn i) - unless (and (string= s1 s2) (string= s2 s3)) - collect (list i s1 s2 s3))) - nil) - -(deftest format.b.9 - (let ((fn (formatter "~:b"))) - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = #\, - for s1 = (format nil "~b" i) - for s2 = (format nil "~:B" i) - for s3 = (formatter-call-to-string fn i) - repeat 1000 - unless (and (string= s1 (remove commachar s2)) - (string= s2 s3) - (not (eql (elt s2 0) commachar)) - (or (>= i 0) (not (eql (elt s2 1) commachar))) - (let ((len (length s2)) - (ci+1 4)) - (loop for i from (if (< i 0) 2 1) below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (find (elt s2 i) "01"))))) - collect (list x i commachar s1 s2 s3)))) - nil) - -(deftest format.b.10 - (let ((fn (formatter "~,,v:B"))) - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = (random-from-seq +standard-chars+) - for s1 = (format nil "~b" i) - for s2 = (format nil "~,,v:b" commachar i) - for s3 = (formatter-call-to-string fn commachar i) - repeat 1000 - unless (and - (eql (elt s1 0) (elt s2 0)) - (string= s2 s3) - (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) - (let ((len (length s2)) - (ci+1 4) - (j (if (< i 0) 1 0))) - (loop for i from (if (< i 0) 2 1) below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (eql (elt s1 (incf j)) (elt s2 i)))))) - collect (list x i commachar s1 s2 s3)))) - nil) - -(deftest format.b.11 - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = (random-from-seq +standard-chars+) - for s1 = (format nil "~b" i) - for fmt = (format nil "~~,,'~c:~c" commachar (random-from-seq "bB")) - for s2 = (format nil fmt i) - repeat 1000 - unless (and - (eql (elt s1 0) (elt s2 0)) - (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) - (let ((len (length s2)) - (ci+1 4) - (j (if (< i 0) 1 0))) - (loop for i from (if (< i 0) 2 1) below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (eql (elt s1 (incf j)) (elt s2 i)))))) - collect (list x i commachar s1 s2))) - nil) - -(deftest formatter.b.11 - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = (random-from-seq +standard-chars+) - for s1 = (format nil "~b" i) - for fmt = (format nil "~~,,'~c:~c" commachar (random-from-seq "bB")) - for fn = (eval `(formatter ,fmt)) - for s2 = (formatter-call-to-string fn i) - repeat 100 - unless (and - (eql (elt s1 0) (elt s2 0)) - (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) - (let ((len (length s2)) - (ci+1 4) - (j (if (< i 0) 1 0))) - (loop for i from (if (< i 0) 2 1) below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (eql (elt s1 (incf j)) (elt s2 i)))))) - collect (list x i commachar s1 s2))) - nil) - -(deftest format.b.12 - (let ((fn (formatter "~,,V,V:b"))) - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = (random-from-seq +standard-chars+) - for commaint = (1+ (random 20)) - for s1 = (format nil "~b" i) - for s2 = (format nil "~,,v,v:B" commachar commaint i) - for s3 = (formatter-call-to-string fn commachar commaint i) - repeat 1000 - unless (and - (eql (elt s1 0) (elt s2 0)) - (string= s2 s3) - (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) - (let ((len (length s2)) - (ci+1 (1+ commaint)) - (j (if (< i 0) 1 0))) - (loop for i from (if (< i 0) 2 1) below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (eql (elt s1 (incf j)) (elt s2 i)))))) - collect (list x i commachar s1 s2 s3)))) - nil) - -(deftest format.b.13 - (let ((fn (formatter "~,,V,V@:B"))) - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = (random-from-seq +standard-chars+) - for commaint = (1+ (random 20)) - for s1 = (format nil "~@B" i) - for s2 = (format nil "~,,v,v:@b" commachar commaint i) - for s3 = (formatter-call-to-string fn commachar commaint i) - repeat 1000 - unless (and - (string= s2 s3) - (eql (elt s1 0) (elt s2 0)) - (eql (elt s1 1) (elt s2 1)) - (let ((len (length s2)) - (ci+1 (1+ commaint)) - (j 1)) - (loop for i from 2 below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (eql (elt s1 (incf j)) (elt s2 i)))))) - collect (list x i commachar s1 s2 s3)))) - nil) - -;;; NIL arguments - -(def-format-test format.b.14 - "~vb" (nil #b110100) "110100") - -(def-format-test format.b.15 - "~6,vB" (nil #b100) " 100") - -(def-format-test format.b.16 - "~,,v:b" (nil #b10011) "10,011") - -(def-format-test format.b.17 - "~,,'*,v:B" (nil #b10110) "10*110") - -;;; When the argument is not an integer, print as if using ~A and base 10 - -(deftest format.b.18 - (let ((fn (formatter "~b"))) - (loop for x in *mini-universe* - for s1 = (format nil "~b" x) - for s2 = (let ((*print-base* 2)) (format nil "~A" x)) - for s3 = (formatter-call-to-string fn x) - unless (or (integerp x) (and (string= s1 s2) (string= s1 s3))) - collect (list x s1 s2 s3))) - nil) - -(deftest format.b.19 - (let ((fn (formatter "~:b"))) - (loop for x in *mini-universe* - for s1 = (format nil "~:B" x) - for s2 = (let ((*print-base* 2)) (format nil "~A" x)) - for s3 = (formatter-call-to-string fn x) - unless (or (integerp x) (and (string= s1 s2) (string= s1 s3))) - collect (list x s1 s2 s3))) - nil) - -(deftest format.b.20 - (let ((fn (formatter "~@b"))) - (loop for x in *mini-universe* - for s1 = (format nil "~@b" x) - for s2 = (let ((*print-base* 2)) (format nil "~A" x)) - for s3 = (formatter-call-to-string fn x) - unless (or (integerp x) (and (string= s1 s2) (string= s1 s3))) - collect (list x s1 s2 s3))) - nil) - -(deftest format.b.21 - (let ((fn (formatter "~:@b"))) - (loop for x in *mini-universe* - for s1 = (let ((*print-base* 2)) (format nil "~A" x)) - for s2 = (format nil "~@:B" x) - for s3 = (formatter-call-to-string fn x) - for s4 = (let ((*print-base* 2)) (format nil "~A" x)) - unless (or (integerp x) (and (string= s1 s2) (string= s1 s3)) - (string/= s1 s4)) - collect (list x s1 s2 s3))) - nil) - -;;; Must add tests for non-integers when the parameters -;;; are specified, but it's not clear what the meaning is. -;;; Does mincol apply to the ~A equivalent? What about padchar? -;;; Are comma-char and comma-interval always ignored? - -;;; # arguments - -(deftest format.b.22 - (apply - #'values - (let ((fn (formatter "~#B")) - (bv #b11001)) - (loop for i from 0 to 10 - for args = (make-list i) - for s = (apply #'format nil "~#b" bv args) - for s2 = (with-output-to-string - (stream) - (assert (equal (apply fn stream bv args) args))) - do (assert (string= s s2)) - collect s))) - "11001" - "11001" - "11001" - "11001" - "11001" - " 11001" - " 11001" - " 11001" - " 11001" - " 11001" - " 11001") - -(deftest format.b.23 - (apply - #'values - (let ((fn (formatter "~,,,#:b")) - (bv #b1100100010)) - (loop for i from 0 to 10 - for args = (make-list i) - for s = (apply #'format nil "~,,,#:B" bv args) - for s2 = (with-output-to-string - (stream) - (assert (equal (apply fn stream bv args) args))) - do (assert (string= s s2)) - collect s))) - "1,1,0,0,1,0,0,0,1,0" - "11,00,10,00,10" - "1,100,100,010" - "11,0010,0010" - "11001,00010" - "1100,100010" - "110,0100010" - "11,00100010" - "1,100100010" - "1100100010" - "1100100010") - -(deftest format.b.24 - (apply - #'values - (let ((fn (formatter "~,,,#@:B")) - (bv #b1100100010)) - (loop for i from 0 to 10 - for args = (make-list i) - for s = (apply #'format nil "~,,,#@:B" bv args) - for s2 = (with-output-to-string - (stream) - (assert (equal (apply fn stream bv args) args))) - do (assert (string= s s2)) - collect s))) - "+1,1,0,0,1,0,0,0,1,0" - "+11,00,10,00,10" - "+1,100,100,010" - "+11,0010,0010" - "+11001,00010" - "+1100,100010" - "+110,0100010" - "+11,00100010" - "+1,100100010" - "+1100100010" - "+1100100010") - -(def-format-test format.b.25 - "~+10b" (#b1101) " 1101") - -(def-format-test format.b.26 - "~+10@B" (#b1101) " +1101") - -(def-format-test format.b.27 - "~-1b" (#b1101) "1101") - -(def-format-test format.b.28 - "~-1000000000000000000B" (#b1101) "1101") - -(def-format-test format.b.29 - "~vb" ((1- most-negative-fixnum) #b1101) "1101") - -;;; Randomized test - -(deftest format.b.30 - (let ((fn (formatter "~V,V,V,VB"))) - (loop - for mincol = (and (coin) (random 50)) - for padchar = (and (coin) - (random-from-seq +standard-chars+)) - for commachar = (and (coin) - (random-from-seq +standard-chars+)) - for commaint = (and (coin) (1+ (random 10))) - for k = (ash 1 (+ 2 (random 30))) - for x = (- (random (+ k k)) k) - for fmt = (concatenate - 'string - (if mincol (format nil "~~~d," mincol) "~,") - (if padchar (format nil "'~c," padchar) ",") - (if commachar (format nil "'~c," commachar) ",") - (if commaint (format nil "~db" commaint) "b")) - for s1 = (format nil fmt x) - for s2 = (format nil "~v,v,v,vb" mincol padchar commachar commaint x) - for s3 = (formatter-call-to-string fn mincol padchar commachar commaint x) - repeat 2000 - unless (and (string= s1 s2) (string= s2 s3)) - collect (list mincol padchar commachar commaint fmt x s1 s2))) - nil) diff --git a/t/ansi-test/printer/format/format-brace.lsp b/t/ansi-test/printer/format/format-brace.lsp deleted file mode 100644 index 1a86acc..0000000 --- a/t/ansi-test/printer/format/format-brace.lsp +++ /dev/null @@ -1,368 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Aug 25 22:08:51 2004 -;;;; Contains: Tests of the ~"{ ... ~} format directives - - - - - -(def-format-test format.{.1 - (concatenate 'string "~{~" (string #\Newline) "~}") - (nil) "") - -(def-format-test format.{.1a - "~{~}" ("" nil) "") - -(def-format-test format.{.1b - "~0{~}" ("" '(1 2 3)) "") - -(def-format-test format.{.2 - "~{ ~}" (nil) "") - -(def-format-test format.{.3 - "~{X Y Z~}" (nil) "") - -(def-format-test format.{.4 - "~{~A~}" ('(1 2 3 4)) "1234") - -(def-format-test format.{.5 - "~{~{~A~}~}" ('((1 2 3)(4 5)(6 7 8))) "12345678") - -(def-format-test format.{.6 - "~{~1{~A~}~}" ('((1 2 3)(4 5)(6 7 8))) "146") - -(def-format-test format.{.7 - (concatenate 'string "~1{~" (string #\Newline) "~}") (nil) "") - -(deftest format.{.8 - (loop for i from 0 to 10 - for s = (format nil "~v{~A~}" i '(1 2 3 4 5 6 7 8 9 0)) - unless (string= s (subseq "1234567890" 0 i)) - collect (list i s)) - nil) - -(deftest formatter.{.8 - (let ((fn (formatter "~V{~A~}"))) - (loop for i from 0 to 10 - for s = (formatter-call-to-string fn i '(1 2 3 4 5 6 7 8 9 0)) - unless (string= s (subseq "1234567890" 0 i)) - collect (list i s))) - nil) - -(def-format-test format.{.9 - "~#{~A~}" ('(1 2 3 4 5 6 7) nil nil nil) "1234" 3) - -;;; (missing tests involved ~^ and have been moved to format-circumflex.lsp -;;; and renamed.) - -(def-format-test format.{.15 - "~0{~}" ("~A" '(1 2 3)) "") - -(def-format-test format.{.16 - "~1{~}" ("~A" '(4 5 6)) "4") - -(deftest format.{.17 - (format nil "~{~}" (formatter "") nil) - "") - -(deftest format.{.18 - (format nil "~1{~}" (formatter "") '(1 2 3 4)) - "") - -(deftest format.{.19 - (format nil "~{~}" (formatter "~A") '(1 2 3 4)) - "1234") - -(deftest format.{.20 - (format nil "~3{~}" (formatter "~A") '(1 2 3 4)) - "123") - -(def-format-test format.{.21 - "~V{~}" (2 "~A" '(1 2 3 4 5)) "12") - -(def-format-test format.{.22 - "~#{~}" ("~A" '(1 2 3 4 5)) "12") - -(def-format-test format.{.23 - "~{FOO~:}" (nil) "FOO") - -(def-format-test format.{.24 - "~{~A~:}" ('(1)) "1") - -(def-format-test format.{.25 - "~{~A~:}" ('(1 2)) "12") - -(def-format-test format.{.26 - "~{~A~:}" ('(1 2 3)) "123") - -(def-format-test format.{.27 - "~0{FOO~:}" (nil) "") - -(def-format-test format.{.28 - "~V{FOO~:}" (0 nil) "") - -(def-format-test format.{.29 - "~1{FOO~:}" (nil) "FOO") - -(def-format-test format.{.30 - "~2{FOO~:}" (nil) "FOO") - -(def-format-test format.{.31 - (concatenate 'string "~2{~" (string #\Newline) "~:}") - (nil) "") - -(def-format-test format.{.32 - "~2{FOO~}" (nil) "") - -(def-format-test format.{.33 - "~v{~a~}" (nil '(1 2 3 4 5 6 7)) "1234567") - -;;; ~:{ ... ~} - -(def-format-test format.\:{.1 - "~:{(~A ~A)~}" ('((1 2 3)(4 5)(6 7 8))) "(1 2)(4 5)(6 7)") - -(def-format-test format.\:{.2 - (concatenate 'string "~:{~" (string #\Newline) "~}") - (nil) "") - -(def-format-test format.\:{.3 - "~:{~}" ("" nil) "") - -(def-format-test format.\:{.4 - "~:{~}" ("~A" nil) "") - -(def-format-test format.\:{.5 - "~:{~}" ("X" '(nil (1 2) (3))) "XXX") - -(deftest format.\:{.6 - (format nil "~:{~}" (formatter "~A") '((1 2) (3) (4 5 6))) - "134") - -(def-format-test format.\:{.7 - "~0:{XYZ~}" ('((1))) "") - -(def-format-test format.\:{.8 - "~2:{XYZ~}" ('((1))) "XYZ") - -(def-format-test format.\:{.9 - "~2:{~A~}" ('((1) (2))) "12") - -(def-format-test format.\:{.10 - "~2:{~A~}" ('((1 X) (2 Y) (3 Z))) "12") - -(deftest format.\:{.11 - (loop for i from 0 to 10 collect - (format nil "~v:{~A~}" i '((1) (2) (3 X) (4 Y Z) (5) (6)))) - ("" "1" "12" "123" "1234" "12345" - "123456" "123456" "123456" "123456" "123456")) - -(deftest formatter.\:{.11 - (let ((fn (formatter "~v:{~A~}"))) - (loop for i from 0 to 10 collect - (formatter-call-to-string fn i '((1) (2) (3 X) (4 Y Z) (5) (6))))) - ("" "1" "12" "123" "1234" "12345" - "123456" "123456" "123456" "123456" "123456")) - -(def-format-test format.\:{.12 - "~V:{X~}" (nil '((1) (2) (3) nil (5))) "XXXXX") - -(def-format-test format.\:{.13 - "~#:{~A~}" ('((1) (2) (3) (4) (5)) 'foo 'bar) "123" 2) - -(def-format-test format.\:{.14 - "~:{~A~:}" ('((1 X) (2 Y) (3) (4 A B))) "1234") - -(deftest format.\:{.15 - (loop for i from 0 to 10 collect - (format nil "~v:{~A~:}" i '((1 X) (2 Y) (3) (4 A B)))) - ("" "1" "12" "123" "1234" "1234" - "1234" "1234" "1234" "1234" "1234")) - -(deftest formatter.\:{.15 - (let ((fn (formatter "~v:{~A~:}"))) - (loop for i from 0 to 10 collect - (formatter-call-to-string fn i '((1 X) (2 Y) (3) (4 A B))))) - ("" "1" "12" "123" "1234" "1234" - "1234" "1234" "1234" "1234" "1234")) - -(def-format-test format.\:{.16 - "~:{ABC~:}" ('(nil)) "ABC") - -(def-format-test format.\:{.17 - "~v:{ABC~:}" (nil '(nil)) "ABC") - - -;;; Tests of ~@{ ... ~} - -(def-format-test format.@{.1 - (concatenate 'string "~@{~" (string #\Newline) "~}") - nil "") - -(def-format-test format.@{.1A - "~@{~}" ("") "") - -(def-format-test format.@{.2 - "~@{ ~}" nil "") - -(def-format-test format.@{.3 - "~@{X ~A Y Z~}" (nil) "X NIL Y Z") - -(def-format-test format.@{.4 - "~@{~A~}" (1 2 3 4) "1234") - -(def-format-test format.@{.5 - "~@{~{~A~}~}" ('(1 2 3) '(4 5) '(6 7 8)) "12345678") - -(def-format-test format.@{.6 - "~@{~1{~A~}~}" ('(1 2 3) '(4 5) '(6 7 8)) "146") - -(def-format-test format.@{.7 - "~1@{FOO~}" nil "") - -(def-format-test format.@{.8 - "~v@{~A~}" (nil 1 4 7) "147") - -(def-format-test format.@{.9 - "~#@{~A~}" (1 2 3) "123") - -(deftest format.@{.10 - (loop for i from 0 to 10 - for x = nil then (cons i x) - collect (apply #'format nil "~v@{~A~}" i (reverse x))) - ("" "1" "12" "123" "1234" "12345" - "123456" "1234567" "12345678" "123456789" "12345678910")) - -(deftest formatter.@{.10 - (let ((fn (formatter "~v@{~A~}"))) - (loop for i from 0 to 10 - for x = nil then (cons i x) - for rest = (list 'a 'b 'c) - collect - (with-output-to-string - (s) - (assert (equal (apply fn s i (append (reverse x) rest)) rest))))) - ("" "1" "12" "123" "1234" "12345" - "123456" "1234567" "12345678" "123456789" "12345678910")) - -(def-format-test format.@{.11 - "~@{X~:}" nil "X") - -(def-format-test format.@{.12 - "~@{~}" ((formatter "X~AY") 1) "X1Y") - -(def-format-test format.@{.13 - "~v@{~}" (1 (formatter "X") 'foo) "X" 1) - -;;; ~:@{ - -(def-format-test format.\:@{.1 - (concatenate 'string "~:@{~" (string #\Newline) "~}") - nil "") - -(def-format-test format.\:@{.2 - "~:@{~A~}" ('(1 2) '(3) '(4 5 6)) "134") - -(def-format-test format.\:@{.3 - "~:@{(~A ~A)~}" ('(1 2 4) '(3 7) '(4 5 6)) "(1 2)(3 7)(4 5)") - -(def-format-test format.\:@{.4 - "~:@{~}" ("(~A ~A)" '(1 2 4) '(3 7) '(4 5 6)) "(1 2)(3 7)(4 5)") - -(def-format-test format.\:@{.5 - "~:@{~}" ((formatter "(~A ~A)") '(1 2 4) '(3 7) '(4 5 6)) "(1 2)(3 7)(4 5)") - -(def-format-test format.\:@.6 - "~:@{~A~:}" ('(1 A) '(2 B) '(3) '(4 C D)) "1234") - -(def-format-test format.\:@.7 - "~0:@{~A~:}" ('(1 A) '(2 B) '(3) '(4 C D)) "" 4) - -(def-format-test format.\:@.8 - "~#:@{A~:}" (nil nil nil) "AAA") - -(def-format-test format.\:@.9 - "~v:@{~A~}" (nil '(1) '(2) '(3)) "123") - -(deftest format.\:@.10 - (loop for i from 0 to 10 - for x = nil then (cons (list i) x) - collect - (apply #'format nil "~V:@{~A~}" i (reverse x))) - ("" "1" "12" "123" "1234" "12345" "123456" "1234567" "12345678" - "123456789" "12345678910")) - -(deftest formatter.\:@.10 - (let ((fn (formatter "~V@:{~A~}"))) - (loop for i from 0 to 10 - for x = nil then (cons (list i) x) - for rest = (list 'a 'b) - collect - (with-output-to-string - (s) - (assert (equal (apply fn s i (append (reverse x) rest)) rest))))) - ("" "1" "12" "123" "1234" "12345" "123456" "1234567" "12345678" - "123456789" "12345678910")) - -;;; Error tests - -(deftest format.{.error.1 - (signals-type-error x 'A (format nil "~{~A~}" x)) - t) - -(deftest format.{.error.2 - (signals-type-error x 1 (format nil "~{~A~}" x)) - t) - -(deftest format.{.error.3 - (signals-type-error x "foo" (format nil "~{~A~}" x)) - t) - -(deftest format.{.error.4 - (signals-type-error x #*01101 (format nil "~{~A~}" x)) - t) - -(deftest format.{.error.5 - (signals-error (format nil "~{~A~}" '(x y . z)) type-error) - t) - -(deftest format.\:{.error.1 - (signals-error (format nil "~:{~A~}" '(x)) type-error) - t) - -(deftest format.\:{.error.2 - (signals-type-error x 'x (format nil "~:{~A~}" x)) - t) - -(deftest format.\:{.error.3 - (signals-error (format nil "~:{~A~}" '((x) . y)) type-error) - t) - -(deftest format.\:{.error.4 - (signals-error (format nil "~:{~A~}" '("X")) type-error) - t) - -(deftest format.\:{.error.5 - (signals-error (format nil "~:{~A~}" '(#(X Y Z))) type-error) - t) - -(deftest format.\:@{.error.1 - (signals-type-error x 'x (format nil "~:@{~A~}" x)) - t) - -(deftest format.\:@{.error.2 - (signals-type-error x 0 (format nil "~:@{~A~}" x)) - t) - -(deftest format.\:@{.error.3 - (signals-type-error x #*01101 (format nil "~:@{~A~}" x)) - t) - -(deftest format.\:@{.error.4 - (signals-type-error x "abc" (format nil "~:@{~A~}" x)) - t) - -(deftest format.\:@{.error.5 - (signals-error (format nil "~:@{~A ~A~}" '(x . y)) type-error) - t) diff --git a/t/ansi-test/printer/format/format-c.lsp b/t/ansi-test/printer/format/format-c.lsp deleted file mode 100644 index 4d2a8cc..0000000 --- a/t/ansi-test/printer/format/format-c.lsp +++ /dev/null @@ -1,117 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Jul 27 23:07:16 2004 -;;;; Contains: Tests of formatted output, ~C directive - - - - - -;;; Test of the ~C directive - -(deftest format.c.1 - (loop for c across +standard-chars+ - for s = (format nil "~C" c) - unless (string= s (string c)) - collect (list c s)) - nil) - -(deftest format.c.1a - (loop with count = 0 - for i from 0 below (min #x10000 char-code-limit) - for c = (code-char i) - for s = (and c (format nil "~c" c)) - unless (or (not c) - (not (eql (char-code c) (char-int c))) - (string= s (string c))) - do (incf count) and collect (list i c s) - when (> count 100) collect "count limit exceeded" and do (loop-finish)) - nil) - -(deftest format.c.2 - (loop for c across +standard-chars+ - for s = (format nil "~:c" c) - unless (or (not (graphic-char-p c)) - (eql c #\Space) - (string= s (string c))) - collect (list c s)) - nil) - -(deftest format.c.2a - (loop with count = 0 - for i from 0 below (min #x10000 char-code-limit) - for c = (code-char i) - for s = (and c (format nil "~:C" c)) - unless (or (not c) - (not (eql (char-code c) (char-int c))) - (not (graphic-char-p c)) - (eql c #\Space) - (string= s (string c))) - do (incf count) and collect (list i c s) - when (> count 100) collect "count limit exceeded" and do (loop-finish)) - nil) - -(def-format-test format.c.3 - "~:C" (#\Space) #.(char-name #\Space)) - -(deftest format.c.4 - (loop for c across +standard-chars+ - for s = (format nil "~:C" c) - unless (or (graphic-char-p c) - (string= s (char-name c))) - collect (list c (char-name c) s)) - nil) - -(deftest format.c.4a - (loop with count = 0 - for i from 0 below (min #x10000 char-code-limit) - for c = (code-char i) - for s = (and c (format nil "~:c" c)) - unless (or (not c) - (not (eql (char-code c) (char-int c))) - (graphic-char-p c) - (string= s (char-name c))) - do (incf count) and collect (print (list i c s)) - when (> count 100) collect "count limit exceeded" and do (loop-finish)) - nil) - -(deftest format.c.5 - (loop for c across +standard-chars+ - for s = (format nil "~@c" c) - for c2 = (read-from-string s) - unless (eql c c2) - collect (list c s c2)) - nil) - -(deftest format.c.5a - (loop with count = 0 - for i from 0 below (min #x10000 char-code-limit) - for c = (code-char i) - for s = (and c (format nil "~@C" c)) - for c2 = (and c (read-from-string s)) - unless (eql c c2) - do (incf count) and collect (list c s c2) - when (> count 100) collect "count limit exceeded" and do (loop-finish)) - nil) - -(deftest format.c.6 - (loop for c across +standard-chars+ - for s1 = (format nil "~:C" c) - for s2 = (format nil "~:@C" c) - unless (eql (search s1 s2) 0) - collect (list c s1 s2)) - nil) - -(deftest format.c.6a - (loop with count = 0 - for i from 0 below (min #x10000 char-code-limit) - for c = (code-char i) - for s1 = (and c (format nil "~:C" c)) - for s2 = (and c (format nil "~@:C" c)) - unless (or (not c) (eql (search s1 s2) 0)) - do (incf count) and collect (list c s1 s2) - when (> count 100) collect "count limit exceeded" and do (loop-finish)) - nil) - - - diff --git a/t/ansi-test/printer/format/format-circumflex.lsp b/t/ansi-test/printer/format/format-circumflex.lsp deleted file mode 100644 index 00bd625..0000000 --- a/t/ansi-test/printer/format/format-circumflex.lsp +++ /dev/null @@ -1,830 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Nov 11 20:17:51 2004 -;;;; Contains: Tests of the ~^ format directive (inside other format constructs) - - - - -;;; Tests of ~^ inside ~{ ... ~} - -(def-format-test format.^.{.1 - "~{X ~A~^ Y ~A~^ ~}" ('(1 2 3 4 5)) "X 1 Y 2 X 3 Y 4 X 5") - -(def-format-test format.^.{.2 - "~{X ~A~^ Y ~A~^ ~}" ('(1 2 3 4)) "X 1 Y 2 X 3 Y 4") - -(def-format-test format.^.{.3 - "~1{~A~^~A~}" ('(1)) "1") - -(def-format-test format.^.{.4 - "~0{~A~^~A~}" ('(1)) "") - -(def-format-test format.^.{.5 - "~1{~A~^~A~}" ('(1 2 3)) "12") - -(def-format-test format.^.{.6 - "~{~A~A~0^~A~}" ('(1 2 3 4 5 6)) "12") - -(def-format-test format.^.{.7 - "~{~A~A~v^~A~}" ('(1 2 3 4 5 6 0 7 8 9 10 11 12)) "12456") - -(def-format-test format.^.{.8 - "~{~#,3^~A~}" ('(1 2 3 4 5 6 7 8 9 10)) "1234567") - -(def-format-test format.^.{.9 - "~{~2,#^~A~}~A" ('(1 2 3 4 5 6 7 8 9 10) 0) "123456780") - -(def-format-test format.^.{.10 - "~{~#,#^~A~}" ('(1 2 3 4 5 6 7 8 9 10)) "") - -(def-format-test format.^.{.11 - "~{~#,#,#^~A~}" ('(1 2 3 4 5 6 7 8 9 10)) "") - -(def-format-test format.^.{.12 - "~{~#,1,2^~A~}" ('(1 2 3 4 5 6 7 8 9 10)) "123456789") - -(def-format-test format.^.{.13 - "~{~#,#,v^~A~}" ('(1 2 3 4 5 6 7 8 9 10)) "246") - -(def-format-test format.^.{.14 - "~{~#,#,v^~A~}" ('(1 2 3 4 5 6 7 8 9 10 11)) "246") - -(def-format-test format.^.{.15 - "~{~#,#,v^~A~}" ('(1 2 3 4 5 6 7 8 9 10 11 12)) "246") - -(def-format-test format.^.{.16 - "~{~#,#,v^~A~}" ('(1 2 3 4 5 6 7 8 9 10 11 12 13)) "246") - -(def-format-test format.^.{.17 - "~{~#,#,v^~A~}" ('(1 2 3 4 5 6 7 8 9 10 11 12 13 14)) "2468") - -(def-format-test format.^.{.18 - "~{~v,v^~A~}" ((list (1+ most-positive-fixnum) - (1+ most-positive-fixnum) - 1)) - "") - -(def-format-test format.^.{.19 - "~{~0,v,v^~A~}" ((list (1+ most-positive-fixnum) - (1+ most-positive-fixnum) - 1)) - "") - -(def-format-test format.^.{.20 - "~{~0,v,v^~A~}" ((list (1+ most-positive-fixnum) - most-positive-fixnum - 1)) - "1") - -(def-format-test format.^.{.21 - "~{~1,v^~A~}" ('(nil 8 nil 7 0 6 1 5)) "876") - -(def-format-test format.^.{.22 - "~{~0,v^~A~}" ('(3 8 1 7 3 6 nil 5)) "876") - -(def-format-test format.^.{.23 - "~{~1,2,v^~A~}" ('(0 1 0 2 0 3 3 4)) "123") - -(def-format-test format.^.{.24 - "~{~1,2,v^~A~}" ('(0 1 0 2 0 3 nil 4)) "1234") - -(def-format-test format.^.{.25 - "~{~1,1,v^~A~}" ('(0 1 0 2 0 3 nil 4)) "123") - -(def-format-test format.^.{.26 - "~{~'X^~A~}" ('(1 2 3)) "123") - -(def-format-test format.^.{.27 - "~{~v,'X^~A~}" ('(0 1 #\x 2 nil 3 #\X 4 0 5)) "123") - -(def-format-test format.^.{.28 - "~{~'X,v^~A~}" ('(0 1 #\x 2 nil 3 #\X 4 0 5)) "123") - -(def-format-test format.^.{.29 - "~{~v,v^~A~}" ('(0 2 1 #\x #\X 2 5 #\X 3 #\y #\y 4 1 2 5)) "123") - -(def-format-test format.^.{.30 - "~{~',,',^~A~}" ('(1 2 3)) "") - -(def-format-test format.^.{.31 - "~{~1,v,v^~A~}" ('(#\a nil 0)) "0") - -(def-format-test format.^.{.32 - "~{~v,1,v^~A~}" ('(#\a nil 0)) "0") - -(def-format-test format.^.{.33 - "~{~v,v,v^~A~}" ('(#\a #\a nil 0)) "") - -;;; ~^ with ~:{ - -(def-format-test format.^.\:{.1 - "~:{~A~^~A~A~}" ('((1)(2 3 4)(5 6 7 8))) "1234567") - -(def-format-test format.^.\:{.2 - "~:{~A~0^~A~A~}" ('((1)(2 3 4)(5 6 7 8))) "125") - -(def-format-test format.^.\:{.3 - "~:{~#^~A~}" ('((1)(2 3 4)()(5 6 7 8))()) "125" 1) - -(def-format-test format.^.\:{.4 - "~:{~#^~A~#^~A~#^~A~#^~A~}" ('((1)(2 3 4)()(5 6 7 8))()) "12345678" 1) - -(def-format-test format.^.\:{.5 - "~:{~v^~A~}" ('((1 2 3)(0)(2 4)(0 5)(1 6 7 8))) "246") - -(def-format-test format.^.\:{.6 - "~:{~v^~A~}" ('((nil)(nil 1)(1 2))) "12") - -(def-format-test format.^.\:{.7 - "~:{~v^~A~}" ('((#\x 1)(#\y 2)(0 3)(1 4))) "124") - -(def-format-test format.^.\:{.8 - "~:{~v,3^~A~}" ('((1 1)(2 0)(3 4)(5 6))) "106") - -(def-format-test format.^.\:{.9 - "~:{~3,v^~A~}" ('((1 1)(2 0)(3 4)(5 6))) "106") - -(def-format-test format.^.\:{.10 - "~:{~v,3^~A~}" ('((#\x 1))) "1") - -(def-format-test format.^.\:{.11 - "~:{~2,v^~A~}" ('((#\x 1))) "1") - -(def-format-test format.^.\:{.12 - "~:{~v,v^~A~}" ('((1 2 0) (0 1 1) (1 0 2) (3 3 5) (4 5 6))) "0126") - -(def-format-test format.^.\:{.13 - "~:{~v,v^~A~}" ('((1 2 0) (#\a #\A 1) (#\A #\A 2) (1 2 3))) "013") - -(def-format-test format.^.\:{.14 - "~:{~'x,3^~A~}" ('((1))) "1") - -(def-format-test format.^.\:{.15 - "~:{~3,'x^~A~}" ('((1))) "1") - -(def-format-test format.^.\:{.16 - "~:{~'x,'x^~A~}" ('((1))) "") - -(def-format-test format.^.\:{.17 - "~:{~#,1^~A~}" ('((1)(2 10)(3 a b)(4)(5 x)(6)(7 8))) "2357") - -(def-format-test format.^.\:{.18 - "~:{~1,#^~A~}" ('((1)(2 10)(3 a b)(4)(5 x)(6)(7 8))) "2357") - -(def-format-test format.^.\:{.19 - "~:{~#,#^~A~}" ('((1)()(2 10)(3 a b)(4)(5 x)(6)(7 8))) "") - -(def-format-test format.^.\:{.20 - "~:{~0,v^~A~}" ('((0 1)(1 2)(nil 3)(2 4))) "24") - -(def-format-test format.^.\:{.21 - "~:{~1,v^~A~}" ('((0 1)(1 2)(nil 3)(2 4))) "134") - -(def-format-test format.^.\:{.22 - "~:{~1,1,1^~A~}" ('((1)(2 3)(4 5 6)(7 8 9 0))) "") - -(def-format-test format.^.\:{.23 - "~:{~1,2,3^~A~}" ('((1)(2 3)(4 5 6)(7 8 9 0))) "") - -(def-format-test format.^.\:{.24 - "~:{~1,2,1^~A~}" ('((1)(2 3)(4 5 6)(7 8 9 0))) "1247") - -(def-format-test format.^.\:{.25 - "~:{~1,0,1^~A~}" ('((1)(2 3)(4 5 6)(7 8 9 0))) "1247") - -(def-format-test format.^.\:{.26 - "~:{~3,2,1^~A~}" ('((1)(2 3)(4 5 6)(7 8 9 0))) "1247") - -(def-format-test format.^.\:{.27 - "~:{~v,2,3^~A~}" ('((1 10)(2 20)(3 30)(4 40))) "3040") - -(def-format-test format.^.\:{.28 - "~:{~1,v,3^~A~}" ('((0 7)(1 10)(2 20)(3 30)(4 40))) "740") - -(def-format-test format.^.\:{.29 - "~:{~1,2,v^~A~}" ('((0 0)(1 10)(2 20)(3 30)(4 40)(0 50))) "01050") - -(def-format-test format.^.\:{.30 - "~:{~1,2,v^~A~}" ('((nil 0))) "0") - -(def-format-test format.^.\:{.31 - "~:{~#,3,3^~A~}" ('((1) (2 1) (3 2 1) (4 3 2 1) (5 4 3 2 1))) "45") - -(def-format-test format.^.\:{.32 - "~:{~2,#,3^~A~}" ('((1) (2 1) (3 2 1) (4 3 2 1) (5 4 3 2 1))) "145") - -(def-format-test format.^.\:{.33 - "~:{~0,3,#^~A~}" ('((1) (2 1) (3 2 1) (4 3 2 1) (5 4 3 2 1))) "12") - -(def-format-test format.^.\:{.34 - "~:{~#,#,3^~A~}" ('((1) (2 1) (3 2 1) (4 3 2 1) (5 4 3 2 1))) "45") - -(def-format-test format.^.\:{.35 - "~:{~3,#,#^~A~}" ('((1) (2 1) (3 2 1) (4 3 2 1) (5 4 3 2 1))) "12") - -(def-format-test format.^.\:{.36 - "~:{~#,3,#^~A~}" ('((1) (2 1) (3 2 1) (4 3 2 1) (5 4 3 2 1))) "1245") - -(def-format-test format.^.\:{.37 - "~:{~#,#,#^~A~}" ('((1) (2 1) (3 2 1) (4 3 2 1) (5 4 3 2 1))) "") - -(def-format-test format.^.\:{.38 - "~:{~1,v,v^~A~}" ('((#\a nil 0))) "0") - -(def-format-test format.^.\:{.39 - "~:{~v,1,v^~A~}" ('((#\a nil 0))) "0") - -;;; Tests of ~^ inside ~@{ ... ~} - -(def-format-test format.^.@{.1 - "~@{X ~A~^ Y ~A~^ ~}" (1 2 3 4 5) "X 1 Y 2 X 3 Y 4 X 5") - -(def-format-test format.^.@{.2 - "~@{X ~A~^ Y ~A~^ ~}" (1 2 3 4) "X 1 Y 2 X 3 Y 4") - -(def-format-test format.^.@{.3 - "~1@{~A~^~A~}" (1) "1") - -(def-format-test format.^.@{.4 - "~0@{~A~^~A~}" (1) "" 1) - -(def-format-test format.^.@{.5 - "~1@{~A~^~A~}" (1 2 3) "12" 1) - -(def-format-test format.^.@{.6 - "~@{~A~A~0^~A~}" (1 2 3 4 5 6) "12" 4) - -(def-format-test format.^.@{.7 - "~@{~A~A~v^~A~}" (1 2 3 4 5 6 0 7 8 9 10 11 12) "12456" 6) - -(def-format-test format.^.@{.8 - "~@{~#,3^~A~}" (1 2 3 4 5 6 7 8 9 10) "1234567" 3) - -(def-format-test format.^.@{.9 - "~@{~2,#^~A~}X~A" (1 2 3 4 5 6 7 8 9 10) "12345678X9" 1) - -(def-format-test format.^.@{.10 - "~@{~#,#^~A~}" (1 2 3 4 5 6 7 8 9 10) "" 10) - -(def-format-test format.^.@{.11 - "~@{~#,#,#^~A~}" (1 2 3 4 5 6 7 8 9 10) "" 10) - -(def-format-test format.^.@{.12 - "~@{~#,1,2^~A~}" (1 2 3 4 5 6 7 8 9 10) "123456789" 1) - -(def-format-test format.^.@{.13 - "~@{~#,#,v^~A~}" (1 2 3 4 5 6 7 8 9 10) "246" 3) - -(def-format-test format.^.@{.14 - "~@{~#,#,v^~A~}" (1 2 3 4 5 6 7 8 9 10 11) "246" 4) - -(def-format-test format.^.@{.15 - "~@{~#,#,v^~A~}" (1 2 3 4 5 6 7 8 9 10 11 12) "246" 5) - -(def-format-test format.^.@{.16 - "~@{~#,#,v^~A~}" (1 2 3 4 5 6 7 8 9 10 11 12 13) "246" 6) - -(def-format-test format.^.@{.17 - "~@{~#,#,v^~A~}" (1 2 3 4 5 6 7 8 9 10 11 12 13 14) "2468" 5) - -(def-format-test format.^.@{.18 - "~@{~v,v^~A~}" - ((1+ most-positive-fixnum) - (1+ most-positive-fixnum) - 1) - "" 1) - -(def-format-test format.^.@{.19 - "~@{~0,v,v^~A~}" - ((1+ most-positive-fixnum) - (1+ most-positive-fixnum) - 1) - "" 1) - -(def-format-test format.^.@{.20 - "~@{~0,v,v^~A~}" - ((1+ most-positive-fixnum) - most-positive-fixnum - 1) - "1") - -(def-format-test format.^.@{.21 - "~@{~1,v^~A~}" (nil 8 nil 7 0 6 1 5) "876" 1) - -(def-format-test format.^.@{.22 - "~@{~0,v^~A~}" (3 8 1 7 3 6 nil 5) "876" 1) - -(def-format-test format.^.@{.23 - "~@{~1,2,v^~A~}" (0 1 0 2 0 3 3 4) "123" 1) - -(def-format-test format.^.@{.24 - "~@{~1,2,v^~A~}" (0 1 0 2 0 3 nil 4) "1234") - -(def-format-test format.^.@{.25 - "~@{~1,1,v^~A~}" (0 1 0 2 0 3 nil 4) "123" 1) - -(def-format-test format.^.@{.26 - "~@{~'X^~A~}" (1 2 3) "123") - -(def-format-test format.^.@{.27 - "~@{~v,'X^~A~}" (0 1 #\x 2 nil 3 #\X 4 0 5) "123" 3) - -(def-format-test format.^.@{.28 - "~@{~'X,v^~A~}" (0 1 #\x 2 nil 3 #\X 4 0 5) "123" 3) - -(def-format-test format.^.@{.29 - "~@{~v,v^~A~}" (0 2 1 #\x #\X 2 5 #\X 3 #\y #\y 4 1 2 5) "123" 4) - -(def-format-test format.^.@{.30 - "~@{~',,',^~A~}" (1 2 3) "" 3) - -(def-format-test format.^.@{.31 - "~@{~1,v,v^~A~}" (#\a nil 0) "0") - -(def-format-test format.^.@{.32 - "~@{~v,1,v^~A~}" (#\a nil 0) "0") - -(def-format-test format.^.@{.33 - "~@{~v,v,v^~A~}" (#\a #\a nil 0) "" 1) - -;;; Inside ~:@{ - -(def-format-test format.^.\:@{.1 - "~:@{~A~^~A~A~}" ('(1) '(2 3 4) '(5 6 7 8)) "1234567") - -(def-format-test format.^.\:@{.2 - "~@:{~A~0^~A~A~}" ('(1) '(2 3 4) '(5 6 7 8)) "125") - -(def-format-test format.^.\:@{.3 - "~:@{~#^~A~}" ('(1) '(2 3 4) () '(5 6 7 8) ()) "125") - -(def-format-test format.^.\:@{.4 - "~@:{~#^~A~#^~A~#^~A~#^~A~}" ('(1) '(2 3 4) () '(5 6 7 8) ()) "12345678") - -(def-format-test format.^.\:@{.5 - "~:@{~v^~A~}" ('(1 2 3) '(0) '(2 4) '(0 5) '(1 6 7 8)) "246") - -(def-format-test format.^.\:@{.6 - "~:@{~v^~A~}" ('(nil) '(nil 1) '(1 2)) "12") - -(def-format-test format.^.\:@{.7 - "~:@{~v^~A~}" ('(#\x 1) '(#\y 2) '(0 3) '(1 4)) "124") - -(def-format-test format.^.\:@{.8 - "~:@{~v,3^~A~}" ('(1 1) '(2 0) '(3 4) '(5 6)) "106") - -(def-format-test format.^.\:@{.9 - "~@:{~3,v^~A~}" ('(1 1) '(2 0) '(3 4) '(5 6)) "106") - -(def-format-test format.^.\:@{.10 - "~:@{~v,3^~A~}" ('(#\x 1)) "1") - -(def-format-test format.^.\:@{.11 - "~:@{~2,v^~A~}" ('(#\x 1)) "1") - -(def-format-test format.^.\:@{.12 - "~:@{~v,v^~A~}" ('(1 2 0) '(0 1 1) '(1 0 2) '(3 3 5) '(4 5 6)) "0126") - -(def-format-test format.^.\:@{.13 - "~:@{~v,v^~A~}" ('(1 2 0) '(#\a #\A 1) '(#\A #\A 2) '(1 2 3)) "013") - -(def-format-test format.^.\:@{.14 - "~:@{~'x,3^~A~}" ('(1)) "1") - -(def-format-test format.^.\:@{.15 - "~:@{~3,'x^~A~}" ('(1)) "1") - -(def-format-test format.^.\:@{.16 - "~:@{~'x,'x^~A~}" ('(1)) "") - -(def-format-test format.^.\:@{.17 - "~:@{~#,1^~A~}" ('(1) '(2 10) '(3 a b) '(4) '(5 x) '(6) '(7 8)) "2357") - -(def-format-test format.^.\:@{.18 - "~:@{~1,#^~A~}" ('(1) '(2 10) '(3 a b) '(4) '(5 x) '(6) '(7 8)) "2357") - -(def-format-test format.^.\:@{.19 - "~:@{~#,#^~A~}" ('(1) '() '(2 10) '(3 a b) '(4) '(5 x) '(6) '(7 8)) "") - -(def-format-test format.^.\:@{.20 - "~:@{~0,v^~A~}" ('(0 1) '(1 2) '(nil 3) '(2 4)) "24") - -(def-format-test format.^.\:@{.21 - "~:@{~1,v^~A~}" ('(0 1) '(1 2) '(nil 3) '(2 4)) "134") - -(def-format-test format.^.\:@{.22 - "~:@{~1,1,1^~A~}" ('(1) '(2 3) '(4 5 6) '(7 8 9 0)) "") - -(def-format-test format.^.\:@{.23 - "~:@{~1,2,3^~A~}" ('(1) '(2 3) '(4 5 6) '(7 8 9 0)) "") - -(def-format-test format.^.\:@{.24 - "~:@{~1,2,1^~A~}" ('(1) '(2 3) '(4 5 6) '(7 8 9 0)) "1247") - -(def-format-test format.^.\:@{.25 - "~:@{~1,0,1^~A~}" ('(1) '(2 3) '(4 5 6) '(7 8 9 0)) "1247") - -(def-format-test format.^.\:@{.26 - "~:@{~3,2,1^~A~}" ('(1) '(2 3) '(4 5 6) '(7 8 9 0)) "1247") - -(def-format-test format.^.\:@{.27 - "~:@{~v,2,3^~A~}" ('(1 10) '(2 20) '(3 30) '(4 40)) "3040") - -(def-format-test format.^.\:@{.28 - "~:@{~1,v,3^~A~}" ('(0 7) '(1 10) '(2 20) '(3 30) '(4 40)) "740") - -(def-format-test format.^.\:@{.29 - "~:@{~1,2,v^~A~}" ('(0 0) '(1 10) '(2 20) '(3 30) '(4 40) '(0 50)) - "01050") - -(def-format-test format.^.\:@{.30 - "~:@{~1,2,v^~A~}" ('(nil 0)) "0") - -(def-format-test format.^.\:@{.31 - "~:@{~#,3,3^~A~}" ('(1) '(2 1) '(3 2 1) '(4 3 2 1) '(5 4 3 2 1)) "45") - -(def-format-test format.^.\:@{.32 - "~:@{~2,#,3^~A~}" ('(1) '(2 1) '(3 2 1) '(4 3 2 1) '(5 4 3 2 1)) "145") - -(def-format-test format.^.\:@{.33 - "~:@{~0,3,#^~A~}" ('(1) '(2 1) '(3 2 1) '(4 3 2 1) '(5 4 3 2 1)) "12") - -(def-format-test format.^.\:@{.34 - "~:@{~#,#,3^~A~}" ('(1) '(2 1) '(3 2 1) '(4 3 2 1) '(5 4 3 2 1)) "45") - -(def-format-test format.^.\:@{.35 - "~:@{~3,#,#^~A~}" ('(1) '(2 1) '(3 2 1) '(4 3 2 1) '(5 4 3 2 1)) "12") - -(def-format-test format.^.\:@{.36 - "~:@{~#,3,#^~A~}" ('(1) '(2 1) '(3 2 1) '(4 3 2 1) '(5 4 3 2 1)) "1245") - -(def-format-test format.^.\:@{.37 - "~:@{~#,#,#^~A~}" ('(1) '(2 1) '(3 2 1) '(4 3 2 1) '(5 4 3 2 1)) "") - -(def-format-test format.^.\:@{.38 - "~:@{~1,v,v^~A~}" ('(#\a nil 0)) "0") - -(def-format-test format.^.\:@{.39 - "~:@{~v,1,v^~A~}" ('(#\a nil 0)) "0") - -;;; ~:^ in ~:{ - -(def-format-test format.\:^.\:{.1 - "~:{~:^~A~}" (nil) "") - -(def-format-test format.\:^.\:{.2 - "(~:{~A~:^,~})" ('((1)(2)(3))) "(1,2,3)") - -(def-format-test format.\:^.\:{.3 - "~:{~:^~A~}" ('((1)(2)(3)(4))) "123") - -;;; arguments - -(def-format-test format.\:^.\:{.4 - "~:{~0:^~A~}" ('((1)(2))) "") - -(def-format-test format.\:^.\:{.5 - "~:{~1:^~A~}" ('((1)(2))) "12") - -(def-format-test format.\:^.\:{.6 - "~:{~'X:^~A~}" ('((1)(2))) "12") - -(def-format-test format.\:^.\:{.7 - "~:{~v:^~A~}" ('((1 8)(2 3 4)(3 1)(0)(6 7)(8 10))) "831") - -(def-format-test format.\:^.\:{.8 - "~:{~V:^~A~}" ('((#\X 1)(0 2))) "1") - -(def-format-test format.\:^.\:{.9 - "~:{~#:^~A~}" ('((1)(2)(3 4)(5 6 7)()(8 9 10))) "1235") - -(def-format-test format.\:^.\:{.10 - "~:{~1,1:^~A~}" ('(()(1)(2 3))) "") - -(def-format-test format.\:^.\:{.11 - "~:{~0,1:^~A~}" ('((1)(2 3))) "12") - -(def-format-test format.\:^.\:{.12 - "~:{~v,1:^~A~}" ('((2 3)(4 5 6)(0 2)(1 7)(9 10))) "352") - -(def-format-test format.\:^.\:{.13 - "~:{~1,V:^~A~}" ('((2 3)(4 5 6)(0 2)(1 7)(9 10))) "352") - -(def-format-test format.\:^.\:{.14 - "~:{~V,v:^~A~}" ('((0 1 2) (1 0 3) (4 4) () (5 6 7))) "23") - -(def-format-test format.\:^.\:{.15 - "~:{~#,1:^~A~}" ('((2 3 4)(4 5)(0)(1 7)(9 10))) - "24") - -(def-format-test format.\:^.\:{.16 - "~:{~1,#:^~A~}" ('((2 3 4)(4 5)(0)(1 7)(9 10))) - "24") - -(def-format-test format.\:^.\:{.17 - "~:{~#,#:^~A~}" ('(nil)) - "") - -(def-format-test format.\:^.\:{.18 - "~:{~#,#:^~A~}" ('((1))) - "") - -(def-format-test format.\:^.\:{.19 - "~:{~#,v:^~A~}" ('((1 2)(3 4)(2 5 6)(1)(2))) - "245") - -(def-format-test format.\:^.\:{.20 - "~:{~V,#:^~A~}" ('((0 2)(1 3 4)(1 3)()(0 7))) - "23") - -(def-format-test format.\:^.\:{.21 - "~:{~'X,'Y:^~A~}" ('((1)(2))) - "12") - -(def-format-test format.\:^.\:{.22 - "~:{~'X,'X:^~A~}" ('((1)(2))) - "") - -(def-format-test format.\:^.\:{.23 - "~:{~1,2,3:^~A~}" ('((1)(2))) - "") - -(def-format-test format.\:^.\:{.24 - "~:{~1,2,1:^~A~}" ('((1)(2))) - "12") - -(def-format-test format.\:^.\:{.25 - "~:{~2,1,3:^~A~}" ('((1)(2))) - "12") - -(def-format-test format.\:^.\:{.26 - "~:{~1,1,v:^~A~}" ('((0 4)(nil 1)(0 5))) - "4") - -(def-format-test format.\:^.\:{.27 - "~:{~v,2,2:^~A~}" ('((3 4)(1 1)(4 5))) - "4") - -(def-format-test format.\:^.\:{.28 - "~:{~1,v,2:^~A~}" ('((0 2)(3 4)(1 1)(4 5))) - "24") - -(def-format-test format.\:^.\:{.29 - "~:{~V,v,3:^~A~}" ('((1 4 0)(2 1 7)(4 4 8 0)(1 2 6)(9 8 0))) - "078") - -(def-format-test format.\:^.\:{.30 - "~:{~v,2,v:^~A~}" ('((1 1 0)(3 2 5)(2 1 6)(1 2 0)(10 11 13))) - "056") - -(def-format-test format.\:^.\:{.31 - "~:{~2,V,v:^~A~}" ('((1 1 0)(3 2 5)(2 1 6)(10 11 13)(0 1 0))) - "056") - -(def-format-test format.\:^.\:{.32 - "~:{~v,v,V:^~A~}" ('((1 2 1 0)(2 1 1 4)(2 3 1 6)(1 2 3)(0 1 0 8))) - "046") - -(def-format-test format.\:^.\:{.33 - "~:{~#,2,2:^~A~}" ('((1 2 3)(2 X X)(0 A B C D)(4 5)(5 7 8 9))) - "120") - -(def-format-test format.\:^.\:{.34 - "~:{~2,#,3:^~A~}" ('((1)(2 3 4 5)(3 4)(4 5 6 7 8)())) - "12") - -(def-format-test format.\:^.\:{.35 - "~:{~1,3,#:^~A~}" ('((1)(2 3)(3 4)(4 5 6)(5))) - "123") - -(def-format-test format.\:^.\:{.36 - "~:{~#,#,2:^~A~}" ('((1 2 3)(2 X X)(0 A B C D)(4 5)(5 7 8 9))) - "120") - -(def-format-test format.\:^.\:{.37 - "~:{~3,#,#:^~A~}" ('((1)(2 3)(3 4)(4 5 6)(5))) - "123") - -(def-format-test format.\:^.\:{.38 - "~:{~#,2,#:^~A~}" ('((1 2 3)(2)(0 A B C D)(4 5)(5 7 8 9))) - "120") - -(def-format-test format.\:^.\:{.39 - "~:{~#,#,#:^~A~}" ('((1 2 3)(2)(0 A B C D)(4 5)(5 7 8 9))) - "") - -;;; ~:^ in ~:@{ - -(def-format-test format.\:^.\:@{.1 - "~:@{~:^~A~}" nil "") - -(def-format-test format.\:^.\:@{.2 - "(~:@{~A~:^,~})" ('(1) '(2) '(3)) - "(1,2,3)") - -(def-format-test format.\:^.\:@{.3 - "~:@{~:^~A~}" ('(1) '(2) '(3) '(4)) - "123") - -(def-format-test format.\:^.\:@{.4 - "~:@{~0:^~A~}" ('(1) '(2)) - "" 1) - -(def-format-test format.\:^.\:@{.5 - "~:@{~1:^~A~}" ('(1) '(2)) - "12") - -(def-format-test format.\:^.\:@{.6 - "~:@{~'X:^~A~}" ('(1) '(2)) - "12") - -(def-format-test format.\:^.\:@{.7 - "~:@{~v:^~A~}" ('(1 8) '(2 3 4) '(3 1) '(0) '(6 7) '(8 10)) - "831" 2) - -(def-format-test format.\:^.\:@{.8 - "~:@{~V:^~A~}" ('(#\X 1) '(0 2)) - "1") - -(def-format-test format.\:^.\:@{.9 - "~:@{~#:^~A~}" ('(1) '(2) '(3 4) '(5 6 7) () '(8 9 10)) - "1235" 1) - -(def-format-test format.\:^.\:@{.10 - "~:@{~1,1:^~A~}" (() '(1) '(2 3)) - "" 2) - -(def-format-test format.\:^.\:@{.11 - "~:@{~0,1:^~A~}" ('(1) '(2 3)) - "12") - -(def-format-test format.\:^.\:@{.12 - "~:@{~v,1:^~A~}" ('(2 3) '(4 5 6) '(0 2) '(1 7) '(9 10)) - "352" 1) - -(def-format-test format.\:^.\:@{.13 - "~:@{~1,V:^~A~}" ('(2 3) '(4 5 6) '(0 2) '(1 7) '(9 10)) - "352" 1) - -(def-format-test format.\:^.\:@{.14 - "~:@{~V,v:^~A~}" ('(0 1 2) '(1 0 3) '(4 4) () '(5 6 7)) - "23" 2) - -(def-format-test format.\:^.\:@{.15 - "~:@{~#,1:^~A~}" ('(2 3 4) '(4 5) '(0) '(1 7) '(9 10)) - "24" 2) - -(def-format-test format.\:^.\:@{.16 - "~:@{~1,#:^~A~}" ('(2 3 4) '(4 5) '(0) '(1 7) '(9 10)) - "24" 2) - -(def-format-test format.\:^.\:@{.17 - "~:@{~#,#:^~A~}" (nil) - "") - -(def-format-test format.\:^.\:@{.18 - "~:@{~#,#:^~A~}" ('(1)) - "") - -(def-format-test format.\:^.\:@{.19 - "~:@{~#,v:^~A~}" ('(1 2) '(3 4) '(2 5 6) '(1) '(2)) - "245" 1) - -(def-format-test format.\:^.\:@{.20 - "~:@{~V,#:^~A~}" ('(0 2) '(1 3 4) '(1 3) () '(0 7)) - "23" 2) - -(def-format-test format.\:^.\:@{.21 - "~:@{~'X,'Y:^~A~}" ('(1) '(2)) - "12") - -(def-format-test format.\:^.\:@{.22 - "~:@{~'X,'X:^~A~}" ('(1) '(2)) - "" 1) - -(def-format-test format.\:^.\:@{.23 - "~:@{~1,2,3:^~A~}" ('(1) '(2)) - "" 1) - -(def-format-test format.\:^.\:@{.24 - "~:@{~1,2,1:^~A~}" ('(1) '(2)) - "12") - -(def-format-test format.\:^.\:@{.25 - "~:@{~2,1,3:^~A~}" ('(1) '(2)) - "12") - -(def-format-test format.\:^.\:@{.26 - "~:@{~1,1,v:^~A~}" ('(0 4) '(nil 1) '(0 5)) - "4" 1) - -(def-format-test format.\:^.\:@{.27 - "~:@{~v,2,2:^~A~}" ('(3 4) '(1 1) '(4 5)) - "4" 1) - -(def-format-test format.\:^.\:@{.28 - "~:@{~1,v,2:^~A~}" ('(0 2) '(3 4) '(1 1) '(4 5)) - "24" 1) - -(def-format-test format.\:^.\:@{.29 - "~:@{~V,v,3:^~A~}" ('(1 4 0) '(2 1 7) '(4 4 8 0) '(1 2 6) '(9 8 0)) - "078" 1) - -(def-format-test format.\:^.\:@{.30 - "~:@{~v,2,v:^~A~}" ('(1 1 0) '(3 2 5) '(2 1 6) '(1 2 0) '(10 11 13)) - "056" 1) - -(def-format-test format.\:^.\:@{.31 - "~:@{~2,V,v:^~A~}" ('(1 1 0) '(3 2 5) '(2 1 6) '(10 11 13) '(0 1 0)) - "056" 1) - -(def-format-test format.\:^.\:@{.32 - "~:@{~v,v,V:^~A~}" ('(1 2 1 0) '(2 1 1 4) '(2 3 1 6) '(1 2 3) '(0 1 0 8)) - "046" 1) - -(def-format-test format.\:^.\:@{.33 - "~:@{~#,2,2:^~A~}" ('(1 2 3) '(2 X X) '(0 A B C D) '(4 5) '(5 7 8 9)) - "120" 1) - -(def-format-test format.\:^.\:@{.34 - "~:@{~2,#,3:^~A~}" ('(1) '(2 3 4 5) '(3 4) '(4 5 6 7 8) ()) - "12" 2) - -(def-format-test format.\:^.\:@{.35 - "~:@{~1,3,#:^~A~}" ('(1) '(2 3) '(3 4) '(4 5 6) '(5)) - "123" 1) - -(def-format-test format.\:^.\:@{.36 - "~:@{~#,#,2:^~A~}" ('(1 2 3) '(2 X X) '(0 A B C D) '(4 5) '(5 7 8 9)) - "120" 1) - -(def-format-test format.\:^.\:@{.37 - "~:@{~3,#,#:^~A~}" ('(1) '(2 3) '(3 4) '(4 5 6) '(5)) - "123" 1) - -(def-format-test format.\:^.\:@{.38 - "~:@{~#,2,#:^~A~}" ('(1 2 3) '(2) '(0 A B C D) '(4 5) '(5 7 8 9)) - "120" 1) - -(def-format-test format.\:^.\:@{.39 - "~:@{~#,#,#:^~A~}" ('(1 2 3) '(2) '(0 A B C D) '(4 5) '(5 7 8 9)) - "" 4) - -;;; ~^ inside ~?, ~@? - -(def-format-test format.^.?.1 - "~AY~?X~A" (1 "~A~0^~A" '(2 4) 3) - "1Y2X3") - -(def-format-test format.^.?.2 - "~AY~?X~A" (1 "~A~^~A" '(2) 3) - "1Y2X3") - -(def-format-test format.^.?.3 - "~AY~?X~A" (1 "~A~^~A~^~A" '(2 4) 3) - "1Y24X3") - -(def-format-test format.^.?.4 - "~A~?X~A" (1 "~{~^~A~}~AY~A" '((2 3) 4 5) 6) - "1234Y5X6") - -(def-format-test format.^.@?.1 - "~AY~@?X~A" (1 "~A~0^~A" 2 3 4) - "1Y2X3" 1) - -(def-format-test format.^.@?.2 - "~A~@?X~A" (1 "~{~^~A~}~AY~A" '(2 3) 4 5 6) - "1234Y5X6") - -;;; ~^ in ~[ - -(def-format-test format.^.\[.1 - "~{~[X~;Y~;Z~;~0^~]~}" ('(0 1 2 3 4)) - "XYZ") - -(def-format-test format.^.\[.2 - "~{~[X~;Y~;Z~:;~0^~]~}" ('(1 0 2 8 9 10 0)) - "YXZ") - -(def-format-test format.^.\[.3 - "~{~[X~;Y~0^NO~;Z~;~^~]~}" ('(0 1 2 3 4)) - "XY") - -;;; ~^ in ~( - -(def-format-test format.^.\(.1 - "~{~(~C~C~0^~C~)W~}" ('(#\X #\Y #\Z #\A)) - "xy") - -(def-format-test format.^.\:\(.1 - "~{~:(~C~C~0^~C~)U~}" ('(#\X #\Y #\Z #\A)) - "Xy") - -(def-format-test format.^.@\(.1 - "~{~@(~CA ~Cb ~0^~C~)V~}" ('(#\x #\y #\Z #\A)) - "Xa yb ") - -(def-format-test format.^.@\:\(.1 - "~{~@:(~CA ~Cb ~0^~C~)W~}" ('(#\x #\Y #\Z #\A)) - "XA YB ") diff --git a/t/ansi-test/printer/format/format-conditional.lsp b/t/ansi-test/printer/format/format-conditional.lsp deleted file mode 100644 index 49e57b2..0000000 --- a/t/ansi-test/printer/format/format-conditional.lsp +++ /dev/null @@ -1,173 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Aug 25 19:27:25 2004 -;;;; Contains: Tests of the ~[ ~] forms - - - - - -(def-format-test format.cond.1 - "~[~]" (0) "") - -(def-format-test format.cond.2 - "~[a~]" (0) "a") - -(def-format-test format.cond.3 - "~[a~]" (-1) "") - -(def-format-test format.cond.4 - "~[a~]" ((1- most-negative-fixnum)) "") - -(def-format-test format.cond.5 - "~[a~]" (1) "") - -(def-format-test format.cond.6 - "~[a~]" ((1+ most-positive-fixnum)) "") - -(deftest format.cond.7 - (loop for i from -1 to 10 - collect (format nil "~[a~;b~;c~;d~;e~;f~;g~;h~;i~]" i)) - ("" "a" "b" "c" "d" "e" "f" "g" "h" "i" "" "")) - -(deftest formatter.cond.7 - (let ((fn (formatter "~[a~;b~;c~;d~;e~;f~;g~;h~;i~]"))) - (loop for i from -1 to 10 - collect (formatter-call-to-string fn i))) - ("" "a" "b" "c" "d" "e" "f" "g" "h" "i" "" "")) - -(def-format-test format.cond.8 - "~0[a~;b~;c~;d~]" (3) "a" 1) - -(def-format-test format.cond.9 - "~-1[a~;b~;c~;d~]" (3) "" 1) - -(def-format-test format.cond.10 - "~1[a~;b~;c~;d~]" (3) "b" 1) - -(def-format-test format.cond.11 - "~4[a~;b~;c~;d~]" (3) "" 1) - -(def-format-test format.cond.12 - "~100000000000000000000000000000000[a~;b~;c~;d~]" (3) "" 1) - -(deftest format.cond.13 - (loop for i from -1 to 10 - collect (format nil "~v[a~;b~;c~;d~;e~;f~;g~;h~;i~]" i nil)) - ("" "a" "b" "c" "d" "e" "f" "g" "h" "i" "" "")) - -(deftest formatter.cond.13 - (let ((fn (formatter "~V[a~;b~;c~;d~;e~;f~;g~;h~;i~]"))) - (loop for i from -1 to 10 - collect (formatter-call-to-string fn i))) - ("" "a" "b" "c" "d" "e" "f" "g" "h" "i" "" "")) - -(deftest format.cond.14 - (loop for i from -1 to 10 - collect (format nil "~v[a~;b~;c~;d~;e~;f~;g~;h~;i~]" nil i)) - ("" "a" "b" "c" "d" "e" "f" "g" "h" "i" "" "")) - -(deftest formatter.cond.14 - (let ((fn (formatter "~v[a~;b~;c~;d~;e~;f~;g~;h~;i~]"))) - (loop for i from -1 to 10 - collect (formatter-call-to-string fn nil i))) - ("" "a" "b" "c" "d" "e" "f" "g" "h" "i" "" "")) - -(def-format-test format.cond.15 - "~#[A~;B~]" nil "A") - -(def-format-test format.cond.16 - "~#[A~;B~]" (nil) "B" 1) - -;;; ~[ .~:; ~] - -(deftest format.cond\:.1 - (loop for i from -100 to 100 - for s = (format nil "~[~:;a~]" i) - unless (or (zerop i) (string= s "a")) - collect (list i s)) - nil) - -(deftest formatter.cond\:.1 - (let ((fn (formatter "~[~:;a~]"))) - (loop for i from -100 to 100 - for s = (formatter-call-to-string fn i) - unless (or (zerop i) (string= s "a")) - collect (list i s))) - nil) - -(def-format-test format.cond\:.2 - "~[a~:;b~]" (0) "a") - -(def-format-test format.cond\:.3 - "~[a~:;b~]" ((1- most-negative-fixnum)) "b") - -(def-format-test format.cond\:.4 - "~[a~:;b~]" ((1+ most-positive-fixnum)) "b") - -(deftest format.cond\:.5 - (loop for i from -1 to 10 - collect (format nil "~[a~;b~;c~;d~:;e~]" i)) - ("e" "a" "b" "c" "d" "e" "e" "e" "e" "e" "e" "e")) - -(deftest formatter.cond\:.5 - (let ((fn (formatter "~[a~;b~;c~;d~:;e~]"))) - (loop for i from -1 to 10 - collect (formatter-call-to-string fn i))) - ("e" "a" "b" "c" "d" "e" "e" "e" "e" "e" "e" "e")) - -(deftest format.cond\:.6 - (loop for i from -1 to 10 - collect (format nil "~v[a~;b~;c~;d~:;e~]" i nil)) - ("e" "a" "b" "c" "d" "e" "e" "e" "e" "e" "e" "e")) - -(deftest formatter.cond\:.6 - (let ((fn (formatter "~v[a~;b~;c~;d~:;e~]"))) - (loop for i from -1 to 10 - collect (formatter-call-to-string fn i))) - ("e" "a" "b" "c" "d" "e" "e" "e" "e" "e" "e" "e")) - -(deftest format.cond\:.7 - (loop for i from -1 to 10 - collect (format nil "~v[a~;b~;c~;d~:;e~]" nil i)) - ("e" "a" "b" "c" "d" "e" "e" "e" "e" "e" "e" "e")) - -(deftest formatter.cond\:.7 - (let ((fn (formatter "~v[a~;b~;c~;d~:;e~]"))) - (loop for i from -1 to 10 - collect (formatter-call-to-string fn nil i))) - ("e" "a" "b" "c" "d" "e" "e" "e" "e" "e" "e" "e")) - -(def-format-test format.cond\:.8 - "~#[A~:;B~]" nil "A") - -(def-format-test format.cond\:.9 - "~#[A~:;B~]" (nil nil) "B" 2) - -;;; ~:[...~] - -(def-format-test format.\:cond.1 - "~:[a~;b~]" (nil) "a") - -(deftest format.\:cond.2 - (loop for x in *mini-universe* - for s = (format nil "~:[a~;b~]" x) - when (and x (not (string= s "b"))) - collect (list x s)) - nil) - -(deftest formatter.\:cond.2 - (let ((fn (formatter "~:[a~;b~]"))) - (loop for x in *mini-universe* - for s = (formatter-call-to-string fn x) - when (and x (not (string= s "b"))) - collect (list x s))) - nil) - -;;; ~@[ ... ~] - -(def-format-test format.@cond.1 - "~@[X~]Y~A" (1) "XY1") - -(def-format-test format.@cond.2 - "~@[X~]Y~A" (nil 2) "Y2") diff --git a/t/ansi-test/printer/format/format-d.lsp b/t/ansi-test/printer/format/format-d.lsp deleted file mode 100644 index 028f692..0000000 --- a/t/ansi-test/printer/format/format-d.lsp +++ /dev/null @@ -1,585 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Jul 31 05:19:39 2004 -;;;; Contains: Tests of the ~D format directive - - - - - -(deftest format.d.1 - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~D" i) - for j = (read-from-string s1) - repeat 1000 - when (or (/= i j) - (find #\. s1) - (find #\+ s1) - (find-if #'alpha-char-p s1)) - collect (list i s1 j))) - nil) - -(deftest formatter.d.1 - (let ((fn (formatter "~D"))) - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for s1 = (formatter-call-to-string fn i) - for j = (read-from-string s1) - repeat 1000 - when (or (/= i j) - (find #\. s1) - (find #\+ s1) - (find-if #'alpha-char-p s1)) - collect (list i s1 j)))) - nil) - -(deftest format.d.2 - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~@d" i) - for j = (read-from-string s1) - repeat 1000 - when (or (/= i j) - (find #\. s1) - ;; (find #\+ s1) - (find-if #'alpha-char-p s1)) - collect (list i s1 j))) - nil) - -(deftest formatter.d.2 - (let ((fn (formatter "~@D"))) - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for s1 = (formatter-call-to-string fn i) - for j = (read-from-string s1) - repeat 1000 - when (or (/= i j) - (find #\. s1) - ;; (find #\+ s1) - (find-if #'alpha-char-p s1)) - collect (list i s1 j)))) - nil) - -(deftest format.d.3 - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~d" i) - for s2 = (format nil (format nil "~~~dd" mincol) i) - for pos = (search s1 s2) - repeat 1000 - when (or (null pos) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (not (eql (position #\Space s2 :test-not #'eql) - (- (length s2) (length s1))))))) - collect (list i mincol s1 s2 pos))) - nil) - -(deftest formatter.d.3 - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~d" i) - for format-string = (format nil "~~~dd" mincol) - ; for s2 = (format nil format-string i) - for fn = (eval `(formatter ,format-string)) - for s2 = (formatter-call-to-string fn i) - for pos = (search s1 s2) - repeat 100 - when (or (null pos) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (not (eql (position #\Space s2 :test-not #'eql) - (- (length s2) (length s1))))))) - collect (list i mincol s1 s2 pos))) - nil) - -(deftest format.d.4 - (with-standard-io-syntax - (loop with limit = 10 - with count = 0 - for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~@D" i) - for format-string = (format nil "~~~d@d" mincol) - for s2 = (format nil format-string i) - for pos = (search s1 s2) - repeat 1000 - when (or (null pos) - (and (>= i 0) (not (eql (elt s1 0) #\+))) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (not (eql (position #\Space s2 :test-not #'eql) - (- (length s2) (length s1))))))) - collect (if (> (incf count) limit) - "Count limit exceeded" - (list i mincol s1 format-string s2 pos)) - while (<= count limit))) - nil) - -(deftest formatter.d.4 - (with-standard-io-syntax - (loop with limit = 10 - with count = 0 - for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~@D" i) - for format-string = (format nil "~~~d@d" mincol) - for fn = (eval `(formatter ,format-string)) - for s2 = (formatter-call-to-string fn i) - for pos = (search s1 s2) - repeat 100 - when (or (null pos) - (and (>= i 0) (not (eql (elt s1 0) #\+))) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (not (eql (position #\Space s2 :test-not #'eql) - (- (length s2) (length s1))))))) - collect (if (> (incf count) limit) - "Count limit exceeded" - (list i mincol s1 s2 pos)) - while (<= count limit))) - nil) - -(deftest format.d.5 - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for padchar = (random-from-seq +standard-chars+) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~d" i) - for s2 = (format nil (format nil "~~~d,'~cd" mincol padchar) i) - for pos = (search s1 s2) - repeat 1000 - when (or (null pos) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (find padchar s2 :end (- (length s2) (length s1)) - :test-not #'eql)))) - collect (list i mincol s1 s2 pos))) - nil) - -(deftest formatter.d.5 - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for padchar = (random-from-seq +standard-chars+) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~d" i) - for format-string = (format nil "~~~d,'~cd" mincol padchar) - for fn = (eval `(formatter ,format-string)) - for s2 = (formatter-call-to-string fn i) - for pos = (search s1 s2) - repeat 100 - when (or (null pos) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (find padchar s2 :end (- (length s2) (length s1)) - :test-not #'eql)))) - collect (list i mincol s1 s2 pos))) - nil) - -(deftest format.d.6 - (let ((fn (formatter "~v,vd"))) - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for padchar = (random-from-seq +standard-chars+) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~d" i) - for s2 = (format nil "~v,vD" mincol padchar i) - for s3 = (formatter-call-to-string fn mincol padchar i) - for pos = (search s1 s2) - repeat 1000 - when (or (null pos) - (not (string= s2 s3)) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (find padchar s2 :end (- (length s2) (length s1)) - :test-not #'eql)))) - collect (list i mincol s1 s2 s3 pos)))) - nil) - -(deftest format.d.7 - (let ((fn (formatter "~v,v@D"))) - (with-standard-io-syntax - (loop with limit = 10 - with count = 0 - for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for padchar = (random-from-seq +standard-chars+) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~@d" i) - for s2 = (format nil "~v,v@d" mincol padchar i) - for s3 = (formatter-call-to-string fn mincol padchar i) - for pos = (search s1 s2) - repeat 1000 - when (or (null pos) - (not (string= s2 s3)) - (and (>= i 0) (not (eql (elt s1 0) #\+))) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (find padchar s2 :end (- (length s2) (length s1)) - :test-not #'eql)))) - collect (if (> (incf count) limit) - "Count limit exceeded" - (list i mincol s1 s2 s3 pos)) - while (<= count limit)))) - nil) - -;;; Comma tests - -(deftest format.d.8 - (let ((fn1 (formatter "~d")) - (fn2 (formatter "~:d"))) - (loop for i from -999 to 999 - for s1 = (format nil "~d" i) - for s2 = (format nil "~:d" i) - for s3 = (formatter-call-to-string fn1 i) - for s4 = (formatter-call-to-string fn2 i) - unless (and (string= s1 s2) (string= s1 s3) (string= s1 s4)) - collect (list i s1 s2 s3 s4))) - nil) - -(deftest format.d.9 - (let ((fn1 (formatter "~d")) - (fn2 (formatter "~:d"))) - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = #\, - for s1 = (format nil "~d" i) - for s2 = (format nil "~:d" i) - for s3 = (formatter-call-to-string fn1 i) - for s4 = (formatter-call-to-string fn2 i) - repeat 1000 - unless (and (string= s1 s3) - (string= s2 s4) - (string= s1 (remove commachar s2)) - (not (eql (elt s2 0) commachar)) - (or (>= i 0) (not (eql (elt s2 1) commachar))) - (let ((len (length s2)) - (ci+1 4)) - (loop for i from (if (< i 0) 2 1) below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (find (elt s2 i) "0123456789"))))) - collect (list x i commachar s1 s2 s3 s4)))) - nil) - -(deftest format.d.10 - (let ((fn (formatter "~,,v:d"))) - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = (random-from-seq +standard-chars+) - for s1 = (format nil "~d" i) - for s2 = (format nil "~,,v:d" commachar i) - for s3 = (formatter-call-to-string fn commachar i) - repeat 1000 - unless (and - (string= s2 s3) - (eql (elt s1 0) (elt s2 0)) - (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) - (let ((len (length s2)) - (ci+1 4) - (j (if (< i 0) 1 0))) - (loop for i from (if (< i 0) 2 1) below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (eql (elt s1 (incf j)) (elt s2 i)))))) - collect (list x i commachar s1 s2 s3)))) - nil) - -(deftest format.d.11 - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = (random-from-seq +standard-chars+) - for s1 = (format nil "~d" i) - for format-string = (format nil "~~,,'~c:d" commachar) - for s2 = (format nil format-string i) - repeat 1000 - unless (and - (eql (elt s1 0) (elt s2 0)) - (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) - (let ((len (length s2)) - (ci+1 4) - (j (if (< i 0) 1 0))) - (loop for i from (if (< i 0) 2 1) below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (eql (elt s1 (incf j)) (elt s2 i)))))) - collect (list x i commachar s1 s2))) - nil) - -(deftest formatter.d.11 - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = (random-from-seq +standard-chars+) - for s1 = (format nil "~d" i) - for format-string = (format nil "~~,,'~c:d" commachar) - for fn = (eval `(formatter ,format-string)) - ; for s2 = (format nil format-string i) - for s2 = (formatter-call-to-string fn i) - repeat 100 - unless (and - (eql (elt s1 0) (elt s2 0)) - (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) - (let ((len (length s2)) - (ci+1 4) - (j (if (< i 0) 1 0))) - (loop for i from (if (< i 0) 2 1) below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (eql (elt s1 (incf j)) (elt s2 i)))))) - collect (list x i commachar s1 s2))) - nil) - -(deftest format.d.12 - (let ((fn (formatter "~,,v,v:d"))) - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = (random-from-seq +standard-chars+) - for commaint = (1+ (random 20)) - for s1 = (format nil "~d" i) - for s2 = (format nil "~,,v,v:D" commachar commaint i) - for s3 = (formatter-call-to-string fn commachar commaint i) - repeat 1000 - unless (and - (string= s2 s3) - (eql (elt s1 0) (elt s2 0)) - (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) - (let ((len (length s2)) - (ci+1 (1+ commaint)) - (j (if (< i 0) 1 0))) - (loop for i from (if (< i 0) 2 1) below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (eql (elt s1 (incf j)) (elt s2 i)))))) - collect (list x i commachar s1 s2 s3)))) - nil) - -(deftest format.d.13 - (let ((fn (formatter "~,,v,v:@D"))) - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = (random-from-seq +standard-chars+) - for commaint = (1+ (random 20)) - for s1 = (format nil "~@d" i) - for s2 = (format nil "~,,v,v:@d" commachar commaint i) - for s3 = (formatter-call-to-string fn commachar commaint i) - repeat 1000 - unless (and - (eql (elt s1 0) (elt s2 0)) - (eql (elt s1 1) (elt s2 1)) - (let ((len (length s2)) - (ci+1 (1+ commaint)) - (j 1)) - (loop for i from 2 below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (eql (elt s1 (incf j)) (elt s2 i)))))) - collect (list x i commachar s1 s2 s3)))) - nil) - -;;; NIL arguments - -(def-format-test format.d.14 - "~vD" (nil 100) "100") - -(def-format-test format.d.15 - "~6,vD" (nil 100) " 100") - -(def-format-test format.d.16 - "~,,v:d" (nil 12345) "12,345") - -(def-format-test format.d.17 - "~,,'*,v:d" (nil 12345) "12*345") - -;;; When the argument is not an integer, print as if using ~A and base 10 - -(deftest format.d.18 - (loop for x in *mini-universe* - for s1 = (format nil "~d" x) - for s2 = (format nil "~A" x) - unless (or (integerp x) (string= s1 s2)) - collect (list x s1 s2)) - nil) - -(deftest format.d.19 - (loop for x in *mini-universe* - for s1 = (format nil "~:d" x) - for s2 = (format nil "~A" x) - unless (or (integerp x) (string= s1 s2)) - collect (list x s1 s2)) - nil) - -(deftest format.d.20 - (loop for x in *mini-universe* - for s1 = (format nil "~@d" x) - for s2 = (format nil "~A" x) - unless (or (integerp x) (string= s1 s2)) - collect (list x s1 s2)) - nil) - -(deftest format.d.21 - (loop for x in *mini-universe* - for s1 = (format nil "~A" x) - for s2 = (format nil "~@:d" x) - for s3 = (format nil "~A" x) - unless (or (integerp x) (string= s1 s2) (not (string= s1 s3))) - collect (list x s1 s2)) - nil) - -;;; Must add tests for non-integers when the parameters -;;; are specified, but it's not clear what the meaning is. -;;; Does mincol apply to the ~A equivalent? What about padchar? -;;; Are comma-char and comma-interval always ignored? - -;;; # arguments - -(deftest format.d.22 - (apply - #'values - (loop for i from 0 to 10 - for args = (make-list i) - for s = (apply #'format nil "~#d" 12345 args) - collect s)) - "12345" - "12345" - "12345" - "12345" - "12345" - " 12345" - " 12345" - " 12345" - " 12345" - " 12345" - " 12345") - -(deftest formatter.d.22 - (apply - #'values - (let ((fn (formatter "~#D"))) - (loop for i from 0 to 10 - for args = (make-list i) - ; for s = (apply #'format nil "~#d" 12345 args) - for s = (with-output-to-string - (stream) - (assert (equal (apply fn stream 12345 args) args))) - collect s))) - "12345" - "12345" - "12345" - "12345" - "12345" - " 12345" - " 12345" - " 12345" - " 12345" - " 12345" - " 12345") - -(deftest format.d.23 - (apply - #'values - (let ((fn (formatter "~,,,#:D"))) - (loop for i from 0 to 10 - for args = (make-list i) - for s = (apply #'format nil "~,,,#:d" 1234567890 args) - for s2 = (with-output-to-string - (stream) - (assert (equal (apply fn stream 1234567890 args) args))) - do (assert (string= s s2)) - collect s))) - "1,2,3,4,5,6,7,8,9,0" - "12,34,56,78,90" - "1,234,567,890" - "12,3456,7890" - "12345,67890" - "1234,567890" - "123,4567890" - "12,34567890" - "1,234567890" - "1234567890" - "1234567890") - -(deftest format.d.24 - (apply - #'values - (let ((fn (formatter "~,,,#:@d"))) - (loop for i from 0 to 10 - for args = (make-list i) - for s = (apply #'format nil "~,,,#@:D" 1234567890 args) - for s2 = (with-output-to-string - (stream) - (assert (equal (apply fn stream 1234567890 args) args))) - do (assert (string= s s2)) - collect s))) - "+1,2,3,4,5,6,7,8,9,0" - "+12,34,56,78,90" - "+1,234,567,890" - "+12,3456,7890" - "+12345,67890" - "+1234,567890" - "+123,4567890" - "+12,34567890" - "+1,234567890" - "+1234567890" - "+1234567890") - -(def-format-test format.d.25 - "~+10d" (1234) " 1234") - -(def-format-test format.d.26 - "~+10@d" (1234) " +1234") - -(def-format-test format.d.27 - "~-1d" (1234) "1234") - -(def-format-test format.d.28 - "~-1000000000000000000d" (1234) "1234") - -(def-format-test format.d.29 - "~vd" ((1- most-negative-fixnum) 1234) "1234") - -;;; Randomized test - -(deftest format.d.30 - (let ((fn (formatter "~v,v,v,vD"))) - (loop - for mincol = (and (coin) (random 50)) - for padchar = (and (coin) - (random-from-seq +standard-chars+)) - for commachar = (and (coin) - (random-from-seq +standard-chars+)) - for commaint = (and (coin) (1+ (random 10))) - for k = (ash 1 (+ 2 (random 30))) - for x = (- (random (+ k k)) k) - for fmt = (concatenate - 'string - (if mincol (format nil "~~~d," mincol) "~,") - (if padchar (format nil "'~c," padchar) ",") - (if commachar (format nil "'~c," commachar) ",") - (if commaint (format nil "~dd" commaint) "d")) - for s1 = (format nil fmt x) - for s2 = (format nil "~v,v,v,vd" mincol padchar commachar commaint x) - for s3 = (formatter-call-to-string fn mincol padchar commachar commaint x) - repeat 2000 - unless (and (string= s1 s2) (string= s2 s3)) - collect (list mincol padchar commachar commaint fmt x s1 s2 s3))) - nil) diff --git a/t/ansi-test/printer/format/format-f.lsp b/t/ansi-test/printer/format/format-f.lsp deleted file mode 100644 index 55c6fd6..0000000 --- a/t/ansi-test/printer/format/format-f.lsp +++ /dev/null @@ -1,558 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Aug 1 07:14:17 2004 -;;;; Contains: Tests of the ~f format directive - - - - - -;;; Equivalent to PRIN1 for 0 or (abs x) in range [10^-3,10^7). - -(deftest format.f.1 - (let ((*print-readably* nil) - (fn (formatter "~F"))) - (loop - for type in '(short-float single-float double-float long-float - short-float single-float double-float long-float) - for x in '(0.0s0 0.0f0 0.0d0 0.0l0 - -0.0s0 -0.0f0 -0.0d0 -0.0l0) - for s1 = (let ((*read-default-float-format* type)) (format nil "~f" x)) - for s2 = (let ((*read-default-float-format* type)) (prin1-to-string x)) - for s3 = (let ((*read-default-float-format* type)) - (formatter-call-to-string fn x)) - unless (and (string= s1 s2) (string= s1 s3)) - collect (list x type s1 s2 s3))) - nil) - -(deftest format.f.2 - (let ((*print-readably* nil) - (fn (formatter "~f"))) - (loop - for i = (random 4) - for type = (elt #(short-float single-float double-float long-float) i) - for x = (expt (coerce 10 type) - (- (random 10.0s0) 3)) - for s1 = (let ((*read-default-float-format* type)) (format nil "~f" x)) - for s2 = (let ((*read-default-float-format* type)) (prin1-to-string x)) - for s3 = (let ((*read-default-float-format* type)) - (formatter-call-to-string fn x)) - repeat 1000 - when (and (<= 1/1000 x) - (< x 10000000) - (or (not (string= s1 s2)) - (not (string= s1 s3)))) - collect (list x s1 s2 s3))) - nil) - -(deftest format.f.3 - (let ((*print-readably* nil) - (fn (formatter "~F"))) - (loop - for i = (random 4) - for type = (elt #(short-float single-float double-float long-float) i) - for x = (- (expt (coerce 10 type) - (- (random 10.0s0) 3))) - for s1 = (let ((*read-default-float-format* type)) (format nil "~f" x)) - for s2 = (let ((*read-default-float-format* type)) (prin1-to-string x)) - for s3 = (let ((*read-default-float-format* type)) - (formatter-call-to-string fn x)) - repeat 1000 - when (and (>= -1/1000 x) - (> x -10000000) - (not (and (string= s1 s2) (string= s1 s3)))) - collect (list x s1 s2 s3))) - nil) - -(deftest format.f.4 - (let ((fn (formatter "~3f"))) - (loop for x in (remove-duplicates '(1 1.0s0 1.0f0 1.0d0 1.0l0)) - for s = (format nil "~3f" x) - for s2 = (formatter-call-to-string fn x) - unless (and (string= s "1.0") (string= s s2)) - collect (list x s s2))) - nil) - -(deftest format.f.5 - (let ((fn (formatter "~2f"))) - (loop for x in (remove-duplicates '(1 1.0s0 1.0f0 1.0d0 1.0l0)) - for s = (format nil "~2f" x) - for s2 = (formatter-call-to-string fn x) - unless (and (string= s "1.0") (string= s s2)) - collect (list x s s2))) - nil) - -(deftest format.f.6 - (let ((fn (formatter "~4F"))) - (loop for x in (remove-duplicates '(1 1.0s0 1.0f0 1.0d0 1.0l0)) - for s = (format nil "~4F" x) - for s2 = (formatter-call-to-string fn x) - unless (and (string= s " 1.0") (string= s s2)) - collect (list x s s2))) - nil) - -(deftest format.f.7 - (let ((fn (formatter "~4@F"))) - (loop for x in (remove-duplicates '(1 1.0s0 1.0f0 1.0d0 1.0l0)) - for s = (format nil "~4@f" x) - for s2 = (formatter-call-to-string fn x) - unless (and (string= s "+1.0") (string= s s2)) - collect (list x s s2))) - nil) - -(deftest format.f.8 - (let ((fn (formatter "~3@F"))) - (loop for x in (remove-duplicates '(1 1.0s0 1.0f0 1.0d0 1.0l0)) - for s = (format nil "~3@F" x) - for s2 = (formatter-call-to-string fn x) - unless (and (string= s "+1.0") (string= s s2)) - collect (list x s s2))) - nil) - -(deftest format.f.9 - (let ((fn (formatter "~4f"))) - (loop for x in (remove-duplicates '(1 1.0s0 1.0f0 1.0d0 1.0l0)) - for s = (format nil "~4f" (- x)) - for s2 = (formatter-call-to-string fn (- x)) - unless (and (string= s "-1.0") (string= s s2)) - collect (list (- x) s s2))) - nil) - -(deftest format.f.10 - (let ((fn (formatter "~3F"))) - (loop for x in (remove-duplicates '(1/2 0.5s0 0.5f0 0.5d0 0.5l0)) - for s = (format nil "~3f" x) - for s2 = (formatter-call-to-string fn x) - unless (and (string= s "0.5") (string= s s2)) - collect (list x s s2))) - nil) - -(deftest format.f.11 - (let ((fn (formatter "~4f"))) - (loop for x in (remove-duplicates '(1/2 0.5s0 0.5f0 0.5d0 0.5l0)) - for s = (format nil "~4f" x) - for s2 = (formatter-call-to-string fn x) - unless (and (string= s " 0.5") (string= s s2)) - collect (list x s s2))) - nil) - -(deftest format.f.12 - (let ((fn (formatter "~4,2F"))) - (loop for x in (remove-duplicates '(1/2 0.5s0 0.5f0 0.5d0 0.5l0)) - for s = (format nil "~4,2f" x) - for s2 = (formatter-call-to-string fn x) - unless (and (string= s "0.50") (string= s s2)) - collect (list x s s2))) - nil) - -(deftest format.f.13 - (let ((fn (formatter "~3,2F"))) - (loop for x in (remove-duplicates '(1/2 0.5s0 0.5f0 0.5d0 0.5l0)) - for s = (format nil "~3,2f" x) - for s2 = (formatter-call-to-string fn x) - unless (and (string= s ".50") (string= s s2)) - collect (list x s s2))) - nil) - -(deftest format.f.14 - (let ((fn (formatter "~2,1F"))) - (loop for x in (remove-duplicates '(1/2 0.5s0 0.5f0 0.5d0 0.5l0)) - for s = (format nil "~2,1f" x) - for s2 = (formatter-call-to-string fn x) - unless (and (string= s ".5") (string= s s2)) - collect (list x s s2))) - nil) - -(deftest format.f.15 - (let ((fn (formatter "~4,2@F"))) - (loop for x in (remove-duplicates '(1/2 0.5s0 0.5f0 0.5d0 0.5l0)) - for s = (format nil "~4,2@f" x) - for s2 = (formatter-call-to-string fn x) - unless (and (string= s "+.50") (string= s s2)) - collect (list x s s2))) - nil) - -(deftest format.f.16 - (let ((fn (formatter "~2,2F"))) - (loop for x in (remove-duplicates '(1/2 0.5s0 0.5f0 0.5d0 0.5l0)) - for s = (format nil "~2,2f" x) - for s2 = (formatter-call-to-string fn x) - unless (and (string= s ".50") (string= s s2)) - collect (list x s s2))) - nil) - -(deftest format.f.17 - (let ((fn (formatter "~,2F"))) - (loop for x in (remove-duplicates '(1/2 0.5s0 0.5f0 0.5d0 0.5l0)) - for s = (format nil "~,2f" x) - for s2 = (formatter-call-to-string fn x) - unless (and (string= s "0.50") (string= s s2)) - collect (list x s s2))) - nil) - -(deftest format.f.18 - (let ((fn (formatter "~,2F"))) - (loop for xn in (remove-duplicates '(1/2 0.5s0 0.5f0 0.5d0 0.5l0)) - for x = (- xn) - for s = (format nil "~,2f" x) - for s2 = (formatter-call-to-string fn x) - unless (and (string= s "-0.50") (string= s s2)) - collect (list x s s2))) - nil) - -(deftest format.f.19 - (let ((fn (formatter "~4,2,-1F"))) - (loop for x in (remove-duplicates '(5 5.0s0 5.0f0 5.0d0 5.0l0)) - for s = (format nil "~4,2,-1f" x) - for s2 = (formatter-call-to-string fn x) - unless (and (string= s "0.50") (string= s s2)) - collect (list x s s2))) - nil) - -(deftest format.f.20 - (let ((fn (formatter "~4,2,0F"))) - (loop for x in (remove-duplicates '(1/2 0.5s0 0.5f0 0.5d0 0.5l0)) - for s = (format nil "~4,2,0f" x) - for s2 = (formatter-call-to-string fn x) - unless (and (string= s "0.50") (string= s s2)) - collect (list x s s2))) - nil) - -(deftest format.f.21 - (let ((fn (formatter "~4,2,1f"))) - (loop for x in (remove-duplicates '(1/20 0.05s0 0.05f0 0.05d0 0.05l0)) - for s = (format nil "~4,2,1f" x) - for s2 = (formatter-call-to-string fn x) - unless (and (string= s "0.50") (string= s s2)) - collect (list x s s2))) - nil) - -;;; overflow - -(deftest format.f.22 - (let ((fn (formatter "~5,1,,'*F"))) - (loop for x in (remove-duplicates - '(1000 1000.0s0 1000.0f0 1000.0d0 1000.0l0)) - for s = (format nil "~5,1,,'*f" x) - for s2 = (formatter-call-to-string fn x) - unless (and (string= s "*****") (string= s s2)) - collect (list x s s2))) - nil) - -(deftest format.f.23 - (let ((fn (formatter "~5,1,,'*f"))) - (loop for x in (remove-duplicates - '(100 100.0s0 100.0f0 100.0d0 100.0l0)) - for s = (format nil "~5,1,,'*f" x) - for s2 = (formatter-call-to-string fn x) - unless (and (string= s "100.0") (string= s s2)) - collect (list x s s2))) - nil) - -(deftest format.f.24 - (let ((fn (formatter "~4,0,,'*F"))) - (loop for x in (remove-duplicates - '(100 100.0s0 100.0f0 100.0d0 100.0l0)) - for s = (format nil "~4,0,,'*f" x) - for s2 = (formatter-call-to-string fn x) - unless (and (string= s "100.") (string= s s2)) - collect (list x s s2))) - nil) - -(deftest format.f.25 - (let ((fn (formatter "~1,1,,f"))) - (loop for x in (remove-duplicates - '(100 100.0s0 100.0f0 100.0d0 100.0l0)) - for s = (format nil "~1,1,,f" x) - for s2 = (formatter-call-to-string fn x) - unless (and (string= s "100.0") (string= s s2)) - collect (list x s s2))) - nil) - -;;; padchar - -(deftest format.f.26 - (let ((fn (formatter "~10,1,,f"))) - (loop for x in (remove-duplicates - '(100 100.0s0 100.0f0 100.0d0 100.0l0)) - for s = (format nil "~10,1,,f" x) - for s2 = (formatter-call-to-string fn x) - unless (and (string= s " 100.0") (string= s s2)) - collect (list x s s2))) - nil) - -(deftest format.f.27 - (let ((fn (formatter "~10,1,,,'*F"))) - (loop for x in (remove-duplicates - '(100 100.0s0 100.0f0 100.0d0 100.0l0)) - for s = (format nil "~10,1,,,'*f" x) - for s2 = (formatter-call-to-string fn x) - unless (and (string= s "*****100.0") (string= s s2)) - collect (list x s s2))) - nil) - -;;; v parameters - -(deftest format.f.28 - (let ((fn (formatter "~VF"))) - (loop for x = (random 100.0) - for s1 = (format nil "~f" x) - for s2 = (format nil "~vf" nil x) - for s3 = (formatter-call-to-string fn nil x) - repeat 100 - unless (and (string= s1 s2) (string= s2 s3)) - collect (list x s1 s2 s3))) - nil) - -(deftest format.f.29 - (let ((fn (formatter "~,vf"))) - (loop for x = (random 100.0) - for s1 = (format nil "~f" x) - for s2 = (format nil "~,vf" nil x) - for s3 = (formatter-call-to-string fn nil x) - repeat 100 - unless (and (string= s1 s2) (string= s2 s3)) - collect (list x s1 s2 s3))) - nil) - -(deftest format.f.30 - (let ((fn (formatter "~,,Vf"))) - (loop for x = (random 100.0) - for s1 = (format nil "~f" x) - for s2 = (format nil "~,,vf" nil x) - for s3 = (formatter-call-to-string fn nil x) - repeat 100 - unless (and (string= s1 s2) (string= s2 s3)) - collect (list x s1 s2 s3))) - nil) - -(deftest format.f.31 - (let ((fn (formatter "~,,,vF"))) - (loop for x = (random 100.0) - for s1 = (format nil "~f" x) - for s2 = (format nil "~,,,vf" nil x) - for s3 = (formatter-call-to-string fn nil x) - repeat 100 - unless (and (string= s1 s2) (string= s2 s3)) - collect (list x s1 s2 s3))) - nil) - -(deftest format.f.32 - (let ((fn (formatter "~,,,,VF"))) - (loop for x = (random 100.0) - for s1 = (format nil "~f" x) - for s2 = (format nil "~,,,,vf" nil x) - for s3 = (formatter-call-to-string fn nil x) - repeat 100 - unless (and (string= s1 s2) (string= s2 s3)) - collect (list x s1 s2 s3))) - nil) - -;;; Randomized tests - -#| -(deftest format.f.33 - (let ((bound (if (> 10000000 most-positive-short-float) - most-positive-short-float - (coerce 10000000 'short-float)))) - (loop for d = (random 10) - for w = (+ 1 d (random 10)) - for x = (random bound) - for xr = (rational x) - for s = (format nil "~v,vf" w d x) - for sr = (decode-fixed-decimal-string s) - for eps = (expt 1/10 d) - for abs-xr-sr = (abs (- xr sr)) - for abs-xr-sr-hi = (abs (- xr (+ sr eps))) - for abs-xr-sr-lo = (abs (- xr (- sr eps))) - repeat 100 - unless (and (<= abs-xr-sr abs-xr-sr-hi) - (<= abs-xr-sr abs-xr-sr-lo)) - collect (list d w x xr s sr eps abs-xr-sr abs-xr-sr-hi abs-xr-sr-lo))) - nil) -|# - -(deftest format.f.34 - (with-standard-io-syntax - (let ((*read-default-float-format* 'short-float)) - (loop for i from (- 1 (ash 1 13)) below (ash 1 13) - for sf = (coerce i 'short-float) - for s = (format nil "~f" sf) - for i2 = (floor (read-from-string s)) - unless (or (zerop i) (eql i i2)) - collect (list i sf s i2)))) - nil) - -(deftest format.f.35 - (with-standard-io-syntax - (let ((*read-default-float-format* 'single-float)) - (loop for i = (- (random (1- (ash 1 25))) -1 (ash 1 24)) - for sf = (coerce i 'single-float) - for s = (format nil "~f" sf) - for i2 = (floor (read-from-string s)) - repeat 2000 - unless (or (zerop i) (eql i i2)) - collect (list i sf s i2)))) - nil) - -(deftest format.f.36 - (with-standard-io-syntax - (let ((*read-default-float-format* 'double-float)) - (loop for i = (- (random (1- (ash 1 51))) -1 (ash 1 50)) - for sf = (coerce i 'double-float) - for s = (format nil "~f" sf) - for i2 = (floor (read-from-string s)) - repeat 2000 - unless (or (zerop i) (eql i i2)) - collect (list i sf s i2)))) - nil) - -(deftest format.f.37 - (with-standard-io-syntax - (let ((*read-default-float-format* 'long-float)) - (loop for i = (- (random (1- (ash 1 51))) -1 (ash 1 50)) - for sf = (coerce i 'long-float) - for s = (format nil "~f" sf) - for i2 = (floor (read-from-string s)) - repeat 2000 - unless (or (zerop i) (eql i i2)) - collect (list i sf s i2)))) - nil) - -(deftest format.f.38 - (funcall - (compile - nil - '(lambda () - (with-standard-io-syntax - (let ((*read-default-float-format* 'short-float) - (total 0) - (len 0)) - (loop for i from (- 1 (ash 1 13)) below (ash 1 13) - unless (zerop i) - nconc - (loop for sf = (coerce i 'short-float) - for w = (random 8) - for d = (random 4) - for s = (format nil "~v,vf" w d sf) - for i2 = (ignore-errors (floor (read-from-string s))) - repeat 5 - ; do (print (list w d s i i2)) - unless (eql i i2) - do (incf total) - and collect (list i sf w d s i2)) - when (> total 100) collect "count limit exceeded" - and do (loop-finish))))))) - nil) - -(deftest format.f.39 - (with-standard-io-syntax - (let ((*read-default-float-format* 'single-float)) - (loop for i = (- (random (1- (ash 1 25))) -1 (ash 1 24)) - for sf = (coerce i 'single-float) - for w = (and (coin) (random 16)) - for d = (random 4) - for s = (format nil "~v,vf" w d sf) - for i2 = (floor (read-from-string s)) - repeat 2000 - unless (or (zerop i) (eql i i2)) - collect (list i sf w d s i2)))) - nil) - -(deftest format.f.40 - (with-standard-io-syntax - (let ((*read-default-float-format* 'double-float)) - (loop for i = (- (random (1- (ash 1 51))) -1 (ash 1 50)) - for sf = (coerce i 'double-float) - for w = (and (coin) (random 30)) - for d = (random 6) - for s = (format nil "~v,vf" w d sf) - for i2 = (floor (read-from-string s)) - repeat 2000 - unless (or (zerop i) (eql i i2)) - collect (list i sf w d s i2)))) - nil) - -(deftest format.f.41 - (with-standard-io-syntax - (let ((*read-default-float-format* 'long-float)) - (loop for i = (- (random (1- (ash 1 51))) -1 (ash 1 50)) - for sf = (coerce i 'long-float) - for w = (and (coin) (random 30)) - for d = (random 6) - for s = (format nil "~v,vf" w d sf) - for i2 = (floor (read-from-string s)) - repeat 2000 - unless (or (zerop i) (eql i i2)) - collect (list i sf w d s i2)))) - nil) - -(deftest format.f.42 - (let ((chars +standard-chars+)) - (loop - for k = (and (coin) (random 6)) - for x = (random (/ (random-from-seq #(#.(coerce (* 32 (1- (ash 1 13))) 'short-float) - #.(coerce (* 256 (1- (ash 1 24))) 'single-float) - #.(coerce (* 256 (1- (ash 1 50))) 'double-float) - #.(coerce (* 256 (1- (ash 1 50))) 'long-float))) - (if k (expt 10 k) 1))) - for w = (and (coin) (random 30)) - for d = (and (coin) (random 10)) - for overflowchar = (and (coin) (random-from-seq chars)) - for padchar = (and (coin) (random-from-seq chars)) - for f1 = (concatenate 'string - "~" - (if w (format nil "~d" w) "") - "," - (if d (format nil "~d" d) "") - "," - (if k (format nil "~d" k) "") - "," - (if overflowchar (format nil "'~c" overflowchar) "") - "," - (if padchar (format nil "'~c" padchar) "") - (string (random-from-seq "fF"))) - for s1 = (format nil f1 x) - for s2 = (format nil "~v,v,v,v,vf" w d k overflowchar padchar x) - repeat 2000 - unless (string= s1 s2) - collect (list x w d k overflowchar padchar f1 s1 s2))) - nil) - -;;; This failed in sbcl 0.8.12.25 - -(def-format-test format.f.43 - "~,,,,',f" (0.0) "0.0") - -(deftest format.f.44 - (loop for i from 0 below (min #x10000 char-code-limit) - for x = 2312.9817 - for c = (code-char i) - for f1 = (and c (format nil "~~,,,,'~cf" c)) - for s1 = (and c (ignore-errors (format nil f1 x))) - for s2 = (and c (format nil "~,,,,vf" c x)) - unless (equal s1 s2) - collect (list i c f1 s1 s2)) - nil) - -(def-format-test format.f.45 - "~2f" (1.1) "1.0") - -(def-format-test format.f.45b - "~3f" (1.1) "1.1") - -;; This fails on ECL 15.3.7 -(def-format-test format.f.46 - "~0f" (0.01) ".0") - -;; sbcl prints "." -(def-format-test format.f.46b - "~0,0f" (0.01) "0.") - -;; Most implementations print .00 -(def-format-test format.f.47 - "~3f" (0.000001) "0.0") - -;; CCL 1.10 and ECL 15.3.7 ignore k parameter when w and d aren't set -(def-format-test format.f.48 - "~,,2f" (0.1) "10.0") diff --git a/t/ansi-test/printer/format/format-goto.lsp b/t/ansi-test/printer/format/format-goto.lsp deleted file mode 100644 index 4397f7d..0000000 --- a/t/ansi-test/printer/format/format-goto.lsp +++ /dev/null @@ -1,114 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Aug 24 06:56:13 2004 -;;;; Contains: Tests of the ~* format directive - - - - - -;;; ~* - -(def-format-test format.*.1 - "~A~*~A" (1 2 3) "13") - -(def-format-test format.*.2 - "~A~0*~A" (1 2 3) "12" 1) - -(def-format-test format.*.3 - "~A~v*~A" (1 0 2) "12") - -(def-format-test format.*.4 - "~A~v*~A" (1 1 2 3) "13") - -(def-format-test format.*.5 - "~A~v*~A" (1 nil 2 3) "13") - -(def-format-test format.*.6 - "~A~1{~A~*~A~}~A" (0 '(1 2 3) 4) "0134") - -(def-format-test format.*.7 - "~A~1{~A~0*~A~}~A" (0 '(1 2 3) 4) "0124") - -(def-format-test format.*.8 - "~A~{~A~*~A~}~A" (0 '(1 2 3 4 5 6) 7) "013467") - -(def-format-test format.*.9 - "~A~{~A~A~A~A~v*~^~A~A~A~A~}~A" (0 '(1 2 3 4 nil 6 7 8 9 #\A) 5) - "01234789A5") - -;;; ~:* - -(def-format-test format.\:*.1 - "~A~:*~A" (1 2 3) "11" 2) - -(def-format-test format.\:*.2 - "~A~A~:*~A" (1 2 3) "122" 1) - -(def-format-test format.\:*.3 - "~A~A~0:*~A" (1 2 3) "123") - -(def-format-test format.\:*.4 - "~A~A~2:*~A" (1 2 3) "121" 2) - -(def-format-test format.\:*.5 - "~A~A~v:*~A" (1 2 0 3) "123") - -(def-format-test format.\:*.6 - "~A~A~v:*~A" (6 7 2 3) "677" 2) - -(def-format-test format.\:*.7 - "~A~A~v:*~A" (6 7 nil 3) "67NIL" 1) - -(def-format-test format.\:*.8 - "~A~1{~A~:*~A~}~A" (0 '(1 2 3) 4) "0114") - -(def-format-test format.\:*.9 - "~A~1{~A~A~A~:*~A~}~A" (0 '(1 2 3 4) 5) "012335") - -(def-format-test format.\:*.10 - "~A~1{~A~A~A~2:*~A~A~}~A" (0 '(1 2 3 4) 5) "0123235") - -(def-format-test format.\:*.11 - "~A~{~A~A~A~3:*~A~A~A~A~}~A" (0 '(1 2 3 4) 5) "012312345") - -(def-format-test format.\:*.12 - "~A~{~A~A~A~A~4:*~^~A~A~A~A~}~A" (0 '(1 2 3 4) 5) "0123412345") - -(def-format-test format.\:*.13 - "~A~{~A~A~A~A~v:*~^~A~}~A" (0 '(1 2 3 4 nil) 5) "01234NIL5") - -;;; ~@* - -(def-format-test format.@*.1 - "~A~A~@*~A~A" (1 2 3 4) "1212" 2) - -(def-format-test format.@*.2 - "~A~A~1@*~A~A" (1 2 3 4) "1223" 1) - -(def-format-test format.@*.3 - "~A~A~2@*~A~A" (1 2 3 4) "1234") - -(def-format-test format.@*.4 - "~A~A~3@*~A~A" (1 2 3 4 5) "1245") - -(def-format-test format.@*.5 - "~A~A~v@*~A~A" (1 2 nil 3 4) "1212" 3) - -(def-format-test format.@*.6 - "~A~A~v@*~A~A" (1 2 1 3 4) "1221" 2) - -(def-format-test format.@*.7 - "~A~A~v@*~A~A" (6 7 2 3 4) "6723" 1) - -(def-format-test format.@*.8 - "~A~{~A~A~@*~A~A~}~A" (0 '(1 2) 9) "012129") - -(def-format-test format.@*.9 - "~A~{~A~A~0@*~A~A~}~A" (0 '(1 2) 9) "012129") - -(def-format-test format.@*.10 - "~A~1{~A~A~v@*~A~A~}~A" (0 '(1 2 nil) 9) "012129") - -(def-format-test format.@*.11 - "~A~{~A~A~1@*~A~}~A" (0 '(1 2) 9) "01229") diff --git a/t/ansi-test/printer/format/format-i.lsp b/t/ansi-test/printer/format/format-i.lsp deleted file mode 100644 index 79b1f0e..0000000 --- a/t/ansi-test/printer/format/format-i.lsp +++ /dev/null @@ -1,92 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Aug 21 07:01:36 2004 -;;;; Contains: Tests for the ~I format directive - - - - - -;;; pprint-indent.9 -(def-pprint-test format.i.1 - (format nil "~" '(M M)) - "M - M") - -;;; See pprint-indent.10 -(def-pprint-test format.i.2 - (format nil "~:" '(M M)) - "(M - M)") - -;;; See pprint-indent.11 -(def-pprint-test format.i.3 - (format nil "~<(~;M~-1:i~:@_M~;)~:>" '(M M)) - "(M - M)") - -(def-pprint-test format.i.4 - (format nil "~:" '(M M)) - "(M - M)") - -(def-pprint-test format.i.5 - (format nil "~<(~;M~:I~:@_M~;)~:>" '(M M)) - "(M - M)") - -(def-pprint-test format.i.6 - (format nil "~<(~;M~v:i~:@_M~;)~:>" '(nil)) - "(M - M)") - -(def-pprint-test format.i.7 - (format nil "~:" '(M M)) - "(M -M)") - -(def-pprint-test format.i.8 - (format nil "~" '(M M)) - "M - M") - -;;; See pprint-indent.13 -(def-pprint-test format.i.9 - (format nil "~" '(M M)) - "MMM -MMMMM") - -(def-pprint-test format.i.10 - (format nil "~:" '(M M)) - "(MMM - MMMMM)") - -(def-pprint-test format.i.11 - (format nil "~" '(M M)) - "MMM - MMMMM") - -(def-pprint-test format.i.12 - (format nil "XXX~" '(M M)) - "XXXMMM - MMMMM") - -(def-pprint-test format.i.13 - (format nil "XXX~" '(M M)) - "XXXMMM - MMMMM") - -(def-pprint-test format.i.14 - (format nil "XXX~" '(M M)) - "XXXMMM - MMMMM") - -(def-pprint-test format.i.15 - (format nil "XXX~" '(nil)) - "XXXMMM - MMMMM") - -(def-pprint-test format.i.16 - (format nil "XXX~" '(2)) - "XXXMMM - MMMMM") diff --git a/t/ansi-test/printer/format/format-justify.lsp b/t/ansi-test/printer/format/format-justify.lsp deleted file mode 100644 index bcfd67a..0000000 --- a/t/ansi-test/printer/format/format-justify.lsp +++ /dev/null @@ -1,279 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Aug 22 18:09:49 2004 -;;;; Contains: Tests of the ~< ~> directive - - - - - -(def-pprint-test format.justify.1 - (format nil "~<~>") - "") - -(def-pprint-test format.justify.2 - (loop for i from 1 to 20 - for s1 = (make-string i :initial-element #\x) - for s2 = (format nil "~<~A~>" s1) - unless (string= s1 s2) - collect (list i s1 s2)) - nil) - -(def-pprint-test format.justify.3 - (loop for i from 1 to 20 - for s1 = (make-string i :initial-element #\x) - for s2 = (format nil "~<~A~;~A~>" s1 s1) - unless (string= s2 (concatenate 'string s1 s1)) - collect (list i s1 s2)) - nil) - -(def-pprint-test format.justify.4 - (loop for i from 1 to 20 - for s1 = (make-string i :initial-element #\x) - for expected = (concatenate 'string s1 " " s1) - for s2 = (format nil "~,,1<~A~;~A~>" s1 s1) - unless (string= s2 expected) - collect (list i expected s2)) - nil) - -(def-pprint-test format.justify.5 - (loop for i from 1 to 20 - for s1 = (make-string i :initial-element #\x) - for expected = (concatenate 'string s1 "," s1) - for s2 = (format nil "~,,1,',<~A~;~A~>" s1 s1) - unless (string= s2 expected) - collect (list i expected s2)) - nil) - -(def-pprint-test format.justify.6 - (loop for i from 1 to 20 - for s1 = (make-string i :initial-element #\x) - for expected = (concatenate 'string s1 " " s1) - for s2 = (format nil "~,,2<~A~;~A~>" s1 s1) - unless (string= s2 expected) - collect (list i expected s2)) - nil) - -(def-pprint-test format.justify.7 - (loop for mincol = (random 50) - for len = (random 50) - for s1 = (make-string len :initial-element #\x) - for s2 = (format nil "~v<~A~>" mincol s1) - for expected = (if (< len mincol) - (concatenate 'string - (make-string (- mincol len) :initial-element #\Space) - s1) - s1) - repeat 100 - unless (string= s2 expected) - collect (list mincol len s1 s2 expected)) - nil) - -(def-pprint-test format.justify.8 - (loop for mincol = (random 50) - for minpad = (random 10) - for len = (random 50) - for s1 = (make-string len :initial-element #\x) - for s2 = (format nil "~v,,v<~A~>" mincol minpad s1) - for expected = (if (< len mincol) - (concatenate 'string - (make-string (- mincol len) :initial-element #\Space) - s1) - s1) - repeat 100 - unless (string= s2 expected) - collect (list mincol minpad len s1 s2 expected)) - nil) - -(def-pprint-test format.justify.9 - (loop for mincol = (random 50) - for padchar = (random-from-seq +standard-chars+) - for len = (random 50) - for s1 = (make-string len :initial-element #\x) - for s2 = (format nil "~v,,,v<~A~>" mincol padchar s1) - for expected = (if (< len mincol) - (concatenate 'string - (make-string (- mincol len) :initial-element padchar) - s1) - s1) - repeat 100 - unless (string= s2 expected) - collect (list mincol padchar len s1 s2 expected)) - nil) - -(def-pprint-test format.justify.10 - (loop for mincol = (random 50) - for padchar = (random-from-seq +standard-chars+) - for len = (random 50) - for s1 = (make-string len :initial-element #\x) - for s2 = (format nil (format nil "~~~d,,,'~c<~~A~~>" mincol padchar) s1) - for expected = (if (< len mincol) - (concatenate 'string - (make-string (- mincol len) :initial-element padchar) - s1) - s1) - repeat 500 - unless (string= s2 expected) - collect (list mincol padchar len s1 s2 expected)) - nil) - -(def-pprint-test format.justify.11 - (loop for i = (1+ (random 20)) - for colinc = (1+ (random 10)) - for s1 = (make-string i :initial-element #\x) - for s2 = (format nil "~,v<~A~>" colinc s1) - for expected-len = (* colinc (ceiling i colinc)) - for expected = (concatenate 'string - (make-string (- expected-len i) :initial-element #\Space) - s1) - repeat 10 - unless (string= expected s2) - collect (list i colinc expected s2)) - nil) - -(def-pprint-test format.justify.12 - (format nil "~") - "") - -(def-pprint-test format.justify.13 - (format nil "~") - "XXXXXX") - -(def-pprint-test format.justify.13a - (format nil "~<~~>") - "XXXXXX") - -(def-pprint-test format.justify.14 - (format nil "~") - "XXXXXX") - -(def-pprint-test format.justify.15 - (format nil "~13,,2") - "aaa bbb ccc") - -(def-pprint-test format.justify.16 - (format nil "~10@") - "abcdef ") - -(def-pprint-test format.justify.17 - (format nil "~10:@") - " abcdef ") - -(def-pprint-test format.justify.18 - (format nil "~10:") - " abcdef") - -(def-pprint-test format.justify.19 - (format nil "~4@<~>") - " ") - -(def-pprint-test format.justify.20 - (format nil "~5:@<~>") - " ") - -(def-pprint-test format.justify.21 - (format nil "~6:<~>") - " ") - -(def-pprint-test format.justify.22 - (format nil "~v<~A~>" nil "XYZ") - "XYZ") - -(def-pprint-test format.justify.23 - (format nil "~,v<~A~;~A~>" nil "ABC" "DEF") - "ABCDEF") - -(def-pprint-test format.justify.24 - (format nil "~,,v<~A~;~A~>" nil "ABC" "DEF") - "ABCDEF") - -(def-pprint-test format.justify.25 - (format nil "~,,1,v<~A~;~A~>" nil "ABC" "DEF") - "ABC DEF") - -(def-pprint-test format.justify.26 - (format nil "~,,1,v<~A~;~A~>" #\, "ABC" "DEF") - "ABC,DEF") - -(def-pprint-test format.justify.27 - (format nil "~6") - " abc") - -(def-pprint-test format.justify.28 - (format nil "~6@") - "abc ") - -;;; ~:; tests - -(def-pprint-test format.justify.29 - (format nil "~%X ~,,1<~%X ~:;AAA~;BBB~;CCC~>") - " -X AAA BBB CCC") - -(def-pprint-test format.justify.30 - (format nil "~%X ~<~%X ~0,3:;AAA~>~<~%X ~0,3:;BBB~>~<~%X ~0,3:;CCC~>") - " -X -X AAA -X BBB -X CCC") - -(def-pprint-test format.justify.31 - (format nil "~%X ~<~%X ~0,30:;AAA~>~<~%X ~0,30:;BBB~>~<~%X ~0,30:;CCC~>") - " -X AAABBBCCC") - -(def-pprint-test format.justify.32 - (format nil "~%X ~<~%X ~0,3:;AAA~>,~<~%X ~0,3:;BBB~>,~<~%X ~0,3:;CCC~>") - " -X -X AAA, -X BBB, -X CCC") - -;;; Error cases - -;;; See 22.3.5.2 - -;;; Interaction with ~W - -(deftest format.justify.error.w.1 - (signals-error-always (format nil "~< ~W ~>" nil) error) - t t) - -(deftest format.justify.error.w.2 - (signals-error-always (format nil "~~W" nil) error) - t t) - -(deftest format.justify.error.w.3 - (signals-error-always (format nil "~w~" nil) error) - t t) - -;;; Interaction with ~_ - -(deftest format.justify.error._.1 - (signals-error-always (format nil "~< ~_ ~>") error) - t t) - -(deftest format.justify.error._.2 - (signals-error-always (format nil "~~_") error) - t t) - -(deftest format.justify.error._.3 - (signals-error-always (format nil "~_~") error) - t t) - -;;; Interaction with ~I - -(deftest format.justify.error.i.1 - (signals-error-always (format nil "~< ~i ~>") error) - t t) - -(deftest format.justify.error.i.2 - (signals-error-always (format nil "~~I") error) - t t) - -(deftest format.justify.error.i.3 - (signals-error-always (format nil "~i~") error) - t t) - diff --git a/t/ansi-test/printer/format/format-logical-block.lsp b/t/ansi-test/printer/format/format-logical-block.lsp deleted file mode 100644 index 98155f1..0000000 --- a/t/ansi-test/printer/format/format-logical-block.lsp +++ /dev/null @@ -1,311 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Aug 8 12:17:31 2004 -;;;; Contains: Tests of the ~< ~:> format directives - - - - - -;;; Error cases - -;;; Prefix and suffix cannot contain format directives - -(deftest format.logical-block.error.1 - (signals-error-always (format nil "~" '(X) '(Y)) error) - t t) - -(deftest format.logical-block.error.2 - (signals-error-always (format nil "~" '(X) '(Y)) error) - t t) - -(deftest format.logical-block.error.3 - (signals-error-always (format nil "~" '(X) '(Y)) error) - t t) - -(deftest format.logical-block.error.4 - (signals-error-always (format nil "~" '(X) '(Y)) error) - t t) - -(deftest format.logical-block.error.5 - (signals-error-always (format nil "~" '(X) '(Y)) error) - t t) - -(deftest format.logical-block.error.6 - (signals-error-always (format nil "~" '(X) '(Y)) error) - t t) - -(deftest format.logical-block.error.7 - (signals-error-always (format nil "~<~;~A~;bar~A~:>" '(X) '(Y)) error) - t t) - -(deftest format.logical-block.error.8 - (signals-error-always (format nil "~<~@;~A~;bar~A~:>" '(X) '(Y)) error) - t t) - -(deftest format.logical-block.error.9 - (signals-error-always (format nil "~:" '(X) '(Y)) error) - t t) - -(deftest format.logical-block.error.10 - (signals-error-always (format nil "~:" '(X) '(Y)) error) - t t) - -(deftest format.logical-block.error.11 - (signals-error-always (format nil "~:" '(X) '(Y)) error) - t t) - -(deftest format.logical-block.error.12 - (signals-error-always (format nil "~:" '(X) '(Y)) error) - t t) - -(deftest format.logical-block.error.13 - (signals-error-always (format nil "~:" '(X) '(Y)) error) - t t) - -(deftest format.logical-block.error.14 - (signals-error-always (format nil "~:" '(X) '(Y)) error) - t t) - -(deftest format.logical-block.error.15 - (signals-error-always (format nil "~:<~;~A~;bar~A~:>" '(X) '(Y)) error) - t t) - -(deftest format.logical-block.error.16 - (signals-error-always (format nil "~:<~@;~A~;bar~A~:>" '(X) '(Y)) error) - t t) - -(deftest format.logical-block.error.17 - (signals-error-always (format nil "~@" '(X) '(Y)) error) - t t) - -(deftest format.logical-block.error.18 - (signals-error-always (format nil "~@" '(X) '(Y)) error) - t t) - -(deftest format.logical-block.error.19 - (signals-error-always (format nil "~@" '(X) '(Y)) error) - t t) - -(deftest format.logical-block.error.20 - (signals-error-always (format nil "~@" '(X) '(Y)) error) - t t) - -(deftest format.logical-block.error.21 - (signals-error-always (format nil "~@" '(X) '(Y)) error) - t t) - -(deftest format.logical-block.error.22 - (signals-error-always (format nil "~@" '(X) '(Y)) error) - t t) - -(deftest format.logical-block.error.23 - (signals-error-always (format nil "~@<~;~A~;bar~A~:>" '(X) '(Y)) error) - t t) - -(deftest format.logical-block.error.24 - (signals-error-always (format nil "~@<~@;~A~;bar~A~:>" '(X) '(Y)) error) - t t) - -(deftest format.logical-block.error.25 - (signals-error-always (format nil "1~Z~>2" nil nil nil) error) - t t) - -;;; "an error is also signaled if the ~<...~:;...~> form of ~<...~> is used -;;; in the same format string with ~W, ~_, ~<...~:>, ~I, or ~:T." - -(deftest format.logical-block.error.26 - (signals-error-always (format nil "~<~:;~>~<~:>" nil nil nil) error) - t t) - -(deftest format.logical-block.error.27 - (signals-error-always (format nil "~<~:>~<~:;~>" nil nil nil) error) - t t) - -;;; Non-error tests - -(def-pprint-test format.logical-block.1 - (format nil "~<~A~:>" '(nil)) - "NIL") - -(def-pprint-test format.logical-block.2 - (format nil "~@<~A~:>" nil) - "NIL") - -(def-pprint-test format.logical-block.3 - (format nil "~:<~A~:>" '(nil)) - "(NIL)") - -(def-pprint-test format.logical-block.4 - (format nil "~:@<~A~:>" nil) - "(NIL)") - -(def-pprint-test format.logical-block.5 - (format nil "~@:<~A~:>" nil) - "(NIL)") - -(def-pprint-test format.logical-block.6 - (format nil "~<~@{~A~^*~}~:>" '(1 2 3)) - "1*2*3") - -(def-pprint-test format.logical-block.7 - (format nil "~:<~@{~A~^*~}~:>" '(1 2 3)) - "(1*2*3)") - -(def-pprint-test format.logical-block.8 - (format nil "~:<~@{~A~^*~}~:>" 1) - "1") - -(def-pprint-test format.logical-block.9 - (format nil "~<~;~A~;~:>" '(1 2 3)) - "1") - -(def-pprint-test format.logical-block.10 - (format nil "~<~;~A~:>" '(1 2 3)) - "1") - -(def-pprint-test format.logical-block.11 - (format nil "~@<~;~A~;~:>" '(1 2 3)) - "(1 2 3)") - -(def-pprint-test format.logical-block.12 - (format nil "~@<~;~A~:>" '(1 2 3)) - "(1 2 3)") - -(def-pprint-test format.logical-block.13 - (format nil "~:<[~;~@{~A~^/~}~:>" '(1 2 3)) - "[1/2/3)") - -(def-pprint-test format.logical-block.14 - (format nil "~:<~;~@{~A~^/~}~;]~:>" '(1 2 3)) - "1/2/3]") - -(def-pprint-test format.logical-block.15 - (format nil "~:<[~;~@{~A~^/~}~;]~:>" '(1 2 3)) - "[1/2/3]") - -(def-pprint-test format.logical-block.16 - (format nil "~@<~@{~A~^*~}~:>" 1 2 3) - "1*2*3") - -(def-pprint-test format.logical-block.17 - (format nil "~@<~@{~A~^ ~_~}~:>" 1 2 3) - "1 2 3") - -(def-pprint-test format.logical-block.18 - (format nil "~@<~@{~A~^ ~_~}~:>" 1 2 3) - "1 -2 -3" - :margin 2) - -(def-pprint-test format.logical-block.19 - (format nil "~:@<~@{~A~^ ~_~}~:>" 1 2 3) - "(1 - 2 - 3)" - :margin 2) - -(def-pprint-test format.logical-block.20 - (format nil "~@:<~@{~A~^ ~}~:>" 1 2 3) - "(1 2 3)" - :margin 2) - -(def-pprint-test format.logical-block.21 - (format nil "~@:<~@{~A~^ ~:_~}~:>" 1 2 3) - "(1 - 2 - 3)" - :margin 2) - -(def-pprint-test format.logical-block.22 - (format nil "~:@<~@{~A~^ ~}~:@>" 1 2 3) - "(1 - 2 - 3)" - :margin 2) - -(def-pprint-test format.logical-block.23 - (format nil "~:@<~@{~A~^/~ - ~}~:@>" 1 2 3) - "(1/2/3)" - :margin 2) - -(def-pprint-test format.logical-block.24 - (format nil "~:@<~@{~A~^ ~:_~}~:>" 1 2 3) - "(1 - 2 - 3)" - :margin 2) - -(def-pprint-test format.logical-block.25 - (format nil "~:@<~@{~A~^ ~}~:@>" 1 2 3) - "(1 - 2 - 3)" - :margin 2) - -(def-pprint-test format.logical-block.26 - (format nil "~:@<~@{~A~^~}~:@>" "1 2 3") - "(1 2 3)" - :margin 2) - -(def-pprint-test format.logical-block.27 - (format nil "~@<**~@;~@{~A~^ ~}~:@>" 1 2 3) - "**1 -**2 -**3" - :margin 3) - -(def-pprint-test format.logical-block.28 - (format nil "~@<**~@;~@{~A~^ ~}~;XX~:@>" 1 2 3) - "**1 -**2 -**3XX" - :margin 3) - -(def-pprint-test format.logical-block.29 - (format nil "~:@<**~@;~@{~A~^ ~}~:@>" 1 2 3) - "**1 -**2 -**3)" - :margin 3) - - -;;; Circularity detection - -(def-pprint-test format.logical-block.circle.1 - (format nil "~:<~@{~A~^ ~}~:>" (let ((x (list 0))) (list x x))) - "(#1=(0) #1#)" - :circle t) - -(def-pprint-test format.logical-block.circle.2 - (format nil "~:<~@{~A~^ ~}~:>" (let ((x (list 0))) (cons x x))) - "(#1=(0) . #1#)" - :circle t) - -(def-pprint-test format.logical-block.circle.3 - (format nil "~:<~@{~A~^ ~}~:>" (let ((x (list 0))) - (setf (cdr x) x) - x)) - "#1=(0 . #1#)" - :circle t - :len 500) - -(def-pprint-test format.logical-block.circle.4 - (format nil "~:<~@{~A~^ ~}~:>" (let ((x (list 0))) (list x x))) - "((0) (0))") - -(def-pprint-test format.logical-block.circle.5 - (format nil "~:<~@{~A~^ ~}~:>" (let ((x (list 0))) (cons x x))) - "((0) 0)") - -;;; ~^ terminates a logical block - -(def-pprint-test format.logical-block.escape.1 - (format nil "~<~A~^xxxx~:>" '(1)) - "1") - -(def-pprint-test format.logical-block.escape.2 - (format nil "~<~<~A~^xxx~:>yyy~:>" '((1))) - "1yyy") diff --git a/t/ansi-test/printer/format/format-newline.lsp b/t/ansi-test/printer/format/format-newline.lsp deleted file mode 100644 index 4bf8c78..0000000 --- a/t/ansi-test/printer/format/format-newline.lsp +++ /dev/null @@ -1,20 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Nov 27 08:07:16 2004 -;;;; Contains: Tests of ~ - - - - -(def-format-test format.newline.1 - (concatenate 'string "~" (string #\Newline) " X") - nil "X") - -(def-format-test format.newline.2 - (concatenate 'string "A~:" (string #\Newline) " X") - nil "A X") - -(def-format-test format.newline.3 - (concatenate 'string "A~@" (string #\Newline) " X") - nil #.(concatenate 'string "A" (string #\Newline) "X")) - diff --git a/t/ansi-test/printer/format/format-o.lsp b/t/ansi-test/printer/format/format-o.lsp deleted file mode 100644 index 813d7f9..0000000 --- a/t/ansi-test/printer/format/format-o.lsp +++ /dev/null @@ -1,538 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Aug 1 06:36:30 2004 -;;;; Contains: Tests of format directive ~O - - - - - -(deftest format.o.1 - (let ((fn (formatter "~o"))) - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~O" i) - for j = (let ((*read-base* 8)) (read-from-string s1)) - for s2 = (formatter-call-to-string fn i) - repeat 1000 - when (or (/= i j) - (not (string= s1 s2)) - (find #\. s1) - (find #\+ s1) - (find-if #'alpha-char-p s1)) - collect (list i s1 j s2)))) - nil) - -(deftest format.o.2 - (let ((fn (formatter "~@O"))) - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~@o" i) - for j = (let ((*read-base* 8)) (read-from-string s1)) - for s2 = (formatter-call-to-string fn i) - repeat 1000 - when (or (/= i j) - (not (string= s1 s2)) - (find #\. s1) - ;; (find #\+ s1) - (find-if #'alpha-char-p s1)) - collect (list i s1 j s2)))) - nil) - -(deftest format.o.3 - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~o" i) - for fmt = (format nil "~~~do" mincol) - for s2 = (format nil fmt i) - for pos = (search s1 s2) - repeat 1000 - when (or (null pos) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (not (eql (position #\Space s2 :test-not #'eql) - (- (length s2) (length s1))))))) - collect (list i mincol s1 s2 pos))) - nil) - -(deftest formatter.o.3 - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~o" i) - for fmt = (format nil "~~~do" mincol) - for fn = (eval `(formatter ,fmt)) - for s2 = (formatter-call-to-string fn i) - for pos = (search s1 s2) - repeat 100 - when (or (null pos) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (not (eql (position #\Space s2 :test-not #'eql) - (- (length s2) (length s1))))))) - collect (list i mincol s1 s2 pos))) - nil) - -(deftest format.o.4 - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~@O" i) - for fmt = (format nil "~~~d@o" mincol) - for s2 = (format nil fmt i) - for pos = (search s1 s2) - repeat 1000 - when (or (null pos) - (and (>= i 0) (not (eql (elt s1 0) #\+))) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (not (eql (position #\Space s2 :test-not #'eql) - (- (length s2) (length s1))))))) - collect (list i mincol s1 s2 pos))) - nil) - -(deftest formatter.o.4 - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~@O" i) - for fmt = (format nil "~~~d@o" mincol) - for fn = (eval `(formatter ,fmt)) - for s2 = (formatter-call-to-string fn i) - for pos = (search s1 s2) - repeat 100 - when (or (null pos) - (and (>= i 0) (not (eql (elt s1 0) #\+))) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (not (eql (position #\Space s2 :test-not #'eql) - (- (length s2) (length s1))))))) - collect (list i mincol s1 s2 pos))) - nil) - -(deftest format.o.5 - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for padchar = (random-from-seq +standard-chars+) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~o" i) - for fmt = (format nil "~~~d,'~c~c" mincol padchar - (random-from-seq "oO")) - for s2 = (format nil fmt i) - for pos = (search s1 s2) - repeat 1000 - when (or (null pos) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (find padchar s2 :end (- (length s2) (length s1)) - :test-not #'eql)))) - collect (list i mincol s1 s2 pos))) - nil) - -(deftest formatter.o.5 - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for padchar = (random-from-seq +standard-chars+) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~o" i) - for fmt = (format nil "~~~d,'~c~c" mincol padchar - (random-from-seq "oO")) - for fn = (eval `(formatter ,fmt)) - for s2 = (formatter-call-to-string fn i) - for pos = (search s1 s2) - repeat 100 - when (or (null pos) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (find padchar s2 :end (- (length s2) (length s1)) - :test-not #'eql)))) - collect (list i mincol s1 s2 pos))) - nil) - -(deftest format.o.6 - (let ((fn (formatter "~V,Vo"))) - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for padchar = (random-from-seq +standard-chars+) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~o" i) - for s2 = (format nil "~v,vO" mincol padchar i) - for s3 = (formatter-call-to-string fn mincol padchar i) - for pos = (search s1 s2) - repeat 1000 - when (or (null pos) - (not (string= s2 s3)) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (find padchar s2 :end (- (length s2) (length s1)) - :test-not #'eql)))) - collect (list i mincol s1 s2 s3 pos)))) - nil) - -(deftest format.o.7 - (let ((fn (formatter "~v,V@O"))) - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for padchar = (random-from-seq +standard-chars+) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~@o" i) - for s2 = (format nil "~v,v@o" mincol padchar i) - for s3 = (formatter-call-to-string fn mincol padchar i) - for pos = (search s1 s2) - repeat 1000 - when (or (null pos) - (not (string= s2 s3)) - (and (>= i 0) (not (eql (elt s1 0) #\+))) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (find padchar s2 :end (- (length s2) (length s1)) - :test-not #'eql)))) - collect (list i mincol s1 s2 s3 pos)))) - nil) - -;;; Comma tests - -(deftest format.o.8 - (let ((fn (formatter "~:O"))) - (loop for i from #o-777 to #o777 - for s1 = (format nil "~o" i) - for s2 = (format nil "~:o" i) - for s3 = (formatter-call-to-string fn i) - unless (and (string= s1 s2) (string= s2 s3)) - collect (list i s1 s2 s3))) - nil) - -(deftest format.o.9 - (let ((fn (formatter "~:o"))) - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = #\, - for s1 = (format nil "~o" i) - for s2 = (format nil "~:O" i) - for s3 = (formatter-call-to-string fn i) - repeat 1000 - unless (and (string= s1 (remove commachar s2)) - (string= s2 s3) - (not (eql (elt s2 0) commachar)) - (or (>= i 0) (not (eql (elt s2 1) commachar))) - (let ((len (length s2)) - (ci+1 4)) - (loop for i from (if (< i 0) 2 1) below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (find (elt s2 i) "01234567"))))) - collect (list x i commachar s1 s2 s3)))) - nil) - -(deftest format.o.10 - (let ((fn (formatter "~,,v:o"))) - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = (random-from-seq +standard-chars+) - for s1 = (format nil "~o" i) - for s2 = (format nil "~,,v:o" commachar i) - for s3 = (formatter-call-to-string fn commachar i) - repeat 1000 - unless (and - (eql (elt s1 0) (elt s2 0)) - (string= s2 s3) - (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) - (let ((len (length s2)) - (ci+1 4) - (j (if (< i 0) 1 0))) - (loop for i from (if (< i 0) 2 1) below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (eql (elt s1 (incf j)) (elt s2 i)))))) - collect (list x i commachar s1 s2 s3)))) - nil) - -(deftest format.o.11 - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = (random-from-seq +standard-chars+) - for s1 = (format nil "~o" i) - for fmt = (format nil "~~,,'~c:~c" commachar (random-from-seq "oO")) - for s2 = (format nil fmt i) - repeat 1000 - unless (and - (eql (elt s1 0) (elt s2 0)) - (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) - (let ((len (length s2)) - (ci+1 4) - (j (if (< i 0) 1 0))) - (loop for i from (if (< i 0) 2 1) below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (eql (elt s1 (incf j)) (elt s2 i)))))) - collect (list x i commachar s1 s2))) - nil) - -(deftest formatter.o.11 - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = (random-from-seq +standard-chars+) - for s1 = (format nil "~o" i) - for fmt = (format nil "~~,,'~c:~c" commachar (random-from-seq "oO")) - for fn = (eval `(formatter ,fmt)) - for s2 = (formatter-call-to-string fn i) - repeat 100 - unless (and - (eql (elt s1 0) (elt s2 0)) - (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) - (let ((len (length s2)) - (ci+1 4) - (j (if (< i 0) 1 0))) - (loop for i from (if (< i 0) 2 1) below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (eql (elt s1 (incf j)) (elt s2 i)))))) - collect (list x i commachar s1 s2))) - nil) - -(deftest format.o.12 - (let ((fn (formatter "~,,V,v:O"))) - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = (random-from-seq +standard-chars+) - for commaint = (1+ (random 20)) - for s1 = (format nil "~o" i) - for s2 = (format nil "~,,v,v:O" commachar commaint i) - for s3 = (formatter-call-to-string fn commachar commaint i) - repeat 1000 - unless (and - (eql (elt s1 0) (elt s2 0)) - (string= s2 s3) - (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) - (let ((len (length s2)) - (ci+1 (1+ commaint)) - (j (if (< i 0) 1 0))) - (loop for i from (if (< i 0) 2 1) below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (eql (elt s1 (incf j)) (elt s2 i)))))) - collect (list x i commachar s1 s2 s3)))) - nil) - -(deftest format.o.13 - (let ((fn (formatter "~,,v,V@:O"))) - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = (random-from-seq +standard-chars+) - for commaint = (1+ (random 20)) - for s1 = (format nil "~@o" i) - for s2 = (format nil "~,,v,v:@o" commachar commaint i) - for s3 = (formatter-call-to-string fn commachar commaint i) - repeat 1000 - unless (and - (string= s2 s3) - (eql (elt s1 0) (elt s2 0)) - (eql (elt s1 1) (elt s2 1)) - (let ((len (length s2)) - (ci+1 (1+ commaint)) - (j 1)) - (loop for i from 2 below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (eql (elt s1 (incf j)) (elt s2 i)))))) - collect (list x i commachar s1 s2 s3)))) - nil) - -;;; NIL arguments - -(def-format-test format.o.14 - "~vO" (nil #o100) "100") - -(def-format-test format.o.15 - "~6,vO" (nil #o100) " 100") - -(def-format-test format.o.16 - "~,,v:o" (nil #o12345) "12,345") - -(def-format-test format.o.17 - "~,,'*,v:o" (nil #o12345) "12*345") - -;;; When the argument is not an integer, print as if using ~A and base 10 - -(deftest format.o.18 - (let ((fn (formatter "~o"))) - (loop for x in *mini-universe* - for s1 = (format nil "~o" x) - for s2 = (let ((*print-base* 8)) (format nil "~A" x)) - for s3 = (formatter-call-to-string fn x) - unless (or (integerp x) (and (string= s1 s2) (string= s2 s3))) - collect (list x s1 s2 s3))) - nil) - -(deftest format.o.19 - (let ((fn (formatter "~:o"))) - (loop for x in *mini-universe* - for s1 = (format nil "~:o" x) - for s2 = (let ((*print-base* 8)) (format nil "~A" x)) - for s3 = (formatter-call-to-string fn x) - unless (or (integerp x) (and (string= s1 s2) (string= s2 s3))) - collect (list x s1 s2 s3))) - nil) - -(deftest format.o.20 - (let ((fn (formatter "~@o"))) - (loop for x in *mini-universe* - for s1 = (format nil "~@o" x) - for s2 = (let ((*print-base* 8)) (format nil "~A" x)) - for s3 = (formatter-call-to-string fn x) - unless (or (integerp x) (and (string= s1 s2) (string= s2 s3))) - collect (list x s1 s2 s3))) - nil) - -(deftest format.o.21 - (let ((fn (formatter "~:@o"))) - (loop for x in *mini-universe* - for s1 = (let ((*print-base* 8)) (format nil "~A" x)) - for s2 = (format nil "~@:o" x) - for s3 = (formatter-call-to-string fn x) - for s4 = (let ((*print-base* 8)) (format nil "~A" x)) - unless (or (integerp x) (and (string= s1 s2) (string= s2 s3)) - (string/= s1 s4)) - collect (list x s1 s2 s3))) - nil) - -;;; Must add tests for non-integers when the parameters -;;; are specified, but it's not clear what the meaning is. -;;; Does mincol apply to the ~A equivalent? What about padchar? -;;; Are comma-char and comma-interval always ignored? - -;;; # arguments - -(deftest format.o.22 - (apply - #'values - (let ((fn (formatter "~#o")) - (n #o12345)) - (loop for i from 0 to 10 - for args = (make-list i) - for s = (apply #'format nil "~#o" n args) - for s2 = (with-output-to-string - (stream) - (assert (equal (apply fn stream n args) args))) - do (assert (string= s s2)) - collect s))) - "12345" - "12345" - "12345" - "12345" - "12345" - " 12345" - " 12345" - " 12345" - " 12345" - " 12345" - " 12345") - -(deftest format.o.23 - (apply - #'values - (let ((fn (formatter "~,,,#:o")) - (n #o1234567012)) - (loop for i from 0 to 10 - for args = (make-list i) - for s = (apply #'format nil "~,,,#:o" n args) - for s2 = (with-output-to-string - (stream) - (assert (equal (apply fn stream n args) args))) - do (assert (string= s s2)) - collect s))) - "1,2,3,4,5,6,7,0,1,2" - "12,34,56,70,12" - "1,234,567,012" - "12,3456,7012" - "12345,67012" - "1234,567012" - "123,4567012" - "12,34567012" - "1,234567012" - "1234567012" - "1234567012") - -(deftest format.o.24 - (apply - #'values - (let ((fn (formatter "~,,,#:@o")) - (n #o1234567012)) - (loop for i from 0 to 10 - for args = (make-list i) - for s = (apply #'format nil "~,,,#@:O" n args) - for s2 = (with-output-to-string - (stream) - (assert (equal (apply fn stream n args) args))) - do (assert (string= s s2)) - collect s))) - "+1,2,3,4,5,6,7,0,1,2" - "+12,34,56,70,12" - "+1,234,567,012" - "+12,3456,7012" - "+12345,67012" - "+1234,567012" - "+123,4567012" - "+12,34567012" - "+1,234567012" - "+1234567012" - "+1234567012") - -(def-format-test format.o.25 - "~+10o" (#o1234) " 1234") - -(def-format-test format.o.26 - "~+10@O" (#o1234) " +1234") - -(def-format-test format.o.27 - "~-1O" (#o1234) "1234") - -(def-format-test format.o.28 - "~-1000000000000000000o" (#o1234) "1234") - -(def-format-test format.o.29 - "~vo" ((1- most-negative-fixnum) #o1234) "1234") - -;;; Randomized test - -(deftest format.o.30 - (let ((fn (formatter "~v,v,v,vo"))) - (loop - for mincol = (and (coin) (random 50)) - for padchar = (and (coin) - (random-from-seq +standard-chars+)) - for commachar = (and (coin) - (random-from-seq +standard-chars+)) - for commaint = (and (coin) (1+ (random 10))) - for k = (ash 1 (+ 2 (random 30))) - for x = (- (random (+ k k)) k) - for fmt = (concatenate - 'string - (if mincol (format nil "~~~d," mincol) "~,") - (if padchar (format nil "'~c," padchar) ",") - (if commachar (format nil "'~c," commachar) ",") - (if commaint (format nil "~do" commaint) "o")) - for s1 = (format nil fmt x) - for s2 = (format nil "~v,v,v,vo" mincol padchar commachar commaint x) - for s3 = (formatter-call-to-string fn mincol padchar commachar commaint x) - repeat 2000 - unless (and (string= s1 s2) (string= s2 s3)) - collect (list mincol padchar commachar commaint fmt x s1 s2 s3))) - nil) diff --git a/t/ansi-test/printer/format/format-p.lsp b/t/ansi-test/printer/format/format-p.lsp deleted file mode 100644 index 43158ee..0000000 --- a/t/ansi-test/printer/format/format-p.lsp +++ /dev/null @@ -1,92 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Oct 17 21:32:45 2004 -;;;; Contains: Tests of the ~P format directives - - - - - -(def-format-test format.p.1 - "~p" (1) "") - -(def-format-test format.p.2 - "~P" (2) "s") - -(def-format-test format.p.3 - "~p" (0) "s") - -(def-format-test format.p.4 - "~P" (1.0) "s") - -(deftest format.p.5 - (loop for x in *universe* - for s = (format nil "~p" x) - unless (or (eql x 1) (string= s "s")) - collect (list x s)) - nil) - -(deftest formatter.p.5 - (let ((fn (formatter "~p"))) - (loop for x in *universe* - for s = (formatter-call-to-string fn x) - unless (or (eql x 1) (string= s "s")) - collect (list x s))) - nil) - -;;; :p - -(def-format-test format.p.6 - "~D cat~:P" (1) "1 cat") - -(def-format-test format.p.7 - "~D cat~:p" (2) "2 cats") - -(def-format-test format.p.8 - "~D cat~:P" (0) "0 cats") - -(def-format-test format.p.9 - "~D cat~:p" ("No") "No cats") - -;;; :@p - -(def-format-test format.p.10 - "~D penn~:@P" (1) "1 penny") - -(def-format-test format.p.11 - "~D penn~:@p" (2) "2 pennies") - -(def-format-test format.p.12 - "~D penn~@:P" (0) "0 pennies") - -(def-format-test format.p.13 - "~D penn~@:p" ("No") "No pennies") - -;;; @p - -(def-format-test format.p.14 - "~@p" (1) "y") - -(def-format-test format.p.15 - "~@P" (2) "ies") - -(def-format-test format.p.16 - "~@p" (0) "ies") - -(def-format-test format.p.17 - "~@P" (1.0) "ies") - -(deftest format.p.18 - (loop for x in *universe* - for s = (format nil "~@p" x) - unless (or (eql x 1) (string= s "ies")) - collect (list x s)) - nil) - -(deftest formatter.p.18 - (let ((fn (formatter "~@P"))) - (loop for x in *universe* - for s = (formatter-call-to-string fn x) - unless (or (eql x 1) (string= s "ies")) - collect (list x s))) - nil) diff --git a/t/ansi-test/printer/format/format-page.lsp b/t/ansi-test/printer/format/format-page.lsp deleted file mode 100644 index 1b96e21..0000000 --- a/t/ansi-test/printer/format/format-page.lsp +++ /dev/null @@ -1,44 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Jul 28 00:20:46 2004 -;;;; Contains: Tests of format with ~| directive - - - - -(def-format-test format.page.1 - "~0|" nil "") - -(deftest format.page.2 - (let ((s (format nil "~|"))) - (cond - ((string= s "") nil) - ((> (length s) 1) (values s :too-long)) - (t - (let ((c (elt s 0))) - (loop for i from 2 to 100 - for s = (format nil (format nil "~~~D|" i)) - unless (and (= (length s) i) - (every #'(lambda (c2) (char= c c2)) s)) - collect i))))) - nil) - -(deftest format.page.3 - (let ((s (format nil "~|"))) - (cond - ((string= s "") nil) - ((> (length s) 1) (values s :too-long)) - (t - (let ((c (elt s 0))) - (loop for i from 2 to 100 - for s = (format nil "~v|" i) - unless (and (= (length s) i) - (every #'(lambda (c2) (char= c c2)) s)) - collect i))))) - nil) - -(def-format-test format.page.4 - "~V|" (0) "") - -(def-format-test format.page.5 - "~v|" (nil) #.(format nil "~|")) diff --git a/t/ansi-test/printer/format/format-paren.lsp b/t/ansi-test/printer/format/format-paren.lsp deleted file mode 100644 index 57fad10..0000000 --- a/t/ansi-test/printer/format/format-paren.lsp +++ /dev/null @@ -1,155 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Oct 17 20:28:24 2004 -;;;; Contains: Tests of the ~( format directives - - - - - -(def-format-test format.paren.1 - "~(XXyy~AuuVV~)" ("ABc dEF ghI") "xxyyabc def ghiuuvv") - -;;; Conversion of simple characters to downcase -(deftest format.paren.2 - (loop for i from 0 below (min char-code-limit (ash 1 16)) - for c = (code-char i) - when (and c - (eql (char-code c) (char-int c)) - (upper-case-p c) - (let ((s1 (format nil "~(~c~)" c)) - (s2 (string (char-downcase c)))) - (if - (or (not (eql (length s1) 1)) - (not (eql (length s2) 1)) - (not (eql (elt s1 0) - (elt s2 0)))) - (list i c s1 s2) - nil))) - collect it) - nil) - -(deftest formatter.paren.2 - (let ((fn (formatter "~(~c~)"))) - (loop for i from 0 below (min char-code-limit (ash 1 16)) - for c = (code-char i) - when (and c - (eql (char-code c) (char-int c)) - (upper-case-p c) - (let ((s1 (formatter-call-to-string fn c)) - (s2 (string (char-downcase c)))) - (if - (or (not (eql (length s1) 1)) - (not (eql (length s2) 1)) - (not (eql (elt s1 0) - (elt s2 0)))) - (list i c s1 s2) - nil))) - collect it)) - nil) - - -(def-format-test format.paren.3 - "~@(this is a TEST.~)" nil "This is a test.") - -(def-format-test format.paren.4 - "~@(!@#$%^&*this is a TEST.~)" nil "!@#$%^&*This is a test.") - -(def-format-test format.paren.5 - "~:(this is a TEST.~)" nil "This Is A Test.") - -(def-format-test format.paren.6 - "~:(this is7a TEST.~)" nil "This Is7a Test.") - -(def-format-test format.paren.7 - "~:@(this is AlSo A teSt~)" nil "THIS IS ALSO A TEST") - -(deftest format.paren.8 - (loop for i from 0 below (min char-code-limit (ash 1 16)) - for c = (code-char i) - when (and c - (eql (char-code c) (char-int c)) - (lower-case-p c) - (let ((s1 (format nil "~@:(~c~)" c)) - (s2 (string (char-upcase c)))) - (if - (or (not (eql (length s1) 1)) - (not (eql (length s2) 1)) - (not (eql (elt s1 0) - (elt s2 0)))) - (list i c s1 s2) - nil))) - collect it) - nil) - -(deftest formatter.paren.8 - (let ((fn (formatter "~@:(~c~)"))) - (loop for i from 0 below (min char-code-limit (ash 1 16)) - for c = (code-char i) - when (and c - (eql (char-code c) (char-int c)) - (lower-case-p c) - (let ((s1 (formatter-call-to-string fn c)) - (s2 (string (char-upcase c)))) - (if - (or (not (eql (length s1) 1)) - (not (eql (length s2) 1)) - (not (eql (elt s1 0) - (elt s2 0)))) - (list i c s1 s2) - nil))) - collect it)) - nil) - -;;; Nested conversion - -(def-format-test format.paren.9 - "~(aBc ~:(def~) GHi~)" nil "abc def ghi") - -(def-format-test format.paren.10 - "~(aBc ~(def~) GHi~)" nil "abc def ghi") - -(def-format-test format.paren.11 - "~@(aBc ~:(def~) GHi~)" nil "Abc def ghi") - -(def-format-test format.paren.12 - "~(aBc ~@(def~) GHi~)" nil "abc def ghi") - -(def-format-test format.paren.13 - "~(aBc ~:(def~) GHi~)" nil "abc def ghi") - -(def-format-test format.paren.14 - "~:(aBc ~(def~) GHi~)" nil "Abc Def Ghi") - -(def-format-test format.paren.15 - "~:(aBc ~:(def~) GHi~)" nil "Abc Def Ghi") - -(def-format-test format.paren.16 - "~:(aBc ~@(def~) GHi~)" nil "Abc Def Ghi") - -(def-format-test format.paren.17 - "~:(aBc ~@:(def~) GHi~)" nil "Abc Def Ghi") - -(def-format-test format.paren.18 - "~@(aBc ~(def~) GHi~)" nil "Abc def ghi") - -(def-format-test format.paren.19 - "~@(aBc ~:(def~) GHi~)" nil "Abc def ghi") - -(def-format-test format.paren.20 - "~@(aBc ~@(def~) GHi~)" nil "Abc def ghi") - -(def-format-test format.paren.21 - "~@(aBc ~@:(def~) GHi~)" nil "Abc def ghi") - -(def-format-test format.paren.22 - "~:@(aBc ~(def~) GHi~)" nil "ABC DEF GHI") - -(def-format-test format.paren.23 - "~@:(aBc ~:(def~) GHi~)" nil "ABC DEF GHI") - -(def-format-test format.paren.24 - "~:@(aBc ~@(def~) GHi~)" nil "ABC DEF GHI") - -(def-format-test format.paren.25 - "~@:(aBc ~@:(def~) GHi~)" nil "ABC DEF GHI") diff --git a/t/ansi-test/printer/format/format-percent.lsp b/t/ansi-test/printer/format/format-percent.lsp deleted file mode 100644 index f99d62b..0000000 --- a/t/ansi-test/printer/format/format-percent.lsp +++ /dev/null @@ -1,65 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Jul 27 23:47:44 2004 -;;;; Contains: Tests of format with ~% directive - - - - -(def-format-test format.%.1 - "~%" nil #.(string #\Newline)) - -(deftest format.%.2 - (loop for i from 0 to 100 - for s1 = (make-string i :initial-element #\Newline) - for format-string = (format nil "~~~D%" i) - for s2 = (format nil format-string) - for fn = (eval `(formatter ,s2)) - for s3 = (formatter-call-to-string fn) - unless (and (string= s1 s2) (string= s1 s3)) - collect i) - nil) - -(def-format-test format.%.3 - "~v%" (nil) #.(string #\Newline)) - -(def-format-test format.%.4 - "~V%" (1) #.(string #\Newline)) - -(deftest format.%.5 - (loop for i from 0 to 100 - for s1 = (make-string i :initial-element #\Newline) - for s2 = (format nil "~v%" i) - unless (string= s1 s2) - collect i) - nil) - -(deftest formatter.%.5 - (let ((fn (formatter "~v%"))) - (loop for i from 0 to 100 - for s1 = (make-string i :initial-element #\Newline) - for s2 = (formatter-call-to-string fn i) - unless (string= s1 s2) - collect i)) - nil) - -(deftest format.%.6 - (loop for i from 0 to (min (- call-arguments-limit 3) 100) - for args = (make-list i) - for s1 = (make-string i :initial-element #\Newline) - for s2 = (apply #'format nil "~#%" args) - unless (string= s1 s2) - collect i) - nil) - -(deftest formatter.%.6 - (let ((fn (formatter "~#%"))) - (loop for i from 0 to (min (- call-arguments-limit 3) 100) - for args = (make-list i) - for s1 = (make-string i :initial-element #\Newline) - for s2 = (with-output-to-string - (stream) - (assert (equal (apply fn stream args) args))) - unless (string= s1 s2) - collect i)) - nil) diff --git a/t/ansi-test/printer/format/format-question.lsp b/t/ansi-test/printer/format/format-question.lsp deleted file mode 100644 index 476843c..0000000 --- a/t/ansi-test/printer/format/format-question.lsp +++ /dev/null @@ -1,40 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Oct 17 20:08:18 2004 -;;;; Contains: Tests of the ~? and ~@? format directives - - - - - -(def-format-test format.?.1 - "~?" ("" nil) "") - -(def-format-test format.?.2 - "~?" ("~A" '(1)) "1") - -(def-format-test format.?.3 - "~?" ("" '(1)) "") - -(def-format-test format.?.4 - "~? ~A" ("" '(1) 2) " 2") - -(def-format-test format.?.5 - "a~?z" ("b~?y" '("c~?x" ("~A" (1)))) "abc1xyz") - -;;; Tests of ~@? - -(def-format-test format.@?.1 - "~@?" ("") "") - -(def-format-test format.@?.2 - "~@?" ("~A" 1) "1") - -(def-format-test format.@?.3 - "~@? ~A" ("<~A>" 1 2) "<1> 2") - -(def-format-test format.@?.4 - "a~@?z" ("b~@?y" "c~@?x" "~A" 1) "abc1xyz") - -(def-format-test format.@?.5 - "~{~A~@?~A~}" ('(1 "~4*" 2 3 4 5 6)) "16") diff --git a/t/ansi-test/printer/format/format-r.lsp b/t/ansi-test/printer/format/format-r.lsp deleted file mode 100644 index 32fcd17..0000000 --- a/t/ansi-test/printer/format/format-r.lsp +++ /dev/null @@ -1,466 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Jul 28 00:33:02 2004 -;;;; Contains: Tests of the format directive ~R - - - -;;; Test of various radixes - -(compile-and-load "roman-numerals.lsp") - -(deftest format.r.1 - (loop - for i from 2 to 36 - for s = (format nil "~~~dR" i) - nconc - (loop for x = (let ((bound (ash 1 (+ 2 (random 40))))) - (- (random (* bound 2)) bound)) - for s1 = (format nil s x) - for s2 = (with-standard-io-syntax - (write-to-string x :base i :readably nil)) - repeat 100 - unless (string= s1 s2) - collect (list i x s1 s2))) - nil) - -(deftest formatter.r.1 - (loop - for i from 2 to 36 - for s = (format nil "~~~dR" i) - for fn = (eval `(formatter ,s)) - nconc - (loop for x = (let ((bound (ash 1 (+ 2 (random 40))))) - (- (random (* bound 2)) bound)) - for s1 = (formatter-call-to-string fn x) - for s2 = (with-standard-io-syntax - (write-to-string x :base i :readably nil)) - repeat 100 - unless (string= s1 s2) - collect (list i x s1 s2))) - nil) - -(def-format-test format.r.2 - "~2r" (14) "1110") - -(def-format-test format.r.3 - "~3r" (29) "1002") - -(deftest format.r.4 - (loop for base from 2 to 36 - nconc - (loop for mincol from 0 to 20 - for fmt = (format nil "~~~D,~DR" base mincol) - for s = (format nil fmt base) - unless (if (<= mincol 2) - (string= s "10") - (string= (concatenate - 'string - (make-string (- mincol 2) - :initial-element #\Space) - "10") - s)) - collect (list base mincol s))) - nil) - -(deftest formatter.r.4 - (loop for base from 2 to 36 - nconc - (loop for mincol from 0 to 20 - for fmt = (format nil "~~~D,~DR" base mincol) - for fn = (eval `(formatter ,fmt)) - for s = (formatter-call-to-string fn base) - unless (if (<= mincol 2) - (string= s "10") - (string= (concatenate - 'string - (make-string (- mincol 2) - :initial-element #\Space) - "10") - s)) - collect (list base mincol s))) - nil) - -(deftest format.r.5 - (loop for base from 2 to 36 - nconc - (loop for mincol from 0 to 20 - for fmt = (format nil "~~~D,~D,'*r" base mincol) - for s = (format nil fmt base) - unless (if (<= mincol 2) - (string= s "10") - (string= (concatenate - 'string - (make-string (- mincol 2) - :initial-element #\*) - "10") - s)) - collect (list base mincol s))) - nil) - -(deftest formatter.r.5 - (loop for base from 2 to 36 - nconc - (loop for mincol from 0 to 20 - for fmt = (format nil "~~~D,~D,'*r" base mincol) - for fn = (eval `(formatter ,fmt)) - for s = (formatter-call-to-string fn base) - unless (if (<= mincol 2) - (string= s "10") - (string= (concatenate - 'string - (make-string (- mincol 2) - :initial-element #\*) - "10") - s)) - collect (list base mincol s))) - nil) - -(deftest format.r.6 - (loop for base from 2 to 36 - for s = (format nil "~vr" base (1+ base)) - unless (string= s "11") - collect (list base s)) - nil) - -(deftest formatter.r.6 - (let ((fn (formatter "~vr"))) - (loop for base from 2 to 36 - for s = (formatter-call-to-string fn base (1+ base)) - unless (string= s "11") - collect (list base s))) - nil) - -(defparameter *english-number-names* - '("zero" - "one" "two" "three" "four" "five" "six" "seven" "eight" "nine" "ten" - "eleven" "twelve" "thirteen" "fourteen" "fifteen" "sixteen" - "seventeen" "eighteen" "nineteen" "twenty" - "twenty-one" "twenty-two" "twenty-three" "twenty-four" "twenty-five" - "twenty-six" "twenty-seven" "twenty-eight" "twenty-nine" "thirty" - "thirty-one" "thirty-two" "thirty-three" "thirty-four" "thirty-five" - "thirty-six" "thirty-seven" "thirty-eight" "thirty-nine" "forty" - "forty-one" "forty-two" "forty-three" "forty-four" "forty-five" - "forty-six" "forty-seven" "forty-eight" "forty-nine" "fifty" - "fifty-one" "fifty-two" "fifty-three" "fifty-four" "fifty-five" - "fifty-six" "fifty-seven" "fifty-eight" "fifty-nine" "sixty" - "sixty-one" "sixty-two" "sixty-three" "sixty-four" "sixty-five" - "sixty-six" "sixty-seven" "sixty-eight" "sixty-nine" "seventy" - "seventy-one" "seventy-two" "seventy-three" "seventy-four" "seventy-five" - "seventy-six" "seventy-seven" "seventy-eight" "seventy-nine" "eighty" - "eighty-one" "eighty-two" "eighty-three" "eighty-four" "eighty-five" - "eighty-six" "eighty-seven" "eighty-eight" "eighty-nine" "ninety" - "ninety-one" "ninety-two" "ninety-three" "ninety-four" "ninety-five" - "ninety-six" "ninety-seven" "ninety-eight" "ninety-nine" "one hundred")) - -(deftest format.r.7 - (loop for i from 0 to 100 - for s1 = (format nil "~r" i) - for s2 in *english-number-names* - unless (string= s1 s2) - collect (list i s1 s2)) - nil) - -(deftest formatter.r.7 - (let ((fn (formatter "~r"))) - (loop for i from 0 to 100 - for s1 = (formatter-call-to-string fn i) - for s2 in *english-number-names* - unless (string= s1 s2) - collect (list i s1 s2))) - nil) - -(deftest format.r.7a - (loop for i from 1 to 100 - for s1 = (format nil "~r" (- i)) - for s2 in (cdr *english-number-names*) - for s3 = (concatenate 'string "negative " s2) - for s4 = (concatenate 'string "minus " s2) - unless (or (string= s1 s3) (string= s1 s4)) - collect (list i s1 s3 s4)) - nil) - -(def-format-test format.r.8 - "~vr" (nil 5) "five") - -(def-format-test format.r.9 - "~#r" (4 nil nil) "11" 2) - -(deftest format.r.10 - (with-standard-io-syntax - (let ((*print-radix* t)) - (format nil "~10r" 123))) - "123") - -(deftest formatter.r.10 - (let ((fn (formatter "~10r"))) - (with-standard-io-syntax - (let ((*print-radix* t)) - (values - (format nil fn 123) - (formatter-call-to-string fn 123))))) - "123" - "123") - -(def-format-test format.r.11 - "~8@R" (65) "+101") - -(def-format-test format.r.12 - "~2:r" (126) "1,111,110") - -(def-format-test format.r.13 - "~3@:r" (#3r2120012102) "+2,120,012,102") - -(deftest format.r.14 - (loop - for i from 2 to 36 - for s = (format nil "~~~d:R" i) - nconc - (loop for x = (let ((bound (ash 1 (+ 2 (random 40))))) - (- (random (* bound 2)) bound)) - for s1 = (remove #\, (format nil s x)) - for y = (let ((*read-base* i)) (read-from-string s1)) - repeat 100 - unless (= x y) - collect (list i x s1 y))) - nil) - -(deftest format.r.15 - (loop - for i = (+ 2 (random 35)) - for interval = (1+ (random 20)) - for comma = (loop for c = (random-from-seq +standard-chars+) - unless (alphanumericp c) - return c) - for s = (format nil "~~~d,,,'~c,~d:R" i comma interval) - for x = (let ((bound (ash 1 (+ 2 (random 40))))) - (- (random (* bound 2)) bound)) - for s1 = (remove comma (format nil s x)) - for y = (let ((*read-base* i)) (read-from-string s1)) - repeat 1000 - unless (or (and (eql comma #\-) (< x 0)) - (= x y)) - collect (list i interval comma x s1 y)) - nil) - -(def-format-test format.r.16 - "~2,,,,1000000000000000000r" (17) "10001") - -(def-format-test format.r.17 - "~8,10:@r" (#o526104) " +526,104") - -(defparameter *english-ordinal-names* - '("zeroth" - "first" "second" "third" "fourth" "fifth" "sixth" "seventh" "eighth" "ninth" "tenth" - "eleventh" "twelfth" "thirteenth" "fourteenth" "fifteenth" "sixteenth" - "seventeenth" "eighteenth" "nineteenth" "twentieth" - "twenty-first" "twenty-second" "twenty-third" "twenty-fourth" "twenty-fifth" - "twenty-sixth" "twenty-seventh" "twenty-eighth" "twenty-ninth" "thirtieth" - "thirty-first" "thirty-second" "thirty-third" "thirty-fourth" "thirty-fifth" - "thirty-sixth" "thirty-seventh" "thirty-eighth" "thirty-ninth" "fortieth" - "forty-first" "forty-second" "forty-third" "forty-fourth" "forty-fifth" - "forty-sixth" "forty-seventh" "forty-eighth" "forty-ninth" "fiftieth" - "fifty-first" "fifty-second" "fifty-third" "fifty-fourth" "fifty-fifth" - "fifty-sixth" "fifty-seventh" "fifty-eighth" "fifty-ninth" "sixtieth" - "sixty-first" "sixty-second" "sixty-third" "sixty-fourth" "sixty-fifth" - "sixty-sixth" "sixty-seventh" "sixty-eighth" "sixty-ninth" "seventieth" - "seventy-first" "seventy-second" "seventy-third" "seventy-fourth" "seventy-fifth" - "seventy-sixth" "seventy-seventh" "seventy-eighth" "seventy-ninth" "eightieth" - "eighty-first" "eighty-second" "eighty-third" "eighty-fourth" "eighty-fifth" - "eighty-sixth" "eighty-seventh" "eighty-eighth" "eighty-ninth" "ninetieth" - "ninety-first" "ninety-second" "ninety-third" "ninety-fourth" "ninety-fifth" - "ninety-sixth" "ninety-seventh" "ninety-eighth" "ninety-ninth" "one hundredth")) - -(deftest format.r.18 - (loop for i from 0 to 100 - for s1 = (format nil "~:r" i) - for s2 in *english-ordinal-names* - unless (string= s1 s2) - collect (list i s1 s2)) - nil) - -(deftest formatter.r.18 - (let ((fn (formatter "~:r"))) - (loop for i from 0 to 100 - for s1 = (formatter-call-to-string fn i) - for s2 in *english-ordinal-names* - unless (string= s1 s2) - collect (list i s1 s2))) - nil) - -(deftest format.r.18a - (loop for i from 1 to 100 - for s1 = (format nil "~:r" (- i)) - for s2 in (cdr *english-ordinal-names*) - for s3 = (concatenate 'string "negative " s2) - for s4 = (concatenate 'string "minus " s2) - unless (or (string= s1 s3) (string= s1 s4)) - collect (list i s1 s3 s4)) - nil) - -(deftest format.r.19 - (loop for i from 1 - for s1 in *roman-numerals* - for s2 = (format nil "~@R" i) - unless (string= s1 s2) - collect (list i s1 s2)) - nil) - -(deftest formatter.r.19 - (let ((fn (formatter "~@r"))) - (loop for i from 1 - for s1 in *roman-numerals* - for s2 = (formatter-call-to-string fn i) - unless (string= s1 s2) - collect (list i s1 s2))) - nil) - -;;; Old roman numerals - -(defun old-roman-numeral (x) - (assert (typep x '(integer 1))) - (let ((n-m 0) - (n-d 0) - (n-c 0) - (n-l 0) - (n-x 0) - (n-v 0) - ) - (loop while (>= x 1000) do (incf n-m) (decf x 1000)) - (when (>= x 500) (incf n-d) (decf x 500)) - (loop while (>= x 100) do (incf n-c) (decf x 100)) - (when (>= x 50) (incf n-l) (decf x 50)) - (loop while (>= x 10) do (incf n-x) (decf x 10)) - (when (>= x 5) (incf n-v) (decf x 5)) - (concatenate 'string - (make-string n-m :initial-element #\M) - (make-string n-d :initial-element #\D) - (make-string n-c :initial-element #\C) - (make-string n-l :initial-element #\L) - (make-string n-x :initial-element #\X) - (make-string n-v :initial-element #\V) - (make-string x :initial-element #\I)))) - -(deftest format.r.20 - (loop for i from 1 to 4999 - for s1 = (format nil "~:@r" i) - for s2 = (old-roman-numeral i) - unless (string= s1 s2) - collect (list i s1 s2)) - nil) - -(deftest formatter.r.20 - (let ((fn (formatter "~@:R"))) - (loop for i from 1 to 4999 - for s1 = (formatter-call-to-string fn i) - for s2 = (old-roman-numeral i) - unless (string= s1 s2) - collect (list i s1 s2))) - nil) - -(deftest format.r.21 - (loop for i from 1 to 4999 - for s1 = (format nil "~:@r" i) - for s2 = (format nil "~@:R" i) - unless (string= s1 s2) - collect (list i s1 s2)) - nil) - -;; Combinations of mincol and comma chars - -(def-format-test format.r.22 - "~2,12,,'*:r" (#b1011101) " 1*011*101") - -(def-format-test format.r.23 - "~3,14,'X,',:R" (#3r1021101) "XXXXX1,021,101") - -;; v directive in various positions - -(def-format-test format.r.24 - "~10,vr" (nil 12345) "12345") - -(deftest format.r.25 - (loop for i from 0 to 5 - for s = (format nil "~10,vr" i 12345) - unless (string= s "12345") - collect (list i s)) - nil) - -(deftest formatter.r.25 - (let ((fn (formatter "~10,vr"))) - (loop for i from 0 to 5 - for s = (formatter-call-to-string fn i 12345) - unless (string= s "12345") - collect (list i s))) - nil) - -(def-format-test format.r.26 - "~10,#r" (12345 nil nil nil nil nil) " 12345" 5) - -(def-format-test format.r.27 - "~10,12,vr" (#\/ 123456789) "///123456789") - -(def-format-test format.r.28 - "~10,,,v:r" (#\/ 123456789) "123/456/789") - -(def-format-test format.r.29 - "~10,,,v:r" (nil 123456789) "123,456,789") - -(def-format-test format.r.30 - "~8,,,,v:R" (nil #o12345670) "12,345,670") - -(def-format-test format.r.31 - "~8,,,,v:R" (2 #o12345670) "12,34,56,70") - -(def-format-test format.r.32 - "~16,,,,#:r" (#x12345670 nil nil nil) "1234,5670" 3) - -(def-format-test format.r.33 - "~16,,,,1:r" (#x12345670) "1,2,3,4,5,6,7,0") - -;;; Explicit signs - -(def-format-test format.r.34 - "~+10r" (12345) "12345") - -(def-format-test format.r.35 - "~10,+8r" (12345) " 12345") - -(def-format-test format.r.36 - "~10,0r" (12345) "12345") - -(def-format-test format.r.37 - "~10,-1r" (12345) "12345") - -(def-format-test format.r.38 - "~10,-1000000000000000r" (12345) "12345") - -;;; Randomized test - -(deftest format.r.39 - (let ((fn (formatter "~v,v,v,v,vr"))) - (loop - for radix = (+ 2 (random 35)) - for mincol = (and (coin) (random 50)) - for padchar = (and (coin) - (random-from-seq +standard-chars+)) - for commachar = (and (coin) - (random-from-seq +standard-chars+)) - for commaint = (and (coin) (1+ (random 10))) - for k = (ash 1 (+ 2 (random 30))) - for x = (- (random (+ k k)) k) - for fmt = (concatenate - 'string - (format nil "~~~d," radix) - (if mincol (format nil "~d," mincol) ",") - (if padchar (format nil "'~c," padchar) ",") - (if commachar (format nil "'~c," commachar) ",") - (if commaint (format nil "~dr" commaint) "r")) - for s1 = (format nil fmt x) - for s2 = (format nil "~v,v,v,v,vr" radix mincol padchar commachar commaint x) - for s3 = (formatter-call-to-string fn radix mincol padchar commachar commaint x) - repeat 2000 - unless (and (string= s1 s2) - (string= s1 s3)) - collect (list radix mincol padchar commachar commaint fmt x s1 s2 s3))) - nil) diff --git a/t/ansi-test/printer/format/format-s.lsp b/t/ansi-test/printer/format/format-s.lsp deleted file mode 100644 index 01f4c38..0000000 --- a/t/ansi-test/printer/format/format-s.lsp +++ /dev/null @@ -1,394 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Aug 3 11:55:07 2004 -;;;; Contains: Test of the ~S format directive - - - - -(deftest format.s.1 - (let ((*print-readably* nil) - (*print-case* :upcase)) - (format nil "~s" nil)) - "NIL") - -(deftest formatter.s.1 - (let ((*print-readably* nil) - (*print-case* :upcase)) - (formatter-call-to-string (formatter "~s") nil)) - "NIL") - -(def-format-test format.s.2 - "~:s" (nil) "()") - -(deftest format.s.3 - (let ((*print-readably* nil) - (*print-case* :upcase)) - (format nil "~:s" '(nil))) - "(NIL)") - -(deftest formatter.s.3 - (let ((*print-readably* nil) - (*print-case* :upcase)) - (formatter-call-to-string (formatter "~:s") '(nil))) - "(NIL)") - -(deftest format.s.4 - (let ((*print-readably* nil) - (*print-case* :downcase)) - (format nil "~s" 'nil)) - "nil") - -(deftest formatter.s.4 - (let ((*print-readably* nil) - (*print-case* :downcase)) - (formatter-call-to-string (formatter "~s") 'nil)) - "nil") - -(deftest format.s.5 - (let ((*print-readably* nil) - (*print-case* :capitalize)) - (format nil "~s" 'nil)) - "Nil") - -(deftest formatter.s.5 - (let ((*print-readably* nil) - (*print-case* :capitalize)) - (formatter-call-to-string (formatter "~s") 'nil)) - "Nil") - -(def-format-test format.s.6 - "~:s" (#(nil)) "#(NIL)") - -(deftest format.s.7 - (let ((fn (formatter "~S"))) - (with-standard-io-syntax - (let ((*print-readably* nil)) - (loop for c across +standard-chars+ - for s = (format nil "~S" c) - for s2 = (formatter-call-to-string fn c) - for c2 = (read-from-string s) - unless (and (eql c c2) (string= s s2)) - collect (list c s c2 s2))))) - nil) - -(deftest format.s.8 - (let ((fn (formatter "~s"))) - (with-standard-io-syntax - (let ((*print-readably* nil)) - (loop with count = 0 - for i from 0 below (min #x10000 char-code-limit) - for c = (code-char i) - for s1 = (and c (format nil "#\\~:c" c)) - for s2 = (and c (format nil "~S" c)) - for s3 = (formatter-call-to-string fn c) - unless (or (null c) - (graphic-char-p c) - (and (string= s1 s2) (string= s2 s3))) - do (incf count) and collect (list c s1 s2) - when (> count 100) - collect "count limit exceeded" - and do (loop-finish))))) - nil) - -(deftest format.s.9 - (with-standard-io-syntax - (let ((*print-readably* nil)) - (apply - #'values - (loop for i from 1 to 10 - for fmt = (format nil "~~~d@s" i) - for s = (format nil fmt nil) - for fn = (eval `(formatter ,fmt)) - for s2 = (formatter-call-to-string fn nil) - do (assert (string= s s2)) - collect s)))) - "NIL" - "NIL" - "NIL" - " NIL" - " NIL" - " NIL" - " NIL" - " NIL" - " NIL" - " NIL") - -(deftest format.s.10 - (with-standard-io-syntax - (let ((*print-readably* nil)) - (apply - #'values - (loop for i from 1 to 10 - for fmt = (format nil "~~~dS" i) - for s = (format nil fmt nil) - for fn = (eval `(formatter ,fmt)) - for s2 = (formatter-call-to-string fn nil) - do (assert (string= s s2)) - collect s)))) - "NIL" - "NIL" - "NIL" - "NIL " - "NIL " - "NIL " - "NIL " - "NIL " - "NIL " - "NIL ") - -(deftest format.s.11 - (with-standard-io-syntax - (let ((*print-readably* nil)) - (apply - #'values - (loop for i from 1 to 10 - for fmt = (format nil "~~~d@:S" i) - for s = (format nil fmt nil) - for fn = (eval `(formatter ,fmt)) - for s2 = (formatter-call-to-string fn nil) - do (assert (string= s s2)) - collect s)))) - "()" - "()" - " ()" - " ()" - " ()" - " ()" - " ()" - " ()" - " ()" - " ()") - -(deftest format.s.12 - (with-standard-io-syntax - (let ((*print-readably* nil)) - (apply - #'values - (loop for i from 1 to 10 - for fmt = (format nil "~~~d:s" i) - for s = (format nil fmt nil) - for fn = (eval `(formatter ,fmt)) - for s2 = (formatter-call-to-string fn nil) - do (assert (string= s s2)) - collect s)))) - "()" - "()" - "() " - "() " - "() " - "() " - "() " - "() " - "() " - "() ") - -(deftest format.s.13 - (with-standard-io-syntax - (let ((*print-readably* nil) - (fn (formatter "~V:s"))) - (apply - #'values - (loop for i from 1 to 10 - for s = (format nil "~v:S" i nil) - for s2 = (formatter-call-to-string fn i nil) - do (assert (string= s s2)) - collect s)))) - "()" - "()" - "() " - "() " - "() " - "() " - "() " - "() " - "() " - "() ") - -(deftest format.s.14 - (with-standard-io-syntax - (let ((*print-readably* nil) - (fn (formatter "~V@:s"))) - (apply - #'values - (loop for i from 1 to 10 - for s = (format nil "~v:@s" i nil) - for s2 = (formatter-call-to-string fn i nil) - do (assert (string= s s2)) - collect s)))) - "()" - "()" - " ()" - " ()" - " ()" - " ()" - " ()" - " ()" - " ()" - " ()") - -(def-format-test format.s.15 - "~vS" (nil nil) "NIL") - -(def-format-test format.s.16 - "~v:S" (nil nil) "()") - -(def-format-test format.s.17 - "~@S" (nil) "NIL") - -(def-format-test format.s.18 - "~v@S" (nil nil) "NIL") - -(def-format-test format.s.19 - "~v:@s" (nil nil) "()") - -(def-format-test format.s.20 - "~v@:s" (nil nil) "()") - -;;; With colinc specified - -(def-format-test format.s.21 - "~3,1s" (nil) "NIL") - -(def-format-test format.s.22 - "~4,3s" (nil) "NIL ") - -(def-format-test format.s.23 - "~3,3@s" (nil) "NIL") - -(def-format-test format.s.24 - "~4,4@s" (nil) " NIL") - -(def-format-test format.s.25 - "~5,3@s" (nil) " NIL") - -(def-format-test format.s.26 - "~5,3S" (nil) "NIL ") - -(def-format-test format.s.27 - "~7,3@s" (nil) " NIL") - -(def-format-test format.s.28 - "~7,3S" (nil) "NIL ") - -;;; With minpad - -(deftest format.s.29 - (with-standard-io-syntax - (let ((*print-readably* nil) - (*package* (find-package :cl-test)) - (fn (formatter "~V,,2s"))) - (loop for i from -4 to 10 - for s = (format nil "~v,,2S" i 'ABC) - for s2 = (formatter-call-to-string fn i 'ABC) - do (assert (string= s s2)) - collect s))) - ("ABC " - "ABC " - "ABC " - "ABC " - "ABC " - "ABC " - "ABC " - "ABC " - "ABC " - "ABC " - "ABC " - "ABC " - "ABC " - "ABC " - "ABC ")) - -(def-format-test format.s.30 - "~3,,+2S" ('ABC) "ABC ") - -(def-format-test format.s.31 - "~3,,0S" ('ABC) "ABC") - -(def-format-test format.s.32 - "~3,,-1S" ('ABC) "ABC") - -(def-format-test format.s.33 - "~3,,0S" ('ABCD) "ABCD") - -(def-format-test format.s.34 - "~3,,-1S" ('ABCD) "ABCD") - -;;; With padchar - -(def-format-test format.s.35 - "~4,,,'XS" ('AB) "ABXX") - -(def-format-test format.s.36 - "~4,,,s" ('AB) "AB ") - -(def-format-test format.s.37 - "~4,,,'X@s" ('AB) "XXAB") - -(def-format-test format.s.38 - "~4,,,@S" ('AB) " AB") - -(def-format-test format.s.39 - "~10,,,vS" (nil 'ABCDE) "ABCDE ") - -(def-format-test format.s.40 - "~10,,,v@S" (nil 'ABCDE) " ABCDE") - -(def-format-test format.s.41 - "~10,,,vs" (#\* 'ABCDE) "ABCDE*****") - -(def-format-test format.s.42 - "~10,,,v@s" (#\* 'ABCDE) "*****ABCDE") - -;;; Other tests - -(def-format-test format.s.43 - "~3,,vS" (nil 246) "246") - -(deftest format.s.44 - (with-standard-io-syntax - (let ((*print-readably* nil) - (*package* (find-package :cl-test)) - (fn (formatter "~3,,vs"))) - (loop for i from 0 to 6 - for s = (format nil "~3,,vS" i 'ABC) - for s2 = (formatter-call-to-string fn i 'ABC) - do (assert (string= s s2)) - collect s))) - ("ABC" - "ABC " - "ABC " - "ABC " - "ABC " - "ABC " - "ABC ")) - -(deftest format.s.44a - (with-standard-io-syntax - (let ((*print-readably* nil) - (*package* (find-package :cl-test)) - (fn (formatter "~3,,V@S"))) - (loop for i from 0 to 6 - for s = (format nil "~3,,v@S" i 'ABC) - for s2 = (formatter-call-to-string fn i 'ABC) - do (assert (string= s s2)) - collect s))) - ("ABC" - " ABC" - " ABC" - " ABC" - " ABC" - " ABC" - " ABC")) - -(def-format-test format.s.45 - "~4,,vs" (-1 1234) "1234") - -(def-format-test format.s.46 - "~5,vS" (nil 123) "123 ") - -(def-format-test format.s.47 - "~5,vS" (3 456) "456 ") - -(def-format-test format.s.48 - "~5,v@S" (3 789) " 789") diff --git a/t/ansi-test/printer/format/format-slash.lsp b/t/ansi-test/printer/format/format-slash.lsp deleted file mode 100644 index 9365dbf..0000000 --- a/t/ansi-test/printer/format/format-slash.lsp +++ /dev/null @@ -1,134 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Aug 21 09:51:08 2004 -;;;; Contains: Tests for format directive ~/.../ - - - - - -(def-pprint-test format./.1 - (format nil "~/pprint-linear/" 1) - "1") - -(def-pprint-test format./.2 - (format nil "~/pprint-linear/" 2) - "2" - :pretty nil) - -(def-pprint-test format./.3 - (format nil "~/pprint-linear/" '(17)) - "17") - -(def-pprint-test format./.4 - (format nil "~:/pprint-linear/" '(17)) - "(17)") - -(def-pprint-test format./.5 - (format nil "~@/pprint-linear/" 1) - "1") - -(def-pprint-test format./.6 - (format nil "~@:/pprint-linear/" 1) - "1") - -(def-pprint-test format./.7 - (format nil "~/PPRINT-LINEAR/" 1) - "1") - -(def-pprint-test format./.8 - (format nil "~/pPrINt-lINeaR/" 1) - "1") - -(def-pprint-test format./.9 - (progn - (setf (symbol-function 'FUNCTION-FOR-FORMAT-SLASH-9) #'pprint-linear) - (format nil "~/CL-TEST::FUNCTION-FOR-FORMAT-SLASH-9/" 1)) - "1") - -;;; Single : doesn't mean it has to be exported -(def-pprint-test format./.10 - (progn - (setf (symbol-function 'FUNCTION-FOR-FORMAT-SLASH-10) #'pprint-linear) - (format nil "~/cl-test:FUNCTION-FOR-FORMAT-SLASH-10/" 1)) - "1") - -(def-pprint-test format./.11 - (progn - (setf (symbol-function '|FUNCTION:FOR::FORMAT:SLASH:11|) #'pprint-linear) - (format nil "~/cL-tESt:FUNCTION:FOR::FORMAT:SLASH:11/" 1)) - "1") - -(def-pprint-test format./.12 - (format nil "~<~/pprint-tabular/~:>" '((|M|))) - "M") - -(def-pprint-test format./.13 - (format nil "~<~:/pprint-tabular/~:>" '((|M|))) - "(M)") - -(def-pprint-test format./.14 - (format nil "~<~:@/pprint-tabular/~:>" '((|M|))) - "(M)") - -(def-pprint-test format./.15 - (format nil "~<~@/pprint-tabular/~:>" '((|M|))) - "M") - -(def-pprint-test format./.16 - (format nil "~<~4:/pprint-tabular/~:>" '((|M| |M|))) - "(M M)") - -(def-pprint-test format./.17 - (format nil "~<~v:/pprint-tabular/~:>" '(nil (|M| |M|))) - "(M M)") - -(def-pprint-test format./.18 - (format nil "~<~v:/pprint-tabular/~:>" '(3 (|M| |M|))) - "(M M)") - -(declaim (special *expected-args*)) - -(def-pprint-test format./.19 - (progn - (setf (symbol-function 'function-for-format-slash-19) - #'(lambda (stream &rest args) - (assert (= (length args) (length *expected-args*))) - (assert (equal (car args) (car *expected-args*))) - (assert (if (cadr args) (cadr *expected-args*) - (not (cadr *expected-args*)))) - (assert (if (caddr args) (caddr *expected-args*) - (not (caddr *expected-args*)))) - (apply #'pprint-fill stream (subseq args 0 3)))) - (list - (let ((*expected-args* '(1 nil nil))) - (format nil "~/cl-test::function-for-format-slash-19/" 1)) - (let ((*expected-args* '(2 t nil))) - (format nil "~:/cl-test::function-for-format-slash-19/" 2)) - (let ((*expected-args* '(3 nil t))) - (format nil "~@/cl-test::function-for-format-slash-19/" 3)) - (let ((*expected-args* '(4 t t))) - (format nil "~:@/cl-test::function-for-format-slash-19/" 4)) - (let ((*expected-args* '(5 t t))) - (format nil "~@:/cl-test::function-for-format-slash-19/" 5)) - (let ((*expected-args* '(6 t t 18))) - (format nil "~18@:/cl-test::function-for-format-slash-19/" 6)) - (let ((*expected-args* '(7 nil nil 19))) - (format nil "~v/cl-test::function-for-format-slash-19/" 19 7)) - (let ((*expected-args* '(8 t nil #\X))) - (format nil "~'X:/cl-test::function-for-format-slash-19/" 8)) - (let ((*expected-args* '(9 nil t #\,))) - (format nil "~',@/cl-test::function-for-format-slash-19/" 9)) - (let ((*expected-args* '(10 nil t -1))) - (format nil "~-1@/cl-test::function-for-format-slash-19/" 10)) - (let ((*expected-args* '(11 nil t 1 2 3 4 5 6 7 8 9 10))) - (format nil "~1,2,3,4,5,6,7,8,9,10@/cl-test::function-for-format-slash-19/" 11)) - (let ((*expected-args* '(12 nil t 1 2 3 4 5 6 7 8 9 10))) - (format nil "~v,v,v,v,v,v,v,v,v,v@/cl-test::function-for-format-slash-19/" 1 2 3 4 5 6 7 8 9 10 12)) - )) - ("1" "2" "3" "4" "5" "6" "7" "8" "9" "10" "11" "12")) - - - - - diff --git a/t/ansi-test/printer/format/format-t.lsp b/t/ansi-test/printer/format/format-t.lsp deleted file mode 100644 index d1ceb4d..0000000 --- a/t/ansi-test/printer/format/format-t.lsp +++ /dev/null @@ -1,336 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Aug 21 12:45:22 2004 -;;;; Contains: Tests of the ~T format directive - - - - - -(def-pprint-test format.t.1 - (format nil "~0,0T") - "") - -(def-pprint-test format.t.2 - (format nil "~1,0T") - " ") - -(def-pprint-test format.t.3 - (format nil "~0,1T") - " ") - -(def-pprint-test format.t.4 - (loop for i from 0 to 20 - for s = (format nil "~0,vT" i) - unless (string= s (make-string i :initial-element #\Space)) - collect (list i s)) - nil) - -(def-pprint-test format.t.5 - (loop for i from 0 to 20 - for s = (format nil "~v,0T" i) - unless (string= s (make-string i :initial-element #\Space)) - collect (list i s)) - nil) - -(def-pprint-test format.t.6 - (loop for n1 = (random 30) - for s1 = (make-string n1 :initial-element #\X) - for n2 = (random 30) - for inc = (random 20) - for s2 = (cond - ((< n1 n2) - (concatenate 'string s1 (make-string (- n2 n1) - :initial-element #\Space))) - ((= inc 0) s1) - (t (loop do (incf n2 inc) while (<= n2 n1)) - (concatenate 'string s1 (make-string (- n2 n1) - :initial-element #\Space)))) - for pretty = (coin) - for result = (let ((*print-pretty* pretty)) - (format nil (format nil "~A~~~D,~DT" s1 n2 inc))) - repeat 100 - unless (string= s2 result) - collect (list n1 n2 inc pretty s2 result)) - nil) - -(def-pprint-test format.t.7 - (loop for n1 = (random 30) - for s1 = (make-string n1 :initial-element #\X) - for n2 = (random 30) - for inc = (random 20) - for s2 = (cond - ((< n1 n2) - (concatenate 'string s1 (make-string (- n2 n1) - :initial-element #\Space))) - ((= inc 0) s1) - (t (loop do (incf n2 inc) while (<= n2 n1)) - (concatenate 'string s1 (make-string (- n2 n1) - :initial-element #\Space)))) - for pretty = (coin) - for result = (let ((*print-pretty* pretty)) - (format nil "~A~v,vt" s1 n2 inc)) - repeat 100 - unless (string= s2 result) - collect (list n1 n2 inc pretty s2 result)) - nil) - -(def-pprint-test format.t.8 - (loop for i from 1 to 20 - for s = (format nil " ~v,vT" nil i) - unless (string= s (make-string (1+ i) :initial-element #\Space)) - collect (list i s)) - nil) - -(def-pprint-test format.t.9 - (loop for i from 1 to 20 - for s = (format nil "~v,vT" i nil) - unless (string= s (make-string i :initial-element #\Space)) - collect (list i s)) - nil) - -(def-pprint-test format.t.10 - (format nil "XXXXX~2,0T") - "XXXXX") - -;;; @t - -(def-pprint-test format.@t.1 - (format nil "~1,1@t") - " ") - -(def-pprint-test format.@t.2 - (loop for colnum from 0 to 20 - for s1 = (format nil "~v,1@t" colnum) - for s2 = (make-string colnum :initial-element #\Space) - unless (string= s1 s2) - collect (list colnum s1 s2)) - nil) - -(def-pprint-test format.@t.3 - (loop for colnum = (random 50) - for colinc = (1+ (random 20)) - for s1 = (format nil "~v,v@t" colnum colinc) - for s2 = (make-string (* colinc (ceiling colnum colinc)) - :initial-element #\Space) - repeat 100 - unless (string= s1 s2) - collect (list colnum colinc s1 s2)) - nil) - -(def-pprint-test format.@t.4 - (loop for colnum = (random 50) - for colinc = (1+ (random 20)) - for s1 = (format nil "~v,1@T~0,v@t" colnum colinc) - for s2 = (make-string (* colinc (ceiling colnum colinc)) - :initial-element #\Space) - repeat 100 - unless (string= s1 s2) - collect (list colnum colinc s1 s2)) - nil) - -(def-pprint-test format.@t.5 - (loop for colnum = (random 50) - for colinc = (1+ (random 20)) - for pretty = (coin) - for s1 = (let ((*pretty* pretty)) - (format nil (format nil "~~~d,~d@t" colnum colinc))) - for s2 = (make-string (* colinc (ceiling colnum colinc)) - :initial-element #\Space) - repeat 100 - unless (string= s1 s2) - collect (list colnum colinc pretty s1 s2)) - nil) - -;;; Pretty printing (colon modifier) - -;;; Not a pretty printing stream - -(def-pprint-test format.\:t.1 - (format nil "XX~10:tYY") - "XXYY") - -;;; A pretty printing stream, but *print-pretty* is nil - -(def-pprint-test format.\:t.2 - (with-output-to-string - (s) - (pprint-logical-block - (s '(a b c)) - (format s "XX~10:tYY"))) - "XXYY" - :pretty nil) - -(def-pprint-test format.\:t.3 - (with-output-to-string - (s) - (pprint-logical-block - (s '(a b c)) - (let ((*print-pretty* nil)) - (format s "XX~10:tYY")))) - "XXYY") - -;;; Positive tests - -(def-pprint-test format.\:t.4 - (format nil "~<[~;~0,0:T~;]~:>" '(a)) - "[]") - -(def-pprint-test format.\:t.5 - (format nil "~<[~;~1,0:T~;]~:>" '(a)) - "[ ]") - -(def-pprint-test format.\:t.5a - (format nil "~<[~;~,0:T~;]~:>" '(a)) - "[ ]") - -(def-pprint-test format.\:t.6 - (format nil "~<[~;~0,1:T~;]~:>" '(a)) - "[ ]") - -(def-pprint-test format.\:t.6a - (format nil "~<[~;~0,:T~;]~:>" '(a)) - "[ ]") - -(def-pprint-test format.\:t.6b - (format nil "~<[~;~0:T~;]~:>" '(a)) - "[ ]") - -(def-pprint-test format.\:t.7 - (loop for i from 0 to 20 - for s = (format nil "~" (list i)) - unless (string= s (concatenate 'string "X" (make-string i :initial-element #\Space) "Y")) - collect (list i s)) - nil) - -(def-pprint-test format.\:t.8 - (loop for i from 0 to 20 - for s = (format nil "~" (list i)) - unless (string= s (concatenate 'string "ABC" (make-string i :initial-element #\Space) "DEF")) - collect (list i s)) - nil) - -(def-pprint-test format.\:t.9 - (loop - for n0 = (random 10) - for s0 = (make-string n0 :initial-element #\Space) - for n1 = (random 30) - for s1 = (make-string n1 :initial-element #\X) - for n2 = (random 30) - for inc = (random 20) - for s2 = (cond - ((< n1 n2) - (concatenate 'string s0 s1 (make-string (- n2 n1) - :initial-element #\Space))) - ((= inc 0) (concatenate 'string s0 s1)) - (t (loop do (incf n2 inc) while (<= n2 n1)) - (concatenate 'string s0 s1 (make-string (- n2 n1) - :initial-element #\Space)))) - for result = (format nil (format nil "~A~~<~A~~~D,~D:T~~:>" s0 s1 n2 inc) '(a)) - repeat 100 - unless (string= s2 result) - collect (list n0 n1 n2 inc s2 result)) - nil) - -(def-pprint-test format.\:t.10 - (format nil "~<[~;~2,0:T~;]~:>" '(a)) - "[ ]") - -(def-pprint-test format.\:t.11 - (format nil "~<[~;XXXX~2,0:T~;]~:>" '(a)) - "[XXXX]") - -(def-pprint-test format.\:t.12 - (loop for n0 = (random 20) - for s0 = (make-string n0 :initial-element #\Space) - for n1 = (random 30) - for s1 = (make-string n1 :initial-element #\X) - for n2 = (random 30) - for inc = (random 20) - for s2 = (cond - ((< n1 n2) - (concatenate 'string s0 s1 (make-string (- n2 n1) - :initial-element #\Space))) - ((= inc 0) (concatenate 'string s0 s1)) - (t (loop do (incf n2 inc) while (<= n2 n1)) - (concatenate 'string s0 s1 (make-string (- n2 n1) - :initial-element #\Space)))) - for result = (format nil "~A~<~A~v,v:t~:>" s0 (list s1 n2 inc)) - repeat 100 - unless (string= s2 result) - collect (list n1 n2 inc s2 result)) - nil) - -;;; see 22.3.5.2 - -(deftest format.\:t.error.1 - (signals-error-always (format nil "~") error) - t t) - -(deftest format.\:t.error.2 - (signals-error-always (format nil "~ZZZ~4,5:tWWW") error) - t t) - -(deftest format.\:t.error.3 - (signals-error-always (format nil "AAAA~1,1:TBBB~ZZZ") error) - t t) - -;;; ~:@t - -(def-pprint-test format.\:@t.1 - (format nil "~" '(a)) - "XXX YYY") - -(def-pprint-test format.\:@t.1a - (format nil "~" '(a)) - "XXX YYY") - -(def-pprint-test format.\:@t.1b - (format nil "~" '(a)) - "XXX YYY") - -(def-pprint-test format.\:@t.1c - (format nil "~" '(a)) - "XXX YYY") - -(def-pprint-test format.\:@t.1d - (format nil "~" '(a)) - "XXX YYY") - -(def-pprint-test format.\:@t.2 - (loop for colnum from 0 to 20 - for s1 = (format nil "~" (list colnum)) - for s2 = (concatenate 'string "XXXX" (make-string colnum :initial-element #\Space)) - unless (string= s1 s2) - collect (list colnum s1 s2)) - nil) - -(def-pprint-test format.\:@t.3 - (loop for s0 = (make-string (random 20) :initial-element #\M) - for colnum = (random 50) - for colinc = (1+ (random 20)) - for s1 = (format nil "~A~<~v,v:@t~:>" s0 (list colnum colinc)) - for s2 = (concatenate 'string - s0 - (make-string (* colinc (ceiling colnum colinc)) - :initial-element #\Space)) - repeat 100 - unless (string= s1 s2) - collect (list colnum colinc s1 s2)) - nil) - -;;; Turned off if not pretty printing - -(def-pprint-test format.\:@t.4 - (format nil "XX~10,20:@tYY") - "XXYY" - :pretty nil) - -(def-pprint-test format.\:@t.5 - (with-output-to-string - (s) - (pprint-logical-block - (s '(a b c)) - (format s "XX~10,20@:tYY"))) - "XXYY" - :pretty nil) diff --git a/t/ansi-test/printer/format/format-tilde.lsp b/t/ansi-test/printer/format/format-tilde.lsp deleted file mode 100644 index 16991a8..0000000 --- a/t/ansi-test/printer/format/format-tilde.lsp +++ /dev/null @@ -1,70 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Jul 28 00:27:00 2004 -;;;; Contains: Tests of format directive ~~ - - - - -(def-format-test format.~.1 - "~~" nil "~") - -(deftest format.~.2 - (loop for i from 0 to 100 - for s = (make-string i :initial-element #\~) - for format-string = (format nil "~~~D~~" i) - for s2 = (format nil format-string) - unless (string= s s2) - collect (list i s s2)) - nil) - -(deftest formatter.~.2 - (loop for i from 0 to 100 - for s = (make-string i :initial-element #\~) - for format-string = (format nil "~~~D~~" i) - for fn = (eval `(formatter ,format-string)) - for s2 = (formatter-call-to-string fn) - unless (string= s s2) - collect (list i s s2)) - nil) - -(def-format-test format.~.3 - "~v~" (0) "") - -(deftest format.~.4 - (loop for i from 0 to 100 - for s = (make-string i :initial-element #\~) - for s2 = (format nil "~V~" i) - unless (string= s s2) - collect (list i s s2)) - nil) - -(deftest formatter.~.4 - (let ((fn (formatter "~v~"))) - (loop for i from 0 to 100 - for s = (make-string i :initial-element #\~) - for s2 = (formatter-call-to-string fn i) - unless (string= s s2) - collect (list i s s2))) - nil) - -(deftest format.~.5 - (loop for i from 0 to (min (- call-arguments-limit 3) 100) - for s = (make-string i :initial-element #\~) - for args = (make-list i) - for s2 = (apply #'format nil "~#~" args) - unless (string= s s2) - collect (list i s s2)) - nil) - -(deftest formatter.~.5 - (let ((fn (formatter "~#~"))) - (loop for i from 0 to (min (- call-arguments-limit 3) 100) - for s = (make-string i :initial-element #\~) - for args = (make-list i) - for s2 = (with-output-to-string - (stream) - (assert (equal (apply fn stream args) args))) - unless (string= s s2) - collect (list i s s2))) - nil) diff --git a/t/ansi-test/printer/format/format-underscore.lsp b/t/ansi-test/printer/format/format-underscore.lsp deleted file mode 100644 index 60ae6a2..0000000 --- a/t/ansi-test/printer/format/format-underscore.lsp +++ /dev/null @@ -1,342 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Aug 4 03:36:50 2004 -;;;; Contains: Tests of the ~_ format directive - - - - - -(def-ppblock-test format._.1 - (progn - (dotimes (i 2) (write "A ") (pprint-newline :fill)) - ;; (write "B ") (pprint-newline :linear) - (format t "B ~_") - (dotimes (i 3) (write "A ") (pprint-newline :fill))) - "A A B -A A A " - :margin 10) - -(def-ppblock-test format._.2 - (progn - (dotimes (i 2) (write "A ") (pprint-newline :fill)) - ;; (write "B ") (pprint-newline :linear) - (format t "B ~_") - (dotimes (i 2) (write "C ") (pprint-newline :fill)) - (format t "D ~_") - (dotimes (i 3) (write "A ") (pprint-newline :fill))) - "A A B -C C D -A A A " - :margin 10) - -(def-ppblock-test format._.3 - (format t "A ~_A ~_A ~_A ~_") - "A A A A " - :margin 10) - -(def-ppblock-test format._.4 - (format t "A ~_A ~_A ~_A ~_") - "A A A A " - :margin 10 - :miser 10) - -(def-ppblock-test format._.5 - (format t "A ~_A ~_A ~_A ~_A ~_A ~_A ~_A ~_A ~_A ~_") - "A A A A A A A A A A " - :margin 10 - :pretty nil) - -(def-ppblock-test format._.6 - (dotimes (i 4) (format t "A ~_")) - "A -A -A -A -" - :margin 10) - -(def-ppblock-test format._.7 - (format t "A ~_A ~_A ~_A ~_~%A ~_A ~_A ~_A ~_") - "A -A -A -A - -A -A -A -A -" - :margin 10) - -(def-ppblock-test format._.8 - (progn - (pprint-logical-block (*standard-output* nil) - (format t "A ~_A ~_A ~_A ~_")) - (format t "~_") - (pprint-logical-block (*standard-output* nil) - (format t "A ~_A ~_A ~_A ~_"))) - "A A A A -A A A A " - :margin 10) - -(deftest format._.9 - (with-output-to-string - (s) - (with-standard-io-syntax - (let ((*print-readably* nil) - (*print-escape* nil) - (*print-pretty* t) - (*print-right-margin* 4) - (*print-miser-width* nil)) - (format s "A ~_A ~_A ~_A ~_A ~_")))) - "A A A A A ") - -(deftest formatter._.9 - (with-standard-io-syntax - (let ((*print-readably* nil) - (*print-escape* nil) - (*print-pretty* t) - (*print-right-margin* 4) - (*print-miser-width* nil)) - (formatter-call-to-string - (formatter "A ~_A ~_A ~_A ~_A ~_")))) - "A A A A A ") - -;;; miser - -(def-ppblock-test format.@_.1 - (format t "A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_") - "A A A A A A A A A A " - :margin 10) - -(def-ppblock-test format.@_.2 - (format t "A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_") - "A A A A A A A A A A " - :margin 10 - :miser 0) - -(def-ppblock-test format.@_.3 - (format t "A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_") - "A A A A A A A A A A " - :margin 10 - :miser 9) - -(def-ppblock-test format.@_.4 - (format t "A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_") - "A -A -A -A -A -A -A -A -A -A -" - :margin 10 - :miser 10) - -(def-ppblock-test format.@_.5 - (format t "A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_A ~@_") - "A A A A A A A A A A " - :margin 10 - :miser 10 - :pretty nil) - -(def-ppblock-test format.@_.6 - (format t "~%A~@_") - " -A -" - :margin 20 - :miser 20) - -(def-ppblock-test format.@_.7 - (format t "~@_A~%") - " -A -" - :margin 20 - :miser 20) - -(def-ppblock-test format.@_.8 - (progn - (format t "AAAA ~_") - (pprint-logical-block - (*standard-output* nil) - (format t "A ~@_A ~@_A ~@_A ~@_"))) - "AAAA -A A A A " - :margin 10 - :miser 8) - -(def-ppblock-test format.@_.9 - (progn - (format t "AAAA ~:@_") - (pprint-logical-block - (*standard-output* nil) - (format t "A ~@_A ~@_A ~@_A ~@_"))) - "AAAA -A A A A " - :margin 10 - :miser 8) - -(deftest format.@_.10 - (with-output-to-string - (s) - (with-standard-io-syntax - (let ((*print-readably* nil) - (*print-escape* nil) - (*print-pretty* t) - (*print-right-margin* 4) - (*print-miser-width* 4)) - (format s "A ~@_A ~@_A ~@_A ~@_A ~@_")))) - "A A A A A ") - -(deftest formatter.@_.10 - (with-standard-io-syntax - (let ((*print-readably* nil) - (*print-escape* nil) - (*print-pretty* t) - (*print-right-margin* 4) - (*print-miser-width* 4)) - (formatter-call-to-string - (formatter "A ~@_A ~@_A ~@_A ~@_A ~@_")))) - "A A A A A ") - -;;; fill - -(def-ppblock-test format.\:_.1 - (format t "A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_") - "A A A A A -A A A A A " - :margin 10) - -(def-ppblock-test format.\:_.2 - (format t "A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_") - "A A A -A A A -A A A -A " - :margin 6) - -(def-ppblock-test format.\:_.3 - (format t "A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_") - "A A A -A A A -A A A -A " - :margin 7) - -(def-ppblock-test format.\:_.4 - (format t "A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_") - "A A A A A -A A A A A " - :margin 10 - :miser 9) - -(def-ppblock-test format.\:_.5 - (format t "A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_A ~:_") - "A -A -A -A -A -A -A -A -A -A -" - :margin 10 - :miser 10) - -(def-ppblock-test format.\:_.6 - (format t "~W~W~:_~W~W~:_~W~W~:_~W~W~:_~W~W~:_" - '(A B) #\Space - '(A B) #\Space - '(A B) #\Space - '(A B) #\Space - '(A B) #\Space) - "(A B) (A B) -(A B) (A B) -(A B) " - :margin 12) - -(deftest format.\:_.7 - (with-output-to-string - (s) - (with-standard-io-syntax - (let ((*print-readably* nil) - (*print-escape* nil) - (*print-right-margin* 4) - (*print-pretty* t) - (*print-miser-width* nil)) - (format s "A ~:_A ~:_A ~:_A ~:_A ~:_")))) - "A A A A A ") - -(deftest formatter.\:_.7 - (with-standard-io-syntax - (let ((*print-readably* nil) - (*print-escape* nil) - (*print-right-margin* 4) - (*print-pretty* t) - (*print-miser-width* nil)) - (formatter-call-to-string - (formatter "A ~:_A ~:_A ~:_A ~:_A ~:_")))) - "A A A A A ") - -;;; mandatory - -(def-ppblock-test format.\:@_.1 - (format t "A ~:@_A ~:@_A ~:@_A ~:@_") - "A -A -A -A -") - -(def-ppblock-test format.\:@_.2 - (format t "A ~@:_A ~@:_A ~@:_A ~@:_") - "A -A -A -A -" - :margin 10) - -(def-ppblock-test format.\:@_.3 - (format t "A ~@:_A ") - "A -A " - :margin 1) - -(def-ppblock-test format.\:@_.4 - (format t "A ~@:_A ~@:_A ~@:_A ~@:_") - "A A A A " - :pretty nil) - -(deftest format.\:@_.5 - (with-output-to-string - (s) - (with-standard-io-syntax - (let ((*print-readably* nil) - (*print-escape* nil) - (*print-pretty* t) - (*print-right-margin* 4) - (*print-miser-width* nil)) - (format s "A ~:@_A ~:@_A ~:@_A ~:@_A ~:@_")))) - "A A A A A ") - -(deftest formatter.\:@_.5 - (with-standard-io-syntax - (let ((*print-readably* nil) - (*print-escape* nil) - (*print-pretty* t) - (*print-right-margin* 4) - (*print-miser-width* nil)) - (formatter-call-to-string (formatter "A ~:@_A ~:@_A ~:@_A ~:@_A ~:@_")))) - "A A A A A ") diff --git a/t/ansi-test/printer/format/format-x.lsp b/t/ansi-test/printer/format/format-x.lsp deleted file mode 100644 index 1db94b8..0000000 --- a/t/ansi-test/printer/format/format-x.lsp +++ /dev/null @@ -1,542 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Aug 1 06:51:34 2004 -;;;; Contains: Tests of ~X format directive - - - - - -(deftest format.x.1 - (let ((fn (formatter "~x"))) - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~X" i) - for s2 = (formatter-call-to-string fn i) - for j = (let ((*read-base* 16)) (read-from-string s1)) - repeat 1000 - when (or (/= i j) - (not (string= s1 s2)) - (find #\. s1) - (find #\+ s1) - (loop for c across s1 - thereis (and (not (eql c #\-)) - (not (digit-char-p c 16))))) - collect (list i s1 j s2)))) - nil) - -(deftest format.x.2 - (let ((fn (formatter "~@X"))) - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~@x" i) - for s2 = (formatter-call-to-string fn i) - for j = (let ((*read-base* 16)) (read-from-string s1)) - repeat 1000 - when (or (/= i j) - (not (string= s1 s2)) - (find #\. s1) - ;; (find #\+ s1) - (loop for c across s1 - thereis (and - (not (find c "-+")) - (not (digit-char-p c 16))))) - collect (list i s1 j s2)))) - nil) - -(deftest format.x.3 - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~x" i) - for fmt = (format nil "~~~d~c" mincol (random-from-seq "xX")) - for s2 = (format nil fmt i) - for pos = (search s1 s2) - repeat 1000 - when (or (null pos) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (not (eql (position #\Space s2 :test-not #'eql) - (- (length s2) (length s1))))))) - collect (list i mincol s1 s2 pos))) - nil) - -(deftest formatter.x.3 - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~x" i) - for fmt = (format nil "~~~d~c" mincol (random-from-seq "xX")) - for fn = (eval `(formatter ,fmt)) - for s2 = (formatter-call-to-string fn i) - for pos = (search s1 s2) - repeat 100 - when (or (null pos) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (not (eql (position #\Space s2 :test-not #'eql) - (- (length s2) (length s1))))))) - collect (list i mincol s1 s2 pos))) - nil) - -(deftest format.x.4 - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~@X" i) - for fmt = (format nil "~~~d@~c" mincol (random-from-seq "xX")) - for s2 = (format nil fmt i) - for pos = (search s1 s2) - repeat 1000 - when (or (null pos) - (and (>= i 0) (not (eql (elt s1 0) #\+))) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (not (eql (position #\Space s2 :test-not #'eql) - (- (length s2) (length s1))))))) - collect (list i mincol s1 s2 pos))) - nil) - -(deftest formatter.x.4 - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~@X" i) - for fmt = (format nil "~~~d@~c" mincol (random-from-seq "xX")) - for fn = (eval `(formatter ,fmt)) - for s2 = (formatter-call-to-string fn i) - for pos = (search s1 s2) - repeat 100 - when (or (null pos) - (and (>= i 0) (not (eql (elt s1 0) #\+))) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (not (eql (position #\Space s2 :test-not #'eql) - (- (length s2) (length s1))))))) - collect (list i mincol s1 s2 pos))) - nil) - -(deftest format.x.5 - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for padchar = (random-from-seq +standard-chars+) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~x" i) - for fmt = (format nil "~~~d,'~c~c" mincol padchar (random-from-seq "xX")) - for s2 = (format nil fmt i) - for pos = (search s1 s2) - repeat 1000 - when (or (null pos) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (find padchar s2 :end (- (length s2) (length s1)) - :test-not #'eql)))) - collect (list i mincol s1 s2 pos))) - nil) - -(deftest formatter.x.5 - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for padchar = (random-from-seq +standard-chars+) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~x" i) - for fmt = (format nil "~~~d,'~c~c" mincol padchar (random-from-seq "xX")) - for fn = (eval `(formatter ,fmt)) - for s2 = (formatter-call-to-string fn i) - for pos = (search s1 s2) - repeat 100 - when (or (null pos) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (find padchar s2 :end (- (length s2) (length s1)) - :test-not #'eql)))) - collect (list i mincol s1 s2 pos))) - nil) - -(deftest format.x.6 - (let ((fn (formatter "~V,vx"))) - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for padchar = (random-from-seq +standard-chars+) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~x" i) - for s2 = (format nil "~v,vX" mincol padchar i) - for s3 = (formatter-call-to-string fn mincol padchar i) - for pos = (search s1 s2) - repeat 1000 - when (or (null pos) - (not (string= s2 s3)) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (find padchar s2 :end (- (length s2) (length s1)) - :test-not #'eql)))) - collect (list i mincol s1 s2 s3 pos)))) - nil) - -(deftest format.x.7 - (let ((fn (formatter "~v,V@X"))) - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for padchar = (random-from-seq +standard-chars+) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~@x" i) - for s2 = (format nil "~v,v@x" mincol padchar i) - for s3 = (formatter-call-to-string fn mincol padchar i) - for pos = (search s1 s2) - repeat 1000 - when (or (null pos) - (not (string= s2 s3)) - (and (>= i 0) (not (eql (elt s1 0) #\+))) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (find padchar s2 :end (- (length s2) (length s1)) - :test-not #'eql)))) - collect (list i mincol s1 s2 s3 pos)))) - nil) - -;;; Comma tests - -(deftest format.x.8 - (let ((fn (formatter "~:X"))) - (loop for i from -999 to 999 - for s1 = (format nil "~x" i) - for s2 = (format nil "~:x" i) - for s3 = (formatter-call-to-string fn i) - unless (and (string= s1 s2) (string= s2 s3)) - collect (list i s1 s2 s3))) - nil) - -(deftest format.x.9 - (let ((fn (formatter "~:x"))) - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = #\, - for s1 = (format nil "~x" i) - for s2 = (format nil "~:X" i) - for s3 = (formatter-call-to-string fn i) - repeat 1000 - unless (and (string= s1 (remove commachar s2)) - (string= s2 s3) - (not (eql (elt s2 0) commachar)) - (or (>= i 0) (not (eql (elt s2 1) commachar))) - (let ((len (length s2)) - (ci+1 4)) - (loop for i from (if (< i 0) 2 1) below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (find (elt s2 i) "0123456789ABCDEF" :test #'char-equal))))) - collect (list x i commachar s1 s2 s3)))) - nil) - -(deftest format.x.10 - (let ((fn (formatter "~,,V:x"))) - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = (random-from-seq +standard-chars+) - for s1 = (format nil "~x" i) - for s2 = (format nil "~,,v:X" commachar i) - for s3 = (formatter-call-to-string fn commachar i) - repeat 1000 - unless (and - (eql (elt s1 0) (elt s2 0)) - (string= s2 s3) - (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) - (let ((len (length s2)) - (ci+1 4) - (j (if (< i 0) 1 0))) - (loop for i from (if (< i 0) 2 1) below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (eql (elt s1 (incf j)) (elt s2 i)))))) - collect (list x i commachar s1 s2 s3)))) - nil) - -(deftest format.x.11 - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = (random-from-seq +standard-chars+) - for s1 = (format nil "~x" i) - for fmt = (format nil "~~,,'~c:~c" commachar (random-from-seq "xX")) - for s2 = (format nil fmt i) - repeat 1000 - unless (and - (eql (elt s1 0) (elt s2 0)) - (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) - (let ((len (length s2)) - (ci+1 4) - (j (if (< i 0) 1 0))) - (loop for i from (if (< i 0) 2 1) below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (eql (elt s1 (incf j)) (elt s2 i)))))) - collect (list x i commachar s1 s2))) - nil) - -(deftest formatter.x.11 - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = (random-from-seq +standard-chars+) - for s1 = (format nil "~x" i) - for fmt = (format nil "~~,,'~c:~c" commachar (random-from-seq "xX")) - for fn = (eval `(formatter ,fmt)) - for s2 = (formatter-call-to-string fn i) - repeat 100 - unless (and - (eql (elt s1 0) (elt s2 0)) - (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) - (let ((len (length s2)) - (ci+1 4) - (j (if (< i 0) 1 0))) - (loop for i from (if (< i 0) 2 1) below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (eql (elt s1 (incf j)) (elt s2 i)))))) - collect (list x i commachar s1 s2))) - nil) - -(deftest format.x.12 - (let ((fn (formatter "~,,v,v:X"))) - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = (random-from-seq +standard-chars+) - for commaint = (1+ (random 20)) - for s1 = (format nil "~x" i) - for s2 = (format nil "~,,v,v:X" commachar commaint i) - for s3 = (formatter-call-to-string fn commachar commaint i) - repeat 1000 - unless (and - (eql (elt s1 0) (elt s2 0)) - (string= s2 s3) - (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) - (let ((len (length s2)) - (ci+1 (1+ commaint)) - (j (if (< i 0) 1 0))) - (loop for i from (if (< i 0) 2 1) below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (eql (elt s1 (incf j)) (elt s2 i)))))) - collect (list x i commachar s1 s2 s3)))) - nil) - -(deftest format.x.13 - (let ((fn (formatter "~,,v,V:@x"))) - (with-standard-io-syntax - (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = (random-from-seq +standard-chars+) - for commaint = (1+ (random 20)) - for s1 = (format nil "~@x" i) - for s2 = (format nil "~,,v,v:@x" commachar commaint i) - for s3 = (formatter-call-to-string fn commachar commaint i) - repeat 1000 - unless (and - (eql (elt s1 0) (elt s2 0)) - (eql (elt s1 1) (elt s2 1)) - (string= s2 s3) - (let ((len (length s2)) - (ci+1 (1+ commaint)) - (j 1)) - (loop for i from 2 below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (eql (elt s1 (incf j)) (elt s2 i)))))) - collect (list x i commachar s1 s2 s3)))) - nil) - -;;; NIL arguments - -(def-format-test format.x.14 - "~vx" (nil #x100) "100") - -(def-format-test format.x.15 - "~6,vX" (nil #x100) " 100") - -(def-format-test format.x.16 - "~,,v:x" (nil #x12345) "12,345") - -(def-format-test format.x.17 - "~,,'*,v:x" (nil #x12345) "12*345") - -;;; When the argument is not an integer, print as if using ~A and base 10 - -(deftest format.x.18 - (let ((fn (formatter "~x"))) - (loop for x in *mini-universe* - for s1 = (format nil "~x" x) - for s2 = (let ((*print-base* 16)) (format nil "~A" x)) - for s3 = (formatter-call-to-string fn x) - unless (or (integerp x) (and (string= s1 s2) (string= s2 s3))) - collect (list x s1 s2 s3))) - nil) - -(deftest format.x.19 - (let ((fn (formatter "~:x"))) - (loop for x in *mini-universe* - for s1 = (format nil "~:x" x) - for s2 = (let ((*print-base* 16)) (format nil "~A" x)) - for s3 = (formatter-call-to-string fn x) - unless (or (integerp x) (and (string= s1 s2) (string= s2 s3))) - collect (list x s1 s2 s3))) - nil) - -(deftest format.x.20 - (let ((fn (formatter "~@x"))) - (loop for x in *mini-universe* - for s1 = (format nil "~@x" x) - for s2 = (let ((*print-base* 16)) (format nil "~A" x)) - for s3 = (formatter-call-to-string fn x) - unless (or (integerp x) (and (string= s1 s2) (string= s2 s3))) - collect (list x s1 s2 s3))) - nil) - -(deftest format.x.21 - (let ((fn (formatter "~:@x"))) - (loop for x in *mini-universe* - for s1 = (let ((*print-base* 16)) (format nil "~A" x)) - for s2 = (format nil "~@:x" x) - for s3 = (formatter-call-to-string fn x) - for s4 = (let ((*print-base* 16)) (format nil "~A" x)) - unless (or (string/= s1 s4) - (integerp x) - (and (string= s1 s2) (string= s2 s3))) - collect (list x s1 s2 s3))) - nil) - -;;; Must add tests for non-integers when the parameters -;;; are specified, but it's not clear what the meaning is. -;;; Does mincol apply to the ~A equivalent? What about padchar? -;;; Are comma-char and comma-interval always ignored? - -;;; # arguments - -(deftest format.x.22 - (apply - #'values - (let ((fn (formatter "~#X")) - (n #x1b3fe)) - (loop for i from 0 to 10 - for args = (make-list i) - for s = (apply #'format nil "~#x" n args) - for s2 = (with-output-to-string - (stream) - (assert (equal (apply fn stream n args) args))) - do (assert (string= s s2)) - collect (string-upcase s)))) - "1B3FE" - "1B3FE" - "1B3FE" - "1B3FE" - "1B3FE" - " 1B3FE" - " 1B3FE" - " 1B3FE" - " 1B3FE" - " 1B3FE" - " 1B3FE") - -(deftest format.x.23 - (apply - #'values - (let ((fn (formatter "~,,,#:X")) - (n #x1234567890)) - (loop for i from 0 to 10 - for args = (make-list i) - for s = (apply #'format nil "~,,,#:x" n args) - for s2 = (with-output-to-string - (stream) - (assert (equal (apply fn stream n args) args))) - do (assert (string= s s2)) - collect s))) - "1,2,3,4,5,6,7,8,9,0" - "12,34,56,78,90" - "1,234,567,890" - "12,3456,7890" - "12345,67890" - "1234,567890" - "123,4567890" - "12,34567890" - "1,234567890" - "1234567890" - "1234567890") - -(deftest format.x.24 - (apply - #'values - (let ((fn (formatter "~,,,#@:X")) - (n #x1234567890)) - (loop for i from 0 to 10 - for args = (make-list i) - for s = (apply #'format nil "~,,,#@:X" n args) - for s2 = (with-output-to-string - (stream) - (assert (equal (apply fn stream n args) args))) - do (assert (string= s s2)) - collect s))) - "+1,2,3,4,5,6,7,8,9,0" - "+12,34,56,78,90" - "+1,234,567,890" - "+12,3456,7890" - "+12345,67890" - "+1234,567890" - "+123,4567890" - "+12,34567890" - "+1,234567890" - "+1234567890" - "+1234567890") - -(def-format-test format.x.25 - "~+10x" (#x1234) " 1234") - -(def-format-test format.x.26 - "~+10@X" (#x1234) " +1234") - -(def-format-test format.x.27 - "~-1X" (#x1234) "1234") - -(def-format-test format.x.28 - "~-1000000000000000000x" (#x1234) "1234") - -(def-format-test format.x.29 - "~vx" ((1- most-negative-fixnum) #x1234) "1234") - -;;; Randomized test - -(deftest format.x.30 - (let ((fn (formatter "~v,v,v,vx"))) - (loop - for mincol = (and (coin) (random 50)) - for padchar = (and (coin) - (random-from-seq +standard-chars+)) - for commachar = (and (coin) - (random-from-seq +standard-chars+)) - for commaint = (and (coin) (1+ (random 10))) - for k = (ash 1 (+ 2 (random 30))) - for x = (- (random (+ k k)) k) - for fmt = (concatenate - 'string - (if mincol (format nil "~~~d," mincol) "~,") - (if padchar (format nil "'~c," padchar) ",") - (if commachar (format nil "'~c," commachar) ",") - (if commaint (format nil "~dx" commaint) "x")) - for s1 = (format nil fmt x) - for s2 = (format nil "~v,v,v,vx" mincol padchar commachar commaint x) - for s3 = (formatter-call-to-string fn mincol padchar commachar commaint x) - repeat 2000 - unless (and (string= s1 s2) (string= s2 s3)) - collect (list mincol padchar commachar commaint fmt x s1 s2 s3))) - nil) diff --git a/t/ansi-test/printer/format/formatter-c.lsp b/t/ansi-test/printer/format/formatter-c.lsp deleted file mode 100644 index 91c75b2..0000000 --- a/t/ansi-test/printer/format/formatter-c.lsp +++ /dev/null @@ -1,144 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Dec 5 14:32:46 2004 -;;;; Contains: Tests of FORMATTER on the C directive - - - - - -(deftest formatter.c.1 - (let ((fn (formatter "~C"))) - (loop - for c across +standard-chars+ - when - (let* (n - (ignored (loop for i below (random 5) collect i)) - (s (with-output-to-string (stream) - (setq n (multiple-value-list - (apply fn stream c ignored)))))) - (unless (and (string= s (string c)) - (equal n (list ignored))) - (list s ignored n))) - collect it)) - nil) - -(deftest formatter.c.1a - (let ((fn (formatter "~c"))) - (loop - with count = 0 - for i from 0 below (min #x10000 char-code-limit) - for c = (code-char i) - for ignored = (loop for j below (random 10) collect j) - when - (and c - (eql (char-code c) (char-int c)) - (let* (n - (s (with-output-to-string - (stream) - (setq n (multiple-value-list - (apply fn stream c ignored)))))) - (unless (and (string= s (string c)) - (equal n (list ignored))) - (incf count) - (list i c s ignored n)))) - collect it - when (> count 100) collect "count limit exceeded" and do (loop-finish))) - nil) - -(deftest formatter.c.2 - (let ((fn (formatter "~:C"))) - (loop - for c across +standard-chars+ - when - (and (graphic-char-p c) - (not (eql c #\Space)) - (let* (n - (ignored (loop for i below (random 5) collect i)) - (s (with-output-to-string (stream) - (setq n (multiple-value-list - (apply fn stream c ignored)))))) - (unless (and (string= s (string c)) - (equal n (list ignored))) - (list s ignored n)))) - collect it)) - nil) - -(deftest formatter.c.2a - (let ((fn (formatter "~:C"))) - (loop - with count = 0 - for i from 0 below (min #x10000 char-code-limit) - for c = (code-char i) - for ignored = (loop for j below (random 10) collect j) - when - (and c - (eql (char-code c) (char-int c)) - (graphic-char-p c) - (not (eql c #\Space)) - (let* (n - (s (with-output-to-string - (stream) - (setq n (multiple-value-list - (apply fn stream c ignored)))))) - (unless (and (string= s (string c)) - (equal n (list ignored))) - (incf count) - (list i c s ignored n)))) - collect it - when (> count 100) collect "count limit exceeded" and do (loop-finish))) - nil) - -(deftest formatter.c.4 - (let ((fn (formatter "~:C")) - (n nil)) - (loop for c across +standard-chars+ - for s = (with-output-to-string - (stream) - (setq n (multiple-value-list (funcall fn stream c)))) - unless (or (graphic-char-p c) - (and (string= s (char-name c)) - (equal n '(nil)))) - collect (list c (char-name c) s))) - nil) - -(deftest formatter.c.4a - (let ((fn (formatter "~:C")) - (n nil)) - (loop for i from 0 below (min #x10000 char-code-limit) - for c = (code-char i) - for s = (and c - (with-output-to-string - (stream) - (setq n (multiple-value-list (funcall fn stream c 5))))) - unless (or (not c) - (graphic-char-p c) - (and (string= s (char-name c)) - (equal n '((5))))) - collect (list c (char-name c) s))) - nil) - -(deftest formatter.c.5 - (let ((fn (formatter "~@C")) - (n nil)) - (loop for c across +standard-chars+ - for s = (with-output-to-string - (stream) - (setq n (multiple-value-list (funcall fn stream c 1 2 3)))) - for c2 = (read-from-string s) - unless (and (eql c c2) - (equal n '((1 2 3)))) - collect (list c s c2))) - nil) - -(deftest formatter.c.6 - (let ((n nil) - (fn (formatter "~@:c"))) - (loop for c across +standard-chars+ - for s1 = (with-output-to-string - (stream) - (setf n (multiple-value-list (funcall fn stream c 1 2)))) - for s2 = (format nil "~:@C" c) - unless (and (eql (search s1 s2) 0) (equal n '((1 2)))) - collect (list c s1 s2 n))) - nil) diff --git a/t/ansi-test/printer/format/load.lsp b/t/ansi-test/printer/format/load.lsp deleted file mode 100644 index 8d91949..0000000 --- a/t/ansi-test/printer/format/load.lsp +++ /dev/null @@ -1,52 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Aug 2 21:47:02 2004 -;;;; Contains: Load format-related tests - -;;; Format tests - -;;; 22.3.1 -(load "format/format-c.lsp") -(load "format/formatter-c.lsp") -(load "format/format-percent.lsp") -(load "format/format-ampersand.lsp") -(load "format/format-page.lsp") -(load "format/format-tilde.lsp") - -;;; 22.3.2 -(load "format/format-r.lsp") -(load "format/format-d.lsp") -(load "format/format-b.lsp") -(load "format/format-o.lsp") -(load "format/format-x.lsp") - -;;; 22.3.3 -(load "format/format-f.lsp") - -;;; 22.3.4 -(load "format/format-a.lsp") -(load "format/format-s.lsp") - -;;; 22.3.5 -(load "format/format-underscore.lsp") -(load "format/format-logical-block.lsp") -(load "format/format-i.lsp") -(load "format/format-slash.lsp") - -;;; 22.3.6 -(load "format/format-t.lsp") -(load "format/format-justify.lsp") - -;;; 22.3.7 -(load "format/format-goto.lsp") -(load "format/format-conditional.lsp") -(load "format/format-brace.lsp") -(load "format/format-question.lsp") - -;;; 22.3.8 -(load "format/format-paren.lsp") -(load "format/format-p.lsp") - -;;; 22.3.9 -(load "format/format-circumflex.lsp") -(load "format/format-newline.lsp") diff --git a/t/ansi-test/printer/format/roman-numerals.lsp b/t/ansi-test/printer/format/roman-numerals.lsp deleted file mode 100644 index 5edb74a..0000000 --- a/t/ansi-test/printer/format/roman-numerals.lsp +++ /dev/null @@ -1,484 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Jul 29 08:44:15 2004 -;;;; Contains: The roman numbers from 1 to 3999 - - - -(defparameter *roman-numerals* - '("I" "II" "III" "IV" "V" "VI" "VII" "VIII" "IX" "X" "XI" "XII" "XIII" "XIV" "XV" "XVI" "XVII" - "XVIII" "XIX" "XX" "XXI" "XXII" "XXIII" "XXIV" "XXV" "XXVI" "XXVII" "XXVIII" "XXIX" "XXX" - "XXXI" "XXXII" "XXXIII" "XXXIV" "XXXV" "XXXVI" "XXXVII" "XXXVIII" "XXXIX" "XL" "XLI" "XLII" - "XLIII" "XLIV" "XLV" "XLVI" "XLVII" "XLVIII" "XLIX" "L" "LI" "LII" "LIII" "LIV" "LV" "LVI" - "LVII" "LVIII" "LIX" "LX" "LXI" "LXII" "LXIII" "LXIV" "LXV" "LXVI" "LXVII" "LXVIII" "LXIX" - "LXX" "LXXI" "LXXII" "LXXIII" "LXXIV" "LXXV" "LXXVI" "LXXVII" "LXXVIII" "LXXIX" "LXXX" - "LXXXI" "LXXXII" "LXXXIII" "LXXXIV" "LXXXV" "LXXXVI" "LXXXVII" "LXXXVIII" "LXXXIX" "XC" - "XCI" "XCII" "XCIII" "XCIV" "XCV" "XCVI" "XCVII" "XCVIII" "XCIX" "C" "CI" "CII" "CIII" "CIV" - "CV" "CVI" "CVII" "CVIII" "CIX" "CX" "CXI" "CXII" "CXIII" "CXIV" "CXV" "CXVI" "CXVII" - "CXVIII" "CXIX" "CXX" "CXXI" "CXXII" "CXXIII" "CXXIV" "CXXV" "CXXVI" "CXXVII" "CXXVIII" - "CXXIX" "CXXX" "CXXXI" "CXXXII" "CXXXIII" "CXXXIV" "CXXXV" "CXXXVI" "CXXXVII" "CXXXVIII" - "CXXXIX" "CXL" "CXLI" "CXLII" "CXLIII" "CXLIV" "CXLV" "CXLVI" "CXLVII" "CXLVIII" "CXLIX" - "CL" "CLI" "CLII" "CLIII" "CLIV" "CLV" "CLVI" "CLVII" "CLVIII" "CLIX" "CLX" "CLXI" "CLXII" - "CLXIII" "CLXIV" "CLXV" "CLXVI" "CLXVII" "CLXVIII" "CLXIX" "CLXX" "CLXXI" "CLXXII" "CLXXIII" - "CLXXIV" "CLXXV" "CLXXVI" "CLXXVII" "CLXXVIII" "CLXXIX" "CLXXX" "CLXXXI" "CLXXXII" - "CLXXXIII" "CLXXXIV" "CLXXXV" "CLXXXVI" "CLXXXVII" "CLXXXVIII" "CLXXXIX" "CXC" "CXCI" - "CXCII" "CXCIII" "CXCIV" "CXCV" "CXCVI" "CXCVII" "CXCVIII" "CXCIX" "CC" "CCI" "CCII" "CCIII" - "CCIV" "CCV" "CCVI" "CCVII" "CCVIII" "CCIX" "CCX" "CCXI" "CCXII" "CCXIII" "CCXIV" "CCXV" - "CCXVI" "CCXVII" "CCXVIII" "CCXIX" "CCXX" "CCXXI" "CCXXII" "CCXXIII" "CCXXIV" "CCXXV" - "CCXXVI" "CCXXVII" "CCXXVIII" "CCXXIX" "CCXXX" "CCXXXI" "CCXXXII" "CCXXXIII" "CCXXXIV" - "CCXXXV" "CCXXXVI" "CCXXXVII" "CCXXXVIII" "CCXXXIX" "CCXL" "CCXLI" "CCXLII" "CCXLIII" - "CCXLIV" "CCXLV" "CCXLVI" "CCXLVII" "CCXLVIII" "CCXLIX" "CCL" "CCLI" "CCLII" "CCLIII" - "CCLIV" "CCLV" "CCLVI" "CCLVII" "CCLVIII" "CCLIX" "CCLX" "CCLXI" "CCLXII" "CCLXIII" "CCLXIV" - "CCLXV" "CCLXVI" "CCLXVII" "CCLXVIII" "CCLXIX" "CCLXX" "CCLXXI" "CCLXXII" "CCLXXIII" - "CCLXXIV" "CCLXXV" "CCLXXVI" "CCLXXVII" "CCLXXVIII" "CCLXXIX" "CCLXXX" "CCLXXXI" "CCLXXXII" - "CCLXXXIII" "CCLXXXIV" "CCLXXXV" "CCLXXXVI" "CCLXXXVII" "CCLXXXVIII" "CCLXXXIX" "CCXC" - "CCXCI" "CCXCII" "CCXCIII" "CCXCIV" "CCXCV" "CCXCVI" "CCXCVII" "CCXCVIII" "CCXCIX" "CCC" - "CCCI" "CCCII" "CCCIII" "CCCIV" "CCCV" "CCCVI" "CCCVII" "CCCVIII" "CCCIX" "CCCX" "CCCXI" - "CCCXII" "CCCXIII" "CCCXIV" "CCCXV" "CCCXVI" "CCCXVII" "CCCXVIII" "CCCXIX" "CCCXX" "CCCXXI" - "CCCXXII" "CCCXXIII" "CCCXXIV" "CCCXXV" "CCCXXVI" "CCCXXVII" "CCCXXVIII" "CCCXXIX" "CCCXXX" - "CCCXXXI" "CCCXXXII" "CCCXXXIII" "CCCXXXIV" "CCCXXXV" "CCCXXXVI" "CCCXXXVII" "CCCXXXVIII" - "CCCXXXIX" "CCCXL" "CCCXLI" "CCCXLII" "CCCXLIII" "CCCXLIV" "CCCXLV" "CCCXLVI" "CCCXLVII" - "CCCXLVIII" "CCCXLIX" "CCCL" "CCCLI" "CCCLII" "CCCLIII" "CCCLIV" "CCCLV" "CCCLVI" "CCCLVII" - "CCCLVIII" "CCCLIX" "CCCLX" "CCCLXI" "CCCLXII" "CCCLXIII" "CCCLXIV" "CCCLXV" "CCCLXVI" - "CCCLXVII" "CCCLXVIII" "CCCLXIX" "CCCLXX" "CCCLXXI" "CCCLXXII" "CCCLXXIII" "CCCLXXIV" - "CCCLXXV" "CCCLXXVI" "CCCLXXVII" "CCCLXXVIII" "CCCLXXIX" "CCCLXXX" "CCCLXXXI" "CCCLXXXII" - "CCCLXXXIII" "CCCLXXXIV" "CCCLXXXV" "CCCLXXXVI" "CCCLXXXVII" "CCCLXXXVIII" "CCCLXXXIX" - "CCCXC" "CCCXCI" "CCCXCII" "CCCXCIII" "CCCXCIV" "CCCXCV" "CCCXCVI" "CCCXCVII" "CCCXCVIII" - "CCCXCIX" "CD" "CDI" "CDII" "CDIII" "CDIV" "CDV" "CDVI" "CDVII" "CDVIII" "CDIX" "CDX" "CDXI" - "CDXII" "CDXIII" "CDXIV" "CDXV" "CDXVI" "CDXVII" "CDXVIII" "CDXIX" "CDXX" "CDXXI" "CDXXII" - "CDXXIII" "CDXXIV" "CDXXV" "CDXXVI" "CDXXVII" "CDXXVIII" "CDXXIX" "CDXXX" "CDXXXI" "CDXXXII" - "CDXXXIII" "CDXXXIV" "CDXXXV" "CDXXXVI" "CDXXXVII" "CDXXXVIII" "CDXXXIX" "CDXL" "CDXLI" - "CDXLII" "CDXLIII" "CDXLIV" "CDXLV" "CDXLVI" "CDXLVII" "CDXLVIII" "CDXLIX" "CDL" "CDLI" - "CDLII" "CDLIII" "CDLIV" "CDLV" "CDLVI" "CDLVII" "CDLVIII" "CDLIX" "CDLX" "CDLXI" "CDLXII" - "CDLXIII" "CDLXIV" "CDLXV" "CDLXVI" "CDLXVII" "CDLXVIII" "CDLXIX" "CDLXX" "CDLXXI" "CDLXXII" - "CDLXXIII" "CDLXXIV" "CDLXXV" "CDLXXVI" "CDLXXVII" "CDLXXVIII" "CDLXXIX" "CDLXXX" "CDLXXXI" - "CDLXXXII" "CDLXXXIII" "CDLXXXIV" "CDLXXXV" "CDLXXXVI" "CDLXXXVII" "CDLXXXVIII" "CDLXXXIX" - "CDXC" "CDXCI" "CDXCII" "CDXCIII" "CDXCIV" "CDXCV" "CDXCVI" "CDXCVII" "CDXCVIII" "CDXCIX" - "D" "DI" "DII" "DIII" "DIV" "DV" "DVI" "DVII" "DVIII" "DIX" "DX" "DXI" "DXII" "DXIII" "DXIV" - "DXV" "DXVI" "DXVII" "DXVIII" "DXIX" "DXX" "DXXI" "DXXII" "DXXIII" "DXXIV" "DXXV" "DXXVI" - "DXXVII" "DXXVIII" "DXXIX" "DXXX" "DXXXI" "DXXXII" "DXXXIII" "DXXXIV" "DXXXV" "DXXXVI" - "DXXXVII" "DXXXVIII" "DXXXIX" "DXL" "DXLI" "DXLII" "DXLIII" "DXLIV" "DXLV" "DXLVI" "DXLVII" - "DXLVIII" "DXLIX" "DL" "DLI" "DLII" "DLIII" "DLIV" "DLV" "DLVI" "DLVII" "DLVIII" "DLIX" - "DLX" "DLXI" "DLXII" "DLXIII" "DLXIV" "DLXV" "DLXVI" "DLXVII" "DLXVIII" "DLXIX" "DLXX" - "DLXXI" "DLXXII" "DLXXIII" "DLXXIV" "DLXXV" "DLXXVI" "DLXXVII" "DLXXVIII" "DLXXIX" "DLXXX" - "DLXXXI" "DLXXXII" "DLXXXIII" "DLXXXIV" "DLXXXV" "DLXXXVI" "DLXXXVII" "DLXXXVIII" "DLXXXIX" - "DXC" "DXCI" "DXCII" "DXCIII" "DXCIV" "DXCV" "DXCVI" "DXCVII" "DXCVIII" "DXCIX" "DC" "DCI" - "DCII" "DCIII" "DCIV" "DCV" "DCVI" "DCVII" "DCVIII" "DCIX" "DCX" "DCXI" "DCXII" "DCXIII" - "DCXIV" "DCXV" "DCXVI" "DCXVII" "DCXVIII" "DCXIX" "DCXX" "DCXXI" "DCXXII" "DCXXIII" "DCXXIV" - "DCXXV" "DCXXVI" "DCXXVII" "DCXXVIII" "DCXXIX" "DCXXX" "DCXXXI" "DCXXXII" "DCXXXIII" - "DCXXXIV" "DCXXXV" "DCXXXVI" "DCXXXVII" "DCXXXVIII" "DCXXXIX" "DCXL" "DCXLI" "DCXLII" - "DCXLIII" "DCXLIV" "DCXLV" "DCXLVI" "DCXLVII" "DCXLVIII" "DCXLIX" "DCL" "DCLI" "DCLII" - "DCLIII" "DCLIV" "DCLV" "DCLVI" "DCLVII" "DCLVIII" "DCLIX" "DCLX" "DCLXI" "DCLXII" "DCLXIII" - "DCLXIV" "DCLXV" "DCLXVI" "DCLXVII" "DCLXVIII" "DCLXIX" "DCLXX" "DCLXXI" "DCLXXII" - "DCLXXIII" "DCLXXIV" "DCLXXV" "DCLXXVI" "DCLXXVII" "DCLXXVIII" "DCLXXIX" "DCLXXX" "DCLXXXI" - "DCLXXXII" "DCLXXXIII" "DCLXXXIV" "DCLXXXV" "DCLXXXVI" "DCLXXXVII" "DCLXXXVIII" "DCLXXXIX" - "DCXC" "DCXCI" "DCXCII" "DCXCIII" "DCXCIV" "DCXCV" "DCXCVI" "DCXCVII" "DCXCVIII" "DCXCIX" - "DCC" "DCCI" "DCCII" "DCCIII" "DCCIV" "DCCV" "DCCVI" "DCCVII" "DCCVIII" "DCCIX" "DCCX" - "DCCXI" "DCCXII" "DCCXIII" "DCCXIV" "DCCXV" "DCCXVI" "DCCXVII" "DCCXVIII" "DCCXIX" "DCCXX" - "DCCXXI" "DCCXXII" "DCCXXIII" "DCCXXIV" "DCCXXV" "DCCXXVI" "DCCXXVII" "DCCXXVIII" "DCCXXIX" - "DCCXXX" "DCCXXXI" "DCCXXXII" "DCCXXXIII" "DCCXXXIV" "DCCXXXV" "DCCXXXVI" "DCCXXXVII" - "DCCXXXVIII" "DCCXXXIX" "DCCXL" "DCCXLI" "DCCXLII" "DCCXLIII" "DCCXLIV" "DCCXLV" "DCCXLVI" - "DCCXLVII" "DCCXLVIII" "DCCXLIX" "DCCL" "DCCLI" "DCCLII" "DCCLIII" "DCCLIV" "DCCLV" "DCCLVI" - "DCCLVII" "DCCLVIII" "DCCLIX" "DCCLX" "DCCLXI" "DCCLXII" "DCCLXIII" "DCCLXIV" "DCCLXV" - "DCCLXVI" "DCCLXVII" "DCCLXVIII" "DCCLXIX" "DCCLXX" "DCCLXXI" "DCCLXXII" "DCCLXXIII" - "DCCLXXIV" "DCCLXXV" "DCCLXXVI" "DCCLXXVII" "DCCLXXVIII" "DCCLXXIX" "DCCLXXX" "DCCLXXXI" - "DCCLXXXII" "DCCLXXXIII" "DCCLXXXIV" "DCCLXXXV" "DCCLXXXVI" "DCCLXXXVII" "DCCLXXXVIII" - "DCCLXXXIX" "DCCXC" "DCCXCI" "DCCXCII" "DCCXCIII" "DCCXCIV" "DCCXCV" "DCCXCVI" "DCCXCVII" - "DCCXCVIII" "DCCXCIX" "DCCC" "DCCCI" "DCCCII" "DCCCIII" "DCCCIV" "DCCCV" "DCCCVI" "DCCCVII" - "DCCCVIII" "DCCCIX" "DCCCX" "DCCCXI" "DCCCXII" "DCCCXIII" "DCCCXIV" "DCCCXV" "DCCCXVI" - "DCCCXVII" "DCCCXVIII" "DCCCXIX" "DCCCXX" "DCCCXXI" "DCCCXXII" "DCCCXXIII" "DCCCXXIV" - "DCCCXXV" "DCCCXXVI" "DCCCXXVII" "DCCCXXVIII" "DCCCXXIX" "DCCCXXX" "DCCCXXXI" "DCCCXXXII" - "DCCCXXXIII" "DCCCXXXIV" "DCCCXXXV" "DCCCXXXVI" "DCCCXXXVII" "DCCCXXXVIII" "DCCCXXXIX" - "DCCCXL" "DCCCXLI" "DCCCXLII" "DCCCXLIII" "DCCCXLIV" "DCCCXLV" "DCCCXLVI" "DCCCXLVII" - "DCCCXLVIII" "DCCCXLIX" "DCCCL" "DCCCLI" "DCCCLII" "DCCCLIII" "DCCCLIV" "DCCCLV" "DCCCLVI" - "DCCCLVII" "DCCCLVIII" "DCCCLIX" "DCCCLX" "DCCCLXI" "DCCCLXII" "DCCCLXIII" "DCCCLXIV" - "DCCCLXV" "DCCCLXVI" "DCCCLXVII" "DCCCLXVIII" "DCCCLXIX" "DCCCLXX" "DCCCLXXI" "DCCCLXXII" - "DCCCLXXIII" "DCCCLXXIV" "DCCCLXXV" "DCCCLXXVI" "DCCCLXXVII" "DCCCLXXVIII" "DCCCLXXIX" - "DCCCLXXX" "DCCCLXXXI" "DCCCLXXXII" "DCCCLXXXIII" "DCCCLXXXIV" "DCCCLXXXV" "DCCCLXXXVI" - "DCCCLXXXVII" "DCCCLXXXVIII" "DCCCLXXXIX" "DCCCXC" "DCCCXCI" "DCCCXCII" "DCCCXCIII" - "DCCCXCIV" "DCCCXCV" "DCCCXCVI" "DCCCXCVII" "DCCCXCVIII" "DCCCXCIX" "CM" "CMI" "CMII" - "CMIII" "CMIV" "CMV" "CMVI" "CMVII" "CMVIII" "CMIX" "CMX" "CMXI" "CMXII" "CMXIII" "CMXIV" - "CMXV" "CMXVI" "CMXVII" "CMXVIII" "CMXIX" "CMXX" "CMXXI" "CMXXII" "CMXXIII" "CMXXIV" "CMXXV" - "CMXXVI" "CMXXVII" "CMXXVIII" "CMXXIX" "CMXXX" "CMXXXI" "CMXXXII" "CMXXXIII" "CMXXXIV" - "CMXXXV" "CMXXXVI" "CMXXXVII" "CMXXXVIII" "CMXXXIX" "CMXL" "CMXLI" "CMXLII" "CMXLIII" - "CMXLIV" "CMXLV" "CMXLVI" "CMXLVII" "CMXLVIII" "CMXLIX" "CML" "CMLI" "CMLII" "CMLIII" - "CMLIV" "CMLV" "CMLVI" "CMLVII" "CMLVIII" "CMLIX" "CMLX" "CMLXI" "CMLXII" "CMLXIII" "CMLXIV" - "CMLXV" "CMLXVI" "CMLXVII" "CMLXVIII" "CMLXIX" "CMLXX" "CMLXXI" "CMLXXII" "CMLXXIII" - "CMLXXIV" "CMLXXV" "CMLXXVI" "CMLXXVII" "CMLXXVIII" "CMLXXIX" "CMLXXX" "CMLXXXI" "CMLXXXII" - "CMLXXXIII" "CMLXXXIV" "CMLXXXV" "CMLXXXVI" "CMLXXXVII" "CMLXXXVIII" "CMLXXXIX" "CMXC" - "CMXCI" "CMXCII" "CMXCIII" "CMXCIV" "CMXCV" "CMXCVI" "CMXCVII" "CMXCVIII" "CMXCIX" "M" "MI" - "MII" "MIII" "MIV" "MV" "MVI" "MVII" "MVIII" "MIX" "MX" "MXI" "MXII" "MXIII" "MXIV" "MXV" - "MXVI" "MXVII" "MXVIII" "MXIX" "MXX" "MXXI" "MXXII" "MXXIII" "MXXIV" "MXXV" "MXXVI" "MXXVII" - "MXXVIII" "MXXIX" "MXXX" "MXXXI" "MXXXII" "MXXXIII" "MXXXIV" "MXXXV" "MXXXVI" "MXXXVII" - "MXXXVIII" "MXXXIX" "MXL" "MXLI" "MXLII" "MXLIII" "MXLIV" "MXLV" "MXLVI" "MXLVII" "MXLVIII" - "MXLIX" "ML" "MLI" "MLII" "MLIII" "MLIV" "MLV" "MLVI" "MLVII" "MLVIII" "MLIX" "MLX" "MLXI" - "MLXII" "MLXIII" "MLXIV" "MLXV" "MLXVI" "MLXVII" "MLXVIII" "MLXIX" "MLXX" "MLXXI" "MLXXII" - "MLXXIII" "MLXXIV" "MLXXV" "MLXXVI" "MLXXVII" "MLXXVIII" "MLXXIX" "MLXXX" "MLXXXI" "MLXXXII" - "MLXXXIII" "MLXXXIV" "MLXXXV" "MLXXXVI" "MLXXXVII" "MLXXXVIII" "MLXXXIX" "MXC" "MXCI" - "MXCII" "MXCIII" "MXCIV" "MXCV" "MXCVI" "MXCVII" "MXCVIII" "MXCIX" "MC" "MCI" "MCII" "MCIII" - "MCIV" "MCV" "MCVI" "MCVII" "MCVIII" "MCIX" "MCX" "MCXI" "MCXII" "MCXIII" "MCXIV" "MCXV" - "MCXVI" "MCXVII" "MCXVIII" "MCXIX" "MCXX" "MCXXI" "MCXXII" "MCXXIII" "MCXXIV" "MCXXV" - "MCXXVI" "MCXXVII" "MCXXVIII" "MCXXIX" "MCXXX" "MCXXXI" "MCXXXII" "MCXXXIII" "MCXXXIV" - "MCXXXV" "MCXXXVI" "MCXXXVII" "MCXXXVIII" "MCXXXIX" "MCXL" "MCXLI" "MCXLII" "MCXLIII" - "MCXLIV" "MCXLV" "MCXLVI" "MCXLVII" "MCXLVIII" "MCXLIX" "MCL" "MCLI" "MCLII" "MCLIII" - "MCLIV" "MCLV" "MCLVI" "MCLVII" "MCLVIII" "MCLIX" "MCLX" "MCLXI" "MCLXII" "MCLXIII" "MCLXIV" - "MCLXV" "MCLXVI" "MCLXVII" "MCLXVIII" "MCLXIX" "MCLXX" "MCLXXI" "MCLXXII" "MCLXXIII" - "MCLXXIV" "MCLXXV" "MCLXXVI" "MCLXXVII" "MCLXXVIII" "MCLXXIX" "MCLXXX" "MCLXXXI" "MCLXXXII" - "MCLXXXIII" "MCLXXXIV" "MCLXXXV" "MCLXXXVI" "MCLXXXVII" "MCLXXXVIII" "MCLXXXIX" "MCXC" - "MCXCI" "MCXCII" "MCXCIII" "MCXCIV" "MCXCV" "MCXCVI" "MCXCVII" "MCXCVIII" "MCXCIX" "MCC" - "MCCI" "MCCII" "MCCIII" "MCCIV" "MCCV" "MCCVI" "MCCVII" "MCCVIII" "MCCIX" "MCCX" "MCCXI" - "MCCXII" "MCCXIII" "MCCXIV" "MCCXV" "MCCXVI" "MCCXVII" "MCCXVIII" "MCCXIX" "MCCXX" "MCCXXI" - "MCCXXII" "MCCXXIII" "MCCXXIV" "MCCXXV" "MCCXXVI" "MCCXXVII" "MCCXXVIII" "MCCXXIX" "MCCXXX" - "MCCXXXI" "MCCXXXII" "MCCXXXIII" "MCCXXXIV" "MCCXXXV" "MCCXXXVI" "MCCXXXVII" "MCCXXXVIII" - "MCCXXXIX" "MCCXL" "MCCXLI" "MCCXLII" "MCCXLIII" "MCCXLIV" "MCCXLV" "MCCXLVI" "MCCXLVII" - "MCCXLVIII" "MCCXLIX" "MCCL" "MCCLI" "MCCLII" "MCCLIII" "MCCLIV" "MCCLV" "MCCLVI" "MCCLVII" - "MCCLVIII" "MCCLIX" "MCCLX" "MCCLXI" "MCCLXII" "MCCLXIII" "MCCLXIV" "MCCLXV" "MCCLXVI" - "MCCLXVII" "MCCLXVIII" "MCCLXIX" "MCCLXX" "MCCLXXI" "MCCLXXII" "MCCLXXIII" "MCCLXXIV" - "MCCLXXV" "MCCLXXVI" "MCCLXXVII" "MCCLXXVIII" "MCCLXXIX" "MCCLXXX" "MCCLXXXI" "MCCLXXXII" - "MCCLXXXIII" "MCCLXXXIV" "MCCLXXXV" "MCCLXXXVI" "MCCLXXXVII" "MCCLXXXVIII" "MCCLXXXIX" - "MCCXC" "MCCXCI" "MCCXCII" "MCCXCIII" "MCCXCIV" "MCCXCV" "MCCXCVI" "MCCXCVII" "MCCXCVIII" - "MCCXCIX" "MCCC" "MCCCI" "MCCCII" "MCCCIII" "MCCCIV" "MCCCV" "MCCCVI" "MCCCVII" "MCCCVIII" - "MCCCIX" "MCCCX" "MCCCXI" "MCCCXII" "MCCCXIII" "MCCCXIV" "MCCCXV" "MCCCXVI" "MCCCXVII" - "MCCCXVIII" "MCCCXIX" "MCCCXX" "MCCCXXI" "MCCCXXII" "MCCCXXIII" "MCCCXXIV" "MCCCXXV" - "MCCCXXVI" "MCCCXXVII" "MCCCXXVIII" "MCCCXXIX" "MCCCXXX" "MCCCXXXI" "MCCCXXXII" "MCCCXXXIII" - "MCCCXXXIV" "MCCCXXXV" "MCCCXXXVI" "MCCCXXXVII" "MCCCXXXVIII" "MCCCXXXIX" "MCCCXL" "MCCCXLI" - "MCCCXLII" "MCCCXLIII" "MCCCXLIV" "MCCCXLV" "MCCCXLVI" "MCCCXLVII" "MCCCXLVIII" "MCCCXLIX" - "MCCCL" "MCCCLI" "MCCCLII" "MCCCLIII" "MCCCLIV" "MCCCLV" "MCCCLVI" "MCCCLVII" "MCCCLVIII" - "MCCCLIX" "MCCCLX" "MCCCLXI" "MCCCLXII" "MCCCLXIII" "MCCCLXIV" "MCCCLXV" "MCCCLXVI" - "MCCCLXVII" "MCCCLXVIII" "MCCCLXIX" "MCCCLXX" "MCCCLXXI" "MCCCLXXII" "MCCCLXXIII" - "MCCCLXXIV" "MCCCLXXV" "MCCCLXXVI" "MCCCLXXVII" "MCCCLXXVIII" "MCCCLXXIX" "MCCCLXXX" - "MCCCLXXXI" "MCCCLXXXII" "MCCCLXXXIII" "MCCCLXXXIV" "MCCCLXXXV" "MCCCLXXXVI" "MCCCLXXXVII" - "MCCCLXXXVIII" "MCCCLXXXIX" "MCCCXC" "MCCCXCI" "MCCCXCII" "MCCCXCIII" "MCCCXCIV" "MCCCXCV" - "MCCCXCVI" "MCCCXCVII" "MCCCXCVIII" "MCCCXCIX" "MCD" "MCDI" "MCDII" "MCDIII" "MCDIV" "MCDV" - "MCDVI" "MCDVII" "MCDVIII" "MCDIX" "MCDX" "MCDXI" "MCDXII" "MCDXIII" "MCDXIV" "MCDXV" - "MCDXVI" "MCDXVII" "MCDXVIII" "MCDXIX" "MCDXX" "MCDXXI" "MCDXXII" "MCDXXIII" "MCDXXIV" - "MCDXXV" "MCDXXVI" "MCDXXVII" "MCDXXVIII" "MCDXXIX" "MCDXXX" "MCDXXXI" "MCDXXXII" - "MCDXXXIII" "MCDXXXIV" "MCDXXXV" "MCDXXXVI" "MCDXXXVII" "MCDXXXVIII" "MCDXXXIX" "MCDXL" - "MCDXLI" "MCDXLII" "MCDXLIII" "MCDXLIV" "MCDXLV" "MCDXLVI" "MCDXLVII" "MCDXLVIII" "MCDXLIX" - "MCDL" "MCDLI" "MCDLII" "MCDLIII" "MCDLIV" "MCDLV" "MCDLVI" "MCDLVII" "MCDLVIII" "MCDLIX" - "MCDLX" "MCDLXI" "MCDLXII" "MCDLXIII" "MCDLXIV" "MCDLXV" "MCDLXVI" "MCDLXVII" "MCDLXVIII" - "MCDLXIX" "MCDLXX" "MCDLXXI" "MCDLXXII" "MCDLXXIII" "MCDLXXIV" "MCDLXXV" "MCDLXXVI" - "MCDLXXVII" "MCDLXXVIII" "MCDLXXIX" "MCDLXXX" "MCDLXXXI" "MCDLXXXII" "MCDLXXXIII" - "MCDLXXXIV" "MCDLXXXV" "MCDLXXXVI" "MCDLXXXVII" "MCDLXXXVIII" "MCDLXXXIX" "MCDXC" "MCDXCI" - "MCDXCII" "MCDXCIII" "MCDXCIV" "MCDXCV" "MCDXCVI" "MCDXCVII" "MCDXCVIII" "MCDXCIX" "MD" - "MDI" "MDII" "MDIII" "MDIV" "MDV" "MDVI" "MDVII" "MDVIII" "MDIX" "MDX" "MDXI" "MDXII" - "MDXIII" "MDXIV" "MDXV" "MDXVI" "MDXVII" "MDXVIII" "MDXIX" "MDXX" "MDXXI" "MDXXII" "MDXXIII" - "MDXXIV" "MDXXV" "MDXXVI" "MDXXVII" "MDXXVIII" "MDXXIX" "MDXXX" "MDXXXI" "MDXXXII" - "MDXXXIII" "MDXXXIV" "MDXXXV" "MDXXXVI" "MDXXXVII" "MDXXXVIII" "MDXXXIX" "MDXL" "MDXLI" - "MDXLII" "MDXLIII" "MDXLIV" "MDXLV" "MDXLVI" "MDXLVII" "MDXLVIII" "MDXLIX" "MDL" "MDLI" - "MDLII" "MDLIII" "MDLIV" "MDLV" "MDLVI" "MDLVII" "MDLVIII" "MDLIX" "MDLX" "MDLXI" "MDLXII" - "MDLXIII" "MDLXIV" "MDLXV" "MDLXVI" "MDLXVII" "MDLXVIII" "MDLXIX" "MDLXX" "MDLXXI" "MDLXXII" - "MDLXXIII" "MDLXXIV" "MDLXXV" "MDLXXVI" "MDLXXVII" "MDLXXVIII" "MDLXXIX" "MDLXXX" "MDLXXXI" - "MDLXXXII" "MDLXXXIII" "MDLXXXIV" "MDLXXXV" "MDLXXXVI" "MDLXXXVII" "MDLXXXVIII" "MDLXXXIX" - "MDXC" "MDXCI" "MDXCII" "MDXCIII" "MDXCIV" "MDXCV" "MDXCVI" "MDXCVII" "MDXCVIII" "MDXCIX" - "MDC" "MDCI" "MDCII" "MDCIII" "MDCIV" "MDCV" "MDCVI" "MDCVII" "MDCVIII" "MDCIX" "MDCX" - "MDCXI" "MDCXII" "MDCXIII" "MDCXIV" "MDCXV" "MDCXVI" "MDCXVII" "MDCXVIII" "MDCXIX" "MDCXX" - "MDCXXI" "MDCXXII" "MDCXXIII" "MDCXXIV" "MDCXXV" "MDCXXVI" "MDCXXVII" "MDCXXVIII" "MDCXXIX" - "MDCXXX" "MDCXXXI" "MDCXXXII" "MDCXXXIII" "MDCXXXIV" "MDCXXXV" "MDCXXXVI" "MDCXXXVII" - "MDCXXXVIII" "MDCXXXIX" "MDCXL" "MDCXLI" "MDCXLII" "MDCXLIII" "MDCXLIV" "MDCXLV" "MDCXLVI" - "MDCXLVII" "MDCXLVIII" "MDCXLIX" "MDCL" "MDCLI" "MDCLII" "MDCLIII" "MDCLIV" "MDCLV" "MDCLVI" - "MDCLVII" "MDCLVIII" "MDCLIX" "MDCLX" "MDCLXI" "MDCLXII" "MDCLXIII" "MDCLXIV" "MDCLXV" - "MDCLXVI" "MDCLXVII" "MDCLXVIII" "MDCLXIX" "MDCLXX" "MDCLXXI" "MDCLXXII" "MDCLXXIII" - "MDCLXXIV" "MDCLXXV" "MDCLXXVI" "MDCLXXVII" "MDCLXXVIII" "MDCLXXIX" "MDCLXXX" "MDCLXXXI" - "MDCLXXXII" "MDCLXXXIII" "MDCLXXXIV" "MDCLXXXV" "MDCLXXXVI" "MDCLXXXVII" "MDCLXXXVIII" - "MDCLXXXIX" "MDCXC" "MDCXCI" "MDCXCII" "MDCXCIII" "MDCXCIV" "MDCXCV" "MDCXCVI" "MDCXCVII" - "MDCXCVIII" "MDCXCIX" "MDCC" "MDCCI" "MDCCII" "MDCCIII" "MDCCIV" "MDCCV" "MDCCVI" "MDCCVII" - "MDCCVIII" "MDCCIX" "MDCCX" "MDCCXI" "MDCCXII" "MDCCXIII" "MDCCXIV" "MDCCXV" "MDCCXVI" - "MDCCXVII" "MDCCXVIII" "MDCCXIX" "MDCCXX" "MDCCXXI" "MDCCXXII" "MDCCXXIII" "MDCCXXIV" - "MDCCXXV" "MDCCXXVI" "MDCCXXVII" "MDCCXXVIII" "MDCCXXIX" "MDCCXXX" "MDCCXXXI" "MDCCXXXII" - "MDCCXXXIII" "MDCCXXXIV" "MDCCXXXV" "MDCCXXXVI" "MDCCXXXVII" "MDCCXXXVIII" "MDCCXXXIX" - "MDCCXL" "MDCCXLI" "MDCCXLII" "MDCCXLIII" "MDCCXLIV" "MDCCXLV" "MDCCXLVI" "MDCCXLVII" - "MDCCXLVIII" "MDCCXLIX" "MDCCL" "MDCCLI" "MDCCLII" "MDCCLIII" "MDCCLIV" "MDCCLV" "MDCCLVI" - "MDCCLVII" "MDCCLVIII" "MDCCLIX" "MDCCLX" "MDCCLXI" "MDCCLXII" "MDCCLXIII" "MDCCLXIV" - "MDCCLXV" "MDCCLXVI" "MDCCLXVII" "MDCCLXVIII" "MDCCLXIX" "MDCCLXX" "MDCCLXXI" "MDCCLXXII" - "MDCCLXXIII" "MDCCLXXIV" "MDCCLXXV" "MDCCLXXVI" "MDCCLXXVII" "MDCCLXXVIII" "MDCCLXXIX" - "MDCCLXXX" "MDCCLXXXI" "MDCCLXXXII" "MDCCLXXXIII" "MDCCLXXXIV" "MDCCLXXXV" "MDCCLXXXVI" - "MDCCLXXXVII" "MDCCLXXXVIII" "MDCCLXXXIX" "MDCCXC" "MDCCXCI" "MDCCXCII" "MDCCXCIII" - "MDCCXCIV" "MDCCXCV" "MDCCXCVI" "MDCCXCVII" "MDCCXCVIII" "MDCCXCIX" "MDCCC" "MDCCCI" - "MDCCCII" "MDCCCIII" "MDCCCIV" "MDCCCV" "MDCCCVI" "MDCCCVII" "MDCCCVIII" "MDCCCIX" "MDCCCX" - "MDCCCXI" "MDCCCXII" "MDCCCXIII" "MDCCCXIV" "MDCCCXV" "MDCCCXVI" "MDCCCXVII" "MDCCCXVIII" - "MDCCCXIX" "MDCCCXX" "MDCCCXXI" "MDCCCXXII" "MDCCCXXIII" "MDCCCXXIV" "MDCCCXXV" "MDCCCXXVI" - "MDCCCXXVII" "MDCCCXXVIII" "MDCCCXXIX" "MDCCCXXX" "MDCCCXXXI" "MDCCCXXXII" "MDCCCXXXIII" - "MDCCCXXXIV" "MDCCCXXXV" "MDCCCXXXVI" "MDCCCXXXVII" "MDCCCXXXVIII" "MDCCCXXXIX" "MDCCCXL" - "MDCCCXLI" "MDCCCXLII" "MDCCCXLIII" "MDCCCXLIV" "MDCCCXLV" "MDCCCXLVI" "MDCCCXLVII" - "MDCCCXLVIII" "MDCCCXLIX" "MDCCCL" "MDCCCLI" "MDCCCLII" "MDCCCLIII" "MDCCCLIV" "MDCCCLV" - "MDCCCLVI" "MDCCCLVII" "MDCCCLVIII" "MDCCCLIX" "MDCCCLX" "MDCCCLXI" "MDCCCLXII" "MDCCCLXIII" - "MDCCCLXIV" "MDCCCLXV" "MDCCCLXVI" "MDCCCLXVII" "MDCCCLXVIII" "MDCCCLXIX" "MDCCCLXX" - "MDCCCLXXI" "MDCCCLXXII" "MDCCCLXXIII" "MDCCCLXXIV" "MDCCCLXXV" "MDCCCLXXVI" "MDCCCLXXVII" - "MDCCCLXXVIII" "MDCCCLXXIX" "MDCCCLXXX" "MDCCCLXXXI" "MDCCCLXXXII" "MDCCCLXXXIII" - "MDCCCLXXXIV" "MDCCCLXXXV" "MDCCCLXXXVI" "MDCCCLXXXVII" "MDCCCLXXXVIII" "MDCCCLXXXIX" - "MDCCCXC" "MDCCCXCI" "MDCCCXCII" "MDCCCXCIII" "MDCCCXCIV" "MDCCCXCV" "MDCCCXCVI" - "MDCCCXCVII" "MDCCCXCVIII" "MDCCCXCIX" "MCM" "MCMI" "MCMII" "MCMIII" "MCMIV" "MCMV" "MCMVI" - "MCMVII" "MCMVIII" "MCMIX" "MCMX" "MCMXI" "MCMXII" "MCMXIII" "MCMXIV" "MCMXV" "MCMXVI" - "MCMXVII" "MCMXVIII" "MCMXIX" "MCMXX" "MCMXXI" "MCMXXII" "MCMXXIII" "MCMXXIV" "MCMXXV" - "MCMXXVI" "MCMXXVII" "MCMXXVIII" "MCMXXIX" "MCMXXX" "MCMXXXI" "MCMXXXII" "MCMXXXIII" - "MCMXXXIV" "MCMXXXV" "MCMXXXVI" "MCMXXXVII" "MCMXXXVIII" "MCMXXXIX" "MCMXL" "MCMXLI" - "MCMXLII" "MCMXLIII" "MCMXLIV" "MCMXLV" "MCMXLVI" "MCMXLVII" "MCMXLVIII" "MCMXLIX" "MCML" - "MCMLI" "MCMLII" "MCMLIII" "MCMLIV" "MCMLV" "MCMLVI" "MCMLVII" "MCMLVIII" "MCMLIX" "MCMLX" - "MCMLXI" "MCMLXII" "MCMLXIII" "MCMLXIV" "MCMLXV" "MCMLXVI" "MCMLXVII" "MCMLXVIII" "MCMLXIX" - "MCMLXX" "MCMLXXI" "MCMLXXII" "MCMLXXIII" "MCMLXXIV" "MCMLXXV" "MCMLXXVI" "MCMLXXVII" - "MCMLXXVIII" "MCMLXXIX" "MCMLXXX" "MCMLXXXI" "MCMLXXXII" "MCMLXXXIII" "MCMLXXXIV" "MCMLXXXV" - "MCMLXXXVI" "MCMLXXXVII" "MCMLXXXVIII" "MCMLXXXIX" "MCMXC" "MCMXCI" "MCMXCII" "MCMXCIII" - "MCMXCIV" "MCMXCV" "MCMXCVI" "MCMXCVII" "MCMXCVIII" "MCMXCIX" "MM" "MMI" "MMII" "MMIII" - "MMIV" "MMV" "MMVI" "MMVII" "MMVIII" "MMIX" "MMX" "MMXI" "MMXII" "MMXIII" "MMXIV" "MMXV" - "MMXVI" "MMXVII" "MMXVIII" "MMXIX" "MMXX" "MMXXI" "MMXXII" "MMXXIII" "MMXXIV" "MMXXV" - "MMXXVI" "MMXXVII" "MMXXVIII" "MMXXIX" "MMXXX" "MMXXXI" "MMXXXII" "MMXXXIII" "MMXXXIV" - "MMXXXV" "MMXXXVI" "MMXXXVII" "MMXXXVIII" "MMXXXIX" "MMXL" "MMXLI" "MMXLII" "MMXLIII" - "MMXLIV" "MMXLV" "MMXLVI" "MMXLVII" "MMXLVIII" "MMXLIX" "MML" "MMLI" "MMLII" "MMLIII" - "MMLIV" "MMLV" "MMLVI" "MMLVII" "MMLVIII" "MMLIX" "MMLX" "MMLXI" "MMLXII" "MMLXIII" "MMLXIV" - "MMLXV" "MMLXVI" "MMLXVII" "MMLXVIII" "MMLXIX" "MMLXX" "MMLXXI" "MMLXXII" "MMLXXIII" - "MMLXXIV" "MMLXXV" "MMLXXVI" "MMLXXVII" "MMLXXVIII" "MMLXXIX" "MMLXXX" "MMLXXXI" "MMLXXXII" - "MMLXXXIII" "MMLXXXIV" "MMLXXXV" "MMLXXXVI" "MMLXXXVII" "MMLXXXVIII" "MMLXXXIX" "MMXC" - "MMXCI" "MMXCII" "MMXCIII" "MMXCIV" "MMXCV" "MMXCVI" "MMXCVII" "MMXCVIII" "MMXCIX" "MMC" - "MMCI" "MMCII" "MMCIII" "MMCIV" "MMCV" "MMCVI" "MMCVII" "MMCVIII" "MMCIX" "MMCX" "MMCXI" - "MMCXII" "MMCXIII" "MMCXIV" "MMCXV" "MMCXVI" "MMCXVII" "MMCXVIII" "MMCXIX" "MMCXX" "MMCXXI" - "MMCXXII" "MMCXXIII" "MMCXXIV" "MMCXXV" "MMCXXVI" "MMCXXVII" "MMCXXVIII" "MMCXXIX" "MMCXXX" - "MMCXXXI" "MMCXXXII" "MMCXXXIII" "MMCXXXIV" "MMCXXXV" "MMCXXXVI" "MMCXXXVII" "MMCXXXVIII" - "MMCXXXIX" "MMCXL" "MMCXLI" "MMCXLII" "MMCXLIII" "MMCXLIV" "MMCXLV" "MMCXLVI" "MMCXLVII" - "MMCXLVIII" "MMCXLIX" "MMCL" "MMCLI" "MMCLII" "MMCLIII" "MMCLIV" "MMCLV" "MMCLVI" "MMCLVII" - "MMCLVIII" "MMCLIX" "MMCLX" "MMCLXI" "MMCLXII" "MMCLXIII" "MMCLXIV" "MMCLXV" "MMCLXVI" - "MMCLXVII" "MMCLXVIII" "MMCLXIX" "MMCLXX" "MMCLXXI" "MMCLXXII" "MMCLXXIII" "MMCLXXIV" - "MMCLXXV" "MMCLXXVI" "MMCLXXVII" "MMCLXXVIII" "MMCLXXIX" "MMCLXXX" "MMCLXXXI" "MMCLXXXII" - "MMCLXXXIII" "MMCLXXXIV" "MMCLXXXV" "MMCLXXXVI" "MMCLXXXVII" "MMCLXXXVIII" "MMCLXXXIX" - "MMCXC" "MMCXCI" "MMCXCII" "MMCXCIII" "MMCXCIV" "MMCXCV" "MMCXCVI" "MMCXCVII" "MMCXCVIII" - "MMCXCIX" "MMCC" "MMCCI" "MMCCII" "MMCCIII" "MMCCIV" "MMCCV" "MMCCVI" "MMCCVII" "MMCCVIII" - "MMCCIX" "MMCCX" "MMCCXI" "MMCCXII" "MMCCXIII" "MMCCXIV" "MMCCXV" "MMCCXVI" "MMCCXVII" - "MMCCXVIII" "MMCCXIX" "MMCCXX" "MMCCXXI" "MMCCXXII" "MMCCXXIII" "MMCCXXIV" "MMCCXXV" - "MMCCXXVI" "MMCCXXVII" "MMCCXXVIII" "MMCCXXIX" "MMCCXXX" "MMCCXXXI" "MMCCXXXII" "MMCCXXXIII" - "MMCCXXXIV" "MMCCXXXV" "MMCCXXXVI" "MMCCXXXVII" "MMCCXXXVIII" "MMCCXXXIX" "MMCCXL" "MMCCXLI" - "MMCCXLII" "MMCCXLIII" "MMCCXLIV" "MMCCXLV" "MMCCXLVI" "MMCCXLVII" "MMCCXLVIII" "MMCCXLIX" - "MMCCL" "MMCCLI" "MMCCLII" "MMCCLIII" "MMCCLIV" "MMCCLV" "MMCCLVI" "MMCCLVII" "MMCCLVIII" - "MMCCLIX" "MMCCLX" "MMCCLXI" "MMCCLXII" "MMCCLXIII" "MMCCLXIV" "MMCCLXV" "MMCCLXVI" - "MMCCLXVII" "MMCCLXVIII" "MMCCLXIX" "MMCCLXX" "MMCCLXXI" "MMCCLXXII" "MMCCLXXIII" - "MMCCLXXIV" "MMCCLXXV" "MMCCLXXVI" "MMCCLXXVII" "MMCCLXXVIII" "MMCCLXXIX" "MMCCLXXX" - "MMCCLXXXI" "MMCCLXXXII" "MMCCLXXXIII" "MMCCLXXXIV" "MMCCLXXXV" "MMCCLXXXVI" "MMCCLXXXVII" - "MMCCLXXXVIII" "MMCCLXXXIX" "MMCCXC" "MMCCXCI" "MMCCXCII" "MMCCXCIII" "MMCCXCIV" "MMCCXCV" - "MMCCXCVI" "MMCCXCVII" "MMCCXCVIII" "MMCCXCIX" "MMCCC" "MMCCCI" "MMCCCII" "MMCCCIII" - "MMCCCIV" "MMCCCV" "MMCCCVI" "MMCCCVII" "MMCCCVIII" "MMCCCIX" "MMCCCX" "MMCCCXI" "MMCCCXII" - "MMCCCXIII" "MMCCCXIV" "MMCCCXV" "MMCCCXVI" "MMCCCXVII" "MMCCCXVIII" "MMCCCXIX" "MMCCCXX" - "MMCCCXXI" "MMCCCXXII" "MMCCCXXIII" "MMCCCXXIV" "MMCCCXXV" "MMCCCXXVI" "MMCCCXXVII" - "MMCCCXXVIII" "MMCCCXXIX" "MMCCCXXX" "MMCCCXXXI" "MMCCCXXXII" "MMCCCXXXIII" "MMCCCXXXIV" - "MMCCCXXXV" "MMCCCXXXVI" "MMCCCXXXVII" "MMCCCXXXVIII" "MMCCCXXXIX" "MMCCCXL" "MMCCCXLI" - "MMCCCXLII" "MMCCCXLIII" "MMCCCXLIV" "MMCCCXLV" "MMCCCXLVI" "MMCCCXLVII" "MMCCCXLVIII" - "MMCCCXLIX" "MMCCCL" "MMCCCLI" "MMCCCLII" "MMCCCLIII" "MMCCCLIV" "MMCCCLV" "MMCCCLVI" - "MMCCCLVII" "MMCCCLVIII" "MMCCCLIX" "MMCCCLX" "MMCCCLXI" "MMCCCLXII" "MMCCCLXIII" - "MMCCCLXIV" "MMCCCLXV" "MMCCCLXVI" "MMCCCLXVII" "MMCCCLXVIII" "MMCCCLXIX" "MMCCCLXX" - "MMCCCLXXI" "MMCCCLXXII" "MMCCCLXXIII" "MMCCCLXXIV" "MMCCCLXXV" "MMCCCLXXVI" "MMCCCLXXVII" - "MMCCCLXXVIII" "MMCCCLXXIX" "MMCCCLXXX" "MMCCCLXXXI" "MMCCCLXXXII" "MMCCCLXXXIII" - "MMCCCLXXXIV" "MMCCCLXXXV" "MMCCCLXXXVI" "MMCCCLXXXVII" "MMCCCLXXXVIII" "MMCCCLXXXIX" - "MMCCCXC" "MMCCCXCI" "MMCCCXCII" "MMCCCXCIII" "MMCCCXCIV" "MMCCCXCV" "MMCCCXCVI" - "MMCCCXCVII" "MMCCCXCVIII" "MMCCCXCIX" "MMCD" "MMCDI" "MMCDII" "MMCDIII" "MMCDIV" "MMCDV" - "MMCDVI" "MMCDVII" "MMCDVIII" "MMCDIX" "MMCDX" "MMCDXI" "MMCDXII" "MMCDXIII" "MMCDXIV" - "MMCDXV" "MMCDXVI" "MMCDXVII" "MMCDXVIII" "MMCDXIX" "MMCDXX" "MMCDXXI" "MMCDXXII" - "MMCDXXIII" "MMCDXXIV" "MMCDXXV" "MMCDXXVI" "MMCDXXVII" "MMCDXXVIII" "MMCDXXIX" "MMCDXXX" - "MMCDXXXI" "MMCDXXXII" "MMCDXXXIII" "MMCDXXXIV" "MMCDXXXV" "MMCDXXXVI" "MMCDXXXVII" - "MMCDXXXVIII" "MMCDXXXIX" "MMCDXL" "MMCDXLI" "MMCDXLII" "MMCDXLIII" "MMCDXLIV" "MMCDXLV" - "MMCDXLVI" "MMCDXLVII" "MMCDXLVIII" "MMCDXLIX" "MMCDL" "MMCDLI" "MMCDLII" "MMCDLIII" - "MMCDLIV" "MMCDLV" "MMCDLVI" "MMCDLVII" "MMCDLVIII" "MMCDLIX" "MMCDLX" "MMCDLXI" "MMCDLXII" - "MMCDLXIII" "MMCDLXIV" "MMCDLXV" "MMCDLXVI" "MMCDLXVII" "MMCDLXVIII" "MMCDLXIX" "MMCDLXX" - "MMCDLXXI" "MMCDLXXII" "MMCDLXXIII" "MMCDLXXIV" "MMCDLXXV" "MMCDLXXVI" "MMCDLXXVII" - "MMCDLXXVIII" "MMCDLXXIX" "MMCDLXXX" "MMCDLXXXI" "MMCDLXXXII" "MMCDLXXXIII" "MMCDLXXXIV" - "MMCDLXXXV" "MMCDLXXXVI" "MMCDLXXXVII" "MMCDLXXXVIII" "MMCDLXXXIX" "MMCDXC" "MMCDXCI" - "MMCDXCII" "MMCDXCIII" "MMCDXCIV" "MMCDXCV" "MMCDXCVI" "MMCDXCVII" "MMCDXCVIII" "MMCDXCIX" - "MMD" "MMDI" "MMDII" "MMDIII" "MMDIV" "MMDV" "MMDVI" "MMDVII" "MMDVIII" "MMDIX" "MMDX" - "MMDXI" "MMDXII" "MMDXIII" "MMDXIV" "MMDXV" "MMDXVI" "MMDXVII" "MMDXVIII" "MMDXIX" "MMDXX" - "MMDXXI" "MMDXXII" "MMDXXIII" "MMDXXIV" "MMDXXV" "MMDXXVI" "MMDXXVII" "MMDXXVIII" "MMDXXIX" - "MMDXXX" "MMDXXXI" "MMDXXXII" "MMDXXXIII" "MMDXXXIV" "MMDXXXV" "MMDXXXVI" "MMDXXXVII" - "MMDXXXVIII" "MMDXXXIX" "MMDXL" "MMDXLI" "MMDXLII" "MMDXLIII" "MMDXLIV" "MMDXLV" "MMDXLVI" - "MMDXLVII" "MMDXLVIII" "MMDXLIX" "MMDL" "MMDLI" "MMDLII" "MMDLIII" "MMDLIV" "MMDLV" "MMDLVI" - "MMDLVII" "MMDLVIII" "MMDLIX" "MMDLX" "MMDLXI" "MMDLXII" "MMDLXIII" "MMDLXIV" "MMDLXV" - "MMDLXVI" "MMDLXVII" "MMDLXVIII" "MMDLXIX" "MMDLXX" "MMDLXXI" "MMDLXXII" "MMDLXXIII" - "MMDLXXIV" "MMDLXXV" "MMDLXXVI" "MMDLXXVII" "MMDLXXVIII" "MMDLXXIX" "MMDLXXX" "MMDLXXXI" - "MMDLXXXII" "MMDLXXXIII" "MMDLXXXIV" "MMDLXXXV" "MMDLXXXVI" "MMDLXXXVII" "MMDLXXXVIII" - "MMDLXXXIX" "MMDXC" "MMDXCI" "MMDXCII" "MMDXCIII" "MMDXCIV" "MMDXCV" "MMDXCVI" "MMDXCVII" - "MMDXCVIII" "MMDXCIX" "MMDC" "MMDCI" "MMDCII" "MMDCIII" "MMDCIV" "MMDCV" "MMDCVI" "MMDCVII" - "MMDCVIII" "MMDCIX" "MMDCX" "MMDCXI" "MMDCXII" "MMDCXIII" "MMDCXIV" "MMDCXV" "MMDCXVI" - "MMDCXVII" "MMDCXVIII" "MMDCXIX" "MMDCXX" "MMDCXXI" "MMDCXXII" "MMDCXXIII" "MMDCXXIV" - "MMDCXXV" "MMDCXXVI" "MMDCXXVII" "MMDCXXVIII" "MMDCXXIX" "MMDCXXX" "MMDCXXXI" "MMDCXXXII" - "MMDCXXXIII" "MMDCXXXIV" "MMDCXXXV" "MMDCXXXVI" "MMDCXXXVII" "MMDCXXXVIII" "MMDCXXXIX" - "MMDCXL" "MMDCXLI" "MMDCXLII" "MMDCXLIII" "MMDCXLIV" "MMDCXLV" "MMDCXLVI" "MMDCXLVII" - "MMDCXLVIII" "MMDCXLIX" "MMDCL" "MMDCLI" "MMDCLII" "MMDCLIII" "MMDCLIV" "MMDCLV" "MMDCLVI" - "MMDCLVII" "MMDCLVIII" "MMDCLIX" "MMDCLX" "MMDCLXI" "MMDCLXII" "MMDCLXIII" "MMDCLXIV" - "MMDCLXV" "MMDCLXVI" "MMDCLXVII" "MMDCLXVIII" "MMDCLXIX" "MMDCLXX" "MMDCLXXI" "MMDCLXXII" - "MMDCLXXIII" "MMDCLXXIV" "MMDCLXXV" "MMDCLXXVI" "MMDCLXXVII" "MMDCLXXVIII" "MMDCLXXIX" - "MMDCLXXX" "MMDCLXXXI" "MMDCLXXXII" "MMDCLXXXIII" "MMDCLXXXIV" "MMDCLXXXV" "MMDCLXXXVI" - "MMDCLXXXVII" "MMDCLXXXVIII" "MMDCLXXXIX" "MMDCXC" "MMDCXCI" "MMDCXCII" "MMDCXCIII" - "MMDCXCIV" "MMDCXCV" "MMDCXCVI" "MMDCXCVII" "MMDCXCVIII" "MMDCXCIX" "MMDCC" "MMDCCI" - "MMDCCII" "MMDCCIII" "MMDCCIV" "MMDCCV" "MMDCCVI" "MMDCCVII" "MMDCCVIII" "MMDCCIX" "MMDCCX" - "MMDCCXI" "MMDCCXII" "MMDCCXIII" "MMDCCXIV" "MMDCCXV" "MMDCCXVI" "MMDCCXVII" "MMDCCXVIII" - "MMDCCXIX" "MMDCCXX" "MMDCCXXI" "MMDCCXXII" "MMDCCXXIII" "MMDCCXXIV" "MMDCCXXV" "MMDCCXXVI" - "MMDCCXXVII" "MMDCCXXVIII" "MMDCCXXIX" "MMDCCXXX" "MMDCCXXXI" "MMDCCXXXII" "MMDCCXXXIII" - "MMDCCXXXIV" "MMDCCXXXV" "MMDCCXXXVI" "MMDCCXXXVII" "MMDCCXXXVIII" "MMDCCXXXIX" "MMDCCXL" - "MMDCCXLI" "MMDCCXLII" "MMDCCXLIII" "MMDCCXLIV" "MMDCCXLV" "MMDCCXLVI" "MMDCCXLVII" - "MMDCCXLVIII" "MMDCCXLIX" "MMDCCL" "MMDCCLI" "MMDCCLII" "MMDCCLIII" "MMDCCLIV" "MMDCCLV" - "MMDCCLVI" "MMDCCLVII" "MMDCCLVIII" "MMDCCLIX" "MMDCCLX" "MMDCCLXI" "MMDCCLXII" "MMDCCLXIII" - "MMDCCLXIV" "MMDCCLXV" "MMDCCLXVI" "MMDCCLXVII" "MMDCCLXVIII" "MMDCCLXIX" "MMDCCLXX" - "MMDCCLXXI" "MMDCCLXXII" "MMDCCLXXIII" "MMDCCLXXIV" "MMDCCLXXV" "MMDCCLXXVI" "MMDCCLXXVII" - "MMDCCLXXVIII" "MMDCCLXXIX" "MMDCCLXXX" "MMDCCLXXXI" "MMDCCLXXXII" "MMDCCLXXXIII" - "MMDCCLXXXIV" "MMDCCLXXXV" "MMDCCLXXXVI" "MMDCCLXXXVII" "MMDCCLXXXVIII" "MMDCCLXXXIX" - "MMDCCXC" "MMDCCXCI" "MMDCCXCII" "MMDCCXCIII" "MMDCCXCIV" "MMDCCXCV" "MMDCCXCVI" - "MMDCCXCVII" "MMDCCXCVIII" "MMDCCXCIX" "MMDCCC" "MMDCCCI" "MMDCCCII" "MMDCCCIII" "MMDCCCIV" - "MMDCCCV" "MMDCCCVI" "MMDCCCVII" "MMDCCCVIII" "MMDCCCIX" "MMDCCCX" "MMDCCCXI" "MMDCCCXII" - "MMDCCCXIII" "MMDCCCXIV" "MMDCCCXV" "MMDCCCXVI" "MMDCCCXVII" "MMDCCCXVIII" "MMDCCCXIX" - "MMDCCCXX" "MMDCCCXXI" "MMDCCCXXII" "MMDCCCXXIII" "MMDCCCXXIV" "MMDCCCXXV" "MMDCCCXXVI" - "MMDCCCXXVII" "MMDCCCXXVIII" "MMDCCCXXIX" "MMDCCCXXX" "MMDCCCXXXI" "MMDCCCXXXII" - "MMDCCCXXXIII" "MMDCCCXXXIV" "MMDCCCXXXV" "MMDCCCXXXVI" "MMDCCCXXXVII" "MMDCCCXXXVIII" - "MMDCCCXXXIX" "MMDCCCXL" "MMDCCCXLI" "MMDCCCXLII" "MMDCCCXLIII" "MMDCCCXLIV" "MMDCCCXLV" - "MMDCCCXLVI" "MMDCCCXLVII" "MMDCCCXLVIII" "MMDCCCXLIX" "MMDCCCL" "MMDCCCLI" "MMDCCCLII" - "MMDCCCLIII" "MMDCCCLIV" "MMDCCCLV" "MMDCCCLVI" "MMDCCCLVII" "MMDCCCLVIII" "MMDCCCLIX" - "MMDCCCLX" "MMDCCCLXI" "MMDCCCLXII" "MMDCCCLXIII" "MMDCCCLXIV" "MMDCCCLXV" "MMDCCCLXVI" - "MMDCCCLXVII" "MMDCCCLXVIII" "MMDCCCLXIX" "MMDCCCLXX" "MMDCCCLXXI" "MMDCCCLXXII" - "MMDCCCLXXIII" "MMDCCCLXXIV" "MMDCCCLXXV" "MMDCCCLXXVI" "MMDCCCLXXVII" "MMDCCCLXXVIII" - "MMDCCCLXXIX" "MMDCCCLXXX" "MMDCCCLXXXI" "MMDCCCLXXXII" "MMDCCCLXXXIII" "MMDCCCLXXXIV" - "MMDCCCLXXXV" "MMDCCCLXXXVI" "MMDCCCLXXXVII" "MMDCCCLXXXVIII" "MMDCCCLXXXIX" "MMDCCCXC" - "MMDCCCXCI" "MMDCCCXCII" "MMDCCCXCIII" "MMDCCCXCIV" "MMDCCCXCV" "MMDCCCXCVI" "MMDCCCXCVII" - "MMDCCCXCVIII" "MMDCCCXCIX" "MMCM" "MMCMI" "MMCMII" "MMCMIII" "MMCMIV" "MMCMV" "MMCMVI" - "MMCMVII" "MMCMVIII" "MMCMIX" "MMCMX" "MMCMXI" "MMCMXII" "MMCMXIII" "MMCMXIV" "MMCMXV" - "MMCMXVI" "MMCMXVII" "MMCMXVIII" "MMCMXIX" "MMCMXX" "MMCMXXI" "MMCMXXII" "MMCMXXIII" - "MMCMXXIV" "MMCMXXV" "MMCMXXVI" "MMCMXXVII" "MMCMXXVIII" "MMCMXXIX" "MMCMXXX" "MMCMXXXI" - "MMCMXXXII" "MMCMXXXIII" "MMCMXXXIV" "MMCMXXXV" "MMCMXXXVI" "MMCMXXXVII" "MMCMXXXVIII" - "MMCMXXXIX" "MMCMXL" "MMCMXLI" "MMCMXLII" "MMCMXLIII" "MMCMXLIV" "MMCMXLV" "MMCMXLVI" - "MMCMXLVII" "MMCMXLVIII" "MMCMXLIX" "MMCML" "MMCMLI" "MMCMLII" "MMCMLIII" "MMCMLIV" "MMCMLV" - "MMCMLVI" "MMCMLVII" "MMCMLVIII" "MMCMLIX" "MMCMLX" "MMCMLXI" "MMCMLXII" "MMCMLXIII" - "MMCMLXIV" "MMCMLXV" "MMCMLXVI" "MMCMLXVII" "MMCMLXVIII" "MMCMLXIX" "MMCMLXX" "MMCMLXXI" - "MMCMLXXII" "MMCMLXXIII" "MMCMLXXIV" "MMCMLXXV" "MMCMLXXVI" "MMCMLXXVII" "MMCMLXXVIII" - "MMCMLXXIX" "MMCMLXXX" "MMCMLXXXI" "MMCMLXXXII" "MMCMLXXXIII" "MMCMLXXXIV" "MMCMLXXXV" - "MMCMLXXXVI" "MMCMLXXXVII" "MMCMLXXXVIII" "MMCMLXXXIX" "MMCMXC" "MMCMXCI" "MMCMXCII" - "MMCMXCIII" "MMCMXCIV" "MMCMXCV" "MMCMXCVI" "MMCMXCVII" "MMCMXCVIII" "MMCMXCIX" "MMM" "MMMI" - "MMMII" "MMMIII" "MMMIV" "MMMV" "MMMVI" "MMMVII" "MMMVIII" "MMMIX" "MMMX" "MMMXI" "MMMXII" - "MMMXIII" "MMMXIV" "MMMXV" "MMMXVI" "MMMXVII" "MMMXVIII" "MMMXIX" "MMMXX" "MMMXXI" "MMMXXII" - "MMMXXIII" "MMMXXIV" "MMMXXV" "MMMXXVI" "MMMXXVII" "MMMXXVIII" "MMMXXIX" "MMMXXX" "MMMXXXI" - "MMMXXXII" "MMMXXXIII" "MMMXXXIV" "MMMXXXV" "MMMXXXVI" "MMMXXXVII" "MMMXXXVIII" "MMMXXXIX" - "MMMXL" "MMMXLI" "MMMXLII" "MMMXLIII" "MMMXLIV" "MMMXLV" "MMMXLVI" "MMMXLVII" "MMMXLVIII" - "MMMXLIX" "MMML" "MMMLI" "MMMLII" "MMMLIII" "MMMLIV" "MMMLV" "MMMLVI" "MMMLVII" "MMMLVIII" - "MMMLIX" "MMMLX" "MMMLXI" "MMMLXII" "MMMLXIII" "MMMLXIV" "MMMLXV" "MMMLXVI" "MMMLXVII" - "MMMLXVIII" "MMMLXIX" "MMMLXX" "MMMLXXI" "MMMLXXII" "MMMLXXIII" "MMMLXXIV" "MMMLXXV" - "MMMLXXVI" "MMMLXXVII" "MMMLXXVIII" "MMMLXXIX" "MMMLXXX" "MMMLXXXI" "MMMLXXXII" "MMMLXXXIII" - "MMMLXXXIV" "MMMLXXXV" "MMMLXXXVI" "MMMLXXXVII" "MMMLXXXVIII" "MMMLXXXIX" "MMMXC" "MMMXCI" - "MMMXCII" "MMMXCIII" "MMMXCIV" "MMMXCV" "MMMXCVI" "MMMXCVII" "MMMXCVIII" "MMMXCIX" "MMMC" - "MMMCI" "MMMCII" "MMMCIII" "MMMCIV" "MMMCV" "MMMCVI" "MMMCVII" "MMMCVIII" "MMMCIX" "MMMCX" - "MMMCXI" "MMMCXII" "MMMCXIII" "MMMCXIV" "MMMCXV" "MMMCXVI" "MMMCXVII" "MMMCXVIII" "MMMCXIX" - "MMMCXX" "MMMCXXI" "MMMCXXII" "MMMCXXIII" "MMMCXXIV" "MMMCXXV" "MMMCXXVI" "MMMCXXVII" - "MMMCXXVIII" "MMMCXXIX" "MMMCXXX" "MMMCXXXI" "MMMCXXXII" "MMMCXXXIII" "MMMCXXXIV" "MMMCXXXV" - "MMMCXXXVI" "MMMCXXXVII" "MMMCXXXVIII" "MMMCXXXIX" "MMMCXL" "MMMCXLI" "MMMCXLII" "MMMCXLIII" - "MMMCXLIV" "MMMCXLV" "MMMCXLVI" "MMMCXLVII" "MMMCXLVIII" "MMMCXLIX" "MMMCL" "MMMCLI" - "MMMCLII" "MMMCLIII" "MMMCLIV" "MMMCLV" "MMMCLVI" "MMMCLVII" "MMMCLVIII" "MMMCLIX" "MMMCLX" - "MMMCLXI" "MMMCLXII" "MMMCLXIII" "MMMCLXIV" "MMMCLXV" "MMMCLXVI" "MMMCLXVII" "MMMCLXVIII" - "MMMCLXIX" "MMMCLXX" "MMMCLXXI" "MMMCLXXII" "MMMCLXXIII" "MMMCLXXIV" "MMMCLXXV" "MMMCLXXVI" - "MMMCLXXVII" "MMMCLXXVIII" "MMMCLXXIX" "MMMCLXXX" "MMMCLXXXI" "MMMCLXXXII" "MMMCLXXXIII" - "MMMCLXXXIV" "MMMCLXXXV" "MMMCLXXXVI" "MMMCLXXXVII" "MMMCLXXXVIII" "MMMCLXXXIX" "MMMCXC" - "MMMCXCI" "MMMCXCII" "MMMCXCIII" "MMMCXCIV" "MMMCXCV" "MMMCXCVI" "MMMCXCVII" "MMMCXCVIII" - "MMMCXCIX" "MMMCC" "MMMCCI" "MMMCCII" "MMMCCIII" "MMMCCIV" "MMMCCV" "MMMCCVI" "MMMCCVII" - "MMMCCVIII" "MMMCCIX" "MMMCCX" "MMMCCXI" "MMMCCXII" "MMMCCXIII" "MMMCCXIV" "MMMCCXV" - "MMMCCXVI" "MMMCCXVII" "MMMCCXVIII" "MMMCCXIX" "MMMCCXX" "MMMCCXXI" "MMMCCXXII" "MMMCCXXIII" - "MMMCCXXIV" "MMMCCXXV" "MMMCCXXVI" "MMMCCXXVII" "MMMCCXXVIII" "MMMCCXXIX" "MMMCCXXX" - "MMMCCXXXI" "MMMCCXXXII" "MMMCCXXXIII" "MMMCCXXXIV" "MMMCCXXXV" "MMMCCXXXVI" "MMMCCXXXVII" - "MMMCCXXXVIII" "MMMCCXXXIX" "MMMCCXL" "MMMCCXLI" "MMMCCXLII" "MMMCCXLIII" "MMMCCXLIV" - "MMMCCXLV" "MMMCCXLVI" "MMMCCXLVII" "MMMCCXLVIII" "MMMCCXLIX" "MMMCCL" "MMMCCLI" "MMMCCLII" - "MMMCCLIII" "MMMCCLIV" "MMMCCLV" "MMMCCLVI" "MMMCCLVII" "MMMCCLVIII" "MMMCCLIX" "MMMCCLX" - "MMMCCLXI" "MMMCCLXII" "MMMCCLXIII" "MMMCCLXIV" "MMMCCLXV" "MMMCCLXVI" "MMMCCLXVII" - "MMMCCLXVIII" "MMMCCLXIX" "MMMCCLXX" "MMMCCLXXI" "MMMCCLXXII" "MMMCCLXXIII" "MMMCCLXXIV" - "MMMCCLXXV" "MMMCCLXXVI" "MMMCCLXXVII" "MMMCCLXXVIII" "MMMCCLXXIX" "MMMCCLXXX" "MMMCCLXXXI" - "MMMCCLXXXII" "MMMCCLXXXIII" "MMMCCLXXXIV" "MMMCCLXXXV" "MMMCCLXXXVI" "MMMCCLXXXVII" - "MMMCCLXXXVIII" "MMMCCLXXXIX" "MMMCCXC" "MMMCCXCI" "MMMCCXCII" "MMMCCXCIII" "MMMCCXCIV" - "MMMCCXCV" "MMMCCXCVI" "MMMCCXCVII" "MMMCCXCVIII" "MMMCCXCIX" "MMMCCC" "MMMCCCI" "MMMCCCII" - "MMMCCCIII" "MMMCCCIV" "MMMCCCV" "MMMCCCVI" "MMMCCCVII" "MMMCCCVIII" "MMMCCCIX" "MMMCCCX" - "MMMCCCXI" "MMMCCCXII" "MMMCCCXIII" "MMMCCCXIV" "MMMCCCXV" "MMMCCCXVI" "MMMCCCXVII" - "MMMCCCXVIII" "MMMCCCXIX" "MMMCCCXX" "MMMCCCXXI" "MMMCCCXXII" "MMMCCCXXIII" "MMMCCCXXIV" - "MMMCCCXXV" "MMMCCCXXVI" "MMMCCCXXVII" "MMMCCCXXVIII" "MMMCCCXXIX" "MMMCCCXXX" "MMMCCCXXXI" - "MMMCCCXXXII" "MMMCCCXXXIII" "MMMCCCXXXIV" "MMMCCCXXXV" "MMMCCCXXXVI" "MMMCCCXXXVII" - "MMMCCCXXXVIII" "MMMCCCXXXIX" "MMMCCCXL" "MMMCCCXLI" "MMMCCCXLII" "MMMCCCXLIII" "MMMCCCXLIV" - "MMMCCCXLV" "MMMCCCXLVI" "MMMCCCXLVII" "MMMCCCXLVIII" "MMMCCCXLIX" "MMMCCCL" "MMMCCCLI" - "MMMCCCLII" "MMMCCCLIII" "MMMCCCLIV" "MMMCCCLV" "MMMCCCLVI" "MMMCCCLVII" "MMMCCCLVIII" - "MMMCCCLIX" "MMMCCCLX" "MMMCCCLXI" "MMMCCCLXII" "MMMCCCLXIII" "MMMCCCLXIV" "MMMCCCLXV" - "MMMCCCLXVI" "MMMCCCLXVII" "MMMCCCLXVIII" "MMMCCCLXIX" "MMMCCCLXX" "MMMCCCLXXI" - "MMMCCCLXXII" "MMMCCCLXXIII" "MMMCCCLXXIV" "MMMCCCLXXV" "MMMCCCLXXVI" "MMMCCCLXXVII" - "MMMCCCLXXVIII" "MMMCCCLXXIX" "MMMCCCLXXX" "MMMCCCLXXXI" "MMMCCCLXXXII" "MMMCCCLXXXIII" - "MMMCCCLXXXIV" "MMMCCCLXXXV" "MMMCCCLXXXVI" "MMMCCCLXXXVII" "MMMCCCLXXXVIII" "MMMCCCLXXXIX" - "MMMCCCXC" "MMMCCCXCI" "MMMCCCXCII" "MMMCCCXCIII" "MMMCCCXCIV" "MMMCCCXCV" "MMMCCCXCVI" - "MMMCCCXCVII" "MMMCCCXCVIII" "MMMCCCXCIX" "MMMCD" "MMMCDI" "MMMCDII" "MMMCDIII" "MMMCDIV" - "MMMCDV" "MMMCDVI" "MMMCDVII" "MMMCDVIII" "MMMCDIX" "MMMCDX" "MMMCDXI" "MMMCDXII" - "MMMCDXIII" "MMMCDXIV" "MMMCDXV" "MMMCDXVI" "MMMCDXVII" "MMMCDXVIII" "MMMCDXIX" "MMMCDXX" - "MMMCDXXI" "MMMCDXXII" "MMMCDXXIII" "MMMCDXXIV" "MMMCDXXV" "MMMCDXXVI" "MMMCDXXVII" - "MMMCDXXVIII" "MMMCDXXIX" "MMMCDXXX" "MMMCDXXXI" "MMMCDXXXII" "MMMCDXXXIII" "MMMCDXXXIV" - "MMMCDXXXV" "MMMCDXXXVI" "MMMCDXXXVII" "MMMCDXXXVIII" "MMMCDXXXIX" "MMMCDXL" "MMMCDXLI" - "MMMCDXLII" "MMMCDXLIII" "MMMCDXLIV" "MMMCDXLV" "MMMCDXLVI" "MMMCDXLVII" "MMMCDXLVIII" - "MMMCDXLIX" "MMMCDL" "MMMCDLI" "MMMCDLII" "MMMCDLIII" "MMMCDLIV" "MMMCDLV" "MMMCDLVI" - "MMMCDLVII" "MMMCDLVIII" "MMMCDLIX" "MMMCDLX" "MMMCDLXI" "MMMCDLXII" "MMMCDLXIII" - "MMMCDLXIV" "MMMCDLXV" "MMMCDLXVI" "MMMCDLXVII" "MMMCDLXVIII" "MMMCDLXIX" "MMMCDLXX" - "MMMCDLXXI" "MMMCDLXXII" "MMMCDLXXIII" "MMMCDLXXIV" "MMMCDLXXV" "MMMCDLXXVI" "MMMCDLXXVII" - "MMMCDLXXVIII" "MMMCDLXXIX" "MMMCDLXXX" "MMMCDLXXXI" "MMMCDLXXXII" "MMMCDLXXXIII" - "MMMCDLXXXIV" "MMMCDLXXXV" "MMMCDLXXXVI" "MMMCDLXXXVII" "MMMCDLXXXVIII" "MMMCDLXXXIX" - "MMMCDXC" "MMMCDXCI" "MMMCDXCII" "MMMCDXCIII" "MMMCDXCIV" "MMMCDXCV" "MMMCDXCVI" - "MMMCDXCVII" "MMMCDXCVIII" "MMMCDXCIX" "MMMD" "MMMDI" "MMMDII" "MMMDIII" "MMMDIV" "MMMDV" - "MMMDVI" "MMMDVII" "MMMDVIII" "MMMDIX" "MMMDX" "MMMDXI" "MMMDXII" "MMMDXIII" "MMMDXIV" - "MMMDXV" "MMMDXVI" "MMMDXVII" "MMMDXVIII" "MMMDXIX" "MMMDXX" "MMMDXXI" "MMMDXXII" - "MMMDXXIII" "MMMDXXIV" "MMMDXXV" "MMMDXXVI" "MMMDXXVII" "MMMDXXVIII" "MMMDXXIX" "MMMDXXX" - "MMMDXXXI" "MMMDXXXII" "MMMDXXXIII" "MMMDXXXIV" "MMMDXXXV" "MMMDXXXVI" "MMMDXXXVII" - "MMMDXXXVIII" "MMMDXXXIX" "MMMDXL" "MMMDXLI" "MMMDXLII" "MMMDXLIII" "MMMDXLIV" "MMMDXLV" - "MMMDXLVI" "MMMDXLVII" "MMMDXLVIII" "MMMDXLIX" "MMMDL" "MMMDLI" "MMMDLII" "MMMDLIII" - "MMMDLIV" "MMMDLV" "MMMDLVI" "MMMDLVII" "MMMDLVIII" "MMMDLIX" "MMMDLX" "MMMDLXI" "MMMDLXII" - "MMMDLXIII" "MMMDLXIV" "MMMDLXV" "MMMDLXVI" "MMMDLXVII" "MMMDLXVIII" "MMMDLXIX" "MMMDLXX" - "MMMDLXXI" "MMMDLXXII" "MMMDLXXIII" "MMMDLXXIV" "MMMDLXXV" "MMMDLXXVI" "MMMDLXXVII" - "MMMDLXXVIII" "MMMDLXXIX" "MMMDLXXX" "MMMDLXXXI" "MMMDLXXXII" "MMMDLXXXIII" "MMMDLXXXIV" - "MMMDLXXXV" "MMMDLXXXVI" "MMMDLXXXVII" "MMMDLXXXVIII" "MMMDLXXXIX" "MMMDXC" "MMMDXCI" - "MMMDXCII" "MMMDXCIII" "MMMDXCIV" "MMMDXCV" "MMMDXCVI" "MMMDXCVII" "MMMDXCVIII" "MMMDXCIX" - "MMMDC" "MMMDCI" "MMMDCII" "MMMDCIII" "MMMDCIV" "MMMDCV" "MMMDCVI" "MMMDCVII" "MMMDCVIII" - "MMMDCIX" "MMMDCX" "MMMDCXI" "MMMDCXII" "MMMDCXIII" "MMMDCXIV" "MMMDCXV" "MMMDCXVI" - "MMMDCXVII" "MMMDCXVIII" "MMMDCXIX" "MMMDCXX" "MMMDCXXI" "MMMDCXXII" "MMMDCXXIII" - "MMMDCXXIV" "MMMDCXXV" "MMMDCXXVI" "MMMDCXXVII" "MMMDCXXVIII" "MMMDCXXIX" "MMMDCXXX" - "MMMDCXXXI" "MMMDCXXXII" "MMMDCXXXIII" "MMMDCXXXIV" "MMMDCXXXV" "MMMDCXXXVI" "MMMDCXXXVII" - "MMMDCXXXVIII" "MMMDCXXXIX" "MMMDCXL" "MMMDCXLI" "MMMDCXLII" "MMMDCXLIII" "MMMDCXLIV" - "MMMDCXLV" "MMMDCXLVI" "MMMDCXLVII" "MMMDCXLVIII" "MMMDCXLIX" "MMMDCL" "MMMDCLI" "MMMDCLII" - "MMMDCLIII" "MMMDCLIV" "MMMDCLV" "MMMDCLVI" "MMMDCLVII" "MMMDCLVIII" "MMMDCLIX" "MMMDCLX" - "MMMDCLXI" "MMMDCLXII" "MMMDCLXIII" "MMMDCLXIV" "MMMDCLXV" "MMMDCLXVI" "MMMDCLXVII" - "MMMDCLXVIII" "MMMDCLXIX" "MMMDCLXX" "MMMDCLXXI" "MMMDCLXXII" "MMMDCLXXIII" "MMMDCLXXIV" - "MMMDCLXXV" "MMMDCLXXVI" "MMMDCLXXVII" "MMMDCLXXVIII" "MMMDCLXXIX" "MMMDCLXXX" "MMMDCLXXXI" - "MMMDCLXXXII" "MMMDCLXXXIII" "MMMDCLXXXIV" "MMMDCLXXXV" "MMMDCLXXXVI" "MMMDCLXXXVII" - "MMMDCLXXXVIII" "MMMDCLXXXIX" "MMMDCXC" "MMMDCXCI" "MMMDCXCII" "MMMDCXCIII" "MMMDCXCIV" - "MMMDCXCV" "MMMDCXCVI" "MMMDCXCVII" "MMMDCXCVIII" "MMMDCXCIX" "MMMDCC" "MMMDCCI" "MMMDCCII" - "MMMDCCIII" "MMMDCCIV" "MMMDCCV" "MMMDCCVI" "MMMDCCVII" "MMMDCCVIII" "MMMDCCIX" "MMMDCCX" - "MMMDCCXI" "MMMDCCXII" "MMMDCCXIII" "MMMDCCXIV" "MMMDCCXV" "MMMDCCXVI" "MMMDCCXVII" - "MMMDCCXVIII" "MMMDCCXIX" "MMMDCCXX" "MMMDCCXXI" "MMMDCCXXII" "MMMDCCXXIII" "MMMDCCXXIV" - "MMMDCCXXV" "MMMDCCXXVI" "MMMDCCXXVII" "MMMDCCXXVIII" "MMMDCCXXIX" "MMMDCCXXX" "MMMDCCXXXI" - "MMMDCCXXXII" "MMMDCCXXXIII" "MMMDCCXXXIV" "MMMDCCXXXV" "MMMDCCXXXVI" "MMMDCCXXXVII" - "MMMDCCXXXVIII" "MMMDCCXXXIX" "MMMDCCXL" "MMMDCCXLI" "MMMDCCXLII" "MMMDCCXLIII" "MMMDCCXLIV" - "MMMDCCXLV" "MMMDCCXLVI" "MMMDCCXLVII" "MMMDCCXLVIII" "MMMDCCXLIX" "MMMDCCL" "MMMDCCLI" - "MMMDCCLII" "MMMDCCLIII" "MMMDCCLIV" "MMMDCCLV" "MMMDCCLVI" "MMMDCCLVII" "MMMDCCLVIII" - "MMMDCCLIX" "MMMDCCLX" "MMMDCCLXI" "MMMDCCLXII" "MMMDCCLXIII" "MMMDCCLXIV" "MMMDCCLXV" - "MMMDCCLXVI" "MMMDCCLXVII" "MMMDCCLXVIII" "MMMDCCLXIX" "MMMDCCLXX" "MMMDCCLXXI" - "MMMDCCLXXII" "MMMDCCLXXIII" "MMMDCCLXXIV" "MMMDCCLXXV" "MMMDCCLXXVI" "MMMDCCLXXVII" - "MMMDCCLXXVIII" "MMMDCCLXXIX" "MMMDCCLXXX" "MMMDCCLXXXI" "MMMDCCLXXXII" "MMMDCCLXXXIII" - "MMMDCCLXXXIV" "MMMDCCLXXXV" "MMMDCCLXXXVI" "MMMDCCLXXXVII" "MMMDCCLXXXVIII" "MMMDCCLXXXIX" - "MMMDCCXC" "MMMDCCXCI" "MMMDCCXCII" "MMMDCCXCIII" "MMMDCCXCIV" "MMMDCCXCV" "MMMDCCXCVI" - "MMMDCCXCVII" "MMMDCCXCVIII" "MMMDCCXCIX" "MMMDCCC" "MMMDCCCI" "MMMDCCCII" "MMMDCCCIII" - "MMMDCCCIV" "MMMDCCCV" "MMMDCCCVI" "MMMDCCCVII" "MMMDCCCVIII" "MMMDCCCIX" "MMMDCCCX" - "MMMDCCCXI" "MMMDCCCXII" "MMMDCCCXIII" "MMMDCCCXIV" "MMMDCCCXV" "MMMDCCCXVI" "MMMDCCCXVII" - "MMMDCCCXVIII" "MMMDCCCXIX" "MMMDCCCXX" "MMMDCCCXXI" "MMMDCCCXXII" "MMMDCCCXXIII" - "MMMDCCCXXIV" "MMMDCCCXXV" "MMMDCCCXXVI" "MMMDCCCXXVII" "MMMDCCCXXVIII" "MMMDCCCXXIX" - "MMMDCCCXXX" "MMMDCCCXXXI" "MMMDCCCXXXII" "MMMDCCCXXXIII" "MMMDCCCXXXIV" "MMMDCCCXXXV" - "MMMDCCCXXXVI" "MMMDCCCXXXVII" "MMMDCCCXXXVIII" "MMMDCCCXXXIX" "MMMDCCCXL" "MMMDCCCXLI" - "MMMDCCCXLII" "MMMDCCCXLIII" "MMMDCCCXLIV" "MMMDCCCXLV" "MMMDCCCXLVI" "MMMDCCCXLVII" - "MMMDCCCXLVIII" "MMMDCCCXLIX" "MMMDCCCL" "MMMDCCCLI" "MMMDCCCLII" "MMMDCCCLIII" "MMMDCCCLIV" - "MMMDCCCLV" "MMMDCCCLVI" "MMMDCCCLVII" "MMMDCCCLVIII" "MMMDCCCLIX" "MMMDCCCLX" "MMMDCCCLXI" - "MMMDCCCLXII" "MMMDCCCLXIII" "MMMDCCCLXIV" "MMMDCCCLXV" "MMMDCCCLXVI" "MMMDCCCLXVII" - "MMMDCCCLXVIII" "MMMDCCCLXIX" "MMMDCCCLXX" "MMMDCCCLXXI" "MMMDCCCLXXII" "MMMDCCCLXXIII" - "MMMDCCCLXXIV" "MMMDCCCLXXV" "MMMDCCCLXXVI" "MMMDCCCLXXVII" "MMMDCCCLXXVIII" "MMMDCCCLXXIX" - "MMMDCCCLXXX" "MMMDCCCLXXXI" "MMMDCCCLXXXII" "MMMDCCCLXXXIII" "MMMDCCCLXXXIV" "MMMDCCCLXXXV" - "MMMDCCCLXXXVI" "MMMDCCCLXXXVII" "MMMDCCCLXXXVIII" "MMMDCCCLXXXIX" "MMMDCCCXC" "MMMDCCCXCI" - "MMMDCCCXCII" "MMMDCCCXCIII" "MMMDCCCXCIV" "MMMDCCCXCV" "MMMDCCCXCVI" "MMMDCCCXCVII" - "MMMDCCCXCVIII" "MMMDCCCXCIX" "MMMCM" "MMMCMI" "MMMCMII" "MMMCMIII" "MMMCMIV" "MMMCMV" - "MMMCMVI" "MMMCMVII" "MMMCMVIII" "MMMCMIX" "MMMCMX" "MMMCMXI" "MMMCMXII" "MMMCMXIII" - "MMMCMXIV" "MMMCMXV" "MMMCMXVI" "MMMCMXVII" "MMMCMXVIII" "MMMCMXIX" "MMMCMXX" "MMMCMXXI" - "MMMCMXXII" "MMMCMXXIII" "MMMCMXXIV" "MMMCMXXV" "MMMCMXXVI" "MMMCMXXVII" "MMMCMXXVIII" - "MMMCMXXIX" "MMMCMXXX" "MMMCMXXXI" "MMMCMXXXII" "MMMCMXXXIII" "MMMCMXXXIV" "MMMCMXXXV" - "MMMCMXXXVI" "MMMCMXXXVII" "MMMCMXXXVIII" "MMMCMXXXIX" "MMMCMXL" "MMMCMXLI" "MMMCMXLII" - "MMMCMXLIII" "MMMCMXLIV" "MMMCMXLV" "MMMCMXLVI" "MMMCMXLVII" "MMMCMXLVIII" "MMMCMXLIX" - "MMMCML" "MMMCMLI" "MMMCMLII" "MMMCMLIII" "MMMCMLIV" "MMMCMLV" "MMMCMLVI" "MMMCMLVII" - "MMMCMLVIII" "MMMCMLIX" "MMMCMLX" "MMMCMLXI" "MMMCMLXII" "MMMCMLXIII" "MMMCMLXIV" "MMMCMLXV" - "MMMCMLXVI" "MMMCMLXVII" "MMMCMLXVIII" "MMMCMLXIX" "MMMCMLXX" "MMMCMLXXI" "MMMCMLXXII" - "MMMCMLXXIII" "MMMCMLXXIV" "MMMCMLXXV" "MMMCMLXXVI" "MMMCMLXXVII" "MMMCMLXXVIII" - "MMMCMLXXIX" "MMMCMLXXX" "MMMCMLXXXI" "MMMCMLXXXII" "MMMCMLXXXIII" "MMMCMLXXXIV" - "MMMCMLXXXV" "MMMCMLXXXVI" "MMMCMLXXXVII" "MMMCMLXXXVIII" "MMMCMLXXXIX" "MMMCMXC" "MMMCMXCI" - "MMMCMXCII" "MMMCMXCIII" "MMMCMXCIV" "MMMCMXCV" "MMMCMXCVI" "MMMCMXCVII" "MMMCMXCVIII" - "MMMCMXCIX")) diff --git a/t/ansi-test/printer/load.lsp b/t/ansi-test/printer/load.lsp deleted file mode 100644 index 4a65cc3..0000000 --- a/t/ansi-test/printer/load.lsp +++ /dev/null @@ -1,50 +0,0 @@ -;;;; Tests of the lisp printer -(compile-and-load "ANSI-TESTS:AUX;printer-aux.lsp") -(compile-and-load "ANSI-TESTS:AUX;backquote-aux.lsp") - -(in-package #:cl-test) - -(let ((*default-pathname-defaults* - (make-pathname - :directory (pathname-directory *load-pathname*)))) - (load "copy-pprint-dispatch.lsp") - (load "print-integers.lsp") - (load "print-ratios.lsp") - (load "print-floats.lsp") - (load "print-complex.lsp") - (load "print-characters.lsp") - (load "print-lines.lsp") - (load "print-symbols.lsp") - (load "print-strings.lsp") - (load "print-cons.lsp") - (load "print-backquote.lsp") - (load "print-bit-vector.lsp") - (load "print-vector.lsp") - (load "print-array.lsp") - (load "print-random-state.lsp") - (load "print-pathname.lsp") - (load "print-structure.lsp") - (load "printer-control-vars.lsp") - (load "pprint-dispatch.lsp") - (load "pprint-fill.lsp") - (load "pprint-linear.lsp") - (load "pprint-tabular.lsp") - (load "pprint-indent.lsp") - (load "pprint-logical-block.lsp") - (load "pprint-exit-if-list-exhausted.lsp") - (load "pprint-newline.lsp") - (load "pprint-tab.lsp") - (load "print-unreadable-object.lsp") - (load "write.lsp") - (load "print.lsp") - (load "pprint.lsp") - (load "prin1.lsp") - (load "princ.lsp") - (load "write-to-string.lsp") - (load "prin1-to-string.lsp") - (load "princ-to-string.lsp") - (load "print-level.lsp") - (load "print-length.lsp") - - (load "format/load.lsp") -) diff --git a/t/ansi-test/printer/pprint-dispatch.lsp b/t/ansi-test/printer/pprint-dispatch.lsp deleted file mode 100644 index 1476261..0000000 --- a/t/ansi-test/printer/pprint-dispatch.lsp +++ /dev/null @@ -1,286 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Jun 12 13:14:53 2004 -;;;; Contains: Tests of PPRINT-DISPATCH, SET-PPRINT-DISPATCH - -(in-package :cl-test) - -(deftest pprint-dispatch.1 - (loop for x in (append *universe* *cl-symbols*) - for vals = (multiple-value-list (pprint-dispatch x)) - for vals2 = (multiple-value-list (pprint-dispatch - x - *print-pprint-dispatch*)) - unless - (and (= (length vals) 2) - (= (length vals2) 2) - (destructuring-bind (fun foundp) - vals - (if foundp - (and (or (typep fun 'function) - (and (symbolp fun) - (symbol-function fun))) - (destructuring-bind (fun2 foundp2) - vals2 - (and (equal fun fun2) - foundp2))) - (not (cadr vals2))))) - collect (list x vals vals2)) - nil) -#| -(deftest pprint-dispatch.2 - (loop for sym in *cl-symbols* - for x = (list sym nil nil) - for vals = (multiple-value-list (pprint-dispatch x)) - for vals2 = (multiple-value-list (pprint-dispatch - x - *print-pprint-dispatch*)) - unless - (and (= (length vals) 2) - (= (length vals2) 2) - (destructuring-bind (fun foundp) - vals - (if foundp - (and (or (typep fun 'function) - (and (symbolp fun) - (symbol-function fun))) - (destructuring-bind (fun2 foundp2) - vals2 - (and (equal fun fun2) - foundp2))) - (not (cadr vals2))))) - collect (list x vals vals2)) - nil) -|# - -;;; Test that setting the pprint dispatch of a symbol causes -;;; the printing to change, and that it can be unset. -(deftest pprint-dispatch.3 - (my-with-standard-io-syntax - (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil)) - (*print-readably* nil) - (*print-escape* nil) - (*print-pretty* t)) - (let ((f #'(lambda (stream obj) - (declare (ignore obj)) - (write "ABC" :stream stream)))) - (values - (write-to-string '|X|) - (set-pprint-dispatch '(eql |X|) f) - (write-to-string '|X|) - (set-pprint-dispatch '(eql |X|) nil) - (write-to-string '|X|))))) - "X" nil "ABC" nil "X") - -;;; Test that setting the pprint dispatch of a symbol causes -;;; the printing to change for any real weight, and that it can be unset. -(deftest pprint-dispatch.4 - (my-with-standard-io-syntax - (loop for v1 in (remove-if-not #'realp *universe*) - unless - (equal - (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil)) - (*print-readably* nil) - (*print-escape* nil) - (*print-pretty* t)) - (let ((f #'(lambda (stream obj) - (declare (ignore obj)) - (write "ABC" :stream stream)))) - (list - (write-to-string '|X|) - (set-pprint-dispatch '(eql |X|) f v1) - (write-to-string '|X|) - (set-pprint-dispatch '(eql |X|) nil) - (write-to-string '|X|)))) - '("X" nil "ABC" nil "X")) - collect v1)) - nil) - -;;; Test that setting the pprint dispatch of a symbol causes -;;; the printing to change, and that it can be unset with any real weight -(deftest pprint-dispatch.5 - (my-with-standard-io-syntax - (loop for v1 in (remove-if-not #'realp *universe*) - unless - (equal - (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil)) - (*print-readably* nil) - (*print-escape* nil) - (*print-pretty* t)) - (let ((f #'(lambda (stream obj) - (declare (ignore obj)) - (write "ABC" :stream stream)))) - (list - (write-to-string '|X|) - (set-pprint-dispatch '(eql |X|) f) - (write-to-string '|X|) - (set-pprint-dispatch '(eql |X|) nil v1) - (write-to-string '|X|)))) - '("X" nil "ABC" nil "X")) - collect v1)) - nil) - -;;; Check that specifying the pprint-dispatch table argument to set-pprint-dispatch -;;; causes that table to be changed, not *print-pprint-dispatch*. -(deftest pprint-dispatch.6 - (my-with-standard-io-syntax - (let ((other-ppd-table (copy-pprint-dispatch nil)) - (*print-pprint-dispatch* (copy-pprint-dispatch nil)) - (*print-readably* nil) - (*print-escape* nil) - (*print-pretty* t)) - (let ((f #'(lambda (stream obj) - (declare (ignore obj)) - (write "ABC" :stream stream)))) - (values - (write-to-string '|X|) - (set-pprint-dispatch '(eql |X|) f 0 other-ppd-table) - (write-to-string '|X|) - (let ((*print-pprint-dispatch* other-ppd-table)) - (write-to-string '|X|)) - (set-pprint-dispatch '(eql |X|) f) - (write-to-string '|X|) - (set-pprint-dispatch '(eql |X|) nil) - (write-to-string '|X|))))) - "X" nil "X" "ABC" nil "ABC" nil "X") - -;;; Test that the default weight of set-pprint-dispatch is 0 - -(deftest pprint-dispatch.7 - (my-with-standard-io-syntax - (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil)) - (*print-readably* nil) - (*print-escape* nil) - (*print-pretty* t)) - (let ((f #'(lambda (stream obj) - (declare (ignore obj)) - (write "ABC" :stream stream))) - (g #'(lambda (stream obj) - (declare (ignore obj)) - (write "DEF" :stream stream)))) - (values - (write-to-string '|X|) - (set-pprint-dispatch '(eql |X|) f) - (write-to-string '|X|) - (set-pprint-dispatch '(member |X| |Y|) g .0001) - (write-to-string '|X|) - (write-to-string '|Y|))))) - "X" nil "ABC" nil "DEF" "DEF") - -(deftest pprint-dispatch.8 - (my-with-standard-io-syntax - (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil)) - (*print-readably* nil) - (*print-escape* nil) - (*print-pretty* t)) - (let ((f #'(lambda (stream obj) - (declare (ignore obj)) - (write "ABC" :stream stream))) - (g #'(lambda (stream obj) - (declare (ignore obj)) - (write "DEF" :stream stream)))) - (values - (write-to-string '|X|) - (set-pprint-dispatch '(eql |X|) f) - (write-to-string '|X|) - (set-pprint-dispatch '(member |X| |Y|) g -.0001) - (write-to-string '|X|) - (write-to-string '|Y|))))) - "X" nil "ABC" nil "ABC" "DEF") - -;;; Funtion designators in pprint-dispatch - -(defun pprint-dispatch-test-fn.1 (stream obj) (declare (ignore obj)) (write "ABC" :stream stream)) -(defun pprint-dispatch-test-fn.2 (stream obj) (declare (ignore obj)) (write "DEF" :stream stream)) - -(deftest pprint-dispatch.9 - (my-with-standard-io-syntax - (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil)) - (*print-readably* nil) - (*print-escape* nil) - (*print-pretty* t)) - (values - (write-to-string '|X|) - (multiple-value-list (set-pprint-dispatch '(eql |X|) 'pprint-dispatch-test-fn.1)) - (write-to-string '|X|) - (multiple-value-list (set-pprint-dispatch '(eql |X|) 'pprint-dispatch-test-fn.2)) - (write-to-string '|X|)))) - "X" (nil) "ABC" (nil) "DEF") - -#| -(deftest pprint-dispatch.10 - (my-with-standard-io-syntax - (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil)) - (*print-readably* nil) - (*print-escape* nil) - (*print-pretty* t)) - (let ((f #'(lambda (stream obj) - (declare (ignore obj)) - (write "ABC" :stream stream))) - (g #'(lambda (stream obj) - (declare (ignore obj)) - (write "DEF" :stream stream))) - (sym (gensym))) - (setf (symbol-function sym) f) - (values - (write-to-string '|X|) - (set-pprint-dispatch '(eql |X|) sym) - (write-to-string '|X|) - (progn - (setf (symbol-function sym) g) - (write-to-string '|X|)))))) - "X" nil "ABC" "DEF") -|# - -;;; Error tests - -(deftest pprint-dispatch.error.1 - (signals-error (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil))) - (pprint-dispatch)) - program-error) - t) - -(deftest pprint-dispatch.error.2 - (signals-error (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil))) - (pprint-dispatch nil nil nil)) - program-error) - t) - -(deftest set-pprint-dispatch.error.1 - (signals-error (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil))) - (set-pprint-dispatch)) - program-error) - t) - -(deftest set-pprint-dispatch.error.2 - (signals-error (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil))) - (set-pprint-dispatch t)) - program-error) - t) - -(deftest set-pprint-dispatch.error.3 - (signals-error (let ((table (copy-pprint-dispatch nil))) - (set-pprint-dispatch t 'identity 0 table nil)) - program-error) - t) - - -(deftest set-pprint-dispatch.error.4 - (loop for x in *mini-universe* - unless (or (typep x 'real) - (eval `(signals-error (let ((table (copy-pprint-dispatch nil))) - (set-pprint-dispatch t 'identity ',x)) - error))) - collect x) - nil) - -(deftest set-pprint-dispatch.error.4-unsafe - (loop for x in *mini-universe* - unless (or (typep x 'real) - (eval `(signals-error (let ((table (copy-pprint-dispatch nil))) - (declare (optimize (safety 0))) - (set-pprint-dispatch t 'identity ',x)) - error))) - collect x) - nil) - diff --git a/t/ansi-test/printer/pprint-exit-if-list-exhausted.lsp b/t/ansi-test/printer/pprint-exit-if-list-exhausted.lsp deleted file mode 100644 index 3894a1e..0000000 --- a/t/ansi-test/printer/pprint-exit-if-list-exhausted.lsp +++ /dev/null @@ -1,326 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Jul 6 06:11:01 2004 -;;;; Contains: Tests of PPRINT-EXIT-IF-LIST-EXHAUSTED, PPRINT-POP - -(in-package :cl-test) - -(deftest pprint-exit-if-list-exhausted.1 - (with-standard-io-syntax - (let ((*print-pretty* nil) - (*print-escape* nil) - (*print-right-margin* 100) - (*print-readably* nil) - ) - (with-output-to-string - (os) - (pprint-logical-block - (os '(1 2)) - (assert (equal (multiple-value-list - (pprint-exit-if-list-exhausted)) - '(nil))) - (write (pprint-pop) :stream os) - (assert (equal (multiple-value-list - (pprint-exit-if-list-exhausted)) - '(nil))) - (write #\Space :stream os) - (write (pprint-pop) :stream os) - (pprint-exit-if-list-exhausted) - (assert nil))))) - "1 2") - -(deftest pprint-exit-if-list-exhausted.2 - (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-escape* nil) - (*print-right-margin* 100) - (*print-readably* nil) - ) - (with-output-to-string - (os) - (pprint-logical-block - (os '(1 2)) - (assert (equal (multiple-value-list - (pprint-exit-if-list-exhausted)) - '(nil))) - (write (pprint-pop) :stream os) - (assert (equal (multiple-value-list - (pprint-exit-if-list-exhausted)) - '(nil))) - (write #\Space :stream os) - (write (pprint-pop) :stream os) - (pprint-exit-if-list-exhausted) - (assert nil))))) - "1 2") - -(deftest pprint-exit-if-list-exhausted.3 - (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-escape* nil) - (*print-right-margin* 100) - (*print-readably* nil) - ) - (with-output-to-string - (os) - (pprint-logical-block - (os '(1 . 2)) - (assert (equal (multiple-value-list - (pprint-exit-if-list-exhausted)) - '(nil))) - (write (pprint-pop) :stream os) - (write #\Space :stream os) - (assert (equal (multiple-value-list - (pprint-exit-if-list-exhausted)) - '(nil))) - (pprint-pop) - (assert nil))))) - "1 . 2") - -(deftest pprint-exit-if-list-exhausted.4 - (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-escape* nil) - (*print-right-margin* 100) - (*print-readably* nil) - ) - (with-output-to-string - (os) - (pprint-logical-block - (os '(1 . 2) :prefix "[" :suffix "]") - (assert (equal (multiple-value-list - (pprint-exit-if-list-exhausted)) - '(nil))) - (write (pprint-pop) :stream os) - (write #\Space :stream os) - (assert (equal (multiple-value-list - (pprint-exit-if-list-exhausted)) - '(nil))) - (pprint-pop) - (assert nil))))) - "[1 . 2]") - -;;; Tests focusing on pprint-pop - -(deftest pprint-pop.1 - (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-escape* nil) - (*print-right-margin* 100) - (*print-readably* nil) - (*print-length* 0)) - (with-output-to-string - (os) - (pprint-logical-block - (os nil) - (pprint-pop) - (assert nil))))) - "...") - -(deftest pprint-pop.2 - (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-escape* nil) - (*print-right-margin* 100) - (*print-readably* nil) - (*print-length* 0)) - (with-output-to-string - (os) - (pprint-logical-block - (os 1) - (pprint-pop))))) - "1") - -(deftest pprint-pop.3 - (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-escape* nil) - (*print-right-margin* 100) - (*print-readably* nil) - (*print-length* 1)) - (with-output-to-string - (os) - (pprint-logical-block - (os '(1)) - (assert (equal '(1) (multiple-value-list (pprint-pop)))))))) - "") - -(deftest pprint-pop.4 - (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-escape* nil) - (*print-right-margin* 100) - (*print-readably* nil) - (*print-length* 0)) - (with-output-to-string - (os) - (pprint-logical-block - (os '(1 2 3) :prefix "{" :suffix "}") - (pprint-pop) - (assert nil))))) - "{...}") - -(deftest pprint-pop.5 - (flet ((%f (len) - (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-escape* nil) - (*print-right-margin* 100) - (*print-readably* nil) - (*print-length* len)) - (with-output-to-string - (os) - (pprint-logical-block - (os '(1 2 3 4 5) :prefix "{" :suffix "}") - (pprint-exit-if-list-exhausted) - (write (pprint-pop) :stream os) - (loop (pprint-exit-if-list-exhausted) - (write #\Space :stream os) - (write (pprint-pop) :stream os)))))))) - (values (%f 0) (%f 1) (%f 2) (%f 3) (%f 4) (%f 5) (%f 6))) - "{...}" - "{1 ...}" - "{1 2 ...}" - "{1 2 3 ...}" - "{1 2 3 4 ...}" - "{1 2 3 4 5}" - "{1 2 3 4 5}") - -(deftest pprint-pop.6 - (flet ((%f (len) - (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-escape* nil) - (*print-right-margin* 100) - (*print-readably* nil) - (*print-length* len)) - (with-output-to-string - (os) - (pprint-logical-block - (os '(1 2 . 3) :prefix "{" :suffix "}") - (pprint-exit-if-list-exhausted) - (write (pprint-pop) :stream os) - (loop (pprint-exit-if-list-exhausted) - (write #\Space :stream os) - (write (pprint-pop) :stream os)))))))) - (values (%f 0) (%f 1) (%f 2) (%f 3) (%f 4))) - "{...}" - "{1 ...}" - "{1 2 . 3}" - "{1 2 . 3}" - "{1 2 . 3}") - -;;; pprint-pop and circularity/sharing - -(deftest pprint-pop.7 - (flet ((%f (len) - (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-escape* nil) - (*print-right-margin* 100) - (*print-readably* nil) - (*print-length* len) - (*print-circle* t)) - (with-output-to-string - (os) - (let* ((tail (list 1)) - (x (list* tail 2 tail))) - (pprint-logical-block - (os x :prefix "<" :suffix ">") - (pprint-exit-if-list-exhausted) - (write (pprint-pop) :stream os) - (loop (pprint-exit-if-list-exhausted) - (write #\Space :stream os) - (write (pprint-pop) :stream os))))))))) - (values (%f nil) (%f 0) (%f 1) (%f 2) (%f 3) (%f 4))) - "<#1=(1) 2 . #1#>" - "<...>" - "<(1) ...>" - "<(1) 2 ...>" - "<#1=(1) 2 . #1#>" - "<#1=(1) 2 . #1#>") - -(deftest pprint-pop.8 - (flet ((%f (len) - (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-escape* nil) - (*print-right-margin* 100) - (*print-readably* nil) - (*print-length* len) - (*print-circle* t)) - (with-output-to-string - (os) - (let* ((tail (list 2)) - (x (list* 1 tail))) - (setf (cdr tail) tail) - (pprint-logical-block - (os x :prefix "[[" :suffix "]]") - (pprint-exit-if-list-exhausted) - (write (pprint-pop) :stream os) - (loop (pprint-exit-if-list-exhausted) - (write #\Space :stream os) - (write (pprint-pop) :stream os))))))))) - (values (%f 0) (%f 1) (%f 2) (%f 3) (%f 10) (%f 20))) - "[[...]]" - "[[1 ...]]" - "[[1 2 ...]]" - "[[1 . #1=(2 . #1#)]]" - "[[1 . #1=(2 . #1#)]]" - "[[1 . #1=(2 . #1#)]]") - -;;; pprint-pop when pprint-logical-block is given NIL - -(deftest pprint-pop.9 - (flet ((%f (len) - (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-escape* nil) - (*print-right-margin* 100) - (*print-readably* nil) - (*print-length* len)) - (with-output-to-string - (os) - (pprint-logical-block - (os nil :prefix "{" :suffix "}") - (let ((vals (multiple-value-list (pprint-pop)))) - (assert (equal vals '(nil)) () "First call returned ~A" vals)) - (write 1 :stream os) - (write #\Space :stream os) - (let ((vals (multiple-value-list (pprint-pop)))) - (assert (equal vals '(nil)) () "Second call returned ~A" vals)) - (write 2 :stream os) - (write #\Space :stream os) - (let ((vals (multiple-value-list (pprint-pop)))) - (assert (equal vals '(nil)) () "Third call returned ~A" vals)) - (write 3 :stream os) - )))))) - (values (%f nil) (%f 0) (%f 1) (%f 2) (%f 3) (%f 4))) - "{1 2 3}" - "{...}" - "{1 ...}" - "{1 2 ...}" - "{1 2 3}" - "{1 2 3}") - -;;; Error cases - -(deftest pprint-exit-if-list-exhausted.error.1 - (signals-error (pprint-exit-if-list-exhausted) error) - t) - -(deftest pprint-exit-if-list-exhausted.error.1-unsafe - (locally (declare (optimize (safety 0))) - (signals-error (locally (declare (optimize (safety 0))) - (pprint-exit-if-list-exhausted)) - error)) - t) - -(deftest pprint-pop.error.1 - (signals-error (pprint-pop) error) - t) - - -(deftest pprint-pop.error.1-unsafe - (locally (declare (optimize (safety 0))) - (signals-error (locally (declare (optimize (safety 0))) (pprint-pop)) error)) - t) diff --git a/t/ansi-test/printer/pprint-fill.lsp b/t/ansi-test/printer/pprint-fill.lsp deleted file mode 100644 index 3716a46..0000000 --- a/t/ansi-test/printer/pprint-fill.lsp +++ /dev/null @@ -1,173 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Jun 25 22:03:01 2004 -;;;; Contains: Tests of PPRINT-FILL - -(in-package :cl-test) - -;;; When printing a non-list, the result is the same as calling WRITE." -(deftest pprint-fill.1 - (my-with-standard-io-syntax - (let ((*print-pretty* t) - (*print-readably* nil)) - (loop for obj in *mini-universe* - nconc - (and (not (listp obj)) - (let ((s1 (write-to-string obj)) - (s2 (with-output-to-string (s) (pprint-fill s obj)))) - (unless (equal s1 s2) - (list (list obj s1 s2)))))))) - nil) - -(deftest pprint-fill.2 - (my-with-standard-io-syntax - (let ((*print-pretty* nil) - (*print-readably* nil)) - (loop for obj in *mini-universe* - nconc - (and (not (listp obj)) - (let ((s1 (write-to-string obj)) - (s2 (with-output-to-string (s) (pprint-fill s obj)))) - (unless (equal s1 s2) - (list (list obj s1 s2)))))))) - nil) - -(defmacro def-pprint-fill-test (name args expected-value &key (margin 100) (circle nil) (len nil)) - `(deftest ,name - (my-with-standard-io-syntax - (let ((*print-pretty* t) - (*print-readably* nil) - (*print-right-margin* ,margin) - (*package* (find-package "CL-TEST")) - (*print-length* ,len) - (*print-circle* ,circle)) - (with-output-to-string (s) (pprint-fill s ,@args)))) - ,expected-value)) - -(def-pprint-fill-test pprint-fill.3 ('(|A|)) "(A)") -(def-pprint-fill-test pprint-fill.4 ('(|A|) t) "(A)") -(def-pprint-fill-test pprint-fill.5 ('(|A|) nil) "A") -(def-pprint-fill-test pprint-fill.6 ('(1 2 3 4 5)) "(1 2 3 4 5)") -(def-pprint-fill-test pprint-fill.7 ('((1) (2) #(3) "abc" 5) nil) "(1) (2) #(3) \"abc\" 5") - -;;; The fourth argument is ignored -(def-pprint-fill-test pprint-fill.8 ('(1 2 3 4 5) t nil) "(1 2 3 4 5)") -(def-pprint-fill-test pprint-fill.9 ('(1 2 3 4 5) nil t) "1 2 3 4 5") - -;;; Takes T, NIL as stream designators - -(deftest pprint-fill.10 - (my-with-standard-io-syntax - (let ((*print-pretty* nil) - (*print-readably* nil) - (*print-right-margin* 100)) - (with-output-to-string - (os) - (with-input-from-string - (is "") - (with-open-stream (*terminal-io* (make-two-way-stream is os)) - (pprint-fill t '(1 2 3))))))) - "(1 2 3)") - -(deftest pprint-fill.11 - (my-with-standard-io-syntax - (let ((*print-pretty* t) - (*print-readably* nil) - (*print-right-margin* 100)) - (with-output-to-string (*standard-output*) (pprint-fill nil '(1 2 3))))) - "(1 2 3)") - - -;;; Now tests for cases that should be wrapped -;;; It's not entirely clear what they should be doing -;;; but check for some obvious properties - -(deftest pprint-fill.12 - (my-with-standard-io-syntax - (let ((*print-pretty* t) - (*print-readably* nil) - (*package* (find-package :cl-test)) - (obj '(|M| |M| |M| |M| |M| |M| |M| |M| |M| |M|))) - (loop for i from 1 to 10 - for result = - (let* ((*print-right-margin* i) - (s (with-output-to-string (os) - (terpri os) - (pprint-fill os obj)))) - (cond - ((not (eql (elt s 0) #\Newline)) - (list :bad1 s)) - ((not (equal (read-from-string s) obj)) - (list :bad2 s)) - ((not (find #\Newline s :start 1)) - (list :bad3 s)) - (t t))) - unless (eql result t) - collect (list i result)))) - nil) - - -(deftest pprint-fill.13 - (my-with-standard-io-syntax - (let ((*print-pretty* t) - (*print-readably* nil) - (*package* (find-package :cl-test)) - (obj '(|M| |M| |M| |M| |M| |M| |M| |M| |M| |M| |M|))) - (loop for i from 1 to 10 - for result = - (let* ((*print-right-margin* i) - (s (with-output-to-string (os) - (terpri os) - (pprint-fill os obj nil)))) - (cond - ((not (eql (elt s 0) #\Newline)) - (list :bad1 s)) - ((not (equal (read-from-string (concatenate 'string "(" s ")")) - obj)) - (list :bad2 s)) - ((not (find #\Newline s :start 1)) - (list :bad3 s)) - (t t))) - unless (eql result t) - collect (list i result)))) - nil) - -;;; -(def-pprint-fill-test pprint-fill.14 ((let ((x (list '|A|))) (list x x))) - "(#1=(A) #1#)" :circle t) - -(def-pprint-fill-test pprint-fill.15 ((let ((x (list '|A|))) (setf (cdr x) x) x)) - "#1=(A . #1#)" :circle t :len 500) - - -;;; Test that pprint-fill returns NIL - -(deftest pprint-fill.return-values.1 - (my-with-standard-io-syntax - (let ((*print-pretty* nil) - (*package* (find-package "CL-TEST"))) - (with-open-stream (s (make-broadcast-stream)) - (pprint-fill s '(a b))))) - nil) - -(deftest pprint-fill.return-values.2 - (my-with-standard-io-syntax - (let ((*print-pretty* nil) - (*package* (find-package :cl-test))) - (with-open-stream (s (make-broadcast-stream)) - (pprint-fill s 10 nil t)))) - nil) - -;;; Error tests - -(deftest pprint-fill.error.1 - (signals-error (pprint-fill) program-error) - t) - -(deftest pprint-fill.error.2 - (signals-error (pprint-fill *standard-output*) program-error) - t) - -(deftest pprint-fill.error.3 - (signals-error (pprint-fill *standard-output* nil t t t) program-error) - t) diff --git a/t/ansi-test/printer/pprint-indent.lsp b/t/ansi-test/printer/pprint-indent.lsp deleted file mode 100644 index 1f7e21d..0000000 --- a/t/ansi-test/printer/pprint-indent.lsp +++ /dev/null @@ -1,415 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Jul 3 08:50:40 2004 -;;;; Contains: Tests of PPRINT-INDENT - -(in-package :cl-test) - -(deftest pprint-indent.1 - (with-standard-io-syntax - (let ((*print-pretty* nil)) - (with-open-stream (*standard-output* (make-string-output-stream)) - (pprint-indent :block 0)))) - nil) - -(deftest pprint-indent.2 - (with-standard-io-syntax - (let ((*print-pretty* nil)) - (with-open-stream (*standard-output* (make-broadcast-stream)) - (pprint-indent :current 0)))) - nil) - -(deftest pprint-indent.3 - (with-standard-io-syntax - (let ((*print-pretty* nil)) - (with-open-stream (s (make-string-output-stream)) - (pprint-indent :current 10 s)))) - nil) - -(deftest pprint-indent.4 - (with-standard-io-syntax - (let ((*print-pretty* nil)) - (with-open-stream (s (make-string-output-stream)) - (pprint-indent :block 1/2 s)))) - nil) - -(deftest pprint-indent.5 - (with-standard-io-syntax - (let ((*print-pretty* nil)) - (with-open-stream (s (make-string-output-stream)) - (pprint-indent :block 0.1 s)))) - nil) - -(deftest pprint-indent.6 - (with-standard-io-syntax - (let ((*print-pretty* nil)) - (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) - unless - (equal - (multiple-value-list - (with-open-stream (s (make-string-output-stream)) - (pprint-indent :block x s))) - '(nil)) - collect x))) - nil) - -(deftest pprint-indent.7 - (with-standard-io-syntax - (let ((*print-pretty* nil)) - (with-open-stream (*standard-output* (make-broadcast-stream)) - (pprint-indent :current 0 nil)))) - nil) - -(deftest pprint-indent.8 - (with-standard-io-syntax - (let ((*print-pretty* nil)) - (with-open-stream - (os (make-string-output-stream)) - (with-open-stream - (is (make-string-input-stream "")) - (with-open-stream (*terminal-io* (make-two-way-stream is os)) - (pprint-indent :current 0 t)))))) - nil) - -;;; Now test with pprint-logical-block - -;;; :current - -(deftest pprint-indent.9 - (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-readably* nil) - (*print-right-margin* 100) - (*print-escape* nil)) - (with-output-to-string - (os) - (pprint-logical-block - (os '(|M| |M|)) - (write '|M| :stream os) - (pprint-indent :current 3 os) - (pprint-newline :mandatory os) - (write '|M| :stream os))))) - "M - M") - -(deftest pprint-indent.10 - (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-readably* nil) - (*print-right-margin* 100) - (*print-escape* nil)) - (with-output-to-string - (os) - (pprint-logical-block - (os '(|M| |M|) :prefix "(" :suffix ")") - (write '|M| :stream os) - (pprint-indent :current 1 os) - (pprint-newline :mandatory os) - (write '|M| :stream os))))) - "(M - M)") - -(deftest pprint-indent.11 - (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-readably* nil) - (*print-right-margin* 100) - (*print-escape* nil)) - (with-output-to-string - (os) - (pprint-logical-block - (os '(|M| |M|) :prefix "(" :suffix ")") - (write '|M| :stream os) - (pprint-indent :current -1 os) - (pprint-newline :mandatory os) - (write '|M| :stream os))))) - "(M - M)") - -(deftest pprint-indent.12 - (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-readably* nil) - (*print-right-margin* 100) - (*print-escape* nil)) - (with-output-to-string - (os) - (pprint-logical-block - (os '(|M| |M|) :prefix "(" :suffix ")") - (write '|M| :stream os) - (pprint-indent :current -2.0 os) - (pprint-newline :mandatory os) - (write '|M| :stream os))))) - "(M -M)") - -;;; :block - -(deftest pprint-indent.13 - (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-readably* nil) - (*print-right-margin* 100) - (*print-escape* nil)) - (with-output-to-string - (os) - (pprint-logical-block - (os '(|M| |M|)) - (write '|MMM| :stream os) - (pprint-indent :block 0 os) - (pprint-newline :mandatory os) - (write '|MMMMM| :stream os))))) - "MMM -MMMMM") - -(deftest pprint-indent.13a - (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-readably* nil) - (*print-right-margin* 100) - (*print-escape* nil)) - (with-output-to-string - (os) - (pprint-logical-block - (os '(|M| |M|) :prefix "(" :suffix ")") - (write '|MMM| :stream os) - (pprint-indent :block 0 os) - (pprint-newline :mandatory os) - (write '|MMMMM| :stream os))))) - "(MMM - MMMMM)") - -(deftest pprint-indent.14 - (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-readably* nil) - (*print-right-margin* 100) - (*print-escape* nil)) - (with-output-to-string - (os) - (pprint-logical-block - (os '(|M| |M|)) - (write '|MMM| :stream os) - (pprint-indent :block 1 os) - (pprint-newline :mandatory os) - (write '|MMMMM| :stream os))))) - "MMM - MMMMM") - -(deftest pprint-indent.15 - (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-readably* nil) - (*print-right-margin* 100) - (*print-escape* nil)) - (with-output-to-string - (os) - (pprint-logical-block - (os '(|M| |M|)) - (write '|MMM| :stream os) - (pprint-indent :block -1 os) - (pprint-newline :mandatory os) - (write '|MMMMM| :stream os))))) - "MMM -MMMMM") - -(deftest pprint-indent.16 - (loop for n in '(3.0s0 3.0f0 3.0d0 3.0l0) - unless (string= - (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-readably* nil) - (*print-right-margin* 100) - (*print-escape* nil)) - (with-output-to-string - (os) - (pprint-logical-block - (os '(|M| |M|)) - (write '|MMM| :stream os) - (pprint-indent :block n os) - (pprint-newline :mandatory os) - (write '|MMMMM| :stream os))))) - "MMM - MMMMM") - collect n) - nil) - -;;; *print-pretty* must be true for pprint-indent to have an effect - -(deftest pprint-indent.17 - (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-readably* nil) - (*print-right-margin* 100) - (*print-escape* nil)) - (with-output-to-string - (os) - (pprint-logical-block - (os '(|M| |M|)) - (write '|M| :stream os) - (let ((*print-pretty* nil)) (pprint-indent :current 3 os)) - (pprint-newline :mandatory os) - (write '|M| :stream os))))) - "M -M") - -(deftest pprint-indent.18 - (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-readably* nil) - (*print-right-margin* 100) - (*print-escape* nil)) - (with-output-to-string - (os) - (pprint-logical-block - (os '(|M| |M|)) - (write '|M| :stream os) - (let ((*print-pretty* nil)) (pprint-indent :block 3 os)) - (pprint-newline :mandatory os) - (write '|M| :stream os))))) - "M -M") - -;;; indentation interaction with :per-line-prefix - -(deftest pprint-indent.19 - (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-readably* nil) - (*print-right-margin* 100) - (*print-escape* nil)) - (with-output-to-string - (os) - (pprint-logical-block - (os '(|M| |M| |M|) :per-line-prefix ">>>>") - (write '|M| :stream os) - (pprint-indent :block 2 os) - (write #\Space :stream os) - (write '|M| :stream os) - (pprint-newline :mandatory os) - (write '|M| :stream os))))) - ">>>>M M ->>>> M") - -(deftest pprint-indent.20 - (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-readably* nil) - (*print-right-margin* 100) - (*print-escape* nil)) - (with-output-to-string - (os) - (pprint-logical-block - (os '(|M| |M|) :per-line-prefix ">>>>") - (write '|M| :stream os) - (pprint-indent :block -1 os) - (pprint-newline :mandatory os) - (write '|M| :stream os))))) - ">>>>M ->>>>M") - -(deftest pprint-indent.21 - (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-readably* nil) - (*print-right-margin* 100) - (*print-escape* nil)) - (with-output-to-string - (os) - (pprint-logical-block - (os '(|M| |M| |M| |M|) :per-line-prefix ">>>>") - (write '|M| :stream os) - (pprint-indent :block 3 os) - (pprint-newline :mandatory os) - (write '|M| :stream os) - (pprint-indent :current -2 os) - (pprint-newline :mandatory os) - (write '|M| :stream os) - (pprint-indent :current -5 os) - (pprint-newline :mandatory os) - (write '|M| :stream os) - )))) - - ">>>>M ->>>> M ->>>> M ->>>>M") - -;;; In miser mode, indentation is ignored - -(deftest pprint-indent.22 - (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-readably* nil) - (*print-right-margin* 100) - (*print-miser-width* 200) - (*print-escape* nil)) - (with-output-to-string - (os) - (pprint-logical-block - (os '(1 2 3) :prefix "(" :suffix ")") - (write 1 :stream os) - (pprint-indent :current 1 os) - (pprint-newline :mandatory os) - (write 2 :stream os) - (pprint-indent :block 3 os) - (pprint-newline :mandatory os) - (write 3 :stream os))))) - "(1 - 2 - 3)") - -;;; TERPRI or printing newline characters does not invoke indentation - -(deftest pprint-indent.23 - (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-readably* nil) - (*print-right-margin* 100) - (*print-escape* nil)) - (with-output-to-string - (os) - (pprint-logical-block - (os '(1 2 3 4)) - (pprint-indent :block 2 os) - (write 1 :stream os) - (terpri os) - (write 2 :stream os) - (write #\Newline :stream os) - (write 3 :stream os) - (pprint-newline :mandatory os) - (write 4 :stream os))))) - "1 -2 -3 - 4") - -;;; Error cases - -(deftest pprint-indent.error.1 - (signals-error (pprint-indent) program-error) - t) - -(deftest pprint-indent.error.2 - (signals-error (pprint-indent :current) program-error) - t) - -(deftest pprint-indent.error.3 - (signals-error (pprint-indent :block 0 *standard-output* nil) program-error) - t) - -(deftest pprint-indent.error.4 - (loop for x in *mini-universe* - when (and (not (member x '(:block :current))) - (not (eval `(signals-error (pprint-indent ',x 0) error)))) - collect x) - nil) - -(deftest pprint-indent.error.4-unsafe - (loop for x in *mini-universe* - when (and (not (member x '(:block :current))) - (not (eval `(signals-error (locally (declare (optimize (safety 0))) (pprint-indent ',x 0)) - error)))) - collect x) - nil) - diff --git a/t/ansi-test/printer/pprint-linear.lsp b/t/ansi-test/printer/pprint-linear.lsp deleted file mode 100644 index ab4c135..0000000 --- a/t/ansi-test/printer/pprint-linear.lsp +++ /dev/null @@ -1,150 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Jun 26 21:55:26 2004 -;;;; Contains: Tests of PPRINT-LINEAR - -(in-package :cl-test) - -;;; When printing a non-list, the result is the same as calling WRITE." -(deftest pprint-linear.1 - (my-with-standard-io-syntax - (let ((*print-pretty* t) - (*print-readably* nil)) - (loop for obj in *mini-universe* - nconc - (and (not (listp obj)) - (let ((s1 (write-to-string obj)) - (s2 (with-output-to-string (s) (assert (equal (multiple-value-list - (pprint-linear s obj)) - '(nil)))))) - (unless (equal s1 s2) - (list (list obj s1 s2)))))))) - nil) - -(deftest pprint-linear.2 - (my-with-standard-io-syntax - (let ((*print-pretty* nil) - (*print-readably* nil)) - (loop for obj in *mini-universe* - nconc - (and (not (listp obj)) - (let ((s1 (write-to-string obj)) - (s2 (with-output-to-string (s) (assert (equal (multiple-value-list - (pprint-linear s obj)) - '(nil)))))) - (unless (equal s1 s2) - (list (list obj s1 s2)))))))) - nil) - -(defmacro def-pprint-linear-test (name args expected-value &key (margin 100) (circle nil)) - `(deftest ,name - (my-with-standard-io-syntax - (let ((*print-pretty* t) - (*print-readably* nil) - (*print-right-margin* ,margin) - (*package* (find-package "CL-TEST")) - (*print-circle* ,circle)) - (with-output-to-string - (s) - (pprint-linear s ,@args)))) - ,expected-value)) - -(def-pprint-linear-test pprint-linear.3 ('(|A|)) "(A)") -(def-pprint-linear-test pprint-linear.4 ('(|A|) t) "(A)") -(def-pprint-linear-test pprint-linear.5 ('(|A|) nil) "A") -(def-pprint-linear-test pprint-linear.6 ('(1 2 3 4 5)) "(1 2 3 4 5)") -(def-pprint-linear-test pprint-linear.7 ('((1) (2) #(3) "abc" 5) nil) "(1) (2) #(3) \"abc\" 5") - -;;; The fourth argument is ignored -(def-pprint-linear-test pprint-linear.8 ('(1 2 3 4 5) t nil) "(1 2 3 4 5)") -(def-pprint-linear-test pprint-linear.9 ('(1 2 3 4 5) nil t) "1 2 3 4 5") - -;;; Takes T, NIL as stream designators - -(deftest pprint-linear.10 - (my-with-standard-io-syntax - (let ((*print-pretty* nil) - (*print-readably* nil) - (*print-right-margin* 100)) - (with-output-to-string - (os) - (with-input-from-string - (is "") - (with-open-stream (*terminal-io* (make-two-way-stream is os)) - (pprint-linear t '(1 2 3))))))) - "(1 2 3)") - -(deftest pprint-linear.11 - (my-with-standard-io-syntax - (let ((*print-pretty* t) - (*print-readably* nil) - (*print-right-margin* 100)) - (with-output-to-string (*standard-output*) (pprint-linear nil '(1 2 3))))) - "(1 2 3)") - -(deftest pprint-linear.12 - (my-with-standard-io-syntax - (let ((*print-pretty* t) - (*print-readably* nil) - (*package* (find-package :cl-test)) - (obj '(|M| |M| |M| |M| |M| |M| |M| |M| |M| |M|))) - (loop for i from 1 to 10 - for result = - (let* ((*print-right-margin* i) - (s (with-output-to-string (os) - (terpri os) - (pprint-linear os obj)))) - (cond - ((not (eql (elt s 0) #\Newline)) - (list :bad1 s)) - ((not (equal (read-from-string s) obj)) - (list :bad2 s)) - ((< (count #\Newline s) (length obj)) - (list :bad3 s)) - (t t))) - unless (eql result t) - collect (list i result)))) - nil) - -(deftest pprint-linear.13 - (my-with-standard-io-syntax - (let ((*print-pretty* t) - (*print-readably* nil) - (*package* (find-package :cl-test)) - (obj '(|M| |M| |M| |M| |M| |M| |M| |M| |M| |M| |M|))) - (loop for i from 1 to 10 - for result = - (let* ((*print-right-margin* i) - (s (with-output-to-string (os) - (terpri os) - (pprint-linear os obj nil)))) - (cond - ((not (eql (elt s 0) #\Newline)) - (list :bad1 s)) - ((not (equal (read-from-string (concatenate 'string "(" s ")")) - obj)) - (list :bad2 s)) - ((< (count #\Newline s) (length obj)) - (list :bad3 s)) - (t t))) - unless (eql result t) - collect (list i result)))) - nil) - -;;; -(def-pprint-linear-test pprint-linear.14 ((let ((x (list '|A|))) (list x x))) - "(#1=(A) #1#)" :circle t) - -;;; Error tests - -(deftest pprint-linear.error.1 - (signals-error (pprint-linear) program-error) - t) - -(deftest pprint-linear.error.2 - (signals-error (pprint-linear *standard-output*) program-error) - t) - -(deftest pprint-linear.error.3 - (signals-error (pprint-linear *standard-output* nil t t t) program-error) - t) diff --git a/t/ansi-test/printer/pprint-logical-block.lsp b/t/ansi-test/printer/pprint-logical-block.lsp deleted file mode 100644 index 4b4963c..0000000 --- a/t/ansi-test/printer/pprint-logical-block.lsp +++ /dev/null @@ -1,314 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jul 4 07:17:52 2004 -;;;; Contains: Tests of PPRINT-LOGICAL-BLOCK - -(in-package :cl-test) - -(deftest pprint-logical-block.1 - (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-right-margin* 100) - (*print-readably* nil)) - (with-open-stream - (os (make-string-output-stream)) - (values - (multiple-value-list (pprint-logical-block (os 1))) - (get-output-stream-string os))))) - (nil) "1") - -(deftest pprint-logical-block.2 - (with-standard-io-syntax - (let ((*print-pretty* nil) - (*print-right-margin* 100) - (*print-readably* nil) - (val '(1 a (b) (c . d) 1.0s0 2.0f0 -3.0d0 4.0l0 1/2 #(x y z)))) - (string=t (with-output-to-string (s) (write val :stream s)) - (with-output-to-string (s) (pprint-logical-block (s val) (write val :stream s)))))) - t) - -(deftest pprint-logical-block.3 - (with-standard-io-syntax - (let ((*print-pretty* nil) - (*print-right-margin* 100) - (*print-readably* nil)) - (with-output-to-string - (*standard-output*) - (pprint-logical-block (nil 1))))) - "1") - -(deftest pprint-logical-block.4 - (with-standard-io-syntax - (let ((*print-pretty* nil) - (*print-right-margin* 100) - (*print-readably* nil)) - (with-output-to-string - (os) - (with-input-from-string - (is "") - (with-open-stream (*terminal-io* (make-two-way-stream is os)) - (pprint-logical-block (t 1))))))) - "1") - -(deftest pprint-logical-block.5 - (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-right-margin* 100) - (*print-readably* nil) - (val '(1))) - (with-output-to-string - (os) - (pprint-logical-block - (os val) - (write (car val) :stream os))))) - "1") - -(deftest pprint-logical-block.6 - (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-right-margin* 100) - (*print-readably* nil) - (val '(2))) - (with-output-to-string - (os) - (pprint-logical-block - (os val :prefix "[" :suffix "]") - (write (car val) :stream os))))) - "[2]") - -(deftest pprint-logical-block.7 - :notes (:nil-vectors-are-strings) - (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-right-margin* 100) - (*print-readably* nil) - (val '(3))) - (with-output-to-string - (os) - (pprint-logical-block - (os val - :prefix (make-array '(0) :element-type nil) - :suffix (make-array '(0) :element-type nil)) - (write (car val) :stream os))))) - "3") - -(deftest pprint-logical-block.8 - (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-right-margin* 100) - (*print-readably* nil) - (val '(4))) - (with-output-to-string - (os) - (pprint-logical-block - (os val - :prefix (make-array '(10) :element-type 'character - :initial-contents "abcdefghij" - :fill-pointer 3) - :suffix (make-array '(2) :element-type 'base-char - :initial-contents "!?" - :adjustable t)) - (write (car val) :stream os))))) - "abc4!?") - -(deftest pprint-logical-block.9 - (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-right-margin* 100) - (*print-readably* nil) - (*print-level* 1) - (val '((4)))) - (with-output-to-string - (os) - (pprint-logical-block - (os val :prefix "{" :suffix "}") - (pprint-logical-block - (os (car val) :prefix "[" :suffix "]") - (write (caar val) :stream os)))))) - "{#}") - -(deftest pprint-logical-block.10 - (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-right-margin* 100) - (*print-readably* nil) - (*print-level* 0) - (val '(5))) - (with-output-to-string - (os) - (pprint-logical-block - (os val :prefix "[" :suffix "]") - (write (car val) :stream os))))) - "#") - -(deftest pprint-logical-block.11 - (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-right-margin* 100) - (*print-readably* nil) - (val '(6))) - (with-output-to-string - (os) - (pprint-logical-block - (os val :per-line-prefix "abcd") - (write (car val) :stream os))))) - "abcd6") - -(deftest pprint-logical-block.12 - (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-right-margin* 100) - (*print-readably* nil) - (val '(a b c))) - (with-output-to-string - (os) - (pprint-logical-block - (os val :per-line-prefix "abcd") - (write 1 :stream os) - (terpri os) - (terpri os) - (write 2 :stream os) - (terpri os) - (write 3 :stream os))))) - - "abcd1 -abcd -abcd2 -abcd3") - -;;; Same as pprint-logical-block.10, but *print-pretty* is bound to nil -(deftest pprint-logical-block.13 - (with-standard-io-syntax - (let ((*print-pretty* nil) - (*print-right-margin* 100) - (*print-readably* nil) - (*print-level* 0) - (val '(5))) - (with-output-to-string - (os) - (pprint-logical-block - (os val :prefix "[" :suffix "]") - (write (car val) :stream os))))) - "#") - -;;; Both :suffix and :per-line-prefix may be supplied -(deftest pprint-logical-block.14 - (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-right-margin* 100) - (*print-readably* nil) - (val '(6))) - (with-output-to-string - (os) - (pprint-logical-block (os val :per-line-prefix "[" :suffix "]") - (write (car val) :stream os))))) - "[6]") - -;;; Declarations are allowed - -(deftest pprint-logical-block.15 - (with-standard-io-syntax - (let ((*print-pretty* t) - (x 0)) - (with-output-to-string - (os) - (declare (integer x)) - (declare (optimize (safety 3)))))) - "") - -;;; Two conditions that cause :prefix, :suffix to be omitted - -(deftest pprint-logical-block.16 - (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-right-margin* 100) - (*print-readably* nil) - (val 9)) - (with-output-to-string - (os) - (pprint-logical-block (os val :prefix "[" :suffix "]") - (write val :stream os))))) - "9") - -(deftest pprint-logical-block.17 - (with-standard-io-syntax - (let* ((*print-pretty* t) - (*print-right-margin* 100) - (*print-readably* nil) - (*print-circle* t) - (v1 '(8)) - (val (list v1 v1))) - (with-output-to-string - (os) - (pprint-logical-block - (os val :prefix "(" :suffix ")") - (pprint-logical-block (os (car val) :prefix "(" :suffix ")") - (write (caar val) :stream os)) - (write-char #\Space os) - (pprint-logical-block (os (cadr val) :prefix "(" :suffix ")") - (write (caadr val) :stream os)))))) - "(#1=(8) #1#)") - -;;; Error cases - -(deftest pprint-logical-block.error.1 - (check-type-error #'(lambda (x) - (pprint-logical-block (*standard-output* '(1) :prefix x))) - #'stringp) - nil) - -(deftest pprint-logical-block.error.1-unsafe - (check-type-error #'(lambda (x) - (declare (optimize (safety 0))) - (pprint-logical-block (*standard-output* '(1) :prefix x))) - #'stringp) - nil) - -(deftest pprint-logical-block.error.2 - (check-type-error #'(lambda (x) - (pprint-logical-block (*standard-output* '(1) :suffix x))) - #'stringp) - nil) - -(deftest pprint-logical-block.error.2-unsafe - (check-type-error #'(lambda (x) - (declare (optimize (safety 0))) - (pprint-logical-block (*standard-output* '(1) :suffix x))) - #'stringp) - nil) - -(deftest pprint-logical-block.error.3 - (check-type-error #'(lambda (x) - (pprint-logical-block (*standard-output* '(1) :per-line-prefix x))) - #'stringp) - nil) - -(deftest pprint-logical-block.error.3-unsafe - (check-type-error #'(lambda (x) - (declare (optimize (safety 0))) - (pprint-logical-block (*standard-output* '(1) :per-line-prefix x))) - #'stringp) - nil) - -(deftest pprint-logical-block.error.4 - (signals-error (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-right-margin* 100) - (*print-readably* nil) - (val '(7))) - (pprint-logical-block (os val :prefix "" :per-line-prefix "") - (write (car val) :stream os)))) - error) - t) - -(deftest pprint-logical-block.error.4-unsafe - (signals-error (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-right-margin* 100) - (*print-readably* nil) - (val '(7))) - (pprint-logical-block (os val :prefix "" :per-line-prefix "") - (write (car val) :stream os)))) - error - :safety 0) - t) diff --git a/t/ansi-test/printer/pprint-newline.lsp b/t/ansi-test/printer/pprint-newline.lsp deleted file mode 100644 index bc77f2b..0000000 --- a/t/ansi-test/printer/pprint-newline.lsp +++ /dev/null @@ -1,471 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Jul 7 07:48:01 2004 -;;;; Contains: Tests of PPRINT-NEWLINE - -(in-package :cl-test) - - - -(defmacro def-pprint-newline-test (name form expected-value &rest key-args) - `(def-pprint-test ,name - (with-output-to-string - (*standard-output*) - (pprint-logical-block (*standard-output* nil) ,form)) - ,expected-value - ,@key-args)) - -;;; NIL designates the standard output - -(def-pprint-test pprint-newline.1 - (with-output-to-string - (*standard-output*) - (pprint-logical-block - (*standard-output* nil) - (dotimes (i 8) - (write-char #\A) - (write-char #\Space) - (pprint-newline :fill nil)))) - "A A A A A -A A A " - :margin 10) - -;;; T designates the stream *terminal-io* -(def-pprint-test pprint-newline.2 - (with-output-to-string - (os) - (with-input-from-string - (is "") - (with-open-stream - (*terminal-io* (make-two-way-stream is os)) - (pprint-logical-block - (*terminal-io* nil) - (dotimes (i 8) - (write "A " :stream t) - (pprint-newline :fill t)))))) - "A A A A A -A A A " - :margin 10) - -;;; No stream is standard output - -(def-pprint-test pprint-newline.3 - (with-output-to-string - (*standard-output*) - (pprint-logical-block - (*standard-output* nil) - (dotimes (i 8) - (write-char #\A) - (write-char #\Space) - (pprint-newline :fill)))) - "A A A A A -A A A " - :margin 10) - -;;; :linear - -(def-ppblock-test pprint-newline.linear.1 - (progn - (dotimes (i 2) (write "A ") (pprint-newline :fill)) - (write "B ") (pprint-newline :linear) - (dotimes (i 3) (write "A ") (pprint-newline :fill))) - "A A B -A A A " - :margin 10) - -(def-ppblock-test pprint-newline.linear.2 - (progn - (dotimes (i 2) (write "A ") (pprint-newline :fill)) - (write "B ") (pprint-newline :linear) - (dotimes (i 2) (write "C ") (pprint-newline :fill)) - (write "D ") (pprint-newline :linear) - (dotimes (i 3) (write "A ") (pprint-newline :fill))) - "A A B -C C D -A A A " - :margin 10) - -(def-ppblock-test pprint-newline.linear.3 - (dotimes (i 4) (write "A ") (pprint-newline :linear)) - "A A A A " - :margin 10) - -(def-ppblock-test pprint-newline.linear.4 - (dotimes (i 4) (write "A ") (pprint-newline :linear)) - "A A A A " - :margin 10 - :miser 10) - -(def-ppblock-test pprint-newline.linear.5 - (dotimes (i 10) (write "A ") (pprint-newline :linear)) - "A A A A A A A A A A " - :margin 10 - :pretty nil) - -(def-ppblock-test pprint-newline.linear.6 - (dotimes (i 4) (write "A ") (pprint-newline :linear)) - "A -A -A -A -" - :margin 10) - -(def-ppblock-test pprint-newline.linear.7 - (progn - (dotimes (i 4) (write "A ") (pprint-newline :linear)) - (terpri) - (dotimes (i 4) (write "A ") (pprint-newline :linear))) - "A -A -A -A - -A -A -A -A -" - :margin 10) - -(def-ppblock-test pprint-newline.linear.8 - (progn - (pprint-logical-block (*standard-output* nil) - (dotimes (i 4) - (write "A ") - (pprint-newline :linear))) - (pprint-newline :linear) - (pprint-logical-block (*standard-output* nil) - (dotimes (i 4) - (write "A ") - (pprint-newline :linear)))) - "A A A A -A A A A " - :margin 10) - -(def-ppblock-test pprint-newline.linear.9 - (dotimes (i 10) (write "A ") (let ((*print-pretty* nil)) (pprint-newline :linear))) - "A A A A A A A A A A " - :margin 10) - -(deftest pprint-newline.linear.10 - (with-standard-io-syntax - (let ((*print-readably* nil) - (*print-escape* nil) - (*print-pretty* t) - (*print-right-margin* 4) - (*print-miser-width* nil)) - (with-output-to-string - (*standard-output*) - (dotimes (i 5) (write "A ") (pprint-newline :linear))))) - "A A A A A ") - -;;; :miser - -(def-ppblock-test pprint-newline.miser.1 - (dotimes (i 10) (write "A ") (pprint-newline :miser)) - "A A A A A A A A A A " - :margin 10) - -(def-ppblock-test pprint-newline.miser.2 - (dotimes (i 10) (write "A ") (pprint-newline :miser)) - "A A A A A A A A A A " - :margin 10 - :miser 0) - -(def-ppblock-test pprint-newline.miser.3 - (dotimes (i 10) (write "A ") (pprint-newline :miser)) - "A A A A A A A A A A " - :margin 10 - :miser 9) - -(def-ppblock-test pprint-newline.miser.4 - (dotimes (i 10) (write "A ") (pprint-newline :miser)) - "A -A -A -A -A -A -A -A -A -A -" - :margin 10 - :miser 10) - -(def-ppblock-test pprint-newline.miser.5 - (dotimes (i 10) (write "A ") (pprint-newline :miser)) - "A A A A A A A A A A " - :margin 10 - :miser 10 - :pretty nil) - -(def-ppblock-test pprint-newline.miser.6 - (progn - (terpri) - (write "A") - (pprint-newline :miser)) - " -A -" - :margin 20 - :miser 20) - -(def-ppblock-test pprint-newline.miser.7 - (progn - (pprint-newline :miser) - (write "A") - (terpri)) - " -A -" - :margin 20 - :miser 20) - -(def-ppblock-test pprint-newline.miser.8 - (progn - (write "AAAA ") - (pprint-newline :linear) - (pprint-logical-block - (*standard-output* nil) - (dotimes (i 4) (write "A ") (pprint-newline :miser)))) - "AAAA -A A A A " - :margin 10 - :miser 8) - -(def-ppblock-test pprint-newline.miser.9 - (progn - (write "AAAA ") - (pprint-newline :fill) - (pprint-logical-block - (*standard-output* nil) - (dotimes (i 4) (write "A ") (pprint-newline :miser)))) - "AAAA -A A A A " - :margin 10 - :miser 8) - -(def-ppblock-test pprint-newline.miser.10 - (pprint-logical-block (*standard-output* nil :prefix "(" :suffix ")") - (write "A") - (pprint-newline :miser) - (pprint-newline :mandatory)) - "(A - - )" - :margin 20 - :miser 20) - -(def-ppblock-test pprint-newline.miser.11 - (pprint-logical-block (*standard-output* nil :prefix "(" :suffix ")") - (write "A") - (pprint-newline :miser) - (pprint-newline :mandatory)) - "(A - - )" - :margin 20 - :miser 19) - -(def-ppblock-test pprint-newline.miser.12 - (pprint-logical-block (*standard-output* nil :prefix "(" :suffix ")") - (write "A") - (pprint-newline :miser) - (pprint-newline :mandatory)) - "(A - )" - :margin 20 - :miser 18) - -(deftest pprint-newline.miser.13 - (with-standard-io-syntax - (let ((*print-readably* nil) - (*print-escape* nil) - (*print-pretty* t) - (*print-right-margin* 4) - (*print-miser-width* 4)) - (with-output-to-string - (*standard-output*) - (dotimes (i 5) (write "A ") (pprint-newline :miser))))) - "A A A A A ") - -;;; :fill - -(def-ppblock-test pprint-newline.fill.1 - (dotimes (i 10) (write "A ") (pprint-newline :fill)) - "A A A A A -A A A A A " - :margin 10) - -(def-ppblock-test pprint-newline.fill.2 - (dotimes (i 10) (write "A ") (pprint-newline :fill)) - "A A A -A A A -A A A -A " - :margin 6) - -(def-ppblock-test pprint-newline.fill.3 - (dotimes (i 10) (write "A ") (pprint-newline :fill)) - "A A A -A A A -A A A -A " - :margin 7) - -(def-ppblock-test pprint-newline.fill.4 - (dotimes (i 10) (write "A ") (pprint-newline :fill)) - "A A A A A -A A A A A " - :margin 10 - :miser 9) - -(def-ppblock-test pprint-newline.fill.5 - (dotimes (i 10) (write "A ") (pprint-newline :fill)) - "A -A -A -A -A -A -A -A -A -A -" - :margin 10 - :miser 10) - -(def-ppblock-test pprint-newline.fill.6 - (dotimes (i 5) - (write '(A B)) - (write #\Space) - (pprint-newline :fill)) - "(A B) (A B) -(A B) (A B) -(A B) " - :margin 12) - -(def-ppblock-test pprint-newline.fill.7 - (dolist (x '(A (A B) (A A A A A A A A) X (C D) (E F))) - (pprint-fill nil x) - (write #\Space) - (pprint-newline :fill)) - "A (A B) -(A A A A A - A A A) -X (C D) -(E F) " - :margin 12) - -(def-ppblock-test pprint-newline.fill.8 - (dotimes (i 5) - (write '(A B) :pretty nil) - (write #\Space) - (let ((*print-pretty* nil)) (pprint-newline :fill))) - "(A B) (A B) (A B) (A B) (A B) " - :margin 12) - -(deftest pprint-newline.fill.9 - (with-standard-io-syntax - (let ((*print-readably* nil) - (*print-escape* nil) - (*print-right-margin* 4) - (*print-pretty* t) - (*print-miser-width* nil)) - (with-output-to-string - (*standard-output*) - (dotimes (i 5) (write "A ") (pprint-newline :fill))))) - "A A A A A ") - -(deftest pprint-newline.fill.10 - (with-standard-io-syntax - (let ((*print-readably* nil) - (*print-escape* nil) - (*print-right-margin* 4) - (*print-pretty* t) - (*print-miser-width* 4)) - (with-output-to-string - (*standard-output*) - (dotimes (i 5) (write "A ") (pprint-newline :fill))))) - "A A A A A ") - - -;;; :mandatory - -(def-ppblock-test pprint-newline.mandatory.1 - (dotimes (i 4) (write "A ") (pprint-newline :mandatory)) - "A -A -A -A -") - -(def-ppblock-test pprint-newline.mandatory.2 - (dotimes (i 4) (write "A ") (pprint-newline :mandatory)) - "A -A -A -A -" - :margin 10) - -(def-ppblock-test pprint-newline.mandatory.3 - (progn - (write "A ") - (pprint-newline :mandatory) - (write "A ")) - "A -A " - :margin 1) - -(def-ppblock-test pprint-newline.mandatory.4 - (dotimes (i 4) (write "A ") (pprint-newline :mandatory)) - "A A A A " - :pretty nil) - -(def-ppblock-test pprint-newline.mandatory.5 - (pprint-logical-block - (*standard-output* nil :prefix "<<<" :suffix ">>>") - (dotimes (i 4) (write "A ") (pprint-newline :mandatory)) - (write "A")) - "<<>>") - -(deftest pprint-newline.mandatory.6 - (with-standard-io-syntax - (let ((*print-readably* nil) - (*print-escape* nil) - (*print-pretty* t) - (*print-right-margin* 4) - (*print-miser-width* nil)) - (with-output-to-string - (*standard-output*) - (dotimes (i 5) (write "A ") (pprint-newline :mandatory))))) - "A A A A A ") - -;;; Error cases - -(deftest pprint-newline.error.1 - (check-type-error #'pprint-newline - (typef '(member :linear :miser :fill :mandatory))) - nil) - -(deftest pprint-newline.error.1-unsafe - (check-type-error #'(lambda (x) (declare (optimize (safety 0))) (pprint-newline x)) - (typef '(member :linear :miser :fill :mandatory))) - nil) - -(deftest pprint-newline.error.2 - (signals-error (pprint-newline) program-error) - t) - -(deftest pprint-newline.error.3 - (signals-error (pprint-newline :fill nil nil) program-error) - t) diff --git a/t/ansi-test/printer/pprint-tab.lsp b/t/ansi-test/printer/pprint-tab.lsp deleted file mode 100644 index 5eca2f1..0000000 --- a/t/ansi-test/printer/pprint-tab.lsp +++ /dev/null @@ -1,238 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Jul 10 14:08:08 2004 -;;;; Contains: Tests of PPRINT-TAB - -(in-package :cl-test) - - - -;;; No effect in a non-pprint stream - -(def-pprint-test pprint-tab.non-pretty.1 - (with-output-to-string - (*standard-output*) - (write "A") - (pprint-tab :line 10 3) - (write "B")) - "AB") - -(def-pprint-test pprint-tab.non-pretty.2 - (with-output-to-string - (*standard-output*) - (write "A") - (pprint-tab :section 10 3) - (write "B")) - "AB") - -(def-pprint-test pprint-tab.non-pretty.3 - (with-output-to-string - (*standard-output*) - (write "A") - (pprint-tab :line-relative 10 3) - (write "B")) - "AB") - -(def-pprint-test pprint-tab.non-pretty.4 - (with-output-to-string - (*standard-output*) - (write "A") - (pprint-tab :section-relative 10 3) - (write "B")) - "AB") - -(def-ppblock-test pprint-tab.non-pretty.5 - (progn (write "A") (pprint-tab :line 10 3) (write "B")) - "AB" - :pretty nil) - -(def-ppblock-test pprint-tab.non-pretty.6 - (progn (write "A") (pprint-tab :section 10 3) (write "B")) - "AB" - :pretty nil) - -(def-ppblock-test pprint-tab.non-pretty.7 - (progn (write "A") (pprint-tab :line-relative 10 3) (write "B")) - "AB" - :pretty nil) - -(def-ppblock-test pprint-tab.non-pretty.8 - (progn (write "A") (pprint-tab :section-relative 10 3) (write "B")) - "AB" - :pretty nil) - - -;;; nil designates *standard-output* - -(def-ppblock-test pprint-tab.nil.1 - (progn (write "A") - (pprint-tab :line 10 1 nil) - (write "B")) - "A B") - -;;; t designates *terminal-io* - -(def-pprint-test pprint-tab.t.1 - (with-output-to-string - (os) - (with-input-from-string - (is "") - (with-open-stream - (*terminal-io* (make-two-way-stream is os)) - (pprint-logical-block - (*terminal-io* nil) - (write "A" :stream t) - (pprint-tab :line 10 1 t) - (write "B" :stream t))))) - "A B") - -;;; Now test actual tabbing behavior - -;;; NOTE -;;; I am assuming that when colnum <= current column, -;;; and the current column == colnum + k * colinc for some positive integer k, -;;; then pprint-tab :line will tab at least 1 space. - -(def-pprint-test pprint-tab.line.1 - (loop - for offset = (random 100) - for colnum = (random 100) - for colinc = (min (random 50) (random 50)) - for s = (with-output-to-string - (*standard-output*) - (pprint-logical-block - (*standard-output* nil) - (dotimes (i offset) (write #\Space)) - (pprint-tab :line colnum colinc) - (write #\A))) - for expected-col = (cond ((< offset colnum) colnum) - ((= colinc 0) offset) - ((= offset colnum) (+ offset colinc)) - (t (let ((k (mod (- colnum offset) colinc))) - (if (= k 0) - (+ offset colinc) - (+ offset k))))) - repeat 200 - nconc - (unless (string= s (concatenate - 'string - (make-string expected-col :initial-element #\Space) - "A")) - (list (list offset colnum colinc expected-col (count #\Space s) s)))) - nil - :margin 1000) - -(def-pprint-test pprint-tab.section.1 - (loop - for prefix-length = (random 50) - for offset = (random 50) - for colnum = (random 50) - for colinc = (min (random 50) (random 50)) - for s = (with-output-to-string - (*standard-output*) - (pprint-logical-block - (*standard-output* nil :prefix (make-string prefix-length - :initial-element #\Space)) - (dotimes (i offset) (write #\Space)) - (pprint-tab :section colnum colinc) - (write #\A))) - for expected-col = (+ prefix-length - (cond ((< offset colnum) colnum) - ((= colinc 0) offset) - ((= offset colnum) (+ offset colinc)) - (t (let ((k (mod (- colnum offset) colinc))) - (if (= k 0) - (+ offset colinc) - (+ offset k)))))) - repeat 200 - nconc - (unless (string= s (concatenate - 'string - (make-string expected-col :initial-element #\Space) - "A")) - (list (list offset colnum colinc expected-col (count #\Space s) s)))) - nil - :margin 1000) - -(def-pprint-test pprint-tab.line-relative.1 - (loop - for offset = (random 100) - for colrel = (random 100) - for colinc = (1+ (min (random 50) (random 50))) - for extra = (mod (- (+ offset colrel)) colinc) - for s = (with-output-to-string - (*standard-output*) - (pprint-logical-block - (*standard-output* nil) - (dotimes (i offset) (write #\Space)) - (pprint-tab :line-relative colrel colinc) - (write #\A))) - for expected-col = (+ offset colrel extra) - repeat 200 - nconc - (unless (string= s (concatenate - 'string - (make-string expected-col :initial-element #\Space) - "A")) - (list (list offset colrel colinc expected-col (count #\Space s) s)))) - nil - :margin 1000) - -(def-pprint-test pprint-tab.section-relative.1 - (loop - for prefix-length = (random 50) - for offset = (random 50) - for colrel = (random 50) - for colinc = (1+ (min (random 50) (random 50))) - for extra = (mod (- (+ offset colrel)) colinc) - for s = (with-output-to-string - (*standard-output*) - (pprint-logical-block - (*standard-output* nil :prefix (make-string prefix-length - :initial-element #\Space)) - (dotimes (i offset) (write #\Space)) - (pprint-tab :section-relative colrel colinc) - (write #\A))) - for expected-col = (+ prefix-length offset colrel extra) - - repeat 200 - nconc - (unless (string= s (concatenate - 'string - (make-string expected-col :initial-element #\Space) - "A")) - (list (list prefix-length offset colrel colinc extra expected-col (count #\Space s) s)))) - nil - :margin 1000) - -;;; Error cases - -(deftest pprint-tab.error.1 - (signals-error (pprint-tab) program-error) - t) - -(deftest pprint-tab.error.2 - (signals-error (pprint-tab :line) program-error) - t) - -(deftest pprint-tab.error.3 - (signals-error (pprint-tab :line 1) program-error) - t) - -(deftest pprint-tab.error.4 - (signals-error (pprint-tab :line 1 1 nil nil) program-error) - t) - -(deftest pprint-tab.error.5 - (loop for x in *mini-universe* - unless (or (member x '(:line :section :line-relative :section-relative)) - (eval `(signals-error (pprint-tab ',x 1 1) error))) - collect x) - nil) - -(deftest pprint-tab.error.5-unsafe - (loop for x in *mini-universe* - unless (or (member x '(:line :section :line-relative :section-relative)) - (eval `(signals-error (locally (declare (optimize (safety 0))) (pprint-tab ',x 1 1)) error))) - collect x) - nil) diff --git a/t/ansi-test/printer/pprint-tabular.lsp b/t/ansi-test/printer/pprint-tabular.lsp deleted file mode 100644 index 603936a..0000000 --- a/t/ansi-test/printer/pprint-tabular.lsp +++ /dev/null @@ -1,153 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jun 27 06:29:39 2004 -;;;; Contains: Tests of PPRINT-TABULAR - -(in-package :cl-test) - -;;; When printing a non-list, the result is the same as calling WRITE." -(deftest pprint-tabular.1 - (my-with-standard-io-syntax - (let ((*print-pretty* t) - (*print-readably* nil)) - (loop for obj in *mini-universe* - nconc - (and (not (listp obj)) - (let ((s1 (write-to-string obj)) - (s2 (with-output-to-string (s) (pprint-tabular s obj)))) - (unless (equal s1 s2) - (list (list obj s1 s2)))))))) - nil) - -(deftest pprint-tabular.2 - (my-with-standard-io-syntax - (let ((*print-pretty* nil) - (*print-readably* nil)) - (loop for obj in *mini-universe* - nconc - (and (not (listp obj)) - (let ((s1 (write-to-string obj)) - (s2 (with-output-to-string (s) (pprint-tabular s obj)))) - (unless (equal s1 s2) - (list (list obj s1 s2)))))))) - nil) - -(defmacro def-pprint-tabular-test (name args expected-value &key (margin 100) (circle nil) (pre nil)) - `(deftest ,name - (my-with-standard-io-syntax - (let ((*print-pretty* t) - (*print-readably* nil) - (*print-right-margin* ,margin) - (*package* (find-package :cl-test)) - (*print-circle* ,circle)) - (with-output-to-string - (s) - ,@(when pre (list pre)) - (pprint-tabular s ,@args)))) - ,expected-value)) - -;;; -;;; Note -;;; The prefix and suffix "(" and ")" are not considered part of the -;;; logical block they enclose (see the spec page for pprint-logical-block. -;;; - -(def-pprint-tabular-test pprint-tabular.3 ('(|M|)) "(M)") -(def-pprint-tabular-test pprint-tabular.4 ('(|M|) t) "(M)") -(def-pprint-tabular-test pprint-tabular.5 ('(|M|) nil) "M") - -(def-pprint-tabular-test pprint-tabular.6 ('(|M| |M|)) "(M M)") -(def-pprint-tabular-test pprint-tabular.7 ('(|M| |M|) t nil 1) "(M M)") -(def-pprint-tabular-test pprint-tabular.8 ('(|M| |M|) t t 3) "(M M)") -(def-pprint-tabular-test pprint-tabular.9 ('(|M| |M|) t nil 4) "(M M)") -(def-pprint-tabular-test pprint-tabular.10 ('(|MM| |MM|) t nil 4) "(MM MM)") -(def-pprint-tabular-test pprint-tabular.11 ('(|MM| |MM|) t nil 5) "(MM MM)") -(def-pprint-tabular-test pprint-tabular.12 ('(|M| |MM|) t nil 5) "(M MM)") - -(def-pprint-tabular-test pprint-tabular.13 ((let ((x (list '|A|))) (list x x)) t nil 1) - "(#1=(A) #1#)" :circle t) - -(def-pprint-tabular-test pprint-tabular.14 ('(|M| |M|) t t 4) "(M M)") - -(def-pprint-tabular-test pprint-tabular.15 ('(1 2 3 4) t t 1) "(1 2 3 4)") -(def-pprint-tabular-test pprint-tabular.16 ('(10 20 30 40) t t 1) "(10 20 30 40)") -(def-pprint-tabular-test pprint-tabular.17 ('(10 200 3000 40000) t t 1) "(10 200 3000 40000)") -(def-pprint-tabular-test pprint-tabular.18 ('(10 20 30 40) t t 2) "(10 20 30 40)") -(def-pprint-tabular-test pprint-tabular.19 ('(10 200 3000 40000) t t 2) "(10 200 3000 40000)") - -(def-pprint-tabular-test pprint-tabular.20 ('(1 2 3) t nil 1) - " (1 2 3)" - :pre (write " " :stream s :escape nil)) - -(def-pprint-tabular-test pprint-tabular.21 ('(1 2 3) t nil 1) - " (1 - 2 - 3)" - :pre (write " " :stream s :escape nil) :margin 9) - - -(def-pprint-tabular-test pprint-tabular.22 ('(1 2 3) t nil 1) - " (1 2 - 3)" - :pre (write " " :stream s :escape nil) :margin 10) - -;;; Takes T, NIL as stream designators - -(deftest pprint-tabular.23 - (my-with-standard-io-syntax - (let ((*print-pretty* nil) - (*print-readably* nil) - (*print-right-margin* 100)) - (with-output-to-string - (os) - (with-input-from-string - (is "") - (with-open-stream (*terminal-io* (make-two-way-stream is os)) - (pprint-tabular t '(1 2 3) t nil 1)))))) - "(1 2 3)") - -(deftest pprint-tabular.24 - (my-with-standard-io-syntax - (let ((*print-pretty* t) - (*print-readably* nil) - (*print-right-margin* 100)) - (with-output-to-string (*standard-output*) (pprint-tabular nil '(1 2 3) t nil 1)))) - "(1 2 3)") - -;;; FIXME: add test for colon-p argument of NIL - -;;; Test that pprint-tabular returns NIL - -(deftest pprint-tabular.return-values.1 - (my-with-standard-io-syntax - (let ((*print-pretty* nil) - (*package* (find-package :cl-test))) - (with-open-stream (s (make-broadcast-stream)) - (pprint-tabular s '(a b))))) - nil) - -(deftest pprint-tabular.return-values.2 - (my-with-standard-io-syntax - (let ((*print-pretty* nil) - (*package* (find-package :cl-test))) - (with-open-stream (s (make-broadcast-stream)) - (pprint-tabular s 10 nil nil 100)))) - nil) - -;;; Error tests - -(deftest pprint-tabular.error.1 - (signals-error (pprint-tabular) program-error) - t) - -(deftest pprint-tabular.error.2 - (signals-error (pprint-tabular *standard-output*) program-error) - t) - -(deftest pprint-tabular.error.3 - (signals-error (pprint-tabular *standard-output* nil t nil 1 nil) program-error) - t) - -(deftest pprint-tabular.error.4 - (signals-error (pprint-tabular *standard-output* '(a b c) t t 1 nil) program-error) - t) diff --git a/t/ansi-test/printer/pprint.lsp b/t/ansi-test/printer/pprint.lsp deleted file mode 100644 index 25bd1d3..0000000 --- a/t/ansi-test/printer/pprint.lsp +++ /dev/null @@ -1,49 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jul 25 11:42:48 2004 -;;;; Contains: Tests of PPRINT - -(in-package :cl-test) - - - -;;; This function is mostly tested elsewhere - -(deftest pprint.1 - (random-pprint-test 1000) - nil) - -(deftest pprint.2 - (with-standard-io-syntax - (with-output-to-string - (os) - (with-input-from-string - (is "") - (with-open-stream (*terminal-io* (make-two-way-stream is os)) - (pprint 2 t))))) - " -2") - -(deftest pprint.3 - (with-standard-io-syntax - (with-output-to-string - (*standard-output*) - (pprint 3 nil))) - " -3") - -;;; Error tests - -(deftest pprint.error.1 - (signals-error - (with-output-to-string (*standard-output*) (pprint)) - program-error) - t) - -(deftest pprint.error.2 - (signals-error - (with-output-to-string (s) (pprint nil s nil)) - program-error) - t) - - diff --git a/t/ansi-test/printer/prin1-to-string.lsp b/t/ansi-test/printer/prin1-to-string.lsp deleted file mode 100644 index aba16db..0000000 --- a/t/ansi-test/printer/prin1-to-string.lsp +++ /dev/null @@ -1,26 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Jul 26 12:18:22 2004 -;;;; Contains: Tests of PRIN1-TO-STRING - -(in-package :cl-test) - - - -(deftest prin1-to-string.1 - (random-prin1-to-string-test 5) - nil) - -(deftest prin1-to-string.2 - (with-standard-io-syntax (prin1-to-string 2)) - "2") - -;;; Error tests - -(deftest prin1-to-string.error.1 - (signals-error (prin1-to-string) program-error) - t) - -(deftest prin1-to-string.error.2 - (signals-error (prin1-to-string nil nil) program-error) - t) diff --git a/t/ansi-test/printer/prin1.lsp b/t/ansi-test/printer/prin1.lsp deleted file mode 100644 index 8dd77ab..0000000 --- a/t/ansi-test/printer/prin1.lsp +++ /dev/null @@ -1,45 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jul 25 11:33:40 2004 -;;;; Contains: Tests of PRIN1 - -(in-package :cl-test) - - - -;;; This function is mostly tested elsewhere - -(deftest prin1.1 - (random-prin1-test 1000) - nil) - -(deftest prin1.2 - (with-standard-io-syntax - (with-output-to-string - (os) - (with-input-from-string - (is "") - (with-open-stream (*terminal-io* (make-two-way-stream is os)) - (prin1 2 t))))) - "2") - -(deftest prin1.3 - (with-standard-io-syntax - (with-output-to-string - (*standard-output*) - (prin1 3 nil))) - "3") - -;;; Error tests - -(deftest prin1.error.1 - (signals-error - (with-output-to-string (*standard-output*) (prin1)) - program-error) - t) - -(deftest prin1.error.2 - (signals-error - (with-output-to-string (s) (prin1 nil s nil)) - program-error) - t) diff --git a/t/ansi-test/printer/princ-to-string.lsp b/t/ansi-test/printer/princ-to-string.lsp deleted file mode 100644 index 5276f04..0000000 --- a/t/ansi-test/printer/princ-to-string.lsp +++ /dev/null @@ -1,27 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Jul 26 12:19:32 2004 -;;;; Contains: Tests of PRINC-TO-STRING - -(in-package :cl-test) - - - -(deftest princ-to-string.1 - (random-princ-to-string-test 1000) - nil) - -(deftest princ-to-string.2 - (with-standard-io-syntax (princ-to-string 2)) - "2") - -;;; Error tests - -(deftest princ-to-string.error.1 - (signals-error (princ-to-string) program-error) - t) - -(deftest princ-to-string.error.2 - (signals-error (princ-to-string nil nil) program-error) - t) - diff --git a/t/ansi-test/printer/princ.lsp b/t/ansi-test/printer/princ.lsp deleted file mode 100644 index fd0edb6..0000000 --- a/t/ansi-test/printer/princ.lsp +++ /dev/null @@ -1,45 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jul 25 11:40:37 2004 -;;;; Contains: Tests of PRINC - -(in-package :cl-test) - - - -;;; This function is mostly tested elsewhere - -(deftest princ.1 - (random-princ-test 5) - nil) - -(deftest princ.2 - (with-standard-io-syntax - (with-output-to-string - (os) - (with-input-from-string - (is "") - (with-open-stream (*terminal-io* (make-two-way-stream is os)) - (princ 2 t))))) - "2") - -(deftest princ.3 - (with-standard-io-syntax - (with-output-to-string - (*standard-output*) - (princ 3 nil))) - "3") - -;;; Error tests - -(deftest princ.error.1 - (signals-error - (with-output-to-string (*standard-output*) (princ)) - program-error) - t) - -(deftest princ.error.2 - (signals-error - (with-output-to-string (s) (princ nil s nil)) - program-error) - t) diff --git a/t/ansi-test/printer/print-array.lsp b/t/ansi-test/printer/print-array.lsp deleted file mode 100644 index 2f0f2f9..0000000 --- a/t/ansi-test/printer/print-array.lsp +++ /dev/null @@ -1,474 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Apr 22 22:38:11 2004 -;;;; Contains: Tests of printing of arrays (other than vectors) - - - -(in-package :cl-test) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Zero dimensional arrays - -(deftest print.array.0.1 - (let ((a (make-array nil :initial-element 0))) - (with-standard-io-syntax - (write-to-string a :readably nil :array t))) - "#0A0") - -(deftest print.array.0.2 - (with-standard-io-syntax - (let ((a (make-array nil :initial-element '|A|)) - (*package* (find-package "CL-TEST"))) - (write-to-string a :readably nil :array t))) - "#0AA") - -(deftest print.array.0.3 - (let* ((a (make-array nil :initial-element 0)) - (result (write-to-string a :readably nil :array nil))) - (values - (subseq result 0 2) - (subseq result (1- (length result))))) - "#<" ">") - -(deftest print.array.0.4 - (let ((a (make-array nil :initial-element 0 :adjustable t))) - (with-standard-io-syntax - (write-to-string a :readably nil :array t))) - "#0A0") - -(deftest print.array.0.5 - (let* ((a (make-array nil :initial-element 0 :adjustable t)) - (b (make-array nil :displaced-to a :displaced-index-offset 0))) - (with-standard-io-syntax - (write-to-string b :readably nil :array t))) - "#0A0") - -(deftest print.array.0.6 - (let ((a (make-array nil :initial-element 0 - :element-type '(integer 0 2)))) - (with-standard-io-syntax - (write-to-string a :readably nil :array t))) - "#0A0") - -(deftest print.array.0.7 - (loop for a = (make-array nil :initial-element (- (random 1000000) 500000)) - repeat 30 nconc (randomly-check-readability a :test #'is-similar)) - nil) - -(deftest print.array.0.8 - (loop for i from 1 to 64 - for type = `(unsigned-byte ,i) - nconc - (let ((a (make-array nil :initial-element 1 :element-type type))) - (loop repeat 5 nconc (randomly-check-readability a :test #'is-similar - :can-fail t)))) - nil) - -(deftest print.array.0.9 - (loop for a = (make-array nil :initial-element (random 1000000) :adjustable t) - repeat 30 - nconc (randomly-check-readability a :test #'is-similar)) - nil) - -(deftest print.array.0.10 - (loop for a = (make-array nil :initial-element (random 1000000000)) - for b = (make-array nil :displaced-to a :displaced-index-offset 0) - repeat 30 nconc (randomly-check-readability b :test #'is-similar)) - nil) - -(deftest print.array.0.11 - (loop for type in '(short-float single-float double-float long-float float) - for zero = (coerce 0 type) - for a = (make-array nil :initial-element zero - :element-type type) - nconc - (loop repeat 30 nconc (randomly-check-readability a :test #'is-similar - :can-fail t))) - nil) - -(deftest print.array.0.12 - (loop for type0 in '(short-float single-float double-float long-float float) - for type = `(complex ,type0) - for zero = (complex (coerce 0.0s0 type0)) - for a = (make-array nil :initial-element zero - :element-type type) - nconc - (loop repeat 30 nconc (randomly-check-readability a :test #'is-similar - :can-fail t))) - nil) - -(deftest print.array.0.13 - (let ((result (write-to-string (make-array nil :initial-element 0) - :readably nil :array nil))) - (values - (subseq result 0 2) - (subseq result (1- (length result))))) - "#<" ">") - -(deftest print.array.0.14 - (loop for i from 1 to 64 - for type = `(unsigned-byte ,i) - for a = (make-array nil :element-type type :initial-element 1) - for result = (write-to-string a :readably nil :array nil) - unless (and (string= (subseq result 0 2) "#<") - (string= (subseq result (1- (length result))) ">")) - collect (list i result)) - nil) - -(deftest print.array.0.15 - (loop for i from 1 to 64 - for type = `(signed-byte ,i) - for a = (make-array nil :element-type type :initial-element -1) - for result = (write-to-string a :readably nil :array nil) - unless (and (string= (subseq result 0 2) "#<") - (string= (subseq result (1- (length result))) ">")) - collect (list i result)) - nil) - -(deftest print.array.0.16 - (loop for type in '(short-float single-float double-float long-float) - for a = (make-array nil :element-type type - :initial-element (coerce 17 type)) - for result = (write-to-string a :readably nil :array nil) - unless (and (string= (subseq result 0 2) "#<") - (string= (subseq result (1- (length result))) ">")) - collect (list type result)) - nil) - -(deftest print.array.0.17 - (loop for type0 in '(short-float single-float double-float - long-float float real) - for type = `(complex ,type0) - for a = (make-array nil :element-type type - :initial-element (complex 0 (coerce 3 type0))) - for result = (write-to-string a :readably nil :array nil) - unless (and (string= (subseq result 0 2) "#<") - (string= (subseq result (1- (length result))) ">")) - collect (list type result)) - nil) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Two-d arrays -(deftest print.array.2.1 - (let ((a (make-array '(1 1) :initial-contents '((1))))) - (with-standard-io-syntax - (write-to-string a :readably nil :array t))) - "#2A((1))") - -(deftest print.array.2.2 - (let ((a (make-array '(2 3) :initial-contents '((1 3 8)(2 6 10))))) - (with-standard-io-syntax - (write-to-string a :readably nil :array t))) - "#2A((1 3 8) (2 6 10))") - -(deftest print.array.2.3 - (let ((a (make-array '(0 1)))) - (with-standard-io-syntax - (write-to-string a :readably nil :array t))) - "#2A()") - -(deftest print.array.2.4 - (let ((a (make-array '(1 0)))) - (with-standard-io-syntax - (write-to-string a :readably nil :array t))) - "#2A(())") - -(deftest print.array.2.5 - (let ((a (make-array '(0 0)))) - (with-standard-io-syntax - (write-to-string a :readably nil :array t))) - "#2A()") - -(deftest print.array.2.6 - (let ((a (make-array '(10 0)))) - (with-standard-io-syntax - (write-to-string a :readably nil :array t))) - "#2A(() () () () () () () () () ())") - -(deftest print.array.2.7 - (let* ((a (make-array '(3 3) :initial-contents '((1 3 8) (2 67 121) (65 432 6)))) - (b (make-array '(3 3) :displaced-to a - :displaced-index-offset 0))) - (with-standard-io-syntax - (write-to-string b :readably nil :array t))) - "#2A((1 3 8) (2 67 121) (65 432 6))") - -(deftest print.array.2.8 - (let* ((a (make-array '(3 3) :initial-contents '((1 3 8) (2 67 121) (65 432 6)))) - (b (make-array '(2 3) :displaced-to a - :displaced-index-offset 0))) - (with-standard-io-syntax - (write-to-string b :readably nil :array t))) - "#2A((1 3 8) (2 67 121))") - -(deftest print.array.2.9 - (let* ((a (make-array '(3 3) :initial-contents '((1 3 8) (2 67 121) (65 432 6)))) - (b (make-array '(2 2) :displaced-to a - :displaced-index-offset 4))) - (with-standard-io-syntax - (write-to-string b :readably nil :array t))) - "#2A((67 121) (65 432))") - -(deftest print.array.2.10 - (let* ((a (make-array '(3 3) :initial-contents '((1 3 8) (2 67 121) (65 432 6)))) - (b (make-array '(2 2) :displaced-to a - :displaced-index-offset 4 - :adjustable t))) - (with-standard-io-syntax - (write-to-string b :readably nil :array t))) - "#2A((67 121) (65 432))") - -(deftest print.array.2.11 - (let* ((a (make-array '(3 4) - :initial-contents '((7 8 9 10) (65 12 42 -1) (:|W| :|X| :|Y| :|Z| )) - :adjustable t))) - (with-standard-io-syntax - (write-to-string a :readably nil :array t))) - "#2A((7 8 9 10) (65 12 42 -1) (:W :X :Y :Z))") - -(deftest print.array.2.12 - (let ((desired-result "#2A((0 1 1) (1 1 0))")) - (loop for i from 2 to 64 - for a = (make-array '(2 3) :element-type `(unsigned-byte ,i) - :initial-contents '((0 1 1) (1 1 0))) - for result = (with-standard-io-syntax - (write-to-string a :readably nil :array t)) - unless (string= desired-result result) - collect (list i a result))) - nil) - -(deftest print.array.2.13 - (let ((desired-result "#2A((0 -1 -1) (-1 -1 0))")) - (loop for i from 1 to 64 - for a = (make-array '(2 3) :element-type `(signed-byte ,i) - :initial-contents '((0 -1 -1) (-1 -1 0))) - for result = (with-standard-io-syntax - (write-to-string a :readably nil :array t)) - unless (string= desired-result result) - collect (list i a result))) - nil) - -(deftest print.array.2.14 - (let ((desired-result "#2A((0 1 1) (1 1 0))")) - (loop for i from 2 to 64 - for a = (make-array '(2 3) :element-type `(unsigned-byte ,i) - :adjustable t - :initial-contents '((0 1 1) (1 1 0))) - for result = (with-standard-io-syntax - (write-to-string a :readably nil :array t)) - unless (string= desired-result result) - collect (list i a result))) - nil) - -(deftest print.array.2.15 - (let ((desired-result "#2A((0 -1 -1) (-1 -1 0))")) - (loop for i from 1 to 64 - for a = (make-array '(2 3) :element-type `(signed-byte ,i) - :adjustable t - :initial-contents '((0 -1 -1) (-1 -1 0))) - for result = (with-standard-io-syntax - (write-to-string a :readably nil :array t)) - unless (string= desired-result result) - collect (list i a result))) - nil) - -(deftest print.array.2.16 - (let ((desired-result "#2A((1 1) (1 0))")) - (loop for i from 2 to 64 - for type = `(unsigned-byte ,i) - for a = (make-array '(2 3) :element-type type - :adjustable t - :initial-contents '((0 1 1) (1 1 0))) - for b = (make-array '(2 2) :displaced-to a :displaced-index-offset 2 - :element-type type) - for result = (with-standard-io-syntax - (write-to-string b :readably nil :array t)) - unless (string= desired-result result) - collect (list i b result))) - nil) - -(deftest print.array.2.17 - (let ((desired-result "#2A((1 -1) (-2 0))")) - (loop for i from 2 to 64 - for type = `(signed-byte ,i) - for a = (make-array '(2 3) :element-type type - :adjustable t - :initial-contents '((0 1 1) (-1 -2 0))) - for b = (make-array '(2 2) :displaced-to a :displaced-index-offset 2 - :element-type type) - for result = (with-standard-io-syntax - (write-to-string b :readably nil :array t)) - unless (string= desired-result result) - collect (list i b result))) - nil) - -(deftest print.array.2.20 - (let* ((a (make-array '(9) :initial-contents '(1 3 8 2 67 121 65 432 6))) - (b (make-array '(2 2) :displaced-to a - :displaced-index-offset 1))) - (with-standard-io-syntax - (write-to-string b :readably nil :array t))) - "#2A((3 8) (2 67))") - -(deftest print.array.2.21 - (trim-list - (loop - for dims = (list (random 4) (random 4)) - for a = (make-array dims :initial-element (- (random 1000000) 500000)) - repeat 100 - nconc (let ((result (randomly-check-readability a :test #'is-similar :can-fail t))) - (and result (list (cons dims (first result)))))) - 10) - nil) - -(deftest print.array.2.22 - (loop for a = (make-array (list (random 4) (random 4)) - :initial-element (- (random 1000000) 500000) - :adjustable t) - repeat 100 nconc (randomly-check-readability a :test #'is-similar - :can-fail t)) - nil) - -(deftest print.array.2.23 - (loop for d1 = (random 10) - for d2 = (random 10) - for a = (make-array (list d1 d2) - :initial-element (- (random 1000000) 500000)) - for d1a = (random (1+ d1)) - for d2a = (random (1+ d2)) - for offset = (random (1+ (- (* d1 d2) (* d1a d2a)))) - for b = (make-array (list d1a d2a) :displaced-to a - :displaced-index-offset offset) - repeat 100 nconc (randomly-check-readability b :test #'is-similar - :can-fail t)) - nil) - -(deftest print.array.2.24 - (loop for i from 1 to 64 - for type = `(unsigned-byte ,i) - nconc - (let ((a (make-array '(3 4) :initial-element 1 :element-type type))) - (loop repeat 5 nconc (randomly-check-readability a :test #'is-similar - :can-fail t)))) - nil) - -(deftest print.array.2.25 - (let ((a (make-array '(3 4) :initial-element #\a :element-type 'character))) - (loop repeat 10 nconc (randomly-check-readability a :test #'is-similar - :can-fail t))) - nil) - -(deftest print.array.2.26 - (let ((a (make-array '(3 4) :initial-element #\a :element-type 'base-char))) - (loop repeat 10 nconc (randomly-check-readability a :test #'is-similar - :can-fail t))) - nil) - - -(deftest print.array.2.27 - (let ((str (write-to-string (make-array '(2 3) :initial-element 0) - :readably nil :array nil))) - (values (subseq str 0 2) (subseq str (1- (length str))))) - "#<" ">") - -(deftest print.array.2.28 - (loop for i from 1 to 64 - for type = `(unsigned-byte ,i) - for a = (make-array '(4 3) :element-type type :initial-element 1) - for result = (write-to-string a :readably nil :array nil) - unless (and (string= (subseq result 0 2) "#<") - (string= (subseq result (1- (length result))) ">")) - collect (list i result)) - nil) - -(deftest print.array.2.29 - (loop for i from 1 to 64 - for type = `(signed-byte ,i) - for a = (make-array '(4 8) :element-type type :initial-element -1) - for result = (write-to-string a :readably nil :array nil) - unless (and (string= (subseq result 0 2) "#<") - (string= (subseq result (1- (length result))) ">")) - collect (list i result)) - nil) - -(deftest print.array.2.30 - (loop for type in '(short-float single-float double-float long-float) - for a = (make-array '(5 7) :element-type type - :initial-element (coerce 17 type)) - for result = (write-to-string a :readably nil :array nil) - unless (and (string= (subseq result 0 2) "#<") - (string= (subseq result (1- (length result))) ">")) - collect (list type result)) - nil) - -(deftest print.array.2.31 - (loop for type0 in '(short-float single-float double-float - long-float float real) - for type = `(complex ,type0) - for a = (make-array '(13 5) :element-type type - :initial-element (complex 0 (coerce 3 type0))) - for result = (write-to-string a :readably nil :array nil) - unless (and (string= (subseq result 0 2) "#<") - (string= (subseq result (1- (length result))) ">")) - collect (list type result)) - nil) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Three D arrays - -(deftest print.array.3.1 - (let* ((a (make-array '(1 2 3) :initial-contents '(((:|A| :|B| :|C|) (:|D| :|E| :|F|))))) - (b (make-array '(3 2 1) :displaced-to a - :displaced-index-offset 0))) - (with-standard-io-syntax - (values - (write-to-string a :readably nil :array t) - (write-to-string b :readably nil :array t)))) - "#3A(((:A :B :C) (:D :E :F)))" - "#3A(((:A) (:B)) ((:C) (:D)) ((:E) (:F)))") - - -;;; Multidimensional arrays - -(deftest print.array.multi-dim.1 - (with-standard-io-syntax - (loop for d in (remove array-rank-limit - '(4 5 6 7 8 9 10 12 16 20 30 40 100 200 400 600 800 1023) - :test #'<=) - for dims = (make-list d :initial-element 1) - for a = (make-array dims :initial-element 0) - for result = (with-standard-io-syntax - (write-to-string a :readably nil :array t)) - for expected-result = - (concatenate 'string - (format nil "#~DA" d) - (make-string d :initial-element #\() - "0" - (make-string d :initial-element #\))) - unless (string= result expected-result) - collect (list d result expected-result))) - nil) - -(deftest print.array.multi-dim.2 - (with-standard-io-syntax - (loop for d = (+ 4 (random (min (- array-rank-limit 4) 1000))) - for p = (random d) - for dims = (let ((list (make-list d :initial-element 1))) - (setf (elt list p) 0) - list) - for a = (make-array dims :initial-element 0) - for result = (with-standard-io-syntax - (write-to-string a :readably nil :array t)) - for expected-result = - (concatenate 'string - (format nil "#~DA" d) - (make-string (1+ p) :initial-element #\() - (make-string (1+ p) :initial-element #\))) - repeat 50 - unless (string= result expected-result) - collect (list d result expected-result))) - nil) - -;;; To add: more tests for high dimensional arrays, including arrays with -;;; element types diff --git a/t/ansi-test/printer/print-backquote.lsp b/t/ansi-test/printer/print-backquote.lsp deleted file mode 100644 index ca282b0..0000000 --- a/t/ansi-test/printer/print-backquote.lsp +++ /dev/null @@ -1,134 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Jun 10 19:31:01 2004 -;;;; Contains: Tests of printing of backquote forms (and fragments thereof) - -(in-package :cl-test) - - - - -(deftest print.backquote.random.1 - (let* ((x '`(a ,b ,@c (d . ,e) ,.f #(1 2 ,p ,@q ,.r s) g)) - (y (copy-tree x))) - (or - (loop - repeat 20 - nconc (randomly-check-readability y :test #'is-similar)) - (and (not (equal x y)) (list :modified x y)))) - nil) - -(deftest print.backquote.random.2 - (let* ((x '`(,@a ,@b)) - (y (copy-tree x))) - (or - (loop - repeat 20 - nconc (randomly-check-readability y :test #'is-similar)) - (and (not (is-similar x y)) (list :modified x y)))) - nil) - -(deftest print.backquote.random.3 - (let* ((x '`(,.a ,.b)) - (y (copy-tree x))) - (or - (loop - repeat 20 - nconc (randomly-check-readability y :test #'is-similar)) - (and (not (is-similar x y)) (list :modified x y)))) - nil) - -(deftest print.backquote.random.4 - (let* ((x '`(,a ,b)) - (y (copy-tree x))) - (or - (loop - repeat 20 - nconc (randomly-check-readability y :test #'is-similar)) - (and (not (is-similar x y)) (list :modified x y)))) - nil) - -(deftest print.backquote.random.5 - (let* ((x '`#(,a ,b)) - (y (copy-tree x))) - (or - (loop - repeat 20 - nconc (randomly-check-readability y :test #'is-similar)) - (and (not (is-similar x y)) (list :modified x y)))) - nil) - -(deftest print.backquote.random.6 - (let ((x '`(,@a ,@b))) - (and (consp x) - (symbolp (car x)) - (loop - repeat 20 - nconc (randomly-check-readability (list (car x)) :test #'is-similar)))) - nil) - -(deftest print.backquote.random.7 - (let ((x '`(,.a ,.b))) - (and (consp x) - (symbolp (car x)) - (loop - repeat 20 - nconc (randomly-check-readability (list (car x)) :test #'is-similar)))) - nil) - -(deftest print.backquote.random.8 - (let ((x '`(,a ,b))) - (and (consp x) - (symbolp (car x)) - (loop - repeat 20 - nconc (randomly-check-readability (list (car x)) :test #'is-similar)))) - nil) - -(deftest print.backquote.random.9 - (let ((x '`#(,a ,b))) - (and (consp x) - (symbolp (car x)) - (loop - repeat 20 - nconc (randomly-check-readability (list (car x)) :test #'is-similar)))) - nil) - -(deftest print.backquote.random.10 - (let ((x '`#(,a , .b))) - (loop - repeat 20 - nconc (randomly-check-readability x :test #'is-similar))) - nil) - -(deftest print.backquote.random.11 - (let ((x '`#(,a , @b))) - (loop - repeat 20 - nconc (randomly-check-readability x :test #'is-similar))) - nil) - -(deftest print.backquote.random.12 - (let ((x '`#(,a ,b c))) - (and (consp x) - (symbolp (car x)) - (loop - repeat 20 - nconc (randomly-check-readability (list (car x)) :test #'is-similar)))) - nil) - -(deftest print.backquote.random.13 - (let* ((x '`#(,a ,b c)) - (y (copy-tree x))) - (or - (loop - repeat 20 - nconc (randomly-check-readability x :test #'is-similar)) - (and (not (is-similar x y)) (list :modified x y)))) - nil) - -(deftest print.backquote.random.14 - (loop for x = (make-random-backquoted-form 100) - repeat 500 - nconc (randomly-check-readability x :test #'is-similar)) - nil) diff --git a/t/ansi-test/printer/print-bit-vector.lsp b/t/ansi-test/printer/print-bit-vector.lsp deleted file mode 100644 index 1ea931a..0000000 --- a/t/ansi-test/printer/print-bit-vector.lsp +++ /dev/null @@ -1,69 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Apr 20 22:10:53 2004 -;;;; Contains: Tests for printing of bit vectors - - - -(in-package :cl-test) - -(deftest print.bit-vector.1 - (with-standard-io-syntax - (write-to-string #* :readably nil :escape nil)) - "#*") - -(deftest print.bit-vector.2 - (with-standard-io-syntax - (subseq (write-to-string #* :readably nil :escape nil :array nil) - 0 2)) - "#<") - -(deftest print.bit-vector.3 - (with-standard-io-syntax - (write-to-string #*001101010011011 :readably nil :escape nil)) - "#*001101010011011") - -(deftest print.bit-vector.4 - (with-standard-io-syntax - (subseq (write-to-string #*11010011010110101 - :readably nil :escape nil :array nil) - 0 2)) - "#<") - -(deftest print.bit-vector.5 - (let* ((bv1 #*0001100101) - (bv2 (make-array 5 :displaced-to bv1 - :displaced-index-offset 1 - :element-type 'bit))) - (with-standard-io-syntax - (write-to-string bv2 :readably nil :escape nil))) - "#*00110") - -(deftest print.bit-vector.6 - (let* ((bv (make-array 10 - :element-type 'bit - :initial-contents '(1 0 0 1 0 0 1 1 1 0) - :fill-pointer 5))) - (with-standard-io-syntax - (write-to-string bv :readably nil :escape nil))) - "#*10010") - - -(deftest print.bit-vector.7 - (let* ((bv (make-array 10 - :element-type 'bit - :initial-contents '(1 0 0 1 0 0 1 1 1 0) - :adjustable t))) - (with-standard-io-syntax - (write-to-string bv :readably nil :escape nil))) - "#*1001001110") - - - -(deftest print.bit-vector.random - (loop - for len = (random 100) - for bv = (coerce (loop repeat len collect (random 2)) 'bit-vector) - repeat 1000 - nconc (randomly-check-readability bv)) - nil) diff --git a/t/ansi-test/printer/print-characters.lsp b/t/ansi-test/printer/print-characters.lsp deleted file mode 100644 index 5e70be5..0000000 --- a/t/ansi-test/printer/print-characters.lsp +++ /dev/null @@ -1,118 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Mar 5 07:12:20 2004 -;;;; Contains: Tests for printing of characters - -(in-package :cl-test) - - - -;;; See CLtS section 22.1.3.2, "Printing Characters" - -(deftest print.char.1 - (with-standard-io-syntax - (loop for c across +standard-chars+ - unless (equal (string c) - (with-output-to-string (s) - (princ c s))) - collect c)) - nil) - -(deftest print.char.2 - (with-standard-io-syntax - (loop for c across +code-chars+ - unless (equal (string c) - (with-output-to-string (s) - (princ c s))) - collect c)) - nil) - -(deftest print.char.3 - (with-standard-io-syntax - (let ((*print-readably* nil)) - (loop for c across +base-chars+ - unless (or (eql c #\Space) - (equal (format nil "#\\~C" c) - (with-output-to-string (s) - (prin1 c s)))) - collect c))) - nil) - -(deftest print.char.4 - (with-standard-io-syntax - (let ((*print-readably* nil)) - (with-output-to-string (s) - (prin1 #\Space s)))) - "#\\ ") - -(deftest print.char.5 - (with-standard-io-syntax - (let ((*print-readably* nil)) - (with-output-to-string (s) - (prin1 #\Newline s)))) - "#\\Newline") - -(deftest print.char.6 - (with-standard-io-syntax - (let ((*print-readably* nil)) - (with-output-to-string (s) - (princ #\Newline s)))) - #.(string #\Newline)) - -(deftest print.char.7 - (with-standard-io-syntax - (let ((*print-readably* nil)) - (loop for c across +code-chars+ - for str = (with-output-to-string (s) (prin1 c s)) - for len = (length str) - unless (and (>= len 3) - (equal (subseq str 0 2) "#\\") - (or (= len 3) - (let ((name (subseq str 2))) - (eql c (name-char name))))) - collect c))) - nil) - -(deftest print.char.8 - (loop for i = (random (min char-code-limit (ash 1 16))) - for c = (code-char i) - repeat 1000 - unless (null c) - nconc (let ((result (randomly-check-readability c))) - (and result (list (cons i (first result)))))) - nil) - -(deftest print.char.9 - (loop for i = (random (min char-code-limit (ash 1 32))) - for c = (code-char i) - repeat 1000 - unless (null c) - nconc (let ((result (randomly-check-readability c))) - (and result (list (cons i (first result)))))) - nil) - -(deftest print.char.10 - (with-standard-io-syntax - (let ((*print-readably* nil)) - (loop for c across +standard-chars+ - for str = (with-output-to-string (s) (prin1 c s)) - unless (or (eql c #\Newline) - (equal str (concatenate 'string "#\\" (string c)))) - collect (list c str)))) - nil) - -(deftest print.char.11 - (with-standard-io-syntax - (let ((*print-readably* nil)) - (let ((names '("Newline" "Tab" "Rubout" "Linefeed" "Page" - "Backspace" "Return"))) - (loop for name in names - for c = (name-char name) - for str = (with-output-to-string (s) (prin1 c s)) - unless (or (null c) - (and (>= (length str) 3) - (equal (subseq str 0 2) "#\\") - (member (subseq str 2) names - :test #'equal))) - collect (list c str))))) - nil) diff --git a/t/ansi-test/printer/print-complex.lsp b/t/ansi-test/printer/print-complex.lsp deleted file mode 100644 index bfab48d..0000000 --- a/t/ansi-test/printer/print-complex.lsp +++ /dev/null @@ -1,56 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Mar 3 06:44:04 2004 -;;;; Contains: Tests of printing complex numbers - -(in-package :cl-test) - - - -(deftest print.complex.1 - (equalt - (with-standard-io-syntax - (let ((*print-readably* nil)) - (with-output-to-string (s) (prin1 (complex 1 2) s)))) - "#C(1 2)") - t) - -(deftest print.complex.2 - (equalt - (with-standard-io-syntax - (let ((*print-readably* nil)) - (with-output-to-string (s) (prin1 (complex 1.0 2.0) s)))) - "#C(1.0 2.0)") - t) - -(deftest print.complex.random.1 - (loop for numbits = (random 40) - for bound = (ash 1 numbits) - for r = (- (random (+ bound bound)) bound) - for i = (- (random (+ bound bound)) bound) - repeat 1000 - unless (= i 0) - nconc (randomly-check-readability (complex r i))) - nil) - -(deftest print.complex.random.2 - (loop for numbits = (random 40) - for bound = (ash 1 numbits) - for num1 = (- (random (+ bound bound)) bound) - for num2 = (- (random (+ bound bound)) bound) - for denom1 = (1+ (random bound)) - for denom2 = (1+ (random bound)) - for r = (/ num1 denom1) - for i = (/ num2 denom2) - repeat 1000 - unless (= i 0) - nconc (randomly-check-readability (complex r i))) - nil) - -;; General floating point complex printing tests will go here - - - - - - diff --git a/t/ansi-test/printer/print-cons.lsp b/t/ansi-test/printer/print-cons.lsp deleted file mode 100644 index 8327ee1..0000000 --- a/t/ansi-test/printer/print-cons.lsp +++ /dev/null @@ -1,170 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Apr 19 07:28:40 2004 -;;;; Contains: Tests of printing of conses - - - -(in-package :cl-test) - -(deftest print.cons.1 - (my-with-standard-io-syntax - (let ((*print-readably* nil)) - (write-to-string '(|A|) :case :upcase :pretty nil :escape nil))) - "(A)") - -(deftest print.cons.2 - (my-with-standard-io-syntax - (let ((*print-readably* nil)) - (write-to-string '(|A| |B|) :case :upcase :pretty nil :escape nil))) - "(A B)") - -(deftest print.cons.3 - (my-with-standard-io-syntax - (let ((*print-readably* nil)) - (write-to-string (cons '|A| '|B|) :case :upcase :pretty nil :escape nil))) - "(A . B)") - -(deftest print.cons.4 - (my-with-standard-io-syntax - (let ((*print-readably* nil)) - (write-to-string (let ((s '#:|X|)) (cons s s)) :case :upcase :pretty nil :escape t))) - "(#:X . #:X)") - -(deftest print.cons.5 - (my-with-standard-io-syntax - (let ((*print-readably* nil)) - (write-to-string (let ((s '#:|X|)) (cons s s)) :case :upcase :pretty nil :escape t :circle t))) - "(#1=#:X . #1#)") - -(deftest print.cons.6 - (my-with-standard-io-syntax - (let ((*print-readably* nil)) - (write-to-string (let ((s1 (make-symbol "X")) - (s2 (make-symbol "X"))) - (list s1 s2 s1 s2)) - :case :upcase :pretty nil :escape t :circle t))) - "(#1=#:X #2=#:X #1# #2#)") - -(deftest print.cons.7 - (my-with-standard-io-syntax - (let ((*print-readably* nil)) - (write-to-string (let ((a (list 17 nil))) - (setf (cdr a) a) - a) - :circle t :pretty nil :escape nil))) - "#1=(17 . #1#)") - -;;; Random printing - -(deftest print.cons.random.1 - (trim-list - (loop - for x = (make-random-cons-tree (random 100)) - repeat 50 - nconc (randomly-check-readability x)) - 10) - nil) - -;; random circular cons graphs -#-lispworks -(deftest print.cons.random.2 - (loop repeat 50 - nconc - (let* ((n 20) - (conses (apply #'vector - (loop repeat n collect (cons nil nil))))) - (loop for x across conses - for j = (random n) - for k = (random n) - do (setf (car x) (elt conses j) - (cdr x) (elt conses k))) - (randomly-check-readability (elt conses 0) :test #'is-similar - :circle t))) - nil) - -;;; Printing with *print-length* - -(deftest print.cons.length.1 - (my-with-standard-io-syntax - (let ((*print-readably* nil)) - (write-to-string '(a) :length 0 :pretty nil :escape nil))) - "(...)") - -(deftest print.cons.length.2 - (my-with-standard-io-syntax - (let ((*print-readably* nil)) - (write-to-string '(81) :length 1 :pretty nil :escape nil))) - "(81)") - -(deftest print.cons.length.3 - (my-with-standard-io-syntax - (let ((*print-readably* nil)) - (write-to-string '(4 . 8) :length 1 :pretty nil :escape nil))) - "(4 . 8)") - -(deftest print.cons.length.4 - (my-with-standard-io-syntax - (let ((*print-readably* nil)) - (write-to-string '(4 8) :length 1 :pretty nil :escape nil))) - "(4 ...)") - -(deftest print.cons.length.5 - (my-with-standard-io-syntax - (let ((*print-readably* nil)) - (write-to-string '(a b c d e f g h i j k l m n o p) - :case :downcase :length 10 - :pretty nil :escape nil))) - "(a b c d e f g h i j ...)") - - -(deftest print.cons.length.6 - (my-with-standard-io-syntax - (let ((*print-readably* nil)) - (write-to-string '(((((((0))))))) - :case :downcase :length 3 - :pretty nil :escape nil))) - "(((((((0)))))))") - -;;; Printing with *print-level* - -(deftest print.cons.level.1 - (my-with-standard-io-syntax - (let ((*print-readably* nil)) - (write-to-string '(a) - :case :downcase :level 0 - :escape nil :pretty nil))) - "#") - -(deftest print.cons.level.2 - (my-with-standard-io-syntax - (let ((*print-readably* nil)) - (write-to-string '(a) - :case :downcase :level 1 - :escape nil :pretty nil))) - "(a)") - -(deftest print.cons.level.3 - (my-with-standard-io-syntax - (let ((*print-readably* nil)) - (write-to-string '((a)) - :case :downcase :level 1 - :escape nil :pretty nil))) - "(#)") - - -(deftest print.cons.level.4 - (my-with-standard-io-syntax - (let ((*print-readably* nil)) - (write-to-string '(a) - :case :downcase :level 2 - :escape nil :pretty nil))) - "(a)") - -(deftest print.cons.level.5 - (my-with-standard-io-syntax - (let ((*print-readably* nil)) - (write-to-string '(#(a) #*1101 "abc") - :case :downcase :level 1 - :pretty nil))) - "(# #*1101 \"abc\")") diff --git a/t/ansi-test/printer/print-floats.lsp b/t/ansi-test/printer/print-floats.lsp deleted file mode 100644 index dfabc83..0000000 --- a/t/ansi-test/printer/print-floats.lsp +++ /dev/null @@ -1,386 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Mar 2 07:32:57 2004 -;;;; Contains: Tests of printing of floating point numbers - -(in-package :cl-test) - - - -(deftest print.short-float.1 - (with-standard-io-syntax - (let ((*print-readably* nil) - (*read-default-float-format* 'short-float)) - (loop for i from -4000 to 4000 - for f = (float i 0.0s0) - for s1 = (with-output-to-string (s) (prin1 f s)) - for s2 = (format nil "~A.0" i) - unless (equalp s1 s2) - collect (list i f s1 s2)))) - nil) - -(deftest print.short-float.2 - (with-standard-io-syntax - (let ((*print-readably* nil) - (*read-default-float-format* 'short-float)) - (loop for i = (- (random 20000000) 10000000) - for f = (float i 0.0s0) - for s1 = (with-output-to-string (s) (prin1 f s)) - for s2 = (format nil "~A.0" i) - repeat 10000 - unless (or (/= i (rational f)) ; not enough bits - ;; (> (nth-value 1 (integer-decode-float f)) 0) - (equalp s1 s2)) - collect (list i f s1 s2)))) - nil) - -(defparameter *possible-short-float-exponent-markers* - (loop for type in '(short-float single-float double-float long-float) - for c across "SFDL" - when (subtypep 'short-float type) - nconc (list c (char-downcase c)))) - -(deftest print.short-float.3 - (let ((chars *possible-short-float-exponent-markers*)) - (loop for type in '(single-float double-float long-float) - nconc - (and (not (subtypep 'short-float type)) - (with-standard-io-syntax - (let ((*print-readably* nil) - (*read-default-float-format* type)) - (loop for i from -4000 to 4000 - for f = (float i 0.0s0) - for s1 = (with-output-to-string (s) (prin1 f s)) - for len1 = (length s1) - for s2 = (format nil "~A.0" i) - unless (and (> len1 4) - (string-equal s1 s2 :start1 0 :end1 (- len1 2)) - (eql (char s1 (- len1 1)) #\0) - (member (char s1 (- len1 2)) chars)) - collect (list type i f s1 s2))))))) - nil) - -(deftest print.short-float.4 - (let ((chars *possible-short-float-exponent-markers*)) - (loop for type in '(single-float double-float long-float) - nconc - (and (not (subtypep 'short-float type)) - (with-standard-io-syntax - (let ((*print-readably* nil) - (*read-default-float-format* type)) - (loop for i = (- (random 20000000) 10000000) - for f = (float i 0.0s0) - for s1 = (with-output-to-string (s) (prin1 f s)) - for len1 = (length s1) - for s2 = (format nil "~A.0" i) - repeat 10000 - unless (or (/= i (rational f)) ;; not enough bits - ;; (> (nth-value 1 (integer-decode-float f)) 0) - (and (> len1 4) - (string-equal s1 s2 :start1 0 :end1 (- len1 2)) - (eql (char s1 (- len1 1)) #\0) - (member (char s1 (- len1 2)) chars))) - collect (list type i f s1 s2))))))) - nil) - -(deftest print.short-float.random - (let ((lower-bound (if (< (log least-positive-short-float 10) -100) - (expt 0.1s0 100) - least-positive-short-float)) - (upper-bound (/ (if (> (log most-positive-short-float 10) 100) - (expt 10.0s0 100) - most-positive-short-float) - 10))) - (loop for sf = lower-bound then (* 10 sf) - while (< sf upper-bound) - nconc - (loop for x = (handler-case (random sf) (arithmetic-error (c) 0.0s0)) - for y = (if (coin) (- x) x) - repeat 10 - nconc (randomly-check-readability y)))) - nil) - -;;; single floats - -(deftest print.single-float.1 - (with-standard-io-syntax - (let ((*print-readably* nil) - (*read-default-float-format* 'single-float)) - (loop for i from -4000 to 4000 - for f = (float i 0.0f0) - for s1 = (with-output-to-string (s) (prin1 f s)) - for s2 = (format nil "~A.0" i) - unless (equalp s1 s2) - collect (list i f s1 s2)))) - nil) - -(deftest print.single-float.2 - (with-standard-io-syntax - (let ((*print-readably* nil) - (*read-default-float-format* 'single-float)) - (loop for i = (- (random 20000000) 10000000) - for f = (float i 0.0f0) - for s1 = (with-output-to-string (s) (prin1 f s)) - for s2 = (format nil "~A.0" i) - repeat 10000 - unless (or (/= i (rational f)) ;; not enough bits - ;; (> (nth-value 1 (integer-decode-float f)) 0) - (equalp s1 s2)) - collect (list i f s1 s2)))) - nil) - -(defparameter *possible-single-float-exponent-markers* - (loop for type in '(short-float single-float double-float long-float) - for c across "SFDL" - when (subtypep 'single-float type) - nconc (list c (char-downcase c)))) - -(deftest print.single-float.3 - (let ((chars *possible-single-float-exponent-markers*)) - (loop for type in '(short-float double-float long-float) - nconc - (and (not (subtypep 'single-float type)) - (with-standard-io-syntax - (let ((*print-readably* nil) - (*read-default-float-format* type)) - (loop for i from -4000 to 4000 - for f = (float i 0.0f0) - for s1 = (with-output-to-string (s) (prin1 f s)) - for len1 = (length s1) - for s2 = (format nil "~A.0" i) - unless (and (> len1 4) - (string-equal s1 s2 :start1 0 :end1 (- len1 2)) - (eql (char s1 (- len1 1)) #\0) - (member (char s1 (- len1 2)) chars)) - collect (list type i f s1 s2))))))) - nil) - -(deftest print.single-float.4 - (let ((chars *possible-single-float-exponent-markers*)) - (loop for type in '(short-float double-float long-float) - nconc - (and (not (subtypep 'single-float type)) - (with-standard-io-syntax - (let ((*print-readably* nil) - (*read-default-float-format* type)) - (loop for i = (- (random 20000000) 10000000) - for f = (float i 0.0f0) - for s1 = (with-output-to-string (s) (prin1 f s)) - for len1 = (length s1) - for s2 = (format nil "~A.0" i) - repeat 10000 - unless (or (/= i (rational f)) ;; not enough bits - ;; (> (nth-value 1 (integer-decode-float f)) 0) - (and (> len1 4) - (string-equal s1 s2 :start1 0 :end1 (- len1 2)) - (eql (char s1 (- len1 1)) #\0) - (member (char s1 (- len1 2)) chars))) - collect (list type i f s1 s2))))))) - nil) - -(deftest print.single-float.random - (let ((lower-bound (if (< (log least-positive-single-float 10) -100) - (expt 0.1f0 100) - least-positive-single-float)) - (upper-bound (/ (if (> (log most-positive-single-float 10) 100) - (expt 10.0f0 100) - most-positive-single-float) - 10))) - (loop for f = lower-bound then (* 10 f) - while (< f upper-bound) - nconc - (loop for x = (handler-case (random f) (arithmetic-error (c) 0.0f0)) - for y = (if (coin) (- x) x) - repeat 10 - nconc (randomly-check-readability y)))) - nil) - -;;; double float - -(deftest print.double-float.1 - (with-standard-io-syntax - (let ((*print-readably* nil) - (*read-default-float-format* 'double-float)) - (loop for i from -4000 to 4000 - for f = (float i 0.0d0) - for s1 = (with-output-to-string (s) (prin1 f s)) - for s2 = (format nil "~A.0" i) - unless (equalp s1 s2) - collect (list i f s1 s2)))) - nil) - -(deftest print.double-float.2 - (with-standard-io-syntax - (let ((*print-readably* nil) - (*read-default-float-format* 'double-float)) - (loop for i = (- (random 20000000) 10000000) - for f = (float i 0.0d0) - for s1 = (with-output-to-string (s) (prin1 f s)) - for s2 = (format nil "~A.0" i) - repeat 10000 - unless (or (/= i (rational f)) ;; not enough bits - ;; (> (nth-value 1 (integer-decode-float f)) 0) - (equalp s1 s2)) - collect (list i f s1 s2)))) - nil) - -(defparameter *possible-double-float-exponent-markers* - (loop for type in '(short-float single-float double-float long-float) - for c across "SFDL" - when (subtypep 'double-float type) - nconc (list c (char-downcase c)))) - -(deftest print.double-float.3 - (let ((chars *possible-double-float-exponent-markers*)) - (loop for type in '(short-float double-float long-float) - nconc - (and (not (subtypep 'double-float type)) - (with-standard-io-syntax - (let ((*print-readably* nil) - (*read-default-float-format* type)) - (loop for i from -4000 to 4000 - for f = (float i 0.0d0) - for s1 = (with-output-to-string (s) (prin1 f s)) - for len1 = (length s1) - for s2 = (format nil "~A.0" i) - unless (and (> len1 4) - (string-equal s1 s2 :start1 0 :end1 (- len1 2)) - (eql (char s1 (- len1 1)) #\0) - (member (char s1 (- len1 2)) chars)) - collect (list type i f s1 s2))))))) - nil) - -(deftest print.double-float.4 - (let ((chars *possible-double-float-exponent-markers*)) - (loop for type in '(short-float double-float long-float) - nconc - (and (not (subtypep 'double-float type)) - (with-standard-io-syntax - (let ((*print-readably* nil) - (*read-default-float-format* type)) - (loop for i = (- (random 20000000) 10000000) - for f = (float i 0.0d0) - for s1 = (with-output-to-string (s) (prin1 f s)) - for len1 = (length s1) - for s2 = (format nil "~A.0" i) - repeat 10000 - unless (or (/= i (rational f)) ;; not enough bits - ;; (> (nth-value 1 (integer-decode-float f)) 0) - (and (> len1 4) - (string-equal s1 s2 :start1 0 :end1 (- len1 2)) - (eql (char s1 (- len1 1)) #\0) - (member (char s1 (- len1 2)) chars))) - collect (list type i f s1 s2))))))) - nil) - -(deftest print.double-float.random - (let ((lower-bound (if (< (log least-positive-double-float 10) -100) - (expt 0.1d0 100) - least-positive-double-float)) - (upper-bound (/ (if (> (log most-positive-double-float 10) 100) - (expt 10.0d0 100) - most-positive-double-float) - 10))) - (loop for f = lower-bound then (* 10 f) - while (< f upper-bound) - nconc - (loop for x = (handler-case (random f) (arithmetic-error (c) 0.0d0)) - for y = (if (coin) (- x) x) - repeat 10 - nconc (randomly-check-readability y)))) - nil) - -;;; long float - -(deftest print.long-float.1 - (with-standard-io-syntax - (let ((*print-readably* nil) - (*read-default-float-format* 'long-float)) - (loop for i from -4000 to 4000 - for f = (float i 0.0l0) - for s1 = (with-output-to-string (s) (prin1 f s)) - for s2 = (format nil "~A.0" i) - unless (equalp s1 s2) - collect (list i f s1 s2)))) - nil) - -(deftest print.long-float.2 - (with-standard-io-syntax - (let ((*print-readably* nil) - (*read-default-float-format* 'long-float)) - (loop for i = (- (random 20000000) 10000000) - for f = (float i 0.0l0) - for s1 = (with-output-to-string (s) (prin1 f s)) - for s2 = (format nil "~A.0" i) - repeat 10000 - unless (or (/= i (rational f)) ;; not enough bits - ;; (> (nth-value 1 (integer-decode-float f)) 0) - (equalp s1 s2)) - collect (list i f s1 s2)))) - nil) - -(defparameter *possible-long-float-exponent-markers* - (loop for type in '(short-float single-float double-float long-float) - for c across "SFDL" - when (subtypep 'long-float type) - nconc (list c (char-downcase c)))) - -(deftest print.long-float.3 - (let ((chars *possible-long-float-exponent-markers*)) - (loop for type in '(short-float double-float long-float) - nconc - (and (not (subtypep 'long-float type)) - (with-standard-io-syntax - (let ((*print-readably* nil) - (*read-default-float-format* type)) - (loop for i from -4000 to 4000 - for f = (float i 0.0l0) - for s1 = (with-output-to-string (s) (prin1 f s)) - for len1 = (length s1) - for s2 = (format nil "~A.0" i) - unless (and (> len1 4) - (string-equal s1 s2 :start1 0 :end1 (- len1 2)) - (eql (char s1 (- len1 1)) #\0) - (member (char s1 (- len1 2)) chars)) - collect (list type i f s1 s2))))))) - nil) - -(deftest print.long-float.4 - (let ((chars *possible-long-float-exponent-markers*)) - (loop for type in '(short-float double-float long-float) - nconc - (and (not (subtypep 'long-float type)) - (with-standard-io-syntax - (let ((*print-readably* nil) - (*read-default-float-format* type)) - (loop for i = (- (random 20000000) 10000000) - for f = (float i 0.0l0) - for s1 = (with-output-to-string (s) (prin1 f s)) - for len1 = (length s1) - for s2 = (format nil "~A.0" i) - repeat 10000 - unless (or (/= i (rational f)) ;; not enough bits - ;; (> (nth-value 1 (integer-decode-float f)) 0) - (and (> len1 4) - (string-equal s1 s2 :start1 0 :end1 (- len1 2)) - (eql (char s1 (- len1 1)) #\0) - (member (char s1 (- len1 2)) chars))) - collect (list type i f s1 s2))))))) - nil) - -(deftest print.long-float.random - (let ((lower-bound (if (< (log least-positive-long-float 10) -100) - (expt 0.1l0 100) - least-positive-long-float)) - (upper-bound (/ (if (> (log most-positive-long-float 10) 100) - (expt 10.0l0 100) - most-positive-long-float) - 10))) - (loop for f = lower-bound then (* 10 f) - while (< f upper-bound) - nconc - (loop for x = (handler-case (random f) (arithmetic-error (c) 0.0l0)) - for y = (if (coin) (- x) x) - repeat 10 - nconc (randomly-check-readability y)))) - nil) diff --git a/t/ansi-test/printer/print-integers.lsp b/t/ansi-test/printer/print-integers.lsp deleted file mode 100644 index b6eaf89..0000000 --- a/t/ansi-test/printer/print-integers.lsp +++ /dev/null @@ -1,327 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Feb 23 06:26:25 2004 -;;;; Contains: Printing tests for integers - -(in-package :cl-test) - - - -;;; Tests with *print-base* - -(def-print-test print.integers.1 1 "1") -(def-print-test print.integers.2 2 "2") -(def-print-test print.integers.3 3 "3") -(def-print-test print.integers.4 4 "4") -(def-print-test print.integers.5 5 "5") -(def-print-test print.integers.6 6 "6") -(def-print-test print.integers.7 7 "7") -(def-print-test print.integers.8 8 "8") -(def-print-test print.integers.9 9 "9") - -(def-print-test print.integers.10 -0 "0") -(def-print-test print.integers.11 -1 "-1") -(def-print-test print.integers.12 -2 "-2") -(def-print-test print.integers.13 -3 "-3") -(def-print-test print.integers.14 -4 "-4") -(def-print-test print.integers.15 -5 "-5") -(def-print-test print.integers.16 -6 "-6") -(def-print-test print.integers.17 -7 "-7") -(def-print-test print.integers.18 -8 "-8") -(def-print-test print.integers.19 -9 "-9") - -(def-print-test print.integers.20 (expt 10 20) "100000000000000000000") -(def-print-test print.integers.21 (- (expt 10 20)) "-100000000000000000000") - -(def-print-test print.integers.base.2.0 0 "0" (*print-base* 2)) -(def-print-test print.integers.base.2.1 1 "1" (*print-base* 2)) -(def-print-test print.integers.base.2.2 2 "10" (*print-base* 2)) -(def-print-test print.integers.base.2.3 3 "11" (*print-base* 2)) -(def-print-test print.integers.base.2.4 -1 "-1" (*print-base* 2)) -(def-print-test print.integers.base.2.5 -2 "-10" (*print-base* 2)) -(def-print-test print.integers.base.2.6 -3 "-11" (*print-base* 2)) -(def-print-test print.integers.base.2.7 255 "11111111" (*print-base* 2)) -(def-print-test print.integers.base.2.8 -252 "-11111100" (*print-base* 2)) -(def-print-test print.integers.base.2.9 (expt 2 40) - "10000000000000000000000000000000000000000" (*print-base* 2)) -(def-print-test print.integers.base.2.10 (- (expt 2 40)) - "-10000000000000000000000000000000000000000" (*print-base* 2)) - -(def-print-test print.integers.base.3.0 0 "0" (*print-base* 3)) -(def-print-test print.integers.base.3.1 1 "1" (*print-base* 3)) -(def-print-test print.integers.base.3.2 2 "2" (*print-base* 3)) -(def-print-test print.integers.base.3.3 3 "10" (*print-base* 3)) -(def-print-test print.integers.base.3.4 -1 "-1" (*print-base* 3)) -(def-print-test print.integers.base.3.5 -2 "-2" (*print-base* 3)) -(def-print-test print.integers.base.3.6 -3 "-10" (*print-base* 3)) -(def-print-test print.integers.base.3.7 80 "2222" (*print-base* 3)) -(def-print-test print.integers.base.3.8 -78 "-2220" (*print-base* 3)) -(def-print-test print.integers.base.3.9 (expt 3 40) - "10000000000000000000000000000000000000000" (*print-base* 3)) -(def-print-test print.integers.base.3.10 (- (expt 3 40)) - "-10000000000000000000000000000000000000000" (*print-base* 3)) - -(def-print-test print.integers.base.4.0 0 "0" (*print-base* 4)) -(def-print-test print.integers.base.4.1 1 "1" (*print-base* 4)) -(def-print-test print.integers.base.4.2 2 "2" (*print-base* 4)) -(def-print-test print.integers.base.4.3 3 "3" (*print-base* 4)) -(def-print-test print.integers.base.4.4 4 "10" (*print-base* 4)) -(def-print-test print.integers.base.4.5 5 "11" (*print-base* 4)) -(def-print-test print.integers.base.4.6 -1 "-1" (*print-base* 4)) -(def-print-test print.integers.base.4.7 -2 "-2" (*print-base* 4)) -(def-print-test print.integers.base.4.8 -3 "-3" (*print-base* 4)) -(def-print-test print.integers.base.4.9 -4 "-10" (*print-base* 4)) -(def-print-test print.integers.base.4.10 -5 "-11" (*print-base* 4)) -(def-print-test print.integers.base.4.11 255 "3333" (*print-base* 4)) -(def-print-test print.integers.base.4.12 -255 "-3333" (*print-base* 4)) -(def-print-test print.integers.base.4.13 (expt 4 40) - "10000000000000000000000000000000000000000" (*print-base* 4)) -(def-print-test print.integers.base.4.14 (- (expt 4 40)) - "-10000000000000000000000000000000000000000" (*print-base* 4)) - -(def-print-test print.integers.base.7.0 0 "0" (*print-base* 7)) -(def-print-test print.integers.base.7.1 1 "1" (*print-base* 7)) -(def-print-test print.integers.base.7.2 2 "2" (*print-base* 7)) -(def-print-test print.integers.base.7.3 16 "22" (*print-base* 7)) -(def-print-test print.integers.base.7.4 66 "123" (*print-base* 7)) -(def-print-test print.integers.base.7.5 -1 "-1" (*print-base* 7)) -(def-print-test print.integers.base.7.6 -7 "-10" (*print-base* 7)) -(def-print-test print.integers.base.7.7 -48 "-66" (*print-base* 7)) -(def-print-test print.integers.base.7.8 (expt 7 40) - "10000000000000000000000000000000000000000" (*print-base* 7)) -(def-print-test print.integers.base.7.9 (- (expt 7 40)) - "-10000000000000000000000000000000000000000" (*print-base* 7)) - -(def-print-test print.integers.base.11.0 0 "0" (*print-base* 11)) -(def-print-test print.integers.base.11.1 1 "1" (*print-base* 11)) -(def-print-test print.integers.base.11.2 2 "2" (*print-base* 11)) -(def-print-test print.integers.base.11.3 10 "A" (*print-base* 11)) -(def-print-test print.integers.base.11.4 11 "10" (*print-base* 11)) -(def-print-test print.integers.base.11.5 121 "100" (*print-base* 11)) -(def-print-test print.integers.base.11.6 -1 "-1" (*print-base* 11)) -(def-print-test print.integers.base.11.7 -10 "-A" (*print-base* 11)) -(def-print-test print.integers.base.11.8 -21 "-1A" (*print-base* 11)) -(def-print-test print.integers.base.11.9 -110 "-A0" (*print-base* 11)) -(def-print-test print.integers.base.11.10 (expt 11 40) - "10000000000000000000000000000000000000000" (*print-base* 11)) -(def-print-test print.integers.base.11.11 (- (expt 11 40)) - "-10000000000000000000000000000000000000000" (*print-base* 11)) - -(def-print-test print.integers.base.16.0 0 "0" (*print-base* 16)) -(def-print-test print.integers.base.16.1 1 "1" (*print-base* 16)) -(def-print-test print.integers.base.16.2 2 "2" (*print-base* 16)) -(def-print-test print.integers.base.16.3 12 "C" (*print-base* 16)) -(def-print-test print.integers.base.16.4 17 "11" (*print-base* 16)) -(def-print-test print.integers.base.16.5 256 "100" (*print-base* 16)) -(def-print-test print.integers.base.16.6 -1 "-1" (*print-base* 16)) -(def-print-test print.integers.base.16.7 -14 "-E" (*print-base* 16)) -(def-print-test print.integers.base.16.8 -30 "-1E" (*print-base* 16)) -(def-print-test print.integers.base.16.9 -208 "-D0" (*print-base* 16)) -(def-print-test print.integers.base.16.10 (expt 16 40) - "10000000000000000000000000000000000000000" (*print-base* 16)) -(def-print-test print.integers.base.16.11 (- (expt 16 40)) - "-10000000000000000000000000000000000000000" (*print-base* 16)) - -(def-print-test print.integers.base.36.0 0 "0" (*print-base* 36)) -(def-print-test print.integers.base.36.1 1 "1" (*print-base* 36)) -(def-print-test print.integers.base.36.2 2 "2" (*print-base* 36)) -(def-print-test print.integers.base.36.3 12 "C" (*print-base* 36)) -(def-print-test print.integers.base.36.4 37 "11" (*print-base* 36)) -(def-print-test print.integers.base.36.5 (* 36 36) "100" (*print-base* 36)) -(def-print-test print.integers.base.36.6 -1 "-1" (*print-base* 36)) -(def-print-test print.integers.base.36.7 -14 "-E" (*print-base* 36)) -(def-print-test print.integers.base.36.8 -35 "-Z" (*print-base* 36)) -(def-print-test print.integers.base.36.9 -37 "-11" (*print-base* 36)) -(def-print-test print.integers.base.36.10 (- 2 (* 36 36)) "-ZY" (*print-base* 36)) -(def-print-test print.integers.base.36.11 (expt 36 40) - "10000000000000000000000000000000000000000" (*print-base* 36)) -(def-print-test print.integers.base.36.12 (- (expt 36 40)) - "-10000000000000000000000000000000000000000" (*print-base* 36)) - -;;; With *print-radix* - -(def-print-test print.integers.radix.0 0 "0." (*print-radix* t)) -(def-print-test print.integers.radix.1 1 "1." (*print-radix* t)) -(def-print-test print.integers.radix.2 123456 "123456." (*print-radix* t)) -(def-print-test print.integers.radix.3 123456789 "123456789." (*print-radix* t)) -(def-print-test print.integers.radix.4 -5 "-5." (*print-radix* t)) -(def-print-test print.integers.radix.5 -249213 "-249213." (*print-radix* t)) -(def-print-test print.integers.radix.6 -917512001 "-917512001." (*print-radix* t)) - -(def-print-test print.integers.radix.base.2.0 0 "#b0" (*print-radix* t) (*print-base* 2)) -(def-print-test print.integers.radix.base.2.1 1 "#b1" (*print-radix* t) (*print-base* 2)) -(def-print-test print.integers.radix.base.2.2 2 "#b10" (*print-radix* t) (*print-base* 2)) -(def-print-test print.integers.radix.base.2.3 3 "#b11" (*print-radix* t) (*print-base* 2)) -(def-print-test print.integers.radix.base.2.4 -1 "#b-1" (*print-radix* t) (*print-base* 2)) -(def-print-test print.integers.radix.base.2.5 -2 "#b-10" (*print-radix* t) (*print-base* 2)) -(def-print-test print.integers.radix.base.2.6 -3 "#b-11" (*print-radix* t) (*print-base* 2)) -(def-print-test print.integers.radix.base.2.7 256 "#b100000000" (*print-radix* t) (*print-base* 2)) -(def-print-test print.integers.radix.base.2.8 -256 "#b-100000000" (*print-radix* t) (*print-base* 2)) -(def-print-test print.integers.radix.base.2.9 (expt 2 100) - (concatenate 'string "#b1" (make-string 100 :initial-element #\0)) - (*print-radix* t) (*print-base* 2)) -(def-print-test print.integers.radix.base.2.10 (- (expt 2 200)) - (concatenate 'string "#b-1" (make-string 200 :initial-element #\0)) - (*print-radix* t) (*print-base* 2)) - -(def-print-test print.integers.radix.base.3.0 0 "#3r0" (*print-radix* t) (*print-base* 3)) -(def-print-test print.integers.radix.base.3.1 1 "#3r1" (*print-radix* t) (*print-base* 3)) -(def-print-test print.integers.radix.base.3.2 2 "#3r2" (*print-radix* t) (*print-base* 3)) -(def-print-test print.integers.radix.base.3.3 4 "#3r11" (*print-radix* t) (*print-base* 3)) -(def-print-test print.integers.radix.base.3.4 -1 "#3r-1" (*print-radix* t) (*print-base* 3)) -(def-print-test print.integers.radix.base.3.5 -2 "#3r-2" (*print-radix* t) (*print-base* 3)) -(def-print-test print.integers.radix.base.3.6 -4 "#3r-11" (*print-radix* t) (*print-base* 3)) -(def-print-test print.integers.radix.base.3.7 6561 "#3r100000000" (*print-radix* t) (*print-base* 3)) -(def-print-test print.integers.radix.base.3.8 -81 "#3r-10000" (*print-radix* t) (*print-base* 3)) -(def-print-test print.integers.radix.base.3.9 (expt 3 100) - (concatenate 'string "#3r1" (make-string 100 :initial-element #\0)) - (*print-radix* t) (*print-base* 3)) -(def-print-test print.integers.radix.base.3.10 (- 1 (expt 3 200)) - (concatenate 'string "#3r-" (make-string 200 :initial-element #\2)) - (*print-radix* t) (*print-base* 3)) - -(def-print-test print.integers.radix.base.5.0 0 "#5r0" (*print-radix* t) (*print-base* 5)) -(def-print-test print.integers.radix.base.5.1 1 "#5r1" (*print-radix* t) (*print-base* 5)) -(def-print-test print.integers.radix.base.5.2 2 "#5r2" (*print-radix* t) (*print-base* 5)) -(def-print-test print.integers.radix.base.5.3 6 "#5r11" (*print-radix* t) (*print-base* 5)) -(def-print-test print.integers.radix.base.5.4 -1 "#5r-1" (*print-radix* t) (*print-base* 5)) -(def-print-test print.integers.radix.base.5.5 -2 "#5r-2" (*print-radix* t) (*print-base* 5)) -(def-print-test print.integers.radix.base.5.6 -8 "#5r-13" (*print-radix* t) (*print-base* 5)) -(def-print-test print.integers.radix.base.5.7 390625 "#5r100000000" (*print-radix* t) (*print-base* 5)) -(def-print-test print.integers.radix.base.5.8 -625 "#5r-10000" (*print-radix* t) (*print-base* 5)) -(def-print-test print.integers.radix.base.5.9 (expt 5 100) - (concatenate 'string "#5r1" (make-string 100 :initial-element #\0)) - (*print-radix* t) (*print-base* 5)) -(def-print-test print.integers.radix.base.5.10 (- 1 (expt 5 200)) - (concatenate 'string "#5r-" (make-string 200 :initial-element #\4)) - (*print-radix* t) (*print-base* 5)) - -(def-print-test print.integers.radix.base.8.0 0 "#o0" (*print-radix* t) (*print-base* 8)) -(def-print-test print.integers.radix.base.8.1 1 "#o1" (*print-radix* t) (*print-base* 8)) -(def-print-test print.integers.radix.base.8.2 2 "#o2" (*print-radix* t) (*print-base* 8)) -(def-print-test print.integers.radix.base.8.3 9 "#o11" (*print-radix* t) (*print-base* 8)) -(def-print-test print.integers.radix.base.8.4 -1 "#o-1" (*print-radix* t) (*print-base* 8)) -(def-print-test print.integers.radix.base.8.5 -2 "#o-2" (*print-radix* t) (*print-base* 8)) -(def-print-test print.integers.radix.base.8.6 -11 "#o-13" (*print-radix* t) (*print-base* 8)) -(def-print-test print.integers.radix.base.8.7 16777216 "#o100000000" (*print-radix* t) (*print-base* 8)) -(def-print-test print.integers.radix.base.8.8 -4096 "#o-10000" (*print-radix* t) (*print-base* 8)) -(def-print-test print.integers.radix.base.8.9 (expt 8 100) - (concatenate 'string "#o1" (make-string 100 :initial-element #\0)) - (*print-radix* t) (*print-base* 8)) -(def-print-test print.integers.radix.base.8.10 (- 1 (expt 8 200)) - (concatenate 'string "#o-" (make-string 200 :initial-element #\7)) - (*print-radix* t) (*print-base* 8)) - -(def-print-test print.integers.radix.base.12.0 0 "#12r0" (*print-radix* t) (*print-base* 12)) -(def-print-test print.integers.radix.base.12.1 1 "#12r1" (*print-radix* t) (*print-base* 12)) -(def-print-test print.integers.radix.base.12.2 2 "#12r2" (*print-radix* t) (*print-base* 12)) -(def-print-test print.integers.radix.base.12.3 13 "#12r11" (*print-radix* t) (*print-base* 12)) -(def-print-test print.integers.radix.base.12.4 -1 "#12r-1" (*print-radix* t) (*print-base* 12)) -(def-print-test print.integers.radix.base.12.5 -2 "#12r-2" (*print-radix* t) (*print-base* 12)) -(def-print-test print.integers.radix.base.12.6 -15 "#12r-13" (*print-radix* t) (*print-base* 12)) -(def-print-test print.integers.radix.base.12.7 (expt 12 8) - "#12r100000000" (*print-radix* t) (*print-base* 12)) -(def-print-test print.integers.radix.base.12.8 (- (* 12 12 12 12)) - "#12r-10000" (*print-radix* t) (*print-base* 12)) -(def-print-test print.integers.radix.base.12.9 (expt 12 100) - (concatenate 'string "#12r1" (make-string 100 :initial-element #\0)) - (*print-radix* t) (*print-base* 12)) -(def-print-test print.integers.radix.base.12.10 (- 1 (expt 12 200)) - (concatenate 'string "#12r-" (make-string 200 :initial-element #\B)) - (*print-radix* t) (*print-base* 12)) - -(def-print-test print.integers.radix.base.16.0 0 "#x0" (*print-radix* t) (*print-base* 16)) -(def-print-test print.integers.radix.base.16.1 1 "#x1" (*print-radix* t) (*print-base* 16)) -(def-print-test print.integers.radix.base.16.2 2 "#x2" (*print-radix* t) (*print-base* 16)) -(def-print-test print.integers.radix.base.16.3 17 "#x11" (*print-radix* t) (*print-base* 16)) -(def-print-test print.integers.radix.base.16.4 -1 "#x-1" (*print-radix* t) (*print-base* 16)) -(def-print-test print.integers.radix.base.16.5 -2 "#x-2" (*print-radix* t) (*print-base* 16)) -(def-print-test print.integers.radix.base.16.6 -19 "#x-13" (*print-radix* t) (*print-base* 16)) -(def-print-test print.integers.radix.base.16.7 (expt 16 8) - "#x100000000" (*print-radix* t) (*print-base* 16)) -(def-print-test print.integers.radix.base.16.8 (- (* 16 16 16 16)) - "#x-10000" (*print-radix* t) (*print-base* 16)) -(def-print-test print.integers.radix.base.16.9 (expt 16 100) - (concatenate 'string "#x1" (make-string 100 :initial-element #\0)) - (*print-radix* t) (*print-base* 16)) -(def-print-test print.integers.radix.base.16.10 (- 1 (expt 16 200)) - (concatenate 'string "#x-" (make-string 200 :initial-element #\F)) - (*print-radix* t) (*print-base* 16)) - -(def-print-test print.integers.radix.base.36.0 0 "#36r0" (*print-radix* t) (*print-base* 36)) -(def-print-test print.integers.radix.base.36.1 1 "#36r1" (*print-radix* t) (*print-base* 36)) -(def-print-test print.integers.radix.base.36.2 2 "#36r2" (*print-radix* t) (*print-base* 36)) -(def-print-test print.integers.radix.base.36.3 37 "#36r11" (*print-radix* t) (*print-base* 36)) -(def-print-test print.integers.radix.base.36.4 -1 "#36r-1" (*print-radix* t) (*print-base* 36)) -(def-print-test print.integers.radix.base.36.5 -2 "#36r-2" (*print-radix* t) (*print-base* 36)) -(def-print-test print.integers.radix.base.36.6 -39 "#36r-13" (*print-radix* t) (*print-base* 36)) -(def-print-test print.integers.radix.base.36.7 (expt 36 8) - "#36r100000000" (*print-radix* t) (*print-base* 36)) -(def-print-test print.integers.radix.base.36.8 (- (* 36 36 36 36)) - "#36r-10000" (*print-radix* t) (*print-base* 36)) -(def-print-test print.integers.radix.base.36.9 (expt 36 100) - (concatenate 'string "#36r1" (make-string 100 :initial-element #\0)) - (*print-radix* t) (*print-base* 36)) -(def-print-test print.integers.radix.base.36.10 (- 1 (expt 36 200)) - (concatenate 'string "#36r-" (make-string 200 :initial-element #\Z)) - (*print-radix* t) (*print-base* 36)) - -(deftest print.integers.base.various.1 - (with-standard-io-syntax - (loop for b from 2 to 36 - nconc - (let ((*print-base* b) (*read-base* b)) - (loop for i from 1 to 100 - for n = (expt b i) - for str = (with-output-to-string (s) (prin1 n s)) - for result = (read-from-string str) - unless (= n result) - collect (list b i n str result))))) - nil) - -(deftest print.integers.base.various.2 - (with-standard-io-syntax - (loop for b from 2 to 36 - nconc - (let ((*print-base* b) (*read-base* b)) - (loop for i from 1 to 100 - for n = (- (expt b i)) - for str = (with-output-to-string (s) (prin1 n s)) - for result = (read-from-string str) - unless (= n result) - collect (list b i n str result))))) - nil) - -(deftest print.integers.base.various.3 - (with-standard-io-syntax - (loop for b from 2 to 36 - nconc - (let ((*print-base* b) (*read-base* b) (*print-radix* t)) - (loop for i from 1 to 100 - for n = (expt b i) - for str = (with-output-to-string (s) (prin1 n s)) - for result = (read-from-string str) - unless (= n result) - collect (list b i n str result))))) - nil) - -(deftest print.integers.base.various.4 - (with-standard-io-syntax - (loop for b from 2 to 36 - nconc - (let ((*print-base* b) (*read-base* b) (*print-radix* t)) - (loop for i from 1 to 100 - for n = (- (expt b i)) - for str = (with-output-to-string (s) (prin1 n s)) - for result = (read-from-string str) - unless (= n result) - collect (list b i n str result))))) - nil) - -(deftest print.integers.random.1 - (loop for numbits = (random 40) - for bound = (ash 1 numbits) - for r = (- (random (+ bound bound)) bound) - repeat 10000 - nconc (randomly-check-readability r)) - nil) diff --git a/t/ansi-test/printer/print-length.lsp b/t/ansi-test/printer/print-length.lsp deleted file mode 100644 index 4b65e39..0000000 --- a/t/ansi-test/printer/print-length.lsp +++ /dev/null @@ -1,147 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Jul 27 08:27:37 2004 -;;;; Contains: Tests involving *PRINT-LENGTH* - -(in-package :cl-test) - - - -(def-print-test print-length.1 - '(1) - "(...)" - (*print-length* 0)) - -(def-print-test print-length.2 - '(1) - "(1)" - (*print-length* nil)) - -(def-print-test print-length.3 - '(1) - "(1)" - (*print-length* 1)) - -(def-print-test print-length.4 - '(1 . 2) - "(1 . 2)" - (*print-length* 1)) - -(deftest print-length.5 - (let ((x '(|A| |B| |C| |D| |E| |F|))) - (with-standard-io-syntax - (let ((*print-case* :upcase) - (*print-escape* nil) - (*print-readably* nil) - (*print-pretty* nil) - (*print-length* nil)) - (apply - #'values - (loop for i from 0 to 8 - collect (let ((*print-length* i)) - (write-to-string x))))))) - "(...)" - "(A ...)" - "(A B ...)" - "(A B C ...)" - "(A B C D ...)" - "(A B C D E ...)" - "(A B C D E F)" - "(A B C D E F)" - "(A B C D E F)") - -(deftest print-length.6 - (let ((x '(|A| |B| |C| |D| |E| |F| . |G|))) - (with-standard-io-syntax - (let ((*print-case* :upcase) - (*print-escape* nil) - (*print-readably* nil) - (*print-pretty* nil) - (*print-length* nil)) - (apply - #'values - (loop for i from 0 to 8 - collect (let ((*print-length* i)) - (write-to-string x))))))) - "(...)" - "(A ...)" - "(A B ...)" - "(A B C ...)" - "(A B C D ...)" - "(A B C D E ...)" - "(A B C D E F . G)" - "(A B C D E F . G)" - "(A B C D E F . G)") - -(def-print-test print-length.7 - '(1) - "(1)" - (*print-length* (1+ most-positive-fixnum))) - -(deftest print-length.8 - (let ((x #(|A| |B| |C| |D| |E| |F|))) - (with-standard-io-syntax - (let ((*print-case* :upcase) - (*print-escape* nil) - (*print-readably* nil) - (*print-pretty* nil) - (*print-length* nil)) - (apply - #'values - (loop for i from 0 to 8 - collect (let ((*print-length* i)) - (write-to-string x))))))) - "#(...)" - "#(A ...)" - "#(A B ...)" - "#(A B C ...)" - "#(A B C D ...)" - "#(A B C D E ...)" - "#(A B C D E F)" - "#(A B C D E F)" - "#(A B C D E F)") - -(def-print-test print-length.9 - "A modest sentence with six words." - "\"A modest sentence with six words.\"" - (*print-length* 0)) - -(def-print-test print-length.10 - #*00110101100011 - "#*00110101100011" - (*print-length* 0)) - -(defstruct print-length-struct foo) - -;;; The next test tacitly assumes issue STRUCTURE-READ-PRINT-SYNTAX - -(deftest print-length.11 - (let ((result - (with-standard-io-syntax - (let ((*print-case* :upcase) - (*print-escape* nil) - (*print-readably* nil) - (*print-pretty* nil) - (*print-length* nil) - (*package* (find-package "CL-TEST")) - (s (make-print-length-struct :foo 17))) - (apply - #'list - (loop for i from 0 to 4 - collect (let ((*print-length* i)) - (write-to-string s)))))))) - (if (member result - '(("#S(...)" - "#S(PRINT-LENGTH-STRUCT ...)" - "#S(PRINT-LENGTH-STRUCT :FOO ...)" - "#S(PRINT-LENGTH-STRUCT :FOO 17)" - "#S(PRINT-LENGTH-STRUCT :FOO 17)") - ("#S(PRINT-LENGTH-STRUCT ...)" - "#S(PRINT-LENGTH-STRUCT :FOO 17)" - "#S(PRINT-LENGTH-STRUCT :FOO 17)" - "#S(PRINT-LENGTH-STRUCT :FOO 17)" - "#S(PRINT-LENGTH-STRUCT :FOO 17)")) - :test 'equal) - :good - result)) - :good) diff --git a/t/ansi-test/printer/print-level.lsp b/t/ansi-test/printer/print-level.lsp deleted file mode 100644 index 4e7721f..0000000 --- a/t/ansi-test/printer/print-level.lsp +++ /dev/null @@ -1,135 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Jul 26 13:07:51 2004 -;;;; Contains: Tests of binding the *PRINT-LEVEL* variable - -(in-package :cl-test) - - - -#| -(deftest print-level.1 - (with-standard-io-syntax - (let ((*print-readably* nil)) - (loop for x in *mini-universe* - for s1 = (write-to-string x) - for s2 = (let ((*print-level* 0)) (write-to-string x)) - when (and (or (consp x) - (and (arrayp x) - (not (stringp x)) - (not (typep x 'bit-vector))) - (typep (class-of x) 'structure-class)) - (not (string= s2 "#"))) - collect (list x s1 s2)))) - nil) -|# - -(defclass print-level-test-class nil (a b c)) - -;;; The CLHS page for PRINT-OBJECT makes it clear that tests -;;; PRINT-LEVEL.2,6,7,10,11 were testing for implementation-dependent -;;; behavior. They have been commented out. - -#| -(deftest print-level.2 - (with-standard-io-syntax - (write-to-string (make-instance 'print-level-test-class) - :level 0 - :readably nil)) - "#") -|# - -(deftest print-level.3 - (with-standard-io-syntax - (write-to-string (make-array '(4) :initial-contents '(a b c d)) - :readably nil - :array t - :level 0)) - "#") - -(deftest print-level.4 - (with-standard-io-syntax - (write-to-string (make-array '(4) :initial-contents '(1 1 0 1) - :element-type 'bit) - :readably nil - :array t - :level 0)) - "#*1101") - -(deftest print-level.5 - (with-standard-io-syntax - (write-to-string "abcd" - :readably nil - :array t - :level 0)) - "\"abcd\"") - -(define-condition print-level-condition (condition) (a b c)) - -#| -(deftest print-level.6 - (with-standard-io-syntax - (write-to-string (make-condition 'print-level-condition) - :level 0 :pretty nil :readably nil)) - "#") - -(deftest print-level.7 - (with-standard-io-syntax - (write-to-string (make-condition 'print-level-condition) - :level 0 :pretty t :readably nil)) - "#") -|# - -(defstruct print-level-struct) - -(deftest print-level.8 - (with-standard-io-syntax - (let* ((*package* (find-package "CL-TEST")) - (*print-pretty* nil) - (s (make-print-level-struct))) - (values - (write-to-string s :level 0 :readably nil) - (write-to-string s :level 1 :readably nil) - (write-to-string s :level nil :readably nil)))) - ;; sds: consistency with PRINT-LEVEL.3 requires "#" as the 1st value - "#" - "#S(PRINT-LEVEL-STRUCT)" - "#S(PRINT-LEVEL-STRUCT)") - -(deftest print-level.9 - (with-standard-io-syntax - (let* ((*package* (find-package "CL-TEST")) - (*print-pretty* t) - (s (make-print-level-struct))) - (values - (write-to-string s :level 0 :readably nil) - (write-to-string s :level 1 :readably nil) - (write-to-string s :level nil :readably nil)))) - ;; sds: consistency with PRINT-LEVEL.3 requires "#" as the 1st value - "#" - "#S(PRINT-LEVEL-STRUCT)" - "#S(PRINT-LEVEL-STRUCT)") - -(defstruct print-level-struct2 a b c) - -#| -(deftest print-level.10 - (with-standard-io-syntax - (let ((*package* (find-package "CL-TEST"))) - (write-to-string (make-print-level-struct2) - :level 0 :pretty nil :readably nil))) - "#") - -(deftest print-level.11 - (with-standard-io-syntax - (let ((*package* (find-package "CL-TEST"))) - (write-to-string (make-print-level-struct2) - :level 0 :pretty t :readably nil))) - "#") -|# - -(deftest print-level.12 - (with-standard-io-syntax - (let ((*print-level* (1+ most-positive-fixnum))) - (write-to-string '((1 2) (3 4)) :pretty nil :readably nil))) - "((1 2) (3 4))") diff --git a/t/ansi-test/printer/print-lines.lsp b/t/ansi-test/printer/print-lines.lsp deleted file mode 100644 index 8e7da38..0000000 --- a/t/ansi-test/printer/print-lines.lsp +++ /dev/null @@ -1,44 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Jul 27 09:32:46 2004 -;;;; Contains: Tests involving PRINT-LINES - -(deftest print-lines.1 - *print-lines* - nil) - -;; original test had different expected values, but print margin is in -;; ems and I think there is no definite anwer what this should print. -#+(or) -(deftest print-lines.2 - (with-standard-io-syntax - (let ((*print-lines* 1) - (*print-readably* nil) - (*print-miser-width* nil) - (*print-pprint-dispatch* (copy-pprint-dispatch))) - (set-pprint-dispatch '(cons (eql 1) t) 'pprint-fill) - (apply - #'values - (loop - for i from 1 to 10 - for s in '("(1 ..)" - "(1 ..)" - "(1 ..)" - "(1 ..)" - "(1 2 ..)" - "(1 2 ..)" - "(1 2 3 ..)" - "(1 2 3 ..)" - "(1 2 3 4 ..)" - "(1 2 3 4 ..)") - collect - (let ((result - (let ((*print-right-margin* i)) - (subseq - (with-output-to-string (*standard-output*) - (terpri) - (pprint '(1 2 3 4 5 6 7 8 9))) - 2)))) - (or (equal s result) - (list s result))))))) - T T T T T T T T T T) diff --git a/t/ansi-test/printer/print-pathname.lsp b/t/ansi-test/printer/print-pathname.lsp deleted file mode 100644 index ee3f46a..0000000 --- a/t/ansi-test/printer/print-pathname.lsp +++ /dev/null @@ -1,35 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue May 25 08:22:03 2004 -;;;; Contains: Printer tests for pathnames - -(in-package :cl-test) - - - -(deftest print.pathname.1 - (loop for p in *universe* - when (typep p 'pathname) - nconc - (loop repeat 10 - nconc (randomly-check-readability p :test #'is-similar - :can-fail t))) - nil) - -(deftest print.pathname.2 - (loop for p in *universe* - when (typep p 'pathname) - nconc - (let ((ns (ignore-errors (namestring p)))) - "Read 22.1.3.11 before commenting on this test" - (when ns - (let ((expected-result - (concatenate 'string "#P" - (with-standard-io-syntax - (write-to-string ns :readably nil - :escape t)))) - (result (with-standard-io-syntax - (write-to-string p :readably nil :escape t)))) - (unless (string= expected-result result) - (list (list expected-result result))))))) - nil) diff --git a/t/ansi-test/printer/print-random-state.lsp b/t/ansi-test/printer/print-random-state.lsp deleted file mode 100644 index 2ad5533..0000000 --- a/t/ansi-test/printer/print-random-state.lsp +++ /dev/null @@ -1,21 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue May 25 07:15:02 2004 -;;;; Contains: Tests of printing random states - -(in-package :cl-test) - - - -(deftest print.random-state.1 - (loop repeat 100 - do (loop repeat 50 do (random 1000)) - nconc - (let* ((rs1 (make-random-state *random-state*)) - (rs2 (with-standard-io-syntax - (read-from-string - (write-to-string rs1 :readably t)))) - (result (list (notnot (random-state-p rs2)) - (is-similar rs1 rs2)))) - (unless (equal result '(t t)) (list result rs1 rs2)))) - nil) diff --git a/t/ansi-test/printer/print-ratios.lsp b/t/ansi-test/printer/print-ratios.lsp deleted file mode 100644 index b420f4f..0000000 --- a/t/ansi-test/printer/print-ratios.lsp +++ /dev/null @@ -1,19 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Mar 1 22:03:58 2004 -;;;; Contains: Tests for printing ratios - -(in-package :cl-test) - - - -(deftest print.ratios.random - (loop for i from 1 to 1000 - for numbits = (1+ (random 40)) - for bound = (ash 1 numbits) - for num = (- (random (+ bound bound)) bound) - for denom = (1+ (random bound)) - for r = (/ num denom) - nconc (randomly-check-readability r)) - nil) - diff --git a/t/ansi-test/printer/print-strings.lsp b/t/ansi-test/printer/print-strings.lsp deleted file mode 100644 index f299e5d..0000000 --- a/t/ansi-test/printer/print-strings.lsp +++ /dev/null @@ -1,155 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Apr 19 05:53:48 2004 -;;;; Contains: Tests of string printing - -(in-package :cl-test) - - - -(deftest print.string.1 - (with-standard-io-syntax - (write-to-string "" :escape nil :readably nil)) - "") - -(deftest print.string.2 - (with-standard-io-syntax - (loop for c across +standard-chars+ - for s1 = (string c) - for s2 = (write-to-string s1 :escape nil :readably nil) - unless (string= s1 s2) - collect (list c s1 s2))) - nil) - -(deftest print.string.3 - (with-standard-io-syntax - (loop for i below 256 - for c = (code-char i) - when c - nconc - (let* ((s1 (string c)) - (s2 (write-to-string s1 :escape nil :readably nil))) - (unless (string= s1 s2) - (list (list c s1 s2)))))) - nil) - -(deftest print.string.4 - (with-standard-io-syntax - (loop for c across +standard-chars+ - for s1 = (string c) - for s2 = (write-to-string s1 :escape t :readably nil) - unless (or (find c "\"\\") (string= (concatenate 'string "\"" s1 "\"") s2)) - collect (list c s1 s2))) - nil) - -(deftest print.string.5 - (with-standard-io-syntax - (write-to-string "\"" :escape t :readably nil)) - "\"\\\"\"") - -(deftest print.string.6 - (with-standard-io-syntax - (write-to-string "\\" :escape t :readably nil)) - "\"\\\\\"") - -;;; Not affected by *print-array* - -(deftest print.string.7 - (with-standard-io-syntax - (loop for s1 in (remove-if-not #'stringp *universe*) - for s2 = (write-to-string s1 :escape nil :readably nil) - for s3 = (write-to-string s1 :array t :escape nil :readably nil) - unless (string= s2 s3) - collect (list s1 s2 s3))) - nil) - -(deftest print.string.8 - (with-standard-io-syntax - (loop for s1 in (remove-if-not #'stringp *universe*) - for s2 = (write-to-string s1 :escape t :readably nil) - for s3 = (write-to-string s1 :array t :escape t :readably nil) - unless (string= s2 s3) - collect (list s1 s2 s3))) - nil) - -;;; Only active elements of the string are printed - -(deftest print.string.9 - (let* ((s (make-array '(10) :fill-pointer 5 :element-type 'character - :initial-contents "abcdefghij")) - (result - (with-standard-io-syntax - (write-to-string s :escape nil :readably nil)))) - (or (and (string= result "abcde") t) - result)) - t) - -(deftest print.string.10 - (let* ((s (make-array '(10) :fill-pointer 5 :element-type 'character - :initial-contents "aBcDefGHij")) - (result - (with-standard-io-syntax - (write-to-string s :escape t :readably nil)))) - (or (and (string= result "\"aBcDe\"") t) - result)) - t) - -(deftest print.string.11 - (let* ((s (make-array '(8) :element-type 'base-char - :initial-contents "abcdefgh" - :adjustable t)) - (result - (with-standard-io-syntax - (write-to-string s :escape t :readably nil)))) - (or (and (string= result "\"abcdefgh\"") t) - result)) - t) - -(deftest print.string.12 - (let* ((s1 (make-array '(8) :element-type 'character - :initial-contents "abcdefgh")) - (s2 (make-array '(4) :element-type 'character - :displaced-to s1 - :displaced-index-offset 2)) - (result - (with-standard-io-syntax - (write-to-string s2 :escape t :readably nil)))) - (or (and (string= result "\"cdef\"") t) - result)) - t) - -;;; *print-array* should not affect string printing - -(deftest print.string.13 - (with-standard-io-syntax - (write-to-string "1234" :array nil :readably nil :escape t)) - "\"1234\"") - - -;;; The ever-popular nil string - -(deftest print.string.nil.1 - :notes (:nil-vectors-are-strings) - (let ((s (make-array '(0) :element-type nil))) - (write-to-string s :escape nil :readably nil)) - "") - -(deftest print.string.nil.2 - :notes (:nil-vectors-are-strings) - (let ((s (make-array '(0) :element-type nil))) - (write-to-string s :escape t :readably nil)) - "\"\"") - - -;;; Random tests - -(deftest print.string.random.1 - (trim-list - (loop for len = (1+ (random 5)) - for s = (coerce (loop repeat len - collect (random-from-seq +standard-chars+)) - 'string) - repeat 1000 - append (randomly-check-readability s)) - 10) - nil) diff --git a/t/ansi-test/printer/print-structure.lsp b/t/ansi-test/printer/print-structure.lsp deleted file mode 100644 index 2f25d20..0000000 --- a/t/ansi-test/printer/print-structure.lsp +++ /dev/null @@ -1,39 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed May 26 22:19:52 2004 -;;;; Contains: Printing tests for structures - -(in-package :cl-test) - - -(defstruct print-struct-1 - foo bar) - -(deftest print-structure.1 - (let ((s (make-print-struct-1 :foo 1 :bar 2))) - (with-standard-io-syntax - (let ((*tst-pkg* (find-package "CL-TEST")) - (*kwd-pkg* (find-package "KEYWORD"))) - (let ((str (write-to-string s :readably nil :case :upcase :escape nil))) - (assert (string= (subseq str 0 3) "#S(")) - (let ((vals (read-from-string (subseq str 2)))) - (assert (listp vals)) - (assert (= (length vals) 5)) - (assert (eq (car vals) 'print-struct-1)) - (assert (symbolp (second vals))) - (assert (symbolp (fourth vals))) - (assert (eql *tst-pkg* (symbol-package (first vals)))) - (assert (eql *kwd-pkg* (symbol-package (second vals)))) - (assert (eql *kwd-pkg* (symbol-package (fourth vals)))) - (cond - ((string= (symbol-name (second vals)) "FOO") - (assert (string= (symbol-name (fourth vals)) "BAR")) - (assert (= (third vals) 1)) - (assert (= (fifth vals) 2))) - (t - (assert (string= (symbol-name (second vals)) "BAR")) - (assert (string= (symbol-name (fourth vals)) "FOO")) - (assert (= (third vals) 2)) - (assert (= (fifth vals) 1)))) - nil))))) - nil) diff --git a/t/ansi-test/printer/print-symbols.lsp b/t/ansi-test/printer/print-symbols.lsp deleted file mode 100644 index b7351cd..0000000 --- a/t/ansi-test/printer/print-symbols.lsp +++ /dev/null @@ -1,704 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Mar 6 11:47:55 2004 -;;;; Contains: Tests of symbol printing - -(in-package :cl-test) - - - -;;; Symbol printing when escaping is off - -(defun princ.symbol.fn (sym case *print-case* expected) - (setf (readtable-case *readtable*) case) - (let ((str (with-output-to-string (s) (princ sym s)))) - (or (equalt str expected) - (list str expected)))) - -(defun prin1.symbol.fn (sym case *print-case* expected) - (setf (readtable-case *readtable*) case) - (let ((str (with-output-to-string (s) (prin1 sym s)))) - (or (and (member str expected :test #'string=) t) - (list str expected)))) - -(deftest print.symbol.1 - (with-standard-io-syntax - (let ((*print-readably* nil) - (*readtable* (copy-readtable nil))) - (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) - (values - (%p '|XYZ| :upcase :upcase "XYZ") - (%p '|XYZ| :upcase :downcase "xyz") - (%p '|XYZ| :upcase :capitalize "Xyz") - (%p '|XYZ| :downcase :upcase "XYZ") - (%p '|XYZ| :downcase :downcase "XYZ") - (%p '|XYZ| :downcase :capitalize "XYZ") - (%p '|XYZ| :preserve :upcase "XYZ") - (%p '|XYZ| :preserve :downcase "XYZ") - (%p '|XYZ| :preserve :capitalize "XYZ") - (%p '|XYZ| :invert :upcase "xyz") - (%p '|XYZ| :invert :downcase "xyz") - (%p '|XYZ| :invert :capitalize "xyz"))))) - t t t t t t t t t t t t) - -(deftest print.symbol.2 - (with-standard-io-syntax - (let ((*print-readably* nil) - (*readtable* (copy-readtable nil))) - (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) - (values - (%p '|xyz| :upcase :upcase "xyz") - (%p '|xyz| :upcase :downcase "xyz") - (%p '|xyz| :upcase :capitalize "xyz") - (%p '|xyz| :downcase :upcase "XYZ") - (%p '|xyz| :downcase :downcase "xyz") - (%p '|xyz| :downcase :capitalize "Xyz") - (%p '|xyz| :preserve :upcase "xyz") - (%p '|xyz| :preserve :downcase "xyz") - (%p '|xyz| :preserve :capitalize "xyz") - (%p '|xyz| :invert :upcase "XYZ") - (%p '|xyz| :invert :downcase "XYZ") - (%p '|xyz| :invert :capitalize "XYZ"))))) - t t t t t t t t t t t t) - -(deftest print.symbol.3 - (with-standard-io-syntax - (let ((*print-readably* nil) - (*readtable* (copy-readtable nil))) - (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) - (values - (%p '|Xyz| :upcase :upcase "Xyz") - (%p '|Xyz| :upcase :downcase "xyz") - (%p '|Xyz| :upcase :capitalize "Xyz") - (%p '|Xyz| :downcase :upcase "XYZ") - (%p '|Xyz| :downcase :downcase "Xyz") - (%p '|Xyz| :downcase :capitalize "Xyz") - (%p '|Xyz| :preserve :upcase "Xyz") - (%p '|Xyz| :preserve :downcase "Xyz") - (%p '|Xyz| :preserve :capitalize "Xyz") - (%p '|Xyz| :invert :upcase "Xyz") - (%p '|Xyz| :invert :downcase "Xyz") - (%p '|Xyz| :invert :capitalize "Xyz"))))) - t t t t t t t t t t t t) - -(deftest print.symbol.4 - (with-standard-io-syntax - (let ((*print-readably* nil) - (*readtable* (copy-readtable nil))) - (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) - (values - (%p '|xYZ| :upcase :upcase "xYZ") - (%p '|xYZ| :upcase :downcase "xyz") - (%p '|xYZ| :upcase :capitalize "xyz") - (%p '|xYZ| :downcase :upcase "XYZ") - (%p '|xYZ| :downcase :downcase "xYZ") - (%p '|xYZ| :downcase :capitalize "XYZ") - (%p '|xYZ| :preserve :upcase "xYZ") - (%p '|xYZ| :preserve :downcase "xYZ") - (%p '|xYZ| :preserve :capitalize "xYZ") - (%p '|xYZ| :invert :upcase "xYZ") - (%p '|xYZ| :invert :downcase "xYZ") - (%p '|xYZ| :invert :capitalize "xYZ"))))) - t t t t t t t t t t t t) - -(deftest print.symbol.5 - (with-standard-io-syntax - (let ((*print-readably* nil) - (*readtable* (copy-readtable nil))) - (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) - (values - (%p '|X1Z| :upcase :upcase "X1Z") - (%p '|X1Z| :upcase :downcase "x1z") - (%p '|X1Z| :upcase :capitalize "X1z") - (%p '|X1Z| :downcase :upcase "X1Z") - (%p '|X1Z| :downcase :downcase "X1Z") - (%p '|X1Z| :downcase :capitalize "X1Z") - (%p '|X1Z| :preserve :upcase "X1Z") - (%p '|X1Z| :preserve :downcase "X1Z") - (%p '|X1Z| :preserve :capitalize "X1Z") - (%p '|X1Z| :invert :upcase "x1z") - (%p '|X1Z| :invert :downcase "x1z") - (%p '|X1Z| :invert :capitalize "x1z"))))) - t t t t t t t t t t t t) - -(deftest print.symbol.6 - (with-standard-io-syntax - (let ((*print-readably* nil) - (*readtable* (copy-readtable nil))) - (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) - (values - (%p '|x1z| :upcase :upcase "x1z") - (%p '|x1z| :upcase :downcase "x1z") - (%p '|x1z| :upcase :capitalize "x1z") - (%p '|x1z| :downcase :upcase "X1Z") - (%p '|x1z| :downcase :downcase "x1z") - (%p '|x1z| :downcase :capitalize "X1z") - (%p '|x1z| :preserve :upcase "x1z") - (%p '|x1z| :preserve :downcase "x1z") - (%p '|x1z| :preserve :capitalize "x1z") - (%p '|x1z| :invert :upcase "X1Z") - (%p '|x1z| :invert :downcase "X1Z") - (%p '|x1z| :invert :capitalize "X1Z"))))) - t t t t t t t t t t t t) - -(deftest print.symbol.7 - (with-standard-io-syntax - (let ((*print-readably* nil) - (*readtable* (copy-readtable nil))) - (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) - (values - (%p '|X1z| :upcase :upcase "X1z") - (%p '|X1z| :upcase :downcase "x1z") - (%p '|X1z| :upcase :capitalize "X1z") - (%p '|X1z| :downcase :upcase "X1Z") - (%p '|X1z| :downcase :downcase "X1z") - (%p '|X1z| :downcase :capitalize "X1z") - (%p '|X1z| :preserve :upcase "X1z") - (%p '|X1z| :preserve :downcase "X1z") - (%p '|X1z| :preserve :capitalize "X1z") - (%p '|X1z| :invert :upcase "X1z") - (%p '|X1z| :invert :downcase "X1z") - (%p '|X1z| :invert :capitalize "X1z"))))) - t t t t t t t t t t t t) - -(deftest print.symbol.8 - (with-standard-io-syntax - (let ((*print-readably* nil) - (*readtable* (copy-readtable nil))) - (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) - (values - (%p '|x1Z| :upcase :upcase "x1Z") - (%p '|x1Z| :upcase :downcase "x1z") - (%p '|x1Z| :upcase :capitalize "x1z") - (%p '|x1Z| :downcase :upcase "X1Z") - (%p '|x1Z| :downcase :downcase "x1Z") - (%p '|x1Z| :downcase :capitalize "X1Z") - (%p '|x1Z| :preserve :upcase "x1Z") - (%p '|x1Z| :preserve :downcase "x1Z") - (%p '|x1Z| :preserve :capitalize "x1Z") - (%p '|x1Z| :invert :upcase "x1Z") - (%p '|x1Z| :invert :downcase "x1Z") - (%p '|x1Z| :invert :capitalize "x1Z"))))) - t t t t t t t t t t t t) - -(deftest print.symbol.9 - (with-standard-io-syntax - (let ((*print-readably* nil) - (*readtable* (copy-readtable nil))) - (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) - (values - (%p '|X Z| :upcase :upcase "X Z") - (%p '|X Z| :upcase :downcase "x z") - (%p '|X Z| :upcase :capitalize "X Z") - (%p '|X Z| :downcase :upcase "X Z") - (%p '|X Z| :downcase :downcase "X Z") - (%p '|X Z| :downcase :capitalize "X Z") - (%p '|X Z| :preserve :upcase "X Z") - (%p '|X Z| :preserve :downcase "X Z") - (%p '|X Z| :preserve :capitalize "X Z") - (%p '|X Z| :invert :upcase "x z") - (%p '|X Z| :invert :downcase "x z") - (%p '|X Z| :invert :capitalize "x z"))))) - t t t t t t t t t t t t) - -(deftest print.symbol.10 - (with-standard-io-syntax - (let ((*print-readably* nil) - (*readtable* (copy-readtable nil))) - (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) - (values - (%p '|x z| :upcase :upcase "x z") - (%p '|x z| :upcase :downcase "x z") - (%p '|x z| :upcase :capitalize "x z") - (%p '|x z| :downcase :upcase "X Z") - (%p '|x z| :downcase :downcase "x z") - (%p '|x z| :downcase :capitalize "X Z") - (%p '|x z| :preserve :upcase "x z") - (%p '|x z| :preserve :downcase "x z") - (%p '|x z| :preserve :capitalize "x z") - (%p '|x z| :invert :upcase "X Z") - (%p '|x z| :invert :downcase "X Z") - (%p '|x z| :invert :capitalize "X Z"))))) - t t t t t t t t t t t t) - -(deftest print.symbol.11 - (with-standard-io-syntax - (let ((*print-readably* nil) - (*readtable* (copy-readtable nil))) - (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) - (values - (%p '|X z| :upcase :upcase "X z") - (%p '|X z| :upcase :downcase "x z") - (%p '|X z| :upcase :capitalize "X z") - (%p '|X z| :downcase :upcase "X Z") - (%p '|X z| :downcase :downcase "X z") - (%p '|X z| :downcase :capitalize "X Z") - (%p '|X z| :preserve :upcase "X z") - (%p '|X z| :preserve :downcase "X z") - (%p '|X z| :preserve :capitalize "X z") - (%p '|X z| :invert :upcase "X z") - (%p '|X z| :invert :downcase "X z") - (%p '|X z| :invert :capitalize "X z"))))) - t t t t t t t t t t t t) - -(deftest print.symbol.12 - (with-standard-io-syntax - (let ((*print-readably* nil) - (*readtable* (copy-readtable nil))) - (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) - (values - (%p '|x Z| :upcase :upcase "x Z") - (%p '|x Z| :upcase :downcase "x z") - (%p '|x Z| :upcase :capitalize "x Z") - (%p '|x Z| :downcase :upcase "X Z") - (%p '|x Z| :downcase :downcase "x Z") - (%p '|x Z| :downcase :capitalize "X Z") - (%p '|x Z| :preserve :upcase "x Z") - (%p '|x Z| :preserve :downcase "x Z") - (%p '|x Z| :preserve :capitalize "x Z") - (%p '|x Z| :invert :upcase "x Z") - (%p '|x Z| :invert :downcase "x Z") - (%p '|x Z| :invert :capitalize "x Z"))))) - t t t t t t t t t t t t) - -;;; Randomized printing tests - -(deftest print.symbol.random.1 - (let ((pkg-name "PRINT-SYMBOL-TEST-PACKAGE")) - (when (find-package pkg-name) - (delete-package pkg-name)) - (prog1 - (let ((*package* (make-package pkg-name))) - (trim-list - (loop for c across +standard-chars+ - nconc - (loop repeat 50 - nconc (randomly-check-readability (intern (string c))))) - 10)) -;; (delete-package pkg-name) - )) - nil) - -(deftest print.symbol.random.2 - (let ((pkg-name "PRINT-SYMBOL-TEST-PACKAGE")) - (when (find-package pkg-name) - (delete-package pkg-name)) - (prog1 - (let ((*package* (make-package pkg-name)) - (count 0)) - (trim-list - (loop for c1 = (random-from-seq +standard-chars+) - for c2 = (random-from-seq +standard-chars+) - for string = (concatenate 'string (string c1) (string c2)) - for result = (randomly-check-readability (intern string)) - for tries from 1 to 10000 - when result do (incf count) - nconc result - when (= count 10) - collect (format nil "... ~A out of ~A, stopping test ..." - count tries) - while (< count 10)) - 10)) - ;; (delete-package pkg-name) - )) - nil) - -(deftest print.symbol.random.3 - (let ((count 0) - (symbols (make-array '(1000) :fill-pointer 0 :adjustable t))) - ;; Find all symbols that have a home package, put into array SYMBOLS - (do-all-symbols (s) - (when (symbol-package s) - (vector-push-extend s symbols (array-dimension symbols 0)))) - (loop for i = (random (fill-pointer symbols)) - for s = (aref symbols i) - for tries from 1 to 10000 - for problem = (randomly-check-readability s) - nconc problem - when problem do (incf count) - while (< count 10))) - nil) - -(deftest print.symbol.random.4 - (let ((count 0) - (symbols (make-array '(1000) :fill-pointer 0 :adjustable t))) - ;; Find all symbols that have a home package, put into array SYMBOLS - (do-all-symbols (s) - (when (symbol-package s) - (vector-push-extend s symbols (array-dimension symbols 0)))) - (loop for i = (random (fill-pointer symbols)) - for s = (aref symbols i) - for tries from 1 to 10000 - for problem = (let ((*package* (symbol-package s))) - (randomly-check-readability s)) - nconc problem - when problem do (incf count) - while (< count 10))) - nil) - -;;;; Tests of printing with escaping enabled - -(deftest prin1.symbol.1 - (with-standard-io-syntax - (let ((*print-readably* nil) - (*package* (find-package :cl-test)) - (*readtable* (copy-readtable nil))) - (flet ((%p (&rest args) (apply #'prin1.symbol.fn args))) - (values - (%p '|X| :upcase :upcase '("x" "X" "\\X" "|X|")) - (%p '|X| :upcase :downcase '("x" "X" "\\X" "|X|")) - (%p '|X| :upcase :capitalize '("x" "X" "\\X" "|X|")) - (%p '|X| :downcase :upcase '("\\X" "|X|")) - (%p '|X| :downcase :downcase '("\\X" "|X|")) - (%p '|X| :downcase :capitalize '("\\X" "|X|")) - (%p '|X| :preserve :upcase '("X" "\\X" "|X|")) - (%p '|X| :preserve :downcase '("X" "\\X" "|X|")) - (%p '|X| :preserve :capitalize '("X" "\\X" "|X|")) - (%p '|X| :invert :upcase '("x" "\\X" "|X|")) - (%p '|X| :invert :downcase '("x" "\\X" "|X|")) - (%p '|X| :invert :capitalize '("x" "\\X" "|X|")) - )))) - t t t t t t t t t t t t) - -(deftest prin1.symbol.2 - (with-standard-io-syntax - (let ((*print-readably* nil) - (*package* (find-package :cl-test)) - (*readtable* (copy-readtable nil))) - (flet ((%p (&rest args) (apply #'prin1.symbol.fn args))) - (values - (%p '|x| :upcase :upcase '("\\x" "|x|")) - (%p '|x| :upcase :downcase '("\\x" "|x|")) - (%p '|x| :upcase :capitalize '("\\x" "|x|")) - (%p '|x| :downcase :upcase '("x" "X" "\\x" "|x|")) - (%p '|x| :downcase :downcase '("x" "X" "\\x" "|x|")) - (%p '|x| :downcase :capitalize '("x" "X" "\\x" "|x|")) - (%p '|x| :preserve :upcase '("x" "\\x" "|x|")) - (%p '|x| :preserve :downcase '("x" "\\x" "|x|")) - (%p '|x| :preserve :capitalize '("x" "\\x" "|x|")) - (%p '|x| :invert :upcase '("X" "\\x" "|x|")) - (%p '|x| :invert :downcase '("X" "\\x" "|x|")) - (%p '|x| :invert :capitalize '("X" "\\x" "|x|")) - )))) - t t t t t t t t t t t t) - -(deftest prin1.symbol.3 - (with-standard-io-syntax - (let ((*print-readably* nil) - (*package* (find-package :cl-test)) - (*readtable* (copy-readtable nil))) - (flet ((%p (&rest args) (apply #'prin1.symbol.fn args))) - (values - (%p '|1| :upcase :upcase '("\\1" "|1|")) - (%p '|1| :upcase :downcase '("\\1" "|1|")) - (%p '|1| :upcase :capitalize '("\\1" "|1|")) - (%p '|1| :downcase :upcase '("1" "\\1" "|1|")) - (%p '|1| :downcase :downcase '("1" "\\1" "|1|")) - (%p '|1| :downcase :capitalize '("1" "\\1" "|1|")) - (%p '|1| :preserve :upcase '("1" "\\1" "|1|")) - (%p '|1| :preserve :downcase '("1" "\\1" "|1|")) - (%p '|1| :preserve :capitalize '("1" "\\1" "|1|")) - (%p '|1| :invert :upcase '("1" "\\1" "|1|")) - (%p '|1| :invert :downcase '("1" "\\1" "|1|")) - (%p '|1| :invert :capitalize '("1" "\\1" "|1|")) - )))) - t t t t t t t t t t t t) - -;;; Random symbol printing tests when *print-escape* is true -;;; and *print-readably* is false. - -;;; I AM NOT SURE THESE ARE CORRECT, SO THEY ARE COMMENTED OUT FOR NOW -- PFD - -#| -(deftest print.symbol.escaped-random.1 - (let ((pkg-name "PRINT-SYMBOL-TEST-PACKAGE")) - (when (find-package pkg-name) - (delete-package pkg-name)) - (prog1 - (let ((*package* (make-package pkg-name)) - (result - (loop for c across +standard-chars+ - for s = (intern (string c)) - append - (loop repeat 50 - nconc (randomly-check-readability - s - :readable nil - :escape t))))) - (subseq result 0 (min (length result) 10))) - ;; (delete-package pkg-name) - )) - nil) - -(deftest print.symbol.escaped-random.2 - (let ((result - (loop for c across +standard-chars+ - for s = (make-symbol (string c)) - nconc - (loop repeat 50 - nconc (randomly-check-readability - s - :readable nil - :escape t - :gensym t - :test #'similar-uninterned-symbols))))) - (subseq result 0 (min (length result) 10))) - nil) - -(deftest print.symbol.escaped-random.3 - (let ((pkg-name "PRINT-SYMBOL-TEST-PACKAGE")) - (when (find-package pkg-name) - (delete-package pkg-name)) - (prog1 - (let ((*package* (make-package pkg-name)) - (result - (loop for i below 256 - for c = (code-char i) - when c - nconc - (let ((s (intern (string c)))) - (loop repeat 50 - nconc (randomly-check-readability - s - :readable nil - :escape t)))))) - (subseq result 0 (min (length result) 10))) - ;; (delete-package pkg-name) - )) - nil) - -(deftest print.symbol.escaped-random.4 - (let ((result - (loop for i below 256 - for c = (code-char i) - when c - nconc - (let ((s (make-symbol (string c)))) - (loop repeat 50 - nconc (randomly-check-readability - s - :readable nil - :escape t - :gensym t - :test #'similar-uninterned-symbols)))))) - (subseq result 0 (min (length result) 10))) - nil) - -(deftest print.symbol.escaped-random.5 - (loop for s in *universe* - when (and (symbolp s) (symbol-package s) ) - nconc - (loop repeat 50 - nconc (randomly-check-readability - s - :readable nil - :escape t))) - nil) - -(deftest print.symbol.escaped-random.6 - (let ((*package* (find-package "KEYWORD"))) - (loop for s in *universe* - when (and (symbolp s) (symbol-package s)) - nconc - (loop repeat 50 - nconc (randomly-check-readability - s - :readable nil - :escape t)))) - nil) - -(deftest print.symbol.escaped-random.7 - (loop for s in *universe* - when (and (symbolp s) (not (symbol-package s))) - nconc - (loop repeat 50 - nconc (randomly-check-readability - s - :readable nil - :escape t - :gensym t - :test #'similar-uninterned-symbols))) - nil) - -(deftest print.symbol.escaped-random.8 - (let ((*package* (find-package "KEYWORD"))) - (loop for s in *universe* - when (and (symbolp s) (not (symbol-package s))) - nconc - (loop repeat 50 - nconc (randomly-check-readability - s - :readable nil - :escape t - :gensym t - :test #'similar-uninterned-symbols)))) - nil) - -(deftest print.symbol.escaped.9 - (let* ((*package* (find-package "CL-TEST")) - (s (intern "()"))) - (randomly-check-readability s :readable nil :escape t)) - nil) - -(deftest print.symbol.escaped.10 - (let* ((*package* (find-package "KEYWORD")) - (s (intern "()"))) - (randomly-check-readability s :readable nil :escape t)) - nil) - -|# - -;;; Tests of printing package prefixes - -(deftest print.symbol.prefix.1 - (with-standard-io-syntax - (let ((s (write-to-string (make-symbol "ABC") :gensym t :case :upcase :escape t :readably nil))) - (if (string= s "#:ABC") t s))) - t) - -(deftest print.symbol.prefix.2 - (with-standard-io-syntax - (let ((s (write-to-string (make-symbol "ABC") :gensym nil :case :upcase :readably nil :escape nil))) - (if (string= s "ABC") t s))) - t) - -(deftest print.symbol.prefix.3 - (with-standard-io-syntax - (let ((s (write-to-string (make-symbol "ABC") - :gensym nil :case :upcase - :readably t :escape nil))) - (if (and (string= (subseq s 0 2) "#:") - (string= (symbol-name (read-from-string s)) "ABC")) - t s))) - t) - -(deftest print.symbol.prefix.4 - (with-standard-io-syntax - (let ((s (write-to-string (make-symbol "ABC") :gensym nil :case :upcase :readably nil :escape t))) - (if (string= s "ABC") t s))) - t) - -(deftest print.symbol.prefix.5 - (with-standard-io-syntax - (let ((pkg-name "PRINT-SYMBOL-TEST-PACKAGE")) - (when (find-package pkg-name) - (delete-package pkg-name)) - (let ((pkg (make-package pkg-name))) - (multiple-value-prog1 - (let* ((*package* (find-package "CL-TEST")) - (s (intern "ABC" pkg))) - (values - (write-to-string s :case :upcase :readably nil :escape t) - (let ((*package* pkg)) - (write-to-string s :case :upcase :readably nil :escape t)) - (let ((*package* pkg)) - (write-to-string s :case :downcase :readably nil :escape t)) - )) - ;; (delete-package pkg) - )))) - "PRINT-SYMBOL-TEST-PACKAGE::ABC" - "ABC" - "abc") - - -(deftest print.symbol.prefix.6 - (let ((pkg-name "PRINT-SYMBOL-TEST-PACKAGE")) - (when (find-package pkg-name) - (delete-package pkg-name)) - (let ((pkg (make-package pkg-name))) - (prog1 - (with-standard-io-syntax - (let* ((*package* pkg) - (s (intern "X" pkg))) - (write-to-string s :case :upcase :readably nil)) - ;; (delete-package pkg) - )))) - "X") - -(deftest print.symbol.prefix.6a - (with-standard-io-syntax - (let ((*package* (find-package "CL-TEST"))) - (write-to-string 'x :case :upcase :readably nil))) - "X") - -(deftest print.symbol.prefix.6b - (funcall - (compile - nil - '(lambda () - (declare (optimize speed (safety 0))) - (with-standard-io-syntax - (let ((*package* (find-package "CL-TEST"))) - (write-to-string 'cl-test::x :case :upcase :readably nil)))))) - "X") - -(deftest print.symbol.prefix.7 - (with-standard-io-syntax - (let ((pkg-name "PRINT-SYMBOL-TEST-PACKAGE") - (pkg-name2 "ANOTHER-PRINT-SYMBOL-TEST-PACKAGE")) - (when (find-package pkg-name) - (delete-package pkg-name)) - (when (find-package pkg-name2) - (delete-package pkg-name2)) - (prog1 - (let* ((pkg (make-package pkg-name)) - (pkg2 (make-package pkg-name2)) - (s (intern "ABC" pkg))) - (import s pkg2) - (let ((*package* pkg2)) - (write-to-string s :case :upcase :readably nil :escape t))) - ;; (delete-package pkg) - ))) - "ABC") - -(deftest print.symbol.prefix.8 - (with-standard-io-syntax - (let ((pkg-name "PRINT-SYMBOL-TEST-PACKAGE") - (pkg-name2 "ANOTHER-PRINT-SYMBOL-TEST-PACKAGE")) - (when (find-package pkg-name) - (delete-package pkg-name)) - (when (find-package pkg-name2) - (delete-package pkg-name2)) - (prog1 - (let* ((pkg (make-package pkg-name)) - (pkg2 (make-package pkg-name2)) - (s (intern "ABC" pkg2))) - (import s pkg) - (delete-package pkg2) - (let ((*package* pkg)) - (write-to-string s :case :upcase :gensym t :readably nil :escape t))) - ;; (delete-package pkg) - ))) - "#:ABC") - -(deftest print.symbol.prefix.9 - (with-standard-io-syntax - (let ((pkg-name "PRINT-SYMBOL-TEST-PACKAGE")) - (when (find-package pkg-name) - (delete-package pkg-name)) - (prog1 - (let* ((pkg (make-package pkg-name)) - (s (intern "ABC" pkg))) - (export s pkg) - (let ((*package* (find-package "CL-TEST"))) - (write-to-string s :case :upcase :readably nil :escape t))) - ;; (delete-package pkg) - ))) - "PRINT-SYMBOL-TEST-PACKAGE:ABC") - - -(deftest print.symbol.prefix.10 - (with-standard-io-syntax - (let ((pkg-name "PRINT-SYMBOL-TEST-PACKAGE")) - (when (find-package pkg-name) - (delete-package pkg-name)) - (prog1 - (let* ((pkg (make-package pkg-name)) - (s :|X|)) - (import s pkg) - (let ((*package* pkg)) - (write-to-string s :case :upcase :readably nil :escape t))) - ;; (delete-package pkg) - ))) - ":X") - diff --git a/t/ansi-test/printer/print-unreadable-object.lsp b/t/ansi-test/printer/print-unreadable-object.lsp deleted file mode 100644 index 6b83c6a..0000000 --- a/t/ansi-test/printer/print-unreadable-object.lsp +++ /dev/null @@ -1,141 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Jul 12 06:06:01 2004 -;;;; Contains: Tests of PRINT-UNREADABLE-OBJECT - -(in-package :cl-test) - - - -(def-pprint-test print-unreadable-object.1 - (loop - for x in *mini-universe* - for return-vals = nil - for s = (with-output-to-string - (s) - (setq return-vals - (multiple-value-list (print-unreadable-object (x s))))) - unless (and (equal return-vals '(nil)) - (equal s "#<>")) - collect (list x return-vals s)) - nil) - -(def-pprint-test print-unreadable-object.2 - (loop - for x in *mini-universe* - for return-vals1 = nil - for return-vals2 = nil - for s1 = (with-output-to-string - (s) - (setq return-vals1 - (multiple-value-list (print-unreadable-object - (x s :type t))))) - for s2 = (with-output-to-string - (s) - (setq return-vals2 - (multiple-value-list (print-unreadable-object - (x s :type t) - (write-char #\X s))))) - unless (and (equal return-vals1 '(nil)) - (equal return-vals2 '(nil)) - (string= s1 "#<" :end1 2) - (string= s1 s2 :end1 (- (length s1) 1) - :end2 (- (length s2) 2)) - (string= s2 " X>" :start1 (- (length s2) 3))) - collect (list x return-vals1 return-vals2 s1 s2)) - nil) - -(def-pprint-test print-unreadable-object.3 - (loop - for x in *mini-universe* - for return-vals1 = nil - for return-vals2 = nil - for s1 = (with-output-to-string - (s) - (setq return-vals1 - (multiple-value-list (print-unreadable-object - (x s :identity t) - (write "FOO" :stream s) - (values 1 2 3 4 5) ;; test if this is ignored - )))) - for s2 = (with-output-to-string - (s) - (setq return-vals2 - (multiple-value-list (print-unreadable-object - (x s :identity t) - )))) - unless (and (equal return-vals1 '(nil)) - (equal return-vals2 '(nil)) - (string= s1 "#) - (eql (char s2 (1- (length s2))) #\>) - (string= s1 s2 :start2 3 :start1 6)) - collect (list x return-vals1 return-vals2 s1 s2)) - nil) - -(def-pprint-test print-unreadable-object.4 - (loop - for x in *mini-universe* - for return-vals = nil - for s = (with-output-to-string - (s) - (setq return-vals - (multiple-value-list (print-unreadable-object - (x s :identity t :type t) - (write "FOO" :stream s) - (values) ;; test if this is ignored - )))) - unless (and (equal return-vals '(nil)) - (string= s "#<" :end1 2) - (eql (char s (1- (length s))) #\>) - (>= (count #\Space s) 2)) - collect (list x return-vals s)) - nil) - -;;; TODO Tests that the :identity and :type arguments are evaluated -;;; TODO Tests where :type, :identity are provided, but are nil -;;; TODO Test that the type/identity parts of the output are the same -;;; for the both-printed case as they are in the only-one printed case, -;;; and that only a single space occurs between them if FORMS is omitted. - -;;; Error cases - -(deftest print-unreadable-object.error.1 - (with-standard-io-syntax - (let ((*print-readably* t)) - (loop for x in *mini-universe* - for form = `(with-output-to-string - (*standard-output*) - (assert (signals-error - (print-unreadable-object (',x *standard-output*)) - print-not-readable))) - unless (equal (eval form) "") - collect x))) - nil) - -;;; Stream designators - -(deftest print-unreadable-object.t.1 - (with-output-to-string - (os) - (with-input-from-string - (is "") - (with-open-stream - (*terminal-io* (make-two-way-stream is os)) - (let ((*print-readably* nil)) - (assert - (equal (multiple-value-list (print-unreadable-object (1 t))) - '(nil))))))) - "#<>") - -(deftest print-unreadable-object.nil.1 - (with-output-to-string - (*standard-output*) - (let ((*print-readably* nil)) - (assert - (equal (multiple-value-list (print-unreadable-object (1 nil))) - '(nil))))) - "#<>") - - diff --git a/t/ansi-test/printer/print-vector.lsp b/t/ansi-test/printer/print-vector.lsp deleted file mode 100644 index 4ff50ac..0000000 --- a/t/ansi-test/printer/print-vector.lsp +++ /dev/null @@ -1,423 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Apr 20 22:36:53 2004 -;;;; Contains: Tests of vector printing - - - -(in-package :cl-test) - -;;; Empty vector tests - -(deftest print.vector.1 - (with-standard-io-syntax - (write-to-string #() :readably nil :array t)) - "#()") - -(deftest print.vector.2 - (with-standard-io-syntax - (loop for i from 2 to 100 - for a = (make-array '(0) :element-type `(unsigned-byte ,i)) - for s = (write-to-string a :readably nil :array t :pretty nil) - unless (string= s "#()") - collect (list i s))) - nil) - -(deftest print.vector.3 - (with-standard-io-syntax - (loop for i from 1 to 100 - for a = (make-array '(0) :element-type `(signed-byte ,i)) - for s = (write-to-string a :readably nil :array t :pretty nil) - unless (string= s "#()") - collect (list i s))) - nil) - -(deftest print.vector.4 - (with-standard-io-syntax - (loop for type in '(short-float single-float double-float long-float) - for a = (make-array '(0) :element-type type) - for s = (write-to-string a :readably nil :array t :pretty nil) - unless (string= s "#()") - collect (list type s))) - nil) - -;;; Nonempty vectors - -(deftest print.vector.5 - (with-standard-io-syntax - (let* ((*package* (find-package "CL-TEST")) - (result - (write-to-string #(a b c) - :readably nil :array t - :pretty nil :case :downcase))) - (or (and (string= result "#(a b c)") t) - result))) - t) - -(deftest print.vector.6 - (with-standard-io-syntax - (loop - for i from 2 to 100 - for a = (make-array '(4) :element-type `(unsigned-byte ,i) - :initial-contents '(3 0 2 1)) - for s = (write-to-string a :readably nil :array t :pretty nil) - unless (string= s "#(3 0 2 1)") - collect (list i a s))) - nil) - -(deftest print.vector.7 - (with-standard-io-syntax - (loop - for i from 2 to 100 - for a = (make-array '(4) :element-type `(signed-byte ,i) - :initial-contents '(-2 -1 0 1)) - for s = (write-to-string a :readably nil :array t :pretty nil) - unless (string= s "#(-2 -1 0 1)") - collect (list i a s))) - nil) - -;;; Vectors with fill pointers - -(deftest print.vector.fill.1 - (with-standard-io-syntax - (let ((v (make-array '(10) :initial-contents '(a b c d e f g h i j) - :fill-pointer 0)) - (*package* (find-package "CL-TEST"))) - (loop for i from 0 to 10 - do (setf (fill-pointer v) i) - collect (write-to-string v :readably nil :array t :pretty nil - :case :downcase)))) - ("#()" - "#(a)" - "#(a b)" - "#(a b c)" - "#(a b c d)" - "#(a b c d e)" - "#(a b c d e f)" - "#(a b c d e f g)" - "#(a b c d e f g h)" - "#(a b c d e f g h i)" - "#(a b c d e f g h i j)")) - -(deftest print.vector.fill.2 - (with-standard-io-syntax - (let ((expected '("#()" "#(0)" "#(0 1)" "#(0 1 2)" "#(0 1 2 3)"))) - (loop for i from 2 to 100 - nconc - (let ((v (make-array '(4) :initial-contents '(0 1 2 3) - :element-type `(unsigned-byte ,i) - :fill-pointer 0))) - (loop for fp from 0 to 4 - for expected-result in expected - for actual-result = - (progn - (setf (fill-pointer v) fp) - (write-to-string v :readably nil :array t :pretty nil)) - unless (string= expected-result actual-result) - collect (list i fp expected-result actual-result)))))) - nil) - -(deftest print.vector.fill.3 - (with-standard-io-syntax - (let ((expected '("#()" "#(0)" "#(0 -1)" "#(0 -1 -2)" "#(0 -1 -2 1)"))) - (loop for i from 2 to 100 - nconc - (let ((v (make-array '(4) :initial-contents '(0 -1 -2 1) - :element-type `(signed-byte ,i) - :fill-pointer 0))) - (loop for fp from 0 to 4 - for expected-result in expected - for actual-result = - (progn - (setf (fill-pointer v) fp) - (write-to-string v :readably nil :array t :pretty nil)) - unless (string= expected-result actual-result) - collect (list i fp expected-result actual-result)))))) - nil) - -;;; Displaced vectors - -(deftest print.vector.displaced.1 - (let* ((v1 (vector 'a 'b 'c 'd 'e 'f 'g)) - (v2 (make-array 3 :displaced-to v1 :displaced-index-offset 4))) - (with-standard-io-syntax - (write-to-string v2 :readably nil :array t :case :downcase :pretty nil - :escape nil))) - "#(e f g)") - -(deftest print.vector.displaced.2 - (with-standard-io-syntax - (loop for i from 2 to 100 - nconc - (let* ((type `(unsigned-byte ,i)) - (v1 (make-array 8 :element-type type - :initial-contents '(0 1 2 3 0 1 2 3))) - (v2 (make-array 5 :displaced-to v1 - :displaced-index-offset 2 - :element-type type)) - (result - (write-to-string v2 :readably nil :array t :pretty nil))) - (unless (string= result "#(2 3 0 1 2)") - (list (list i v1 v2 result)))))) - nil) - - -(deftest print.vector.displaced.3 - (with-standard-io-syntax - (loop for i from 2 to 100 - nconc - (let* ((type `(signed-byte ,i)) - (v1 (make-array 8 :element-type type - :initial-contents '(0 1 -1 -2 0 1 -1 -2))) - (v2 (make-array 5 :displaced-to v1 - :displaced-index-offset 2 - :element-type type)) - (result - (write-to-string v2 :readably nil :array t :pretty nil))) - (unless (string= result "#(-1 -2 0 1 -1)") - (list (list i v1 v2 result)))))) - nil) - - -;;; Adjustable vectors - -(deftest print.vector.adjustable.1 - (with-standard-io-syntax - (let ((v (make-array '(10) :initial-contents '(a b c d e f g h i j) - :adjustable t))) - (write-to-string v :readably nil :array t :case :downcase :pretty nil - :escape nil))) - "#(a b c d e f g h i j)") - -(deftest print.vector.adjustable.2 - (with-standard-io-syntax - (loop for i from 2 to 100 - for type = `(unsigned-byte ,i) - for v = (make-array '(8) :initial-contents '(0 1 2 3 3 0 2 1) - :adjustable t) - for s = - (write-to-string v :readably nil :array t :case :downcase :pretty nil - :escape nil) - unless (string= s "#(0 1 2 3 3 0 2 1)") - collect (list i v s))) - nil) - -(deftest print.vector.adjustable.3 - (with-standard-io-syntax - (loop for i from 2 to 100 - for type = `(signed-byte ,i) - for v = (make-array '(8) :initial-contents '(0 1 -1 -2 -1 0 -2 1) - :adjustable t) - for s = - (write-to-string v :readably nil :array t :case :downcase :pretty nil - :escape nil) - unless (string= s "#(0 1 -1 -2 -1 0 -2 1)") - collect (list i v s))) - nil) - -;;; Printing with *print-array* and *print-readably* bound to nil - -(deftest print.vector.unreadable.1 - (with-standard-io-syntax - (subseq (write-to-string #(a b c d e) :array nil :readably nil) 0 2)) - "#<") - -(deftest print.vector.unreadable.2 - (with-standard-io-syntax - (loop for i from 2 to 100 - for type = `(unsigned-byte ,i) - for v = (make-array '(4) :element-type type - :initial-contents '(0 1 2 3)) - for result = (write-to-string v :array nil :readably nil) - unless (string= (subseq result 0 2) "#<") - collect (list i type v result))) - nil) - - -(deftest print.vector.unreadable.3 - (with-standard-io-syntax - (loop for i from 2 to 100 - for type = `(signed-byte ,i) - for v = (make-array '(4) :element-type type - :initial-contents '(0 1 -2 -1)) - for result = (write-to-string v :array nil :readably nil) - unless (string= (subseq result 0 2) "#<") - collect (list i type v result))) - nil) - -;;; Readability tests - -(deftest print.vector.random.1 - (trim-list - (loop for v in *universe* - when (vectorp v) - nconc - (loop repeat 10 - nconc (randomly-check-readability - v :test #'equalp - :can-fail (not (subtypep t (array-element-type v)))))) - 10) - nil) - -(deftest print.vector.random.2 - (trim-list - (loop for i from 2 to 100 - for type = `(unsigned-byte ,i) - for v = (make-array '(4) :element-type type - :initial-contents '(1 3 2 0)) - nconc - (loop repeat 10 - nconc (randomly-check-readability v :test #'equalp - :can-fail t))) - 10) - nil) - -(deftest print.vector.random.3 - (trim-list - (loop for i from 2 to 100 - for type = `(signed-byte ,i) - for v = (make-array '(4) :element-type type - :initial-contents '(-1 1 0 -2)) - nconc - (loop repeat 10 - nconc (randomly-check-readability v :test #'equalp - :can-fail t))) - 10) - nil) - -(deftest print.vector.random.4 - (trim-list - (loop for v = (make-random-vector (1+ (random 100))) - repeat 1000 - nconc (randomly-check-readability v :test #'equalp)) - 10) - nil) - -;;; *print-length* checks - -(deftest print.vector.length.1 - (with-standard-io-syntax - (write-to-string #() :pretty nil :length 0 :readably nil)) - "#()") - -(deftest print.vector.length.2 - (with-standard-io-syntax - (write-to-string #(1) :pretty nil :length 0 :readably nil)) - "#(...)") - -(deftest print.vector.length.3 - (with-standard-io-syntax - (write-to-string #(1) :pretty nil :length 1 :readably nil)) - "#(1)") - -(deftest print.vector.length.4 - (with-standard-io-syntax - (write-to-string #(a b c d e f g h) - :pretty nil - :array t :escape nil - :length 5 :case :downcase - :readably nil)) - "#(a b c d e ...)") - -(deftest print.vector.length.5 - (with-standard-io-syntax - (loop for i from 2 to 100 - for type = `(unsigned-byte ,i) - for v = (make-array '(0) :element-type type) - for result = (write-to-string v :array t :readably nil - :pretty nil - :length 0) - unless (string= result "#()") - collect (list i type v result))) - nil) - -(deftest print.vector.length.6 - (with-standard-io-syntax - (loop for i from 2 to 100 - for type = `(unsigned-byte ,i) - for v = (make-array '(1) :element-type type :initial-contents '(2)) - for result = (write-to-string v - :pretty nil - :array t - :readably nil - :length 0) - unless (string= result "#(...)") - collect (list i type v result))) - nil) - -(deftest print.vector.length.7 - (with-standard-io-syntax - (loop for i from 1 to 100 - for type = `(signed-byte ,i) - for v = (make-array '(1) :element-type type :initial-contents '(-1)) - for result = (write-to-string v - :pretty nil - :array t - :readably nil - :length 0) - unless (string= result "#(...)") - collect (list i type v result))) - nil) - -(deftest print.vector.length.8 - (with-standard-io-syntax - (loop for i from 2 to 100 - for type = `(unsigned-byte ,i) - for v = (make-array '(4) :element-type type - :initial-contents '(1 3 0 2)) - for result = (write-to-string v - :pretty nil - :array t - :readably nil - :length 2) - unless (string= result "#(1 3 ...)") - collect (list i type v result))) - nil) - -(deftest print.vector.length.9 - (with-standard-io-syntax - (loop for i from 2 to 100 - for type = `(signed-byte ,i) - for v = (make-array '(4) :element-type type - :initial-contents '(1 -2 0 -1)) - for result = (write-to-string v - :pretty nil - :array t - :readably nil - :length 2) - unless (string= result "#(1 -2 ...)") - collect (list i type v result))) - nil) - -;;; Printing with *print-level* bound - -(deftest print.vector.level.1 - (with-standard-io-syntax - (write-to-string #() :level 0 :readably nil :pretty nil)) - "#") - -(deftest print.vector.level.2 - (with-standard-io-syntax - (write-to-string #() :level 1 :readably nil :pretty nil)) - "#()") - -(deftest print.vector.level.3 - (with-standard-io-syntax - (write-to-string #(17) :level 1 :readably nil :pretty nil)) - "#(17)") - -(deftest print.vector.level.4 - (with-standard-io-syntax - (write-to-string #(4 (17) 9 (a) (b) 0) :level 1 :readably nil :pretty nil)) - "#(4 # 9 # # 0)") - -(deftest print.vector.level.5 - (with-standard-io-syntax - (write-to-string '(#(a)) :level 1 :readably nil :pretty nil)) - "(#)") - -(deftest print.vector.level.6 - (with-standard-io-syntax - (write-to-string '#(#(a)) :level 1 :readably nil :pretty nil)) - "#(#)") - diff --git a/t/ansi-test/printer/print.lsp b/t/ansi-test/printer/print.lsp deleted file mode 100644 index dac56e7..0000000 --- a/t/ansi-test/printer/print.lsp +++ /dev/null @@ -1,48 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jul 25 11:41:16 2004 -;;;; Contains: Tests of PRINT - -(in-package :cl-test) - - - -;;; This function is mostly tested elsewhere - -(deftest print.1 - (random-print-test 1000) - nil) - -(deftest print.2 - (with-standard-io-syntax - (with-output-to-string - (os) - (with-input-from-string - (is "") - (with-open-stream (*terminal-io* (make-two-way-stream is os)) - (print 2 t))))) - " -2 ") - -(deftest print.3 - (with-standard-io-syntax - (with-output-to-string - (*standard-output*) - (print 3 nil))) - " -3 ") - -;;; Error tests - -(deftest print.error.1 - (signals-error - (with-output-to-string (*standard-output*) (print)) - program-error) - t) - -(deftest print.error.2 - (signals-error - (with-output-to-string (s) (print nil s nil)) - program-error) - t) - diff --git a/t/ansi-test/printer/printer-control-vars.lsp b/t/ansi-test/printer/printer-control-vars.lsp deleted file mode 100644 index 6b854c9..0000000 --- a/t/ansi-test/printer/printer-control-vars.lsp +++ /dev/null @@ -1,52 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Jun 3 06:25:52 2004 -;;;; Contains: Tests of initial values of printer control variables - -(in-package :cl-test) - -(deftest print-base.init.1 - *print-base* - 10) - -(deftest print-radix.init.1 - *print-radix* - nil) - -(deftest print-case.init.1 - *print-case* - :upcase) - -(deftest print-circle.init.1 - *print-circle* - nil) - -(deftest print-escape.init.1 - (notnot *print-escape*) - t) - -(deftest print-gensym.init.1 - (notnot *print-gensym*) - t) - -(deftest print-level.init.1 - *print-level* - nil) - -(deftest print-length.init.1 - *print-length* - nil) - -(deftest print-lines.init.1 - *print-lines* - nil) - -(deftest print-readably.init.1 - *print-readably* - nil) - -(deftest print-right-margin.init.1 - *print-right-margin* - nil) - - diff --git a/t/ansi-test/printer/write-to-string.lsp b/t/ansi-test/printer/write-to-string.lsp deleted file mode 100644 index 2832cb3..0000000 --- a/t/ansi-test/printer/write-to-string.lsp +++ /dev/null @@ -1,43 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jul 25 12:53:11 2004 -;;;; Contains: Tests of WRITE-TO-STRING - -(in-package :cl-test) - - - -;;; This function is extensively used elsewhere - -(deftest write-to-string.1 - (random-write-to-string-test 1000) - nil) - -(deftest write-to-string.2 - (with-standard-io-syntax - (write-to-string 2 :allow-other-keys nil)) - "2") - -(deftest write-to-string.3 - (with-standard-io-syntax - (write-to-string 3 :allow-other-keys t '#.(gensym) 0)) - "3") - -(deftest write-to-string.4 - (with-standard-io-syntax - (write-to-string 4 :base 10 :base 2)) - "4") - -;;; Error tests - -(deftest write-to-string.error.1 - (signals-error (write-to-string) program-error) - t) - -(deftest write-to-string.error.2 - (signals-error (write-to-string nil '#.(gensym) nil) program-error) - t) - -(deftest write-to-string.error.3 - (signals-error (write-to-string nil :radix) program-error) - t) diff --git a/t/ansi-test/printer/write.lsp b/t/ansi-test/printer/write.lsp deleted file mode 100644 index 23cb105..0000000 --- a/t/ansi-test/printer/write.lsp +++ /dev/null @@ -1,92 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Jul 15 06:43:55 2004 -;;;; Contains: Tests of WRITE - -(in-package :cl-test) - - -;; (compile-and-load "write-aux.lsp") - -;;; This function is also incidentally tested elsewhere. - -(deftest write.1 - (random-write-test 1000) - nil) - -(deftest write.2 - (with-standard-io-syntax - (let ((*print-readably* nil)) - (with-output-to-string - (*standard-output*) - (write 2 :stream nil)))) - "2") - -(deftest write.3 - (with-standard-io-syntax - (let ((*print-readably* nil)) - (with-output-to-string - (os) - (with-input-from-string - (is "") - (with-open-stream (*terminal-io* (make-two-way-stream is os)) - (write 3 :stream t)))))) - "3") - -(deftest write.4 - (with-standard-io-syntax - (let ((*print-readably* nil)) - (with-output-to-string - (os) - (write 4 :stream os)))) - "4") - -(deftest write.5 - (with-standard-io-syntax - (let ((*print-readably* nil)) - (with-output-to-string - (*standard-output*) - (write 5 :allow-other-keys nil)))) - "5") - -(deftest write.6 - (with-standard-io-syntax - (let ((*print-readably* nil)) - (with-output-to-string - (*standard-output*) - (write 6 :allow-other-keys t :foo 'bar)))) - "6") - -(deftest write.7 - (with-standard-io-syntax - (let ((*print-readably* nil)) - (with-output-to-string - (*standard-output*) - (write 7 :base 10 :base 3)))) - "7") - -;;; Error tests - -(deftest write.error.1 - (signals-error (write) program-error) - t) - -(deftest write.error.2 - (signals-error (write 1 :stream) program-error) - t) - -(deftest write.error.3 - (signals-error (write 1 :allow-other-keys nil :foo 'bar) program-error) - t) - -(deftest write.error.4 - (signals-error (write 1 :allow-other-keys nil :allow-other-keys t :foo 'bar) program-error) - t) - - - - - - - - diff --git a/t/ansi-test/random/make-random-element-of.lsp b/t/ansi-test/random/make-random-element-of.lsp deleted file mode 100644 index dcbea8a..0000000 --- a/t/ansi-test/random/make-random-element-of.lsp +++ /dev/null @@ -1,274 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Dec 28 20:28:03 2004 -;;;; Contains: Code to make random elements of types - -(in-package :cl-test) - -(defgeneric make-random-element-of (type) - (:documentation - "Create a random element of TYPE, or throw an error if it can't figure out how to do it.")) - -(defgeneric make-random-element-of-compound-type (type args &key &allow-other-keys) - (:documentation - "Create a random element of (TYPE . ARGS), or throw an error if it can't figure out how to do it.")) - -(defmethod make-random-element-of ((type cons)) - (make-random-element-of-compound-type (car type) (cdr type))) - -(defmethod make-random-element-of ((type (eql bit))) (random 2)) - -(defmethod make-random-element-of ((type (eql boolean))) - (random-from-seq #(nil t))) - -(defmethod make-random-elememt-of ((type (eql symbol))) - (random-from-seq #(nil t a b c :a :b :c |z| foo |foo| car))) - -(defmethod make-random-element-of ((type (eql unsigned-byte))) - (random-from-interval - (1+ (ash 1 (random *maximum-random-int-bits*))))) - -(defmethod make-random-elememt-of ((type (eql signed-byte))) - (random-from-interval - (1+ (ash 1 (random *maximum-random-int-bits*))) - (- (ash 1 (random *maximum-random-int-bits*))))) - -(defmethod make-random-element-of ((type (eql rational))) - (let* ((r (ash 1 (1+ (random *maximum-random-int-bits*)))) - (n (random r)) - (d (loop for x = (random r) unless (zerop x) do (return x)))) - (if (coin) (/ n d) (- (/ n d))))) - -(defmethod make-random-element-of ((type (eql integer))) - (let* ((b (random *maximum-random-int-bits*)) - (x (ash 1 b))) - (rcase - (1 (+ x (make-random-element-of 'integer))) - (1 (- (make-random-element-of 'integer) x)) - (6 (random-from-interval (1+ x) (- x)))))) - -(defmethod make-random-element-of ((type (eql short-float))) - (make-random-element-of (list type))) - -(defmethod make-random-element-of ((type (eql single-float))) - (make-random-element-of (list type))) - -(defmethod make-random-element-of ((type (eql double-float))) - (make-random-element-of (list type))) - -(defmethod make-random-element-of ((type (eql long-float))) - (make-random-element-of (list type))) - -(defmethod make-random-element-of ((type (eql float))) - (make-random-element-of - (list (random-from-seq #'(short-float single-float double-float long-float))))) - -(defmethod make-random-element-of ((type (eql real))) - (make-random-element-of (random-from-seq #(integer rational float)))) - -(defmethod make-random-element-of ((type (eql ratio))) - (loop for x = (make-random-element-of 'rational) - unless (integerp x) return x)) - -(defmethod make-random-element-of ((type complex)) - (make-random-element-of '(complex real))) - -(defmethod make-random-element-of ((type fixnum)) - (make-random-element-of `(integer ,most-negative-fixnum ,most-positive-fixnum))) - -(defmethod make-random-element-of ((type bignum)) - (make-random-element-of `(or (integer * (,most-negative-fixnum)) - (integer (,most-positive-fixnum))))) - -(defmethod make-random-element-of ((type (eql number))) - (make-random-element-of (random-from-seq #(integer rational float complex)))) - -(defmethod make-random-element-of ((type (eql character))) - (rcase - (3 (random-from-seq +standard-chars+)) - (2 (let ((r (random 256))) - (or (code-char r) (make-random-element-of 'character)))) - (1 (let ((r (random #.(ash 1 16)))) - (or (code-char r) (make-random-element-of 'character)))) - (1 (let ((r (random #.(ash 1 24)))) - (or (code-char r) (make-random-element-of 'character)))))) - -(defmethod make-random-element-of ((type 'base-char)) - (random-from-seq +standard-chars+)) - -(defmethod make-random-element-of ((type 'standard-char)) - (random-from-seq +standard-chars+)) - -(defmethod make-random-element-of ((type (eql bit-vector))) - (make-random-vector 'bit '*)) - -(defmethod make-random-element-of ((type (eql simple-bit-vector))) - (make-random-vector 'bit '* :simple t)) - -(defmethod make-random-element-of ((type (eql vector))) - (make-random-vector '* '*)) - -(defmethod make-random-element-of ((type (eql simple-vector))) - (make-random-vector 't '* :simple t)) - -(defmethod make-random-elemnt-of ((type (eql array))) - (make-random-array '* '*)) - -(defmethod make-random-elemnt-of ((type (eql simple-array))) - (make-random-array '* '* :simple t)) - -(defmethod make-random-elememt-of ((type (eql string))) - (make-random-string '*)) - -(defmethod make-random-elememt-of ((type (eql simple-string))) - (make-random-string '* :simple t)) - -(defmethod make-random-element-of ((type (eql base-string))) - (make-random-vector 'base-char '*)) - -(defmethod make-random-element-of ((type (eql simple-base-string))) - (make-random-vector 'base-char '* :simple t)) - -(defmethod make-random-element-of ((type (eql cons))) - (make-random-element-of '(cons t t))) - -(defmethod make-random-element-of ((type (eql null))) nil) - -(defmethod make-random-elememt-of ((type (eql list))) - (let ((len (min (random 10) (random 10)))) - (loop repeat len collect (make-random-element-of-type t)))) - -(defmethod make-random-element-of ((type (eql sequence))) - (make-random-element-of '(or list vector))) - -;;;; - -(defun make-random-vector (length &key simple (element-type '*)) - (setq element-type (make-random-array-element-type element-type)) - (make-random-element-of `(,(if simple 'simple-vector 'vector) ,element-type ,length))) - -(defun make-random-array (dimensions &key simple (element-type '*)) - (setq element-type (make-random-array-element-type element-type)) - (make-random-element-of `(,(if simple 'simple-array 'array) ,element-type ,length))) - -(defun make-random-array-element-type (elememt-type) - (if (eq element-type '*) - (rcase - (1 'bit) - (1 `(unsigned-byte (1+ (random *maximum-random-int-bits*)))) - (1 `(signed-byte (1+ (random *maximum-random-int-bits*)))) - (2 (random-from-seq #(character base-char standard-char))) - ;; Put float, complex types here also - (4 t)) - element-type)) - -;;;; - -(defmethod make-random-element-of-compound-type ((type-op (eql or)) (args cons)) - (make-random-element-of (random-from-seq args))) - -(defmethod make-random-element-of-compound-type ((type-op (eql and)) (args cons)) - (loop for e = (make-random-element-of (car args)) - repeat 100 - when (or (null (cdr args)) (typep e (cons 'and (cdr args)))) - return x - finally (error "Cannot generate a random element of ~A" - (cons 'and args)))) - -(defmethod make-random-element-of-compound-type ((type-op (eql integer)) (args t)) - (let ((lo (let ((lo (car args))) - (cond - ((consp lo) (1+ (car lo))) - ((eq lo nil) '*) - (t lo)))) - (hi (let ((hi (cadr args))) - (cond - ((consp hi) (1- (car hi))) - ((eq hi nil) '*) - (t hi))))) - (if (eq lo '*) - (if (eq hi '*) - (let ((x (ash 1 (random *maximum-random-int-bits*)))) - (random-from-interval x (- x))) - (random-from-interval (1+ hi) - (- hi (random (ash 1 *maximum-random-int-bits*))))) - - (if (eq hi '*) - (random-from-interval (+ lo (random (ash 1 *maximum-random-int-bits*)) 1) - lo) - ;; May generalize the next case to increase odds - ;; of certain integers (near 0, near endpoints, near - ;; powers of 2...) - (random-from-interval (1+ hi) lo))))) - -(defmethod make-random-element-of-compound-type ((type-op (eql short-float)) (args t)) - (make-random-element-of-float-type type args)) - -(defmethod make-random-element-of-compound-type ((type-op (eql single-float)) (args t)) - (make-random-element-of-float-type type args)) - -(defmethod make-random-element-of-compound-type ((type-op (eql double-float)) (args t)) - (make-random-element-of-float-type type args)) - -(defmethod make-random-element-of-compound-type ((type-op (eql long-float)) (args t)) - (make-random-element-of-float-type type args)) - -(defun make-random-element-of-float-type (type-op args) - (let ((lo (car args)) - (hi (cadr args)) - lo= hi=) - (cond - ((consp lo) nil) - ((member lo '(* nil)) - (setq lo (most-negative-float type-op)) - (setq lo= t)) - (t - (assert (typep lo type-op)) - (setq lo= t))) - (cond - ((consp hi) nil) - ((member hi '(* nil)) - (setq hi (most-positive-float type-op)) - (setq hi= t)) - (t - (assert (typep hi type-op)) - (setq hi= t))) - (assert (<= lo hi)) - (assert (or (< lo hi) (and lo= hi=))) - (let ((limit 100000)) - (cond - ((or (<= hi 0) - (>= lo 0) - (and (<= (- limit) hi limit) (<= (- limit) lo limit))) - (loop for x = (+ (random (- hi lo)) lo) - do (when (or lo= (/= x lo)) (return x)))) - (t - (rcase - (1 (random (min hi (float limit hi)))) - (1 (- (random (min (float limit lo) (- lo))))))))))) - -(defmethod make-random-element-of-compound-type ((type-op (eql mod)) (args cons)) - (let ((modulus (car args))) - (assert (integerp modulus)) - (assert (plusp modulus)) - (make-random-element-of `(integer 0 (,modulus))))) - -(defmethod make-random-element-of-compound-type ((type-op (eql unsigned-byte)) (args t)) - (if (null args) - (make-random-element-of '(integer 0 *)) - (let ((bits (car args))) - (if (eq bits'*) - (make-random-element-of '(integer 0 *)) - (progn - (assert (and (integerp bits) (>= bits 1))) - (make-random-element-of `(integer 0 ,(1- (ash 1 bits))))))))) - -(defmethod make-random-element-of-compound-type ((type-op (eql eql)) (args cons)) - (assert (null (cdr args))) - (car args)) - -(defmethod make-random-element-of-compound-type ((type-op (eql member)) (args cons)) - (random-from-seq args)) - - - diff --git a/t/ansi-test/random/random-class.lsp b/t/ansi-test/random/random-class.lsp deleted file mode 100644 index 1453fdd..0000000 --- a/t/ansi-test/random/random-class.lsp +++ /dev/null @@ -1,9 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Oct 10 07:13:47 2004 -;;;; Contains: Randomized tests on classes - -(in-package :cl-test) - -(compile-and-load "random-class-aux.lsp") - diff --git a/t/ansi-test/random/random-int-form.lsp b/t/ansi-test/random/random-int-form.lsp deleted file mode 100644 index 7c18b16..0000000 --- a/t/ansi-test/random/random-int-form.lsp +++ /dev/null @@ -1,2971 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Sep 10 18:03:52 2003 -;;;; Contains: Simple randon form generator/tester - -(in-package :cl-test) - -(compile-and-load "random-aux.lsp") - -;;; -;;; This file contains a routine for generating random legal Common Lisp functions -;;; for differential testing. -;;; -;;; To run the random tests by themselves, start a lisp in the ansi-tests directory -;;; and do the following: -;;; (load "gclload1.lsp") -;;; (compile-and-load "random-int-form.lsp") -;;; (in-package :cl-test) -;;; (let ((*random-state* (make-random-state t))) -;;; (test-random-integer-forms 100 4 10000)) ;; or other parameters -;;; -;;; If a test breaks during testing the variables *optimized-fn-src*, -;;; *unoptimized-fn-src*, and *int-form-vals* can be used to get the source -;;; of the optimized/unoptimized lambda forms being compiled, and the arguments -;;; on which they are called. -;;; -;;; If a difference is found between optimized/unoptimized functions the forms, -;;; values, and results are collected. A list of all these discrepancies is returned -;;; after testing finishes (assuming nothing breaks). -;;; -;;; The variable *compile-unoptimized-form* controls whether the low optimization -;;; form is compiled, or if a form funcalling it is EVALed. The latter is often -;;; faster, and may find more problems since an interpreter and compiler may evaluate -;;; forms in very different ways. -;;; -;;; The rctest/ subdirectory contains fragments of a more OO random form generator -;;; that will eventually replace this preliminary effort. -;;; -;;; The file misc.lsp contains tests that were mostly for bugs found by this -;;; random tester in various Common Lisp implementations. -;;; - -(declaim (special *optimized-fn-src* *unoptimized-fn-src* *int-form-vals* - *opt-result* *unopt-result* $x $y $z - *compile-unoptimized-form* - *make-random-integer-form-cdf*)) - -;;; Little functions used to run collected tests. -;;; (f i) runs the ith collected optimized test -;;; (g i) runs the ith collected unoptimized test -;;; (p i) prints the ith test (forms, input values, and other information) - -(defun f (i) (let ((plist (elt $y i))) - (apply (compile nil (getf plist :optimized-lambda-form)) - (getf plist :vals)))) - -(defun g (i) (let ((plist (elt $y i))) - (if *compile-unoptimized-form* - (apply (compile nil (getf plist :unoptimized-lambda-form)) - (getf plist :vals)) - (apply (the function (eval `(function ,(getf plist :unoptimized-lambda-form)))) - (getf plist :vals))))) - -(defun p (i) (write (elt $y i) :pretty t :escape t) (values)) - -(defun load-failures (&key (pathname "failures.lsp")) - (length (setq $y (with-open-file (s pathname :direction :input) - (loop for x = (read s nil) - while x collect x))))) - -(defun tn (n &optional (size 100)) - (length (setq $y (prune-results (setq $x (test-random-integer-forms size 2 n)))))) - -(declaim (special *s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8* *s9*)) - -(defparameter *random-special-vars* - #(*s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8* *s9*)) - -(defparameter *loop-random-int-form-period* 2000) - -(defmacro cl-handler-bind (&rest args) - `(cl:handler-bind ,@args)) - -(defmacro cl-handler-case (&rest args) - `(cl:handler-case ,@args)) - -(eval-when - (:compile-toplevel :load-toplevel :execute) - (defun cumulate (vec) - (loop for i from 1 below (length vec) - do (incf (aref vec i) (aref vec (1- i)))) - vec)) - -(defparameter *default-make-random-integer-form-cdf* - (cumulate (copy-seq #(10 5 40 4 5 4 2 2 10 1 1 #-armedbead 1 #-armedbear 1 - #-allegro 5 5 5 #-(or gcl ecl armedbear) 2 - 2 #-(or cmu allegro poplog) 5 4 30 - 4 20 3 2 2 1 1 5 30 #-poplog 5 - #-(or allegro poplog) 10 - 50 4 4 10 20 10 10 3 - 20 5 #-(or armedbear) 20 - 2 2 2)))) - -(defparameter *make-random-integer-form-cdf* - (copy-seq *default-make-random-integer-form-cdf*)) - -(eval-when - (:compile-toplevel :load-toplevel :execute) - (defmacro with-random-integer-form-params (&body forms) - (let ((len (gensym "LEN")) - (vec (gensym "VEC"))) - `(let* ((,len (length *default-make-random-integer-form-cdf*)) - (,vec (make-array ,len))) - (loop for i from 0 below ,len do (setf (aref ,vec i) - (1+ (min (random 100) - (random 100))))) - (setq ,vec (cumulate ,vec)) - (let ((*make-random-integer-form-cdf* ,vec)) - ,@forms))))) - -;;; Run the random tester, collecting failures into the special -;;; variable $y. - -(defun loop-random-int-forms (&optional (size 200) (nvars 3)) - (unless (boundp '$x) (setq $x nil)) - (unless (boundp '$y) (setq $y nil)) - (loop - for i from 1 - do - (format t "~6D | " i) - (finish-output *standard-output*) - (let ((x (test-random-integer-forms - size nvars *loop-random-int-form-period* - :index (* (1- i) *loop-random-int-form-period*)))) - (when x - (setq $x (append $x x)) - (setq x (prune-results x)) - (terpri) (print x) (finish-output *standard-output*) - (setq $y (append $y x))) - (terpri)))) - -(defvar *random-int-form-blocks* nil) -(defvar *random-int-form-catch-tags* nil) -(defvar *go-tags* nil) - -(defvar *random-vals-list-bound* 10) - -(defvar *max-compile-time* 0) -(defvar *max-compile-term* nil) - -(defvar *print-immediately* nil) - -(defvar *compile-unoptimized-form* - #+(or allegro sbcl) t - #-(or allegro sbcl) nil) - -(declaim (special *vars*)) - -(defstruct var-desc - (name nil :type symbol) - (type t)) - -(defun test-random-integer-forms - (size nvars n - &key ((:random-state *random-state*) (make-random-state t)) - (file-prefix "b") - (index 0) - (random-size nil) - (random-nvars nil) - ) - - "Generate random integer forms of size SIZE with NVARS variables. - Do this N times, returning all those on which a discrepancy - is found between optimized and nonoptimize, notinlined code." - - (assert (integerp nvars)) - (assert (<= 1 nvars 26)) - (assert (and (integerp n) (plusp n))) - (assert (and (integerp n) (plusp size))) - - (loop for i from 1 to n - do (when (= (mod i 100) 0) - ;; #+sbcl (print "Do gc...") - ;; #+sbcl (sb-ext::gc :full t) - ;; #+lispworks-personal-edition (cl-user::normal-gc) - (prin1 i) (princ " ") (finish-output *standard-output*)) - nconc (let ((result (test-random-integer-form - (if random-size (1+ (random size)) size) - (if random-nvars (1+ (random nvars)) nvars) - :index (+ index i) - :file-prefix file-prefix))) - (when result - (let ((*print-readably* nil)) - (format t "~%~A~%" (format nil "~S" (car result))) - (finish-output *standard-output*))) - result))) - -(defun test-random-integer-form - (size nvars &key (index 0) (file-prefix "b")) - (let* ((vars (subseq '(a b c d e f g h i j k l m - n o p q r s u v w x y z) 0 nvars)) - (var-ranges (mapcar #'make-random-integer-range vars)) - (var-types (mapcar #'(lambda (range) - (let ((lo (car range)) - (hi (cadr range))) - (assert (>= hi lo)) - `(integer ,lo ,hi))) - var-ranges)) - (form (let ((*vars* (loop for v in vars - for tp in var-types - collect (make-var-desc :name v - :type tp))) - (*random-int-form-blocks* nil) - (*random-int-form-catch-tags* nil) - (*go-tags* nil) - ) - (with-random-integer-form-params - (make-random-integer-form (1+ (random size)))))) - (vals-list - (loop repeat *random-vals-list-bound* - collect - (mapcar #'(lambda (range) - (let ((lo (car range)) - (hi (cadr range))) - (random-from-interval (1+ hi) lo))) - var-ranges))) - (opt-decls-1 (make-random-optimize-settings)) - (opt-decls-2 (make-random-optimize-settings))) - (when *print-immediately* - (with-open-file - (s (format nil "~A~A.lsp" file-prefix index) - :direction :output :if-exists :error) - (print `(defparameter *x* - '(:vars ,vars - :var-types ,var-types - :vals-list ,vals-list - :decls1 ,opt-decls-1 - :decls2 ,opt-decls-2 - :form ,form)) - s) - (print '(load "c.lsp") s) - (finish-output s)) - ;; (cl-user::gc) - ;; (make-list 1000000) - ) - (test-int-form form vars var-types vals-list opt-decls-1 opt-decls-2))) - -(defun make-random-optimize-settings () - (loop for settings = (list* - (list 'speed (random 4)) - #+sbcl '(sb-c:insert-step-conditions 0) - (loop for s in '(space safety debug compilation-speed) - for n = (random 4) - collect (list s n))) - while - #+allegro (subsetp '((speed 3) (safety 0)) settings :test 'equal) - #-allegro nil - finally (return (random-permute settings)))) - -(defun fn-symbols-in-form (form) - "Return a list of the distinct standardized lisp function - symbols occuring ing FORM. These are used to generate a NOTINLINE - declaration for the unoptimized form." - (intersection - (remove-duplicates (fn-symbols-in-form* form) :test #'eq) - *cl-function-or-accessor-symbols*)) - -(defun fn-symbols-in-form* (form) - (when (consp form) - (if (symbolp (car form)) - (cons (car form) (mapcan #'fn-symbols-in-form* (cdr form))) - (mapcan #'fn-symbols-in-form* form)))) - -(defun fn-arg-name (fn-name arg-index) - (intern (concatenate 'string - (subseq (symbol-name fn-name) 1) - (format nil "-~D" arg-index)) - (symbol-package fn-name))) - -(declaim (special *flet-names*)) -(defparameter *flet-names* nil) - - - -(defun random-var-desc () - (loop - (let* ((pos (random (length *vars*))) - (desc (elt *vars* pos))) - (when (= pos (position (var-desc-name desc) (the list *vars*) - :key #'var-desc-name)) - (return desc))))) - -(defun is-zero-rank-integer-array-type (type) - "This function was introduced because of a bug in ACL 6.2" - ; (subtypep type '(array integer 0)) - (and (consp type) - (eq (car type) 'array) - (cddr type) - (or (eq (cadr type) '*) - (subtypep (cadr type) 'integer)) - (or (eql (caddr type) 0) - (null (caddr type))))) - -(defun make-random-integer-form (size) - "Generate a random legal lisp form of size SIZE (roughly)." - - (if (<= size 1) - ;; Leaf node -- generate a variable, constant, or flet function call - (loop - when - (rcase - (10 (make-random-integer)) - (9 (if *vars* - (let* ((desc (random-var-desc)) - (type (var-desc-type desc)) - (name (var-desc-name desc))) - (cond - ((subtypep type 'integer) name) - (; (subtypep type '(array integer 0)) - (is-zero-rank-integer-array-type type) - `(aref ,name)) - ((subtypep type '(cons integer integer)) - (rcase (1 `(car ,name)) - (1 `(cdr ,name)))) - (t nil))) - nil)) - (1 (if *go-tags* `(go ,(random-from-seq *go-tags*)) nil)) - (2 (if *flet-names* - (let* ((flet-entry (random-from-seq *flet-names*)) - (flet-name (car flet-entry)) - (flet-minargs (cadr flet-entry)) - (flet-maxargs (caddr flet-entry)) - (nargs (random-from-interval (1+ flet-maxargs) flet-minargs)) - (args (loop repeat nargs - collect (make-random-integer-form 1)))) - `(,flet-name ,@args)) - nil))) - return it) - ;; (> size 1) - (rselect *make-random-integer-form-cdf* - - ;; flet call - (make-random-integer-flet-call-form size) - (make-random-aref-form size) - ;; Unary ops - (let ((op (random-from-seq '(- abs signum 1+ 1- conjugate - rational rationalize - numerator denominator - identity progn floor - ;; #-(or armedbear) - ignore-errors - cl:handler-case - restart-case - ceiling truncate round realpart imagpart - integer-length logcount values - locally)))) - `(,op ,(make-random-integer-form (1- size)))) - - (make-random-integer-unwind-protect-form size) - (make-random-integer-mapping-form size) - - ;; prog1, multiple-value-prog1 - (let* ((op (random-from-seq #(prog1 multiple-value-prog1))) - (nforms (random 4)) - (sizes (random-partition (1- size) (1+ nforms))) - (args (mapcar #'make-random-integer-form sizes))) - `(,op ,@args)) - - ;; prog2 - (let* ((nforms (random 4)) - (sizes (random-partition (1- size) (+ nforms 2))) - (args (mapcar #'make-random-integer-form sizes))) - `(prog2 ,@args)) - - `(isqrt (abs ,(make-random-integer-form (- size 2)))) - - `(the integer ,(make-random-integer-form (1- size))) - - `(cl:handler-bind nil ,(make-random-integer-form (1- size))) - `(restart-bind nil ,(make-random-integer-form (1- size))) - #-armedbear - `(macrolet () ,(make-random-integer-form (1- size))) - #-armedbear - `(symbol-macrolet () ,(make-random-integer-form (1- size))) - - ;; dotimes - #-allegro - (let* ((var (random-from-seq #(iv1 iv2 iv3 iv4))) - (count (random 4)) - (sizes (random-partition (1- size) 2)) - (body (let ((*vars* (cons (make-var-desc :name var :type nil) - *vars*))) - (make-random-integer-form (first sizes)))) - (ret-form (make-random-integer-form (second sizes)))) - (unless (consp body) (setq body `(progn ,body))) - `(dotimes (,var ,count ,ret-form) ,body)) - - ;; loop - (make-random-loop-form (1- size)) - - (make-random-count-form size) - - #-(or gcl ecl armedbear) - ;; load-time-value - (let ((arg (let ((*flet-names* nil) - (*vars* nil) - (*random-int-form-blocks* nil) - (*random-int-form-catch-tags* nil) - (*go-tags* nil)) - (make-random-integer-form (1- size))))) - (rcase - (4 `(load-time-value ,arg t)) - (2 `(load-time-value ,arg)) - (2 `(load-time-value ,arg nil)))) - - ;; eval - (make-random-integer-eval-form size) - - #-(or cmu allegro poplog) - (destructuring-bind (s1 s2) - (random-partition (- size 2) 2) - `(ash ,(make-random-integer-form s1) - (min ,(random 100) - ,(make-random-integer-form s2)))) - - ;; binary floor, ceiling, truncate, round - (let ((op (random-from-seq #(floor ceiling truncate round mod rem))) - (op2 (random-from-seq #(max min)))) - (destructuring-bind (s1 s2) - (random-partition (- size 2) 2) - `(,op ,(make-random-integer-form s1) - (,op2 ,(if (eq op2 'max) - (1+ (random 100)) - (- (1+ (random 100)))) - ,(make-random-integer-form s2))))) - - ;; Binary op - (let* ((op (random-from-seq - '(+ - * logand min max gcd - lcm - #-:allegro - logandc1 - logandc2 logeqv logior lognand lognor - #-:allegro - logorc1 - logorc2 - logxor - )))) - (destructuring-bind (leftsize rightsize) - (random-partition (1- size) 2) - (let ((e1 (make-random-integer-form leftsize)) - (e2 (make-random-integer-form rightsize))) - `(,op ,e1 ,e2)))) - - ;; boole - (let* ((op (random-from-seq - #(boole-1 boole-2 boole-and boole-andc1 boole-andc2 - boole-c1 boole-c2 boole-clr boole-eqv boole-ior boole-nand - boole-nor boole-orc1 boole-orc2 boole-set boole-xor)))) - (destructuring-bind (leftsize rightsize) - (random-partition (- size 2) 2) - (let ((e1 (make-random-integer-form leftsize)) - (e2 (make-random-integer-form rightsize))) - `(boole ,op ,e1 ,e2)))) - - ;; n-ary ops - (let* ((op (random-from-seq #(+ - * logand min max - logior values lcm gcd logxor))) - (nmax (case op ((* lcm gcd) 4) (t (1+ (random 40))))) - (nargs (1+ (min (random nmax) (random nmax)))) - (sizes (random-partition (1- size) nargs)) - (args (mapcar #'make-random-integer-form sizes))) - `(,op ,@args)) - - ;; expt - `(expt ,(make-random-integer-form (1- size)) ,(random 3)) - - ;; coerce - `(coerce ,(make-random-integer-form (1- size)) 'integer) - - ;; complex (degenerate case) - `(complex ,(make-random-integer-form (1- size)) 0) - - ;; quotient (degenerate cases) - `(/ ,(make-random-integer-form (1- size)) 1) - `(/ ,(make-random-integer-form (1- size)) -1) - - ;; tagbody - (make-random-tagbody-and-progn size) - - ;; conditionals - (let* ((cond-size (random (max 1 (floor size 2)))) - (then-size (random (- size cond-size))) - (else-size (- size 1 cond-size then-size)) - (pred (make-random-pred-form cond-size)) - (then-part (make-random-integer-form then-size)) - (else-part (make-random-integer-form else-size))) - `(if ,pred ,then-part ,else-part)) - #-poplog - (destructuring-bind (s1 s2 s3) (random-partition (1- size) 3) - `(,(random-from-seq '(deposit-field dpb)) - ,(make-random-integer-form s1) - ,(make-random-byte-spec-form s2) - ,(make-random-integer-form s3))) - - #-(or allegro poplog) - (destructuring-bind (s1 s2) (random-partition (1- size) 2) - `(,(random-from-seq '(ldb mask-field)) - ,(make-random-byte-spec-form s1) - ,(make-random-integer-form s2))) - - (make-random-integer-binding-form size) - - ;; progv - (make-random-integer-progv-form size) - - `(let () ,(make-random-integer-form (1- size))) - - (let* ((name (random-from-seq #(b1 b2 b3 b4 b5 b6 b7 b8))) - (*random-int-form-blocks* (adjoin name *random-int-form-blocks*))) - `(block ,name ,(make-random-integer-form (1- size)))) - - (let* ((tag (list 'quote (random-from-seq #(ct1 ct2 ct2 ct4 ct5 ct6 ct7 ct8)))) - (*random-int-form-catch-tags* (cons tag *random-int-form-catch-tags*))) - `(catch ,tag ,(make-random-integer-form (1- size)))) - - ;; setq and similar - (make-random-integer-setq-form size) - - (make-random-integer-case-form size) - - (if *random-int-form-blocks* - (let ((name (random-from-seq *random-int-form-blocks*)) - (form (make-random-integer-form (1- size)))) - `(return-from ,name ,form)) - ;; No blocks -- try again - (make-random-integer-form size)) - - (if *random-int-form-catch-tags* - (let ((tag (random-from-seq *random-int-form-catch-tags*)) - (form (make-random-integer-form (1- size)))) - `(throw ,tag ,form)) - ;; No catch tags -- try again - (make-random-integer-form size)) - - (if *random-int-form-blocks* - (destructuring-bind (s1 s2 s3) (random-partition (1- size) 3) - (let ((name (random-from-seq *random-int-form-blocks*)) - (pred (make-random-pred-form s1)) - (then (make-random-integer-form s2)) - (else (make-random-integer-form s3))) - `(if ,pred (return-from ,name ,then) ,else))) - ;; No blocks -- try again - (make-random-integer-form size)) - - #-(or armedbear) - (make-random-flet-form size) - - (let* ((nbits (1+ (min (random 20) (random 20)))) - (bvec (coerce (loop repeat nbits collect (random 2)) 'simple-bit-vector)) - (op (random-from-seq #(bit sbit)))) - `(,op ,bvec (min ,(1- nbits) (max 0 ,(make-random-integer-form (- size 3 nbits)))))) - - (let* ((nvals (1+ (min (random 20) (random 20)))) - (lim (ash 1 (+ 3 (random 40)))) - (vec (coerce (loop repeat nvals collect (random lim)) 'simple-vector)) - (op (random-from-seq #(aref svref elt)))) - `(,op ,vec (min ,(1- nvals) (max 0 ,(make-random-integer-form (- size 3 nvals)))))) - - (let* ((nvals (1+ (min (random 20) (random 20)))) - (lim (ash 1 (+ 3 (random 40)))) - (vals (loop repeat nvals collect (random lim))) - (op 'elt)) - `(,op ',vals (min ,(1- nvals) (max 0 ,(make-random-integer-form (- size 3 nvals)))))) - - ))) - -(defun make-random-aref-form (size) - (or - (when *vars* - (let* ((desc (random-var-desc)) - (type (var-desc-type desc)) - (name (var-desc-name desc))) - (cond - ((null type) nil) - ((subtypep type '(array integer (*))) - `(aref ,name (min ,(1- (first (third type))) - (max 0 ,(make-random-integer-form (- size 2)))))) - ((subtypep type '(array integer (* *))) - (destructuring-bind (s1 s2) (random-partition (max 2 (- size 2)) 2) - `(aref ,name - (min ,(1- (first (third type))) - (max 0 ,(make-random-integer-form s1))) - (min ,(1- (second (third type))) - (max 0 ,(make-random-integer-form s2)))))) - (t nil)))) - (make-random-integer-form size))) - -(defun make-random-count-form (size) - (destructuring-bind (s1 s2) - (random-partition (1- size) 2) - (let ((arg1 (make-random-integer-form s1)) - (arg2-args (loop repeat s2 collect (make-random-integer)))) - (let ((op 'count) - (test (random-from-seq #(eql = /= < > <= >=))) - (arg2 (rcase - (1 (make-array (list s2) :initial-contents arg2-args)) - (1 - (let* ((mask (1- (ash 1 (1+ (random 32)))))) - (make-array (list s2) - :initial-contents - (mapcar #'(lambda (x) (logand x mask)) arg2-args) - :element-type `(integer 0 ,mask)))) - (1 `(quote ,arg2-args))))) - `(,op ,arg1 ,arg2 ,@(rcase - (2 nil) - (1 (list :test `(quote ,test))) - (1 (list :test-not `(quote ,test))))))))) - -(defun make-random-integer-flet-call-form (size) - (if *flet-names* - (let* ((flet-entry (random-from-seq *flet-names*)) - (flet-name (car flet-entry)) - (flet-minargs (cadr flet-entry)) - (flet-maxargs (caddr flet-entry)) - (nargs (random-from-interval (1+ flet-maxargs) flet-minargs)) - ) - (cond - ((> nargs 0) - (let* ((arg-sizes (random-partition (1- size) nargs)) - (args (mapcar #'make-random-integer-form arg-sizes))) - (rcase - (1 `(,flet-name ,@args)) - (1 `(multiple-value-call #',flet-name (values ,@args))) - (1 `(funcall (function ,flet-name) ,@args)) - (1 (let ((r (random (1+ (length args))))) - `(apply (function ,flet-name) - ,@(subseq args 0 r) - (list ,@(subseq args r)))))))) - (t (make-random-integer-form size)))) - (make-random-integer-form size))) - -(defun make-random-integer-unwind-protect-form (size) - (let* ((op 'unwind-protect) - (nforms (random 4)) - (sizes (random-partition (1- size) (1+ nforms))) - (arg (make-random-integer-form (first sizes))) - (unwind-forms - ;; We have to be careful not to generate code that will - ;; illegally transfer control to a dead location - (let ((*flet-names* nil) - (*go-tags* nil) - (*random-int-form-blocks* nil) - (*random-int-form-catch-tags* nil)) - (mapcar #'make-random-integer-form (rest sizes))))) - `(,op ,arg ,@unwind-forms))) - -(defun make-random-integer-eval-form (size) - (flet ((%arg (size) - (let ((*flet-names* nil) - (*vars* (remove-if-not #'(lambda (s) - (find (var-desc-name s) - *random-special-vars*)) - *vars*)) - (*random-int-form-blocks* nil) - (*go-tags* nil)) - (make-random-integer-form size)))) - (rcase - (2 `(eval ',(%arg (1- size)))) - (2 (let* ((nargs (1+ (random 4))) - (sizes (random-partition (1- size) nargs)) - (args (mapcar #'%arg sizes))) - `(eval (values ,@args)))) - ))) - -(defun make-random-type-for-var (var e1) - (let (desc) - (values - (cond - ((and (find var *random-special-vars*) - (setq desc (find var *vars* :key #'var-desc-name))) - (var-desc-type desc)) - (t (rcase - (4 '(integer * *)) - (1 (setq e1 `(make-array nil :initial-element ,e1 - ,@(rcase (1 nil) (1 '(:adjustable t))))) - '(array integer nil)) - (1 (let ((size (1+ (random 10)))) - (setq e1 `(make-array '(,size):initial-element ,e1 - ,@(rcase (1 nil) (1 '(:adjustable t))))) - `(array integer (,size)))) - #| - (1 (let ((size1 (1+ (random 10))) - (size2 (1+ (random 10)))) - (setq e1 `(make-array '(,size1 ,size2):initial-element ,e1 - ,@(rcase (1 nil) (1 '(:adjustable t))))) - `(array integer (,size1 ,size2)))) - |# - (1 (setq e1 `(cons ,e1 ,(make-random-integer-form 1))) - '(cons integer integer)) - (1 (setq e1 `(cons ,(make-random-integer-form 1) ,e1)) - '(cons integer integer))))) - e1))) - -(defun random2 (n) - (min (random n) (random n))) - -(defun random-from-seq2 (seq) - (elt seq (random2 (length seq)))) - -(defun make-random-integer-binding-form (size) - (destructuring-bind (s1 s2) (random-partition (1- size) 2) - (let* ((var (random-from-seq2 (rcase - (2 #(v1 v2 v3 v4 v5 v6 v7 v8 v9 v10)) - #-ecl (2 *random-special-vars*) - ))) - (e1 (make-random-integer-form s1)) - (type (multiple-value-bind (type2 e) - (make-random-type-for-var var e1) - (setq e1 e) - type2)) - (e2 (let ((*vars* (cons (make-var-desc :name var :type type) - *vars*))) - (make-random-integer-form s2))) - (op (random-from-seq #(let let*)))) - ;; for now, avoid shadowing - (if (member var *vars* :key #'var-desc-name) - (make-random-integer-form size) - (rcase - (8 `(,op ((,var ,e1)) - ,@(rcase (1 `((declare (dynamic-extent ,var)))) - (3 nil)) - ,e2)) - (2 `(multiple-value-bind (,var) ,e1 ,e2))))))) - -(defun make-random-integer-progv-form (size) - (let* ((num-vars (random 4)) - (possible-vars *random-special-vars*) - (vars nil)) - (loop repeat num-vars - do (loop for r = (elt possible-vars (random (length possible-vars))) - while (member r vars) - finally (push r vars))) - (setq vars (remove-if #'(lambda (var) (let ((desc (find var *vars* :key #'var-desc-name))) - (and desc (not (subtypep (var-desc-type desc) 'integer))))) - vars) - num-vars (length vars)) - (if (null vars) - `(progv nil nil ,(make-random-integer-form (1- size))) - (destructuring-bind (s1 s2) (random-partition (1- size) 2) - (let* ((var-sizes (random-partition s1 num-vars)) - (var-forms (mapcar #'make-random-integer-form var-sizes)) - (*vars* (append (loop for v in vars collect - (make-var-desc :name v :type '(integer * *))) - *vars*)) - (body-form (make-random-integer-form s2))) - `(progv ',vars (list ,@var-forms) ,body-form)))))) - -(defun make-random-integer-mapping-form (size) - ;; reduce - (let ((keyargs nil) - (nargs (1+ (random (min 10 (max 1 size))))) - (sequence-op (random-from-seq '(vector list)))) - (when (coin 2) (setq keyargs '(:from-end t))) - (cond - ((coin 2) - (let ((start (random nargs))) - (setq keyargs `(:start ,start ,@keyargs)) - (when (coin 2) - (let ((end (+ start 1 (random (- nargs start))))) - (setq keyargs `(:end ,end ,@keyargs)))))) - (t - (when (coin 2) - (let ((end (1+ (random nargs)))) - (setq keyargs `(:end ,end ,@keyargs)))))) - (rcase - (1 - (let ((sizes (random-partition (1- size) nargs)) - (op (random-from-seq #(+ - * logand logxor logior max min)))) - `(reduce ,(rcase (1 `(function ,op)) - (1 `(quote ,op))) - (,sequence-op - ,@(mapcar #'make-random-integer-form sizes)) - ,@keyargs))) - #-(or armedbear) - (1 - (destructuring-bind (size1 size2) (random-partition (1- size) 2) - (let* ((vars '(lmv1 lmv2 lmv3 lmv4 lmv5 lmv6)) - (var1 (random-from-seq vars)) - (var2 (random-from-seq (remove var1 vars))) - (form (let ((*vars* (list* - (make-var-desc :name var1 :type '(integer * *)) - (make-var-desc :name var2 :type '(integer * *)) - *vars*))) - (make-random-integer-form size1))) - (sizes (random-partition size2 nargs)) - (args (mapcar #'make-random-integer-form sizes))) - `(reduce (function (lambda (,var1 ,var2) ,form)) - (,sequence-op ,@args) - ,@keyargs))))))) - -(defun make-random-integer-setq-form (size) - (if *vars* - (let* ((vdesc (random-from-seq *vars*)) - (var (var-desc-name vdesc)) - (type (var-desc-type vdesc)) - (op (random-from-seq #(setq setf shiftf)))) - (cond - ((subtypep '(integer * *) type) - (assert (not (member var '(lv1 lv2 lv3 lv4 lv5 lv6 lv7 lv8)))) - (rcase - (1 (when (find var *random-special-vars*) - (setq op (random-from-seq #(setf shiftf)) - var `(symbol-value ',var)))) - (1 (setq op 'multiple-value-setq) - (setq var (list var))) - (5 (setf op (random-from-seq #(setq setf shiftf incf decf))))) - `(,op ,var ,(make-random-integer-form (1- size)))) - ((and (consp type) - (eq (car type) 'integer) - (integerp (second type)) - (integerp (third type))) - (assert (not (member var '(lv1 lv2 lv3 lv4 lv5 lv6 lv7 lv8)))) - (rcase - (1 (when (find var *random-special-vars*) - (setq op (random-from-seq #(setf shiftf)) - var `(symbol-value ',var)))) - (1 (setq op 'multiple-value-setq) - (setq var (list var))) - (5 nil)) - `(,op ,var ,(random-from-interval (1+ (third type)) (second type)))) - ((and type (is-zero-rank-integer-array-type type)) ; (subtypep type '(array integer nil)) - (assert (not (member var '(lv1 lv2 lv3 lv4 lv5 lv6 lv7 lv8)))) - (when (eq op 'setq) - (setq op (random-from-seq #(setf shiftf)))) - `(,op (aref ,var) ,(make-random-integer-form (- size 2)))) - ((and type (subtypep type '(array integer (*)))) - (when (eq op 'setq) - (setq op (random-from-seq #(setf shiftf)))) - (destructuring-bind (s1 s2) (random-partition (max 2 (- size 2)) 2) - `(,op (aref ,var (min ,(1- (first (third type))) - (max 0 - ,(make-random-integer-form s1)))) - ,(make-random-integer-form s2)))) - ((and type (subtypep type '(array integer (* *)))) - (when (eq op 'setq) - (setq op (random-from-seq #(setf shiftf)))) - (destructuring-bind (s1 s2 s3) (random-partition (max 3 (- size 3)) 3) - `(,op (aref ,var - (min ,(1- (first (third type))) - (max 0 - ,(make-random-integer-form s1))) - (min ,(1- (second (third type))) - (max 0 - ,(make-random-integer-form s2)))) - ,(make-random-integer-form s3)))) - ;; Abort -- can't assign - (t (make-random-integer-form size)))) - (make-random-integer-form size))) - - -(defun make-random-integer-case-form (size) - (let ((ncases (1+ (random 10)))) - (if (< (+ size size) (+ ncases 2)) - ;; Too small, give up - (make-random-integer-form size) - (let* ((sizes (random-partition (1- size) (+ ncases 2))) - (bound (ash 1 (+ 2 (random 16)))) - (lower-bound (if (coin 3) 0 (- bound))) - (upper-bound (if (and (< lower-bound 0) (coin 3)) - 1 - (1+ bound))) - (cases - (loop - for case-size in (cddr sizes) - for vals = (loop repeat (1+ (min (random 10) (random 10))) - collect (random-from-interval - upper-bound lower-bound)) - for result = (make-random-integer-form case-size) - repeat ncases - collect `(,vals ,result))) - (expr (make-random-integer-form (first sizes)))) - `(case ,expr - ,@cases - (t ,(make-random-integer-form (second sizes)))))))) - -(defun make-random-flet-form (size) - "Generate random flet, labels forms, for now with no arguments - and a single binding per form." - (let ((fname (random-from-seq #(%f1 %f2 %f3 %f4 %f5 %f6 %f7 %f8 %f9 %f10 - %f11 %f12 %f13 %f14 %f15 %f16 %f17 %f18)))) - (if (assoc fname *flet-names*) - ;; Fail if the name is in use - (make-random-integer-form size) - (let* ((op (random-from-seq #(flet labels))) - (minargs (random 4)) - (maxargs #+:allegro minargs - #-:allegro - (rcase - (1 minargs) - (1 (+ minargs (random 4))))) - (keyarg-p (coin 2)) - (keyarg-n (if keyarg-p (random 3) 0)) - (arg-names (loop for i from 1 to maxargs - collect (fn-arg-name fname i))) - (key-arg-names (loop for i from 1 to keyarg-n - collect (intern (format nil "KEY~A" i) - (find-package "CL-TEST")))) - (allow-other-keys (and keyarg-p (coin 3))) - ) - (let* ((sizes (random-partition (1- size) (+ 2 keyarg-n (- maxargs minargs)))) - (s1 (car sizes)) - (s2 (cadr sizes)) - (opt-sizes (cddr sizes))) - (let* ((form1 - ;; Allow return-from of the flet/labels function - (let ((*random-int-form-blocks* - (cons fname *random-int-form-blocks*)) - (*vars* (nconc (loop for var in (append arg-names key-arg-names) - collect (make-var-desc :name var - :type '(integer * *))) - *vars*))) - (make-random-integer-form s1))) - (form2 (let ((*flet-names* (cons (list fname minargs maxargs keyarg-p) - *flet-names*))) - (make-random-integer-form s2))) - (opt-forms (mapcar #'make-random-integer-form opt-sizes) - )) - (if opt-forms - `(,op ((,fname (,@(subseq arg-names 0 minargs) - &optional - ,@(mapcar #'list - (subseq arg-names minargs) - opt-forms) - ,@(when keyarg-p - (append '(&key) - (mapcar #'list - key-arg-names - (subseq opt-forms (- maxargs minargs))) - (when allow-other-keys '(&allow-other-keys)) - ))) - ,form1)) - ,form2) - `(,op ((,fname (,@arg-names - ,@(when keyarg-p - (append '(&key) - (mapcar #'list - key-arg-names - opt-forms ) - (when allow-other-keys '(&allow-other-keys)) - ))) - ,form1)) - ,form2)))))))) - -(defun make-random-tagbody (size) - (let* ((num-forms (random 6)) - (tags nil)) - (loop for i below num-forms - do (loop for tag = (rcase - #-allegro (1 (random 8)) - (1 (random-from-seq #(tag1 tag2 tag3 tag4 - tag5 tag6 tag7 tag8)))) - while (member tag tags) - finally (push tag tags))) - (assert (= (length (remove-duplicates tags)) (length tags))) - (let* ((*go-tags* (set-difference *go-tags* tags)) - (sizes (if (> num-forms 0) (random-partition (1- size) num-forms) nil)) - (forms - (loop for tag-list on tags - for i below num-forms - for size in sizes - collect (let ((*go-tags* (append tag-list *go-tags*))) - (make-random-integer-form size))))) - `(tagbody ,@(loop for tag in tags - for form in forms - when (atom form) do (setq form `(progn ,form)) - append `(,form ,tag)))))) - -(defun make-random-tagbody-and-progn (size) - (let* ((final-size (random (max 1 (floor size 5)))) - (tagbody-size (- size final-size))) - (let ((final-form (make-random-integer-form final-size)) - (tagbody-form (make-random-tagbody tagbody-size))) - `(progn ,tagbody-form ,final-form)))) - -(defun make-random-pred-form (size) - "Make a random form whose value is to be used as a generalized boolean." - (if (<= size 1) - (rcase - (1 (if (coin) t nil)) - (2 - `(,(random-from-seq '(< <= = > >= /= eql equal)) - ,(make-random-integer-form size) - ,(make-random-integer-form size)))) - (rcase - (1 (if (coin) t nil)) - (3 `(not ,(make-random-pred-form (1- size)))) - (12 (destructuring-bind (leftsize rightsize) - (random-partition (1- size) 2) - `(,(random-from-seq '(and or)) - ,(make-random-pred-form leftsize) - ,(make-random-pred-form rightsize)))) - (1 (let* ((nsizes (+ 1 (random 3))) - (sizes (random-partition (1- size) nsizes))) - `(,(random-from-seq (if (= nsizes 2) #(< <= > >= = /= eql equal) - #(< <= > >= = /=))) - ,@(mapcar #'make-random-integer-form sizes)))) - (3 (let* ((cond-size (random (max 1 (floor size 2)))) - (then-size (random (- size cond-size))) - (else-size (- size 1 cond-size then-size)) - (pred (make-random-pred-form cond-size)) - (then-part (make-random-pred-form then-size)) - (else-part (make-random-pred-form else-size))) - `(if ,pred ,then-part ,else-part))) - #-poplog - (1 (destructuring-bind (s1 s2) - (random-partition (1- size) 2) - `(ldb-test ,(make-random-byte-spec-form s1) - ,(make-random-integer-form s2)))) - (2 (let ((form (make-random-integer-form (1- size))) - (op (random-from-seq #(evenp oddp minusp plusp zerop)))) - `(,op ,form))) - (2 (destructuring-bind (s1 s2) - (random-partition (1- size) 2) - (let ((arg1 (make-random-integer-form s1)) - (arg2-args (loop repeat s2 collect (make-random-integer)))) - (let ((op (random-from-seq #(find position))) - (test (random-from-seq #(eql = /= < > <= >=))) - (arg2 (rcase - (1 (make-array (list s2) :initial-contents arg2-args)) - (1 - (let* ((mask (1- (ash 1 (1+ (random 32)))))) - (make-array (list s2) - :initial-contents - (mapcar #'(lambda (x) (logand x mask)) arg2-args) - :element-type `(integer 0 ,mask)))) - (1 `(quote ,arg2-args))))) - `(,op ,arg1 ,arg2 ,@(rcase - (2 nil) - (1 (list :test `(quote ,test))) - (1 (list :test-not `(quote ,test))))))))) - - (1 (let ((index (random (1+ (random *maximum-random-int-bits*)))) - (form (make-random-integer-form (1- size)))) - `(logbitp ,index ,form))) - (1 ;; typep form - (let ((subform (make-random-integer-form (- size 2))) - (type - (rcase - (1 `(real ,@(make-random-integer-range))) - (1 `(rational ,@(make-random-integer-range))) - (1 `(rational ,(+ 1/2 (make-random-integer)))) - (1 `(rational * ,(+ 1/2 (make-random-integer)))) - (1 `(integer ,@(make-random-integer-range))) - (1 `(integer ,(make-random-integer))) - (1 `(integer * ,(make-random-integer))) - (1 'fixnum) - (1 'bignum) - (1 `(integer))))) - `(typep ,subform ',type))) - ))) - -(defun make-random-loop-form (size) - (if (<= size 2) - (make-random-integer-form size) - (let* ((var (random-from-seq #(lv1 lv2 lv3 lv4))) - (count (random 4)) - (*vars* (cons (make-var-desc :name var :type nil) - *vars*))) - (rcase - (1 `(loop for ,var below ,count count ,(make-random-pred-form (- size 2)))) - (1 `(loop for ,var below ,count sum ,(make-random-integer-form (- size 2)))) - )))) - -(defun make-random-byte-spec-form (size) - (declare (ignore size)) - (let* ((pform (random 33)) - (sform (1+ (random 33)))) - `(byte ,sform ,pform))) - -(defgeneric make-random-element-of-type (type) - (:documentation "Create a random element of a lisp type.")) - -(defgeneric make-random-element-of-compound-type (type-op type-args) - (:documentation "Create a random element of type `(,TYPE-OP ,@TYPE-ARGS)") - (:method ((type-op (eql 'or)) type-args) - (assert type-args) - (make-random-element-of-type (random-from-seq type-args))) - (:method ((type-op (eql 'and)) type-args) - (assert type-args) - (loop for x = (make-random-element-of-type (car type-args)) - repeat 100 - when (typep x (cons 'and (cdr type-args))) - return x - finally (error "Cannot generate random element of ~A" - (cons type-op type-args)))) - (:method ((type-op (eql 'not)) type-args) - (assert (eql (length type-args) 1)) - (make-random-element-of-type `(and t (not ,(car type-args))))) - (:method ((type-op (eql 'integer)) type-args) - (let ((lo (let ((lo (car type-args))) - (cond - ((consp lo) (1+ (car lo))) - ((eq lo nil) '*) - (t lo)))) - (hi (let ((hi (cadr type-args))) - (cond - ((consp hi) (1- (car hi))) - ((eq hi nil) '*) - (t hi))))) - (if (eq lo '*) - (if (eq hi '*) - (let ((x (ash 1 (random *maximum-random-int-bits*)))) - (random-from-interval x (- x))) - (random-from-interval (1+ hi) - (- hi (random (ash 1 *maximum-random-int-bits*))))) - - (if (eq hi '*) - (random-from-interval (+ lo (random (ash 1 *maximum-random-int-bits*)) 1) - lo) - ;; May generalize the next case to increase odds - ;; of certain integers (near 0, near endpoints, near - ;; powers of 2...) - (random-from-interval (1+ hi) lo))))) - (:method ((type-op (eql 'rational)) type-args) - (let ((type (cons type-op type-args))) - (or - (let ((r (make-random-element-of-type 'rational))) - (and (typep r type) r)) - (let ((lo (car type-args)) - (hi (cadr type-args)) - lo= hi=) - (cond - ((consp lo) nil) - ((member lo '(* nil)) - (setq lo nil) - (setq lo= nil)) - (t - (assert (typep lo 'rational)) - (setq lo= t))) - (cond - ((consp hi) nil) - ((member hi '(* nil)) - (setq hi nil) - (setq hi= nil)) - (t - (assert (typep hi 'rational)) - (setq hi= t))) - (assert (or (null lo) (null hi) (<= lo hi))) - (assert (or (null lo) (null hi) (< lo hi) (and lo= hi=))) - (cond - ((null lo) - (cond - ((null hi) (make-random-rational)) - (hi= (- hi (make-random-nonnegative-rational))) - (t (- hi (make-random-positive-rational))))) - ((null hi) - (cond - (lo= (+ lo (make-random-nonnegative-rational))) - (t (+ lo (make-random-positive-rational))))) - (t - (+ lo (make-random-bounded-rational (- hi lo) lo= hi=)))))))) - - (:method ((type-op (eql 'ratio)) type-args) - (let ((r 0)) - (loop - do (setq r (make-random-element-of-compound-type 'rational type-args)) - while (integerp r)) - r)) - - (:method ((type-op (eql 'real)) type-args) - (rcase - (1 (let ((lo (and (numberp (car type-args)) - (rational (car type-args)))) - (hi (and (numberp (cadr type-args)) - (rational (cadr type-args))))) - (make-random-element-of-compound-type 'rational - `(,(or lo '*) - ,(or hi '*))))) - (1 (make-random-element-of-compound-type 'float - `(,(or (car type-args) '*) - ,(or (cadr type-args) '*)))))) - - (:method ((type-op (eql 'float)) type-args) - (let* ((new-type-op (random-from-seq #(single-float double-float long-float short-float))) - (lo (car type-args)) - (hi (cadr type-args)) - (most-neg (most-negative-float new-type-op)) - (most-pos (most-positive-float new-type-op))) - (cond - ((or (and (realp lo) (< lo most-neg)) - (and (realp hi) (> hi most-pos))) - ;; try again - (make-random-element-of-compound-type type-op type-args)) - (t - (when (and (realp lo) (not (typep lo new-type-op))) - (cond - ((< lo most-neg) (setq lo '*)) - (t (setq lo (coerce lo new-type-op))))) - (when (and (realp hi) (not (typep hi new-type-op))) - (cond - ((> hi most-pos) (setq hi '*)) - (t (setq hi (coerce hi new-type-op))))) - (make-random-element-of-compound-type new-type-op `(,(or lo '*) ,(or hi '*))))))) - - (:method ((type-op (eql 'short-float)) type-args) - (assert (<= (length type-args) 2)) - (apply #'make-random-element-of-float-type type-op type-args)) - (:method ((type-op (eql 'single-float)) type-args) - (assert (<= (length type-args) 2)) - (apply #'make-random-element-of-float-type type-op type-args)) - (:method ((type-op (eql 'double-float)) type-args) - (assert (<= (length type-args) 2)) - (apply #'make-random-element-of-float-type type-op type-args)) - (:method ((type-op (eql 'long-float)) type-args) - (assert (<= (length type-args) 2)) - (apply #'make-random-element-of-float-type type-op type-args)) - - (:method ((type-op (eql 'mod)) type-args) - (let ((modulus (second type-args))) - (assert (integerp modulus)) - (assert (plusp modulus)) - (make-random-element-of-compound-type 'integer `(0 (,modulus))))) - - (:method ((type-op (eql 'unsigned-byte)) type-args) - (assert (<= (length type-args) 1)) - (if (null type-args) - (make-random-element-of-type '(integer 0 *)) - (let ((bits (first type-args))) - (if (eq bits '*) - (make-random-element-of-type '(integer 0 *)) - (progn - (assert (and (integerp bits) (>= bits 1))) - (make-random-element-of-type - `(integer 0 ,(1- (ash 1 bits))))))))) - - (:method ((type-op (eql 'signed-byte)) type-args) - (assert (<= (length type-args) 1)) - (if (null type-args) - (make-random-element-of-type 'integer) - (let ((bits (car type-args))) - (if (eq bits'*) - (make-random-element-of-type 'integer) - (progn - (assert (and (integerp bits) (>= bits 1))) - (make-random-element-of-type - `(integer ,(- (ash 1 (1- bits))) ,(1- (ash 1 (1- bits)))))))))) - - (:method ((type-op (eql 'eql)) type-args) - (assert (= (length type-args) 1)) - (car type-args)) - - (:method ((type-op (eql 'member)) type-args) - (assert type-args) - (random-from-seq type-args)) - - (:method ((type-op (eql 'vector)) type-args) - (assert (<= (length type-args) 2)) - (let ((etype-spec (if type-args (car type-args) '*)) - (size-spec (if (cdr type-args) (cadr type-args) '*))) - (make-random-vector etype-spec size-spec))) - - (:method ((type-op (eql 'aimple-vector)) type-args) - (assert (<= (length type-args) 1)) - (let ((size-spec (if type-args (car type-args) '*))) - (make-random-vector t size-spec :simple t))) - - (:method ((type-op (eql 'array)) type-args) - (assert (<= (length type-args) 2)) - (let ((etype-spec (if type-args (car type-args) '*)) - (size-spec (if (cdr type-args) (cadr type-args) '*))) - (make-random-array etype-spec size-spec))) - - (:method ((type-op (eql 'simple-array)) type-args) - (assert (<= (length type-args) 2)) - (let ((etype-spec (if type-args (car type-args) '*)) - (size-spec (if (cdr type-args) (cadr type-args) '*))) - (make-random-array etype-spec size-spec :simple t))) - - (:method ((type-op (eql 'string)) type-args) - (assert (<= (length type-args) 1)) - (let ((size-spec (if type-args (car type-args) '*))) - (make-random-string size-spec))) - - (:method ((type-op (eql 'simple-string)) type-args) - (assert (<= (length type-args) 1)) - (let ((size-spec (if type-args (car type-args) '*))) - (make-random-string size-spec :simple t))) - - (:method ((type-op (eql 'base-string)) type-args) - (assert (<= (length type-args) 1)) - (let ((size-spec (if type-args (car type-args) '*))) - (make-random-vector 'base-char size-spec))) - - (:method ((type-op (eql 'simple-base-string)) type-args) - (assert (<= (length type-args) 1)) - (let ((size-spec (if type-args (car type-args) '*))) - (make-random-vector 'base-char size-spec :simple t))) - - (:method ((type-op (eql 'bit-vector)) type-args) - (assert (<= (length type-args) 1)) - (let ((size-spec (if type-args (car type-args) '*))) - (make-random-vector 'bit size-spec))) - - (:method ((type-op (eql 'simple-bit-vector)) type-args) - (assert (<= (length type-args) 1)) - (let ((size-spec (if type-args (car type-args) '*))) - (make-random-vector 'bit size-spec :simple t))) - - (:method ((type-op (eql 'cons)) type-args) - (assert (<= (length type-args) 2)) - (cons (make-random-element-of-type (if type-args (car type-args) t)) - (make-random-element-of-type (if (cdr type-args) (cadr type-args) t)))) - - (:method ((type-op (eql 'complex)) type-args) - (cond - ((null type-args) - (make-random-element-of-type 'complex)) - (t - (assert (null (cdr type-args))) - (let ((etype (car type-args))) - (loop for v1 = (make-random-element-of-type etype) - for v2 = (make-random-element-of-type etype) - for c = (complex v1 v2) - when (typep c (cons 'complex type-args)) - return c))))) - ) - -(defmethod make-random-element-of-type ((type cons)) - (make-random-element-of-compound-type (car type) (cdr type))) - -(defun make-random-element-of-float-type (type-op &optional lo hi) - (let (lo= hi=) - (cond - ((consp lo) nil) - ((member lo '(* nil)) - (setq lo (most-negative-float type-op)) - (setq lo= t)) - (t - (assert (typep lo type-op)) - (setq lo= t))) - (cond - ((consp hi) nil) - ((member hi '(* nil)) - (setq hi (most-positive-float type-op)) - (setq hi= t)) - (t - (assert (typep hi type-op)) - (setq hi= t))) - (assert (<= lo hi)) - (assert (or (< lo hi) (and lo= hi=))) - (let ((limit 100000)) - (cond - ((or (<= hi 0) - (>= lo 0) - (and (<= (- limit) hi limit) (<= (- limit) lo limit))) - (loop for x = (+ (random (- hi lo)) lo) - do (when (or lo= (/= x lo)) (return x)))) - (t - (rcase - (1 (random (min hi (float limit hi)))) - (1 (- (random (min (float limit lo) (- lo))))))))))) - -#| -(defmethod make-random-element-of-type ((type cons)) - (let ((type-op (first type))) - (ecase type-op - (or - (assert (cdr type)) - (make-random-element-of-type (random-from-seq (cdr type)))) - (and - (assert (cdr type)) - (loop for x = (make-random-element-of-type (cadr type)) - repeat 100 - when (typep x (cons 'and (cddr type))) - return x - finally (error "Cannot generate random element of ~A" type))) - (not - (assert (cdr type)) - (assert (not (cddr type))) - (make-random-element-of-type `(and t ,type))) - (integer - (let ((lo (let ((lo (cadr type))) - (cond - ((consp lo) (1+ (car lo))) - ((eq lo nil) '*) - (t lo)))) - (hi (let ((hi (caddr type))) - (cond - ((consp hi) (1- (car hi))) - ((eq hi nil) '*) - (t hi))))) - (if (eq lo '*) - (if (eq hi '*) - (let ((x (ash 1 (random *maximum-random-int-bits*)))) - (random-from-interval x (- x))) - (random-from-interval (1+ hi) - (- hi (random (ash 1 *maximum-random-int-bits*))))) - - (if (eq hi '*) - (random-from-interval (+ lo (random (ash 1 *maximum-random-int-bits*)) 1) - lo) - ;; May generalize the next case to increase odds - ;; of certain integers (near 0, near endpoints, near - ;; powers of 2...) - (random-from-interval (1+ hi) lo))))) - - (rational - (or - (let ((r (make-random-element-of-type 'rational))) - (and (typep r type) r)) - (let ((lo (cadr type)) - (hi (caddr type)) - lo= hi=) - (cond - ((consp lo) nil) - ((member lo '(* nil)) - (setq lo nil) - (setq lo= nil)) - (t - (assert (typep lo 'rational)) - (setq lo= t))) - (cond - ((consp hi) nil) - ((member hi '(* nil)) - (setq hi nil) - (setq hi= nil)) - (t - (assert (typep hi 'rational)) - (setq hi= t))) - (assert (or (null lo) (null hi) (<= lo hi))) - (assert (or (null lo) (null hi) (< lo hi) (and lo= hi=))) - (cond - ((null lo) - (cond - ((null hi) (make-random-rational)) - (hi= (- hi (make-random-nonnegative-rational))) - (t (- hi (make-random-positive-rational))))) - ((null hi) - (cond - (lo= (+ lo (make-random-nonnegative-rational))) - (t (+ lo (make-random-positive-rational))))) - (t - (+ lo (make-random-bounded-rational (- hi lo) lo= hi=))))))) - - (ratio - (let ((r 0)) - (loop - do (setq r (make-random-element-of-type `(rational ,@(cdr type)))) - while (integerp r)) - r)) - - (real - (rcase - (1 (let ((lo (and (numberp (cadr type)) - (rational (cadr type)))) - (hi (and (numberp (caddr type)) - (rational (caddr type))))) - (make-random-element-of-type `(rational ,(or lo '*) - ,(or hi '*))))) - (1 (make-random-element-of-type `(float ,(or (cadr type) '*) - ,(or (caddr type) '*)))))) - - ((float) - (let* ((new-type-op (random-from-seq #(single-float double-float - long-float short-float))) - (lo (cadr type)) - (hi (caddr type)) - (most-neg (most-negative-float new-type-op)) - (most-pos (most-positive-float new-type-op))) - (cond - ((or (and (realp lo) (< lo most-neg)) - (and (realp hi) (> hi most-pos))) - ;; try again - (make-random-element-of-type type)) - (t - (when (and (realp lo) (not (typep lo new-type-op))) - (cond - ((< lo most-neg) (setq lo '*)) - (t (setq lo (coerce lo new-type-op))))) - (when (and (realp hi) (not (typep hi new-type-op))) - (cond - ((> hi most-pos) (setq hi '*)) - (t (setq hi (coerce hi new-type-op))))) - (make-random-element-of-type - `(,new-type-op ,(or lo '*) ,(or hi '*))))))) - - ((single-float double-float long-float short-float) - (let ((lo (cadr type)) - (hi (caddr type)) - lo= hi=) - (cond - ((consp lo) nil) - ((member lo '(* nil)) - (setq lo (most-negative-float type-op)) - (setq lo= t)) - (t - (assert (typep lo type-op)) - (setq lo= t))) - (cond - ((consp hi) nil) - ((member hi '(* nil)) - (setq hi (most-positive-float type-op)) - (setq hi= t)) - (t - (assert (typep hi type-op)) - (setq hi= t))) - (assert (<= lo hi)) - (assert (or (< lo hi) (and lo= hi=))) - (let ((limit 100000)) - (cond - ((or (<= hi 0) - (>= lo 0) - (and (<= (- limit) hi limit) (<= (- limit) lo limit))) - (loop for x = (+ (random (- hi lo)) lo) - do (when (or lo= (/= x lo)) (return x)))) - (t - (rcase - (1 (random (min hi (float limit hi)))) - (1 (- (random (min (float limit lo) (- lo))))))))))) - - (mod - (let ((modulus (second type))) - (assert (and (integerp modulus) - (plusp modulus))) - (make-random-element-of-type `(integer 0 (,modulus))))) - (unsigned-byte - (if (null (cdr type)) - (make-random-element-of-type '(integer 0 *)) - (let ((bits (second type))) - (if (eq bits'*) - (make-random-element-of-type '(integer 0 *)) - (progn - (assert (and (integerp bits) (>= bits 1))) - (make-random-element-of-type - `(integer 0 ,(1- (ash 1 bits))))))))) - (signed-byte - (if (null (cdr type)) - (make-random-element-of-type 'integer) - (let ((bits (second type))) - (if (eq bits'*) - (make-random-element-of-type 'integer) - (progn - (assert (and (integerp bits) (>= bits 1))) - (make-random-element-of-type - `(integer ,(- (ash 1 (1- bits))) ,(1- (ash 1 (1- bits)))))))))) - (eql - (assert (= (length type) 2)) - (cadr type)) - (member - (assert (cdr type)) - (random-from-seq (cdr type))) - ((vector) - (let ((etype-spec (if (cdr type) (cadr type) '*)) - (size-spec (if (cddr type) (caddr type) '*))) - (make-random-vector etype-spec size-spec))) - ((simple-vector) - (let ((size-spec (if (cdr type) (cadr type) '*))) - (make-random-vector t size-spec :simple t))) - ((array simple-array) - (let ((etype-spec (if (cdr type) (cadr type) '*)) - (size-spec (if (cddr type) (caddr type) '*))) - (make-random-array etype-spec size-spec :simple (eql (car type) 'simple-array)))) - ((string simple-string) - (let ((size-spec (if (cdr type) (cadr type) '*))) - (make-random-string size-spec :simple (eql (car type) 'simple-string)))) - ((base-string simple-base-string) - (let ((size-spec (if (cdr type) (cadr type) '*))) - (make-random-vector 'base-char size-spec :simple (eql (car type) 'simple-base-string)))) - ((bit-vector simple-bit-vector) - (let ((size-spec (if (cdr type) (cadr type) '*))) - (make-random-vector 'bit size-spec :simple (eql (car type) 'simple-bit-vector)))) - ((cons) - (cons (make-random-element-of-type (if (cdr type) (cadr type) t)) - (make-random-element-of-type (if (cddr type) (caddr type) t)))) - ((complex) - (cond - ((null (cdr type)) - (make-random-element-of-type 'complex)) - (t - (assert (null (cddr type))) - (let ((etype (cadr type))) - (loop for v1 = (make-random-element-of-type etype) - for v2 = (make-random-element-of-type etype) - for c = (complex v1 v2) - when (typep c type) - return c))))) - ))) -|# - -(defmethod make-random-element-of-type ((type class)) - (make-random-element-of-type (class-name type))) - -(defmethod make-random-element-of-type ((type (eql 'bit))) (random 2)) -(defmethod make-random-element-of-type ((type (eql 'boolean))) - (random-from-seq #(nil t))) -(defmethod make-random-element-of-type ((type (eql 'symbol))) - (random-from-seq #(nil t a b c :a :b :c |z| foo |foo| car))) -(defmethod make-random-element-of-type ((type (eql 'keyword))) - (random-from-seq #(:a :b :c :d :e :f :g :h :i :j))) -(defmethod make-random-element-of-type ((type (eql 'unsigned-byte))) - (random-from-interval (1+ (ash 1 (random *maximum-random-int-bits*))) 0)) -(defmethod make-random-element-of-type ((type (eql 'signed-byte))) - (random-from-interval - (1+ (ash 1 (random *maximum-random-int-bits*))) - (- (ash 1 (random *maximum-random-int-bits*))))) -(defmethod make-random-element-of-type ((type (eql 'rational))) - (make-random-rational)) -(defmethod make-random-element-of-type ((type (eql 'ratio))) - (let ((r 0)) - (loop do (setq r (make-random-element-of-type 'rational)) - while (integerp r)) - r)) -(defmethod make-random-element-of-type ((type (eql 'integer))) - (let ((x (ash 1 (random *maximum-random-int-bits*)))) - (random-from-interval (1+ x) (- x)))) -(defmethod make-random-element-of-type ((type (eql 'float))) - (make-random-element-of-type - (random-from-seq #(short-float single-float double-float long-float)))) -(defmethod make-random-element-of-type ((type (eql 'real))) - (make-random-element-of-type (random-from-seq #(integer rational float)))) -(defmethod make-random-element-of-type ((type (eql 'number))) - (make-random-element-of-type (random-from-seq #(integer rational float #-ecl complex)))) -(defmethod make-random-element-of-type ((type (eql 'bit-vector))) - (make-random-vector 'bit '*)) -(defmethod make-random-element-of-type ((type (eql 'simple-bit-vector))) - (make-random-vector 'bit '* :simple t)) -(defmethod make-random-element-of-type ((type (eql 'vector))) - (make-random-vector '* '*)) -(defmethod make-random-element-of-type ((type (eql 'simple-vector))) - (make-random-vector 't '* :simple t)) -(defmethod make-random-element-of-type ((type (eql 'array))) - (make-random-array '* '*)) -(defmethod make-random-element-of-type ((type (eql 'simple-array))) - (make-random-array '* '* :simple t)) -(defmethod make-random-element-of-type ((type (eql 'string))) - (make-random-string '*)) -(defmethod make-random-element-of-type ((type (eql 'simple-string))) - (make-random-string '* :simple t)) -(defmethod make-random-element-of-type ((type (eql 'base-string))) - (make-random-vector 'base-char '*)) -(defmethod make-random-element-of-type ((type (eql 'simple-base-string))) - (make-random-vector 'base-char '* :simple t)) -(defmethod make-random-element-of-type ((type (eql 'character))) - (make-random-character)) -(defmethod make-random-element-of-type ((type (eql 'extended-char))) - (loop for x = (make-random-character) - when (typep x 'extended-char) return x)) -(defmethod make-random-element-of-type ((type (eql 'null))) nil) -(defmethod make-random-element-of-type ((type (eql 'fixnum))) - (random-from-interval (1+ most-positive-fixnum) most-negative-fixnum)) -(defmethod make-random-element-of-type ((type (eql 'complex))) - (make-random-element-of-type '(complex real))) -(defmethod make-random-element-of-type ((type (eql 'cons))) - (make-random-element-of-type '(cons t t))) -(defmethod make-random-element-of-type ((type (eql 'list))) - ;; Should modify this to allow non-proper lists? - (let ((len (min (random 10) (random 10)))) - (loop repeat len collect (make-random-element-of-type t)))) -(defmethod make-random-element-of-type ((type (eql 'sequence))) - (make-random-element-of-type '(or list vector))) -(defmethod make-random-element-of-type ((type (eql 'function))) - (rcase - (5 (symbol-function (random-from-seq *cl-function-symbols*))) - (5 (symbol-function (random-from-seq *cl-accessor-symbols*))) - (1 #'(lambda (x) (cons x x))) - (1 (eval '#'(lambda (x) (cons x x)))))) - -(defmethod make-random-element-of-type ((type symbol)) - (case type - ((single-float short-float double-float long-float) - (make-random-element-of-type (list type))) - ((base-char standard-char) - (random-from-seq +standard-chars+)) - ;; Default - ((atom t *) (make-random-element-of-type - (random-from-seq #(real symbol boolean integer unsigned-byte - #-ecl complex character - (string 1) (bit-vector 1))))) - (t (call-next-method type)) - )) - -(defun make-random-character () - (loop - when (rcase - (3 (random-from-seq +standard-chars+)) - (3 (code-char (random (min 256 char-code-limit)))) - (1 (code-char (random (min (ash 1 16) char-code-limit)))) - (1 (code-char (random (min (ash 1 24) char-code-limit)))) - (1 (code-char (random char-code-limit)))) - return it)) - -(defun make-random-array-element-type () - ;; Create random types for array elements - (let ((bits 40)) - (rcase - (2 t) - (1 'symbol) - (1 `(unsigned-byte ,(1+ (random bits)))) - (1 `(signed-byte ,(1+ (random bits)))) - (1 'character) - (1 'base-char) - (1 'bit) - (1 (random-from-seq #(short-float single-float double-float long-float)))))) - -(defun make-random-vector (etype-spec size-spec &key simple) - (let* ((etype (if (eql etype-spec '*) - (make-random-array-element-type) - etype-spec)) - (size (if (eql size-spec '*) - (random (ash 1 (+ 2 (random 8)))) - size-spec)) - (displaced? (and (not simple) (coin 4))) - (displaced-size (+ size (random (max 6 size)))) - (displacement (random (1+ (- displaced-size size)))) - (adjustable (and (not simple) (coin 3))) - (fill-pointer (and (not simple) - (rcase (3 nil) (1 t) (1 (random (1+ size))))))) - (assert (<= size 1000000)) - (if displaced? - (let ((displaced-vector (make-array displaced-size :element-type etype - :initial-contents (loop repeat displaced-size - collect (make-random-element-of-type etype))))) - (make-array size :element-type etype :adjustable adjustable - :fill-pointer fill-pointer - :displaced-to displaced-vector - :displaced-index-offset displacement)) - (make-array size - :element-type etype - :initial-contents (loop repeat size - collect (make-random-element-of-type etype)) - :adjustable adjustable - :fill-pointer fill-pointer - )))) - -(defun make-random-array (etype-spec dim-specs &key simple) - (when (eql dim-specs '*) - (setq dim-specs (random 10))) - (when (numberp dim-specs) - (setq dim-specs (make-list dim-specs :initial-element '*))) - (let* ((etype (if (eql etype-spec '*) t etype-spec)) - (rank (length dim-specs)) - (dims (loop for dim in dim-specs - collect (if (eql dim '*) - (1+ (random (ash 1 (floor 9 rank)))) - dim)))) - (assert (<= (reduce '* dims :initial-value 1) 1000000)) - (assert (<= (reduce 'max dims :initial-value 1) 1000000)) - (make-array dims - :element-type etype - :initial-contents - (labels ((%init (dims) - (if (null dims) - (make-random-element-of-type etype) - (loop repeat (car dims) - collect (%init (cdr dims)))))) - (%init dims)) - :adjustable (and (not simple) (coin)) - ;; Do displacements later - ))) - -(defun most-negative-float (float-type-symbol) - (ecase float-type-symbol - (short-float most-negative-short-float) - (single-float most-negative-single-float) - (double-float most-negative-double-float) - (long-float most-negative-long-float) - (float (min most-negative-short-float most-negative-single-float - most-negative-double-float most-negative-long-float)))) - -(defun most-positive-float (float-type-symbol) - (ecase float-type-symbol - (short-float most-positive-short-float) - (single-float most-positive-single-float) - (double-float most-positive-double-float) - (long-float most-positive-long-float) - (float (max most-positive-short-float most-positive-single-float - most-positive-double-float most-positive-long-float)))) - -(defun make-optimized-lambda-form (form vars var-types opt-decls) - `(lambda ,vars - ,@(mapcar #'(lambda (tp var) `(declare (type ,tp ,var))) - var-types vars) - (declare (ignorable ,@vars)) - #+cmu (declare (optimize (extensions:inhibit-warnings 3))) - (declare (optimize ,@opt-decls)) - ,form)) - -(defun make-unoptimized-lambda-form (form vars var-types opt-decls) - (declare (ignore var-types)) - `(lambda ,vars - (declare (notinline ,@(fn-symbols-in-form form))) - #+cmu (declare (optimize (extensions:inhibit-warnings 3))) - (declare (optimize ,@opt-decls)) - ,form)) - -(defvar *compile-using-defun* - #-(or allegro lispworks) nil - #+(or allegro lispworks) t) - -(defvar *compile-using-defgeneric* nil - "If true and *COMPILE-USING-DEFUN* is false, then build a defgeneric form - for the function and compile that.") - -(defvar *name-to-use-in-optimized-defun* 'dummy-fn-name1) -(defvar *name-to-use-in-unoptimized-defun* 'dummy-fn-name2) - -(defun test-int-form (form vars var-types vals-list opt-decls-1 opt-decls-2) - ;; Try to compile FORM with associated VARS, and if it compiles - ;; check for equality of the two compiled forms. - ;; Return a non-nil list of details if a problem is found, - ;; NIL otherwise. - (let ((optimized-fn-src (make-optimized-lambda-form form vars var-types opt-decls-1)) - (unoptimized-fn-src (make-unoptimized-lambda-form form vars var-types opt-decls-2))) - (setq *int-form-vals* nil - *optimized-fn-src* optimized-fn-src - *unoptimized-fn-src* unoptimized-fn-src) - (flet ((%compile - (lambda-form opt-defun-name) - (cl:handler-bind - (#+sbcl (sb-ext::compiler-note #'muffle-warning) - (warning #'muffle-warning) - ((or error serious-condition) - #'(lambda (c) - (format t "Compilation failure~%~A~%" - (format nil "~S" form)) - (finish-output *standard-output*) - (return-from test-int-form - (list (list :vars vars - :form form - :var-types var-types - :vals (first vals-list) - :lambda-form lambda-form - :decls1 opt-decls-1 - :decls2 opt-decls-2 - :compiler-condition - (with-output-to-string - (s) - (prin1 c s)))))))) - (let ((start-time (get-universal-time)) - (clf (cdr lambda-form))) - (prog1 - (cond - (*compile-using-defun* - (fmakunbound opt-defun-name) - (eval `(defun ,opt-defun-name ,@clf)) - (compile opt-defun-name) - (symbol-function opt-defun-name)) - (*compile-using-defgeneric* - (fmakunbound opt-defun-name) - (eval `(defgeneric ,opt-defun-name ,(car clf))) - (eval `(defmethod ,opt-defun-name,(mapcar #'(lambda (name) `(,name integer)) (car clf)) - ,@(cdr clf))) - (compile opt-defun-name) - (symbol-function opt-defun-name)) - (t (compile nil lambda-form))) - (let* ((stop-time (get-universal-time)) - (total-time (- stop-time start-time))) - (when (> total-time *max-compile-time*) - (setf *max-compile-time* total-time) - (setf *max-compile-term* lambda-form))) - ;; #+:ecl (si:gc t) - ))))) - (let ((optimized-compiled-fn (%compile optimized-fn-src - *name-to-use-in-optimized-defun*)) - (unoptimized-compiled-fn - (if *compile-unoptimized-form* - (%compile unoptimized-fn-src *name-to-use-in-unoptimized-defun*) - (eval `(function ,unoptimized-fn-src))))) - (declare (type function optimized-compiled-fn unoptimized-compiled-fn)) - (dolist (vals vals-list) - (setq *int-form-vals* vals) - (flet ((%eval-error - (kind) - (let ((*print-circle* t)) - (format t "~A~%" (format nil "~S" form))) - (finish-output *standard-output*) - (return - (list (list :vars vars - :vals vals - :form form - :var-types var-types - :decls1 opt-decls-1 - :decls2 opt-decls-2 - :optimized-lambda-form optimized-fn-src - :unoptimized-lambda-form unoptimized-fn-src - :kind kind))))) - - (let ((unopt-result - (cl-handler-case - (cl-handler-bind - (#+sbcl (sb-ext::compiler-note #'muffle-warning) - (warning #'muffle-warning)) - (identity ;; multiple-value-list - (apply unoptimized-compiled-fn vals))) - ((or error serious-condition) - (c) - (%eval-error (list :unoptimized-form-error - (with-output-to-string - (s) (prin1 c s))))))) - (opt-result - (cl-handler-case - (cl-handler-bind - (#+sbcl (sb-ext::compiler-note #'muffle-warning) - (warning #'muffle-warning)) - (identity ;; multiple-value-list - (apply optimized-compiled-fn vals))) - ((or error serious-condition) - (c) - (%eval-error (list :optimized-form-error - (with-output-to-string - (s) (prin1 c s)))))))) - (if (equal opt-result unopt-result) - nil - (progn - (format t "Different results: ~A, ~A~%" - opt-result unopt-result) - (setq *opt-result* opt-result - *unopt-result* unopt-result) - (%eval-error (list :different-results - opt-result - unopt-result))))))))))) - -;;; Interface to the form pruner - -(declaim (special *prune-table*)) - -(defun prune-int-form (input-form vars var-types vals-list opt-decls-1 opt-decls-2) - "Conduct tests on selected simplified versions of INPUT-FORM. Return the - minimal form that still causes some kind of failure." - (loop do - (let ((form input-form)) - (flet ((%try-fn (new-form) - (when (test-int-form new-form vars var-types vals-list - opt-decls-1 opt-decls-2) - (setf form new-form) - (throw 'success nil)))) - (let ((*prune-table* (make-hash-table :test #'eq))) - (loop - (catch 'success - (prune form #'%try-fn) - (return form))))) - (when (equal form input-form) (return form)) - (setq input-form form)))) - -(defun prune-results (result-list) - "Given a list of test results, prune their forms down to a minimal set." - (loop for result in result-list - collect - (let* ((form (getf result :form)) - (vars (getf result :vars)) - (var-types (getf result :var-types)) - (vals-list (list (getf result :vals))) - (opt-decl-1 (getf result :decls1)) - (opt-decl-2 (getf result :decls2)) - (pruned-form (prune-int-form form vars var-types vals-list opt-decl-1 opt-decl-2)) - (optimized-lambda-form (make-optimized-lambda-form - pruned-form vars var-types opt-decl-1)) - (unoptimized-lambda-form (make-unoptimized-lambda-form - pruned-form vars var-types opt-decl-2))) - `(:vars ,vars - :var-types ,var-types - :vals ,(first vals-list) - :form ,pruned-form - :decls1 ,opt-decl-1 - :decls2 ,opt-decl-2 - :optimized-lambda-form ,optimized-lambda-form - :unoptimized-lambda-form ,unoptimized-lambda-form)))) - -;;; -;;; The call (PRUNE form try-fn) attempts to simplify the lisp form -;;; so that it still satisfies TRY-FN. The function TRY-FN should -;;; return if the substitution is a failure. Otherwise, it should -;;; transfer control elsewhere via GO, THROW, etc. -;;; -;;; The return value of PRUNE should be ignored. -;;; -(defun prune (form try-fn) - (declare (type function try-fn)) - (when (gethash form *prune-table*) - (return-from prune nil)) - (flet ((try (x) (funcall try-fn x))) - (cond - ((keywordp form) nil) - ((integerp form) - (unless (zerop form) (try 0))) - ((consp form) - (let* ((op (car form)) - (args (cdr form)) - (nargs (length args))) - (case op - - ((quote) nil) - - ((go) - (try 0)) - - ((signum integer-length logcount - logandc1 logandc2 lognand lognor logorc1 logorc2 - realpart imagpart) - (try 0) - (mapc try-fn args) - (prune-fn form try-fn)) - - ((make-array) - (when (and (eq (car args) nil) - (eq (cadr args) ':initial-element) - ; (null (cdddr args)) - ) - (prune (caddr args) #'(lambda (form) (try `(make-array nil :initial-element ,form . ,(cdddr args))))) - (when (cdddr args) - (try `(make-array nil :initial-element ,(caddr args)))) - )) - - ((cons) - (prune-fn form try-fn)) - - ((dotimes) - (try 0) - (let* ((binding-form (first args)) - (body (rest args)) - (var (first binding-form)) - (count-form (second binding-form)) - (result (third binding-form))) - (try result) - (unless (eql count-form 0) - (try `(dotimes (,var 0 ,result) ,@body))) - (prune result #'(lambda (form) - (try `(dotimes (,var ,count-form ,form) ,@body)))) - (when (= (length body) 1) - (prune (first body) - #'(lambda (form) - (when (consp form) - (try `(dotimes (,var ,count-form ,result) ,form)))))))) - - ((abs 1+ 1-) - (try 0) - (mapc try-fn args) - (prune-fn form try-fn)) - - ((identity ignore-errors cl:handler-case restart-case locally) - (unless (and (consp args) - (consp (car args)) - (eql (caar args) 'tagbody)) - (mapc try-fn args)) - (prune-fn form try-fn)) - - ((boole) - (try (second args)) - (try (third args)) - (prune (second args) - #'(lambda (form) (try `(boole ,(first args) ,form ,(third args))))) - (prune (third args) - #'(lambda (form) (try `(boole ,(first args) ,(second args) ,form))))) - - ((unwind-protect prog1 multiple-value-prog1) - (try (first args)) - (let ((val (first args)) - (rest (rest args))) - (when rest - (try `(unwind-protect ,val)) - (when (cdr rest) - (loop for i from 0 below (length rest) - do - (try `(unwind-protect ,val - ,@(subseq rest 0 i) - ,@(subseq rest (1+ i)))))))) - (prune-fn form try-fn)) - - ((prog2) - (assert (>= (length args) 2)) - (let ((val1 (first args)) - (arg2 (second args)) - (rest (cddr args))) - (try arg2) - (prune-fn form try-fn) - (when rest - (try `(prog2 ,val1 ,arg2)) - (when (cdr rest) - (loop for i from 0 below (length rest) - do - (try `(prog2 ,val1 ,arg2 - ,@(subseq rest 0 i) - ,@(subseq rest (1+ i))))))))) - - ((typep) - (try (car args)) - (prune (car args) - #'(lambda (form) `(,op ,form ,@(cdr args))))) - - ((load-time-value) - (let ((arg (first args))) - (try arg) - (cond - ((cdr args) - (try `(load-time-value ,arg)) - (prune arg - #'(lambda (form) - (try `(load-time-value ,form ,(second args)))))) - (t - (prune arg - #'(lambda (form) - (try `(load-time-value ,form)))))))) - - ((eval) - (try 0) - (let ((arg (first args))) - (cond - ((consp arg) - (cond - ((eql (car arg) 'quote) - (prune (cadr arg) #'(lambda (form) (try `(eval ',form))))) - (t - (try arg) - (prune arg #'(lambda (form) `(eval ,form)))))) - (t (try arg))))) - - ((the macrolet cl:handler-bind restart-bind) - (assert (= (length args) 2)) - (try (second args)) - (prune (second args) try-fn)) - - ((not eq eql equal) - (when (every #'constantp args) - (try (eval form))) - (try t) - (try nil) - (mapc try-fn args) - (prune-fn form try-fn) - ) - - ((and or = < > <= >= /=) - (when (every #'constantp args) - (try (eval form))) - (try t) - (try nil) - (mapc try-fn args) - (prune-nary-fn form try-fn) - (prune-fn form try-fn)) - - ((- + * min max logand logior logxor logeqv gcd lcm values) - (when (every #'constantp args) - (try (eval form))) - (try 0) - (mapc try-fn args) - (prune-nary-fn form try-fn) - (prune-fn form try-fn)) - - ((/) - (when (every #'constantp args) - (try (eval form))) - (try 0) - (try (car args)) - (when (cddr args) - (prune (car args) #'(lambda (form) (try `(/ ,form ,(second args))))))) - - ((expt rationalize rational numberator denominator) - (try 0) - (mapc try-fn args) - (prune-fn form try-fn)) - - ((coerce) - (try 0) - (try (car args)) - (prune (car args) #'(lambda (form) (try `(coerce ,form ,(cadr args)))))) - - - ((multiple-value-call) - ;; Simplify usual case - (when (= nargs 2) - (destructuring-bind (arg1 arg2) args - (when (and (consp arg1) (consp arg2) - (eql (first arg1) 'function) - (eql (first arg2) 'values)) - (mapc try-fn (rest arg2)) - (let ((fn (second arg1))) - (when (symbolp fn) - (try `(,fn ,@(rest arg2))))) - ;; Prune the VALUES form - (prune-list (rest arg2) - #'prune - #'(lambda (args) - (try `(multiple-value-call ,arg1 (values ,@args))))) - ))) - (mapc try-fn (rest args))) - - ((bit sbit elt aref svref) - (try 0) - (when (= (length args) 2) - (let ((arg1 (car args)) - (arg2 (cadr args))) - (when (and (consp arg2) - (eql (car arg2) 'min) - (integerp (cadr arg2))) - (let ((arg2.2 (caddr arg2))) - (try arg2.2) - (when (and (consp arg2.2) - (eql (car arg2.2) 'max) - (integerp (cadr arg2.2))) - (prune (caddr arg2.2) - #'(lambda (form) - (try `(,op ,arg1 (min ,(cadr arg2) - (max ,(cadr arg2.2) ,form)))))))))))) - - ((car cdr) - (try 0) - (try 1)) - - ((if) - (let (;; (pred (first args)) - (then (second args)) - (else (third args))) - (try then) - (try else) - (when (every #'constantp args) - (try (eval form))) - (prune-fn form try-fn))) - - ((incf decf) - (try 0) - (assert (member (length form) '(2 3))) - (try (first args)) - (when (> (length args) 1) - (try (second args)) - (try `(,op ,(first args))) - (unless (integerp (second args)) - (prune (second args) - #'(lambda (form) - (try `(,op ,(first args) ,form))))))) - - ((setq setf shiftf) - (try 0) - ;; Assumes only one assignment - (assert (= (length form) 3)) - (try (first args)) - (try (second args)) - (unless (integerp (second args)) - (prune (second args) - #'(lambda (form) - (try `(,op ,(first args) ,form)))))) - - ((rotatef) - (try 0) - (mapc try-fn (cdr form))) - - ((multiple-value-setq) - (try 0) - ;; Assumes only one assignment, and one variable - (assert (= (length form) 3)) - (assert (= (length (first args)) 1)) - (try `(setq ,(caar args) ,(cadr args))) - (unless (integerp (second args)) - (prune (second args) - #'(lambda (form) - (try `(,op ,(first args) ,form)))))) - - ((byte) - (prune-fn form try-fn)) - - ((deposit-field dpb) - (try 0) - (destructuring-bind (a1 a2 a3) - args - (try a1) - (try a3) - (when (and (integerp a1) - (integerp a3) - (and (consp a2) - (eq (first a2) 'byte) - (integerp (second a2)) - (integerp (third a2)))) - (try (eval form)))) - (prune-fn form try-fn)) - - ((ldb mask-field) - (try 0) - (try (second args)) - (when (and (consp (first args)) - (eq 'byte (first (first args))) - (every #'numberp (cdr (first args))) - (numberp (second args))) - (try (eval form))) - (prune-fn form try-fn)) - - ((ldb-test) - (try t) - (try nil) - (prune-fn form try-fn)) - - ((let let*) - (prune-let form try-fn)) - - ((multiple-value-bind) - (assert (= (length args) 3)) - (let ((arg1 (first args)) - (arg2 (second args)) - (body (caddr args))) - (when (= (length arg1) 1) - (try `(let ((,(first arg1) ,arg2)) ,body))) - (prune arg2 #'(lambda (form) - (try `(multiple-value-bind ,arg1 ,form ,body)))) - (prune body #'(lambda (form) - (try `(multiple-value-bind ,arg1 ,arg2 ,form)))))) - - ((block) - (let ((name (second form)) - (body (cddr form))) - (when (and body (null (cdr body))) - (let ((form1 (first body))) - - ;; Try removing the block entirely if it is not in use - (when (not (find-in-tree name body)) - (try form1)) - - ;; Try removing the block if its only use is an immediately - ;; enclosed return-from: (block (return-from )) - (when (and (consp form1) - (eq (first form1) 'return-from) - (eq (second form1) name) - (not (find-in-tree name (third form1)))) - (try (third form1))) - - ;; Otherwise, try to simplify the subexpression - (prune form1 - #'(lambda (x) - (try `(block ,name ,x)))))))) - - ((catch) - (let* ((tag (second form)) - (name (if (consp tag) (cadr tag) tag)) - (body (cddr form))) - (when (and body (null (cdr body))) - (let ((form1 (first body))) - - ;; Try removing the catch entirely if it is not in use - ;; We make assumptions here about what throws can - ;; be present. - (when (or (not (find-in-tree 'throw body)) - (not (find-in-tree name body))) - (try form1)) - - ;; Try removing the block if its only use is an immediately - ;; enclosed return-from: (block (return-from )) - (when (and (consp form1) - (eq (first form1) 'throw) - (equal (second form1) name) - (not (find-in-tree name (third form1)))) - (try (third form1))) - - ;; Otherwise, try to simplify the subexpression - (prune form1 - #'(lambda (x) - (try `(catch ,tag ,x)))))))) - - ((throw) - (try (second args)) - (prune (second args) - #'(lambda (x) (try `(throw ,(first args) ,x))))) - - ((flet labels) - (try 0) - (prune-flet form try-fn)) - - ((case) - (prune-case form try-fn)) - - ((isqrt) - (let ((arg (second form))) - (assert (null (cddr form))) - (assert (consp arg)) - (assert (eq (first arg) 'abs)) - (let ((arg2 (second arg))) - (try arg2) - ;; Try to fold - (when (integerp arg2) - (try (isqrt (abs arg2)))) - ;; Otherwise, simplify arg2 - (prune arg2 #'(lambda (form) - (try `(isqrt (abs ,form)))))))) - - ((ash) - (try 0) - (let ((form1 (second form)) - (form2 (third form))) - (try form1) - (try form2) - (prune form1 - #'(lambda (form) - (try `(ash ,form ,form2)))) - (when (and (consp form2) - (= (length form2) 3)) - (when (and (integerp form1) - (eq (first form2) 'min) - (every #'integerp (cdr form2))) - (try (eval form))) - (let ((form3 (third form2))) - (prune form3 - #'(lambda (form) - (try - `(ash ,form1 (,(first form2) ,(second form2) - ,form))))))))) - - ((floor ceiling truncate round mod rem) - (try 0) - (let ((form1 (second form)) - (form2 (third form))) - (try form1) - (when (cddr form) (try form2)) - (prune form1 - (if (cddr form) - #'(lambda (form) - (try `(,op ,form ,form2))) - #'(lambda (form) (try `(,op ,form))))) - (when (and (consp form2) - (= (length form2) 3)) - (when (and (integerp form1) - (member (first form2) '(max min)) - (every #'integerp (cdr form2))) - (try (eval form))) - (let ((form3 (third form2))) - (prune form3 - #'(lambda (form) - (try - `(,op ,form1 (,(first form2) ,(second form2) - ,form))))))))) - - ((constantly) - (unless (eql (car args) 0) - (prune (car args) - #'(lambda (arg) (try `(constantly ,arg)))))) - - ((funcall) - (try 0) - (let ((fn (second form)) - (fn-args (cddr form))) - (mapc try-fn fn-args) - (unless (equal fn '(constantly 0)) - (try `(funcall (constantly 0) ,@fn-args))) - (when (and (consp fn) - (eql (car fn) 'function) - (symbolp (cadr fn))) - (try `(,(cadr fn) ,@fn-args))) - (prune-list fn-args - #'prune - #'(lambda (args) - (try `(funcall ,fn ,@args)))))) - - ((reduce) - (try 0) - (let ((arg1 (car args)) - (arg2 (cadr args)) - (rest (cddr args))) - (when (and ;; (null (cddr args)) - (consp arg1) - (eql (car arg1) 'function)) - (let ((arg1.2 (cadr arg1))) - (when (and (consp arg1.2) - (eql (car arg1.2) 'lambda)) - (let ((largs (cadr arg1.2)) - (body (cddr arg1.2))) - (when (null (cdr body)) - (prune (car body) - #'(lambda (bform) - (try `(reduce (function (lambda ,largs ,bform)) - ,arg2 ,@rest))))))))) - (when (consp arg2) - (case (car arg2) - ((list vector) - (let ((arg2.rest (cdr arg2))) - (mapc try-fn arg2.rest) - (prune-list arg2.rest - #'prune - #'(lambda (args) - (try `(reduce ,arg1 - (,(car arg2) ,@args) - ,@rest)))))))))) - - ((apply) - (try 0) - (let ((fn (second form)) - (fn-args (butlast (cddr form))) - (list-arg (car (last form)))) - (mapc try-fn fn-args) - (unless (equal fn '(constantly 0)) - (try `(apply (constantly 0) ,@(cddr form)))) - (when (and (consp list-arg) - (eq (car list-arg) 'list)) - (mapc try-fn (cdr list-arg))) - (prune-list fn-args - #'prune - #'(lambda (args) - (try `(apply ,fn ,@args ,list-arg)))) - (when (and (consp list-arg) - (eq (car list-arg) 'list)) - (try `(apply ,fn ,@fn-args ,@(cdr list-arg) nil)) - (prune-list (cdr list-arg) - #'prune - #'(lambda (args) - (try `(apply ,fn ,@fn-args - (list ,@args)))))))) - - ((progv) - (try 0) - (prune-progv form try-fn)) - - ((tagbody) - (try 0) - (prune-tagbody form try-fn)) - - ((progn) - (when (null args) (try nil)) - (try (car (last args))) - (loop for i from 0 below (1- (length args)) - for a in args - do (try `(progn ,@(subseq args 0 i) - ,@(subseq args (1+ i)))) - do (when (and (consp a) - (or - (eq (car a) 'progn) - (and (eq (car a) 'tagbody) - (every #'consp (cdr a))))) - (try `(progn ,@(subseq args 0 i) - ,@(copy-list (cdr a)) - ,@(subseq args (1+ i)))))) - (prune-fn form try-fn)) - - ((loop) - (try 0) - (when (and (eql (length args) 6) - (eql (elt args 0) 'for) - (eql (elt args 2) 'below)) - (let ((var (elt args 1)) - (count (elt args 3)) - (form (elt args 5))) - (unless (eql count 0) (try count)) - (case (elt args 4) - (sum - (try `(let ((,(elt args 1) 0)) ,(elt args 5))) - (prune form #'(lambda (form) - (try `(loop for ,var below ,count sum ,form))))) - (count - (unless (or (eql form t) (eql form nil)) - (try `(loop for ,var below ,count count t)) - (try `(loop for ,var below ,count count nil)) - (prune form - #'(lambda (form) - (try `(loop for ,var below ,count count ,form)))))) - )))) - - (otherwise - (try 0) - (prune-fn form try-fn)) - - ))))) - (setf (gethash form *prune-table*) t) - nil) - -(defun find-in-tree (value tree) - "Return true if VALUE is eql to a node in TREE." - (or (eql value tree) - (and (consp tree) - (or (find-in-tree value (car tree)) - (find-in-tree value (cdr tree)))))) - -(defun prune-list (list element-prune-fn list-try-fn) - (declare (type function element-prune-fn list-try-fn)) - "Utility function for pruning in a list." - (loop for i from 0 - for e in list - do (funcall element-prune-fn - e - #'(lambda (form) - (funcall list-try-fn - (append (subseq list 0 i) - (list form) - (subseq list (1+ i)))))))) - -(defun prune-case (form try-fn) - (declare (type function try-fn)) - (flet ((try (e) (funcall try-fn e))) - (let* ((op (first form)) - (expr (second form)) - (cases (cddr form))) - - ;; Try just the top expression - (try expr) - - ;; Try simplifying the expr - (prune expr - #'(lambda (form) - (try `(,op ,form ,@cases)))) - - ;; Try individual cases - (loop for case in cases - do (try (first (last (rest case))))) - - ;; Try deleting individual cases - (loop for i from 0 below (1- (length cases)) - do (try `(,op ,expr - ,@(subseq cases 0 i) - ,@(subseq cases (1+ i))))) - - ;; Try simplifying the cases - ;; Assume each case has a single form - (prune-list cases - #'(lambda (case try-fn) - (declare (type function try-fn)) - (when (and (listp (car case)) - (> (length (car case)) 1)) - ;; try removing constants - (loop for i below (length (car case)) - do (funcall try-fn - `((,@(subseq (car case) 0 i) - ,@(subseq (car case) (1+ i))) - ,@(cdr case))))) - (when (eql (length case) 2) - (prune (cadr case) - #'(lambda (form) - (funcall try-fn - (list (car case) form)))))) - #'(lambda (cases) - (try `(,op ,expr ,@cases))))))) - -(defun prune-tagbody (form try-fn) - (declare (type function try-fn)) - (let (;; (op (car form)) - (body (cdr form))) - (loop for i from 0 - for e in body - do - (cond - ((atom e) - ;; A tag - (unless (find-in-tree e (subseq body 0 i)) - (funcall try-fn `(tagbody ,@(subseq body 0 i) - ,@(subseq body (1+ i)))))) - (t - (funcall try-fn - `(tagbody ,@(subseq body 0 i) - ,@(subseq body (1+ i)))) - (prune e - #'(lambda (form) - ;; Don't put an atom here. - (when (consp form) - (funcall - try-fn - `(tagbody ,@(subseq body 0 i) - ,form - ,@(subseq body (1+ i)))))))))))) - -(defun prune-progv (form try-fn) - (declare (type function try-fn)) - (let (;; (op (car form)) - (vars-form (cadr form)) - (vals-form (caddr form)) - (body-list (cdddr form))) - (when (and (null vars-form) (null vals-form)) - (funcall try-fn `(let () ,@body-list))) - (when (and (consp vals-form) (eql (car vals-form) 'list)) - (when (and (consp vars-form) (eql (car vars-form) 'quote)) - (let ((vars (cadr vars-form)) - (vals (cdr vals-form))) - (when (eql (length vars) (length vals)) - (let ((let-form `(let () ,@body-list))) - (mapc #'(lambda (var val) - (setq let-form `(let ((,var ,val)) ,let-form))) - vars vals) - (funcall try-fn let-form))) - ;; Try simplifying the vals forms - (prune-list vals - #'prune - #'(lambda (vals) - (funcall try-fn - `(progv ,vars-form (list ,@vals) ,@body-list))))))) - ;; Try simplifying the body - (when (eql (length body-list) 1) - (prune (car body-list) - #'(lambda (form) - (funcall try-fn - `(progv ,vars-form ,vals-form ,form))))))) - -(defun prune-nary-fn (form try-fn) - ;; Attempt to reduce the number of arguments to the fn - ;; Do not reduce below 1 - (declare (type function try-fn)) - (let* ((op (car form)) - (args (cdr form)) - (nargs (length args))) - (when (> nargs 1) - (loop for i from 1 to nargs - do (funcall try-fn `(,op ,@(subseq args 0 (1- i)) - ,@(subseq args i))))))) - -(defun prune-fn (form try-fn) - "Attempt to simplify a function call form. It is considered - acceptable to replace the call by one of its argument forms." - (declare (type function try-fn)) - (prune-list (cdr form) - #'prune - #'(lambda (args) - (funcall try-fn (cons (car form) args))))) - -(defun prune-let (form try-fn) - "Attempt to simplify a LET form." - (declare (type function try-fn)) - (let* ((op (car form)) - (binding-list (cadr form)) - (body (cddr form)) - (body-len (length body)) - (len (length binding-list)) - ) - - (when (> body-len 1) - (funcall try-fn `(,op ,binding-list ,@(cdr body)))) - - ;; Try to simplify (let (( )) ...) to - #| - (when (and (>= len 1) - ;; (eql body-len 1) - ;; (eql (caar binding-list) (car body)) - ) - (let ((val-form (cadar binding-list))) - (unless (and (consp val-form) - (eql (car val-form) 'make-array)) - (funcall try-fn val-form)))) - |# - - (when (>= len 1) - (let ((val-form (cadar binding-list))) - (when (consp val-form) - (case (car val-form) - ((make-array) - (let ((init (getf (cddr val-form) :initial-element))) - (when init - (funcall try-fn init)))) - ((cons) - (funcall try-fn (cadr val-form)) - (funcall try-fn (caddr val-form))))))) - - ;; Try to simplify the forms in the RHS of the bindings - (prune-list binding-list - #'(lambda (binding try-fn) - (declare (type function try-fn)) - (prune (cadr binding) - #'(lambda (form) - (funcall try-fn - (list (car binding) - form))))) - #'(lambda (bindings) - (funcall try-fn `(,op ,bindings ,@body)))) - - ;; Prune off unused variable - (when (and binding-list - (not (rest binding-list)) - (let ((name (caar binding-list))) - (and (symbolp name) - (not (find-if-subtree #'(lambda (x) (eq x name)) body))))) - (funcall try-fn `(progn ,@body))) - - ;; Try to simplify the body of the LET form - (when body - (unless binding-list - (funcall try-fn (car (last body)))) - (when (and (first binding-list) - (not (rest binding-list)) - (not (rest body))) - (let ((binding (first binding-list))) - (unless (or (consp (second binding)) - (has-binding-to-var (first binding) body) - (has-assignment-to-var (first binding) body) - ) - (funcall try-fn `(let () - ,@(subst (second binding) - (first binding) - (remove-if #'(lambda (x) (and (consp x) (eq (car x) 'declare))) - body) - )))))) - (prune (car (last body)) - #'(lambda (form2) - (funcall try-fn - `(,@(butlast form) ,form2))))))) - -(defun has-assignment-to-var (var form) - (find-if-subtree - #'(lambda (form) - (and (consp form) - (or - (and (member (car form) '(setq setf shiftf incf decf) :test #'eq) - (eq (cadr form) var)) - (and (eql (car form) 'multiple-value-setq) - (member var (cadr form)))))) - form)) - -(defun has-binding-to-var (var form) - (find-if-subtree - #'(lambda (form) - (and (consp form) - (case (car form) - ((let let*) - (loop for binding in (cadr form) - thereis (eq (car binding) var))) - ((progv) - (and (consp (cadr form)) - (eq (caadr form) 'quote) - (consp (second (cadr form))) - (member var (second (cadr form))))) - (t nil)))) - form)) - -(defun find-if-subtree (pred tree) - (declare (type function pred)) - (cond - ((funcall pred tree) tree) - ((consp tree) - (or (find-if-subtree pred (car tree)) - (find-if-subtree pred (cdr tree)))) - (t nil))) - -(defun prune-flet (form try-fn) - "Attempt to simplify a FLET form." - (declare (type function try-fn)) - - (let* ((op (car form)) - (binding-list (cadr form)) - (body (cddr form))) - - ;; Remove a declaration, if any - (when (and (consp body) - (consp (car body)) - (eq (caar body) 'declare)) - (funcall try-fn `(,op ,binding-list ,@(cdr body)))) - - ;; Try to prune optional arguments - (prune-list binding-list - #'(lambda (binding try-fn) - (declare (type function try-fn)) - (let* ((name (car binding)) - (args (cadr binding)) - (body (cddr binding)) - (opt-pos (position-if #'(lambda (e) (member e '(&key &optional))) - (the list args)))) - (when opt-pos - (incf opt-pos) - (let ((normal-args (subseq args 0 (1- opt-pos))) - (optionals (subseq args opt-pos))) - (prune-list optionals - #'(lambda (opt-lambda-arg try-fn) - (declare (type function try-fn)) - (when (consp opt-lambda-arg) - (let ((name (first opt-lambda-arg)) - (form (second opt-lambda-arg))) - (prune form - #'(lambda (form) - (funcall try-fn (list name form))))))) - #'(lambda (opt-args) - (funcall try-fn - `(,name (,@normal-args - &optional - ,@opt-args) - ,@body)))))))) - #'(lambda (bindings) - (funcall try-fn `(,op ,bindings ,@body)))) - - - ;; Try to simplify the forms in the RHS of the bindings - (prune-list binding-list - #'(lambda (binding try-fn) - (declare (type function try-fn)) - - ;; Prune body of a binding - (prune (third binding) - #'(lambda (form) - (funcall try-fn - (list (first binding) - (second binding) - form))))) - #'(lambda (bindings) - (funcall try-fn `(,op ,bindings ,@body)))) - - ;; ;; Try to simplify the body of the FLET form - (when body - - ;; No bindings -- try to simplify to the last form in the body - (unless binding-list - (funcall try-fn (first (last body)))) - - (when (and (consp binding-list) - (null (rest binding-list))) - (let ((binding (first binding-list))) - ;; One binding -- match on (flet (( () )) ()) - (when (and (symbolp (first binding)) - (not (find-in-tree (first binding) (rest binding))) - (null (second binding)) - (equal body (list (list (first binding))))) - (funcall try-fn `(,op () ,@(cddr binding)))) - ;; One binding -- try to remove it if not used - (when (and (symbolp (first binding)) - (not (find-in-tree (first binding) body))) - (funcall try-fn (first (last body)))) - )) - - - ;; Try to simplify (the last form in) the body. - (prune (first (last body)) - #'(lambda (form2) - (funcall try-fn - `(,@(butlast form) ,form2))))))) - -;;; Routine to walk form, applying a function at each form -;;; The fn is applied in preorder. When it returns :stop, do -;;; not descend into subforms - -#| -(defun walk (form fn) - (declare (type function fn)) - (unless (eq (funcall fn form) :stop) - (when (consp form) - (let ((op (car form))) - (case op - ((let let*) - (walk-let form fn)) - ((cond) - (dolist (clause (cdr form)) - (walk-implicit-progn clause fn))) - ((multiple-value-bind) - (walk (third form) fn) - (walk-body (cdddr form) fn)) - ((function quote declare) nil) - ((block the return-from) - (walk-implicit-progn (cddr form) fn)) - ((case typecase) - (walk (cadr form) fn) - (dolist (clause (cddr form)) - (walk-implicit-progn (cdr clause) fn))) - ((flet labels) - - - - -|# - -;;;;;;;;;;;;;;;;;;;;;; -;;; Convert pruned results to test cases - -(defun produce-test-cases (instances &key - (stream *standard-output*) - (prefix "MISC.") - (index 1)) - (dolist (inst instances) - (let* (;; (vars (getf inst :vars)) - (vals (getf inst :vals)) - (optimized-lambda-form (getf inst :optimized-lambda-form)) - (unoptimized-lambda-form (getf inst :unoptimized-lambda-form)) - (name (intern - (concatenate 'string prefix (format nil "~D" index)) - "CL-TEST")) - (test-form - `(deftest ,name - (let* ((fn1 ',optimized-lambda-form) - (fn2 ',unoptimized-lambda-form) - (vals ',vals) - (v1 (apply (compile nil fn1) vals)) - (v2 (apply (compile nil fn2) vals))) - (if (eql v1 v2) - :good - (list v1 v2))) - :good))) - (print test-form stream) - (terpri stream) - (incf index))) - (values)) diff --git a/t/ansi-test/random/random-intern.lsp b/t/ansi-test/random/random-intern.lsp deleted file mode 100644 index 5041b98..0000000 --- a/t/ansi-test/random/random-intern.lsp +++ /dev/null @@ -1,72 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Contains: Code to randomly intern and unintern random strings -;;;; in a package. Exercises package and hash table routines - -(in-package :cl-test) - -(defconstant +max-len-random-symbol+ 63) - -(defun make-random-symbol (package) - (declare (optimize (speed 3) (safety 3))) - (loop - (let* ((len (random (1+ +max-len-random-symbol+))) - (str (make-string len))) - (declare (type (integer 0 #.+max-len-random-symbol+) len)) - (loop - for i from 0 to (1- len) do - (setf (schar str i) - (schar +base-chars+ - (random +num-base-chars+)))) - (multiple-value-bind - (symbol status) - (intern (copy-seq str) package) - (unless (equal str (symbol-name symbol)) - (error "Intern gave bad symbol: ~A, ~A~%" str symbol)) - (unless status (return symbol)))))) - -(defun queue-insert (q x) - (declare (type cons q)) - (push x (cdr q))) - -(defun queue-remove (q) - (declare (type cons q)) - (when (null (car q)) - (when (null (cdr q)) - (error "Attempty to remove from empty queue.~%")) - (setf (car q) (nreverse (cdr q))) - (setf (cdr q) nil)) - (pop (car q))) - -(defun queue-empty (q) - (and (null (car q)) - (null (cdr q)))) - -(defun random-intern (n) - (declare (fixnum n)) - (let ((q (list nil)) - (xp (defpackage "X" (:use)))) - (declare (type cons q)) - (loop - for i from 1 to n do - (if (and - (= (random 2) 0) - (not (queue-empty q))) - (unintern (queue-remove q) xp) - (queue-insert q (make-random-symbol xp)))))) - -(defun fill-intern (n) - (declare (fixnum n)) - (let ((xp (defpackage "X" (:use)))) - (loop - for i from 1 to n do - (make-random-symbol xp)))) - - - - - - - - - diff --git a/t/ansi-test/random/random-type-prop-tests-01.lsp b/t/ansi-test/random/random-type-prop-tests-01.lsp deleted file mode 100644 index da3a53e..0000000 --- a/t/ansi-test/random/random-type-prop-tests-01.lsp +++ /dev/null @@ -1,73 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Mar 6 20:36:56 2005 -;;;; Contains: Test that invoke the random type prop infrastructure, part 1 - -(in-package :cl-test) - -(def-type-prop-test special-operator-p 'special-operator-p '(symbol) 1) -(def-type-prop-test type-of 'type-of '(t) 1) -(def-type-prop-test typep.1 '(lambda (x y) (typep x (type-of y))) '(t t) 2) -(def-type-prop-test typep.2 'typep - (list t #'(lambda (x) - (let ((type (make-random-type-containing x))) - `(eql ,type)))) - 2) -(def-type-prop-test subtypep - '(lambda (x y) (subtypep (type-of x) (type-of y))) '(t t) 2) -(def-type-prop-test fboundp.1 'fboundp '(symbol) 1) -(def-type-prop-test fboundp.2 'fboundp '((cons (eql setf) (cons symbol null))) 1) -(def-type-prop-test functionp 'functionp '(t) 1) -(def-type-prop-test compiled-function-p 'compiled-function-p '(t) 1) -(def-type-prop-test not 'not '(t) 1) -(def-type-prop-test eq 'eq (list - '(and t (not number) (not character)) - #'(lambda (x) (rcase - (1 `(eql ,x)) - (1 '(and t (not number) (not character)))))) - 2) -(def-type-prop-test eql.1 'eql '(t t) 2) -(def-type-prop-test eql.2 'eql (list t #'(lambda (x) `(eql ,x))) 2) -(def-type-prop-test equal.1 'equal '(t t) 2) -(def-type-prop-test equal.2 'equal (list t #'(lambda (x) `(eql ,x))) 2) -(def-type-prop-test equalp.1 'equalp '(t t) 2) -(def-type-prop-test equalp.2 'equalp (list t #'(lambda (x) `(eql ,x))) 2) -(def-type-prop-test identity 'identity '(t) 1) -(def-type-prop-test complement - '(lambda (f y) (funcall (complement f) y)) (list `(eql ,#'symbolp) t) 2) -(def-type-prop-test constantly - '(lambda (x) (funcall (constantly x))) '(t) 1) -(def-type-prop-test and.1 'and '(t) 1) -(def-type-prop-test and.2 'and '((or null t) t) 2) -(def-type-prop-test and.3 'and '((or null t) (or null t) t) 3) -(def-type-prop-test if.1 'if '(boolean t) 2) -(def-type-prop-test if.2 'if '(boolean t t) 3) -(def-type-prop-test if.3 '(lambda (p q x y z) (if p (if q x y) z)) - '(boolean boolean t t t) 5) -(def-type-prop-test if.4 '(lambda (p q x y z) (if p x (if q y z))) - '(boolean boolean t t t) 5) -(def-type-prop-test if.5 '(lambda (p q x y) (if (or p q) x y)) - '(boolean boolean t t) 4) -(def-type-prop-test if.6 '(lambda (p q x y) (if (and p q) x y)) - '(boolean boolean t t) 4) -(def-type-prop-test cond.1 '(lambda (p x y) (cond (p x) (t y))) '(boolean t t) 3) -(def-type-prop-test cond.2 '(lambda (p x y) (cond (p x) (t y))) '((or null t) t t) 3) -(def-type-prop-test or.1 'or '(t) 1) -(def-type-prop-test or.2 'or '((or null t) t) 2) -(def-type-prop-test or.3 'or '((or null null t) (or null t) t) 3) -(def-type-prop-test when 'when '((or null t) t) 2) -(def-type-prop-test unless 'unless '((or null t) t) 2) -(def-type-prop-test slot-exists-p 'slot-exists-p '(t symbol) 2) -(def-type-prop-test find-class 'find-class '(symbol null) 2) -(def-type-prop-test class-of 'class-of '(t) 1) -(def-type-prop-test find-restart 'find-restart '((and symbol (not null))) 1) -(def-type-prop-test symbolp 'symbolp '(t) 1) -(def-type-prop-test keywordp 'keywordp '(t) 1) -(def-type-prop-test make-symbol 'make-symbol '(string) 1 - :test #'(lambda (x y) (string= (symbol-name x) (symbol-name y)))) -(def-type-prop-test symbol-name 'symbol-name '(symbol) 1) -(def-type-prop-test symbol-package 'symbol-package '(symbol) 1) -(def-type-prop-test boundp 'boundp '(symbol) 1) -(def-type-prop-test find-symbol 'find-symbol '(string) 1) -(def-type-prop-test find-package 'find-package '((or string symbol character)) 1) - diff --git a/t/ansi-test/random/random-type-prop-tests-02.lsp b/t/ansi-test/random/random-type-prop-tests-02.lsp deleted file mode 100644 index 458aa8f..0000000 --- a/t/ansi-test/random/random-type-prop-tests-02.lsp +++ /dev/null @@ -1,115 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Mar 6 20:37:57 2005 -;;;; Contains: Tests that invoke the random type prop infrastructure, part 2 - -(in-package :cl-test) - -(def-type-prop-test =.1 '= '(number number) 2) -(def-type-prop-test =.2 '= '(number number number) 3) -(def-type-prop-test =.3 '= nil 4 :maxargs 10 :rest-type 'number) -(def-type-prop-test =.4 '= '(integer integer) 2) -(def-type-prop-test =.5 '= (list 'number #'(lambda (x) (if (coin) 'number - `(eql ,x)))) 2) -(def-type-prop-test =.6 '= (list 'number 'number - #'(lambda (x y) (rcase - (2 'number) - (1 `(eql ,x)) - (1 `(eql ,y))))) - 3) -(def-type-prop-test /=.1 '/= '(number number) 2) -(def-type-prop-test /=.2 '/= '(number number number) 3) -(def-type-prop-test /=.3 '/= nil 4 :maxargs 10 :rest-type 'number) -(def-type-prop-test /=.4 '/= '(integer integer) 2) -(def-type-prop-test /=.5 '/= (list 'number #'(lambda (x) (if (coin) 'number - `(eql ,x)))) 2) -(def-type-prop-test /=.6 '/= (list 'number 'number - #'(lambda (x y) (rcase - (2 'number) - (1 `(eql ,x)) - (1 `(eql ,y))))) - 3) -(def-type-prop-test <.1 '< '(real real) 2) -(def-type-prop-test <.2 '< '(real real real) 3) -(def-type-prop-test <.3 '< nil 4 :maxargs 10 :rest-type 'real) -(def-type-prop-test <.4 '< '(integer integer) 2) -(def-type-prop-test <.5 '< (list 'real #'(lambda (x) (if (coin) 'real - `(eql ,x)))) 2) -(def-type-prop-test <.6 '< (list 'real 'real - #'(lambda (x y) (rcase - (2 'real) - (1 `(eql ,x)) - (1 `(eql ,y))))) - 3) -(def-type-prop-test >.1 '> '(real real) 2) -(def-type-prop-test >.2 '> '(real real real) 3) -(def-type-prop-test >.3 '> nil 4 :maxargs 10 :rest-type 'real) -(def-type-prop-test >.4 '> '(integer integer) 2) -(def-type-prop-test >.5 '> (list 'real #'(lambda (x) (if (coin) 'real - `(eql ,x)))) 2) -(def-type-prop-test >.6 '> (list 'real 'real - #'(lambda (x y) (rcase - (2 'real) - (1 `(eql ,x)) - (1 `(eql ,y))))) - 3) -(def-type-prop-test <=.1 '<= '(real real) 2) -(def-type-prop-test <=.2 '<= '(real real real) 3) -(def-type-prop-test <=.3 '<= nil 4 :maxargs 10 :rest-type 'real) -(def-type-prop-test <=.4 '<= '(integer integer) 2) -(def-type-prop-test <=.5 '<= (list 'real #'(lambda (x) (if (coin) 'real - `(eql ,x)))) 2) -(def-type-prop-test <=.6 '<= (list 'real 'real - #'(lambda (x y) (rcase - (2 'real) - (1 `(eql ,x)) - (1 `(eql ,y))))) - 3) -(def-type-prop-test >=.1 '>= '(real real) 2) -(def-type-prop-test >=.2 '>= '(real real real) 3) -(def-type-prop-test >=.3 '>= nil 4 :maxargs 10 :rest-type 'real) -(def-type-prop-test >=.4 '>= '(integer integer) 2) -(def-type-prop-test >=.5 '>= (list 'real #'(lambda (x) (if (coin) 'real - `(eql ,x)))) 2) -(def-type-prop-test >=.6 '>= (list 'real 'real - #'(lambda (x y) (rcase - (2 'real) - (1 `(eql ,x)) - (1 `(eql ,y))))) - 3) - -(def-type-prop-test min.1 'min nil 2 :maxargs 6 :rest-type 'integer) -(def-type-prop-test min.2 'min nil 2 :maxargs 6 :rest-type 'rational) -(def-type-prop-test min.3 'min nil 2 :maxargs 6 :rest-type 'real) -(def-type-prop-test max.1 'max nil 2 :maxargs 6 :rest-type 'integer) -(def-type-prop-test max.2 'max nil 2 :maxargs 6 :rest-type 'rational) -(def-type-prop-test max.3 'max nil 2 :maxargs 6 :rest-type 'real) - -(def-type-prop-test minusp 'minusp '(real) 1) -(def-type-prop-test plusp 'plusp '(real) 1) -(def-type-prop-test zerop 'zerop '(number) 1) - -(def-type-prop-test floor.1 'floor '(real) 1) -(def-type-prop-test floor.2 'floor '(real (and integer (not (satisfies zerop)))) 2) -(def-type-prop-test floor.3 'floor '(real (and real (not (satisfies zerop)))) 2) -(def-type-prop-test ffloor.1 'ffloor '(real) 1) -(def-type-prop-test ffloor.2 'ffloor '(real (and integer (not (satisfies zerop)))) 2) -(def-type-prop-test ffloor.3 'ffloor '(real (and real (not (satisfies zerop)))) 2) -(def-type-prop-test ceiling.1 'ceiling '(real) 1) -(def-type-prop-test ceiling.2 'ceiling '(real (and integer (not (satisfies zerop)))) 2) -(def-type-prop-test ceiling.3 'ceiling '(real (and real (not (satisfies zerop)))) 2) -(def-type-prop-test fceiling.1 'fceiling '(real) 1) -(def-type-prop-test fceiling.2 'fceiling '(real (and integer (not (satisfies zerop)))) 2) -(def-type-prop-test fceiling.3 'fceiling '(real (and real (not (satisfies zerop)))) 2) -(def-type-prop-test truncate.1 'truncate '(real) 1) -(def-type-prop-test truncate.2 'truncate '(real (and integer (not (satisfies zerop)))) 2) -(def-type-prop-test truncate.3 'truncate '(real (and real (not (satisfies zerop)))) 2) -(def-type-prop-test ftruncate.1 'ftruncate '(real) 1) -(def-type-prop-test ftruncate.2 'ftruncate '(real (and integer (not (satisfies zerop)))) 2) -(def-type-prop-test ftruncate.3 'ftruncate '(real (and real (not (satisfies zerop)))) 2) -(def-type-prop-test round.1 'round '(real) 1) -(def-type-prop-test round.2 'round '(real (and integer (not (satisfies zerop)))) 2) -(def-type-prop-test round.3 'round '(real (and real (not (satisfies zerop)))) 2) -(def-type-prop-test fround.1 'fround '(real) 1) -(def-type-prop-test fround.2 'fround '(real (and integer (not (satisfies zerop)))) 2) -(def-type-prop-test fround.3 'fround '(real (and real (not (satisfies zerop)))) 2) diff --git a/t/ansi-test/random/random-type-prop-tests-03.lsp b/t/ansi-test/random/random-type-prop-tests-03.lsp deleted file mode 100644 index a564c21..0000000 --- a/t/ansi-test/random/random-type-prop-tests-03.lsp +++ /dev/null @@ -1,186 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Mar 6 20:39:10 2005 -;;;; Contains: Tests that invoke the random type prop infrastructure, part 3 - -(in-package :cl-test) - -;;; trig, hyperbolic functions here - -;;; WARNING -- these tests may cause floating point overflow/underflow -;;; Ignore those failures -(def-type-prop-test *.1 '* '(integer integer) 2) -(def-type-prop-test *.2 '* nil 1 :rest-type 'integer :maxargs 4) -(def-type-prop-test *.3 '* nil 2 :rest-type 'integer :maxargs 10) -(def-type-prop-test *.4 '* '(real real) 2 :test #'approx=) -(def-type-prop-test *.5 '* '(number number) 2 :test #'approx=) - -(def-type-prop-test \+.1 '+ '(integer integer) 2) -(def-type-prop-test \+.2 '+ nil 1 :rest-type 'integer :maxargs 4) -(def-type-prop-test \+.3 '+ nil 2 :rest-type 'integer :maxargs 10) -(def-type-prop-test \+.4 '+ '(real real) 2 :test #'approx=) -(def-type-prop-test \+.5 '+ '(number number) 2 :test #'approx=) - -(def-type-prop-test \-.1 '- '(integer integer) 2) -(def-type-prop-test \-.2 '- nil 1 :rest-type 'integer :maxargs 4) -(def-type-prop-test \-.3 '- nil 2 :rest-type 'integer :maxargs 10) -(def-type-prop-test \-.4 '- '(real real) 2 :test #'approx=) -(def-type-prop-test \-.5 '- '(number number) 2 :test #'approx=) -(def-type-prop-test \-.6 '- '(number) 1) - -;;; WARNING -- these tests may cause floating point overflow/underflow -;;; Ignore those failures -(def-type-prop-test /.1 '/ '((and integer (not (satisfies zerop)))) 1) -(def-type-prop-test /.2 '/ '((and rational (not (satisfies zerop)))) 1) -(def-type-prop-test /.3 '/ '((and real (not (satisfies zerop)))) 1 :ignore 'arithmetic-error) -(def-type-prop-test /.4 '/ '((and complex (not (satisfies zerop)))) 1 :ignore 'arithmetic-error) -(def-type-prop-test /.5 '/ '(integer) 2 :maxargs 6 :rest-type '(and integer (not (satisfies zerop)))) -(def-type-prop-test /.6 '/ '(rational) 2 :maxargs 6 :rest-type '(and rational (not (satisfies zerop)))) -(def-type-prop-test /.7 '/ '(real) 2 :maxargs 6 :rest-type '(and real (not (satisfies zerop))) - :test #'approx= :ignore 'arithmetic-error) -(def-type-prop-test /.8 '/ '(number) 2 :maxargs 6 :rest-type '(and number (not (satisfies zerop))) - :test #'approx= :ignore 'arithmetic-error) - -(def-type-prop-test 1+.1 '1+ '(integer) 1) -(def-type-prop-test 1+.2 '1+ '(rational) 1) -(def-type-prop-test 1+.3 '1+ '(real) 1) -(def-type-prop-test 1+.4 '1+ '(number) 1) - -(def-type-prop-test 1-.1 '1- '(integer) 1) -(def-type-prop-test 1-.2 '1- '(rational) 1) -(def-type-prop-test 1-.3 '1- '(real) 1) -(def-type-prop-test 1-.4 '1- '(number) 1) - -(def-type-prop-test abs.1 'abs '(integer) 1) -(def-type-prop-test abs.2 'abs '(rational) 1) -(def-type-prop-test abs.3 'abs '(real) 1) -(def-type-prop-test abs.4 'abs '(number) 1) - -(def-type-prop-test evenp 'evenp '(integer) 1) -(def-type-prop-test oddp 'oddp '(integer) 1) - -;;; exp, expt here - -(def-type-prop-test gcd 'gcd nil 1 :maxargs 6 :rest-type 'integer) -(def-type-prop-test lcm 'lcm nil 1 :maxargs 6 :rest-type 'integer) - -(def-type-prop-test log.1 'log '((and real (not (satisfies zerop)))) 1 :test #'approx=) -(def-type-prop-test log.2 'log '((and number (not (satisfies zerop)))) 1 :test #'approx=) - -(def-type-prop-test mod.1 'mod '(integer (and integer (not (satisfies zerop)))) 2) -(def-type-prop-test mod.2 'mod '(real (and real (not (satisfies zerop)))) 2 :test #'approx=) -(def-type-prop-test rem.1 'rem '(integer (and integer (not (satisfies zerop)))) 2) -(def-type-prop-test rem.2 'rem '(real (and real (not (satisfies zerop)))) 2 :test #'approx=) - -(def-type-prop-test signum.1 'signum '(integer) 1) -(def-type-prop-test signum.2 'signum '(rational) 1) -(def-type-prop-test signum.3 'signum '(real) 1) -(def-type-prop-test signum.4 'signum '(number) 1) - -(def-type-prop-test sqrt.1 'sqrt '(integer) 1 :test #'approx=) -(def-type-prop-test sqrt.2 'sqrt '(rational) 1 :test #'approx=) -(def-type-prop-test sqrt.3 'sqrt '(real) 1 :test #'approx=) -(def-type-prop-test sqrt.4 'sqrt '(number) 1 :test #'approx=) - -(def-type-prop-test isqrt 'isqrt '((integer 0)) 1) - -(def-type-prop-test numberp 'numberp '(t) 1) - -(def-type-prop-test complex.1 'complex '(integer) 1) -(def-type-prop-test complex.2 'complex '(rational) 1) -(def-type-prop-test complex.3 'complex '(real) 1) -(def-type-prop-test complex.4 'complex '(rational rational) 2) -(def-type-prop-test complex.5 'complex '(real real) 2) - -(def-type-prop-test complexp 'complexp '(t) 1) - -(def-type-prop-test conjugate 'conjugate '(number) 1) - -(def-type-prop-test phase.1 'phase '(real) 1) -(def-type-prop-test phase.2 'phase '(number) 1 :test #'approx=) - -(def-type-prop-test realpart.1 'realpart '(real) 1) -(def-type-prop-test realpart.2 'realpart '(number) 1) -(def-type-prop-test imagpart.1 'imagpart '(real) 1) -(def-type-prop-test imagpart.2 'imagpart '(number) 1) - -(def-type-prop-test realp 'realp '(t) 1) - -(def-type-prop-test numerator 'numerator '(rational) 1) -(def-type-prop-test denominator 'denominator '(rational) 1) - -(def-type-prop-test rational 'rational '(real) 1) -(def-type-prop-test rationalize 'rationalize '(real) 1) - -(def-type-prop-test rationalp 'rationalp '(t) 1) - -(def-type-prop-test ash.1 'ash '(integer (integer -32 32)) 2) -(def-type-prop-test ash.2 'ash '(integer (integer -100 100)) 2) - -(def-type-prop-test integer-length 'integer-length '(integer) 1) -(def-type-prop-test integerp 'integerp '(t) 1) - -(def-type-prop-test logand.1 'logand '(integer integer) 2) -(def-type-prop-test logand.2 'logand nil 2 :rest-type 'integer :maxargs 6) - -(def-type-prop-test logandc1 'logandc1 '(integer integer) 2) -(def-type-prop-test logandc2 'logandc2 '(integer integer) 2) - -(def-type-prop-test lognand 'lognand '(integer integer) 2) -(def-type-prop-test lognor 'lognor '(integer integer) 2) - -(def-type-prop-test logeqv.1 'logeqv '(integer integer) 2) -(def-type-prop-test logeqv.2 'logeqv nil 2 :rest-type 'integer :maxargs 6) - -(def-type-prop-test logior.1 'logior '(integer integer) 2) -(def-type-prop-test logior.2 'logior nil 2 :rest-type 'integer :maxargs 6) - -(def-type-prop-test logxor.1 'logxor '(integer integer) 2) -(def-type-prop-test logxor.2 'logxor nil 2 :rest-type 'integer :maxargs 6) - -(def-type-prop-test logorc1 'logorc1 '(integer integer) 2) -(def-type-prop-test logorc2 'logorc2 '(integer integer) 2) - -(def-type-prop-test lognot 'lognot '(integer) 1) - -(def-type-prop-test logbitp.1 'logbitp '((integer 0 32) integer) 2) -(def-type-prop-test logbitp.2 'logbitp '((integer 0 100) integer) 2) -; (def-type-prop-test logbitp.3 'logbitp '((integer 0) integer) 2) - -(def-type-prop-test logcount 'logcount '(integer) 1) -(def-type-prop-test logtest 'logtest '(integer integer) 2) - -(def-type-prop-test decode-float.1 'decode-float '(float) 1) -(def-type-prop-test decode-float.2 '(lambda (x) (nth-value 1 (decode-float x))) '(float) 1) -(def-type-prop-test decode-float.3 '(lambda (x) (nth-value 2 (decode-float x))) '(float) 1) -(def-type-prop-test float-radix 'float-radix '(float) 1) -(def-type-prop-test scale-float 'scale-float '(float (integer -30 30)) 2 :ignore 'arithmetic-error :test #'approx=) -(def-type-prop-test float-sign.1 'float-sign '(float) 1) -(def-type-prop-test float-sign.2 'float-sign '(float float) 2) -(def-type-prop-test float-digits 'float-digits '(float) 1) -(def-type-prop-test float-precision 'float-precision '(float) 1) -(def-type-prop-test integer-decode-float.1 'integer-decode-float '(float) 1) -(def-type-prop-test integer-decode-float.2 '(lambda (x) (nth-value 1 (integer-decode-float x))) '(float) 1) -(def-type-prop-test integer-decode-float.3 '(lambda (x) (nth-value 2 (integer-decode-float x))) '(float) 1) - - -(def-type-prop-test float.1 'float '(real) 1) -(def-type-prop-test float.2 'float '(real float) 2) -(def-type-prop-test floatp 'floatp '(t) 1) - -(defun has-nonzero-length (x) (> (length x) 0)) - -(def-type-prop-test parse-integer.1 'parse-integer - '((and (vector (member #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) - (satisfies has-nonzero-length))) - 1) - -(def-type-prop-test parse-integer.2 'parse-integer - `((and (vector (member #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) - (satisfies has-nonzero-length)) - (eql :start) - ,#'(lambda (x &rest rest) (declare (ignore rest)) - `(integer 0 (,(length x))))) - 3) - -(def-type-prop-test sxhash 'sxhash '(t) 1) diff --git a/t/ansi-test/random/random-type-prop-tests-04.lsp b/t/ansi-test/random/random-type-prop-tests-04.lsp deleted file mode 100644 index b12aae4..0000000 --- a/t/ansi-test/random/random-type-prop-tests-04.lsp +++ /dev/null @@ -1,107 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Mar 6 21:44:41 2005 -;;;; Contains: Test that invoke the random type prop infrastructure, part 4 - -(in-package :cl-test) - -(defun char-or-same (c &rest args) - (declare (ignore args)) - (if (coin) `(eql ,c) 'character)) - -(eval-when (:load-toplevel :execute) (compile 'char-or-same)) - -(def-type-prop-test char=.1 'char= nil 2 :rest-type 'base-char :maxargs 5) -(def-type-prop-test char=.2 'char= '(character character) 2) -(def-type-prop-test char=.3 'char= (list 'character #'char-or-same) 2) -(def-type-prop-test char=.4 'char= (list 'character #'char-or-same #'char-or-same) 3) -(def-type-prop-test char=.5 'char= '(character) 3 :rest-type #'char-or-same :maxargs 6) - -(def-type-prop-test char/=.1 'char/= nil 2 :rest-type 'base-char :maxargs 5) -(def-type-prop-test char/=.2 'char/= '(character character) 2) -(def-type-prop-test char/=.3 'char/= (list 'character #'char-or-same) 2) -(def-type-prop-test char/=.4 'char/= (list 'character 'character #'char-or-same) 3) -(def-type-prop-test char/=.5 'char/= nil 2 :rest-type 'character :maxargs 6) - -(def-type-prop-test char<=.1 'char<= nil 2 :rest-type 'base-char :maxargs 5) -(def-type-prop-test char<=.2 'char<= '(character character) 2) -(def-type-prop-test char<=.3 'char<= (list 'character #'char-or-same) 2) -(def-type-prop-test char<=.4 'char<= (list 'character #'char-or-same #'char-or-same) 3) -(def-type-prop-test char<=.5 'char<= '(character) 3 :rest-type #'char-or-same :maxargs 6) - -(def-type-prop-test char>=.1 'char>= nil 2 :rest-type 'base-char :maxargs 5) -(def-type-prop-test char>=.2 'char>= '(character character) 2) -(def-type-prop-test char>=.3 'char>= (list 'character #'char-or-same) 2) -(def-type-prop-test char>=.4 'char>= (list 'character #'char-or-same #'char-or-same) 3) -(def-type-prop-test char>=.5 'char>= '(character) 3 :rest-type #'char-or-same :maxargs 6) - -(def-type-prop-test char<.1 'char< nil 2 :rest-type 'base-char :maxargs 5) -(def-type-prop-test char<.2 'char< '(character character) 2) -(def-type-prop-test char<.3 'char< (list 'character #'char-or-same) 2) -(def-type-prop-test char<.4 'char< (list 'character 'character #'char-or-same) 3) -(def-type-prop-test char<.5 'char< nil 2 :rest-type 'character :maxargs 6) - -(def-type-prop-test char>.1 'char> nil 2 :rest-type 'base-char :maxargs 5) -(def-type-prop-test char>.2 'char> '(character character) 2) -(def-type-prop-test char>.3 'char> (list 'character #'char-or-same) 2) -(def-type-prop-test char>.4 'char> (list 'character 'character #'char-or-same) 3) -(def-type-prop-test char>.5 'char> nil 2 :rest-type 'character :maxargs 6) - - -(def-type-prop-test char-equal.1 'char-equal nil 2 :rest-type 'base-char :maxargs 5) -(def-type-prop-test char-equal.2 'char-equal '(character character) 2) -(def-type-prop-test char-equal.3 'char-equal (list 'character #'char-or-same) 2) -(def-type-prop-test char-equal.4 'char-equal (list 'character #'char-or-same #'char-or-same) 3) -(def-type-prop-test char-equal.5 'char-equal '(character) 3 :rest-type #'char-or-same :maxargs 6) - -(def-type-prop-test char-not-equal.1 'char-not-equal nil 2 :rest-type 'base-char :maxargs 5) -(def-type-prop-test char-not-equal.2 'char-not-equal '(character character) 2) -(def-type-prop-test char-not-equal.3 'char-not-equal (list 'character #'char-or-same) 2) -(def-type-prop-test char-not-equal.4 'char-not-equal (list 'character 'character #'char-or-same) 3) -(def-type-prop-test char-not-equal.5 'char-not-equal nil 2 :rest-type 'character :maxargs 6) - -(def-type-prop-test char-not-greaterp.1 'char-not-greaterp nil 2 :rest-type 'base-char :maxargs 5) -(def-type-prop-test char-not-greaterp.2 'char-not-greaterp '(character character) 2) -(def-type-prop-test char-not-greaterp.3 'char-not-greaterp (list 'character #'char-or-same) 2) -(def-type-prop-test char-not-greaterp.4 'char-not-greaterp (list 'character #'char-or-same #'char-or-same) 3) -(def-type-prop-test char-not-greaterp.5 'char-not-greaterp '(character) 3 :rest-type #'char-or-same :maxargs 6) - -(def-type-prop-test char-not-lessp.1 'char-not-lessp nil 2 :rest-type 'base-char :maxargs 5) -(def-type-prop-test char-not-lessp.2 'char-not-lessp '(character character) 2) -(def-type-prop-test char-not-lessp.3 'char-not-lessp (list 'character #'char-or-same) 2) -(def-type-prop-test char-not-lessp.4 'char-not-lessp (list 'character #'char-or-same #'char-or-same) 3) -(def-type-prop-test char-not-lessp.5 'char-not-lessp '(character) 3 :rest-type #'char-or-same :maxargs 6) - -(def-type-prop-test char-lessp.1 'char-lessp nil 2 :rest-type 'base-char :maxargs 5) -(def-type-prop-test char-lessp.2 'char-lessp '(character character) 2) -(def-type-prop-test char-lessp.3 'char-lessp (list 'character #'char-or-same) 2) -(def-type-prop-test char-lessp.4 'char-lessp (list 'character 'character #'char-or-same) 3) -(def-type-prop-test char-lessp.5 'char-lessp nil 2 :rest-type 'character :maxargs 6) - -(def-type-prop-test char-greaterp.1 'char-greaterp nil 2 :rest-type 'base-char :maxargs 5) -(def-type-prop-test char-greaterp.2 'char-greaterp '(character character) 2) -(def-type-prop-test char-greaterp.3 'char-greaterp (list 'character #'char-or-same) 2) -(def-type-prop-test char-greaterp.4 'char-greaterp (list 'character 'character #'char-or-same) 3) -(def-type-prop-test char-greaterp.5 'char-greaterp nil 2 :rest-type 'character :maxargs 6) - -(defun length1-p (seq) (= (length seq) 1)) - -(def-type-prop-test character 'character '((or character (and (string 1) (satisfies length1-p)))) 1) -(def-type-prop-test characterp 'characterp '(t) 1) -(def-type-prop-test alpha-char-p 'alpha-char-p '(character) 1) -(def-type-prop-test alphanumericp 'alphanumericp '(character) 1) -(def-type-prop-test digit-char 'digit-char '((or (integer 0 36) (integer 0)) (integer 2 36)) 1 :maxargs 2) -(def-type-prop-test digit-char-p 'digit-char-p '(character) 1) -(def-type-prop-test graphic-char-p 'graphic-char-p '(character) 1) -(def-type-prop-test standard-char-p 'standard-char-p '(character) 1) -(def-type-prop-test char-upcase 'char-upcase '(character) 1) -(def-type-prop-test char-downcase 'char-downcase '(character) 1) -(def-type-prop-test upper-case-p 'upper-case-p '(character) 1) -(def-type-prop-test lower-case-p 'lower-case-p '(character) 1) -(def-type-prop-test both-case-p 'both-case-p '(character) 1) -(def-type-prop-test char-code 'char-code '(character) 1) -(def-type-prop-test char-int 'char-int '(character) 1) -(def-type-prop-test code-char 'code-char '((integer 0 #.char-code-limit)) 1) -(def-type-prop-test char-name 'char-name '(character) 1) -(def-type-prop-test name-char 'name-char '(string) 1) - diff --git a/t/ansi-test/random/random-type-prop-tests-05.lsp b/t/ansi-test/random/random-type-prop-tests-05.lsp deleted file mode 100644 index 5ef8ee9..0000000 --- a/t/ansi-test/random/random-type-prop-tests-05.lsp +++ /dev/null @@ -1,528 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Mar 8 20:31:08 2005 -;;;; Contains: Random type prop tests, part 5 (Cons) - -(in-package :cl-test) - -(def-type-prop-test list.1 'list nil 1 :rest-type 't :maxargs 10) -(def-type-prop-test list.2 '(lambda (x) (car (list x))) '(t) 1) -(def-type-prop-test list.3 '(lambda (x y) (cdr (list x y))) '(t t) 2) -(def-type-prop-test list.4 '(lambda (x y z) (cadr (list x y z))) '(t t t) 3) -(def-type-prop-test list.5 '(lambda (x) (let ((z (list x))) (declare (dynamic-extent z)) (car z))) '(t) 1) - -(def-type-prop-test list* 'list* () 1 :rest-type t :maxargs 10) - -(def-type-prop-test null 'null '(t) 1) -(def-type-prop-test cons.1 'cons '(t t) 2) -(def-type-prop-test cons.2 '(lambda (x y) (car (cons y x))) '(t t) 2) -(def-type-prop-test cons.3 '(lambda (x y) (cdr (cons x y))) '(t t) 2) - -(def-type-prop-test consp 'consp '(t) 1) -(def-type-prop-test atom 'atom '(t) 1) - -(def-type-prop-test rplaca 'rplaca '(cons t) 2 :replicate '(t nil)) -(def-type-prop-test rplacd 'rplacd '(cons t) 2 :replicate '(t nil)) - -(def-type-prop-test car 'car '((cons t t)) 1) -(def-type-prop-test first 'first '((cons t t)) 1) -(def-type-prop-test cdr 'cdr '((cons t t)) 1) -(def-type-prop-test rest 'rest '((cons t t)) 1) -(def-type-prop-test caar 'caar '((cons (cons t t) t)) 1) -(def-type-prop-test cdar 'cdar '((cons (cons t t) t)) 1) -(def-type-prop-test cadr 'cadr '((cons t (cons t t))) 1) -(def-type-prop-test second 'second '((cons t (cons t t))) 1) -(def-type-prop-test cddr 'cddr '((cons t (cons t t))) 1) -(def-type-prop-test caaar 'caaar '((cons (cons (cons t t) t) t)) 1) -(def-type-prop-test cdaar 'cdaar '((cons (cons (cons t t) t) t)) 1) -(def-type-prop-test cadar 'cadar '((cons (cons t (cons t t)) t)) 1) -(def-type-prop-test cddar 'cddar '((cons (cons t (cons t t)) t)) 1) -(def-type-prop-test caadr 'caadr '((cons t (cons (cons t t) t))) 1) -(def-type-prop-test cdadr 'cdadr '((cons t (cons (cons t t) t))) 1) -(def-type-prop-test caddr 'caddr '((cons t (cons t (cons t t)))) 1) -(def-type-prop-test third 'third '((cons t (cons t (cons t t)))) 1) -(def-type-prop-test cdddr 'cdddr '((cons t (cons t (cons t t)))) 1) - -(def-type-prop-test caaaar'caaaar '((cons (cons (cons (cons t t) t) t) t)) 1) -(def-type-prop-test cdaaar 'cdaaar '((cons (cons (cons (cons t t) t) t) t)) 1) -(def-type-prop-test cadaar 'cadaar '((cons (cons (cons t (cons t t)) t) t)) 1) -(def-type-prop-test cddaar 'cddaar '((cons (cons (cons t (cons t t)) t) t)) 1) -(def-type-prop-test caadar 'caadar '((cons (cons t (cons (cons t t) t)) t)) 1) -(def-type-prop-test cdadar 'cdadar '((cons (cons t (cons (cons t t) t)) t)) 1) -(def-type-prop-test caddar 'caddar '((cons (cons t (cons t (cons t t))) t)) 1) -(def-type-prop-test cdddar 'cdddar '((cons (cons t (cons t (cons t t))) t)) 1) -(def-type-prop-test caaadr 'caaadr '((cons t (cons (cons (cons t t) t) t))) 1) -(def-type-prop-test cdaadr 'cdaadr '((cons t (cons (cons (cons t t) t) t))) 1) -(def-type-prop-test cadadr 'cadadr '((cons t (cons (cons t (cons t t)) t))) 1) -(def-type-prop-test cddadr 'cddadr '((cons t (cons (cons t (cons t t)) t))) 1) -(def-type-prop-test caaddr 'caaddr '((cons t (cons t (cons (cons t t) t)))) 1) -(def-type-prop-test cdaddr 'cdaddr '((cons t (cons t (cons (cons t t) t)))) 1) -(def-type-prop-test cadddr 'cadddr '((cons t (cons t (cons t (cons t t))))) 1) -(def-type-prop-test fourth 'fourth '((cons t (cons t (cons t (cons t t))))) 1) -(def-type-prop-test cddddr 'cddddr '((cons t (cons t (cons t (cons t t))))) 1) - -(def-type-prop-test fifth 'fifth '((cons t (cons t (cons t (cons t (cons t t)))))) 1) -(def-type-prop-test sixth 'sixth '((cons t (cons t (cons t (cons t (cons t (cons t t))))))) 1) -(def-type-prop-test seventh 'seventh '((cons t (cons t (cons t (cons t (cons t (cons t (cons t t)))))))) 1) -(def-type-prop-test eighth 'eighth - '((cons t (cons t (cons t (cons t (cons t (cons t (cons t (cons t t))))))))) - 1) -(def-type-prop-test ninth 'ninth - '((cons t (cons t (cons t (cons t (cons t (cons t (cons t (cons t (cons t t)))))))))) - 1) -(def-type-prop-test tenth 'tenth - '((cons t (cons t (cons t (cons t (cons t (cons t (cons t (cons t (cons t (cons t t))))))))))) - 1) - -(def-type-prop-test pop '(lambda (x) (list (pop x) x)) '((cons t t)) 1) -(def-type-prop-test push '(lambda (x y) (list (push x y) x y)) '(t t) 2) - -(def-type-prop-test copy-tree.1 'copy-tree '((cons t t)) 1) -(def-type-prop-test copy-tree.2 'copy-tree '((cons (cons t t) (cons t t))) 1) -(def-type-prop-test copy-tree.3 'copy-tree '((cons t (cons (cons t (cons t t)) t))) 1) -(def-type-prop-test copy-tree.4 'copy-tree '(list) 1) - -(def-type-prop-test sublis.1 'sublis '((cons (cons symbol t) null) list) 2) -(def-type-prop-test sublis.2 'sublis '((cons (cons (integer 0 7) t) null) list) 2) -(def-type-prop-test sublis.3 'sublis '(null list) 2) -(def-type-prop-test sublis.4 'sublis `((cons (cons boolean t) null) list - (eql :key) - (or null (eql not) (eql ,#'not))) 4) -(def-type-prop-test sublis.5 'sublis `((cons (cons t t) null) list (eql :test) (or (eql equal) (eql ,#'equal))) 4) -(def-type-prop-test sublis.6 'sublis `((cons (cons t t) null) list (eql :test-not) (or (eql eql) (eql ,#'eql))) 4) - -(def-type-prop-test subst.1 'subst '(t t t) 3) -(def-type-prop-test subst.2 'subst '(t t (cons t t)) 3) -(def-type-prop-test subst.3 'subst '(t t list) 3) -(def-type-prop-test subst.4 'subst '(t t (cons (cons t t) (cons t t))) 3) -(def-type-prop-test subst.5 'subst `(boolean t (cons (cons t t) (cons t t)) - (eql :key) - (or null (eql not) (eql ,#'not))) 5) -(def-type-prop-test subst.6 'subst `(t t (cons (cons t t) (cons t t)) (eql :test) (or (eql equal) (eql ,#'equal))) 5) -(def-type-prop-test subst.7 'subst `(t t (cons (cons t t) (cons t t)) (eql :test-not) (or (eql equal) (eql ,#'equal))) 5) -(def-type-prop-test subst.8 'subst `(t t (cons (cons t t) (cons t t)) - (eql :key) (or null (eql not) (eql ,#'not)) - (eql :test) (or (eql equal) (eql ,#'equal))) 7) - -(def-type-prop-test nsubst.1 'nsubst '(t t t) 3 :replicate '(nil nil t)) -(def-type-prop-test nsubst.2 'nsubst '(t t (cons t t)) 3 :replicate '(nil nil t)) -(def-type-prop-test nsubst.3 'nsubst '(t t list) 3 :replicate '(nil nil t)) -(def-type-prop-test nsubst.4 'nsubst '(t t (cons (cons t t) (cons t t))) 3 :replicate '(nil nil t)) -(def-type-prop-test nsubst.5 'nsubst `(boolean t (cons (cons t t) (cons t t)) - (eql :key) - (or null (eql not) (eql ,#'not))) 5 - :replicate '(nil nil t nil nil)) -(def-type-prop-test nsubst.6 'nsubst `(t t (cons (cons t t) (cons t t)) (eql :test) (or (eql equal) (eql ,#'equal))) 5 :replicate '(nil nil t nil nil)) -(def-type-prop-test nsubst.7 'nsubst `(t t (cons (cons t t) (cons t t)) (eql :test-not) (or (eql equal) (eql ,#'equal))) 5 :replicate '(nil nil t nil nil)) -(def-type-prop-test nsubst.8 'nsubst `(t t (cons (cons t t) (cons t t)) - (eql :key) (or null (eql not) (eql ,#'not)) - (eql :test) (or (eql equal) (eql ,#'equal))) 7 - :replicate '(nil nil t nil nil nil nil)) - - -(def-type-prop-test subst-if.1 'subst-if `(t (or (eql not) (eql ,#'not)) list) 3) -(def-type-prop-test subst-if.2 'subst-if `(t (or (eql not) (eql ,#'not)) (cons (or null t) (or null t))) 3) -(def-type-prop-test subst-if.3 'subst-if `(t (eql identity) - (cons (cons (cons t t) (cons t t)) (cons (cons t t) (cons t t))) - (eql :key) (or null (eql not) (eql ,#'not))) 5) - -(def-type-prop-test nsubst-if.1 'nsubst-if `(t (or (eql not) (eql ,#'not)) list) 3 :replicate '(nil nil t)) -(def-type-prop-test nsubst-if.2 'nsubst-if `(t (or (eql not) (eql ,#'not)) (cons (or null t) (or null t))) 3 :replicate '(nil nil t)) -(def-type-prop-test nsubst-if.3 'nsubst-if `(t (eql identity) - (cons (cons (cons t t) (cons t t)) (cons (cons t t) (cons t t))) - (eql :key) (or null (eql not) (eql ,#'not))) 5 - :replicate '(nil nil t nil nil)) - -(def-type-prop-test subst-if-not.1 'subst-if-not `(t (or (eql not) (eql ,#'not)) list) 3) -(def-type-prop-test subst-if-not.2 'subst-if-not `(t (or (eql not) (eql ,#'not)) (cons (or null t) (or null t))) 3) -(def-type-prop-test subst-if-not.3 'subst-if-not `(t (eql identity) - (cons (cons (cons t t) (cons t t)) (cons (cons t t) (cons t t))) - (eql :key) (or null (eql not) (eql ,#'not))) 5) - -(def-type-prop-test nsubst-if-not.1 'nsubst-if-not `(t (or (eql not) (eql ,#'not)) list) 3 :replicate '(nil nil t)) -(def-type-prop-test nsubst-if-not.2 'nsubst-if-not `(t (or (eql not) (eql ,#'not)) (cons (or null t) (or null t))) 3 :replicate '(nil nil t)) -(def-type-prop-test nsubst-if-not.3 'nsubst-if-not `(t (eql identity) - (cons (cons (cons t t) (cons t t)) (cons (cons t t) (cons t t))) - (eql :key) (or null (eql not) (eql ,#'not))) 5 - :replicate '(nil nil t nil nil)) - -(def-type-prop-test tree-equal.1 'tree-equal (list t #'(lambda (x) `(or t (eql ,(copy-tree x))))) 2) -(def-type-prop-test tree-equal.2 'tree-equal (list 'list #'(lambda (x) `(or list (eql ,(copy-tree t))))) 2) -(def-type-prop-test tree-equal.3 'tree-equal (list '(cons t t) - #'(lambda (x) `(or (cons t t) (eql ,(copy-tree x)))) - '(eql :test) - `(or (eql equal) (eql ,#'equal))) - 4) -(def-type-prop-test tree-equal.4 'tree-equal (list t #'(lambda (x) `(or t (eql ,(copy-tree x)))) - '(eql :test-not) '(eql eql)) - 4) - -(def-type-prop-test copy-list.1 'copy-list '(list) 1) -(def-type-prop-test copy-list.2 'copy-list '((cons t t)) 1) -(def-type-prop-test copy-list.3 'copy-list '((cons t (cons t (or t (cons t (or t (cons t t))))))) 1) - -(def-type-prop-test list-length.1 'list-length '(list) 1) -(def-type-prop-test list-length.2 'list-length '((cons t list)) 1) - -(def-type-prop-test listp 'listp '(t) 1) - -(def-type-prop-test make-list.1 'make-list '((integer 0 100)) 1) -(def-type-prop-test make-list.2 '(lambda (x) (length (make-list x))) '((integer 0 100)) 1) -(def-type-prop-test make-list.3 'make-list '((integer 0 100) (eql :initial-element) t) 3) - -(def-type-prop-test nth.1 'nth '((integer 0 12) list) 2) - -(def-type-prop-test endp.1 'endp '((or null (cons t t))) 1) - -(def-type-prop-test append.1 'append nil 1 :maxargs 10 :rest-type 'list) -(def-type-prop-test append.2 'append '(list t) 2) -(def-type-prop-test append.3 'append '(list list t) 3) -(def-type-prop-test append.4 'append '(list list list t) 4) - -(def-type-prop-test nconc.1 'nconc '(list) 1) -(def-type-prop-test nconc.2 'nconc '(list list) 2 :replicate '(t nil)) -(def-type-prop-test nconc.3 'nconc '(list list list) 3 :replicate '(t t nil)) -(def-type-prop-test nconc.4 'nconc '(list list list list) 4 :replicate '(t t t nil)) - -(def-type-prop-test revappend 'revappend '(list t) 2) -(def-type-prop-test nreconc 'nreconc '(list t) 2 :replicate '(t nil)) - -(def-type-prop-test butlast.1 'butlast '(list) 1) -(def-type-prop-test butlast.2 'butlast '(list (integer 0 20)) 2) - -(def-type-prop-test nbutlast.1 'nbutlast '(list) 1 :replicate '(t)) -(def-type-prop-test nbutlast.2 'nbutlast '(list (integer 0 20)) 2 :replicate '(t nil)) - -(def-type-prop-test last.1 'last '(list) 1) -(def-type-prop-test last.2 'last '(list (integer 0 15)) 2) -(def-type-prop-test last.3 'last '((cons t (or t (cons t (or t (cons t t)))))) 1) -(def-type-prop-test last.4 'last '((cons t (or t (cons t (or t (cons t t))))) (integer 0 5)) 2) - -(def-type-prop-test ldiff.1 'ldiff '(list t) 2) -(def-type-prop-test ldiff.2 'ldiff (list 'list - #'(lambda (x) - (if (consp x) - `(or t (eql ,(nthcdr (random (length x)) x))) - t))) - 2) - -(def-type-prop-test tailp.1 'tailp '(t list) 2) -(def-type-prop-test tailp.2 'tailp (list t #'(lambda (x) (make-list-type (1+ (random 10)) `(eql ,x)))) 2) - -(def-type-prop-test nthcdr 'nthcdr '((integer 0 20) list) 2) - -(def-type-prop-test member.1 'member '(t list) 2) -(def-type-prop-test member.2 'member - (list t #'(lambda (x) (make-list-type (random 5) `(cons (eql ,x) ,(make-list-type (random 5)))))) - 2) -(def-type-prop-test member.3 'member `(t list (eql :key) (or (eql not) (eql ,#'not))) 4) -(def-type-prop-test member.4 'member `(t list (eql :test) (or (eql equalp) (eql ,#'equalp))) 4) -(def-type-prop-test member.5 'member `(t list (eql :test-not) (or (eql eql) (eql ,#'eql))) 4) -(def-type-prop-test member.6 'member `(t list (eql :allow-other-keys) (and t (not null)) (eql :foo) t) 6) - -(def-type-prop-test member-if.1 'member-if `((or (eql symbolp) (eql ,#'symbolp)) list) 2) -(def-type-prop-test member-if.2 'member-if - (list '(eql zerop) #'(lambda (x) (make-list-type (random 10) 'null '(integer 0 10)))) - 2) -(def-type-prop-test member-if.3 'member-if - (list '(eql zerop) #'(lambda (x) (make-list-type (random 10) 'null '(integer 0 10))) - '(eql :key)`(or (eql 1-) (eql ,#'1-))) - 4) - -(def-type-prop-test member-if-not.1 'member-if-not `((or (eql symbolp) (eql ,#'symbolp)) list) 2) -(def-type-prop-test member-if-not.2 'member-if-not - (list '(eql plusp) #'(lambda (x) (make-list-type (random 10) 'null '(integer 0 10)))) - 2) -(def-type-prop-test member-if-not.3 'member-if-not - (list '(eql plusp) - #'(lambda (x) (make-list-type (random 10) 'null '(integer 0 10))) - '(eql :key) - `(or (eql 1-) (eql ,#'1-))) - 4) -(def-type-prop-test member-if-not.4 'member-if-not - `((eql identity) list - (eql :allow-other-keys) (and t (not null)) - (member :foo :bar #:xyz) t) - 6) - -(def-type-prop-test mapc.1 'mapc '((eql list)) 2 :rest-type 'list :maxargs 10) -(def-type-prop-test mapc.2 'mapc `((eql ,#'values)) 2 :rest-type 'list :maxargs 10) - -(def-type-prop-test mapcar.1 'mapcar '((eql list)) 2 :rest-type 'list :maxargs 10) -(def-type-prop-test mapcar.2 'mapcar `((eql ,#'vector)) 2 :rest-type 'list :maxargs 10) - -(def-type-prop-test maplist.1 'maplist '((eql list)) 2 :rest-type 'list :maxargs 10) -(def-type-prop-test maplist.2 'maplist `((eql ,#'vector)) 2 :rest-type 'list :maxargs 10) - -(def-type-prop-test mapl.1 'mapl '((eql list)) 2 :rest-type 'list :maxargs 10) -(def-type-prop-test mapl.2 'mapl `((eql ,#'vector)) 2 :rest-type 'list :maxargs 10) - -(def-type-prop-test mapcan.1 'mapcan '((eql list)) 2 :rest-type 'list :maxargs 10) - -(def-type-prop-test mapcon.1 'mapcon '((eql copy-list) list) 2) - -(def-type-prop-test acons 'acons - (list t t #'(lambda (x y) (make-list-type (random 5) 'null '(or null (cons t t))))) - 3) - -(def-type-prop-test assoc.1 'assoc (list t #'(lambda (x) (make-list-type (random 6) 'null '(or null (cons t t))))) 2) -(def-type-prop-test assoc.2 'assoc - (list t #'(lambda (x) (make-list-type (random 6) 'null `(or null (cons t t) (cons (eql ,x) t))))) - 2) -(def-type-prop-test assoc.3 'assoc - (list t #'(lambda (x) (make-list-type (random 6) 'null `(or null (cons t t) (cons (eql ,x) t)))) - '(eql :key) `(or (eql not) (eql ,#'not))) - 4) -(def-type-prop-test assoc.4 'assoc - (list 'real - #'(lambda (x) (make-list-type (random 6) 'null `(or null (cons real t) (cons (eql ,x) t)))) - `(member :test :test-not) `(member <= < = /= > >= ,#'<= ,#'< ,#'= ,#'/= ,#'> ,#'>=)) - 4) - -(def-type-prop-test assoc-if.1 'assoc-if - (list `(member identity not symbolp numberp arrayp ,#'identity ,#'not ,#'symbolp ,#'numberp ,#'arrayp) - (make-list-type (random 8) 'null '(or null (cons t t)))) - 2) -(def-type-prop-test assoc-if.2 'assoc-if - (list `(member plusp minusp zerop ,#'plusp ,#'minusp ,#'zerop) - (make-list-type (random 8) 'null '(or null (cons real t))) - '(eql :key) `(member 1+ 1- - abs signum ,#'1+ ,#'1- ,#'- ,#'abs ,#'signum)) - 2) - -(def-type-prop-test assoc-if-not.1 'assoc-if-not - (list `(member identity not symbolp numberp arrayp ,#'identity ,#'not ,#'symbolp ,#'numberp ,#'arrayp) - (make-list-type (random 8) 'null '(or null (cons t t)))) - 2) -(def-type-prop-test assoc-if-not.2 'assoc-if-not - (list `(member plusp minusp zerop ,#'plusp ,#'minusp ,#'zerop) - (make-list-type (random 8) 'null '(or null (cons real t))) - '(eql :key) `(member 1+ 1- - abs signum ,#'1+ ,#'1- ,#'- ,#'abs ,#'signum)) - 2) - -(def-type-prop-test copy-alist 'copy-alist - (list #'(lambda () (make-list-type (random 10) 'null '(or null (cons t t))))) - 1) - -(def-type-prop-test pairlis.1 'pairlis - (list 'list #'(lambda (x) (make-list-type (length x) 'null t))) - 2) - -(def-type-prop-test pairlis.2 'pairlis - (list 'list #'(lambda (x) (make-list-type (length x) 'null t)) - #'(lambda (x y) (make-list-type (random 6) 'null '(or null (cons t t))))) - 3) - -(def-type-prop-test rassoc.1 'rassoc (list t #'(lambda (x) (make-list-type (random 6) 'null '(or null (cons t t))))) 2) -(def-type-prop-test rassoc.2 'rassoc - (list t #'(lambda (x) (make-list-type (random 6) 'null `(or null (cons t t) (cons t (eql ,x)))))) - 2) -(def-type-prop-test rassoc.3 'rassoc - (list t #'(lambda (x) (make-list-type (random 6) 'null `(or null (cons t t) (cons t (eql ,x))))) - '(eql :key) `(or (eql not) (eql ,#'not))) - 4) -(def-type-prop-test rassoc.4 'rassoc - (list 'real - #'(lambda (x) (make-list-type (random 6) 'null `(or null (cons t real) (cons t (eql ,x))))) - `(member :test :test-not) `(member <= < = /= > >= ,#'<= ,#'< ,#'= ,#'/= ,#'> ,#'>=)) - 4) - -(def-type-prop-test rassoc-if.1 'rassoc-if - (list `(member identity not symbolp numberp arrayp ,#'identity ,#'not ,#'symbolp ,#'numberp ,#'arrayp) - (make-list-type (random 8) 'null '(or null (cons t t)))) - 2) -(def-type-prop-test rassoc-if.2 'rassoc-if - (list `(member plusp minusp zerop ,#'plusp ,#'minusp ,#'zerop) - (make-list-type (random 8) 'null '(or null (cons t real))) - '(eql :key) `(member 1+ 1- - abs signum ,#'1+ ,#'1- ,#'- ,#'abs ,#'signum)) - 2) - -(def-type-prop-test rassoc-if-not.1 'rassoc-if-not - (list `(member identity not symbolp numberp arrayp ,#'identity ,#'not ,#'symbolp ,#'numberp ,#'arrayp) - (make-list-type (random 8) 'null '(or null (cons t t)))) - 2) -(def-type-prop-test rassoc-if-not.2 'rassoc-if-not - (list `(member plusp minusp zerop ,#'plusp ,#'minusp ,#'zerop) - (make-list-type (random 8) 'null '(or null (cons t real))) - '(eql :key) `(member 1+ 1- - abs signum ,#'1+ ,#'1- ,#'- ,#'abs ,#'signum)) - 2) - -;;; We don't use numbers or characters as indicators, since the test is EQ, -;;; which is not well-behaved on these types. - -(def-type-prop-test get-properties.1 'get-properties - (list #'(lambda () (make-list-type (* 2 (random 5)) 'null '(not (or number character)))) 'list) - 2) -(def-type-prop-test get-properties.2 'get-properties - (list #'(lambda () (make-list-type (* 2 (random 5)) 'null '(not (or number character)))) - #'(lambda (plist) (let ((len (length plist))) - (if (= len 0) '(cons t null) - (let ((ind (elt plist (* 2 (random (floor len 2)))))) - `(cons (eql ,ind) null)))))) - 2) - -(def-type-prop-test getf.1 'getf - (list #'(lambda () (make-list-type (* 2 (random 5)) 'null '(not (or number character)))) t) - 2) -(def-type-prop-test getf.2 'getf - (list #'(lambda () (make-list-type (* 2 (random 5)) 'null '(not (or number character)))) - #'(lambda (plist) (let ((len (length plist))) - (if (= len 0) t - (let ((ind (elt plist (* 2 (random (floor len 2)))))) - `(eql ,ind)))))) - 2) -(def-type-prop-test getf.3 'getf - (list #'(lambda () (make-list-type (* 2 (random 5)) 'null '(not (or number character)))) - t t) - 3) - -(def-type-prop-test intersection.1 'intersection '(list list) 2 :test #'same-set-p) -(def-type-prop-test intersection.2 'intersection '(list list (eql :key) (eql identity)) 4 :test #'same-set-p) -(def-type-prop-test intersection.3 'intersection - (list #'(lambda () (make-list-type (random 10) 'null 'integer)) - #'(lambda (x) (make-list-type (random 10) 'null 'integer)) - '(eql :key) - `(member 1+ ,#'1+)) - 4 - :test #'same-set-p) -(def-type-prop-test intersection.4 'intersection - (list #'(lambda () (make-list-type (random 10) 'null '(cons integer null))) - #'(lambda (x) (make-list-type (random 10) 'null '(cons integer null))) - '(eql :key) - `(member car ,#'car)) - 4 - :test #'(lambda (x y) (same-set-p x y :key #'car))) -(def-type-prop-test intersection.5 'intersection - (list #'(lambda () (make-list-type (random 10) 'null '(cons integer null))) - #'(lambda (x) (make-list-type (random 10) 'null '(cons integer null))) - '(eql :test) - `(member equal ,#'equal)) - 4 - :test #'(lambda (x y) (same-set-p x y :key #'car))) - -(def-type-prop-test nintersection.1 'nintersection '(list list) 2 :test #'same-set-p :replicate '(t t)) -(def-type-prop-test nintersection.2 'nintersection '(list list (eql :key) (eql identity)) 4 :test #'same-set-p :replicate '(t t nil nil)) -(def-type-prop-test nintersection.3 'nintersection - (list #'(lambda () (make-list-type (random 10) 'null 'integer)) - #'(lambda (x) (make-list-type (random 10) 'null 'integer)) - '(eql :key) - `(member 1+ ,#'1+)) - 4 - :test #'same-set-p - :replicate '(t t nil nil)) -(def-type-prop-test nintersection.4 'nintersection - (list #'(lambda () (make-list-type (random 10) 'null '(cons integer null))) - #'(lambda (x) (make-list-type (random 10) 'null '(cons integer null))) - '(eql :key) - `(member car ,#'car)) - 4 - :test #'(lambda (x y) (same-set-p x y :key #'car)) - :replicate '(t t nil nil)) -(def-type-prop-test nintersection.5 'nintersection - (list #'(lambda () (make-list-type (random 10) 'null '(cons integer null))) - #'(lambda (x) (make-list-type (random 10) 'null '(cons integer null))) - '(eql :test) - `(member equal ,#'equal)) - 4 - :test #'(lambda (x y) (same-set-p x y :key #'car)) - :replicate '(t t nil nil)) - - -(def-type-prop-test adjoin.1 'adjoin '(t list) 2) -(def-type-prop-test adjoin.2 'adjoin '((integer 0 1) list) 2) -(def-type-prop-test adjoin.3 'adjoin `((integer 0 10) (cons number (cons number (cons number null))) - (eql :test) (or (eql =) (eql ,#'=))) - 4) -(def-type-prop-test adjoin.4 'adjoin `(number - (cons number (cons number (cons number (cons number null)))) - (eql :test-not) (or (eql /=) (eql ,#'/=))) - 4) -(def-type-prop-test adjoin.5 'adjoin `(number - (cons number (cons number (cons number (cons number null)))) - (eql :key) (or (member 1+ 1- ,#'1+ ,#'1-))) - 4) - -(def-type-prop-test pushnew.1 '(lambda (x y) (list (pushnew x y) y)) '(t list) 2) -(def-type-prop-test pushnew.2 '(lambda (x y) (list (pushnew x y) y)) '((integer 0 1) list) 2) -(def-type-prop-test pushnew.3 '(lambda (x y) (list (pushnew x y :test #'=) y)) - `((integer 0 10) (cons number (cons number (cons number null)))) - 2) -(def-type-prop-test pushnew.4 '(lambda (x y) (list (pushnew x y :test-not #'/=) y)) - `((integer 0 10) (cons number (cons number (cons number null)))) - 2) -(def-type-prop-test pushnew.5 '(lambda (x y) (list (pushnew x y :key #'1+) y)) - `(number (cons number (cons number (cons number (cons number null))))) - 2) - -(def-type-prop-test set-difference.1 'set-difference '(list list) 2) -(def-type-prop-test set-difference.2 'set-difference '((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) - (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))) - 2) -(def-type-prop-test set-difference.3 'set-difference `((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) - (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) - (eql :test) (member = ,#'=)) - 4) -(def-type-prop-test set-difference.4 'set-difference `((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) - (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) - (eql :test-not) (member /= ,#'/=)) - 4) -(def-type-prop-test set-difference.5 'set-difference `((cons (unsigned-byte 3) (cons (unsigned-byte 3) null)) - (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)) - (eql :key) (member evenp oddp ,#'evenp ,#'oddp)) - 4) - -(def-type-prop-test nset-difference.1 'nset-difference '(list list) 2 :replicate '(t t)) -(def-type-prop-test nset-difference.2 'nset-difference '((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) - (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))) - 2 :replicate '(t t)) -(def-type-prop-test nset-difference.3 'nset-difference `((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) - (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) - (eql :test) (member = ,#'=)) - 4 :replicate '(t t nil nil)) -(def-type-prop-test nset-difference.4 'nset-difference `((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) - (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) - (eql :test-not) (member /= ,#'/=)) - 4 :replicate '(t t nil nil)) -(def-type-prop-test nset-difference.5 'nset-difference `((cons (unsigned-byte 3) (cons (unsigned-byte 3) null)) - (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)) - (eql :key) (member evenp oddp ,#'evenp ,#'oddp)) - 4 :replicate '(t t nil nil)) - - -(def-type-prop-test set-exclusive-or.1 'set-exclusive-or '(list list) 2) -(def-type-prop-test set-exclusive-or.2 'set-exclusive-or '((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) - (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))) - 2) -(def-type-prop-test set-exclusive-or.3 'set-exclusive-or `((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) - (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) - (eql :test) (member = ,#'=)) - 4) -(def-type-prop-test set-exclusive-or.4 'set-exclusive-or `((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) - (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) - (eql :test-not) (member /= ,#'/=)) - 4) -(def-type-prop-test set-exclusive-or.5 'set-exclusive-or `((cons (unsigned-byte 3) (cons (unsigned-byte 3) null)) - (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)) - (eql :key) (member evenp oddp ,#'evenp ,#'oddp)) - 4) - -(def-type-prop-test nset-exclusive-or.1 'nset-exclusive-or '(list list) 2 :replicate '(t t)) -(def-type-prop-test nset-exclusive-or.2 'nset-exclusive-or '((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) - (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))) - 2 :replicate '(t t)) -(def-type-prop-test nset-exclusive-or.3 'nset-exclusive-or `((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) - (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) - (eql :test) (member = ,#'=)) - 4 :replicate '(t t nil nil)) -(def-type-prop-test nset-exclusive-or.4 'nset-exclusive-or `((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) - (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) - (eql :test-not) (member /= ,#'/=)) - 4 :replicate '(t t nil nil)) -(def-type-prop-test nset-exclusive-or.5 'nset-exclusive-or `((cons (unsigned-byte 3) (cons (unsigned-byte 3) null)) - (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)) - (eql :key) (member evenp oddp ,#'evenp ,#'oddp)) - 4 :replicate '(t t nil nil)) - -(def-type-prop-test subsetp.1 'subsetp '(list list) 2) -(def-type-prop-test subsetp.2 'subsetp '((cons integer null) - (cons integer (cons integer (cons integer (cons integer null))))) - 2) diff --git a/t/ansi-test/random/random-type-prop-tests-06.lsp b/t/ansi-test/random/random-type-prop-tests-06.lsp deleted file mode 100644 index b90f9d0..0000000 --- a/t/ansi-test/random/random-type-prop-tests-06.lsp +++ /dev/null @@ -1,146 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Mar 13 15:33:55 2005 -;;;; Contains: Random type prop tests, part 6 (arrays) - -(in-package :cl-test) - -(def-type-prop-test adjustable-array-p 'adjustable-array-p '(array) 1) - -(def-type-prop-test aref.0 'aref '((array * nil)) 1) -(def-type-prop-test aref.1 'aref (list '(array * (*)) (index-type-for-dim 0)) 2) -(def-type-prop-test aref.2 'aref (list '(array * (* *)) (index-type-for-dim 0) (index-type-for-dim 1)) 3) -(def-type-prop-test aref.3 'aref (list '(array * (* * *)) - (index-type-for-dim 0) (index-type-for-dim 1) (index-type-for-dim 2)) - 4) - -(def-type-prop-test array-dimension 'array-dimension - (list 'array #'(lambda (x) (let ((r (array-rank x))) (and (> r 0) `(integer 0 (,r)))))) - 2) -(def-type-prop-test array-dimensions 'array-dimensions '(array) 1) -(def-type-prop-test array-element-type 'array-element-type '(array) 1) -(def-type-prop-test array-has-fill-pointer-p.1 'array-has-fill-pointer-p '(array) 1) -(def-type-prop-test array-has-fill-pointer-p.2 'array-has-fill-pointer-p '(vector) 1) -(def-type-prop-test array-displacement.1 'array-displacement '(array) 1) -(def-type-prop-test array-displacement.2 'array-displacement '(vector) 1) - -(def-type-prop-test array-in-bounds-p.0 'array-in-bounds-p '((array * nil)) 1) -(def-type-prop-test array-in-bounds-p.1 'array-in-bounds-p (list '(array * (*)) (index-type-for-dim 0)) 2) -(def-type-prop-test array-in-bounds-p.2 'array-in-bounds-p - (list '(array * (* *)) (index-type-for-dim 0) (index-type-for-dim 1)) 3) -(def-type-prop-test array-in-bounds-p.3 'array-in-bounds-p - (list '(array * (* * *)) (index-type-for-dim 0) (index-type-for-dim 1) (index-type-for-dim 2)) - 4) -(def-type-prop-test array-in-bounds-p.4 'array-in-bounds-p '((array * (*)) integer) 2) -(def-type-prop-test array-in-bounds-p.5 'array-in-bounds-p '((array * (* *)) integer integer) 3) -(def-type-prop-test array-in-bounds-p.6 'array-in-bounds-p '((array * (* * *)) integer integer integer) 4) -(def-type-prop-test array-rank 'array-rank '(array) 1) - -(def-type-prop-test array-row-major-index.0 'array-row-major-index '((array * nil)) 1) -(def-type-prop-test array-row-major-index.1 'array-row-major-index (list '(array * (*)) (index-type-for-dim 0)) 2) -(def-type-prop-test array-row-major-index.2 'array-row-major-index - (list '(array * (* *)) (index-type-for-dim 0) (index-type-for-dim 1)) 3) -(def-type-prop-test array-row-major-index.3 'array-row-major-index - (list '(array * (* * *)) (index-type-for-dim 0) (index-type-for-dim 1) (index-type-for-dim 2)) - 4) -(def-type-prop-test array-total-size 'array-total-size '(array) 1) - -(def-type-prop-test arrayp 'arrayp '(t) 1) - -(def-type-prop-test fill-pointer '(lambda (x) (and (array-has-fill-pointer-p x) (fill-pointer x))) '(vector) 1) - -(def-type-prop-test row-major-aref 'row-major-aref - (list 'array #'(lambda (a) (let ((s (array-total-size a))) (and (> s 0) `(integer 0 (,s)))))) - 2) - -(def-type-prop-test upgraded-array-element-type 'upgraded-array-element-type - (list #'(lambda () (let ((x (make-random-element-of-type t))) - `(eql ,(make-random-type-containing x))))) - 1) - -(def-type-prop-test simple-vector-p.1 'simple-vector-p '(t) 1) -(def-type-prop-test simple-vector-p.2 'simple-vector-p '(vector) 1) - -(def-type-prop-test svref 'svref (list 'simple-vector (index-type-for-dim 0)) 2) -(def-type-prop-test vector 'vector nil 1 :rest-type t :maxargs 10) -(def-type-prop-test vectorp.1 'vectorp '(t) 1) -(def-type-prop-test vectorp.2 'vectorp '(array) 1) - -(def-type-prop-test bit.1 'bit (list '(array bit (*)) (index-type-for-dim 0)) 2) -(def-type-prop-test bit.2 'bit (list '(array bit (* *)) (index-type-for-dim 0) (index-type-for-dim 1)) 3) -(def-type-prop-test bit.3 'bit - (list '(array bit (* * *)) (index-type-for-dim 0) (index-type-for-dim 1) (index-type-for-dim 2)) - 4) - -(def-type-prop-test sbit.1 'sbit (list '(simple-array bit (*)) (index-type-for-dim 0)) 2) -(def-type-prop-test sbit.2 'sbit (list '(simple-array bit (* *)) (index-type-for-dim 0) (index-type-for-dim 1)) 3) -(def-type-prop-test sbit.3 'sbit - (list '(simple-array bit (* * *)) (index-type-for-dim 0) (index-type-for-dim 1) (index-type-for-dim 2)) - 4) - - -(def-type-prop-test bit-and.1 'bit-and (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) - `(array bit ,dims)))) - 2) -(def-type-prop-test bit-and.2 'bit-and - (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) - 3) -(def-type-prop-test bit-andc1.1 'bit-andc1 (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) - `(array bit ,dims)))) - 2) -(def-type-prop-test bit-andc1.2 'bit-andc1 - (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) - 3) -(def-type-prop-test bit-andc2.1 'bit-andc2 (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) - `(array bit ,dims)))) - 2) -(def-type-prop-test bit-andc2.2 'bit-andc2 - (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) - 3) -(def-type-prop-test bit-ior.1 'bit-ior (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) - `(array bit ,dims)))) - 2) -(def-type-prop-test bit-ior.2 'bit-ior - (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) - 3) -(def-type-prop-test bit-orc1.1 'bit-orc1 (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) - `(array bit ,dims)))) - 2) -(def-type-prop-test bit-orc1.2 'bit-orc1 - (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) - 3) -(def-type-prop-test bit-orc2.1 'bit-orc2 (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) - `(array bit ,dims)))) - 2) -(def-type-prop-test bit-orc2.2 'bit-orc2 - (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) - 3) -(def-type-prop-test bit-eqv.1 'bit-eqv (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) - `(array bit ,dims)))) - 2) -(def-type-prop-test bit-eqv.2 'bit-eqv - (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) - 3) -(def-type-prop-test bit-xor.1 'bit-xor (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) - `(array bit ,dims)))) - 2) -(def-type-prop-test bit-xor.2 'bit-xor - (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) - 3) -(def-type-prop-test bit-nand.1 'bit-nand (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) - `(array bit ,dims)))) - 2) -(def-type-prop-test bit-nand.2 'bit-nand - (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) - 3) -(def-type-prop-test bit-nor.1 'bit-nor (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) - `(array bit ,dims)))) - 2) -(def-type-prop-test bit-nor.2 'bit-nor - (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) - 3) -(def-type-prop-test bit-not.1 'bit-not '((array bit)) 1) -(def-type-prop-test bit-not.2 'bit-not '((array bit) null) 2) - -(def-type-prop-test bit-vector-p 'bit-vector-p '(t) 1) -(def-type-prop-test simple-bit-vector-p 'simple-bit-vector-p '(t) 1) diff --git a/t/ansi-test/random/random-type-prop-tests-07.lsp b/t/ansi-test/random/random-type-prop-tests-07.lsp deleted file mode 100644 index efe6f59..0000000 --- a/t/ansi-test/random/random-type-prop-tests-07.lsp +++ /dev/null @@ -1,121 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Mar 13 17:03:52 2005 -;;;; Contains: Random type prop tests, part 7 (strings) - -(in-package :cl-test) - -(def-type-prop-test simple-string-p 'simple-string-p '(t) 1) -(def-type-prop-test char 'char (list 'string (index-type-for-dim 0)) 2) -(def-type-prop-test schar 'schar (list 'simple-string (index-type-for-dim 0)) 2) - -(def-type-prop-test string 'string '((or string symbol character)) 1) -(def-type-prop-test string-upcase 'string-upcase '(string) 1) -(def-type-prop-test string-downcase 'string-downcase '(string) 1) -(def-type-prop-test string-capitalize 'string-capitalize '(string) 1) - -(def-type-prop-test string-trim.1 'string-trim '(string string) 2) -(def-type-prop-test string-trim.2 'string-trim (list #'(lambda () (make-list-type (random 10) 'null 'character)) - 'string) - 2) -(def-type-prop-test string-left-trim.1 'string-left-trim '(string string) 2) -(def-type-prop-test string-left-trim.2 'string-left-trim (list #'(lambda () (make-list-type (random 10) 'null 'character)) - 'string) - 2) -(def-type-prop-test string-right-trim.1 'string-right-trim '(string string) 2) -(def-type-prop-test string-right-trim.2 'string-right-trim - (list #'(lambda () (make-list-type (random 10) 'null 'character)) 'string) - 2) - -(defmacro def-string-comparison-type-prop-test (op) - (flet ((%makename (n) (intern (format nil "~A.~A" op n) :cl-test))) - `(progn - (def-type-prop-test ,(%makename 1) ',op '(string string) 2) - (def-type-prop-test ,(%makename 2) ',op - `(string string (eql :start1) ,#'index-type-for-v1) - 4) - (def-type-prop-test ,(%makename 3) ',op - `(string string (eql :start2) ,#'index-type-for-v2) - 4) - (def-type-prop-test ,(%makename 4) ',op - `(string string (eql :end1) ,#'end-type-for-v1) - 4) - (def-type-prop-test ,(%makename 5) ',op - `(string string (eql :end2) ,#'end-type-for-v2) - 4) - (def-type-prop-test ,(%makename 6) ',op - `(string string - (eql :start1) ,#'index-type-for-v1 - (eql :end1) ,#'end-type-for-v1) - 6) - (def-type-prop-test ,(%makename 7) ',op - `(string string - (eql :start1) ,#'index-type-for-v1 - (eql :end2) ,#'end-type-for-v2) - 6) - (def-type-prop-test ,(%makename 8) ',op - `(string string - (eql :start2) ,#'index-type-for-v2 - (eql :end1) ,#'end-type-for-v1) - 6) - (def-type-prop-test ,(%makename 9) ',op - `(string string - (eql :start2) ,#'index-type-for-v2 - (eql :end2) ,#'end-type-for-v2) - 6) - (def-type-prop-test ,(%makename 10) ',op - `(string string - (eql :start1) ,#'index-type-for-v1 - (eql :start2) ,#'index-type-for-v2 - (eql :end1) ,#'end-type-for-v1) - 8) - (def-type-prop-test ,(%makename 11) ',op - `(string string - (eql :start1) ,#'index-type-for-v1 - (eql :start2) ,#'index-type-for-v2 - (eql :end2) ,#'end-type-for-v2) - 8) - (def-type-prop-test ,(%makename 12) ',op - `(string string - (eql :start1) ,#'index-type-for-v1 - (eql :end2) ,#'end-type-for-v2 - (eql :end1) ,#'end-type-for-v1) - 8) - (def-type-prop-test ,(%makename 13) ',op - `(string string - (eql :start2) ,#'index-type-for-v2 - (eql :end2) ,#'end-type-for-v2 - (eql :end1) ,#'end-type-for-v1) - 8) - (def-type-prop-test ,(%makename 14) ',op - `(string string - (eql :start1) ,#'index-type-for-v1 - (eql :start2) ,#'index-type-for-v2 - (eql :end2) ,#'end-type-for-v2 - (eql :end1) ,#'end-type-for-v1) - 10) - ))) - -(def-string-comparison-type-prop-test string=) -(def-string-comparison-type-prop-test string/=) -(def-string-comparison-type-prop-test string<) -(def-string-comparison-type-prop-test string<=) -(def-string-comparison-type-prop-test string>) -(def-string-comparison-type-prop-test string>=) - -(def-string-comparison-type-prop-test string-equal) -(def-string-comparison-type-prop-test string-not-equal) -(def-string-comparison-type-prop-test string-lessp) -(def-string-comparison-type-prop-test string-greaterp) -(def-string-comparison-type-prop-test string-not-lessp) -(def-string-comparison-type-prop-test string-not-greaterp) - -(def-type-prop-test stringp 'stringp '(t) 1) - -(def-type-prop-test make-string.1 'make-string '((integer 0 100) (eql :initial-element) character) 3) -(def-type-prop-test make-string.2 'make-string `((integer 0 100) (eql :initial-element) character - (eql :element-type) - ,#'(lambda (&rest args) - `(eql (and character - ,(make-random-type-containing (third args)))))) - 5) diff --git a/t/ansi-test/random/random-type-prop-tests-08.lsp b/t/ansi-test/random/random-type-prop-tests-08.lsp deleted file mode 100644 index 9f8c938..0000000 --- a/t/ansi-test/random/random-type-prop-tests-08.lsp +++ /dev/null @@ -1,348 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Mar 13 18:31:57 2005 -;;;; Contains: Random type prop tests, part 8 (sequences) - -(in-package :cl-test) - -(def-type-prop-test copy-seq 'copy-seq '((or vector list)) 1) - -(def-type-prop-test elt 'elt (list '(or vector list) - #'(lambda (x) (let ((len (length x))) - (and (> len 0) `(integer 0 (,len)))))) - 2) - -(defmacro rfill (x y &rest other-args) - `(fill ,y ,x ,@other-args)) - -(def-type-prop-test fill.1 'rfill - (list t #'make-random-sequence-type-containing) - 2 :replicate '(nil t)) - -(def-type-prop-test fill.2 'rfill - (list 'integer #'make-random-sequence-type-containing) - 2 :replicate '(nil t)) - -(def-type-prop-test fill.3 'rfill - (list 'character #'make-random-sequence-type-containing) - 2 :replicate '(nil t)) - -(def-type-prop-test fill.4 'rfill - (list t #'make-random-sequence-type-containing - '(eql :start) - #'(lambda (v s k1) (declare (ignore v k1)) - (let ((len (length s))) - `(integer 0 ,len)))) - 4 :replicate '(nil t nil nil)) - -(def-type-prop-test fill.5 'rfill - (list t #'make-random-sequence-type-containing - '(eql :end) - #'(lambda (v s k1) (declare (ignore v k1)) - (let ((len (length s))) - `(integer 0 ,len)))) - 4 :replicate '(nil t nil nil)) - -(def-type-prop-test fill.6 'rfill - (list t #'make-random-sequence-type-containing - '(eql :start) - #'(lambda (v s k1) (declare (ignore v k1)) - (let ((len (length s))) - `(integer 0 ,len))) - '(eql :end) - #'(lambda (v s k1 start k2) - (declare (ignore v k1 k2)) - (let ((len (length s))) - `(integer ,start ,len)))) - 6 :replicate '(nil t nil nil nil nil)) - -;;; make-sequence tests here - -(def-type-prop-test subseq.1 'subseq - (list 'sequence #'(lambda (s) `(integer 0 ,(length s)))) - 2) - -(def-type-prop-test subseq.2 'subseq - (list 'sequence #'(lambda (s) `(integer 0 ,(length s))) - #'(lambda (s start) `(integer ,start ,(length s)))) - 3) - -;;; map tests here - -(def-type-prop-test map.1 'map - (list '(member list vector) - '(member list #.#'list) - '(or list vector)) - 3) - -(def-type-prop-test map.2 'map - (list '(member list vector) - '(member list #.#'list) - '(or list vector) - '(or list vector)) - 4) - -(def-type-prop-test map.3 'map - (list '(member list vector) - '(member list #.#'list) - '(or list vector) - '(or list vector) - '(or list vector)) - 5) - -(def-type-prop-test map.4 'map - (list '(member list vector (vector (unsigned-byte 32))) - '(member 1+ #.#'1+) - `(or ,@(loop for i from 1 to 31 collect `(vector (unsigned-byte ,i))))) - 3) - -(def-type-prop-test map.5 'map - (list `(member ,@(loop for i from 1 to 32 collect `(vector (unsigned-byte ,i)))) - '(member 1+ #.#'1+) - #'(lambda (type fun) - (declare (ignore fun)) - (let ((i (cadadr type))) - `(or ,@(loop for j from i to 32 collect `(vector (integer 0 ,(- (ash 1 i) 2)))))))) - 3) - - - -;;; map-into tests here - -(def-type-prop-test map-into.1 'map-into - (list '(or list (vector t)) - '(member list #.#'list) - '(or list vector)) - 3 :replicate '(t nil nil)) - -(def-type-prop-test map-into.2 'map-into - (list '(or list (vector t)) - '(member list #.#'list) - '(or list vector) - '(or list vector)) - 4 :replicate '(t nil nil nil)) - -;;; reduce tests here - -(def-type-prop-test count.1 'count '(t sequence) 2) -(def-type-prop-test count.2 'count - (list t #'make-random-sequence-type-containing) - 2) -(def-type-prop-test count.3 'count - (list t #'make-random-sequence-type-containing - '(eql :start) - #'(lambda (x s k1) (declare (ignore x k1)) - `(integer 0 ,(length s)))) - 4) -(def-type-prop-test count.4 'count - (list t #'make-random-sequence-type-containing - '(eql :end) - #'(lambda (x s k1) (declare (ignore x k1)) - `(integer 0 ,(length s)))) - 4) -(def-type-prop-test count.5 'count - (list t #'make-random-sequence-type-containing - '(eql :start) - #'(lambda (x s k1) (declare (ignore x k1)) - `(integer 0 ,(length s))) - '(eql :end) - #'(lambda (x s k1 start k2) (declare (ignore x k1 k2)) - `(integer ,start ,(length s)))) - 6) - -(def-type-prop-test count.6 'count - (list '(or short-float single-float double-float long-float) - #'(lambda (f) `(vector (or ,(typecase f - (short-float 'short-float) - (single-float 'single-float) - (double-float 'double-float) - (long-float 'long-float) - (t 'float)) - (eql ,f))))) - 2) - -(def-type-prop-test count.7 'count '(bit (vector bit)) 2) -(def-type-prop-test count.8 'count '((unsigned-byte 2) (vector (unsigned-byte 2))) 2) -(def-type-prop-test count.9 'count '((unsigned-byte 4) (vector (unsigned-byte 4))) 2) -(def-type-prop-test count.10 'count '((unsigned-byte 8) (vector (unsigned-byte 8))) 2) - - -;;; count-if tests - -(def-type-prop-test count-if.1 'count-if - (list (let ((funs '(numberp rationalp realp floatp complexp - symbolp identity null functionp listp consp - arrayp vectorp simple-vector-p - stringp simple-string-p - bit-vector-p simple-bit-vector-p))) - `(member ,@funs ,@(mapcar #'symbol-function funs))) - '(or list vector)) - 2) - -(def-type-prop-test count-if.2 'count-if - (list (let ((funs '(numberp rationalp realp floatp complexp - symbolp identity null functionp listp consp - arrayp vectorp simple-vector-p - stringp simple-string-p - bit-vector-p simple-bit-vector-p))) - `(member ,@funs ,@(mapcar #'symbol-function funs))) - '(or list vector) - '(eql :key) - (let ((key-funs '(identity not null))) - `(member ,@key-funs ,@(mapcar #'symbol-function key-funs)))) - 4) - - -;;; Put count-if-not tests here - - -(def-type-prop-test length.1 'length '(sequence) 1) - -(def-type-prop-test reverse.1 'reverse '(sequence) 1) -(def-type-prop-test nreverse.1 'nreverse '(sequence) 1 :replicate '(t)) - -(def-type-prop-test sort.1 'sort - `((vector bit) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 - :replicate '(t nil)) - -(def-type-prop-test sort.2 'sort - `((or (vector (unsigned-byte 2)) - (vector (unsigned-byte 3)) - (vector (unsigned-byte 4)) - (vector (unsigned-byte 5)) - (vector (unsigned-byte 6)) - (vector (unsigned-byte 7)) - (vector (unsigned-byte 8))) - (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) - 2 :replicate '(t nil)) - -(def-type-prop-test sort.3 'sort - `((or (vector (unsigned-byte 10)) - (vector (unsigned-byte 13)) - (vector (unsigned-byte 15)) - (vector (unsigned-byte 16))) - (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) - 2 :replicate '(t nil)) - -(def-type-prop-test sort.4 'sort - `((or (vector (unsigned-byte 20)) - (vector (unsigned-byte 24)) - (vector (unsigned-byte 28)) - (vector (unsigned-byte 31)) - (vector (unsigned-byte 32))) - (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) - 2 :replicate '(t nil)) - -(def-type-prop-test sort.5 'sort - `((or (vector (signed-byte 2)) - (vector (signed-byte 3)) - (vector (signed-byte 4)) - (vector (signed-byte 5)) - (vector (signed-byte 6)) - (vector (signed-byte 7)) - (vector (signed-byte 8))) - (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) - 2 :replicate '(t nil)) - -(def-type-prop-test sort.6 'sort - `((or (vector (signed-byte 10)) - (vector (signed-byte 13)) - (vector (signed-byte 15)) - (vector (signed-byte 16))) - (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) - 2 :replicate '(t nil)) - -(def-type-prop-test sort.7 'sort - `((or (vector (signed-byte 20)) - (vector (signed-byte 24)) - (vector (signed-byte 28)) - (vector (signed-byte 31)) - (vector (signed-byte 32))) - (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) - 2 :replicate '(t nil)) - -(def-type-prop-test sort.8 'sort - `((or (vector short-float) - (vector single-float) - (vector double-float) - (vector long-float)) - (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) - 2 :replicate '(t nil)) - -;;; Stable sort - -(def-type-prop-test stable-sort.1 'stable-sort - `((vector bit) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 - :replicate '(t nil)) - -(def-type-prop-test stable-sort.2 'stable-sort - `((or (vector (unsigned-byte 2)) - (vector (unsigned-byte 3)) - (vector (unsigned-byte 4)) - (vector (unsigned-byte 5)) - (vector (unsigned-byte 6)) - (vector (unsigned-byte 7)) - (vector (unsigned-byte 8))) - (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) - 2 :replicate '(t nil)) - -(def-type-prop-test stable-sort.3 'stable-sort - `((or (vector (unsigned-byte 10)) - (vector (unsigned-byte 13)) - (vector (unsigned-byte 15)) - (vector (unsigned-byte 16))) - (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) - 2 :replicate '(t nil)) - -(def-type-prop-test stable-sort.4 'stable-sort - `((or (vector (unsigned-byte 20)) - (vector (unsigned-byte 24)) - (vector (unsigned-byte 28)) - (vector (unsigned-byte 31)) - (vector (unsigned-byte 32))) - (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) - 2 :replicate '(t nil)) - -(def-type-prop-test stable-sort.5 'stable-sort - `((or (vector (signed-byte 2)) - (vector (signed-byte 3)) - (vector (signed-byte 4)) - (vector (signed-byte 5)) - (vector (signed-byte 6)) - (vector (signed-byte 7)) - (vector (signed-byte 8))) - (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) - 2 :replicate '(t nil)) - -(def-type-prop-test stable-sort.6 'stable-sort - `((or (vector (signed-byte 10)) - (vector (signed-byte 13)) - (vector (signed-byte 15)) - (vector (signed-byte 16))) - (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) - 2 :replicate '(t nil)) - -(def-type-prop-test stable-sort.7 'stable-sort - `((or (vector (signed-byte 20)) - (vector (signed-byte 24)) - (vector (signed-byte 28)) - (vector (signed-byte 31)) - (vector (signed-byte 32))) - (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) - 2 :replicate '(t nil)) - -(def-type-prop-test stable-sort.8 'stable-sort - `((or (vector short-float) - (vector single-float) - (vector double-float) - (vector long-float)) - (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) - 2 :replicate '(t nil)) - -(def-type-prop-test stable-sort.9 'stable-sort - `((vector (cons (integer 0 4) (eql nil))) - (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=) - (eql :key) - (member car ,#'car)) - 4 :replicate '(t nil nil nil) - :test #'equalp-and-eql-elements) diff --git a/t/ansi-test/random/random-type-prop-tests-09.lsp b/t/ansi-test/random/random-type-prop-tests-09.lsp deleted file mode 100644 index 46270c3..0000000 --- a/t/ansi-test/random/random-type-prop-tests-09.lsp +++ /dev/null @@ -1,717 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Contains: Random type prop tests, part 9 (sequences) - -(in-package :cl-test) - -;;; FIND - -(def-type-prop-test find.1 'find - (list t #'make-random-sequence-type-containing) - 2) - -(def-type-prop-test find.2 'find - (list 'integer #'make-random-sequence-type-containing) - 2) - -(def-type-prop-test find.3 'find - (list 'character #'make-random-sequence-type-containing) - 2) - -(def-type-prop-test find.4 'find - (list t - #'make-random-sequence-type-containing - '(eql :start) - #'(lambda (v s k1) (declare (ignore v k1)) - (let ((len (length s))) - `(integer 0 ,len)))) - 4) - -(def-type-prop-test find.5 'find - (list t - #'make-random-sequence-type-containing - '(eql :end) - #'(lambda (v s k1) (declare (ignore v k1)) - (let ((len (length s))) - `(integer 0 ,len)))) - 4) - -(def-type-prop-test find.6 'find - (list t #'make-random-sequence-type-containing - '(eql :start) - #'(lambda (v s k1) (declare (ignore v k1)) - (let ((len (length s))) - `(integer 0 ,len))) - '(eql :end) - #'(lambda (v s k1 start k2) - (declare (ignore v k1 k2)) - (let ((len (length s))) - `(integer ,start ,len)))) - 6) - -(def-type-prop-test find.7 'find - (list 'integer #'(lambda (x) (declare (ignore x)) - (make-sequence-type - (random 10) - (random-from-seq #(bit integer float rational real number)))) - '(eql :key) - '(member 1+ #.#'1+ 1- #.#'1- - #.#'-)) - 4) - -(def-type-prop-test find.8 'find - (list 'character - #'(lambda (x) (declare (ignore x)) - (make-sequence-type - (random 10) - (random-from-seq #(character base-char standard-char)))) - '(eql :key) - '(member char-upcase #.#'char-upcase - char-downcase #.#'char-downcase - upper-case-p #.#'upper-case-p - lower-case-p #.#'lower-case-p - both-case-p #.#'both-case-p - char-code #.#'char-code - char-int #.#'char-int - alpha-char-p #.#'alpha-char-p - digit-char-p #.#'digit-char-p - alphanumericp #.#'alphanumericp)) - 4) - -(def-type-prop-test find.9 'find - (list t #'make-random-sequence-type-containing - '(eql :from-end) - '(or null t)) - 4) - -(def-type-prop-test find.10 'find - (list 'real #'(lambda (x) (make-sequence-type - (random 10) - (random-from-seq #(bit integer float rational real)))) - '(eql :from-end) - '(or null t) - '(member :test :test-not) - (list 'member '< #'< '> #'> '<= #'<= '>= #'>= '= #'= '/= #'/= - 'equal #'equal 'eql #'eql)) - 6) - -;;; FIND-IF - -(def-type-prop-test find-if.1 'find-if - (list - (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) - 'sequence) - 2) - -(def-type-prop-test find-if.2 'find-if - (list - (let ((char-predicates - '(alpha-char-p digit-char-p upper-case-p lower-case-p - both-case-p alphanumericp graphic-char-p - standard-char-p))) - (append '(member) char-predicates - (mapcar #'symbol-function char-predicates))) - #'(lambda (x) (declare (ignore x)) - (make-sequence-type (random 10) - '(or standard-char base-char character)))) - 2) - -(def-type-prop-test find-if.3 'find-if - (list - (let ((integer-predicates '(zerop plusp minusp evenp oddp))) - (append '(member) integer-predicates - (mapcar #'symbol-function integer-predicates))) - #'(lambda (x) (declare (ignore x)) - (make-sequence-type (random 10) - `(or bit bit bit bit bit bit bit - ,@(loop for x from 2 to 32 - collect `(unsigned-byte ,x)) - ,@(loop for x from 2 to 32 - collect `(signed-byte ,x)))))) - 2) - -(def-type-prop-test find-if.4 'find-if - (list - (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) - 'sequence - '(eql :start) - #'(lambda (f s k1) (declare (ignore f k1)) - (let ((len (length s))) - `(integer 0 ,len)))) - 4) - -(def-type-prop-test find-if.5 'find-if - (list - (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) - 'sequence - '(eql :end) - #'(lambda (f s k1) (declare (ignore f k1)) - (let ((len (length s))) - `(integer 0 ,len)))) - 4) - -(def-type-prop-test find-if.6 'find-if - (list - (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) - 'sequence - '(eql :start) - #'(lambda (f s k1) (declare (ignore f k1)) - (let ((len (length s))) - `(integer 0 ,len))) - '(eql :end) - #'(lambda (f s k1 start k2) - (declare (ignore f k1 k2)) - (let ((len (length s))) - `(integer ,start ,len)))) - 6) - -(def-type-prop-test find-if.7 'find-if - (list - (let ((integer-predicates '(zerop plusp minusp evenp oddp))) - (append '(member) integer-predicates - (mapcar #'symbol-function integer-predicates))) - #'(lambda (x) (declare (ignore x)) - (make-sequence-type (random 10) - `(or bit bit bit bit bit bit bit - ,@(loop for x from 2 to 32 - collect `(unsigned-byte ,x)) - ,@(loop for x from 2 to 32 - collect `(signed-byte ,x))))) - '(eql :key) - (list 'member '1+ '1- 'identity '- - #'1+ #'1- #'identity #'-)) - 4) - -(def-type-prop-test find-if.8 'find-if - (list - (let ((integer-predicates '(zerop plusp minusp evenp oddp))) - (append '(member) integer-predicates - (mapcar #'symbol-function integer-predicates))) - #'(lambda (x) (declare (ignore x)) - (make-sequence-type (random 10) - `(or bit bit bit bit bit bit bit - ,@(loop for x from 2 to 32 - collect `(unsigned-byte ,x)) - ,@(loop for x from 2 to 32 - collect `(signed-byte ,x))))) - '(eql :from-end) - '(or null t)) - 4) - -(def-type-prop-test find-if.9 'find-if - (list - (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) - 'sequence - '(eql :start) - #'(lambda (f s k1) (declare (ignore f k1)) - (let ((len (length s))) - `(integer 0 ,len))) - '(eql :from-end) - '(or null t)) - 6) - -(def-type-prop-test find-if.10 'find-if - (list - (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) - 'sequence - '(eql :end) - #'(lambda (f s k1) (declare (ignore f k1)) - (let ((len (length s))) - `(integer 0 ,len))) - '(eql :from-end) - '(or null t)) - 6) - -;;; FIND-IF-NOT - -(def-type-prop-test find-if-not.1 'find-if-not - (list - (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) - 'sequence) - 2) - -(def-type-prop-test find-if-not.2 'find-if-not - (list - (let ((char-predicates - '(alpha-char-p digit-char-p upper-case-p lower-case-p - both-case-p alphanumericp graphic-char-p - standard-char-p))) - (append '(member) char-predicates - (mapcar #'symbol-function char-predicates))) - #'(lambda (x) (declare (ignore x)) - (make-sequence-type (random 10) - '(or standard-char base-char character)))) - 2) - -(def-type-prop-test find-if-not.3 'find-if-not - (list - (let ((integer-predicates '(zerop plusp minusp evenp oddp))) - (append '(member) integer-predicates - (mapcar #'symbol-function integer-predicates))) - #'(lambda (x) (declare (ignore x)) - (make-sequence-type (random 10) - `(or bit bit bit bit bit bit bit - ,@(loop for x from 2 to 32 - collect `(unsigned-byte ,x)) - ,@(loop for x from 2 to 32 - collect `(signed-byte ,x)))))) - 2) - -(def-type-prop-test find-if-not.4 'find-if-not - (list - (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) - 'sequence - '(eql :start) - #'(lambda (f s k1) (declare (ignore f k1)) - (let ((len (length s))) - `(integer 0 ,len)))) - 4) - -(def-type-prop-test find-if-not.5 'find-if-not - (list - (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) - 'sequence - '(eql :end) - #'(lambda (f s k1) (declare (ignore f k1)) - (let ((len (length s))) - `(integer 0 ,len)))) - 4) - -(def-type-prop-test find-if-not.6 'find-if-not - (list - (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) - 'sequence - '(eql :start) - #'(lambda (f s k1) (declare (ignore f k1)) - (let ((len (length s))) - `(integer 0 ,len))) - '(eql :end) - #'(lambda (f s k1 start k2) - (declare (ignore f k1 k2)) - (let ((len (length s))) - `(integer ,start ,len)))) - 6) - -(def-type-prop-test find-if-not.7 'find-if-not - (list - (let ((integer-predicates '(zerop plusp minusp evenp oddp))) - (append '(member) integer-predicates - (mapcar #'symbol-function integer-predicates))) - #'(lambda (x) (declare (ignore x)) - (make-sequence-type (random 10) - `(or bit bit bit bit bit bit bit - ,@(loop for x from 2 to 32 - collect `(unsigned-byte ,x)) - ,@(loop for x from 2 to 32 - collect `(signed-byte ,x))))) - '(eql :key) - (list 'member '1+ '1- 'identity '- - #'1+ #'1- #'identity #'-)) - 4) - -(def-type-prop-test find-if-not.8 'find-if-not - (list - (let ((integer-predicates '(zerop plusp minusp evenp oddp))) - (append '(member) integer-predicates - (mapcar #'symbol-function integer-predicates))) - #'(lambda (x) (declare (ignore x)) - (make-sequence-type (random 10) - `(or bit bit bit bit bit bit bit - ,@(loop for x from 2 to 32 - collect `(unsigned-byte ,x)) - ,@(loop for x from 2 to 32 - collect `(signed-byte ,x))))) - '(eql :from-end) - '(or null t)) - 4) - -(def-type-prop-test find-if-not.9 'find-if-not - (list - (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) - 'sequence - '(eql :start) - #'(lambda (f s k1) (declare (ignore f k1)) - (let ((len (length s))) - `(integer 0 ,len))) - '(eql :from-end) - '(or null t)) - 6) - -(def-type-prop-test find-if-not.10 'find-if-not - (list - (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) - 'sequence - '(eql :end) - #'(lambda (f s k1) (declare (ignore f k1)) - (let ((len (length s))) - `(integer 0 ,len))) - '(eql :from-end) - '(or null t)) - 6) - -;;; POSITION - -(def-type-prop-test position.1 'position - (list t #'make-random-sequence-type-containing) - 2) - -(def-type-prop-test position.2 'position - (list 'integer #'make-random-sequence-type-containing) - 2) - -(def-type-prop-test position.3 'position - (list 'character #'make-random-sequence-type-containing) - 2) - -(def-type-prop-test position.4 'position - (list t - #'make-random-sequence-type-containing - '(eql :start) - #'(lambda (v s k1) (declare (ignore v k1)) - (let ((len (length s))) - `(integer 0 ,len)))) - 4) - -(def-type-prop-test position.5 'position - (list t - #'make-random-sequence-type-containing - '(eql :end) - #'(lambda (v s k1) (declare (ignore v k1)) - (let ((len (length s))) - `(integer 0 ,len)))) - 4) - -(def-type-prop-test position.6 'position - (list t #'make-random-sequence-type-containing - '(eql :start) - #'(lambda (v s k1) (declare (ignore v k1)) - (let ((len (length s))) - `(integer 0 ,len))) - '(eql :end) - #'(lambda (v s k1 start k2) - (declare (ignore v k1 k2)) - (let ((len (length s))) - `(integer ,start ,len)))) - 6) - -(def-type-prop-test position.7 'position - (list 'integer #'(lambda (x) (declare (ignore x)) - (make-sequence-type - (random 10) - (random-from-seq #(bit integer float rational real number)))) - '(eql :key) - '(member 1+ #.#'1+ 1- #.#'1- - #.#'-)) - 4) - -(def-type-prop-test position.8 'position - (list 'character - #'(lambda (x) (declare (ignore x)) - (make-sequence-type - (random 10) - (random-from-seq #(character base-char standard-char)))) - '(eql :key) - '(member char-upcase #.#'char-upcase - char-downcase #.#'char-downcase - upper-case-p #.#'upper-case-p - lower-case-p #.#'lower-case-p - both-case-p #.#'both-case-p - char-code #.#'char-code - char-int #.#'char-int - alpha-char-p #.#'alpha-char-p - digit-char-p #.#'digit-char-p - alphanumericp #.#'alphanumericp)) - 4) - -(def-type-prop-test position.9 'position - (list t #'make-random-sequence-type-containing - '(eql :from-end) - '(or null t)) - 4) - -(def-type-prop-test position.10 'position - (list 'real #'(lambda (x) (make-sequence-type - (random 10) - (random-from-seq #(bit integer float rational real)))) - '(eql :from-end) - '(or null t) - '(member :test :test-not) - (list 'member '< #'< '> #'> '<= #'<= '>= #'>= '= #'= '/= #'/= - 'equal #'equal 'eql #'eql)) - 6) - -;;; POSITION-IF - -(def-type-prop-test position-if.1 'position-if - (list - (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) - 'sequence) - 2) - -(def-type-prop-test position-if.2 'position-if - (list - (let ((char-predicates - '(alpha-char-p digit-char-p upper-case-p lower-case-p - both-case-p alphanumericp graphic-char-p - standard-char-p))) - (append '(member) char-predicates - (mapcar #'symbol-function char-predicates))) - #'(lambda (x) (declare (ignore x)) - (make-sequence-type (random 10) - '(or standard-char base-char character)))) - 2) - -(def-type-prop-test position-if.3 'position-if - (list - (let ((integer-predicates '(zerop plusp minusp evenp oddp))) - (append '(member) integer-predicates - (mapcar #'symbol-function integer-predicates))) - #'(lambda (x) (declare (ignore x)) - (make-sequence-type (random 10) - `(or bit bit bit bit bit bit bit - ,@(loop for x from 2 to 32 - collect `(unsigned-byte ,x)) - ,@(loop for x from 2 to 32 - collect `(signed-byte ,x)))))) - 2) - -(def-type-prop-test position-if.4 'position-if - (list - (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) - 'sequence - '(eql :start) - #'(lambda (f s k1) (declare (ignore f k1)) - (let ((len (length s))) - `(integer 0 ,len)))) - 4) - -(def-type-prop-test position-if.5 'position-if - (list - (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) - 'sequence - '(eql :end) - #'(lambda (f s k1) (declare (ignore f k1)) - (let ((len (length s))) - `(integer 0 ,len)))) - 4) - -(def-type-prop-test position-if.6 'position-if - (list - (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) - 'sequence - '(eql :start) - #'(lambda (f s k1) (declare (ignore f k1)) - (let ((len (length s))) - `(integer 0 ,len))) - '(eql :end) - #'(lambda (f s k1 start k2) - (declare (ignore f k1 k2)) - (let ((len (length s))) - `(integer ,start ,len)))) - 6) - -(def-type-prop-test position-if.7 'position-if - (list - (let ((integer-predicates '(zerop plusp minusp evenp oddp))) - (append '(member) integer-predicates - (mapcar #'symbol-function integer-predicates))) - #'(lambda (x) (declare (ignore x)) - (make-sequence-type (random 10) - `(or bit bit bit bit bit bit bit - ,@(loop for x from 2 to 32 - collect `(unsigned-byte ,x)) - ,@(loop for x from 2 to 32 - collect `(signed-byte ,x))))) - '(eql :key) - (list 'member '1+ '1- 'identity '- - #'1+ #'1- #'identity #'-)) - 4) - -(def-type-prop-test position-if.8 'position-if - (list - (let ((integer-predicates '(zerop plusp minusp evenp oddp))) - (append '(member) integer-predicates - (mapcar #'symbol-function integer-predicates))) - #'(lambda (x) (declare (ignore x)) - (make-sequence-type (random 10) - `(or bit bit bit bit bit bit bit - ,@(loop for x from 2 to 32 - collect `(unsigned-byte ,x)) - ,@(loop for x from 2 to 32 - collect `(signed-byte ,x))))) - '(eql :from-end) - '(or null t)) - 4) - -(def-type-prop-test position-if.9 'position-if - (list - (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) - 'sequence - '(eql :start) - #'(lambda (f s k1) (declare (ignore f k1)) - (let ((len (length s))) - `(integer 0 ,len))) - '(eql :from-end) - '(or null t)) - 6) - -(def-type-prop-test position-if.10 'position-if - (list - (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) - 'sequence - '(eql :end) - #'(lambda (f s k1) (declare (ignore f k1)) - (let ((len (length s))) - `(integer 0 ,len))) - '(eql :from-end) - '(or null t)) - 6) - -;;; POSITION-IF-NOT - -(def-type-prop-test position-if-not.1 'position-if-not - (list - (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) - 'sequence) - 2) - -(def-type-prop-test position-if-not.2 'position-if-not - (list - (let ((char-predicates - '(alpha-char-p digit-char-p upper-case-p lower-case-p - both-case-p alphanumericp graphic-char-p - standard-char-p))) - (append '(member) char-predicates - (mapcar #'symbol-function char-predicates))) - #'(lambda (x) (declare (ignore x)) - (make-sequence-type (random 10) - '(or standard-char base-char character)))) - 2) - -(def-type-prop-test position-if-not.3 'position-if-not - (list - (let ((integer-predicates '(zerop plusp minusp evenp oddp))) - (append '(member) integer-predicates - (mapcar #'symbol-function integer-predicates))) - #'(lambda (x) (declare (ignore x)) - (make-sequence-type (random 10) - `(or bit bit bit bit bit bit bit - ,@(loop for x from 2 to 32 - collect `(unsigned-byte ,x)) - ,@(loop for x from 2 to 32 - collect `(signed-byte ,x)))))) - 2) - -(def-type-prop-test position-if-not.4 'position-if-not - (list - (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) - 'sequence - '(eql :start) - #'(lambda (f s k1) (declare (ignore f k1)) - (let ((len (length s))) - `(integer 0 ,len)))) - 4) - -(def-type-prop-test position-if-not.5 'position-if-not - (list - (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) - 'sequence - '(eql :end) - #'(lambda (f s k1) (declare (ignore f k1)) - (let ((len (length s))) - `(integer 0 ,len)))) - 4) - -(def-type-prop-test position-if-not.6 'position-if-not - (list - (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) - 'sequence - '(eql :start) - #'(lambda (f s k1) (declare (ignore f k1)) - (let ((len (length s))) - `(integer 0 ,len))) - '(eql :end) - #'(lambda (f s k1 start k2) - (declare (ignore f k1 k2)) - (let ((len (length s))) - `(integer ,start ,len)))) - 6) - -(def-type-prop-test position-if-not.7 'position-if-not - (list - (let ((integer-predicates '(zerop plusp minusp evenp oddp))) - (append '(member) integer-predicates - (mapcar #'symbol-function integer-predicates))) - #'(lambda (x) (declare (ignore x)) - (make-sequence-type (random 10) - `(or bit bit bit bit bit bit bit - ,@(loop for x from 2 to 32 - collect `(unsigned-byte ,x)) - ,@(loop for x from 2 to 32 - collect `(signed-byte ,x))))) - '(eql :key) - (list 'member '1+ '1- 'identity '- - #'1+ #'1- #'identity #'-)) - 4) - -(def-type-prop-test position-if-not.8 'position-if-not - (list - (let ((integer-predicates '(zerop plusp minusp evenp oddp))) - (append '(member) integer-predicates - (mapcar #'symbol-function integer-predicates))) - #'(lambda (x) (declare (ignore x)) - (make-sequence-type (random 10) - `(or bit bit bit bit bit bit bit - ,@(loop for x from 2 to 32 - collect `(unsigned-byte ,x)) - ,@(loop for x from 2 to 32 - collect `(signed-byte ,x))))) - '(eql :from-end) - '(or null t)) - 4) - -(def-type-prop-test position-if-not.9 'position-if-not - (list - (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) - 'sequence - '(eql :start) - #'(lambda (f s k1) (declare (ignore f k1)) - (let ((len (length s))) - `(integer 0 ,len))) - '(eql :from-end) - '(or null t)) - 6) - -(def-type-prop-test position-if-not.10 'position-if-not - (list - (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) - 'sequence - '(eql :end) - #'(lambda (f s k1) (declare (ignore f k1)) - (let ((len (length s))) - `(integer 0 ,len))) - '(eql :from-end) - '(or null t)) - 6) diff --git a/t/ansi-test/random/random-type-prop-tests-10.lsp b/t/ansi-test/random/random-type-prop-tests-10.lsp deleted file mode 100644 index 71d2347..0000000 --- a/t/ansi-test/random/random-type-prop-tests-10.lsp +++ /dev/null @@ -1,114 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Contains: Random type prop tests, part 10 (sequences, cont.) - -(in-package :cl-test) - -;;; SEARCH - -(def-type-prop-test search.1 'search - (list 'sequence 'sequence) - 2) - -(def-type-prop-test search.2 'search - (list 'bit-vector 'bit-vector) - 2) - -(def-type-prop-test search.3 'search - (list '(vector * 1) 'sequence) - 2) - -(def-type-prop-test search.4 'search - (list '(vector * 2) 'sequence '(eql :from-end) '(or null t)) - 4) - -(def-type-prop-test search.5 'search - (list 'sequence 'sequence '(eql :key) - (list 'member 'identity nil #'identity 'not #'not)) - 4) - -(def-type-prop-test search.6 'search - (list #'(lambda () (make-sequence-type - (random 10) - (let ((i1 (make-random-integer)) - (i2 (make-random-integer))) - `(integer ,(min i1 i2) ,(max i1 i2))))) - #'(lambda (s) - (declare (ignore s)) - (make-sequence-type - (random 10) - (let ((i1 (make-random-integer)) - (i2 (make-random-integer))) - `(integer ,(min i1 i2) ,(max i1 i2)))))) - 2) - -(def-type-prop-test search.7 'search - (list #'(lambda () (make-sequence-type - (random 10) - (let ((i1 (make-random-integer)) - (i2 (make-random-integer))) - `(integer ,(min i1 i2) ,(max i1 i2))))) - #'(lambda (s) - (declare (ignore s)) - (make-sequence-type - (random 10) - (let ((i1 (make-random-integer)) - (i2 (make-random-integer))) - `(integer ,(min i1 i2) ,(max i1 i2))))) - '(eql :test) - (list 'member 'eql #'eql 'equal #'equal '= #'= - '/= #'/= #'(lambda (x y) (= (logand x 1) (logand y 1))))) - 4) - -(def-type-prop-test search.8 'search - (labels ((%random-char-type () (random-from-seq #(base-char standard-char character))) - (%random-char-sequence-type (&rest ignored) - (declare (ignore ignored)) - (make-sequence-type (random 10) (%random-char-type)))) - - (list #'%random-char-sequence-type - #'%random-char-sequence-type - '(member :test :test-not) - (let ((char-compare-funs - '(char= char/= char< char> char<= char>= - char-equal char-not-equal char-lessp char-greaterp - char-not-lessp char-not-greaterp))) - `(member ,@char-compare-funs - ,@(mapcar #'symbol-function char-compare-funs))))) - 4) - -(def-type-prop-test search.9 'search - (list 'sequence 'sequence - '(eql :start1) - #'(lambda (s1 s2 k) - (declare (ignore s2 k)) - (let ((len (length s1))) - `(integer 0 ,len)))) - 4) - -(def-type-prop-test search.10 'search - (list 'sequence 'sequence - '(eql :end1) - #'(lambda (s1 s2 k) - (declare (ignore s2 k)) - (let ((len (length s1))) - `(integer 0 ,len)))) - 4) - -(def-type-prop-test search.11 'search - (list 'sequence 'sequence - '(eql :start2) - #'(lambda (s1 s2 k) - (declare (ignore s1 k)) - (let ((len (length s2))) - `(integer 0 ,len)))) - 4) - -(def-type-prop-test search.12 'search - (list 'sequence 'sequence - '(eql :end2) - #'(lambda (s1 s2 k) - (declare (ignore s1 k)) - (let ((len (length s2))) - `(integer 0 ,len)))) - 4) diff --git a/t/ansi-test/random/random-type-prop-tests-structs.lsp b/t/ansi-test/random/random-type-prop-tests-structs.lsp deleted file mode 100644 index 9a4423a..0000000 --- a/t/ansi-test/random/random-type-prop-tests-structs.lsp +++ /dev/null @@ -1,72 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Contains: Random type prop tests: structures - -(in-package :cl-test) - -(defstruct rtpt-1 a b) - -(defmethod make-random-element-of-type ((type (eql 'rtpt-1))) - (make-rtpt-1 :a (make-random-element-of-type t) - :b (make-random-element-of-type t))) - -(defmethod replicate ((obj rtpt-1)) - (or (gethash obj *replicate-table*) - (let ((x (make-rtpt-1))) - (setf (gethash obj *replicate-table*) x) - (setf (rtpt-1-a x) (replicate (rtpt-1-a obj))) - (setf (rtpt-1-b x) (replicate (rtpt-1-b obj))) - x))) - -(defmethods make-random-type-containing* - (1 ((val rtpt-1)) 'rtpt-1)) - -(def-type-prop-test structure-ref.1 'rtpt-1-a '(rtpt-1) 1) - -(def-type-prop-test copy-structure.1 'copy-structure '(rtpt-1) 1 - :test #'equalp) - - -(defstruct rtpt-2 a) -(defstruct (rtpt-2.1 (:include rtpt-2)) c d) -(defstruct (rtpt-2.2 (:include rtpt-2)) d e) - -(defmethod make-random-element-of-type ((type (eql 'rtpt-2))) - (rcase - (1 (make-rtpt-2 :a (make-random-element-of-type t))) - (1 (make-random-element-of-type 'rtpt-2.1)) - (1 (make-random-element-of-type 'rtpt-2.2)))) - -(defmethod make-random-element-of-type ((type (eql 'rtpt-2.1))) - (make-rtpt-2.1 :a (make-random-element-of-type t) - :c (make-random-element-of-type t) - :d (make-random-element-of-type t))) - -(defmethod make-random-element-of-type ((type (eql 'rtpt-2.2))) - (make-rtpt-2.2 :a (make-random-element-of-type t) - :d (make-random-element-of-type t) - :e (make-random-element-of-type t))) - -(defmethod replicate ((obj rtpt-2)) - (replicate-with (obj x (make-rtpt-2)) - (setf (rtpt-2-a x) (replicate (rtpt-2-a obj))))) - -(defmethod replicate ((obj rtpt-2.1)) - (replicate-with (obj x (make-rtpt-2.1)) - (setf (rtpt-2.1-a x) (replicate (rtpt-2.1-a obj))) - (setf (rtpt-2.1-c x) (replicate (rtpt-2.1-c obj))) - (setf (rtpt-2.1-d x) (replicate (rtpt-2.1-d obj))))) - -(defmethod replicate ((obj rtpt-2.2)) - (replicate-with (obj x (make-rtpt-2.2)) - (setf (rtpt-2.2-a x) (replicate (rtpt-2.2-a obj))) - (setf (rtpt-2.2-d x) (replicate (rtpt-2.2-d obj))) - (setf (rtpt-2.2-e x) (replicate (rtpt-2.2-e obj))))) - -(defmethods make-random-type-containing* - (1 ((val rtpt-2)) 'rtpt-2) - (1 ((val rtpt-2.1)) 'rtpt-2.1) - (1 ((val rtpt-2.2)) 'rtpt-2.2)) - -(def-type-prop-test structure-ref.2 'rtpt-2-a '(rtpt-2) 1) - diff --git a/t/ansi-test/random/random-type-prop-tests.lsp b/t/ansi-test/random/random-type-prop-tests.lsp deleted file mode 100644 index 6f86d1c..0000000 --- a/t/ansi-test/random/random-type-prop-tests.lsp +++ /dev/null @@ -1,22 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Feb 20 11:50:26 2005 -;;;; Contains: Randomized tests of type propagation during compilation - -(compile-and-load "random-type-prop.lsp") - -(in-package :cl-test) - -(load "random-type-prop-tests-01.lsp") -(load "random-type-prop-tests-02.lsp") -(load "random-type-prop-tests-03.lsp") -(load "random-type-prop-tests-04.lsp") -(load "random-type-prop-tests-05.lsp") -(load "random-type-prop-tests-06.lsp") -(load "random-type-prop-tests-07.lsp") -(load "random-type-prop-tests-08.lsp") -(load "random-type-prop-tests-09.lsp") -(load "random-type-prop-tests-10.lsp") - -(load "random-type-prop-tests-structs.lsp") - diff --git a/t/ansi-test/random/random-type-prop.lsp b/t/ansi-test/random/random-type-prop.lsp deleted file mode 100644 index bacb02c..0000000 --- a/t/ansi-test/random/random-type-prop.lsp +++ /dev/null @@ -1,664 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Dec 23 20:39:22 2004 -;;;; Contains: Randomized tests of type propagation in the compiler - -(in-package :cl-test) - -(eval-when (:compile-toplevel :load-toplevel) - (compile-and-load "random-aux.lsp") - (compile-and-load "random-int-form.lsp")) - -(defvar *print-random-type-prop-input* nil) -(defparameter *random-type-prop-result* nil) - -(declaim (special *param-types* *params* *is-var?* *form*)) -(declaim (special *replicate-type*)) - -(defparameter *default-reps* 1000) -(defparameter *default-cell* nil) -(defparameter *default-ignore* 'arithmetic-error) -(defparameter *default-arg-the* t) - -;;; -;;; The random type prop tester takes three required arguments: -;;; -;;; operator A lisp operator (either a symbol or a lambda form) -;;; arg-types A list consisting either of certain kinds of lisp types -;;; (that make-random-element-of-type understands) and/or -;;; functions that yield types. -;;; minargs Minimum number of arguments to be given to the operator. -;;; Must be a positive integer <= maxargs. -;;; -;;; There are also keyword arguments, some with defaults given by special -;;; variables. -;;; -;;; The random type prop tester generates between minargs and maxargs -;;; (maxargs defaults to minargs) random arguments. The type of each -;;; argument is given by the corresponding type in arg-types (or by rest-type, -;;; if there aren't enough elements of arg-types). If the element of arg-types -;;; is a function, the type for the parameter is produced by calling the function -;;; with the previously generated actual parameters as its arguments. -;;; -;;; The list of parameters is stored into the special variable *params*. -;;; -;;; The tester evaluates (operator . arguments), and also builds a lambda -;;; form to be compiled and called on (a subset of) the parameters. The lambda -;;; form is stored in the special variable *form*. -;;; -;;; The macro def-type-prop-test wraps a call to do-random-type-prop-tests -;;; in a deftest form. See random-type-prop-tests.lsp (and subfiles) for examples -;;; of its use testing CL builtin operators. To use it: -;;; -;;; (load "gclload1.lsp") -;;; (compile-and-load "random-int-form.lsp") ;; do this on lisps not supporting recursive compiles -;;; (compile-and-load "random-type-prop.lsp") -;;; (in-package :cl-test) -;;; (load "random-type-prop-tests.lsp") -;;; (let (*catch-errors*) (do-test ')) -;;; or (let (*catch-errors*) (do-tests)) -;;; -;;; Running all the tests may take a while, particularly on lisps with slow compilers. -;;; -;;; -;;; Keyword arguments to do-random-type-prop-tests: -;;; -;;; Argument Default Meaning -;;; -;;; maxargs minargs Maximum number of actual parameters to generate (max 20). -;;; rest-type t Type of arguments beyond those specified in arg-types -;;; reps *default-reps* Number of repetitions to try before stopping. -;;; The default is controlled by a special variable that -;;; is initially 1000. -;;; enclosing-the nil If true, with prob 1/2 randomly generate an enclosing -;;; (THE ...) form around the form invoking the operator. -;;; arg-the *default-arg-the* If true (which is the initial value of the default -;;; special variable), with probability 1/2 randomly generate -;;; a (THE ...) form around each actual parameter. -;;; cell *default-cell* If true (default is NIL), store the result into a rank-0 -;;; array of specialized type. This enables one to test -;;; forms where the result will be unboxed. Otherwise, just -;;; return the values. -;;; ignore *default-ignore* Ignore conditions that are elements of IGNORE. Default is -;;; ARITHMETIC-ERROR. -;;; test rt::equalp-with-case The test function used to compare outputs. It's -;;; also handy to use #'approx= to handle approximate equality -;;; when testing floating point computations, where compiled code -;;; may have different roundoff errors. -;;; replicate nil Cause arguments to be copied (preserving sharing in conses -;;; and arrays) before applying the operator. This is used to test -;;; destructive operators. -;;; -;;; - -(defun do-random-type-prop-tests - (operator arg-types minargs - &key - (maxargs minargs) - (rest-type t) - (reps *default-reps*) - (enclosing-the nil) - (arg-the *default-arg-the*) - (cell *default-cell*) - (ignore *default-ignore*) - (test #'regression-test::equalp-with-case) - (replicate nil replicate-p)) - (assert (<= 1 minargs maxargs 20)) -(prog1 - (dotimes (i reps) - again - (handler-bind - #-lispworks ((error #'(lambda (c) (when (typep c ignore) (go again))))) - #+lispworks () - (let* ((param-names - '(p1 p2 p3 p4 p5 p6 p7 p8 p9 p10 - p11 p12 p13 p14 p15 p16 p17 p18 p19 p20)) - (nargs (+ minargs (random (- maxargs minargs -1)))) - (types (subseq - (append arg-types - (make-list (max 0 (- nargs (length arg-types))) - :initial-element rest-type)) - 0 nargs)) - (replicate (if replicate-p replicate - (mapcar (constantly nil) types))) - ; (vals (mapcar #'make-random-element-of-type types)) - (vals (setq *params* - (or (make-random-arguments types) (go again)))) - (vals - (if replicate - (mapcar #'replicate vals) - vals)) - (is-var? (if (consp replicate) - (progn - (assert (= (length replicate) (length vals))) - (loop for x in replicate collect (or x (coin)))) - (loop repeat (length vals) collect (coin)))) - (*is-var?* is-var?) - (params (loop for x in is-var? - for p in param-names - when x collect p)) - (param-types (mapcar #'make-random-type-containing vals replicate)) - (*param-types* param-types) - (type-decls (loop for x in is-var? - for p in param-names - for tp in param-types - when x - collect `(type ,tp ,p))) - (rval (cl:handler-bind - (#+sbcl (sb-ext::compiler-note #'muffle-warning) - (warning #'muffle-warning)) - (let* ((vals (if replicate (mapcar #'replicate vals) vals)) - (eval-form (cons operator (loop for v in vals - collect `(quote ,v))))) - ;; (print eval-form) (terpri) - ;; (dotimes (i 100) (eval eval-form)) - (eval eval-form)))) - (result-type (if (and enclosing-the (integerp rval)) - (make-random-type-containing rval) - t)) - (expr `(,operator ,@(loop for x in is-var? - for v in vals - for r in replicate - for p in param-names - collect (if x - (if (and arg-the (coin)) - (let ((tp (make-random-type-containing v r))) - `(the ,tp ,p)) - p) - (if (or (consp v) - (and (symbolp v) (not (or (keywordp v) - (member v '(nil t)))))) - `(quote ,v) - v))))) - (speed (random 4)) - (space (random 4)) - (safety #-allegro (random 4) - #+allegro (1+ (random 3))) - (debug (random 4)) - (store-into-cell? (and cell (coin))) - (upgraded-result-type (and store-into-cell? - (upgraded-array-element-type `(eql ,rval)))) - (form - (setq *form* - `(lambda (,@(when store-into-cell? '(r)) ,@params) - (declare (optimize (speed ,speed) (safety ,safety) (debug ,debug) (space ,space)) - ,@(when store-into-cell? `((type (simple-array ,upgraded-result-type nil) r))) - ,@ type-decls) - ,(let ((result-form - (if enclosing-the `(the ,result-type ,expr) expr))) - (if store-into-cell? - `(setf (aref r) ,result-form) - result-form))))) - ) - (when *print-random-type-prop-input* - (let ((*print-pretty* t) - (*print-case* :downcase)) - (print (list :form form :vals vals)))) - (finish-output) - (let* ((param-vals (loop for x in is-var? - for v in vals - when x collect v)) - (fn (cl:handler-bind - (#+sbcl (sb-ext::compiler-note #'muffle-warning) - (warning #'muffle-warning)) - (compile nil form))) - (result - (if store-into-cell? - (let ((r (make-array nil :element-type upgraded-result-type))) - (apply fn r param-vals) - (aref r)) - (apply fn param-vals)))) - (setq *random-type-prop-result* - (list :upgraded-result-type upgraded-result-type - :form form - :vals vals - :result result - :rval rval)) - (unless (funcall test result rval) - (return *random-type-prop-result*)))) - ;; #+allegro (excl::gc t) - )))) - -(defun make-random-arguments (types-or-funs) - (let ((vals nil)) - (loop for type-or-fun in types-or-funs - for type = (or (typecase type-or-fun - ((and function (not symbol)) - (apply type-or-fun vals)) - (t type-or-fun)) - (return-from make-random-arguments nil) ;; null type - ) - for val = (make-random-element-of-type type) - do (setf vals (nconc vals (list val)))) - ;; (dolist (v vals) (describe v)) - vals)) - -(defmacro defmethods (name &rest bodies) - `(progn - ,@(mapcar - #'(lambda (body) `(defmethod ,name ,@body)) - bodies))) - -(defgeneric make-random-type-containing* (val) - (:method-combination randomized) - (:documentation "Produce a random type containing VAL. If the special -variable *REPLICATE-TYPE* is true, and the value is mutable, then do not -use the value in MEMBER or EQL type specifiers.")) - -(defun make-random-type-containing (type &optional *replicate-type*) - (declare (special *replicate-type*)) - (make-random-type-containing* type)) - -(defmethods make-random-type-containing* - (4 ((val t)) - (declare (special *replicate-type*)) - (rcase - (1 t) - (1 (if (consp val) 'cons 'atom)) - (1 (if *replicate-type* (make-random-type-containing* val) - `(eql ,val))) - (1 - (if *replicate-type* (make-random-type-containing* val) - (let* ((n1 (random 4)) - (n2 (random 4)) - ;; Replace these calls with (make-random-element-of-type t) - ;; at some point - (l1 (loop repeat n1 collect (random-leaf))) - (l2 (loop repeat n2 collect (random-leaf)))) - `(member ,@l1 ,val ,@l2)))))) - - (1 ((val standard-object)) 'standard-object) - (1 ((val structure-object)) 'structure-object) - (1 ((val class)) 'class) - (1 ((val standard-class)) 'standard-class) - (1 ((val structure-class)) 'structure-class) - (1 ((val number)) 'number) - (1 ((val real)) 'real) - (1 ((val ratio)) 'ratio) - - (1 ((val integer)) - (rcase - (1 'integer) - (1 'signed-byte) - (1 (let* ((n1 (random 4)) - (n2 (random 4)) - (l1 (loop repeat n1 collect (make-random-integer))) - (l2 (loop repeat n2 collect (make-random-integer)))) - `(member ,@l1 ,val ,@l2))) - (1 (let ((lo (abs (make-random-integer)))) - `(integer ,(- val lo)))) - (2 (let ((lo (abs (make-random-integer)))) - `(integer ,(- val lo) *))) - (2 (let ((hi (abs (make-random-integer)))) - `(integer * ,(+ val hi)))) - (4 (let ((lo (abs (make-random-integer))) - (hi (abs (make-random-integer)))) - `(integer ,(- val lo) ,(+ val hi)))) - (1 (if (>= val 0) 'unsigned-byte (throw 'fail nil))))) - - (2 ((val character)) - (rcase - (1 'character) - (1 (if (typep val 'base-char) 'base-char - #-sbcl 'extended-char - #+sbcl (throw 'fail nil) - )) - (1 (if (typep val 'standard-char) 'standard-char (throw 'fail nil))) - (1 (let* ((n1 (random 4)) - (n2 (random 4)) - (l1 (loop repeat n1 collect (make-random-character))) - (l2 (loop repeat n2 collect (make-random-character)))) - `(member ,@l1 ,val ,@l2))))) - - (1 ((val null)) 'null) - - (2 ((val symbol)) - (rcase - (1 'symbol) - (1 (typecase val (boolean 'boolean) (keyword 'keyword) (otherwise (throw 'fail nil)))) - (1 (let* ((n1 (random 4)) - (n2 (random 4)) - (l1 (loop repeat n1 collect (make-random-symbol))) - (l2 (loop repeat n2 collect (make-random-symbol)))) - `(member ,@l1 ,val ,@l2))))) - - (1 ((val rational)) - (rcase - (1 'rational) - (1 (let* ((n1 (random 4)) - (n2 (random 4)) - (l1 (loop repeat n1 collect (make-random-element-of-type 'rational))) - (l2 (loop repeat n2 collect (make-random-element-of-type 'rational)))) - `(member ,@l1 ,val ,@l2))) - (1 `(rational ,val)) - (1 `(rational * ,val)) - (1 (let ((v (make-random-element-of-type 'rational))) - (if (<= v val) - `(rational ,v ,val) - `(rational ,val ,v)))))) - - (1 ((val float)) - (rcase - (1 (let* ((n1 (random 4)) - (n2 (random 4)) - (l1 (loop repeat n1 collect (- 2 (random (float 1.0 val))))) - (l2 (loop repeat n2 collect (- 2 (random (float 1.0 val)))))) - `(member ,@l1 ,val ,@l2))) - (1 (let ((names (float-types-containing val))) - (random-from-seq names))) - (1 (let ((name (random-from-seq (float-types-containing val)))) - (if (>= val 0) - `(,name ,(coerce 0 name) ,val) - `(,name ,val ,(coerce 0 name))))))) - ) - -(defun float-types-containing (val) - (loop for n in '(short-float single-float double-float long-float float) - when (typep val n) - collect n)) - -(defun make-random-array-dimension-spec (array dim-index) - (assert (<= 0 dim-index)) - (assert (< dim-index (array-rank array))) - (let ((dim (array-dimension array dim-index))) - (rcase (1 '*) (1 dim)))) - -;;; More methods -(defmethods make-random-type-containing* - (3 ((val bit-vector)) - (let ((root (if (and (coin) - (typep val 'simple-bit-vector)) - 'simple-bit-vector - 'bit-vector))) - (rcase (1 root) - (1 `(,root)) - (3 `(,root ,(make-random-array-dimension-spec val 0)))))) - - (3 ((val vector)) - (let ((root 'vector) - (alt-root (if (and (coin) (simple-vector-p val)) 'simple-vector 'vector)) - (etype (rcase (1 '*) - (1 (array-element-type val)) - ;; Add rule for creating new element types? - ))) - (rcase (1 alt-root) - (1 `(,alt-root)) - (1 `(,root ,etype)) - (2 (if (and (simple-vector-p val) (coin)) - `(simple-vector ,(make-random-array-dimension-spec val 0)) - `(,root ,etype ,(make-random-array-dimension-spec val 0))))))) - - (3 ((val array)) - (let ((root (if (and (coin) (typep val 'simple-array)) 'simple-array 'array)) - (etype (rcase (1 (array-element-type val)) (1 '*))) - (rank (array-rank val))) - (rcase - (1 root) - (1 `(,root)) - (1 `(,root ,etype)) - (1 `(,root ,etype ,(loop for i below rank collect (make-random-array-dimension-spec val i)))) - (1 `(,root ,etype ,(loop for i below rank collect (array-dimension val i)))) - #-ecl (1 `(,root ,etype ,rank))))) - - (3 ((val string)) - (let ((root (cond - ((and (coin) - (typep val 'base-string)) - (cond - ((and (coin) (typep val 'simple-base-string)) - 'simple-base-string) - (t 'base-string))) - ((and (coin) - (typep val 'simple-string)) - 'simple-string) - (t 'string)))) - (rcase (1 root) - (1 `(,root)) - (3 `(,root ,(make-random-array-dimension-spec val 0)))))) - - (1 ((val list)) 'list) - - (1 ((val cons)) - (rcase - (1 'cons) - (2 `(cons ,(make-random-type-containing* (car val)) - ,(make-random-type-containing* (cdr val)))) - (1 `(cons ,(make-random-type-containing* (car val)) - ,(random-from-seq #(t *)))) - (1 `(cons ,(make-random-type-containing* (car val)))) - (1 `(cons ,(random-from-seq #(t *)) - ,(make-random-type-containing* (cdr val)) - )))) - - (1 ((val complex)) - (rcase - (1 'complex) - #-gcl - (1 (let* ((t1 (type-of (realpart val))) - (t2 (type-of (imagpart val))) - (part-type - (cond - ((subtypep t1 t2) (upgraded-complex-part-type t2)) - ((subtypep t2 t1) (upgraded-complex-part-type t1)) - ((and (subtypep t1 'rational) - (subtypep t2 'rational)) - 'rational) - (t - (upgraded-complex-part-type `(or ,t1 ,t2)))))) - (if (subtypep 'real part-type) - '(complex real) - `(complex ,part-type)))))) - - (1 ((val generic-function)) 'generic-function) - (1 ((val function)) - (rcase - (1 'function) - (1 (if (typep val 'compiled-function) - 'compiled-function - 'function)))) - ) - -;;; Macro for defining random type prop tests - -(defmacro def-type-prop-test (name &body args) - `(deftest ,(intern (concatenate 'string "RANDOM-TYPE-PROP." - (string name)) - (find-package :cl-test)) - (do-random-type-prop-tests ,@args) - nil)) - -;;; Function used in constructing list types for some random type prop tests - -(defun make-list-type (length &optional (rest-type 'null) (element-type t)) - (let ((result rest-type)) - (loop repeat length - do (setq result `(cons ,element-type ,result))) - result)) - -(defun make-sequence-type (length &optional (element-type t)) - (rcase - (1 `(vector ,element-type ,length)) - (1 `(array ,element-type (,length))) - (1 `(simple-array ,element-type (,length))) - (2 (make-list-type length 'null element-type)))) - -(defun make-random-sequence-type-containing (element &optional *replicate-type*) - (make-sequence-type (random 10) (make-random-type-containing* element))) - -(defun same-set-p (set1 set2 &rest args &key key test test-not) - (declare (ignorable key test test-not)) - (and (apply #'subsetp set1 set2 args) - (apply #'subsetp set2 set2 args) - t)) - -(defun index-type-for-dim (dim) - "Returns a function that computes integer type for valid indices - of an array dimension, or NIL if there are none." - #'(lambda (array &rest other) - (declare (ignore other)) - (let ((d (array-dimension array dim))) - (and (> d 0) `(integer 0 (,d)))))) - -(defun index-type-for-v1 (v1 &rest other) - "Computes integer type for valid indices for the first of two vectors" - (declare (ignore other)) - (let ((d (length v1))) `(integer 0 ,d))) - -(defun index-type-for-v2 (v1 v2 &rest other) - "Computes integer type for valid indices for the second of two vectors" - (declare (ignore v1 other)) - (let ((d (length v2))) `(integer 0 ,d))) - -(defun end-type-for-v1 (v1 v2 &rest other) - (declare (ignore v2)) - (let ((d (length v1)) - (start1 (or (cadr (member :start1 other)) 0))) - `(integer ,start1 ,d))) - -(defun end-type-for-v2 (v1 v2 &rest other) - (declare (ignore v1)) - (let ((d (length v2)) - (start2 (or (cadr (member :start2 other)) 0))) - `(integer ,start2 ,d))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defgeneric replicate (obj) - (:documentation "Copies the structure of a lisp object recursively, preserving sharing.")) - -(defmacro replicate-with ((source-obj dest-obj copy-form) &body body) - `(or (gethash ,source-obj *replicate-table*) - (let ((,dest-obj ,copy-form)) - (setf (gethash ,source-obj *replicate-table*) ,dest-obj) - ,@body - ,dest-obj))) - -(declaim (special *replicate-table*)) - -(defmethod replicate :around ((obj t)) - "Wrapper to create a hash table for structure sharing, if none exists." - (if (boundp '*replicate-table*) - (call-next-method obj) - (let ((*replicate-table* (make-hash-table))) - (call-next-method obj)))) - -(defmethod replicate ((obj cons)) - (or (gethash obj *replicate-table*) - (let ((x (cons nil nil))) - (setf (gethash obj *replicate-table*) x) - (setf (car x) (replicate (car obj))) - (setf (cdr x) (replicate (cdr obj))) - x))) - -;;; Default method for objects without internal structure -(defmethod replicate ((obj t)) obj) - -(defmethod replicate ((obj array)) - (multiple-value-bind - (new-obj old-leaf new-leaf) - (replicate-displaced-array obj) - (when new-leaf - (loop for i below (array-total-size new-leaf) - do (setf (row-major-aref new-leaf i) - (row-major-aref old-leaf i)))) - new-obj)) - -(defun replicate-displaced-array (obj) - "Replicate the non-terminal (and not already replicated) arrays - in a displaced array chain. Return the new root array, the - old leaf array, and the new (but empty) leaf array. The latter - two are NIL if the leaf did not have to be copied again." - (or (gethash obj *replicate-table*) - (multiple-value-bind - (displaced-to displaced-index-offset) - (array-displacement obj) - (let ((dims (array-dimensions obj)) - (element-type (array-element-type obj)) - (fill-pointer (and (array-has-fill-pointer-p obj) - (fill-pointer obj))) - (adj (adjustable-array-p obj))) - (if displaced-to - ;; The array is displaced - ;; Copy recursively - (multiple-value-bind - (new-displaced-to old-leaf new-leaf) - (replicate-displaced-array displaced-to) - (let ((new-obj (make-array dims :element-type element-type - :fill-pointer fill-pointer - :adjustable adj - :displaced-to new-displaced-to - :displaced-index-offset displaced-index-offset))) - (setf (gethash obj *replicate-table*) new-obj) - (values new-obj old-leaf new-leaf))) - ;; The array is not displaced - ;; This is the leaf array - (let ((new-obj (make-array dims :element-type element-type - :fill-pointer fill-pointer - :adjustable adj))) - (setf (gethash obj *replicate-table*) new-obj) - (values new-obj obj new-obj))))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(declaim (special *isomorphism-table*)) - -(defun isomorphic-p (obj1 obj2) - (let ((*isomorphism-table* (make-hash-table))) - (isomorphic-p* obj1 obj2))) - -(defgeneric isomorphic-p* (obj1 obj2) - (:documentation - "Returns true iff obj1 and obj2 are 'isomorphic' (that is, have the same structure, - including the same leaf values and the same pattern of sharing). It should be - the case that (isomorphic-p obj (replicate obj)) is true.")) - -(defmethod isomorphic-p* ((obj1 t) (obj2 t)) - (eql obj1 obj2)) - -(defmethod isomorphic-p* ((obj1 cons) (obj2 cons)) - (let ((previous (gethash obj1 *isomorphism-table*))) - (cond - (previous - ;; If we've already produced a mapping from obj1 to something, - ;; isomorphism requires that obj2 be that object - (eq previous obj2)) - ;; Otherwise, assume obj1 will map to obj2 and recurse - (t - (setf (gethash obj1 *isomorphism-table*) obj2) - (and (isomorphic-p* (car obj1) (car obj2)) - (isomorphic-p* (cdr obj1) (cdr obj2))))))) - -(defmethod isomorphic-p* ((obj1 array) (obj2 array)) - (let ((previous (gethash obj1 *isomorphism-table*))) - (cond - (previous - ;; If we've already produced a mapping from obj1 to something, - ;; isomorphism requires that obj2 be that object - (eq previous obj2)) - (t - (setf (gethash obj1 *isomorphism-table*) obj2) - (and (equal (array-dimensions obj1) (array-dimensions obj2)) - (equal (array-element-type obj1) (array-element-type obj2)) - (if (array-has-fill-pointer-p obj1) - (and (array-has-fill-pointer-p obj2) - (eql (fill-pointer obj1) (fill-pointer obj2))) - (not (array-has-fill-pointer-p obj2))) - (let (to-1 (index-1 0) to-2 (index-2 0)) - (multiple-value-setq (to-1 index-1) (array-displacement obj1)) - (multiple-value-setq (to-2 index-2) (array-displacement obj2)) - (if to-1 - (and to-2 - (eql index-1 index-2) - (isomorphic-p* to-1 to-2)) - ;; Not displaced -- recurse on elements - (let ((total-size (array-total-size obj1))) - (loop for i below total-size - always (isomorphic-p* (row-major-aref obj1 i) - (row-major-aref obj2 i))))))))))) - -;;; Test that sequences have identical elements - -(defun equalp-and-eql-elements (s1 s2) - (and (equalp s1 s2) - (every #'eql s1 s2))) diff --git a/t/ansi-test/random/random-types.lsp b/t/ansi-test/random/random-types.lsp deleted file mode 100644 index fa9b061..0000000 --- a/t/ansi-test/random/random-types.lsp +++ /dev/null @@ -1,369 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Oct 6 05:04:45 2003 -;;;; Contains: Generating random types and testing relationships on them - -(in-package :cl-test) - -(compile-and-load "types-aux.lsp") -(compile-and-load "random-aux.lsp") -(compile-and-load "random-int-form.lsp") - -(defparameter *random-types* nil) - -(defun make-random-type (size) - (if (<= size 1) - (rcase - (1 nil) - (1 t) - (1 `(eql ,(let ((r (ash 1 (random 45)))) - (random-from-interval r (- r))))) - (1 (random-from-seq #(integer unsigned-byte ratio rational real float - short-float single-float double-float - long-float complex symbol cons function))) - (1 - (let* ((len (random *maximum-random-int-bits*)) - (r1 (ash 1 len)) - (r2 (+ r1 r1)) - (x (- (random r2) r1)) - (y (- (random r2) r1)) - (lo (min x y)) - (hi (max x y))) - `(integer ,lo ,hi))) - (1 (make-random-real-type)) - ;; (1 (make-random-complex-type)) - ) - (rcase - (2 (let* ((op (random-from-seq #(cons cons and or))) - (nargs (if (eq op 'cons) 2 - (1+ (random (min size 4))))) - (sizes (random-partition (1- size) nargs))) - `(,op ,@(mapcar #'make-random-type sizes)))) - (1 `(not ,(make-random-type (1- size)))) - ; (1 (make-random-function-type size)) - ))) - -(defun make-random-real-type () - (rcase - (1 (random-from-seq '(integer unsigned-byte short-float single-float - double-float long-float rational real))) - (1 (destructuring-bind (lo hi) - (make-random-integer-range) - (rcase - (4 `(integer ,lo ,hi)) - (1 `(integer ,lo)) - (1 `(integer ,lo *)) - (2 `(integer * ,hi))))) - (1 (let ((r1 (random-real)) - (r2 (random-real))) - `(real ,(min r1 r2) ,(max r2 r2)))) - ;;; Add more cases here - )) - -(defun make-random-complex-type () - `(complex ,(make-random-real-type))) - -(defun make-random-function-type (size) - (let* ((sizes (random-partition (1- size) 2)) - (types (mapcar #'make-random-type sizes))) - `(function (,(car types)) ,(cadr types)))) - -(defun size-of-type (type) - (if (consp type) - (case (car type) - (complex (1+ (size-of-type (cadr type)))) - ((array simple-array) (1+ (size-of-type (cadr type)))) - (vector (1+ (size-of-type (cadr type)))) - (complex (1+ (size-of-type (cadr type)))) - ((cons or and not) (reduce #'+ (cdr type) :initial-value 1 - :key #'size-of-type)) - (t 1)) - 1)) - -(defun mutate-type (type) - (let* ((size (size-of-type type)) - (r (random size))) - (flet ((%f () - (rcase - (6 (make-random-type (random (1+ size)))) - (2 `(not ,type)) - (1 `(and ,(make-random-type 1) ,type)) - (1 `(and ,type ,(make-random-type 1))) - (1 `(or ,(make-random-type 1) ,type)) - (1 `(or ,type ,(make-random-type 1))))) - (%random-int () - (let ((bits (1+ (min (random 20) (random 20))))) - (- (ash 1 bits) (random (ash 1 (1+ bits))))))) - (if (or (and (= r 0) (coin)) (not (consp type))) - (%f) - (case (car type) - ((and or not cons complex) - (let ((sizes (mapcar #'size-of-type (cdr type)))) - (loop with sum = 0 - for e on sizes - for ctype in (cdr type) - for i from 0 - do (setf sum (incf (car e) sum)) - when (>= sum r) - return (rcase - (1 ctype) ;; replace with component type - (1 (cons (car type) - (append (subseq (cdr type) 0 i) - (list (mutate-type ctype)) - (subseq (cdr type) (1+ i))))))))) - ((array simple-array vector) - (let ((ctype (if (cdr type) (cadr type) t))) - (rcase - (1 (if (eql ctype *) t ctype)) - (1 (cons (car type) - (cons (mutate-type ctype) - (cddr type))))))) - ((unsigned-byte) - (if (integerp (cadr type)) - (rcase - (1 'unsigned-byte) - (1 `(unsigned-byte (+ (cadr type) (- 10 (random 20)))))) - (%f))) - - ((integer) - (let ((lo-delta (%random-int)) - (hi-delta (%random-int)) - (old-lo (or (cadr type) '*)) - (old-hi (or (caddr type) '*))) - (flet ((%inc (old delta) - (if (or (coin) (not (integerp old))) - delta - (+ old delta)))) - (rcase - (1 `(integer ,old-lo *)) - (1 `(integer * ,old-hi)) - (1 (let ((new-lo (%inc old-lo lo-delta))) - (if (or (null (cdr type)) - (null (cddr type)) - (not (integerp old-hi))) - `(integer ,new-lo ,@(cddr type)) - ;; caddr is integer - (if (<= new-lo old-hi) - `(integer ,new-lo ,old-hi) - `(integer ,old-hi ,new-lo))))) - (1 (let ((new-hi (%inc old-hi hi-delta))) - (if (or (null (cdr type)) - (null (cddr type)) - (not (integerp old-lo))) - `(integer ,old-lo ,new-hi) - (if (<= old-lo new-hi) - `(integer ,old-lo ,new-hi) - `(integer ,new-hi ,old-lo))))) - (1 (let ((new-lo (%inc old-lo lo-delta)) - (new-hi (%inc old-hi hi-delta))) - (if (<= new-lo new-hi) - `(integer ,new-lo ,new-hi) - `(integer ,new-hi ,new-lo)))))))) - - (t (%f))))))) - -(defun test-random-types (n size) - (loop for t1 = (make-random-type size) - for t2 = (make-random-type size) - for i from 0 below n - ;; do (print (list t1 t2)) - do (setf *random-types* (list t1 t2)) - do (when (and (= (mod i 100) 0) (> i 0)) - (format t "~A " i) (finish-output *standard-output*)) - when (test-types t1 t2) - collect (list t1 t2) - finally (terpri))) - -(defun test-random-mutated-types (n size &key (reps 1)) - (loop for t1 = (make-random-type size) - for t2 = (let ((x t1)) (loop repeat reps - do (setq x (mutate-type x))) x) - for i from 0 below n - ;; do (print (list t1 t2)) - do (setf *random-types* (list t1 t2)) - do (when (and (= (mod i 100) 0) (> i 0)) - (format t "~A " i) (finish-output *standard-output*)) - when (test-types t1 t2) - collect (list t1 t2) - finally (terpri))) - -(defun test-types (t1 t2) - (multiple-value-bind (sub success) - (subtypep t1 t2) - (when success - (if sub - (check-all-subtypep t1 t2) - (let ((nt1 `(not ,t1)) - (nt2 `(not ,t2))) - (subtypep nt2 nt1)))))) - -(defun prune-type (tp try-fn) - (declare (type function try-fn)) - (flet ((try (x) (funcall try-fn x))) - (cond - ((member tp '(nil t))) - ((symbolp tp) - (try nil) - (try t)) - ((consp tp) - (try nil) - (try t) - (let ((op (first tp)) - (args (rest tp))) - (case op - ((cons) - (try 'cons) - (prune-list args - #'prune-type - #'(lambda (args) (try `(cons ,@args))))) - ((integer) - (try op) - (try '(eql 0)) - (when (= (length args) 2) - (let ((arg1 (first args)) - (arg2 (second args))) - (when (and (integerp arg1) (integerp arg2)) - (try `(eql ,arg1)) - (try `(eql ,arg2)) - (when (and (< arg1 0) (<= 0 arg2)) - (try `(integer 0 ,arg2))) - (when (and (<= arg1 0) (< 0 arg2)) - (try `(integer ,arg1 0))) - (when (> (- arg2 arg1) 1) - (try `(integer ,(+ arg1 (floor (- arg2 arg1) 2)) ,arg2)) - (try `(integer ,arg1 ,(- arg2 (floor (- arg2 arg1) 2))))))))) - - ((real float ratio single-float double-float short-float long-float) - (try op)) - - ((or and) - (mapc try-fn args) - (loop for i from 0 below (length args) - do (try `(,op ,@(subseq args 0 i) - ,@(subseq args (1+ i))))) - (prune-list args - #'prune-type - #'(lambda (args) (try (cons op args))))) - ((not) - (let ((arg (first args))) - (try arg) - (when (and (consp arg) - (eq (car arg) 'not)) - (try (second arg))) - (prune-type arg #'(lambda (arg) (try `(not ,arg)))))) - - ((member) - (dolist (arg (cdr tp)) - (try `(eql ,arg))) - (when (cddr tp) - (try `(member ,@(cddr tp))))) - - ((eql) - (assert (= (length args) 1)) - (let ((arg (first args))) - (unless (= arg 0) - (try `(eql 0)) - (cond - ((< arg -1) - (try `(eql ,(ceiling arg 2)))) - ((> arg 1) - (try `(eql ,(floor arg 2)))))))) - - ))))) - (values)) - -(defun prune-type-pair (pair &optional (fn #'test-types)) - (declare (type function fn)) - (let ((t1 (first pair)) - (t2 (second pair)) - changed) - (loop - do (flet ((%try2 (new-tp) - (when (funcall fn t1 new-tp) - (print "Success in first loop") - (print new-tp) - (setq t2 new-tp - changed t) - (throw 'success nil)))) - (catch 'success - (prune-type t2 #'%try2))) - do (flet ((%try1 (new-tp) - (when (funcall fn new-tp t2) - (print "Success in second loop") - (print new-tp) - (setq t1 new-tp - changed t) - (throw 'success nil)))) - (catch 'success - (prune-type t1 #'%try1))) - while changed - do (setq changed nil)) - (list t1 t2))) - -(defun test-type-triple (t1 t2 t3) - ;; Returns non-nil if a problem is found - (catch 'problem - (multiple-value-bind (sub1 success1) - (subtypep t1 t2) - (when success1 - (if sub1 - (append - (check-all-subtypep t1 `(or ,t2 ,t3)) - (check-all-subtypep `(and ,t1 ,t3) t2)) - (or (subtypep `(or ,t1 ,t3) t2) - (subtypep t1 `(and ,t2 ,t3)))))))) - -(defun test-random-types3 (n size) - (loop for t1 = (make-random-type (1+ (random size))) - for t2 = (make-random-type (1+ (random size))) - for t3 = (make-random-type (1+ (random size))) - for i from 1 to n - ;; do (print (list t1 t2)) - do (setf *random-types* (list t1 t2 t3)) - do (when (and (= (mod i 100) 0) (> i 0)) - (format t "~A " i) (finish-output *standard-output*)) - when (test-type-triple t1 t2 t3) - collect (list t1 t2 t3) - finally (terpri))) - -(defun prune-type-triple (pair &optional (fn #'test-type-triple)) - (declare (type function fn)) - (let ((t1 (first pair)) - (t2 (second pair)) - (t3 (third pair)) - changed) - (loop - do (flet ((%try2 (new-tp) - (when (funcall fn t1 new-tp t3) - (print "Success in first loop") - (print new-tp) - (setq t2 new-tp - changed t) - (throw 'success nil)))) - (catch 'success - (prune-type t2 #'%try2))) - do (flet ((%try1 (new-tp) - (when (funcall fn new-tp t2 t3) - (print "Success in second loop") - (print new-tp) - (setq t1 new-tp - changed t) - (throw 'success nil)))) - (catch 'success - (prune-type t1 #'%try1))) - do (flet ((%try3 (new-tp) - (when (funcall fn t1 t2 new-tp) - (print "Success in second loop") - (print new-tp) - (setq t3 new-tp - changed t) - (throw 'success nil)))) - (catch 'success - (prune-type t3 #'%try3))) - while changed - do (setq changed nil)) - (list t1 t2 t3))) - - - - diff --git a/t/ansi-test/rctest/README b/t/ansi-test/rctest/README deleted file mode 100644 index 975ec76..0000000 --- a/t/ansi-test/rctest/README +++ /dev/null @@ -1,3 +0,0 @@ -This directory contains (or will contain) a program for generating -random Lisp code. The intent is to generate random input cases to -test for compile and/or eval bugs. diff --git a/t/ansi-test/rctest/form-generators.lsp b/t/ansi-test/rctest/form-generators.lsp deleted file mode 100644 index 10e3185..0000000 --- a/t/ansi-test/rctest/form-generators.lsp +++ /dev/null @@ -1,31 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Jun 21 10:56:09 2003 -;;;; Contains: Generators for forms - -(in-package :rctest) - -(defclass form-generator (composite-generator) ()) - -(defparameter *form-generator* (make-instance 'composite-generator)) - -(defclass implicit-progn-generator (random-iterative-generator) - ((subgenerator :initform *form-generator*))) - -(defgenerator var-form-generator - :keys (vars) - :body (random-from-seq vars)) - -(defgenerator int-form-generator - :body (random-case - 0 - (random-from-seq - #.(apply #'vector (loop for i from 0 to 31 collect (ash 1 i)))) - (random-from-seq - #.(apply #'vector (loop for i from 0 to 31 collect (- (ash 1 i))))) - (random-from-seq - #.(make-array 128 :initial-contents - (loop for i from 0 to 31 - for x = (ash 1 i) - nconc (list (1- x) (1+ x) (- 1 x) (- -1 x))))) - (random 1000))) diff --git a/t/ansi-test/rctest/generator.lsp b/t/ansi-test/rctest/generator.lsp deleted file mode 100644 index 79d0522..0000000 --- a/t/ansi-test/rctest/generator.lsp +++ /dev/null @@ -1,109 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Jun 6 18:15:50 2003 -;;;; Contains: Generator class and associated generic function definitions - -(in-package :rctest) - -(compile-and-load "rctest-util.lsp") - -(defvar *prototype-class-table* (make-hash-table) - "Contains a map from names of classes to prototype instances - for those classes.") - -(defgeneric prototype (class) - ;; Map a class to a prototype instance of the class. Cache using - ;; *prototype-class-table*. - (:method ((class standard-class) &aux (name (class-name class))) - (or (gethash name *prototype-class-table*) - (setf (gethash name *prototype-class-table*) - (make-instance class)))) - (:method ((class symbol)) - (prototype (find-class class)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Generators are objects that are used to create random instances. - -(defclass generator () ()) - -(defclass composite-generator (generator) - ((subgenerators :type array :initform (make-array '(10) - :adjustable t - :fill-pointer 0)) - (cumulative-weights :type array - :initform (make-array '(10) - :fill-pointer 0 - :adjustable t - :element-type 'single-float - :initial-element 0.0f0)) - )) - -(defclass simple-generator (generator) ()) - -(defgeneric generate (gen size &rest ctxt &key &allow-other-keys) - (:method - ((gen composite-generator) (size real) &rest ctxt) - (let* ((subgens (slot-value gen 'subgenerators)) - (n (fill-pointer subgens))) - (when (<= n 0) (return-from generate (values nil nil))) - (let* ((cum-weights (slot-value gen 'cumulative-weights)) - (total-weight (aref cum-weights (1- n))) - (random-weight (random total-weight)) - ;; Replace POSITION call with a binary search if necessary - (index (position random-weight cum-weights :test #'>=))) - (loop for i from 1 to 10 - do (multiple-value-bind (val success?) - (apply #'generate (aref subgens index) size ctxt) - (when success? (return (values val t)))) - finally (return (values nil nil)))))) - ) - -(defmethod generate ((gen symbol) size &rest ctxt &key &allow-other-keys) - (apply #'generate (prototype gen) size ctxt)) - -(defgeneric add-subgenerator (gen subgen weight) - (:method - ((gen composite-generator) (subgen generator) weight) - (let* ((subgens (slot-value gen 'subgenerators)) - (n (fill-pointer subgens)) - (cum-weights (slot-value gen 'cumulative-weights)) - (total-weight (if (> n 0) (aref cum-weights (1- n)) 0.0f0))) - (vector-push-extend gen subgens n) - (vector-push-extend (+ total-weight weight) cum-weights n) - (values)))) - -(defclass iterative-generator (generator) - ((subgenerator :initarg :sub))) - -(defclass random-iterative-generator (iterative-generator) ()) - -(defmethod generate ((gen random-iterative-generator) size &rest ctxt) - (if (<= size 1) - nil - (let ((subgen (slot-value gen 'subgenerator)) - (subsizes (randomly-partition (1- size) (min (isqrt size) 10)))) - (loop for subsize in subsizes - for (element success) = (multiple-value-list - (apply #'generate subgen subsize ctxt)) - when success collect element)))) - -;;; Macro for defining simple generator objects -;;; BODY is the body of the method with arguments (gen ctxt size) -;;; for computing the result. Inside the body the function FAIL causes -;;; the generator to return (nil nil). - -(defmacro defgenerator (name &key - keys - body - (superclass 'simple-generator) - slots) - (let ((rtag (gensym))) - (unless (listp keys) (setf keys (list keys))) - `(progn - (defclass ,name (,superclass) ,slots) - (defmethod generate ((gen ,name) (size real) &rest ctxt &key ,@keys) - (declare (ignorable gen size ctxt)) - (block ,rtag - (flet ((fail () (return-from ,rtag (values nil nil)))) - ,body)))))) diff --git a/t/ansi-test/rctest/lambda-generator.lsp b/t/ansi-test/rctest/lambda-generator.lsp deleted file mode 100644 index ced2be3..0000000 --- a/t/ansi-test/rctest/lambda-generator.lsp +++ /dev/null @@ -1,31 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Jun 9 20:57:34 2003 -;;;; Contains: Generators for lambda expressions - -(in-package :rctest) - -(compile-and-load "generator.lsp") - - -(defgenerator lambda-list-generator - :body - (let ((vars (loop for i from 1 to size collect (gensym)))) - (values vars t vars))) - -(defvar *lambda-list-generator* (make-instance 'lambda-list-generator)) - -(defgenerator lambda-generator.1 :keys (vars) - :body - (let* ((s1 (random (min 5 size))) - (s2 (- size s1))) - (multiple-value-bind (lambda-list success1 lambda-vars) - (apply #'generate *lambda-list-generator* s1 ctxt) - (let ((vars (append (mapcar #'list lambda-vars) vars))) - (multiple-value-bind (body success2) - (apply #'generate 'implicit-progn-generator s2 :vars vars ctxt) - (if (and success1 success2) - (values `(lambda ,lambda-list ,@body)) - (values nil nil))))))) - -(defvar *lambda-generator* (make-instance 'lambda-generator.1)) diff --git a/t/ansi-test/rctest/load.lsp b/t/ansi-test/rctest/load.lsp deleted file mode 100644 index 1686785..0000000 --- a/t/ansi-test/rctest/load.lsp +++ /dev/null @@ -1,12 +0,0 @@ -;;; Compile and load the rctest system - -(load "../compile-and-load.lsp") -(load "../rt-package.lsp") -(compile-and-load "../rt.lsp") -(load "../cl-test-package.lsp") -(compile-and-load "ANSI-TESTS:AUX;random-aux.lsp") -(load "rctest-package.lsp") -(compile-and-load "rctest-util.lsp") -(compile-and-load "generator.lsp") -(compile-and-load "lambda-generator.lsp") -(compile-and-load "form-generators.lsp") diff --git a/t/ansi-test/rctest/makefile b/t/ansi-test/rctest/makefile deleted file mode 100644 index 2e9ee10..0000000 --- a/t/ansi-test/rctest/makefile +++ /dev/null @@ -1,3 +0,0 @@ - -clean: - rm -f test.out *.fasl *.o *.so *~ *.fn *.x86f *.fasl *.ufsl diff --git a/t/ansi-test/rctest/rctest-package.lsp b/t/ansi-test/rctest/rctest-package.lsp deleted file mode 100644 index f166029..0000000 --- a/t/ansi-test/rctest/rctest-package.lsp +++ /dev/null @@ -1,13 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Jun 6 16:46:31 2003 -;;;; Contains: Definition of the RCTEST package - -(defpackage :rctest - (:use :cl :cl-test) - (:import-from "COMMON-LISP-USER" #:compile-and-load) - (:export - #:generate - )) - -;; (in-package :rctest) diff --git a/t/ansi-test/rctest/rctest-util.lsp b/t/ansi-test/rctest/rctest-util.lsp deleted file mode 100644 index 2708343..0000000 --- a/t/ansi-test/rctest/rctest-util.lsp +++ /dev/null @@ -1,19 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Jun 7 21:42:23 2003 -;;;; Contains: Utility functions for RCTEST - -(in-package :rctest) - -(defun randomly-partition (size &optional (limit 1)) - "Return a randomly generated list of positive integers whose - sum is SIZE. Try to make no element be < LIMIT." - (declare (type unsigned-byte size limit)) - (let ((result nil)) - (loop - while (> size 0) - do - (let* ((e0 (min size (max limit (1+ (min (random size) (random size))))))) - (push e0 result) - (decf size e0))) - (random-permute result))) diff --git a/t/ansi-test/reader/copy-readtable.lsp b/t/ansi-test/reader/copy-readtable.lsp deleted file mode 100644 index d92b150..0000000 --- a/t/ansi-test/reader/copy-readtable.lsp +++ /dev/null @@ -1,54 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Dec 31 07:15:35 2004 -;;;; Contains: Tests of COPY-READTABLE - -(in-package :cl-test) - -(deftest copy-readtable.1 - (notnot-mv (typep (copy-readtable) 'readtable)) - t) - -(deftest copy-readtable.2 - (notnot-mv (typep (copy-readtable *readtable*) 'readtable)) - t) - -(deftest copy-readtable.3 - (notnot-mv (typep (copy-readtable *readtable* nil) 'readtable)) - t) - -(deftest copy-readtable.4 - (let ((rt (copy-readtable *readtable*))) - (eql rt *readtable*)) - nil) - -(deftest copy-readtable.5 - (let ((rt (copy-readtable *readtable* nil))) - (eql rt *readtable*)) - nil) - -(deftest copy-readtable.6 - (let* ((rt (copy-readtable)) - (rt2 (copy-readtable *readtable* rt))) - (notnot (eql rt rt2))) - t) - -;;; NIL as a readtable designator indicating the standard readtable -(deftest copy-readtable.7 - (let ((rt (copy-readtable nil))) - (values - (notnot rt) - (notnot (readtablep rt)) - (not (eql rt *readtable*)))) - t t t) - -;;; Error tests - -(deftest copy-readtable.error.1 - (signals-error (copy-readtable *readtable* nil nil) program-error) - t) - - - - - diff --git a/t/ansi-test/reader/dispatch-macro-characters.lsp b/t/ansi-test/reader/dispatch-macro-characters.lsp deleted file mode 100644 index fbb15dc..0000000 --- a/t/ansi-test/reader/dispatch-macro-characters.lsp +++ /dev/null @@ -1,78 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Feb 5 11:42:24 2005 -;;;; Contains: Tests of dispatch macro character functions - -(in-package :cl-test) - -(deftest make-dispatch-macro-character.1 - (with-standard-io-syntax - (let* ((*readtable* (copy-readtable nil)) - (*package* (find-package "CL-TEST"))) - (values - (make-dispatch-macro-character #\!) - (read-from-string "123!")))) - t 123) - -(deftest make-dispatch-macro-character.2 - (with-standard-io-syntax - (let* ((*readtable* (copy-readtable nil)) - (*package* (find-package "CL-TEST"))) - (values - (make-dispatch-macro-character #\! t) - (read-from-string "123!")))) - t 123!) - -(deftest make-dispatch-macro-character.3 - (with-standard-io-syntax - (let* ((*readtable* (copy-readtable nil)) - (*package* (find-package "CL-TEST"))) - (values - (make-dispatch-macro-character #\!) - (loop for c across +standard-chars+ - for result = (handler-case - (read-from-string (coerce (list #\! c #\X) 'string)) - (reader-error (c) :good) - (error (c) :bad)) - unless (eql result :good) - collect (list c result))))) - t nil) - -(deftest make-dispatch-macro-character.4 - (with-standard-io-syntax - (let* ((rt (copy-readtable nil)) - (*package* (find-package "CL-TEST"))) - (values - (make-dispatch-macro-character #\! t rt) - (read-from-string "!") - (let ((*readtable* rt)) - (read-from-string "123!"))))) - t ! 123!) - -(deftest make-dispatch-macro-character.error.1 - (let ((*readtable* (copy-readtable nil))) - (signals-error (make-dispatch-macro-character) program-error)) - t) - -(deftest make-dispatch-macro-character.error.2 - (let ((*readtable* (copy-readtable nil))) - (signals-error (make-dispatch-macro-character #\! t *readtable* nil) - program-error)) - t) - -;;; GET-DISPATCH-MACRO-CHARACTER - -(deftest get-dispatch-macro-character.1 - (loop for c across +standard-chars+ - when (and (not (eql c #\#)) - (handler-case - (list - (get-dispatch-macro-character c #\a) - c) - (error (cnd) nil))) - collect it) - nil) - - - - diff --git a/t/ansi-test/reader/get-macro-character.lsp b/t/ansi-test/reader/get-macro-character.lsp deleted file mode 100644 index 4f7d7c8..0000000 --- a/t/ansi-test/reader/get-macro-character.lsp +++ /dev/null @@ -1,124 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jan 2 15:54:27 2005 -;;;; Contains: Tests of GET-MACRO-CHARACTER - -(in-package :cl-test) - - - -(def-syntax-test get-macro-character.1 - (loop for c across "()';\"`,#" - collect - (let ((vals (multiple-value-list (get-macro-character c)))) - (list - (=t (length vals) 2) - (or (notnot (functionp (car vals))) - (and (symbolp (car vals)) - (notnot (fboundp (car vals))))) - (notnot (cadr vals))))) - ((t t nil) (t t nil) (t t nil) (t t nil) - (t t nil) (t t nil) (t t nil) (t t t))) - -(def-syntax-test get-macro-character.2 - (loop for c across (concatenate - 'string - "abcdefghijklmnopqrstuvwxyz" - "ABCDEFGHIJKLMNOPQRSTUVWXYZ" - "1234567890!@$%^&*_-+={[}]<>?/~") - for (fn non-term-p) = (multiple-value-list - (get-macro-character c)) - unless (or (null fn) non-term-p) - collect (list c fn non-term-p)) - nil) - -(def-syntax-test get-macro-character.3 - (loop for rt in (list nil *readtable* (copy-readtable)) - collect - (loop for c across "()';\"`,#" - collect - (let ((vals (multiple-value-list (get-macro-character c rt)))) - (list - (=t (length vals) 2) - (or (notnot (functionp (car vals))) - (and (symbolp (car vals)) - (notnot (fboundp (car vals))))) - (notnot (cadr vals)))))) - (((t t nil) (t t nil) (t t nil) (t t nil) - (t t nil) (t t nil) (t t nil) (t t t)) - ((t t nil) (t t nil) (t t nil) (t t nil) - (t t nil) (t t nil) (t t nil) (t t t)) - ((t t nil) (t t nil) (t t nil) (t t nil) - (t t nil) (t t nil) (t t nil) (t t t)))) - -(def-syntax-test get-macro-character.4 - (loop for rt in (list nil *readtable* (copy-readtable)) - nconc - (loop for c across (concatenate - 'string - "abcdefghijklmnopqrstuvwxyz" - "ABCDEFGHIJKLMNOPQRSTUVWXYZ" - "1234567890!@$%^&*_-+={[}]<>?/~") - for (fn non-term-p) = (multiple-value-list - (get-macro-character c rt)) - unless (or (null fn) non-term-p) - collect (list rt c fn non-term-p))) - nil) - -;;; Copying a readtable preserves the reader macros - -(def-syntax-test get-macro-character.5 - (let ((rt (copy-readtable))) - (loop for c across +standard-chars+ - for (fn1 ntp1) = (multiple-value-list (get-macro-character c)) - for (fn2 ntp2) = (multiple-value-list (get-macro-character c rt)) - unless (and (or (not (symbolp fn1)) - (not (symbolp fn2)) - (eql fn1 fn2)) - (if ntp1 ntp2 (not ntp2))) - collect (list c fn1 ntp1 fn2 ntp2))) - nil) - -(def-syntax-test get-macro-character.6 - (let ((rt (copy-readtable))) - (loop for i below (min 65536 char-code-limit) - for c = (code-char i) - for (fn1 ntp1) = (if c (multiple-value-list (get-macro-character c)) - '(nil nil)) - for (fn2 ntp2) = (if c (multiple-value-list (get-macro-character c rt)) - '(nil nil)) - unless (and (or (not (symbolp fn1)) - (not (symbolp fn2)) - (eql fn1 fn2)) - (if ntp1 ntp2 (not ntp2))) - collect (list c fn1 ntp1 fn2 ntp2))) - nil) - -(def-syntax-test get-macro-character.7 - (let ((rt (copy-readtable))) - (loop for i = (random (min char-code-limit (ash 1 24))) - for c = (code-char i) - for (fn1 ntp1) = (if c (multiple-value-list (get-macro-character c)) - '(nil nil)) - for (fn2 ntp2) = (if c (multiple-value-list (get-macro-character c rt)) - '(nil nil)) - repeat 10000 - unless (and (or (not (symbolp fn1)) - (not (symbolp fn2)) - (eql fn1 fn2)) - (if ntp1 ntp2 (not ntp2))) - collect (list c fn1 ntp1 fn2 ntp2))) - nil) - - -;;; Error tests - -(deftest get-macro-character.error.1 - (signals-error (get-macro-character) program-error) - t) - -(deftest get-macro-character.error.2 - (signals-error (get-macro-character #\; (copy-readtable) nil) program-error) - t) - - diff --git a/t/ansi-test/reader/load.lsp b/t/ansi-test/reader/load.lsp deleted file mode 100644 index de2bf59..0000000 --- a/t/ansi-test/reader/load.lsp +++ /dev/null @@ -1,25 +0,0 @@ -;;;; Tests of the reader -(compile-and-load "ANSI-TESTS:AUX;reader-aux.lsp") - -(in-package #:cl-test) - -(let ((*default-pathname-defaults* - (make-pathname - :directory (pathname-directory *load-pathname*)))) - (load "reader-test.lsp") - (load "with-standard-io-syntax.lsp") - (load "copy-readtable.lsp") - (load "read.lsp") - (load "read-preserving-whitespace.lsp") - (load "read-delimited-list.lsp") - (load "read-from-string.lsp") - (load "readtable-case.lsp") - (load "readtablep.lsp") - (load "get-macro-character.lsp") - (load "set-macro-character.lsp") - (load "read-suppress.lsp") - (load "set-syntax-from-char.lsp") - (load "dispatch-macro-characters.lsp") - - (load "syntax.lsp") - (load "syntax-tokens.lsp")) diff --git a/t/ansi-test/reader/read-delimited-list.lsp b/t/ansi-test/reader/read-delimited-list.lsp deleted file mode 100644 index e32249c..0000000 --- a/t/ansi-test/reader/read-delimited-list.lsp +++ /dev/null @@ -1,66 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Jan 1 11:17:21 2005 -;;;; Contains: Tests of READ-DELIMITED-LIST - -(in-package :cl-test) - -(deftest read-delimited-list.1 - (with-input-from-string - (*standard-input* "1 2 3)") - (read-delimited-list #\))) - (1 2 3)) - -(deftest read-delimited-list.2 - (with-input-from-string - (*standard-input* "1 2 3 ]") - (read-delimited-list #\] nil)) - (1 2 3)) - -(deftest read-delimited-list.3 - (with-input-from-string - (is "1 2 3)") - (with-open-stream - (os (make-broadcast-stream)) - (with-open-stream - (*terminal-io* (make-two-way-stream is os)) - (read-delimited-list #\) t)))) - (1 2 3)) - -(deftest read-delimited-list.4 - (with-input-from-string - (is "1 2 3)X") - (values - (read-delimited-list #\) is) - (notnot (eql (read-char is) #\X)))) - (1 2 3) t) - -(deftest read-delimited-list.5 - (with-input-from-string - (is "1 2 3) X") - (values - (read-delimited-list #\) is nil) - (notnot (eql (read-char is) #\Space)))) - (1 2 3) t) - -(deftest read-delimited-list.6 - (with-input-from-string - (is (concatenate 'string "1 2 3" (string #\Newline) "]")) - (read-delimited-list #\] is)) - (1 2 3)) - -;;; Tests with RECURSIVE-P set to true must be done inside a reader macro function - -;;; Error tests - -(deftest read-delimited-list.error.1 - (signals-error (read-delimited-list) program-error) - t) - -(deftest read-delimited-list.error.2 - (signals-error - (with-input-from-string - (is "1 2 3)") - (read-delimited-list #\) is nil nil)) - program-error) - t) diff --git a/t/ansi-test/reader/read-from-string.lsp b/t/ansi-test/reader/read-from-string.lsp deleted file mode 100644 index ccfc98b..0000000 --- a/t/ansi-test/reader/read-from-string.lsp +++ /dev/null @@ -1,238 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Jan 1 14:50:09 2005 -;;;; Contains: Tests of READ-FROM-STRING - -(in-package :cl-test) - -(deftest read-from-string.1 - (let ((*package* (find-package :cl-test))) - (do-special-strings - (s "123") - (let ((vals (multiple-value-list (read-from-string s)))) - (assert (= (length vals) 2)) - (assert (eql (first vals) 123)) - (assert (member (second vals) '(3 4)))))) - nil) - -(deftest read-from-string.2 - (let ((*package* (find-package :cl-test))) - (do-special-strings - (s "XYZ ") - (let ((vals (multiple-value-list (read-from-string s)))) - (assert (equal vals '(|XYZ| 4)))))) - nil) - -(deftest read-from-string.3 - (let ((*package* (find-package :cl-test))) - (do-special-strings - (s "(1 2 3)X") - (let ((vals (multiple-value-list (read-from-string s)))) - (assert (equal vals '((1 2 3) 7)))))) - nil) - -(deftest read-from-string.4 - (do-special-strings - (s "") - (let ((vals (multiple-value-list (read-from-string s nil :good)))) - (assert (= (length vals) 2)) - (assert (equal (first vals) :good)) - (assert (member (second vals) '(0 1))))) - nil) - -(deftest read-from-string.5 - (let ((*package* (find-package :cl-test))) - (do-special-strings - (s "71235") - (let ((vals (multiple-value-list - (read-from-string s t nil :start 1 :end 4)))) - (assert (equal vals '(123 4)))))) - nil) - -(deftest read-from-string.6 - (let ((*package* (find-package :cl-test))) - (do-special-strings - (s "7123 ") - (let ((vals (multiple-value-list - (read-from-string s t nil :start 1)))) - (assert (equal vals '(123 5)))))) - nil) - - -(deftest read-from-string.7 - (let ((*package* (find-package :cl-test))) - (do-special-strings - (s "7123 ") - (let ((vals (multiple-value-list - (read-from-string s t nil :end 4)))) - (assert (equal vals '(7123 4)))))) - nil) - -(deftest read-from-string.8 - (let ((*package* (find-package :cl-test))) - (do-special-strings - (s "7123") - (let ((vals (multiple-value-list - (read-from-string s nil 'foo :start 2 :end 2)))) - (assert (equal vals '(foo 2)))))) - nil) - -(deftest read-from-string.9 - (let ((*package* (find-package :cl-test))) - (do-special-strings - (s "123 ") - (let ((vals (multiple-value-list - (read-from-string s t nil :preserve-whitespace t)))) - (assert (equal vals '(123 3)))))) - nil) - -(deftest read-from-string.10 - (let ((*package* (find-package :cl-test))) - (do-special-strings - (s (concatenate 'string "( )" (string #\Newline))) - (let ((vals (multiple-value-list - (read-from-string s t nil :preserve-whitespace t)))) - (assert (equal vals '(nil 3)))))) - nil) - -;;; Multiple keywords - -(deftest read-from-string.11 - (let ((*package* (find-package :cl-test))) - (do-special-strings - (s "7123 ") - (let ((vals (multiple-value-list - (read-from-string s t nil :start 1 :start 2)))) - (assert (equal vals '(123 5)))))) - nil) - -(deftest read-from-string.12 - (let ((*package* (find-package :cl-test))) - (do-special-strings - (s "7123 ") - (let ((vals (multiple-value-list - (read-from-string s t nil :end 4 :end 2)))) - (assert (equal vals '(7123 4)))))) - nil) - -(deftest read-from-string.13 - (let ((*package* (find-package :cl-test))) - (do-special-strings - (s (concatenate 'string "( )" (string #\Newline))) - (let ((vals (multiple-value-list - (read-from-string s t nil :preserve-whitespace t - :preserve-whitespace nil)))) - (assert (equal vals '(nil 3)))))) - nil) - -;;; Allow other keys - -(deftest read-from-string.14 - (with-standard-io-syntax - (let ((*package* (find-package :cl-test))) - (do-special-strings - (s "abc ") - (let ((vals (multiple-value-list - (read-from-string s t nil :allow-other-keys nil)))) - (assert (equal vals '(|ABC| 4)) (vals) "VALS is ~A" vals))))) - nil) - -(deftest read-from-string.15 - (let ((*package* (find-package :cl-test))) - (do-special-strings - (s "123 ") - (let ((vals (multiple-value-list - (read-from-string s t nil :foo 'bar :allow-other-keys t)))) - (assert (equal vals '(123 4)) (vals) "VALS is ~A" vals)))) - nil) - -(deftest read-from-string.16 - (let ((*package* (find-package :cl-test))) - (do-special-strings - (s "123 ") - (let ((vals (multiple-value-list - (read-from-string s t nil :allow-other-keys t - :allow-other-keys nil :foo 'bar)))) - (assert (equal vals '(123 4)) (vals) "VALS is ~A" vals)))) - nil) - -;;; default for :end - -(deftest read-from-string.17 - (let ((*package* (find-package :cl-test))) - (do-special-strings - (s "XYZ ") - (let ((vals (multiple-value-list (read-from-string s t nil :end nil)))) - (assert (equal vals '(|XYZ| 4)))))) - nil) - -;;; TODO Add tests for reading from strings containing non-base characters - -;;; Error tests - -(deftest read-from-string.error.1 - (signals-error (read-from-string "") error) - t) - -(deftest read-from-string.error.2 - (signals-error (read-from-string "(A B ") error) - t) - -(deftest read-from-string.error.3 - (signals-error (read-from-string "" t) error) - t) - -(deftest read-from-string.error.4 - (signals-error (read-from-string "" t nil) error) - t) - -(deftest read-from-string.error.5 - (signals-error (read-from-string "(A B " nil) error) - t) - -(deftest read-from-string.error.6 - (signals-error (read-from-string "(A B " t) error) - t) - -(deftest read-from-string.error.7 - (signals-error (read-from-string "123" t nil :start 0 :end 0) error) - t) - -(deftest read-from-string.error.8 - (signals-error (read-from-string) program-error) - t) - -(deftest read-from-string.error.9 - (signals-error (read-from-string "A" nil t :bad-keyword t) program-error) - t) - - -(deftest read-from-string.error.10 - (signals-error (read-from-string "A" nil t - :bad-keyword t - :allow-other-keys nil) - program-error) - t) - -(deftest read-from-string.error.11 - (signals-error (read-from-string "A" nil t - :bad-keyword t - :allow-other-keys nil - :allow-other-keys t) - program-error) - t) - -(deftest read-from-string.error.12 - (signals-error (read-from-string "A" nil t - :allow-other-keys nil - :allow-other-keys t - :bad-keyword t) - program-error) - t) - -(deftest read-from-string.error.13 - (signals-error (read-from-string "A" nil t :start) - program-error) - t) - - diff --git a/t/ansi-test/reader/read-preserving-whitespace.lsp b/t/ansi-test/reader/read-preserving-whitespace.lsp deleted file mode 100644 index effd48c..0000000 --- a/t/ansi-test/reader/read-preserving-whitespace.lsp +++ /dev/null @@ -1,161 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Jan 1 08:54:28 2005 -;;;; Contains: Tests of READ-PRESERVING-WHITESPACE - -(in-package :cl-test) - -;;; Input stream designators - -(deftest read-preserving-whitespace.1 - (block done - (with-input-from-string - (is "1 2 3") - (with-output-to-string - (os) - (with-open-stream - (*terminal-io* (make-two-way-stream is os)) - (return-from done (read-preserving-whitespace t)))))) - 1) - -(deftest read-preserving-whitespace.2 - (with-input-from-string - (*standard-input* "1 2 3") - (read-preserving-whitespace nil)) - 1) - -(deftest read-preserving-whitespace.3 - (with-input-from-string - (*standard-input* "1 2 3") - (read-preserving-whitespace)) - 1) - -(deftest read-preserving-whitespace.4 - (with-input-from-string - (s "1 2 3") - (read-preserving-whitespace s)) - 1) - -;;; eof handling - -(deftest read-preserving-whitespace.5 - (with-input-from-string (s "") (read-preserving-whitespace s nil)) - nil) - -(deftest read-preserving-whitespace.6 - (with-input-from-string (s "") (read-preserving-whitespace s nil 'foo)) - foo) - -(deftest read-preserving-whitespace.7 - (with-input-from-string (s "1") (read-preserving-whitespace s)) - 1) - -(deftest read-preserving-whitespace.8 - (let ((*package* (find-package "CL-TEST"))) - (with-input-from-string (s "X") (read-preserving-whitespace s))) - |X|) - -(deftest read-preserving-whitespace.9 - (with-input-from-string (s "1.2") (read-preserving-whitespace s)) - 1.2) - -(deftest read-preserving-whitespace.10 - (with-input-from-string (s "1.0s0") (read-preserving-whitespace s)) - 1.0s0) - -(deftest read-preserving-whitespace.11 - (with-input-from-string (s "1.0f0") (read-preserving-whitespace s)) - 1.0f0) - -(deftest read-preserving-whitespace.12 - (with-input-from-string (s "1.0d0") (read-preserving-whitespace s)) - 1.0d0) - -(deftest read-preserving-whitespace.13 - (with-input-from-string (s "1.0l0") (read-preserving-whitespace s)) - 1.0l0) - -(deftest read-preserving-whitespace.14 - (with-input-from-string (s "()") (read-preserving-whitespace s)) - nil) - -(deftest read-preserving-whitespace.15 - (with-input-from-string (s "(1 2 3)") (read-preserving-whitespace s)) - (1 2 3)) - -;;; Throwing away whitespace chars - -(deftest read-preserving-whitespace.16 - (with-standard-io-syntax - (with-input-from-string - (s ":ABC X") - (assert (eq (read-preserving-whitespace s) :|ABC|)) - (read-char s))) - #\Space) - -(deftest read-preserving-whitespace.17 - (with-standard-io-syntax - (with-input-from-string - (s ":ABC X") - (assert (eq (read-preserving-whitespace s) :|ABC|)) - (read-char s))) - #\Space) - -(deftest read-preserving-whitespace.18 - (with-standard-io-syntax - (with-input-from-string - (s ":ABC(") - (assert (eq (read-preserving-whitespace s) :|ABC|)) - (read-char s))) - #\() - -;;; eof value - -(deftest read-preserving-whitespace.19 - (with-input-from-string - (s "") - (read-preserving-whitespace s nil 'foo)) - foo) - -;;; Error tests - -(deftest read-preserving-whitespace.error.1 - (signals-error (with-input-from-string (s "") (read-preserving-whitespace s)) end-of-file) - t) - -(deftest read-preserving-whitespace.error.2 - (signals-error (with-input-from-string (s "") (read-preserving-whitespace s)) stream-error) - t) - -(deftest read-preserving-whitespace.error.3 - (signals-error (with-input-from-string (s "") (read-preserving-whitespace s t)) stream-error) - t) - -(deftest read-preserving-whitespace.error.4 - (signals-error (with-input-from-string (s "(") (read-preserving-whitespace s nil)) end-of-file) - t) - -(deftest read-preserving-whitespace.error.5 - (signals-error (with-input-from-string (s "(") (read-preserving-whitespace s t)) end-of-file) - t) - -(deftest read-preserving-whitespace.error.6 - (signals-error (with-input-from-string (s "#(") (read-preserving-whitespace s t)) end-of-file) - t) - -(deftest read-preserving-whitespace.error.7 - (signals-error (with-input-from-string (s "#S(") (read-preserving-whitespace s t)) end-of-file) - t) - -;;; Note -- cannot easily test calls with RECURSIVE-P set to T. These have to be -;;; done from read-preserving-whitespaceer macro functions so that READ-PRESERVING-WHITESPACE -;;; is not called without having any requisite dynamic environment created -;;; around the call. - -(deftest read-preserving-whitespace.error.8 - (signals-error - (with-input-from-string - (s "1 2 3") - (read-preserving-whitespace s nil nil nil nil)) - program-error) - t) diff --git a/t/ansi-test/reader/read-suppress.lsp b/t/ansi-test/reader/read-suppress.lsp deleted file mode 100644 index a8eccd5..0000000 --- a/t/ansi-test/reader/read-suppress.lsp +++ /dev/null @@ -1,252 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Jan 15 13:55:27 2005 -;;;; Contains: Tests of reading with *READ-SUPPRESS* bound to true - -(in-package :cl-test) - - - -(defmacro def-read-suppress-test (name string) - `(def-syntax-test ,name - (let ((*read-suppress* t)) - (read-from-string ,string)) - nil ,(length string))) - -(def-read-suppress-test read-suppress.1 "NONEXISTENT-PACKAGE::FOO") -(def-read-suppress-test read-suppress.2 ":") -(def-read-suppress-test read-suppress.3 "::") -(def-read-suppress-test read-suppress.4 ":::") -(def-read-suppress-test read-suppress.5 "123.45") -;; (def-read-suppress-test read-suppress.6 ".") -(def-read-suppress-test read-suppress.7 "..") -(def-read-suppress-test read-suppress.8 "...") -(def-read-suppress-test read-suppress.9 "(1 2)") -(def-read-suppress-test read-suppress.10 "(1 . 2)") -(def-read-suppress-test read-suppress.11 "(1 .. 2 . 3)") -(def-read-suppress-test read-suppress.12 "(...)") - -(defparameter *non-macro-chars* - (coerce "1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ-=+_~!@$%^&*{}[]<>/?." - 'simple-base-string)) - -(declaim (type simple-base-string *non-macro-chars*)) - -(defmacro def-random-suppress-test (name &key - (chars '*non-macro-chars*) - (reps 1000) - (maxlen 8) - (count 10) - (prefix "") - (suffix "")) - `(def-syntax-test ,name - (let* ((chars ,chars) - (prefix ,prefix) - (suffix ,suffix) - (*read-suppress* t) - (count 0) - (maxlen ,maxlen) - (reps ,reps) - (maxcount ,count)) - (loop for n = (1+ (random maxlen)) - for s = (concatenate 'string - prefix - (loop repeat n - collect (random-from-seq chars)) - suffix) - for vals = (multiple-value-list - (handler-case (read-from-string s) - (reader-error (rc) rc))) - repeat reps - unless (equal vals (list nil (length s))) - collect (progn (when (> (incf count) maxcount) - (loop-finish)) - (list n s vals)))) - nil)) - -(def-random-suppress-test read-suppress.13) -(def-random-suppress-test read-suppress.14 :prefix "(" :suffix ")") -(def-random-suppress-test read-suppress.15 :prefix "#(" :suffix ")") -(def-random-suppress-test read-suppress.16 :chars "0123456789.eEfFsSdDlL+-") - -(def-read-suppress-test read-suppress.sharp-slash.1 "#\\boguscharname") -(def-read-suppress-test read-suppress.sharp-slash.2 "#\\:x") -(def-read-suppress-test read-suppress.sharp-slash.3 "#\\::::") -(def-read-suppress-test read-suppress.sharp-slash.4 "#\\123") -(def-read-suppress-test read-suppress.sharp-slash.5 "#0\\ ") -(def-read-suppress-test read-suppress.sharp-slash.6 "#100000000\\Space") - -(def-read-suppress-test read-suppress.sharp-quote.1 "#'foo") -(def-read-suppress-test read-suppress.sharp-quote.2 "#'1") -(def-read-suppress-test read-suppress.sharp-quote.3 "#'(setf bar)") -(def-read-suppress-test read-suppress.sharp-quote.5 "#'.") -(def-read-suppress-test read-suppress.sharp-quote.6 "#'1.2.3") -(def-read-suppress-test read-suppress.sharp-quote.7 "#0'F") -(def-read-suppress-test read-suppress.sharp-quote.8 "#1000000'F") - -(def-read-suppress-test read-suppress.sharp-left-paren.1 "#()") -(def-read-suppress-test read-suppress.sharp-left-paren.2 "#(A)") -(def-read-suppress-test read-suppress.sharp-left-paren.3 "#(A B)") -(def-read-suppress-test read-suppress.sharp-left-paren.4 "#0()") -(def-read-suppress-test read-suppress.sharp-left-paren.5 "#0(A)") -(def-read-suppress-test read-suppress.sharp-left-paren.6 "#1(A)") -(def-read-suppress-test read-suppress.sharp-left-paren.7 "#1(A B C D E)") -(def-read-suppress-test read-suppress.sharp-left-paren.8 "#4(A B C D E)") -(def-read-suppress-test read-suppress.sharp-left-paren.9 "#10(A B C D E)") -(def-read-suppress-test read-suppress.sharp-left-paren.10 "#100()") -(def-read-suppress-test read-suppress.sharp-left-paren.11 "#10000000000000()") -(def-read-suppress-test read-suppress.sharp-left-paren.12 "#10000000000000(A)") - -(def-read-suppress-test read-suppress.sharp-asterisk.1 "#*") -(def-read-suppress-test read-suppress.sharp-asterisk.2 "#0*") -(def-read-suppress-test read-suppress.sharp-asterisk.3 "#*1") -(def-read-suppress-test read-suppress.sharp-asterisk.4 "#*0111001") -(def-read-suppress-test read-suppress.sharp-asterisk.5 "#*73298723497132") -(def-read-suppress-test read-suppress.sharp-asterisk.6 - "#*abcdefghijklmnopqrstuvwxyz") -(def-read-suppress-test read-suppress.sharp-asterisk.7 - "#*ABCDEFGHIJKLMNOPQRSTUVWXYZ") -(def-read-suppress-test read-suppress.sharp-asterisk.8 "#*:") -(def-read-suppress-test read-suppress.sharp-asterisk.9 "#*::::") -(def-read-suppress-test read-suppress.sharp-asterisk.10 "#1*") -(def-read-suppress-test read-suppress.sharp-asterisk.11 "#10000*") -(def-read-suppress-test read-suppress.sharp-asterisk.12 "#10000000000000*") -(def-read-suppress-test read-suppress.sharp-asterisk.13 "#4*001101001") -(def-read-suppress-test read-suppress.sharp-asterisk.14 "#2*") - -(def-read-suppress-test read-suppress.sharp-colon.1 "#:1") -(def-read-suppress-test read-suppress.sharp-colon.2 "#:foo") -(def-read-suppress-test read-suppress.sharp-colon.3 "#0:1/2") -(def-read-suppress-test read-suppress.sharp-colon.4 "#10:-2") -(def-read-suppress-test read-suppress.sharp-colon.5 "#100000000000:x") -(def-read-suppress-test read-suppress.sharp-colon.6 "#3:foo") -(def-read-suppress-test read-suppress.sharp-colon.7 "#::") -(def-read-suppress-test read-suppress.sharp-colon.8 "#:123") -(def-read-suppress-test read-suppress.sharp-colon.9 "#:.") - -(def-read-suppress-test read-suppress.sharp-dot.1 "#.1") -(def-read-suppress-test read-suppress.sharp-dot.2 "#.#:foo") -(def-read-suppress-test read-suppress.sharp-dot.3 "#.(throw 'foo nil)") -(def-read-suppress-test read-suppress.sharp-dot.4 "#0.1") -(def-read-suppress-test read-suppress.sharp-dot.5 "#10.1") -(def-read-suppress-test read-suppress.sharp-dot.6 "#1000000000000000.1") - -(def-read-suppress-test read-suppress.sharp-b.1 "#b0") -(def-read-suppress-test read-suppress.sharp-b.2 "#B1") -(def-read-suppress-test read-suppress.sharp-b.3 "#BX") -(def-read-suppress-test read-suppress.sharp-b.4 "#b.") -(def-read-suppress-test read-suppress.sharp-b.5 "#0b0") -(def-read-suppress-test read-suppress.sharp-b.6 "#1B1") -(def-read-suppress-test read-suppress.sharp-b.7 "#100b010") -(def-read-suppress-test read-suppress.sharp-b.8 "#1000000000000b010") -(def-read-suppress-test read-suppress.sharp-b.9 "#B101/100") -(def-read-suppress-test read-suppress.sharp-b.10 "#b101/100/11") - -(def-read-suppress-test read-suppress.sharp-o.1 "#o0") -(def-read-suppress-test read-suppress.sharp-o.2 "#O1") -(def-read-suppress-test read-suppress.sharp-o.3 "#OX") -(def-read-suppress-test read-suppress.sharp-o.4 "#o.") -(def-read-suppress-test read-suppress.sharp-o.5 "#od6") -(def-read-suppress-test read-suppress.sharp-o.6 "#1O9") -(def-read-suppress-test read-suppress.sharp-o.7 "#100O010") -(def-read-suppress-test read-suppress.sharp-o.8 "#1000000000000o27423") -(def-read-suppress-test read-suppress.sharp-o.9 "#O123/457") -(def-read-suppress-test read-suppress.sharp-o.10 "#o12/17/21") - -(def-read-suppress-test read-suppress.sharp-c.1 "#c(0 0)") -(def-read-suppress-test read-suppress.sharp-c.2 "#C(1.0 1.0)") -(def-read-suppress-test read-suppress.sharp-c.3 "#cFOO") -(def-read-suppress-test read-suppress.sharp-c.4 "#c1") -(def-read-suppress-test read-suppress.sharp-c.5 "#C(1 2 3)") -(def-read-suppress-test read-suppress.sharp-c.6 "#c.") -(def-read-suppress-test read-suppress.sharp-c.7 "#c()") -(def-read-suppress-test read-suppress.sharp-c.8 "#c(1)") -(def-read-suppress-test read-suppress.sharp-c.9 "#C(1 . 2)") -(def-read-suppress-test read-suppress.sharp-c.10 "#c(1 2 3)") -(def-read-suppress-test read-suppress.sharp-c.11 "#0c(1 2)") -(def-read-suppress-test read-suppress.sharp-c.12 "#1C(1 2)") -(def-read-suppress-test read-suppress.sharp-c.13 "#10c(1 2)") -(def-read-suppress-test read-suppress.sharp-c.14 "#123456789c(1 2)") -(def-read-suppress-test read-suppress.sharp-c.15 "#c(..)") - -(def-read-suppress-test read-suppress.sharp-x.1 "#x0") -(def-read-suppress-test read-suppress.sharp-x.2 "#X1") -(def-read-suppress-test read-suppress.sharp-x.3 "#XX") -(def-read-suppress-test read-suppress.sharp-x.4 "#x.") -(def-read-suppress-test read-suppress.sharp-x.5 "#xy6") -(def-read-suppress-test read-suppress.sharp-x.6 "#1X9") -(def-read-suppress-test read-suppress.sharp-x.7 "#100X010") -(def-read-suppress-test read-suppress.sharp-x.8 "#1000000000000x2af23") -(def-read-suppress-test read-suppress.sharp-x.9 "#X123/DE7") -(def-read-suppress-test read-suppress.sharp-x.10 "#x12/17/21") - -(def-read-suppress-test read-suppress.sharp-r.1 "#2r1101") -(def-read-suppress-test read-suppress.sharp-r.2 "#10R9871") -(def-read-suppress-test read-suppress.sharp-r.3 "#36r721zwoqnASLDKJA22") -(def-read-suppress-test read-suppress.sharp-r.4 "#r.") -(def-read-suppress-test read-suppress.sharp-r.5 "#2r379ze") -(def-read-suppress-test read-suppress.sharp-r.6 "#0r0") -(def-read-suppress-test read-suppress.sharp-r.7 "#1r0") -(def-read-suppress-test read-suppress.sharp-r.8 "#100r0A") -(def-read-suppress-test read-suppress.sharp-r.9 "#1000000000000r0A") -(def-read-suppress-test read-suppress.sharp-r.10 "#2r!@#$%^&*_-+={}[]:<>.?/") - -(def-read-suppress-test read-suppress.sharp-a.1 "#a()") -(def-read-suppress-test read-suppress.sharp-a.2 "#2a((a)(b c))") -(def-read-suppress-test read-suppress.sharp-a.3 "#a1") -(def-read-suppress-test read-suppress.sharp-a.4 "#1a1") -(def-read-suppress-test read-suppress.sharp-a.5 "#10a(a b c)") -(def-read-suppress-test read-suppress.sharp-a.6 "#100a(a b c)") -(def-read-suppress-test read-suppress.sharp-a.7 "#10000000000000a(a b c)") -(def-read-suppress-test read-suppress.sharp-a.8 "#a..") -(def-read-suppress-test read-suppress.sharp-a.9 "#a(...)") - -(def-read-suppress-test read-suppress.sharp-s.1 "#s()") -(def-read-suppress-test read-suppress.sharp-s.2 "#S(invalid-sname)") -(def-read-suppress-test read-suppress.sharp-s.3 "#s(..)") -(def-read-suppress-test read-suppress.sharp-s.4 "#S(foo bar)") -(def-read-suppress-test read-suppress.sharp-s.5 "#0s()") -(def-read-suppress-test read-suppress.sharp-s.6 "#1S()") -(def-read-suppress-test read-suppress.sharp-s.7 "#10s()") -(def-read-suppress-test read-suppress.sharp-s.8 "#271S()") -(def-read-suppress-test read-suppress.sharp-s.9 "#712897459812s()") - -(def-read-suppress-test read-suppress.sharp-p.1 "#p\"\"") -(def-read-suppress-test read-suppress.sharp-p.2 "#P123") -(def-read-suppress-test read-suppress.sharp-p.3 "#p1/3") -(def-read-suppress-test read-suppress.sharp-p.4 "#0P\"\"") -(def-read-suppress-test read-suppress.sharp-p.5 "#1p\"\"") -(def-read-suppress-test read-suppress.sharp-p.6 "#100P\"\"") -(def-read-suppress-test read-suppress.sharp-p.7 "#1234567890p\"\"") - -(def-read-suppress-test read-suppress.sharp-equal.1 "#=nil") -(def-read-suppress-test read-suppress.sharp-equal.2 "#1=nil") -(def-read-suppress-test read-suppress.sharp-equal.3 "#100=nil") -(def-read-suppress-test read-suppress.sharp-equal.4 "(#1=nil #1=nil)") - -(def-read-suppress-test read-suppress.sharp-sharp.1 "##") -(def-read-suppress-test read-suppress.sharp-sharp.2 "#1#") -(def-read-suppress-test read-suppress.sharp-sharp.3 "#100#") -(def-read-suppress-test read-suppress.sharp-sharp.4 "#123456789#") - -;;; Error cases - -(def-syntax-test read-suppress.error.1 - (signals-error (let ((*read-suppress* t)) (read-from-string "')")) - reader-error) - t) - -(def-syntax-test read-suppress.error.2 - (signals-error (let ((*read-suppress* t)) (read-from-string "#<")) - reader-error) - t) - -(def-syntax-test read-suppress.error.3 - (signals-error (let ((*read-suppress* t)) (read-from-string "# ")) - reader-error) - t) - -(def-syntax-test read-suppress.error.4 - (signals-error (let ((*read-suppress* t)) (read-from-string "#)")) - reader-error) - t) diff --git a/t/ansi-test/reader/read.lsp b/t/ansi-test/reader/read.lsp deleted file mode 100644 index 9b47035..0000000 --- a/t/ansi-test/reader/read.lsp +++ /dev/null @@ -1,161 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Dec 31 07:52:06 2004 -;;;; Contains: Tests of READ - -(in-package :cl-test) - -;;; Input stream designators - -(deftest read.1 - (block done - (with-input-from-string - (is "1 2 3") - (with-output-to-string - (os) - (with-open-stream - (*terminal-io* (make-two-way-stream is os)) - (return-from done (read t)))))) - 1) - -(deftest read.2 - (with-input-from-string - (*standard-input* "1 2 3") - (read nil)) - 1) - -(deftest read.3 - (with-input-from-string - (*standard-input* "1 2 3") - (read)) - 1) - -(deftest read.4 - (with-input-from-string - (s "1 2 3") - (read s)) - 1) - -;;; eof handling - -(deftest read.5 - (with-input-from-string (s "") (read s nil)) - nil) - -(deftest read.6 - (with-input-from-string (s "") (read s nil 'foo)) - foo) - -(deftest read.7 - (with-input-from-string (s "1") (read s)) - 1) - -(deftest read.8 - (let ((*package* (find-package "CL-TEST"))) - (with-input-from-string (s "X") (read s))) - |X|) - -(deftest read.9 - (with-input-from-string (s "1.2") (read s)) - 1.2) - -(deftest read.10 - (with-input-from-string (s "1.0s0") (read s)) - 1.0s0) - -(deftest read.11 - (with-input-from-string (s "1.0f0") (read s)) - 1.0f0) - -(deftest read.12 - (with-input-from-string (s "1.0d0") (read s)) - 1.0d0) - -(deftest read.13 - (with-input-from-string (s "1.0l0") (read s)) - 1.0l0) - -(deftest read.14 - (with-input-from-string (s "()") (read s)) - nil) - -(deftest read.15 - (with-input-from-string (s "(1 2 3)") (read s)) - (1 2 3)) - -;;; Throwing away whitespace chars - -(deftest read.16 - (with-standard-io-syntax - (with-input-from-string - (s ":ABC X") - (assert (eq (read s) :|ABC|)) - (read-char s))) - #\X) - -(deftest read.17 - (with-standard-io-syntax - (with-input-from-string - (s ":ABC X") - (assert (eq (read s) :|ABC|)) - (read-char s))) - #\Space) - -(deftest read.18 - (with-standard-io-syntax - (with-input-from-string - (s ":ABC(") - (assert (eq (read s) :|ABC|)) - (read-char s))) - #\() - -;;; eof value - -(deftest read.19 - (with-input-from-string - (s "") - (read s nil 'foo)) - foo) - -;;; Error tests - -(deftest read.error.1 - (signals-error (with-input-from-string (s "") (read s)) end-of-file) - t) - -(deftest read.error.2 - (signals-error (with-input-from-string (s "") (read s)) stream-error) - t) - -(deftest read.error.3 - (signals-error (with-input-from-string (s "") (read s t)) stream-error) - t) - -(deftest read.error.4 - (signals-error (with-input-from-string (s "(") (read s nil)) end-of-file) - t) - -(deftest read.error.5 - (signals-error (with-input-from-string (s "(") (read s t)) end-of-file) - t) - -(deftest read.error.6 - (signals-error (with-input-from-string (s "#(") (read s t)) end-of-file) - t) - -(deftest read.error.7 - (signals-error (with-input-from-string (s "#S(") (read s t)) end-of-file) - t) - -;;; Note -- cannot easily test calls with RECURSIVE-P set to T -;;; These have to be done from reader macro functions so that READ is not -;;; called without having any requisite dynamic environment created -;;; around the call. - -(deftest read.error.8 - (signals-error - (with-input-from-string - (s "1 2 3") - (read s nil nil nil nil)) - program-error) - t) diff --git a/t/ansi-test/reader/reader-test.lsp b/t/ansi-test/reader/reader-test.lsp deleted file mode 100644 index 9537ba9..0000000 --- a/t/ansi-test/reader/reader-test.lsp +++ /dev/null @@ -1,286 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Apr 8 20:03:45 1998 -;;;; Contains: Tests on readtables (just started, very incomplete) - -(in-package :cl-test) - - - -(def-syntax-test read-symbol.1 - (read-from-string "a") - a 1) - -(def-syntax-test read-symbol.2 - (read-from-string "|a|") - |a| 3) - -(def-syntax-test read-symbol.3 - (multiple-value-bind (s n) - (read-from-string "#:abc") - (not - (and (symbolp s) - (eql n 5) - (not (symbol-package s)) - (string-equal (symbol-name s) "abc")))) - nil) - -(def-syntax-test read-symbol.4 - (multiple-value-bind (s n) - (read-from-string "#:|abc|") - (not - (and (symbolp s) - (eql n 7) - (not (symbol-package s)) - (string= (symbol-name s) "abc")))) - nil) - -(def-syntax-test read-symbol.5 - (multiple-value-bind (s n) - (read-from-string "#:||") - (if (not (symbolp s)) - s - (not (not - (and (eql n 4) - (not (symbol-package s)) - (string= (symbol-name s) "")))))) - t) - -(def-syntax-test read-symbol.6 - (let ((str "cl-test::abcd0123")) - (multiple-value-bind (s n) - (read-from-string str) - (if (not (symbolp s)) - s - (not (not - (and (eql n (length str)) - (eqt (symbol-package s) (find-package :cl-test)) - (string-equal (symbol-name s) - "abcd0123"))))))) - t) - -(def-syntax-test read-symbol.7 - (multiple-value-bind (s n) - (read-from-string ":ABCD") - (if (not (symbolp s)) - s - (not (not - (and (eql n 5) - (eqt (symbol-package s) (find-package "KEYWORD")) - (string-equal (symbol-name s) - "ABCD")))))) - t) - -(defun read-symbol.9-body (natoms maxlen &optional (chars +standard-chars+)) - (loop - repeat natoms - count - (let* ((len (random (1+ maxlen))) - (actual-len 0) - (s (make-string (+ 2 (* 2 len)))) - (s2 (make-string len))) - (loop for j from 0 to (1- len) do - (let ((c (random-from-seq chars))) - (when (member c '(#\| #\\)) - (setf (elt s actual-len) #\\) - (incf actual-len)) - (setf (elt s actual-len) c) - (setf (elt s2 j) c) - (incf actual-len))) - (let ((actual-string (subseq s 0 actual-len))) - (multiple-value-bind (sym nread) - (read-from-string - (concatenate 'string "#:|" actual-string "|")) - (unless (and (symbolp sym) - (eql nread (+ 4 actual-len)) - (string-equal s2 (symbol-name sym))) - (let ((*print-readably* t)) - (format t "Symbol read failed: ~S (~S) read as ~S~%" - actual-string s2 sym)) - t)))))) - -(def-syntax-test read-symbol.9 - (read-symbol.9-body 1000 100) - 0) - -(def-syntax-test read-symbol.9a - (let ((chars (coerce (loop for i below (min 256 char-code-limit) - for c = (code-char i) - when c collect c) - 'string))) - (if (> (length chars) 0) - (read-symbol.9-body 1000 100) - 0)) - 0) - -(def-syntax-test read-symbol.9b - (let ((chars (coerce (loop for i below (min 65536 char-code-limit) - for c = (code-char i) - when c collect c) - 'string))) - (if (> (length chars) 0) - (read-symbol.9-body 1000 100) - 0)) - 0) - -(def-syntax-test read-symbol.10 - (equalt (symbol-name - (read-from-string - (with-output-to-string (s) - (write (make-symbol ":") - :readably t - :stream s)))) - ":") - t) - -(def-syntax-test read-symbol.11 - (loop for c across +standard-chars+ - for str = (make-array 2 :element-type 'character :initial-contents (list #\\ c)) - for sym = (read-from-string str) - unless (and (symbolp sym) - (eql sym (find-symbol (string c))) - (equal (symbol-name sym) (string c))) - collect (list c str sym)) - nil) - -(def-syntax-test read-symbol.12 - (loop for c across +standard-chars+ - for str = (make-array 2 :element-type 'base-char :initial-contents (list #\\ c)) - for sym = (read-from-string str) - unless (and (symbolp sym) - (eql sym (find-symbol (string c))) - (equal (symbol-name sym) (string c))) - collect (list c str sym)) - nil) - -(def-syntax-test read-symbol.13 - (loop for i below (min 65536 char-code-limit) - for c = (code-char i) - for str = (and c (make-array 2 :element-type 'character :initial-contents (list #\\ c))) - for sym = (and c (read-from-string str)) - unless (or (not c) - (and (symbolp sym) - (eql sym (find-symbol (string c))) - (equal (symbol-name sym) (string c)))) - collect (list c str sym)) - nil) - -(def-syntax-test read-symbol.14 - (loop for i = (random (min (ash 1 24) char-code-limit)) - for c = (code-char i) - for str = (and c (make-array 2 :element-type 'character :initial-contents (list #\\ c))) - for sym = (and c (read-from-string str)) - repeat 1000 - unless (or (not c) - (and (symbolp sym) - (eql sym (find-symbol (string c))) - (equal (symbol-name sym) (string c)))) - collect (list c str sym)) - nil) - -(def-syntax-test read-symbol.15 - (loop for c across "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ!@$%^&*_-+={}[]<>?/~" - for str = (string c) - for sym = (read-from-string str) - unless (eql sym (find-symbol (string (char-upcase c)))) - collect (list c str sym)) - nil) - -(def-syntax-test read-symbol.16 - (let ((*readtable* (copy-readtable))) - (setf (readtable-case *readtable*) :downcase) - (loop for c across "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ!@$%^&*_-+={}[]<>?/~" - for str = (string c) - for sym = (read-from-string str) - unless (eql sym (find-symbol (string (char-downcase c)))) - collect (list c str sym))) - nil) - -(def-syntax-test read-symbol.17 - (let ((*readtable* (copy-readtable))) - (setf (readtable-case *readtable*) :preserve) - (loop for c across "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ!@$%^&*_-+={}[]<>?/~" - for str = (string c) - for sym = (read-from-string str) - unless (eql sym (find-symbol str)) - collect (list c str sym))) - nil) - -(def-syntax-test read-symbol.18 - (let ((*readtable* (copy-readtable))) - (setf (readtable-case *readtable*) :invert) - (loop for c across "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ!@$%^&*_-+={}[]<>?/~" - for str = (string c) - for sym = (read-from-string str) - for c2 = (cond ((upper-case-p c) (char-downcase c)) - ((lower-case-p c) (char-upcase c)) - (t c)) - unless (eql sym (find-symbol (string c2))) - collect (list c c2 str sym))) - nil) - -(def-syntax-test read-symbol.19 - (read-from-string "123||") - |123| 5) - -(def-syntax-test read-symbol.20 - (read-from-string "123\\4") - |1234| 5) - -(def-syntax-test read-symbol.21 - (read-from-string "\\:1234") - |:1234| 6) - -(def-syntax-test read-symbol.22 - (read-from-string "||") - #.(intern "" (find-package "CL-TEST")) 2) - -(def-syntax-test read-symbol.23 - (loop for c across +standard-chars+ - for s = (concatenate 'string (string c) ".") - for sym = (intern (string-upcase s)) - when (alpha-char-p c) - nconc - (let ((sym2 (let ((*read-base* 36)) - (read-from-string s)))) - (if (eq sym sym2) - nil - (list c s sym sym2)))) - nil) - -(def-syntax-test read-symbol.24 - (loop for c1 = (random-from-seq +alpha-chars+) - for c2 = (random-from-seq +alpha-chars+) - for d1 = (loop repeat (random 4) collect (random-from-seq +digit-chars+)) - for d2 = (loop repeat (random 4) collect (random-from-seq +digit-chars+)) - for s = (concatenate 'string d1 (list c1 c2) d2) - for sym = (intern (string-upcase s)) - repeat 1000 - nconc - (let ((sym2 (read-from-string s))) - (if (eq sym sym2) - nil - (list c1 c2 d1 d2 s sym sym2)))) - nil) - -(def-syntax-test read-symbol.25 - (let ((potential-chars "01234567890123456789+-esdlf_^/") - (*readtable* (copy-readtable))) - (setf (readtable-case *readtable*) :preserve) - (loop for d1 = (loop repeat (random 6) - collect (random-from-seq potential-chars)) - for c = (random-from-seq potential-chars) - for d2 = (loop repeat (random 6) - collect (random-from-seq potential-chars)) - for s1 = (concatenate 'string d1 (list c) d2) - for sym1 = (intern s1) - for s2 = (concatenate 'string d1 (list #\\ c) d2) - for sym2 = (read-from-string s2) - repeat 1000 - unless (eql sym1 sym2) - collect (list d1 c d2 s1 sym1 s2 sym2))) - nil) - -(deftest read-float.1 - (eqlt -0.0 (- 0.0)) - t) diff --git a/t/ansi-test/reader/readtable-case.lsp b/t/ansi-test/reader/readtable-case.lsp deleted file mode 100644 index 0e9d3a8..0000000 --- a/t/ansi-test/reader/readtable-case.lsp +++ /dev/null @@ -1,112 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Jan 1 18:43:46 2005 -;;;; Contains: Tests of READTABLE-CASE - -(in-package :cl-test) - -;;; readtable-case setting - -(deftest readtable-case.1 - (with-standard-io-syntax - (readtable-case *readtable*)) - :upcase) - -(deftest readtable-case.2 - (with-standard-io-syntax - (let ((rt (copy-readtable))) - (readtable-case rt))) - :upcase) - -(deftest readtable-case.3 - (let ((rt (copy-readtable))) - (values - (setf (readtable-case rt) :upcase) - (readtable-case rt))) - :upcase :upcase) - -(deftest readtable-case.4 - (let ((rt (copy-readtable))) - (values - (setf (readtable-case rt) :downcase) - (readtable-case rt))) - :downcase :downcase) - -(deftest readtable-case.5 - (let ((rt (copy-readtable))) - (values - (setf (readtable-case rt) :preserve) - (readtable-case rt))) - :preserve :preserve) - -(deftest readtable-case.6 - (let ((rt (copy-readtable))) - (values - (setf (readtable-case rt) :invert) - (readtable-case rt))) - :invert :invert) - -(deftest readtable-case.7 - (let ((rt (copy-readtable))) - (loop for rtc in '(:upcase :downcase :preserve :invert) - do (setf (readtable-case rt) rtc) - nconc (let ((rt2 (copy-readtable rt))) - (unless (eq (readtable-case rt2) rtc) - (list rtc rt2))))) - nil) - -;; readtable-case reading -(symbol-macrolet ((lookup-table - '(:SYMBOL ("zebra" "Zebra" "ZEBRA" "zebr\\a" "zebr\\A" "ZEBR\\a" "ZEBR\\A" "Zebr\\a" "Zebr\\A") - :UPCASE (|ZEBRA| |ZEBRA| |ZEBRA| |ZEBRa| |ZEBRA| |ZEBRa| |ZEBRA| |ZEBRa| |ZEBRA|) - :DOWNCASE (|zebra| |zebra| |zebra| |zebra| |zebrA| |zebra| |zebrA| |zebra| |zebrA|) - :PRESERVE (|zebra| |Zebra| |ZEBRA| |zebra| |zebrA| |ZEBRa| |ZEBRA| |Zebra| |ZebrA|) - :INVERT (|ZEBRA| |Zebra| |zebra| |ZEBRa| |ZEBRA| |zebra| |zebrA| |Zebra| |ZebrA|)))) - (macrolet - ((def-readtable-case-test (reader-case) - `(deftest ,(make-symbol (concatenate 'string "READTABLE-CASE.CASE-" - (symbol-name reader-case))) - (let ((*readtable* (copy-readtable))) - (setf (readtable-case *readtable*) ,reader-case) - (mapcar #'(lambda (x) - (read-from-string x)) - ',(getf lookup-table :symbol))) - ,(getf lookup-table reader-case)))) - (def-readtable-case-test :upcase) - (def-readtable-case-test :downcase) - (def-readtable-case-test :preserve) - (def-readtable-case-test :invert))) - -;; when readtable was :invert quoted characters may get inverted too -(deftest readtable.case.invert-char - (let ((*readtable* (copy-readtable))) - (setf (readtable-case *readtable*) :invert) - (read-from-string "#\\a")) - #\a 3) - -;;; Error cases - -(deftest readtable-case.error.1 - (signals-error (readtable-case) program-error) - t) - -(deftest readtable-case.error.2 - (signals-error (readtable-case *readtable* nil) program-error) - t) - -(deftest readtable-case.error.3 - (check-type-error #'readtable-case (typef 'readtable)) - nil) - -(deftest readtable-case.error.4 - (check-type-error #'(lambda (x) - (let ((rt (copy-readtable))) - (setf (readtable-case rt) x))) - (typef '(member :upcase :downcase :preserve :invert))) - nil) - -(deftest readtable-case.error.5 - (check-type-error #'(lambda (x) (setf (readtable-case x) :upcase)) - (typef 'readtable)) - nil) - diff --git a/t/ansi-test/reader/readtablep.lsp b/t/ansi-test/reader/readtablep.lsp deleted file mode 100644 index 3626c07..0000000 --- a/t/ansi-test/reader/readtablep.lsp +++ /dev/null @@ -1,59 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Jan 1 19:19:42 2005 -;;;; Contains: Tests of READTABLEP - -(in-package :cl-test) - -(deftest readtablep.1 - (and (not (readtablep nil)) - (not (readtablep 'a)) - (not (readtablep 0)) - (not (readtablep 1/2)) - (not (readtablep 1.2)) - (not (readtablep 1.2s2)) - (not (readtablep 1.2f3)) - (not (readtablep 1.2e2)) - (not (readtablep 1.2d2)) - (not (readtablep (list 'a))) - (not (readtablep "abcde")) - (not (readtablep t)) - (not (readtablep '*readtable*)) - (not (readtablep (make-array '(10)))) - (not (readtablep (make-array '(10) :element-type 'fixnum))) - (not (readtablep (make-array '(10) :element-type 'float))) - (not (readtablep (make-array '(10) :element-type 'double-float))) - (not (readtablep (make-array '(10) :element-type 'string))) - (not (readtablep (make-array '(10) :element-type 'character))) - (not (readtablep (make-array '(10) :element-type 'bit))) - (not (readtablep (make-array '(10) :element-type 'boolean))) - (not (not (readtablep (copy-readtable)))) - (not (readtablep #'car)) - ) - t) - -(deftest readtablep.2 - (check-type-predicate #'readtablep 'readtable) - nil) - -(deftest readtablep.3 - (notnot-mv (readtablep *readtable*)) - t) - -(deftest readtablep.4 - (notnot-mv (readtablep (copy-readtable))) - t) - -;;; Error tests - -(deftest readtablep.error.1 - (signals-error (readtablep) program-error) - t) - -(deftest readtablep.error.2 - (signals-error (readtablep *readtable* nil) program-error) - t) - -(deftest readtablep.error.3 - (signals-error (readtablep *readtable* nil t t t t) program-error) - t) diff --git a/t/ansi-test/reader/set-macro-character.lsp b/t/ansi-test/reader/set-macro-character.lsp deleted file mode 100644 index c62cc37..0000000 --- a/t/ansi-test/reader/set-macro-character.lsp +++ /dev/null @@ -1,65 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Jan 3 10:37:16 2005 -;;;; Contains: Tests of SET-MACRO-CHARACTER - -(in-package :cl-test) - -(def-syntax-test set-macro-character.1 - (let ((*readtable* (copy-readtable)) - (*package* (find-package :cl-test))) - (let ((v1 (read-from-string "?!"))) - (assert (eql v1 '?!)) - (flet ((%f (stream char) - (declare (ignore stream)) - (assert (eql char #\?)) - 17)) - (let ((fn #'%f)) - (assert (equal (multiple-value-list - (set-macro-character #\? fn nil)) - '(t))) - (values - (multiple-value-list (read-from-string "?!")) - (multiple-value-list (read-from-string "!?"))))))) - (17 1) - (! 1)) - -(def-syntax-test set-macro-character.2 - (let ((rt (copy-readtable)) - (*package* (find-package :cl-test))) - (let ((v1 (read-from-string "?!"))) - (assert (eql v1 '?!)) - (flet ((%f (stream char) - (declare (ignore stream)) - (assert (eql char #\?)) - 17)) - (let ((fn #'%f)) - (assert (equal (multiple-value-list - (set-macro-character #\? fn t rt)) - '(t))) - (let ((*readtable* rt)) - (values - (multiple-value-list (read-from-string "?!")) - (multiple-value-list (read-from-string "!?")))))))) - (17 1) - (!? 2)) - -(defun set-macro-character.3-test-fn (stream char) - (declare (ignore stream)) - (assert (eql char #\?)) - :foo) - -(def-syntax-test set-macro-character.3 - (let ((*readtable* (copy-readtable)) - (*package* (find-package :cl-test))) - (let ((v1 (read-from-string "?!")) - (fn 'set-macro-character.3-test-fn)) - (assert (eql v1 '?!)) - (assert (equal (multiple-value-list - (set-macro-character #\? fn nil)) - '(t))) - (values - (multiple-value-list (read-from-string "?!")) - (multiple-value-list (read-from-string "!?"))))) - (:foo 1) - (! 1)) diff --git a/t/ansi-test/reader/set-syntax-from-char.lsp b/t/ansi-test/reader/set-syntax-from-char.lsp deleted file mode 100644 index d1d0381..0000000 --- a/t/ansi-test/reader/set-syntax-from-char.lsp +++ /dev/null @@ -1,473 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Jan 29 06:37:18 2005 -;;;; Contains: Tests of SET-SYNTAX-FROM-CHAR - -(in-package :cl-test) - - - -(defmacro def-set-syntax-from-char-test (name form &body expected-values) - `(deftest ,name - (with-standard-io-syntax - (let ((*readtable* (copy-readtable nil))) - (setf (readtable-case *readtable*) :preserve) - ,form)) - ,@expected-values)) - -;;; Test that constituent traits are not altered when a constituent character -;;; syntax type is set - -(defmacro def-set-syntax-from-char-trait-test (c test-form expected-value) - (setq c (typecase c - (character c) - ((or string symbol) (name-char (string c))) - (t nil))) - (when c - ;; (format t "~A ~A~%" c (char-name c)) - `(def-set-syntax-from-char-test - ,(intern (concatenate 'string "SET-SYNTAX-FROM-CHAR-TRAIT-X-" (or (char-name c) - (string c))) - :cl-test) - (let ((c ,c)) - (values - (set-syntax-from-char c #\X) - ,test-form)) - t ,expected-value))) - -(defmacro def-set-syntax-from-char-alphabetic-trait-test (c) - `(def-set-syntax-from-char-trait-test ,c - (let* ((*package* (find-package "CL-TEST")) - (sym (read-from-string (string c)))) - (list (let ((sym2 (find-symbol (string c)))) - (or (eqt sym sym2) - (list sym sym2))) - (or (equalt (symbol-name sym) (string c)) - (list (symbol-name sym) (string c))))) - (t t))) - -(loop for c across "\\|!\"#$%&'()*,;<=>?@[]^_`~{}+-/abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" - do (eval `(def-set-syntax-from-char-alphabetic-trait-test ,c))) - -;;; The invalid constituent character trait of invalid and whitespace characters -;;; is exposed when they are turned into constituent characters - -(defmacro def-set-syntax-from-char-invalid-trait-test (c) - `(def-set-syntax-from-char-trait-test ,c - (handler-case - (let* ((*package* (find-package "CL-TEST")) - (sym (read-from-string (concatenate 'string (string c) "Z")))) - sym) - (reader-error (c) (declare (ignore c)) :good)) - :good)) - -(loop for name in '("Backspace" "Tab" "Newline" "Linefeed" "Page" "Return" "Space" "Rubout") - do (eval `(def-set-syntax-from-char-invalid-trait-test ,name))) - -;;; Turning characters into single escape characters - -(deftest set-syntax-from-char.single-escape.1 - (loop for c across +standard-chars+ - nconc - (with-standard-io-syntax - (let ((*readtable* (copy-readtable nil)) - (*package* (find-package "CL-TEST"))) - (let ((results - (list - (set-syntax-from-char c #\\) - (read-from-string (concatenate 'string (list c #\Z)))))) - (unless (equal results '(t |Z|)) - (list (list c results))))))) - nil) - -(deftest set-syntax-from-char.single-escape.2 - (loop for c across +standard-chars+ - unless (eql c #\") - nconc - (with-standard-io-syntax - (let ((*readtable* (copy-readtable nil)) - (*package* (find-package "CL-TEST"))) - (let ((results - (list - (set-syntax-from-char c #\\) - (read-from-string (concatenate 'string - (list #\" c #\" #\")))))) - (unless (equal results '(t "\"")) - (list (list c results))))))) - nil) - - -(deftest set-syntax-from-char.multiple-escape - (loop for c across +standard-chars+ - nconc - (with-standard-io-syntax - (let ((*readtable* (copy-readtable nil)) - (*package* (find-package "CL-TEST"))) - (let ((results - (list - (set-syntax-from-char c #\|) - (handler-case - (read-from-string (concatenate 'string (list c #\Z c))) - (error (c) c)) - (handler-case - (read-from-string (concatenate 'string (list c #\z #\|))) - (error (c) c)) - (handler-case - (read-from-string (concatenate 'string (list #\| #\Z c))) - (error (c) c))))) - (unless (or (eql c #\Z) (eql c #\z) (equal results '(t |Z| |z| |Z|))) - (list (list c results))))))) - nil) - -(deftest set-syntax-from-char.semicolon - (loop for c across +standard-chars+ - nconc - (with-standard-io-syntax - (let ((*readtable* (copy-readtable nil)) - (*package* (find-package "CL-TEST")) - (expected (if (eql c #\0) '1 '0)) - (c2 (if (eql c #\0) #\1 #\0))) - (let ((results - (list - (set-syntax-from-char c #\;) - (handler-case - (read-from-string (concatenate 'string (list c2 c #\2))) - (error (c) c)) - (handler-case - (read-from-string (concatenate 'string (list c2 c #\2 #\Newline #\3))) - (error (c) c)) - (handler-case - (read-from-string (concatenate 'string (list c #\2 #\Newline c2))) - (error (c) c))))) - (unless (equal results (list t expected expected expected)) - (list (list c results))))))) - nil) - -(deftest set-syntax-from-char.left-paren - (loop for c across +standard-chars+ - unless (find c ")") - nconc - (with-standard-io-syntax - (let ((*readtable* (copy-readtable nil)) - (*package* (find-package "CL-TEST")) - (expected (if (eql c #\0) '(1) '(0))) - (c2 (if (eql c #\0) #\1 #\0))) - (let ((results - (list - (set-syntax-from-char c #\() - (handler-case - (read-from-string (concatenate 'string (list c) ")")) - (error (c) c)) - (handler-case - (read-from-string (concatenate 'string (list c c2) ")2" (list #\Newline #\3))) - (error (c) c)) - (handler-case - (read-from-string (concatenate 'string (list c c2) ")")) - (error (c) c))))) - (unless (equal results (list t nil expected expected)) - (list (list c results))))))) - nil) - -(deftest set-syntax-from-char.right-paren - (loop for c across +standard-chars+ - nconc - (with-standard-io-syntax - (let ((*readtable* (copy-readtable nil)) - (*package* (find-package "CL-TEST"))) - (let ((results - (list - (set-syntax-from-char c #\)) - (handler-case - (read-from-string (string c) nil nil) - (reader-error (c) :good) - (error (c) c))))) - (unless (equal results '(t :good)) - (list (list c results))))))) - nil) - -(deftest set-syntax-from-char.single-quote - (loop for c across +standard-chars+ - nconc - (with-standard-io-syntax - (let ((*readtable* (copy-readtable nil)) - (*package* (find-package "CL-TEST")) - (expected (if (eql c #\0) ''1 ''0)) - (c2 (if (eql c #\0) #\1 #\0))) - (let ((results - (list - (set-syntax-from-char c #\') - (handler-case - (read-from-string (concatenate 'string (list c c2))) - (error (c) c)) - (handler-case - (read-from-string (concatenate 'string (list c c2) " 2")) - (error (c) c)) - (handler-case - (read-from-string (concatenate 'string (list c c2) ")")) - (error (c) c))))) - (unless (equal results (list t expected expected expected)) - (list (list c results))))))) - nil) - -;;; I do not test that setting syntax from #\" allows the character to be -;;; used as the terminator of a double quoted string. It is not clear that -;;; the standard implies this. - -(deftest set-syntax-from-char.double-quote - (loop for c across +standard-chars+ - nconc - (with-standard-io-syntax - (let ((*readtable* (copy-readtable nil)) - (*package* (find-package "CL-TEST")) - (expected (if (eql c #\0) "1" "0")) - (c2 (if (eql c #\0) #\1 #\0))) - (let ((results - (list - (set-syntax-from-char c #\") - (handler-case - (read-from-string - (concatenate 'string (list c c2 c))) - (error (c) c)) - (handler-case - (read-from-string - (concatenate 'string (list c c2 c #\2))) - (error (c) c)) - (handler-case - (read-from-string (concatenate 'string (list c c2 c) ")")) - (error (c) c))))) - (unless (equal results (list t expected expected expected)) - (list (list c results))))))) - nil) - -(deftest set-syntax-from-char.backquote - (loop for c across +standard-chars+ - unless (find c ",x") - nconc - (with-standard-io-syntax - (let* ((*readtable* (copy-readtable nil)) - (*package* (find-package "CL-TEST")) - (c2 (if (eql c #\Space) #\Newline #\Space)) - (results - (list - (set-syntax-from-char c #\`) - (handler-case - (eval `(let ((x 0)) - ,(read-from-string - (concatenate 'string (list c #\, #\x))))) - (error (c) c)) - (handler-case - (eval `(let ((x 0)) - ,(read-from-string - (concatenate 'string (list c #\, #\x c2))))) - (error (c) c)) - (handler-case - (eval `(let ((x 0)) - ,(read-from-string - (concatenate 'string (list c c2 #\, #\x c2))))) - (error (c) c))))) - (unless (equal results '(t 0 0 0)) - (list (list c results)))))) - nil) - -(deftest set-syntax-from-char.comma - (loop for c across +standard-chars+ - unless (find c "`x") - nconc - (with-standard-io-syntax - (let* ((*readtable* (copy-readtable nil)) - (*package* (find-package "CL-TEST")) - (c2 (if (eql c #\Space) #\Newline #\Space)) - (results - (list - (set-syntax-from-char c #\,) - (handler-case - (read-from-string (string c)) - (reader-error (c) :good) - (error (c) c)) - (handler-case - (eval `(let ((x 0)) - ,(read-from-string - (concatenate 'string "`" (list c) "x")))) - (error (c) c))))) - (unless (equal results '(t :good 0)) - (list (list c results)))))) - nil) - -;;; Tests of set-syntax-from-char on #\# - -(deftest set-syntax-from-char.sharp.1 - (loop for c across +standard-chars+ - nconc - (with-standard-io-syntax - (let* ((*readtable* (copy-readtable nil)) - (*package* (find-package "CL-TEST")) - (results - (list - (set-syntax-from-char c #\#) - (if (not (eql c #\Space)) - (handler-case - (read-from-string - (concatenate 'string (list c #\Space))) - (reader-error () :good) - (error (c) c)) - :good) - (if (not (find c "'X")) - (handler-case - (read-from-string - (concatenate 'string (list c) "'X")) - (error (c) c)) - '#'|X|) - (if (not (find c "(X)")) - (handler-case - (read-from-string - (concatenate 'string (list c) "(X)")) - (error (c) c)) - #(|X|)) - (if (not (find c ")")) - (handler-case - (read-from-string - (concatenate 'string (list c) ")")) - (reader-error (c) :good) - (error (c) c)) - :good) - (if (not (find c "*")) - (handler-case - (read-from-string - (concatenate 'string (list c #\*))) - (error (c) c)) - #*) - (if (not (find c ":|")) - (handler-case - (let ((sym (read-from-string - (concatenate 'string (list c) ":||")))) - (and (symbolp sym) - (null (symbol-package sym)) - (symbol-name sym))) - (error (c) c)) - "") - (handler-case - (read-from-string - (concatenate 'string (list c #\<))) - (reader-error (c) :good) - (error (c) c)) - (handler-case - (read-from-string - (concatenate 'string (list c #\\ #\X))) - (error (c) c)) - (if (not (find c "1")) - (handler-case - (read-from-string - (concatenate 'string (list c) "|1111|#1")) - (error (c) c)) - 1) - (if (not (find c "1")) - (handler-case - (read-from-string - (concatenate 'string (list c) "|11#|111|#11|#1")) - (error (c) c)) - 1) - ))) - (unless (equalp results '(t :good #'|X| #(|X|) :good #* "" :good #\X 1 1)) - (list (list c results)))))) - nil) - -(deftest set-syntax-from-char.sharp.2 - (loop for c across +standard-chars+ - nconc - (with-standard-io-syntax - (let* ((*readtable* (copy-readtable nil)) - (*package* (find-package "CL-TEST")) - (results - (list - (set-syntax-from-char c #\#) - (if (not (find c "+XC ")) - (handler-case - (let ((*features* (cons ':X *features*))) - (read-from-string - (concatenate 'string (list c) "+X C"))) - (error (c) c)) - 'c) - (if (not (find c "-(OR)")) - (handler-case - (read-from-string - (concatenate 'string (list c) "-(OR)R")) - (error (c) c)) - 'r) - (if (not (find c ".1")) - (handler-case - (read-from-string - (concatenate 'string (list c) ".1")) - (error (c) c)) - 1) - (if (not (find c "01aA")) - (handler-case - (list - (read-from-string - (concatenate 'string (list c) "0a1")) - (read-from-string - (concatenate 'string (list c) "0A1"))) - (error (c) c)) - '(#0a1 #0a1)) - (if (not (find c "01bB")) - (handler-case - (list - (read-from-string - (concatenate 'string (list c) "b101")) - (read-from-string - (concatenate 'string (list c) "B011"))) - (error (c) c)) - '(5 3)) - (if (not (find c "cC()12 ")) - (handler-case - (list - (read-from-string - (concatenate 'string (list c) "c(1 2)")) - (read-from-string - (concatenate 'string (list c) "C(2 1)"))) - (error (c) c)) - '(#c(1 2) #c(2 1))) - (if (not (find c "oO0127")) - (handler-case - (list - (read-from-string - (concatenate 'string (list c) "o172")) - (read-from-string - (concatenate 'string (list c) "O7721"))) - (error (c) c)) - '(#o172 #o7721)) - (if (not (find c "pP\"")) - (handler-case - (list - (read-from-string - (concatenate 'string (list c) "p\"\"")) - (read-from-string - (concatenate 'string (list c) "P\"\""))) - (error (c) c)) - '(#p"" #p"")) - (if (not (find c "rR0123")) - (handler-case - (list - (read-from-string - (concatenate 'string (list c) "3r210")) - (read-from-string - (concatenate 'string (list c) "3R1111"))) - (error (c) c)) - '(#3r210 #3r1111)) - ;;; Add #s test here - (if (not (find c "xX04dF")) - (handler-case - (list - (read-from-string - (concatenate 'string (list c) "x40Fd")) - (read-from-string - (concatenate 'string (list c) "XFd04"))) - (error (c) c)) - '(#x40fd #xfd04)) - ))) - (unless (equalp results - '(t c r 1 (#0a1 #0a1) (5 3) (#c(1 2) #c(2 1)) - (#o172 #o7721) (#p"" #p"") (#3r210 #3r1111) - (#x40fd #xfd04))) - (list (list c results))) - ))) - nil) diff --git a/t/ansi-test/reader/syntax-tokens.lsp b/t/ansi-test/reader/syntax-tokens.lsp deleted file mode 100644 index c41c6c6..0000000 --- a/t/ansi-test/reader/syntax-tokens.lsp +++ /dev/null @@ -1,138 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Jan 14 07:43:24 2005 -;;;; Contains: Tests of reading of tokens - -(in-package :cl-test) - - - -;; Erroneous numbers - -(def-syntax-test syntax.number-token.error.1 - (signals-error (read-from-string "1/0") reader-error) - t) - -#| -(def-syntax-test syntax.number-token.error.2 - (loop for f in (list most-positive-short-float - most-positive-single-float - most-positive-double-float - most-positive-long-float) - for c across "sfdl" - for r = (float-radix f) - for x = (nth-value 1 (decode-float f)) - for n = (1+ (ceiling (* (log r 10) x))) - for s = (format nil "1.0~C~D" c n) - for vals = (multiple-value-list - (eval `(signals-error (read-from-string ,s) - reader-error))) - unless (equal vals '(t)) - collect (list f c r x n s vals)) - nil) -|# - -(def-syntax-test syntax.number-token.3 - (loop for tp in '(short-float single-float double-float long-float) - for c across "sfdl" - for s = (concatenate 'string "1.0" - (make-string 1000 :initial-element #\0) - "1" (string c) "0") - for n = (read-from-string s) - unless (and (typep n tp) - (<= 1 n) - (< n 2)) - collect (list c tp s n)) - nil) - -(def-syntax-test syntax.number-token.4 - (loop for type in '(short-float single-float double-float long-float) - nconc - (let* ((*read-default-float-format* type) - (s (concatenate 'string - "1." (make-string 1000 :initial-element #\0) - "1")) - (n (read-from-string s))) - (unless (and (typep n type) - (<= 1 n) - (< n 2)) - (list (list type s n))))) - nil) - - -;;; Dot tokens - -(def-syntax-test syntax.dot-token.1 - (read-from-string "\\.") - |.| 2) - -(def-syntax-test syntax.dot-token.2 - (read-from-string ".\\.") - |..| 3) - -(def-syntax-test syntax.dot-token.3 - (read-from-string "\\..") - |..| 3) - -(def-syntax-test syntax.dot-token.4 - (read-from-string "..\\.") - |...| 4) - -(def-syntax-test syntax.dot-token.5 - (read-from-string ".\\..") - |...| 4) - -(def-syntax-test syntax.dot-token.6 - (read-from-string "\\...") - |...| 4) - -(def-syntax-test syntax.dot-token.7 - (read-from-string ".||") - |.| 3) - -(def-syntax-test syntax.dot-token.8 - (read-from-string "..||") - |..| 4) - -(def-syntax-test syntax.dot-error.1 - (signals-error (read-from-string ".") reader-error) - t) - -(def-syntax-test syntax.dot-error.2 - (signals-error (read-from-string "..") reader-error) - t) - -(def-syntax-test syntax.dot-error.3 - (signals-error (read-from-string "...") reader-error) - t) - -(def-syntax-test syntax.dot-error.4 - (signals-error (read-from-string "( . 1)") reader-error) - t) - -(def-syntax-test syntax.dot-error.5 - (signals-error (read-from-string "(1 ..)") reader-error) - t) - -(def-syntax-test syntax.dot-error.6 - (signals-error (read-from-string "(1 .. 2)") reader-error) - t) - -(def-syntax-test syntax.dot-error.7 - (signals-error (read-from-string "#(1 . 2)") reader-error) - t) - -;;; right paren - -(def-syntax-test syntax.right-paren-error.1 - (signals-error (read-from-string ")") reader-error) - t) - -(def-syntax-test syntax.comma-error.1 - (signals-error (read-from-string ",") reader-error) - t) - -(def-syntax-test syntax.comma-error.2 - (signals-error (read-from-string ",1") reader-error) - t) - diff --git a/t/ansi-test/reader/syntax.lsp b/t/ansi-test/reader/syntax.lsp deleted file mode 100644 index 8835a44..0000000 --- a/t/ansi-test/reader/syntax.lsp +++ /dev/null @@ -1,1148 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jan 2 08:12:51 2005 -;;;; Contains: Tests of standard syntax - -(in-package :cl-test) - - - -(def-syntax-test syntax.whitespace.1 - ;; Check that various standard or semistandard characters are whitespace[2] - (let ((names '("Tab" "Newline" "Linefeed" "Space" "Return" "Page"))) - (loop for name in names - for c = (name-char name) - nconc - (when c - (let* ((s (concatenate 'string (string c) "123")) - (val (read-from-string s))) - (unless (eql val 123) - (list (list name c s val))))))) - nil) - -(def-syntax-test syntax.constituent.1 - ;; Tests of various characters that they are constituent characters, - ;; and parse to symbols - (let ((chars (concatenate - 'string - "!$%&*<=>?@[]^_-{}+/" - "abcdefghijklmnopqrstuvwxyz" - "ABCDEFGHIJKLMNOPQRSTUVWXYZ"))) - (loop for c across chars - for s = (string c) - for sym = (read-from-string s) - unless (string= (symbol-name sym) (string-upcase s)) - collect (list c sym))) - nil) - -;;; Backspace is an invalid constituent character - -(def-syntax-test syntax.backspace.invalid - (let ((c (name-char "Backspace"))) - (if (not c) t - (eval `(signals-error (read-from-string (string ,c)) reader-error)))) - t) - -;;; Rubout is an invalid constituent character - -(def-syntax-test syntax.rubout.invalid - (let ((c (name-char "Rubout"))) - (if (not c) t - (eval `(signals-error (read-from-string (string ,c)) reader-error)))) - t) - -;;; Digits are alphabetic if >= the read base - -(def-syntax-test syntax.digits.alphabetic.1 - (loop for base from 2 to 9 - nconc - (let ((*read-base* base)) - (loop for digit-val from base to 9 - for c = (elt "0123456789" digit-val) - for s = (string c) - for val = (read-from-string s) - unless (and (symbolp val) - (string= s (symbol-name val))) - collect (list base digit-val c s val)))) - nil) - -;;; Reading escaped characters - -(def-syntax-test syntax.escaped.1 - (loop for c across +standard-chars+ - for s0 = (string c) - for s = (concatenate 'string "\\" s0) - for sym = (read-from-string s) - unless (and (symbolp sym) - (string= (symbol-name sym) s0)) - collect (list c s0 s sym)) - nil) - -(def-syntax-test syntax.escaped.2 - (let ((count 0)) - (loop for i from 0 below (min 65536 char-code-limit) - for c = (code-char i) - for s0 = (and c (string c)) - for s = (and c (concatenate 'string "\\" s0)) - for sym = (and c (read-from-string s)) - unless (or (not c) - (and (symbolp sym) - (string= (symbol-name sym) s0))) - collect (progn - (when (> (incf count) 100) (loop-finish)) - (list i c s0 s sym)))) - nil) - -(def-syntax-test syntax.escaped.3 - (loop for i = (random (min char-code-limit (ash 1 24))) - for c = (code-char i) - for s0 = (and c (string c)) - for s = (and c (concatenate 'string "\\" s0)) - for sym = (and c (read-from-string s)) - repeat 1000 - unless (or (not c) - (and (symbolp sym) - (string= (symbol-name sym) s0))) - collect (list i c s0 s sym)) - nil) - -(def-syntax-test syntax.escaped.4 - (loop for c across +standard-chars+ - for bad = (find c "\\|") - for s0 = (string c) - for s = (concatenate 'string "|" s0 "|") - for sym = (and (not bad) (read-from-string s)) - unless (or bad - (and (symbolp sym) - (string= (symbol-name sym) s0))) - collect (list c s0 s sym)) - nil) - -(def-syntax-test syntax.escaped.5 - (let ((count 0)) - (loop for i from 0 below (min 65536 char-code-limit) - for c = (code-char i) - for bad = (or (not c) (find c "\\|")) - for s0 = (and c (string c)) - for s = (and c (concatenate 'string "|" s0 "|")) - for sym = (and c (not bad) (read-from-string s)) - unless (or bad - (and (symbolp sym) - (string= (symbol-name sym) s0))) - collect (progn - (when (> (incf count) 100) (loop-finish)) - (list c s0 s sym)))) - nil) - -(def-syntax-test syntax.escaped.6 - (loop for i = (random (min char-code-limit (ash 1 24))) - for c = (code-char i) - for bad = (or (not c) (find c "\\|")) - for s0 = (and c (string c)) - for s = (and c (concatenate 'string "|" s0 "|")) - for sym = (and (not bad) (read-from-string s)) - repeat 1000 - unless (or bad - (and (symbolp sym) - (string= (symbol-name sym) s0))) - collect (list c s0 s sym)) - nil) - -(def-syntax-test syntax.escape.whitespace.1 - (let ((names '("Tab" "Newline" "Linefeed" "Space" "Return" "Page" - "Rubout" "Backspace"))) - (loop for name in names - for c = (name-char name) - nconc - (when c - (let* ((s (concatenate 'string "\\" (string c))) - (val (read-from-string s))) - (unless (eql val (intern (string c))) - (list (list name c s val))))))) - nil) - -;;; -;;; CLtS appears to be inconsistent on the next test. -;;; Compare the definition of 'invalid' with the specification -;;; of the token reading algorithm. -;;; -(def-syntax-test syntax.escape.whitespace.2 - (let ((names '("Tab" "Newline" "Linefeed" "Space" "Return" "Page"))) - (loop for name in names - for c = (name-char name) - nconc - (when c - (let* ((s (concatenate 'string "|" (string c) "|")) - (val (read-from-string s))) - (unless (eql val (intern (string c))) - (list (list name c s val))))))) - nil) - -#| -(def-syntax-test syntax.multiple-escape.invalid.backspace - (let ((c (name-char "Backspace"))) - (or (not c) - (let ((s (concatenate 'string "|" (string c) "|"))) - (eval `(signals-error (read-from-string ',s) reader-error))))) - t) - -(def-syntax-test syntax.multiple-escape.invalid.rubout - (let ((c (name-char "Rubout"))) - (or (not c) - (let ((s (concatenate 'string "|" (string c) "|"))) - (eval `(signals-error (read-from-string ',s) reader-error))))) - t) -|# - - -;;; Tests of #\ - -(def-syntax-test syntax.sharp-backslash.1 - (loop for c across +standard-chars+ - for s = (concatenate 'string "#\\" (string c)) - for c2 = (read-from-string s) - unless (eql c c2) - collect (list c s c2)) - nil) - -(def-syntax-test syntax.sharp-backslash.2 - (let ((count 0)) - (loop for i below (min 65536 char-code-limit) - for c = (code-char i) - for s = (and c (concatenate 'string "#\\" (string c))) - for c2 = (and c (read-from-string s)) - unless (eql c c2) - collect (progn (when (> (incf count) 100) (loop-finish)) - (list c s c2)))) - nil) - -(def-syntax-test syntax.sharp-backslash.3 - (loop for i = (random (min (ash 1 24) char-code-limit)) - for c = (code-char i) - for s = (and c (concatenate 'string "#\\" (string c))) - for c2 = (and c (read-from-string s)) - repeat 1000 - unless (eql c c2) - collect (list i c s c2)) - nil) - -(def-syntax-test syntax.sharp-backslash.4 - (flet ((%f (s) (read-from-string (concatenate 'string "#\\" s)))) - (loop for s in '("SPACE" "NEWLINE" "TAB" "RUBOUT" "BACKSPACE" "PAGE" "LINEFEED" "RETURN") - for c = (name-char s) - unless (or (null c) - (and (eql (%f s) c) - (eql (%f (string-downcase s)) c) - (eql (%f (string-capitalize s)) c))) - collect (list s c))) - nil) - -(def-syntax-test syntax.sharp-backslash.5 - (flet ((%f (s) (read-from-string (concatenate 'string "#\\" s)))) - (let ((good-chars (concatenate 'string +alphanumeric-chars+ - "<,.>\"':/?[]{}~`!@#$%^&*_-+="))) - (loop for c across +standard-chars+ - for name = (char-name c) - unless (or (null name) - (string/= "" (string-trim good-chars name)) - (and (eql (%f name) c) - (eql (%f (string-downcase name)) c) - (eql (%f (string-upcase name)) c) - (eql (%f (string-capitalize name)) c))) - collect (list c name)))) - nil) - -(def-syntax-test syntax.sharp-backslash.6 - (flet ((%f (s) (read-from-string (concatenate 'string "#\\" s)))) - (let ((good-chars (concatenate 'string +alphanumeric-chars+ - "<,.>\"':/?[]{}~`!@#$%^&*_-+="))) - (loop for i below (min 65536 char-code-limit) - for c = (code-char i) - for name = (and c (char-name c)) - unless (or (null name) - (string/= "" (string-trim good-chars name)) - (and (eql (%f name) c) - (eql (%f (string-downcase name)) c) - (eql (%f (string-upcase name)) c) - (eql (%f (string-capitalize name)) c))) - collect (list i c name)))) - nil) - -(def-syntax-test syntax.sharp-backslash.7 - (flet ((%f (s) (read-from-string (concatenate 'string "#\\" s)))) - (let ((good-chars (concatenate 'string +alphanumeric-chars+ - "<,.>\"':/?[]{}~`!@#$%^&*_-+="))) - (loop for i = (random (min (ash 1 24) char-code-limit)) - for c = (code-char i) - for name = (and c (char-name c)) - repeat 1000 - unless (or (null name) - (string/= "" (string-trim good-chars name)) - (and (eql (%f name) c) - (eql (%f (string-downcase name)) c) - (eql (%f (string-upcase name)) c) - (eql (%f (string-capitalize name)) c))) - collect (list i c name)))) - nil) - - -;;; Tests of #' - -(def-syntax-test syntax.sharp-quote.1 - (read-from-string "#'X") - (function |X|) 3) - -(def-syntax-test syntax.sharp-quote.2 - (read-from-string "#':X") - (function :|X|) 4) - -(def-syntax-test syntax.sharp-quote.3 - (read-from-string "#'17") - (function 17) 4) - -(def-syntax-test syntax.sharp-quote.error.1 - (signals-error (read-from-string "#'") end-of-file) - t) - -(def-syntax-test syntax.sharp-quote.error.2 - (signals-error (read-from-string "(#'" nil nil) end-of-file) - t) - -;;; Tess of #(...) - -(def-syntax-vector-test syntax.sharp-left-paren.1 - "#()") - -(def-syntax-vector-test syntax.sharp-left-paren.2 - "#0()") - -(def-syntax-vector-test syntax.sharp-left-paren.3 - "#(a)" a) - -(def-syntax-vector-test syntax.sharp-left-paren.4 - "#(a b c)" a b c) - -(def-syntax-vector-test syntax.sharp-left-paren.5 - "#2(a)" a a) - -(def-syntax-vector-test syntax.sharp-left-paren.6 - "#5(a b)" a b b b b) - -(def-syntax-vector-test syntax.sharp-left-paren.7 - "#5(a b c d e)" a b c d e) - -(def-syntax-vector-test syntax.sharp-left-paren.8 - "#9(a b c d e)" a b c d e e e e e) - -(def-syntax-test syntax.sharp-left-paren.9 - (let ((*read-base* 2)) - (read-from-string "#10(a)")) - #(a a a a a a a a a a) - 6) - -(def-syntax-test syntax.sharp-left-paren.error.1 - (signals-error (read-from-string "#(") end-of-file) - t) - -(def-syntax-test syntax.sharp-left-paren.error.2 - (signals-error (read-from-string "(#(" nil nil) end-of-file) - t) - -;;; Tests of #* - -(def-syntax-bit-vector-test syntax.sharp-asterisk.1 - "#*") - -(def-syntax-bit-vector-test syntax.sharp-asterisk.2 - "#0*") - -(def-syntax-bit-vector-test syntax.sharp-asterisk.3 - "#1*0" 0) - -(def-syntax-bit-vector-test syntax.sharp-asterisk.4 - "#1*1" 1) - -(def-syntax-bit-vector-test syntax.sharp-asterisk.5 - "#2*1" 1 1) - -(def-syntax-bit-vector-test syntax.sharp-asterisk.6 - "#2*0" 0 0) - -(def-syntax-bit-vector-test syntax.sharp-asterisk.7 - "#5*010" 0 1 0 0 0) - -(def-syntax-bit-vector-test syntax.sharp-asterisk.8 - "#7*0101" 0 1 0 1 1 1 1) - -(def-syntax-bit-vector-test syntax.sharp-asterisk.9 - "#10*01010" 0 1 0 1 0 0 0 0 0 0) - -(def-syntax-test syntax.sharp-asterisk.10 - (let ((*read-base* 3)) - (read-from-string "#10*01")) - #*0111111111 - 6) - -(def-syntax-test syntax.sharp-asterisk.11 - (let ((*read-suppress* t)) - (values (read-from-string "#1* "))) - nil) - -(def-syntax-test syntax.sharp-asterisk.12 - (let ((*read-suppress* t)) - (values (read-from-string "#1*00"))) - nil) - -(def-syntax-test syntax.sharp-asterisk.13 - (let ((*read-suppress* t)) - (values (read-from-string "#*012"))) - nil) - -(def-syntax-test syntax.sharp-asterisk.error.1 - (signals-error (read-from-string "#1* X") reader-error) - t) - -(def-syntax-test syntax.sharp-asterisk.error.2 - (signals-error (read-from-string "#2*011") reader-error) - t) - -(def-syntax-test syntax.sharp-asterisk.error.3 - (signals-error (read-from-string "#*012") reader-error) - t) - -;;; Tests of #: ... - -; (def-syntax-unintern-test syntax.sharp-colon.1 "") -; (def-syntax-unintern-test syntax.sharp-colon.2 "#") -(def-syntax-unintern-test syntax.sharp-colon.3 "a") -(def-syntax-unintern-test syntax.sharp-colon.4 "A") -(def-syntax-unintern-test syntax.sharp-colon.5 "NIL") -(def-syntax-unintern-test syntax.sharp-colon.6 "T") -(def-syntax-unintern-test syntax.sharp-colon.7 ".") - - -;;; Tests of #. - -(def-syntax-test syntax.sharp-dot.1 - (read-from-string "#.(+ 1 2)") - 3 9) - -(def-syntax-test syntax.sharp-dot.2 - (read-from-string "#.'X") - X 4) - -(def-syntax-test syntax.sharp-dot.error.1 - (signals-error (read-from-string "#.") end-of-file) - t) - -(def-syntax-test syntax.sharp-dot.error.2 - (signals-error (read-from-string "(#." nil nil) end-of-file) - t) - -(def-syntax-test syntax.sharp-dot.error.3 - (signals-error (let ((*read-eval* nil)) (read-from-string "#.1")) reader-error) - t) - -;;; Tests of #B - -(def-syntax-test syntax.sharp-b.1 - (read-from-string "#b0") - 0 3) - -(def-syntax-test syntax.sharp-b.2 - (read-from-string "#B1") - 1 3) - -(def-syntax-test syntax.sharp-b.3 - (read-from-string "#b101101") - 45 8) - -(def-syntax-test syntax.sharp-b.4 - (read-from-string "#B101101") - 45 8) - -(def-syntax-test syntax.sharp-b.5 - (read-from-string "#b010001/100") - 17/4 12) - -(def-syntax-test syntax.sharp-b.6 - (read-from-string "#b-10011") - -19 8) - -(def-syntax-test syntax.sharp-b.7 - (read-from-string "#B-1/10") - -1/2 7) - -(def-syntax-test syntax.sharp-b.8 - (read-from-string "#B-0/10") - 0 7) - -(def-syntax-test syntax.sharp-b.9 - (read-from-string "#b0/111") - 0 7) - -(def-syntax-test syntax.sharp-b.10 - (let ((*read-eval* nil)) - (read-from-string "#b-10/11")) - -2/3 8) - -;;; Tests of #O - -(def-syntax-test syntax.sharp-o.1 - (read-from-string "#o0") - 0 3) - -(def-syntax-test syntax.sharp-o.2 - (read-from-string "#O7") - 7 3) - -(def-syntax-test syntax.sharp-o.3 - (read-from-string "#o10") - 8 4) - -(def-syntax-test syntax.sharp-o.4 - (read-from-string "#O011") - 9 5) - -(def-syntax-test syntax.sharp-o.5 - (read-from-string "#o-0") - 0 4) - -(def-syntax-test syntax.sharp-o.6 - (read-from-string "#O-1") - -1 4) - -(def-syntax-test syntax.sharp-o.7 - (read-from-string "#O11/10") - 9/8 7) - -(def-syntax-test syntax.sharp-o.8 - (read-from-string "#o-1/10") - -1/8 7) - -(def-syntax-test syntax.sharp-o.9 - (read-from-string "#O0/10") - 0 6) - -(def-syntax-test syntax.sharp-o.10 - (let ((*read-eval* nil)) - (read-from-string "#o-10/11")) - -8/9 8) - -;;; Tests of #X - -(def-syntax-test syntax.sharp-x.1 - (read-from-string "#x0") - 0 3) - -(def-syntax-test syntax.sharp-x.2 - (read-from-string "#X1") - 1 3) - -(def-syntax-test syntax.sharp-x.3 - (read-from-string "#xa") - 10 3) - -(def-syntax-test syntax.sharp-x.4 - (read-from-string "#Xb") - 11 3) - -(def-syntax-test syntax.sharp-x.5 - (read-from-string "#XC") - 12 3) - -(def-syntax-test syntax.sharp-x.6 - (read-from-string "#xD") - 13 3) - -(def-syntax-test syntax.sharp-x.7 - (read-from-string "#xe") - 14 3) - -(def-syntax-test syntax.sharp-x.8 - (read-from-string "#Xf") - 15 3) - -(def-syntax-test syntax.sharp-x.9 - (read-from-string "#x10") - 16 4) - -(def-syntax-test syntax.sharp-x.10 - (read-from-string "#X1ab") - 427 5) - -(def-syntax-test syntax.sharp-x.11 - (read-from-string "#x-1") - -1 4) - -(def-syntax-test syntax.sharp-x.12 - (read-from-string "#X-0") - 0 4) - -(def-syntax-test syntax.sharp-x.13 - (read-from-string "#xa/B") - 10/11 5) - -(def-syntax-test syntax.sharp-x.14 - (read-from-string "#X-1/1c") - -1/28 7) - -(def-syntax-test syntax.sharp-x.15 - (let ((*read-eval* nil)) - (read-from-string "#x-10/11")) - -16/17 8) - -;;; Tests of #nR - -(def-syntax-test syntax.sharp-r.1 - (loop for i = (random (ash 1 (+ 2 (random 32)))) - for base = (+ 2 (random 35)) - for s = (write-to-string i :radix nil :base base :readably nil) - for c = (random-from-seq "rR") - for s2 = (format nil "#~d~c~a" base c s) - for s3 = (rcase (1 (string-upcase s2)) - (1 (string-downcase s2)) - (1 (string-capitalize s2)) - (1 s2)) - for base2 = (+ 2 (random 35)) - for vals = (let ((*read-base* base2)) - (multiple-value-list - (read-from-string s3))) - repeat 1000 - unless (equal vals (list i (length s3) )) - collect (list i base s c s2 s3 base2 vals)) - nil) - -(def-syntax-test syntax.sharp-r.2 - (read-from-string "#2r0") - 0 4) - -(def-syntax-test syntax.sharp-r.3 - (read-from-string "#36r0") - 0 5) - -(def-syntax-test syntax.sharp-r.4 - (read-from-string "#29R-0") - 0 6) - -(def-syntax-test syntax.sharp-r.5 - (read-from-string "#23r-1") - -1 6) - -(def-syntax-test syntax.sharp-r.6 - (read-from-string "#17r11") - 18 6) - -(def-syntax-test syntax.sharp-t.7 - (read-from-string "#3r10/11") - 3/4 8) - -(def-syntax-test syntax.sharp-t.8 - (read-from-string "#5R-10/11") - -5/6 9) - -;;; Tests of #c - -(def-syntax-test syntax.sharp-c.1 - (read-from-string "#c(1 1)") - #.(complex 1 1) 7) - -(def-syntax-test syntax.sharp-c.2 - (read-from-string "#C(1 0)") - 1 7) - -(def-syntax-test syntax.sharp-c.3 - (read-from-string "#c(0 1)") - #.(complex 0 1) 7) - -(def-syntax-test syntax.sharp-c.4 - (read-from-string "#c(-1/2 1)") - #.(complex -1/2 1) 10) - -(def-syntax-test syntax.sharp-c.5 - (read-from-string "#c (1 1)") - #.(complex 1 1) 8) - -(def-syntax-test syntax.sharp-c.6 - (loop for format in '(short-float single-float double-float long-float) - for c = (let ((*read-default-float-format* format)) - (read-from-string "#c(1.0 0.0)")) - unless (eql c (complex (coerce 1 format) - (coerce 0 format))) - collect (list format c)) - nil) - -(def-syntax-test syntax.sharp-c.7 - (loop for format in '(short-float single-float double-float long-float) - for c = (let ((*read-default-float-format* format)) - (read-from-string "#C(0.0 1.0)")) - unless (eql c (complex (coerce 0 format) - (coerce 1 format))) - collect (list format c)) - nil) - -;;; Tests of #a - -(def-syntax-array-test syntax.sharp-a.1 - "#0anil" - (make-array nil :initial-element nil)) - -(def-syntax-array-test syntax.sharp-a.2 - "#0a1" - (make-array nil :initial-element 1)) - -(def-syntax-array-test syntax.sharp-a.3 - "#1a(1 2 3 5)" - (make-array '(4) :initial-contents '(1 2 3 5))) - -(def-syntax-array-test syntax.sharp-a.4 - "#1a\"abcd\"" - (make-array '(4) :initial-contents '(#\a #\b #\c #\d))) - -(def-syntax-array-test syntax.sharp-a.5 - "#1a#1a(:a :b :c)" - (make-array '(3) :initial-contents '(:a :b :c))) - -(def-syntax-array-test syntax.sharp-a.6 - "#1a#.(coerce \"abcd\" 'simple-base-string)" - (make-array '(4) :initial-contents '(#\a #\b #\c #\d))) - -(def-syntax-array-test syntax.sharp-a.7 - "#1a#*000110" - (make-array '(6) :initial-contents '(0 0 0 1 1 0))) - -(def-syntax-array-test syntax.sharp-a.8 - "#1a#.(make-array 4 :element-type '(unsigned-byte 8) - :initial-contents '(1 2 3 5))" - (make-array '(4) :initial-contents '(1 2 3 5))) - -(def-syntax-array-test syntax.sharp-a.9 - "#1a#.(make-array 4 :element-type '(unsigned-byte 4) - :initial-contents '(1 2 3 5))" - (make-array '(4) :initial-contents '(1 2 3 5))) - -(def-syntax-array-test syntax.sharp-a.10 - "#1a#.(make-array 4 :element-type '(signed-byte 4) - :initial-contents '(1 2 3 5))" - (make-array '(4) :initial-contents '(1 2 3 5))) - -(def-syntax-array-test syntax.sharp-a.11 - "#1a#.(make-array 4 :element-type '(signed-byte 8) - :initial-contents '(1 2 3 5))" - (make-array '(4) :initial-contents '(1 2 3 5))) - -(def-syntax-array-test syntax.sharp-a.12 - "#1a#.(make-array 4 :element-type '(unsigned-byte 16) - :initial-contents '(1 2 3 5))" - (make-array '(4) :initial-contents '(1 2 3 5))) - -(def-syntax-array-test syntax.sharp-a.13 - "#1a#.(make-array 4 :element-type '(signed-byte 16) - :initial-contents '(1 2 3 5))" - (make-array '(4) :initial-contents '(1 2 3 5))) - -(def-syntax-array-test syntax.sharp-a.14 - "#1a#.(make-array 4 :element-type '(unsigned-byte 32) - :initial-contents '(1 2 3 5))" - (make-array '(4) :initial-contents '(1 2 3 5))) - -(def-syntax-array-test syntax.sharp-a.15 - "#1a#.(make-array 4 :element-type '(signed-byte 32) - :initial-contents '(1 2 3 5))" - (make-array '(4) :initial-contents '(1 2 3 5))) - -(def-syntax-array-test syntax.sharp-a.16 - "#1a#.(make-array 4 :element-type 'fixnum - :initial-contents '(1 2 3 5))" - (make-array '(4) :initial-contents '(1 2 3 5))) - -(def-syntax-array-test syntax.sharp-a.17 - "#1anil" - (make-array '(0))) - -(def-syntax-array-test syntax.sharp-a.18 - "#2anil" - (make-array '(0 0))) - -(def-syntax-array-test syntax.sharp-a.19 - "#2a((2))" - (make-array '(1 1) :initial-element 2)) - -(def-syntax-array-test syntax.sharp-a.20 - "#2a((1 2 3)(4 5 6))" - (make-array '(2 3) :initial-contents #(#(1 2 3) #(4 5 6)))) - -(def-syntax-array-test syntax.sharp-a.21 - "#2a#(#(1 2 3)#(4 5 6))" - (make-array '(2 3) :initial-contents '((1 2 3) (4 5 6)))) - -(def-syntax-array-test syntax.sharp-a.22 - "#2a\"\"" - (make-array '(0 0))) - -(def-syntax-array-test syntax.sharp-a.23 - "#2a#*" - (make-array '(0 0))) - -(def-syntax-array-test syntax.sharp-a.24 - "#1a#.(make-array '(10) :fill-pointer 5 :initial-element 17)" - (make-array '(5) :initial-contents '(17 17 17 17 17))) - -(def-syntax-array-test syntax.sharp-a.25 - "#1a#.(make-array '(5) :adjustable t :initial-element 17)" - (make-array '(5) :initial-contents '(17 17 17 17 17))) - -(def-syntax-array-test syntax.sharp-a.26 - "#1A#.(let ((x (make-array '(10) :adjustable t - :initial-contents '(1 2 3 4 5 6 7 8 9 10)))) - (make-array '(5) :displaced-to x :displaced-index-offset 2))" - (make-array '(5) :initial-contents '(3 4 5 6 7))) - -;;; Tests of #S - -(unless (find-class 'syntax-test-struct-1 nil) - (defstruct syntax-test-struct-1 - a b c)) - -(def-syntax-test syntax.sharp-s.1 - (let ((v (read-from-string "#s(syntax-test-struct-1)"))) - (values - (notnot (typep v 'syntax-test-struct-1)) - (syntax-test-struct-1-a v) - (syntax-test-struct-1-b v) - (syntax-test-struct-1-c v))) - t nil nil nil) - -(def-syntax-test syntax.sharp-s.2 - (let ((v (read-from-string "#S(syntax-test-struct-1 :a x :c y :b z)"))) - (values - (notnot (typep v 'syntax-test-struct-1)) - (syntax-test-struct-1-a v) - (syntax-test-struct-1-b v) - (syntax-test-struct-1-c v))) - t x z y) - -(def-syntax-test syntax.sharp-s.3 - (let ((v (read-from-string "#s(syntax-test-struct-1 \"A\" x)"))) - (values - (notnot (typep v 'syntax-test-struct-1)) - (syntax-test-struct-1-a v) - (syntax-test-struct-1-b v) - (syntax-test-struct-1-c v))) - t x nil nil) - -(def-syntax-test syntax.sharp-s.4 - (let ((v (read-from-string "#S(syntax-test-struct-1 #\\A x)"))) - (values - (notnot (typep v 'syntax-test-struct-1)) - (syntax-test-struct-1-a v) - (syntax-test-struct-1-b v) - (syntax-test-struct-1-c v))) - t x nil nil) - -(def-syntax-test syntax.sharp-s.5 - (let ((v (read-from-string "#s(syntax-test-struct-1 :a x :a y)"))) - (values - (notnot (typep v 'syntax-test-struct-1)) - (syntax-test-struct-1-a v) - (syntax-test-struct-1-b v) - (syntax-test-struct-1-c v))) - t x nil nil) - -(def-syntax-test syntax.sharp-s.6 - (let ((v (read-from-string "#S(syntax-test-struct-1 :a x :allow-other-keys 1)"))) - (values - (notnot (typep v 'syntax-test-struct-1)) - (syntax-test-struct-1-a v) - (syntax-test-struct-1-b v) - (syntax-test-struct-1-c v))) - t x nil nil) - -(def-syntax-test syntax.sharp-s.7 - (let ((v (read-from-string "#s(syntax-test-struct-1 :b z :allow-other-keys nil)"))) - (values - (notnot (typep v 'syntax-test-struct-1)) - (syntax-test-struct-1-a v) - (syntax-test-struct-1-b v) - (syntax-test-struct-1-c v))) - t nil z nil) - - -(def-syntax-test syntax.sharp-s.8 - (let ((v (read-from-string "#S(syntax-test-struct-1 :b z :allow-other-keys t :a x :foo bar)"))) - (values - (notnot (typep v 'syntax-test-struct-1)) - (syntax-test-struct-1-a v) - (syntax-test-struct-1-b v) - (syntax-test-struct-1-c v))) - t x z nil) - -(def-syntax-test syntax.sharp-s.9 - (let ((v (read-from-string "#s(syntax-test-struct-1 a x c y b z :a :bad :b bad2 :c bad3)"))) - (values - (notnot (typep v 'syntax-test-struct-1)) - (syntax-test-struct-1-a v) - (syntax-test-struct-1-b v) - (syntax-test-struct-1-c v))) - t x z y) - -(def-syntax-test syntax.sharp-s.10 - (let ((v (read-from-string "#S(syntax-test-struct-1 #:a x #:c y #:b z)"))) - (values - (notnot (typep v 'syntax-test-struct-1)) - (syntax-test-struct-1-a v) - (syntax-test-struct-1-b v) - (syntax-test-struct-1-c v))) - t x z y) - -;; (Put more tests of this in the structure tests) - -;;; Tests of #P - -(def-syntax-test syntax.sharp-p.1 - (read-from-string "#p\"\"") - #.(parse-namestring "") 4) - -(def-syntax-test syntax.sharp-p.2 - (read-from-string "#P\"syntax.lsp\"") - #.(parse-namestring "syntax.lsp") 14) - -(def-syntax-test syntax.sharp-p.3 - (read-from-string "#P \"syntax.lsp\"") - #.(parse-namestring "syntax.lsp") 15) - -(def-syntax-test syntax.sharp-p.4 - (let ((*read-eval* nil)) - (read-from-string "#p\"syntax.lsp\"")) - #.(parse-namestring "syntax.lsp") 14) - -(def-syntax-test syntax.sharp-p.5 - (read-from-string "#P#.(make-array '(10) :initial-contents \"syntax.lsp\" :element-type 'base-char)") - #.(parse-namestring "syntax.lsp") 78) - -;;; ## and #= - -(def-syntax-test syntax.sharp-circle.1 - (let ((x (read-from-string "(#1=(17) #1#)"))) - (assert (eq (car x) (cadr x))) - x) - ((17) (17))) - -(def-syntax-test syntax.sharp-circle.2 - (let ((x (read-from-string "(#0=(17) #0#)"))) - (assert (eq (car x) (cadr x))) - x) - ((17) (17))) - -(def-syntax-test syntax.sharp-circle.3 - (let ((x (read-from-string "(#123456789123456789=(17) #123456789123456789#)"))) - (assert (eq (car x) (cadr x))) - x) - ((17) (17))) - -(def-syntax-test syntax.sharp-circle.4 - (let ((x (read-from-string "#1=(A B . #1#)"))) - (assert (eq (cddr x) x)) - (values (car x) (cadr x))) - a b) - -(def-syntax-test syntax.sharp-circle.5 - (let ((x (read-from-string "#1=#(A B #1#)"))) - (assert (typep x '(simple-vector 3))) - (assert (eq (elt x 2) x)) - (values (elt x 0) (elt x 1))) - a b) - -(def-syntax-test syntax.sharp-circle.6 - (let ((x (read-from-string "((#1=(17)) #1#)"))) - (assert (eq (caar x) (cadr x))) - x) - (((17)) (17))) - -(def-syntax-test syntax.sharp-circle.7 - (let ((x (read-from-string "((#1=#2=(:x)) #1# #2#)"))) - (assert (eq (caar x) (cadr x))) - (assert (eq (caar x) (caddr x))) - x) - (((:x)) (:x) (:x))) - -;;; #+ - -(def-syntax-test syntax.sharp-plus.1 - (let ((*features* nil)) - (read-from-string "#+X :bad :good")) - :good 14) - -(def-syntax-test syntax.sharp-plus.2 - (let ((*features* '(:a :x :b))) - (read-from-string "#+X :good :bad")) - :good 10) - -(def-syntax-test syntax.sharp-plus.3 - (let ((*features* '(:a :x :b))) - (read-from-string "#+:x :good :bad")) - :good 11) - -(def-syntax-test syntax.sharp-plus.4 - (let ((*features* '(:a :x :b))) - (read-from-string "#+(and):good :bad")) - :good 13) - -(def-syntax-test syntax.sharp-plus.5 - (let ((*features* '(:a :x :b))) - (read-from-string "#+(:and):good :bad")) - :good 14) - -(def-syntax-test syntax.sharp-plus.6 - (let ((*features* '(:a :x :b))) - (read-from-string "#+(or) :bad :good")) - :good 17) - -(def-syntax-test syntax.sharp-plus.7 - (let ((*features* '(:a :x :b))) - (read-from-string "#+(:or) :bad :good")) - :good 18) - -(def-syntax-test syntax.sharp-plus.8 - (let ((*features* '(x))) - (read-from-string "#+X :bad :good")) - :good 14) - -(def-syntax-test syntax.sharp-plus.9 - (let ((*features* '(x))) - (read-from-string "#+CL-TEST::X :good :bad")) - :good 19) - -(def-syntax-test syntax.sharp-plus.10 - (let ((*features* nil)) - (read-from-string "#+(not x) :good :bad")) - :good 16) - -(def-syntax-test syntax.sharp-plus.11 - (let ((*features* '(:x))) - (read-from-string "#+(not x) :bad :good")) - :good 20) - -(def-syntax-test syntax.sharp-plus.12 - (let ((*features* nil)) - (read-from-string "#+(:not :x) :good :bad")) - :good 18) - -(def-syntax-test syntax.sharp-plus.13 - (let ((*features* '(:a :x :b))) - (read-from-string "#+(and a b) :good :bad")) - :good 18) - -(def-syntax-test syntax.sharp-plus.14 - (let ((*features* '(:a :x :b))) - (read-from-string "#+(and a c) :bad :good")) - :good 22) - -(def-syntax-test syntax.sharp-plus.15 - (let ((*features* '(:a :x :b))) - (read-from-string "#+(or c b) :good :bad")) - :good 17) - -(def-syntax-test syntax.sharp-plus.16 - (let ((*features* '(:a :x :b))) - (read-from-string "#+(or c d) :bad :good")) - :good 21) - -;;; Tests of #| |# - -(def-syntax-test syntax.sharp-bar.1 - (read-from-string "#||#1") - 1 5) - -(def-syntax-test syntax.sharp-bar.2 - (read-from-string "1#||#2") - |1##2| 6) - -(def-syntax-test syntax.sharp-bar.3 - (read-from-string "#| #| |# |#1") - 1 12) - -(def-syntax-test syntax.sharp-bar.4 - (read-from-string "#| ; |#1") - 1 8) - -(def-syntax-test syntax.sharp-bar.5 - (read-from-string "#| ( |#1") - 1 8) - -(def-syntax-test syntax.sharp-bar.6 - (read-from-string "#| # |#1") - 1 8) - -(def-syntax-test syntax.sharp-bar.7 - (read-from-string "#| .. |#1") - 1 9) - -(def-syntax-test syntax.sharp-bar.8 - (loop for c across +standard-chars+ - for s = (concatenate 'string "\#| " (string c) " |\#1") - for vals = (multiple-value-list (read-from-string s)) - unless (equal vals '(1 8)) - collect (list c s vals)) - nil) - -(def-syntax-test syntax.sharp-bar.9 - (loop for i below (min (ash 1 16) char-code-limit) - for c = (code-char i) - for s = (and c (concatenate 'string "\#| " (string c) " |\#1")) - for vals = (and c (multiple-value-list (read-from-string s))) - unless (or (not c) (equal vals '(1 8))) - collect (list i c s vals)) - nil) - -(def-syntax-test syntax.sharp-bar.10 - (loop for i = (random (min (ash 1 24) char-code-limit)) - for c = (code-char i) - for s = (and c (concatenate 'string "\#| " (string c) " |\#1")) - for vals = (and c (multiple-value-list (read-from-string s))) - repeat 1000 - unless (or (not c) (equal vals '(1 8))) - collect (list i c s vals)) - nil) - -;;;; Various error cases - -(def-syntax-test syntax.sharp-whitespace.1 - (let ((names '("Tab" "Newline" "Linefeed" "Space" "Return" "Page"))) - (loop for name in names - for c = (name-char name) - when c - nconc - (let* ((form `(signals-error - (read-from-string ,(concatenate 'string "#" (string c))) - reader-error)) - (vals (multiple-value-list (eval form)))) - (unless (equal vals '(t)) - (list (list name c form vals)))))) - nil) - -(def-syntax-test syntax.sharp-less-than.1 - (signals-error (read-from-string "#<" nil nil) reader-error) - t) - - -(def-syntax-test syntax.sharp-close-paren.1 - (signals-error (read-from-string "#)" nil nil) reader-error) - t) - -(def-syntax-test syntax.single-escape-eof.1 - (signals-error (read-from-string "\\") end-of-file) - t) - -(def-syntax-test syntax.single-escape-eof.2 - (signals-error (read-from-string "\\" nil nil) end-of-file) - t) - -(def-syntax-test syntax.multiple-escape-eof.1 - (signals-error (read-from-string "|") end-of-file) - t) - -(def-syntax-test syntax.multiple-escape-eof.2 - (signals-error (read-from-string "|" nil nil) end-of-file) - t) - diff --git a/t/ansi-test/reader/with-standard-io-syntax.lsp b/t/ansi-test/reader/with-standard-io-syntax.lsp deleted file mode 100644 index 3d9c0f9..0000000 --- a/t/ansi-test/reader/with-standard-io-syntax.lsp +++ /dev/null @@ -1,129 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Feb 23 05:12:13 2004 -;;;; Contains: Tests of WITH-STANDARD-IO-SYNTAX - -(in-package :cl-test) - -(deftest with-standard-io-syntax.1 - (let ((*package* (find-package :cl-test))) - (with-standard-io-syntax - (eqlt *package* (find-package "CL-USER")))) - t) - -(deftest with-standard-io-syntax.2 - (let ((*print-array* nil)) - (with-standard-io-syntax *print-array*)) - t) - -(deftest with-standard-io-syntax.3 - (let ((*print-base* 8)) - (with-standard-io-syntax *print-base*)) - 10) - -(deftest with-standard-io-syntax.4 - (let ((*print-case* :downcase)) - (with-standard-io-syntax *print-case*)) - :upcase) - -(deftest with-standard-io-syntax.5 - (let ((*print-circle* t)) - (with-standard-io-syntax *print-circle*)) - nil) - -(deftest with-standard-io-syntax.6 - (let ((*print-escape* nil)) - (with-standard-io-syntax *print-escape*)) - t) - -(deftest with-standard-io-syntax.7 - (let ((*print-gensym* nil)) - (with-standard-io-syntax *print-gensym*)) - t) - -(deftest with-standard-io-syntax.8 - (let ((*print-length* 100)) - (with-standard-io-syntax *print-length*)) - nil) - -(deftest with-standard-io-syntax.9 - (let ((*print-level* 100)) - (with-standard-io-syntax *print-level*)) - nil) - -(deftest with-standard-io-syntax.10 - (let ((*print-lines* 100)) - (with-standard-io-syntax *print-lines*)) - nil) - -(deftest with-standard-io-syntax.11 - (let ((*print-miser-width* 100)) - (with-standard-io-syntax *print-miser-width*)) - nil) - -(deftest with-standard-io-syntax.12 - (let ((*print-pretty* t)) - (with-standard-io-syntax *print-pretty*)) - nil) - -(deftest with-standard-io-syntax.13 - (let ((*print-right-margin* 100)) - (with-standard-io-syntax *print-right-margin*)) - nil) - -(deftest with-standard-io-syntax.14 - (let ((*read-base* 8)) - (with-standard-io-syntax *read-base*)) - 10) - -(deftest with-standard-io-syntax.15 - (let ((*read-default-float-format 'long-float)) - (with-standard-io-syntax *read-default-float-format*)) - single-float) - -(deftest with-standard-io-syntax.16 - (let ((*read-eval* nil)) - (with-standard-io-syntax *read-eval*)) - t) - -(deftest with-standard-io-syntax.17 - (let ((*read-suppress* t)) - (with-standard-io-syntax *read-suppress*)) - nil) - -(deftest with-standard-io-syntax.18 - (with-standard-io-syntax (notnot-mv (readtablep *readtable*))) - t) - -(deftest with-standard-io-syntax.19 - (with-standard-io-syntax) - nil) - -(deftest with-standard-io-syntax.20 - (with-standard-io-syntax (values 'a 'b 'c)) - a b c) - -(deftest with-standard-io-syntax.21 - (block done - (tagbody - (with-standard-io-syntax (go 10) 10 (return-from done :bad)) - 10 - (return-from done :good))) - :good) - -(deftest with-standard-io-syntax.22 - (let ((i 3)) - (with-standard-io-syntax - (incf i 10) - (+ i 2))) - 15) - -(deftest with-standard-io-syntax.23 - (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil))) - (set-pprint-dispatch 'symbol #'(lambda (stream obj) - (declare (ignore obj)) - (write-string "FOO" stream))) - (list (let ((*print-pretty* t)) (princ-to-string 'bar)) - (with-standard-io-syntax - (let ((*print-pretty* t)) (princ-to-string 'bar))))) - ("FOO" "BAR")) diff --git a/t/ansi-test/regression-test.asd b/t/ansi-test/regression-test.asd deleted file mode 100644 index 9e6e2dc..0000000 --- a/t/ansi-test/regression-test.asd +++ /dev/null @@ -1,7 +0,0 @@ -(cl:in-package #:asdf-user) - -(defsystem :regression-test - :serial t - :components - ((:cl-source-file.lsp "rt-package") - (:cl-source-file.lsp "rt"))) diff --git a/t/ansi-test/rt-acl.system b/t/ansi-test/rt-acl.system deleted file mode 100644 index d9cfc7f..0000000 --- a/t/ansi-test/rt-acl.system +++ /dev/null @@ -1,12 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Mar 7 23:30:22 1998 -;;;; Contains: Allegro CL defsystem for RT testing system - -(defsystem :rt-acl - (:default-pathname #.(directory-namestring (truename *LOAD-PATHNAME*)) - :default-file-type "lsp") - (:definitions - "rt-package" - "rt")) - diff --git a/t/ansi-test/rt-doc.txt b/t/ansi-test/rt-doc.txt deleted file mode 100644 index 8c07b8d..0000000 --- a/t/ansi-test/rt-doc.txt +++ /dev/null @@ -1,194 +0,0 @@ - -#|----------------------------------------------------------------------------| - | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. | - | | - | Permission to use, copy, modify, and distribute this software and its | - | documentation for any purpose and without fee is hereby granted, provided | - | that this copyright and permission notice appear in all copies and | - | supporting documentation, and that the name of M.I.T. not be used in | - | advertising or publicity pertaining to distribution of the software | - | without specific, written prior permission. M.I.T. makes no | - | representations about the suitability of this software for any purpose. | - | It is provided "as is" without express or implied warranty. | - | | - | M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING | - | ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL | - | M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR | - | ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, | - | WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, | - | ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS | - | SOFTWARE. | - |----------------------------------------------------------------------------|# - - (This is the December 19, 1990 version of brief documentation for the - RT regression tester. A more complete discussion can be found in - the article in Lisp Pointers.) - -The functions, macros, and variables that make up the RT regression tester are -in a package called "RT". The ten exported symbols are documented below. If -you want to refer to these symbols without a package prefix, you have to `use' -the package. - -The basic unit of concern of RT is the test. Each test has an identifying name -and a body that specifies the action of the test. Functions are provided for -defining, redefining, removing, and performing individual tests and the test -suite as a whole. In addition, information is maintained about which tests have -succeeded and which have failed. - - -<> deftest NAME FORM &rest VALUES - -Individual tests are defined using the macro DEFTEST. The identifying NAME is -typically a number or symbol, but can be any Lisp form. If the test suite -already contains a test with the same (EQUAL) NAME, then this test is redefined -and a warning message printed. (This warning is important to alert the user -when a test suite definition file contains two tests with the same name.) When -the test is a new one, it is added to the end of the suite. In either case, -NAME is returned as the value of DEFTEST and stored in the variable *TEST*. - -(deftest t-1 (floor 15/7) 2 1/7) => t-1 - -(deftest (t 2) (list 1) (1)) => (t 2) - -(deftest bad (1+ 1) 1) => bad - -(deftest good (1+ 1) 2) => good - -The FORM can be any kind of Lisp form. The zero or more VALUES can be any kind -of Lisp objects. The test is performed by evaluating FORM and comparing the -results with the VALUES. The test succeeds if and only if FORM produces the -correct number of results and each one is EQUAL to the corresponding VALUE. - - -<> *test* NAME-OF-CURRENT-TEST - -The variable *TEST* contains the name of the test most recently defined or -performed. It is set by DEFTEST and DO-TEST. - - -<> do-test &optional (NAME *TEST*) - -The function DO-TEST performs the test identified by NAME, which defaults to -*TEST*. Before running the test, DO-TEST stores NAME in the variable *TEST*. -If the test succeeds, DO-TEST returns NAME as its value. If the test fails, -DO-TEST returns NIL, after printing an error report on *STANDARD-OUTPUT*. The -following examples show the results of performing two of the tests defined -above. - -(do-test '(t 2)) => (t 2) - -(do-test 'bad) => nil ; after printing: -Test BAD failed -Form: (1+ 1) -Expected value: 1 -Actual value: 2. - - -<> *do-tests-when-defined* default value NIL - -If the value of this variable is non-null, each test is performed at the moment -that it is defined. This is helpful when interactively constructing a suite of -tests. However, when loading a test suite for later use, performing tests as -they are defined is not liable to be helpful. - - -<> get-test &optional (NAME *TEST*) - -This function returns the NAME, FORM, and VALUES of the specified test. - -(get-test '(t 2)) => ((t 2) (list 1) (1)) - - -<> rem-test &optional (NAME *TEST*) - -If the indicated test is in the test suite, this function removes it and returns -NAME. Otherwise, NIL is returned. - - -<> rem-all-tests - -This function reinitializes RT by removing every test from the test suite and -returns NIL. Generally, it is advisable for the whole test suite to apply to -some one system. When switching from testing one system to testing another, it -is wise to remove all the old tests before beginning to define new ones. - - -<> do-tests &optional (OUT *STANDARD-OUTPUT*) - -This function uses DO-TEST to run each of the tests in the test suite and prints -a report of the results on OUT, which can either be an output stream or the name -of a file. If OUT is omitted, it defaults to *STANDARD-OUTPUT*. DO-TESTS -returns T if every test succeeded and NIL if any test failed. - -As illustrated below, the first line of the report produced by DO-TEST shows how -many tests need to be performed. The last line shows how many tests failed and -lists their names. While the tests are being performed, DO-TESTS prints the -names of the successful tests and the error reports from the unsuccessful tests. - -(do-tests "report.txt") => nil -; the file "report.txt" contains: -Doing 4 pending tests of 4 tests total. - T-1 (T 2) -Test BAD failed -Form: (1+ 1) -Expected value: 1 -Actual value: 2. - GOOD -1 out of 4 total tests failed: BAD. - -It is best if the individual tests in the suite are totally independent of each -other. However, should the need arise for some interdependence, you can rely on -the fact that DO-TESTS will run tests in the order they were originally defined. - - -<> pending-tests - -When a test is defined or redefined, it is marked as pending. In addition, -DO-TEST marks the test to be run as pending before running it and DO-TESTS marks -every test as pending before running any of them. The only time a test is -marked as not pending is when it completes successfully. The function -PENDING-TESTS returns a list of the names of the currently pending tests. - -(pending-tests) => (bad) - - -<> continue-testing - -This function is identical to DO-TESTS except that it only runs the tests that -are pending and always writes its output on *STANDARD-OUTPUT*. - -(continue-testing) => nil ; after printing: -Doing 1 pending test out of 4 total tests. -Test BAD failed -Form: (1+ 1) -Expected value: 1 -Actual value: 2. -1 out of 4 total tests failed: BAD. - -CONTINUE-TESTING has a special meaning if called at a breakpoint generated while -a test is being performed. The failure of a test to return the correct value -does not trigger an error break. However, there are many kinds of things that -can go wrong while a test is being performed (e.g., dividing by zero) that will -cause breaks. - -If CONTINUE-TESTING is evaluated in a break generated during testing, it aborts -the current test (which remains pending) and forces the processing of tests to -continue. Note that in such a breakpoint, *TEST* is bound to the name of the -test being performed and (GET-TEST) can be used to look at the test. - -When building a system, it is advisable to start constructing a test suite for -it as soon as possible. Since individual tests are rather weak, a comprehensive -test suite requires large numbers of tests. However, these can be accumulated -over time. In particular, whenever a bug is found by some means other than -testing, it is wise to add a test that would have found the bug and therefore -will ensure that the bug will not reappear. - -Every time the system is changed, the entire test suite should be run to make -sure that no unintended changes have occurred. Typically, some tests will fail. -Sometimes, this merely means that tests have to be changed to reflect changes in -the system's specification. Other times, it indicates bugs that have to be -tracked down and fixed. During this phase, CONTINUE-TESTING is useful for -focusing on the tests that are failing. However, for safety sake, it is always -wise to reinitialize RT, redefine the entire test suite, and run DO-TESTS one -more time after you think all of the tests are working. - diff --git a/t/ansi-test/rt-package.lsp b/t/ansi-test/rt-package.lsp deleted file mode 100644 index c766642..0000000 --- a/t/ansi-test/rt-package.lsp +++ /dev/null @@ -1,61 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Dec 17 21:10:53 2002 -;;;; Contains: Package definition for RT - - -;; (eval-when (:execute :compile-toplevel :load-toplevel) -#| (defpackage :regression-test - (:use :cl) - (:nicknames :rtest #-lispworks :rt) - (:export - #:*do-tests-when-defined* - #:*compile-tests* - #:*test* - #:continue-testing - #:deftest - #:do-test - #:do-tests - #:get-test - #:pending-tests - #:rem-all-tests - #:rem-test - #:defnote - #:my-aref - #:*catch-errors* - #:disable-note - )) - |# - (let* ((name (symbol-name :regression-test)) - (pkg (find-package name))) - (unless pkg (setq pkg (make-package name - :nicknames (mapcar #'symbol-name '(:rtest #-lispworks :rt)) - :use '(#-wcl :cl #+wcl :lisp) - ))) - (let ((*package* pkg)) - (export (mapcar #'intern - (mapcar #'symbol-name - '(#:*compile-tests* - #:*do-tests-when-defined* - #:*test* - #:continue-testing - #:deftest - #:do-test - #:do-tests - #:do-extended-tests - #:get-test - #:pending-tests - #:rem-all-tests - #:rem-test - #:defnote - #:my-aref - #:*catch-errors* - #:*passed-tests* - #:*failed-tests* - #:disable-note - #:*expected-failures* - #:*unexpected-failures* - #:*unexpected-successes*)))))) -;; ) - -;; (in-package :regression-test) diff --git a/t/ansi-test/rt-test.lsp b/t/ansi-test/rt-test.lsp deleted file mode 100644 index 60c9a96..0000000 --- a/t/ansi-test/rt-test.lsp +++ /dev/null @@ -1,238 +0,0 @@ -;-*-syntax:COMMON-LISP-*- - -#|----------------------------------------------------------------------------| - | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. | - | | - | Permission to use, copy, modify, and distribute this software and its | - | documentation for any purpose and without fee is hereby granted, provided | - | that this copyright and permission notice appear in all copies and | - | supporting documentation, and that the name of M.I.T. not be used in | - | advertising or publicity pertaining to distribution of the software | - | without specific, written prior permission. M.I.T. makes no | - | representations about the suitability of this software for any purpose. | - | It is provided "as is" without express or implied warranty. | - | | - | M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING | - | ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL | - | M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR | - | ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, | - | WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, | - | ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS | - | SOFTWARE. | - |----------------------------------------------------------------------------|# - -;This is the December 19, 1990 version of a set of tests that use the -;RT regression tester to test itself. See the documentation of RT for -;a discusion of how to use this file. - -(cl:defpackage :rt-tests - (:use :cl :regression-test)) - -(in-package :rt-tests) -;; (require "RT") -;;(use-package :regression-test) - -(defmacro setup (&rest body) - `(do-setup '(progn ., body))) - -(defmacro with-blank-tests (&body body) - `(let ((regression-test::*entries* (list nil)) - (regression-test::*entries-table* (make-hash-table :test #'equal)) - (*test* nil) - (regression-test::*in-test* nil)) - (let ((regression-test::*entries-tail* regression-test::*entries*)) - ,@body))) - -(defun do-setup (form) - (with-blank-tests - (let ((*do-tests-when-defined* nil) - (regression-test::*debug* t) - result) - (deftest t1 4 4) - (deftest (t 2) 4 3) - (values-list - (cons (normalize - (with-output-to-string (*standard-output*) - (setq result - (multiple-value-list - (catch 'regression-test::*debug* (eval form)))))) - result))))) - -(defun normalize (string) - (with-input-from-string (s string) - (normalize-stream s))) - -(defvar *file-name* nil) - -(defun get-file-name () - (loop (if *file-name* (return *file-name*)) - (format *error-output* - "~%Type a string representing naming of a scratch disk file: ") - (setq *file-name* (read)) - (if (not (stringp *file-name*)) (setq *file-name* nil)))) - -(get-file-name) - -(defmacro with-temporary-file (f &body forms) - `(let ((,f *file-name*)) - ,@ forms - (get-file-output ,f))) - -(defun get-file-output (f) - (prog1 (with-open-file (in f) - (normalize-stream in)) - (delete-file f))) - -(defun normalize-stream (s) - (let ((l nil)) - (loop (push (read-line s nil s) l) - (when (eq (car l) s) - (setq l (nreverse (cdr l))) - (return nil))) - (delete "" l :test #'equal))) - -(rem-all-tests) - -(deftest deftest-1 - (setup (deftest t1 3 3) (values (get-test 't1) *test* (pending-tests))) - ("Redefining test RT-TESTS::T1") (t1 3 3) t1 (t1 (t 2))) -(deftest deftest-2 - (setup (deftest (t 2) 3 3) (get-test '(t 2))) - ("Redefining test (T 2)") ((t 2) 3 3)) -(deftest deftest-3 - (setup (deftest 2 3 3) (values (get-test 2) *test* (pending-tests))) - () (2 3 3) 2 (t1 (t 2) 2)) -(deftest deftest-4 - (setup (let ((*do-tests-when-defined* t)) (deftest (temp) 4 3))) - ("Test (RT-TESTS::TEMP) failed" - "Form: 4" - "Expected value: 3" - "Actual value: 4.") - (temp)) - -(deftest do-test-1 - (setup (values (do-test 't1) *test* (pending-tests))) - () t1 t1 ((t 2))) -(deftest do-test-2 - (setup (values (do-test '(t 2)) (pending-tests))) - ("Test (T 2) failed" - "Form: 4" - "Expected value: 3" - "Actual value: 4.") nil (t1 (t 2))) -(deftest do-test-3 - (setup (let ((*test* 't1)) (do-test))) - () t1) - -(deftest get-test-1 - (setup (values (get-test 't1) *test*)) - () (t1 4 4) (t 2)) -(deftest get-test-2 - (setup (get-test '(t 2))) - () ((t 2) 4 3)) -(deftest get-test-3 - (setup (let ((*test* 't1)) (get-test))) - () (t1 4 4)) -(deftest get-test-4 - (setup (deftest t3 1 1) (get-test)) - () (t3 1 1)) -(deftest get-test-5 - (setup (get-test 't0)) - ("No test with name RT-TESTS::T0.") nil) - -(deftest rem-test-1 - (setup (values (rem-test 't1) (pending-tests))) - () t1 ((t 2))) -(deftest rem-test-2 - (setup (values (rem-test '(t 2)) (pending-tests))) - () (t 2) (t1)) -(deftest rem-test-3 - (setup (let ((*test* '(t 2))) (rem-test)) (pending-tests)) - () (t1)) -(deftest rem-test-4 - (setup (values (rem-test 't0) (pending-tests))) - () nil (t1 (t 2))) -(deftest rem-test-5 - (setup (rem-all-tests) (rem-test 't0) (pending-tests)) - () ()) - -(deftest rem-all-tests-1 - (setup (values (rem-all-tests) (pending-tests))) - () nil nil) -(deftest rem-all-tests-2 - (setup (rem-all-tests) (rem-all-tests) (pending-tests)) - () nil) - -(deftest do-tests-1 - (setup (let ((*print-case* :downcase)) - (values (do-tests) (continue-testing) (do-tests)))) - ("Doing 2 pending tests of 2 tests total." - " RT-TESTS::T1" - "Test (T 2) failed" - "Form: 4" - "Expected value: 3" - "Actual value: 4." - "1 out of 2 total tests failed: (T 2)." - "Doing 1 pending test of 2 tests total." - "Test (T 2) failed" - "Form: 4" - "Expected value: 3" - "Actual value: 4." - "1 out of 2 total tests failed: (T 2)." - "Doing 2 pending tests of 2 tests total." - " RT-TESTS::T1" - "Test (T 2) failed" - "Form: 4" - "Expected value: 3" - "Actual value: 4." - "1 out of 2 total tests failed: (T 2).") - nil - nil - nil) - -(deftest do-tests-2 - (setup (rem-test '(t 2)) - (deftest (t 2) 3 3) - (values (do-tests) (continue-testing) (do-tests))) - ("Doing 2 pending tests of 2 tests total." - " RT-TESTS::T1 (T 2)" - "No tests failed." - "Doing 0 pending tests of 2 tests total." - "No tests failed." - "Doing 2 pending tests of 2 tests total." - " RT-TESTS::T1 (T 2)" - "No tests failed.") - t - t - t) -(deftest do-tests-3 - (setup (rem-all-tests) (values (do-tests) (continue-testing))) - ("Doing 0 pending tests of 0 tests total." - "No tests failed." - "Doing 0 pending tests of 0 tests total." - "No tests failed.") - t - t) -(deftest do-tests-4 - (setup (normalize (with-output-to-string (s) (do-tests :out s)))) - () - ("Doing 2 pending tests of 2 tests total." - " RT-TESTS::T1" - "Test (T 2) failed" - "Form: 4" - "Expected value: 3" - "Actual value: 4." - "1 out of 2 total tests failed: (T 2).")) -(deftest do-tests-5 - (setup (with-temporary-file s (do-tests :out s))) - () - ("Doing 2 pending tests of 2 tests total." - " RT-TESTS::T1" - "Test (T 2) failed" - "Form: 4" - "Expected value: 3" - "Actual value: 4." - "1 out of 2 total tests failed: (T 2).")) - -(deftest continue-testing-1 - (setup (deftest temp (continue-testing) 5) (do-test 'temp) (pending-tests)) - () (t1 (t 2) temp)) diff --git a/t/ansi-test/rt.lsp b/t/ansi-test/rt.lsp deleted file mode 100644 index 349fa00..0000000 --- a/t/ansi-test/rt.lsp +++ /dev/null @@ -1,453 +0,0 @@ -;-*-syntax:COMMON-LISP;Package:(RT :use "COMMON-LISP" :colon-mode :external)-*- - -#|----------------------------------------------------------------------------| - | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. | - | | - | Permission to use, copy, modify, and distribute this software and its | - | documentation for any purpose and without fee is hereby granted, provided | - | that this copyright and permission notice appear in all copies and | - | supporting documentation, and that the name of M.I.T. not be used in | - | advertising or publicity pertaining to distribution of the software | - | without specific, written prior permission. M.I.T. makes no | - | representations about the suitability of this software for any purpose. | - | It is provided "as is" without express or implied warranty. | - | | - | M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING | - | ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL | - | M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR | - | ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, | - | WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, | - | ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS | - | SOFTWARE. | - |----------------------------------------------------------------------------|# - -;This was the December 19, 1990 version of the regression tester, but -;has since been modified. - -(in-package :regression-test) - -(declaim (ftype (function (t) t) get-entry expanded-eval do-entries)) -(declaim (type list *entries*)) -(declaim (ftype (function (t &rest t) t) report-error)) -(declaim (ftype (function (t &optional t) t) do-entry)) - -(defvar *test* nil "Current test name") -(defvar *do-tests-when-defined* nil) -(defvar *entries* (list nil) "Test database. Has a leading dummy cell that does not contain an entry.") -(defvar *entries-tail* *entries* "Tail of the *entries* list") -(defvar *entries-table* (make-hash-table :test #'equal) - "Map the names of entries to the cons cell in *entries* that precedes the one whose car is the entry.") -(defvar *in-test* nil "Used by TEST") -(defvar *debug* nil "For debugging") -(defvar *catch-errors* t "When true, causes errors in a test to be caught.") -(defvar *print-circle-on-failure* nil - "Failure reports are printed with *PRINT-CIRCLE* bound to this value.") - -(defvar *compile-tests* nil "When true, compile the tests before running them.") -(defvar *expanded-eval* nil "When true, convert the tests into a form that is less likely to have compiler optimizations.") -(defvar *optimization-settings* '((safety 3))) - -(defvar *failed-tests* nil "After DO-TESTS, becomes the list of names of tests that have failed") -(defvar *passed-tests* nil "After DO-TESTS, becomes the list of names of tests that have passed") - -(defvar *expected-failures* nil - "A list of test names that are expected to fail.") - -(defvar *unexpected-successes* nil - "A list of tests that passed but were expected to fail.") - -(defvar *unexpected-failures* nil - "A list of tests that failed but were not expected to fail.") - -(defvar *notes* (make-hash-table :test 'equal) - "A mapping from names of notes to note objects.") - -(defstruct (entry (:conc-name nil)) - pend name props form vals) - -;;; Note objects are used to attach information to tests. -;;; A typical use is to mark tests that depend on a particular -;;; part of a set of requirements, or a particular interpretation -;;; of the requirements. - -(defstruct note - name - contents - disabled ;; When true, tests with this note are considered inactive - ) - -;; (defmacro vals (entry) `(cdddr ,entry)) - -(defmacro defn (entry) - (let ((var (gensym))) - `(let ((,var ,entry)) - (list* (name ,var) (form ,var) (vals ,var))))) - -(defun entry-notes (entry) - (let* ((props (props entry)) - (notes (getf props :notes))) - (if (listp notes) - notes - (list notes)))) - -(defun has-disabled-note (entry) - (let ((notes (entry-notes entry))) - (loop for n in notes - for note = (if (note-p n) n - (gethash n *notes*)) - thereis (and note (note-disabled note))))) - -(defun has-note (entry note) - (unless (note-p note) - (let ((new-note (gethash note *notes*))) - (setf note new-note))) - (and note (not (not (member note (entry-notes entry)))))) - -(defun pending-tests () - (loop for entry in (cdr *entries*) - when (and (pend entry) (not (has-disabled-note entry))) - collect (name entry))) - -(defun rem-all-tests () - (setq *entries* (list nil)) - (setq *entries-tail* *entries*) - (clrhash *entries-table*) - nil) - -(defun rem-test (&optional (name *test*)) - (let ((pred (gethash name *entries-table*))) - (when pred - (if (null (cddr pred)) - (setq *entries-tail* pred) - (setf (gethash (name (caddr pred)) *entries-table*) pred)) - (setf (cdr pred) (cddr pred)) - (remhash name *entries-table*) - name))) - -(defun get-test (&optional (name *test*)) - (defn (get-entry name))) - -(defun get-entry (name) - (let ((entry ;; (find name (the list (cdr *entries*)) - ;; :key #'name :test #'equal) - (cadr (gethash name *entries-table*)) - )) - (when (null entry) - (report-error t - "~%No test with name ~:@(~S~)." - name)) - entry)) - -(defmacro deftest (name &rest body) - (let* ((p body) - (properties - (loop while (keywordp (first p)) - unless (cadr p) - do (error "Poorly formed deftest: ~A~%" - (list* 'deftest name body)) - append (list (pop p) (pop p)))) - (form (pop p)) - (vals p)) - `(add-entry (make-entry :pend t - :name ',name - :props ',properties - :form ',form - :vals ',vals)))) - -(defun add-entry (entry) - (setq entry (copy-entry entry)) - (let* ((pred (gethash (name entry) *entries-table*))) - (cond - (pred - (setf (cadr pred) entry) - (report-error nil - "Redefining test ~:@(~S~)" - (name entry))) - (t - (setf (gethash (name entry) *entries-table*) *entries-tail*) - (setf (cdr *entries-tail*) (cons entry nil)) - (setf *entries-tail* (cdr *entries-tail*)) - ))) - (when *do-tests-when-defined* - (do-entry entry)) - (setq *test* (name entry))) - -(defun report-error (error? &rest args) - (cond (*debug* - (apply #'format t args) - (if error? (throw '*debug* nil))) - (error? (apply #'error args)) - (t (apply #'warn args))) - nil) - -(defun do-test (&optional (name *test*) &rest key-args) - (flet ((%parse-key-args - (&key - ((:catch-errors *catch-errors*) *catch-errors*) - ((:compile *compile-tests*) *compile-tests*)) - (do-entry (get-entry name)))) - (apply #'%parse-key-args key-args))) - -(defun my-aref (a &rest args) - (apply #'aref a args)) - -(defun my-row-major-aref (a index) - (row-major-aref a index)) - -(defun equalp-with-case (x y) - "Like EQUALP, but doesn't do case conversion of characters. - Currently doesn't work on arrays of dimension > 2." - (cond - ((eq x y) t) - ((consp x) - (and (consp y) - (equalp-with-case (car x) (car y)) - (equalp-with-case (cdr x) (cdr y)))) - ((and (typep x 'array) - (= (array-rank x) 0)) - (equalp-with-case (my-aref x) (my-aref y))) - ((typep x 'vector) - (and (typep y 'vector) - (let ((x-len (length x)) - (y-len (length y))) - (and (eql x-len y-len) - (loop - for i from 0 below x-len - for e1 = (my-aref x i) - for e2 = (my-aref y i) - always (equalp-with-case e1 e2)))))) - ((and (typep x 'array) - (typep y 'array) - (not (equal (array-dimensions x) - (array-dimensions y)))) - nil) - - ((typep x 'array) - (and (typep y 'array) - (let ((size (array-total-size x))) - (loop for i from 0 below size - always (equalp-with-case (my-row-major-aref x i) - (my-row-major-aref y i)))))) - ((typep x 'pathname) - (equal x y)) - (t (eql x y)))) - -(defun do-entry (entry &optional - (s *standard-output*)) - (catch '*in-test* - (setq *test* (name entry)) - (setf (pend entry) t) - (let* ((*in-test* t) - ;; (*break-on-warnings* t) - (aborted nil) - r) - ;; (declare (special *break-on-warnings*)) - - (block aborted - (setf r - (flet ((%do () - (handler-bind - #-sbcl nil - #+sbcl ((sb-ext:code-deletion-note #'(lambda (c) - (if (has-note entry :do-not-muffle) - nil - (muffle-warning c))))) - (cond - (*compile-tests* - (multiple-value-list - (funcall (compile - nil - `(lambda () - (declare - (optimize ,@*optimization-settings*)) - ,(form entry)))))) - (*expanded-eval* - (multiple-value-list - (expanded-eval (form entry)))) - (t - (multiple-value-list - (eval (form entry)))))))) - (if *catch-errors* - (handler-bind - (#-ecl (style-warning #'(lambda (c) (if (has-note entry :do-not-muffle-warnings) - c - (muffle-warning c)))) - (error #'(lambda (c) - (setf aborted t) - (setf r (list c)) - (return-from aborted nil)))) - (%do)) - (%do))))) - - (setf (pend entry) - (or aborted - (not (equalp-with-case r (vals entry))))) - - (when (pend entry) - (let ((*print-circle* *print-circle-on-failure*)) - (format s "~&Test ~:@(~S~) failed~%Form: ~S~%Expected value~P:~%" - *test* (form entry) (length (vals entry))) - (dolist (v (vals entry)) (format s "~10t~S~%" v)) - (handler-case - (progn - (format s "Actual value~P:~%" (length r)) - (dolist (v r) - (format s "~10t~S~:[~; [~2:*~A]~]~%" - v (typep v 'condition)))) - (error () (format s "Actual value: #~%"))) - (finish-output s))))) - (when (not (pend entry)) *test*)) - -(defun expanded-eval (form) - "Split off top level of a form and eval separately. This reduces the chance that - compiler optimizations will fold away runtime computation." - (if (not (consp form)) - (eval form) - (let ((op (car form))) - (cond - ((eq op 'let) - (let* ((bindings (loop for b in (cadr form) - collect (if (consp b) b (list b nil)))) - (vars (mapcar #'car bindings)) - (binding-forms (mapcar #'cadr bindings))) - (apply - (the function - (eval `(lambda ,vars ,@(cddr form)))) - (mapcar #'eval binding-forms)))) - ((and (eq op 'let*) (cadr form)) - (let* ((bindings (loop for b in (cadr form) - collect (if (consp b) b (list b nil)))) - (vars (mapcar #'car bindings)) - (binding-forms (mapcar #'cadr bindings))) - (funcall - (the function - (eval `(lambda (,(car vars) &aux ,@(cdr bindings)) ,@(cddr form)))) - (eval (car binding-forms))))) - ((eq op 'progn) - (loop for e on (cdr form) - do (if (null (cdr e)) (return (eval (car e))) - (eval (car e))))) - ((and (symbolp op) (fboundp op) - (not (macro-function op)) - (not (special-operator-p op))) - (apply (symbol-function op) - (mapcar #'eval (cdr form)))) - (t (eval form)))))) - -(defun continue-testing () - (if *in-test* - (throw '*in-test* nil) - (do-entries *standard-output*))) - -(defun do-tests (&key (out *standard-output*) - ((:catch-errors *catch-errors*) *catch-errors*) - ((:compile *compile-tests*) *compile-tests*)) - (setq *failed-tests* nil - *passed-tests* nil) - (dolist (entry (cdr *entries*)) - (setf (pend entry) t)) - (if (streamp out) - (do-entries out) - (with-open-file - (stream out :direction :output) - (do-entries stream)))) - -(defun do-entries (s) - (format s "~&Doing ~A pending test~:P ~ - of ~A tests total.~%" - (count t (the list (cdr *entries*)) :key #'pend) - (length (cdr *entries*))) - (finish-output s) - (dolist (entry (cdr *entries*)) - (when (and (pend entry) - (not (has-disabled-note entry))) - (let ((success? (do-entry entry s))) - (if success? - (push (name entry) *passed-tests*) - (push (name entry) *failed-tests*)) - (format s "~@[~<~%~:; ~:@(~S~)~>~]" success?)) - (finish-output s) - )) - (let ((pending (pending-tests)) - (expected-table (make-hash-table :test #'equal))) - (dolist (ex *expected-failures*) - (setf (gethash ex expected-table) t)) - (let ((new-failures - (loop for pend in pending - unless (gethash pend expected-table) - collect pend))) - (if (null pending) - (format s "~&No tests failed.") - (progn - (format t "~&~A out of ~A total tests failed: ~%(~{~a~^~%~})" - (length pending) - (length (cdr *entries*)) - pending) - (if (null new-failures) - (format s "~&No unexpected failures.") - (when *expected-failures* - (setf *unexpected-failures* new-failures) - (format s "~&~A unexpected failures: ~ - ~:@(~{~<~% ~1:;~S~>~ - ~^, ~}~)." - (length new-failures) - new-failures))) - (when *expected-failures* - (let ((pending-table (make-hash-table :test #'equal))) - (dolist (ex pending) - (setf (gethash ex pending-table) t)) - (let ((unexpected-successes - (loop :for ex :in *expected-failures* - :unless (gethash ex pending-table) :collect ex))) - (if unexpected-successes - (progn - (setf *unexpected-successes* unexpected-successes) - (format t "~&~:D unexpected successes: ~ - ~:@(~{~<~% ~1:;~S~>~ - ~^, ~}~)." - (length unexpected-successes) - unexpected-successes)) - (format t "~&No unexpected successes."))))) - )) - (finish-output s) - (null pending)))) - -;;; Note handling functions and macros - -(defmacro defnote (name contents &optional disabled) - `(eval-when (:load-toplevel :execute) - (let ((note (make-note :name ',name - :contents ',contents - :disabled ',disabled))) - (setf (gethash (note-name note) *notes*) note) - note))) - -(defun disable-note (n) - (let ((note (if (note-p n) n - (setf n (gethash n *notes*))))) - (unless note (error "~A is not a note or note name." n)) - (setf (note-disabled note) t) - note)) - -(defun enable-note (n) - (let ((note (if (note-p n) n - (setf n (gethash n *notes*))))) - (unless note (error "~A is not a note or note name." n)) - (setf (note-disabled note) nil) - note)) - -;;; Extended random regression - -(defun do-extended-tests (&key (tests *passed-tests*) (count nil) - ((:catch-errors *catch-errors*) *catch-errors*) - ((:compile *compile-tests*) *compile-tests*)) - "Execute randomly chosen tests from TESTS until one fails or until - COUNT is an integer and that many tests have been executed." - (let ((test-vector (coerce tests 'simple-vector))) - (let ((n (length test-vector))) - (when (= n 0) (error "Must provide at least one test.")) - (loop for i from 0 - for name = (svref test-vector (random n)) - until (eql i count) - do (print name) - unless (do-test name) return (values name (1+ i)))))) diff --git a/t/ansi-test/rt.system b/t/ansi-test/rt.system deleted file mode 100644 index c30eea7..0000000 --- a/t/ansi-test/rt.system +++ /dev/null @@ -1,22 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Mar 7 23:30:22 1998 -;;;; Contains: Portable defsystem for RT testing system - -(mk::defsystem "rt" - :source-pathname #.(directory-namestring *LOAD-TRUENAME*) - :binary-pathname #.(mk::append-directories - (directory-namestring *LOAD-TRUENAME*) - "binary/") - :source-extension "lsp" - :binary-extension - #+CMU #.(C::BACKEND-FASL-FILE-TYPE C::*TARGET-BACKEND*) - #+ALLEGRO "fasl" - #+(OR AKCL GCL) "o" - #+CLISP "fas" - #-(OR CMU ALLEGRO AKCL GCL CLISP) - #.(pathname-type (compile-file-pathname "foo.lisp")) - :components - ( - "rt-package" - ("rt" :depends-on ("rt-package")))) diff --git a/t/ansi-test/sequences/concatenate.lsp b/t/ansi-test/sequences/concatenate.lsp deleted file mode 100644 index e33d094..0000000 --- a/t/ansi-test/sequences/concatenate.lsp +++ /dev/null @@ -1,332 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Sep 4 22:53:51 2002 -;;;; Contains: Tests for CONCATENATE - -(in-package :cl-test) - -(deftest concatenate.1 - (concatenate 'list) - nil) - -(deftest concatenate.2 - (let* ((orig (list 'a 'b 'c 'd 'e)) - (copy (concatenate 'list orig))) - (values - copy - (intersection (loop for e on orig collect e) - (loop for e on copy collect e) - :test #'eq))) - (a b c d e) - nil) - -(deftest concatenate.3 - (concatenate 'list "") - nil) - -(deftest concatenate.4 - (concatenate 'list "abcd" '(x y z) nil #*1101 #()) - (#\a #\b #\c #\d x y z 1 1 0 1)) - -(deftest concatenate.5 - (concatenate 'vector) - #()) - -(deftest concatenate.6 - (concatenate 'vector nil "abcd" '(x y z) nil #*1101 #()) - #(#\a #\b #\c #\d x y z 1 1 0 1)) - -(deftest concatenate.7 - (let* ((orig (vector 'a 'b 'c 'd 'e)) - (copy (concatenate 'vector orig))) - (values - copy - (eqt copy orig))) - #(a b c d e) - nil) - -(deftest concatenate.8 - (concatenate 'simple-vector '(a b c) #(1 2 3)) - #(a b c 1 2 3)) - -(deftest concatenate.9 - (concatenate 'simple-vector) - #()) - -(deftest concatenate.10 - (concatenate 'bit-vector nil) - #*) - -(deftest concatenate.11 - (concatenate 'bit-vector) - #*) - -(deftest concatenate.12 - (concatenate 'bit-vector '(0 1 1) nil #(1 0 1) #()) - #*011101) - -(deftest concatenate.13 - (concatenate 'simple-bit-vector nil) - #*) - -(deftest concatenate.14 - (concatenate 'simple-bit-vector) - #*) - -(deftest concatenate.15 - (concatenate 'simple-bit-vector '(0 1 1) nil #(1 0 1) #()) - #*011101) - -(deftest concatenate.16 - (concatenate 'string "abc" '(#\d #\e) nil #() "fg") - "abcdefg") - -(deftest concatenate.17 - (concatenate 'simple-string "abc" '(#\d #\e) nil #() "fg") - "abcdefg") - -(deftest concatenate.18 - (concatenate '(vector * *) '(a b c) '(d e f) #(g h)) - #(a b c d e f g h)) - -(deftest concatenate.18a - (concatenate '(vector *) '(a b c) '(d e f) #(g h)) - #(a b c d e f g h)) - -(deftest concatenate.18b - (concatenate '(vector) '(a b c) '(d e f) #(g h)) - #(a b c d e f g h)) - -(deftest concatenate.18c - (concatenate '(simple-vector *) '(a b c) '(d e f) #(g h)) - #(a b c d e f g h)) - -(deftest concatenate.18d - (concatenate '(simple-vector) '(a b c) '(d e f) #(g h)) - #(a b c d e f g h)) - -(deftest concatenate.19 - (concatenate '(vector * 8) '(a b c) '(d e f) #(g h)) - #(a b c d e f g h)) - -(deftest concatenate.20 - (concatenate '(vector symbol 8) '(a b c) '(d e f) #(g h)) - #(a b c d e f g h)) - -(deftest concatenate.21 - (concatenate '(vector symbol) '(a b c) '(d e f) #(g h)) - #(a b c d e f g h)) - -(deftest concatenate.22 - (concatenate '(vector symbol *) '(a b c) '(d e f) #(g h)) - #(a b c d e f g h)) - -(deftest concatenate.23 - (concatenate 'cons '(a b c) '(d e f)) - (a b c d e f)) - -(deftest concatenate.24 - (concatenate 'null nil nil) - nil) - -;;; Tests on vectors with fill pointers - -(deftest concatenate.25 - (let ((x (make-array '(10) :initial-contents '(a b c d e f g h i j) - :fill-pointer 5))) - (concatenate 'list x x)) - (a b c d e a b c d e)) - -(deftest concatenate.26 - (let ((x (make-array '(10) :initial-contents '(a b c d e f g h i j) - :fill-pointer 5))) - (concatenate 'list x)) - (a b c d e)) - -(deftest concatenate.27 - (let* ((x (make-array '(10) :initial-contents '(a b c d e f g h i j) - :fill-pointer 5)) - (result (concatenate 'vector x))) - (values (not (simple-vector-p result)) - result)) - nil - #(a b c d e)) - -(deftest concatenate.28 - (let* ((x (make-array '(10) :initial-contents "abcdefghij" - :fill-pointer 5 :element-type 'character))) - (values - (concatenate 'string x '(#\z)) - (concatenate 'string '(#\z) x) - (concatenate 'string x x) - (concatenate 'string x) - (not (simple-string-p (concatenate 'string x))) - )) - "abcdez" - "zabcde" - "abcdeabcde" - "abcde" - nil) - -(deftest concatenate.29 - (let* ((x (make-array '(10) :initial-contents "abcdefghij" - :fill-pointer 5 :element-type 'base-char))) - (values - (concatenate 'string x '(#\z)) - (concatenate 'string '(#\z) x) - (concatenate 'string x x) - (concatenate 'string x) - (not (simple-string-p (concatenate 'string x))) - )) - "abcdez" - "zabcde" - "abcdeabcde" - "abcde" - nil) - -(deftest concatenate.30 - (let* ((x (make-array '(10) :initial-contents #*0110010111 - :fill-pointer 5 :element-type 'bit))) - (values - (concatenate 'bit-vector x '(0)) - (concatenate '(bit-vector) '(0) x) - (concatenate '(bit-vector 10) x x) - (concatenate '(bit-vector *) x) - (not (simple-bit-vector-p (concatenate 'bit-vector x))) - )) - #*011000 - #*001100 - #*0110001100 - #*01100 - nil) - -(deftest concatenate.30a - (let* ((x (make-array '(10) :initial-contents #*0110010111 - :fill-pointer 5 :element-type 'bit))) - (values - (concatenate 'simple-bit-vector x '(0)) - (concatenate 'simple-bit-vector '(0) x) - (concatenate 'simple-bit-vector x x) - (concatenate 'simple-bit-vector x) - (not (simple-bit-vector-p (concatenate 'bit-vector x))) - )) - #*011000 - #*001100 - #*0110001100 - #*01100 - nil) - -(deftest concatenate.31 - :notes (:nil-vectors-are-strings) - (concatenate 'string "abc" (make-array '(0) :element-type nil) "def") - "abcdef") - -(deftest concatenate.32 - :notes (:nil-vectors-are-strings) - (concatenate '(array nil (*))) - "") - -(deftest concatenate.33 - (do-special-strings - (s "abc" nil) - (assert (string= (concatenate 'string s s s) "abcabcabc")) - (assert (string= (concatenate 'string "xy" s) "xyabc")) - (assert (string= (concatenate 'simple-string s "z" s "w" s) "abczabcwabc")) - (assert (string= (concatenate 'base-string s "z" s "w" s) "abczabcwabc")) - (assert (string= (concatenate 'simple-base-string s "z" s "w" s) "abczabcwabc")) - (assert (string= (concatenate '(vector character) s "z" s "w" s) "abczabcwabc"))) - nil) - -(deftest concatenate.34 - (concatenate 'simple-string "abc" "def") - "abcdef") - -(deftest concatenate.35 - (concatenate '(simple-string) "abc" "def") - "abcdef") - -(deftest concatenate.36 - (concatenate '(simple-string *) "abc" "def") - "abcdef") - -(deftest concatenate.37 - (concatenate '(simple-string 6) "abc" "def") - "abcdef") - -(deftest concatenate.38 - (concatenate '(string) "abc" "def") - "abcdef") - -(deftest concatenate.39 - (concatenate '(string *) "abc" "def") - "abcdef") - -(deftest concatenate.40 - (concatenate '(string 6) "abc" "def") - "abcdef") - -;;; Order of evaluation tests - -(deftest concatenate.order.1 - (let ((i 0) w x y z) - (values - (concatenate (progn (setf w (incf i)) 'string) - (progn (setf x (incf i)) "abc") - (progn (setf y (incf i)) "def") - (progn (setf z (incf i)) "ghi")) - i w x y z)) - "abcdefghi" 4 1 2 3 4) - -(deftest concatenate.order.2 - (let ((i 0) x y z) - (values - (concatenate 'string - (progn (setf x (incf i)) "abc") - (progn (setf y (incf i)) "def") - (progn (setf z (incf i)) "ghi")) - i x y z)) - "abcdefghi" 3 1 2 3) - -;;; Constant folding tests - -(def-fold-test concatenate.fold.1 (concatenate 'list '(a b) '(c d))) -(def-fold-test concatenate.fold.2 (concatenate 'vector '(a b) '(c d))) -(def-fold-test concatenate.fold.3 (concatenate 'bit-vector '(0 0) '(1 0 1))) -(def-fold-test concatenate.fold.4 (concatenate 'string "ab" "cd")) -(def-fold-test concatenate.fold.5 (concatenate 'list '(a b c d))) -(def-fold-test concatenate.fold.6 (concatenate 'vector #(a b c d))) -(def-fold-test concatenate.fold.7 (concatenate 'bit-vector #*110101101)) -(def-fold-test concatenate.fold.8 (concatenate 'string "abcdef")) - -;;; Error tests - -(deftest concatenate.error.1 - (signals-error (concatenate 'sequence '(a b c)) error) - t) - -(deftest concatenate.error.2 - (signals-error-always (concatenate 'fixnum '(a b c d e)) error) - t t) - -(deftest concatenate.error.3 - (signals-error (concatenate '(vector * 3) '(a b c d e)) - type-error) - t) - -(deftest concatenate.error.4 - (signals-error (concatenate) program-error) - t) - -(deftest concatenate.error.5 - (signals-error (locally (concatenate '(vector * 3) '(a b c d e)) t) - type-error) - t) - -(deftest concatenate.error.6 - :notes (:result-type-element-type-by-subtype) - (let ((type '(or (vector bit) (vector t)))) - (if (subtypep type 'vector) - (eval `(signals-error-always (concatenate ',type '(0 1 0) '(1 1 0)) error)) - (values t t))) - t t) - diff --git a/t/ansi-test/sequences/copy-seq.lsp b/t/ansi-test/sequences/copy-seq.lsp deleted file mode 100644 index eb17040..0000000 --- a/t/ansi-test/sequences/copy-seq.lsp +++ /dev/null @@ -1,251 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Nov 2 21:38:08 2002 -;;;; Contains: Tests for COPY-SEQ - -(in-package :cl-test) - -;;; This function is extensively used elsewhere, but is tested again -;;; here for completeness. - -(deftest copy-seq.1 - (copy-seq nil) - nil) - -(deftest copy-seq.2 - (let* ((s1 '(a b c)) - (s2 (check-values (copy-seq s1)))) - (and (not (eql s1 s2)) - (equalt s1 s2))) - t) - -(deftest copy-seq.3 - (let* ((s1 #(a b c)) - (s2 (check-values (copy-seq s1)))) - (and (not (eql s1 s2)) s2)) - #(a b c)) - -(deftest copy-seq.4 - (let* ((s1 (make-array '(4) :initial-contents '(a b c d) - :adjustable t)) - (s2 (check-values (copy-seq s1)))) - (and (not (eql s1 s2)) - (simple-vector-p s2) - s2)) - #(a b c d)) - - -(deftest copy-seq.5 - (let* ((s1 (make-array '(4) :initial-contents '(a b c d) - :fill-pointer 3)) - (s2 (check-values (copy-seq s1)))) - (and (not (eql s1 s2)) - (simple-vector-p s2) - s2)) - #(a b c)) - -(deftest copy-seq.6 - (let* ((a1 (make-array '(6) :initial-contents '(a b c d e f))) - (a2 (make-array '(4) :displaced-to a1 - :displaced-index-offset 1)) - (s2 (check-values (copy-seq a2)))) - (and (not (eql a2 s2)) - (simple-vector-p s2) - s2)) - #(b c d e)) - -(deftest copy-seq.7 - (let* ((s1 (make-array '(4) - :element-type 'base-char - :initial-contents '(#\a #\b #\c #\d) - :adjustable t)) - (s2 (check-values (copy-seq s1)))) - (and (not (eql s1 s2)) - (simple-string-p s2) - s2)) - "abcd") - - -(deftest copy-seq.8 - (let* ((s1 (make-array '(4) - :element-type 'base-char - :initial-contents '(#\a #\b #\c #\d) - :fill-pointer 3)) - (s2 (check-values (copy-seq s1)))) - (and (not (eql s1 s2)) - (simple-string-p s2) - s2)) - "abc") - -(deftest copy-seq.9 - (let* ((a1 (make-array '(6) :initial-contents '(#\a #\b #\c #\d #\e #\f) - :element-type 'base-char)) - (a2 (make-array '(4) :displaced-to a1 - :element-type 'base-char - :displaced-index-offset 1)) - (s2 (check-values (copy-seq a2)))) - (and (not (eql a2 s2)) - (simple-string-p s2) - s2)) - "bcde") - -(deftest copy-seq.10 - (let*((s1 "abcd") - (s2 (check-values (copy-seq s1)))) - (and (not (eql s1 s2)) - s2)) - "abcd") - -(deftest copy-seq.11 - (let* ((s1 #*0010110) - (s2 (check-values (copy-seq s1)))) - (and (not (eql s1 s2)) - (simple-bit-vector-p s2) - s2)) - #*0010110) - -(deftest copy-seq.12 - (let* ((s1 (make-array '(4) :initial-contents '(0 0 1 0) - :element-type 'bit - :adjustable t)) - (s2 (check-values (copy-seq s1)))) - (and (not (eql s1 s2)) - (simple-bit-vector-p s2) - s2)) - #*0010) - -(deftest copy-seq.13 - (let* ((s1 (make-array '(4) :initial-contents '(0 0 1 0) - :element-type 'bit - :fill-pointer 3)) - (s2 (check-values (copy-seq s1)))) - (and (not (eql s1 s2)) - (simple-bit-vector-p s2) - s2)) - #*001) - -(deftest copy-seq.14 - (let* ((a1 (make-array '(6) :initial-contents '(0 0 1 0 1 1) - :element-type 'bit)) - (a2 (make-array '(4) :displaced-to a1 - :displaced-index-offset 1 - :element-type 'bit)) - (s2 (check-values (copy-seq a2)))) - (and (not (eql a2 s2)) - (simple-bit-vector-p s2) - s2)) - #*0101) - -(deftest copy-seq.15 - (copy-seq "") - "") - -(deftest copy-seq.16 - (copy-seq #*) - #*) - -(deftest copy-seq.17 - (copy-seq #()) - #()) - -(deftest copy-seq.18 - (let* ((x (make-array '(10) :initial-contents '(a b c d e f g h i j))) - (y (check-values (copy-seq x)))) - (equal-array x y)) - t) - -(deftest copy-seq.19 - :notes (:nil-vectors-are-strings) - (copy-seq (make-array '(0) :element-type nil)) - "") - -;;; Specialized string tests - -(deftest copy-seq.20 - (do-special-strings - (s "abcde" nil) - (let ((s2 (copy-seq s))) - (assert (typep s2 'simple-array)) - (assert (string= s s2)) - (assert (equal (array-element-type s) (array-element-type s2))))) - nil) - -;;; Specialized vector tests - -(deftest copy-seq.21 - (let ((v0 #(1 1 0 1 1 2))) - (do-special-integer-vectors - (v v0 nil) - (let ((v2 (copy-seq v))) - (assert (typep v2 'simple-array)) - (assert (equalp v v2)) - (assert (equalp v v0)) - (assert (equal (array-element-type v) (array-element-type v2)))))) - nil) - -(deftest copy-seq.22 - (let ((v0 #(-1 1 1 0 1 -1 0))) - (do-special-integer-vectors - (v v0 nil) - (let ((v2 (copy-seq v))) - (assert (typep v2 'simple-array)) - (assert (equalp v v2)) - (assert (equalp v v0)) - (assert (equal (array-element-type v) (array-element-type v2)))))) - nil) - -(deftest copy-seq.23 - (loop for type in '(short-float single-float long-float double-float) - for len = 10 - for vals = (loop for i from 1 to len collect (coerce i type)) - for vec = (make-array len :element-type type :initial-contents vals) - for result = (copy-seq vec) - unless (and (= (length result) len) - (equal (array-element-type vec) (array-element-type result)) - (equalp vec result)) - collect (list type vals result)) - nil) - -(deftest copy-seq.24 - (loop for etype in '(short-float single-float long-float double-float) - for type = `(complex ,etype) - for len = 10 - for vals = (loop for i from 1 to len collect (complex (coerce i etype) - (coerce (- i) etype))) - for vec = (make-array len :element-type type :initial-contents vals) - for result = (copy-seq vec) - unless (and (= (length result) len) - (equal (array-element-type vec) (array-element-type result)) - (equalp vec result)) - collect (list type vals result)) - nil) - -;;; Order of evaluation test - -(deftest copy-seq.order.1 - (let ((i 0)) - (values (copy-seq (progn (incf i) "abc")) i)) - "abc" 1) - -(def-fold-test copy-seq.fold.1 (copy-seq '(a b c))) -(def-fold-test copy-seq.fold.2 (copy-seq #(a b c))) -(def-fold-test copy-seq.fold.3 (copy-seq #*01101100)) -(def-fold-test copy-seq.fold.4 (copy-seq "abcdef")) - -;;; Error tests - -(deftest copy-seq.error.1 - (check-type-error #'copy-seq #'sequencep) - nil) - -(deftest copy-seq.error.4 - (signals-error (copy-seq) program-error) - t) - -(deftest copy-seq.error.5 - (signals-error (copy-seq "abc" 2 nil) program-error) - t) - -(deftest copy-seq.error.6 - (signals-error (locally (copy-seq 10) t) type-error) - t) diff --git a/t/ansi-test/sequences/count-if-not.lsp b/t/ansi-test/sequences/count-if-not.lsp deleted file mode 100644 index a2f7dfd..0000000 --- a/t/ansi-test/sequences/count-if-not.lsp +++ /dev/null @@ -1,585 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Aug 20 22:42:35 2002 -;;;; Contains: Tests for COUNT-IF-NOT - -(in-package :cl-test) - -(deftest count-if-not-list.1 - (count-if-not #'identity '(a b nil c d nil e)) - 2) - -(deftest count-if-not-list.2 - (count-if-not #'not '(a b nil c d nil e)) - 5) - -(deftest count-if-not-list.3 - (count-if-not #'(lambda (x) (break)) nil) - 0) - -(deftest count-if-not-list.4 - (count-if-not #'identity '(a b nil c d nil e) :key #'identity) - 2) - -(deftest count-if-not-list.5 - (count-if-not 'identity '(a b nil c d nil e) :key #'identity) - 2) - -(deftest count-if-not-list.6 - (count-if-not #'identity '(a b nil c d nil e) :key 'identity) - 2) - -(deftest count-if-not-list.8 - (count-if-not #'identity '(a b nil c d nil e) :key 'not) - 5) - -(deftest count-if-not-list.9 - (count-if-not #'oddp '(1 2 3 4 4 1 8 10 1)) - 5) - -(deftest count-if-not-list.10 - (count-if-not #'oddp '(1 2 3 4 4 1 8 10 1) :key #'1+) - 4) - -(deftest count-if-not-list.11 - (let ((c 0)) - (count-if-not #'oddp '(1 2 3 4 4 1 8 10 1) - :key #'(lambda (x) (+ x (incf c))))) - 6) - -(deftest count-if-not-list.12 - (let ((c 0)) - (count-if-not #'oddp '(0 1 2 3 4 4 1 7 10 1) - :from-end t - :key #'(lambda (x) (+ x (incf c))))) - 8) - -(deftest count-if-not-list.13 - (count-if-not #'(lambda (x) (not (eqt x 'a))) - '(a b c d a e f a e f f a a) :start 2) - 4) - -(deftest count-if-not-list.14 - (count-if-not #'(lambda (x) (not (eqt x 'a))) - '(a b c d a e f a e f f a a) :end 7) - 2) - -(deftest count-if-not-list.15 - (count-if-not #'(lambda (x) (not (eqt x 'a))) - '(a b c d a e f a e f f a a) :end 7 - :start 2) - 1) - -(deftest count-if-not-list.16 - (count-if-not #'(lambda (x) (not (eqt x 'a))) - '(a b c d a e f a e f f a a) :end 7 - :start 2 :from-end t) - 1) - - -;;; tests on vectors - -(deftest count-if-not-vector.1 - (count-if-not #'identity #(a b nil c d nil e)) - 2) - -(deftest count-if-not-vector.2 - (count-if-not #'not #(a b nil c d nil e)) - 5) - -(deftest count-if-not-vector.3 - (count-if-not #'(lambda (x) (break)) #()) - 0) - -(deftest count-if-not-vector.4 - (count-if-not #'not #(a b nil c d nil e) :key #'identity) - 5) - -(deftest count-if-not-vector.5 - (count-if-not 'not #(a b nil c d nil e) :key #'identity) - 5) - -(deftest count-if-not-vector.6 - (count-if-not #'not #(a b nil c d nil e) :key 'identity) - 5) - -(deftest count-if-not-vector.8 - (count-if-not #'not #(a b nil c d nil e) :key 'not) - 2) - -(deftest count-if-not-vector.9 - (count-if-not #'oddp #(1 2 3 4 4 1 8 10 1)) - 5) - -(deftest count-if-not-vector.10 - (count-if-not #'oddp #(1 2 3 4 4 1 8 10 1) :key #'1+) - 4) - -(deftest count-if-not-vector.11 - (let ((c 0)) - (count-if-not #'oddp #(1 2 3 4 4 1 8 10 1) - :key #'(lambda (x) (+ x (incf c))))) - 6) - -(deftest count-if-not-vector.12 - (let ((c 0)) - (count-if-not #'oddp #(0 1 2 3 4 4 1 7 10 1) - :from-end t - :key #'(lambda (x) (+ x (incf c))))) - 8) - -(deftest count-if-not-vector.13 - (count-if-not #'(lambda (x) (not (eqt x 'a))) - #(a b c d a e f a e f f a a) :start 2) - 4) - -(deftest count-if-not-vector.14 - (count-if-not #'(lambda (x) (not (eqt x 'a))) - #(a b c d a e f a e f f a a) :end 7) - 2) - -(deftest count-if-not-vector.15 - (count-if-not #'(lambda (x) (not (eqt x 'a))) - #(a b c d a e f a e f f a a) :end 7 - :start 2) - 1) - -(deftest count-if-not-vector.16 - (count-if-not #'(lambda (x) (not (eqt x 'a))) - #(a b c d a e f a e f f a a) :end 7 - :start 2 :from-end t) - 1) - -;;; Non-simple vectors - -(deftest count-if-not-nonsimple-vector.1 - (count-if-not #'identity (make-array 7 :initial-contents '(a b nil c d nil e) - :fill-pointer t - :adjustable t)) - 2) - -(deftest count-if-not-nonsimple-vector.2 - (count-if-not #'not (make-array 7 :initial-contents '(a b nil c d nil e) - :fill-pointer t - :adjustable t)) - 5) - -(deftest count-if-not-nonsimple-vector.3 - (count-if-not #'(lambda (x) (break)) (make-array 0 - :fill-pointer t - :adjustable t)) - 0) - -(deftest count-if-not-nonsimple-vector.4 - (count-if-not #'not - (make-array 7 :initial-contents '(a b nil c d nil e) - :fill-pointer t - :adjustable t) - :key #'identity) - 5) - -(deftest count-if-not-nonsimple-vector.5 - (count-if-not 'not - (make-array 7 :initial-contents '(a b nil c d nil e) - :fill-pointer t - :adjustable t) - :key #'identity) - 5) - -(deftest count-if-not-nonsimple-vector.6 - (count-if-not #'not - (make-array 7 :initial-contents '(a b nil c d nil e) - :fill-pointer t - :adjustable t) - :key 'identity) - 5) - -(deftest count-if-not-nonsimple-vector.8 - (count-if-not #'not - (make-array 7 :initial-contents '(a b nil c d nil e) - :fill-pointer t - :adjustable t) - :key 'not) - 2) - -(deftest count-if-not-nonsimple-vector.9 - (count-if-not #'oddp (make-array 9 :initial-contents '(1 2 3 4 4 1 8 10 1) - :fill-pointer t :adjustable t)) - 5) - -(deftest count-if-not-nonsimple-vector.10 - (count-if-not #'oddp - (make-array 9 :initial-contents '(1 2 3 4 4 1 8 10 1) - :fill-pointer t :adjustable t) - :key #'1+) - 4) - -(deftest count-if-not-nonsimple-vector.11 - (let ((c 0)) - (count-if-not #'oddp - (make-array 9 :initial-contents '(1 2 3 4 4 1 8 10 1) - :fill-pointer t :adjustable t) - :key #'(lambda (x) (+ x (incf c))))) - 6) - -(deftest count-if-not-nonsimple-vector.12 - (let ((c 0)) - (count-if-not #'oddp - (make-array 10 :initial-contents '(0 1 2 3 4 4 1 7 10 1) - :fill-pointer t :adjustable t) - :from-end t - :key #'(lambda (x) (+ x (incf c))))) - 8) - -(deftest count-if-not-nonsimple-vector.13 - (count-if-not #'(lambda (x) (not (eqt x 'a))) - (make-array 13 :initial-contents '(a b c d a e f a e f f a a) - :fill-pointer t :adjustable t) - :start 2) - 4) - -(deftest count-if-not-nonsimple-vector.14 - (count-if-not #'(lambda (x) (not (eqt x 'a))) - (make-array 13 :initial-contents '(a b c d a e f a e f f a a) - :fill-pointer t :adjustable t) - :end 7) - 2) - -(deftest count-if-not-nonsimple-vector.15 - (count-if-not #'(lambda (x) (not (eqt x 'a))) - (make-array 13 :initial-contents '(a b c d a e f a e f f a a) - :fill-pointer t :adjustable t) - :end 7 :start 2) - 1) - -(deftest count-if-not-nonsimple-vector.16 - (count-if-not #'(lambda (x) (not (eqt x 'a))) - (make-array 13 :initial-contents '(a b c d a e f a e f f a a) - :fill-pointer t :adjustable t) - :end 7 :start 2 :from-end t) - 1) - -(deftest count-if-not-nonsimple-vector.17 - (flet ((%a (c) (not (eqt c 'a))) - (%f (c) (not (eqt c 'f)))) - (let ((a (make-array 13 :initial-contents '(a b c d a e f a e f f a a) - :fill-pointer 9))) - (values (count-if-not #'%a a) - (count-if-not #'%a a :from-end t) - (count-if-not #'%f a) - (count-if-not #'%f a :from-end t) - ))) - 3 3 1 1) - -;;; Other special vectors - -`(deftest count-if-not.special-vector.1 - (do-special-integer-vectors - (v #(1 0 1 1 1 0 1 1 1 0 1) nil) - (assert (eql (count-if-not #'plusp v) 3)) - (assert (eql (count-if-not #'zerop v) 8)) - (assert (eql (count-if-not #'plusp v :start 2) 2)) - (assert (eql (count-if-not #'zerop v :end 9) 7))) - nil) - -(deftest count-if-not.special-vector.2 - (do-special-integer-vectors - (v #(1 3 2 4 7 5 6 1 0 2 4) nil) - (assert (eql (count-if-not #'evenp v) 5)) - (assert (eql (count-if-not #'oddp v) 6)) - (assert (eql (count-if-not #'plusp v :start 2) 1)) - (assert (eql (count-if-not #'zerop v :end 8) 8))) - nil) - -(deftest count-if-not.special-vector.3 - (loop for etype in '(short-float single-float double-float long-float) - for vals = (loop for e in '(0 1 2 1 3 0 4 5 6 0) - collect (coerce e etype)) - for vec = (make-array (length vals) :element-type etype :initial-contents vals) - for result = (count-if-not #'zerop vec) - unless (= result 7) - collect (list etype vals vec result)) - nil) - -(deftest count-if-not.special-vector.4 - (loop for cetype in '(short-float single-float double-float long-float integer rational) - for etype = `(complex ,cetype) - for vals = (loop for e in '(6 1 2 1 3 -4 4 5 6 100) - collect (complex 0 (coerce e cetype))) - for vec = (make-array (length vals) :element-type etype :initial-contents vals) - for result = (count-if-not #'(lambda (x) (< (abs x) 5/2)) vec) - unless (= result 7) - collect (list etype vals vec result)) - nil) - - -;;; tests on bit-vectors - -(deftest count-if-not-bit-vector.1 - (count-if-not #'oddp #*001011101101) - 5) - -(deftest count-if-not-bit-vector.2 - (count-if-not #'identity #*001011101101) - 0) - -(deftest count-if-not-bit-vector.3 - (count-if-not #'(lambda (x) (break)) #*) - 0) - -(deftest count-if-not-bit-vector.4 - (count-if-not #'identity #*001011101101 :key #'zerop) - 7) - -(deftest count-if-not-bit-vector.5 - (count-if-not 'not #*001011101101 :key #'zerop) - 5) - -(deftest count-if-not-bit-vector.6 - (count-if-not #'not #*001011101101 :key 'zerop) - 5) - -(deftest count-if-not-bit-vector.8 - (count-if-not #'identity #*001011101101 :key 'oddp) - 5) - -(deftest count-if-not-bit-vector.10 - (count-if-not #'oddp #*001011101101 :key #'1+) - 7) - -(deftest count-if-not-bit-vector.11 - (let ((c 0)) - (count-if-not #'oddp #*001011101101 - :key #'(lambda (x) (+ x (incf c))))) - 7) - -(deftest count-if-not-bit-vector.12 - (let ((c 0)) - (count-if-not #'oddp #*001011101101 - :from-end t - :key #'(lambda (x) (+ x (incf c))))) - 5) - -(deftest count-if-not-bit-vector.13 - (count-if-not #'zerop #*0111011011100 :start 2) - 7) - -(deftest count-if-not-bit-vector.14 - (count-if-not #'zerop #*0111011011100 :end 7) - 5) - -(deftest count-if-not-bit-vector.15 - (count-if-not #'zerop #*0111011011100 :end 7 :start 2) - 4) - -(deftest count-if-not-bit-vector.16 - (count-if-not #'zerop #*0111011011100 :end 7 :start 2 :from-end t) - 4) - -(deftest count-if-not-bit-vector.17 - (let ((a (make-array '(10) :initial-contents '(0 0 0 1 1 1 0 1 0 0) - :fill-pointer 5 - :element-type 'bit))) - (and (bit-vector-p a) - (values (count-if-not #'zerop a) - (count-if-not #'oddp a) - (count-if-not #'zerop a :from-end t) - (count-if-not #'oddp a :from-end t)))) - 2 3 2 3) - -;;; tests on strings - -(deftest count-if-not-string.1 - (count-if-not #'(lambda (x) (eql x #\0)) "001011101101") - 7) - -(deftest count-if-not-string.2 - (count-if-not #'identity "001011101101") - 0) - -(deftest count-if-not-string.3 - (count-if-not #'(lambda (x) (break)) "") - 0) - -(deftest count-if-not-string.4 - (count-if-not #'identity "001011101101" :key #'(lambda (x) (eql x #\0))) - 7) - -(deftest count-if-not-string.5 - (count-if-not 'identity "001011101101" :key #'(lambda (x) (eql x #\0))) - 7) - -(deftest count-if-not-string.6 - (count-if-not #'(lambda (x) (eql x #\0)) "001011101101" :key 'identity) - 7) - -(deftest count-if-not-string.8 - (count-if-not #'identity "001011101101" :key #'(lambda (x) (eql x #\1))) - 5) - -(deftest count-if-not-string.11 - (let ((c 0)) - (count-if-not #'oddp "001011101101" - :key #'(lambda (x) (+ (if (eql x #\0) 0 1) (incf c))))) - 7) - -(deftest count-if-not-string.12 - (let ((c 0)) - (count-if-not #'oddp "001011101101" - :from-end t - :key #'(lambda (x) (+ (if (eql x #\0) 0 1) (incf c))))) - 5) - -(deftest count-if-not-string.13 - (count-if-not #'(lambda (x) (eql x #\0)) "0111011011100" :start 2) - 7) - -(deftest count-if-not-string.14 - (count-if-not #'(lambda (x) (eql x #\0)) "0111011011100" :end 7) - 5) - -(deftest count-if-not-string.15 - (count-if-not #'(lambda (x) (eql x #\0)) "0111011011100" :end 7 :start 2) - 4) - -(deftest count-if-not-string.16 - (count-if-not #'(lambda (x) (eql x #\0)) - "0111011011100" :end 7 :start 2 :from-end t) - 4) - -(deftest count-if-not-string.17 - (flet ((%zerop (c) (eql c #\0)) - (%onep (c) (eql c #\1))) - (let ((a (make-array '(10) :initial-contents "0001110100" - :fill-pointer 5 - :element-type 'character))) - (and (stringp a) - (values (count-if-not #'%zerop a) - (count-if-not #'%onep a) - (count-if-not #'%zerop a :from-end t) - (count-if-not #'%onep a :from-end t))))) - 2 3 2 3) - -(deftest count-if-not-string.18 - (do-special-strings - (s "a1ha^%&%#( 873ff83nfa!" nil) - (assert (= (count-if-not #'alpha-char-p s) 14))) - nil) - -;;; Argument order tests - -(deftest count-if-not.order.1 - (let ((i 0) c1 c2 c3 c4 c5 c6) - (values - (count-if-not - (progn (setf c1 (incf i)) #'null) - (progn (setf c2 (incf i)) '(a nil b c nil d e)) - :start (progn (setf c3 (incf i)) 0) - :end (progn (setf c4 (incf i)) 3) - :key (progn (setf c5 (incf i)) #'not) - :from-end (progn (setf c6 (incf i)) nil) - ) - i c1 c2 c3 c4 c5 c6)) - 1 6 1 2 3 4 5 6) - -(deftest count-if-not.order.2 - (let ((i 0) c1 c2 c3 c4 c5 c6) - (values - (count-if-not - (progn (setf c1 (incf i)) #'null) - (progn (setf c2 (incf i)) '(a nil b c nil d e)) - :from-end (progn (setf c3 (incf i)) nil) - :key (progn (setf c4 (incf i)) #'not) - :end (progn (setf c5 (incf i)) 3) - :start (progn (setf c6 (incf i)) 0) - ) - i c1 c2 c3 c4 c5 c6)) - 1 6 1 2 3 4 5 6) - -;;; Keyword tests - -(deftest count-if-not.keywords.1 - (count-if-not #'oddp '(1 2 3 4 5) :bad t :allow-other-keys t) - 2) - -(deftest count-if-not.keywords.2 - (count-if-not #'oddp '(1 2 3 4 5) :allow-other-keys #p"*" :also-bad t) - 2) - -;;; The leftmost of two :allow-other-keys arguments is the one that matters. -(deftest count-if-not.keywords.3 - (count-if-not #'oddp '(1 2 3 4 5) - :allow-other-keys t - :allow-other-keys nil - :bad t) - 2) - -(deftest count-if-not.keywords.4 - (count-if-not #'oddp '(1 2 3 4 5) :key #'identity :key #'1+) - 2) - -(deftest count-if-not.allow-other-keys.5 - (count-if-not #'null '(nil a b c nil) :allow-other-keys nil) - 3) - -;;; Error tests - -(deftest count-if-not.error.1 - (check-type-error #'(lambda (x) (count-if-not #'identity x)) #'sequencep) - nil) - -(deftest count-if-not.error.4 - (signals-error (count-if-not) program-error) - t) - -(deftest count-if-not.error.5 - (signals-error (count-if-not #'null) program-error) - t) - -(deftest count-if-not.error.6 - (signals-error (count-if-not #'null nil :bad t) program-error) - t) - -(deftest count-if-not.error.7 - (signals-error (count-if-not #'null nil :bad t :allow-other-keys nil) - program-error) - t) - -(deftest count-if-not.error.8 - (signals-error (count-if-not #'null nil :key) program-error) - t) - -(deftest count-if-not.error.9 - (signals-error (count-if-not #'null nil 3 3) program-error) - t) - -;;; Only leftmost :allow-other-keys argument matters -(deftest count-if-not.error.10 - (signals-error (count-if-not #'null nil :bad t - :allow-other-keys nil - :allow-other-keys t) - program-error) - t) - -(deftest count-if-not.error.11 - (signals-error (locally (count-if-not #'identity 1) t) - type-error) - t) - -(deftest count-if-not.error.12 - (signals-error (count-if-not #'cons '(a b c)) program-error) - t) - -(deftest count-if-not.error.13 - (signals-error (count-if-not #'car '(a b c)) type-error) - t) - -(deftest count-if-not.error.14 - (signals-error (count-if-not #'identity '(a b c) :key #'cdr) - type-error) - t) - -(deftest count-if-not.error.15 - (signals-error (count-if-not #'identity '(a b c) :key #'cons) - program-error) - t) diff --git a/t/ansi-test/sequences/count-if.lsp b/t/ansi-test/sequences/count-if.lsp deleted file mode 100644 index 26d62c1..0000000 --- a/t/ansi-test/sequences/count-if.lsp +++ /dev/null @@ -1,584 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Aug 20 08:01:30 2002 -;;;; Contains: Tests for COUNT-IF - -(in-package :cl-test) - -(deftest count-if-list.1 - (count-if #'identity '(a b nil c d nil e)) - 5) - -(deftest count-if-list.2 - (count-if #'not '(a b nil c d nil e)) - 2) - -(deftest count-if-list.3 - (count-if #'(lambda (x) (break)) nil) - 0) - -(deftest count-if-list.4 - (count-if #'identity '(a b nil c d nil e) :key #'identity) - 5) - -(deftest count-if-list.5 - (count-if 'identity '(a b nil c d nil e) :key #'identity) - 5) - -(deftest count-if-list.6 - (count-if #'identity '(a b nil c d nil e) :key 'identity) - 5) - -(deftest count-if-list.8 - (count-if #'identity '(a b nil c d nil e) :key 'not) - 2) - -(deftest count-if-list.9 - (count-if #'evenp '(1 2 3 4 4 1 8 10 1)) - 5) - -(deftest count-if-list.10 - (count-if #'evenp '(1 2 3 4 4 1 8 10 1) :key #'1+) - 4) - -(deftest count-if-list.11 - (let ((c 0)) - (count-if #'evenp '(1 2 3 4 4 1 8 10 1) - :key #'(lambda (x) (+ x (incf c))))) - 6) - -(deftest count-if-list.12 - (let ((c 0)) - (count-if #'evenp '(0 1 2 3 4 4 1 7 10 1) - :from-end t - :key #'(lambda (x) (+ x (incf c))))) - 8) - -(deftest count-if-list.13 - (count-if #'(lambda (x) (eqt x 'a)) - '(a b c d a e f a e f f a a) :start 2) - 4) - -(deftest count-if-list.14 - (count-if #'(lambda (x) (eqt x 'a)) - '(a b c d a e f a e f f a a) :end 7) - 2) - -(deftest count-if-list.15 - (count-if #'(lambda (x) (eqt x 'a)) - '(a b c d a e f a e f f a a) :end 7 - :start 2) - 1) - -(deftest count-if-list.16 - (count-if #'(lambda (x) (eqt x 'a)) - '(a b c d a e f a e f f a a) :end 7 - :start 2 :from-end t) - 1) - - -;;; tests on vectors - -(deftest count-if-vector.1 - (count-if #'identity #(a b nil c d nil e)) - 5) - -(deftest count-if-vector.2 - (count-if #'not #(a b nil c d nil e)) - 2) - -(deftest count-if-vector.3 - (count-if #'(lambda (x) (break)) #()) - 0) - -(deftest count-if-vector.4 - (count-if #'identity #(a b nil c d nil e) :key #'identity) - 5) - -(deftest count-if-vector.5 - (count-if 'identity #(a b nil c d nil e) :key #'identity) - 5) - -(deftest count-if-vector.6 - (count-if #'identity #(a b nil c d nil e) :key 'identity) - 5) - -(deftest count-if-vector.8 - (count-if #'identity #(a b nil c d nil e) :key 'not) - 2) - -(deftest count-if-vector.9 - (count-if #'evenp #(1 2 3 4 4 1 8 10 1)) - 5) - -(deftest count-if-vector.10 - (count-if #'evenp #(1 2 3 4 4 1 8 10 1) :key #'1+) - 4) - -(deftest count-if-vector.11 - (let ((c 0)) - (count-if #'evenp #(1 2 3 4 4 1 8 10 1) - :key #'(lambda (x) (+ x (incf c))))) - 6) - -(deftest count-if-vector.12 - (let ((c 0)) - (count-if #'evenp #(0 1 2 3 4 4 1 7 10 1) - :from-end t - :key #'(lambda (x) (+ x (incf c))))) - 8) - -(deftest count-if-vector.13 - (count-if #'(lambda (x) (eqt x 'a)) - #(a b c d a e f a e f f a a) :start 2) - 4) - -(deftest count-if-vector.14 - (count-if #'(lambda (x) (eqt x 'a)) - #(a b c d a e f a e f f a a) :end 7) - 2) - -(deftest count-if-vector.15 - (count-if #'(lambda (x) (eqt x 'a)) - #(a b c d a e f a e f f a a) :end 7 - :start 2) - 1) - -(deftest count-if-vector.16 - (count-if #'(lambda (x) (eqt x 'a)) - #(a b c d a e f a e f f a a) :end 7 - :start 2 :from-end t) - 1) - -;;; Non-simple vectors - -(deftest count-if-nonsimple-vector.1 - (count-if #'identity (make-array 7 :initial-contents '(a b nil c d nil e) - :fill-pointer t - :adjustable t)) - 5) - -(deftest count-if-nonsimple-vector.2 - (count-if #'not (make-array 7 :initial-contents '(a b nil c d nil e) - :fill-pointer t - :adjustable t)) - 2) - -(deftest count-if-nonsimple-vector.3 - (count-if #'(lambda (x) (break)) (make-array 0 - :fill-pointer t - :adjustable t)) - 0) - -(deftest count-if-nonsimple-vector.4 - (count-if #'identity - (make-array 7 :initial-contents '(a b nil c d nil e) - :fill-pointer t - :adjustable t) - :key #'identity) - 5) - -(deftest count-if-nonsimple-vector.5 - (count-if 'identity - (make-array 7 :initial-contents '(a b nil c d nil e) - :fill-pointer t - :adjustable t) - :key #'identity) - 5) - -(deftest count-if-nonsimple-vector.6 - (count-if #'identity - (make-array 7 :initial-contents '(a b nil c d nil e) - :fill-pointer t - :adjustable t) - :key 'identity) - 5) - -(deftest count-if-nonsimple-vector.8 - (count-if #'identity - (make-array 7 :initial-contents '(a b nil c d nil e) - :fill-pointer t - :adjustable t) - :key 'not) - 2) - -(deftest count-if-nonsimple-vector.9 - (count-if #'evenp (make-array 9 :initial-contents '(1 2 3 4 4 1 8 10 1) - :fill-pointer t :adjustable t)) - 5) - -(deftest count-if-nonsimple-vector.10 - (count-if #'evenp - (make-array 9 :initial-contents '(1 2 3 4 4 1 8 10 1) - :fill-pointer t :adjustable t) - :key #'1+) - 4) - -(deftest count-if-nonsimple-vector.11 - (let ((c 0)) - (count-if #'evenp - (make-array 9 :initial-contents '(1 2 3 4 4 1 8 10 1) - :fill-pointer t :adjustable t) - :key #'(lambda (x) (+ x (incf c))))) - 6) - -(deftest count-if-nonsimple-vector.12 - (let ((c 0)) - (count-if #'evenp - (make-array 10 :initial-contents '(0 1 2 3 4 4 1 7 10 1) - :fill-pointer t :adjustable t) - :from-end t - :key #'(lambda (x) (+ x (incf c))))) - 8) - -(deftest count-if-nonsimple-vector.13 - (count-if #'(lambda (x) (eqt x 'a)) - (make-array 13 :initial-contents '(a b c d a e f a e f f a a) - :fill-pointer t :adjustable t) - :start 2) - 4) - -(deftest count-if-nonsimple-vector.14 - (count-if #'(lambda (x) (eqt x 'a)) - (make-array 13 :initial-contents '(a b c d a e f a e f f a a) - :fill-pointer t :adjustable t) - :end 7) - 2) - -(deftest count-if-nonsimple-vector.15 - (count-if #'(lambda (x) (eqt x 'a)) - (make-array 13 :initial-contents '(a b c d a e f a e f f a a) - :fill-pointer t :adjustable t) - :end 7 :start 2) - 1) - -(deftest count-if-nonsimple-vector.16 - (count-if #'(lambda (x) (eqt x 'a)) - (make-array 13 :initial-contents '(a b c d a e f a e f f a a) - :fill-pointer t :adjustable t) - :end 7 :start 2 :from-end t) - 1) - -(deftest count-if-nonsimple-vector.17 - (flet ((%f (x) (eqt x 'a))) - (let ((s (make-array 13 :initial-contents '(a b c d a e f a e f f a a) - :fill-pointer 6))) - (values (count-if #'%f s) - (count-if #'%f s :end nil) - (count-if #'%f s :end 4) - (count-if #'%f s :start 1) - (count-if #'%f s :start 1 :end 4) - (count-if #'%f s :start 1 :end 4 :from-end t)))) - 2 2 1 1 0 0) - -;;; Other special vectors - -(deftest count-if.special-vector.1 - (do-special-integer-vectors - (v #(1 0 1 1 1 0 1 1 1 0 1) nil) - (assert (eql (count-if #'plusp v) 8)) - (assert (eql (count-if #'zerop v) 3)) - (assert (eql (count-if #'plusp v :start 2) 7)) - (assert (eql (count-if #'zerop v :end 9) 2))) - nil) - -(deftest count-if.special-vector.2 - (do-special-integer-vectors - (v #(1 3 2 4 7 5 6 1 0 2 4) nil) - (assert (eql (count-if #'evenp v) 6)) - (assert (eql (count-if #'oddp v) 5)) - (assert (eql (count-if #'plusp v :start 2) 8)) - (assert (eql (count-if #'zerop v :end 8) 0))) - nil) - -(deftest count-if.special-vector.3 - (loop for etype in '(short-float single-float double-float long-float) - for vals = (loop for e in '(0 1 2 1 3 0 4 5 6 0) - collect (coerce e etype)) - for vec = (make-array (length vals) :element-type etype :initial-contents vals) - for result = (count-if #'zerop vec) - unless (= result 3) - collect (list etype vals vec result)) - nil) - -(deftest count-if.special-vector.4 - (loop for cetype in '(short-float single-float double-float long-float integer rational) - for etype = `(complex ,cetype) - for vals = (loop for e in '(6 1 2 1 3 -4 4 5 6 100) - collect (complex 0 (coerce e cetype))) - for vec = (make-array (length vals) :element-type etype :initial-contents vals) - for result = (count-if #'(lambda (x) (< (abs x) 5/2)) vec) - unless (= result 3) - collect (list etype vals vec result)) - nil) - - -;;; tests on bit-vectors - -(deftest count-if-bit-vector.1 - (count-if #'evenp #*001011101101) - 5) - -(deftest count-if-bit-vector.2 - (count-if #'identity #*001011101101) - 12) - -(deftest count-if-bit-vector.3 - (count-if #'(lambda (x) (break)) #*) - 0) - -(deftest count-if-bit-vector.4 - (count-if #'identity #*001011101101 :key #'zerop) - 5) - -(deftest count-if-bit-vector.5 - (count-if 'identity #*001011101101 :key #'zerop) - 5) - -(deftest count-if-bit-vector.6 - (count-if #'identity #*001011101101 :key 'zerop) - 5) - -(deftest count-if-bit-vector.8 - (count-if #'identity #*001011101101 :key 'oddp) - 7) - -(deftest count-if-bit-vector.10 - (count-if #'evenp #*001011101101 :key #'1+) - 7) - -(deftest count-if-bit-vector.11 - (let ((c 0)) - (count-if #'evenp #*001011101101 - :key #'(lambda (x) (+ x (incf c))))) - 7) - -(deftest count-if-bit-vector.12 - (let ((c 0)) - (count-if #'evenp #*001011101101 - :from-end t - :key #'(lambda (x) (+ x (incf c))))) - 5) - -(deftest count-if-bit-vector.13 - (count-if #'zerop #*0111011011100 :start 2) - 4) - -(deftest count-if-bit-vector.14 - (count-if #'zerop #*0111011011100 :end 7) - 2) - -(deftest count-if-bit-vector.15 - (count-if #'zerop #*0111011011100 :end 7 :start 2) - 1) - -(deftest count-if-bit-vector.16 - (count-if #'zerop #*0111011011100 :end 7 :start 2 :from-end t) - 1) - -(deftest count-if-bit-vector.17 - (let ((s (make-array '(10) :initial-contents '(0 0 1 0 1 0 0 1 1 0) - :element-type 'bit - :fill-pointer 6))) - (values (count-if #'zerop s) - (count-if #'zerop s :end nil) - (count-if #'zerop s :end 4) - (count-if #'zerop s :start 5) - (count-if #'zerop s :start 1 :end 4))) - 4 4 3 1 2) - -;;; tests on strings - -(deftest count-if-string.1 - (count-if #'(lambda (x) (eql x #\0)) "001011101101") - 5) - -(deftest count-if-string.2 - (count-if #'identity "001011101101") - 12) - -(deftest count-if-string.3 - (count-if #'(lambda (x) (break)) "") - 0) - -(deftest count-if-string.4 - (count-if #'identity "001011101101" :key #'(lambda (x) (eql x #\0))) - 5) - -(deftest count-if-string.5 - (count-if 'identity "001011101101" :key #'(lambda (x) (eql x #\0))) - 5) - -(deftest count-if-string.6 - (count-if #'(lambda (x) (eql x #\0)) "001011101101" :key 'identity) - 5) - -(deftest count-if-string.8 - (count-if #'identity "001011101101" :key #'(lambda (x) (eql x #\1))) - 7) - -(deftest count-if-string.11 - (let ((c 0)) - (count-if #'evenp "001011101101" - :key #'(lambda (x) (+ (if (eql x #\0) 0 1) (incf c))))) - 7) - -(deftest count-if-string.12 - (let ((c 0)) - (count-if #'evenp "001011101101" - :from-end t - :key #'(lambda (x) (+ (if (eql x #\0) 0 1) (incf c))))) - 5) - -(deftest count-if-string.13 - (count-if #'(lambda (x) (eql x #\0)) "0111011011100" :start 2) - 4) - -(deftest count-if-string.14 - (count-if #'(lambda (x) (eql x #\0)) "0111011011100" :end 7) - 2) - -(deftest count-if-string.15 - (count-if #'(lambda (x) (eql x #\0)) "0111011011100" :end 7 :start 2) - 1) - -(deftest count-if-string.16 - (count-if #'(lambda (x) (eql x #\0)) - "0111011011100" :end 7 :start 2 :from-end t) - 1) - -(deftest count-if-string.17 - (let ((s (make-array '(10) - :initial-contents "00a0aa0a0a" - :element-type 'character - :fill-pointer 6))) - (values (count-if #'digit-char-p s) - (count-if #'digit-char-p s :end nil) - (count-if #'digit-char-p s :start 1) - (count-if #'digit-char-p s :end 2) - (count-if #'digit-char-p s :start 1 :end 2))) - 3 3 2 2 1) - -(deftest count-if-string.18 - (do-special-strings - (s "1abC3!?deZ" nil) - (assert (= (count-if #'alpha-char-p s) 6))) - nil) - -;;; Argument order tests - -(deftest count-if.order.1 - (let ((i 0) c1 c2 c3 c4 c5 c6) - (values - (count-if (progn (setf c1 (incf i)) #'null) - (progn (setf c2 (incf i)) '(a nil b c nil d e)) - :start (progn (setf c3 (incf i)) 0) - :end (progn (setf c4 (incf i)) 3) - :key (progn (setf c5 (incf i)) #'identity) - :from-end (progn (setf c6 (incf i)) nil) - ) - i c1 c2 c3 c4 c5 c6)) - 1 6 1 2 3 4 5 6) - -(deftest count-if.order.2 - (let ((i 0) c1 c2 c3 c4 c5 c6) - (values - (count-if (progn (setf c1 (incf i)) #'null) - (progn (setf c2 (incf i)) '(a nil b c nil d e)) - :from-end (progn (setf c3 (incf i)) nil) - :key (progn (setf c4 (incf i)) #'identity) - :end (progn (setf c5 (incf i)) 3) - :start (progn (setf c6 (incf i)) 0) - ) - i c1 c2 c3 c4 c5 c6)) - 1 6 1 2 3 4 5 6) - - -;;; Keyword tests - -(deftest count-if.allow-other-keys.1 - (count-if #'evenp '(1 2 3 4 5) :bad t :allow-other-keys t) - 2) - -(deftest count-if.allow-other-keys.2 - (count-if #'evenp '(1 2 3 4 5) :allow-other-keys #p"*" :also-bad t) - 2) - -;;; The leftmost of two :allow-other-keys arguments is the one that matters. -(deftest count-if.allow-other-keys.3 - (count-if #'evenp '(1 2 3 4 5) - :allow-other-keys t - :allow-other-keys nil - :bad t) - 2) - -(deftest count-if.keywords.4 - (count-if #'evenp '(1 2 3 4 5) :key #'identity :key #'1+) - 2) - -(deftest count-if.allow-other-keys.5 - (count-if #'evenp '(1 2 3 4 5) :allow-other-keys nil) - 2) - - -;;; Error tests - -(deftest count-if.error.1 - (check-type-error #'(lambda (x) (count-if #'identity x)) - #'sequencep) - nil) - -(deftest count-if.error.4 - (signals-error (count-if) program-error) - t) - -(deftest count-if.error.5 - (signals-error (count-if #'null) program-error) - t) - -(deftest count-if.error.6 - (signals-error (count-if #'null nil :bad t) program-error) - t) - -(deftest count-if.error.7 - (signals-error (count-if #'null nil :bad t :allow-other-keys nil) - program-error) - t) - -(deftest count-if.error.8 - (signals-error (count-if #'null nil :key) program-error) - t) - -(deftest count-if.error.9 - (signals-error (count-if #'null nil 3 3) program-error) - t) - -;;; Only leftmost :allow-other-keys argument matters -(deftest count-if.error.10 - (signals-error (count-if #'null nil :bad t - :allow-other-keys nil - :allow-other-keys t) - program-error) - t) - -(deftest count-if.error.11 - (signals-error (locally (count-if #'identity 1) t) type-error) - t) - -(deftest count-if.error.12 - (signals-error (count-if #'cons '(a b c)) program-error) - t) - -(deftest count-if.error.13 - (signals-error (count-if #'car '(a b c)) type-error) - t) - -(deftest count-if.error.14 - (signals-error (count-if #'identity '(a b c) :key #'cdr) - type-error) - t) - -(deftest count-if.error.15 - (signals-error (count-if #'identity '(a b c) :key #'cons) - program-error) - t) diff --git a/t/ansi-test/sequences/count.lsp b/t/ansi-test/sequences/count.lsp deleted file mode 100644 index 269c39a..0000000 --- a/t/ansi-test/sequences/count.lsp +++ /dev/null @@ -1,713 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Aug 19 07:31:55 2002 -;;;; Contains: Tests for COUNT - -(in-package :cl-test) - -(deftest count-list.1 - (count 'a '(a b c d e a e f)) - 2) - -(deftest count-list.2 - (count 'a '(a b c d e a e f) :test #'eql) - 2) - -(deftest count-list.3 - (count 'a '(a b c d e a e f) :test 'eql) - 2) - -(deftest count-list.4 - (count 1 '(1 2 2 3 2 1 2 2 5 4) :key #'1-) - 5) - -(deftest count-list.5 - (count 1 '(1 2 2 3 2 1 2 2 5 4) :key '1-) - 5) - -(deftest count-list.6 - (count 1 '(1 2 2 3 2 1 2 2 5 4) :key #'1- :test #'equal) - 5) - -(deftest count-list.7 - (count 1 '(2 1 1 2 3 1 4 1 7 6 1 8) :from-end t) - 5) - -(deftest count-list.8 - (let ((c 0)) - (count 1 '(1 2 3 1 4 1 7 6 1 8) - :key #'(lambda (x) - ;; (format t "~%~A ~A" x c) - (prog1 (- x c) (incf c))))) - 4) - -(deftest count-list.9 - (let ((c 0)) - (count 1 '(1 2 3 7 4 5 7 6 2 8) - :from-end t - :key #'(lambda (x) - ;; (format t "~%~A ~A" x c) - (prog1 (- x c) (incf c))))) - 3) - -(deftest count-list.10 - (count 1 '(1 1 1 1 1 2 1 1) :start 3) - 4) - -(deftest count-list.11 - (count 1 '(1 1 1 1 1 2 1 1) :end 6) - 5) - -(deftest count-list.12 - (count 1 '(1 1 1 1 1 2 1 1) :start 2 :end 7) - 4) - -(deftest count-list.13 - (count 1 '(1 1 1 1 1 2 1 1) :start 3 :end nil) - 4) - -(deftest count-list.14 - (count 1 '(1 1 1 1 1 2 1 1) :end nil) - 7) - -(deftest count-list.15 - (count 1 '(1 1 1 1 1 2 1 1) :test-not #'eql) - 1) - -(deftest count-list.16 - (count 1 '(1 1 1 3 1 2 1 1) :start 2 :end 7 - :test #'(lambda (x y) (declare (ignore x y)) t)) - 5) - -(deftest count-list.17 - (count 10 '(1 11 2 4 14 5 18 6 7) :test #'<) - 3) - -(deftest count-list.18 - (count 10 '(1 11 2 4 14 5 18 6 7) :test-not #'>=) - 3) - -(defharmless count-list.test-and-test-not.1 - (count 0 '(0 1 2 0 1 2 3 0 1) :test #'eql :test-not #'eql)) - -(defharmless count-list.test-and-test-not.2 - (count 0 '(0 1 2 0 1 2 3 0 1) :test-not #'eql :test #'eql)) - -;;; On vectors - -(deftest count-vector.1 - (count 'a #(a b c d e a e f)) - 2) - -(deftest count-vector.2 - (count 'a #(a b c d e a e f) :test #'eql) - 2) - -(deftest count-vector.3 - (count 'a #(a b c d e a e f) :test 'eql) - 2) - -(deftest count-vector.4 - (count 1 #(1 2 2 3 2 1 2 2 5 4) :key #'1-) - 5) - -(deftest count-vector.5 - (count 1 #(1 2 2 3 2 1 2 2 5 4) :key '1-) - 5) - -(deftest count-vector.6 - (count 1 #(1 2 2 3 2 1 2 2 5 4) :key #'1- :test #'equal) - 5) - -(deftest count-vector.7 - (count 1 #(2 1 1 2 3 1 4 1 7 6 1 8) :from-end t) - 5) - -(deftest count-vector.8 - (let ((c 0)) - (count 1 #(1 2 3 1 4 1 7 6 1 8) - :key #'(lambda (x) - ;; (format t "~%~A ~A" x c) - (prog1 (- x c) (incf c))))) - 4) - -(deftest count-vector.9 - (let ((c 0)) - (count 1 #(1 2 3 7 4 5 7 6 2 8) - :from-end t - :key #'(lambda (x) - ;; (format t "~%~A ~A" x c) - (prog1 (- x c) (incf c))))) - 3) - -(deftest count-vector.10 - (count 1 #(1 1 1 1 1 2 1 1) :start 3) - 4) - -(deftest count-vector.11 - (count 1 #(1 1 1 1 1 2 1 1) :end 6) - 5) - -(deftest count-vector.12 - (count 1 #(1 1 1 1 1 2 1 1) :start 2 :end 7) - 4) - -(deftest count-vector.13 - (count 1 #(1 1 1 1 1 2 1 1) :start 3 :end nil) - 4) - -(deftest count-vector.14 - (count 1 #(1 1 1 1 1 2 1 1) :end nil) - 7) - -(deftest count-vector.15 - (count 1 #(1 1 1 1 1 2 1 1) :test-not #'eql) - 1) - -(deftest count-vector.16 - (count 1 #(1 1 1 3 1 2 1 1) :start 2 :end 7 - :test #'(lambda (x y) (declare (ignore x y)) t)) - 5) - -(deftest count-vector.17 - (count 10 #(1 11 2 4 14 5 18 6 7) :test #'<) - 3) - -(deftest count-vector.18 - (count 10 #(1 11 2 4 14 5 18 6 7) :test-not #'>=) - 3) - -(defharmless count-vector.test-and-test-not.1 - (count 0 #(0 1 2 0 1 2 3 0 1) :test #'eql :test-not #'eql)) - -(defharmless count-vector.test-and-test-not.2 - (count 0 #(0 1 2 0 1 2 3 0 1) :test-not #'eql :test #'eql)) - -;;; Non-simple vectors - -(deftest count-filled-vector.1 - (count 'a (make-array 8 :initial-contents '(a b c d e a e f) - :fill-pointer t)) - 2) - -(deftest count-filled-vector.2 - (count 'a (make-array 8 :initial-contents '(a b c d e a e f) - :fill-pointer t) - :test #'eql) - 2) - -(deftest count-filled-vector.3 - (count 'a (make-array 8 :initial-contents '(a b c d e a e f) - :fill-pointer t) - :test 'eql) - 2) - -(deftest count-filled-vector.4 - (count 1 (make-array 10 :initial-contents '(1 2 2 3 2 1 2 2 5 4) - :fill-pointer t) - :key #'1-) - 5) - -(deftest count-filled-vector.5 - (count 1 (make-array 10 :initial-contents '(1 2 2 3 2 1 2 2 5 4) - :fill-pointer t) - :key '1-) - 5) - -(deftest count-filled-vector.6 - (count 1 (make-array 10 :initial-contents '(1 2 2 3 2 1 2 2 5 4) - :fill-pointer t) - :key #'1- :test #'equal) - 5) - -(deftest count-filled-vector.7 - (count 1 (make-array 12 :initial-contents '(2 1 1 2 3 1 4 1 7 6 1 8) - :fill-pointer t) - :from-end t) - 5) - -(deftest count-filled-vector.8 - (let ((c 0)) - (count 1 (make-array 10 :initial-contents '(1 2 3 1 4 1 7 6 1 8) - :fill-pointer t) - :key #'(lambda (x) - ;; (format t "~%~A ~A" x c) - (prog1 (- x c) (incf c))))) - 4) - -(deftest count-filled-vector.9 - (let ((c 0)) - (count 1 (make-array 10 :initial-contents '(1 2 3 7 4 5 7 6 2 8) - :fill-pointer t) - :from-end t - :key #'(lambda (x) - ;; (format t "~%~A ~A" x c) - (prog1 (- x c) (incf c))))) - 3) - -(deftest count-filled-vector.10 - (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 2 1 1) - :fill-pointer t) - :start 3) - 4) - -(deftest count-filled-vector.11 - (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 2 1 1) - :fill-pointer t) - :end 6) - 5) - -(deftest count-filled-vector.12 - (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 2 1 1) - :fill-pointer t) - :start 2 :end 7) - 4) - -(deftest count-filled-vector.13 - (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 2 1 1) - :fill-pointer t) - :start 3 :end nil) - 4) - -(deftest count-filled-vector.14 - (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 2 1 1) - :fill-pointer t) - :end nil) - 7) - -(deftest count-filled-vector.15 - (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 2 1 1) - :fill-pointer t) - :test-not #'eql) - 1) - -(deftest count-filled-vector.16 - (count 1 (make-array 8 :initial-contents '(1 1 1 3 1 2 1 1) - :fill-pointer t) - :start 2 :end 7 - :test #'(lambda (x y) (declare (ignore x y)) t)) - 5) - -(deftest count-filled-vector.17 - (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 1 1 1) - :fill-pointer 6)) - 6) - -(deftest count-filled-vector.18 - (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 1 1 1) - :fill-pointer 6) - :start 2) - 4) -(deftest count-filled-vector.19 - (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 1 1 1) - :fill-pointer 6) - :from-end 'foo) - 6) - -(deftest count-filled-vector.20 - (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 1 1 1) - :fill-pointer 6) - :start 2 :from-end 'yes) - 4) - -;;; Other specialized vectors - -(deftest count.special-vector.1 - (do-special-integer-vectors - (v #(0 1 1 0 1 1 1 0 1 1 1 1 0) nil) - (assert (eql (count 0 v) 4)) - (assert (eql (count 1 v) 9)) - (assert (eql (count 2 v) 0)) - (assert (eql (count 0 v :start 2) 3)) - (assert (eql (count 1 v :end 11) 8))) - nil) - -(deftest count.special-vector.2 - (do-special-integer-vectors - (v #(1 2 3 4 5 6 7) nil) - (assert (eql (count 0 v) 0)) - (assert (eql (count 1 v) 1)) - (assert (eql (count 2 v) 1)) - (assert (eql (count 3 v) 1)) - (assert (eql (count 4 v) 1)) - (assert (eql (count 5 v) 1)) - (assert (eql (count 6 v) 1)) - (assert (eql (count 7 v) 1))) - nil) - -(deftest count.special-vector.3 - (loop for etype in '(short-float single-float double-float long-float) - for vals = (loop for e in '(0 1 2 1 3 1 4 5 6 0) - collect (coerce e etype)) - for vec = (make-array (length vals) :element-type etype :initial-contents vals) - for result = (count (coerce 1 etype) vec) - unless (= result 3) - collect (list etype vals vec result)) - nil) - -(deftest count.special-vector.4 - (loop for cetype in '(short-float single-float double-float long-float rational integer) - for etype = `(complex ,cetype) - for vals = (loop for e in '(4 1 2 1 3 1 4 5 6 6) - collect (complex 0 (coerce e cetype))) - for vec = (make-array (length vals) :element-type etype :initial-contents vals) - for result = (count (complex 0 (coerce 1 cetype)) vec) - unless (= result 3) - collect (list etype vals vec result)) - nil) - - - -;;; Tests on bit vectors - -(deftest count-bit-vector.1 - (count 1 #*00101100011011000) - 7) - -(deftest count-bit-vector.2 - (count 1 #*00101100011011000 :test #'eql) - 7) - -(deftest count-bit-vector.3 - (count 1 #*00101100011011000 :test 'eql) - 7) - -(deftest count-bit-vector.4 - (count 1 #*00101100011011000 :key #'1+) - 10) - -(deftest count-bit-vector.5 - (count 0 #*00101100011011000 :key '1-) - 7) - -(deftest count-bit-vector.6 - (count 0 #*00101100011011000 :key #'1- :test #'equal) - 7) - -(deftest count-bit-vector.7 - (count 1 #*00101100011011000 :from-end t) - 7) - -(deftest count-bit-vector.8 - (let ((c 1)) - (count 0 #*0000110101001 - :key #'(lambda (x) (setf c (- c)) (+ c x)))) - 2) - -(deftest count-bit-vector.9 - (let ((c 1)) - (count 0 #*0000011010101 - :from-end t - :key #'(lambda (x) (setf c (- c)) (+ c x)))) - 4) - -(deftest count-bit-vector.10 - (count 1 #*11000110110 :start 3) - 4) - -(deftest count-bit-vector.11 - (count 1 '#*110111110111 :end 6) - 5) - -(deftest count-bit-vector.12 - (count 1 #*11111011 :start 2 :end 7) - 4) - -(deftest count-bit-vector.13 - (count 1 #*11111011 :start 3 :end nil) - 4) - -(deftest count-bit-vector.14 - (count 1 #*11111011 :end nil) - 7) - -(deftest count-bit-vector.15 - (count 1 #*11111011 :test-not #'eql) - 1) - -(deftest count-bit-vector.16 - (count 1 #*11101101 :start 2 :end 7 - :test #'(lambda (x y) (declare (ignore x y)) t)) - 5) - -(deftest count-bit-vector.17 - (count 1 (make-array 8 :initial-contents '(1 0 1 1 1 1 1 1) - :element-type 'bit - :fill-pointer 5)) - 4) - -(deftest count-bit-vector.18 - (count 1 (make-array 8 :initial-contents '(1 0 1 1 1 1 1 1) - :element-type 'bit - :fill-pointer 5) - :start 1) - 3) - -(deftest count-bit-vector.19 - (count 1 (make-array 8 :initial-contents '(1 0 1 1 1 1 1 1) - :element-type 'bit - :fill-pointer 5) - :end nil) - 4) - - -(deftest count-bit-vector.20 - (count 1 (make-array 8 :initial-contents '(1 0 1 1 1 1 1 1) - :element-type 'bit - :fill-pointer 6) - :end 4) - 3) - -(deftest count-bit-vector.21 - (count 1 #*00001100100 :test #'<=) - 3) - -(deftest count-bit-vector.22 - (count 1 #*00001100100 :test-not #'>) - 3) - -(defharmless count-bit-vector.test-and-test-not.1 - (count 0 #*0011010101100010000 :test #'eql :test-not #'eql)) - -(defharmless count-bit-vector.test-and-test-not.2 - (count 0 #*0011010101100010000 :test-not #'eql :test #'eql)) - -;;; Tests on strings - -(deftest count-string.1 - (count #\1 "00101100011011000") - 7) - -(deftest count-string.2 - (count #\1 "00101100011011000" :test #'eql) - 7) - -(deftest count-string.3 - (count #\1 "00101100011011000" :test 'eql) - 7) - -(deftest count-string.4 - (count #\1 "00101100011011000" :key #'(lambda (x) (if (eql x #\0) #\1 #\2))) - 10) - -(deftest count-string.5 - (count #\1 "00101100011011000" :key 'identity) - 7) - -(deftest count-string.6 - (count #\1 "00101100011011000" :key #'identity :test #'equal) - 7) - -(deftest count-string.7 - (count #\1 "00101100011011000" :from-end t) - 7) - -(deftest count-string.8 - (let ((c nil)) - (count #\0 "0000110101001" - :key #'(lambda (x) (setf c (not c)) - (and c x)))) - 5) - -(deftest count-string.9 - (let ((c nil)) - (count #\0 "0000011010101" - :from-end t - :key #'(lambda (x) (setf c (not c)) - (and c x)))) - 3) - -(deftest count-string.10 - (count #\1 "11000110110" :start 3) - 4) - -(deftest count-string.11 - (count #\1 '"110111110111" :end 6) - 5) - -(deftest count-string.12 - (count #\1 "11111011" :start 2 :end 7) - 4) - -(deftest count-string.13 - (count #\1 "11111011" :start 3 :end nil) - 4) - -(deftest count-string.14 - (count #\1 "11111011" :end nil) - 7) - -(deftest count-string.15 - (count #\1 "11111011" :test-not #'eql) - 1) - -(deftest count-string.16 - (count #\1 "11101101" :start 2 :end 7 - :test #'(lambda (x y) (declare (ignore x y)) t)) - 5) - -(deftest count-string.17 - (count #\a (make-array 10 :initial-contents "abaaacaaaa" - :fill-pointer 7 - :element-type 'character)) - 5) - -(deftest count-string.18 - (count #\a (make-array 10 :initial-contents "abaaacaaaa" - :fill-pointer 7 - :element-type 'character) - :start 1) - 4) - -(deftest count-string.19 - (count #\a (make-array 10 :initial-contents "abaaacaaaa" - :fill-pointer 7 - :element-type 'character) - :end nil) - 5) - -(deftest count-string.20 - (count #\a (make-array 10 :initial-contents "abaaacaaaa" - :fill-pointer 7 - :element-type 'character) - :start 2 :end 5) - 3) - -(deftest count-string.21 - (count #\1 "00001100100" :test #'char<=) - 3) - -(deftest count-string.22 - (count #\1 "00001100100" :test-not #'char>) - 3) - -(deftest count-string.23 - (do-special-strings - (s "a1a3abcda" nil) - (assert (= (count #\a s) 4))) - nil) - -(defharmless count-string.test-and-test-not.1 - (count #\0 "0011010101100010000" :test #'eql :test-not #'eql)) - -(defharmless count-string.test-and-test-not.2 - (count #\0 "0011010101100010000" :test-not #'eql :test #'eql)) - -;;; Argument order tests - -(deftest count.order.1 - (let ((i 0) c1 c2 c3 c4 c5 c6 c7) - (values - (count (progn (setf c1 (incf i)) nil) - (progn (setf c2 (incf i)) '(a nil b c nil d e)) - :start (progn (setf c3 (incf i)) 0) - :end (progn (setf c4 (incf i)) 3) - :key (progn (setf c5 (incf i)) #'identity) - :from-end (progn (setf c6 (incf i)) nil) - :test (progn (setf c7 (incf i)) #'eql) - ) - i c1 c2 c3 c4 c5 c6 c7)) - 1 7 1 2 3 4 5 6 7) - -(deftest count.order.2 - (let ((i 0) c1 c2 c3 c4 c5 c6 c7) - (values - (count (progn (setf c1 (incf i)) nil) - (progn (setf c2 (incf i)) '(a nil b c nil d e)) - :test (progn (setf c3 (incf i)) #'eql) - :from-end (progn (setf c4 (incf i)) nil) - :key (progn (setf c5 (incf i)) #'identity) - :end (progn (setf c6 (incf i)) 3) - :start (progn (setf c7 (incf i)) 0) - ) - i c1 c2 c3 c4 c5 c6 c7)) - 1 7 1 2 3 4 5 6 7) - - -;;; Keyword tests - -(deftest count.allow-other-keys.1 - (count 'a '(b a d a c) :bad t :allow-other-keys t) - 2) - -(deftest count.allow-other-keys.2 - (count 'a '(b a d a c) :allow-other-keys #p"*" :also-bad t) - 2) - -;;; The leftmost of two :allow-other-keys arguments is the one that matters. -(deftest count.allow-other-keys.3 - (count 'a '(b a d a c) - :allow-other-keys t - :allow-other-keys nil - :bad t) - 2) - -(deftest count.keywords.4 - (count 2 '(1 2 3 2 5) :key #'identity :key #'1+) - 2) - -(deftest count.allow-other-keys.5 - (count 'a '(a b c a) :allow-other-keys nil) - 2) - -;;; Error tests - -(deftest count.error.1 - (check-type-error #'(lambda (x) (count 'a x)) #'sequencep) - nil) - -(deftest count.error.4 - (signals-error (count) program-error) - t) - -(deftest count.error.5 - (signals-error (count nil) program-error) - t) - -(deftest count.error.6 - (signals-error (count nil nil :bad t) program-error) - t) - -(deftest count.error.7 - (signals-error (count nil nil :bad t :allow-other-keys nil) - program-error) - t) - -(deftest count.error.8 - (signals-error (count nil nil :key) program-error) - t) - -(deftest count.error.9 - (signals-error (count nil nil 3 3) program-error) - t) - -;;; Only leftmost :allow-other-keys argument matters -(deftest count.error.10 - (signals-error (count 'a nil :bad t - :allow-other-keys nil - :allow-other-keys t) - program-error) - t) - -(deftest count.error.11 - (signals-error (locally (count 'a 1) t) type-error) - t) - -(deftest count.error.12 - (signals-error (count 'b '(a b c) :test #'identity) - program-error) - t) - -(deftest count.error.13 - (signals-error (count 'b '(a b c) :key #'car) type-error) - t) - -(deftest count.error.14 - (signals-error (count 'b '(a b c) :test-not #'identity) - program-error) - t) - -(deftest count.error.15 - (signals-error (count 'b '(a b c) :key #'cons) - program-error) - t) diff --git a/t/ansi-test/sequences/elt.lsp b/t/ansi-test/sequences/elt.lsp deleted file mode 100644 index 173a53d..0000000 --- a/t/ansi-test/sequences/elt.lsp +++ /dev/null @@ -1,457 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Oct 12 19:38:29 2002 -;;;; Contains: Tests of ELT - -(in-package :cl-test) - -(declaim (optimize (safety 3))) - -;; elt on lists - -(deftest elt.1 - (signals-error (elt nil 0) type-error) - t) - -(deftest elt.1a - (signals-error (elt nil -10) type-error) - t) - -(deftest elt.1b - (signals-error (locally (elt nil 0) t) type-error) - t) - -(deftest elt.2 - (signals-error (elt nil 1000000) type-error) - t) - -(deftest elt.3 (elt '(a b c d e) 0) a) -(deftest elt.4 (elt '(a b c d e) 2) c) -(deftest elt.5 (elt '(a b c d e) 4) e) -(deftest elt.5a - (signals-error (elt '(a b c d e) -4) type-error) - t) - -(deftest elt.6 - (let ((x (make-int-list 1000))) - (notnot-mv - (every - #'(lambda (i) (eql i (elt x i))) - x))) - t) - -(deftest elt.7 - (let* ((x (list 'a 'b 'c 'd)) - (y (setf (elt x 0) 'e))) - (list x y)) - ((e b c d) e)) - -(deftest elt.8 - (let* ((x (list 'a 'b 'c 'd)) - (y (setf (elt x 1) 'e))) - (list x y)) - ((a e c d) e)) - -(deftest elt.9 - (let* ((x (list 'a 'b 'c 'd)) - (y (setf (elt x 3) 'e))) - (list x y)) - ((a b c e) e)) - -(deftest elt.10 - (signals-error - (let ((x (list 'a 'b 'c))) - (setf (elt x 4) 'd)) - type-error) - t) - -(deftest elt.11 - (let ((x (list 'a 'b 'c 'd 'e))) - (let ((y (loop for c on x collect c))) - (setf (elt x 2) 'f) - (notnot-mv - (every #'eq - y - (loop for c on x collect c))))) - t) - -(deftest elt.12 - (let ((x (make-int-list 100000))) - (elt x 90000)) - 90000) - -(deftest elt.13 - (let ((x (make-int-list 100000))) - (setf (elt x 80000) 'foo) - (list (elt x 79999) - (elt x 80000) - (elt x 80001))) - (79999 foo 80001)) - -(deftest elt.14 - (signals-error - (let ((x (list 'a 'b 'c))) - (elt x 10)) - type-error) - t) - -(deftest elt.15 - (signals-error - (let ((x (list 'a 'b 'c))) - (elt x 'a)) - type-error) - t) - -(deftest elt.16 - (signals-error - (let ((x (list 'a 'b 'c))) - (elt x 10.0)) - type-error) - t) - -(deftest elt.17 - (signals-error - (let ((x (list 'a 'b 'c))) - (elt x -1)) - type-error) - t) - -(deftest elt.18 - (signals-error - (let ((x (list 'a 'b 'c))) - (elt x -100000000000000000)) - type-error) - t) - -(deftest elt.19 - (signals-error - (let ((x (list 'a 'b 'c))) - (elt x #\w)) - type-error) - t) - -(deftest elt.order.1 - (let ((i 0) x y) - (values - (elt (progn (setf x (incf i)) '(a b c d e)) - (progn (setf y (incf i)) 3)) - i x y)) - d 2 1 2) - -(deftest elt.order.2 - (let ((i 0) x y z) - (let ((a (make-array 1 :initial-element (list 'a 'b 'c 'd 'e)))) - (values - (setf (elt (aref a (progn (setf x (incf i)) 0)) - (progn (setf y (incf i)) 3)) - (progn (setf z (incf i)) 'k)) - (aref a 0) - i x y z))) - k (a b c k e) 3 1 2 3) - -(deftest elt-v.1 - (signals-error (elt (make-array '(0)) 0) type-error) - t) - -;; (deftest elt-v.2 (elt (make-array '(1)) 0) nil) ;; actually undefined -(deftest elt-v.3 - (elt (make-array '(5) :initial-contents '(a b c d e)) 0) - a) - -(deftest elt-v.4 - (elt (make-array '(5) :initial-contents '(a b c d e)) 2) - c) - -(deftest elt-v.5 - (elt (make-array '(5) :initial-contents '(a b c d e)) 4) - e) - -(deftest elt-v.6 - (elt-v-6-body) - t) - -(deftest elt-v.7 - (let* ((x (make-array '(4) :initial-contents (list 'a 'b 'c 'd))) - (y (setf (elt x 0) 'e))) - (list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y)) - (e b c d e)) - -(deftest elt-v.8 - (let* ((x (make-array '(4) :initial-contents (list 'a 'b 'c 'd))) - (y (setf (elt x 1) 'e))) - (list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y)) - (a e c d e)) - -(deftest elt-v.9 - (let* ((x (make-array '(4) :initial-contents (list 'a 'b 'c 'd))) - (y (setf (elt x 3) 'e))) - (list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y)) - (a b c e e)) - -(deftest elt-v.10 - (signals-error - (let ((x (make-array '(3) :initial-contents (list 'a 'b 'c)))) - (setf (elt x 4) 'd)) - type-error) - t) - -(deftest elt-v.11 - (signals-error - (let ((x (make-array '(3) :initial-contents (list 'a 'b 'c)))) - (setf (elt x -100) 'd)) - type-error) - t) - -(deftest elt-v.12 - (let ((x (make-int-array 100000))) - (elt x 90000)) - 90000) - -(deftest elt-v.13 - (let ((x (make-int-array 100000))) - (setf (elt x 80000) 'foo) - (list (elt x 79999) - (elt x 80000) - (elt x 80001))) - (79999 foo 80001)) - -;;; Adjustable arrays - -(deftest elt-adj-array.1 - (signals-error (elt (make-adj-array '(0)) 0) type-error) - t) - -;;; (deftest elt-adj-array.2 (elt (make-adj-array '(1)) 0) nil) ;; actually undefined - -(deftest elt-adj-array.3 - (elt (make-adj-array '(5) :initial-contents '(a b c d e)) 0) - a) - -(deftest elt-adj-array.4 - (elt (make-adj-array '(5) :initial-contents '(a b c d e)) 2) - c) - -(deftest elt-adj-array.5 - (elt (make-adj-array '(5) :initial-contents '(a b c d e)) 4) - e) - -(deftest elt-adj-array.6 - (elt-adj-array-6-body) - t) - -(deftest elt-adj-array.7 - (let* ((x (make-adj-array '(4) :initial-contents (list 'a 'b 'c 'd))) - (y (setf (elt x 0) 'e))) - (list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y)) - (e b c d e)) - -(deftest elt-adj-array.8 - (let* ((x (make-adj-array '(4) :initial-contents (list 'a 'b 'c 'd))) - (y (setf (elt x 1) 'e))) - (list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y)) - (a e c d e)) - -(deftest elt-adj-array.9 - (let* ((x (make-adj-array '(4) :initial-contents (list 'a 'b 'c 'd))) - (y (setf (elt x 3) 'e))) - (list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y)) - (a b c e e)) - -(deftest elt-adj-array.10 - (signals-error - (let ((x (make-adj-array '(3) :initial-contents (list 'a 'b 'c)))) - (setf (elt x 4) 'd)) - type-error) - t) - -(deftest elt-adj-array.11 - (signals-error - (let ((x (make-adj-array '(3) :initial-contents (list 'a 'b 'c)))) - (setf (elt x -100) 'd)) - type-error) - t) - -(deftest elt-adj-array.12 - (let ((x (make-int-array 100000 #'make-adj-array))) - (elt x 90000)) - 90000) - -(deftest elt-adj-array.13 - (let ((x (make-int-array 100000 #'make-adj-array))) - (setf (elt x 80000) 'foo) - (list (elt x 79999) - (elt x 80000) - (elt x 80001))) - (79999 foo 80001)) - -;; displaced arrays - -(deftest elt-displaced-array.1 - (signals-error (elt (make-displaced-array '(0) 100) 0) type-error) - t) - -(deftest elt-displaced-array.2 - (elt (make-displaced-array '(1) 100) 0) - 100) - -(deftest elt-displaced-array.3 - (elt (make-displaced-array '(5) 100) 4) - 104) - -;;; Arrays with fill points - -(deftest elt-fill-pointer.1 - (let ((a (make-array '(5) :initial-contents '(a b c d e) - :fill-pointer 3))) - (values (elt a 0) (elt a 1) (elt a 2))) - a b c) - -(deftest elt-fill-pointer.2 - (let ((a (make-array '(5) - :initial-contents '(0 0 1 0 0) - :element-type 'bit - :fill-pointer 3))) - (values (elt a 0) (elt a 1) (elt a 2))) - 0 0 1) - -(deftest elt-fill-pointer.3 - (signals-error - (let ((a (make-array '(5) - :initial-contents '(0 0 1 0 0) - :fill-pointer 3))) - (elt a 4)) - type-error) - t) - -(deftest elt-fill-pointer.4 - (signals-error - (let ((a (make-array '(5) - :initial-contents '(0 0 1 0 0) - :element-type 'bit - :fill-pointer 3))) - (elt a 4)) - type-error) - t) - -(deftest elt-fill-pointer.5 - (let ((a (make-array '(5) - :initial-contents '(#\a #\b #\c #\d #\e) - :element-type 'character - :fill-pointer 3))) - (values (elt a 0) (elt a 1) (elt a 2))) - #\a #\b #\c) - -(deftest elt-fill-pointer.6 - (signals-error - (let ((a (make-array '(5) - :initial-contents '(#\a #\b #\c #\d #\e) - :element-type 'character - :fill-pointer 3))) - (elt a 4)) - type-error) - t) - -(deftest elt-fill-pointer.7 - (let ((a (make-array '(5) - :initial-contents '(#\a #\b #\c #\d #\e) - :element-type 'base-char - :fill-pointer 3))) - (values (elt a 0) (elt a 1) (elt a 2))) - #\a #\b #\c) - -(deftest elt-fill-pointer.8 - (signals-error - (let ((a (make-array '(5) - :initial-contents '(#\a #\b #\c #\d #\e) - :element-type 'base-char - :fill-pointer 3))) - (elt a 4)) - type-error) - t) - -;;; Specialized strings - -(deftest elt.special-strings.1 - (do-special-strings - (s "abcde" nil) - (assert (char= (elt s 0) #\a)) - (assert (char= (elt s 3) #\d)) - (assert (char= (elt s 4) #\e))) - nil) - -;;; Specialized integer vectors - -(deftest elt.special-vectors.1 - (do-special-integer-vectors - (v #(1 1 0 1 0 1) nil) - (assert (= (elt v 0) 1)) - (assert (= (elt v 1) 1)) - (assert (= (elt v 2) 0)) - (assert (= (elt v 3) 1)) - (assert (= (elt v 4) 0)) - (assert (= (elt v 5) 1))) - nil) - -(deftest elt.special-vectors.2 - (do-special-integer-vectors - (v #(1 2 0 -1 0 3) nil) - (assert (= (elt v 0) 1)) - (assert (= (elt v 1) 2)) - (assert (= (elt v 2) 0)) - (assert (= (elt v 3) -1)) - (assert (= (elt v 4) 0)) - (assert (= (elt v 5) 3))) - nil) - -(deftest elt.special-vectors.3 - (loop for type in '(short-float single-float long-float double-float) - for len = 10 - for vals = (loop for i from 1 to len collect (coerce i type)) - for vec = (make-array len :element-type type :initial-contents vals) - unless (loop for i below len always (eql (elt vec i) - (coerce (1+ i) type))) - collect (list type vals vec)) - nil) - -(deftest elt.special-vectors.4 - (loop for etype in '(short-float single-float long-float double-float - integer rational) - for type = `(complex ,etype) - for len = 10 - for vals = (loop for i from 1 to len collect (complex (coerce i etype) - (coerce (- i) etype))) - for vec = (make-array len :element-type type :initial-contents vals) - unless (loop for i below len always (eql (elt vec i) - (elt vals i))) - collect (list type vals vec)) - nil) - - - -;;; Error tests - -(deftest elt.error.1 - (signals-error (elt) program-error) - t) - -(deftest elt.error.2 - (signals-error (elt nil) program-error) - t) - -(deftest elt.error.3 - (signals-error (elt nil 0 nil) program-error) - t) - -(deftest elt.error.4 - (do-special-integer-vectors - (v #(1 1 0 1 0 1) nil) - (assert (eql t (eval `(signals-error (elt ,v -1) type-error)))) - (assert (eql t (eval `(signals-error (elt ,v 6) type-error))))) - nil) - -(deftest elt.error.5 - (do-special-strings - (s "ABCDEFGH" nil) - (assert (eql t (eval `(signals-error (elt ,s -1) type-error)))) - (assert (eql t (eval `(signals-error (elt ,s 8) type-error))))) - nil) diff --git a/t/ansi-test/sequences/fill-strings.lsp b/t/ansi-test/sequences/fill-strings.lsp deleted file mode 100644 index 38bdc3c..0000000 --- a/t/ansi-test/sequences/fill-strings.lsp +++ /dev/null @@ -1,26 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Aug 17 08:04:27 2002 -;;;; Contains: Test cases for FILL on strings - -(in-package :cl-test) - -(deftest array-string-fill.1 - (array-string-fill-test-fn "abcde" #\Z) - t "ZZZZZ") - -(deftest array-string-fill.2 - (array-string-fill-test-fn "abcde" #\Z :start 2) - t "abZZZ") - -(deftest array-string-fill.3 - (array-string-fill-test-fn "abcde" #\Z :end 3) - t "ZZZde") - -(deftest array-string-fill.4 - (array-string-fill-test-fn "abcde" #\Z :start 1 :end 4) - t "aZZZe") - -(deftest array-string-fill.5 - (array-string-fill-test-fn "abcde" #\Z :start 2 :end 3) - t "abZde") diff --git a/t/ansi-test/sequences/fill.lsp b/t/ansi-test/sequences/fill.lsp deleted file mode 100644 index cb2378f..0000000 --- a/t/ansi-test/sequences/fill.lsp +++ /dev/null @@ -1,599 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Oct 12 19:44:45 2002 -;;;; Contains: Tests on FILL - -(in-package :cl-test) - -(deftest fill.error.1 - (signals-error (fill 'a 'b) type-error) - t) - -(deftest fill.error.2 - (signals-error (fill) program-error) - t) - -(deftest fill.error.3 - (signals-error (fill (list 'a 'b)) program-error) - t) - -(deftest fill.error.4 - (signals-error (fill (list 'a 'b) 'c :bad t) program-error) - t) - -(deftest fill.error.5 - (signals-error (fill (list 'a 'b) 'c :bad t :allow-other-keys nil) - program-error) - t) - -(deftest fill.error.6 - (signals-error (fill (list 'a 'b) 'c :start) program-error) - t) - -(deftest fill.error.7 - (signals-error (fill (list 'a 'b) 'c :end) program-error) - t) - -(deftest fill.error.8 - (signals-error (fill (list 'a 'b) 'c 1 2) program-error) - t) - -(deftest fill.error.10 - (signals-error (fill (list 'a 'b) 'c :bad t :allow-other-keys nil - :allow-other-keys t) - program-error) - t) - -(deftest fill.error.11 - (signals-error (locally (fill 'a 'b) t) type-error) - t) - -;;; Fill on arrays - -(deftest array-fill-1 - (let* ((a (make-array '(5) :initial-contents '(a b c d e))) - (b (fill a 'x))) - (values (eqt a b) - (map 'list #'identity a))) - t (x x x x x)) - -(deftest array-fill-2 - (let* ((a (make-array '(5) :initial-contents '(a b c d e))) - (b (fill a 'x :start 2))) - (values (eqt a b) - (map 'list #'identity a))) - t (a b x x x)) - -(deftest array-fill-3 - (let* ((a (make-array '(5) :initial-contents '(a b c d e))) - (b (fill a 'x :end 2))) - (values (eqt a b) - (map 'list #'identity a))) - t (x x c d e)) - -(deftest array-fill-4 - (let* ((a (make-array '(5) :initial-contents '(a b c d e))) - (b (fill a 'x :start 1 :end 3))) - (values (eqt a b) - (map 'list #'identity a))) - t (a x x d e)) - -(deftest array-fill-5 - (let* ((a (make-array '(5) :initial-contents '(a b c d e))) - (b (fill a 'x :start 1 :end nil))) - (values (eqt a b) - (map 'list #'identity a))) - t (a x x x x)) - -(deftest array-fill-6 - (let* ((a (make-array '(5) :initial-contents '(a b c d e))) - (b (fill a 'x :end nil))) - (values (eqt a b) - (map 'list #'identity a))) - t (x x x x x)) - -(deftest array-fill-7 - (signals-error - (let* ((a (make-array '(5)))) - (fill a 'x :start -1)) - type-error) - t) - -(deftest array-fill-8 - (signals-error - (let* ((a (make-array '(5)))) - (fill a 'x :start 'a)) - type-error) - t) - -(deftest array-fill-9 - (signals-error - (let* ((a (make-array '(5)))) - (fill a 'x :end -1)) - type-error) - t) - -(deftest array-fill-10 - (signals-error - (let* ((a (make-array '(5)))) - (fill a 'x :end 'a)) - type-error) - t) - -;;; fill on arrays of fixnums - -(deftest array-fixnum-fill-1 - (let* ((a (make-array '(5) :element-type 'fixnum :initial-contents '(1 2 3 4 5))) - (b (fill a 6))) - (values (eqt a b) - (map 'list #'identity a))) - t (6 6 6 6 6)) - -(deftest array-fixnum-fill-2 - (let* ((a (make-array '(5) :element-type 'fixnum :initial-contents '(1 2 3 4 5))) - (b (fill a 6 :start 2))) - (values (eqt a b) - (map 'list #'identity a))) - t (1 2 6 6 6)) - -(deftest array-fixnum-fill-3 - (let* ((a (make-array '(5) :element-type 'fixnum :initial-contents '(1 2 3 4 5))) - (b (fill a 7 :end 2))) - (values (eqt a b) - (map 'list #'identity a))) - t (7 7 3 4 5)) - -(deftest array-fixnum-fill-4 - (let* ((a (make-array '(5) :element-type 'fixnum :initial-contents '(1 2 3 4 5))) - (b (fill a 8 :start 1 :end 3))) - (values (eqt a b) - (map 'list #'identity a))) - t (1 8 8 4 5)) - -(deftest array-fixnum-fill-5 - (let* ((a (make-array '(5) :element-type 'fixnum :initial-contents '(1 2 3 4 5))) - (b (fill a 0 :start 1 :end nil))) - (values (eqt a b) - (map 'list #'identity a))) - t (1 0 0 0 0)) - -(deftest array-fixnum-fill-6 - (let* ((a (make-array '(5) :element-type 'fixnum :initial-contents '(1 2 3 4 5))) - (b (fill a -1 :end nil))) - (values (eqt a b) - (map 'list #'identity a))) - t (-1 -1 -1 -1 -1)) - -(deftest array-fixnum-fill-7 - (signals-error - (let* ((a (make-array '(5) :element-type 'fixnum))) - (fill a 10 :start -1)) - type-error) - t) - -(deftest array-fixnum-fill-8 - (signals-error - (let* ((a (make-array '(5) :element-type 'fixnum))) - (fill a 100 :start 'a)) - type-error) - t) - -(deftest array-fixnum-fill-9 - (signals-error - (let* ((a (make-array '(5) :element-type 'fixnum))) - (fill a -5 :end -1)) - type-error) - t) - -(deftest array-fixnum-fill-10 - (signals-error - (let* ((a (make-array '(5) :element-type 'fixnum))) - (fill a 17 :end 'a)) - type-error) - t) - -;;; fill on arrays of unsigned eight bit bytes - -(deftest array-unsigned-byte8-fill-1 - (array-unsigned-byte-fill-test-fn 8 6) - t (6 6 6 6 6)) - -(deftest array-unsigned-byte8-fill-2 - (array-unsigned-byte-fill-test-fn 8 6 :start 2) - t (1 2 6 6 6)) - -(deftest array-unsigned-byte8-fill-3 - (array-unsigned-byte-fill-test-fn 8 7 :end 2) - t (7 7 3 4 5)) - -(deftest array-unsigned-byte8-fill-4 - (array-unsigned-byte-fill-test-fn 8 8 :start 1 :end 3) - t (1 8 8 4 5)) - -(deftest array-unsigned-byte8-fill-5 - (array-unsigned-byte-fill-test-fn 8 9 :start 1 :end nil) - t (1 9 9 9 9)) - -(deftest array-unsigned-byte8-fill-6 - (array-unsigned-byte-fill-test-fn 8 0 :end nil) - t (0 0 0 0 0)) - -(deftest array-unsigned-byte8-fill-7 - (signals-error (array-unsigned-byte-fill-test-fn 8 0 :start -1) - type-error) - t) - -(deftest array-unsigned-byte8-fill-8 - (signals-error (array-unsigned-byte-fill-test-fn 8 100 :start 'a) - type-error) - t) - -(deftest array-unsigned-byte8-fill-9 - (signals-error (array-unsigned-byte-fill-test-fn 8 19 :end -1) - type-error) - t) - -(deftest array-unsigned-byte8-fill-10 - (signals-error (array-unsigned-byte-fill-test-fn 8 17 :end 'a) - type-error) - t) - -;;; Tests on arrays with fill pointers - -(deftest array-fill-pointer-fill.1 - (let ((s1 (make-array '(10) :fill-pointer 5 :initial-element nil))) - (fill s1 'a) - (loop for i from 0 to 9 collect (aref s1 i))) - (a a a a a nil nil nil nil nil)) - -(deftest array-fill-pointer-fill.2 - (let ((s1 (make-array '(10) :fill-pointer 5 :initial-element nil))) - (fill s1 'a :end nil) - (loop for i from 0 to 9 collect (aref s1 i))) - (a a a a a nil nil nil nil nil)) - -;;; Tests on strings - -(deftest fill.string.1 - (let* ((s1 (copy-seq "abcde")) - (s2 (fill s1 #\z))) - (values (eqt s1 s2) s2)) - t - "zzzzz") - -(deftest fill.string.2 - (let* ((s1 (copy-seq "abcde")) - (s2 (fill s1 #\z :start 0 :end 1))) - (values (eqt s1 s2) s2)) - t - "zbcde") - -(deftest fill.string.3 - (let* ((s1 (copy-seq "abcde")) - (s2 (fill s1 #\z :end 2))) - (values (eqt s1 s2) s2)) - t - "zzcde") - -(deftest fill.string.4 - (let* ((s1 (copy-seq "abcde")) - (s2 (fill s1 #\z :end nil))) - (values (eqt s1 s2) s2)) - t - "zzzzz") - -(deftest fill.string.5 - (let* ((s1 "aaaaaaaa") - (len (length s1))) - (loop for start from 0 to (1- len) - always - (loop for end from (1+ start) to len - always - (let* ((s2 (copy-seq s1)) - (s3 (fill s2 #\z :start start :end end))) - (and (eqt s2 s3) - (string= s3 - (substitute-if #\z (constantly t) s1 - :start start :end end)) - t))))) - t) - -(deftest fill.string.6 - (let* ((s1 "aaaaaaaa") - (len (length s1))) - (loop for start from 0 to (1- len) - always - (let* ((s2 (copy-seq s1)) - (s3 (fill s2 #\z :start start))) - (and (eqt s2 s3) - (string= s3 - (substitute-if #\z (constantly t) s1 - :start start)) - t)))) - t) - -(deftest fill.string.7 - (let* ((s1 "aaaaaaaa") - (len (length s1))) - (loop for start from 0 to (1- len) - always - (let* ((s2 (copy-seq s1)) - (s3 (fill s2 #\z :end nil :start start))) - (and (eqt s2 s3) - (string= s3 - (substitute-if #\z (constantly t) s1 - :end nil :start start)) - t)))) - t) - -(deftest fill.string.8 - (let* ((s1 "aaaaaaaa") - (len (length s1))) - (loop for end from 1 to len - always - (let* ((s2 (copy-seq s1)) - (s3 (fill s2 #\z :end end))) - (and (eqt s2 s3) - (string= s3 - (substitute-if #\z (constantly t) s1 - :end end)) - t)))) - t) - -(deftest fill.string.9 - (let* ((s1 (make-array '(8) :element-type 'character - :initial-element #\z - :fill-pointer 4)) - (s2 (fill s1 #\a))) - (and (eqt s1 s2) - (coerce (loop for i from 0 to 7 collect (aref s2 i)) - 'string))) - "aaaazzzz") - -(deftest fill.string.10 - (let* ((s1 (make-array '(8) :element-type 'base-char - :initial-element #\z - :fill-pointer 4)) - (s2 (fill s1 #\a))) - (and (eqt s1 s2) - (coerce (loop for i from 0 to 7 collect (aref s2 i)) - 'base-string))) - "aaaazzzz") - -;;; Tests for bit vectors - -(deftest fill.bit-vector.1 - (let* ((s1 (copy-seq #*01100)) - (s2 (fill s1 0))) - (values (eqt s1 s2) s2)) - t - #*00000) - -(deftest fill.bit-vector.2 - (let* ((s1 (copy-seq #*00100)) - (s2 (fill s1 1 :start 0 :end 1))) - (values (eqt s1 s2) s2)) - t - #*10100) - -(deftest fill.bit-vector.3 - (let* ((s1 (copy-seq #*00010)) - (s2 (fill s1 1 :end 2))) - (values (eqt s1 s2) s2)) - t - #*11010) - -(deftest fill.bit-vector.4 - (let* ((s1 (copy-seq #*00111)) - (s2 (fill s1 0 :end nil))) - (values (eqt s1 s2) s2)) - t - #*00000) - -(deftest fill.bit-vector.5 - (let* ((s1 #*00000000) - (len (length s1))) - (loop for start from 0 to (1- len) - always - (loop for end from (1+ start) to len - always - (let* ((s2 (copy-seq s1)) - (s3 (fill s2 1 :start start :end end))) - (and (eqt s2 s3) - (equalp s3 - (substitute-if 1 (constantly t) s1 - :start start :end end)) - t))))) - t) - -(deftest fill.bit-vector.6 - (let* ((s1 #*11111111) - (len (length s1))) - (loop for start from 0 to (1- len) - always - (let* ((s2 (copy-seq s1)) - (s3 (fill s2 0 :start start))) - (and (eqt s2 s3) - (equalp s3 - (substitute-if 0 (constantly t) s1 - :start start)) - t)))) - t) - -(deftest fill.bit-vector.7 - (let* ((s1 #*00000000) - (len (length s1))) - (loop for start from 0 to (1- len) - always - (let* ((s2 (copy-seq s1)) - (s3 (fill s2 1 :end nil :start start))) - (and (eqt s2 s3) - (equalp s3 - (substitute-if 1 (constantly t) s1 - :end nil :start start)) - t)))) - t) - -(deftest fill.bit-vector.8 - (let* ((s1 #*11111111) - (len (length s1))) - (loop for end from 1 to len - always - (let* ((s2 (copy-seq s1)) - (s3 (fill s2 0 :end end))) - (and (eqt s2 s3) - (equalp s3 - (substitute-if 0 (constantly t) s1 - :end end)) - t)))) - t) - -(deftest fill.bit-vector.9 - (let* ((s1 (make-array '(8) :element-type 'bit - :initial-element 0 - :fill-pointer 4)) - (s2 (fill s1 1))) - (and (eqt s1 s2) - (coerce (loop for i from 0 to 7 collect (aref s2 i)) - 'bit-vector))) - #*11110000) - -;;; Test of :allow-other-keys - -(deftest fill.allow-other-keys.1 - (fill (list 'a 'b 'c 'd 'e) 'a :allow-other-keys t) - (a a a a a)) - -(deftest fill.allow-other-keys.2 - (fill (list 'a 'b 'c 'd 'e) 'a :allow-other-keys nil) - (a a a a a)) - -(deftest fill.allow-other-keys.3 - (fill (list 'a 'b 'c 'd 'e) 'a :allow-other-keys t :bad t) - (a a a a a)) - -(deftest fill.allow-other-keys.4 - (fill (list 'a 'b 'c 'd 'e) 'a :bad t :allow-other-keys t) - (a a a a a)) - -(deftest fill.allow-other-keys.5 - (fill (list 'a 'b 'c 'd 'e) 'a 'bad t :allow-other-keys t) - (a a a a a)) - -(deftest fill.allow-other-keys.6 - (fill (list 'a 'b 'c 'd 'e) 'a :bad t :allow-other-keys t - :allow-other-keys nil) - (a a a a a)) - -(deftest fill.allow-other-keys.7 - (fill (list 'a 'b 'c 'd 'e) 'a :allow-other-keys t :allow-other-keys nil - :bad t) - (a a a a a)) - - -;;; Tests of evaluation order - -(deftest fill.order.1 - (let ((i 0) x y (a (copy-seq #(a a a a)))) - (values - (fill (progn (setf x (incf i)) a) - (progn (setf y (incf i)) 'z)) - i x y)) - #(z z z z) 2 1 2) - -(deftest fill.order.2 - (let ((i 0) x y z w (a (copy-seq #(a a a a)))) - (values - (fill (progn (setf x (incf i)) a) - (progn (setf y (incf i)) 'z) - :start (progn (setf z (incf i)) 1) - :end (progn (setf w (incf i)) 3)) - i x y z w)) - #(a z z a) 4 1 2 3 4) - -(deftest fill.order.3 - (let ((i 0) x y z w (a (copy-seq #(a a a a)))) - (values - (fill (progn (setf x (incf i)) a) - (progn (setf y (incf i)) 'z) - :end (progn (setf z (incf i)) 3) - :start (progn (setf w (incf i)) 1)) - i x y z w)) - #(a z z a) 4 1 2 3 4) - -(deftest fill.order.4 - (let ((i 0) x y z p q r s w (a (copy-seq #(a a a a)))) - (values - (fill (progn (setf x (incf i)) a) - (progn (setf y (incf i)) 'z) - :end (progn (setf z (incf i)) 3) - :end (progn (setf p (incf i)) 1) - :end (progn (setf q (incf i)) 1) - :end (progn (setf r (incf i)) 1) - :start (progn (setf s (incf i)) 1) - :start (progn (setf w (incf i)) 0)) - i x y z p q r s w)) - #(a z z a) 8 1 2 3 4 5 6 7 8) - -;;; Specialized strings - -(deftest fill.specialized-strings.1 - (do-special-strings - (s (copy-seq "abcde") nil) - (assert (string= s "abcde")) - (assert (eq s (fill s #\x))) - (assert (string= s "xxxxx"))) - nil) - -(deftest fill.specialized-strings.2 - (do-special-strings - (s (copy-seq "abcde") nil) - (assert (string= s "abcde")) - (assert (eq s (fill s #\x :start 2))) - (assert (string= s "abxxx"))) - nil) - -(deftest fill.specialized-strings.3 - (do-special-strings - (s (copy-seq "abcde") nil) - (assert (string= s "abcde")) - (assert (eq s (fill s #\x :end 3))) - (assert (string= s "xxxde"))) - nil) - -(deftest fill.specialized-strings.4 - (do-special-strings - (s (copy-seq "abcde") nil) - (assert (string= s "abcde")) - (assert (eq s (fill s #\x :start 1 :end 4))) - (assert (string= s "axxxe"))) - nil) - -;;; Specialized vector tests - -(deftest fill.specialized-vectors.1 - (do-special-integer-vectors - (v #(0 1 1 0 1) nil) - (let ((etype (array-element-type v))) - (assert (eq v (fill v 0))) - (assert (equal (array-element-type v) etype))) - (assert (equalp v #(0 0 0 0 0)))) - nil) - -(deftest fill.specialized-vectors.2 - (do-special-integer-vectors - (v #(0 -1 1 0 -1) nil) - (let ((etype (array-element-type v))) - (assert (eq v (fill v 1))) - (assert (equal (array-element-type v) etype))) - (assert (equalp v #(1 1 1 1 1)))) - nil) - -(deftest fill.specialized-vectors.3 - (do-special-integer-vectors - (v #(1 1 1 1 0) nil) - (let ((etype (array-element-type v))) - (assert (eq v (fill v 0 :start 1 :end 3))) - (assert (equal (array-element-type v) etype))) - (assert (equalp v #(1 0 0 1 0)))) - nil) diff --git a/t/ansi-test/sequences/find-if-not.lsp b/t/ansi-test/sequences/find-if-not.lsp deleted file mode 100644 index cc6f031..0000000 --- a/t/ansi-test/sequences/find-if-not.lsp +++ /dev/null @@ -1,612 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Aug 28 20:53:24 2002 -;;;; Contains: Tests for FIND-IF-NOT - -(in-package :cl-test) - -(deftest find-if-not-list.1 - (find-if-not #'identity ()) - nil) - -(deftest find-if-not-list.2 - (find-if-not #'null '(a)) - a) - -(deftest find-if-not-list.2a - (find-if-not 'null '(a)) - a) - -(deftest find-if-not-list.3 - (find-if-not #'oddp '(1 2 4 8 3 1 6 7)) - 2) - -(deftest find-if-not-list.4 - (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :from-end t) - 6) - -(deftest find-if-not-list.5 - (loop for i from 0 to 7 collect - (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :start i)) - (2 2 4 8 6 6 6 nil)) - -(deftest find-if-not-list.6 - (loop for i from 0 to 7 collect - (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :start i :end nil)) - (2 2 4 8 6 6 6 nil)) - -(deftest find-if-not-list.7 - (loop for i from 0 to 7 collect - (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :start i :from-end t)) - (6 6 6 6 6 6 6 nil)) - -(deftest find-if-not-list.8 - (loop for i from 0 to 7 collect - (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :start i :end nil :from-end t)) - (6 6 6 6 6 6 6 nil)) - -(deftest find-if-not-list.9 - (loop for i from 0 to 8 collect - (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :end i)) - (nil nil 2 2 2 2 2 2 2)) - -(deftest find-if-not-list.10 - (loop for i from 0 to 8 collect - (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :end i :from-end t)) - (nil nil 2 4 8 8 8 6 6)) - -(deftest find-if-not-list.11 - (loop for j from 0 to 7 - collect - (loop for i from (1+ j) to 8 collect - (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :start j :end i))) - ((nil 2 2 2 2 2 2 2) - (2 2 2 2 2 2 2) - (4 4 4 4 4 4) - (8 8 8 8 8) - (nil nil 6 6) - (nil 6 6) - (6 6) - (nil))) - -(deftest find-if-not-list.12 - (loop for j from 0 to 7 - collect - (loop for i from (1+ j) to 8 collect - (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :start j :end i - :from-end t))) - ((nil 2 4 8 8 8 6 6) - (2 4 8 8 8 6 6) - (4 8 8 8 6 6) - (8 8 8 6 6) - (nil nil 6 6) - (nil 6 6) - (6 6) - (nil))) - -(deftest find-if-not-list.13 - (loop for i from 0 to 6 - collect - (find-if-not #'oddp '(1 6 11 32 45 71 100) :key #'1+ :start i)) - (1 11 11 45 45 71 nil)) - -(deftest find-if-not-list.14 - (loop for i from 0 to 6 - collect - (find-if-not #'oddp '(1 6 11 32 45 71 100) :key '1+ :start i :from-end t)) - (71 71 71 71 71 71 nil)) - -(deftest find-if-not-list.15 - (loop for i from 0 to 7 - collect - (find-if-not #'oddp '(1 6 11 32 45 71 100) :key #'1+ :end i)) - (nil 1 1 1 1 1 1 1)) - -(deftest find-if-not-list.16 - (loop for i from 0 to 7 - collect - (find-if-not #'oddp '(1 6 11 32 45 71 100) :key '1+ :end i :from-end t)) - (nil 1 1 11 11 45 71 71)) - -(deftest find-if-not-list.17 - (loop for j from 0 to 7 - collect - (loop for i from (1+ j) to 8 collect - (find-if-not #'evenp '(1 2 4 8 3 1 6 7) :start j :end i :key #'1-))) - ((nil 2 2 2 2 2 2 2) - (2 2 2 2 2 2 2) - (4 4 4 4 4 4) - (8 8 8 8 8) - (nil nil 6 6) - (nil 6 6) - (6 6) - (nil))) - -(deftest find-if-not-list.18 - (loop for j from 0 to 7 - collect - (loop for i from (1+ j) to 8 collect - (find-if-not #'evenp '(1 2 4 8 3 1 6 7) :start j :end i - :from-end t :key #'1+))) - ((nil 2 4 8 8 8 6 6) - (2 4 8 8 8 6 6) - (4 8 8 8 6 6) - (8 8 8 6 6) - (nil nil 6 6) - (nil 6 6) - (6 6) - (nil))) - -;;; tests for vectors - -(deftest find-if-not-vector.1 - (find-if-not #'identity #()) - nil) - -(deftest find-if-not-vector.2 - (find-if-not #'not #(a)) - a) - -(deftest find-if-not-vector.2a - (find-if-not 'null #(a)) - a) - -(deftest find-if-not-vector.3 - (find-if-not #'oddp #(1 2 4 8 3 1 6 7)) - 2) - -(deftest find-if-not-vector.4 - (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :from-end t) - 6) - -(deftest find-if-not-vector.5 - (loop for i from 0 to 7 collect - (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :start i)) - (2 2 4 8 6 6 6 nil)) - -(deftest find-if-not-vector.6 - (loop for i from 0 to 7 collect - (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :start i :end nil)) - (2 2 4 8 6 6 6 nil)) - -(deftest find-if-not-vector.7 - (loop for i from 0 to 7 collect - (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :start i :from-end t)) - (6 6 6 6 6 6 6 nil)) - -(deftest find-if-not-vector.8 - (loop for i from 0 to 7 collect - (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :start i :end nil :from-end t)) - (6 6 6 6 6 6 6 nil)) - -(deftest find-if-not-vector.9 - (loop for i from 0 to 8 collect - (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :end i)) - (nil nil 2 2 2 2 2 2 2)) - -(deftest find-if-not-vector.10 - (loop for i from 0 to 8 collect - (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :end i :from-end t)) - (nil nil 2 4 8 8 8 6 6)) - -(deftest find-if-not-vector.11 - (loop for j from 0 to 7 - collect - (loop for i from (1+ j) to 8 collect - (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :start j :end i))) - ((nil 2 2 2 2 2 2 2) - (2 2 2 2 2 2 2) - (4 4 4 4 4 4) - (8 8 8 8 8) - (nil nil 6 6) - (nil 6 6) - (6 6) - (nil))) - -(deftest find-if-not-vector.12 - (loop for j from 0 to 7 - collect - (loop for i from (1+ j) to 8 collect - (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :start j :end i - :from-end t))) - ((nil 2 4 8 8 8 6 6) - (2 4 8 8 8 6 6) - (4 8 8 8 6 6) - (8 8 8 6 6) - (nil nil 6 6) - (nil 6 6) - (6 6) - (nil))) - -(deftest find-if-not-vector.13 - (loop for i from 0 to 6 - collect - (find-if-not #'oddp #(1 6 11 32 45 71 100) :key #'1+ :start i)) - (1 11 11 45 45 71 nil)) - -(deftest find-if-not-vector.14 - (loop for i from 0 to 6 - collect - (find-if-not #'oddp #(1 6 11 32 45 71 100) :key '1+ :start i :from-end t)) - (71 71 71 71 71 71 nil)) - -(deftest find-if-not-vector.15 - (loop for i from 0 to 7 - collect - (find-if-not #'oddp #(1 6 11 32 45 71 100) :key #'1+ :end i)) - (nil 1 1 1 1 1 1 1)) - -(deftest find-if-not-vector.16 - (loop for i from 0 to 7 - collect - (find-if-not #'oddp #(1 6 11 32 45 71 100) :key '1+ :end i :from-end t)) - (nil 1 1 11 11 45 71 71)) - -(deftest find-if-not-vector.17 - (loop for j from 0 to 7 - collect - (loop for i from (1+ j) to 8 collect - (find-if-not #'evenp #(1 2 4 8 3 1 6 7) :start j :end i :key #'1-))) - ((nil 2 2 2 2 2 2 2) - (2 2 2 2 2 2 2) - (4 4 4 4 4 4) - (8 8 8 8 8) - (nil nil 6 6) - (nil 6 6) - (6 6) - (nil))) - -(deftest find-if-not-vector.18 - (loop for j from 0 to 7 - collect - (loop for i from (1+ j) to 8 collect - (find-if-not #'evenp #(1 2 4 8 3 1 6 7) :start j :end i - :from-end t :key #'1+))) - ((nil 2 4 8 8 8 6 6) - (2 4 8 8 8 6 6) - (4 8 8 8 6 6) - (8 8 8 6 6) - (nil nil 6 6) - (nil 6 6) - (6 6) - (nil))) - -;;; Tests for bit vectors - -(deftest find-if-not-bit-vector.1 - (find-if-not #'identity #*) - nil) - -(deftest find-if-not-bit-vector.2 - (find-if-not #'null #*1) - 1) - -(deftest find-if-not-bit-vector.3 - (find-if-not #'not #*0) - 0) - -(deftest find-if-not-bit-vector.4 - (loop for i from 0 to 6 - collect (loop for j from i to 7 - collect (find-if-not #'oddp #*0110110 :start i :end j))) - ((nil 0 0 0 0 0 0 0) - (nil nil nil 0 0 0 0) - (nil nil 0 0 0 0) - (nil 0 0 0 0) - (nil nil nil 0) - (nil nil 0) - (nil 0))) - -(deftest find-if-not-bit-vector.5 - (loop for i from 0 to 6 - collect (loop for j from i to 7 - collect (find-if-not #'oddp #*0110110 :start i :end j - :from-end t))) - ((nil 0 0 0 0 0 0 0) - (nil nil nil 0 0 0 0) - (nil nil 0 0 0 0) - (nil 0 0 0 0) - (nil nil nil 0) - (nil nil 0) - (nil 0))) - -(deftest find-if-not-bit-vector.6 - (loop for i from 0 to 6 - collect (loop for j from i to 7 - collect (find-if-not #'evenp #*0110110 :start i :end j - :from-end t :key #'1+))) - ((nil 0 0 0 0 0 0 0) - (nil nil nil 0 0 0 0) - (nil nil 0 0 0 0) - (nil 0 0 0 0) - (nil nil nil 0) - (nil nil 0) - (nil 0))) - -(deftest find-if-not-bit-vector.7 - (loop for i from 0 to 6 - collect (loop for j from i to 7 - collect (find-if-not #'evenp #*0110110 :start i :end j - :key '1-))) - ((nil 0 0 0 0 0 0 0) - (nil nil nil 0 0 0 0) - (nil nil 0 0 0 0) - (nil 0 0 0 0) - (nil nil nil 0) - (nil nil 0) - (nil 0))) - -;;; Tests for strings - -(deftest find-if-not-string.1 - (find-if-not #'identity "") - nil) - -(deftest find-if-not-string.2 - (find-if-not #'null "a") - #\a) - -(deftest find-if-not-string.2a - (find-if-not 'null "a") - #\a) - -(deftest find-if-not-string.3 - (find-if-not #'odddigitp "12483167") - #\2) - -(deftest find-if-not-string.3a - (find-if-not #'oddp "12483167" :key #'(lambda (c) (read-from-string (string c)))) - #\2) - -(deftest find-if-not-string.4 - (find-if-not #'odddigitp "12483167" :from-end t) - #\6) - -(deftest find-if-not-string.5 - (loop for i from 0 to 7 collect - (find-if-not #'odddigitp "12483167" :start i)) - (#\2 #\2 #\4 #\8 #\6 #\6 #\6 nil)) - -(deftest find-if-not-string.6 - (loop for i from 0 to 7 collect - (find-if-not #'odddigitp "12483167" :start i :end nil)) - (#\2 #\2 #\4 #\8 #\6 #\6 #\6 nil)) - -(deftest find-if-not-string.7 - (loop for i from 0 to 7 collect - (find-if-not #'odddigitp "12483167" :start i :from-end t)) - (#\6 #\6 #\6 #\6 #\6 #\6 #\6 nil)) - -(deftest find-if-not-string.8 - (loop for i from 0 to 7 collect - (find-if-not #'odddigitp "12483167" :start i :end nil :from-end t)) - (#\6 #\6 #\6 #\6 #\6 #\6 #\6 nil)) - -(deftest find-if-not-string.9 - (loop for i from 0 to 8 collect - (find-if-not #'odddigitp "12483167" :end i)) - (nil nil #\2 #\2 #\2 #\2 #\2 #\2 #\2)) - -(deftest find-if-not-string.10 - (loop for i from 0 to 8 collect - (find-if-not #'odddigitp "12483167" :end i :from-end t)) - (nil nil #\2 #\4 #\8 #\8 #\8 #\6 #\6)) - -(deftest find-if-not-string.11 - (loop for j from 0 to 7 - collect - (loop for i from (1+ j) to 8 collect - (find-if-not #'odddigitp "12483167" :start j :end i))) - ((nil #\2 #\2 #\2 #\2 #\2 #\2 #\2) - (#\2 #\2 #\2 #\2 #\2 #\2 #\2) - (#\4 #\4 #\4 #\4 #\4 #\4) - (#\8 #\8 #\8 #\8 #\8) - (nil nil #\6 #\6) - (nil #\6 #\6) - (#\6 #\6) - (nil))) - -(deftest find-if-not-string.12 - (loop for j from 0 to 7 - collect - (loop for i from (1+ j) to 8 collect - (find-if-not #'odddigitp "12483167" :start j :end i - :from-end t))) - ((nil #\2 #\4 #\8 #\8 #\8 #\6 #\6) - (#\2 #\4 #\8 #\8 #\8 #\6 #\6) - (#\4 #\8 #\8 #\8 #\6 #\6) - (#\8 #\8 #\8 #\6 #\6) - (nil nil #\6 #\6) - (nil #\6 #\6) - (#\6 #\6) - (nil))) - -(deftest find-if-not-string.13 - (loop for i from 0 to 6 - collect - (find-if-not #'oddp "1473816" - :key (compose #'read-from-string #'string) - :start i)) - (#\4 #\4 #\8 #\8 #\8 #\6 #\6)) - -(deftest find-if-not-string.14 - (loop for i from 0 to 6 - collect - (find-if-not #'oddp "1473816" - :key (compose #'read-from-string #'string) - :start i :from-end t)) - (#\6 #\6 #\6 #\6 #\6 #\6 #\6)) - -(deftest find-if-not-string.15 - (loop for i from 0 to 7 - collect - (find-if-not #'oddp "1473816" - :key (compose #'read-from-string #'string) - :end i)) - (nil nil #\4 #\4 #\4 #\4 #\4 #\4)) - -(deftest find-if-not-string.16 - (loop for i from 0 to 7 - collect - (find-if-not #'oddp "1473816" - :key (compose #'read-from-string #'string) - :end i :from-end t)) - (nil nil #\4 #\4 #\4 #\8 #\8 #\6)) - -(deftest find-if-not-string.17 - (loop for j from 0 to 6 - collect - (loop for i from (1+ j) to 7 collect - (find-if-not #'oddp "1473816" - :key (compose #'read-from-string #'string) - :start j :end i))) - ((nil #\4 #\4 #\4 #\4 #\4 #\4) - (#\4 #\4 #\4 #\4 #\4 #\4) - (nil nil #\8 #\8 #\8) - (nil #\8 #\8 #\8) - (#\8 #\8 #\8) - (nil #\6) - (#\6))) - -(deftest find-if-not-string.18 - (loop for j from 0 to 6 - collect - (loop for i from (1+ j) to 7 collect - (find-if-not #'oddp "1473816" - :key (compose #'read-from-string #'string) - :start j :end i - :from-end t))) - ((nil #\4 #\4 #\4 #\8 #\8 #\6) - (#\4 #\4 #\4 #\8 #\8 #\6) - (nil nil #\8 #\8 #\6) - (nil #\8 #\8 #\6) - (#\8 #\8 #\6) - (nil #\6) - (#\6))) - -(deftest find-if-not-string.19 - (do-special-strings - (s "abc1def" nil) - (assert (eql (find-if-not #'alpha-char-p s) #\1))) - nil) - -;;; Keyword tests - -(deftest find-if-not.allow-other-keys.1 - (find-if-not #'oddp '(1 2 3 4 5) :bad t :allow-other-keys t) - 2) - -(deftest find-if-not.allow-other-keys.2 - (find-if-not #'oddp '(1 2 3 4 5) :allow-other-keys t :also-bad t) - 2) - -;;; The leftmost of two :allow-other-keys arguments is the one that matters. -(deftest find-if-not.allow-other-keys.3 - (find-if-not #'oddp '(1 2 3 4 5) - :allow-other-keys t - :allow-other-keys nil - :bad t) - 2) - -(deftest find-if-not.keywords.4 - (find-if-not #'oddp '(1 2 3 4 5) :key #'identity :key #'1+) - 2) - -(deftest find-if-not.allow-other-keys.5 - (find-if-not #'null '(nil a b c nil) :allow-other-keys nil) - a) - -;;; Error tests - -(deftest find-if-not.error.1 - (check-type-error #'(lambda (x) (find-if-not #'null x)) #'(lambda (x) (typep x 'sequence))) - nil) - -(deftest find-if-not.error.4 - (signals-error (find-if-not 'identity '(a b c . d)) - type-error) - t) - -(deftest find-if-not.error.5 - (signals-error (find-if-not) program-error) - t) - -(deftest find-if-not.error.6 - (signals-error (find-if-not #'null) program-error) - t) - -(deftest find-if-not.error.7 - (signals-error (find-if-not #'null nil :bad t) program-error) - t) - -(deftest find-if-not.error.8 - (signals-error (find-if-not #'null nil :bad t :allow-other-keys nil) - program-error) - t) - -(deftest find-if-not.error.9 - (signals-error (find-if-not #'null nil 1 1) program-error) - t) - -(deftest find-if-not.error.10 - (signals-error (find-if-not #'null nil :key) program-error) - t) - -(deftest find-if-not.error.11 - (signals-error (locally (find-if-not #'null 'b) t) type-error) - t) - -(deftest find-if-not.error.12 - (signals-error (find-if-not #'cons '(a b c)) program-error) - t) - -(deftest find-if-not.error.13 - (signals-error (find-if-not #'car '(a b c)) type-error) - t) - -(deftest find-if-not.error.14 - (signals-error (find-if-not #'identity '(a b c) :key #'cons) - program-error) - t) - -(deftest find-if-not.error.15 - (signals-error (find-if-not #'identity '(a b c) :key #'car) - type-error) - t) - -;;; Order of evaluation tests - -(deftest find-if-not.order.1 - (let ((i 0) x y) - (values - (find-if-not (progn (setf x (incf i)) #'null) - (progn (setf y (incf i)) '(nil nil nil a nil nil))) - i x y)) - a 2 1 2) - -(deftest find-if-not.order.2 - (let ((i 0) a b c d e f) - (values - (find-if-not (progn (setf a (incf i)) #'identity) - (progn (setf b (incf i)) '(nil nil nil a nil nil)) - :start (progn (setf c (incf i)) 1) - :end (progn (setf d (incf i)) 4) - :from-end (setf e (incf i)) - :key (progn (setf f (incf i)) #'null) - ) - i a b c d e f)) - a 6 1 2 3 4 5 6) - - -(deftest find-if-not.order.3 - (let ((i 0) a b c d e f) - (values - (find-if-not (progn (setf a (incf i)) #'identity) - (progn (setf b (incf i)) '(nil nil nil a nil nil)) - :key (progn (setf c (incf i)) #'null) - :from-end (setf d (incf i)) - :end (progn (setf e (incf i)) 4) - :start (progn (setf f (incf i)) 1) - ) - i a b c d e f)) - a 6 1 2 3 4 5 6) diff --git a/t/ansi-test/sequences/find-if.lsp b/t/ansi-test/sequences/find-if.lsp deleted file mode 100644 index 9fd712d..0000000 --- a/t/ansi-test/sequences/find-if.lsp +++ /dev/null @@ -1,634 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Aug 28 18:37:52 2002 -;;;; Contains: Tests for FIND-IF - -(in-package :cl-test) - -(deftest find-if-list.1 - (find-if #'identity ()) - nil) - -(deftest find-if-list.2 - (find-if #'identity '(a)) - a) - -(deftest find-if-list.2a - (find-if 'identity '(a)) - a) - -(deftest find-if-list.3 - (find-if #'evenp '(1 2 4 8 3 1 6 7)) - 2) - -(deftest find-if-list.4 - (find-if #'evenp '(1 2 4 8 3 1 6 7) :from-end t) - 6) - -(deftest find-if-list.5 - (loop for i from 0 to 7 collect - (find-if #'evenp '(1 2 4 8 3 1 6 7) :start i)) - (2 2 4 8 6 6 6 nil)) - -(deftest find-if-list.6 - (loop for i from 0 to 7 collect - (find-if #'evenp '(1 2 4 8 3 1 6 7) :start i :end nil)) - (2 2 4 8 6 6 6 nil)) - -(deftest find-if-list.7 - (loop for i from 0 to 7 collect - (find-if #'evenp '(1 2 4 8 3 1 6 7) :start i :from-end t)) - (6 6 6 6 6 6 6 nil)) - -(deftest find-if-list.8 - (loop for i from 0 to 7 collect - (find-if #'evenp '(1 2 4 8 3 1 6 7) :start i :end nil :from-end t)) - (6 6 6 6 6 6 6 nil)) - -(deftest find-if-list.9 - (loop for i from 0 to 8 collect - (find-if #'evenp '(1 2 4 8 3 1 6 7) :end i)) - (nil nil 2 2 2 2 2 2 2)) - -(deftest find-if-list.10 - (loop for i from 0 to 8 collect - (find-if #'evenp '(1 2 4 8 3 1 6 7) :end i :from-end t)) - (nil nil 2 4 8 8 8 6 6)) - -(deftest find-if-list.11 - (loop for j from 0 to 7 - collect - (loop for i from (1+ j) to 8 collect - (find-if #'evenp '(1 2 4 8 3 1 6 7) :start j :end i))) - ((nil 2 2 2 2 2 2 2) - (2 2 2 2 2 2 2) - (4 4 4 4 4 4) - (8 8 8 8 8) - (nil nil 6 6) - (nil 6 6) - (6 6) - (nil))) - -(deftest find-if-list.12 - (loop for j from 0 to 7 - collect - (loop for i from (1+ j) to 8 collect - (find-if #'evenp '(1 2 4 8 3 1 6 7) :start j :end i - :from-end t))) - ((nil 2 4 8 8 8 6 6) - (2 4 8 8 8 6 6) - (4 8 8 8 6 6) - (8 8 8 6 6) - (nil nil 6 6) - (nil 6 6) - (6 6) - (nil))) - -(deftest find-if-list.13 - (loop for i from 0 to 6 - collect - (find-if #'evenp '(1 6 11 32 45 71 100) :key #'1+ :start i)) - (1 11 11 45 45 71 nil)) - -(deftest find-if-list.14 - (loop for i from 0 to 6 - collect - (find-if #'evenp '(1 6 11 32 45 71 100) :key '1+ :start i :from-end t)) - (71 71 71 71 71 71 nil)) - -(deftest find-if-list.15 - (loop for i from 0 to 7 - collect - (find-if #'evenp '(1 6 11 32 45 71 100) :key #'1+ :end i)) - (nil 1 1 1 1 1 1 1)) - -(deftest find-if-list.16 - (loop for i from 0 to 7 - collect - (find-if #'evenp '(1 6 11 32 45 71 100) :key '1+ :end i :from-end t)) - (nil 1 1 11 11 45 71 71)) - -(deftest find-if-list.17 - (loop for j from 0 to 7 - collect - (loop for i from (1+ j) to 8 collect - (find-if #'oddp '(1 2 4 8 3 1 6 7) :start j :end i :key #'1-))) - ((nil 2 2 2 2 2 2 2) - (2 2 2 2 2 2 2) - (4 4 4 4 4 4) - (8 8 8 8 8) - (nil nil 6 6) - (nil 6 6) - (6 6) - (nil))) - -(deftest find-if-list.18 - (loop for j from 0 to 7 - collect - (loop for i from (1+ j) to 8 collect - (find-if #'oddp '(1 2 4 8 3 1 6 7) :start j :end i - :from-end t :key #'1+))) - ((nil 2 4 8 8 8 6 6) - (2 4 8 8 8 6 6) - (4 8 8 8 6 6) - (8 8 8 6 6) - (nil nil 6 6) - (nil 6 6) - (6 6) - (nil))) - -;;; tests for vectors - -(deftest find-if-vector.1 - (find-if #'identity #()) - nil) - -(deftest find-if-vector.2 - (find-if #'identity #(a)) - a) - -(deftest find-if-vector.2a - (find-if 'identity #(a)) - a) - -(deftest find-if-vector.3 - (find-if #'evenp #(1 2 4 8 3 1 6 7)) - 2) - -(deftest find-if-vector.4 - (find-if #'evenp #(1 2 4 8 3 1 6 7) :from-end t) - 6) - -(deftest find-if-vector.5 - (loop for i from 0 to 7 collect - (find-if #'evenp #(1 2 4 8 3 1 6 7) :start i)) - (2 2 4 8 6 6 6 nil)) - -(deftest find-if-vector.6 - (loop for i from 0 to 7 collect - (find-if #'evenp #(1 2 4 8 3 1 6 7) :start i :end nil)) - (2 2 4 8 6 6 6 nil)) - -(deftest find-if-vector.7 - (loop for i from 0 to 7 collect - (find-if #'evenp #(1 2 4 8 3 1 6 7) :start i :from-end t)) - (6 6 6 6 6 6 6 nil)) - -(deftest find-if-vector.8 - (loop for i from 0 to 7 collect - (find-if #'evenp #(1 2 4 8 3 1 6 7) :start i :end nil :from-end t)) - (6 6 6 6 6 6 6 nil)) - -(deftest find-if-vector.9 - (loop for i from 0 to 8 collect - (find-if #'evenp #(1 2 4 8 3 1 6 7) :end i)) - (nil nil 2 2 2 2 2 2 2)) - -(deftest find-if-vector.10 - (loop for i from 0 to 8 collect - (find-if #'evenp #(1 2 4 8 3 1 6 7) :end i :from-end t)) - (nil nil 2 4 8 8 8 6 6)) - -(deftest find-if-vector.11 - (loop for j from 0 to 7 - collect - (loop for i from (1+ j) to 8 collect - (find-if #'evenp #(1 2 4 8 3 1 6 7) :start j :end i))) - ((nil 2 2 2 2 2 2 2) - (2 2 2 2 2 2 2) - (4 4 4 4 4 4) - (8 8 8 8 8) - (nil nil 6 6) - (nil 6 6) - (6 6) - (nil))) - -(deftest find-if-vector.12 - (loop for j from 0 to 7 - collect - (loop for i from (1+ j) to 8 collect - (find-if #'evenp #(1 2 4 8 3 1 6 7) :start j :end i - :from-end t))) - ((nil 2 4 8 8 8 6 6) - (2 4 8 8 8 6 6) - (4 8 8 8 6 6) - (8 8 8 6 6) - (nil nil 6 6) - (nil 6 6) - (6 6) - (nil))) - -(deftest find-if-vector.13 - (loop for i from 0 to 6 - collect - (find-if #'evenp #(1 6 11 32 45 71 100) :key #'1+ :start i)) - (1 11 11 45 45 71 nil)) - -(deftest find-if-vector.14 - (loop for i from 0 to 6 - collect - (find-if #'evenp #(1 6 11 32 45 71 100) :key '1+ :start i :from-end t)) - (71 71 71 71 71 71 nil)) - -(deftest find-if-vector.15 - (loop for i from 0 to 7 - collect - (find-if #'evenp #(1 6 11 32 45 71 100) :key #'1+ :end i)) - (nil 1 1 1 1 1 1 1)) - -(deftest find-if-vector.16 - (loop for i from 0 to 7 - collect - (find-if #'evenp #(1 6 11 32 45 71 100) :key '1+ :end i :from-end t)) - (nil 1 1 11 11 45 71 71)) - -(deftest find-if-vector.17 - (loop for j from 0 to 7 - collect - (loop for i from (1+ j) to 8 collect - (find-if #'oddp #(1 2 4 8 3 1 6 7) :start j :end i :key #'1-))) - ((nil 2 2 2 2 2 2 2) - (2 2 2 2 2 2 2) - (4 4 4 4 4 4) - (8 8 8 8 8) - (nil nil 6 6) - (nil 6 6) - (6 6) - (nil))) - -(deftest find-if-vector.18 - (loop for j from 0 to 7 - collect - (loop for i from (1+ j) to 8 collect - (find-if #'oddp #(1 2 4 8 3 1 6 7) :start j :end i - :from-end t :key #'1+))) - ((nil 2 4 8 8 8 6 6) - (2 4 8 8 8 6 6) - (4 8 8 8 6 6) - (8 8 8 6 6) - (nil nil 6 6) - (nil 6 6) - (6 6) - (nil))) - -(deftest find-if-vector.19 - (let ((a (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) - :fill-pointer 5))) - (values - (find-if #'evenp a) - (find-if #'evenp a :from-end t) - (find-if #'oddp a) - (find-if #'oddp a :from-end t) - )) - 2 4 1 5) - -;;; Tests for bit vectors - -(deftest find-if-bit-vector.1 - (find-if #'identity #*) - nil) - -(deftest find-if-bit-vector.2 - (find-if #'identity #*1) - 1) - -(deftest find-if-bit-vector.3 - (find-if #'identity #*0) - 0) - -(deftest find-if-bit-vector.4 - (loop for i from 0 to 6 - collect (loop for j from i to 7 - collect (find-if #'evenp #*0110110 :start i :end j))) - ((nil 0 0 0 0 0 0 0) - (nil nil nil 0 0 0 0) - (nil nil 0 0 0 0) - (nil 0 0 0 0) - (nil nil nil 0) - (nil nil 0) - (nil 0))) - -(deftest find-if-bit-vector.5 - (loop for i from 0 to 6 - collect (loop for j from i to 7 - collect (find-if #'evenp #*0110110 :start i :end j - :from-end t))) - ((nil 0 0 0 0 0 0 0) - (nil nil nil 0 0 0 0) - (nil nil 0 0 0 0) - (nil 0 0 0 0) - (nil nil nil 0) - (nil nil 0) - (nil 0))) - -(deftest find-if-bit-vector.6 - (loop for i from 0 to 6 - collect (loop for j from i to 7 - collect (find-if #'oddp #*0110110 :start i :end j - :from-end t :key #'1+))) - ((nil 0 0 0 0 0 0 0) - (nil nil nil 0 0 0 0) - (nil nil 0 0 0 0) - (nil 0 0 0 0) - (nil nil nil 0) - (nil nil 0) - (nil 0))) - -(deftest find-if-bit-vector.7 - (loop for i from 0 to 6 - collect (loop for j from i to 7 - collect (find-if #'oddp #*0110110 :start i :end j - :key '1-))) - ((nil 0 0 0 0 0 0 0) - (nil nil nil 0 0 0 0) - (nil nil 0 0 0 0) - (nil 0 0 0 0) - (nil nil nil 0) - (nil nil 0) - (nil 0))) - -;;; Tests for strings - -(deftest find-if-string.1 - (find-if #'identity "") - nil) - -(deftest find-if-string.2 - (find-if #'identity "a") - #\a) - -(deftest find-if-string.2a - (find-if 'identity "a") - #\a) - -(deftest find-if-string.3 - (find-if #'evendigitp "12483167") - #\2) - -(deftest find-if-string.3a - (find-if #'evenp "12483167" :key #'(lambda (c) (read-from-string (string c)))) - #\2) - -(deftest find-if-string.4 - (find-if #'evendigitp "12483167" :from-end t) - #\6) - -(deftest find-if-string.5 - (loop for i from 0 to 7 collect - (find-if #'evendigitp "12483167" :start i)) - (#\2 #\2 #\4 #\8 #\6 #\6 #\6 nil)) - -(deftest find-if-string.6 - (loop for i from 0 to 7 collect - (find-if #'evendigitp "12483167" :start i :end nil)) - (#\2 #\2 #\4 #\8 #\6 #\6 #\6 nil)) - -(deftest find-if-string.7 - (loop for i from 0 to 7 collect - (find-if #'evendigitp "12483167" :start i :from-end t)) - (#\6 #\6 #\6 #\6 #\6 #\6 #\6 nil)) - -(deftest find-if-string.8 - (loop for i from 0 to 7 collect - (find-if #'evendigitp "12483167" :start i :end nil :from-end t)) - (#\6 #\6 #\6 #\6 #\6 #\6 #\6 nil)) - -(deftest find-if-string.9 - (loop for i from 0 to 8 collect - (find-if #'evendigitp "12483167" :end i)) - (nil nil #\2 #\2 #\2 #\2 #\2 #\2 #\2)) - -(deftest find-if-string.10 - (loop for i from 0 to 8 collect - (find-if #'evendigitp "12483167" :end i :from-end t)) - (nil nil #\2 #\4 #\8 #\8 #\8 #\6 #\6)) - -(deftest find-if-string.11 - (loop for j from 0 to 7 - collect - (loop for i from (1+ j) to 8 collect - (find-if #'evendigitp "12483167" :start j :end i))) - ((nil #\2 #\2 #\2 #\2 #\2 #\2 #\2) - (#\2 #\2 #\2 #\2 #\2 #\2 #\2) - (#\4 #\4 #\4 #\4 #\4 #\4) - (#\8 #\8 #\8 #\8 #\8) - (nil nil #\6 #\6) - (nil #\6 #\6) - (#\6 #\6) - (nil))) - -(deftest find-if-string.12 - (loop for j from 0 to 7 - collect - (loop for i from (1+ j) to 8 collect - (find-if #'evendigitp "12483167" :start j :end i - :from-end t))) - ((nil #\2 #\4 #\8 #\8 #\8 #\6 #\6) - (#\2 #\4 #\8 #\8 #\8 #\6 #\6) - (#\4 #\8 #\8 #\8 #\6 #\6) - (#\8 #\8 #\8 #\6 #\6) - (nil nil #\6 #\6) - (nil #\6 #\6) - (#\6 #\6) - (nil))) - -(deftest find-if-string.13 - (loop for i from 0 to 6 - collect - (find-if #'evenp "1473816" - :key (compose #'read-from-string #'string) - :start i)) - (#\4 #\4 #\8 #\8 #\8 #\6 #\6)) - -(deftest find-if-string.14 - (loop for i from 0 to 6 - collect - (find-if #'evenp "1473816" - :key (compose #'read-from-string #'string) - :start i :from-end t)) - (#\6 #\6 #\6 #\6 #\6 #\6 #\6)) - -(deftest find-if-string.15 - (loop for i from 0 to 7 - collect - (find-if #'evenp "1473816" - :key (compose #'read-from-string #'string) - :end i)) - (nil nil #\4 #\4 #\4 #\4 #\4 #\4)) - -(deftest find-if-string.16 - (loop for i from 0 to 7 - collect - (find-if #'evenp "1473816" - :key (compose #'read-from-string #'string) - :end i :from-end t)) - (nil nil #\4 #\4 #\4 #\8 #\8 #\6)) - -(deftest find-if-string.17 - (loop for j from 0 to 6 - collect - (loop for i from (1+ j) to 7 collect - (find-if #'evenp "1473816" - :key (compose #'read-from-string #'string) - :start j :end i))) - ((nil #\4 #\4 #\4 #\4 #\4 #\4) - (#\4 #\4 #\4 #\4 #\4 #\4) - (nil nil #\8 #\8 #\8) - (nil #\8 #\8 #\8) - (#\8 #\8 #\8) - (nil #\6) - (#\6))) - -(deftest find-if-string.18 - (loop for j from 0 to 6 - collect - (loop for i from (1+ j) to 7 collect - (find-if #'evenp "1473816" - :key (compose #'read-from-string #'string) - :start j :end i - :from-end t))) - ((nil #\4 #\4 #\4 #\8 #\8 #\6) - (#\4 #\4 #\4 #\8 #\8 #\6) - (nil nil #\8 #\8 #\6) - (nil #\8 #\8 #\6) - (#\8 #\8 #\6) - (nil #\6) - (#\6))) - -(deftest find-if-string.19 - (let ((a (make-array '(10) :initial-contents "123456789a" - :fill-pointer 5 - :element-type 'character))) - (values - (find-if #'evendigitp a) - (find-if #'evendigitp a :from-end t) - (find-if #'odddigitp a) - (find-if #'odddigitp a :from-end t) - )) - #\2 #\4 #\1 #\5) - -(deftest find-if-string.20 - (do-special-strings - (s "123a456" nil) - (assert (eql (find-if #'alpha-char-p s) #\a))) - nil) - -;;; Keyword tests - -(deftest find-if.allow-other-keys.1 - (find-if #'evenp '(1 2 3 4 5) :bad t :allow-other-keys t) - 2) - -(deftest find-if.allow-other-keys.2 - (find-if #'evenp '(1 2 3 4 5) :allow-other-keys t :also-bad t) - 2) - -;;; The leftmost of two :allow-other-keys arguments is the one that matters. -(deftest find-if.allow-other-keys.3 - (find-if #'evenp '(1 2 3 4 5) - :allow-other-keys t - :allow-other-keys nil - :bad t) - 2) - -(deftest find-if.keywords.4 - (find-if #'evenp '(1 2 3 4 5) :key #'identity :key #'1+) - 2) - -(deftest find-if.allow-other-keys.5 - (find-if #'identity '(nil a b c nil) :allow-other-keys nil) - a) - - -;;; Error tests - -(deftest find-if.error.1 - (check-type-error #'(lambda (x) (find-if #'null x)) #'(lambda (x) (typep x 'sequence))) - nil) - -(deftest find-if.error.4 - (signals-error (find-if 'null '(a b c . d)) type-error) - t) - -(deftest find-if.error.5 - (signals-error (find-if) program-error) - t) - -(deftest find-if.error.6 - (signals-error (find-if #'null) program-error) - t) - -(deftest find-if.error.7 - (signals-error (find-if #'null nil :bad t) program-error) - t) - -(deftest find-if.error.8 - (signals-error (find-if #'null nil :bad t :allow-other-keys nil) - program-error) - t) - -(deftest find-if.error.9 - (signals-error (find-if #'null nil 1 1) program-error) - t) - -(deftest find-if.error.10 - (signals-error (find-if #'null nil :key) program-error) - t) - -(deftest find-if.error.11 - (signals-error (locally (find-if #'null 'b) t) type-error) - t) - -(deftest find-if.error.12 - (signals-error (find-if #'cons '(a b c)) program-error) - t) - -(deftest find-if.error.13 - (signals-error (find-if #'car '(a b c)) type-error) - t) - -(deftest find-if.error.14 - (signals-error (find-if #'identity '(a b c) :key #'cons) program-error) - t) - -(deftest find-if.error.15 - (signals-error (find-if #'identity '(a b c) :key #'car) - type-error) - t) - -;;; Order of evaluation tests - -(deftest find-if.order.1 - (let ((i 0) x y) - (values - (find-if (progn (setf x (incf i)) #'identity) - (progn (setf y (incf i)) '(nil nil nil a nil nil))) - i x y)) - a 2 1 2) - -(deftest find-if.order.2 - (let ((i 0) a b c d e f) - (values - (find-if (progn (setf a (incf i)) #'null) - (progn (setf b (incf i)) '(nil nil nil a nil nil)) - :start (progn (setf c (incf i)) 1) - :end (progn (setf d (incf i)) 4) - :from-end (setf e (incf i)) - :key (progn (setf f (incf i)) #'null) - ) - i a b c d e f)) - a 6 1 2 3 4 5 6) - - -(deftest find-if.order.3 - (let ((i 0) a b c d e f) - (values - (find-if (progn (setf a (incf i)) #'null) - (progn (setf b (incf i)) '(nil nil nil a nil nil)) - :key (progn (setf c (incf i)) #'null) - :from-end (setf d (incf i)) - :end (progn (setf e (incf i)) 4) - :start (progn (setf f (incf i)) 1) - ) - i a b c d e f)) - a 6 1 2 3 4 5 6) diff --git a/t/ansi-test/sequences/find.lsp b/t/ansi-test/sequences/find.lsp deleted file mode 100644 index b3c2da6..0000000 --- a/t/ansi-test/sequences/find.lsp +++ /dev/null @@ -1,958 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Aug 23 07:49:49 2002 -;;;; Contains: Tests for FIND - -(in-package :cl-test) - -(deftest find-list.1 - (find 'c '(a b c d e c a)) - c) - -(deftest find-list.2 - (find 'c '(a b c d e c a) :from-end t) - c) - -(deftest find-list.3 - (loop for i from 0 to 7 collect - (find 'c '(a b c d e c a) :start i)) - (c c c c c c nil nil)) - -(deftest find-list.4 - (loop for i from 0 to 7 collect - (find 'c '(a b c d e c a) :start i :end nil)) - (c c c c c c nil nil)) - -(deftest find-list.5 - (loop for i from 7 downto 0 collect - (find 'c '(a b c d e c a) :end i)) - (c c c c c nil nil nil)) - -(deftest find-list.6 - (loop for i from 0 to 7 collect - (find 'c '(a b c d e c a) :start i :from-end t)) - (c c c c c c nil nil)) - -(deftest find-list.7 - (loop for i from 0 to 7 collect - (find 'c '(a b c d e c a) :start i :end nil :from-end t)) - (c c c c c c nil nil)) - -(deftest find-list.8 - (loop for i from 7 downto 0 collect - (find 'c '(a b c d e c a) :end i :from-end t)) - (c c c c c nil nil nil)) - -(deftest find-list.9 - (loop for i from 0 to 6 collect - (loop for j from (1+ i) to 7 - collect - (find 'c '(a b c d e c a) :start i :end j))) - ((nil nil c c c c c) - (nil c c c c c) - (c c c c c) - (nil nil c c) - (nil c c) - (c c) - (nil))) - -(deftest find-list.10 - (loop for i from 0 to 6 collect - (loop for j from (1+ i) to 7 - collect - (find 'c '(a b c d e c a) :start i :end j :from-end t))) - ((nil nil c c c c c) - (nil c c c c c) - (c c c c c) - (nil nil c c) - (nil c c) - (c c) - (nil))) - -(deftest find-list.11 - (find 5 '(1 2 3 4 5 6 4 8) :key #'1+) - 4) - -(deftest find-list.12 - (find 5 '(1 2 3 4 5 6 4 8) :key '1+) - 4) - -(deftest find-list.13 - (find 5 '(1 2 3 4 5 6 4 8) :key #'1+ :from-end t) - 4) - -(deftest find-list.14 - (find 'a '(a a b a c e d a f a) :test (complement #'eql)) - b) - -(deftest find-list.15 - (find 'a '(a a b a c e d a f a) :test (complement #'eql) - :from-end t) - f) - -(deftest find-list.16 - (find 'a '(a a b a c e d a f a) :test-not #'eql) - b) - -(deftest find-list.17 - (find 'a '(a a b a c e d a f a) :test-not 'eql - :from-end t) - f) - -(deftest find-list.18 - (find 'a '(a a b a c e d a f a) :test-not 'eql) - b) - -(deftest find-list.19 - (find 'a '(a a b a c e d a f a) :test-not #'eql - :from-end t) - f) - -(deftest find-list.20 - (find 'a '(a a b a c e d a f a) :test-not #'eql) - b) - -(deftest find-list.21 - (find 'a '(a a b a c e d a f a) :test #'eql - :start 2) - a) - -(deftest find-list.22 - (find 'a '(a a b a c e d a f a) :test #'eql - :start 2 :end nil) - a) - -(deftest find-list.23 - (find 'a '(a a b a c e d a f a) :test-not #'eql - :start 0 :end 5) - b) - -(deftest find-list.24 - (find 'a '(a a b a c e d a f a) :test-not #'eql - :start 0 :end 5 :from-end t) - c) - -(deftest find-list.25 - (find "ab" '("a" #(#\b #\a) #(#\a #\b #\c) #(#\a #\b) #(#\d #\e) f) :test #'equalp) - #(#\a #\b)) - -(deftest find-list.26 - (find 'a '((c) (b a) (a b c) (a b) (d e) f) :key #'car) - (a b c)) - -(deftest find-list.27 - (find 'a '((c) (b a) (a b c) (z) (a b) (d e) f) :key #'car - :start 3) - (a b)) - -(deftest find-list.28 - (find 'a '((c) (b a) (a b c) (z) (a b) (d e) (f)) :key #'car - :start 2 :from-end t) - (a b)) - -(deftest find-list.29 - (find 10 '(1 2 3 8 20 3 1 21 3) :test #'<) - 20) - -(deftest find-list.30 - (find 10 '(1 2 3 8 20 3 1 21 3) :test-not #'>=) - 20) - -;;; Tests on vectors - -(deftest find-vector.1 - (find 'c #(a b c d e c a)) - c) - -(deftest find-vector.1a - (find 'z #(a b c d e c a)) - nil) - -(deftest find-vector.2 - (find 'c #(a b c d e c a) :from-end t) - c) - -(deftest find-vector.2a - (find 'z #(a b c d e c a) :from-end t) - nil) - -(deftest find-vector.3 - (loop for i from 0 to 7 collect - (find 'c #(a b c d e c a) :start i)) - (c c c c c c nil nil)) - -(deftest find-vector.4 - (loop for i from 0 to 7 collect - (find 'c #(a b c d e c a) :start i :end nil)) - (c c c c c c nil nil)) - -(deftest find-vector.5 - (loop for i from 7 downto 0 collect - (find 'c #(a b c d e c a) :end i)) - (c c c c c nil nil nil)) - -(deftest find-vector.6 - (loop for i from 0 to 7 collect - (find 'c #(a b c d e c a) :start i :from-end t)) - (c c c c c c nil nil)) - -(deftest find-vector.7 - (loop for i from 0 to 7 collect - (find 'c #(a b c d e c a) :start i :end nil :from-end t)) - (c c c c c c nil nil)) - -(deftest find-vector.8 - (loop for i from 7 downto 0 collect - (find 'c #(a b c d e c a) :end i :from-end t)) - (c c c c c nil nil nil)) - -(deftest find-vector.9 - (loop for i from 0 to 6 collect - (loop for j from (1+ i) to 7 - collect - (find 'c #(a b c d e c a) :start i :end j))) - ((nil nil c c c c c) - (nil c c c c c) - (c c c c c) - (nil nil c c) - (nil c c) - (c c) - (nil))) - -(deftest find-vector.10 - (loop for i from 0 to 6 collect - (loop for j from (1+ i) to 7 - collect - (find 'c #(a b c d e c a) :start i :end j :from-end t))) - ((nil nil c c c c c) - (nil c c c c c) - (c c c c c) - (nil nil c c) - (nil c c) - (c c) - (nil))) - -(deftest find-vector.11 - (find 5 #(1 2 3 4 5 6 4 8) :key #'1+) - 4) - -(deftest find-vector.12 - (find 5 #(1 2 3 4 5 6 4 8) :key '1+) - 4) - -(deftest find-vector.13 - (find 5 #(1 2 3 4 5 6 4 8) :key #'1+ :from-end t) - 4) - -(deftest find-vector.14 - (find 'a #(a a b a c e d a f a) :test (complement #'eql)) - b) - -(deftest find-vector.15 - (find 'a #(a a b a c e d a f a) :test (complement #'eql) - :from-end t) - f) - -(deftest find-vector.16 - (find 'a #(a a b a c e d a f a) :test-not #'eql) - b) - -(deftest find-vector.17 - (find 'a #(a a b a c e d a f a) :test-not 'eql - :from-end t) - f) - -(deftest find-vector.18 - (find 'a #(a a b a c e d a f a) :test-not 'eql) - b) - -(deftest find-vector.19 - (find 'a #(a a b a c e d a f a) :test-not #'eql - :from-end t) - f) - -(deftest find-vector.20 - (find 'a #(a a b a c e d a f a) :test-not #'eql) - b) - -(deftest find-vector.21 - (find 'a #(a a b a c e d a f a) :test #'eql - :start 2) - a) - -(deftest find-vector.22 - (find 'a #(a a b a c e d a f a) :test #'eql - :start 2 :end nil) - a) - -(deftest find-vector.23 - (find 'a #(a a b a c e d a f a) :test-not #'eql - :start 0 :end 5) - b) - -(deftest find-vector.24 - (find 'a #(a a b a c e d a f a) :test-not #'eql - :start 0 :end 5 :from-end t) - c) - -(deftest find-vector.25 - (find "ab" #("a" #(#\b #\a) #(#\a #\b #\c) #(#\a #\b) #(#\d #\e) f) :test #'equalp) - #(#\a #\b)) - -(deftest find-vector.26 - (find 'a #((c) (b a) (a b c) (a b) (d e) f) :key #'car) - (a b c)) - -(deftest find-vector.27 - (find 'a #((c) (b a) (a b c) (z) (a b) (d e) f) :key #'car - :start 3) - (a b)) - -(deftest find-vector.28 - (find 'a #((c) (b a) (a b c) (z) (a b) (d e) (f)) :key #'car - :start 2 :from-end t) - (a b)) - -(deftest find-vector.29 - (let ((a (make-array '(10) - :initial-contents '(1 2 3 4 5 6 7 8 9 10) - :fill-pointer 5))) - (loop for i from 1 to 10 collect (find i a))) - (1 2 3 4 5 nil nil nil nil nil)) - -(deftest find-vector.30 - (let ((a (make-array '(10) - :initial-contents (loop for i from 1 for e in '(1 2 3 4 5 5 4 3 2 1) - collect (list e i)) - :fill-pointer 5))) - (loop for i from 1 to 5 collect (find i a :from-end t :key #'car))) - ((1 1) (2 2) (3 3) (4 4) (5 5))) - -(deftest find-vector.31 - (find 10 #(1 2 3 8 20 3 1 21 3) :test #'<) - 20) - -(deftest find-vector.32 - (find 10 #(1 2 3 8 20 3 1 21 3) :test-not #'>=) - 20) - -(deftest find-vector.33 - (do-special-integer-vectors - (v #(1 2 3 4 5 6 7) nil) - (assert (null (find 0 v))) - (assert (= (find 4 v) 4)) - (assert (= (find -1 v :test #'<) 1)) - (assert (= (find -1 v :test #'< :from-end t) 7))) - nil) - -(deftest find-vector.34 - (do-special-integer-vectors - (v #(0 0 0 0) nil) - (assert (eql (find 0 v) 0)) - (assert (eql (find 0 v :start 1) 0)) - (assert (eql (find 0 v :from-end t) 0)) - (assert (null (find 1 v))) - (assert (null (find 'a v))) - (assert (null (find 0.0 v))) - (assert (null (find #c(1.0 0.0) v))) - (assert (null (find -1 v))) - (assert (null (find 2 v)))) - nil) - -;;; tests on bit vectors - -(deftest find-bit-vector.1 - (find 1 #*001001010100) - 1) - -(deftest find-bit-vector.1a - (find 0 #*001001010100) - 0) - -(deftest find-bit-vector.1b - (find 2 #*001001010100) - nil) - -(deftest find-bit-vector.1c - (find 'a #*001001010100) - nil) - -(deftest find-bit-vector.1d - (find 1 #*000000) - nil) - -(deftest find-bit-vector.2 - (find 1 #*001001010100 :from-end t) - 1) - -(deftest find-bit-vector.2a - (find 1 #*00000 :from-end t) - nil) - -(deftest find-bit-vector.2b - (find 0 #*00000 :from-end t) - 0) - -(deftest find-bit-vector.2c - (find 0 #*11111 :from-end t) - nil) - -(deftest find-bit-vector.2d - (find 2 #*11111 :from-end t) - nil) - -(deftest find-bit-vector.2e - (find 'a #*11111 :from-end t) - nil) - -(deftest find-bit-vector.3 - (loop for i from 0 to 7 collect - (find 1 #*0010010 :start i)) - (1 1 1 1 1 1 nil nil)) - -(deftest find-bit-vector.4 - (loop for i from 0 to 7 collect - (find 1 #*0010010 :start i :end nil)) - (1 1 1 1 1 1 nil nil)) - -(deftest find-bit-vector.5 - (loop for i from 7 downto 0 collect - (find 1 #*0010010 :end i)) - (1 1 1 1 1 nil nil nil)) - -(deftest find-bit-vector.6 - (loop for i from 0 to 7 collect - (find 1 #*0010010 :start i :from-end t)) - (1 1 1 1 1 1 nil nil)) - -(deftest find-bit-vector.7 - (loop for i from 0 to 7 collect - (find 0 #*1101101 :start i :end nil :from-end t)) - (0 0 0 0 0 0 nil nil)) - -(deftest find-bit-vector.8 - (loop for i from 7 downto 0 collect - (find 0 #*1101101 :end i :from-end t)) - (0 0 0 0 0 nil nil nil)) - -(deftest find-bit-vector.9 - (loop for i from 0 to 6 collect - (loop for j from (1+ i) to 7 - collect - (find 1 #*0010010 :start i :end j))) - ((nil nil 1 1 1 1 1) - (nil 1 1 1 1 1) - (1 1 1 1 1) - (nil nil 1 1) - (nil 1 1) - (1 1) - (nil))) - -(deftest find-bit-vector.10 - (loop for i from 0 to 6 collect - (loop for j from (1+ i) to 7 - collect - (find 1 #*0010010 :start i :end j :from-end t))) - ((nil nil 1 1 1 1 1) - (nil 1 1 1 1 1) - (1 1 1 1 1) - (nil nil 1 1) - (nil 1 1) - (1 1) - (nil))) - -(deftest find-bit-vector.11 - (find 2 #*00010001010 :key #'1+) - 1) - -(deftest find-bit-vector.12 - (find 2 #*00010001010 :key '1+) - 1) - -(deftest find-bit-vector.13 - (find 2 #*0010001000 :key #'1+ :from-end t) - 1) - -(deftest find-bit-vector.14 - (find 0 #*0010111010 :test (complement #'eql)) - 1) - -(deftest find-bit-vector.15 - (find 0 #*0010111010 :test (complement #'eql) - :from-end t) - 1) - -(deftest find-bit-vector.16 - (find 0 #*0010111010 :test-not #'eql) - 1) - -(deftest find-bit-vector.16a - (find 1 #*111111111111 :test-not #'eql) - nil) - -(deftest find-bit-vector.16b - (find 0 #*0000000 :test-not #'eql) - nil) - -(deftest find-bit-vector.17 - (find 0 #*001011101 :test-not 'eql - :from-end t) - 1) - -(deftest find-bit-vector.17a - (find 0 #*0000000 :test-not 'eql - :from-end t) - nil) - -(deftest find-bit-vector.17b - (find 1 #*111111111111 :test-not 'eql - :from-end t) - nil) - -(deftest find-bit-vector.18 - (find 0 #*00101110 :test-not 'eql) - 1) - -(deftest find-bit-vector.18a - (find 0 #*00000000 :test-not 'eql) - nil) - -(deftest find-bit-vector.19 - (find 0 #*00101110 :test-not #'eql - :from-end t) - 1) - -(deftest find-bit-vector.19a - (find 0 #*00000000 :test-not #'eql - :from-end t) - nil) - -(deftest find-bit-vector.20 - (find 0 #*00101110 :test-not #'eql) - 1) - -(deftest find-bit-vector.21 - (find 0 #*00101110 :test #'eql - :start 2) - 0) - -(deftest find-bit-vector.21a - (find 0 #*00111111 :test #'eql - :start 2) - nil) - -(deftest find-bit-vector.21b - (find 1 #*00111111 :test #'eql - :start 2) - 1) - -(deftest find-bit-vector.22 - (find 0 #*00101110 :test #'eql - :start 2 :end nil) - 0) - -(deftest find-bit-vector.22a - (find 0 #*001111111 :test #'eql - :start 2 :end nil) - nil) - -(deftest find-bit-vector.22b - (find 1 #*001111111 :test #'eql - :start 2 :end nil) - 1) - -(deftest find-bit-vector.23 - (find 0 #*00101110 :test-not #'eql - :start 0 :end 5) - 1) - -(deftest find-bit-vector.23a - (find 0 #*00000111 :test-not #'eql - :start 0 :end 5) - nil) - -(deftest find-bit-vector.23b - (find 0 #*00001000 :test-not #'eql - :start 0 :end 5) - 1) - -(deftest find-bit-vector.24 - (find 0 #*00101110 :test-not #'eql - :start 0 :end 5 :from-end t) - 1) - -(deftest find-bit-vector.24a - (find 0 #*0000001111 :test-not #'eql - :start 0 :end 5 :from-end t) - nil) - -(deftest find-bit-vector.24b - (find 0 #*0000100 :test-not #'eql - :start 0 :end 5 :from-end t) - 1) - -(deftest find-bit-vector.25 - (find 2 #*1100001010 :key #'1+ - :start 3) - 1) - -(deftest find-bit-vector.26 - (find 2 #*11100000 :key #'1+ - :start 3) - nil) - -(deftest find-bit-vector.26a - (find 2 #*11110000 :key #'1+ - :start 3) - 1) - -(deftest find-bit-vector.27 - (find 2 #*1100001010 :key #'1+ - :start 2 :from-end t) - 1) - -(deftest find-bit-vector.28 - (find 2 #*1100000000 :key #'1+ - :start 2 :from-end t) - nil) - -(deftest find-bit-vector.29 - (let ((a - (make-array '(10) :initial-contents '(1 1 1 1 1 0 0 0 0 0) - :element-type 'bit - :fill-pointer 5))) - (values (find 0 a) - (find 0 a :from-end t))) - nil nil) - -(deftest find-bit-vector.30 - (let ((a (make-array '(10) :initial-contents '(1 1 1 1 0 0 0 0 0 0) - :element-type 'bit - :fill-pointer 5))) - (values (find 0 a) (find 0 a :from-end t))) - 0 0) - -(deftest find-bit-vector.31 - (find 2 #*00011010010 :test #'<) - nil) - -(deftest find-bit-vector.32 - (find 2 #*0010101101 :test-not #'>=) - nil) - -(deftest find-bit-vector.33 - (find 0 #*00011010010 :test #'<) - 1) - -(deftest find-bit-vector.34 - (find 0 #*0010101101 :test-not #'>=) - 1) - -;;; strings - -(deftest find-string.1 - (find #\c "abcdeca") - #\c) - -(deftest find-string.1a - (find #\c "abCa") - nil) - -(deftest find-string.2 - (find #\c "abcdeca" :from-end t) - #\c) - -(deftest find-string.2a - (find #\c "abCCCa" :from-end t) - nil) - -(deftest find-string.3 - (loop for i from 0 to 7 collect - (find #\c "abcdeca" :start i)) - (#\c #\c #\c #\c #\c #\c nil nil)) - -(deftest find-string.4 - (loop for i from 0 to 7 collect - (find #\c "abcdeca" :start i :end nil)) - (#\c #\c #\c #\c #\c #\c nil nil)) - -(deftest find-string.5 - (loop for i from 7 downto 0 collect - (find #\c "abcdeca" :end i)) - (#\c #\c #\c #\c #\c nil nil nil)) - -(deftest find-string.6 - (loop for i from 0 to 7 collect - (find #\c "abcdeca" :start i :from-end t)) - (#\c #\c #\c #\c #\c #\c nil nil)) - -(deftest find-string.7 - (loop for i from 0 to 7 collect - (find #\c "abcdeca" :start i :end nil :from-end t)) - (#\c #\c #\c #\c #\c #\c nil nil)) - -(deftest find-string.8 - (loop for i from 7 downto 0 collect - (find #\c "abcdeca" :end i :from-end t)) - (#\c #\c #\c #\c #\c nil nil nil)) - -(deftest find-string.9 - (loop for i from 0 to 6 collect - (loop for j from (1+ i) to 7 - collect - (find #\c "abcdeca" :start i :end j))) - ((nil nil #\c #\c #\c #\c #\c) - (nil #\c #\c #\c #\c #\c) - (#\c #\c #\c #\c #\c) - (nil nil #\c #\c) - (nil #\c #\c) - (#\c #\c) - (nil))) - -(deftest find-string.10 - (loop for i from 0 to 6 collect - (loop for j from (1+ i) to 7 - collect - (find #\c "abcdeca" :start i :end j :from-end t))) - ((nil nil #\c #\c #\c #\c #\c) - (nil #\c #\c #\c #\c #\c) - (#\c #\c #\c #\c #\c) - (nil nil #\c #\c) - (nil #\c #\c) - (#\c #\c) - (nil))) - -(deftest find-string.11 - (find 5 "12345648" :key #'(lambda (c) - (1+ (read-from-string (string c))))) - #\4) - -(deftest find-string.13 - (find 5 "12345648" :key #'(lambda (c) - (1+ (read-from-string (string c)))) - :from-end t) - #\4) - -(deftest find-string.14 - (find #\a "aabacedafa" :test (complement #'eql)) - #\b) - -(deftest find-string.15 - (find #\a "aabacedafa" :test (complement #'eql) - :from-end t) - #\f) - -(deftest find-string.16 - (find #\a "aabacedafa" :test-not #'eql) - #\b) - -(deftest find-string.17 - (find #\a "aabacedafa" :test-not 'eql - :from-end t) - #\f) - -(deftest find-string.18 - (find #\a "aabacedafa" :test-not 'eql) - #\b) - -(deftest find-string.19 - (find #\a "aabacedafa" :test-not #'eql - :from-end t) - #\f) - -(deftest find-string.20 - (find #\a "aabacedafa" :test-not #'eql) - #\b) - -(deftest find-string.21 - (find #\a "aabAcedafa" :test #'char-equal - :start 2) - #\A) - -(deftest find-string.22 - (find #\a "aabAcedafa" :test #'char-equal - :start 2 :end nil) - #\A) - -(deftest find-string.23 - (find #\a "aAbAcedafa" :test-not #'char-equal - :start 0 :end 5) - #\b) - -(deftest find-string.24 - (find #\a "aabacedafa" :test-not #'char-equal - :start 0 :end 5 :from-end t) - #\c) - -(deftest find-string.25 - (let ((s (make-array '(10) :initial-contents "abcdefghij" - :element-type 'character - :fill-pointer 5))) - (values - (loop for e across "abcdefghij" - collect (find e s)) - (loop for e across "abcdefghij" - collect (find e s :from-end t)))) - (#\a #\b #\c #\d #\e nil nil nil nil nil) - (#\a #\b #\c #\d #\e nil nil nil nil nil)) - -(deftest find-string.26 - (find #\k "abcdmnop" :test #'char<) - #\m) - -(deftest find-string.27 - (find #\k "abcdmnop" :test-not #'char>=) - #\m) - -(deftest find-string.28 - (do-special-strings - (s "abcdef" nil) - (assert (char= (find #\c s :test #'char<) #\d))) - nil) - -;;; Test & test not - -(defharmless find-list.test-and-test-not.1 - (find 'b '(a b c) :test #'eql :test-not #'eql)) - -(defharmless find-list.test-and-test-not.2 - (find 'b '(a b c) :test-not #'eql :test #'eql)) - -(defharmless find-vector.test-and-test-not.1 - (find 'b #(a b c) :test #'eql :test-not #'eql)) - -(defharmless find-vector.test-and-test-not.2 - (find 'b #(a b c) :test-not #'eql :test #'eql)) - -(defharmless find-string.test-and-test-not.1 - (find #\b "abc" :test #'eql :test-not #'eql)) - -(defharmless find-string.test-and-test-not.2 - (find #\b "abc" :test-not #'eql :test #'eql)) - -(defharmless find-bit-string.test-and-test-not.1 - (find 0 #*110110 :test #'eql :test-not #'eql)) - -(defharmless find-bit-string.test-and-test-not.2 - (find 0 #*110110 :test-not #'eql :test #'eql)) - -;;; Keyword tests - -(deftest find.allow-other-keys.1 - (find 0 '(1 2 3 4 5) :key #'(lambda (x) (mod x 2)) - :bad t :allow-other-keys t) - 2) - -(deftest find.allow-other-keys.2 - (find 0 '(1 2 3 4 5) :key #'(lambda (x) (mod x 2)) - :allow-other-keys t :also-bad t) - 2) - -;;; The leftmost of two :allow-other-keys arguments is the one that matters. -(deftest find.allow-other-keys.3 - (find 0 '(1 2 3 4 5) :key #'(lambda (x) (mod x 2)) - :allow-other-keys t - :allow-other-keys nil - :bad t) - 2) - -(deftest find.keywords.4 - (find 2 '(1 2 3 4 5) :key #'identity :key #'1+) - 2) - -(deftest find.allow-other-keys.5 - (find 'b '(nil a b c nil) :allow-other-keys nil) - b) - - -;;; Error tests - -(deftest find.error.1 - (check-type-error #'(lambda (x) (find 'a x)) #'(lambda (x) (typep x 'sequence))) - nil) - -(deftest find.error.4 - (signals-error (find 'e '(a b c . d)) type-error) - t) - -(deftest find.error.5 - (signals-error (find) program-error) - t) - -(deftest find.error.6 - (signals-error (find 'a) program-error) - t) - -(deftest find.error.7 - (signals-error (find 'a nil :bad t) program-error) - t) - -(deftest find.error.8 - (signals-error (find 'a nil :bad t :allow-other-keys nil) - program-error) - t) - -(deftest find.error.9 - (signals-error (find 'a nil 1 1) program-error) - t) - -(deftest find.error.10 - (signals-error (find 'a nil :key) program-error) - t) - -(deftest find.error.11 - (signals-error (locally (find 'a 'b) t) type-error) - t) - -(deftest find.error.12 - (signals-error (find 'b '(a b c) :test #'identity) program-error) - t) - -(deftest find.error.13 - (signals-error (find 'b '(a b c) :test-not #'identity) program-error) - t) - -(deftest find.error.14 - (signals-error (find 'c '(a b c) :key #'cons) program-error) - t) - -(deftest find.error.15 - (signals-error (find 'c '(a b c) :key #'car) type-error) - t) - - -;;; Order of evaluation tests - -(deftest find.order.1 - (let ((i 0) x y) - (values - (find (progn (setf x (incf i)) 'a) - (progn (setf y (incf i)) '(nil nil nil a nil nil))) - i x y)) - a 2 1 2) - -(deftest find.order.2 - (let ((i 0) a b c d e f) - (values - (find (progn (setf a (incf i)) nil) - (progn (setf b (incf i)) '(nil nil nil a nil nil)) - :start (progn (setf c (incf i)) 1) - :end (progn (setf d (incf i)) 4) - :from-end (setf e (incf i)) - :key (progn (setf f (incf i)) #'null) - ) - i a b c d e f)) - a 6 1 2 3 4 5 6) - -(deftest find.order.3 - (let ((i 0) a b c d e f) - (values - (find (progn (setf a (incf i)) nil) - (progn (setf b (incf i)) '(nil nil nil a nil nil)) - :key (progn (setf c (incf i)) #'null) - :from-end (setf d (incf i)) - :end (progn (setf e (incf i)) 4) - :start (progn (setf f (incf i)) 1) - ) - i a b c d e f)) - a 6 1 2 3 4 5 6) diff --git a/t/ansi-test/sequences/length.lsp b/t/ansi-test/sequences/length.lsp deleted file mode 100644 index 3ce5a9c..0000000 Binary files a/t/ansi-test/sequences/length.lsp and /dev/null differ diff --git a/t/ansi-test/sequences/load.lsp b/t/ansi-test/sequences/load.lsp deleted file mode 100644 index ea22f23..0000000 --- a/t/ansi-test/sequences/load.lsp +++ /dev/null @@ -1,51 +0,0 @@ -;;; Tests of sequences -(compile-and-load "ANSI-TESTS:AUX;search-aux.lsp") -(compile-and-load "ANSI-TESTS:AUX;subseq-aux.lsp") -(compile-and-load "ANSI-TESTS:AUX;remove-aux.lsp") -(compile-and-load "ANSI-TESTS:AUX;remove-duplicates-aux.lsp") - -(in-package #:cl-test) - -(let ((*default-pathname-defaults* - (make-pathname - :directory (pathname-directory *load-pathname*)))) - (load "copy-seq.lsp") - (load "elt.lsp") - (load "fill.lsp") - (load "fill-strings.lsp") - (load "make-sequence.lsp") - (load "map.lsp") - (load "map-into.lsp") - (load "reduce.lsp") - (load "count.lsp") - (load "count-if.lsp") - (load "count-if-not.lsp") - (load "reverse.lsp") - (load "nreverse.lsp") - (load "sort.lsp") - (load "stable-sort.lsp") - (load "length.lsp") - (load "find.lsp") - (load "find-if.lsp") - (load "find-if-not.lsp") - (load "position.lsp") - (load "position-if.lsp") - (load "position-if-not.lsp") - (load "search-list.lsp") - (load "search-vector.lsp") - (load "search-bitvector.lsp") - (load "search-string.lsp") - (load "mismatch.lsp") - (load "replace.lsp") - (load "subseq.lsp") - (load "substitute.lsp") - (load "substitute-if.lsp") - (load "substitute-if-not.lsp") - (load "nsubstitute.lsp") - (load "nsubstitute-if.lsp") - (load "nsubstitute-if-not.lsp") - (load "concatenate.lsp") - (load "merge.lsp") - (load "remove.lsp") ;; also related funs - (load "remove-duplicates.lsp") ;; also delete-duplicates -) diff --git a/t/ansi-test/sequences/make-sequence.lsp b/t/ansi-test/sequences/make-sequence.lsp deleted file mode 100644 index 0b59e6e..0000000 --- a/t/ansi-test/sequences/make-sequence.lsp +++ /dev/null @@ -1,516 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Sep 14 09:58:47 2002 -;;;; Contains: Tests for MAKE-SEQUENCE - -(in-package :cl-test) - -(deftest make-sequence.1 - (let ((x (make-sequence 'list 4))) - (and (eql (length x) 4) - (listp x) - #+:ansi-tests-strict-initial-element - (loop for e in x always (eql (car x) e)) - t)) - t) - -(deftest make-sequence.2 - (make-sequence 'list 4 :initial-element 'a) - (a a a a)) - -(deftest make-sequence.3 - (let ((x (make-sequence 'cons 4))) - (and (eql (length x) 4) - (listp x) - #+:ansi-tests-strict-initial-element - (loop for e in x always (eql (car x) e)) - t)) - t) - -(deftest make-sequence.4 - (make-sequence 'cons 4 :initial-element 'a) - (a a a a)) - -(deftest make-sequence.5 - (make-sequence 'string 10 :initial-element #\a) - "aaaaaaaaaa") - -(deftest make-sequence.6 - (let ((s (make-sequence 'string 10))) - (and (eql (length s) 10) - #+:ansi-tests-strict-initial-element - (loop for e across s always (eql e (aref s 0))) - t)) - t) - -(deftest make-sequence.7 - (make-sequence 'simple-string 10 :initial-element #\a) - "aaaaaaaaaa") - - -(deftest make-sequence.8 - (let ((s (make-sequence 'simple-string 10))) - (and (eql (length s) 10) - #+:ansi-tests-strict-initial-element - (loop for e across s always (eql e (aref s 0))) - t)) - t) - -(deftest make-sequence.9 - (make-sequence 'null 0) - nil) - -(deftest make-sequence.10 - (let ((x (make-sequence 'vector 10))) - (and (eql (length x) 10) - #+:ansi-tests-strict-initial-element - (loop for e across x always (eql e (aref x 0))) - t)) - t) - -(deftest make-sequence.11 - (let* ((u (list 'a)) - (x (make-sequence 'vector 10 :initial-element u))) - (and (eql (length x) 10) - (loop for e across x always (eql e u)) - t)) - t) - -(deftest make-sequence.12 - (let ((x (make-sequence 'simple-vector 10))) - (and (eql (length x) 10) - #+:ansi-tests-strict-initial-element - (loop for e across x always (eql e (aref x 0))) - t)) - t) - -(deftest make-sequence.13 - (let* ((u (list 'a)) - (x (make-sequence 'simple-vector 10 :initial-element u))) - (and (eql (length x) 10) - (loop for e across x always (eql e u)) - t)) - t) - -(deftest make-sequence.14 - (let ((x (make-sequence '(vector *) 10))) - (and (eql (length x) 10) - #+:ansi-tests-strict-initial-element - (loop for e across x always (eql e (aref x 0))) - t)) - t) - -(deftest make-sequence.15 - (let* ((u (list 'a)) - (x (make-sequence '(vector *) 10 :initial-element u))) - (and (eql (length x) 10) - (loop for e across x always (eql e u)) - t)) - t) - -(deftest make-sequence.16 - (let ((x (make-sequence '(simple-vector *) 10))) - (and (eql (length x) 10) - #+:ansi-tests-strict-initial-element - (loop for e across x always (eql e (aref x 0))) - t)) - t) - -(deftest make-sequence.17 - (let* ((u (list 'a)) - (x (make-sequence '(simple-vector *) 10 :initial-element u))) - (and (eql (length x) 10) - (loop for e across x always (eql e u)) - t)) - t) - -(deftest make-sequence.18 - (let ((x (make-sequence '(string *) 10))) - (and (eql (length x) 10) - #+:ansi-tests-strict-initial-element - (loop for e across x always (eql e (aref x 0))) - t)) - t) - -(deftest make-sequence.19 - (let* ((u #\a) - (x (make-sequence '(string *) 10 :initial-element u))) - (and (eql (length x) 10) - (loop for e across x always (eql e u)) - t)) - t) - -(deftest make-sequence.20 - (let ((x (make-sequence '(simple-string *) 10))) - (and (eql (length x) 10) - #+:ansi-tests-strict-initial-element - (loop for e across x always (eql e (aref x 0))) - t)) - t) - -(deftest make-sequence.21 - (let* ((u #\a) - (x (make-sequence '(simple-string *) 10 :initial-element u))) - (and (eql (length x) 10) - (loop for e across x always (eql e u)) - t)) - t) - -(deftest make-sequence.22 - (make-sequence '(vector * 5) 5 :initial-element 'a) - #(a a a a a)) - -(deftest make-sequence.23 - (make-sequence '(vector fixnum 5) 5 :initial-element 1) - #(1 1 1 1 1)) - -(deftest make-sequence.24 - (make-sequence '(vector (integer 0 255) 5) 5 :initial-element 17) - #(17 17 17 17 17)) - -(deftest make-sequence.25 - (make-sequence '(simple-vector 5) 5 :initial-element 'a) - #(a a a a a)) - -#+:ansi-tests-strict-initial-element -(deftest make-sequence.26 - (equalp (make-sequence 'string 5) (make-string 5)) - t) - -(deftest make-sequence.27 - (let ((len 10)) - (loop for i from 1 to 40 - for etype = `(unsigned-byte ,i) - for type = `(vector ,etype) - for vec = (make-sequence type len :initial-element 0) - unless (and (typep vec type) - (loop for i below len always (eql (elt vec i) 0))) - collect (list i etype type vec))) - nil) - -(deftest make-sequence.28 - (let ((len 10)) - (loop for i from 1 to 40 - for etype = `(signed-byte ,i) - for type = `(vector ,etype) - for vec = (make-sequence type len :initial-element 0) - unless (and (typep vec type) - (loop for i below len always (eql (elt vec i) 0))) - collect (list i etype type vec))) - nil) - -(deftest make-sequence.29 - (let ((len 10)) - (loop for etype in '(short-float single-float double-float long-float) - for type = `(vector ,etype) - for elem = (coerce 1 etype) - for vec = (make-sequence type len :initial-element elem) - unless (and (typep vec type) - (loop for i below len always (eql (elt vec i) elem))) - collect (list etype type vec))) - nil) - -(deftest make-sequence.30 - (let ((len 10)) - (loop for cetype in '(short-float single-float double-float long-float - integer rational) - for etype = `(complex ,cetype) - for type = `(vector ,etype) - for elem = (complex (coerce 1 cetype) (coerce -1 cetype)) - for vec = (make-sequence type len :initial-element elem) - unless (and (typep vec type) - (loop for i below len always (eql (elt vec i) elem))) - collect (list etype type vec))) - nil) - -;;; Other type specifiers - -(deftest make-sequence.31 - (make-sequence '(simple-string) 10 :initial-element #\X) - "XXXXXXXXXX") - -(deftest make-sequence.32 - (make-sequence '(simple-string 10) 10 :initial-element #\X) - "XXXXXXXXXX") - -(deftest make-sequence.33 - (make-sequence '(string) 10 :initial-element #\X) - "XXXXXXXXXX") - -(deftest make-sequence.34 - (make-sequence '(vector) 10 :initial-element nil) - #(nil nil nil nil nil nil nil nil nil nil)) - -(deftest make-sequence.35 - (make-sequence '(simple-vector) 10 :initial-element nil) - #(nil nil nil nil nil nil nil nil nil nil)) - -(deftest make-sequence.36 - (make-sequence '(vector * *) 10 :initial-element nil) - #(nil nil nil nil nil nil nil nil nil nil)) - -;;; Bit vectors - -(deftest make-sequence.37 - (make-sequence 'bit-vector 5 :initial-element 0) - #*00000) - -(deftest make-sequence.38 - (make-sequence 'bit-vector 7 :initial-element 1) - #*1111111) - -(deftest make-sequence.39 - (make-sequence 'bit-vector 0) - #*) - -(deftest make-sequence.40 - (make-sequence '(bit-vector) 4 :initial-element 1) - #*1111) - -(deftest make-sequence.41 - (make-sequence '(bit-vector *) 10 :initial-element 0) - #*0000000000) - -(deftest make-sequence.42 - (make-sequence '(bit-vector 5) 5 :initial-element 0) - #*00000) - -(deftest make-sequence.43 - (make-sequence 'simple-bit-vector 5 :initial-element 0) - #*00000) - -(deftest make-sequence.44 - (make-sequence 'simple-bit-vector 7 :initial-element 1) - #*1111111) - -(deftest make-sequence.45 - (make-sequence 'simple-bit-vector 0) - #*) - -(deftest make-sequence.46 - (make-sequence '(simple-bit-vector) 4 :initial-element 1) - #*1111) - -(deftest make-sequence.47 - (make-sequence '(simple-bit-vector *) 10 :initial-element 0) - #*0000000000) - -(deftest make-sequence.48 - (make-sequence '(simple-bit-vector 5) 5 :initial-element 0) - #*00000) - -(deftest make-sequence.49 - (if (subtypep (class-of nil) 'sequence) - (make-sequence (class-of nil) 0) - nil) - nil) - -(deftest make-sequence.50 - (if (subtypep (class-of '(nil nil nil)) 'sequence) - (make-sequence (class-of '(nil nil nil)) 3 :initial-element nil) - '(nil nil nil)) - (nil nil nil)) - -(deftest make-sequence.51 - (loop for i from 1 to 40 - for vec = (make-array 1 :element-type `(unsigned-byte ,i) - :initial-element 1) - for class = (class-of vec) - nconc - (if (subtypep class 'vector) - (let ((vec2 (make-sequence class 1 :initial-element 1))) - (unless (equalp vec vec) - (list (list i vec class vec2)))) - nil)) - nil) - -(deftest make-sequence.52 - (let ((class (class-of "aaaa"))) - (if (subtypep class 'vector) - (make-sequence class 4 :initial-element #\a) - "aaaa")) - "aaaa") - -(deftest make-sequence.53 - (let ((class (class-of (make-array 4 :element-type 'base-char - :fill-pointer 4 - :adjustable t - :initial-contents "aaaa")))) - (if (subtypep class 'vector) - (make-sequence class 4 :initial-element #\a) - "aaaa")) - "aaaa") - -(deftest make-sequence.54 - (let ((class (class-of (make-array 4 :element-type 'character - :fill-pointer 4 - :adjustable t - :initial-contents "aaaa")))) - (if (subtypep class 'vector) - (make-sequence class 4 :initial-element #\a) - "aaaa")) - "aaaa") - -(deftest make-sequence.55 - (let ((class (class-of (make-array 4 :element-type 'character - :initial-contents "aaaa")))) - (if (subtypep class 'vector) - (make-sequence class 4 :initial-element #\a) - "aaaa")) - "aaaa") - -(deftest make-sequence.56 - (loop for i from 1 to 40 - for vec = (make-array 1 :element-type `(unsigned-byte ,i) - :adjustable t :fill-pointer 1 - :initial-element 1) - for class = (class-of vec) - nconc - (if (subtypep class 'vector) - (let ((vec2 (make-sequence class 1 :initial-element 1))) - (unless (equalp vec vec) - (list (list i vec class vec2)))) - nil)) - nil) - -(deftest make-sequence.57 - (make-sequence (find-class 'list) 4 :initial-element 'x) - (x x x x)) - -(deftest make-sequence.58 - (make-sequence (find-class 'cons) 4 :initial-element 'x) - (x x x x)) - -;;; Keyword tests - -(deftest make-sequence.allow-other-keys.1 - (make-sequence 'list 5 :allow-other-keys t :initial-element 'a :bad t) - (a a a a a)) - -(deftest make-sequence.allow-other-keys.2 - (make-sequence 'list 5 :initial-element 'a :bad t :allow-other-keys t) - (a a a a a)) - -(deftest make-sequence.allow-other-keys.3 - (make-sequence 'list 5 :initial-element 'a :allow-other-keys t) - (a a a a a)) - -(deftest make-sequence.allow-other-keys.4 - (make-sequence 'list 5 :initial-element 'a :allow-other-keys nil) - (a a a a a)) - -(deftest make-sequence.allow-other-keys.5 - (make-sequence 'list 5 :initial-element 'a :allow-other-keys t - :allow-other-keys nil :bad t) - (a a a a a)) - -(deftest make-sequence.keywords.6 - (make-sequence 'list 5 :initial-element 'a :initial-element 'b) - (a a a a a)) - -;;; Tests for errors - -(deftest make-sequence.error.1 - (signals-error-always (make-sequence 'symbol 10) type-error) - t t) - -(deftest make-sequence.error.2 - (signals-error (make-sequence 'null 1) type-error) - t) - -(deftest make-sequence.error.3 - (signals-error (make-sequence '(vector * 4) 3) type-error) - t) - -(deftest make-sequence.error.4 - (signals-error (make-sequence '(vector * 2) 3) type-error) - t) - -(deftest make-sequence.error.5 - (signals-error (make-sequence '(string 4) 3) type-error) - t) - -(deftest make-sequence.error.6 - (signals-error (make-sequence '(simple-string 2) 3) type-error) - t) - -(deftest make-sequence.error.7 - (signals-error (make-sequence 'cons 0) type-error) - t) - -(deftest make-sequence.error.8 - (signals-error (make-sequence) program-error) - t) - -(deftest make-sequence.error.9 - (signals-error (make-sequence 'list) program-error) - t) - -(deftest make-sequence.error.10 - (signals-error (make-sequence 'list 10 :bad t) program-error) - t) - -(deftest make-sequence.error.11 - (signals-error (make-sequence 'list 10 :bad t :allow-other-keys nil) - program-error) - t) - -(deftest make-sequence.error.12 - (signals-error (make-sequence 'list 10 :initial-element) - program-error) - t) - -(deftest make-sequence.error.13 - (signals-error (make-sequence 'list 10 0 0) program-error) - t) - -(deftest make-sequence.error.14 - (signals-error-always (locally (make-sequence 'symbol 10) t) - type-error) - t t) - -(deftest make-sequence.error.15 - :notes (:result-type-element-type-by-subtype) - (if (subtypep '(or (vector bit) (vector t)) 'vector) - (signals-error (make-sequence '(or (vector bit) (vector t)) 10 :initial-element 0) error) - t) - t) - -(deftest make-sequence.error.16 - (signals-error-always (make-sequence (find-class 'integer) 0) type-error) - t t) - -;;; Order of execution tests - -(deftest make-sequence.order.1 - (let ((i 0) a b c) - (values - (make-sequence (progn (setf a (incf i)) 'list) - (progn (setf b (incf i)) 5) - :initial-element (progn (setf c (incf i)) 'a)) - i a b c)) - (a a a a a) 3 1 2 3) - -(deftest make-sequence.order.2 - (let ((i 0) a b c d e) - (values - (make-sequence (progn (setf a (incf i)) 'list) - (progn (setf b (incf i)) 5) - :allow-other-keys (setf c (incf i)) - :initial-element (progn (setf d (incf i)) 'a) - :foo (setf e (incf i))) - i a b c d e)) - (a a a a a) 5 1 2 3 4 5) - -;;; Const fold tests - -(def-fold-test make-sequence.fold.1 - (make-sequence 'list 5 :initial-element 'a)) -(def-fold-test make-sequence.fold.2 - (make-sequence 'vector 5 :initial-element 'a)) -(def-fold-test make-sequence.fold.3 - (make-sequence 'bit-vector 5 :initial-element 0)) -(def-fold-test make-sequence.fold.4 - (make-sequence 'string 5 :initial-element #\a)) - -;;; FIXME: Add tests for upgrading of character subtypes diff --git a/t/ansi-test/sequences/map-into.lsp b/t/ansi-test/sequences/map-into.lsp deleted file mode 100644 index 5df0ec2..0000000 --- a/t/ansi-test/sequences/map-into.lsp +++ /dev/null @@ -1,516 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Aug 18 10:10:04 2002 -;;;; Contains: Tests for the MAP-INTO function - -(in-package :cl-test) - -(deftest map-into-list.1 - (let ((a (copy-seq '(a b c d e f))) - (b nil)) - (map-into a #'(lambda (x) (push x b) x) '(1 2 3 4 5 6)) - (values a b)) - (1 2 3 4 5 6) - (6 5 4 3 2 1)) - -(deftest map-into-list.2 - (let ((a (copy-seq '(a b c d e f g)))) - (map-into a #'identity '(1 2 3)) - a) - (1 2 3 d e f g)) - -(deftest map-into-list.3 - (let ((a (copy-seq '(a b c)))) - (map-into a #'identity '(1 2 3 4 5 6)) - a) - (1 2 3)) - -(deftest map-into-list.4 - (let ((a (copy-seq '(a b c d e f))) - (b nil)) - (map-into a #'(lambda (x y) (let ((z (+ x y))) (push z b) z)) - '(1 2 3 4 5 6) - '(10 11 12 13 14 15)) - (values a b)) - (11 13 15 17 19 21) - (21 19 17 15 13 11)) - -(deftest map-into-list.5 - (let ((a (copy-seq '(a b c d e f)))) - (map-into a 'identity '(1 2 3 4 5 6)) - a) - (1 2 3 4 5 6)) - -(deftest map-into-list.6 - (let ((b nil)) - (values - (map-into nil #'(lambda (x y) (let ((z (+ x y))) (push z b) z)) - '(1 2 3 4 5 6) - '(10 11 12 13 14 15)) - b)) - nil nil) - -(deftest map-into-list.7 - (let ((a (copy-seq '(a b c d e f)))) - (map-into a #'(lambda () 1)) - a) - (1 1 1 1 1 1)) - -(deftest map-into-list.8 - (let ((a (copy-seq '(a b c d e f))) - (s2 (make-array '(6) :initial-element 'x - :fill-pointer 4))) - (map-into a #'identity s2) - a) - (x x x x e f)) - -(deftest map-into-array.1 - (let ((a (copy-seq #(a b c d e f))) - b) - (map-into a #'(lambda (x) (push x b) x) '(1 2 3 4 5 6)) - (values a b)) - #(1 2 3 4 5 6) - (6 5 4 3 2 1)) - -(deftest map-into-array.2 - (let ((a (copy-seq #(a b c d e f g h))) - b) - (map-into a #'(lambda (x) (push x b) x) '(1 2 3 4 5 6)) - (values a b)) - #(1 2 3 4 5 6 g h) - (6 5 4 3 2 1)) - -(deftest map-into-array.3 - (let ((a (copy-seq #(a b c d))) - b) - (map-into a #'(lambda (x) (push x b) x) '(1 2 3 4 5 6)) - (values a b)) - #(1 2 3 4) - (4 3 2 1)) - -(deftest map-into-array.4 - (let ((a (copy-seq #(a b c d e f))) - b) - (map-into a #'(lambda (x) (push x b) x) #(1 2 3 4 5 6)) - (values a b)) - #(1 2 3 4 5 6) - (6 5 4 3 2 1)) - -(deftest map-into-array.5 - (let ((a (copy-seq #(a b c d e f g h))) - b) - (map-into a #'(lambda (x) (push x b) x) #(1 2 3 4 5 6)) - (values a b)) - #(1 2 3 4 5 6 g h) - (6 5 4 3 2 1)) - -(deftest map-into-array.6 - (let ((a (copy-seq #(a b c d))) - b) - (map-into a #'(lambda (x) (push x b) x) #(1 2 3 4 5 6)) - (values a b)) - #(1 2 3 4) - (4 3 2 1)) - -;;; Tests of mapping into arrays with fill pointers -(deftest map-into-array.7 - (let ((a (make-array 6 :initial-element 'x - :fill-pointer 3))) - (map-into a #'identity '(1 2 3)) - a) - #(1 2 3)) - -(deftest map-into-array.8 - (let ((a (make-array 6 :initial-element 'x - :fill-pointer 3))) - (map-into a #'identity '(1 2)) - a) - #(1 2)) - -(deftest map-into-array.9 - (let ((a (make-array 6 :initial-element 'x - :fill-pointer 3))) - (map-into a #'identity '(1 2 3 4 5)) - (and (eqlt (fill-pointer a) 5) - a)) - #(1 2 3 4 5)) - -(deftest map-into-array.10 - (let ((a (make-array 6 :initial-element 'x - :fill-pointer 3))) - (map-into a #'(lambda () 'y)) - (and (eqlt (fill-pointer a) 6) - a)) - #(y y y y y y)) - -(deftest map-into-array.11 - (let ((a (copy-seq #(a b c d e f))) - (s2 (make-array '(6) :initial-element 'x - :fill-pointer 4))) - (map-into a #'identity s2) - a) - #(x x x x e f)) - -;;; mapping into strings - -(deftest map-into-string.1 - (let ((a (copy-seq "abcdef"))) - (map-into a #'identity "123456") - (values (not (not (stringp a))) a)) - t - "123456") - -(deftest map-into-string.2 - (let ((a (copy-seq "abcdef"))) - (map-into a #'identity "1234") - (values (not (not (stringp a))) a)) - t - "1234ef") - -(deftest map-into-string.3 - (let ((a (copy-seq "abcd"))) - (map-into a #'identity "123456") - (values (not (not (stringp a))) a)) - t - "1234") - -(deftest map-into-string.4 - (let ((a (make-array 6 :initial-element #\x - :element-type 'character - :fill-pointer 3))) - (map-into a #'identity "abcde") - (values - (fill-pointer a) - (aref a 5) - a)) - 5 - #\x - "abcde") - -(deftest map-into-string.5 - (let ((a (make-array 6 :initial-element #\x - :element-type 'character - :fill-pointer 3))) - (map-into a #'(lambda () #\y)) - (values (fill-pointer a) - a)) - 6 - "yyyyyy") - -(deftest map-into-string.6 - (let ((a (make-array 6 :initial-element #\x - :element-type 'character))) - (map-into a #'(lambda () #\y)) - a) - "yyyyyy") - -(deftest map-into-string.7 - (let ((a (make-array 6 :initial-element #\x - :element-type 'base-char - :fill-pointer 3))) - (map-into a #'identity "abcde") - (values (fill-pointer a) - (aref a 5) - a)) - 5 - #\x - "abcde") - -(deftest map-into-string.8 - (let ((a (make-array 6 :initial-element #\x - :element-type 'base-char - :fill-pointer 3))) - (map-into a #'(lambda () #\y)) - (values (fill-pointer a) - a)) - 6 - "yyyyyy") - -(deftest map-into-string.9 - (let ((a (make-array 6 :initial-element #\x - :element-type 'base-char))) - (map-into a #'(lambda () #\y)) - a) - "yyyyyy") - -(deftest map-into-string.10 - (let ((a (copy-seq "abcdef")) - (s2 (make-array '(6) :initial-element #\x - :fill-pointer 4))) - (map-into a #'identity s2) - a) - "xxxxef") - -(deftest map-into-string.11 - (let ((a (make-array 6 :initial-element #\x - :element-type 'character - :fill-pointer 3))) - (map-into a #'identity "abcd") - (values - (fill-pointer a) - (aref a 4) - (aref a 5) - a)) - 4 - #\x - #\x - "abcd") - -(deftest map-into-string.12 - (let ((a (make-array 6 :initial-element #\x - :element-type 'character - :fill-pointer 3))) - (map-into a #'identity "abcdefgh") - (values - (fill-pointer a) - a)) - 6 - "abcdef") - -(deftest map-into-string.13 - (do-special-strings - (s (copy-seq "12345") nil) - (let ((s2 (map-into s #'identity "abcde"))) - (assert (eq s s2)) - (assert (string= s2 "abcde")))) - nil) - -(deftest map-into-string.14 - (do-special-strings - (s "abcde" nil) - (let* ((s1 (copy-seq "123456")) - (s2 (map-into s1 #'identity s))) - (assert (eq s1 s2)) - (assert (string= s2 "abcde6")))) - nil) - -;;; Tests on bit vectors - -(deftest map-into.bit-vector.1 - (let ((v (copy-seq #*0100110))) - (map-into v #'(lambda (x) (- 1 x)) v) - (and (bit-vector-p v) - v)) - #*1011001) - -(deftest map-into.bit-vector.2 - (let ((v (copy-seq #*0100110))) - (map-into v #'(lambda () 0)) - (and (bit-vector-p v) - v)) - #*0000000) - -(deftest map-into.bit-vector.3 - (let ((v (copy-seq #*0100110))) - (map-into v #'identity '(0 1 1 1 0 0 1)) - (and (bit-vector-p v) - v)) - #*0111001) - -(deftest map-into.bit-vector.4 - (let ((v (copy-seq #*0100110))) - (map-into v #'identity '(0 1 1 1)) - (and (bit-vector-p v) - v)) - #*0111110) - -(deftest map-into.bit-vector.5 - (let ((v (copy-seq #*0100110))) - (map-into v #'identity '(0 1 1 1 0 0 1 4 5 6 7)) - (and (bit-vector-p v) - v)) - #*0111001) - -(deftest map-into.bit-vector.6 - (let ((v (make-array '(8) :initial-contents '(0 1 0 0 1 1 0 1) - :fill-pointer 4 - :element-type 'bit))) - (map-into v #'(lambda () 1)) - (and (bit-vector-p v) - v)) - #*11111111) - -(deftest map-into.bit-vector.7 - (let ((v (make-array '(8) :initial-contents '(0 1 0 0 1 1 0 1) - :fill-pointer 4 - :element-type 'bit))) - (map-into v #'identity v) - (and (bit-vector-p v) - v)) - #*0100) - -(deftest map-into.bit-vector.8 - (let ((v (make-array '(8) :initial-contents '(0 1 0 0 1 1 0 1) - :fill-pointer 4 - :element-type 'bit))) - (map-into v #'identity '(1 1 1 1 1 1)) - (and (bit-vector-p v) - (values (fill-pointer v) - v))) - 6 - #*111111) - -(deftest map-into.bit-vector.9 - (let ((v (make-array '(8) :initial-contents '(0 1 0 0 1 1 0 1) - :fill-pointer 4 - :element-type 'bit))) - (map-into v #'identity '(1 1 1 1 1 1 0 0 1 1 1)) - (and (bit-vector-p v) - (values (fill-pointer v) - v))) - 8 - #*11111100) - -;;; Other specialized vectors - -(deftest map-into.specialized-vector.1 - (do-special-integer-vectors - (v #(1 2 3 4) nil) - (let ((result (list nil nil nil nil))) - (assert (eq (map-into result #'identity v) result)) - (assert (equal result '(1 2 3 4))))) - nil) - -(deftest map-into.specialized-vector.2 - (do-special-integer-vectors - (v #(1 2 3) nil) - (let ((result (list nil nil nil nil))) - (assert (eq (map-into result #'identity v) result)) - (assert (equal result '(1 2 3 nil))))) - nil) - -(deftest map-into.specialized-vector.3 - (do-special-integer-vectors - (v #(1 1 0 1 1) nil) - (let ((result (list nil nil nil nil))) - (assert (eq (map-into result #'identity v) result)) - (assert (equal result '(1 1 0 1))))) - nil) - -(deftest map-into.specialized-vector.4 - (do-special-integer-vectors - (v #(1 2 1 2 2) nil) - (let ((v2 #(2 1 2 2 1))) - (assert (eq (map-into v #'identity v2) v)) - (assert (equalp v #(2 1 2 2 1))))) - nil) - -(deftest map-into.specialized-vector.5 - (let ((len 10)) - (loop for etype in '(short-float single-float double-float long-float) - for vals = (loop for i below len collect (coerce i etype)) - for vec = (make-array len :initial-contents vals :element-type etype) - for target = (loop repeat len collect nil) - for result = (map-into target #'identity vec) - unless (and (eq target result) - (= (length result) len) - (= (length vec) len) - (equal vals result)) - collect (list etype vals vec result))) - nil) - -(deftest map-into.specialized-vector.6 - (let ((len 10)) - (loop for cetype in '(short-float single-float double-float long-float) - for etype = `(complex ,cetype) - for vals = (loop for i from 1 to len collect (complex (coerce i cetype) - (coerce (- i) cetype))) - for vec = (make-array len :initial-contents vals :element-type etype) - for target = (loop repeat len collect nil) - for result = (map-into target #'identity vec) - unless (and (eq target result) - (= (length result) len) - (= (length vec) len) - (equal vals result)) - collect (list etype vals vec result))) - nil) - -(deftest map-into.specialized-vector.7 - (let ((len 10)) - (loop for etype in '(short-float single-float double-float long-float) - for vals = (loop for i below len collect (coerce i etype)) - for target = (make-array len :initial-contents vals :element-type etype) - for result = (map-into target #'identity vals) - unless (and (eq target result) - (= (length result) len) - (every #'= result vals)) - collect (list etype vals result))) - nil) - -(deftest map-into.specialized-vector.8 - (let ((len 10)) - (loop for cetype in '(short-float single-float double-float long-float) - for etype = `(complex ,cetype) - for vals = (loop for i from 1 to len collect (complex (coerce i cetype) - (coerce (- i) cetype))) - for target = (make-array len :initial-contents vals :element-type etype) - for result = (map-into target #'identity vals) - unless (and (eq target result) - (= (length result) len) - (every #'= result vals)) - collect (list etype vals result))) - nil) - -;;; Error cases - -(deftest map-into.error.1 - (check-type-error #'(lambda (x) (map-into x (constantly nil))) #'sequencep) - nil) - -;;; The next test was changed because if the first argument -;;; is NIL, map-into is said to 'return nil immediately', so -;;; the 'should be prepared' notation for the error checking -;;; means that error checking may be skipped. -(deftest map-into.error.2 - (and (locally (declare (optimize (safety 3))) - (handler-case (eval '(map-into nil #'identity 'a)) - (type-error () nil))) - :bad) - nil) - -(deftest map-into.error.3 - (check-type-error #'(lambda (x) (map-into (copy-seq '(a b c)) #'cons '(d e f) x)) - #'sequencep) - nil) - -(deftest map-into.error.4 - (signals-error (map-into) program-error) - t) - -(deftest map-into.error.5 - (signals-error (map-into (list 'a 'b 'c)) program-error) - t) - -(deftest map-into.error.6 - (signals-error (locally (map-into 'a #'(lambda () nil)) t) - type-error) - t) - -(deftest map-into.error.7 - (signals-error (map-into (list 'a 'b 'c) #'cons '(a b c)) program-error) - t) - -(deftest map-into.error.8 - (signals-error (map-into (list 'a 'b 'c) #'car '(a b c)) type-error) - t) - -;;; Order of evaluation tests - -(deftest map-into.order.1 - (let ((i 0) a b c) - (values - (map-into (progn (setf a (incf i)) (list 1 2 3 4)) - (progn (setf b (incf i)) #'identity) - (progn (setf c (incf i)) '(a b c d))) - i a b c)) - (a b c d) 3 1 2 3) - -(deftest map-into.order.2 - (let ((i 0) a b c d) - (values - (map-into (progn (setf a (incf i)) (list 1 2 3 4)) - (progn (setf b (incf i)) #'list) - (progn (setf c (incf i)) '(a b c d)) - (progn (setf d (incf i)) '(e f g h))) - i a b c d)) - ((a e) (b f) (c g) (d h)) 4 1 2 3 4) diff --git a/t/ansi-test/sequences/map.lsp b/t/ansi-test/sequences/map.lsp deleted file mode 100644 index 846c96d..0000000 --- a/t/ansi-test/sequences/map.lsp +++ /dev/null @@ -1,431 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Aug 17 20:54:48 2002 -;;;; Contains: Tests for the MAP function - -(in-package :cl-test) - -(deftest map-array.1 - (map 'list #'1+ #(1 2 3 4)) - (2 3 4 5)) - -(deftest map-array.2 - (map 'vector #'+ #(1 2 3 4) #(6 6 6 6)) - #(7 8 9 10)) - -(deftest map-array.3 - (map 'vector #'+ #(1 2 3 4 5) #(6 6 6 6)) - #(7 8 9 10)) - -(deftest map-array.4 - (map 'vector #'+ #(1 2 3 4) #(6 6 6 6 6)) - #(7 8 9 10)) - -(deftest map-array.5 - (map '(vector *) #'+ #(1 2 3 4) #(6 6 6 6)) - #(7 8 9 10)) - -(deftest map-array.6 - (map '(vector * 4) #'+ #(1 2 3 4) #(6 6 6 6)) - #(7 8 9 10)) - -;;; (deftest map-array.7 -;;; (map 'array #'identity '(a b c d e f)) -;;; #(a b c d e f)) - -;;; (deftest map-array.8 -;;; (map 'simple-array #'identity '(a b c d e f)) -;;; #(a b c d e f)) - -(deftest map-array.9 - (map 'simple-vector #'identity '(a b c d e f)) - #(a b c d e f)) - -(deftest map-array.10 - (map 'simple-vector #'cons '(a b c d e f) #(1 2 3 4 5 6)) - #((a . 1) (b . 2) (c . 3) (d . 4) (e . 5) (f . 6))) - -(deftest map-array.11 - (map 'vector #'identity '(#\a #\b #\c #\d #\e)) - #(#\a #\b #\c #\d #\e)) - -(deftest map-array.12 - (map 'vector #'identity "abcde") - #(#\a #\b #\c #\d #\e)) - -(deftest map-array.13 - (map 'vector #'identity #*000001) - #(0 0 0 0 0 1)) - -(deftest map-array.14 - (map 'list #'identity #*000001) - (0 0 0 0 0 1)) - -(deftest map-bit-vector.15 - (map 'bit-vector #'identity '(0 0 0 0 0 1)) - #*000001) - -(deftest map-bit-vector.16 - (map 'simple-bit-vector #'identity '(0 0 0 0 0 1)) - #*000001) - -(deftest map-bit-vector.17 - (map '(vector bit) #'identity '(0 0 0 0 0 1)) - #*000001) - -(deftest map-bit-vector.18 - (map '(simple-vector *) #'identity '(0 0 0 0 0 1)) - #*000001) - -(deftest map-bit-vector.19 - (map '(bit-vector 6) #'identity '(0 0 0 0 0 1)) - #*000001) - -(deftest map-bit-vector.20 - (map '(bit-vector *) #'identity '(0 0 0 0 0 1)) - #*000001) - -(deftest map-bit-vector.21 - (map '(simple-bit-vector 6) #'identity '(0 0 0 0 0 1)) - #*000001) - -(deftest map-bit-vector.22 - (map '(simple-bit-vector *) #'identity '(0 0 0 0 0 1)) - #*000001) - -(deftest map-bit-vector.23 - (map '(vector bit 6) #'identity '(0 0 0 0 0 1)) - #*000001) - -(deftest map-bit-vector.24 - (map '(vector bit *) #'identity '(0 0 0 0 0 1)) - #*000001) - -(deftest map-bit-vector.25 - (map '(simple-vector 6) #'identity '(0 0 0 0 0 1)) - #*000001) - -(deftest map-string.26 - (map 'string #'identity '(#\a #\b #\c #\d #\e)) - "abcde") - -(deftest map-string.27 - (map 'string #'identity "abcde") - "abcde") - -(deftest map-string.28 - (map '(vector character) #'identity '(#\a #\b #\c #\d #\e)) - "abcde") - -(deftest map-string.29 - (map '(vector character 5) #'identity '(#\a #\b #\c #\d #\e)) - "abcde") - -(deftest map-string.30 - (map '(simple-vector 5) #'identity '(#\a #\b #\c #\d #\e)) - "abcde") - -;;; Use a more elaborate form of the simple-array type specifier -;;; (deftest map-string.31 -;;; (map '(simple-array character *) #'identity "abcde") -;;; "abcde") - -;;; Use a more elaborate form of the simple-array type specifier -;;; (deftest map-string.32 -;;; (map '(simple-array character 5) #'identity "abcde") -;;; "abcde") - -(deftest map-nil.33 - (let ((a nil)) - (values (map nil #'(lambda (x) (push x a)) "abcdef") a)) - nil (#\f #\e #\d #\c #\b #\a)) - -(deftest map-nil.34 - (let ((a nil)) - (values (map nil #'(lambda (x) (push x a)) '(a b c d e)) a)) - nil (e d c b a)) - -(deftest map-nil.35 - (let ((a nil)) - (values (map nil #'(lambda (x) (push x a)) #(a b c d e)) a)) - nil (e d c b a)) - -(deftest map-nil.36 - (let ((a nil)) - (values (map nil #'(lambda (x) (push x a)) #*001011110) a)) - nil (0 1 1 1 1 0 1 0 0)) - -(deftest map-null.1 - (map 'null #'identity nil) - nil) - -(deftest map-cons.1 - (map 'cons #'identity '(a b c)) - (a b c)) - -(deftest map.37 - (map 'simple-string #'identity '(#\a #\b #\c)) - "abc") - -(deftest map.38 - (map '(simple-string) #'identity '(#\a #\b #\c)) - "abc") - -(deftest map.39 - (map '(simple-string *) #'identity '(#\a #\b #\c)) - "abc") - -(deftest map.40 - (map '(simple-string 3) #'identity '(#\a #\b #\c)) - "abc") - -(deftest map.41 - (map '(base-string) #'identity '(#\a #\b #\c)) - "abc") - -(deftest map.42 - (map '(base-string *) #'identity '(#\a #\b #\c)) - "abc") - -(deftest map.43 - (map '(base-string 3) #'identity '(#\a #\b #\c)) - "abc") - -(deftest map.44 - (map 'simple-base-string #'identity '(#\a #\b #\c)) - "abc") - -(deftest map.45 - (map '(simple-base-string) #'identity '(#\a #\b #\c)) - "abc") - -(deftest map.46 - (map '(simple-base-string *) #'identity '(#\a #\b #\c)) - "abc") - -(deftest map.47 - (map '(simple-base-string 3) #'identity '(#\a #\b #\c)) - "abc") - -(deftest map.48 - :notes (:result-type-element-type-by-subtype) - (let ((type '(or (vector t 10) (vector t 5)))) - (if (subtypep type '(vector t)) - (equalpt (map type #'identity '(1 2 3 4 5)) #(1 2 3 4 5)) - t)) - t) - -;;; Error tests - -(deftest map.error.1 - (signals-error-always (map 'symbol #'identity '(a b c)) type-error) - t t) - -(deftest map.error.1a - (signals-error (map 'symbol #'identity '(a b c)) type-error) - t) - -(deftest map.error.2 - (signals-error (map '(vector * 8) #'identity '(a b c)) type-error) - t) - -(deftest map.error.3 - (signals-error (map 'list #'identity '(a b . c)) type-error) - t) - -(deftest map.error.4 - (signals-error (map) program-error) - t) - -(deftest map.error.5 - (signals-error (map 'list) program-error) - t) - -(deftest map.error.6 - (signals-error (map 'list #'null) program-error) - t) - -(deftest map.error.7 - (signals-error (map 'list #'cons '(a b c d)) program-error) - t) - -(deftest map.error.8 - (signals-error (map 'list #'cons '(a b c d) '(1 2 3 4) '(5 6 7 8)) - program-error) - t) - -(deftest map.error.9 - (signals-error (map 'list #'car '(a b c d)) type-error) - t) - -(deftest map.error.10 - :notes (:result-type-element-type-by-subtype) - (let ((type '(or (vector bit) (vector t)))) - (if (subtypep type 'vector) - (eval `(signals-error-always (map ',type #'identity '(1 0 1)) error)) - (values t t))) - t t) - -(deftest map.error.11 - (let ((type '(or (vector t 5) (vector t 10)))) - (if (subtypep type 'vector) - (eval `(signals-error (map ',type #'identity '(1 2 3 4 5 6)) type-error)) - t)) - t) - -(deftest map.error.12 - (check-type-error #'(lambda (x) (map 'list #'identity x)) #'sequencep) - nil) - -(deftest map.error.13 - (check-type-error #'(lambda (x) (map 'vector #'cons '(a b c d) x)) #'sequencep) - nil) - -;;; Test mapping on arrays with fill pointers - -(deftest map.fill.1 - (let ((s1 (make-array '(10) :initial-contents '(a b c d e f g h i j) - :fill-pointer 8))) - (map 'list #'identity s1)) - (a b c d e f g h)) - -(deftest map.fill.2 - (let ((s1 (make-array '(10) :initial-contents '(a b c d e f g h i j) - :fill-pointer 8))) - (map 'list #'(lambda (x y) x) '(1 2 3 4 5 6 7 8 9 10) s1)) - (1 2 3 4 5 6 7 8)) - -(deftest map.fill.3 - (let ((s1 (make-array '(10) :initial-element #\a - :element-type 'character - :fill-pointer 8))) - (map 'string #'identity s1)) - "aaaaaaaa") - -(deftest map.fill.4 - (let ((s1 (make-array '(10) :initial-element #\a - :element-type 'base-char - :fill-pointer 8))) - (map 'list #'(lambda (x y) x) '(1 2 3 4 5 6 7 8 9 10) s1)) - (1 2 3 4 5 6 7 8)) - -(deftest map.fill.5 - (let ((s1 (make-array '(10) :initial-element 0 - :element-type 'bit - :fill-pointer 8))) - (map 'bit-vector #'identity s1)) - #*00000000) - -(deftest map.fill.6 - (let ((s1 (make-array '(10) :initial-element 1 - :element-type 'bit - :fill-pointer 8))) - (map 'list #'(lambda (x y) x) '(1 2 3 4 5 6 7 8 9 10) s1)) - (1 2 3 4 5 6 7 8)) - -;;; Specialized string tests - -(deftest map.specialized-string.1 - (do-special-strings - (s "abcde" nil) - (let ((s2 (map 'list #'identity s))) - (assert (equal s2 '(#\a #\b #\c #\d #\e))))) - nil) - -(deftest map.specialized-string.2 - (do-special-strings - (s "abcde" nil) - (let ((s2 (map 'list #'(lambda (x y) y) '(1 2 3 4 5) s))) - (assert (equal s2 '(#\a #\b #\c #\d #\e))))) - nil) - -(deftest map.specialized-string.3 - (let ((s (map 'base-string #'identity '(#\a #\b #\c)))) - (assert (typep s 'base-string)) - s) - "abc") - -;;; FIXME: Add tests for building strings of other character types - -;;; Special vector types - -(deftest map.specialized-vector.1 - (do-special-integer-vectors - (v #(0 1 1 0 0 1) nil) - (assert (equal (map 'list #'list v v) '((0 0) (1 1) (1 1) (0 0) (0 0) (1 1))))) - nil) - -(deftest map.specialized-vector.2 - (do-special-integer-vectors - (v #(1 2 3 4 5 6 7) nil) - (assert (equal (map 'list #'identity v) '(1 2 3 4 5 6 7)))) - nil) - -(deftest map.specialized-vector.3 - (do-special-integer-vectors - (v #(-1 -2 -3 -4 -5 -6 -7) nil) - (assert (equal (map 'list #'- v) '(1 2 3 4 5 6 7)))) - nil) - -(deftest map.specialized-vector.4 - (loop for i from 1 to 40 - for type = `(unsigned-byte ,i) - for bound = (ash 1 i) - for len = 10 - for vals = (loop repeat len collect (random i)) - for result = (map `(vector ,type) #'identity vals) - unless (and (= (length result) len) - (every #'eql vals result)) - collect (list i vals result)) - nil) - -(deftest map.specialized-vector.5 - (loop for i from 1 to 40 - for type = `(signed-byte ,i) - for bound = (ash 1 i) - for len = 10 - for vals = (loop repeat len collect (- (random i) (/ bound 2))) - for result = (map `(vector ,type) #'identity vals) - unless (and (= (length result) len) - (every #'eql vals result)) - collect (list i vals result)) - nil) - -(deftest map.specialized-vector.6 - (loop for type in '(short-float single-float long-float double-float) - for len = 10 - for vals = (loop for i from 1 to len collect (coerce i type)) - for result = (map `(vector ,type) #'identity vals) - unless (and (= (length result) len) - (every #'eql vals result)) - collect (list type vals result)) - nil) - -(deftest map.specialized-vector.7 - (loop for etype in '(short-float single-float long-float double-float - integer rational) - for type = `(complex ,etype) - for len = 10 - for vals = (loop for i from 1 to len collect (complex (coerce i etype) - (coerce (- i) etype))) - for result = (map `(vector ,type) #'identity vals) - unless (and (= (length result) len) - (every #'eql vals result)) - collect (list type vals result)) - nil) - -;;; Order of evaluation tests - -(deftest map.order.1 - (let ((i 0) a b c d) - (values - (map (progn (setf a (incf i)) 'list) - (progn (setf b (incf i)) #'list) - (progn (setf c (incf i)) '(a b c)) - (progn (setf d (incf i)) '(b c d))) - i a b c d)) - ((a b)(b c)(c d)) 4 1 2 3 4) - -;;; Constant folding test - -(def-fold-test map.fold.1 (map 'vector #'identity '(a b c))) diff --git a/t/ansi-test/sequences/merge.lsp b/t/ansi-test/sequences/merge.lsp deleted file mode 100644 index 692244b..0000000 --- a/t/ansi-test/sequences/merge.lsp +++ /dev/null @@ -1,692 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Sep 6 07:24:17 2002 -;;;; Contains: Tests for MERGE - -(in-package :cl-test) - -(deftest merge-list.1 - (let ((x (list 1 3 7 8 10)) - (y (list 2 4 5 8 11))) - (merge 'list x y #'<)) - (1 2 3 4 5 7 8 8 10 11)) - -(deftest merge-list.2 - (let ((x nil) - (y (list 2 4 5 8 11))) - (merge 'list x y #'<)) - (2 4 5 8 11)) - -(deftest merge-list.3 - (let ((x nil) - (y (list 2 4 5 8 11))) - (merge 'list y x #'<)) - (2 4 5 8 11)) - -(deftest merge-list.4 - (merge 'list nil nil #'<) - nil) - -(deftest merge-list.5 - (let ((x (vector 1 3 7 8 10)) - (y (list 2 4 5 8 11))) - (merge 'list x y #'<)) - (1 2 3 4 5 7 8 8 10 11)) - -(deftest merge-list.6 - (let ((x (list 1 3 7 8 10)) - (y (vector 2 4 5 8 11))) - (merge 'list x y #'<)) - (1 2 3 4 5 7 8 8 10 11)) - -(deftest merge-list.7 - (let ((x (vector 1 3 7 8 10)) - (y (vector 2 4 5 8 11))) - (merge 'list x y #'<)) - (1 2 3 4 5 7 8 8 10 11)) - -(deftest merge-list.8 - (let ((x (sort (list 1 3 7 8 10) #'>)) - (y (sort (list 2 4 5 8 11) #'>))) - (merge 'list x y #'< :key #'-)) - (11 10 8 8 7 5 4 3 2 1)) - -(deftest merge-list.9 - (let ((x (list 1 3 7 8 10)) - (y (list 2 4 5 8 11))) - (merge 'list x y #'< :key nil)) - (1 2 3 4 5 7 8 8 10 11)) - -(deftest merge-list.10 - (let ((x (list 1 3 7 8 10)) - (y (list 2 4 5 8 11))) - (merge 'list x y '<)) - (1 2 3 4 5 7 8 8 10 11)) - -(deftest merge-list.11 - (let ((x (vector)) (y (vector))) - (merge 'list x y #'<)) - nil) - -(deftest merge-list.12 - (let ((x nil) (y (vector 1 2 3))) - (merge 'list x y #'<)) - (1 2 3)) - -(deftest merge-list.13 - (let ((x (vector)) (y (list 1 2 3))) - (merge 'list x y #'<)) - (1 2 3)) - -(deftest merge-list.14 - (let ((x nil) (y (vector 1 2 3))) - (merge 'list y x #'<)) - (1 2 3)) - -(deftest merge-list.15 - (let ((x (vector)) (y (list 1 2 3))) - (merge 'list y x #'<)) - (1 2 3)) - -;;; Tests yielding vectors - -(deftest merge-vector.1 - (let ((x (list 1 3 7 8 10)) - (y (list 2 4 5 8 11))) - (merge 'vector x y #'<)) - #(1 2 3 4 5 7 8 8 10 11)) - -(deftest merge-vector.2 - (let ((x nil) - (y (list 2 4 5 8 11))) - (merge 'vector x y #'<)) - #(2 4 5 8 11)) - -(deftest merge-vector.3 - (let ((x nil) - (y (list 2 4 5 8 11))) - (merge 'vector y x #'<)) - #(2 4 5 8 11)) - -(deftest merge-vector.4 - (merge 'vector nil nil #'<) - #()) - -(deftest merge-vector.5 - (let ((x (vector 1 3 7 8 10)) - (y (list 2 4 5 8 11))) - (merge 'vector x y #'<)) - #(1 2 3 4 5 7 8 8 10 11)) - -(deftest merge-vector.6 - (let ((x (list 1 3 7 8 10)) - (y (vector 2 4 5 8 11))) - (merge 'vector x y #'<)) - #(1 2 3 4 5 7 8 8 10 11)) - -(deftest merge-vector.7 - (let ((x (vector 1 3 7 8 10)) - (y (vector 2 4 5 8 11))) - (merge 'vector x y #'<)) - #(1 2 3 4 5 7 8 8 10 11)) - -(deftest merge-vector.8 - (let ((x (sort (list 1 3 7 8 10) #'>)) - (y (sort (list 2 4 5 8 11) #'>))) - (merge 'vector x y #'< :key #'-)) - #(11 10 8 8 7 5 4 3 2 1)) - -(deftest merge-vector.9 - (let ((x (list 1 3 7 8 10)) - (y (list 2 4 5 8 11))) - (merge 'vector x y #'< :key nil)) - #(1 2 3 4 5 7 8 8 10 11)) - -(deftest merge-vector.10 - (let ((x (list 1 3 7 8 10)) - (y (list 2 4 5 8 11))) - (merge 'vector x y '<)) - #(1 2 3 4 5 7 8 8 10 11)) - -(deftest merge-vector.11 - (let ((x (vector)) (y (vector))) - (merge 'vector x y #'<)) - #()) - -(deftest merge-vector.12 - (let ((x nil) (y (vector 1 2 3))) - (merge 'vector x y #'<)) - #(1 2 3)) - -(deftest merge-vector.13 - (let ((x (vector)) (y (list 1 2 3))) - (merge 'vector x y #'<)) - #(1 2 3)) - -(deftest merge-vector.14 - (let ((x nil) (y (vector 1 2 3))) - (merge 'vector y x #'<)) - #(1 2 3)) - -(deftest merge-vector.15 - (let ((x (vector)) (y (list 1 2 3))) - (merge 'vector y x #'<)) - #(1 2 3)) - -(deftest merge-vector.16 - (let ((x (make-array '(10) :initial-contents '(2 5 8 9 11 12 14 15 18 30) - :fill-pointer 5)) - (y (list 1 6 10))) - (merge 'vector x y #'<)) - #(1 2 5 6 8 9 10 11)) - -(deftest merge-vector.16a - (let ((x (make-array '(10) :initial-contents '(2 5 8 9 11 12 14 15 18 30) - :fill-pointer 5)) - (y (list 1 6 10))) - (merge 'vector y x #'<)) - #(1 2 5 6 8 9 10 11)) - -(deftest merge-vector.17 - (let* ((x (make-array '(10) :initial-contents '(2 5 8 9 11 12 14 15 18 30) - :fill-pointer 5)) - (result (merge 'vector x () #'<))) - (values - (array-element-type result) - result)) - t - #(2 5 8 9 11)) - -(deftest merge-vector.18 - (merge '(vector) (list 1 3 10) (list 2 4 6) #'<) - #(1 2 3 4 6 10)) - -(deftest merge-vector.19 - (merge '(vector *) (list 1 3 10) (list 2 4 6) #'<) - #(1 2 3 4 6 10)) - -(deftest merge-vector.20 - (merge '(vector t) (list 1 3 10) (list 2 4 6) #'<) - #(1 2 3 4 6 10)) - -(deftest merge-vector.21 - (merge '(vector * 6) (list 1 3 10) (list 2 4 6) #'<) - #(1 2 3 4 6 10)) - -(deftest merge-vector.22 - (merge '(simple-vector) (list 2 4 6) (list 1 3 5) #'<) - #(1 2 3 4 5 6)) - -(deftest merge-vector.23 - (merge '(simple-vector *) (list 2 4 6) (list 1 3 5) #'<) - #(1 2 3 4 5 6)) - -(deftest merge-vector.24 - (merge '(simple-vector 6) (list 2 4 6) (list 1 3 5) #'<) - #(1 2 3 4 5 6)) - -;;; Tests on strings - -(deftest merge-string.1 - (let ((x (list #\1 #\3 #\7 #\8)) - (y (list #\2 #\4 #\5 #\9))) - (merge 'string x y #'char<)) - "12345789") - -(deftest merge-string.1a - (let ((x (copy-seq "1378")) - (y (list #\2 #\4 #\5 #\9))) - (merge 'string x y #'char<)) - "12345789") - -(deftest merge-string.1b - (let ((x (list #\1 #\3 #\7 #\8)) - (y (copy-seq "2459"))) - (merge 'string x y #'char<)) - "12345789") - -(deftest merge-string.1c - (let ((x (copy-seq "1378")) - (y (copy-seq "2459"))) - (merge 'string x y #'char<)) - "12345789") - -(deftest merge-string.1d - (let ((x (copy-seq "1378")) - (y (copy-seq "2459"))) - (merge 'string y x #'char<)) - "12345789") - -(deftest merge-string.2 - (let ((x nil) - (y (list #\2 #\4 #\5 #\9))) - (merge 'string x y #'char<)) - "2459") - -(deftest merge-string.3 - (let ((x nil) - (y (list #\2 #\4 #\5 #\9))) - (merge 'string y x #'char<)) - "2459") - -(deftest merge-string.4 - (merge 'string nil nil #'char<) - "") - -(deftest merge-string.8 - (let ((x (list #\1 #\3 #\7 #\8)) - (y (list #\2 #\4 #\5))) - (merge 'string x y #'char< :key #'nextdigit)) - "1234578") - -(deftest merge-string.9 - (let ((x (list #\1 #\3 #\7 #\8)) - (y (list #\2 #\4 #\5 #\9))) - (merge 'string x y #'char< :key nil)) - "12345789") - -(deftest merge-string.10 - (let ((x (list #\1 #\3 #\7 #\8)) - (y (list #\2 #\4 #\5 #\9))) - (merge 'string x y 'char<)) - "12345789") - -(deftest merge-string.11 - (let ((x (vector)) (y (vector))) - (merge 'string x y #'char<)) - "") - -(deftest merge-string.12 - (let ((x nil) (y (vector #\1 #\2 #\3))) - (merge 'string x y #'char<)) - "123") - -(deftest merge-string.13 - (let ((x (vector)) (y (list #\1 #\2 #\3))) - (merge 'string x y #'char<)) - "123") - -(deftest merge-string.13a - (let ((x (copy-seq "")) (y (list #\1 #\2 #\3))) - (merge 'string x y #'char<)) - "123") - -(deftest merge-string.14 - (let ((x nil) (y (vector #\1 #\2 #\3))) - (merge 'string y x #'char<)) - "123") - -(deftest merge-string.14a - (let ((x (copy-seq "")) (y (vector #\1 #\2 #\3))) - (merge 'string y x #'char<)) - "123") - -(deftest merge-string.15 - (let* ((x (make-array '(10) :initial-contents "adgkmpruwv" - :fill-pointer 5 :element-type 'character)) - (y (copy-seq "bci"))) - (merge 'string x y #'char<)) - "abcdgikm") - -(deftest merge-string.16 - (let* ((x (make-array '(10) :initial-contents "adgkmpruwv" - :fill-pointer 5 :element-type 'character)) - (y (copy-seq "bci"))) - (merge 'string y x #'char<)) - "abcdgikm") - -(deftest merge-string.17 - (let* ((x (make-array '(10) :initial-contents "adgkmpruwv" - :fill-pointer 5 :element-type 'character))) - (merge 'string nil x #'char<)) - "adgkm") - -(deftest merge-string.18 - (let* ((x (make-array '(10) :initial-contents "adgkmpruwv" - :fill-pointer 5 :element-type 'character))) - (merge 'string x nil #'char<)) - "adgkm") - -(deftest merge-string.19 - (do-special-strings - (s "ace" nil) - (assert (string= (merge 'string s (copy-seq "bdf") #'char<) "abcdef"))) - nil) - -(deftest merge-string.20 - (do-special-strings - (s "ace" nil) - (assert (string= (merge 'base-string (copy-seq "bdf") s #'char<) "abcdef"))) - nil) - -(deftest merge-string.21 - (do-special-strings - (s "ace" nil) - (assert (string= (merge 'simple-string s (copy-seq "bdf") #'char<) "abcdef"))) - nil) - -(deftest merge-string.22 - (do-special-strings - (s "ace" nil) - (assert (string= (merge 'simple-base-string s (copy-seq "bdf") #'char<) "abcdef"))) - nil) - -(deftest merge-string.23 - (do-special-strings - (s "ace" nil) - (assert (string= (merge '(vector character) s (copy-seq "bdf") #'char<) "abcdef"))) - nil) - -(deftest merge-string.24 - (merge '(string) (copy-seq "ace") (copy-seq "bdf") #'char<) - "abcdef") - -(deftest merge-string.25 - (merge '(string *) (copy-seq "ace") (copy-seq "bdf") #'char<) - "abcdef") - -(deftest merge-string.26 - (merge '(string 6) (copy-seq "ace") (copy-seq "bdf") #'char<) - "abcdef") - -(deftest merge-string.27 - (merge '(simple-string) (copy-seq "ace") (copy-seq "bdf") #'char<) - "abcdef") - -(deftest merge-string.28 - (merge '(simple-string *) (copy-seq "ace") (copy-seq "bdf") #'char<) - "abcdef") - -(deftest merge-string.29 - (merge '(simple-string 6) (copy-seq "ace") (copy-seq "bdf") #'char<) - "abcdef") - -(deftest merge-string.30 - (merge '(base-string) (copy-seq "ace") (copy-seq "bdf") #'char<) - "abcdef") - -(deftest merge-string.31 - (merge '(base-string *) (copy-seq "ace") (copy-seq "bdf") #'char<) - "abcdef") - -(deftest merge-string.32 - (merge '(base-string 6) (copy-seq "ace") (copy-seq "bdf") #'char<) - "abcdef") - -(deftest merge-string.33 - (merge '(simple-base-string) (copy-seq "ace") (copy-seq "bdf") #'char<) - "abcdef") - -(deftest merge-string.34 - (merge '(simple-base-string *) (copy-seq "ace") (copy-seq "bdf") #'char<) - "abcdef") - -(deftest merge-string.35 - (merge '(simple-base-string 6) (copy-seq "ace") (copy-seq "bdf") #'char<) - "abcdef") - - -;;; Tests for bit vectors - -(deftest merge-bit-vector.1 - (let ((x (list 0 0 1 1 1)) - (y (list 0 0 0 1 1))) - (merge 'bit-vector x y #'<)) - #*0000011111) - -(deftest merge-bit-vector.2 - (let ((x nil) - (y (list 0 0 0 1 1))) - (merge 'bit-vector x y #'<)) - #*00011) - -(deftest merge-bit-vector.3 - (let ((x nil) - (y (list 0 0 0 1 1))) - (merge 'bit-vector y x #'<)) - #*00011) - -(deftest merge-bit-vector.4 - (merge 'bit-vector nil nil #'<) - #*) - -(deftest merge-bit-vector.5 - (let ((x (vector 0 0 1 1 1)) - (y (list 0 0 0 1 1))) - (merge 'bit-vector x y #'<)) - #*0000011111) - -(deftest merge-bit-vector.5a - (let ((x (copy-seq #*00111)) - (y (list 0 0 0 1 1))) - (merge 'bit-vector x y #'<)) - #*0000011111) - -(deftest merge-bit-vector.5b - (let ((x (list 0 0 1 1 1)) - (y (copy-seq #*00011))) - (merge 'bit-vector x y #'<)) - #*0000011111) - -(deftest merge-bit-vector.5c - (let ((x (copy-seq #*00111)) - (y (copy-seq #*00011))) - (merge 'bit-vector x y #'<)) - #*0000011111) - -(deftest merge-bit-vector.5d - (let ((x (copy-seq #*11111)) - (y (copy-seq #*00000))) - (merge 'bit-vector x y #'<)) - #*0000011111) - -(deftest merge-bit-vector.5e - (let ((x (copy-seq #*11111)) - (y (copy-seq #*00000))) - (merge 'bit-vector y x #'<)) - #*0000011111) - -(deftest merge-bit-vector.6 - (let ((x (list 0 0 1 1 1)) - (y (vector 0 0 0 1 1))) - (merge 'bit-vector x y #'<)) - #*0000011111) - -(deftest merge-bit-vector.7 - (let ((x (vector 0 0 1 1 1)) - (y (vector 0 0 0 1 1))) - (merge 'bit-vector x y #'<)) - #*0000011111) - -(deftest merge-bit-vector.8 - (let ((x (list 1 1 1 0 0)) - (y (list 1 1 0 0 0))) - (merge 'bit-vector x y #'< :key #'-)) - #*1111100000) - -(deftest merge-bit-vector.9 - (let ((x (list 0 0 1 1 1)) - (y (list 0 0 0 1 1))) - (merge 'bit-vector x y #'< :key nil)) - #*0000011111) - -(deftest merge-bit-vector.10 - (let ((x (list 0 0 1 1 1)) - (y (list 0 0 0 1 1))) - (merge 'bit-vector x y '<)) - #*0000011111) - -(deftest merge-bit-vector.11 - (let ((x (copy-seq #*)) (y (copy-seq #*))) - (merge 'bit-vector x y #'<)) - #*) - -(deftest merge-bit-vector.12 - (let ((x (copy-seq #*)) (y (copy-seq #*011))) - (merge 'bit-vector x y #'<)) - #*011) - -(deftest merge-bit-vector.13 - (let ((x (copy-seq #*)) (y (list 0 1 1))) - (merge 'bit-vector x y #'<)) - #*011) - -(deftest merge-bit-vector.14 - (let ((x nil) (y (vector 0 1 1))) - (merge 'bit-vector y x #'<)) - #*011) - -(deftest merge-bit-vector.15 - (let ((x (copy-seq #*)) (y (list 0 1 1))) - (merge 'bit-vector y x #'<)) - #*011) - -(deftest merge-bit-vector.16 - (let* ((x (make-array '(10) :initial-contents #*0001101010 - :fill-pointer 5 :element-type 'bit)) - (y (copy-seq #*001))) - (merge 'bit-vector x y #'<)) - #*00000111) - -(deftest merge-bit-vector.17 - (let* ((x (make-array '(10) :initial-contents #*0001101010 - :fill-pointer 5 :element-type 'bit)) - (y (copy-seq #*001))) - (merge 'bit-vector y x #'<)) - #*00000111) - -(deftest merge-bit-vector.18 - (let* ((x (make-array '(10) :initial-contents #*0001101010 - :fill-pointer 5 :element-type 'bit))) - (merge 'bit-vector nil x #'<)) - #*00011) - -(deftest merge-bit-vector.19 - (let* ((x (make-array '(10) :initial-contents #*0001101010 - :fill-pointer 5 :element-type 'bit))) - (merge 'bit-vector x nil #'<)) - #*00011) - - -;;; Cons (which is a recognizable subtype of list) - -(deftest merge-cons.1 - (merge 'cons (list 1 2 3) (list 4 5 6) #'<) - (1 2 3 4 5 6)) - -;;; Null, which is a recognizable subtype of list - -(deftest merge-null.1 - (merge 'null nil nil #'<) - nil) - -;;; Vectors with length - -(deftest merge-vector-length.1 - (merge '(vector * 6) (list 1 2 3) (list 4 5 6) #'<) - #(1 2 3 4 5 6)) - -(deftest merge-bit-vector-length.1 - (merge '(bit-vector 6) (list 0 1 1) (list 0 0 1) #'<) - #*000111) - -;;; Order of evaluation - -(deftest merge.order.1 - (let ((i 0) a b c d) - (values - (merge (progn (setf a (incf i)) 'list) - (progn (setf b (incf i)) (list 2 5 6)) - (progn (setf c (incf i)) (list 1 3 4)) - (progn (setf d (incf i)) #'<)) - i a b c d)) - (1 2 3 4 5 6) 4 1 2 3 4) - -;;; Tests of error situations - -(deftest merge.error.1 - (handler-case (eval - '(locally (declare (optimize safety)) - (merge 'symbol (list 1 2 3) (list 4 5 6) #'<))) - (error () :caught)) - :caught) - -(deftest merge.error.2 - (signals-error (merge '(vector * 3) (list 1 2 3) (list 4 5 6) #'<) - type-error) - t) - -(deftest merge.error.3 - (signals-error (merge '(bit-vector 3) (list 0 0 0) (list 1 1 1) #'<) - type-error) - t) - -(deftest merge.error.4 - (signals-error (merge '(vector * 7) (list 1 2 3) (list 4 5 6) #'<) - type-error) - t) - -(deftest merge.error.5 - (signals-error (merge '(bit-vector 7) (list 0 0 0) (list 1 1 1) #'<) - type-error) - t) - -(deftest merge.error.6 - (signals-error (merge 'null (list 1 2 3) (list 4 5 6) #'<) - type-error) - t) - -(deftest merge.error.7 - (signals-error (merge) program-error) - t) - -(deftest merge.error.8 - (signals-error (merge 'list) program-error) - t) - -(deftest merge.error.9 - (signals-error (merge 'list (list 2 4 6)) program-error) - t) - -(deftest merge.error.10 - (signals-error (merge 'list (list 2 4 6) (list 1 3 5)) - program-error) - t) - -(deftest merge.error.11 - (signals-error (merge 'list (list 2 4 6) (list 1 3 5) #'< :bad t) - program-error) - t) - -(deftest merge.error.12 - (signals-error (merge 'list (list 2 4 6) (list 1 3 5) #'< :key) - program-error) - t) - -(deftest merge.error.13 - (signals-error (merge 'list (list 2 4 6) (list 1 3 5) #'< :bad t - :allow-other-keys nil) - program-error) - t) - -(deftest merge.error.14 - (signals-error (merge 'list (list 2 4 6) (list 1 3 5) #'< 1 2) - program-error) - t) - -(deftest merge.error.15 - (signals-error (locally (merge '(vector * 3) (list 1 2 3) - (list 4 5 6) #'<) - t) - type-error) - t) - -(deftest merge.error.16 - (signals-error (merge 'list (list 1 2) (list 3 4) #'car) - program-error) - t) - -(deftest merge.error.17 - (signals-error (merge 'list (list 'a 'b) (list 3 4) #'max) - type-error) - t) diff --git a/t/ansi-test/sequences/mismatch.lsp b/t/ansi-test/sequences/mismatch.lsp deleted file mode 100644 index 5aafdb8..0000000 --- a/t/ansi-test/sequences/mismatch.lsp +++ /dev/null @@ -1,758 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Aug 26 23:55:29 2002 -;;;; Contains: Tests for MISMATCH - -(in-package :cl-test) - -(deftest mismatch-list.1 - (mismatch '() '(a b c)) - 0) - -(deftest mismatch-list.2 - (mismatch '(a b c d) '()) - 0) - -(deftest mismatch-list.3 - (mismatch '(a b c) '(a b c)) - nil) - -(deftest mismatch-list.4 - (mismatch '(a b c) '(a b d)) - 2) - -(deftest mismatch-list.5 - (mismatch '(a b c) '(b c) :start1 1) - nil) - -(deftest mismatch-list.6 - (mismatch '(a b c d) '(z b c e) :start1 1 :start2 1) - 3) - -(deftest mismatch-list.7 - (mismatch '(a b c d) '(z b c e) :start1 1 :start2 1 :end1 3 :end2 3) - nil) - -(deftest mismatch-list.8 - (mismatch '(1 2 3 4) '(5 6 7 8) :test #'(lambda (x y) (= x (- y 4)))) - nil) - -(deftest mismatch-list.9 - (mismatch '(1 2 3 4) '(5 6 17 8) :test #'(lambda (x y) (= x (- y 4)))) - 2) - -(deftest mismatch-list.10 - (mismatch '(1 2 3 4) '(10 11 7 123) :test-not #'(lambda (x y) (= x (- y 4)))) - 2) - -(deftest mismatch-list.11 - (mismatch '(1 2 3 4) '(5 6 17 8) :key #'evenp) - nil) - -(deftest mismatch-list.12 - (mismatch '(1 2 3 4) '(5 6 12 8) :key 'oddp) - 2) - -(deftest mismatch-list.13 - (mismatch '(1 2 3 4) '(1 2 3 4) :test 'eql) - nil) - -(deftest mismatch-list.14 - (mismatch '(1 2 3 4) '(5 6 7 8) :test-not 'eql) - nil) - -(deftest mismatch-list.15 - (mismatch '(a b c d e f g h i j k) '(a b c c e f g h z j k)) - 3) - -(deftest mismatch-list.16 - (mismatch '(a b c d e f g h i j k) '(a b c c y f g h z j k) :from-end t) - 9) - -(deftest mismatch-list.17 - (mismatch '(a b c) '(a b c a b c d) :from-end t) - 3) - -(deftest mismatch-list.18 - (mismatch '(a b c a b c d) '(a b c) :from-end t) - 7) - -(deftest mismatch-list.19 - (mismatch '(1 1 1) '(2 2 2 2 2 1 2 2) :from-end t :test-not 'eql) - 1) - -(deftest mismatch-list.20 - (mismatch '(1 1 1 1 1 1 1) '(2 3 3) :from-end t :key #'evenp) - 5) - -(deftest mismatch-list.21 - (mismatch '(1 1 1) '(2 2 2 2 2 1 2 2) :from-end t :test-not #'equal) - 1) - -(deftest mismatch-list.22 - (mismatch '(1 1 1 1 1 1 1) '(2 3 3) :from-end t :key 'evenp) - 5) - -;;; tests on vectors - -(deftest mismatch-vector.1 - (mismatch #() #(a b c)) - 0) - -(deftest mismatch-vector.2 - (mismatch #(a b c d) #()) - 0) - -(deftest mismatch-vector.3 - (mismatch #(a b c) #(a b c)) - nil) - -(deftest mismatch-vector.4 - (mismatch #(a b c) #(a b d)) - 2) - -(deftest mismatch-vector.5 - (mismatch #(a b c) #(b c) :start1 1) - nil) - -(deftest mismatch-vector.6 - (mismatch #(a b c d) #(z b c e) :start1 1 :start2 1) - 3) - -(deftest mismatch-vector.7 - (mismatch #(a b c d) #(z b c e) :start1 1 :start2 1 :end1 3 :end2 3) - nil) - -(deftest mismatch-vector.8 - (mismatch #(1 2 3 4) #(5 6 7 8) :test #'(lambda (x y) (= x (- y 4)))) - nil) - -(deftest mismatch-vector.9 - (mismatch #(1 2 3 4) #(5 6 17 8) :test #'(lambda (x y) (= x (- y 4)))) - 2) - -(deftest mismatch-vector.10 - (mismatch #(1 2 3 4) #(10 11 7 123) :test-not #'(lambda (x y) (= x (- y 4)))) - 2) - -(deftest mismatch-vector.11 - (mismatch #(1 2 3 4) #(5 6 17 8) :key #'evenp) - nil) - -(deftest mismatch-vector.12 - (mismatch #(1 2 3 4) #(5 6 12 8) :key 'oddp) - 2) - -(deftest mismatch-vector.13 - (mismatch #(1 2 3 4) #(1 2 3 4) :test 'eql) - nil) - -(deftest mismatch-vector.14 - (mismatch #(1 2 3 4) #(5 6 7 8) :test-not 'eql) - nil) - -(deftest mismatch-vector.15 - (mismatch #(a b c d e f g h i j k) #(a b c c e f g h z j k)) - 3) - -(deftest mismatch-vector.16 - (mismatch #(a b c d e f g h i j k) #(a b c c y f g h z j k) :from-end t) - 9) - -(deftest mismatch-vector.17 - (mismatch #(a b c) #(a b c a b c d) :from-end t) - 3) - -(deftest mismatch-vector.18 - (mismatch #(a b c a b c d) #(a b c) :from-end t) - 7) - -(deftest mismatch-vector.19 - (mismatch #(1 1 1) #(2 2 2 2 2 1 2 2) :from-end t :test-not 'eql) - 1) - -(deftest mismatch-vector.20 - (mismatch #(1 1 1 1 1 1 1) #(2 3 3) :from-end t :key #'evenp) - 5) - -(deftest mismatch-vector.21 - (mismatch #(1 1 1) #(2 2 2 2 2 1 2 2) :from-end t :test-not #'equal) - 1) - -(deftest mismatch-vector.22 - (mismatch #(1 1 1 1 1 1 1) #(2 3 3) :from-end t :key 'evenp) - 5) - -(deftest mismatch-vector.23 - (let ((a (make-array '(9) :initial-contents '(1 2 3 4 5 6 7 8 9) - :fill-pointer 5))) - (values - (mismatch '(1 2 3 4 5) a) - (mismatch '(1 2 3 4 5) a :from-end t) - (mismatch '(1 2 3 4) a) - (mismatch '(1 2 3 4 5 6) a) - (mismatch '(6 7 8 9) a :from-end t) - (mismatch '(2 3 4 5) a :from-end t))) - nil nil 4 5 4 0) - -(deftest mismatch-vector.24 - (let ((m (make-array '(6) :initial-contents '(1 2 3 4 5 6) - :fill-pointer 4)) - (a '(1 2 3 4 5))) - (list - (mismatch m a) - (mismatch m a :from-end t) - (setf (fill-pointer m) 5) - (mismatch m a) - (mismatch m a :from-end t) - (setf (fill-pointer m) 6) - (mismatch m a) - (mismatch m a :from-end t))) - (4 4 5 nil nil 6 5 6)) - -;;; tests on bit vectors - -(deftest mismatch-bit-vector.1 - (mismatch "" #*111) - 0) - -(deftest mismatch-bit-vector.1a - (mismatch '() #*111) - 0) - -(deftest mismatch-bit-vector.1b - (mismatch "" '(1 1 1)) - 0) - -(deftest mismatch-bit-vector.2 - (mismatch #*1010 #*) - 0) - -(deftest mismatch-bit-vector.2a - (mismatch #*1010 '()) - 0) - -(deftest mismatch-bit-vector.2b - (mismatch '(1 0 1 0) #*) - 0) - -(deftest mismatch-bit-vector.3 - (mismatch #*101 #*101) - nil) - -(deftest mismatch-bit-vector.4 - (mismatch #*101 #*100) - 2) - -(deftest mismatch-bit-vector.5 - (mismatch #*101 #*01 :start1 1) - nil) - -(deftest mismatch-bit-vector.6 - (mismatch #*0110 #*0111 :start1 1 :start2 1) - 3) - -(deftest mismatch-bit-vector.7 - (mismatch #*0110 #*0111 :start1 1 :start2 1 :end1 3 :end2 3) - nil) - -(deftest mismatch-bit-vector.7a - (mismatch '(0 1 1 0) #*0111 :start1 1 :start2 1 :end1 3 :end2 3) - nil) - -(deftest mismatch-bit-vector.7b - (mismatch #*0110 '(0 1 1 1) :start1 1 :start2 1 :end1 3 :end2 3) - nil) - -(deftest mismatch-bit-vector.8 - (mismatch #*1001 #*0110 :test #'(lambda (x y) (= x (- 1 y)))) - nil) - -(deftest mismatch-bit-vector.8a - (mismatch #*1001 '(5 4 4 5) :test #'(lambda (x y) (= x (- y 4)))) - nil) - -(deftest mismatch-bit-vector.9 - (mismatch #*1001 '(5 4 17 5) :test #'(lambda (x y) (= x (- y 4)))) - 2) - -(deftest mismatch-bit-vector.9a - (mismatch '(5 4 17 5) #*1001 :test #'(lambda (x y) (= y (- x 4)))) - 2) - -(deftest mismatch-bit-vector.9b - (mismatch #*0100 #*1001 :test #'(lambda (x y) (= x (- 1 y)))) - 2) - -(deftest mismatch-bit-vector.10 - (mismatch #*1001 '(10 11 4 123) :test-not #'(lambda (x y) (= x (- y 4)))) - 2) - -(deftest mismatch-bit-vector.10a - (mismatch #*1001 '(10 11 100 123) :test-not #'(lambda (x y) (= x (- y 4)))) - nil) - -(deftest mismatch-bit-vector.11 - (mismatch #*1010 '(5 6 17 8) :key #'evenp) - nil) - -(deftest mismatch-bit-vector.11a - (mismatch '(5 6 17 8) #*1010 :key #'evenp) - nil) - -(deftest mismatch-bit-vector.11b - (mismatch #*0101 #*1010 :key #'evenp :test-not 'eql) - nil) - -(deftest mismatch-bit-vector.11c - (mismatch '(5 6 17 8) #*10101 :key #'evenp) - 4) - -(deftest mismatch-bit-vector.11d - (mismatch '(5 6 17 8 100) #*1010 :key #'evenp) - 4) - -(deftest mismatch-bit-vector.12 - (mismatch #*1010 #*1000 :key 'oddp) - 2) - -(deftest mismatch-bit-vector.12a - (mismatch #*1010 '(5 6 8 8) :key 'oddp) - 2) - -(deftest mismatch-bit-vector.12b - (mismatch '(5 6 8 8) #*1010 :key 'oddp) - 2) - -(deftest mismatch-bit-vector.13 - (mismatch #*0001 #*0001 :test 'eql) - nil) - -(deftest mismatch-bit-vector.14 - (mismatch '#*10001 #*01110 :test-not 'eql) - nil) - -(deftest mismatch-bit-vector.15 - (mismatch #*00100010100 #*00110010000) - 3) - -(deftest mismatch-bit-vector.16 - (mismatch #*00100010100 #*00110010000 :from-end t) - 9) - -(deftest mismatch-bit-vector.17 - (mismatch #*001 #*0010010 :from-end t) - 3) - -(deftest mismatch-bit-vector.18 - (mismatch #*0010010 #*001 :from-end t) - 7) - -(deftest mismatch-bit-vector.19 - (mismatch #*000 #*11111011 :from-end t :test-not 'eql) - 1) - -(deftest mismatch-bit-vector.20 - (mismatch #*1111111 '(2 3 3) :from-end t :key #'evenp) - 5) - -(deftest mismatch-bit-vector.21 - (mismatch #*111 #*00000100 :from-end t :test-not #'equal) - 1) - -(deftest mismatch-bit-vector.22 - (mismatch #*1111111 '(2 3 3) :from-end t :key 'evenp) - 5) - -(deftest mismatch-bit-vector.23 - (let ((a (make-array '(9) :initial-contents #*001011000 - :fill-pointer 5 - :element-type 'bit))) - (values - (mismatch #*00101 a) - (mismatch #*00101 a :from-end t) - (mismatch #*0010 a) - (mismatch #*001011 a) - (mismatch #*1000 a :from-end t) - (mismatch #*0010 a :from-end t))) - nil nil 4 5 4 4) - -(deftest mismatch-bit-vector.24 - (let ((m (make-array '(6) :initial-contents #*001011 - :fill-pointer 4 - :element-type 'bit)) - (a #*00101)) - (list - (mismatch m a) - (mismatch m a :from-end t) - (setf (fill-pointer m) 5) - (mismatch m a) - (mismatch m a :from-end t) - (setf (fill-pointer m) 6) - (mismatch m a) - (mismatch m a :from-end t))) - (4 4 5 nil nil 6 5 5)) - -;;; tests on strings - -(deftest mismatch-string.1 - (mismatch "" "111") - 0) - -(deftest mismatch-string.1a - (mismatch '() "111") - 0) - -(deftest mismatch-string.1b - (mismatch "" '(1 1 1)) - 0) - -(deftest mismatch-string.2 - (mismatch "1010" "") - 0) - -(deftest mismatch-string.2a - (mismatch "1010" '()) - 0) - -(deftest mismatch-string.2b - (mismatch '(1 0 1 0) "") - 0) - -(deftest mismatch-string.3 - (mismatch "101" "101") - nil) - -(deftest mismatch-string.4 - (mismatch "101" "100") - 2) - -(deftest mismatch-string.5 - (mismatch "101" "01" :start1 1) - nil) - -(deftest mismatch-string.6 - (mismatch "0110" "0111" :start1 1 :start2 1) - 3) - -(deftest mismatch-string.7 - (mismatch "0110" "0111" :start1 1 :start2 1 :end1 3 :end2 3) - nil) - -(deftest mismatch-string.7a - (mismatch '(#\0 #\1 #\1 #\0) "0111" :start1 1 :start2 1 :end1 3 :end2 3) - nil) - -(deftest mismatch-string.7b - (mismatch "0110" '(#\0 #\1 #\1 #\1) :start1 1 :start2 1 :end1 3 :end2 3) - nil) - -(deftest mismatch-string.8 - (mismatch "1001" "0110" :test #'(lambda (x y) (eql x (if (eql y #\0) - #\1 #\0)))) - nil) - -(deftest mismatch-string.8a - (mismatch "1001" '(5 4 4 5) :test #'(lambda (x y) - (setq x (read-from-string (string x))) - (= x (- y 4)))) - nil) - -(deftest mismatch-string.9 - (mismatch "1001" '(5 4 17 5) :test #'(lambda (x y) - (setq x (read-from-string (string x))) - (= x (- y 4)))) - 2) - -(deftest mismatch-string.9a - (mismatch '(5 4 17 5) "1001" :test #'(lambda (x y) - (setq y (read-from-string (string y))) - (= y (- x 4)))) - 2) - -(deftest mismatch-string.9b - (mismatch "0100" "1001" :test #'(lambda (x y) (eql x (if (eql y #\0) #\1 #\0)))) - 2) - -(deftest mismatch-string.10 - (mismatch "1001" "0049" :test-not #'(lambda (x y) - (setq x (read-from-string (string x))) - (setq y (read-from-string (string y))) - (eql x (- y 4)))) - 2) - -(deftest mismatch-string.10a - (mismatch "1001" "3333" :test-not #'(lambda (x y) - (setq x (read-from-string (string x))) - (setq y (read-from-string (string y))) - (eql x (- y 4)))) - nil) - -(deftest mismatch-string.11 - (mismatch "1010" "5678" :key #'evendigitp) - nil) - -(deftest mismatch-string.11a - (mismatch "5678" "1010" :key #'odddigitp) - nil) - -(deftest mismatch-string.11b - (mismatch "0101" "1010" :key #'evendigitp :test-not 'eql) - nil) - -(deftest mismatch-string.11c - (mismatch "5678" "10101" :key #'evendigitp) - 4) - -(deftest mismatch-string.11d - (mismatch "56122" "1010" :key #'evendigitp) - 4) - -(deftest mismatch-string.11e - (mismatch "0101" '(#\1 #\0 #\1 #\0) :key #'evendigitp :test-not 'eql) - nil) - -(deftest mismatch-string.12 - (mismatch "1010" "1000" :key 'odddigitp) - 2) - -(deftest mismatch-string.12a - (mismatch "1010" "5688" :key 'odddigitp) - 2) - -(deftest mismatch-string.12b - (mismatch '(#\5 #\6 #\8 #\8) "1010" :key 'odddigitp) - 2) - -(deftest mismatch-string.13 - (mismatch "0001" "0001" :test 'eql) - nil) - -(deftest mismatch-string.14 - (mismatch "10001" "01110" :test-not 'eql) - nil) - -(deftest mismatch-string.15 - (mismatch "00100010100" "00110010000") - 3) - -(deftest mismatch-string.16 - (mismatch "00100010100" "00110010000" :from-end t) - 9) - -(deftest mismatch-string.17 - (mismatch "001" "0010010" :from-end t) - 3) - -(deftest mismatch-string.18 - (mismatch "0010010" "001" :from-end t) - 7) - -(deftest mismatch-string.19 - (mismatch "000" "11111011" :from-end t :test-not 'eql) - 1) - -(deftest mismatch-string.20 - (mismatch "1111111" "233" :from-end t :key #'evendigitp) - 5) - -(deftest mismatch-string.20a - (mismatch "1111111" '(#\2 #\3 #\3) :from-end t :key #'evendigitp) - 5) - -(deftest mismatch-string.21 - (mismatch "111" "00000100" :from-end t :test-not #'equal) - 1) - -(deftest mismatch-string.22 - (mismatch "1111111" "233" :from-end t :key 'evendigitp) - 5) - -(deftest mismatch-string.23 - (let ((a (make-array '(9) :initial-contents "123456789" - :fill-pointer 5 - :element-type 'character))) - (values - (mismatch "12345" a) - (mismatch "12345" a :from-end t) - (mismatch "1234" a) - (mismatch "123456" a) - (mismatch "6789" a :from-end t) - (mismatch "2345" a :from-end t))) - nil nil 4 5 4 0) - -(deftest mismatch-string.24 - (let ((m (make-array '(6) :initial-contents "123456" - :fill-pointer 4 - :element-type 'character)) - (a "12345")) - (list - (mismatch m a) - (mismatch m a :from-end t) - (setf (fill-pointer m) 5) - (mismatch m a) - (mismatch m a :from-end t) - (setf (fill-pointer m) 6) - (mismatch m a) - (mismatch m a :from-end t))) - (4 4 5 nil nil 6 5 6)) - -(deftest mistmatch-string.25 - (let ((s0 "12345") - (s1 "123A") - (s2 "245")) - (do-special-strings - (s s0 nil) - (assert (null (mismatch s s0))) - (assert (null (mismatch s0 s))) - (assert (null (mismatch s s0 :from-end t))) - (assert (null (mismatch s0 s :from-end t))) - (assert (eql (mismatch s s1) 3)) - (assert (eql (mismatch s1 s) 3)) - )) - nil) - -;;; test and test-not tests - -(defharmless mismatch.test-and-test-not.1 - (mismatch '(1 2 3) '(1 2 4) :test #'eql :test-not #'eql)) - -(defharmless mismatch.test-and-test-not.2 - (mismatch '(1 2 3) '(1 2 4) :test-not #'eql :test #'eql)) - -(defharmless mismatch.test-and-test-not.3 - (mismatch #(1 2 3) #(1 2 4) :test #'eql :test-not #'eql)) - -(defharmless mismatch.test-and-test-not.4 - (mismatch #(1 2 3) #(1 2 4) :test-not #'eql :test #'eql)) - -(defharmless mismatch.test-and-test-not.5 - (mismatch "abc" "abd" :test #'eql :test-not #'eql)) - -(defharmless mismatch.test-and-test-not.6 - (mismatch "abc" "abd" :test-not #'eql :test #'eql)) - -(defharmless mismatch.test-and-test-not.7 - (mismatch #*011 #*010 :test #'eql :test-not #'eql)) - -(defharmless mismatch.test-and-test-not.8 - (mismatch #*011 #*010 :test-not #'eql :test #'eql)) - -;;; Keyword tests - -(deftest mismatch.allow-other-keys.1 - (mismatch "1234" "1244" :allow-other-keys t :bad t) - 2) - -(deftest mismatch.allow-other-keys.2 - (mismatch "1234" "1244" :bad t :allow-other-keys t) - 2) - -(deftest mismatch.allow-other-keys.3 - (mismatch "1234" "1244" :bad t :allow-other-keys t :allow-other-keys nil) - 2) - -(deftest mismatch.allow-other-keys.4 - (mismatch "1234" "1244" :allow-other-keys t :bad t - :allow-other-keys nil) - 2) - -(deftest mismatch.allow-other-keys.5 - (mismatch "1234" "1244" :allow-other-keys t - :allow-other-keys nil - :bad t) - 2) - -(deftest mismatch.keywords.6 - (mismatch "1234" "1244" :test #'equal :test (complement #'equal)) - 2) - -(deftest mismatch.allow-other-keys.7 - (mismatch "1234" "1244" :bad t :allow-other-keys t - :test (complement #'equal)) - 0) - -;;; Order of evaluation - -(deftest mismatch.order.1 - (let ((i 0) a b) - (values - (mismatch (progn (setf a (incf i)) "abcd") - (progn (setf b (incf i)) "abzd")) - i a b)) - 2 2 1 2) - -(deftest mismatch.order.2 - (let ((i 0) a b c d e f g h j) - (values - (mismatch (progn (setf a (incf i)) "abcdef") - (progn (setf b (incf i)) "abcdef") - :key (progn (setf c (incf i)) #'identity) - :test (progn (setf d (incf i)) #'equal) - :start1 (progn (setf e (incf i)) 1) - :start2 (progn (setf f (incf i)) 1) - :end1 (progn (setf g (incf i)) 4) - :end2 (progn (setf h (incf i)) 4) - :from-end (setf j (incf i))) - i a b c d e f g h j)) - nil 9 1 2 3 4 5 6 7 8 9) - -(deftest mismatch.order.3 - (let ((i 0) a b c d e f g h j) - (values - (mismatch (progn (setf a (incf i)) "abcdef") - (progn (setf b (incf i)) "abcdef") - :from-end (setf c (incf i)) - :end2 (progn (setf d (incf i)) 4) - :end1 (progn (setf e (incf i)) 4) - :start2 (progn (setf f (incf i)) 1) - :start1 (progn (setf g (incf i)) 1) - :test (progn (setf h (incf i)) #'equal) - :key (progn (setf j (incf i)) #'identity)) - i a b c d e f g h j)) - nil 9 1 2 3 4 5 6 7 8 9) - - -;;; Error cases - -(deftest mismatch.error.1 - (signals-error (mismatch) program-error) - t) - -(deftest mismatch.error.2 - (signals-error (mismatch nil) program-error) - t) - -(deftest mismatch.error.3 - (signals-error (mismatch nil nil :bad t) program-error) - t) - -(deftest mismatch.error.4 - (signals-error (mismatch nil nil :bad t :allow-other-keys nil) - program-error) - t) - -(deftest mismatch.error.5 - (signals-error (mismatch nil nil :key) program-error) - t) - -(deftest mismatch.error.6 - (signals-error (mismatch nil nil 1 2) program-error) - t) - -(deftest mismatch.error.7 - (signals-error (mismatch '(a b) '(a b) :test #'identity) program-error) - t) - -(deftest mismatch.error.8 - (signals-error (mismatch '(a b) '(a b) :test-not #'identity) program-error) - t) - -(deftest mismatch.error.9 - (signals-error (mismatch '(a b) '(a b) :key #'car) type-error) - t) - -(deftest mismatch.error.10 - (signals-error (mismatch '(a b) '(a b) :key #'cons) program-error) - t) - diff --git a/t/ansi-test/sequences/nreverse.lsp b/t/ansi-test/sequences/nreverse.lsp deleted file mode 100644 index ac2b71f..0000000 --- a/t/ansi-test/sequences/nreverse.lsp +++ /dev/null @@ -1,170 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Aug 21 00:04:57 2002 -;;;; Contains: Tests for NREVERSE - -(in-package :cl-test) - -(deftest nreverse-list.1 - (nreverse nil) - nil) - -(deftest nreverse-list.2 - (let ((x (copy-seq '(a b c)))) - (nreverse x)) - (c b a)) - -(deftest nreverse-vector.1 - (nreverse #()) - #()) - -(deftest nreverse-vector.2 - (let ((x (copy-seq #(a b c d e)))) - (nreverse x)) - #(e d c b a)) - -(deftest nreverse-vector.4 - (let ((x (make-array 0 :fill-pointer t :adjustable t))) - (nreverse x)) - #()) - -(deftest nreverse-vector.5 - (let* ((x (make-array 5 :initial-contents '(1 2 3 4 5) - :fill-pointer t :adjustable t)) - (y (nreverse x))) - (values y (equalt (type-of x) (type-of y)))) - #(5 4 3 2 1) - t) - -(deftest nreverse-vector.6 - (let* ((x (make-array 10 :initial-contents '(1 2 3 4 5 6 7 8 9 10) - :fill-pointer 5)) - (y (nreverse x))) - (values y (equalt (type-of x) (type-of y)))) - #(5 4 3 2 1) - t) - -;;; Unusual vectors - -(deftest nreverse-vector.7 - (do-special-integer-vectors - (v #(0 0 1 0 1 1) nil) - (let ((nv (nreverse v))) - (assert (= (length nv) 6)) - (assert (every #'= nv #(1 1 0 1 0 0))))) - nil) - -(deftest nreverse-vector.8 - (do-special-integer-vectors - (v #(0 0 -1 0 -1 -1 0 -1) nil) - (let ((nv (nreverse v))) - (assert (= (length nv) 8)) - (assert (every #'= nv #(-1 0 -1 -1 0 -1 0 0))))) - nil) - -(deftest nreverse-vector.9 - (let ((len 10)) - (loop for etype in '(short-float single-float double-float long-float rational) - for vals = (loop for i from 1 to len collect (coerce i etype)) - for vec = (make-array len :element-type etype :initial-contents vals) - for nvec = (nreverse vec) - unless (and (eql (length nvec) len) - (every #'eql (reverse vals) nvec)) - collect (list etype vals nvec))) - nil) - -(deftest nreverse-vector.10 - (let ((len 10)) - (loop for cetype in '(short-float single-float double-float long-float rational integer) - for etype = `(complex ,cetype) - for vals = (loop for i from 1 to len collect (complex (coerce i cetype) - (coerce (- i) cetype))) - for vec = (make-array len :element-type etype :initial-contents vals) - for nvec = (nreverse vec) - unless (and (eql (length nvec) len) - (every #'eql (reverse vals) nvec)) - collect (list etype vals nvec))) - nil) - - -;;; Bit vectors - -(deftest nreverse-bit-vector.1 - (nreverse #*) - #*) - -(deftest nreverse-bit-vector.2 - (let ((x (copy-seq #*000110110110))) - (nreverse x)) - #*011011011000) - -(deftest nreverse-bit-vector.3 - (let* ((x (make-array 10 :initial-contents '(0 0 0 1 1 0 1 0 1 0) - :fill-pointer 5 - :element-type 'bit)) - (y (nreverse x))) - y) - #*11000) - -;;; Strings - -(deftest nreverse-string.1 - (nreverse "") - "") - -(deftest nreverse-string.2 - (let ((x (copy-seq "000110110110"))) - (nreverse x)) - "011011011000") - -(deftest nreverse-string.3 - (let* ((x (make-array 10 :initial-contents "abcdefghij" - :fill-pointer 5 - :element-type 'character)) - (y (nreverse x))) - y) - "edcba") - -(deftest nreverse-string.4 - (let* ((x (make-array 10 :initial-contents "abcdefghij" - :fill-pointer 5 - :element-type 'base-char)) - (y (nreverse x))) - y) - "edcba") - -(deftest nreverse-string.5 - (do-special-strings - (s (copy-seq "12345") nil) - (let ((s2 (nreverse s))) - (assert (stringp s2)) - (assert (string= s2 "54321")) - (assert (equal (array-element-type s) (array-element-type s2))))) - nil) - -;;; Argument is evaluated only once - -(deftest nreverse.order.1 - (let ((i 0)) - (values - (nreverse (progn (incf i) (list 'a 'b 'c 'd))) - i)) - (d c b a) 1) - -;;; Error tests - -(deftest nreverse.error.1 - (check-type-error #'nreverse #'sequencep) - nil) - -(deftest nreverse.error.6 - (signals-error (nreverse) program-error) - t) - -(deftest nreverse.error.7 - (signals-error (nreverse nil nil) program-error) - t) - -(deftest nreverse.error.8 - (signals-error (locally (nreverse 'a) t) type-error) - t) diff --git a/t/ansi-test/sequences/nsubstitute-if-not.lsp b/t/ansi-test/sequences/nsubstitute-if-not.lsp deleted file mode 100644 index c37f84a..0000000 --- a/t/ansi-test/sequences/nsubstitute-if-not.lsp +++ /dev/null @@ -1,799 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Aug 31 19:00:55 2002 -;;;; Contains: Tests for NSUBSTITUTE-IF-NOT - -(in-package :cl-test) - -(deftest nsubstitute-if-not-list.1 - (nsubstitute-if-not 'b 'identity nil) - nil) - -(deftest nsubstitute-if-not-list.2 - (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eql-p 'a) x) x) - (b b b c)) - -(deftest nsubstitute-if-not-list.3 - (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eql-p 'a) x :count nil)) - (b b b c)) - -(deftest nsubstitute-if-not-list.4 - (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eql-p 'a) x :count 2)) - (b b b c)) - -(deftest nsubstitute-if-not-list.5 - (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eql-p 'a) x :count 1)) - (b b a c)) - -(deftest nsubstitute-if-not-list.6 - (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eql-p 'a) x :count 0)) - (a b a c)) - -(deftest nsubstitute-if-not-list.7 - (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eql-p 'a) x :count -1)) - (a b a c)) - -(deftest nsubstitute-if-not-list.8 - (nsubstitute-if-not 'b (is-not-eql-p 'a) nil :from-end t) - nil) - -(deftest nsubstitute-if-not-list.9 - (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eql-p 'a) x :from-end t)) - (b b b c)) - -(deftest nsubstitute-if-not-list.10 - (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eql-p 'a) x :from-end t :count nil)) - (b b b c)) - -(deftest nsubstitute-if-not-list.11 - (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eql-p 'a) x :count 2 :from-end t)) - (b b b c)) - -(deftest nsubstitute-if-not-list.12 - (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eql-p 'a) x :count 1 :from-end t)) - (a b b c)) - -(deftest nsubstitute-if-not-list.13 - (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eql-p 'a) x :count 0 :from-end t)) - (a b a c)) - -(deftest nsubstitute-if-not-list.14 - (let ((x (copy-seq '(a b a c)))) (nsubstitute-if-not 'b (is-not-eql-p 'a) x :count -1 :from-end t)) - (a b a c)) - -(deftest nsubstitute-if-not-list.15 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute-if-not 'x (is-not-eql-p 'a) x :start i :end j))) - (equal y (nconc (make-list i :initial-element 'a) - (make-list (- j i) :initial-element 'x) - (make-list (- 10 j) :initial-element 'a)))))) - t) - -(deftest nsubstitute-if-not-list.16 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute-if-not 'x (is-not-eql-p 'a) x :start i :end j :from-end t))) - (equal y (nconc (make-list i :initial-element 'a) - (make-list (- j i) :initial-element 'x) - (make-list (- 10 j) :initial-element 'a)))))) - t) - -(deftest nsubstitute-if-not-list.17 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute-if-not 'x (is-not-eql-p 'a) x :start i :end j :count c))) - (equal y (nconc (make-list i :initial-element 'a) - (make-list c :initial-element 'x) - (make-list (- 10 (+ i c)) :initial-element 'a))))))) - t) - -(deftest nsubstitute-if-not-list.18 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute-if-not 'x (is-not-eql-p 'a) x :start i :end j :count c :from-end t))) - (equal y (nconc (make-list (- j c) :initial-element 'a) - (make-list c :initial-element 'x) - (make-list (- 10 j) :initial-element 'a))))))) - t) - -;;; Tests on vectors - -(deftest nsubstitute-if-not-vector.1 - (let ((x #())) (nsubstitute-if-not 'b (is-not-eql-p 'a) x)) - #()) - -(deftest nsubstitute-if-not-vector.2 - (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eql-p 'a) x)) - #(b b b c)) - -(deftest nsubstitute-if-not-vector.3 - (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eql-p 'a) x :count nil) x) - #(b b b c)) - -(deftest nsubstitute-if-not-vector.4 - (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eql-p 'a) x :count 2)) - #(b b b c)) - -(deftest nsubstitute-if-not-vector.5 - (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eql-p 'a) x :count 1)) - #(b b a c)) - -(deftest nsubstitute-if-not-vector.6 - (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eql-p 'a) x :count 0)) - #(a b a c)) - -(deftest nsubstitute-if-not-vector.7 - (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eql-p 'a) x :count -1)) - #(a b a c)) - -(deftest nsubstitute-if-not-vector.8 - (let ((x #())) (nsubstitute-if-not 'b (is-not-eql-p 'a) x :from-end t)) - #()) - -(deftest nsubstitute-if-not-vector.9 - (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eql-p 'a) x :from-end t)) - #(b b b c)) - -(deftest nsubstitute-if-not-vector.10 - (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eql-p 'a) x :from-end t :count nil)) - #(b b b c)) - -(deftest nsubstitute-if-not-vector.11 - (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eql-p 'a) x :count 2 :from-end t)) - #(b b b c)) - -(deftest nsubstitute-if-not-vector.12 - (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eql-p 'a) x :count 1 :from-end t)) - #(a b b c)) - -(deftest nsubstitute-if-not-vector.13 - (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eql-p 'a) x :count 0 :from-end t)) - #(a b a c)) - -(deftest nsubstitute-if-not-vector.14 - (let ((x (copy-seq #(a b a c)))) (nsubstitute-if-not 'b (is-not-eql-p 'a) x :count -1 :from-end t)) - #(a b a c)) - -(deftest nsubstitute-if-not-vector.15 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute-if-not 'x (is-not-eql-p 'a) x :start i :end j))) - (equalp y (concatenate 'simple-vector - (make-array i :initial-element 'a) - (make-array (- j i) :initial-element 'x) - (make-array (- 10 j) :initial-element 'a)))))) - t) - -(deftest nsubstitute-if-not-vector.16 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute-if-not 'x (is-not-eql-p 'a) x :start i :end j :from-end t))) - (equalp y (concatenate 'simple-vector - (make-array i :initial-element 'a) - (make-array (- j i) :initial-element 'x) - (make-array (- 10 j) :initial-element 'a)))))) - t) - -(deftest nsubstitute-if-not-vector.17 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute-if-not 'x (is-not-eql-p 'a) x :start i :end j :count c))) - (equalp y (concatenate 'simple-vector - (make-array i :initial-element 'a) - (make-array c :initial-element 'x) - (make-array (- 10 (+ i c)) :initial-element 'a))))))) - t) - -(deftest nsubstitute-if-not-vector.18 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute-if-not 'x (is-not-eql-p 'a) x :start i :end j :count c :from-end t))) - (equalp y (concatenate 'simple-vector - (make-array (- j c) :initial-element 'a) - (make-array c :initial-element 'x) - (make-array (- 10 j) :initial-element 'a))))))) - t) - -(deftest nsubstitute-if-not-vector.28 - (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (nsubstitute-if-not 'z (is-not-eql-p 'a) x))) - result) - #(z b z c b)) - -(deftest nsubstitute-if-not-vector.29 - (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (nsubstitute-if-not 'z (is-not-eql-p 'a) x :from-end t))) - result) - #(z b z c b)) - -(deftest nsubstitute-if-not-vector.30 - (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (nsubstitute-if-not 'z (is-not-eql-p 'a) x :count 1))) - result) - #(z b a c b)) - -(deftest nsubstitute-if-not-vector.31 - (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (nsubstitute-if-not 'z (is-not-eql-p 'a) x - :from-end t :count 1))) - result) - #(a b z c b)) - -(deftest nsubstitute-if-not-vector.32 - (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) - (v2 (make-array '(8) :displaced-to v1 - :displaced-index-offset 3))) - (nsubstitute-if-not 'x (is-not-eql-p 'c) v2 :count 1)) - #(d a b x d a b c)) - -(deftest nsubstitute-if-not-vector.33 - (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) - (v2 (make-array '(8) :displaced-to v1 - :displaced-index-offset 3))) - (nsubstitute-if-not 'x (is-not-eql-p 'c) v2 :count 1 :from-end t)) - #(d a b c d a b x)) - -;;; Tests on strings - -(deftest nsubstitute-if-not-string.1 - (let ((x "")) (nsubstitute-if-not #\b (is-not-eql-p #\a) x)) - "") - -(deftest nsubstitute-if-not-string.2 - (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eql-p #\a) x)) - "bbbc") - -(deftest nsubstitute-if-not-string.3 - (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eql-p #\a) x :count nil)) - "bbbc") - -(deftest nsubstitute-if-not-string.4 - (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eql-p #\a) x :count 2)) - "bbbc") - -(deftest nsubstitute-if-not-string.5 - (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eql-p #\a) x :count 1)) - "bbac") - -(deftest nsubstitute-if-not-string.6 - (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eql-p #\a) x :count 0)) - "abac") - -(deftest nsubstitute-if-not-string.7 - (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eql-p #\a) x :count -1)) - "abac") - -(deftest nsubstitute-if-not-string.8 - (let ((x "")) (nsubstitute-if-not #\b (is-not-eql-p #\a) x :from-end t)) - "") - -(deftest nsubstitute-if-not-string.9 - (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eql-p #\a) x :from-end t)) - "bbbc") - -(deftest nsubstitute-if-not-string.10 - (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eql-p #\a) x :from-end t :count nil)) - "bbbc") - -(deftest nsubstitute-if-not-string.11 - (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eql-p #\a) x :count 2 :from-end t)) - "bbbc") - -(deftest nsubstitute-if-not-string.12 - (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eql-p #\a) x :count 1 :from-end t)) - "abbc") - -(deftest nsubstitute-if-not-string.13 - (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eql-p #\a) x :count 0 :from-end t)) - "abac") - -(deftest nsubstitute-if-not-string.14 - (let ((x (copy-seq "abac"))) (nsubstitute-if-not #\b (is-not-eql-p #\a) x :count -1 :from-end t)) - "abac") - -(deftest nsubstitute-if-not-string.15 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (nsubstitute-if-not #\x (is-not-eql-p #\a) x :start i :end j))) - (equalp y (concatenate 'simple-string - (make-array i :initial-element #\a) - (make-array (- j i) :initial-element #\x) - (make-array (- 10 j) :initial-element #\a)))))) - t) - -(deftest nsubstitute-if-not-string.16 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (nsubstitute-if-not #\x (is-not-eql-p #\a) x :start i :end j :from-end t))) - (equalp y (concatenate 'simple-string - (make-array i :initial-element #\a) - (make-array (- j i) :initial-element #\x) - (make-array (- 10 j) :initial-element #\a)))))) - t) - -(deftest nsubstitute-if-not-string.17 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (nsubstitute-if-not #\x (is-not-eql-p #\a) x :start i :end j :count c))) - (equalp y (concatenate 'simple-string - (make-array i :initial-element #\a) - (make-array c :initial-element #\x) - (make-array (- 10 (+ i c)) :initial-element #\a))))))) - t) - -(deftest nsubstitute-if-not-string.18 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (nsubstitute-if-not #\x (is-not-eql-p #\a) x :start i :end j :count c :from-end t))) - (equalp y (concatenate 'simple-string - (make-array (- j c) :initial-element #\a) - (make-array c :initial-element #\x) - (make-array (- 10 j) :initial-element #\a))))))) - t) - -(deftest nsubstitute-if-not-string.28 - (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (nsubstitute-if-not #\z (is-not-eql-p #\a) x))) - result) - "zbzcb") - -(deftest nsubstitute-if-not-string.29 - (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (nsubstitute-if-not #\z (is-not-eql-p #\a) x :from-end t))) - result) - "zbzcb") - -(deftest nsubstitute-if-not-string.30 - (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (nsubstitute-if-not #\z (is-not-eql-p #\a) x :count 1))) - result) - "zbacb") - -(deftest nsubstitute-if-not-string.31 - (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (nsubstitute-if-not #\z (is-not-eql-p #\a) x - :from-end t :count 1))) - result) - "abzcb") - -(deftest nsubstitute-if-not-string.32 - (do-special-strings - (s "xyzabcxyzabc" nil) - (assert (string= (nsubstitute-if-not #\! (is-not-eql-p #\a) s) "xyz!bcxyz!bc"))) - nil) - -(deftest nsubstitute-if-not-string.33 - (do-special-strings - (s "xyzabcxyzabc" nil) - (assert (string= (nsubstitute-if-not #\! (is-not-eql-p #\a) s :count 1) "xyz!bcxyzabc"))) - nil) - -(deftest nsubstitute-if-not-string.34 - (do-special-strings - (s "xyzabcxyzabc" nil) - (assert (string= (nsubstitute-if-not #\! (is-not-eql-p #\a) s :count 1 :from-end t) "xyzabcxyz!bc"))) - nil) - - -;;; Tests on bit-vectors - -(deftest nsubstitute-if-not-bit-vector.1 - (let* ((orig #*) - (x (copy-seq orig)) - (result (nsubstitute-if-not 0 (is-not-eql-p 1) x))) - result) - #*) - -(deftest nsubstitute-if-not-bit-vector.2 - (let* ((orig #*) - (x (copy-seq orig)) - (result (nsubstitute-if-not 1 (is-not-eql-p 0) x))) - result) - #*) - -(deftest nsubstitute-if-not-bit-vector.3 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if-not 0 (is-not-eql-p 1) x))) - result) - #*000000) - -(deftest nsubstitute-if-not-bit-vector.4 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if-not 1 (is-not-eql-p 0) x))) - result) - #*111111) - -(deftest nsubstitute-if-not-bit-vector.5 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if-not 1 (is-not-eql-p 0) x :start 1))) - result) - #*011111) - -(deftest nsubstitute-if-not-bit-vector.6 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if-not 0 (is-not-eql-p 1) x :start 2 :end nil))) - result) - #*010000) - -(deftest nsubstitute-if-not-bit-vector.7 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if-not 1 (is-not-eql-p 0) x :end 4))) - result) - #*111101) - -(deftest nsubstitute-if-not-bit-vector.8 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if-not 0 (is-not-eql-p 1) x :end nil))) - result) - #*000000) - -(deftest nsubstitute-if-not-bit-vector.9 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if-not 0 (is-not-eql-p 1) x :end 3))) - result) - #*000101) - -(deftest nsubstitute-if-not-bit-vector.10 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if-not 0 (is-not-eql-p 1) x :start 2 :end 4))) - result) - #*010001) - -(deftest nsubstitute-if-not-bit-vector.11 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if-not 1 (is-not-eql-p 0) x :start 2 :end 4))) - result) - #*011101) - -(deftest nsubstitute-if-not-bit-vector.12 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if-not 1 (is-not-eql-p 0) x :count 1))) - result) - #*110101) - -(deftest nsubstitute-if-not-bit-vector.13 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if-not 1 (is-not-eql-p 0) x :count 0))) - result) - #*010101) - -(deftest nsubstitute-if-not-bit-vector.14 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if-not 1 (is-not-eql-p 0) x :count -1))) - result) - #*010101) - -(deftest nsubstitute-if-not-bit-vector.15 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if-not 1 (is-not-eql-p 0) x :count 1 :from-end t))) - result) - #*010111) - -(deftest nsubstitute-if-not-bit-vector.16 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if-not 1 (is-not-eql-p 0) x :count 0 :from-end t))) - result) - #*010101) - -(deftest nsubstitute-if-not-bit-vector.17 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if-not 1 (is-not-eql-p 0) x :count -1 :from-end t))) - result) - #*010101) - -(deftest nsubstitute-if-not-bit-vector.18 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if-not 1 (is-not-eql-p 0) x :count nil))) - result) - #*111111) - -(deftest nsubstitute-if-not-bit-vector.19 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if-not 1 (is-not-eql-p 0) x :count nil :from-end t))) - result) - #*111111) - -(deftest nsubstitute-if-not-bit-vector.20 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #*0000000000) - (x (copy-seq orig)) - (y (nsubstitute-if-not 1 (is-not-eql-p 0) x :start i :end j :count c))) - (equalp y (concatenate - 'simple-bit-vector - (make-list i :initial-element 0) - (make-list c :initial-element 1) - (make-list (- 10 (+ i c)) :initial-element 0))))))) - t) - -(deftest nsubstitute-if-not-bit-vector.21 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #*1111111111) - (x (copy-seq orig)) - (y (nsubstitute-if-not 0 (is-not-eql-p 1) x :start i :end j :count c :from-end t))) - (equalp y (concatenate - 'simple-bit-vector - (make-list (- j c) :initial-element 1) - (make-list c :initial-element 0) - (make-list (- 10 j) :initial-element 1))))))) - t) - - -;;; More tests - -(deftest nsubstitute-if-not-list.24 - (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (nsubstitute-if-not '(a 10) (is-not-eql-p 'a) x :key #'car))) - result) - ((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) - -(deftest nsubstitute-if-not-list.25 - (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (nsubstitute-if-not '(a 10) (is-not-eql-p 'a) x - :key #'car :start 1 :end 5))) - result) - ((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) - -(deftest nsubstitute-if-not-vector.24 - (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (nsubstitute-if-not '(a 10) (is-not-eql-p 'a) x :key #'car))) - result) - #((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) - -(deftest nsubstitute-if-not-vector.25 - (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (nsubstitute-if-not '(a 10) (is-not-eql-p 'a) x :key #'car :start 1 :end 5))) - result) - #((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) - -(deftest nsubstitute-if-not-string.24 - (let* ((orig "0102342015") - (x (copy-seq orig)) - (result (nsubstitute-if-not #\a (is-not-eql-p #\1) x :key #'nextdigit))) - result) - "a1a2342a15") - -(deftest nsubstitute-if-not-string.25 - (let* ((orig "0102342015") - (x (copy-seq orig)) - (result (nsubstitute-if-not #\a (is-not-eql-p #\1) x :key #'nextdigit :start 1 :end 6))) - result) - "01a2342015") - -(deftest nsubstitute-if-not-bit-vector.26 - (let* ((orig #*00111001011010110) - (x (copy-seq orig)) - (result (nsubstitute-if-not 1 (is-not-eql-p 1) x :key #'1+))) - result) - #*11111111111111111) - -(deftest nsubstitute-if-not-bit-vector.27 - (let* ((orig #*00111001011010110) - (x (copy-seq orig)) - (result (nsubstitute-if-not 1 (is-not-eql-p 1) x :key #'1+ :start 1 :end 10))) - result) - #*01111111111010110) - -(deftest nsubstitute-if-not-bit-vector.30 - (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (nsubstitute-if-not 1 #'onep x))) - result) - #*11111) - -(deftest nsubstitute-if-not-bit-vector.31 - (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (nsubstitute-if-not 1 #'onep x :from-end t))) - result) - #*11111) - -(deftest nsubstitute-if-not-bit-vector.32 - (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (nsubstitute-if-not 1 #'onep x :count 1))) - result) - #*11011) - -(deftest nsubstitute-if-not-bit-vector.33 - (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (nsubstitute-if-not 1 #'onep x :from-end t :count 1))) - result) - #*01111) - -(deftest nsubstitute-if-not.order.1 - (let ((i 0) a b c d e f g h) - (values - (nsubstitute-if-not - (progn (setf a (incf i)) 'a) - (progn (setf b (incf i)) #'identity) - (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) - :count (progn (setf d (incf i)) 2) - :start (progn (setf e (incf i)) 0) - :end (progn (setf f (incf i)) 7) - :key (progn (setf g (incf i)) #'identity) - :from-end (setf h (incf i)) - ) - i a b c d e f g h)) - (nil 1 2 a 3 4 a 5) - 8 1 2 3 4 5 6 7 8) - -(deftest nsubstitute-if-not.order.2 - (let ((i 0) a b c d e f g h) - (values - (nsubstitute-if-not - (progn (setf a (incf i)) 'a) - (progn (setf b (incf i)) #'identity) - (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) - :from-end (setf h (incf i)) - :key (progn (setf g (incf i)) #'identity) - :end (progn (setf f (incf i)) 7) - :start (progn (setf e (incf i)) 0) - :count (progn (setf d (incf i)) 2) - ) - i a b c d e f g h)) - (nil 1 2 a 3 4 a 5) - 8 1 2 3 8 7 6 5 4) - - -;;; Keyword tests - -(deftest nsubstitute-if-not.allow-other-keys.1 - (nsubstitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) - :allow-other-keys t :bad t) - (a a 0 a a 0 a)) - -(deftest nsubstitute-if-not.allow-other-keys.2 - (nsubstitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) - :bad t :allow-other-keys t) - (a a 0 a a 0 a)) - -(deftest nsubstitute-if-not.allow-other-keys.3 - (nsubstitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t - :allow-other-keys nil :bad t) - (a a 0 a a 0 a)) - -(deftest nsubstitute-if-not.allow-other-keys.4 - (nsubstitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :bad t - :allow-other-keys t :allow-other-keys nil) - (a a 0 a a 0 a)) - -(deftest nsubstitute-if-not.allow-other-keys.5 - (nsubstitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) - :allow-other-keys t :key #'1-) - (1 a a a 1 a a)) - -(deftest nsubstitute-if-not.keywords.6 - (nsubstitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) - :key #'1- :key #'identity) - (1 a a a 1 a a)) - -(deftest nsubstitute-if-not.allow-other-keys.7 - (nsubstitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t - :bad t :allow-other-keys nil) - (a a 0 a a 0 a)) - -(deftest nsubstitute-if-not.allow-other-keys.8 - (nsubstitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys nil) - (a a 0 a a 0 a)) - - -;;; Error cases - -(deftest nsubstitute-if-not.error.1 - (signals-error (nsubstitute-if-not) program-error) - t) - -(deftest nsubstitute-if-not.error.2 - (signals-error (nsubstitute-if-not 'a) program-error) - t) - -(deftest nsubstitute-if-not.error.3 - (signals-error (nsubstitute-if-not 'a #'null) program-error) - t) - -(deftest nsubstitute-if-not.error.4 - (signals-error (nsubstitute-if-not 'a #'null nil 'bad t) program-error) - t) - -(deftest nsubstitute-if-not.error.5 - (signals-error (nsubstitute-if-not 'a #'null nil - 'bad t :allow-other-keys nil) - program-error) - t) - -(deftest nsubstitute-if-not.error.6 - (signals-error (nsubstitute-if-not 'a #'null nil :key) program-error) - t) - -(deftest nsubstitute-if-not.error.7 - (signals-error (nsubstitute-if-not 'a #'null nil 1 2) program-error) - t) - -(deftest nsubstitute-if-not.error.8 - (signals-error (nsubstitute-if-not 'a #'cons (list 'a 'b 'c)) program-error) - t) - -(deftest nsubstitute-if-not.error.9 - (signals-error (nsubstitute-if-not 'a #'car (list 'a 'b 'c)) type-error) - t) - -(deftest nsubstitute-if-not.error.10 - (signals-error (nsubstitute-if-not 'a #'identity (list 'a 'b 'c) - :key #'car) - type-error) - t) - -(deftest nsubstitute-if-not.error.11 - (signals-error (nsubstitute-if-not 'a #'identity (list 'a 'b 'c) - :key #'cons) - program-error) - t) - -(deftest nsubstitute-if-not.error.12 - (check-type-error #'(lambda (x) (nsubstitute-if-not 1 #'null x)) #'sequencep) - nil) diff --git a/t/ansi-test/sequences/nsubstitute-if.lsp b/t/ansi-test/sequences/nsubstitute-if.lsp deleted file mode 100644 index 1f36de7..0000000 --- a/t/ansi-test/sequences/nsubstitute-if.lsp +++ /dev/null @@ -1,797 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Aug 31 18:56:41 2002 -;;;; Contains: Tests for NSUBSTITUTE-IF - -(in-package :cl-test) - -(deftest nsubstitute-if-list.1 - (nsubstitute-if 'b 'identity nil) - nil) - -(deftest nsubstitute-if-list.2 - (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eql-p 'a) x) x) - (b b b c)) - -(deftest nsubstitute-if-list.3 - (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eql-p 'a) x :count nil)) - (b b b c)) - -(deftest nsubstitute-if-list.4 - (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eql-p 'a) x :count 2)) - (b b b c)) - -(deftest nsubstitute-if-list.5 - (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eql-p 'a) x :count 1)) - (b b a c)) - -(deftest nsubstitute-if-list.6 - (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eql-p 'a) x :count 0)) - (a b a c)) - -(deftest nsubstitute-if-list.7 - (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eql-p 'a) x :count -1)) - (a b a c)) - -(deftest nsubstitute-if-list.8 - (nsubstitute-if 'b (is-eql-p 'a) nil :from-end t) - nil) - -(deftest nsubstitute-if-list.9 - (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eql-p 'a) x :from-end t)) - (b b b c)) - -(deftest nsubstitute-if-list.10 - (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eql-p 'a) x :from-end t :count nil)) - (b b b c)) - -(deftest nsubstitute-if-list.11 - (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eql-p 'a) x :count 2 :from-end t)) - (b b b c)) - -(deftest nsubstitute-if-list.12 - (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eql-p 'a) x :count 1 :from-end t)) - (a b b c)) - -(deftest nsubstitute-if-list.13 - (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eql-p 'a) x :count 0 :from-end t)) - (a b a c)) - -(deftest nsubstitute-if-list.14 - (let ((x (copy-seq '(a b a c)))) (nsubstitute-if 'b (is-eql-p 'a) x :count -1 :from-end t)) - (a b a c)) - -(deftest nsubstitute-if-list.15 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute-if 'x (is-eql-p 'a) x :start i :end j))) - (equal y (nconc (make-list i :initial-element 'a) - (make-list (- j i) :initial-element 'x) - (make-list (- 10 j) :initial-element 'a)))))) - t) - -(deftest nsubstitute-if-list.16 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute-if 'x (is-eql-p 'a) x :start i :end j :from-end t))) - (equal y (nconc (make-list i :initial-element 'a) - (make-list (- j i) :initial-element 'x) - (make-list (- 10 j) :initial-element 'a)))))) - t) - -(deftest nsubstitute-if-list.17 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute-if 'x (is-eql-p 'a) x :start i :end j :count c))) - (equal y (nconc (make-list i :initial-element 'a) - (make-list c :initial-element 'x) - (make-list (- 10 (+ i c)) :initial-element 'a))))))) - t) - -(deftest nsubstitute-if-list.18 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute-if 'x (is-eql-p 'a) x :start i :end j :count c :from-end t))) - (equal y (nconc (make-list (- j c) :initial-element 'a) - (make-list c :initial-element 'x) - (make-list (- 10 j) :initial-element 'a))))))) - t) - -;;; Tests on vectors - -(deftest nsubstitute-if-vector.1 - (let ((x #())) (nsubstitute-if 'b (is-eql-p 'a) x)) - #()) - -(deftest nsubstitute-if-vector.2 - (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eql-p 'a) x)) - #(b b b c)) - -(deftest nsubstitute-if-vector.3 - (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eql-p 'a) x :count nil) x) - #(b b b c)) - -(deftest nsubstitute-if-vector.4 - (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eql-p 'a) x :count 2)) - #(b b b c)) - -(deftest nsubstitute-if-vector.5 - (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eql-p 'a) x :count 1)) - #(b b a c)) - -(deftest nsubstitute-if-vector.6 - (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eql-p 'a) x :count 0)) - #(a b a c)) - -(deftest nsubstitute-if-vector.7 - (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eql-p 'a) x :count -1)) - #(a b a c)) - -(deftest nsubstitute-if-vector.8 - (let ((x #())) (nsubstitute-if 'b (is-eql-p 'a) x :from-end t)) - #()) - -(deftest nsubstitute-if-vector.9 - (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eql-p 'a) x :from-end t)) - #(b b b c)) - -(deftest nsubstitute-if-vector.10 - (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eql-p 'a) x :from-end t :count nil)) - #(b b b c)) - -(deftest nsubstitute-if-vector.11 - (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eql-p 'a) x :count 2 :from-end t)) - #(b b b c)) - -(deftest nsubstitute-if-vector.12 - (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eql-p 'a) x :count 1 :from-end t)) - #(a b b c)) - -(deftest nsubstitute-if-vector.13 - (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eql-p 'a) x :count 0 :from-end t)) - #(a b a c)) - -(deftest nsubstitute-if-vector.14 - (let ((x (copy-seq #(a b a c)))) (nsubstitute-if 'b (is-eql-p 'a) x :count -1 :from-end t)) - #(a b a c)) - -(deftest nsubstitute-if-vector.15 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute-if 'x (is-eql-p 'a) x :start i :end j))) - (equalp y (concatenate 'simple-vector - (make-array i :initial-element 'a) - (make-array (- j i) :initial-element 'x) - (make-array (- 10 j) :initial-element 'a)))))) - t) - -(deftest nsubstitute-if-vector.16 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute-if 'x (is-eql-p 'a) x :start i :end j :from-end t))) - (equalp y (concatenate 'simple-vector - (make-array i :initial-element 'a) - (make-array (- j i) :initial-element 'x) - (make-array (- 10 j) :initial-element 'a)))))) - t) - -(deftest nsubstitute-if-vector.17 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute-if 'x (is-eql-p 'a) x :start i :end j :count c))) - (equalp y (concatenate 'simple-vector - (make-array i :initial-element 'a) - (make-array c :initial-element 'x) - (make-array (- 10 (+ i c)) :initial-element 'a))))))) - t) - -(deftest nsubstitute-if-vector.18 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute-if 'x (is-eql-p 'a) x :start i :end j :count c :from-end t))) - (equalp y (concatenate 'simple-vector - (make-array (- j c) :initial-element 'a) - (make-array c :initial-element 'x) - (make-array (- 10 j) :initial-element 'a))))))) - t) - -(deftest nsubstitute-if-vector.28 - (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (nsubstitute-if 'z (is-eql-p 'a) x))) - result) - #(z b z c b)) - -(deftest nsubstitute-if-vector.29 - (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (nsubstitute-if 'z (is-eql-p 'a) x :from-end t))) - result) - #(z b z c b)) - -(deftest nsubstitute-if-vector.30 - (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (nsubstitute-if 'z (is-eql-p 'a) x :count 1))) - result) - #(z b a c b)) - -(deftest nsubstitute-if-vector.31 - (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (nsubstitute-if 'z (is-eql-p 'a) x :from-end t :count 1))) - result) - #(a b z c b)) - -(deftest nsubstitute-if-vector.32 - (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) - (v2 (make-array '(8) :displaced-to v1 - :displaced-index-offset 3))) - (values - (nsubstitute-if 'x (is-eql-p 'c) v2 :count 1) - v1)) - #(d a b x d a b c) - #(a b c d a b x d a b c d a b c d)) - -(deftest nsubstitute-if-vector.33 - (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) - (v2 (make-array '(8) :displaced-to v1 - :displaced-index-offset 3))) - (values - (nsubstitute-if 'x (is-eql-p 'c) v2 :count 1 :from-end t) - v1)) - #(d a b c d a b x) - #(a b c d a b c d a b x d a b c d)) - -;;; Tests on strings - -(deftest nsubstitute-if-string.1 - (let ((x "")) (nsubstitute-if #\b (is-eql-p #\a) x)) - "") - -(deftest nsubstitute-if-string.2 - (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eql-p #\a) x)) - "bbbc") - -(deftest nsubstitute-if-string.3 - (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eql-p #\a) x :count nil)) - "bbbc") - -(deftest nsubstitute-if-string.4 - (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eql-p #\a) x :count 2)) - "bbbc") - -(deftest nsubstitute-if-string.5 - (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eql-p #\a) x :count 1)) - "bbac") - -(deftest nsubstitute-if-string.6 - (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eql-p #\a) x :count 0)) - "abac") - -(deftest nsubstitute-if-string.7 - (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eql-p #\a) x :count -1)) - "abac") - -(deftest nsubstitute-if-string.8 - (let ((x "")) (nsubstitute-if #\b (is-eql-p #\a) x :from-end t)) - "") - -(deftest nsubstitute-if-string.9 - (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eql-p #\a) x :from-end t)) - "bbbc") - -(deftest nsubstitute-if-string.10 - (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eql-p #\a) x :from-end t :count nil)) - "bbbc") - -(deftest nsubstitute-if-string.11 - (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eql-p #\a) x :count 2 :from-end t)) - "bbbc") - -(deftest nsubstitute-if-string.12 - (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eql-p #\a) x :count 1 :from-end t)) - "abbc") - -(deftest nsubstitute-if-string.13 - (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eql-p #\a) x :count 0 :from-end t)) - "abac") - -(deftest nsubstitute-if-string.14 - (let ((x (copy-seq "abac"))) (nsubstitute-if #\b (is-eql-p #\a) x :count -1 :from-end t)) - "abac") - -(deftest nsubstitute-if-string.15 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (nsubstitute-if #\x (is-eql-p #\a) x :start i :end j))) - (equalp y (concatenate 'simple-string - (make-array i :initial-element #\a) - (make-array (- j i) :initial-element #\x) - (make-array (- 10 j) :initial-element #\a)))))) - t) - -(deftest nsubstitute-if-string.16 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (nsubstitute-if #\x (is-eql-p #\a) x :start i :end j :from-end t))) - (equalp y (concatenate 'simple-string - (make-array i :initial-element #\a) - (make-array (- j i) :initial-element #\x) - (make-array (- 10 j) :initial-element #\a)))))) - t) - -(deftest nsubstitute-if-string.17 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (nsubstitute-if #\x (is-eql-p #\a) x :start i :end j :count c))) - (equalp y (concatenate 'simple-string - (make-array i :initial-element #\a) - (make-array c :initial-element #\x) - (make-array (- 10 (+ i c)) :initial-element #\a))))))) - t) - -(deftest nsubstitute-if-string.18 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (nsubstitute-if #\x (is-eql-p #\a) x :start i :end j :count c :from-end t))) - (equalp y (concatenate 'simple-string - (make-array (- j c) :initial-element #\a) - (make-array c :initial-element #\x) - (make-array (- 10 j) :initial-element #\a))))))) - t) - -(deftest nsubstitute-if-string.28 - (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (nsubstitute-if #\z (is-eql-p #\a) x))) - result) - "zbzcb") - -(deftest nsubstitute-if-string.29 - (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (nsubstitute-if #\z (is-eql-p #\a) x :from-end t))) - result) - "zbzcb") - -(deftest nsubstitute-if-string.30 - (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (nsubstitute-if #\z (is-eql-p #\a) x :count 1))) - result) - "zbacb") - -(deftest nsubstitute-if-string.31 - (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (nsubstitute-if #\z (is-eql-p #\a) x :from-end t :count 1))) - result) - "abzcb") - -(deftest nsubstitute-if-string.32 - (do-special-strings - (s "xyzabcxyzabc" nil) - (assert (string= (nsubstitute-if #\! (is-eql-p #\a) s) "xyz!bcxyz!bc")) - (assert (string= s "xyz!bcxyz!bc"))) - nil) - -(deftest nsubstitute-if-string.33 - (do-special-strings - (s "xyzabcxyzabc" nil) - (assert (string= (nsubstitute-if #\! (is-eql-p #\a) s :count 1) "xyz!bcxyzabc")) - (assert (string= s "xyz!bcxyzabc"))) - nil) - -(deftest nsubstitute-if-string.34 - (do-special-strings - (s "xyzabcxyzabc" nil) - (assert (string= (nsubstitute-if #\! (is-eql-p #\a) s :count 1 :from-end t) "xyzabcxyz!bc")) - (assert (string= s "xyzabcxyz!bc"))) - nil) - - -;;; Tests on bit-vectors - -(deftest nsubstitute-if-bit-vector.1 - (let* ((orig #*) - (x (copy-seq orig)) - (result (nsubstitute-if 0 (is-eql-p 1) x))) - result) - #*) - -(deftest nsubstitute-if-bit-vector.2 - (let* ((orig #*) - (x (copy-seq orig)) - (result (nsubstitute-if 1 (is-eql-p 0) x))) - result) - #*) - -(deftest nsubstitute-if-bit-vector.3 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if 0 (is-eql-p 1) x))) - result) - #*000000) - -(deftest nsubstitute-if-bit-vector.4 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if 1 (is-eql-p 0) x))) - result) - #*111111) - -(deftest nsubstitute-if-bit-vector.5 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if 1 (is-eql-p 0) x :start 1))) - result) - #*011111) - -(deftest nsubstitute-if-bit-vector.6 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if 0 (is-eql-p 1) x :start 2 :end nil))) - result) - #*010000) - -(deftest nsubstitute-if-bit-vector.7 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if 1 (is-eql-p 0) x :end 4))) - result) - #*111101) - -(deftest nsubstitute-if-bit-vector.8 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if 0 (is-eql-p 1) x :end nil))) - result) - #*000000) - -(deftest nsubstitute-if-bit-vector.9 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if 0 (is-eql-p 1) x :end 3))) - result) - #*000101) - -(deftest nsubstitute-if-bit-vector.10 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if 0 (is-eql-p 1) x :start 2 :end 4))) - result) - #*010001) - -(deftest nsubstitute-if-bit-vector.11 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if 1 (is-eql-p 0) x :start 2 :end 4))) - result) - #*011101) - -(deftest nsubstitute-if-bit-vector.12 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if 1 (is-eql-p 0) x :count 1))) - result) - #*110101) - -(deftest nsubstitute-if-bit-vector.13 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if 1 (is-eql-p 0) x :count 0))) - result) - #*010101) - -(deftest nsubstitute-if-bit-vector.14 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if 1 (is-eql-p 0) x :count -1))) - result) - #*010101) - -(deftest nsubstitute-if-bit-vector.15 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if 1 (is-eql-p 0) x :count 1 :from-end t))) - result) - #*010111) - -(deftest nsubstitute-if-bit-vector.16 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if 1 (is-eql-p 0) x :count 0 :from-end t))) - result) - #*010101) - -(deftest nsubstitute-if-bit-vector.17 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if 1 (is-eql-p 0) x :count -1 :from-end t))) - result) - #*010101) - -(deftest nsubstitute-if-bit-vector.18 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if 1 (is-eql-p 0) x :count nil))) - result) - #*111111) - -(deftest nsubstitute-if-bit-vector.19 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if 1 (is-eql-p 0) x :count nil :from-end t))) - result) - #*111111) - -(deftest nsubstitute-if-bit-vector.20 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #*0000000000) - (x (copy-seq orig)) - (y (nsubstitute-if 1 (is-eql-p 0) x :start i :end j :count c))) - (equalp y (concatenate - 'simple-bit-vector - (make-list i :initial-element 0) - (make-list c :initial-element 1) - (make-list (- 10 (+ i c)) :initial-element 0))))))) - t) - -(deftest nsubstitute-if-bit-vector.21 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #*1111111111) - (x (copy-seq orig)) - (y (nsubstitute-if 0 (is-eql-p 1) x :start i :end j :count c :from-end t))) - (equalp y (concatenate - 'simple-bit-vector - (make-list (- j c) :initial-element 1) - (make-list c :initial-element 0) - (make-list (- 10 j) :initial-element 1))))))) - t) - -;;; More tests - -(deftest nsubstitute-if-list.24 - (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (nsubstitute-if '(a 10) (is-eql-p 'a) x :key #'car))) - result) - ((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) - -(deftest nsubstitute-if-list.25 - (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (nsubstitute-if '(a 10) (is-eql-p 'a) x - :key #'car :start 1 :end 5))) - result) - ((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) - -(deftest nsubstitute-if-vector.24 - (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (nsubstitute-if '(a 10) (is-eql-p 'a) x :key #'car))) - result) - #((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) - -(deftest nsubstitute-if-vector.25 - (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (nsubstitute-if '(a 10) (is-eql-p 'a) x :key #'car :start 1 :end 5))) - result) - #((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) - -(deftest nsubstitute-if-string.24 - (let* ((orig "0102342015") - (x (copy-seq orig)) - (result (nsubstitute-if #\a (is-eql-p #\1) x :key #'nextdigit))) - result) - "a1a2342a15") - -(deftest nsubstitute-if-string.25 - (let* ((orig "0102342015") - (x (copy-seq orig)) - (result (nsubstitute-if #\a (is-eql-p #\1) x :key #'nextdigit :start 1 :end 6))) - result) - "01a2342015") - -(deftest nsubstitute-if-bit-vector.26 - (let* ((orig #*00111001011010110) - (x (copy-seq orig)) - (result (nsubstitute-if 1 (is-eql-p 1) x :key #'1+))) - result) - #*11111111111111111) - -(deftest nsubstitute-if-bit-vector.27 - (let* ((orig #*00111001011010110) - (x (copy-seq orig)) - (result (nsubstitute-if 1 (is-eql-p 1) x :key #'1+ :start 1 :end 10))) - result) - #*01111111111010110) - -(deftest nsubstitute-if-bit-vector.30 - (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (nsubstitute-if 1 #'zerop x))) - result) - #*11111) - -(deftest nsubstitute-if-bit-vector.31 - (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (nsubstitute-if 1 #'zerop x :from-end t))) - result) - #*11111) - -(deftest nsubstitute-if-bit-vector.32 - (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (nsubstitute-if 1 #'zerop x :count 1))) - result) - #*11011) - -(deftest nsubstitute-if-bit-vector.33 - (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (nsubstitute-if 1 #'zerop x :from-end t :count 1))) - result) - #*01111) - -(deftest nsubstitute-if.order.1 - (let ((i 0) a b c d e f g h) - (values - (nsubstitute-if - (progn (setf a (incf i)) 'a) - (progn (setf b (incf i)) #'null) - (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) - :count (progn (setf d (incf i)) 2) - :start (progn (setf e (incf i)) 0) - :end (progn (setf f (incf i)) 7) - :key (progn (setf g (incf i)) #'identity) - :from-end (setf h (incf i)) - ) - i a b c d e f g h)) - (nil 1 2 a 3 4 a 5) - 8 1 2 3 4 5 6 7 8) - -(deftest nsubstitute-if.order.2 - (let ((i 0) a b c d e f g h) - (values - (nsubstitute-if - (progn (setf a (incf i)) 'a) - (progn (setf b (incf i)) #'null) - (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) - :from-end (setf h (incf i)) - :key (progn (setf g (incf i)) #'identity) - :end (progn (setf f (incf i)) 7) - :start (progn (setf e (incf i)) 0) - :count (progn (setf d (incf i)) 2) - ) - i a b c d e f g h)) - (nil 1 2 a 3 4 a 5) - 8 1 2 3 8 7 6 5 4) - - -;;; Keyword tests - -(deftest nsubstitute-if.allow-other-keys.1 - (nsubstitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t :bad t) - (1 2 a 3 1 a 3)) - -(deftest nsubstitute-if.allow-other-keys.2 - (nsubstitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :bad t :allow-other-keys t) - (1 2 a 3 1 a 3)) - -(deftest nsubstitute-if.allow-other-keys.3 - (nsubstitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t - :allow-other-keys nil :bad t) - (1 2 a 3 1 a 3)) - -(deftest nsubstitute-if.allow-other-keys.4 - (nsubstitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :bad t - :allow-other-keys t :allow-other-keys nil) - (1 2 a 3 1 a 3)) - -(deftest nsubstitute-if.allow-other-keys.5 - (nsubstitute-if 'a #'zerop (list 1 2 0 3 1 0 3) - :allow-other-keys t :key #'1-) - (a 2 0 3 a 0 3)) - -(deftest nsubstitute-if.keywords.6 - (nsubstitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :key #'1- :key #'identity) - (a 2 0 3 a 0 3)) - -(deftest nsubstitute-if.allow-other-keys.7 - (nsubstitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t - :bad t :allow-other-keys nil) - (1 2 a 3 1 a 3)) - -(deftest nsubstitute-if.allow-other-keys.8 - (nsubstitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys nil) - (1 2 a 3 1 a 3)) - -;;; Error cases - -(deftest nsubstitute-if.error.1 - (signals-error (nsubstitute-if) program-error) - t) - -(deftest nsubstitute-if.error.2 - (signals-error (nsubstitute-if 'a) program-error) - t) - -(deftest nsubstitute-if.error.3 - (signals-error (nsubstitute-if 'a #'null) program-error) - t) - -(deftest nsubstitute-if.error.4 - (signals-error (nsubstitute-if 'a #'null nil 'bad t) program-error) - t) - -(deftest nsubstitute-if.error.5 - (signals-error (nsubstitute-if 'a #'null nil 'bad t :allow-other-keys nil) program-error) - t) - -(deftest nsubstitute-if.error.6 - (signals-error (nsubstitute-if 'a #'null nil :key) program-error) - t) - -(deftest nsubstitute-if.error.7 - (signals-error (nsubstitute-if 'a #'null nil 1 2) program-error) - t) - -(deftest nsubstitute-if.error.8 - (signals-error (nsubstitute-if 'a #'cons (list 'a 'b 'c)) program-error) - t) - -(deftest nsubstitute-if.error.9 - (signals-error (nsubstitute-if 'a #'car (list 'a 'b 'c)) type-error) - t) - -(deftest nsubstitute-if.error.10 - (signals-error (nsubstitute-if 'a #'identity (list 'a 'b 'c) - :key #'car) type-error) - t) - -(deftest nsubstitute-if.error.11 - (signals-error (nsubstitute-if 'a #'identity (list 'a 'b 'c) - :key #'cons) program-error) - t) - -(deftest nsubstitute-if.error.12 - (check-type-error #'(lambda (x) (nsubstitute-if 0 #'identity x)) #'sequencep) - nil) diff --git a/t/ansi-test/sequences/nsubstitute.lsp b/t/ansi-test/sequences/nsubstitute.lsp deleted file mode 100644 index d84b099..0000000 --- a/t/ansi-test/sequences/nsubstitute.lsp +++ /dev/null @@ -1,1029 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Aug 31 16:56:48 2002 -;;;; Contains: Tests for NSUBSTITUTE - -(in-package :cl-test) - -(deftest nsubstitute-list.1 - (nsubstitute 'b 'a nil) - nil) - -(deftest nsubstitute-list.2 - (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x) x) - (b b b c)) - -(deftest nsubstitute-list.3 - (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :count nil)) - (b b b c)) - -(deftest nsubstitute-list.4 - (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :count 2)) - (b b b c)) - -(deftest nsubstitute-list.5 - (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :count 1)) - (b b a c)) - -(deftest nsubstitute-list.6 - (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :count 0)) - (a b a c)) - -(deftest nsubstitute-list.7 - (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :count -1)) - (a b a c)) - -(deftest nsubstitute-list.8 - (nsubstitute 'b 'a nil :from-end t) - nil) - -(deftest nsubstitute-list.9 - (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :from-end t)) - (b b b c)) - -(deftest nsubstitute-list.10 - (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :from-end t :count nil)) - (b b b c)) - -(deftest nsubstitute-list.11 - (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :count 2 :from-end t)) - (b b b c)) - -(deftest nsubstitute-list.12 - (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :count 1 :from-end t)) - (a b b c)) - -(deftest nsubstitute-list.13 - (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :count 0 :from-end t)) - (a b a c)) - -(deftest nsubstitute-list.14 - (let ((x (copy-seq '(a b a c)))) (nsubstitute 'b 'a x :count -1 :from-end t)) - (a b a c)) - -(deftest nsubstitute-list.15 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute 'x 'a x :start i :end j))) - (equal y (nconc (make-list i :initial-element 'a) - (make-list (- j i) :initial-element 'x) - (make-list (- 10 j) :initial-element 'a)))))) - t) - -(deftest nsubstitute-list.16 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute 'x 'a x :start i :end j :from-end t))) - (equal y (nconc (make-list i :initial-element 'a) - (make-list (- j i) :initial-element 'x) - (make-list (- 10 j) :initial-element 'a)))))) - t) - -(deftest nsubstitute-list.17 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute 'x 'a x :start i :end j :count c))) - (equal y (nconc (make-list i :initial-element 'a) - (make-list c :initial-element 'x) - (make-list (- 10 (+ i c)) :initial-element 'a))))))) - t) - -(deftest nsubstitute-list.18 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute 'x 'a x :start i :end j :count c :from-end t))) - (equal y (nconc (make-list (- j c) :initial-element 'a) - (make-list c :initial-element 'x) - (make-list (- 10 j) :initial-element 'a))))))) - t) - -(deftest nsubstitute-list.19 - (let* ((orig '(1 2 3 4 5 6 7 8 9)) - (x (copy-seq orig)) - (result (nsubstitute 'x 5 x :test #'(lambda (a b) (<= (abs (- a b)) 2))))) - result) - (1 2 x x x x x 8 9)) - -(deftest nsubstitute-list.20 - (let* ((orig '(1 2 3 4 5 6 7 8 9)) - (x (copy-seq orig)) - (c -4) - (result (nsubstitute 'x 5 x :test #'(lambda (a b) (incf c 2) (= (+ b c) a))))) - result) - (1 2 x 4 5 6 7 8 9)) - - -(deftest nsubstitute-list.21 - (let* ((orig '(1 2 3 4 5 6 7 8 9)) - (x (copy-seq orig)) - (c 5) - (result (nsubstitute 'x 9 x :test #'(lambda (a b) (incf c -2) (= (+ b c) a)) - :from-end t))) - result) - (1 2 3 4 5 6 7 x 9)) - -(deftest nsubstitute-list.22 - (let* ((orig '(1 2 3 4 5 6 7 8 9)) - (x (copy-seq orig)) - (c -4) - (result (nsubstitute 'x 5 x :test-not #'(lambda (a b) (incf c 2) (/= (+ b c) a))))) - result) - (1 2 x 4 5 6 7 8 9)) - - -(deftest nsubstitute-list.23 - (let* ((orig '(1 2 3 4 5 6 7 8 9)) - (x (copy-seq orig)) - (c 5) - (result (nsubstitute 'x 9 x :test-not #'(lambda (a b) (incf c -2) (/= (+ b c) a)) - :from-end t))) - result) - (1 2 3 4 5 6 7 x 9)) - -;;; Tests on vectors - -(deftest nsubstitute-vector.1 - (let ((x #())) (values (nsubstitute 'b 'a x) x)) - #() #()) - -(deftest nsubstitute-vector.2 - (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x)) - #(b b b c)) - -(deftest nsubstitute-vector.3 - (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :count nil) x) - #(b b b c)) - -(deftest nsubstitute-vector.4 - (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :count 2)) - #(b b b c)) - -(deftest nsubstitute-vector.5 - (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :count 1)) - #(b b a c)) - -(deftest nsubstitute-vector.6 - (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :count 0)) - #(a b a c)) - -(deftest nsubstitute-vector.7 - (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :count -1)) - #(a b a c)) - -(deftest nsubstitute-vector.8 - (let ((x #())) (nsubstitute 'b 'a x :from-end t)) - #()) - -(deftest nsubstitute-vector.9 - (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :from-end t)) - #(b b b c)) - -(deftest nsubstitute-vector.10 - (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :from-end t :count nil)) - #(b b b c)) - -(deftest nsubstitute-vector.11 - (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :count 2 :from-end t)) - #(b b b c)) - -(deftest nsubstitute-vector.12 - (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :count 1 :from-end t)) - #(a b b c)) - -(deftest nsubstitute-vector.13 - (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :count 0 :from-end t)) - #(a b a c)) - -(deftest nsubstitute-vector.14 - (let ((x (copy-seq #(a b a c)))) (nsubstitute 'b 'a x :count -1 :from-end t)) - #(a b a c)) - -(deftest nsubstitute-vector.15 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute 'x 'a x :start i :end j))) - (equalp y (concatenate 'simple-vector - (make-array i :initial-element 'a) - (make-array (- j i) :initial-element 'x) - (make-array (- 10 j) :initial-element 'a)))))) - t) - -(deftest nsubstitute-vector.16 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute 'x 'a x :start i :end j :from-end t))) - (equalp y (concatenate 'simple-vector - (make-array i :initial-element 'a) - (make-array (- j i) :initial-element 'x) - (make-array (- 10 j) :initial-element 'a)))))) - t) - -(deftest nsubstitute-vector.17 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute 'x 'a x :start i :end j :count c))) - (equalp y (concatenate 'simple-vector - (make-array i :initial-element 'a) - (make-array c :initial-element 'x) - (make-array (- 10 (+ i c)) :initial-element 'a))))))) - t) - -(deftest nsubstitute-vector.18 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute 'x 'a x :start i :end j :count c :from-end t))) - (equalp y (concatenate 'simple-vector - (make-array (- j c) :initial-element 'a) - (make-array c :initial-element 'x) - (make-array (- 10 j) :initial-element 'a))))))) - t) - -(deftest nsubstitute-vector.19 - (let* ((orig #(1 2 3 4 5 6 7 8 9)) - (x (copy-seq orig)) - (result (nsubstitute 'x 5 x :test #'(lambda (a b) (<= (abs (- a b)) 2))))) - result) - #(1 2 x x x x x 8 9)) - -(deftest nsubstitute-vector.20 - (let* ((orig #(1 2 3 4 5 6 7 8 9)) - (x (copy-seq orig)) - (c -4) - (result (nsubstitute 'x 5 x :test #'(lambda (a b) (incf c 2) (= (+ b c) a))))) - result) - #(1 2 x 4 5 6 7 8 9)) - - -(deftest nsubstitute-vector.21 - (let* ((orig #(1 2 3 4 5 6 7 8 9)) - (x (copy-seq orig)) - (c 5) - (result (nsubstitute 'x 9 x :test #'(lambda (a b) (incf c -2) (= (+ b c) a)) - :from-end t))) - result) - #(1 2 3 4 5 6 7 x 9)) - -(deftest nsubstitute-vector.22 - (let* ((orig #(1 2 3 4 5 6 7 8 9)) - (x (copy-seq orig)) - (c -4) - (result (nsubstitute 'x 5 x :test-not #'(lambda (a b) (incf c 2) (/= (+ b c) a))))) - result) - #(1 2 x 4 5 6 7 8 9)) - -(deftest nsubstitute-vector.23 - (let* ((orig #(1 2 3 4 5 6 7 8 9)) - (x (copy-seq orig)) - (c 5) - (result (nsubstitute 'x 9 x :test-not #'(lambda (a b) (incf c -2) (/= (+ b c) a)) - :from-end t))) - result) - #(1 2 3 4 5 6 7 x 9)) - -(deftest nsubstitute-vector.28 - (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (nsubstitute 'z 'a x))) - result) - #(z b z c b)) - -(deftest nsubstitute-vector.29 - (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (nsubstitute 'z 'a x :from-end t))) - result) - #(z b z c b)) - -(deftest nsubstitute-vector.30 - (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (nsubstitute 'z 'a x :count 1))) - result) - #(z b a c b)) - -(deftest nsubstitute-vector.31 - (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (nsubstitute 'z 'a x :from-end t :count 1))) - result) - #(a b z c b)) - -;;; Tests on strings - -(deftest nsubstitute-string.1 - (let ((x "")) (nsubstitute #\b #\a x)) - "") - -(deftest nsubstitute-string.2 - (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x)) - "bbbc") - -(deftest nsubstitute-string.3 - (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :count nil)) - "bbbc") - -(deftest nsubstitute-string.4 - (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :count 2)) - "bbbc") - -(deftest nsubstitute-string.5 - (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :count 1)) - "bbac") - -(deftest nsubstitute-string.6 - (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :count 0)) - "abac") - -(deftest nsubstitute-string.7 - (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :count -1)) - "abac") - -(deftest nsubstitute-string.8 - (let ((x "")) (nsubstitute #\b #\a x :from-end t)) - "") - -(deftest nsubstitute-string.9 - (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :from-end t)) - "bbbc") - -(deftest nsubstitute-string.10 - (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :from-end t :count nil)) - "bbbc") - -(deftest nsubstitute-string.11 - (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :count 2 :from-end t)) - "bbbc") - -(deftest nsubstitute-string.12 - (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :count 1 :from-end t)) - "abbc") - -(deftest nsubstitute-string.13 - (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :count 0 :from-end t)) - "abac") - -(deftest nsubstitute-string.14 - (let ((x (copy-seq "abac"))) (nsubstitute #\b #\a x :count -1 :from-end t)) - "abac") - -(deftest nsubstitute-string.15 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (nsubstitute #\x #\a x :start i :end j))) - (equalp y (concatenate 'simple-string - (make-array i :initial-element #\a) - (make-array (- j i) :initial-element #\x) - (make-array (- 10 j) :initial-element #\a)))))) - t) - -(deftest nsubstitute-string.16 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (nsubstitute #\x #\a x :start i :end j :from-end t))) - (equalp y (concatenate 'simple-string - (make-array i :initial-element #\a) - (make-array (- j i) :initial-element #\x) - (make-array (- 10 j) :initial-element #\a)))))) - t) - -(deftest nsubstitute-string.17 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (nsubstitute #\x #\a x :start i :end j :count c))) - (equalp y (concatenate 'simple-string - (make-array i :initial-element #\a) - (make-array c :initial-element #\x) - (make-array (- 10 (+ i c)) :initial-element #\a))))))) - t) - -(deftest nsubstitute-string.18 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (nsubstitute #\x #\a x :start i :end j :count c :from-end t))) - (equalp y (concatenate 'simple-string - (make-array (- j c) :initial-element #\a) - (make-array c :initial-element #\x) - (make-array (- 10 j) :initial-element #\a))))))) - t) - -(deftest nsubstitute-string.19 - (let* ((orig "123456789") - (x (copy-seq orig)) - (result (nsubstitute #\x #\5 x :test #'(lambda (a b) - (setq a (read-from-string (string a))) - (setq b (read-from-string (string b))) - (<= (abs (- a b)) 2))))) - result) - "12xxxxx89") - -(deftest nsubstitute-string.20 - (let* ((orig "123456789") - (x (copy-seq orig)) - (c -4) - (result (nsubstitute #\x #\5 x :test #'(lambda (a b) - (setq a (read-from-string (string a))) - (setq b (read-from-string (string b))) - (incf c 2) (= (+ b c) a))))) - result) - "12x456789") - - -(deftest nsubstitute-string.21 - (let* ((orig "123456789") - (x (copy-seq orig)) - (c 5) - (result (nsubstitute #\x #\9 x :test #'(lambda (a b) - (setq a (read-from-string (string a))) - (setq b (read-from-string (string b))) - (incf c -2) (= (+ b c) a)) - :from-end t))) - result) - "1234567x9") - -(deftest nsubstitute-string.22 - (let* ((orig "123456789") - (x (copy-seq orig)) - (c -4) - (result (nsubstitute #\x #\5 x :test-not #'(lambda (a b) - (setq a (read-from-string (string a))) - (setq b (read-from-string (string b))) - (incf c 2) (/= (+ b c) a))))) - result) - "12x456789") - - -(deftest nsubstitute-string.23 - (let* ((orig "123456789") - (x (copy-seq orig)) - (c 5) - (result (nsubstitute #\x #\9 x :test-not #'(lambda (a b) - (setq a (read-from-string (string a))) - (setq b (read-from-string (string b))) - (incf c -2) (/= (+ b c) a)) - :from-end t))) - result) - "1234567x9") - -(deftest nsubstitute-string.28 - (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (nsubstitute #\z #\a x))) - result) - "zbzcb") - -(deftest nsubstitute-string.29 - (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (nsubstitute #\z #\a x :from-end t))) - result) - "zbzcb") - -(deftest nsubstitute-string.30 - (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (nsubstitute #\z #\a x :count 1))) - result) - "zbacb") - -(deftest nsubstitute-string.31 - (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (nsubstitute #\z #\a x :from-end t :count 1))) - result) - "abzcb") - - -;;; Tests on bit-vectors - -(deftest nsubstitute-bit-vector.1 - (let* ((orig #*) - (x (copy-seq orig)) - (result (nsubstitute 0 1 x))) - result) - #*) - -(deftest nsubstitute-bit-vector.2 - (let* ((orig #*) - (x (copy-seq orig)) - (result (nsubstitute 1 0 x))) - result) - #*) - -(deftest nsubstitute-bit-vector.3 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute 0 1 x))) - result) - #*000000) - -(deftest nsubstitute-bit-vector.4 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute 1 0 x))) - result) - #*111111) - -(deftest nsubstitute-bit-vector.5 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute 1 0 x :start 1))) - result) - #*011111) - -(deftest nsubstitute-bit-vector.6 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute 0 1 x :start 2 :end nil))) - result) - #*010000) - -(deftest nsubstitute-bit-vector.7 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute 1 0 x :end 4))) - result) - #*111101) - -(deftest nsubstitute-bit-vector.8 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute 0 1 x :end nil))) - result) - #*000000) - -(deftest nsubstitute-bit-vector.9 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute 0 1 x :end 3))) - result) - #*000101) - -(deftest nsubstitute-bit-vector.10 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute 0 1 x :start 2 :end 4))) - result) - #*010001) - -(deftest nsubstitute-bit-vector.11 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute 1 0 x :start 2 :end 4))) - result) - #*011101) - -(deftest nsubstitute-bit-vector.12 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute 1 0 x :count 1))) - result) - #*110101) - -(deftest nsubstitute-bit-vector.13 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute 1 0 x :count 0))) - result) - #*010101) - -(deftest nsubstitute-bit-vector.14 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute 1 0 x :count -1))) - result) - #*010101) - -(deftest nsubstitute-bit-vector.15 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute 1 0 x :count 1 :from-end t))) - result) - #*010111) - -(deftest nsubstitute-bit-vector.16 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute 1 0 x :count 0 :from-end t))) - result) - #*010101) - -(deftest nsubstitute-bit-vector.17 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute 1 0 x :count -1 :from-end t))) - result) - #*010101) - -(deftest nsubstitute-bit-vector.18 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute 1 0 x :count nil))) - result) - #*111111) - -(deftest nsubstitute-bit-vector.19 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute 1 0 x :count nil :from-end t))) - result) - #*111111) - -(deftest nsubstitute-bit-vector.20 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #*0000000000) - (x (copy-seq orig)) - (y (nsubstitute 1 0 x :start i :end j :count c))) - (equalp y (concatenate - 'simple-bit-vector - (make-list i :initial-element 0) - (make-list c :initial-element 1) - (make-list (- 10 (+ i c)) :initial-element 0))))))) - t) - -(deftest nsubstitute-bit-vector.21 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #*1111111111) - (x (copy-seq orig)) - (y (nsubstitute 0 1 x :start i :end j :count c :from-end t))) - (equalp y (concatenate - 'simple-bit-vector - (make-list (- j c) :initial-element 1) - (make-list c :initial-element 0) - (make-list (- 10 j) :initial-element 1))))))) - t) - -(deftest nsubstitute-bit-vector.22 - (let* ((orig #*0101010101) - (x (copy-seq orig)) - (c 0) - (result (nsubstitute 1 0 x :test #'(lambda (a b) (incf c) (and (<= 2 c 5) (= a b)))))) - result) - #*0111110101) - -(deftest nsubstitute-bit-vector.23 - (let* ((orig #*0101010101) - (x (copy-seq orig)) - (c 0) - (result (nsubstitute 1 0 x :test-not #'(lambda (a b) (incf c) - (not (and (<= 2 c 5) (= a b))))))) - result) - #*0111110101) - -(deftest nsubstitute-bit-vector.24 - (let* ((orig #*0101010101) - (x (copy-seq orig)) - (c 0) - (result (nsubstitute 1 0 x :test #'(lambda (a b) (incf c) (and (<= 2 c 5) (= a b))) - :from-end t))) - result) - #*0101011111) - -(deftest nsubstitute-bit-vector.25 - (let* ((orig #*0101010101) - (x (copy-seq orig)) - (c 0) - (result (nsubstitute 1 0 x :test-not #'(lambda (a b) (incf c) - (not (and (<= 2 c 5) (= a b)))) - :from-end t))) - result) - #*0101011111) - -(defharmless nsubstitute.test-and-test-not.1 - (nsubstitute 'b 'a (list 'a 'b 'c 'd 'a 'b) :test #'eql :test-not #'eql)) - -(defharmless nsubstitute.test-and-test-not.2 - (nsubstitute 'b 'a (list 'a 'b 'c 'd 'a 'b) :test-not #'eql :test #'eql)) - -(defharmless nsubstitute.test-and-test-not.3 - (nsubstitute 'b 'a (vector 'a 'b 'c 'd 'a 'b) :test #'eql :test-not #'eql)) - -(defharmless nsubstitute.test-and-test-not.4 - (nsubstitute 'b 'a (vector 'a 'b 'c 'd 'a 'b) :test-not #'eql :test #'eql)) - -(defharmless nsubstitute.test-and-test-not.5 - (nsubstitute #\b #\a (copy-seq "abcdab") :test #'eql :test-not #'eql)) - -(defharmless nsubstitute.test-and-test-not.6 - (nsubstitute #\b #\a (copy-seq "abcdab") :test-not #'eql :test #'eql)) - -(defharmless nsubstitute.test-and-test-not.7 - (nsubstitute 1 0 (copy-seq #*001101001) :test #'eql :test-not #'eql)) - -(defharmless nsubstitute.test-and-test-not.8 - (nsubstitute 0 1 (copy-seq #*1100110101) :test-not #'eql :test #'eql)) - - -;;;; additional tests - -(deftest nsubstitute-list.24 - (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (nsubstitute '(a 10) 'a x :key #'car))) - result) - ((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) - -(deftest nsubstitute-list.25 - (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (nsubstitute '(a 10) 'a x :key #'car :start 1 :end 5))) - result) - ((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) - -(deftest nsubstitute-list.26 - (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (nsubstitute '(a 10) 'a x :key #'car :test (complement #'eql)))) - result) - ((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) - -(deftest nsubstitute-list.27 - (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (nsubstitute '(a 10) 'a x :key #'car :test-not #'eql))) - result) - ((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) - -(deftest nsubstitute-vector.24 - (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (nsubstitute '(a 10) 'a x :key #'car))) - result) - #((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) - -(deftest nsubstitute-vector.25 - (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (nsubstitute '(a 10) 'a x :key #'car :start 1 :end 5))) - result) - #((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) - -(deftest nsubstitute-vector.26 - (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (nsubstitute '(a 10) 'a x :key #'car :test (complement #'eql)))) - result) - #((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) - -(deftest nsubstitute-vector.27 - (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (nsubstitute '(a 10) 'a x :key #'car :test-not #'eql))) - result) - #((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) - -(deftest nsubstitute-vector.32 - (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) - (v2 (make-array '(8) :displaced-to v1 - :displaced-index-offset 3))) - (values - (nsubstitute 'x 'c v2 :count 1) - v1)) - #(d a b x d a b c) - #(a b c d a b x d a b c d a b c d)) - -(deftest nsubstitute-vector.33 - (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) - (v2 (make-array '(8) :displaced-to v1 - :displaced-index-offset 3))) - (values - (nsubstitute 'x 'c v2 :count 1 :from-end t) - v1)) - #(d a b c d a b x) - #(a b c d a b c d a b x d a b c d)) - - -(deftest nsubstitute-string.24 - (let* ((orig "0102342015") - (x (copy-seq orig)) - (result (nsubstitute #\a #\1 x :key #'nextdigit))) - result) - "a1a2342a15") - -(deftest nsubstitute-string.25 - (let* ((orig "0102342015") - (x (copy-seq orig)) - (result (nsubstitute #\a #\1 x :key #'nextdigit :start 1 :end 6))) - result) - "01a2342015") - -(deftest nsubstitute-string.26 - (let* ((orig "0102342015") - (x (copy-seq orig)) - (result (nsubstitute #\a #\1 x :key #'nextdigit :test (complement #'eql)))) - result) - "0a0aaaa0aa") - -(deftest nsubstitute-string.27 - (let* ((orig "0102342015") - (x (copy-seq orig)) - (result (nsubstitute #\a #\1 x :key #'nextdigit :test-not #'eql))) - result) - "0a0aaaa0aa") - -(deftest nsubstitute-string.32 - (do-special-strings - (s "xyzabcxyzabc" nil) - (assert (string= (nsubstitute #\! #\a s) "xyz!bcxyz!bc")) - (assert (string= s "xyz!bcxyz!bc"))) - nil) - -(deftest nsubstitute-string.33 - (do-special-strings - (s "xyzabcxyzabc" nil) - (assert (string= (nsubstitute #\! #\a s :count 1) "xyz!bcxyzabc")) - (assert (string= s "xyz!bcxyzabc"))) - nil) - -(deftest nsubstitute-string.34 - (do-special-strings - (s "xyzabcxyzabc" nil) - (assert (string= (nsubstitute #\! #\a s :count 1 :from-end t) "xyzabcxyz!bc")) - (assert (string= s "xyzabcxyz!bc"))) - nil) - -;;; More bit vector tests - -(deftest nsubstitute-bit-vector.30 - (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (nsubstitute 1 0 x))) - result) - #*11111) - -(deftest nsubstitute-bit-vector.31 - (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (nsubstitute 1 0 x :from-end t))) - result) - #*11111) - -(deftest nsubstitute-bit-vector.32 - (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (nsubstitute 1 0 x :count 1))) - result) - #*11011) - -(deftest nsubstitute-bit-vector.33 - (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (nsubstitute 1 0 x :from-end t :count 1))) - result) - #*01111) - -(deftest nsubstitute.order.1 - (let ((i 0) a b c d e f g h) - (values - (nsubstitute - (progn (setf a (incf i)) 'a) - (progn (setf b (incf i)) nil) - (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) - :count (progn (setf d (incf i)) 2) - :start (progn (setf e (incf i)) 0) - :end (progn (setf f (incf i)) 7) - :key (progn (setf g (incf i)) #'identity) - :from-end (setf h (incf i)) - ) - i a b c d e f g h)) - (nil 1 2 a 3 4 a 5) - 8 1 2 3 4 5 6 7 8) - -(deftest nsubstitute.order.2 - (let ((i 0) a b c d e f g h) - (values - (nsubstitute - (progn (setf a (incf i)) 'a) - (progn (setf b (incf i)) nil) - (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) - :from-end (setf h (incf i)) - :key (progn (setf g (incf i)) #'identity) - :end (progn (setf f (incf i)) 7) - :start (progn (setf e (incf i)) 0) - :count (progn (setf d (incf i)) 2) - ) - i a b c d e f g h)) - (nil 1 2 a 3 4 a 5) - 8 1 2 3 8 7 6 5 4) - -;;; Keyword tests - -(deftest nsubstitute.allow-other-keys.1 - (nsubstitute 'a 0 (list 1 2 0 3 1 0 3) :allow-other-keys t :bad t) - (1 2 a 3 1 a 3)) - -(deftest nsubstitute.allow-other-keys.2 - (nsubstitute 'a 0 (list 1 2 0 3 1 0 3) :bad t :allow-other-keys t) - (1 2 a 3 1 a 3)) - -(deftest nsubstitute.allow-other-keys.3 - (nsubstitute 'a 0 (list 1 2 0 3 1 0 3) :allow-other-keys t - :allow-other-keys nil :bad t) - (1 2 a 3 1 a 3)) - -(deftest nsubstitute.allow-other-keys.4 - (nsubstitute 'a 0 (list 1 2 0 3 1 0 3) :bad t - :allow-other-keys t :allow-other-keys nil) - (1 2 a 3 1 a 3)) - -(deftest nsubstitute.allow-other-keys.5 - (nsubstitute 'a 0 (list 1 2 0 3 1 0 3) - :allow-other-keys t :key #'1-) - (a 2 0 3 a 0 3)) - -(deftest nsubstitute.keywords.6 - (nsubstitute 'a 0 (list 1 2 0 3 1 0 3) :key #'1- :key #'identity) - (a 2 0 3 a 0 3)) - -(deftest nsubstitute.allow-other-keys.7 - (nsubstitute 'a 0 (list 1 2 0 3 1 0 3) :allow-other-keys t - :bad t :allow-other-keys nil) - (1 2 a 3 1 a 3)) - -(deftest nsubstitute.allow-other-keys.8 - (nsubstitute 'a 0 (list 1 2 0 3 1 0 3) :allow-other-keys nil) - (1 2 a 3 1 a 3)) - - -;;; Error cases - -(deftest nsubstitute.error.1 - (signals-error (nsubstitute) program-error) - t) - -(deftest nsubstitute.error.2 - (signals-error (nsubstitute 'a) program-error) - t) - -(deftest nsubstitute.error.3 - (signals-error (nsubstitute 'a 'b) program-error) - t) - -(deftest nsubstitute.error.4 - (signals-error (nsubstitute 'a 'b nil 'bad t) program-error) - t) - -(deftest nsubstitute.error.5 - (signals-error (nsubstitute 'a 'b nil 'bad t :allow-other-keys nil) program-error) - t) - -(deftest nsubstitute.error.6 - (signals-error (nsubstitute 'a 'b nil :key) program-error) - t) - -(deftest nsubstitute.error.7 - (signals-error (nsubstitute 'a 'b nil 1 2) program-error) - t) - -(deftest nsubstitute.error.8 - (signals-error (nsubstitute 'a 'b (list 'a 'b 'c) :test #'identity) program-error) - t) - -(deftest nsubstitute.error.9 - (signals-error (nsubstitute 'a 'b (list 'a 'b 'c) :test-not #'identity) program-error) - t) - -(deftest nsubstitute.error.10 - (signals-error (nsubstitute 'a 'b (list 'a 'b 'c) :key #'cons) program-error) - t) - -(deftest nsubstitute.error.11 - (signals-error (nsubstitute 'a 'b (list 'a 'b 'c) :key #'car) type-error) - t) - -(deftest nsubstitute.error.12 - (check-type-error #'(lambda (x) (nsubstitute 1 0 x)) #'sequencep) - nil) diff --git a/t/ansi-test/sequences/position-if-not.lsp b/t/ansi-test/sequences/position-if-not.lsp deleted file mode 100644 index fea34fb..0000000 --- a/t/ansi-test/sequences/position-if-not.lsp +++ /dev/null @@ -1,589 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Aug 24 07:10:05 2002 -;;;; Contains: Tests for POSITION-IF-NOT-NOT - -(in-package :cl-test) - -(deftest position-if-not-list.1 - (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9)) - 3) - -(deftest position-if-not-list.2 - (position-if-not 'oddp '(1 3 1 4 3 2 1 8 9)) - 3) - -(deftest position-if-not-list.3 - (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9) :start 4) - 5) - -(deftest position-if-not-list.4 - (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9) :from-end t) - 7) - -(deftest position-if-not-list.5 - (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9) :from-end nil) - 3) - -(deftest position-if-not-list.6 - (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9) :start 4 - :from-end t) - 7) - -(deftest position-if-not-list.7 - (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9) :end nil) - 3) - -(deftest position-if-not-list.8 - (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9) :end 3) - nil) - -(deftest position-if-not-list.9 - (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9) :start i :end j))) - ((nil nil nil 3 3 3 3 3 3) - (nil nil 3 3 3 3 3 3) - (nil 3 3 3 3 3 3) - (3 3 3 3 3 3) - (nil 5 5 5 5) - (5 5 5 5) - (nil 7 7) - (7 7) - (nil))) - -(deftest position-if-not-list.10 - (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9) :start i :end j - :from-end t))) - ((nil nil nil 3 3 5 5 7 7) - (nil nil 3 3 5 5 7 7) - (nil 3 3 5 5 7 7) - (3 3 5 5 7 7) - (nil 5 5 7 7) - (5 5 7 7) - (nil 7 7) - (7 7) - (nil))) - -(deftest position-if-not-list.11 - (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if-not #'evenp '(1 3 1 4 3 2 1 8 9) :start i :end j - :key '1+))) - ((nil nil nil 3 3 3 3 3 3) - (nil nil 3 3 3 3 3 3) - (nil 3 3 3 3 3 3) - (3 3 3 3 3 3) - (nil 5 5 5 5) - (5 5 5 5) - (nil 7 7) - (7 7) - (nil))) - -(deftest position-if-not-list.12 - (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if-not #'evenp '(1 3 1 4 3 2 1 8 9) :start i :end j - :key #'1+ :from-end t))) - ((nil nil nil 3 3 5 5 7 7) - (nil nil 3 3 5 5 7 7) - (nil 3 3 5 5 7 7) - (3 3 5 5 7 7) - (nil 5 5 7 7) - (5 5 7 7) - (nil 7 7) - (7 7) - (nil))) - -;;; Vector tests - -(deftest position-if-not-vector.1 - (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9)) - 3) - -(deftest position-if-not-vector.2 - (position-if-not 'oddp #(1 3 1 4 3 2 1 8 9)) - 3) - -(deftest position-if-not-vector.3 - (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9) :start 4) - 5) - -(deftest position-if-not-vector.4 - (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9) :from-end t) - 7) - -(deftest position-if-not-vector.5 - (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9) :from-end nil) - 3) - -(deftest position-if-not-vector.6 - (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9) :start 4 - :from-end t) - 7) - -(deftest position-if-not-vector.7 - (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9) :end nil) - 3) - -(deftest position-if-not-vector.8 - (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9) :end 3) - nil) - -(deftest position-if-not-vector.9 - (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9) :start i :end j))) - ((nil nil nil 3 3 3 3 3 3) - (nil nil 3 3 3 3 3 3) - (nil 3 3 3 3 3 3) - (3 3 3 3 3 3) - (nil 5 5 5 5) - (5 5 5 5) - (nil 7 7) - (7 7) - (nil))) - -(deftest position-if-not-vector.10 - (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9) :start i :end j - :from-end t))) - ((nil nil nil 3 3 5 5 7 7) - (nil nil 3 3 5 5 7 7) - (nil 3 3 5 5 7 7) - (3 3 5 5 7 7) - (nil 5 5 7 7) - (5 5 7 7) - (nil 7 7) - (7 7) - (nil))) - -(deftest position-if-not-vector.11 - (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if-not #'evenp #(1 3 1 4 3 2 1 8 9) :start i :end j - :key '1+))) - ((nil nil nil 3 3 3 3 3 3) - (nil nil 3 3 3 3 3 3) - (nil 3 3 3 3 3 3) - (3 3 3 3 3 3) - (nil 5 5 5 5) - (5 5 5 5) - (nil 7 7) - (7 7) - (nil))) - -(deftest position-if-not-vector.12 - (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if-not #'evenp #(1 3 1 4 3 2 1 8 9) :start i :end j - :key #'1+ :from-end t))) - ((nil nil nil 3 3 5 5 7 7) - (nil nil 3 3 5 5 7 7) - (nil 3 3 5 5 7 7) - (3 3 5 5 7 7) - (nil 5 5 7 7) - (5 5 7 7) - (nil 7 7) - (7 7) - (nil))) - -(deftest position-if-not-vector.13 - (let ((a (make-array '(10) :initial-contents '(1 2 3 4 5 a b c d e) - :fill-pointer 5))) - (values - (position-if-not #'numberp a) - (position-if-not #'symbolp a) - (position-if-not #'numberp a :from-end t) - (position-if-not #'symbolp a :from-end t))) - nil 0 nil 4) - -(deftest position-if-not-vector.14 - (let* ((v1 #(x x x a b 1 d a b 2 d y y y y y)) - (v2 (make-array '(8) :displaced-to v1 - :displaced-index-offset 3))) - (values (position-if-not #'symbolp v2) - (position-if-not #'symbolp v2 :from-end t))) - 2 6) - -;;; Bit vector tests - -(deftest position-if-not-bit-vector.1 - (position-if-not #'oddp #*111010101) - 3) - -(deftest position-if-not-bit-vector.2 - (position-if-not 'oddp #*111010101) - 3) - -(deftest position-if-not-bit-vector.3 - (position-if-not #'oddp #*111010101 :start 4) - 5) - -(deftest position-if-not-bit-vector.4 - (position-if-not #'oddp #*111010101 :from-end t) - 7) - -(deftest position-if-not-bit-vector.5 - (position-if-not #'oddp #*111010101 :from-end nil) - 3) - -(deftest position-if-not-bit-vector.6 - (position-if-not #'oddp #*111010101 :start 4 - :from-end t) - 7) - -(deftest position-if-not-bit-vector.7 - (position-if-not #'oddp #*111010101 :end nil) - 3) - -(deftest position-if-not-bit-vector.8 - (position-if-not #'oddp #*111010101 :end 3) - nil) - -(deftest position-if-not-bit-vector.9 - (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if-not #'oddp #*111010101 :start i :end j))) - ((nil nil nil 3 3 3 3 3 3) - (nil nil 3 3 3 3 3 3) - (nil 3 3 3 3 3 3) - (3 3 3 3 3 3) - (nil 5 5 5 5) - (5 5 5 5) - (nil 7 7) - (7 7) - (nil))) - -(deftest position-if-not-bit-vector.10 - (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if-not #'oddp #*111010101 :start i :end j - :from-end t))) - ((nil nil nil 3 3 5 5 7 7) - (nil nil 3 3 5 5 7 7) - (nil 3 3 5 5 7 7) - (3 3 5 5 7 7) - (nil 5 5 7 7) - (5 5 7 7) - (nil 7 7) - (7 7) - (nil))) - -(deftest position-if-not-bit-vector.11 - (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if-not #'evenp #*111010101 :start i :end j - :key #'1+))) - ((nil nil nil 3 3 3 3 3 3) - (nil nil 3 3 3 3 3 3) - (nil 3 3 3 3 3 3) - (3 3 3 3 3 3) - (nil 5 5 5 5) - (5 5 5 5) - (nil 7 7) - (7 7) - (nil))) - -(deftest position-if-not-bit-vector.12 - (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if-not #'evenp #*111010101 :start i :end j - :key '1+ :from-end t))) - ((nil nil nil 3 3 5 5 7 7) - (nil nil 3 3 5 5 7 7) - (nil 3 3 5 5 7 7) - (3 3 5 5 7 7) - (nil 5 5 7 7) - (5 5 7 7) - (nil 7 7) - (7 7) - (nil))) - -(deftest position-if-not-bit-vector.13 - (let ((a (make-array '(10) :initial-contents '(1 1 1 1 1 0 0 0 0 0) - :fill-pointer 5 - :element-type 'bit))) - (values - (position-if-not #'zerop a) - (position-if-not (complement #'zerop) a) - (position-if-not #'zerop a :from-end t) - (position-if-not (complement #'zerop) a :from-end t))) - 0 nil 4 nil) - -;;; string tests - -(deftest position-if-not-string.1 - (position-if-not #'odddigitp "131432189") - 3) - -(deftest position-if-not-string.2 - (position-if-not 'odddigitp "131432189") - 3) - -(deftest position-if-not-string.3 - (position-if-not #'odddigitp "131432189" :start 4) - 5) - -(deftest position-if-not-string.4 - (position-if-not #'odddigitp "131432189" :from-end t) - 7) - -(deftest position-if-not-string.5 - (position-if-not #'odddigitp "131432189" :from-end nil) - 3) - -(deftest position-if-not-string.6 - (position-if-not #'odddigitp "131432189" :start 4 - :from-end t) - 7) - -(deftest position-if-not-string.7 - (position-if-not #'odddigitp "131432189" :end nil) - 3) - -(deftest position-if-not-string.8 - (position-if-not #'odddigitp "131432189" :end 3) - nil) - -(deftest position-if-not-string.9 - (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if-not #'odddigitp "131432189" :start i :end j))) - ((nil nil nil 3 3 3 3 3 3) - (nil nil 3 3 3 3 3 3) - (nil 3 3 3 3 3 3) - (3 3 3 3 3 3) - (nil 5 5 5 5) - (5 5 5 5) - (nil 7 7) - (7 7) - (nil))) - -(deftest position-if-not-string.10 - (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if-not #'odddigitp "131432189" :start i :end j - :from-end t))) - ((nil nil nil 3 3 5 5 7 7) - (nil nil 3 3 5 5 7 7) - (nil 3 3 5 5 7 7) - (3 3 5 5 7 7) - (nil 5 5 7 7) - (5 5 7 7) - (nil 7 7) - (7 7) - (nil))) - -(deftest position-if-not-string.11 - (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if-not #'evendigitp "131432183" :start i :end j - :key #'nextdigit))) - ((nil nil nil 3 3 3 3 3 3) - (nil nil 3 3 3 3 3 3) - (nil 3 3 3 3 3 3) - (3 3 3 3 3 3) - (nil 5 5 5 5) - (5 5 5 5) - (nil 7 7) - (7 7) - (nil))) - -(deftest position-if-not-string.12 - (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if-not #'evendigitp "131432183" :start i :end j - :key 'nextdigit :from-end t))) - ((nil nil nil 3 3 5 5 7 7) - (nil nil 3 3 5 5 7 7) - (nil 3 3 5 5 7 7) - (3 3 5 5 7 7) - (nil 5 5 7 7) - (5 5 7 7) - (nil 7 7) - (7 7) - (nil))) - -(deftest position-if-not-string.13 - (let ((a (make-array '(10) :initial-contents "55555aaaaa" - :fill-pointer 5 - :element-type 'character))) - (and (stringp a) - (values - (position-if-not #'digit-char-p a) - (position-if-not (complement #'digit-char-p) a) - (position-if-not #'digit-char-p a :from-end t) - (position-if-not (complement #'digit-char-p) a :from-end t)))) - nil 0 nil 4) - -(deftest position-if-not-string.14 - (do-special-strings - (s "12345a6 78b90" nil) - (let ((pos (position-if-not (complement #'alpha-char-p) s))) - (assert (eql pos 5) () "First alpha char in ~A is at position ~A" s pos))) - nil) - -(deftest position-if-not-string.15 - (do-special-strings - (s "12345a6 78b90" nil) - (let ((pos (position-if-not (complement #'alpha-char-p) s :from-end t))) - (assert (eql pos 11) () "Last alpha char in ~A is at position ~A" s pos))) - nil) - -(deftest position-if-not.order.1 - (let ((i 0) a b c d e f) - (values - (position-if-not - (progn (setf a (incf i)) (complement #'zerop)) - (progn (setf b (incf i)) '(3 1 8 2 1 2 3 4)) - :from-end (setf c (incf i)) - :start (progn (setf d (incf i)) 1) - :end (progn (setf e (incf i)) 6) - :key (progn (setf f (incf i)) #'1-)) - i a b c d e f)) - 4 6 1 2 3 4 5 6) - -(deftest position-if-not.order.2 - (let ((i 0) a b c d e f) - (values - (position-if-not - (progn (setf a (incf i)) (complement #'zerop)) - (progn (setf b (incf i)) '(3 1 8 2 1 2 3 4)) - :key (progn (setf c (incf i)) #'1-) - :end (progn (setf d (incf i)) 6) - :start (progn (setf e (incf i)) 1) - :from-end (setf f (incf i))) - i a b c d e f)) - 4 6 1 2 3 4 5 6) - -;;; Keyword tests - -(deftest position-if-not.allow-other-keys.1 - (position-if-not #'zerop '(0 0 3 2 0 1) :allow-other-keys t) - 2) - -(deftest position-if-not.allow-other-keys.2 - (position-if-not #'zerop '(0 0 3 2 0 1) :allow-other-keys nil) - 2) - -(deftest position-if-not.allow-other-keys.3 - (position-if-not #'zerop '(0 0 1 2 3 0) :allow-other-keys t :bad t) - 2) - -(deftest position-if-not.allow-other-keys.4 - (position-if-not #'zerop '(0 0 1 2 3 0) :bad t :allow-other-keys t) - 2) - -(deftest position-if-not.allow-other-keys.5 - (position-if-not #'zerop '(0 0 1 2 3 0) :bad t :allow-other-keys t :key #'1-) - 0) - -(deftest position-if-not.keywords.6 - (position-if-not #'zerop '(0 0 1 2 3 0) :key #'1- :key #'identity) - 0) - -(deftest position-if-not.allow-other-keys.7 - (position-if-not #'zerop '(0 0 1 2 3 0) :bad t :allow-other-keys t - :allow-other-keys nil) - 2) - -(deftest position-if-not.allow-other-keys.8 - (position-if-not #'zerop '(0 0 1 2 3 0) :allow-other-keys t :bad t - :allow-other-keys nil) - 2) - -(deftest position-if-not.allow-other-keys.9 - (position-if-not #'zerop '(0 0 1 2 3 0) :allow-other-keys t - :allow-other-keys nil :bad t) - 2) - - -;;; Error tests - -(deftest position-if-not.error.1 - (check-type-error #'(lambda (x) (position-if-not #'identity x)) #'sequencep) - nil) - -(deftest position-if-not.error.4 - (signals-error (position-if-not 'identity '(a b c . d)) type-error) - t) - -(deftest position-if-not.error.5 - (signals-error (position-if-not) program-error) - t) - -(deftest position-if-not.error.6 - (signals-error (position-if-not #'null) program-error) - t) - -(deftest position-if-not.error.7 - (signals-error (position-if-not #'null nil :key) program-error) - t) - -(deftest position-if-not.error.8 - (signals-error (position-if-not #'null nil 'bad t) program-error) - t) - -(deftest position-if-not.error.9 - (signals-error (position-if-not #'null nil 'bad t :allow-other-keys nil) program-error) - t) - -(deftest position-if-not.error.10 - (signals-error (position-if-not #'null nil 1 2) program-error) - t) - -(deftest position-if-not.error.11 - (signals-error (locally (position-if-not #'identity 'b) t) type-error) - t) - -(deftest position-if-not.error.12 - (signals-error (position-if-not #'cons '(a b c d)) program-error) - t) - -(deftest position-if-not.error.13 - (signals-error (position-if-not #'car '(a b c d)) type-error) - t) - -(deftest position-if-not.error.14 - (signals-error (position-if-not #'identity '(a b c d) :key #'cdr) type-error) - t) - -(deftest position-if-not.error.15 - (signals-error (position-if-not #'identity '(a b c d) :key #'cons) program-error) - t) diff --git a/t/ansi-test/sequences/position-if.lsp b/t/ansi-test/sequences/position-if.lsp deleted file mode 100644 index 98e9cd3..0000000 --- a/t/ansi-test/sequences/position-if.lsp +++ /dev/null @@ -1,587 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Aug 23 22:08:57 2002 -;;;; Contains: Tests for POSITION-IF - -(in-package :cl-test) - -(deftest position-if-list.1 - (position-if #'evenp '(1 3 1 4 3 2 1 8 9)) - 3) - -(deftest position-if-list.2 - (position-if 'evenp '(1 3 1 4 3 2 1 8 9)) - 3) - -(deftest position-if-list.3 - (position-if #'evenp '(1 3 1 4 3 2 1 8 9) :start 4) - 5) - -(deftest position-if-list.4 - (position-if #'evenp '(1 3 1 4 3 2 1 8 9) :from-end t) - 7) - -(deftest position-if-list.5 - (position-if #'evenp '(1 3 1 4 3 2 1 8 9) :from-end nil) - 3) - -(deftest position-if-list.6 - (position-if #'evenp '(1 3 1 4 3 2 1 8 9) :start 4 - :from-end t) - 7) - -(deftest position-if-list.7 - (position-if #'evenp '(1 3 1 4 3 2 1 8 9) :end nil) - 3) - -(deftest position-if-list.8 - (position-if #'evenp '(1 3 1 4 3 2 1 8 9) :end 3) - nil) - -(deftest position-if-list.9 - (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if #'evenp '(1 3 1 4 3 2 1 8 9) :start i :end j))) - ((nil nil nil 3 3 3 3 3 3) - (nil nil 3 3 3 3 3 3) - (nil 3 3 3 3 3 3) - (3 3 3 3 3 3) - (nil 5 5 5 5) - (5 5 5 5) - (nil 7 7) - (7 7) - (nil))) - -(deftest position-if-list.10 - (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if #'evenp '(1 3 1 4 3 2 1 8 9) :start i :end j - :from-end t))) - ((nil nil nil 3 3 5 5 7 7) - (nil nil 3 3 5 5 7 7) - (nil 3 3 5 5 7 7) - (3 3 5 5 7 7) - (nil 5 5 7 7) - (5 5 7 7) - (nil 7 7) - (7 7) - (nil))) - -(deftest position-if-list.11 - (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if #'oddp '(1 3 1 4 3 2 1 8 9) :start i :end j - :key '1+))) - ((nil nil nil 3 3 3 3 3 3) - (nil nil 3 3 3 3 3 3) - (nil 3 3 3 3 3 3) - (3 3 3 3 3 3) - (nil 5 5 5 5) - (5 5 5 5) - (nil 7 7) - (7 7) - (nil))) - -(deftest position-if-list.12 - (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if #'oddp '(1 3 1 4 3 2 1 8 9) :start i :end j - :key #'1+ :from-end t))) - ((nil nil nil 3 3 5 5 7 7) - (nil nil 3 3 5 5 7 7) - (nil 3 3 5 5 7 7) - (3 3 5 5 7 7) - (nil 5 5 7 7) - (5 5 7 7) - (nil 7 7) - (7 7) - (nil))) - -;;; Vector tests - -(deftest position-if-vector.1 - (position-if #'evenp #(1 3 1 4 3 2 1 8 9)) - 3) - -(deftest position-if-vector.2 - (position-if 'evenp #(1 3 1 4 3 2 1 8 9)) - 3) - -(deftest position-if-vector.3 - (position-if #'evenp #(1 3 1 4 3 2 1 8 9) :start 4) - 5) - -(deftest position-if-vector.4 - (position-if #'evenp #(1 3 1 4 3 2 1 8 9) :from-end t) - 7) - -(deftest position-if-vector.5 - (position-if #'evenp #(1 3 1 4 3 2 1 8 9) :from-end nil) - 3) - -(deftest position-if-vector.6 - (position-if #'evenp #(1 3 1 4 3 2 1 8 9) :start 4 - :from-end t) - 7) - -(deftest position-if-vector.7 - (position-if #'evenp #(1 3 1 4 3 2 1 8 9) :end nil) - 3) - -(deftest position-if-vector.8 - (position-if #'evenp #(1 3 1 4 3 2 1 8 9) :end 3) - nil) - -(deftest position-if-vector.9 - (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if #'evenp #(1 3 1 4 3 2 1 8 9) :start i :end j))) - ((nil nil nil 3 3 3 3 3 3) - (nil nil 3 3 3 3 3 3) - (nil 3 3 3 3 3 3) - (3 3 3 3 3 3) - (nil 5 5 5 5) - (5 5 5 5) - (nil 7 7) - (7 7) - (nil))) - -(deftest position-if-vector.10 - (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if #'evenp #(1 3 1 4 3 2 1 8 9) :start i :end j - :from-end t))) - ((nil nil nil 3 3 5 5 7 7) - (nil nil 3 3 5 5 7 7) - (nil 3 3 5 5 7 7) - (3 3 5 5 7 7) - (nil 5 5 7 7) - (5 5 7 7) - (nil 7 7) - (7 7) - (nil))) - -(deftest position-if-vector.11 - (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if #'oddp #(1 3 1 4 3 2 1 8 9) :start i :end j - :key '1+))) - ((nil nil nil 3 3 3 3 3 3) - (nil nil 3 3 3 3 3 3) - (nil 3 3 3 3 3 3) - (3 3 3 3 3 3) - (nil 5 5 5 5) - (5 5 5 5) - (nil 7 7) - (7 7) - (nil))) - -(deftest position-if-vector.12 - (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if #'oddp #(1 3 1 4 3 2 1 8 9) :start i :end j - :key #'1+ :from-end t))) - ((nil nil nil 3 3 5 5 7 7) - (nil nil 3 3 5 5 7 7) - (nil 3 3 5 5 7 7) - (3 3 5 5 7 7) - (nil 5 5 7 7) - (5 5 7 7) - (nil 7 7) - (7 7) - (nil))) - -(deftest position-if-vector.13 - (let ((a (make-array '(10) :initial-contents '(1 3 1 4 3 1 2 1 8 9) - :fill-pointer 5))) - (flet ((%f (x) (eql x 1))) - (values (position-if #'%f a) - (position-if #'%f a :from-end t)))) - 0 2) - -(deftest position-if-vector.14 - (let* ((v1 #(x x x a b 1 d a b 2 d y y y y y)) - (v2 (make-array '(8) :displaced-to v1 - :displaced-index-offset 3))) - (values (position-if #'integerp v2) - (position-if #'integerp v2 :from-end t))) - 2 6) - -;;; Bit vector tests - -(deftest position-if-bit-vector.1 - (position-if #'evenp #*111010101) - 3) - -(deftest position-if-bit-vector.2 - (position-if 'evenp #*111010101) - 3) - -(deftest position-if-bit-vector.3 - (position-if #'evenp #*111010101 :start 4) - 5) - -(deftest position-if-bit-vector.4 - (position-if #'evenp #*111010101 :from-end t) - 7) - -(deftest position-if-bit-vector.5 - (position-if #'evenp #*111010101 :from-end nil) - 3) - -(deftest position-if-bit-vector.6 - (position-if #'evenp #*111010101 :start 4 - :from-end t) - 7) - -(deftest position-if-bit-vector.7 - (position-if #'evenp #*111010101 :end nil) - 3) - -(deftest position-if-bit-vector.8 - (position-if #'evenp #*111010101 :end 3) - nil) - -(deftest position-if-bit-vector.9 - (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if #'evenp #*111010101 :start i :end j))) - ((nil nil nil 3 3 3 3 3 3) - (nil nil 3 3 3 3 3 3) - (nil 3 3 3 3 3 3) - (3 3 3 3 3 3) - (nil 5 5 5 5) - (5 5 5 5) - (nil 7 7) - (7 7) - (nil))) - -(deftest position-if-bit-vector.10 - (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if #'evenp #*111010101 :start i :end j - :from-end t))) - ((nil nil nil 3 3 5 5 7 7) - (nil nil 3 3 5 5 7 7) - (nil 3 3 5 5 7 7) - (3 3 5 5 7 7) - (nil 5 5 7 7) - (5 5 7 7) - (nil 7 7) - (7 7) - (nil))) - -(deftest position-if-bit-vector.11 - (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if #'oddp #*111010101 :start i :end j - :key #'1+))) - ((nil nil nil 3 3 3 3 3 3) - (nil nil 3 3 3 3 3 3) - (nil 3 3 3 3 3 3) - (3 3 3 3 3 3) - (nil 5 5 5 5) - (5 5 5 5) - (nil 7 7) - (7 7) - (nil))) - -(deftest position-if-bit-vector.12 - (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if #'oddp #*111010101 :start i :end j - :key '1+ :from-end t))) - ((nil nil nil 3 3 5 5 7 7) - (nil nil 3 3 5 5 7 7) - (nil 3 3 5 5 7 7) - (3 3 5 5 7 7) - (nil 5 5 7 7) - (5 5 7 7) - (nil 7 7) - (7 7) - (nil))) - -(deftest position-if-bit-vector.13 - (let ((a (make-array '(10) :initial-contents '(1 1 1 1 1 0 0 0 0 0) - :fill-pointer 5 - :element-type 'bit))) - (values (position-if #'evenp a) - (position-if #'evenp a :from-end 'foo) - (position-if #'oddp a) - (position-if #'oddp a :from-end 'foo))) - nil nil 0 4) - -;;; string tests - -(deftest position-if-string.1 - (position-if #'evendigitp "131432189") - 3) - -(deftest position-if-string.2 - (position-if 'evendigitp "131432189") - 3) - -(deftest position-if-string.3 - (position-if #'evendigitp "131432189" :start 4) - 5) - -(deftest position-if-string.4 - (position-if #'evendigitp "131432189" :from-end t) - 7) - -(deftest position-if-string.5 - (position-if #'evendigitp "131432189" :from-end nil) - 3) - -(deftest position-if-string.6 - (position-if #'evendigitp "131432189" :start 4 - :from-end t) - 7) - -(deftest position-if-string.7 - (position-if #'evendigitp "131432189" :end nil) - 3) - -(deftest position-if-string.8 - (position-if #'evendigitp "131432189" :end 3) - nil) - -(deftest position-if-string.9 - (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if #'evendigitp "131432189" :start i :end j))) - ((nil nil nil 3 3 3 3 3 3) - (nil nil 3 3 3 3 3 3) - (nil 3 3 3 3 3 3) - (3 3 3 3 3 3) - (nil 5 5 5 5) - (5 5 5 5) - (nil 7 7) - (7 7) - (nil))) - -(deftest position-if-string.10 - (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if #'evendigitp "131432189" :start i :end j - :from-end t))) - ((nil nil nil 3 3 5 5 7 7) - (nil nil 3 3 5 5 7 7) - (nil 3 3 5 5 7 7) - (3 3 5 5 7 7) - (nil 5 5 7 7) - (5 5 7 7) - (nil 7 7) - (7 7) - (nil))) - -(deftest position-if-string.11 - (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if #'odddigitp "131432189" :start i :end j - :key #'nextdigit))) - ((nil nil nil 3 3 3 3 3 3) - (nil nil 3 3 3 3 3 3) - (nil 3 3 3 3 3 3) - (3 3 3 3 3 3) - (nil 5 5 5 5) - (5 5 5 5) - (nil 7 7) - (7 7) - (nil))) - -(deftest position-if-string.12 - (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if #'odddigitp "131432189" :start i :end j - :key 'nextdigit :from-end t))) - ((nil nil nil 3 3 5 5 7 7) - (nil nil 3 3 5 5 7 7) - (nil 3 3 5 5 7 7) - (3 3 5 5 7 7) - (nil 5 5 7 7) - (5 5 7 7) - (nil 7 7) - (7 7) - (nil))) - -(deftest position-if-string.13 - (flet ((%f (c) (eql c #\0)) - (%g (c) (eql c #\1))) - (let ((a (make-array '(10) :initial-contents "1111100000" - :fill-pointer 5 - :element-type 'character))) - (values (position-if #'%f a) - (position-if #'%f a :from-end 'foo) - (position-if #'%g a) - (position-if #'%g a :from-end 'foo)))) - nil nil 0 4) - -(deftest position-if-string.14 - (do-special-strings - (s "12345a6 78b90" nil) - (let ((pos (position-if #'alpha-char-p s))) - (assert (eql pos 5) () "First alpha char in ~A is at position ~A" s pos))) - nil) - -(deftest position-if-string.15 - (do-special-strings - (s "12345a6 78b90" nil) - (let ((pos (position-if #'alpha-char-p s :from-end t))) - (assert (eql pos 11) () "Last alpha char in ~A is at position ~A" s pos))) - nil) - - -(deftest position-if.order.1 - (let ((i 0) a b c d e f) - (values - (position-if - (progn (setf a (incf i)) #'zerop) - (progn (setf b (incf i)) '(3 1 8 2 1 2 3 4)) - :from-end (setf c (incf i)) - :start (progn (setf d (incf i)) 1) - :end (progn (setf e (incf i)) 6) - :key (progn (setf f (incf i)) #'1-)) - i a b c d e f)) - 4 6 1 2 3 4 5 6) - -(deftest position-if.order.2 - (let ((i 0) a b c d e f) - (values - (position-if - (progn (setf a (incf i)) #'zerop) - (progn (setf b (incf i)) '(3 1 8 2 1 2 3 4)) - :key (progn (setf c (incf i)) #'1-) - :end (progn (setf d (incf i)) 6) - :start (progn (setf e (incf i)) 1) - :from-end (setf f (incf i))) - i a b c d e f)) - 4 6 1 2 3 4 5 6) - -;;; Keyword tests - -(deftest position-if.allow-other-keys.1 - (position-if #'zerop '(1 2 0 3 2 1) :allow-other-keys t) - 2) - -(deftest position-if.allow-other-keys.2 - (position-if #'zerop '(1 2 0 3 2 1) :allow-other-keys nil) - 2) - -(deftest position-if.allow-other-keys.3 - (position-if #'zerop '(1 2 0 3 2 1) :allow-other-keys t :bad t) - 2) - -(deftest position-if.allow-other-keys.4 - (position-if #'zerop '(1 2 0 3 2 1) :bad t :allow-other-keys t) - 2) - -(deftest position-if.allow-other-keys.5 - (position-if #'zerop '(1 2 0 3 2 1) :bad t :allow-other-keys t :key #'1-) - 0) - -(deftest position-if.keywords.6 - (position-if #'zerop '(1 2 0 3 2 1) :key #'1- :key #'identity) - 0) - -(deftest position-if.allow-other-keys.7 - (position-if #'zerop '(1 2 0 3 2 1) :bad t :allow-other-keys t - :allow-other-keys nil) - 2) - -(deftest position-if.allow-other-keys.8 - (position-if #'zerop '(1 2 0 3 2 1) :allow-other-keys t :bad t - :allow-other-keys nil) - 2) - -(deftest position-if.allow-other-keys.9 - (position-if #'zerop '(1 2 0 3 2 1) :allow-other-keys t - :allow-other-keys nil :bad t) - 2) - - -;;; Error tests - -(deftest position-if.error.1 - (check-type-error #'(lambda (x) (position-if #'identity x)) #'sequencep) - nil) - -(deftest position-if.error.4 - (signals-error (position-if 'null '(a b c . d)) type-error) - t) - -(deftest position-if.error.5 - (signals-error (position-if) program-error) - t) - -(deftest position-if.error.6 - (signals-error (position-if #'null) program-error) - t) - -(deftest position-if.error.7 - (signals-error (position-if #'null nil :key) program-error) - t) - -(deftest position-if.error.8 - (signals-error (position-if #'null nil 'bad t) program-error) - t) - -(deftest position-if.error.9 - (signals-error (position-if #'null nil 'bad t :allow-other-keys nil) program-error) - t) - -(deftest position-if.error.10 - (signals-error (position-if #'null nil 1 2) program-error) - t) - -(deftest position-if.error.11 - (signals-error (locally (position-if #'identity 'b) t) type-error) - t) - -(deftest position-if.error.12 - (signals-error (position-if #'cons '(a b c d)) program-error) - t) - -(deftest position-if.error.13 - (signals-error (position-if #'car '(a b c d)) type-error) - t) - -(deftest position-if.error.14 - (signals-error (position-if #'identity '(a b c d) :key #'cdr) type-error) - t) - -(deftest position-if.error.15 - (signals-error (position-if #'identity '(a b c d) :key #'cons) program-error) - t) diff --git a/t/ansi-test/sequences/position.lsp b/t/ansi-test/sequences/position.lsp deleted file mode 100644 index 615822f..0000000 --- a/t/ansi-test/sequences/position.lsp +++ /dev/null @@ -1,860 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Aug 23 07:49:49 2002 -;;;; Contains: Tests for POSITION - -(in-package :cl-test) - -(deftest position-list.1 - (position 'c '(a b c d e c a)) - 2) - -(deftest position-list.2 - (position 'c '(a b c d e c a) :from-end t) - 5) - -(deftest position-list.3 - (loop for i from 0 to 7 collect - (position 'c '(a b c d e c a) :start i)) - (2 2 2 5 5 5 nil nil)) - -(deftest position-list.4 - (loop for i from 0 to 7 collect - (position 'c '(a b c d e c a) :start i :end nil)) - (2 2 2 5 5 5 nil nil)) - -(deftest position-list.5 - (loop for i from 7 downto 0 collect - (position 'c '(a b c d e c a) :end i)) - (2 2 2 2 2 nil nil nil)) - -(deftest position-list.6 - (loop for i from 0 to 7 collect - (position 'c '(a b c d e c a) :start i :from-end t)) - (5 5 5 5 5 5 nil nil)) - -(deftest position-list.7 - (loop for i from 0 to 7 collect - (position 'c '(a b c d e c a) :start i :end nil :from-end t)) - (5 5 5 5 5 5 nil nil)) - -(deftest position-list.8 - (loop for i from 7 downto 0 collect - (position 'c '(a b c d e c a) :end i :from-end t)) - (5 5 2 2 2 nil nil nil)) - -(deftest position-list.9 - (loop for i from 0 to 6 collect - (loop for j from (1+ i) to 7 - collect - (position 'c '(a b c d e c a) :start i :end j))) - ((nil nil 2 2 2 2 2) - (nil 2 2 2 2 2) - (2 2 2 2 2) - (nil nil 5 5) - (nil 5 5) - (5 5) - (nil))) - -(deftest position-list.10 - (loop for i from 0 to 6 collect - (loop for j from (1+ i) to 7 - collect - (position 'c '(a b c d e c a) :start i :end j :from-end t))) - ((nil nil 2 2 2 5 5) - (nil 2 2 2 5 5) - (2 2 2 5 5) - (nil nil 5 5) - (nil 5 5) - (5 5) - (nil))) - -(deftest position-list.11 - (position 5 '(1 2 3 4 5 6 4 8) :key #'1+) - 3) - -(deftest position-list.12 - (position 5 '(1 2 3 4 5 6 4 8) :key '1+) - 3) - -(deftest position-list.13 - (position 5 '(1 2 3 4 5 6 4 8) :key #'1+ :from-end t) - 6) - -(deftest position-list.14 - (position 'a '(a a b a c e d a f a) :test (complement #'eql)) - 2) - -(deftest position-list.15 - (position 'a '(a a b a c e d a f a) :test (complement #'eql) - :from-end t) - 8) - -(deftest position-list.16 - (position 'a '(a a b a c e d a f a) :test-not #'eql) - 2) - -(deftest position-list.17 - (position 'a '(a a b a c e d a f a) :test-not 'eql - :from-end t) - 8) - -(deftest position-list.18 - (position 'a '(a a b a c e d a f a) :test-not 'eql) - 2) - -(deftest position-list.19 - (position 'a '(a a b a c e d a f a) :test-not #'eql - :from-end t) - 8) - -(deftest position-list.20 - (position 'a '(a a b a c e d a f a) :test-not #'eql) - 2) - -(deftest position-list.21 - (position 'a '(a a b a c e d a f a) :test #'eql - :start 2) - 3) - -(deftest position-list.22 - (position 'a '(a a b a c e d a f a) :test #'eql - :start 2 :end nil) - 3) - -(deftest position-list.23 - (position 'a '(a a b a c e d a f a) :test-not #'eql - :start 0 :end 5) - 2) - -(deftest position-list.24 - (position 'a '(a a b a c e d a f a) :test-not #'eql - :start 0 :end 5 :from-end t) - 4) - -(deftest position-list.25 - (position '(a b) '(a (b a) (a b c) (a b) (d e) f) :test #'equal) - 3) - -(deftest position-list.26 - (position 'a '((c) (b a) (a b c) (a b) (d e) f) :key #'car) - 2) - -(deftest position-list.27 - (position 'a '((c) (b a) (a b c) (z) (a b) (d e) f) :key #'car - :start 3) - 4) - -(deftest position-list.28 - (position 'a '((c) (b a) (a b c) (z) (a b) (d e) (f)) :key #'car - :start 2 :from-end t) - 4) - -(deftest position-list.29 - (position 10 '(1 4 8 10 15 20) :test #'<) - 4) - -(deftest position-list.30 - (position 10 '(1 4 8 10 15 20) :test-not #'>=) - 4) - -;;; Tests on vectors - -(deftest position-vector.1 - (position 'c #(a b c d e c a)) - 2) - -(deftest position-vector.2 - (position 'c #(a b c d e c a) :from-end t) - 5) - -(deftest position-vector.3 - (loop for i from 0 to 7 collect - (position 'c #(a b c d e c a) :start i)) - (2 2 2 5 5 5 nil nil)) - -(deftest position-vector.4 - (loop for i from 0 to 7 collect - (position 'c #(a b c d e c a) :start i :end nil)) - (2 2 2 5 5 5 nil nil)) - -(deftest position-vector.5 - (loop for i from 7 downto 0 collect - (position 'c #(a b c d e c a) :end i)) - (2 2 2 2 2 nil nil nil)) - -(deftest position-vector.6 - (loop for i from 0 to 7 collect - (position 'c #(a b c d e c a) :start i :from-end t)) - (5 5 5 5 5 5 nil nil)) - -(deftest position-vector.7 - (loop for i from 0 to 7 collect - (position 'c #(a b c d e c a) :start i :end nil :from-end t)) - (5 5 5 5 5 5 nil nil)) - -(deftest position-vector.8 - (loop for i from 7 downto 0 collect - (position 'c #(a b c d e c a) :end i :from-end t)) - (5 5 2 2 2 nil nil nil)) - -(deftest position-vector.9 - (loop for i from 0 to 6 collect - (loop for j from (1+ i) to 7 - collect - (position 'c #(a b c d e c a) :start i :end j))) - ((nil nil 2 2 2 2 2) - (nil 2 2 2 2 2) - (2 2 2 2 2) - (nil nil 5 5) - (nil 5 5) - (5 5) - (nil))) - -(deftest position-vector.10 - (loop for i from 0 to 6 collect - (loop for j from (1+ i) to 7 - collect - (position 'c #(a b c d e c a) :start i :end j :from-end t))) - ((nil nil 2 2 2 5 5) - (nil 2 2 2 5 5) - (2 2 2 5 5) - (nil nil 5 5) - (nil 5 5) - (5 5) - (nil))) - -(deftest position-vector.11 - (position 5 #(1 2 3 4 5 6 4 8) :key #'1+) - 3) - -(deftest position-vector.12 - (position 5 #(1 2 3 4 5 6 4 8) :key '1+) - 3) - -(deftest position-vector.13 - (position 5 #(1 2 3 4 5 6 4 8) :key #'1+ :from-end t) - 6) - -(deftest position-vector.14 - (position 'a #(a a b a c e d a f a) :test (complement #'eql)) - 2) - -(deftest position-vector.15 - (position 'a #(a a b a c e d a f a) :test (complement #'eql) - :from-end t) - 8) - -(deftest position-vector.16 - (position 'a #(a a b a c e d a f a) :test-not #'eql) - 2) - -(deftest position-vector.17 - (position 'a #(a a b a c e d a f a) :test-not 'eql - :from-end t) - 8) - -(deftest position-vector.18 - (position 'a #(a a b a c e d a f a) :test-not 'eql) - 2) - -(deftest position-vector.19 - (position 'a #(a a b a c e d a f a) :test-not #'eql - :from-end t) - 8) - -(deftest position-vector.20 - (position 'a #(a a b a c e d a f a) :test-not #'eql) - 2) - -(deftest position-vector.21 - (position 'a #(a a b a c e d a f a) :test #'eql - :start 2) - 3) - -(deftest position-vector.22 - (position 'a #(a a b a c e d a f a) :test #'eql - :start 2 :end nil) - 3) - -(deftest position-vector.23 - (position 'a #(a a b a c e d a f a) :test-not #'eql - :start 0 :end 5) - 2) - -(deftest position-vector.24 - (position 'a #(a a b a c e d a f a) :test-not #'eql - :start 0 :end 5 :from-end t) - 4) - -(deftest position-vector.25 - (position '(a b) #(a (b a) (a b c) (a b) (d e) f) :test #'equal) - 3) - -(deftest position-vector.26 - (position 'a #((c) (b a) (a b c) (a b) (d e) f) :key #'car) - 2) - -(deftest position-vector.27 - (position 'a #((c) (b a) (a b c) (z) (a b) (d e) f) :key #'car - :start 3) - 4) - -(deftest position-vector.28 - (position 'a #((c) (b a) (a b c) (z) (a b) (d e) (f)) :key #'car - :start 2 :from-end t) - 4) - -(deftest position-vector.29 - (position 'a (make-array '(10) :initial-contents '(b b b b b a a a a a) - :fill-pointer 5)) - nil) - -(deftest position-vector.30 - (position 'a (make-array '(10) :initial-contents '(b b b b a a a a a a) - :fill-pointer 5)) - 4) - -(deftest position-vector.31 - (position 'a (make-array '(10) :initial-contents '(b a b b a a a a a a) - :fill-pointer 5) - :from-end t) - 4) - -(deftest position-vector.32 - (position 10 #(1 4 8 10 15 20) :test #'<) - 4) - -(deftest position-vector.33 - (position 10 #(1 4 8 10 15 20) :test-not #'>=) - 4) - -(deftest position-vector.34 - (let* ((v1 #(x x x a b c d a b c d y y y y y)) - (v2 (make-array '(8) :displaced-to v1 - :displaced-index-offset 3))) - (values (position 'c v2) - (position 'c v2 :from-end t))) - 2 6) - -;;; tests on bit vectors - -(deftest position-bit-vector.1 - (position 1 #*001001010100) - 2) - -(deftest position-bit-vector.2 - (position 1 #*001001010100 :from-end t) - 9) - -(deftest position-bit-vector.3 - (loop for i from 0 to 7 collect - (position 1 #*0010010 :start i)) - (2 2 2 5 5 5 nil nil)) - -(deftest position-bit-vector.4 - (loop for i from 0 to 7 collect - (position 1 #*0010010 :start i :end nil)) - (2 2 2 5 5 5 nil nil)) - -(deftest position-bit-vector.5 - (loop for i from 7 downto 0 collect - (position 1 #*0010010 :end i)) - (2 2 2 2 2 nil nil nil)) - -(deftest position-bit-vector.6 - (loop for i from 0 to 7 collect - (position 1 #*0010010 :start i :from-end t)) - (5 5 5 5 5 5 nil nil)) - -(deftest position-bit-vector.7 - (loop for i from 0 to 7 collect - (position 0 #*1101101 :start i :end nil :from-end t)) - (5 5 5 5 5 5 nil nil)) - -(deftest position-bit-vector.8 - (loop for i from 7 downto 0 collect - (position 0 #*1101101 :end i :from-end t)) - (5 5 2 2 2 nil nil nil)) - -(deftest position-bit-vector.9 - (loop for i from 0 to 6 collect - (loop for j from (1+ i) to 7 - collect - (position 1 #*0010010 :start i :end j))) - ((nil nil 2 2 2 2 2) - (nil 2 2 2 2 2) - (2 2 2 2 2) - (nil nil 5 5) - (nil 5 5) - (5 5) - (nil))) - -(deftest position-bit-vector.10 - (loop for i from 0 to 6 collect - (loop for j from (1+ i) to 7 - collect - (position 1 #*0010010 :start i :end j :from-end t))) - ((nil nil 2 2 2 5 5) - (nil 2 2 2 5 5) - (2 2 2 5 5) - (nil nil 5 5) - (nil 5 5) - (5 5) - (nil))) - -(deftest position-bit-vector.11 - (position 2 #*00010001010 :key #'1+) - 3) - -(deftest position-bit-vector.12 - (position 2 #*00010001010 :key '1+) - 3) - -(deftest position-bit-vector.13 - (position 2 #*0010001000 :key #'1+ :from-end t) - 6) - -(deftest position-bit-vector.14 - (position 0 #*0010111010 :test (complement #'eql)) - 2) - -(deftest position-bit-vector.15 - (position 0 #*0010111010 :test (complement #'eql) - :from-end t) - 8) - -(deftest position-bit-vector.16 - (position 0 #*0010111010 :test-not #'eql) - 2) - -(deftest position-bit-vector.17 - (position 0 #*001011101 :test-not 'eql - :from-end t) - 8) - -(deftest position-bit-vector.18 - (position 0 #*00101110 :test-not 'eql) - 2) - -(deftest position-bit-vector.19 - (position 0 #*00101110 :test-not #'eql - :from-end t) - 6) - -(deftest position-bit-vector.20 - (position 0 #*00101110 :test-not #'eql) - 2) - -(deftest position-bit-vector.21 - (position 0 #*00101110 :test #'eql - :start 2) - 3) - -(deftest position-bit-vector.22 - (position 0 #*00101110 :test #'eql - :start 2 :end nil) - 3) - -(deftest position-bit-vector.23 - (position 0 #*00101110 :test-not #'eql - :start 0 :end 5) - 2) - -(deftest position-bit-vector.24 - (position 0 #*00101110 :test-not #'eql - :start 0 :end 5 :from-end t) - 4) - -(deftest position-bit-vector.25 - (position 2 #*1100001010 :key #'1+ - :start 3) - 6) - -(deftest position-bit-vector.27 - (position 2 #*1100001010 :key #'1+ - :start 2 :from-end t) - 8) - -(deftest position-bit-vector.28 - (position 0 (make-array '(10) :initial-contents '(1 1 1 1 1 0 0 0 0 0) - :element-type 'bit - :fill-pointer 5)) - nil) - -(deftest position-bit-vector.29 - (position 0 (make-array '(10) :initial-contents '(1 1 1 1 1 0 0 0 0 0) - :element-type 'bit - :fill-pointer 5) - :from-end t) - nil) - -(deftest position-bit-vector.30 - (position 0 (make-array '(10) :initial-contents '(1 1 1 1 0 0 0 0 0 0) - :element-type 'bit - :fill-pointer 5)) - 4) - -(deftest position-bit-vector.31 - (position 0 (make-array '(10) :initial-contents '(0 1 0 1 0 0 0 0 0 0) - :element-type 'bit - :fill-pointer 5) - :from-end t) - 4) - -(deftest position-bit-vector.32 - (position 0 (make-array '(10) :initial-contents '(1 0 1 1 0 0 0 0 0 0) - :element-type 'bit - :fill-pointer 5)) - 1) - -(deftest position-bit-vector.33 - (position 0 #*1111000 :test #'>=) - 4) - -(deftest position-bit-vector.34 - (position 0 #*1111000 :test-not #'<) - 4) - -;;; strings - -(deftest position-string.1 - (position #\c "abcdeca") - 2) - -(deftest position-string.2 - (position #\c "abcdeca" :from-end t) - 5) - -(deftest position-string.3 - (loop for i from 0 to 7 collect - (position #\c "abcdeca" :start i)) - (2 2 2 5 5 5 nil nil)) - -(deftest position-string.4 - (loop for i from 0 to 7 collect - (position #\c "abcdeca" :start i :end nil)) - (2 2 2 5 5 5 nil nil)) - -(deftest position-string.5 - (loop for i from 7 downto 0 collect - (position #\c "abcdeca" :end i)) - (2 2 2 2 2 nil nil nil)) - -(deftest position-string.6 - (loop for i from 0 to 7 collect - (position #\c "abcdeca" :start i :from-end t)) - (5 5 5 5 5 5 nil nil)) - -(deftest position-string.7 - (loop for i from 0 to 7 collect - (position #\c "abcdeca" :start i :end nil :from-end t)) - (5 5 5 5 5 5 nil nil)) - -(deftest position-string.8 - (loop for i from 7 downto 0 collect - (position #\c "abcdeca" :end i :from-end t)) - (5 5 2 2 2 nil nil nil)) - -(deftest position-string.9 - (loop for i from 0 to 6 collect - (loop for j from (1+ i) to 7 - collect - (position #\c "abcdeca" :start i :end j))) - ((nil nil 2 2 2 2 2) - (nil 2 2 2 2 2) - (2 2 2 2 2) - (nil nil 5 5) - (nil 5 5) - (5 5) - (nil))) - -(deftest position-string.10 - (loop for i from 0 to 6 collect - (loop for j from (1+ i) to 7 - collect - (position #\c "abcdeca" :start i :end j :from-end t))) - ((nil nil 2 2 2 5 5) - (nil 2 2 2 5 5) - (2 2 2 5 5) - (nil nil 5 5) - (nil 5 5) - (5 5) - (nil))) - -(deftest position-string.11 - (position 5 "12345648" :key #'(lambda (c) - (1+ (read-from-string (string c))))) - 3) - -(deftest position-string.13 - (position 5 "12345648" :key #'(lambda (c) - (1+ (read-from-string (string c)))) - :from-end t) - 6) - -(deftest position-string.14 - (position #\a "aabacedafa" :test (complement #'eql)) - 2) - -(deftest position-string.15 - (position #\a "aabacedafa" :test (complement #'eql) - :from-end t) - 8) - -(deftest position-string.16 - (position #\a "aabacedafa" :test-not #'eql) - 2) - -(deftest position-string.17 - (position #\a "aabacedafa" :test-not 'eql - :from-end t) - 8) - -(deftest position-string.18 - (position #\a "aabacedafa" :test-not 'eql) - 2) - -(deftest position-string.19 - (position #\a "aabacedafa" :test-not #'eql - :from-end t) - 8) - -(deftest position-string.20 - (position #\a "aabacedafa" :test-not #'eql) - 2) - -(deftest position-string.21 - (position #\a "aabacedafa" :test #'eql - :start 2) - 3) - -(deftest position-string.22 - (position #\a "aabacedafa" :test #'eql - :start 2 :end nil) - 3) - -(deftest position-string.23 - (position #\a "aabacedafa" :test-not #'eql - :start 0 :end 5) - 2) - -(deftest position-string.24 - (position #\a "aabacedafa" :test-not #'eql - :start 0 :end 5 :from-end t) - 4) - -(deftest position-string.25 - (position #\a (make-array '(10) :initial-contents "bbbbbaaaaa" - :element-type 'character - :fill-pointer 5)) - nil) - -(deftest position-string.26 - (position #\a (make-array '(10) :initial-contents "bbbbbaaaaa" - :element-type 'character - :fill-pointer 5) - :from-end t) - nil) - -(deftest position-string.27 - (position #\a (make-array '(10) :initial-contents "bbbbaaaaaa" - :element-type 'character - :fill-pointer 5)) - 4) - -(deftest position-string.28 - (position #\a (make-array '(10) :initial-contents "babbaaaaaa" - :element-type 'character - :fill-pointer 5) - :from-end t) - 4) - -(deftest position-string.29 - (position #\m "adfmpz" :test #'char<) - 4) - -(deftest position-string.30 - (position #\m "adfmpz" :test-not #'char>=) - 4) - -(deftest position-string.31 - (let* ((s1 (copy-seq "xxxabcdyyyyy")) - (s2 (make-array '(4) :displaced-to s1 - :displaced-index-offset 3 - :element-type (array-element-type s1)))) - (position #\c s2)) - 2) - -(deftest position-string.32 - (let* ((s1 (copy-seq "xxxabcdabcdyyyyyyyy")) - (s2 (make-array '(8) :displaced-to s1 - :displaced-index-offset 3 - :element-type (array-element-type s1)))) - (position #\c s2 :from-end t)) - 6) - -(deftest position-string.33 - (do-special-strings - (s "abcdabcdabcd" nil) - (let* ((c #\c) - (pos (position c s))) - (assert (eql pos 2) () "First position of ~A in ~A is ~A" c s pos))) - nil) - -(deftest position-string.34 - (do-special-strings - (s "abcdabcdabcd" nil) - (let* ((c #\c) - (pos (position c s :from-end t))) - (assert (eql pos 10) () "Last position of ~A in ~A is ~A" c s pos))) - nil) - -(defharmless position.test-and-test-not.1 - (position 'b '(a b c d) :test #'eql :test-not #'eql)) - -(defharmless position.test-and-test-not.2 - (position 'b '(a b c d) :test-not #'eql :test #'eql)) - -(defharmless position.test-and-test-not.3 - (position 'b #(a b c d) :test #'eql :test-not #'eql)) - -(defharmless position.test-and-test-not.4 - (position 'b #(a b c d) :test-not #'eql :test #'eql)) - -(defharmless position.test-and-test-not.5 - (position #\b "abcd" :test #'eql :test-not #'eql)) - -(defharmless position.test-and-test-not.6 - (position #\b "abcd" :test-not #'eql :test #'eql)) - -(defharmless position.test-and-test-not.7 - (position 1 #*001010010 :test #'eql :test-not #'eql)) - -(defharmless position.test-and-test-not.8 - (position 0 #*1110010110111 :test-not #'eql :test #'eql)) - -(deftest position.order.1 - (let ((i 0) a b c d e f g) - (values - (position - (progn (setf a (incf i)) 0) - (progn (setf b (incf i)) '(3 1 8 2 1 2 3 4)) - :from-end (setf c (incf i)) - :start (progn (setf d (incf i)) 1) - :end (progn (setf e (incf i)) 6) - :key (progn (setf f (incf i)) #'1-) - :test (progn (setf g (incf i)) #'=) - ) - i a b c d e f g)) - 4 7 1 2 3 4 5 6 7) - -(deftest position.order.2 - (let ((i 0) a b c d e f g) - (values - (position - (progn (setf a (incf i)) 0) - (progn (setf b (incf i)) '(3 1 8 2 1 2 3 4)) - :test-not (progn (setf c (incf i)) #'/=) - :key (progn (setf d (incf i)) #'1-) - :end (progn (setf e (incf i)) 6) - :start (progn (setf f (incf i)) 1) - :from-end (setf g (incf i)) - ) - i a b c d e f g)) - 4 7 1 2 3 4 5 6 7) - -;;; Keyword tests - -(deftest position.allow-other-keys.1 - (position 0 '(1 2 0 3 2 1) :allow-other-keys t) - 2) - -(deftest position.allow-other-keys.2 - (position 0 '(1 2 0 3 2 1) :allow-other-keys nil) - 2) - -(deftest position.allow-other-keys.3 - (position 0 '(1 2 0 3 2 1) :allow-other-keys t :bad t) - 2) - -(deftest position.allow-other-keys.4 - (position 0 '(1 2 0 3 2 1) :bad t :allow-other-keys t) - 2) - -(deftest position.allow-other-keys.5 - (position 0 '(1 2 0 3 2 1) :bad t :allow-other-keys t :key #'1-) - 0) - -(deftest position.keywords.6 - (position 0 '(1 2 0 3 2 1) :key #'1- :key #'identity) - 0) - -(deftest position.allow-other-keys.7 - (position 0 '(1 2 0 3 2 1) :bad t :allow-other-keys t - :allow-other-keys nil) - 2) - -(deftest position.allow-other-keys.8 - (position 0 '(1 2 0 3 2 1) :allow-other-keys t :bad t - :allow-other-keys nil) - 2) - -(deftest position.allow-other-keys.9 - (position 0 '(1 2 0 3 2 1) :allow-other-keys t - :allow-other-keys nil :bad t) - 2) - -;;; Error tests - -(deftest position.error.1 - (check-type-error #'(lambda (x) (position 'a x)) #'sequencep) - nil) - -(deftest position.error.4 - (signals-error (position 'e '(a b c . d)) type-error) - t) - -(deftest position.error.5 - (signals-error (position) program-error) - t) - -(deftest position.error.6 - (signals-error (position 'a) program-error) - t) - -(deftest position.error.7 - (signals-error (position 'a nil :key) program-error) - t) - -(deftest position.error.8 - (signals-error (position 'a nil 'bad t) program-error) - t) - -(deftest position.error.9 - (signals-error (position 'a nil 'bad t :allow-other-keys nil) program-error) - t) - -(deftest position.error.10 - (signals-error (position 'a nil 1 2) program-error) - t) - -(deftest position.error.11 - (signals-error (locally (position 'a 'b) t) type-error) - t) - -(deftest position.error.12 - (signals-error (position 'b '(a b c d) :test #'identity) program-error) - t) - -(deftest position.error.13 - (signals-error (position 'b '(a b c d) :test-not #'not) program-error) - t) - -(deftest position.error.14 - (signals-error (position 'b '(a b c d) :key #'cdr) type-error) - t) - -(deftest position.error.15 - (signals-error (position 'b '(a b c d) :key #'cons) program-error) - t) diff --git a/t/ansi-test/sequences/reduce.lsp b/t/ansi-test/sequences/reduce.lsp deleted file mode 100644 index d421fd8..0000000 --- a/t/ansi-test/sequences/reduce.lsp +++ /dev/null @@ -1,545 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Aug 18 14:08:57 2002 -;;;; Contains: Tests for function REDUCE - -(in-package :cl-test) - -(deftest reduce-list.1 - (reduce #'cons '(a b c d e f)) - (((((a . b) . c) . d) . e) . f)) - -(deftest reduce-list.2 - (reduce #'cons '(a b c d e f) :from-end t) - (a b c d e . f)) - -(deftest reduce-list.3 - (reduce #'cons '(a b c d e f) :initial-value 'z) - ((((((z . a) . b) . c) . d) . e) . f)) - -(deftest reduce-list.4 - (reduce #'cons '(a b c d e f) :from-end t :initial-value 'g) - (a b c d e f . g)) - -(deftest reduce-list.5 - (reduce #'cons '(a b c d e f) :from-end nil) - (((((a . b) . c) . d) . e) . f)) - -(deftest reduce-list.6 - (reduce #'cons '(a b c d e f) :from-end 17) - (a b c d e . f)) - -(deftest reduce-list.7 - (reduce #'cons '(a b c d e f) :end nil) - (((((a . b) . c) . d) . e) . f)) - -(deftest reduce-list.8 - (reduce #'cons '(a b c d e f) :end 3) - ((a . b) . c)) - -(deftest reduce-list.9 - (reduce #'cons '(a b c d e f) :start 1 :end 4) - ((b . c) . d)) - -(deftest reduce-list.10 - (reduce #'cons '(a b c d e f) :start 1 :end 4 :from-end t) - (b c . d)) - -(deftest reduce-list.11 - (reduce #'cons '(a b c d e f) :start 1 :end 4 :from-end t - :initial-value nil) - (b c d)) - -(deftest reduce-list.12 - (reduce 'cons '(a b c d e f)) - (((((a . b) . c) . d) . e) . f)) - -(deftest reduce-list.13 - (reduce #'+ nil) - 0) - -(deftest reduce-list.14 - (reduce #'+ '(1 2 3) :start 0 :end 0) - 0) - -(deftest reduce-list.15 - (reduce #'+ '(1 2 3) :key '1+) - 9) - -(deftest reduce-list.16 - (reduce #'cons '(1 2 3) :key '1+ :from-end t :initial-value nil) - (2 3 4)) - -(deftest reduce-list.17 - (reduce #'+ '(1 2 3 4 5 6 7) :key '1+ :start 2 :end 6) - 22) - -;;;;;;; - -(deftest reduce-array.1 - (reduce #'cons #(a b c d e f)) - (((((a . b) . c) . d) . e) . f)) - -(deftest reduce-array.2 - (reduce #'cons #(a b c d e f) :from-end t) - (a b c d e . f)) - -(deftest reduce-array.3 - (reduce #'cons #(a b c d e f) :initial-value 'z) - ((((((z . a) . b) . c) . d) . e) . f)) - -(deftest reduce-array.4 - (reduce #'cons #(a b c d e f) :from-end t :initial-value 'g) - (a b c d e f . g)) - -(deftest reduce-array.5 - (reduce #'cons #(a b c d e f) :from-end nil) - (((((a . b) . c) . d) . e) . f)) - -(deftest reduce-array.6 - (reduce #'cons #(a b c d e f) :from-end 17) - (a b c d e . f)) - -(deftest reduce-array.7 - (reduce #'cons #(a b c d e f) :end nil) - (((((a . b) . c) . d) . e) . f)) - -(deftest reduce-array.8 - (reduce #'cons #(a b c d e f) :end 3) - ((a . b) . c)) - -(deftest reduce-array.9 - (reduce #'cons #(a b c d e f) :start 1 :end 4) - ((b . c) . d)) - -(deftest reduce-array.10 - (reduce #'cons #(a b c d e f) :start 1 :end 4 :from-end t) - (b c . d)) - -(deftest reduce-array.11 - (reduce #'cons #(a b c d e f) :start 1 :end 4 :from-end t - :initial-value nil) - (b c d)) - -(deftest reduce-array.12 - (reduce 'cons #(a b c d e f)) - (((((a . b) . c) . d) . e) . f)) - -(deftest reduce-array.13 - (reduce #'+ #(1 2 3) :start 0 :end 0) - 0) - -(deftest reduce-array.14 - (let ((a (make-array '(8) :initial-contents '(1 2 3 4 5 6 7 8) - :fill-pointer 4))) - (reduce #'+ a)) - 10) - -(deftest reduce-array.15 - (let ((a (make-array '(8) :initial-contents '(1 2 3 4 5 6 7 8) - :fill-pointer 4))) - (reduce #'+ a :end nil)) - 10) - -(deftest reduce-array.16 - (let ((a (make-array '(8) :initial-contents '(1 2 3 4 5 6 7 8) - :fill-pointer 4))) - (reduce #'+ a :from-end t)) - 10) - -(deftest reduce-array.17 - (let ((a (make-array '(8) :initial-contents '(1 2 3 4 5 6 7 8) - :fill-pointer 4))) - (reduce #'+ a :initial-value 1)) - 11) - -(deftest reduce-array.18 - (let ((a (make-array '(8) :initial-contents '(1 2 3 4 5 6 7 8) - :fill-pointer 4))) - (reduce #'+ a :initial-value 1 :start 2)) - 8) - -(deftest reduce-array.19 - (let ((a (make-array '(8) :initial-contents '(1 2 3 4 5 6 7 8) - :fill-pointer 4))) - (reduce #'+ a :end 3)) - 6) - -;;; Specialized vectors - -(deftest reduce-array.20 - (do-special-integer-vectors - (v #(1 0 0 1 1 0) nil) - (assert (eql (reduce #'+ v) 3))) - nil) - -(deftest reduce-array.21 - (do-special-integer-vectors - (v #(1 0 0 1 1 0) nil) - (assert (equal (reduce #'cons v :from-end t :initial-value nil) - '(1 0 0 1 1 0)))) - nil) - -(deftest reduce-array.22 - (do-special-integer-vectors - (v #(1 2 3 4 5 6 7) nil) - (assert (eql (reduce #'+ v) 28)) - (assert (eql (reduce #'+ v :from-end t) 28)) - (assert (eql (reduce #'+ v :start 1) 27)) - (assert (eql (reduce #'+ v :initial-value 10) 38)) - (assert (eql (reduce #'+ v :end 6) 21))) - nil) - -(deftest reduce-array.23 - (let* ((len 10) - (expected (* 1/2 (1+ len) len))) - (loop for etype in '(short-float single-float double-float long-float) - for vals = (loop for i from 1 to len collect (coerce i etype)) - for vec = (make-array len :initial-contents vals :element-type etype) - for result = (reduce #'+ vec) - unless (= result (coerce expected etype)) - collect (list etype vals vec result))) - nil) - -(deftest reduce-array.24 - (let* ((len 10) - (expected (* 1/2 (1+ len) len))) - (loop for cetype in '(short-float single-float double-float long-float) - for etype = `(complex ,cetype) - for vals = (loop for i from 1 to len collect (complex (coerce i cetype) - (coerce (- i) cetype))) - for vec = (make-array len :initial-contents vals :element-type etype) - for result = (reduce #'+ vec) - unless (= result (complex (coerce expected cetype) (coerce (- expected) cetype))) - collect (list etype vals vec result))) - nil) - -(deftest reduce-array.25 - (do-special-integer-vectors - (v (vector 0 most-positive-fixnum 0 most-positive-fixnum 0) nil) - (assert (eql (reduce #'+ v) (* 2 most-positive-fixnum)))) - nil) - -;;;;;;;; - -(deftest reduce.error.1 - (check-type-error #'(lambda (x) (reduce 'cons x)) #'sequencep) - nil) - -(deftest reduce.error.2 - (signals-error (reduce) program-error) - t) - -(deftest reduce.error.3 - (signals-error (reduce #'list nil :start) program-error) - t) - -(deftest reduce.error.4 - (signals-error (reduce #'list nil 'bad t) program-error) - t) - -(deftest reduce.error.5 - (signals-error (reduce #'list nil 'bad t :allow-other-keys nil) program-error) - t) - -(deftest reduce.error.6 - (signals-error (reduce #'list nil 1 2) program-error) - t) - -(deftest reduce.error.7 - (signals-error (locally (reduce 'cons 'a) t) type-error) - t) - -(deftest reduce.error.8 - (signals-error (reduce #'identity '(a b c)) program-error) - t) - -(deftest reduce.error.9 - (signals-error (reduce #'cons '(a b c) :key #'cons) program-error) - t) - -(deftest reduce.error.10 - (signals-error (reduce #'cons '(a b c) :key #'car) type-error) - t) - - -;;;;;;;; - -(deftest reduce-string.1 - (reduce #'cons "abcdef") - (((((#\a . #\b) . #\c) . #\d) . #\e) . #\f)) - -(deftest reduce-string.2 - (reduce #'cons "abcdef" :from-end t) - (#\a #\b #\c #\d #\e . #\f)) - -(deftest reduce-string.3 - (reduce #'cons "abcdef" :initial-value 'z) - ((((((z . #\a) . #\b) . #\c) . #\d) . #\e) . #\f)) - -(deftest reduce-string.4 - (reduce #'cons "abcdef" :from-end t :initial-value 'g) - (#\a #\b #\c #\d #\e #\f . g)) - -(deftest reduce-string.5 - (reduce #'cons "abcdef" :from-end nil) - (((((#\a . #\b) . #\c) . #\d) . #\e) . #\f)) - -(deftest reduce-string.6 - (reduce #'cons "abcdef" :from-end 17) - (#\a #\b #\c #\d #\e . #\f)) - -(deftest reduce-string.7 - (reduce #'cons "abcdef" :end nil) - (((((#\a . #\b) . #\c) . #\d) . #\e) . #\f)) - -(deftest reduce-string.8 - (reduce #'cons "abcdef" :end 3) - ((#\a . #\b) . #\c)) - -(deftest reduce-string.9 - (reduce #'cons "abcdef" :start 1 :end 4) - ((#\b . #\c) . #\d)) - -(deftest reduce-string.10 - (reduce #'cons "abcdef" :start 1 :end 4 :from-end t) - (#\b #\c . #\d)) - -(deftest reduce-string.11 - (reduce #'cons "abcdef" :start 1 :end 4 :from-end t - :initial-value nil) - (#\b #\c #\d)) - -(deftest reduce-string.12 - (reduce 'cons "abcdef") - (((((#\a . #\b) . #\c) . #\d) . #\e) . #\f)) - -(deftest reduce-string.13 - (reduce #'+ "abc" :start 0 :end 0) - 0) - -(deftest reduce-string.14 - (let ((s (make-array '(8) :initial-contents "abcdefgh" - :fill-pointer 6 - :element-type 'character))) - (coerce (reduce #'(lambda (x y) (cons y x)) s :initial-value nil) - 'string)) - "fedcba") - -(deftest reduce-string.15 - (let ((s (make-array '(8) :initial-contents "abcdefgh" - :fill-pointer 6 - :element-type 'character))) - (coerce (reduce #'(lambda (x y) (cons y x)) s :initial-value nil - :start 1) - 'string)) - "fedcb") - -(deftest reduce-string.16 - (let ((s (make-array '(8) :initial-contents "abcdefgh" - :fill-pointer 6 - :element-type 'character))) - (coerce (reduce #'(lambda (x y) (cons y x)) s :end nil - :initial-value nil) - 'string)) - "fedcba") - -(deftest reduce-string.17 - (let ((s (make-array '(8) :initial-contents "abcdefgh" - :fill-pointer 6 - :element-type 'character))) - (coerce (reduce #'(lambda (x y) (cons y x)) s :end 4 - :initial-value nil) - 'string)) - "dcba") - -(deftest reduce-string.18 - (do-special-strings - (s "12345" nil) - (let ((x (reduce #'(lambda (x y) (cons y x)) s))) - (assert (equal x '(#\5 #\4 #\3 #\2 . #\1))))) - nil) - -(deftest reduce-string.19 - (do-special-strings - (s "54321" nil) - (let ((x (reduce #'cons s :from-end t))) - (assert (equal x '(#\5 #\4 #\3 #\2 . #\1))))) - nil) - -(deftest reduce-string.20 - (do-special-strings - (s "12345" nil) - (let ((x (reduce #'(lambda (x y) (cons y x)) s :initial-value nil))) - (assert (equal x '(#\5 #\4 #\3 #\2 #\1))))) - nil) - -;;;;;;;; - -(deftest reduce-bitstring.1 - (reduce #'cons #*001101) - (((((0 . 0) . 1) . 1) . 0) . 1)) - -(deftest reduce-bitstring.2 - (reduce #'cons #*001101 :from-end t) - (0 0 1 1 0 . 1)) - -(deftest reduce-bitstring.3 - (reduce #'cons #*001101 :initial-value 'z) - ((((((z . 0) . 0) . 1) . 1) . 0) . 1)) - -(deftest reduce-bitstring.4 - (reduce #'cons #*001101 :from-end t :initial-value 'g) - (0 0 1 1 0 1 . g)) - -(deftest reduce-bitstring.5 - (reduce #'cons #*001101 :from-end nil) - (((((0 . 0) . 1) . 1) . 0) . 1)) - -(deftest reduce-bitstring.6 - (reduce #'cons #*001101 :from-end 17) - (0 0 1 1 0 . 1)) - -(deftest reduce-bitstring.7 - (reduce #'cons #*001101 :end nil) - (((((0 . 0) . 1) . 1) . 0) . 1)) - -(deftest reduce-bitstring.8 - (reduce #'cons #*001101 :end 3) - ((0 . 0) . 1)) - -(deftest reduce-bitstring.9 - (reduce #'cons #*001101 :start 1 :end 4) - ((0 . 1) . 1)) - -(deftest reduce-bitstring.10 - (reduce #'cons #*001101 :start 1 :end 4 :from-end t) - (0 1 . 1)) - -(deftest reduce-bitstring.11 - (reduce #'cons #*001101 :start 1 :end 4 :from-end t - :initial-value nil) - (0 1 1)) - -(deftest reduce-bitstring.12 - (reduce 'cons #*001101) - (((((0 . 0) . 1) . 1) . 0) . 1)) - -(deftest reduce-bitstring.13 - (reduce #'+ #(1 1 1) :start 0 :end 0) - 0) - -(deftest reduce-bitstring.14 - (let ((s (make-array '(8) :initial-contents '(0 0 1 0 1 1 0 1) - :fill-pointer 6 - :element-type 'bit))) - (reduce #'+ s)) - 3) - -(deftest reduce-bitstring.15 - (let ((s (make-array '(8) :initial-contents '(0 0 1 0 1 1 0 1) - :fill-pointer 6 - :element-type 'bit))) - (reduce #'+ s :start 3)) - 2) - -(deftest reduce-bitstring.16 - (let ((s (make-array '(8) :initial-contents '(0 0 1 0 1 1 0 1) - :fill-pointer 6 - :element-type 'bit))) - (reduce #'+ s :start 3 :initial-value 10)) - 12) - -(deftest reduce-bitstring.17 - (let ((s (make-array '(8) :initial-contents '(0 0 1 0 1 1 0 1) - :fill-pointer 6 - :element-type 'bit))) - (reduce #'+ s :end nil)) - 3) - -(deftest reduce-bitstring.18 - (let ((s (make-array '(8) :initial-contents '(1 1 1 1 1 1 1 1) - :fill-pointer 6 - :element-type 'bit))) - (reduce #'+ s :start 2 :end 4)) - 2) - -;;; Order of evaluation tests - -(deftest reduce.order.1 - (let ((i 0) x y) - (values - (reduce (progn (setf x (incf i)) #'cons) - (progn (setf y (incf i)) '(a b c))) - i x y)) - ((a . b) . c) 2 1 2) - -(deftest reduce.order.2 - (let ((i 0) a b c d e f g) - (values - (reduce (progn (setf a (incf i)) #'cons) - (progn (setf b (incf i)) '(a b c d e f)) - :from-end (progn (setf c (incf i)) t) - :initial-value (progn (setf d (incf i)) 'nil) - :start (progn (setf e (incf i)) 1) - :end (progn (setf f (incf i)) 4) - :key (progn (setf g (incf i)) #'identity) - ) - i a b c d e f g)) - (b c d) 7 1 2 3 4 5 6 7) - -(deftest reduce.order.3 - (let ((i 0) a b c d e f g) - (values - (reduce (progn (setf a (incf i)) #'cons) - (progn (setf b (incf i)) '(a b c d e f)) - :key (progn (setf c (incf i)) #'identity) - :end (progn (setf d (incf i)) 4) - :start (progn (setf e (incf i)) 1) - :initial-value (progn (setf f (incf i)) 'nil) - :from-end (progn (setf g (incf i)) t) - ) - i a b c d e f g)) - (b c d) 7 1 2 3 4 5 6 7) - - -;;; Keyword tests - -(deftest reduce.allow-other-keys.1 - (reduce #'+ '(1 2 3) :allow-other-keys t) - 6) - -(deftest reduce.allow-other-keys.2 - (reduce #'+ '(1 2 3) :allow-other-keys nil) - 6) - -(deftest reduce.allow-other-keys.3 - (reduce #'+ '(1 2 3) :bad t :allow-other-keys t) - 6) - -(deftest reduce.allow-other-keys.4 - (reduce #'+ '(1 2 3) :allow-other-keys t :bad t) - 6) - -(deftest reduce.allow-other-keys.5 - (reduce #'+ '(1 2 3) :allow-other-keys t :allow-other-keys nil :bad t) - 6) - -(deftest reduce.allow-other-keys.6 - (reduce #'+ '(1 2 3) :allow-other-keys t :bad t :allow-other-keys nil) - 6) - -(deftest reduce.allow-other-keys.7 - (reduce #'+ '(1 2 3) :bad t :allow-other-keys t :allow-other-keys nil) - 6) - -(deftest reduce.allow-other-keys.8 - (reduce #'cons '(1 2 3) :allow-other-keys t :from-end t :bad t - :initial-value nil) - (1 2 3)) - -(deftest reduce.keywords.9 - (reduce #'cons '(1 2 3) :from-end t :from-end nil - :initial-value nil :initial-value 'a) - (1 2 3)) - diff --git a/t/ansi-test/sequences/remove-duplicates.lsp b/t/ansi-test/sequences/remove-duplicates.lsp deleted file mode 100644 index df3113f..0000000 --- a/t/ansi-test/sequences/remove-duplicates.lsp +++ /dev/null @@ -1,462 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Sep 29 20:49:47 2002 -;;;; Contains: Tests for REMOVE-DUPLICATES, DELETE-DUPLICATES - -(in-package :cl-test) - - - - -(deftest random-remove-duplicates - (loop for result = (random-test-remove-dups (1+ (random 20))) - repeat 1000 - unless (eq result t) - collect result) - nil) - -(deftest random-delete-duplicates - (loop for result = (random-test-remove-dups (1+ (random 20)) nil) - repeat 1000 - unless (eq result t) - collect result) - nil) - -;;; Look for :KEY NIL bugs - -(deftest remove-duplicates.1 - (let* ((orig '(1 2 3 4 1 3 4 1 2 5 6 2 7)) - (x (copy-seq orig)) - (y (remove-duplicates x :key nil))) - (and (equalp orig x) y)) - (3 4 1 5 6 2 7)) - -(deftest delete-duplicates.1 - (let* ((orig '(1 2 3 4 1 3 4 1 2 5 6 2 7)) - (x (copy-seq orig)) - (y (delete-duplicates x :key nil))) - y) - (3 4 1 5 6 2 7)) - -(defharmless remove-duplicates.test-and-test-not.1 - (remove-duplicates (list 'a 'b 'c 'd 'a 'e 'f 'd 'g) :test #'eql - :test-not #'eql)) - -(defharmless remove-duplicates.test-and-test-not.2 - (remove-duplicates (list 'a 'b 'c 'd 'a 'e 'f 'd 'g) :test-not #'eql - :test #'eql)) - -(defharmless delete-duplicates.test-and-test-not.1 - (delete-duplicates (list 'a 'b 'c 'd 'a 'e 'f 'd 'g) :test #'eql - :test-not #'eql)) - -(defharmless delete-duplicates.test-and-test-not.2 - (delete-duplicates (list 'a 'b 'c 'd 'a 'e 'f 'd 'g) :test-not #'eql - :test #'eql)) - -;;; Const fold tests - -(def-fold-test remove-duplicates.fold.1 (remove-duplicates '(1 2 3 3))) -(def-fold-test remove-duplicates.fold.2 (remove-duplicates #(1 2 3 3))) -(def-fold-test remove-duplicates.fold.3 (remove-duplicates #*0011)) -(def-fold-test remove-duplicates.fold.4 (remove-duplicates "1233")) - -;;; Order of evaluation tests - -(deftest remove-duplicates.order.1 - (let ((i 0) a b c d e f) - (values - (remove-duplicates - (progn (setf a (incf i)) (list 1 2 3 1 3 1 2 4)) - :from-end (progn (setf b (incf i)) nil) - :start (progn (setf c (incf i)) 0) - :end (progn (setf d (incf i)) nil) - :key (progn (setf e (incf i)) #'identity) - :test (progn (setf f (incf i)) #'=) - ) - i a b c d e f)) - (3 1 2 4) 6 1 2 3 4 5 6) - -(deftest remove-duplicates.order.2 - (let ((i 0) a b c d e f) - (values - (remove-duplicates - (progn (setf a (incf i)) (list 1 2 3 1 3 1 2 4)) - :test-not (progn (setf b (incf i)) #'/=) - :key (progn (setf c (incf i)) #'identity) - :end (progn (setf d (incf i)) nil) - :start (progn (setf e (incf i)) 0) - :from-end (progn (setf f (incf i)) nil) - ) - i a b c d e f)) - (3 1 2 4) 6 1 2 3 4 5 6) - - -;;; Keyword tests - -(deftest remove-duplicates.allow-other-keys.1 - (remove-duplicates '(1 2 3 4 2 7 8 1 5) :allow-other-keys t) - (3 4 2 7 8 1 5)) - -(deftest remove-duplicates.allow-other-keys.2 - (remove-duplicates '(1 2 3 4 2 7 8 1 5) :allow-other-keys nil) - (3 4 2 7 8 1 5)) - -(deftest remove-duplicates.allow-other-keys.3 - (remove-duplicates '(1 2 3 4 2 7 8 1 5) :bad t :allow-other-keys t) - (3 4 2 7 8 1 5)) - -(deftest remove-duplicates.allow-other-keys.4 - (remove-duplicates '(1 2 3 4 2 7 8 1 5) :allow-other-keys t :bad t) - (3 4 2 7 8 1 5)) - -(deftest remove-duplicates.allow-other-keys.5 - (remove-duplicates '(1 2 3 4 2 7 8 1 5) :bad t - :allow-other-keys t :allow-other-keys nil) - (3 4 2 7 8 1 5)) - -(deftest remove-duplicates.allow-other-keys.6 - (remove-duplicates '(1 2 3 4 2 7 8 1 5) - :allow-other-keys t :bad t :allow-other-keys nil) - (3 4 2 7 8 1 5)) - -(deftest remove-duplicates.allow-other-keys.7 - (remove-duplicates '(1 2 3 4 2 7 8 1 5) - :allow-other-keys t :allow-other-keys nil :bad t) - (3 4 2 7 8 1 5)) - -(deftest remove-duplicates.allow-other-keys.8 - (remove-duplicates '(1 2 3 4 2 7 8 1 5) - :allow-other-keys t :from-end t) - (1 2 3 4 7 8 5)) - -(deftest remove-duplicates.keywords.1 - (remove-duplicates '(1 2 3 4 2 7 8 1 5) :from-end t :from-end nil) - (1 2 3 4 7 8 5)) - - -(deftest delete-duplicates.allow-other-keys.1 - (delete-duplicates (list 1 2 3 4 2 7 8 1 5) :allow-other-keys t) - (3 4 2 7 8 1 5)) - -(deftest delete-duplicates.allow-other-keys.2 - (delete-duplicates (list 1 2 3 4 2 7 8 1 5) :allow-other-keys nil) - (3 4 2 7 8 1 5)) - -(deftest delete-duplicates.allow-other-keys.3 - (delete-duplicates (list 1 2 3 4 2 7 8 1 5) :bad t :allow-other-keys t) - (3 4 2 7 8 1 5)) - -(deftest delete-duplicates.allow-other-keys.4 - (delete-duplicates (list 1 2 3 4 2 7 8 1 5) :allow-other-keys t :bad t) - (3 4 2 7 8 1 5)) - -(deftest delete-duplicates.allow-other-keys.5 - (delete-duplicates (list 1 2 3 4 2 7 8 1 5) :bad t - :allow-other-keys t :allow-other-keys nil) - (3 4 2 7 8 1 5)) - -(deftest delete-duplicates.allow-other-keys.6 - (delete-duplicates (list 1 2 3 4 2 7 8 1 5) - :allow-other-keys t :bad t :allow-other-keys nil) - (3 4 2 7 8 1 5)) - -(deftest delete-duplicates.allow-other-keys.7 - (delete-duplicates (list 1 2 3 4 2 7 8 1 5) - :allow-other-keys t :allow-other-keys nil :bad t) - (3 4 2 7 8 1 5)) - -(deftest delete-duplicates.allow-other-keys.8 - (delete-duplicates (list 1 2 3 4 2 7 8 1 5) - :allow-other-keys t :from-end t) - (1 2 3 4 7 8 5)) - -(deftest delete-duplicates.keywords.1 - (delete-duplicates (list 1 2 3 4 2 7 8 1 5) :from-end t :from-end nil) - (1 2 3 4 7 8 5)) - -;;; Order of evaluation tests - -(deftest delete-duplicates.order.1 - (let ((i 0) a b c d e f) - (values - (delete-duplicates - (progn (setf a (incf i)) (list 1 2 3 1 3 1 2 4)) - :from-end (progn (setf b (incf i)) nil) - :start (progn (setf c (incf i)) 0) - :end (progn (setf d (incf i)) nil) - :key (progn (setf e (incf i)) #'identity) - :test (progn (setf f (incf i)) #'=) - ) - i a b c d e f)) - (3 1 2 4) 6 1 2 3 4 5 6) - -(deftest delete-duplicates.order.2 - (let ((i 0) a b c d e f) - (values - (delete-duplicates - (progn (setf a (incf i)) (list 1 2 3 1 3 1 2 4)) - :test-not (progn (setf b (incf i)) #'/=) - :key (progn (setf c (incf i)) #'identity) - :end (progn (setf d (incf i)) nil) - :start (progn (setf e (incf i)) 0) - :from-end (progn (setf f (incf i)) nil) - ) - i a b c d e f)) - (3 1 2 4) 6 1 2 3 4 5 6) - -;;; Error cases - -(deftest remove-duplicates.error.1 - (signals-error (remove-duplicates) program-error) - t) - -(deftest remove-duplicates.error.2 - (signals-error (remove-duplicates nil :start) program-error) - t) - -(deftest remove-duplicates.error.3 - (signals-error (remove-duplicates nil 'bad t) program-error) - t) - -(deftest remove-duplicates.error.4 - (signals-error (remove-duplicates nil 'bad t :allow-other-keys nil) program-error) - t) - -(deftest remove-duplicates.error.5 - (signals-error (remove-duplicates nil 1 2) program-error) - t) - -(deftest remove-duplicates.error.6 - (signals-error (remove-duplicates (list 'a 'b 'c) :test #'identity) program-error) - t) - -(deftest remove-duplicates.error.7 - (signals-error (remove-duplicates (list 'a 'b 'c) :test-not #'identity) program-error) - t) - -(deftest remove-duplicates.error.8 - (signals-error (remove-duplicates (list 'a 'b 'c) :key #'cons) program-error) - t) - -(deftest remove-duplicates.error.9 - (signals-error (remove-duplicates (list 'a 'b 'c) :key #'car) type-error) - t) - -(deftest remove-duplicates.error.10 - (check-type-error #'remove-duplicates #'sequencep) - nil) - -;;; - -(deftest delete-duplicates.error.1 - (signals-error (delete-duplicates) program-error) - t) - -(deftest delete-duplicates.error.2 - (signals-error (delete-duplicates nil :start) program-error) - t) - -(deftest delete-duplicates.error.3 - (signals-error (delete-duplicates nil 'bad t) program-error) - t) - -(deftest delete-duplicates.error.4 - (signals-error (delete-duplicates nil 'bad t :allow-other-keys nil) program-error) - t) - -(deftest delete-duplicates.error.5 - (signals-error (delete-duplicates nil 1 2) program-error) - t) - -(deftest delete-duplicates.error.6 - (signals-error (delete-duplicates (list 'a 'b 'c) :test #'identity) program-error) - t) - -(deftest delete-duplicates.error.7 - (signals-error (delete-duplicates (list 'a 'b 'c) :test-not #'identity) program-error) - t) - -(deftest delete-duplicates.error.8 - (signals-error (delete-duplicates (list 'a 'b 'c) :key #'cons) program-error) - t) - -(deftest delete-duplicates.error.9 - (signals-error (delete-duplicates (list 'a 'b 'c) :key #'car) type-error) - t) - -(deftest delete-duplicates.error.10 - (check-type-error #'delete-duplicates #'sequencep) - nil) - -;;; Specialized string tests - -(deftest remove-duplicates.string.1 - (do-special-strings - (s "abcadefabgz" nil) - (let ((s2 (remove-duplicates s))) - (assert (string= s "abcadefabgz")) - (assert (equal (array-element-type s) - (array-element-type s2))) - (assert (string= s2 "cdefabgz")))) - nil) - -(deftest remove-duplicates.string.2 - (do-special-strings - (s "abcadefabgz" nil) - (let ((s2 (remove-duplicates s :from-end t))) - (assert (string= s "abcadefabgz")) - (assert (equal (array-element-type s) - (array-element-type s2))) - (assert (string= s2 "abcdefgz")))) - nil) - -(deftest delete-duplicates.string.1 - (do-special-strings - (s "abcadefabgz" nil) - (let ((aet (array-element-type s)) - (s2 (delete-duplicates s))) - (assert (equal aet (array-element-type s2))) - (assert (string= s2 "cdefabgz")))) - nil) - -(deftest delete-duplicates.string.2 - (do-special-strings - (s "abcadefabgz" nil) - (let ((aet (array-element-type s)) - (s2 (delete-duplicates s :from-end t))) - (assert (equal aet (array-element-type s2))) - (assert (string= s2 "abcdefgz")))) - nil) - -;;; Order of elements kept under EQUAL, EQUALP tests - -(deftest remove-duplicates.2 - (let* ((x (list 'a)) - (y (list 'a)) - (result (remove-duplicates (list x y) :test 'equal))) - (values - result - (notnot (eql (car result) x)) - (notnot (eql (car result) y)))) - ((a)) nil t) - -(deftest remove-duplicates.2a - (let* ((x (list 'a)) - (y (list 'a)) - (result (remove-duplicates (list x 'x y) :test 'equal))) - (values - result - (notnot (eql (cadr result) x)) - (notnot (eql (cadr result) y)))) - (x (a)) nil t) - -(deftest remove-duplicates.3 - (let* ((x (list 'a)) - (y (list 'a)) - (result (remove-duplicates (list x y) :test 'equal :from-end t))) - (values - result - (notnot (eql (car result) x)) - (notnot (eql (car result) y)))) - ((a)) t nil) - -(deftest remove-duplicates.3a - (let* ((x (list 'a)) - (y (list 'a)) - (result (remove-duplicates (list x 'u 'v y) :test 'equal :from-end t))) - (values - result - (notnot (eql (car result) x)) - (notnot (eql (car result) y)))) - ((a) u v) t nil) - -(deftest remove-duplicates.4 - (let* ((x (list 'a)) - (y (list 'a)) - (result (remove-duplicates (list x y) :test 'equalp))) - (values - result - (notnot (eql (car result) x)) - (notnot (eql (car result) y)))) - ((a)) nil t) - -(deftest remove-duplicates.5 - (let* ((x (list 'a)) - (y (list 'a)) - (result (remove-duplicates (list x y) :test 'equalp :from-end t))) - (values - result - (notnot (eql (car result) x)) - (notnot (eql (car result) y)))) - ((a)) t nil) - -;;; Similar, but destructive - -(deftest delete-duplicates.2 - (let* ((x (list 'a)) - (y (list 'a)) - (result (delete-duplicates (list x y) :test 'equal))) - (values - result - (notnot (eql (car result) x)) - (notnot (eql (car result) y)))) - ((a)) nil t) - -(deftest delete-duplicates.2a - (let* ((x (list 'a)) - (y (list 'a)) - (result (delete-duplicates (list x 'x y) :test 'equal))) - (values - result - (notnot (eql (cadr result) x)) - (notnot (eql (cadr result) y)))) - (x (a)) nil t) - -(deftest delete-duplicates.3 - (let* ((x (list 'a)) - (y (list 'a)) - (result (delete-duplicates (list x y) :test 'equal :from-end t))) - (values - result - (notnot (eql (car result) x)) - (notnot (eql (car result) y)))) - ((a)) t nil) - -(deftest delete-duplicates.3a - (let* ((x (list 'a)) - (y (list 'a)) - (result (delete-duplicates (list x 'u 'v y) :test 'equal :from-end t))) - (values - result - (notnot (eql (car result) x)) - (notnot (eql (car result) y)))) - ((a) u v) t nil) - -(deftest delete-duplicates.4 - (let* ((x (list 'a)) - (y (list 'a)) - (result (delete-duplicates (list x y) :test 'equalp))) - (values - result - (notnot (eql (car result) x)) - (notnot (eql (car result) y)))) - ((a)) nil t) - -(deftest delete-duplicates.5 - (let* ((x (list 'a)) - (y (list 'a)) - (result (delete-duplicates (list x y) :test 'equalp :from-end t))) - (values - result - (notnot (eql (car result) x)) - (notnot (eql (car result) y)))) - ((a)) t nil) - - - - - - - - diff --git a/t/ansi-test/sequences/remove.lsp b/t/ansi-test/sequences/remove.lsp deleted file mode 100644 index 57ff568..0000000 --- a/t/ansi-test/sequences/remove.lsp +++ /dev/null @@ -1,1047 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Sep 14 11:46:05 2002 -;;;; Contains: Tests for REMOVE - - - -(in-package :cl-test) - -(deftest remove-list.1 - (let* ((orig '(a b c a b d a c b a e)) - (x (copy-seq orig)) - (y (remove 'a x))) - (and (equalp orig x) y)) - (b c b d c b e)) - -(deftest remove-list.2 - (let* ((orig '(a b c a b d a c b a e)) - (x (copy-seq orig)) - (y (remove 'a x :count nil))) - (and (equalp orig x) y)) - (b c b d c b e)) - -(deftest remove-list.3 - (let* ((orig '(a b c a b d a c b a e)) - (x (copy-seq orig)) - (y (remove 'a x :key nil))) - (and (equalp orig x) y)) - (b c b d c b e)) - -(deftest remove-list.4 - (let* ((orig '(a b c a b d a c b a e)) - (x (copy-seq orig)) - (y (remove 'a x :count 100))) - (and (equalp orig x) y)) - (b c b d c b e)) - -(deftest remove-list.5 - (let* ((orig '(a b c a b d a c b a e)) - (x (copy-seq orig)) - (y (remove 'a x :count 0))) - (and (equalp orig x) y)) - (a b c a b d a c b a e)) - -(deftest remove-list.6 - (let* ((orig '(a b c a b d a c b a e)) - (x (copy-seq orig)) - (y (remove 'a x :count 1))) - (and (equalp orig x) y)) - (b c a b d a c b a e)) - -(deftest remove-list.7 - (let* ((orig '(a b c a b d a c b a e)) - (x (copy-seq orig)) - (y (remove 'c x :count 1))) - (and (equalp orig x) y)) - (a b a b d a c b a e)) - -(deftest remove-list.8 - (let* ((orig '(a b c a b d a c b a e)) - (x (copy-seq orig)) - (y (remove 'a x :from-end t))) - (and (equalp orig x) y)) - (b c b d c b e)) - -(deftest remove-list.9 - (let* ((orig '(a b c a b d a c b a e)) - (x (copy-seq orig)) - (y (remove 'a x :from-end t :count 1))) - (and (equalp orig x) y)) - (a b c a b d a c b e)) - -(deftest remove-list.10 - (let* ((orig '(a b c a b d a c b a e)) - (x (copy-seq orig)) - (y (remove 'a x :from-end t :count 4))) - (and (equalp orig x) y)) - (b c b d c b e)) - -(deftest remove-list.11 - (let* ((orig '(a b c a b d a c b a e)) - (x (copy-seq orig))) - (values - (loop for i from 0 to 10 - collect (remove 'a x :start i)) - (equalp orig x))) - ((b c b d c b e) - (a b c b d c b e) - (a b c b d c b e) - (a b c b d c b e) - (a b c a b d c b e) - (a b c a b d c b e) - (a b c a b d c b e) - (a b c a b d a c b e) - (a b c a b d a c b e) - (a b c a b d a c b e) - (a b c a b d a c b a e)) - t) - -(deftest remove-list.12 - (let* ((orig '(a b c a b d a c b a e)) - (x (copy-seq orig))) - (values - (loop for i from 0 to 10 - collect (remove 'a x :start i :end nil)) - (equalp orig x))) - ((b c b d c b e) - (a b c b d c b e) - (a b c b d c b e) - (a b c b d c b e) - (a b c a b d c b e) - (a b c a b d c b e) - (a b c a b d c b e) - (a b c a b d a c b e) - (a b c a b d a c b e) - (a b c a b d a c b e) - (a b c a b d a c b a e)) - t) - -(deftest remove-list.13 - (let* ((orig '(a b c a b d a c b a e)) - (x (copy-seq orig))) - (values - (loop for i from 0 to 10 - collect (remove 'a x :start i :end 11)) - (equalp orig x))) - ((b c b d c b e) - (a b c b d c b e) - (a b c b d c b e) - (a b c b d c b e) - (a b c a b d c b e) - (a b c a b d c b e) - (a b c a b d c b e) - (a b c a b d a c b e) - (a b c a b d a c b e) - (a b c a b d a c b e) - (a b c a b d a c b a e)) - t) - -(deftest remove-list.14 - (let* ((orig '(a b c a b d a c b a e)) - (x (copy-seq orig)) - (y (remove 'a x :end nil))) - (and (equalp orig x) y)) - (b c b d c b e)) - -(deftest remove-list.15 - (let* ((orig '(a b c a b d a c b a e)) - (x (copy-seq orig))) - (values - (loop for i from 0 to 9 - collect (remove 'a x :start i :end 9)) - (equalp orig x))) - ((b c b d c b a e) - (a b c b d c b a e) - (a b c b d c b a e) - (a b c b d c b a e) - (a b c a b d c b a e) - (a b c a b d c b a e) - (a b c a b d c b a e) - (a b c a b d a c b a e) - (a b c a b d a c b a e) - (a b c a b d a c b a e)) - t) - -(deftest remove-list.16 - (let* ((orig '(a b c a b d a c b a e)) - (x (copy-seq orig))) - (values - (loop for i from 0 to 10 - collect (remove 'a x :start i :end 11 :count 1)) - (equalp orig x))) - ((b c a b d a c b a e) - (a b c b d a c b a e) - (a b c b d a c b a e) - (a b c b d a c b a e) - (a b c a b d c b a e) - (a b c a b d c b a e) - (a b c a b d c b a e) - (a b c a b d a c b e) - (a b c a b d a c b e) - (a b c a b d a c b e) - (a b c a b d a c b a e)) - t) - -(deftest remove-list.17 - (let* ((orig '(a b c a b d a c b a e)) - (x (copy-seq orig))) - (values - (loop for i from 0 to 10 - collect (remove 'a x :start i :end (1+ i))) - (equalp orig x))) - (( b c a b d a c b a e) - (a b c a b d a c b a e) - (a b c a b d a c b a e) - (a b c b d a c b a e) - (a b c a b d a c b a e) - (a b c a b d a c b a e) - (a b c a b d c b a e) - (a b c a b d a c b a e) - (a b c a b d a c b a e) - (a b c a b d a c b e) - (a b c a b d a c b a e)) - t) - -;;; Show that it tests using EQL, not EQ -;;; NOTE: this test was bogus, since we can't sure non-EQness is preserved -#| -(deftest remove-list.18 - (let* ((i (1+ most-positive-fixnum)) - (orig (list i 0 i 1 i 2 3)) - (x (copy-seq orig)) - (y (remove (1+ most-positive-fixnum) x))) - (and (equalp orig x) y)) - (0 1 2 3)) -|# - -(deftest remove-list.19 - (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) - (x (copy-seq orig)) - (y (remove 1 x :key #'1-))) - (and (equalp orig x) y)) - (1 3 6 1 4 1 3 7)) - -(deftest remove-list.20 - (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) - (x (copy-seq orig)) - (y (remove 3 x :test #'>))) - (and (equalp orig x) y)) - (3 6 4 3 7)) - -(deftest remove-list.21 - (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) - (x (copy-seq orig)) - (y (remove 3 x :test '> :from-end t))) - (and (equalp orig x) y)) - (3 6 4 3 7)) - -(deftest remove-list.22 - (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) - (x (copy-seq orig)) - (y (remove 2 x :key nil))) - (and (equalp orig x) y)) - (1 3 6 1 4 1 3 7)) - -(deftest remove-list.23 - (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) - (x (copy-seq orig)) - (y (remove 1 x :key '1-))) - (and (equalp orig x) y)) - (1 3 6 1 4 1 3 7)) - -(deftest remove-list.24 - (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) - (x (copy-seq orig)) - (y (remove 3 x :test-not #'<=))) - (and (equalp orig x) y)) - (3 6 4 3 7)) - -(deftest remove-list.25 - (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) - (x (copy-seq orig)) - (y (remove 3 x :test-not '<= :from-end t))) - (and (equalp orig x) y)) - (3 6 4 3 7)) - -(deftest remove-list.26 - (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) - (x (copy-seq orig)) - (y (remove 3 x :from-end t :start 1 :end 5))) - (and (equalp orig x) y)) - (1 2 2 6 1 2 4 1 3 2 7)) - -(deftest remove-list.27 - (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) - (x (copy-seq orig)) - (y (remove 3 x :count -1))) - (and (equalp orig x) - (equalpt x y))) - t) - -(deftest remove-list.28 - (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) - (x (copy-seq orig)) - (y (remove 3 x :count -1000000000000))) - (and (equalp orig x) - (equalpt x y))) - t) - -(deftest remove-list.29 - (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) - (x (copy-seq orig)) - (y (remove 3 x :count 1000000000000))) - (and (equalp orig x) - y)) - (1 2 2 6 1 2 4 1 2 7)) - -;;; Assorted tests of remove and delete on vectors, strings, -;;; and bit vectors. These are mostly to exercise bugs previously -;;; detected by the randomized tests - -(deftest remove-vector.1 - (remove 'a (vector 'b 'c 'd)) - #(b c d)) - -(deftest remove-vector.2 - (remove 'a (vector 'b 'c 'd) :count -1) - #(b c d)) - -(deftest remove-vector.3 - (remove 'a (vector 'a 'b 'c 'd) :count -1) - #(a b c d)) - -(deftest remove-string.1 - (remove #\a (copy-seq "abcad")) - "bcd") - -(deftest remove-string.2 - (remove #\a (copy-seq "abcad") :count -1) - "abcad") - -(deftest remove-string.3 - (remove #\a (copy-seq "bcd") :count -1) - "bcd") - -(deftest remove-string.4 - (do-special-strings - (s "abcdbad" nil) - (let ((s2 (remove #\b s))) - (assert (equal (array-element-type s) (array-element-type s2))) - (assert (string= s2 "acdad"))) - (let ((s2 (remove #\b s :count 1))) - (assert (equal (array-element-type s) (array-element-type s2))) - (assert (string= s2 "acdbad"))) - (let ((s2 (remove #\b s :count 1 :from-end t))) - (assert (equal (array-element-type s) (array-element-type s2))) - (assert (string= s2 "abcdad")))) - nil) - -(deftest delete-vector.1 - (delete 'a (vector 'b 'c 'd)) - #(b c d)) - -(deftest delete-vector.2 - (delete 'a (vector 'b 'c 'd) :count -1) - #(b c d)) - -(deftest delete-vector.3 - (delete 'a (vector 'a 'b 'c 'd) :count -1) - #(a b c d)) - -(deftest delete-string.1 - (delete #\a (copy-seq "abcad")) - "bcd") - -(deftest delete-string.2 - (delete #\a (copy-seq "abcad") :count -1) - "abcad") - -(deftest delete-string.3 - (delete #\a (copy-seq "bcd") :count -1) - "bcd") - -(deftest delete-string.4 - (do-special-strings - (s "abcdbad" nil) - (let ((s2 (delete #\b s))) - (assert (equal (array-element-type s) (array-element-type s2))) - (assert (string= s2 "acdad")))) - nil) - -(deftest delete-string.5 - (do-special-strings - (s "abcdbad" nil) - (let ((s2 (delete #\b s :count 1))) - (assert (equal (array-element-type s) (array-element-type s2))) - (assert (string= s2 "acdbad")))) - nil) - -(deftest delete-string.6 - (do-special-strings - (s "abcdbad" nil) - (let ((s2 (delete #\b s :count 1 :from-end t))) - (assert (equal (array-element-type s) (array-element-type s2))) - (assert (string= s2 "abcdad")))) - nil) - -(deftest remove-bit-vector.1 - (remove 0 (copy-seq #*00011101101)) - #*111111) - -(deftest remove-bit-vector.2 - (remove 0 (copy-seq #*00011101101) :count -1) - #*00011101101) - -(deftest remove-bit-vector.3 - (remove 0 (copy-seq #*11111) :count -1) - #*11111) - -(deftest delete-bit-vector.1 - (delete 0 (copy-seq #*00011101101)) - #*111111) - -(deftest delete-bit-vector.2 - (delete 0 (copy-seq #*00011101101) :count -1) - #*00011101101) - -(deftest delete-bit-vector.3 - (delete 0 (copy-seq #*11111) :count -1) - #*11111) - -;;; test & test-not together is harmless - -(defharmless remove-list.test-and-test-not.1 - (remove 'a '(a b c) :test #'eql :test-not #'eql)) - -(defharmless remove-list.test-and-test-not.2 - (remove 'a '(a b c) :test-not #'eql :test #'eql)) - -(defharmless remove-vector.test-and-test-not.1 - (remove 'a #(a b c) :test #'eql :test-not #'eql)) - -(defharmless remove-vector.test-and-test-not.2 - (remove 'a #(a b c) :test-not #'eql :test #'eql)) - -(defharmless remove-bit-string.test-and-test-not.1 - (remove 0 #*0001100100 :test #'eql :test-not #'eql)) - -(defharmless remove-bit-string.test-and-test-not.2 - (remove 0 #*0001100100 :test-not #'eql :test #'eql)) - -(defharmless remove-string.test-and-test-not.1 - (remove #\0 "0001100100" :test #'eql :test-not #'eql)) - -(defharmless remove-string.test-and-test-not.2 - (remove #\0 "0001100100" :test-not #'eql :test #'eql)) - - -(defharmless delete-list.test-and-test-not.1 - (delete 'a (list 'a 'b 'c) :test #'eql :test-not #'eql)) - -(defharmless delete-list.test-and-test-not.2 - (delete 'a (list 'a 'b 'c) :test-not #'eql :test #'eql)) - -(defharmless delete-vector.test-and-test-not.1 - (delete 'a (vector 'a 'b 'c) :test #'eql :test-not #'eql)) - -(defharmless delete-vector.test-and-test-not.2 - (delete 'a (vector 'a 'b 'c) :test-not #'eql :test #'eql)) - -(defharmless delete-bit-string.test-and-test-not.1 - (delete 0 (copy-seq #*0001100100) :test #'eql :test-not #'eql)) - -(defharmless delete-bit-string.test-and-test-not.2 - (delete 0 (copy-seq #*0001100100) :test-not #'eql :test #'eql)) - -(defharmless delete-string.test-and-test-not.1 - (delete #\0 (copy-seq "0001100100") :test #'eql :test-not #'eql)) - -(defharmless delete-string.test-and-test-not.2 - (delete #\0 (copy-seq "0001100100") :test-not #'eql :test #'eql)) - - -;;; Const fold tests - -(def-fold-test remove.fold.1 (remove 'c '(a b c d e))) -(def-fold-test remove.fold.2 (remove 'c #(a b c d e))) -(def-fold-test remove.fold.3 (remove 1 #*0011011001)) -(def-fold-test remove.fold.4 (remove #\c "abcde")) - -(def-fold-test remove-if.fold.1 (remove-if 'null '(a b nil d e))) -(def-fold-test remove-if.fold.2 (remove-if #'null #(a b nil d e))) -(def-fold-test remove-if.fold.3 (remove-if 'plusp #*0011011001)) -(def-fold-test remove-if.fold.4 (remove-if 'digit-char-p "ab0de")) - -(def-fold-test remove-if-not.fold.1 (remove-if-not #'identity '(a b nil d e))) -(def-fold-test remove-if-not.fold.2 (remove-if-not 'identity #(a b nil d e))) -(def-fold-test remove-if-not.fold.3 (remove-if-not #'zerop #*0011011001)) -(def-fold-test remove-if-not.fold.4 (remove-if-not #'alpha-char-p "ab-de")) - -;;; Order of evaluation tests - -(deftest remove.order.1 - (let ((i 0) a b c d e f g h) - (values - (remove - (progn (setf a (incf i)) 'a) - (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) - :from-end (progn (setf c (incf i)) t) - :count (progn (setf d (incf i)) 1) - :key (progn (setf e (incf i)) #'identity) - :test (progn (setf f (incf i)) #'eq) - :start (progn (setf g (incf i)) 0) - :end (progn (setf h (incf i)) nil)) - i a b c d e f g h)) - (a b c d f) 8 1 2 3 4 5 6 7 8) - -(deftest remove.order.2 - (let ((i 0) a b c d e f g h) - (values - (remove - (progn (setf a (incf i)) 'a) - (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) - :end (progn (setf c (incf i)) nil) - :start (progn (setf d (incf i)) 0) - :test-not (progn (setf e (incf i)) (complement #'eq)) - :key (progn (setf f (incf i)) #'identity) - :count (progn (setf g (incf i)) 1) - :from-end (progn (setf h (incf i)) t) - ) - i a b c d e f g h)) - (a b c d f) 8 1 2 3 4 5 6 7 8) - -(deftest delete.order.1 - (let ((i 0) a b c d e f g h) - (values - (delete - (progn (setf a (incf i)) 'a) - (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) - :from-end (progn (setf c (incf i)) t) - :count (progn (setf d (incf i)) 1) - :key (progn (setf e (incf i)) #'identity) - :test (progn (setf f (incf i)) #'eq) - :start (progn (setf g (incf i)) 0) - :end (progn (setf h (incf i)) nil)) - i a b c d e f g h)) - (a b c d f) 8 1 2 3 4 5 6 7 8) - -(deftest delete.order.2 - (let ((i 0) a b c d e f g h) - (values - (delete - (progn (setf a (incf i)) 'a) - (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) - :end (progn (setf c (incf i)) nil) - :start (progn (setf d (incf i)) 0) - :test-not (progn (setf e (incf i)) (complement #'eq)) - :key (progn (setf f (incf i)) #'identity) - :count (progn (setf g (incf i)) 1) - :from-end (progn (setf h (incf i)) t) - ) - i a b c d e f g h)) - (a b c d f) 8 1 2 3 4 5 6 7 8) - -(deftest remove-if.order.1 - (let ((i 0) a b c d e f g) - (values - (remove-if - (progn (setf a (incf i)) #'(lambda (x) (eq x 'a))) - (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) - :from-end (progn (setf c (incf i)) t) - :count (progn (setf d (incf i)) 1) - :key (progn (setf e (incf i)) #'identity) - :start (progn (setf f (incf i)) 0) - :end (progn (setf g (incf i)) nil)) - i a b c d e f g)) - (a b c d f) 7 1 2 3 4 5 6 7) - -(deftest remove-if.order.2 - (let ((i 0) a b c d e f g) - (values - (remove-if - (progn (setf a (incf i)) #'(lambda (x) (eq x 'a))) - (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) - :end (progn (setf c (incf i)) nil) - :start (progn (setf d (incf i)) 0) - :key (progn (setf e (incf i)) #'identity) - :count (progn (setf f (incf i)) 1) - :from-end (progn (setf g (incf i)) t) - ) - i a b c d e f g)) - (a b c d f) 7 1 2 3 4 5 6 7) - -(deftest delete-if.order.1 - (let ((i 0) a b c d e f g) - (values - (delete-if - (progn (setf a (incf i)) #'(lambda (x) (eq x 'a))) - (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) - :from-end (progn (setf c (incf i)) t) - :count (progn (setf d (incf i)) 1) - :key (progn (setf e (incf i)) #'identity) - :start (progn (setf f (incf i)) 0) - :end (progn (setf g (incf i)) nil)) - i a b c d e f g)) - (a b c d f) 7 1 2 3 4 5 6 7) - -(deftest delete-if.order.2 - (let ((i 0) a b c d e f g) - (values - (delete-if - (progn (setf a (incf i)) #'(lambda (x) (eq x 'a))) - (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) - :end (progn (setf c (incf i)) nil) - :start (progn (setf d (incf i)) 0) - :key (progn (setf e (incf i)) #'identity) - :count (progn (setf f (incf i)) 1) - :from-end (progn (setf g (incf i)) t) - ) - i a b c d e f g)) - (a b c d f) 7 1 2 3 4 5 6 7) - -(deftest remove-if-not.order.1 - (let ((i 0) a b c d e f g) - (values - (remove-if-not - (progn (setf a (incf i)) #'(lambda (x) (not (eq x 'a)))) - (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) - :from-end (progn (setf c (incf i)) t) - :count (progn (setf d (incf i)) 1) - :key (progn (setf e (incf i)) #'identity) - :start (progn (setf f (incf i)) 0) - :end (progn (setf g (incf i)) nil)) - i a b c d e f g)) - (a b c d f) 7 1 2 3 4 5 6 7) - -(deftest remove-if-not.order.2 - (let ((i 0) a b c d e f g) - (values - (remove-if-not - (progn (setf a (incf i)) #'(lambda (x) (not (eq x 'a)))) - (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) - :end (progn (setf c (incf i)) nil) - :start (progn (setf d (incf i)) 0) - :key (progn (setf e (incf i)) #'identity) - :count (progn (setf f (incf i)) 1) - :from-end (progn (setf g (incf i)) t) - ) - i a b c d e f g)) - (a b c d f) 7 1 2 3 4 5 6 7) - -(deftest delete-if-not.order.1 - (let ((i 0) a b c d e f g) - (values - (delete-if-not - (progn (setf a (incf i)) #'(lambda (x) (not (eq x 'a)))) - (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) - :from-end (progn (setf c (incf i)) t) - :count (progn (setf d (incf i)) 1) - :key (progn (setf e (incf i)) #'identity) - :start (progn (setf f (incf i)) 0) - :end (progn (setf g (incf i)) nil)) - i a b c d e f g)) - (a b c d f) 7 1 2 3 4 5 6 7) - -(deftest delete-if-not.order.2 - (let ((i 0) a b c d e f g) - (values - (delete-if-not - (progn (setf a (incf i)) #'(lambda (x) (not (eq x 'a)))) - (progn (setf b (incf i)) (list 'a 'b 'c 'd 'a 'f)) - :end (progn (setf c (incf i)) nil) - :start (progn (setf d (incf i)) 0) - :key (progn (setf e (incf i)) #'identity) - :count (progn (setf f (incf i)) 1) - :from-end (progn (setf g (incf i)) t) - ) - i a b c d e f g)) - (a b c d f) 7 1 2 3 4 5 6 7) - -;;; Randomized tests - -(deftest remove-random - (loop for i from 1 to 2500 - unless (eq (random-test-remove 20) t) - do (return *remove-fail-args*)) - nil) - -(deftest remove-if-random - (loop for i from 1 to 2500 - unless (eq (random-test-remove-if 20) t) - do (return *remove-fail-args*)) - nil) - -(deftest remove-if-not-random - (loop for i from 1 to 2500 - unless (eq (random-test-remove-if 20 t) t) - do (return *remove-fail-args*)) - nil) - -(deftest delete-random - (loop for i from 1 to 2500 - unless (eq (random-test-delete 20) t) - do (return *remove-fail-args*)) - nil) - -(deftest delete-if-random - (loop for i from 1 to 2500 - unless (eq (random-test-delete-if 20) t) - do (return *remove-fail-args*)) - nil) - -(deftest delete-if-not-random - (loop for i from 1 to 2500 - unless (eq (random-test-delete-if 20 t) t) - do (return *remove-fail-args*)) - nil) - -;;; Additional tests with KEY = NIL - -(deftest remove-if-list.1 - (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) - (x (copy-seq orig)) - (y (remove-if #'evenp x :key nil))) - (and (equalp orig x) y)) - (1 3 1 1 3 7)) - -(deftest remove-if-list.2 - (let* ((orig '(a b c a b d a c b a e)) - (x (copy-seq orig)) - (y (remove-if #'(lambda (y) (eqt y 'a)) x :key nil))) - (and (equalp orig x) y)) - (b c b d c b e)) - -(deftest remove-if-not-list.1 - (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) - (x (copy-seq orig)) - (y (remove-if-not #'oddp x :key nil))) - (and (equalp orig x) y)) - (1 3 1 1 3 7)) - -(deftest remove-if-not-list.2 - (let* ((orig '(a b c a b d a c b a e)) - (x (copy-seq orig)) - (y (remove-if-not #'(lambda (y) (not (eqt y 'a))) x :key nil))) - (and (equalp orig x) y)) - (b c b d c b e)) - -(deftest delete-if-list.1 - (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) - (x (copy-seq orig)) - (y (delete-if #'evenp x :key nil))) - y) - (1 3 1 1 3 7)) - -(deftest delete-if-list.2 - (let* ((orig '(a b c a b d a c b a e)) - (x (copy-seq orig)) - (y (delete-if #'(lambda (y) (eqt y 'a)) x :key nil))) - y) - (b c b d c b e)) - -(deftest delete-if-not-list.1 - (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) - (x (copy-seq orig)) - (y (delete-if-not #'oddp x :key nil))) - y) - (1 3 1 1 3 7)) - -(deftest delete-if-not-list.2 - (let* ((orig '(a b c a b d a c b a e)) - (x (copy-seq orig)) - (y (delete-if-not #'(lambda (y) (not (eqt y 'a))) x :key nil))) - y) - (b c b d c b e)) - -(deftest delete-list.1 - (let* ((orig '(a b c a b d a c b a e)) - (x (copy-seq orig)) - (y (delete 'a x :key nil))) - y) - (b c b d c b e)) - -(deftest delete-list.2 - (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) - (x (copy-seq orig)) - (y (delete 2 x :key nil))) - y) - (1 3 6 1 4 1 3 7)) - -;;; Keyword tests - -(deftest remove.allow-other-keys.1 - (remove 'a '(a b c a d) :allow-other-keys t) - (b c d)) - -(deftest remove.allow-other-keys.2 - (remove 'a '(a b c a d) :allow-other-keys nil) - (b c d)) - -(deftest remove.allow-other-keys.3 - (remove 'a '(a b c a d) :bad t :allow-other-keys t) - (b c d)) - -(deftest remove.allow-other-keys.4 - (remove 'a '(a b c a d) :allow-other-keys t :bad t :bad nil) - (b c d)) - -(deftest remove.allow-other-keys.5 - (remove 'a '(a b c a d) :bad1 t :allow-other-keys t :bad2 t - :allow-other-keys nil :bad3 t) - (b c d)) - -(deftest remove.allow-other-keys.6 - (remove 'a '(a b c a d) :allow-other-keys t :from-end t :count 1) - (a b c d)) - -(deftest remove.keywords.7 - (remove 'a '(a b c a d) :from-end t :count 1 :from-end nil :count 10) - (a b c d)) - - -(deftest delete.allow-other-keys.1 - (delete 'a (copy-seq '(a b c a d)) :allow-other-keys t) - (b c d)) - -(deftest delete.allow-other-keys.2 - (delete 'a (copy-seq '(a b c a d)) :allow-other-keys nil) - (b c d)) - -(deftest delete.allow-other-keys.3 - (delete 'a (copy-seq '(a b c a d)) :bad t :allow-other-keys t) - (b c d)) - -(deftest delete.allow-other-keys.4 - (delete 'a (copy-seq '(a b c a d)) :allow-other-keys t :bad t :bad nil) - (b c d)) - -(deftest delete.allow-other-keys.5 - (delete 'a (copy-seq '(a b c a d)) :bad1 t :allow-other-keys t :bad2 t - :allow-other-keys nil :bad3 t) - (b c d)) - -(deftest delete.allow-other-keys.6 - (delete 'a (copy-seq '(a b c a d)) :allow-other-keys t :from-end t :count 1) - (a b c d)) - -(deftest delete.keywords.7 - (delete 'a (copy-seq '(a b c a d)) - :from-end t :count 1 :from-end nil :count 10) - (a b c d)) - - - -;;; Error cases - -(deftest remove.error.1 - (signals-error (remove) program-error) - t) - -(deftest remove.error.2 - (signals-error (remove 'a) program-error) - t) - -(deftest remove.error.3 - (signals-error (remove 'a nil :key) program-error) - t) - -(deftest remove.error.4 - (signals-error (remove 'a nil 'bad t) program-error) - t) - -(deftest remove.error.4a - (signals-error (remove 'a nil nil t) program-error) - t) - -(deftest remove.error.5 - (signals-error (remove 'a nil 'bad t :allow-other-keys nil) program-error) - t) - -(deftest remove.error.6 - (signals-error (remove 'a nil 1 2) program-error) - t) - -(deftest remove.error.7 - (signals-error (remove 'a (list 'a 'b 'c) :test #'identity) program-error) - t) - -(deftest remove.error.8 - (signals-error (remove 'a (list 'a 'b 'c) :test-not #'identity) program-error) - t) - -(deftest remove.error.9 - (signals-error (remove 'a (list 'a 'b 'c) :key #'cons) program-error) - t) - -(deftest remove.error.10 - (signals-error (remove 'a (list 'a 'b 'c) :key #'car) type-error) - t) - -(deftest remove.error.11 - (check-type-error #'(lambda (x) (remove 'a x)) #'sequencep) - nil) - - -;;; - -(deftest delete.error.1 - (signals-error (delete) program-error) - t) - -(deftest delete.error.2 - (signals-error (delete 'a) program-error) - t) - -(deftest delete.error.3 - (signals-error (delete 'a nil :key) program-error) - t) - -(deftest delete.error.4 - (signals-error (delete 'a nil 'bad t) program-error) - t) - -(deftest delete.error.5 - (signals-error (delete 'a nil 'bad t :allow-other-keys nil) program-error) - t) - -(deftest delete.error.6 - (signals-error (delete 'a nil 1 2) program-error) - t) - -(deftest delete.error.7 - (signals-error (delete 'a (list 'a 'b 'c) :test #'identity) program-error) - t) - -(deftest delete.error.8 - (signals-error (delete 'a (list 'a 'b 'c) :test-not #'identity) program-error) - t) - -(deftest delete.error.9 - (signals-error (delete 'a (list 'a 'b 'c) :key #'cons) program-error) - t) - -(deftest delete.error.10 - (signals-error (delete 'a (list 'a 'b 'c) :key #'car) type-error) - t) - -(deftest delete.error.11 - (check-type-error #'(lambda (x) (delete 'a x)) #'sequencep) - nil) - -;;; More specialized string tests - -(deftest remove-if-string.1 - (do-special-strings - (s "ab1c23def4" nil) - (let ((s2 (remove-if #'alpha-char-p s))) - (assert (equal (array-element-type s) - (array-element-type s2))) - (assert (string= s2 "1234")) - (assert (string= s "ab1c23def4")))) - nil) - -(deftest remove-if-string.2 - (do-special-strings - (s "ab1c23def4" nil) - (let ((s2 (remove-if #'alpha-char-p s :count 3))) - (assert (equal (array-element-type s) - (array-element-type s2))) - (assert (string= s2 "123def4")) - (assert (string= s "ab1c23def4")))) - nil) - -(deftest remove-if-string.3 - (do-special-strings - (s "ab1c23def4" nil) - (let ((s2 (remove-if #'alpha-char-p s :count 3 :from-end t))) - (assert (equal (array-element-type s) - (array-element-type s2))) - (assert (string= s2 "ab1c234")) - (assert (string= s "ab1c23def4")))) - nil) - -(deftest remove-if-not-string.1 - (do-special-strings - (s "ab1c23def4" nil) - (let ((s2 (remove-if-not #'digit-char-p s))) - (assert (equal (array-element-type s) - (array-element-type s2))) - (assert (string= s2 "1234")) - (assert (string= s "ab1c23def4")))) - nil) - -(deftest remove-if-not-string.2 - (do-special-strings - (s "ab1c23def4" nil) - (let ((s2 (remove-if-not #'digit-char-p s :count 3))) - (assert (equal (array-element-type s) - (array-element-type s2))) - (assert (string= s2 "123def4")) - (assert (string= s "ab1c23def4")))) - nil) - -(deftest remove-if-not-string.3 - (do-special-strings - (s "ab1c23def4" nil) - (let ((s2 (remove-if-not #'digit-char-p s :count 3 :from-end t))) - (assert (equal (array-element-type s) - (array-element-type s2))) - (assert (string= s2 "ab1c234")) - (assert (string= s "ab1c23def4")))) - nil) - - -(deftest delete-if-string.1 - (do-special-strings - (s "ab1c23def4" nil) - (let ((s2 (delete-if #'alpha-char-p s))) - (assert (equal (array-element-type s) - (array-element-type s2))) - (assert (string= s2 "1234")))) - nil) - -(deftest delete-if-string.2 - (do-special-strings - (s "ab1c23def4" nil) - (let ((s2 (delete-if #'alpha-char-p s :count 3))) - (assert (equal (array-element-type s) - (array-element-type s2))) - (assert (string= s2 "123def4")))) - nil) - -(deftest delete-if-string.3 - (do-special-strings - (s "ab1c23def4" nil) - (let ((s2 (delete-if #'alpha-char-p s :count 3 :from-end t))) - (assert (equal (array-element-type s) - (array-element-type s2))) - (assert (string= s2 "ab1c234")))) - nil) - -(deftest delete-if-not-string.1 - (do-special-strings - (s "ab1c23def4" nil) - (let ((s2 (delete-if-not #'digit-char-p s))) - (assert (equal (array-element-type s) - (array-element-type s2))) - (assert (string= s2 "1234")))) - nil) - -(deftest delete-if-not-string.2 - (do-special-strings - (s "ab1c23def4" nil) - (let ((s2 (delete-if-not #'digit-char-p s :count 3))) - (assert (equal (array-element-type s) - (array-element-type s2))) - (assert (string= s2 "123def4")))) - nil) - -(deftest delete-if-not-string.3 - (do-special-strings - (s "ab1c23def4" nil) - (let ((s2 (delete-if-not #'digit-char-p s :count 3 :from-end t))) - (assert (equal (array-element-type s) - (array-element-type s2))) - (assert (string= s2 "ab1c234")))) - nil) diff --git a/t/ansi-test/sequences/replace.lsp b/t/ansi-test/sequences/replace.lsp deleted file mode 100644 index 94e18d5..0000000 --- a/t/ansi-test/sequences/replace.lsp +++ /dev/null @@ -1,724 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Aug 27 16:11:38 2002 -;;;; Contains: Tests for REPLACE - -(in-package :cl-test) - -(deftest replace-list.1 - (let* ((x (copy-seq '(a b c d e f g))) - (result (replace x '(x y z)))) - (values (eqt x result) result)) - t - (x y z d e f g)) - -(deftest replace-list.2 - (let* ((x (copy-seq '(a b c d e f g))) - (result (replace x '(x y z) :start1 1))) - (values (eqt x result) result)) - t - (a x y z e f g)) - -(deftest replace-list.3 - (let* ((x (copy-seq '(a b c d e f g))) - (result (replace x '(x y z) :start1 4))) - (values (eqt x result) result)) - t - (a b c d x y z)) - -(deftest replace-list.4 - (let* ((x (copy-seq '(a b c d e f g))) - (result (replace x '(x y z) :start1 5))) - (values (eqt x result) result)) - t - (a b c d e x y)) - -(deftest replace-list.5 - (let* ((x (copy-seq '(a b c d e f g))) - (result (replace x '(x y z) :start1 6))) - (values (eqt x result) result)) - t - (a b c d e f x)) - -(deftest replace-list.6 - (let* ((x (copy-seq '(a b c d e f g))) - (result (replace x #(x y z) :start1 2))) - (values (eqt x result) result)) - t - (a b x y z f g)) - -(deftest replace-list.7 - (replace nil #(x y z)) - nil) - -(deftest replace-list.8 - (let* ((x (copy-seq '(a b c d e f g))) - (result (replace x '(x y z) :end1 1))) - (values (eqt x result) result)) - t - (x b c d e f g)) - -(deftest replace-list.9 - (let* ((x (copy-seq '(a b c d e f g))) - (result (replace x '(x y z) :start1 3 :end1 4))) - (values (eqt x result) result)) - t - (a b c x e f g)) - -(deftest replace-list.10 - (let* ((x (copy-seq '(a b c d e f g))) - (result (replace x '(x y z) :start1 0 :end1 5))) - (values (eqt x result) result)) - t - (x y z d e f g)) - - -(deftest replace-list.11 - (let* ((x (copy-seq '(a b c d e f g))) - (result (replace x '(x y z) :start2 1))) - (values (eqt x result) result)) - t - (y z c d e f g)) - -(deftest replace-list.12 - (let* ((x (copy-seq '(a b c d e f g))) - (result (replace x '(x y z) :start2 1 :end1 nil))) - (values (eqt x result) result)) - t - (y z c d e f g)) - -(deftest replace-list.13 - (let* ((x (copy-seq '(a b c d e f g))) - (result (replace x '(x y z) :start2 1 :end2 nil))) - (values (eqt x result) result)) - t - (y z c d e f g)) - -(deftest replace-list.14 - (let* ((x (copy-seq '(a b c d e f g))) - (result (replace x '(x y z) :start2 1 :end2 2))) - (values (eqt x result) result)) - t - (y b c d e f g)) - -(deftest replace-list.15 - (let* ((x (copy-seq '(a b c d e f g))) - (result (replace x '(x y z) :start1 4 :end1 5 :start2 1 :end2 2))) - (values (eqt x result) result)) - t - (a b c d y f g)) - -(deftest replace-list.16 - (let* ((x (copy-seq '(a b c d e f))) - (y #(1 2 3)) - (result (replace x y :start1 1))) - (values (eqt x result) result)) - t - (a 1 2 3 e f)) - -(deftest replace-list.17 - (let* ((x (copy-seq '(a b c d e f))) - (y (make-array '(3) :initial-contents '(1 2 3) - :fill-pointer t)) - (result (replace x y :start1 1))) - (values (eqt x result) result)) - t - (a 1 2 3 e f)) - -(deftest replace-list.18 - (let* ((x (copy-seq '(a b c d e f))) - (y (make-array '(6) :initial-contents '(1 2 3 4 5 6) - :fill-pointer 3)) - (result (replace x y :start1 1))) - (values (eqt x result) result)) - t - (a 1 2 3 e f)) - -(deftest replace-list.19 - (let* ((x (copy-seq '(a b c d e f))) - (result (replace x x :start1 0 :end1 3 :start2 1 :end2 4))) - (values (eqt x result) result)) - t - (b c d d e f)) - -(deftest replace-list.20 - (let* ((x (copy-seq '(a b c d e f))) - (result (replace x x :start1 1 :end1 4 :start2 0 :end2 3))) - (values (eqt x result) result)) - t - (a a b c e f)) - - -;;; Tests of vectors - -(deftest replace-vector.1 - (let* ((x (copy-seq #(a b c d e f g))) - (result (replace x #(x y z)))) - (values (eqt x result) result)) - t - #(x y z d e f g)) - -(deftest replace-vector.2 - (let* ((x (copy-seq #(a b c d e f g))) - (result (replace x #(x y z) :start1 1))) - (values (eqt x result) result)) - t - #(a x y z e f g)) - -(deftest replace-vector.3 - (let* ((x (copy-seq #(a b c d e f g))) - (result (replace x #(x y z) :start1 4))) - (values (eqt x result) result)) - t - #(a b c d x y z)) - -(deftest replace-vector.4 - (let* ((x (copy-seq #(a b c d e f g))) - (result (replace x #(x y z) :start1 5))) - (values (eqt x result) result)) - t - #(a b c d e x y)) - -(deftest replace-vector.5 - (let* ((x (copy-seq #(a b c d e f g))) - (result (replace x #(x y z) :start1 6))) - (values (eqt x result) result)) - t - #(a b c d e f x)) - -(deftest replace-vector.6 - (let* ((x (copy-seq #(a b c d e f g))) - (result (replace x '(x y z) :start1 2))) - (values (eqt x result) result)) - t - #(a b x y z f g)) - -(deftest replace-vector.7 - (replace #() #(x y z)) - #()) - -(deftest replace-vector.8 - (let* ((x (copy-seq #(a b c d e f g))) - (result (replace x #(x y z) :end1 1))) - (values (eqt x result) result)) - t - #(x b c d e f g)) - -(deftest replace-vector.9 - (let* ((x (copy-seq #(a b c d e f g))) - (result (replace x #(x y z) :start1 3 :end1 4))) - (values (eqt x result) result)) - t - #(a b c x e f g)) - -(deftest replace-vector.10 - (let* ((x (copy-seq #(a b c d e f g))) - (result (replace x #(x y z) :start1 0 :end1 5))) - (values (eqt x result) result)) - t - #(x y z d e f g)) - - -(deftest replace-vector.11 - (let* ((x (copy-seq #(a b c d e f g))) - (result (replace x #(x y z) :start2 1))) - (values (eqt x result) result)) - t - #(y z c d e f g)) - -(deftest replace-vector.12 - (let* ((x (copy-seq #(a b c d e f g))) - (result (replace x #(x y z) :start2 1 :end1 nil))) - (values (eqt x result) result)) - t - #(y z c d e f g)) - -(deftest replace-vector.13 - (let* ((x (copy-seq #(a b c d e f g))) - (result (replace x #(x y z) :start2 1 :end2 nil))) - (values (eqt x result) result)) - t - #(y z c d e f g)) - -(deftest replace-vector.14 - (let* ((x (copy-seq #(a b c d e f g))) - (result (replace x #(x y z) :start2 1 :end2 2))) - (values (eqt x result) result)) - t - #(y b c d e f g)) - -(deftest replace-vector.15 - (let* ((x (copy-seq #(a b c d e f g))) - (result (replace x #(x y z) :start1 4 :end1 5 :start2 1 :end2 2))) - (values (eqt x result) result)) - t - #(a b c d y f g)) - -(deftest replace-vector.16 - (let* ((x (copy-seq #(a b c d e f))) - (y '(1 2 3)) - (result (replace x y :start1 1))) - (values (eqt x result) result)) - t - #(a 1 2 3 e f)) - -(deftest replace-vector.17 - (let* ((x (copy-seq #(a b c d e f))) - (y (make-array '(3) :initial-contents '(1 2 3) - :fill-pointer t)) - (result (replace x y :start1 1))) - (values (eqt x result) result)) - t - #(a 1 2 3 e f)) - -(deftest replace-vector.18 - (let* ((x (copy-seq #(a b c d e f))) - (y (make-array '(6) :initial-contents '(1 2 3 4 5 6) - :fill-pointer 3)) - (result (replace x y :start1 1))) - (values (eqt x result) result)) - t - #(a 1 2 3 e f)) - -(deftest replace-vector.19 - (let* ((x (copy-seq #(a b c d e f))) - (result (replace x x :start1 0 :end1 3 :start2 1 :end2 4))) - (values (eqt x result) result)) - t - #(b c d d e f)) - -(deftest replace-vector.21 - (let* ((x (copy-seq #(a b c d e f))) - (result (replace x x :start1 1 :end1 4 :start2 0 :end2 3))) - (values (eqt x result) result)) - t - #(a a b c e f)) - -;;; tests on bit vectors - -(deftest replace-bit-vector.1 - (let* ((x (copy-seq #*1101001)) - (result (replace x #*011))) - (values (eqt x result) result)) - t - #*0111001) - -(deftest replace-bit-vector.2 - (let* ((x (copy-seq #*1101001)) - (result (replace x #*011 :start1 1))) - (values (eqt x result) result)) - t - #*1011001) - -(deftest replace-bit-vector.3 - (let* ((x (copy-seq #*1101001)) - (result (replace x #*011 :start1 4))) - (values (eqt x result) result)) - t - #*1101011) - -(deftest replace-bit-vector.4 - (let* ((x (copy-seq #*0000000)) - (result (replace x #*111 :start1 5))) - (values (eqt x result) result)) - t - #*0000011) - -(deftest replace-bit-vector.5 - (let* ((x (copy-seq #*0000000)) - (result (replace x #*100 :start1 6))) - (values (eqt x result) result)) - t - #*0000001) - -(deftest replace-bit-vector.6 - (let* ((x (copy-seq #*0000000)) - (result (replace x '(1 1 1) :start1 2))) - (values (eqt x result) result)) - t - #*0011100) - -(deftest replace-bit-vector.7 - (replace #* #*111) - #*) - -(deftest replace-bit-vector.8 - (let* ((x (copy-seq #*0000000)) - (result (replace x #*111 :end1 1))) - (values (eqt x result) result)) - t - #*1000000) - -(deftest replace-bit-vector.9 - (let* ((x (copy-seq #*0000000)) - (result (replace x #*110 :start1 3 :end1 4))) - (values (eqt x result) result)) - t - #*0001000) - -(deftest replace-bit-vector.10 - (let* ((x (copy-seq #*0000000)) - (result (replace x #*111 :start1 0 :end1 5))) - (values (eqt x result) result)) - t - #*1110000) - - -(deftest replace-bit-vector.11 - (let* ((x (copy-seq #*0000000)) - (result (replace x #*011 :start2 1))) - (values (eqt x result) result)) - t - #*1100000) - -(deftest replace-bit-vector.12 - (let* ((x (copy-seq #*0000000)) - (result (replace x #*011 :start2 1 :end1 nil))) - (values (eqt x result) result)) - t - #*1100000) - -(deftest replace-bit-vector.13 - (let* ((x (copy-seq #*0000000)) - (result (replace x #*011 :start2 1 :end2 nil))) - (values (eqt x result) result)) - t - #*1100000) - -(deftest replace-bit-vector.14 - (let* ((x (copy-seq #*0000000)) - (result (replace x #*011 :start2 1 :end2 2))) - (values (eqt x result) result)) - t - #*1000000) - -(deftest replace-bit-vector.15 - (let* ((x (copy-seq #*0000000)) - (result (replace x #*011 :start1 4 :end1 5 :start2 1 :end2 2))) - (values (eqt x result) result)) - t - #*0000100) - -(deftest replace-bit-vector.16 - (let* ((x (copy-seq #*001011)) - (y '(1 0 1)) - (result (replace x y :start1 1))) - (values (eqt x result) result)) - t - #*010111) - -(deftest replace-bit-vector.17 - (let* ((x (copy-seq #*001011)) - (y (make-array '(3) :initial-contents '(1 0 1) - :fill-pointer t :element-type 'bit)) - (result (replace x y :start1 1))) - (values (eqt x result) result)) - t - #*010111) - -(deftest replace-bit-vector.18 - (let* ((x (copy-seq #*001011)) - (y (make-array '(6) :initial-contents '(1 0 1 0 0 1) - :fill-pointer 3 - :element-type 'bit)) - (result (replace x y :start1 1))) - (values (eqt x result) result)) - t - #*010111) - -(deftest replace-bit-vector.19 - (let* ((x (copy-seq #*001011)) - (result (replace x x :start1 0 :end1 3 :start2 1 :end2 4))) - (values (eqt x result) result)) - t - #*010011) - -(deftest replace-bit-vector.21 - (let* ((x (copy-seq #*001011)) - (result (replace x x :start1 1 :end1 4 :start2 0 :end2 3))) - (values (eqt x result) result)) - t - #*000111) - -;;; Tests on strings - -(deftest replace-string.1 - (let* ((x (copy-seq "abcdefg")) - (result (replace x "xyz"))) - (values (eqt x result) result)) - t - "xyzdefg") - -(deftest replace-string.2 - (let* ((x (copy-seq "abcdefg")) - (result (replace x "xyz" :start1 1))) - (values (eqt x result) result)) - t - "axyzefg") - -(deftest replace-string.3 - (let* ((x (copy-seq "abcdefg")) - (result (replace x "xyz" :start1 4))) - (values (eqt x result) result)) - t - "abcdxyz") - -(deftest replace-string.4 - (let* ((x (copy-seq "abcdefg")) - (result (replace x "xyz" :start1 5))) - (values (eqt x result) result)) - t - "abcdexy") - -(deftest replace-string.5 - (let* ((x (copy-seq "abcdefg")) - (result (replace x "xyz" :start1 6))) - (values (eqt x result) result)) - t - "abcdefx") - -(deftest replace-string.6 - (let* ((x (copy-seq "abcdefg")) - (result (replace x '(#\x #\y #\z) :start1 2))) - (values (eqt x result) result)) - t - "abxyzfg") - -(deftest replace-string.7 - (replace "" "xyz") - "") - -(deftest replace-string.8 - (let* ((x (copy-seq "abcdefg")) - (result (replace x "xyz" :end1 1))) - (values (eqt x result) result)) - t - "xbcdefg") - -(deftest replace-string.9 - (let* ((x (copy-seq "abcdefg")) - (result (replace x "xyz" :start1 3 :end1 4))) - (values (eqt x result) result)) - t - "abcxefg") - -(deftest replace-string.10 - (let* ((x (copy-seq "abcdefg")) - (result (replace x "xyz" :start1 0 :end1 5))) - (values (eqt x result) result)) - t - "xyzdefg") - - -(deftest replace-string.11 - (let* ((x (copy-seq "abcdefg")) - (result (replace x "xyz" :start2 1))) - (values (eqt x result) result)) - t - "yzcdefg") - -(deftest replace-string.12 - (let* ((x (copy-seq "abcdefg")) - (result (replace x "xyz" :start2 1 :end1 nil))) - (values (eqt x result) result)) - t - "yzcdefg") - -(deftest replace-string.13 - (let* ((x (copy-seq "abcdefg")) - (result (replace x "xyz" :start2 1 :end2 nil))) - (values (eqt x result) result)) - t - "yzcdefg") - -(deftest replace-string.14 - (let* ((x (copy-seq "abcdefg")) - (result (replace x "xyz" :start2 1 :end2 2))) - (values (eqt x result) result)) - t - "ybcdefg") - -(deftest replace-string.15 - (let* ((x (copy-seq "abcdefg")) - (result (replace x "xyz" :start1 4 :end1 5 :start2 1 :end2 2))) - (values (eqt x result) result)) - t - "abcdyfg") - -(deftest replace-string.16 - (let* ((x (copy-seq "abcdef")) - (y (coerce "123" 'list)) - (result (replace x y :start1 1))) - (values (eqt x result) result)) - t - "a123ef") - -(deftest replace-string.17 - (let* ((x (copy-seq "abcdef")) - (y (make-array '(3) :initial-contents '(#\1 #\2 #\3) - :fill-pointer t :element-type 'character)) - (result (replace x y :start1 1))) - (values (eqt x result) result)) - t - "a123ef") - -(deftest replace-string.18 - (let* ((x (copy-seq "abcdef")) - (y (make-array '(6) :initial-contents "123456" - :fill-pointer 3 - :element-type 'character)) - (result (replace x y :start1 1))) - (values (eqt x result) result)) - t - "a123ef") - -(deftest replace-string.19 - (let* ((x (copy-seq "abcdef")) - (result (replace x x :start1 0 :end1 3 :start2 1 :end2 4))) - (values (eqt x result) result)) - t - "bcddef") - -(deftest replace-string.21 - (let* ((x (copy-seq "abcdef")) - (result (replace x x :start1 1 :end1 4 :start2 0 :end2 3))) - (values (eqt x result) result)) - t - "aabcef") - -(deftest replace-string.22 - (do-special-strings - (s "abcdefg" nil) - (assert (eq s (replace s "XYZ"))) - (assert (string= s "XYZdefg"))) - nil) - -(deftest replace-string.23 - (do-special-strings - (s "abcdefg" nil) - (assert (eq s (replace s "XYZ" :start1 1))) - (assert (string= s "aXYZefg"))) - nil) - -(deftest replace-string.24 - (do-special-strings - (s "abcdefg" nil) - (assert (eq s (replace s "XYZ" :start1 1 :end2 2))) - (assert (string= s "aXYdefg"))) - nil) - -(deftest replace-string.25 - (do-special-strings - (s "abcdefg" nil) - (assert (eq s (replace s "XYZ" :end1 2))) - (assert (string= s "XYcdefg"))) - nil) - -(deftest replace-string.26 - (do-special-strings - (s "abcdefg" nil) - (assert (eq s (replace s "XYZ" :start2 1))) - (assert (string= s "YZcdefg"))) - nil) - - - - - -;;; Order of evaluation tests - -(deftest replace.order.1 - (let ((i 0) a b) - (values - (replace (progn (setf a (incf i)) (list 'a 'b 'c)) - (progn (setf b (incf i)) (list 'e 'f))) - i a b)) - (e f c) 2 1 2) - -(deftest replace.order.2 - (let ((i 0) a b c d e f) - (values - (replace (progn (setf a (incf i)) (list 'a 'b 'c)) - (progn (setf b (incf i)) (list 'e 'f)) - :start1 (progn (setf c (incf i)) 1) - :end1 (progn (setf d (incf i)) 3) - :start2 (progn (setf e (incf i)) 0) - :end2 (progn (setf f (incf i)) 2) - ) - i a b c d e f)) - (a e f) 6 1 2 3 4 5 6) - -(deftest replace.order.3 - (let ((i 0) a b c d e f) - (values - (replace (progn (setf a (incf i)) (list 'a 'b 'c)) - (progn (setf b (incf i)) (list 'e 'f)) - :end2 (progn (setf c (incf i)) 2) - :start2 (progn (setf d (incf i)) 0) - :end1 (progn (setf e (incf i)) 3) - :start1 (progn (setf f (incf i)) 1) - ) - i a b c d e f)) - (a e f) 6 1 2 3 4 5 6) - -;;; Keyword tests - -(deftest replace.allow-other-keys.1 - (replace (copy-seq "abcdefg") "xyz" :allow-other-keys t) - "xyzdefg") - -(deftest replace.allow-other-keys.2 - (replace (copy-seq "abcdefg") "xyz" :allow-other-keys nil) - "xyzdefg") - -(deftest replace.allow-other-keys.3 - (replace (copy-seq "abcdefg") "xyz" :allow-other-keys t :bad t) - "xyzdefg") - -(deftest replace.allow-other-keys.4 - (replace (copy-seq "abcdefg") "xyz" :bad t :allow-other-keys t) - "xyzdefg") - -(deftest replace.allow-other-keys.5 - (replace (copy-seq "abcdefg") "xyz" :bad1 t :allow-other-keys t - :bad2 t :allow-other-keys nil :bad3 nil) - "xyzdefg") - -(deftest replace.allow-other-keys.6 - (replace (copy-seq "abcdefg") "xyz" :allow-other-keys t :start1 1) - "axyzefg") - -(deftest replace.keywords.7 - (replace (copy-seq "abcdefg") "xyz" :start1 0 :start2 0 :end1 3 :end2 3 - :start1 1 :start2 1 :end1 2 :end1 2) - "xyzdefg") - - - - -;;; Error cases - -(deftest replace.error.1 - (signals-error (replace) program-error) - t) - -(deftest replace.error.2 - (signals-error (replace nil) program-error) - t) - -(deftest replace.error.3 - (signals-error (replace nil nil :start) program-error) - t) - -(deftest replace.error.4 - (signals-error (replace nil nil 'bad t) program-error) - t) - -(deftest replace.error.5 - (signals-error (replace nil nil :allow-other-keys nil 'bad t) program-error) - t) - -(deftest replace.error.6 - (signals-error (replace nil nil 1 2) program-error) - t) - diff --git a/t/ansi-test/sequences/reverse.lsp b/t/ansi-test/sequences/reverse.lsp deleted file mode 100644 index a6a2cf9..0000000 --- a/t/ansi-test/sequences/reverse.lsp +++ /dev/null @@ -1,192 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Aug 20 23:47:28 2002 -;;;; Contains: Tests for REVERSE - -(in-package :cl-test) - -(deftest reverse-list.1 - (reverse nil) - nil) - -(deftest reverse-list.2 - (let ((x '(a b c))) - (values (reverse x) x)) - (c b a) - (a b c)) - -(deftest reverse-vector.1 - (reverse #()) - #()) - -(deftest reverse-vector.2 - (let ((x #(a b c d e))) - (values (reverse x) x)) - #(e d c b a) - #(a b c d e)) - -(deftest reverse-vector.3 - (let ((x (make-array 0 :fill-pointer t :adjustable t))) - (reverse x)) - #()) - -(deftest reverse-vector.4 - (let* ((x (make-array 5 :initial-contents '(1 2 3 4 5) - :fill-pointer t :adjustable t)) - (y (reverse x))) - (values y x)) - #(5 4 3 2 1) - #(1 2 3 4 5)) - -(deftest reverse-vector.5 - (let* ((x (make-array 10 :initial-contents '(1 2 3 4 5 6 7 8 9 10) - :fill-pointer 5)) - (y (reverse x))) - y) - #(5 4 3 2 1)) - -;;; Other unusual vectors - -(deftest reverse-vector.6 - (do-special-integer-vectors - (v #(1 1 0 1 1 0) nil) - (let ((nv (reverse v))) - (assert (typep nv 'simple-array)) - (assert (not (eql v nv))) - (assert (equalp nv #(0 1 1 0 1 1))) - (assert (equalp v #(1 1 0 1 1 0))))) - nil) - -(deftest reverse-vector.7 - (do-special-integer-vectors - (v #(-1 -1 0 -1 -1 0) nil) - (let ((nv (reverse v))) - (assert (typep nv 'simple-array)) - (assert (not (eql v nv))) - (assert (equalp nv #(0 -1 -1 0 -1 -1))) - (assert (equalp v #(-1 -1 0 -1 -1 0))))) - nil) - -(deftest reverse-vector.8 - (let ((len 10)) - (loop for etype in '(short-float single-float double-float long-float rational) - for vals = (loop for i from 1 to len collect (coerce i etype)) - for vec = (make-array len :element-type etype :initial-contents vals) - for nvec = (reverse vec) - unless (and (eql (length nvec) len) - (typep nvec 'simple-array) - (not (eql vec nvec)) - (every #'eql (reverse vals) nvec) - (every #'eql vals vec)) - collect (list etype vals vec nvec))) - nil) - -(deftest reverse-vector.9 - (let ((len 10)) - (loop for cetype in '(short-float single-float double-float long-float rational integer) - for etype = `(complex ,cetype) - for vals = (loop for i from 1 to len collect (complex (coerce i cetype) - (coerce (- i) cetype))) - for vec = (make-array len :element-type etype :initial-contents vals) - for nvec = (reverse vec) - unless (and (eql (length nvec) len) - (typep nvec 'simple-array) - (not (eql vec nvec)) - (every #'eql (reverse vals) nvec) - (every #'eql vals vec)) - collect (list etype vals vec nvec))) - nil) - -;;; Bit vectors - -(deftest reverse-bit-vector.1 - (reverse #*) - #*) - -(deftest reverse-bit-vector.2 - (let ((x #*000110110110)) - (values (reverse x) x)) - #*011011011000 - #*000110110110) - -(deftest reverse-bit-vector.3 - (let* ((x (make-array 10 :initial-contents '(0 0 0 1 1 0 1 0 1 0) - :fill-pointer 5 - :element-type 'bit)) - (y (reverse x))) - y) - #*11000) - -;;; Strings - -(deftest reverse-string.1 - (reverse "") - "") - -(deftest reverse-string.2 - (let ((x "000110110110")) - (values (reverse x) x)) - "011011011000" - "000110110110") - -(deftest reverse-string.3 - (let* ((x (make-array 10 :initial-contents "abcdefghij" - :fill-pointer 5 - :element-type 'character)) - (y (reverse x))) - y) - "edcba") - -(deftest reverse-string.4 - (let* ((x (make-array 10 :initial-contents "abcdefghij" - :fill-pointer 5 - :element-type 'base-char)) - (y (reverse x))) - y) - "edcba") - -;;; Specialized string tests - -(deftest reverse-string.5 - (do-special-strings - (s (copy-seq "12345") nil) - (let ((s2 (reverse s))) - (assert (typep s2 'simple-array)) - (assert (equal (array-element-type s) (array-element-type s2))) - (assert (string= "12345" s)) - (assert (string= "54321" s2)))) - nil) - -;;; Order, number of times of evaluation - -(deftest reverse.order.1 - (let ((i 0)) - (values - (reverse (progn (incf i) (list 'a 'b 'c 'd))) - i)) - (d c b a) 1) - -;;; Constant folding tests - -(def-fold-test reverse.fold.1 (reverse '(a b c))) -(def-fold-test reverse.fold.2 (reverse #(a b c))) -(def-fold-test reverse.fold.3 (reverse #*00111101011011)) -(def-fold-test reverse.fold.4 (reverse "abcdefgh")) - -;;; Error cases - -(deftest reverse.error.1 - (check-type-error #'reverse #'sequencep) - nil) - -(deftest reverse.error.6 - (signals-error (reverse) program-error) - t) - -(deftest reverse.error.7 - (signals-error (reverse nil nil) program-error) - t) - -(deftest reverse.error.8 - (signals-error (locally (reverse 'a) t) type-error) - t) diff --git a/t/ansi-test/sequences/search-bitvector.lsp b/t/ansi-test/sequences/search-bitvector.lsp deleted file mode 100644 index cddf53a..0000000 --- a/t/ansi-test/sequences/search-bitvector.lsp +++ /dev/null @@ -1,192 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Aug 25 13:06:54 2002 -;;;; Contains: Tests for SEARCH on bit vectors - -(in-package :cl-test) - - - -(deftest search-bitvector.1 - (let ((target *searched-bitvector*) - (pat #*0)) - (loop for i from 0 to (1- (length target)) - for tail = (subseq target i) - always - (let ((pos (search pat tail))) - (search-check pat tail pos)))) - t) - -(deftest search-bitvector.2 - (let ((target *searched-bitvector*) - (pat #*0)) - (loop for i from 1 to (length target) - always - (let ((pos (search pat target :end2 i :from-end t))) - (search-check pat target pos :end2 i :from-end t)))) - t) - -(deftest search-bitvector.3 - (let ((target *searched-bitvector*)) - (loop for pat in *pattern-subbitvectors* - for pos = (search pat target) - unless (search-check pat target pos) - collect pat)) - nil) - -(deftest search-bitvector.4 - (let ((target *searched-bitvector*)) - (loop for pat in *pattern-subbitvectors* - for pos = (search pat target :from-end t) - unless (search-check pat target pos :from-end t) - collect pat)) - nil) - -(deftest search-bitvector.5 - (let ((target *searched-bitvector*)) - (loop for pat in *pattern-subbitvectors* - for pos = (search pat target :start2 25 :end2 75) - unless (search-check pat target pos :start2 25 :end2 75) - collect pat)) - nil) - -(deftest search-bitvector.6 - (let ((target *searched-bitvector*)) - (loop for pat in *pattern-subbitvectors* - for pos = (search pat target :from-end t :start2 25 :end2 75) - unless (search-check pat target pos :from-end t - :start2 25 :end2 75) - collect pat)) - nil) - -(deftest search-bitvector.7 - (let ((target *searched-bitvector*)) - (loop for pat in *pattern-subbitvectors* - for pos = (search pat target :start2 20) - unless (search-check pat target pos :start2 20) - collect pat)) - nil) - -(deftest search-bitvector.8 - (let ((target *searched-bitvector*)) - (loop for pat in *pattern-subbitvectors* - for pos = (search pat target :from-end t :start2 20) - unless (search-check pat target pos :from-end t - :start2 20) - collect pat)) - nil) - -(deftest search-bitvector.9 - (let ((target *searched-bitvector*)) - (loop for pat in (mapcar #'(lambda (x) - (map 'vector - #'(lambda (y) - (sublis '((a . 2) (b . 3)) y)) - x)) - *pattern-sublists*) - for pos = (search pat target :start2 20 :key #'evenp) - unless (search-check pat target pos :start2 20 :key #'evenp) - collect pat)) - nil) - -(deftest search-bitvector.10 - (let ((target *searched-bitvector*)) - (loop for pat in (mapcar #'(lambda (x) - (map 'vector - #'(lambda (y) - (sublis '((a . 2) (b . 3)) y)) - x)) - *pattern-sublists*) - for pos = (search pat target :from-end t :start2 20 :key 'oddp) - unless (search-check pat target pos :from-end t - :start2 20 :key 'oddp) - collect pat)) - nil) - -(deftest search-bitvector.11 - (let ((target *searched-bitvector*)) - (loop for pat in *pattern-subbitvectors* - for pos = (search pat target :start2 20 :test (complement #'eql)) - unless (search-check pat target pos :start2 20 - :test (complement #'eql)) - collect pat)) - nil) - -(deftest search-bitvector.12 - (let ((target *searched-bitvector*)) - (loop for pat in *pattern-subbitvectors* - for pos = (search pat target :from-end t :start2 20 :test-not #'eql) - unless (search-check pat target pos :from-end t - :start2 20 :test (complement #'eql)) - collect pat)) - nil) - -(deftest search-bitvector.13 - (let ((target *searched-bitvector*)) - (loop for pat in *pattern-subbitvectors* - when (and (> (length pat) 0) - (let ((pos (search pat target :start1 1 - :test (complement #'eql)))) - (not (search-check pat target pos - :start1 1 - :test (complement #'eql))))) - collect pat)) - nil) - -(deftest search-bitvector.14 - (let ((target *searched-bitvector*)) - (loop for pat in *pattern-subbitvectors* - when (let ((len (length pat))) - (and (> len 0) - (let ((pos (search pat target :end1 (1- len) - :test (complement #'eql)))) - (not (search-check pat target pos - :end1 (1- len) - :test (complement #'eql)))))) - collect pat)) - nil) - -(deftest search-bitvector.15 - (let ((a (make-array '(10) :initial-contents '(0 1 1 0 0 0 1 0 1 1) - :fill-pointer 5 - :element-type 'bit))) - (values - (search #*0 a) - (search #*0 a :from-end t) - (search #*01 a) - (search #*01 a :from-end t) - (search #*010 a) - (search #*010 a :from-end t))) - 0 4 0 0 nil nil) - -(deftest search-bitvector.16 - (let ((pat (make-array '(3) :initial-contents '(0 1 0) - :fill-pointer 1)) - (a #*01100)) - (values - (search pat a) - (search pat a :from-end t) - (progn - (setf (fill-pointer pat) 2) - (search pat a)) - (search pat a :from-end t) - (progn - (setf (fill-pointer pat) 3) - (search pat a)) - (search pat a :from-end t))) - 0 4 0 0 nil nil) - -;; Order of test, test-not - -(deftest search-bitvector.17 - (let ((pat #*10) - (target #*000011)) - (search pat target :test #'<=)) - 4) - -(deftest search-bitvector.18 - (let ((pat #*10) - (target #*000011)) - (search pat target :test-not #'>)) - 4) - diff --git a/t/ansi-test/sequences/search-list.lsp b/t/ansi-test/sequences/search-list.lsp deleted file mode 100644 index c75d7f0..0000000 --- a/t/ansi-test/sequences/search-list.lsp +++ /dev/null @@ -1,292 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Aug 24 07:22:10 2002 -;;;; Contains: Tests for SEARCH on lists - -(in-package :cl-test) - - - -(deftest search-list.1 - (let ((target *searched-list*) - (pat '(a))) - (loop for i from 0 to (1- (length target)) - for tail on target - always - (let ((pos (search pat tail))) - (search-check pat tail pos)))) - t) - -(deftest search-list.2 - (let ((target *searched-list*) - (pat '(a))) - (loop for i from 1 to (length target) - always - (let ((pos (search pat target :end2 i :from-end t))) - (search-check pat target pos :end2 i :from-end t)))) - t) - -(deftest search-list.3 - (let ((target *searched-list*)) - (loop for pat in *pattern-sublists* - for pos = (search pat target) - unless (search-check pat target pos) - collect pat)) - nil) - -(deftest search-list.4 - (let ((target *searched-list*)) - (loop for pat in *pattern-sublists* - for pos = (search pat target :from-end t) - unless (search-check pat target pos :from-end t) - collect pat)) - nil) - -(deftest search-list.5 - (let ((target *searched-list*)) - (loop for pat in *pattern-sublists* - for pos = (search pat target :start2 25 :end2 75) - unless (search-check pat target pos :start2 25 :end2 75) - collect pat)) - nil) - -(deftest search-list.6 - (let ((target *searched-list*)) - (loop for pat in *pattern-sublists* - for pos = (search pat target :from-end t :start2 25 :end2 75) - unless (search-check pat target pos :from-end t - :start2 25 :end2 75) - collect pat)) - nil) - -(deftest search-list.7 - (let ((target *searched-list*)) - (loop for pat in *pattern-sublists* - for pos = (search pat target :start2 20) - unless (search-check pat target pos :start2 20) - collect pat)) - nil) - -(deftest search-list.8 - (let ((target *searched-list*)) - (loop for pat in *pattern-sublists* - for pos = (search pat target :from-end t :start2 20) - unless (search-check pat target pos :from-end t - :start2 20) - collect pat)) - nil) - -(deftest search-list.9 - (let ((target (sublis '((a . 1) (b . 2)) *searched-list*))) - (loop for pat in (sublis '((a . 3) (b . 4)) *pattern-sublists*) - for pos = (search pat target :start2 20 :key #'evenp) - unless (search-check pat target pos :start2 20 :key #'evenp) - collect pat)) - nil) - -(deftest search-list.10 - (let ((target (sublis '((a . 1) (b . 2)) *searched-list*))) - (loop for pat in (sublis '((a . 3) (b . 4)) *pattern-sublists*) - for pos = (search pat target :from-end t :start2 20 :key 'oddp) - unless (search-check pat target pos :from-end t - :start2 20 :key 'oddp) - collect pat)) - nil) - -(deftest search-list.11 - (let ((target *searched-list*)) - (loop for pat in *pattern-sublists* - for pos = (search pat target :start2 20 :test (complement #'eql)) - unless (search-check pat target pos :start2 20 - :test (complement #'eql)) - collect pat)) - nil) - -(deftest search-list.12 - (let ((target *searched-list*)) - (loop for pat in *pattern-sublists* - for pos = (search pat target :from-end t :start2 20 :test-not #'eql) - unless (search-check pat target pos :from-end t - :start2 20 :test (complement #'eql)) - collect pat)) - nil) - -(deftest search-list.13 - (let ((target *searched-list*)) - (loop for pat in *pattern-sublists* - when (and (> (length pat) 0) - (let ((pos (search pat target :start1 1 - :test (complement #'eql)))) - (not (search-check pat target pos - :start1 1 - :test (complement #'eql))))) - collect pat)) - nil) - -(deftest search-list.14 - (let ((target *searched-list*)) - (loop for pat in *pattern-sublists* - when (let ((len (length pat))) - (and (> len 0) - (let ((pos (search pat target :end1 (1- len) - :test (complement #'eql)))) - (not (search-check pat target pos - :end1 (1- len) - :test (complement #'eql)))))) - collect pat)) - nil) - -;; Order of test, test-not - -(deftest search-list.15 - (let ((pat '(10)) - (target '(1 4 6 10 15 20))) - (search pat target :test #'<)) - 4) - -(deftest search-list.16 - (let ((pat '(10)) - (target '(1 4 6 10 15 20))) - (search pat target :test-not #'>=)) - 4) - -(defharmless search.test-and-test-not.1 - (search '(b c) '(a b c d) :test #'eql :test-not #'eql)) - -(defharmless search.test-and-test-not.2 - (search '(b c) '(a b c d) :test-not #'eql :test #'eql)) - -(defharmless search.test-and-test-not.3 - (search #(b c) #(a b c d) :test #'eql :test-not #'eql)) - -(defharmless search.test-and-test-not.4 - (search #(b c) #(a b c d) :test-not #'eql :test #'eql)) - -(defharmless search.test-and-test-not.5 - (search "bc" "abcd" :test #'eql :test-not #'eql)) - -(defharmless search.test-and-test-not.6 - (search "bc" "abcd" :test-not #'eql :test #'eql)) - -(defharmless search.test-and-test-not.7 - (search #*01 #*0011 :test #'eql :test-not #'eql)) - -(defharmless search.test-and-test-not.8 - (search #*01 #*0011 :test-not #'eql :test #'eql)) - - -;;; Keyword tests - -(deftest search.allow-other-keys.1 - (search '(c d) '(a b c d c d e) :allow-other-keys t) - 2) - -(deftest search.allow-other-keys.2 - (search '(c d) '(a b c d c d e) :allow-other-keys nil) - 2) - -(deftest search.allow-other-keys.3 - (search '(c d) '(a b c d c d e) :bad t :allow-other-keys t) - 2) - -(deftest search.allow-other-keys.4 - (search '(c d) '(a b c d c d e) :allow-other-keys 'foo :bad nil) - 2) - -(deftest search.allow-other-keys.5 - (search '(c d) '(a b c d c d e) :bad1 1 :allow-other-keys t :bad2 2 - :allow-other-keys nil :bad3 3) - 2) - -(deftest search.allow-other-keys.6 - (search '(c d) '(a b c d c d e) :allow-other-keys 'foo - :from-end t) - 4) - -(deftest search.allow-other-keys.7 - (search '(c d) '(a b c d c d e) :from-end t :allow-other-keys t) - 4) - -(deftest search.keywords.8 - (search '(c d) '(a b c d c d e) :start1 0 :start2 0 :start1 1 - :start2 6 :from-end t :from-end nil) - 4) - - -;;; Error cases - -(deftest search.error.1 - (signals-error (search) program-error) - t) - -(deftest search.error.2 - (signals-error (search "a") program-error) - t) - -(deftest search.error.3 - (signals-error (search "a" "a" :key) program-error) - t) - -(deftest search.error.4 - (signals-error (search "a" "a" 'bad t) program-error) - t) - -(deftest search.error.5 - (signals-error (search "a" "a" 'bad t :allow-other-keys nil) program-error) - t) - -(deftest search.error.6 - (signals-error (search "a" "a" 1 2) program-error) - t) - -(deftest search.error.7 - (signals-error (search "c" "abcde" :test #'identity) program-error) - t) - -(deftest search.error.8 - (signals-error (search "c" "abcde" :test-not #'identity) program-error) - t) - -(deftest search.error.9 - (signals-error (search "c" "abcde" :key #'cons) program-error) - t) - -(deftest search.error.10 - (signals-error (search "c" "abcde" :key #'car) type-error) - t) - -;;; Order of evaluation - -(deftest search.order.1 - (let ((i 0) a b c d e f g h j) - (values - (search - (progn (setf a (incf i)) '(nil a b nil)) - (progn (setf b (incf i)) '(z z z a a b b z z z)) - :from-end (progn (setf c (incf i)) t) - :start1 (progn (setf d (incf i)) 1) - :end1 (progn (setf e (incf i)) 3) - :start2 (progn (setf f (incf i)) 1) - :end2 (progn (setf g (incf i)) 8) - :key (progn (setf h (incf i)) #'identity) - :test (progn (setf j (incf i)) #'eql) - ) - i a b c d e f g h j)) - 4 9 1 2 3 4 5 6 7 8 9) - -(deftest search.order.2 - (let ((i 0) a b c d e f g h j) - (values - (search - (progn (setf a (incf i)) '(nil a b nil)) - (progn (setf b (incf i)) '(z z z a a b b z z z)) - :test-not (progn (setf c (incf i)) (complement #'eql)) - :key (progn (setf d (incf i)) #'identity) - :end2 (progn (setf e (incf i)) 8) - :start2 (progn (setf f (incf i)) 1) - :end1 (progn (setf g (incf i)) 3) - :start1 (progn (setf h (incf i)) 1) - :from-end (progn (setf j (incf i)) t) - ) - i a b c d e f g h j)) - 4 9 1 2 3 4 5 6 7 8 9) diff --git a/t/ansi-test/sequences/search-string.lsp b/t/ansi-test/sequences/search-string.lsp deleted file mode 100644 index 3c88a50..0000000 --- a/t/ansi-test/sequences/search-string.lsp +++ /dev/null @@ -1,197 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Aug 25 13:06:54 2002 -;;;; Contains: Tests for SEARCH on strings - -(in-package :cl-test) - - - -;;; The next test was busted due to to a stupid cut and paste -;;; error. The loop terminates immediately, doing nothing -;;; useful. -- PFD -#| -(deftest search-string.1 - (let ((target *searched-string*) - (pat #(a))) - (loop for i from 0 to (1- (length target)) - for tail on target - always - (let ((pos (search pat tail))) - (search-check pat tail pos)))) - t) -|# - -(deftest search-string.2 - (let ((target *searched-string*) - (pat #(a))) - (loop for i from 1 to (length target) - always - (let ((pos (search pat target :end2 i :from-end t))) - (search-check pat target pos :end2 i :from-end t)))) - t) - -(deftest search-string.3 - (let ((target *searched-string*)) - (loop for pat in *pattern-substrings* - for pos = (search pat target) - unless (search-check pat target pos) - collect pat)) - nil) - -(deftest search-string.4 - (let ((target *searched-string*)) - (loop for pat in *pattern-substrings* - for pos = (search pat target :from-end t) - unless (search-check pat target pos :from-end t) - collect pat)) - nil) - -(deftest search-string.5 - (let ((target *searched-string*)) - (loop for pat in *pattern-substrings* - for pos = (search pat target :start2 25 :end2 75) - unless (search-check pat target pos :start2 25 :end2 75) - collect pat)) - nil) - -(deftest search-string.6 - (let ((target *searched-string*)) - (loop for pat in *pattern-substrings* - for pos = (search pat target :from-end t :start2 25 :end2 75) - unless (search-check pat target pos :from-end t - :start2 25 :end2 75) - collect pat)) - nil) - -(deftest search-string.7 - (let ((target *searched-string*)) - (loop for pat in *pattern-substrings* - for pos = (search pat target :start2 20) - unless (search-check pat target pos :start2 20) - collect pat)) - nil) - -(deftest search-string.8 - (let ((target *searched-string*)) - (loop for pat in *pattern-substrings* - for pos = (search pat target :from-end t :start2 20) - unless (search-check pat target pos :from-end t - :start2 20) - collect pat)) - nil) - -(deftest search-string.9 - (flet ((%f (x) (case x ((#\0 a) 'c) ((#\1 b) 'd) (t nil)))) - (let ((target *searched-string*)) - (loop for pat in *pattern-sublists* - for pos = (search pat target :start2 20 :key #'%f) - unless (search-check pat target pos :start2 20 :key #'%f) - collect pat))) - nil) - -(deftest search-string.10 - (let ((target *searched-string*)) - (loop for pat in *pattern-substrings* - for pos = (search pat target :start2 20 :test (complement #'eql)) - unless (search-check pat target pos :start2 20 - :test (complement #'eql)) - collect pat)) - nil) - -(deftest search-string.11 - (let ((target *searched-string*)) - (loop for pat in *pattern-substrings* - for pos = (search pat target :from-end t :start2 20 :test-not #'eql) - unless (search-check pat target pos :from-end t - :start2 20 :test (complement #'eql)) - collect pat)) - nil) - -(deftest search-string.13 - (let ((target *searched-string*)) - (loop for pat in *pattern-substrings* - when (and (> (length pat) 0) - (let ((pos (search pat target :start1 1 - :test (complement #'eql)))) - (not (search-check pat target pos - :start1 1 - :test (complement #'eql))))) - collect pat)) - nil) - -(deftest search-string.14 - (let ((target *searched-string*)) - (loop for pat in *pattern-substrings* - when (let ((len (length pat))) - (and (> len 0) - (let ((pos (search pat target :end1 (1- len) - :test (complement #'eql)))) - (not (search-check pat target pos - :end1 (1- len) - :test (complement #'eql)))))) - collect pat)) - nil) - -(deftest search-string.15 - (let ((a (make-array '(10) :initial-contents "abbaaababb" - :fill-pointer 5 - :element-type 'character))) - (values - (search "a" a) - (search "a" a :from-end t) - (search "ab" a) - (search "ab" a :from-end t) - (search "aba" a) - (search "aba" a :from-end t))) - 0 4 0 0 nil nil) - -(deftest search-string.16 - (let ((pat (make-array '(3) :initial-contents '(#\a #\b #\a) - :fill-pointer 1)) - (a "abbaa")) - (values - (search pat a) - (search pat a :from-end t) - (progn - (setf (fill-pointer pat) 2) - (search pat a)) - (search pat a :from-end t) - (progn - (setf (fill-pointer pat) 3) - (search pat a)) - (search pat a :from-end t))) - 0 4 0 0 nil nil) - -;; Order of test, test-not - -(deftest search-string.17 - (let ((pat "m") - (target '"adgmnpq")) - (search pat target :test #'char<)) - 4) - -(deftest search-string.18 - (let ((pat "m") - (target '"adgmnpq")) - (search pat target :test-not #'char>=)) - 4) - -;;; Specialized strings - -(deftest search-string.19 - (do-special-strings - (s "a" nil) - (assert (eql (search s "xyza123apqr") 3)) - (assert (eql (search s "xyza1a3apqr" :start2 4) 5)) - (assert (eql (search s "xyza123apqr" :from-end t) 7))) - nil) - -(deftest search-string.20 - (do-special-strings - (s "xababcdefabc123ababc18" nil) - (assert (eql (search "abc" s) 3)) - (assert (eql (search "abc" s :start2 4) 9)) - (assert (eql (search "abc" s :from-end t) 17))) - nil) - diff --git a/t/ansi-test/sequences/search-vector.lsp b/t/ansi-test/sequences/search-vector.lsp deleted file mode 100644 index 4f12588..0000000 --- a/t/ansi-test/sequences/search-vector.lsp +++ /dev/null @@ -1,192 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Aug 25 13:06:54 2002 -;;;; Contains: Tests for SEARCH on vectors - -(in-package :cl-test) - - - -(deftest search-vector.1 - (let ((target *searched-vector*) - (pat #(a))) - (loop for i from 0 to (1- (length target)) - for tail = (subseq target i) - always - (let ((pos (search pat tail))) - (search-check pat tail pos)))) - t) - -(deftest search-vector.2 - (let ((target *searched-vector*) - (pat #(a))) - (loop for i from 1 to (length target) - always - (let ((pos (search pat target :end2 i :from-end t))) - (search-check pat target pos :end2 i :from-end t)))) - t) - -(deftest search-vector.3 - (let ((target *searched-vector*)) - (loop for pat in *pattern-subvectors* - for pos = (search pat target) - unless (search-check pat target pos) - collect pat)) - nil) - -(deftest search-vector.4 - (let ((target *searched-vector*)) - (loop for pat in *pattern-subvectors* - for pos = (search pat target :from-end t) - unless (search-check pat target pos :from-end t) - collect pat)) - nil) - -(deftest search-vector.5 - (let ((target *searched-vector*)) - (loop for pat in *pattern-subvectors* - for pos = (search pat target :start2 25 :end2 75) - unless (search-check pat target pos :start2 25 :end2 75) - collect pat)) - nil) - -(deftest search-vector.6 - (let ((target *searched-vector*)) - (loop for pat in *pattern-subvectors* - for pos = (search pat target :from-end t :start2 25 :end2 75) - unless (search-check pat target pos :from-end t - :start2 25 :end2 75) - collect pat)) - nil) - -(deftest search-vector.7 - (let ((target *searched-vector*)) - (loop for pat in *pattern-subvectors* - for pos = (search pat target :start2 20) - unless (search-check pat target pos :start2 20) - collect pat)) - nil) - -(deftest search-vector.8 - (let ((target *searched-vector*)) - (loop for pat in *pattern-subvectors* - for pos = (search pat target :from-end t :start2 20) - unless (search-check pat target pos :from-end t - :start2 20) - collect pat)) - nil) - -(deftest search-vector.9 - (let ((target (map 'vector #'(lambda (x) (sublis '((a . 1) (b . 2)) x)) - *searched-list*))) - (loop for pat in (mapcar #'(lambda (x) - (map 'vector - #'(lambda (y) - (sublis '((a . 3) (b . 4)) y)) - x)) - *pattern-sublists*) - for pos = (search pat target :start2 20 :key #'evenp) - unless (search-check pat target pos :start2 20 :key #'evenp) - collect pat)) - nil) - -(deftest search-vector.10 - (let ((target (map 'vector #'(lambda (x) (sublis '((a . 1) (b . 2)) x)) - *searched-list*))) - (loop for pat in (mapcar #'(lambda (x) - (map 'vector - #'(lambda (y) - (sublis '((a . 3) (b . 4)) y)) - x)) - *pattern-sublists*) - for pos = (search pat target :from-end t :start2 20 :key 'oddp) - unless (search-check pat target pos :from-end t - :start2 20 :key 'oddp) - collect pat)) - nil) - -(deftest search-vector.11 - (let ((target *searched-vector*)) - (loop for pat in *pattern-subvectors* - for pos = (search pat target :start2 20 :test (complement #'eql)) - unless (search-check pat target pos :start2 20 - :test (complement #'eql)) - collect pat)) - nil) - -(deftest search-vector.12 - (let ((target *searched-vector*)) - (loop for pat in *pattern-subvectors* - for pos = (search pat target :from-end t :start2 20 :test-not #'eql) - unless (search-check pat target pos :from-end t - :start2 20 :test (complement #'eql)) - collect pat)) - nil) - -(deftest search-vector.13 - (let ((target *searched-vector*)) - (loop for pat in *pattern-subvectors* - when (and (> (length pat) 0) - (let ((pos (search pat target :start1 1 - :test (complement #'eql)))) - (not (search-check pat target pos - :start1 1 - :test (complement #'eql))))) - collect pat)) - nil) - -(deftest search-vector.14 - (let ((target *searched-vector*)) - (loop for pat in *pattern-subvectors* - when (let ((len (length pat))) - (and (> len 0) - (let ((pos (search pat target :end1 (1- len) - :test (complement #'eql)))) - (not (search-check pat target pos - :end1 (1- len) - :test (complement #'eql)))))) - collect pat)) - nil) - -(deftest search-vector.15 - (let ((a (make-array '(10) :initial-contents '(a b b a a a b a b b) - :fill-pointer 5))) - (values - (search '(a) a) - (search '(a) a :from-end t) - (search '(a b) a) - (search '(a b) a :from-end t) - (search '(a b a) a) - (search '(a b a) a :from-end t))) - 0 4 0 0 nil nil) - -(deftest search-vector.16 - (let ((pat (make-array '(3) :initial-contents '(a b a) - :fill-pointer 1)) - (a #(a b b a a))) - (values - (search pat a) - (search pat a :from-end t) - (progn - (setf (fill-pointer pat) 2) - (search pat a)) - (search pat a :from-end t) - (progn - (setf (fill-pointer pat) 3) - (search pat a)) - (search pat a :from-end t))) - 0 4 0 0 nil nil) - -;; Order of test, test-not - -(deftest search-vector.17 - (let ((pat #(10)) - (target #(1 4 6 10 15 20))) - (search pat target :test #'<)) - 4) - -(deftest search-vector.18 - (let ((pat #(10)) - (target #(1 4 6 10 15 20))) - (search pat target :test-not #'>=)) - 4) diff --git a/t/ansi-test/sequences/sort.lsp b/t/ansi-test/sequences/sort.lsp deleted file mode 100644 index 3785f54..0000000 --- a/t/ansi-test/sequences/sort.lsp +++ /dev/null @@ -1,241 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Aug 21 00:11:24 2002 -;;;; Contains: Tests for SORT - -(in-package :cl-test) - -(deftest sort-list.1 - (let ((a (list 1 4 2 5 3))) - (sort a #'<)) - (1 2 3 4 5)) - -(deftest sort-list.2 - (let ((a (list 1 4 2 5 3))) - (sort a #'< :key #'-)) - (5 4 3 2 1)) - -(deftest sort-list.3 - (let ((a (list 1 4 2 5 3))) - (sort a #'(lambda (x y) nil)) - (sort a #'<)) - (1 2 3 4 5)) - -;;; -;;; Confirm that sort only permutes the sequence, even when given -;;; a comparison function that does not define a total order. -;;; -(deftest sort-list.4 - (loop - repeat 100 - always - (let ((a (list 1 2 3 4 5 6 7 8 9 0)) - (cmp (make-array '(10 10)))) - (loop for i from 0 to 9 do - (loop for j from 0 to 9 do - (setf (aref cmp i j) (zerop (logand (random 1024) 512))))) - (setq a (sort a #'(lambda (i j) (aref cmp i j)))) - (and (eqlt (length a) 10) - (equalt (sort a #'<) '(0 1 2 3 4 5 6 7 8 9))))) - t) - -(deftest sort-vector.1 - (let ((a (copy-seq #(1 4 2 5 3)))) - (sort a #'<)) - #(1 2 3 4 5)) - -(deftest sort-vector.2 - (let ((a (copy-seq #(1 4 2 5 3)))) - (sort a #'< :key #'-)) - #(5 4 3 2 1)) - -(deftest sort-vector.3 - (let ((a (copy-seq #(1 4 2 5 3)))) - (sort a #'(lambda (x y) nil)) - (sort a #'<)) - #(1 2 3 4 5)) - -(deftest sort-vector.4 - (let ((a (make-array 10 :initial-contents '(10 40 20 50 30 15 45 25 55 35) - :fill-pointer 5))) - (sort a #'<)) - #(10 20 30 40 50)) - -(deftest sort-vector.5 - (loop - repeat 100 - always - (let ((a (vector 1 2 3 4 5 6 7 8 9 0)) - (cmp (make-array '(10 10)))) - (loop for i from 0 to 9 do - (loop for j from 0 to 9 do - (setf (aref cmp i j) (zerop (logand (random 1024) 512))))) - (setq a (sort a #'(lambda (i j) (aref cmp i j)))) - (and (eqlt (length a) 10) - (equalpt (sort a #'<) #(0 1 2 3 4 5 6 7 8 9))))) - t) - -(deftest sort-vector.6 - (do-special-integer-vectors - (v #(1 4 7 3 2 6 5) nil) - (let ((sv (sort v #'<))) - (assert (equalp sv #(1 2 3 4 5 6 7))))) - nil) - -(deftest sort-vector.7 - (do-special-integer-vectors - (v #(0 1 1 0 1 1 0 1 0) nil) - (let ((sv (sort v #'<))) - (assert (equalp sv #(0 0 0 0 1 1 1 1 1))))) - nil) - -(deftest sort-vector.8 - (do-special-integer-vectors - (v #(0 -1 -1 0 -1 -1 0 -1 0) nil) - (let ((sv (sort v #'>))) - (assert (equalp sv #(0 0 0 0 -1 -1 -1 -1 -1))))) - nil) - -(deftest sort-vector.9 - (let* ((ivals '(1 4 7 3 2 6 5)) - (sivals '(1 2 3 4 5 6 7)) - (len (length ivals))) - (loop for etype in '(short-float single-float double-float long-float rational) - for vals = (loop for i in ivals collect (coerce i etype)) - for svals = (loop for i in sivals collect (coerce i etype)) - for vec = (make-array len :element-type etype :initial-contents vals) - for svec = (sort vec #'<) - unless (and (eql (length svec) len) - (every #'eql svals svec)) - collect (list etype vals svec))) - nil) - -(deftest sort-vector.10 - (let* ((ivals '(1 4 7 3 2 6 5)) - (sivals '(1 2 3 4 5 6 7)) - (len (length ivals))) - (loop for cetype in '(short-float single-float double-float long-float rational) - for etype = `(complex ,cetype) - for vals = (loop for i in ivals collect (complex (coerce i cetype) - (coerce (- i) cetype))) - for svals = (loop for i in sivals collect (complex (coerce i cetype) - (coerce (- i) cetype))) - for vec = (make-array len :element-type etype :initial-contents vals) - for svec = (sort vec #'(lambda (x y) (< (abs x) (abs y)))) - unless (and (eql (length svec) len) - (every #'eql svals svec)) - collect (list etype vals svec))) - nil) - -;;; Bit vectors - -(deftest sort-bit-vector.1 - (let ((a (copy-seq #*10011101))) - (sort a #'<)) - #*00011111) - -(deftest sort-bit-vector.2 - (let ((a (copy-seq #*10011101))) - (values (sort a #'< :key #'-) a)) - #*11111000 - #*11111000) - -(deftest sort-bit-vector.3 - (let ((a (make-array 10 :initial-contents '(1 0 0 1 1 1 1 0 1 1) - :element-type 'bit - :fill-pointer 5))) - (sort a #'<)) - #*00111) - -(deftest sort-string.1 - (let ((a (copy-seq "10011101"))) - (values (sort a #'char<) a)) - "00011111" - "00011111") - -(deftest sort-string.2 - (let ((a (copy-seq "10011101"))) - (values (sort a #'char< :key #'(lambda (c) (if (eql c #\0) #\1 #\0))) a)) - "11111000" - "11111000") - -(deftest sort-string.3 - (let ((a (make-array 10 :initial-contents "1001111011" - :element-type 'character - :fill-pointer 5))) - (sort a #'char<)) - "00111") - -(deftest sort-string.4 - (do-special-strings - (s "aebdc" nil) - (let ((s2 (sort s #'char<))) - (assert (eq s s2)) - (assert (string= s2 "abcde")))) - nil) - -;;; Order of evaluation tests - -(deftest sort.order.1 - (let ((i 0) x y) - (values - (sort (progn (setf x (incf i)) (list 1 7 3 2)) - (progn (setf y (incf i)) #'<)) - i x y)) - (1 2 3 7) 2 1 2) - -(deftest sort.order.2 - (let ((i 0) x y z) - (values - (sort (progn (setf x (incf i)) (list 1 7 3 2)) - (progn (setf y (incf i)) #'<) - :key (progn (setf z (incf i)) #'-)) - i x y z)) - (7 3 2 1) 3 1 2 3) - - -;;; Error cases - -(deftest sort.error.1 - (signals-error (sort) program-error) - t) - -(deftest sort.error.2 - (signals-error (sort nil) program-error) - t) - -(deftest sort.error.3 - (signals-error (sort nil #'< :key) program-error) - t) - -(deftest sort.error.4 - (signals-error (sort nil #'< 'bad t) program-error) - t) - -(deftest sort.error.5 - (signals-error (sort nil #'< 'bad t :allow-other-keys nil) program-error) - t) - -(deftest sort.error.6 - (signals-error (sort nil #'< 1 2) program-error) - t) - -(deftest sort.error.7 - (signals-error (sort (list 1 2 3 4) #'identity) program-error) - t) - -(deftest sort.error.8 - (signals-error (sort (list 1 2 3 4) #'< :key #'cons) program-error) - t) - -(deftest sort.error.9 - (signals-error (sort (list 1 2 3 4) #'< :key #'car) type-error) - t) - -(deftest sort.error.10 - (signals-error (sort (list 1 2 3 4) #'elt) type-error) - t) - -(deftest sort.error.11 - (check-type-error #'(lambda (x) (sort x #'<)) #'sequencep) - nil) diff --git a/t/ansi-test/sequences/stable-sort.lsp b/t/ansi-test/sequences/stable-sort.lsp deleted file mode 100644 index 0cbc201..0000000 --- a/t/ansi-test/sequences/stable-sort.lsp +++ /dev/null @@ -1,222 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Aug 28 21:00:44 2002 -;;;; Contains: Tests for STABLE-SORT - -(in-package :cl-test) - -(deftest stable-sort-list.1 - (let ((a (list 1 4 2 5 3))) - (stable-sort a #'<)) - (1 2 3 4 5)) - -(deftest stable-sort-list.2 - (let ((a (list 1 4 2 5 3))) - (stable-sort a #'< :key #'-)) - (5 4 3 2 1)) - -(deftest stable-sort-list.3 - (let ((a (list 1 4 2 5 3))) - (stable-sort a #'(lambda (x y) nil)) - (stable-sort a #'<)) - (1 2 3 4 5)) - -(deftest stable-sort-list.4 - (let ((a (copy-seq '((1 a) (2 a) (1 b) (2 b) (1 c) (2 c))))) - (stable-sort a #'(lambda (x y) (< (car x) (car y))))) - ((1 a) (1 b) (1 c) (2 a) (2 b) (2 c))) - -(deftest stable-sort-list.5 - (let ((a (reverse (copy-seq '((1 a) (2 a) (1 b) (2 b) (1 c) (2 c)))))) - (stable-sort a #'(lambda (x y) (< (car x) (car y))))) - ((1 c) (1 b) (1 a) (2 c) (2 b) (2 a))) - -(deftest stable-sort-vector.1 - (let ((a (copy-seq #(1 4 2 5 3)))) - (stable-sort a #'<)) - #(1 2 3 4 5)) - -(deftest stable-sort-vector.2 - (let ((a (copy-seq #(1 4 2 5 3)))) - (stable-sort a #'< :key #'-)) - #(5 4 3 2 1)) - -(deftest stable-sort-vector.3 - (let ((a (copy-seq #(1 4 2 5 3)))) - (stable-sort a #'(lambda (x y) nil)) - (stable-sort a #'<)) - #(1 2 3 4 5)) - -(deftest stable-sort-vector.4 - (let ((a (make-array 10 :initial-contents '(10 40 20 50 30 15 45 25 55 35) - :fill-pointer 5))) - (stable-sort a #'<)) - #(10 20 30 40 50)) - -;;; FIXME Add random test similar to sort.5 here - -(deftest stable-sort-vector.6 - (do-special-integer-vectors - (v #(1 4 7 3 2 6 5) nil) - (let ((sv (stable-sort v #'<))) - (assert (equalp sv #(1 2 3 4 5 6 7))))) - nil) - -(deftest stable-sort-vector.7 - (do-special-integer-vectors - (v #(0 1 1 0 1 1 0 1 0) nil) - (let ((sv (stable-sort v #'<))) - (assert (equalp sv #(0 0 0 0 1 1 1 1 1))))) - nil) - -(deftest stable-sort-vector.8 - (do-special-integer-vectors - (v #(0 -1 -1 0 -1 -1 0 -1 0) nil) - (let ((sv (stable-sort v #'>))) - (assert (equalp sv #(0 0 0 0 -1 -1 -1 -1 -1))))) - nil) - -(deftest stable-sort-vector.9 - (let* ((ivals '(1 4 7 3 2 6 5)) - (sivals '(1 2 3 4 5 6 7)) - (len (length ivals))) - (loop for etype in '(short-float single-float double-float long-float rational) - for vals = (loop for i in ivals collect (coerce i etype)) - for svals = (loop for i in sivals collect (coerce i etype)) - for vec = (make-array len :element-type etype :initial-contents vals) - for svec = (stable-sort vec #'<) - unless (and (eql (length svec) len) - (every #'eql svals svec)) - collect (list etype vals svec))) - nil) - -(deftest stable-sort-vector.10 - (let* ((ivals '(1 4 7 3 2 6 5)) - (sivals '(1 2 3 4 5 6 7)) - (len (length ivals))) - (loop for cetype in '(short-float single-float double-float long-float rational) - for etype = `(complex ,cetype) - for vals = (loop for i in ivals collect (complex (coerce i cetype) - (coerce (- i) cetype))) - for svals = (loop for i in sivals collect (complex (coerce i cetype) - (coerce (- i) cetype))) - for vec = (make-array len :element-type etype :initial-contents vals) - for svec = (stable-sort vec #'(lambda (x y) (< (abs x) (abs y)))) - unless (and (eql (length svec) len) - (every #'eql svals svec)) - collect (list etype vals svec))) - nil) - -;;; Bit vectors - -(deftest stable-sort-bit-vector.1 - (let ((a (copy-seq #*10011101))) - (stable-sort a #'<)) - #*00011111) - -(deftest stable-sort-bit-vector.2 - (let ((a (copy-seq #*10011101))) - (values (stable-sort a #'< :key #'-) a)) - #*11111000 - #*11111000) - -(deftest stable-sort-bit-vector.3 - (let ((a (make-array 10 :initial-contents '(1 0 0 1 1 1 1 0 1 1) - :element-type 'bit - :fill-pointer 5))) - (stable-sort a #'<)) - #*00111) - -(deftest stable-sort-string.1 - (let ((a (copy-seq "10011101"))) - (values (stable-sort a #'char<) a)) - "00011111" - "00011111") - -(deftest stable-sort-string.2 - (let ((a (copy-seq "10011101"))) - (values (stable-sort a #'char< - :key #'(lambda (c) (if (eql c #\0) #\1 #\0))) a)) - "11111000" - "11111000") - -(deftest stable-sort-string.3 - (let ((a (make-array 10 :initial-contents "1001111011" - :element-type 'character - :fill-pointer 5))) - (stable-sort a #'char<)) - "00111") - -(deftest stable-sort-string.4 - (do-special-strings - (s "aebdc" nil) - (let ((s2 (stable-sort s #'char<))) - (assert (eq s s2)) - (assert (string= s2 "abcde")))) - nil) - -;;; Order of evaluation tests - -(deftest stable-sort.order.1 - (let ((i 0) x y) - (values - (stable-sort (progn (setf x (incf i)) (list 1 7 3 2)) - (progn (setf y (incf i)) #'<)) - i x y)) - (1 2 3 7) 2 1 2) - -(deftest stable-sort.order.2 - (let ((i 0) x y z) - (values - (stable-sort (progn (setf x (incf i)) (list 1 7 3 2)) - (progn (setf y (incf i)) #'<) - :key (progn (setf z (incf i)) #'-)) - i x y z)) - (7 3 2 1) 3 1 2 3) - - -;;; Error cases - -(deftest stable-sort.error.1 - (signals-error (stable-sort) program-error) - t) - -(deftest stable-sort.error.2 - (signals-error (stable-sort nil) program-error) - t) - -(deftest stable-sort.error.3 - (signals-error (stable-sort nil #'< :key) program-error) - t) - -(deftest stable-sort.error.4 - (signals-error (stable-sort nil #'< 'bad t) program-error) - t) - -(deftest stable-sort.error.5 - (signals-error (stable-sort nil #'< 'bad t :allow-other-keys nil) program-error) - t) - -(deftest stable-sort.error.6 - (signals-error (stable-sort nil #'< 1 2) program-error) - t) - -(deftest stable-sort.error.7 - (signals-error (stable-sort (list 1 2 3 4) #'identity) program-error) - t) - -(deftest stable-sort.error.8 - (signals-error (stable-sort (list 1 2 3 4) #'< :key #'cons) program-error) - t) - -(deftest stable-sort.error.9 - (signals-error (stable-sort (list 1 2 3 4) #'< :key #'car) type-error) - t) - -(deftest stable-sort.error.10 - (signals-error (stable-sort (list 1 2 3 4) #'elt) type-error) - t) - -(deftest stable-sort.error.11 - (check-type-error #'(lambda (x) (stable-sort x #'<)) #'sequencep) - nil) diff --git a/t/ansi-test/sequences/subseq.lsp b/t/ansi-test/sequences/subseq.lsp deleted file mode 100644 index 147f4e1..0000000 --- a/t/ansi-test/sequences/subseq.lsp +++ /dev/null @@ -1,305 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Oct 12 19:41:14 2002 -;;;; Contains: Tests on SUBSEQ - -(in-package :cl-test) - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; subseq, on lists - -(deftest subseq-list.1 - (subseq '(a b c d e) 0 0) - nil) - -(deftest subseq-list.2 - (subseq '(a b c) 0) - (a b c)) - -(deftest subseq-list.3 - (subseq '(a b c) 1) - (b c)) - - -(deftest subseq-list.4 - (subseq-list.4-body) - t) - -(deftest subseq-list.5 - (subseq-list.5-body) - t) - -(deftest subseq-list.6 ;; check that no structure is shared - (subseq-list.6-body) - t) - -(deftest subseq-list.7 - (let ((x (loop for i from 0 to 9 collect i))) - (setf (subseq x 0 3) (list 'a 'b 'c)) - x) - (a b c 3 4 5 6 7 8 9)) - -(deftest subseq-list.8 - (let* ((x '(a b c d e)) - (y (copy-seq x))) - (setf (subseq y 0) '(f g h)) - (list x y)) - ((a b c d e) (f g h d e))) - -(deftest subseq-list.9 - (let* ((x '(a b c d e)) - (y (copy-seq x))) - (setf (subseq y 1 3) '(1 2 3 4 5)) - (list x y)) - ((a b c d e) (a 1 2 d e))) - -(deftest subseq-list.10 - (let* ((x '(a b c d e)) - (y (copy-seq x))) - (setf (subseq y 5) '(1 2 3 4 5)) - (list x y)) - ((a b c d e) (a b c d e))) - -(deftest subseq-list.11 - (let* ((x '(a b c d e)) - (y (copy-seq x))) - (setf (subseq y 2 5) '(1)) - (list x y)) - ((a b c d e) (a b 1 d e))) - -(deftest subseq-list.12 - (let* ((x '(a b c d e)) - (y (copy-seq x))) - (setf (subseq y 0 0) '(1 2)) - (list x y)) - ((a b c d e) (a b c d e))) - -;; subseq on vectors - - -(deftest subseq-vector.1 - (subseq-vector.1-body) - t) - - -(deftest subseq-vector.2 - (subseq-vector.2-body) - t) - - -(deftest subseq-vector.3 - (subseq-vector.3-body) - t) - -(deftest subseq-vector.4 - (subseq-vector.4-body) - t) - -(deftest subseq-vector.5 - (subseq-vector.5-body) - t) - -(deftest subseq-vector.6 - (subseq-vector.6-body) - t) - -(deftest subseq-vector.7 - (let* ((x (make-array '(10) :initial-contents '(a b c d e f g h i j))) - (y (subseq x 2 8))) - (equal-array y (make-array '(6) :initial-contents '(c d e f g h)))) - t) - -(deftest subseq-vector.8 - (let* ((x (make-array '(200) :initial-element 107 - :element-type 'fixnum)) - (y (subseq x 17 95))) - (and (eqlt (length y) (- 95 17)) - (equal-array y - (make-array (list (- 95 17)) - :initial-element 107 - :element-type 'fixnum)))) - t) - -(deftest subseq-vector.9 - (let* ((x (make-array '(1000) :initial-element 17.6e-1 - :element-type 'single-float)) - (lo 164) - (hi 873) - (y (subseq x lo hi))) - (and (eqlt (length y) (- hi lo)) - (equal-array y - (make-array (list (- hi lo)) - :initial-element 17.6e-1 - :element-type 'single-float)))) - t) - -(deftest subseq-vector.10 - (let* ((x (make-array '(2000) :initial-element 3.1415927d4 - :element-type 'double-float)) - (lo 731) - (hi 1942) - (y (subseq x lo hi))) - (and (eqlt (length y) (- hi lo)) - (equal-array y - (make-array (list (- hi lo)) - :initial-element 3.1415927d4 - :element-type 'double-float)))) - t) - -;;; subseq on strings - -(deftest subseq-string.1 - (subseq-string.1-body) - t) - -(deftest subseq-string.2 - (subseq-string.2-body) - t) - -(deftest subseq-string.3 - (subseq-string.3-body) - t) - -;;; Specialized string tests - -(deftest subseq.specialized-string.1 - (let* ((s0 "abcde") - (len (length s0))) - (do-special-strings - (s "abcde" nil) - (loop for i from 0 below len - for s1 = (subseq s i) - do (assert (typep s1 'simple-array)) - do (assert (string= (subseq s i) (subseq s0 i))) - do (loop for j from i to len - for s2 = (subseq s i j) - do (assert (typep s2 'simple-array)) - (assert (string= s2 (subseq s0 i j))))))) - nil) - -;;; Other specialized vectors - -(deftest subseq.specialized-vector.1 - (let* ((v0 #(1 0 1 1 0 1 1 0)) - (len (length v0))) - (do-special-integer-vectors - (v (copy-seq v0) nil) - (loop for i from 0 below len - for v1 = (subseq v i) - do (assert (typep v1 'simple-array)) - do (assert (equalp (subseq v i) (subseq v0 i))) - do (loop for j from i to len - for v2 = (subseq v i j) - do (assert (typep v2 'simple-array)) - (assert (equalp v2 (subseq v0 i j))))))) - nil) - -(deftest subseq.specialized-vector.2 - (loop for type in '(short-float single-float long-float double-float) - for len = 10 - for vals = (loop for i from 1 to len collect (coerce i type)) - for vec = (make-array len :element-type type :initial-contents vals) - for result = (subseq vec 1 9) - unless (and (= (length result) 8) - (equal (array-element-type vec) (array-element-type result)) - (equalp result (apply #'vector (subseq vals 1 9)))) - collect (list type vals result)) - nil) - -(deftest subseq.specialized-vector.3 - (loop for etype in '(short-float single-float long-float double-float - integer rational) - for type = `(complex ,etype) - for len = 10 - for vals = (loop for i from 1 to len collect (complex (coerce i etype) - (coerce (- i) etype))) - for vec = (make-array len :element-type type :initial-contents vals) - for result = (subseq vec 1 9) - unless (and (= (length result) 8) - (equal (array-element-type vec) (array-element-type result)) - (equalp result (apply #'vector (subseq vals 1 9)))) - collect (list type vals result)) - nil) - -;;; Tests on bit vectors - -(deftest subseq-bit-vector.1 - (subseq-bit-vector.1-body) - t) - -(deftest subseq-bit-vector.2 - (subseq-bit-vector.2-body) - t) - -(deftest subseq-bit-vector.3 - (subseq-bit-vector.3-body) - t) - -;;; Order of evaluation - -(deftest subseq.order.1 - (let ((i 0) a b c) - (values - (subseq - (progn (setf a (incf i)) "abcdefgh") - (progn (setf b (incf i)) 1) - (progn (setf c (incf i)) 4)) - i a b c)) - "bcd" 3 1 2 3) - -(deftest subseq.order.2 - (let ((i 0) a b) - (values - (subseq - (progn (setf a (incf i)) "abcdefgh") - (progn (setf b (incf i)) 1)) - i a b)) - "bcdefgh" 2 1 2) - -(deftest subseq.order.3 - (let ((i 0) a b c d - (s (copy-seq "abcdefgh"))) - (values - (setf (subseq - (progn (setf a (incf i)) s) - (progn (setf b (incf i)) 1) - (progn (setf c (incf i)) 4)) - (progn (setf d (incf i)) "xyz")) - s i a b c d)) - "xyz" "axyzefgh" 4 1 2 3 4) - -(deftest subseq.order.4 - (let ((i 0) a b c - (s (copy-seq "abcd"))) - (values - (setf (subseq - (progn (setf a (incf i)) s) - (progn (setf b (incf i)) 1)) - (progn (setf c (incf i)) "xyz")) - s i a b c)) - "xyz" "axyz" 3 1 2 3) - -;;; Constant folding - -(def-fold-test subseq.fold.1 (subseq '(1 2 3) 0)) -(def-fold-test subseq.fold.2 (subseq #(1 2 3) 0)) -(def-fold-test subseq.fold.3 (subseq #*011101 0)) -(def-fold-test subseq.fold.4 (subseq "abcdef" 0)) - -;;; Error cases - -(deftest subseq.error.1 - (signals-error (subseq) program-error) - t) - -(deftest subseq.error.2 - (signals-error (subseq nil) program-error) - t) - -(deftest subseq.error.3 - (signals-error (subseq nil 0 0 0) program-error) - t) - - diff --git a/t/ansi-test/sequences/substitute-if-not.lsp b/t/ansi-test/sequences/substitute-if-not.lsp deleted file mode 100644 index 5b7341a..0000000 --- a/t/ansi-test/sequences/substitute-if-not.lsp +++ /dev/null @@ -1,883 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Aug 31 18:17:09 2002 -;;;; Contains: Tests for SUBSTITUTE-IF-NOT - -(in-package :cl-test) - -(deftest substitute-if-not-list.1 - (let ((x '())) (values (substitute-if-not 'b #'null x) x)) - nil nil) - -(deftest substitute-if-not-list.2 - (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eql-p 'a) x) x)) - (b b b c) - (a b a c)) - -(deftest substitute-if-not-list.3 - (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eql-p 'a) x :count nil) x)) - (b b b c) - (a b a c)) - -(deftest substitute-if-not-list.4 - (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eql-p 'a) x :count 2) x)) - (b b b c) - (a b a c)) - -(deftest substitute-if-not-list.5 - (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eql-p 'a) x :count 1) x)) - (b b a c) - (a b a c)) - -(deftest substitute-if-not-list.6 - (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eql-p 'a) x :count 0) x)) - (a b a c) - (a b a c)) - -(deftest substitute-if-not-list.7 - (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eql-p 'a) x :count -1) x)) - (a b a c) - (a b a c)) - -(deftest substitute-if-not-list.8 - (let ((x '())) (values (substitute-if-not 'b (is-not-eql-p 'a) x :from-end t) x)) - nil nil) - -(deftest substitute-if-not-list.9 - (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eql-p 'a) x :from-end t) x)) - (b b b c) - (a b a c)) - -(deftest substitute-if-not-list.10 - (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eql-p 'a) x :from-end t :count nil) x)) - (b b b c) - (a b a c)) - -(deftest substitute-if-not-list.11 - (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eql-p 'a) x :count 2 :from-end t) x)) - (b b b c) - (a b a c)) - -(deftest substitute-if-not-list.12 - (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eql-p 'a) x :count 1 :from-end t) x)) - (a b b c) - (a b a c)) - -(deftest substitute-if-not-list.13 - (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eql-p 'a) x :count 0 :from-end t) x)) - (a b a c) - (a b a c)) - -(deftest substitute-if-not-list.14 - (let ((x '(a b a c))) (values (substitute-if-not 'b (is-not-eql-p 'a) x :count -1 :from-end t) x)) - (a b a c) - (a b a c)) - -(deftest substitute-if-not-list.15 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute-if-not 'x (is-not-eql-p 'a) x :start i :end j))) - (and (equal orig x) - (equal y (nconc (make-list i :initial-element 'a) - (make-list (- j i) :initial-element 'x) - (make-list (- 10 j) :initial-element 'a))))))) - t) - -(deftest substitute-if-not-list.16 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute-if-not 'x (is-not-eql-p 'a) x :start i :end j :from-end t))) - (and (equal orig x) - (equal y (nconc (make-list i :initial-element 'a) - (make-list (- j i) :initial-element 'x) - (make-list (- 10 j) :initial-element 'a))))))) - t) - -(deftest substitute-if-not-list.17 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute-if-not 'x (is-not-eql-p 'a) x :start i :end j :count c))) - (and (equal orig x) - (equal y (nconc (make-list i :initial-element 'a) - (make-list c :initial-element 'x) - (make-list (- 10 (+ i c)) :initial-element 'a)))))))) - t) - -(deftest substitute-if-not-list.18 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute-if-not 'x (is-not-eql-p 'a) x :start i :end j :count c :from-end t))) - (and (equal orig x) - (equal y (nconc (make-list (- j c) :initial-element 'a) - (make-list c :initial-element 'x) - (make-list (- 10 j) :initial-element 'a)))))))) - t) - -;;; Tests on vectors - -(deftest substitute-if-not-vector.1 - (let ((x #())) (values (substitute-if-not 'b (is-not-eql-p 'a) x) x)) - #() #()) - -(deftest substitute-if-not-vector.2 - (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eql-p 'a) x) x)) - #(b b b c) - #(a b a c)) - -(deftest substitute-if-not-vector.3 - (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eql-p 'a) x :count nil) x)) - #(b b b c) - #(a b a c)) - -(deftest substitute-if-not-vector.4 - (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eql-p 'a) x :count 2) x)) - #(b b b c) - #(a b a c)) - -(deftest substitute-if-not-vector.5 - (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eql-p 'a) x :count 1) x)) - #(b b a c) - #(a b a c)) - -(deftest substitute-if-not-vector.6 - (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eql-p 'a) x :count 0) x)) - #(a b a c) - #(a b a c)) - -(deftest substitute-if-not-vector.7 - (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eql-p 'a) x :count -1) x)) - #(a b a c) - #(a b a c)) - -(deftest substitute-if-not-vector.8 - (let ((x #())) (values (substitute-if-not 'b (is-not-eql-p 'a) x :from-end t) x)) - #() #()) - -(deftest substitute-if-not-vector.9 - (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eql-p 'a) x :from-end t) x)) - #(b b b c) - #(a b a c)) - -(deftest substitute-if-not-vector.10 - (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eql-p 'a) x :from-end t :count nil) x)) - #(b b b c) - #(a b a c)) - -(deftest substitute-if-not-vector.11 - (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eql-p 'a) x :count 2 :from-end t) x)) - #(b b b c) - #(a b a c)) - -(deftest substitute-if-not-vector.12 - (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eql-p 'a) x :count 1 :from-end t) x)) - #(a b b c) - #(a b a c)) - -(deftest substitute-if-not-vector.13 - (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eql-p 'a) x :count 0 :from-end t) x)) - #(a b a c) - #(a b a c)) - -(deftest substitute-if-not-vector.14 - (let ((x #(a b a c))) (values (substitute-if-not 'b (is-not-eql-p 'a) x :count -1 :from-end t) x)) - #(a b a c) - #(a b a c)) - -(deftest substitute-if-not-vector.15 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute-if-not 'x (is-not-eql-p 'a) x :start i :end j))) - (and (equalp orig x) - (equalp y (concatenate 'simple-vector - (make-array i :initial-element 'a) - (make-array (- j i) :initial-element 'x) - (make-array (- 10 j) :initial-element 'a))))))) - t) - -(deftest substitute-if-not-vector.16 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute-if-not 'x (is-not-eql-p 'a) x :start i :end j :from-end t))) - (and (equalp orig x) - (equalp y (concatenate 'simple-vector - (make-array i :initial-element 'a) - (make-array (- j i) :initial-element 'x) - (make-array (- 10 j) :initial-element 'a))))))) - t) - -(deftest substitute-if-not-vector.17 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute-if-not 'x (is-not-eql-p 'a) x :start i :end j :count c))) - (and (equalp orig x) - (equalp y (concatenate 'simple-vector - (make-array i :initial-element 'a) - (make-array c :initial-element 'x) - (make-array (- 10 (+ i c)) :initial-element 'a)))))))) - t) - -(deftest substitute-if-not-vector.18 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute-if-not 'x (is-not-eql-p 'a) x :start i :end j :count c :from-end t))) - (and (equalp orig x) - (equalp y (concatenate 'simple-vector - (make-array (- j c) :initial-element 'a) - (make-array c :initial-element 'x) - (make-array (- 10 j) :initial-element 'a)))))))) - t) - -(deftest substitute-if-not-vector.28 - (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (substitute-if-not 'z (is-not-eql-p 'a) x))) - result) - #(z b z c b)) - -(deftest substitute-if-not-vector.29 - (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (substitute-if-not 'z (is-not-eql-p 'a) x :from-end t))) - result) - #(z b z c b)) - -(deftest substitute-if-not-vector.30 - (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (substitute-if-not 'z (is-not-eql-p 'a) x :count 1))) - result) - #(z b a c b)) - -(deftest substitute-if-not-vector.31 - (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (substitute-if-not 'z (is-not-eql-p 'a) x - :from-end t :count 1))) - result) - #(a b z c b)) - -(deftest substitute-if-not-vector.32 - (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) - (v2 (make-array '(8) :displaced-to v1 - :displaced-index-offset 3))) - (values - (substitute-if-not 'x (is-not-eql-p 'c) v2 :count 1) - v1)) - #(d a b x d a b c) - #(a b c d a b c d a b c d a b c d)) - -(deftest substitute-if-not-vector.33 - (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) - (v2 (make-array '(8) :displaced-to v1 - :displaced-index-offset 3))) - (values - (substitute-if-not 'x (is-not-eql-p 'c) v2 :count 1 :from-end t) - v1)) - #(d a b c d a b x) - #(a b c d a b c d a b c d a b c d)) - - - -;;; Tests on strings - -(deftest substitute-if-not-string.1 - (let ((x "")) (values (substitute-if-not #\b (is-not-eql-p #\a) x) x)) - "" "") - -(deftest substitute-if-not-string.2 - (let ((x "abac")) (values (substitute-if-not #\b (is-not-eql-p #\a) x) x)) - "bbbc" - "abac") - -(deftest substitute-if-not-string.3 - (let ((x "abac")) (values (substitute-if-not #\b (is-not-eql-p #\a) x :count nil) x)) - "bbbc" - "abac") - -(deftest substitute-if-not-string.4 - (let ((x "abac")) (values (substitute-if-not #\b (is-not-eql-p #\a) x :count 2) x)) - "bbbc" - "abac") - -(deftest substitute-if-not-string.5 - (let ((x "abac")) (values (substitute-if-not #\b (is-not-eql-p #\a) x :count 1) x)) - "bbac" - "abac") - -(deftest substitute-if-not-string.6 - (let ((x "abac")) (values (substitute-if-not #\b (is-not-eql-p #\a) x :count 0) x)) - "abac" - "abac") - -(deftest substitute-if-not-string.7 - (let ((x "abac")) (values (substitute-if-not #\b (is-not-eql-p #\a) x :count -1) x)) - "abac" - "abac") - -(deftest substitute-if-not-string.8 - (let ((x "")) (values (substitute-if-not #\b (is-not-eql-p #\a) x :from-end t) x)) - "" "") - -(deftest substitute-if-not-string.9 - (let ((x "abac")) (values (substitute-if-not #\b (is-not-eql-p #\a) x :from-end t) x)) - "bbbc" - "abac") - -(deftest substitute-if-not-string.10 - (let ((x "abac")) (values (substitute-if-not #\b (is-not-eql-p #\a) x :from-end t :count nil) x)) - "bbbc" - "abac") - -(deftest substitute-if-not-string.11 - (let ((x "abac")) (values (substitute-if-not #\b (is-not-eql-p #\a) x :count 2 :from-end t) x)) - "bbbc" - "abac") - -(deftest substitute-if-not-string.12 - (let ((x "abac")) (values (substitute-if-not #\b (is-not-eql-p #\a) x :count 1 :from-end t) x)) - "abbc" - "abac") - -(deftest substitute-if-not-string.13 - (let ((x "abac")) (values (substitute-if-not #\b (is-not-eql-p #\a) x :count 0 :from-end t) x)) - "abac" - "abac") - -(deftest substitute-if-not-string.14 - (let ((x "abac")) (values (substitute-if-not #\b (is-not-eql-p #\a) x :count -1 :from-end t) x)) - "abac" - "abac") - -(deftest substitute-if-not-string.15 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (substitute-if-not #\x (is-not-eql-p #\a) x :start i :end j))) - (and (equalp orig x) - (equalp y (concatenate 'simple-string - (make-array i :initial-element #\a) - (make-array (- j i) :initial-element #\x) - (make-array (- 10 j) :initial-element #\a))))))) - t) - -(deftest substitute-if-not-string.16 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (substitute-if-not #\x (is-not-eql-p #\a) x :start i :end j :from-end t))) - (and (equalp orig x) - (equalp y (concatenate 'simple-string - (make-array i :initial-element #\a) - (make-array (- j i) :initial-element #\x) - (make-array (- 10 j) :initial-element #\a))))))) - t) - -(deftest substitute-if-not-string.17 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (substitute-if-not #\x (is-not-eql-p #\a) x :start i :end j :count c))) - (and (equalp orig x) - (equalp y (concatenate 'simple-string - (make-array i :initial-element #\a) - (make-array c :initial-element #\x) - (make-array (- 10 (+ i c)) :initial-element #\a)))))))) - t) - -(deftest substitute-if-not-string.18 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (substitute-if-not #\x (is-not-eql-p #\a) x :start i :end j :count c :from-end t))) - (and (equalp orig x) - (equalp y (concatenate 'simple-string - (make-array (- j c) :initial-element #\a) - (make-array c :initial-element #\x) - (make-array (- 10 j) :initial-element #\a)))))))) - t) - -(deftest substitute-if-not-string.28 - (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (substitute-if-not #\z (is-not-eql-p #\a) x))) - result) - "zbzcb") - -(deftest substitute-if-not-string.29 - (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (substitute-if-not #\z (is-not-eql-p #\a) x :from-end t))) - result) - "zbzcb") - -(deftest substitute-if-not-string.30 - (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (substitute-if-not #\z (is-not-eql-p #\a) x :count 1))) - result) - "zbacb") - -(deftest substitute-if-not-string.31 - (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (substitute-if-not #\z (is-not-eql-p #\a) x - :from-end t :count 1))) - result) - "abzcb") - - - -;;; Tests on bitstrings - -(deftest substitute-if-not-bitstring.1 - (let* ((orig #*) - (x (copy-seq orig)) - (result (substitute-if-not 0 (is-not-eql-p 1) x))) - (and (equalp orig x) - result)) - #*) - -(deftest substitute-if-not-bitstring.2 - (let* ((orig #*) - (x (copy-seq orig)) - (result (substitute-if-not 1 (complement #'zerop) x))) - (and (equalp orig x) - result)) - #*) - -(deftest substitute-if-not-bitstring.3 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if-not 0 (is-not-eql-p 1) x))) - (and (equalp orig x) - result)) - #*000000) - -(deftest substitute-if-not-bitstring.4 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if-not 1 (complement #'zerop) x))) - (and (equalp orig x) - result)) - #*111111) - -(deftest substitute-if-not-bitstring.5 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if-not 1 (complement #'zerop) x :start 1))) - (and (equalp orig x) - result)) - #*011111) - -(deftest substitute-if-not-bitstring.6 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if-not 0 (is-not-eql-p 1) x :start 2 :end nil))) - (and (equalp orig x) - result)) - #*010000) - -(deftest substitute-if-not-bitstring.7 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if-not 1 (complement #'zerop) x :end 4))) - (and (equalp orig x) - result)) - #*111101) - -(deftest substitute-if-not-bitstring.8 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if-not 0 (is-not-eql-p 1) x :end nil))) - (and (equalp orig x) - result)) - #*000000) - -(deftest substitute-if-not-bitstring.9 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if-not 0 (is-not-eql-p 1) x :end 3))) - (and (equalp orig x) - result)) - #*000101) - -(deftest substitute-if-not-bitstring.10 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if-not 0 (is-not-eql-p 1) x :start 2 :end 4))) - (and (equalp orig x) - result)) - #*010001) - -(deftest substitute-if-not-bitstring.11 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if-not 1 (complement #'zerop) x :start 2 :end 4))) - (and (equalp orig x) - result)) - #*011101) - -(deftest substitute-if-not-bitstring.12 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if-not 1 (complement #'zerop) x :count 1))) - (and (equalp orig x) - result)) - #*110101) - -(deftest substitute-if-not-bitstring.13 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if-not 1 (complement #'zerop) x :count 0))) - (and (equalp orig x) - result)) - #*010101) - -(deftest substitute-if-not-bitstring.14 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if-not 1 (complement #'zerop) x :count -1))) - (and (equalp orig x) - result)) - #*010101) - -(deftest substitute-if-not-bitstring.15 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if-not 1 (complement #'zerop) x :count 1 :from-end t))) - (and (equalp orig x) - result)) - #*010111) - -(deftest substitute-if-not-bitstring.16 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if-not 1 (complement #'zerop) x :count 0 :from-end t))) - (and (equalp orig x) - result)) - #*010101) - -(deftest substitute-if-not-bitstring.17 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if-not 1 (complement #'zerop) x :count -1 :from-end t))) - (and (equalp orig x) - result)) - #*010101) - -(deftest substitute-if-not-bitstring.18 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if-not 1 (complement #'zerop) x :count nil))) - (and (equalp orig x) - result)) - #*111111) - -(deftest substitute-if-not-bitstring.19 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if-not 1 (complement #'zerop) x :count nil :from-end t))) - (and (equalp orig x) - result)) - #*111111) - -(deftest substitute-if-not-bitstring.20 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #*0000000000) - (x (copy-seq orig)) - (y (substitute-if-not 1 (complement #'zerop) x :start i :end j :count c))) - (and (equalp orig x) - (equalp y (concatenate - 'simple-bit-vector - (make-list i :initial-element 0) - (make-list c :initial-element 1) - (make-list (- 10 (+ i c)) :initial-element 0)))))))) - t) - -(deftest substitute-if-not-bitstring.21 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #*1111111111) - (x (copy-seq orig)) - (y (substitute-if-not 0 (is-not-eql-p 1) x :start i :end j :count c :from-end t))) - (and (equalp orig x) - (equalp y (concatenate - 'simple-bit-vector - (make-list (- j c) :initial-element 1) - (make-list c :initial-element 0) - (make-list (- 10 j) :initial-element 1)))))))) - t) - -;;; More tests - -(deftest substitute-if-not-list.24 - (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (substitute-if-not '(a 10) (is-not-eql-p 'a) x :key #'car))) - (and (equal orig x) - result)) - ((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) - -(deftest substitute-if-not-list.25 - (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (substitute-if-not '(a 10) (is-not-eql-p 'a) x - :key #'car :start 1 :end 5))) - (and (equal orig x) - result)) - ((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) - -(deftest substitute-if-not-vector.24 - (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (substitute-if-not '(a 10) (is-not-eql-p 'a) x :key #'car))) - (and (equalp orig x) - result)) - #((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) - -(deftest substitute-if-not-vector.25 - (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (substitute-if-not '(a 10) (is-not-eql-p 'a) x :key #'car :start 1 :end 5))) - (and (equalp orig x) - result)) - #((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) - -(deftest substitute-if-not-string.24 - (let* ((orig "0102342015") - (x (copy-seq orig)) - (result (substitute-if-not #\a (is-not-eql-p #\1) x :key #'nextdigit))) - (and (equalp orig x) - result)) - "a1a2342a15") - -(deftest substitute-if-not-string.25 - (let* ((orig "0102342015") - (x (copy-seq orig)) - (result (substitute-if-not #\a (is-not-eql-p #\1) x :key #'nextdigit :start 1 :end 6))) - (and (equalp orig x) - result)) - "01a2342015") - -(deftest substitute-if-not-string.26 - (do-special-strings - (s "xyzabcxyzabc" nil) - (assert (string= (substitute-if-not #\! (is-not-eql-p #\a) s) "xyz!bcxyz!bc")) - (assert (string= (substitute-if-not #\! (is-not-eql-p #\a) s :count 1) "xyz!bcxyzabc")) - (assert (string= (substitute-if-not #\! (is-not-eql-p #\a) s :count 1 :from-end t) "xyzabcxyz!bc")) - (assert (string= s "xyzabcxyzabc"))) - nil) - -(deftest substitute-if-not-bitstring.26 - (let* ((orig #*00111001011010110) - (x (copy-seq orig)) - (result (substitute-if-not 1 (is-not-eql-p 1) x :key #'1+))) - (and (equalp orig x) - result)) - #*11111111111111111) - -(deftest substitute-if-not-bitstring.27 - (let* ((orig #*00111001011010110) - (x (copy-seq orig)) - (result (substitute-if-not 1 (is-not-eql-p 1) x :key #'1+ :start 1 :end 10))) - (and (equalp orig x) - result)) - #*01111111111010110) - -(deftest substitute-if-not-bit-vector.30 - (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (substitute-if-not 1 #'onep x))) - result) - #*11111) - -(deftest substitute-if-not-bit-vector.31 - (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (substitute-if-not 1 #'onep x :from-end t))) - result) - #*11111) - -(deftest substitute-if-not-bit-vector.32 - (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (substitute-if-not 1 #'onep x :count 1))) - result) - #*11011) - -(deftest substitute-if-not-bit-vector.33 - (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (substitute-if-not 1 #'onep x :from-end t :count 1))) - result) - #*01111) - -(deftest substitute-if-not.order.1 - (let ((i 0) a b c d e f g h) - (values - (substitute-if-not - (progn (setf a (incf i)) 'a) - (progn (setf b (incf i)) #'identity) - (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) - :count (progn (setf d (incf i)) 2) - :start (progn (setf e (incf i)) 0) - :end (progn (setf f (incf i)) 7) - :key (progn (setf g (incf i)) #'identity) - :from-end (setf h (incf i)) - ) - i a b c d e f g h)) - (nil 1 2 a 3 4 a 5) - 8 1 2 3 4 5 6 7 8) - -(deftest substitute-if-not.order.2 - (let ((i 0) a b c d e f g h) - (values - (substitute-if-not - (progn (setf a (incf i)) 'a) - (progn (setf b (incf i)) #'identity) - (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) - :from-end (setf h (incf i)) - :key (progn (setf g (incf i)) #'identity) - :end (progn (setf f (incf i)) 7) - :start (progn (setf e (incf i)) 0) - :count (progn (setf d (incf i)) 2) - ) - i a b c d e f g h)) - (nil 1 2 a 3 4 a 5) - 8 1 2 3 8 7 6 5 4) - -;;; Keyword tests - -(deftest substitute-if-not.allow-other-keys.1 - (substitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) - :allow-other-keys t :bad t) - (a a 0 a a 0 a)) - -(deftest substitute-if-not.allow-other-keys.2 - (substitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) - :bad t :allow-other-keys t) - (a a 0 a a 0 a)) - -(deftest substitute-if-not.allow-other-keys.3 - (substitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t - :allow-other-keys nil :bad t) - (a a 0 a a 0 a)) - -(deftest substitute-if-not.allow-other-keys.4 - (substitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :bad t - :allow-other-keys t :allow-other-keys nil) - (a a 0 a a 0 a)) - -(deftest substitute-if-not.allow-other-keys.5 - (substitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) - :allow-other-keys t :key #'1-) - (1 a a a 1 a a)) - -(deftest substitute-if-not.keywords.6 - (substitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) - :key #'1- :key #'identity) - (1 a a a 1 a a)) - -(deftest substitute-if-not.allow-other-keys.7 - (substitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t - :bad t :allow-other-keys nil) - (a a 0 a a 0 a)) - -(deftest substitute-if-not.allow-other-keys.8 - (substitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys nil) - (a a 0 a a 0 a)) - -;;; Constant folding tests - -(def-fold-test substitute-if-not.fold.1 - (substitute-if-not 'z 'identity '(a nil b))) -(def-fold-test substitute-if-not.fold.2 - (substitute-if-not 'z 'identity #(a nil b))) -(def-fold-test substitute-if-not.fold.3 - (substitute-if-not 0 'zerop #*100110)) -(def-fold-test substitute-if-not.fold.4 - (substitute-if-not #\0 #'digit-char-p "asdaw82213nn1239123dd")) - -;;; Error cases - -(deftest substitute-if-not.error.1 - (signals-error (substitute-if-not) program-error) - t) - -(deftest substitute-if-not.error.2 - (signals-error (substitute-if-not 'a) program-error) - t) - -(deftest substitute-if-not.error.3 - (signals-error (substitute-if-not 'a #'null) program-error) - t) - -(deftest substitute-if-not.error.4 - (signals-error (substitute-if-not 'a #'null nil 'bad t) program-error) - t) - -(deftest substitute-if-not.error.5 - (signals-error (substitute-if-not 'a #'null nil - 'bad t :allow-other-keys nil) program-error) - t) - -(deftest substitute-if-not.error.6 - (signals-error (substitute-if-not 'a #'null nil :key) program-error) - t) - -(deftest substitute-if-not.error.7 - (signals-error (substitute-if-not 'a #'null nil 1 2) program-error) - t) - -(deftest substitute-if-not.error.8 - (signals-error (substitute-if-not 'a #'cons (list 'a 'b 'c)) program-error) - t) - -(deftest substitute-if-not.error.9 - (signals-error (substitute-if-not 'a #'car (list 'a 'b 'c)) type-error) - t) - -(deftest substitute-if-not.error.10 - (signals-error (substitute-if-not 'a #'identity (list 'a 'b 'c) - :key #'car) - type-error) - t) - -(deftest substitute-if-not.error.11 - (signals-error (substitute-if-not 'a #'identity (list 'a 'b 'c) - :key #'cons) - program-error) - t) - -(deftest substitute-if-not.error.12 - (check-type-error #'(lambda (x) (substitute-if-not 'a #'not x)) #'sequencep) - nil) diff --git a/t/ansi-test/sequences/substitute-if.lsp b/t/ansi-test/sequences/substitute-if.lsp deleted file mode 100644 index d70f9d3..0000000 --- a/t/ansi-test/sequences/substitute-if.lsp +++ /dev/null @@ -1,904 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Aug 31 17:42:04 2002 -;;;; Contains: Tests for SUBSTITUTE-IF - -(in-package :cl-test) - -(deftest substitute-if-list.1 - (let ((x '())) (values (substitute-if 'b #'identity x) x)) - nil nil) - -(deftest substitute-if-list.2 - (let ((x '(a b a c))) (values (substitute-if 'b (is-eql-p 'a) x) x)) - (b b b c) - (a b a c)) - -(deftest substitute-if-list.3 - (let ((x '(a b a c))) (values (substitute-if 'b (is-eql-p 'a) x :count nil) x)) - (b b b c) - (a b a c)) - -(deftest substitute-if-list.4 - (let ((x '(a b a c))) (values (substitute-if 'b (is-eql-p 'a) x :count 2) x)) - (b b b c) - (a b a c)) - -(deftest substitute-if-list.5 - (let ((x '(a b a c))) (values (substitute-if 'b (is-eql-p 'a) x :count 1) x)) - (b b a c) - (a b a c)) - -(deftest substitute-if-list.6 - (let ((x '(a b a c))) (values (substitute-if 'b (is-eql-p 'a) x :count 0) x)) - (a b a c) - (a b a c)) - -(deftest substitute-if-list.7 - (let ((x '(a b a c))) (values (substitute-if 'b (is-eql-p 'a) x :count -1) x)) - (a b a c) - (a b a c)) - -(deftest substitute-if-list.8 - (let ((x '())) (values (substitute-if 'b (is-eql-p 'a) x :from-end t) x)) - nil nil) - -(deftest substitute-if-list.9 - (let ((x '(a b a c))) (values (substitute-if 'b (is-eql-p 'a) x :from-end t) x)) - (b b b c) - (a b a c)) - -(deftest substitute-if-list.10 - (let ((x '(a b a c))) (values (substitute-if 'b (is-eql-p 'a) x :from-end t :count nil) x)) - (b b b c) - (a b a c)) - -(deftest substitute-if-list.11 - (let ((x '(a b a c))) (values (substitute-if 'b (is-eql-p 'a) x :count 2 :from-end t) x)) - (b b b c) - (a b a c)) - -(deftest substitute-if-list.12 - (let ((x '(a b a c))) (values (substitute-if 'b (is-eql-p 'a) x :count 1 :from-end t) x)) - (a b b c) - (a b a c)) - -(deftest substitute-if-list.13 - (let ((x '(a b a c))) (values (substitute-if 'b (is-eql-p 'a) x :count 0 :from-end t) x)) - (a b a c) - (a b a c)) - -(deftest substitute-if-list.14 - (let ((x '(a b a c))) (values (substitute-if 'b (is-eql-p 'a) x :count -1 :from-end t) x)) - (a b a c) - (a b a c)) - -(deftest substitute-if-list.15 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute-if 'x (is-eql-p 'a) x :start i :end j))) - (and (equal orig x) - (equal y (nconc (make-list i :initial-element 'a) - (make-list (- j i) :initial-element 'x) - (make-list (- 10 j) :initial-element 'a))))))) - t) - -(deftest substitute-if-list.16 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute-if 'x (is-eql-p 'a) x :start i :end j :from-end t))) - (and (equal orig x) - (equal y (nconc (make-list i :initial-element 'a) - (make-list (- j i) :initial-element 'x) - (make-list (- 10 j) :initial-element 'a))))))) - t) - -(deftest substitute-if-list.17 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute-if 'x (is-eql-p 'a) x :start i :end j :count c))) - (and (equal orig x) - (equal y (nconc (make-list i :initial-element 'a) - (make-list c :initial-element 'x) - (make-list (- 10 (+ i c)) :initial-element 'a)))))))) - t) - -(deftest substitute-if-list.18 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute-if 'x (is-eql-p 'a) x :start i :end j :count c :from-end t))) - (and (equal orig x) - (equal y (nconc (make-list (- j c) :initial-element 'a) - (make-list c :initial-element 'x) - (make-list (- 10 j) :initial-element 'a)))))))) - t) - - -;;; Tests on vectors - -(deftest substitute-if-vector.1 - (let ((x #())) (values (substitute-if 'b (is-eql-p 'a) x) x)) - #() #()) - -(deftest substitute-if-vector.2 - (let ((x #(a b a c))) (values (substitute-if 'b (is-eql-p 'a) x) x)) - #(b b b c) - #(a b a c)) - -(deftest substitute-if-vector.3 - (let ((x #(a b a c))) (values (substitute-if 'b (is-eql-p 'a) x :count nil) x)) - #(b b b c) - #(a b a c)) - -(deftest substitute-if-vector.4 - (let ((x #(a b a c))) (values (substitute-if 'b (is-eql-p 'a) x :count 2) x)) - #(b b b c) - #(a b a c)) - -(deftest substitute-if-vector.5 - (let ((x #(a b a c))) (values (substitute-if 'b (is-eql-p 'a) x :count 1) x)) - #(b b a c) - #(a b a c)) - -(deftest substitute-if-vector.6 - (let ((x #(a b a c))) (values (substitute-if 'b (is-eql-p 'a) x :count 0) x)) - #(a b a c) - #(a b a c)) - -(deftest substitute-if-vector.7 - (let ((x #(a b a c))) (values (substitute-if 'b (is-eql-p 'a) x :count -1) x)) - #(a b a c) - #(a b a c)) - -(deftest substitute-if-vector.8 - (let ((x #())) (values (substitute-if 'b (is-eql-p 'a) x :from-end t) x)) - #() #()) - -(deftest substitute-if-vector.9 - (let ((x #(a b a c))) (values (substitute-if 'b (is-eql-p 'a) x :from-end t) x)) - #(b b b c) - #(a b a c)) - -(deftest substitute-if-vector.10 - (let ((x #(a b a c))) (values (substitute-if 'b (is-eql-p 'a) x :from-end t :count nil) x)) - #(b b b c) - #(a b a c)) - -(deftest substitute-if-vector.11 - (let ((x #(a b a c))) (values (substitute-if 'b (is-eql-p 'a) x :count 2 :from-end t) x)) - #(b b b c) - #(a b a c)) - -(deftest substitute-if-vector.12 - (let ((x #(a b a c))) - (values (substitute-if 'b (is-eql-p 'a) x :count 1 :from-end t) x)) - #(a b b c) - #(a b a c)) - -(deftest substitute-if-vector.13 - (let ((x #(a b a c))) - (values (substitute-if 'b (is-eql-p 'a) x :count 0 :from-end t) x)) - #(a b a c) - #(a b a c)) - -(deftest substitute-if-vector.14 - (let ((x #(a b a c))) - (values (substitute-if 'b (is-eql-p 'a) x :count -1 :from-end t) x)) - #(a b a c) - #(a b a c)) - -(deftest substitute-if-vector.15 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute-if 'x (is-eql-p 'a) x :start i :end j))) - (and (equalp orig x) - (equalp y - (concatenate - 'simple-vector - (make-array i :initial-element 'a) - (make-array (- j i) :initial-element 'x) - (make-array (- 10 j) :initial-element 'a))))))) - t) - -(deftest substitute-if-vector.16 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute-if 'x (is-eql-p 'a) x :start i :end j :from-end t))) - (and (equalp orig x) - (equalp y - (concatenate - 'simple-vector - (make-array i :initial-element 'a) - (make-array (- j i) :initial-element 'x) - (make-array (- 10 j) :initial-element 'a))))))) - t) - -(deftest substitute-if-vector.17 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute-if 'x (is-eql-p 'a) x - :start i :end j :count c))) - (and (equalp orig x) - (equalp - y (concatenate - 'simple-vector - (make-array i :initial-element 'a) - (make-array c :initial-element 'x) - (make-array (- 10 (+ i c)) - :initial-element 'a)))))))) - t) - -(deftest substitute-if-vector.18 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute-if 'x (is-eql-p 'a) x - :start i :end j :count c - :from-end t))) - (and (equalp orig x) - (equalp - y - (concatenate - 'simple-vector - (make-array (- j c) :initial-element 'a) - (make-array c :initial-element 'x) - (make-array (- 10 j) :initial-element 'a)))))))) - t) - -(deftest substitute-if-vector.28 - (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (substitute-if 'z (is-eql-p 'a) x))) - result) - #(z b z c b)) - -(deftest substitute-if-vector.29 - (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (substitute-if 'z (is-eql-p 'a) x :from-end t))) - result) - #(z b z c b)) - -(deftest substitute-if-vector.30 - (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (substitute-if 'z (is-eql-p 'a) x :count 1))) - result) - #(z b a c b)) - -(deftest substitute-if-vector.31 - (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (substitute-if 'z (is-eql-p 'a) x :from-end t :count 1))) - result) - #(a b z c b)) - -(deftest substitute-if-vector.32 - (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) - (v2 (make-array '(8) :displaced-to v1 - :displaced-index-offset 3))) - (values - (substitute-if 'x (is-eql-p 'c) v2 :count 1) - v1)) - #(d a b x d a b c) - #(a b c d a b c d a b c d a b c d)) - -(deftest substitute-if-vector.33 - (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) - (v2 (make-array '(8) :displaced-to v1 - :displaced-index-offset 3))) - (values - (substitute-if 'x (is-eql-p 'c) v2 :count 1 :from-end t) - v1)) - #(d a b c d a b x) - #(a b c d a b c d a b c d a b c d)) - -;;; Tests on strings - -(deftest substitute-if-string.1 - (let ((x "")) (values (substitute-if #\b (is-eql-p #\a) x) x)) - "" "") - -(deftest substitute-if-string.2 - (let ((x "abac")) (values (substitute-if #\b (is-eql-p #\a) x) x)) - "bbbc" - "abac") - -(deftest substitute-if-string.3 - (let ((x "abac")) (values (substitute-if #\b (is-eql-p #\a) x :count nil) x)) - "bbbc" - "abac") - -(deftest substitute-if-string.4 - (let ((x "abac")) (values (substitute-if #\b (is-eql-p #\a) x :count 2) x)) - "bbbc" - "abac") - -(deftest substitute-if-string.5 - (let ((x "abac")) (values (substitute-if #\b (is-eql-p #\a) x :count 1) x)) - "bbac" - "abac") - -(deftest substitute-if-string.6 - (let ((x "abac")) (values (substitute-if #\b (is-eql-p #\a) x :count 0) x)) - "abac" - "abac") - -(deftest substitute-if-string.7 - (let ((x "abac")) (values (substitute-if #\b (is-eql-p #\a) x :count -1) x)) - "abac" - "abac") - -(deftest substitute-if-string.8 - (let ((x "")) (values (substitute-if #\b (is-eql-p #\a) x :from-end t) x)) - "" "") - -(deftest substitute-if-string.9 - (let ((x "abac")) (values (substitute-if #\b (is-eql-p #\a) x :from-end t) x)) - "bbbc" - "abac") - -(deftest substitute-if-string.10 - (let ((x "abac")) (values (substitute-if #\b (is-eql-p #\a) x :from-end t :count nil) x)) - "bbbc" - "abac") - -(deftest substitute-if-string.11 - (let ((x "abac")) (values (substitute-if #\b (is-eql-p #\a) x :count 2 :from-end t) x)) - "bbbc" - "abac") - -(deftest substitute-if-string.12 - (let ((x "abac")) (values (substitute-if #\b (is-eql-p #\a) x :count 1 :from-end t) x)) - "abbc" - "abac") - -(deftest substitute-if-string.13 - (let ((x "abac")) (values (substitute-if #\b (is-eql-p #\a) x :count 0 :from-end t) x)) - "abac" - "abac") - -(deftest substitute-if-string.14 - (let ((x "abac")) (values (substitute-if #\b (is-eql-p #\a) x :count -1 :from-end t) x)) - "abac" - "abac") - -(deftest substitute-if-string.15 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (substitute-if #\x (is-eql-p #\a) x :start i :end j))) - (and (equalp orig x) - (equalp y (concatenate 'simple-string - (make-array i :initial-element #\a) - (make-array (- j i) :initial-element #\x) - (make-array (- 10 j) :initial-element #\a))))))) - t) - -(deftest substitute-if-string.16 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (substitute-if #\x (is-eql-p #\a) x - :start i :end j :from-end t))) - (and (equalp orig x) - (equalp y - (concatenate - 'simple-string - (make-array i :initial-element #\a) - (make-array (- j i) :initial-element #\x) - (make-array (- 10 j) :initial-element #\a))))))) - t) - -(deftest substitute-if-string.17 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (substitute-if #\x (is-eql-p #\a) x - :start i :end j :count c))) - (and (equalp orig x) - (equalp y - (concatenate - 'simple-string - (make-array i :initial-element #\a) - (make-array c :initial-element #\x) - (make-array (- 10 (+ i c)) - :initial-element #\a)))))))) - t) - -(deftest substitute-if-string.18 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (substitute-if #\x (is-eql-p #\a) x - :start i :end j :count c - :from-end t))) - (and (equalp orig x) - (equalp y (concatenate - 'simple-string - (make-array (- j c) :initial-element #\a) - (make-array c :initial-element #\x) - (make-array (- 10 j) - :initial-element #\a)))))))) - t) - - -(deftest substitute-if-string.28 - (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (substitute-if #\z (is-eql-p #\a) x))) - result) - "zbzcb") - -(deftest substitute-if-string.29 - (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (substitute-if #\z (is-eql-p #\a) x :from-end t))) - result) - "zbzcb") - -(deftest substitute-if-string.30 - (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (substitute-if #\z (is-eql-p #\a) x :count 1))) - result) - "zbacb") - -(deftest substitute-if-string.31 - (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (substitute-if #\z (is-eql-p #\a) x :from-end t :count 1))) - result) - "abzcb") - -;;; Tests on bit-vectors - -(deftest substitute-if-bit-vector.1 - (let* ((orig #*) - (x (copy-seq orig)) - (result (substitute-if 0 (is-eql-p 1) x))) - (and (equalp orig x) - result)) - #*) - -(deftest substitute-if-bit-vector.2 - (let* ((orig #*) - (x (copy-seq orig)) - (result (substitute-if 1 'zerop x))) - (and (equalp orig x) - result)) - #*) - -(deftest substitute-if-bit-vector.3 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if 0 (is-eql-p 1) x))) - (and (equalp orig x) - result)) - #*000000) - -(deftest substitute-if-bit-vector.4 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if 1 #'zerop x))) - (and (equalp orig x) - result)) - #*111111) - -(deftest substitute-if-bit-vector.5 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if 1 #'zerop x :start 1))) - (and (equalp orig x) - result)) - #*011111) - -(deftest substitute-if-bit-vector.6 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if 0 (is-eql-p 1) x :start 2 :end nil))) - (and (equalp orig x) - result)) - #*010000) - -(deftest substitute-if-bit-vector.7 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if 1 #'zerop x :end 4))) - (and (equalp orig x) - result)) - #*111101) - -(deftest substitute-if-bit-vector.8 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if 0 (is-eql-p 1) x :end nil))) - (and (equalp orig x) - result)) - #*000000) - -(deftest substitute-if-bit-vector.9 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if 0 (is-eql-p 1) x :end 3))) - (and (equalp orig x) - result)) - #*000101) - -(deftest substitute-if-bit-vector.10 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if 0 (is-eql-p 1) x :start 2 :end 4))) - (and (equalp orig x) - result)) - #*010001) - -(deftest substitute-if-bit-vector.11 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if 1 #'zerop x :start 2 :end 4))) - (and (equalp orig x) - result)) - #*011101) - -(deftest substitute-if-bit-vector.12 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if 1 #'zerop x :count 1))) - (and (equalp orig x) - result)) - #*110101) - -(deftest substitute-if-bit-vector.13 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if 1 #'zerop x :count 0))) - (and (equalp orig x) - result)) - #*010101) - -(deftest substitute-if-bit-vector.14 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if 1 #'zerop x :count -1))) - (and (equalp orig x) - result)) - #*010101) - -(deftest substitute-if-bit-vector.15 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if 1 #'zerop x :count 1 :from-end t))) - (and (equalp orig x) - result)) - #*010111) - -(deftest substitute-if-bit-vector.16 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if 1 #'zerop x :count 0 :from-end t))) - (and (equalp orig x) - result)) - #*010101) - -(deftest substitute-if-bit-vector.17 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if 1 #'zerop x :count -1 :from-end t))) - (and (equalp orig x) - result)) - #*010101) - -(deftest substitute-if-bit-vector.18 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if 1 #'zerop x :count nil))) - (and (equalp orig x) - result)) - #*111111) - -(deftest substitute-if-bit-vector.19 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if 1 #'zerop x :count nil :from-end t))) - (and (equalp orig x) - result)) - #*111111) - -(deftest substitute-if-bit-vector.20 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #*0000000000) - (x (copy-seq orig)) - (y (substitute-if 1 #'zerop x :start i :end j :count c))) - (and (equalp orig x) - (equalp y (concatenate - 'simple-bit-vector - (make-list i :initial-element 0) - (make-list c :initial-element 1) - (make-list (- 10 (+ i c)) :initial-element 0)))))))) - t) - -(deftest substitute-if-bit-vector.21 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #*1111111111) - (x (copy-seq orig)) - (y (substitute-if 0 (is-eql-p 1) x :start i :end j :count c :from-end t))) - (and (equalp orig x) - (equalp y (concatenate - 'simple-bit-vector - (make-list (- j c) :initial-element 1) - (make-list c :initial-element 0) - (make-list (- 10 j) :initial-element 1)))))))) - t) - -;;; More tests - -(deftest substitute-if-list.24 - (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (substitute-if '(a 10) (is-eql-p 'a) x :key #'car))) - (and (equal orig x) - result)) - ((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) - -(deftest substitute-if-list.25 - (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (substitute-if '(a 10) (is-eql-p 'a) x - :key #'car :start 1 :end 5))) - (and (equal orig x) - result)) - ((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) - -(deftest substitute-if-vector.24 - (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (substitute-if '(a 10) (is-eql-p 'a) x :key #'car))) - (and (equalp orig x) - result)) - #((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) - -(deftest substitute-if-vector.25 - (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (substitute-if '(a 10) (is-eql-p 'a) x :key #'car :start 1 :end 5))) - (and (equalp orig x) - result)) - #((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) - -(deftest substitute-if-string.24 - (let* ((orig "0102342015") - (x (copy-seq orig)) - (result (substitute-if #\a (is-eql-p #\1) x :key #'nextdigit))) - (and (equalp orig x) - result)) - "a1a2342a15") - -(deftest substitute-if-string.25 - (let* ((orig "0102342015") - (x (copy-seq orig)) - (result (substitute-if #\a (is-eql-p #\1) x :key #'nextdigit :start 1 :end 6))) - (and (equalp orig x) - result)) - "01a2342015") - -(deftest substitute-if-string.26 - (do-special-strings - (s "xyzabcxyzabc" nil) - (assert (string= (substitute-if #\! (is-eql-p #\a) s) "xyz!bcxyz!bc")) - (assert (string= (substitute-if #\! (is-eql-p #\a) s :count 1) "xyz!bcxyzabc")) - (assert (string= (substitute-if #\! (is-eql-p #\a) s :count 1 :from-end t) "xyzabcxyz!bc")) - (assert (string= s "xyzabcxyzabc"))) - nil) - -;;; More bit vector tests - -(deftest substitute-if-bit-vector.22 - (let* ((orig #*00111001011010110) - (x (copy-seq orig)) - (result (substitute-if 1 (is-eql-p 1) x :key #'1+))) - (and (equalp orig x) - result)) - #*11111111111111111) - -(deftest substitute-if-bit-vector.23 - (let* ((orig #*00111001011010110) - (x (copy-seq orig)) - (result (substitute-if 1 (is-eql-p 1) x :key #'1+ :start 1 :end 10))) - (and (equalp orig x) - result)) - #*01111111111010110) - -(deftest substitute-if-bit-vector.24 - (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (substitute-if 1 #'zerop x))) - result) - #*11111) - -(deftest substitute-if-bit-vector.25 - (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (substitute-if 1 #'zerop x :from-end t))) - result) - #*11111) - -(deftest substitute-if-bit-vector.26 - (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (substitute-if 1 #'zerop x :count 1))) - result) - #*11011) - -(deftest substitute-if-bit-vector.27 - (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (substitute-if 1 #'zerop x :from-end t :count 1))) - result) - #*01111) - -;;; Order of evaluation tests - -(deftest substitute-if.order.1 - (let ((i 0) a b c d e f g h) - (values - (substitute-if - (progn (setf a (incf i)) 'a) - (progn (setf b (incf i)) #'null) - (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) - :count (progn (setf d (incf i)) 2) - :start (progn (setf e (incf i)) 0) - :end (progn (setf f (incf i)) 7) - :key (progn (setf g (incf i)) #'identity) - :from-end (setf h (incf i)) - ) - i a b c d e f g h)) - (nil 1 2 a 3 4 a 5) - 8 1 2 3 4 5 6 7 8) - -(deftest substitute-if.order.2 - (let ((i 0) a b c d e f g h) - (values - (substitute-if - (progn (setf a (incf i)) 'a) - (progn (setf b (incf i)) #'null) - (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) - :from-end (setf h (incf i)) - :key (progn (setf g (incf i)) #'identity) - :end (progn (setf f (incf i)) 7) - :start (progn (setf e (incf i)) 0) - :count (progn (setf d (incf i)) 2) - ) - i a b c d e f g h)) - (nil 1 2 a 3 4 a 5) - 8 1 2 3 8 7 6 5 4) - -;;; Keyword tests - -(deftest substitute-if.allow-other-keys.1 - (substitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t :bad t) - (1 2 a 3 1 a 3)) - -(deftest substitute-if.allow-other-keys.2 - (substitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :bad t :allow-other-keys t) - (1 2 a 3 1 a 3)) - -(deftest substitute-if.allow-other-keys.3 - (substitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t - :allow-other-keys nil :bad t) - (1 2 a 3 1 a 3)) - -(deftest substitute-if.allow-other-keys.4 - (substitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :bad t - :allow-other-keys t :allow-other-keys nil) - (1 2 a 3 1 a 3)) - -(deftest substitute-if.allow-other-keys.5 - (substitute-if 'a #'zerop (list 1 2 0 3 1 0 3) - :allow-other-keys t :key #'1-) - (a 2 0 3 a 0 3)) - -(deftest substitute-if.keywords.6 - (substitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :key #'1- :key #'identity) - (a 2 0 3 a 0 3)) - -(deftest substitute-if.allow-other-keys.7 - (substitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t - :bad t :allow-other-keys nil) - (1 2 a 3 1 a 3)) - -(deftest substitute-if.allow-other-keys.8 - (substitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys nil) - (1 2 a 3 1 a 3)) - -;;; Constant folding tests - -(def-fold-test substitute-if.fold.1 (substitute-if 'z 'null '(a nil b))) -(def-fold-test substitute-if.fold.2 (substitute-if 'z 'null #(a nil b))) -(def-fold-test substitute-if.fold.3 (substitute-if 0 'plusp #*100110)) -(def-fold-test substitute-if.fold.4 (substitute-if #\x 'digit-char-p - "asdf8234n123f")) - -;;; Error cases - -(deftest substitute-if.error.1 - (signals-error (substitute-if) program-error) - t) - -(deftest substitute-if.error.2 - (signals-error (substitute-if 'a) program-error) - t) - -(deftest substitute-if.error.3 - (signals-error (substitute-if 'a #'null) program-error) - t) - -(deftest substitute-if.error.4 - (signals-error (substitute-if 'a #'null nil 'bad t) program-error) - t) - -(deftest substitute-if.error.5 - (signals-error (substitute-if 'a #'null nil 'bad t :allow-other-keys nil) - program-error) - t) - -(deftest substitute-if.error.6 - (signals-error (substitute-if 'a #'null nil :key) program-error) - t) - -(deftest substitute-if.error.7 - (signals-error (substitute-if 'a #'null nil 1 2) program-error) - t) - -(deftest substitute-if.error.8 - (signals-error (substitute-if 'a #'cons (list 'a 'b 'c)) program-error) - t) - -(deftest substitute-if.error.9 - (signals-error (substitute-if 'a #'car (list 'a 'b 'c)) type-error) - t) - -(deftest substitute-if.error.10 - (signals-error (substitute-if 'a #'identity (list 'a 'b 'c) - :key #'car) - type-error) - t) - -(deftest substitute-if.error.11 - (signals-error (substitute-if 'a #'identity (list 'a 'b 'c) - :key #'cons) - program-error) - t) - -(deftest substitute-if.error.12 - (check-type-error #'(lambda (x) (substitute-if 'a #'not x)) #'sequencep) - nil) diff --git a/t/ansi-test/sequences/substitute.lsp b/t/ansi-test/sequences/substitute.lsp deleted file mode 100644 index 483dc91..0000000 --- a/t/ansi-test/sequences/substitute.lsp +++ /dev/null @@ -1,1150 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Aug 28 21:15:33 2002 -;;;; Contains: Tests for SUBSTITUTE - -(in-package :cl-test) - -(deftest substitute-list.1 - (let ((x '())) (values (substitute 'b 'a x) x)) - nil nil) - -(deftest substitute-list.2 - (let ((x '(a b a c))) (values (substitute 'b 'a x) x)) - (b b b c) - (a b a c)) - -(deftest substitute-list.3 - (let ((x '(a b a c))) (values (substitute 'b 'a x :count nil) x)) - (b b b c) - (a b a c)) - -(deftest substitute-list.4 - (let ((x '(a b a c))) (values (substitute 'b 'a x :count 2) x)) - (b b b c) - (a b a c)) - -(deftest substitute-list.5 - (let ((x '(a b a c))) (values (substitute 'b 'a x :count 1) x)) - (b b a c) - (a b a c)) - -(deftest substitute-list.6 - (let ((x '(a b a c))) (values (substitute 'b 'a x :count 0) x)) - (a b a c) - (a b a c)) - -(deftest substitute-list.7 - (let ((x '(a b a c))) (values (substitute 'b 'a x :count -1) x)) - (a b a c) - (a b a c)) - -(deftest substitute-list.8 - (let ((x '())) (values (substitute 'b 'a x :from-end t) x)) - nil nil) - -(deftest substitute-list.9 - (let ((x '(a b a c))) (values (substitute 'b 'a x :from-end t) x)) - (b b b c) - (a b a c)) - -(deftest substitute-list.10 - (let ((x '(a b a c))) (values (substitute 'b 'a x :from-end t :count nil) x)) - (b b b c) - (a b a c)) - -(deftest substitute-list.11 - (let ((x '(a b a c))) (values (substitute 'b 'a x :count 2 :from-end t) x)) - (b b b c) - (a b a c)) - -(deftest substitute-list.12 - (let ((x '(a b a c))) (values (substitute 'b 'a x :count 1 :from-end t) x)) - (a b b c) - (a b a c)) - -(deftest substitute-list.13 - (let ((x '(a b a c))) (values (substitute 'b 'a x :count 0 :from-end t) x)) - (a b a c) - (a b a c)) - -(deftest substitute-list.14 - (let ((x '(a b a c))) (values (substitute 'b 'a x :count -1 :from-end t) x)) - (a b a c) - (a b a c)) - -(deftest substitute-list.15 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute 'x 'a x :start i :end j))) - (and (equal orig x) - (equal y (nconc (make-list i :initial-element 'a) - (make-list (- j i) :initial-element 'x) - (make-list (- 10 j) :initial-element 'a))))))) - t) - -(deftest substitute-list.16 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute 'x 'a x :start i :end j :from-end t))) - (and (equal orig x) - (equal y (nconc (make-list i :initial-element 'a) - (make-list (- j i) :initial-element 'x) - (make-list (- 10 j) :initial-element 'a))))))) - t) - -(deftest substitute-list.17 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute 'x 'a x :start i :end j :count c))) - (and (equal orig x) - (equal y (nconc (make-list i :initial-element 'a) - (make-list c :initial-element 'x) - (make-list (- 10 (+ i c)) :initial-element 'a)))))))) - t) - -(deftest substitute-list.18 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute 'x 'a x :start i :end j :count c :from-end t))) - (and (equal orig x) - (equal y (nconc (make-list (- j c) :initial-element 'a) - (make-list c :initial-element 'x) - (make-list (- 10 j) :initial-element 'a)))))))) - t) - -(deftest substitute-list.19 - (let* ((orig '(1 2 3 4 5 6 7 8 9)) - (x (copy-seq orig)) - (result (substitute 'x 5 x :test #'(lambda (a b) (<= (abs (- a b)) 2))))) - (and (equal orig x) - result)) - (1 2 x x x x x 8 9)) - -(deftest substitute-list.20 - (let* ((orig '(1 2 3 4 5 6 7 8 9)) - (x (copy-seq orig)) - (c -4) - (result (substitute 'x 5 x :test #'(lambda (a b) (incf c 2) (= (+ b c) a))))) - (and (equal orig x) - result)) - (1 2 x 4 5 6 7 8 9)) - - -(deftest substitute-list.21 - (let* ((orig '(1 2 3 4 5 6 7 8 9)) - (x (copy-seq orig)) - (c 5) - (result (substitute 'x 9 x :test #'(lambda (a b) (incf c -2) (= (+ b c) a)) - :from-end t))) - (and (equal orig x) - result)) - (1 2 3 4 5 6 7 x 9)) - -(deftest substitute-list.22 - (let* ((orig '(1 2 3 4 5 6 7 8 9)) - (x (copy-seq orig)) - (c -4) - (result (substitute 'x 5 x :test-not #'(lambda (a b) (incf c 2) (/= (+ b c) a))))) - (and (equal orig x) - result)) - (1 2 x 4 5 6 7 8 9)) - - -(deftest substitute-list.23 - (let* ((orig '(1 2 3 4 5 6 7 8 9)) - (x (copy-seq orig)) - (c 5) - (result (substitute 'x 9 x :test-not #'(lambda (a b) (incf c -2) (/= (+ b c) a)) - :from-end t))) - (and (equal orig x) - result)) - (1 2 3 4 5 6 7 x 9)) - -(deftest substitute-list.24 - (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (substitute '(a 10) 'a x :key #'car))) - (and (equal orig x) - result)) - ((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) - -(deftest substitute-list.25 - (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (substitute '(a 10) 'a x :key #'car :start 1 :end 5))) - (and (equal orig x) - result)) - ((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) - -(deftest substitute-list.26 - (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (substitute '(a 10) 'a x :key #'car :test (complement #'eql)))) - (and (equal orig x) - result)) - ((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) - -(deftest substitute-list.27 - (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (substitute '(a 10) 'a x :key #'car :test-not #'eql))) - (and (equal orig x) - result)) - ((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) - -;;; Tests on vectors - -(deftest substitute-vector.1 - (let ((x #())) (values (substitute 'b 'a x) x)) - #() #()) - -(deftest substitute-vector.2 - (let ((x #(a b a c))) (values (substitute 'b 'a x) x)) - #(b b b c) - #(a b a c)) - -(deftest substitute-vector.3 - (let ((x #(a b a c))) (values (substitute 'b 'a x :count nil) x)) - #(b b b c) - #(a b a c)) - -(deftest substitute-vector.4 - (let ((x #(a b a c))) (values (substitute 'b 'a x :count 2) x)) - #(b b b c) - #(a b a c)) - -(deftest substitute-vector.5 - (let ((x #(a b a c))) (values (substitute 'b 'a x :count 1) x)) - #(b b a c) - #(a b a c)) - -(deftest substitute-vector.6 - (let ((x #(a b a c))) (values (substitute 'b 'a x :count 0) x)) - #(a b a c) - #(a b a c)) - -(deftest substitute-vector.7 - (let ((x #(a b a c))) (values (substitute 'b 'a x :count -1) x)) - #(a b a c) - #(a b a c)) - -(deftest substitute-vector.8 - (let ((x #())) (values (substitute 'b 'a x :from-end t) x)) - #() #()) - -(deftest substitute-vector.9 - (let ((x #(a b a c))) (values (substitute 'b 'a x :from-end t) x)) - #(b b b c) - #(a b a c)) - -(deftest substitute-vector.10 - (let ((x #(a b a c))) (values (substitute 'b 'a x :from-end t :count nil) x)) - #(b b b c) - #(a b a c)) - -(deftest substitute-vector.11 - (let ((x #(a b a c))) (values (substitute 'b 'a x :count 2 :from-end t) x)) - #(b b b c) - #(a b a c)) - -(deftest substitute-vector.12 - (let ((x #(a b a c))) (values (substitute 'b 'a x :count 1 :from-end t) x)) - #(a b b c) - #(a b a c)) - -(deftest substitute-vector.13 - (let ((x #(a b a c))) (values (substitute 'b 'a x :count 0 :from-end t) x)) - #(a b a c) - #(a b a c)) - -(deftest substitute-vector.14 - (let ((x #(a b a c))) (values (substitute 'b 'a x :count -1 :from-end t) x)) - #(a b a c) - #(a b a c)) - -(deftest substitute-vector.15 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute 'x 'a x :start i :end j))) - (and (equalp orig x) - (equalp y (concatenate 'simple-vector - (make-array i :initial-element 'a) - (make-array (- j i) :initial-element 'x) - (make-array (- 10 j) :initial-element 'a))))))) - t) - -(deftest substitute-vector.16 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute 'x 'a x :start i :end j :from-end t))) - (and (equalp orig x) - (equalp y (concatenate 'simple-vector - (make-array i :initial-element 'a) - (make-array (- j i) :initial-element 'x) - (make-array (- 10 j) :initial-element 'a))))))) - t) - -(deftest substitute-vector.17 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute 'x 'a x :start i :end j :count c))) - (and (equalp orig x) - (equalp y (concatenate 'simple-vector - (make-array i :initial-element 'a) - (make-array c :initial-element 'x) - (make-array (- 10 (+ i c)) :initial-element 'a)))))))) - t) - -(deftest substitute-vector.18 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute 'x 'a x :start i :end j :count c :from-end t))) - (and (equalp orig x) - (equalp y (concatenate 'simple-vector - (make-array (- j c) :initial-element 'a) - (make-array c :initial-element 'x) - (make-array (- 10 j) :initial-element 'a)))))))) - t) - -(deftest substitute-vector.19 - (let* ((orig #(1 2 3 4 5 6 7 8 9)) - (x (copy-seq orig)) - (result (substitute 'x 5 x :test #'(lambda (a b) (<= (abs (- a b)) 2))))) - (and (equalp orig x) - result)) - #(1 2 x x x x x 8 9)) - -(deftest substitute-vector.20 - (let* ((orig #(1 2 3 4 5 6 7 8 9)) - (x (copy-seq orig)) - (c -4) - (result (substitute 'x 5 x :test #'(lambda (a b) (incf c 2) (= (+ b c) a))))) - (and (equalp orig x) - result)) - #(1 2 x 4 5 6 7 8 9)) - - -(deftest substitute-vector.21 - (let* ((orig #(1 2 3 4 5 6 7 8 9)) - (x (copy-seq orig)) - (c 5) - (result (substitute 'x 9 x :test #'(lambda (a b) (incf c -2) (= (+ b c) a)) - :from-end t))) - (and (equalp orig x) - result)) - #(1 2 3 4 5 6 7 x 9)) - -(deftest substitute-vector.22 - (let* ((orig #(1 2 3 4 5 6 7 8 9)) - (x (copy-seq orig)) - (c -4) - (result (substitute 'x 5 x :test-not #'(lambda (a b) (incf c 2) (/= (+ b c) a))))) - (and (equalp orig x) - result)) - #(1 2 x 4 5 6 7 8 9)) - - -(deftest substitute-vector.23 - (let* ((orig #(1 2 3 4 5 6 7 8 9)) - (x (copy-seq orig)) - (c 5) - (result (substitute 'x 9 x :test-not #'(lambda (a b) (incf c -2) (/= (+ b c) a)) - :from-end t))) - (and (equalp orig x) - result)) - #(1 2 3 4 5 6 7 x 9)) - -(deftest substitute-vector.24 - (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (substitute '(a 10) 'a x :key #'car))) - (and (equalp orig x) - result)) - #((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) - -(deftest substitute-vector.25 - (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (substitute '(a 10) 'a x :key #'car :start 1 :end 5))) - (and (equalp orig x) - result)) - #((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) - -(deftest substitute-vector.26 - (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (substitute '(a 10) 'a x :key #'car :test (complement #'eql)))) - (and (equalp orig x) - result)) - #((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) - -(deftest substitute-vector.27 - (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (substitute '(a 10) 'a x :key #'car :test-not #'eql))) - (and (equalp orig x) - result)) - #((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) - -(deftest substitute-vector.28 - (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (substitute 'z 'a x))) - result) - #(z b z c b)) - -(deftest substitute-vector.29 - (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (substitute 'z 'a x :from-end t))) - result) - #(z b z c b)) - -(deftest substitute-vector.30 - (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (substitute 'z 'a x :count 1))) - result) - #(z b a c b)) - -(deftest substitute-vector.31 - (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (substitute 'z 'a x :from-end t :count 1))) - result) - #(a b z c b)) - -(deftest substitute-vector.32 - (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) - (v2 (make-array '(8) :displaced-to v1 - :displaced-index-offset 3))) - (values - (substitute 'x 'c v2 :count 1) - v1)) - #(d a b x d a b c) - #(a b c d a b c d a b c d a b c d)) - -(deftest substitute-vector.33 - (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) - (v2 (make-array '(8) :displaced-to v1 - :displaced-index-offset 3))) - (values - (substitute 'x 'c v2 :count 1 :from-end t) - v1)) - #(d a b c d a b x) - #(a b c d a b c d a b c d a b c d)) - -;;; Tests on strings - -(deftest substitute-string.1 - (let ((x "")) (values (substitute #\b #\a x) x)) - "" "") - -(deftest substitute-string.2 - (let ((x "abac")) (values (substitute #\b #\a x) x)) - "bbbc" - "abac") - -(deftest substitute-string.3 - (let ((x "abac")) (values (substitute #\b #\a x :count nil) x)) - "bbbc" - "abac") - -(deftest substitute-string.4 - (let ((x "abac")) (values (substitute #\b #\a x :count 2) x)) - "bbbc" - "abac") - -(deftest substitute-string.5 - (let ((x "abac")) (values (substitute #\b #\a x :count 1) x)) - "bbac" - "abac") - -(deftest substitute-string.6 - (let ((x "abac")) (values (substitute #\b #\a x :count 0) x)) - "abac" - "abac") - -(deftest substitute-string.7 - (let ((x "abac")) (values (substitute #\b #\a x :count -1) x)) - "abac" - "abac") - -(deftest substitute-string.8 - (let ((x "")) (values (substitute #\b #\a x :from-end t) x)) - "" "") - -(deftest substitute-string.9 - (let ((x "abac")) (values (substitute #\b #\a x :from-end t) x)) - "bbbc" - "abac") - -(deftest substitute-string.10 - (let ((x "abac")) (values (substitute #\b #\a x :from-end t :count nil) x)) - "bbbc" - "abac") - -(deftest substitute-string.11 - (let ((x "abac")) (values (substitute #\b #\a x :count 2 :from-end t) x)) - "bbbc" - "abac") - -(deftest substitute-string.12 - (let ((x "abac")) (values (substitute #\b #\a x :count 1 :from-end t) x)) - "abbc" - "abac") - -(deftest substitute-string.13 - (let ((x "abac")) (values (substitute #\b #\a x :count 0 :from-end t) x)) - "abac" - "abac") - -(deftest substitute-string.14 - (let ((x "abac")) (values (substitute #\b #\a x :count -1 :from-end t) x)) - "abac" - "abac") - -(deftest substitute-string.15 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (substitute #\x #\a x :start i :end j))) - (and (equalp orig x) - (equalp y (concatenate 'simple-string - (make-array i :initial-element #\a) - (make-array (- j i) :initial-element #\x) - (make-array (- 10 j) :initial-element #\a))))))) - t) - -(deftest substitute-string.16 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (substitute #\x #\a x :start i :end j :from-end t))) - (and (equalp orig x) - (equalp y (concatenate 'simple-string - (make-array i :initial-element #\a) - (make-array (- j i) :initial-element #\x) - (make-array (- 10 j) :initial-element #\a))))))) - t) - -(deftest substitute-string.17 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (substitute #\x #\a x :start i :end j :count c))) - (and (equalp orig x) - (equalp y (concatenate 'simple-string - (make-array i :initial-element #\a) - (make-array c :initial-element #\x) - (make-array (- 10 (+ i c)) :initial-element #\a)))))))) - t) - -(deftest substitute-string.18 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (substitute #\x #\a x :start i :end j :count c :from-end t))) - (and (equalp orig x) - (equalp y (concatenate 'simple-string - (make-array (- j c) :initial-element #\a) - (make-array c :initial-element #\x) - (make-array (- 10 j) :initial-element #\a)))))))) - t) - -(deftest substitute-string.19 - (let* ((orig "123456789") - (x (copy-seq orig)) - (result (substitute #\x #\5 x :test #'(lambda (a b) - (setq a (read-from-string (string a))) - (setq b (read-from-string (string b))) - (<= (abs (- a b)) 2))))) - (and (equalp orig x) - result)) - "12xxxxx89") - -(deftest substitute-string.20 - (let* ((orig "123456789") - (x (copy-seq orig)) - (c -4) - (result (substitute #\x #\5 x :test #'(lambda (a b) - (setq a (read-from-string (string a))) - (setq b (read-from-string (string b))) - (incf c 2) (= (+ b c) a))))) - (and (equalp orig x) - result)) - "12x456789") - - -(deftest substitute-string.21 - (let* ((orig "123456789") - (x (copy-seq orig)) - (c 5) - (result (substitute #\x #\9 x :test #'(lambda (a b) - (setq a (read-from-string (string a))) - (setq b (read-from-string (string b))) - (incf c -2) (= (+ b c) a)) - :from-end t))) - (and (equalp orig x) - result)) - "1234567x9") - -(deftest substitute-string.22 - (let* ((orig "123456789") - (x (copy-seq orig)) - (c -4) - (result (substitute #\x #\5 x :test-not #'(lambda (a b) - (setq a (read-from-string (string a))) - (setq b (read-from-string (string b))) - (incf c 2) (/= (+ b c) a))))) - (and (equalp orig x) - result)) - "12x456789") - - -(deftest substitute-string.23 - (let* ((orig "123456789") - (x (copy-seq orig)) - (c 5) - (result (substitute #\x #\9 x :test-not #'(lambda (a b) - (setq a (read-from-string (string a))) - (setq b (read-from-string (string b))) - (incf c -2) (/= (+ b c) a)) - :from-end t))) - (and (equalp orig x) - result)) - "1234567x9") - -(deftest substitute-string.24 - (let* ((orig "0102342015") - (x (copy-seq orig)) - (result (substitute #\a #\1 x :key #'nextdigit))) - (and (equalp orig x) - result)) - "a1a2342a15") - -(deftest substitute-string.25 - (let* ((orig "0102342015") - (x (copy-seq orig)) - (result (substitute #\a #\1 x :key #'nextdigit :start 1 :end 6))) - (and (equalp orig x) - result)) - "01a2342015") - -(deftest substitute-string.26 - (let* ((orig "0102342015") - (x (copy-seq orig)) - (result (substitute #\a #\1 x :key #'nextdigit :test (complement #'eql)))) - (and (equalp orig x) - result)) - "0a0aaaa0aa") - -(deftest substitute-string.27 - (let* ((orig "0102342015") - (x (copy-seq orig)) - (result (substitute #\a #\1 x :key #'nextdigit :test-not #'eql))) - (and (equalp orig x) - result)) - "0a0aaaa0aa") - -(deftest substitute-string.28 - (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (substitute #\z #\a x))) - result) - "zbzcb") - -(deftest substitute-string.29 - (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (substitute #\z #\a x :from-end t))) - result) - "zbzcb") - -(deftest substitute-string.30 - (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (substitute #\z #\a x :count 1))) - result) - "zbacb") - -(deftest substitute-string.31 - (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (substitute #\z #\a x :from-end t :count 1))) - result) - "abzcb") - -(deftest substitute-string.32 - (do-special-strings - (s "xyzabcxyzabc" nil) - (assert (string= (substitute #\! #\a s) "xyz!bcxyz!bc")) - (assert (string= (substitute #\! #\a s :count 1) "xyz!bcxyzabc")) - (assert (string= (substitute #\! #\a s :count 1 :from-end t) "xyzabcxyz!bc")) - (assert (string= s "xyzabcxyzabc"))) - nil) - -;;; Tests on bit-vectors - -(deftest substitute-bit-vector.1 - (let* ((orig #*) - (x (copy-seq orig)) - (result (substitute 0 1 x))) - (and (equalp orig x) - result)) - #*) - -(deftest substitute-bit-vector.2 - (let* ((orig #*) - (x (copy-seq orig)) - (result (substitute 1 0 x))) - (and (equalp orig x) - result)) - #*) - -(deftest substitute-bit-vector.3 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute 0 1 x))) - (and (equalp orig x) - result)) - #*000000) - -(deftest substitute-bit-vector.4 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute 1 0 x))) - (and (equalp orig x) - result)) - #*111111) - -(deftest substitute-bit-vector.5 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute 1 0 x :start 1))) - (and (equalp orig x) - result)) - #*011111) - -(deftest substitute-bit-vector.6 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute 0 1 x :start 2 :end nil))) - (and (equalp orig x) - result)) - #*010000) - -(deftest substitute-bit-vector.7 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute 1 0 x :end 4))) - (and (equalp orig x) - result)) - #*111101) - -(deftest substitute-bit-vector.8 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute 0 1 x :end nil))) - (and (equalp orig x) - result)) - #*000000) - -(deftest substitute-bit-vector.9 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute 0 1 x :end 3))) - (and (equalp orig x) - result)) - #*000101) - -(deftest substitute-bit-vector.10 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute 0 1 x :start 2 :end 4))) - (and (equalp orig x) - result)) - #*010001) - -(deftest substitute-bit-vector.11 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute 1 0 x :start 2 :end 4))) - (and (equalp orig x) - result)) - #*011101) - -(deftest substitute-bit-vector.12 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute 1 0 x :count 1))) - (and (equalp orig x) - result)) - #*110101) - -(deftest substitute-bit-vector.13 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute 1 0 x :count 0))) - (and (equalp orig x) - result)) - #*010101) - -(deftest substitute-bit-vector.14 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute 1 0 x :count -1))) - (and (equalp orig x) - result)) - #*010101) - -(deftest substitute-bit-vector.15 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute 1 0 x :count 1 :from-end t))) - (and (equalp orig x) - result)) - #*010111) - -(deftest substitute-bit-vector.16 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute 1 0 x :count 0 :from-end t))) - (and (equalp orig x) - result)) - #*010101) - -(deftest substitute-bit-vector.17 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute 1 0 x :count -1 :from-end t))) - (and (equalp orig x) - result)) - #*010101) - -(deftest substitute-bit-vector.18 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute 1 0 x :count nil))) - (and (equalp orig x) - result)) - #*111111) - -(deftest substitute-bit-vector.19 - (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute 1 0 x :count nil :from-end t))) - (and (equalp orig x) - result)) - #*111111) - -(deftest substitute-bit-vector.20 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #*0000000000) - (x (copy-seq orig)) - (y (substitute 1 0 x :start i :end j :count c))) - (and (equalp orig x) - (equalp y (concatenate - 'simple-bit-vector - (make-list i :initial-element 0) - (make-list c :initial-element 1) - (make-list (- 10 (+ i c)) :initial-element 0)))))))) - t) - -(deftest substitute-bit-vector.21 - (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #*1111111111) - (x (copy-seq orig)) - (y (substitute 0 1 x :start i :end j :count c :from-end t))) - (and (equalp orig x) - (equalp y (concatenate - 'simple-bit-vector - (make-list (- j c) :initial-element 1) - (make-list c :initial-element 0) - (make-list (- 10 j) :initial-element 1)))))))) - t) - -(deftest substitute-bit-vector.22 - (let* ((orig #*0101010101) - (x (copy-seq orig)) - (c 0) - (result (substitute 1 0 x :test #'(lambda (a b) (incf c) (and (<= 2 c 5) (= a b)))))) - (and (equalp orig x) - result)) - #*0111110101) - -(deftest substitute-bit-vector.23 - (let* ((orig #*0101010101) - (x (copy-seq orig)) - (c 0) - (result (substitute 1 0 x :test-not #'(lambda (a b) (incf c) - (not (and (<= 2 c 5) (= a b))))))) - (and (equalp orig x) - result)) - #*0111110101) - -(deftest substitute-bit-vector.24 - (let* ((orig #*0101010101) - (x (copy-seq orig)) - (c 0) - (result (substitute 1 0 x :test #'(lambda (a b) (incf c) (and (<= 2 c 5) (= a b))) - :from-end t))) - (and (equalp orig x) - result)) - #*0101011111) - -(deftest substitute-bit-vector.25 - (let* ((orig #*0101010101) - (x (copy-seq orig)) - (c 0) - (result (substitute 1 0 x :test-not #'(lambda (a b) (incf c) - (not (and (<= 2 c 5) (= a b)))) - :from-end t))) - (and (equalp orig x) - result)) - #*0101011111) - -(deftest substitute-bit-vector.26 - (let* ((orig #*00111001011010110) - (x (copy-seq orig)) - (result (substitute 1 1 x :key #'1+))) - (and (equalp orig x) - result)) - #*11111111111111111) - -(deftest substitute-bit-vector.27 - (let* ((orig #*00111001011010110) - (x (copy-seq orig)) - (result (substitute 1 1 x :key #'1+ :start 1 :end 10))) - (and (equalp orig x) - result)) - #*01111111111010110) - -(deftest substitute-bit-vector.28 - (let* ((orig #*00111001011010110) - (x (copy-seq orig)) - (result (substitute 0 1 x :key #'1+ :test (complement #'eql)))) - (and (equalp orig x) - result)) - #*00000000000000000) - -(deftest substitute-bit-vector.29 - (let* ((orig #*00111001011010110) - (x (copy-seq orig)) - (result (substitute 0 1 x :key #'1+ :test-not #'eql))) - (and (equalp orig x) - result)) - #*00000000000000000) - -(deftest substitute-bit-vector.30 - (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (substitute 1 0 x))) - result) - #*11111) - -(deftest substitute-bit-vector.31 - (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (substitute 1 0 x :from-end t))) - result) - #*11111) - -(deftest substitute-bit-vector.32 - (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (substitute 1 0 x :count 1))) - result) - #*11011) - -(deftest substitute-bit-vector.33 - (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (substitute 1 0 x :from-end t :count 1))) - result) - #*01111) - -(defharmless substitute.test-and-test-not.1 - (substitute 'b 'a (list 'a 'b 'c 'd 'a 'b) :test #'eql :test-not #'eql)) - -(defharmless substitute.test-and-test-not.2 - (substitute 'b 'a (list 'a 'b 'c 'd 'a 'b) :test-not #'eql :test #'eql)) - -(defharmless substitute.test-and-test-not.3 - (substitute 'b 'a (vector 'a 'b 'c 'd 'a 'b) :test #'eql :test-not #'eql)) - -(defharmless substitute.test-and-test-not.4 - (substitute 'b 'a (vector 'a 'b 'c 'd 'a 'b) :test-not #'eql :test #'eql)) - -(defharmless substitute.test-and-test-not.5 - (substitute #\b #\a (copy-seq "abcdab") :test #'eql :test-not #'eql)) - -(defharmless substitute.test-and-test-not.6 - (substitute #\b #\a (copy-seq "abcdab") :test-not #'eql :test #'eql)) - -(defharmless substitute.test-and-test-not.7 - (substitute 1 0 (copy-seq #*001101001) :test #'eql :test-not #'eql)) - -(defharmless substitute.test-and-test-not.8 - (substitute 0 1 (copy-seq #*1100110101) :test-not #'eql :test #'eql)) - - -(deftest substitute.order.1 - (let ((i 0) a b c d e f g h) - (values - (substitute - (progn (setf a (incf i)) 'a) - (progn (setf b (incf i)) nil) - (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) - :count (progn (setf d (incf i)) 2) - :start (progn (setf e (incf i)) 0) - :end (progn (setf f (incf i)) 7) - :key (progn (setf g (incf i)) #'identity) - :from-end (setf h (incf i)) - ) - i a b c d e f g h)) - (nil 1 2 a 3 4 a 5) - 8 1 2 3 4 5 6 7 8) - -(deftest substitute.order.2 - (let ((i 0) a b c d e f g h) - (values - (substitute - (progn (setf a (incf i)) 'a) - (progn (setf b (incf i)) nil) - (progn (setf c (incf i)) (list nil 1 2 nil 3 4 nil 5)) - :from-end (setf h (incf i)) - :key (progn (setf g (incf i)) #'identity) - :end (progn (setf f (incf i)) 7) - :start (progn (setf e (incf i)) 0) - :count (progn (setf d (incf i)) 2) - ) - i a b c d e f g h)) - (nil 1 2 a 3 4 a 5) - 8 1 2 3 8 7 6 5 4) - -;;; Keyword tests - -(deftest substitute.allow-other-keys.1 - (substitute 'a 0 (list 1 2 0 3 1 0 3) :allow-other-keys t :bad t) - (1 2 a 3 1 a 3)) - -(deftest substitute.allow-other-keys.2 - (substitute 'a 0 (list 1 2 0 3 1 0 3) :bad t :allow-other-keys t) - (1 2 a 3 1 a 3)) - -(deftest substitute.allow-other-keys.3 - (substitute 'a 0 (list 1 2 0 3 1 0 3) :allow-other-keys t - :allow-other-keys nil :bad t) - (1 2 a 3 1 a 3)) - -(deftest substitute.allow-other-keys.4 - (substitute 'a 0 (list 1 2 0 3 1 0 3) :bad t - :allow-other-keys t :allow-other-keys nil) - (1 2 a 3 1 a 3)) - -(deftest substitute.allow-other-keys.5 - (substitute 'a 0 (list 1 2 0 3 1 0 3) - :allow-other-keys t :key #'1-) - (a 2 0 3 a 0 3)) - -(deftest substitute.keywords.6 - (substitute 'a 0 (list 1 2 0 3 1 0 3) :key #'1- :key #'identity) - (a 2 0 3 a 0 3)) - -(deftest substitute.allow-other-keys.7 - (substitute 'a 0 (list 1 2 0 3 1 0 3) :allow-other-keys t - :bad t :allow-other-keys nil) - (1 2 a 3 1 a 3)) - -(deftest substitute.allow-other-keys.8 - (substitute 'a 0 (list 1 2 0 3 1 0 3) :allow-other-keys nil) - (1 2 a 3 1 a 3)) - -;;; Constant folding tests - -(def-fold-test substitute.fold.1 (substitute 'z 'b '(a b c))) -(def-fold-test substitute.fold.2 (substitute 'z 'b #(a b c))) -(def-fold-test substitute.fold.3 (substitute 0 1 #*001101)) -(def-fold-test substitute.fold.4 (substitute #\a #\b "abcebadfke")) - -;;; Error cases - -(deftest substitute.error.1 - (signals-error (substitute) program-error) - t) - -(deftest substitute.error.2 - (signals-error (substitute 'a) program-error) - t) - -(deftest substitute.error.3 - (signals-error (substitute 'a 'b) program-error) - t) - -(deftest substitute.error.4 - (signals-error (substitute 'a 'b nil 'bad t) program-error) - t) - -(deftest substitute.error.5 - (signals-error (substitute 'a 'b nil 'bad t :allow-other-keys nil) program-error) - t) - -(deftest substitute.error.6 - (signals-error (substitute 'a 'b nil :key) program-error) - t) - -(deftest substitute.error.7 - (signals-error (substitute 'a 'b nil 1 2) program-error) - t) - -(deftest substitute.error.8 - (signals-error (substitute 'a 'b (list 'a 'b 'c) :test #'identity) program-error) - t) - -(deftest substitute.error.9 - (signals-error (substitute 'a 'b (list 'a 'b 'c) :test-not #'identity) program-error) - t) - -(deftest substitute.error.10 - (signals-error (substitute 'a 'b (list 'a 'b 'c) :key #'cons) program-error) - t) - -(deftest substitute.error.11 - (signals-error (substitute 'a 'b (list 'a 'b 'c) :key #'car) type-error) - t) - -(deftest substitute.error.12 - (check-type-error #'(lambda (x) (substitute 'a 'b x)) #'sequencep) - nil) diff --git a/t/ansi-test/streams/broadcast-stream-streams.lsp b/t/ansi-test/streams/broadcast-stream-streams.lsp deleted file mode 100644 index 9033a08..0000000 --- a/t/ansi-test/streams/broadcast-stream-streams.lsp +++ /dev/null @@ -1,30 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Jan 29 22:06:28 2004 -;;;; Contains: Tests of BROADCAST-STREAM-STREAMS - -(in-package :cl-test) - -(deftest broadcast-stream-streams.1 - (broadcast-stream-streams (make-broadcast-stream)) - nil) - -(deftest broadcast-stream-streams.2 - (equalt - (broadcast-stream-streams (make-broadcast-stream *standard-output*)) - (list *standard-output*)) - t) - -(deftest broadcast-stream-streams.error.1 - (signals-error (broadcast-stream-streams) program-error) - t) - -(deftest broadcast-stream-streams.error.2 - (signals-error (broadcast-stream-streams (make-broadcast-stream) nil) - program-error) - t) - - - - - diff --git a/t/ansi-test/streams/clear-input.lsp b/t/ansi-test/streams/clear-input.lsp deleted file mode 100644 index 7c50796..0000000 --- a/t/ansi-test/streams/clear-input.lsp +++ /dev/null @@ -1,64 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Jan 28 06:12:39 2004 -;;;; Contains: Tests of CLEAR-INPUT - -(in-package :cl-test) - -;;; These tests are limited, since whether an input stream can be -;;; cleared is not well specified. - -(deftest clear-input.1 - (loop for s in (list *debug-io* *query-io* - *standard-input* *terminal-io*) - always (eq (clear-input s) nil)) - t) - -(deftest clear-input.2 - (clear-input) - nil) - -(deftest clear-input.3 - (clear-input nil) - nil) - -(deftest clear-input.4 - (clear-input t) - nil) - -(deftest clear-input.5 - (with-input-from-string - (is "!?*") - (let ((*terminal-io* (make-two-way-stream is (make-broadcast-stream)))) - (clear-input t))) - nil) - -(deftest clear-input.6 - (with-input-from-string - (*standard-input* "345") - (clear-input nil)) - nil) - -;;; Error cases - -(deftest clear-input.error.1 - :notes (:assume-no-simple-streams) - (signals-error (clear-input t nil) program-error) - t) - -(deftest clear-input.error.2 - :notes (:assume-no-simple-streams) - (signals-error (clear-input nil nil) program-error) - t) - -(deftest clear-input.error.3 - (signals-error (clear-input t nil nil) program-error) - t) - -(deftest clear-input.error.4 - (signals-error (clear-input nil nil nil) program-error) - t) - -(deftest clear-input.error.5 - (check-type-error #'clear-input #'(lambda (x) (typep x '(or stream (member nil t))))) - nil) diff --git a/t/ansi-test/streams/clear-output.lsp b/t/ansi-test/streams/clear-output.lsp deleted file mode 100644 index ca4396e..0000000 --- a/t/ansi-test/streams/clear-output.lsp +++ /dev/null @@ -1,53 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Jan 28 06:43:17 2004 -;;;; Contains: Tests of CLEAR-OUTPUT - -(in-package :cl-test) - -(deftest clear-output.1 - (progn (finish-output) (clear-output)) - nil) - -(deftest clear-output.2 - (progn (finish-output) (clear-output t)) - nil) - -(deftest clear-output.3 - (progn (finish-output) (clear-output nil)) - nil) - -(deftest clear-output.4 - (loop for s in (list *debug-io* *error-output* *query-io* - *standard-output* *trace-output* *terminal-io*) - for dummy = (finish-output s) - for results = (multiple-value-list (clear-output s)) - unless (equal results '(nil)) - collect s) - nil) - -(deftest clear-output.5 - (let ((os (make-string-output-stream))) - (let ((*terminal-io* (make-two-way-stream (make-string-input-stream "") - os))) - (clear-output t))) - nil) - -(deftest clear-output.6 - (let ((*standard-output* (make-string-output-stream))) - (clear-output nil)) - nil) - -;;; Error tests - -(deftest clear-output.error.1 - (signals-error (clear-output nil nil) program-error) - t) - -(deftest clear-output.error.2 - (signals-error (clear-output t nil) program-error) - t) - -(deftest clear-output.error.3 - (check-type-error #'clear-output #'(lambda (x) (typep x '(or stream (member nil t))))) - nil) diff --git a/t/ansi-test/streams/concatenated-stream-streams.lsp b/t/ansi-test/streams/concatenated-stream-streams.lsp deleted file mode 100644 index 22d5524..0000000 --- a/t/ansi-test/streams/concatenated-stream-streams.lsp +++ /dev/null @@ -1,67 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Feb 14 08:43:45 2004 -;;;; Contains: Tests of CONCATENATED-STREAM-STREAMS - -(in-package :cl-test) - -(deftest concatenated-stream-streams.1 - (concatenated-stream-streams (make-concatenated-stream)) - nil) - -(deftest concatenated-stream-streams.2 - (equalt (list (list *standard-input*)) - (multiple-value-list - (concatenated-stream-streams - (make-concatenated-stream *standard-input*)))) - t) - -(deftest concatenated-stream-streams.3 - (with-input-from-string - (s1 "abc") - (with-input-from-string - (s2 "def") - (let ((s (make-concatenated-stream s1 s2))) - (equalt (list (list s1 s2)) - (multiple-value-list - (concatenated-stream-streams s)))))) - t) - -(deftest concatenated-stream-streams.4 - (with-input-from-string - (s1 "") - (with-input-from-string - (s2 "def") - (let ((s (make-concatenated-stream s1 s2))) - (equalt (list (list s1 s2)) - (multiple-value-list - (concatenated-stream-streams s)))))) - t) - -(deftest concatenated-stream-streams.5 - (with-input-from-string - (s1 "") - (with-input-from-string - (s2 "def") - (let ((s (make-concatenated-stream s1 s2))) - (values - (read-char s) - (equalt (list (list s2)) - (multiple-value-list - (concatenated-stream-streams s))))))) - #\d t) - -;;; Error cases - -(deftest concatenated-stream-streams.error.1 - (signals-error (concatenated-stream-streams) program-error) - t) - -(deftest concatenated-stream-streams.error.2 - (signals-error (concatenated-stream-streams - (make-concatenated-stream) - nil) - program-error) - t) - - diff --git a/t/ansi-test/streams/echo-stream-input-stream.lsp b/t/ansi-test/streams/echo-stream-input-stream.lsp deleted file mode 100644 index bda8481..0000000 --- a/t/ansi-test/streams/echo-stream-input-stream.lsp +++ /dev/null @@ -1,27 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Feb 12 04:30:40 2004 -;;;; Contains: Tests of ECHO-STREAM-INPUT-STREAM - -(in-package :cl-test) - -(deftest echo-stream-input-stream.1 - (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-echo-stream is os))) - (equalt (multiple-value-list (echo-stream-input-stream s)) - (list is))) - t) - -(deftest echo-stream-input-stream.error.1 - (signals-error (echo-stream-input-stream) program-error) - t) - -(deftest echo-stream-input-stream.error.2 - (signals-error (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-echo-stream is os))) - (echo-stream-input-stream s nil)) - program-error) - t) - diff --git a/t/ansi-test/streams/echo-stream-output-stream.lsp b/t/ansi-test/streams/echo-stream-output-stream.lsp deleted file mode 100644 index f8dee38..0000000 --- a/t/ansi-test/streams/echo-stream-output-stream.lsp +++ /dev/null @@ -1,26 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Feb 12 04:32:33 2004 -;;;; Contains: Tests off ECHO-STREAM-OUTPUT-STREAM - -(in-package :cl-test) - -(deftest echo-stream-output-stream.1 - (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-echo-stream is os))) - (equalt (multiple-value-list (echo-stream-output-stream s)) - (list os))) - t) - -(deftest echo-stream-output-stream.error.1 - (signals-error (echo-stream-output-stream) program-error) - t) - -(deftest echo-stream-output-stream.error.2 - (signals-error (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-echo-stream is os))) - (echo-stream-output-stream s nil)) - program-error) - t) diff --git a/t/ansi-test/streams/file-length.lsp b/t/ansi-test/streams/file-length.lsp deleted file mode 100644 index 17e32a8..0000000 --- a/t/ansi-test/streams/file-length.lsp +++ /dev/null @@ -1,176 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Jan 21 06:21:11 2004 -;;;; Contains: Tests of FILE-LENGTH - -(in-package :cl-test) - -(deftest file-length.error.1 - (signals-error (file-length) program-error) - t) - -(deftest file-length.error.2 - (signals-error - (with-open-file (is "file-length.txt" :direction :input) - (file-length is nil)) - program-error) - t) - -(deftest file-length.error.3 - (loop for x in *mini-universe* - unless (or (typep x 'file-stream) - (typep x 'broadcast-stream) - (handler-case (progn (file-length x) nil) - (type-error (c) - (assert (not (typep x (type-error-expected-type c)))) - t) - (condition () nil))) - collect x) - nil) - -(deftest file-length.error.4 - :notes (:assume-no-simple-streams :assume-no-gray-streams) - (signals-error (with-input-from-string (s "abc") (file-length s)) - type-error) - t) - -(deftest file-length.error.5 - (signals-error - (with-open-file - (is "file-length.txt" :direction :input) - (with-open-file - (os "tmp.txt" :direction :output :if-exists :supersede) - (let ((s (make-two-way-stream is os))) - (unwind-protect (file-length s) (close s))))) - type-error) - t) - -(deftest file-length.error.6 - (signals-error - (with-open-file - (is "file-length.txt" :direction :input) - (with-open-file - (os "tmp.txt" :direction :output :if-exists :supersede) - (let ((s (make-echo-stream is os))) - (unwind-protect (file-length s) (close s))))) - type-error) - t) - -(deftest file-length.error.8 - (with-open-file - (os "tmp.txt" :direction :output :if-exists :supersede) - (let ((s (make-broadcast-stream os))) - (eqlt (file-length s) (file-length os)))) - t) - -(deftest file-length.error.9 - (signals-type-error s (make-concatenated-stream) - (unwind-protect (file-length s) (close s))) - t) - -(deftest file-length.error.10 - (signals-error - (with-open-file - (is "file-length.txt" :direction :input) - (let ((s (make-concatenated-stream is))) - (unwind-protect (file-length s) (close s)))) - type-error) - t) - -(deftest file-length.error.11 - :notes (:assume-no-simple-streams :assume-no-gray-streams) - (signals-type-error s (make-string-input-stream "abcde") - (unwind-protect (file-length s) (close s))) - t) - -(deftest file-length.error.12 - :notes (:assume-no-simple-streams :assume-no-gray-streams) - (signals-type-error s (make-string-output-stream) - (unwind-protect (file-length s) (close s))) - t) - -;;; Non-error tests - -(deftest file-length.1 - (let ((results (multiple-value-list - (with-open-file - (is "file-length.txt" :direction :input) - (file-length is))))) - (and (= (length results) 1) - (typep (car results) '(integer 1)) - t)) - t) - -(deftest file-length.2 - (loop for i from 1 to 32 - for etype = `(unsigned-byte ,i) - for e = (max 0 (- (ash 1 i) 5)) - for os = (open "tmp.dat" :direction :output - :if-exists :supersede - :element-type etype) - do (loop repeat 17 do (write-byte e os)) - do (finish-output os) - unless (= (file-length os) 17) - collect (list i (file-length os)) - do (close os)) - nil) - -(deftest file-length.3 - (loop for i from 1 to 32 - for etype = `(unsigned-byte ,i) - for e = (max 0 (- (ash 1 i) 5)) - for os = (open "tmp.dat" :direction :output - :if-exists :supersede - :element-type etype) - for len = 0 - do (loop repeat 17 do (write-byte e os)) - do (close os) - unless (let ((is (open "tmp.dat" :direction :input - :element-type etype))) - (prog1 - (= (file-length is) 17) - (close is))) - collect i) - nil) - -(deftest file-length.4 - (loop for i from 33 to 100 - for etype = `(unsigned-byte ,i) - for e = (max 0 (- (ash 1 i) 5)) - for os = (open "tmp.dat" :direction :output - :if-exists :supersede - :element-type etype) - do (loop repeat 17 do (write-byte e os)) - do (finish-output os) - unless (= (file-length os) 17) - collect (list i (file-length os)) - do (close os)) - nil) - -(deftest file-length.5 - (loop for i from 33 to 100 - for etype = `(unsigned-byte ,i) - for e = (max 0 (- (ash 1 i) 5)) - for os = (open "tmp.dat" :direction :output - :if-exists :supersede - :element-type etype) - for len = 0 - do (loop repeat 17 do (write-byte e os)) - do (close os) - unless (let ((is (open "tmp.dat" :direction :input - :element-type etype))) - (prog1 - (= (file-length is) 17) - (close is))) - collect i) - nil) - -(deftest file-length.6 - (with-open-file - (*foo* "file-length.txt" :direction :input) - (declare (special *foo*)) - (let ((s (make-synonym-stream '*foo*))) - (unwind-protect - (typep* (file-length s) '(integer 1)) - (close s)))) - t) diff --git a/t/ansi-test/streams/file-position.lsp b/t/ansi-test/streams/file-position.lsp deleted file mode 100644 index 6f26334..0000000 --- a/t/ansi-test/streams/file-position.lsp +++ /dev/null @@ -1,170 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Jan 22 03:02:31 2004 -;;;; Contains: Tests of FILE-POSITION - -(in-package :cl-test) - -(deftest file-position.1 - (with-open-file (is "file-position.txt":direction :input) - (file-position is)) - 0) - -(deftest file-position.2 - (with-open-file (is "file-position.txt":direction :input) - (values - (multiple-value-list - (notnot-mv (file-position is :start))) - (file-position is))) - - (t) 0) - -(deftest file-position.3 - (with-open-file (is "file-position.txt":direction :input) - (values - (multiple-value-list - (notnot-mv (file-position is :end))) - (notnot (> (file-position is) 0)))) - (t) t) - -(deftest file-position.4 - (with-open-file - (is "file-position.txt":direction :input) - (values - (file-position is) - (read-char is) - (notnot (> (file-position is) 0)))) - 0 #\; t) - -(deftest file-position.5 - (with-open-file - (os "tmp.dat":direction :output - :if-exists :supersede) - (values - (file-position os) - (write-char #\x os) - (notnot (> (file-position os) 0)))) - 0 #\x t) - -(deftest file-position.6 - (with-open-file - (os "tmp.dat":direction :output - :if-exists :supersede) - (let ((p1 (file-position os)) - (delta (file-string-length os #\x))) - (write-char #\x os) - (let ((p2 (file-position os))) - (or (null p1) (null p2) (null delta) - (=t (+ p1 delta) p2))))) - t) - -;;; Byte streams - -(deftest file-position.7 - (loop for len from 1 to 32 - for n = (ash 1 len) - do (with-open-file - (os "tmp.dat" :direction :output - :if-exists :supersede - :element-type `(unsigned-byte ,len)) - (loop for i from 0 below 100 - for r = (logand (1- n) i) - for pos = (file-position os) - do (assert (or (not pos) (eql pos i))) - do (write-byte r os))) - do (with-open-file - (is "tmp.dat" :direction :input - :element-type `(unsigned-byte ,len)) - (loop for i from 0 below 100 - for pos = (file-position is) - do (assert (or (not pos) (eql pos i))) - do (let ((byte (read-byte is))) - (assert (eql byte (logand (1- n) i))))))) - nil) - -(deftest file-position.8 - (loop for len from 33 to 100 - for n = (ash 1 len) - do (with-open-file - (os "tmp.dat" :direction :output - :if-exists :supersede - :element-type `(unsigned-byte ,len)) - (loop for i from 0 below 100 - for r = (logand (1- n) i) - for pos = (file-position os) - do (assert (or (not pos) (eql pos i))) - do (write-byte r os))) - do (with-open-file - (is "tmp.dat" :direction :input - :element-type `(unsigned-byte ,len)) - (loop for i from 0 below 100 - for pos = (file-position is) - do (assert (or (not pos) (eql pos i))) - do (let ((byte (read-byte is))) - (assert (eql byte (logand (1- n) i))))))) - nil) - -(deftest file-position.9 - (with-input-from-string - (s "abcdefghijklmnopqrstuvwxyz") - (loop repeat 26 - for p = (file-position s) - unless (or (not p) - (progn - (file-position s p) - (eql (file-position s) p))) - collect p - do (read-char s))) - nil) - -(deftest file-position.10 - (with-output-to-string - (s) - (loop repeat 26 - for p = (file-position s) - unless (or (not p) - (progn - (file-position s p) - (eql (file-position s) p))) - collect p - do (write-char #\x s))) - "xxxxxxxxxxxxxxxxxxxxxxxxxx") - -;;; Error tests - -(deftest file-position.error.1 - (signals-error (file-position) program-error) - t) - -(deftest file-position.error.2 - (signals-error - (file-position (make-string-input-stream "abc") :start nil) - program-error) - t) - -;;; It's not clear what 'too large' means -- can we set the -;;; file position to a point where the file may later be extended -;;; by some other writer? -#| -(deftest file-position.error.3 - (signals-error - (with-open-file - (is "file-position.txt" :direction :input) - (flet ((%fail () (error 'type-error))) - (unless (file-position is :end) (%fail)) - (let ((fp (file-position is))) - (unless fp (%fail)) - (file-position is (+ 1000000 fp))))) - error) - t) - -(deftest file-position.error.4 - (signals-error - (with-open-file - (is "file-position.txt" :direction :input) - (file-position is 1000000000000000000000)) - error) - t) -|# - - diff --git a/t/ansi-test/streams/file-string-length.lsp b/t/ansi-test/streams/file-string-length.lsp deleted file mode 100644 index a4d8c7c..0000000 --- a/t/ansi-test/streams/file-string-length.lsp +++ /dev/null @@ -1,73 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Jan 22 21:34:04 2004 -;;;; Contains: Tests of FILE-STRING-LENGTH - -(in-package :cl-test) - -(deftest file-string-length.1 - (with-open-file - (s "tmp.dat" :direction :output - :if-exists :supersede) - (loop for x across +standard-chars+ - for len = (file-string-length s x) - do (assert (typep len '(or null (integer 0)))) - do (let ((pos1 (file-position s))) - (write-char x s) - (let ((pos2 (file-position s))) - (when (and pos1 pos2 len) - (assert (= (+ pos1 len) pos2))))))) - nil) - -(deftest file-string-length.2 - (with-open-file - (s "tmp.dat" :direction :output - :if-exists :supersede) - (loop for x across +standard-chars+ - for len = (file-string-length s (string x)) - do (assert (typep len '(or null (integer 0)))) - do (let ((pos1 (file-position s))) - (write-sequence (string x) s) - (let ((pos2 (file-position s))) - (when (and pos1 pos2 len) - (assert (= (+ pos1 len) pos2))))))) - nil) - -(deftest file-string-length.3 - (with-open-file - (stream "tmp.dat" :direction :output - :if-exists :supersede) - (let* ((s1 "abcde") - (n (file-string-length stream s1))) - (do-special-strings - (s2 s1 nil) - (assert (= (file-string-length stream s2) n))))) - nil) - -;;; Error tests - -(deftest file-string-length.error.1 - (signals-error (file-string-length) program-error) - t) - -(deftest file-string-length.error.2 - (signals-error - (with-open-file - (s "tmp.dat" :direction :output - :if-exists :supersede) - (file-string-length s)) - program-error) - t) - -(deftest file-string-length.error.3 - (signals-error - (with-open-file - (s "tmp.dat" :direction :output - :if-exists :supersede) - (file-string-length s #\x nil)) - program-error) - t) - - - - diff --git a/t/ansi-test/streams/finish-output.lsp b/t/ansi-test/streams/finish-output.lsp deleted file mode 100644 index 4b398e9..0000000 --- a/t/ansi-test/streams/finish-output.lsp +++ /dev/null @@ -1,54 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Jan 28 06:38:20 2004 -;;;; Contains: Tests of FINISH-OUTPUT - -(in-package :cl-test) - -(deftest finish-output.1 - (finish-output) - nil) - -(deftest finish-output.2 - (finish-output t) - nil) - -(deftest finish-output.3 - (finish-output nil) - nil) - -(deftest finish-output.4 - (loop for s in (list *debug-io* *error-output* *query-io* - *standard-output* *trace-output* *terminal-io*) - for results = (multiple-value-list (finish-output s)) - unless (equal results '(nil)) - collect s) - nil) - -(deftest finish-output.5 - (let ((os (make-string-output-stream))) - (let ((*terminal-io* (make-two-way-stream (make-string-input-stream "") - os))) - (finish-output t))) - nil) - -(deftest finish-output.6 - (let ((*standard-output* (make-string-output-stream))) - (finish-output nil)) - nil) - -;;; Error tests - -(deftest finish-output.error.1 - (signals-error (finish-output nil nil) program-error) - t) - -(deftest finish-output.error.2 - (signals-error (finish-output t nil) program-error) - t) - -(deftest finish-output.error.3 - (check-type-error #'finish-output - #'(lambda (x) (typep x '(or stream (member nil t))))) - nil) - diff --git a/t/ansi-test/streams/force-output.lsp b/t/ansi-test/streams/force-output.lsp deleted file mode 100644 index 9ae066d..0000000 --- a/t/ansi-test/streams/force-output.lsp +++ /dev/null @@ -1,56 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Jan 28 06:41:46 2004 -;;;; Contains: Tests of FORCE-OUTPUT - -(in-package :cl-test) - -(deftest force-output.1 - (force-output) - nil) - -(deftest force-output.2 - (force-output t) - nil) - -(deftest force-output.3 - (force-output nil) - nil) - -(deftest force-output.4 - (loop for s in (list *debug-io* *error-output* *query-io* - *standard-output* *trace-output* *terminal-io*) - for results = (multiple-value-list (force-output s)) - unless (equal results '(nil)) - collect s) - nil) - -(deftest force-output.5 - (let ((os (make-string-output-stream))) - (let ((*terminal-io* (make-two-way-stream (make-string-input-stream "") - os))) - (force-output t))) - nil) - -(deftest force-output.6 - (let ((*standard-output* (make-string-output-stream))) - (force-output nil)) - nil) - - -;;; Error tests - -(deftest force-output.error.1 - (signals-error (force-output nil nil) program-error) - t) - -(deftest force-output.error.2 - (signals-error (force-output t nil) program-error) - t) - -(deftest force-output.error.3 - (check-type-error #'force-output - #'(lambda (x) (typep x '(or stream (member nil t))))) - nil) - - diff --git a/t/ansi-test/streams/fresh-line.lsp b/t/ansi-test/streams/fresh-line.lsp deleted file mode 100644 index b6e0690..0000000 --- a/t/ansi-test/streams/fresh-line.lsp +++ /dev/null @@ -1,87 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jan 18 20:41:18 2004 -;;;; Contains: Tests of FRESH-LINE - -(in-package :cl-test) - -(deftest fresh-line.1 - (let (result) - (values - (with-output-to-string - (*standard-output*) - (write-char #\a) - (setq result (notnot (fresh-line)))) - result)) - #.(concatenate 'string "a" (string #\Newline)) - t) - -(deftest fresh-line.2 - (let (result) - (values - (with-output-to-string - (s) - (write-char #\a s) - (setq result (notnot (fresh-line s)))) - result)) - #.(concatenate 'string "a" (string #\Newline)) - t) - -(deftest fresh-line.3 - (with-output-to-string - (s) - (write-char #\x s) - (fresh-line s) - (fresh-line s) - (write-char #\y s)) - #.(concatenate 'string "x" (string #\Newline) "y")) - -(deftest fresh-line.4 - (let (result) - (values - (with-output-to-string - (*standard-output*) - (setq result (multiple-value-list (fresh-line)))) - result)) - "" (nil)) - -(deftest fresh-line.5 - (let (result) - (values - (with-output-to-string - (s) - (write-char #\Space s) - (setq result - (list - (multiple-value-list (notnot-mv (fresh-line s))) - (multiple-value-list (fresh-line s)) - (multiple-value-list (fresh-line s))))) - result)) - " -" ((t) (nil) (nil))) - -(deftest fresh-line.6 - (with-output-to-string - (os) - (let ((*terminal-io* (make-two-way-stream *standard-input* os))) - (write-char #\a t) - (fresh-line t) - (finish-output t))) - #.(concatenate 'string (string #\a) (string #\Newline))) - -(deftest fresh-line.7 - (with-output-to-string - (*standard-output*) - (write-char #\a nil) - (terpri nil)) - #.(concatenate 'string (string #\a) (string #\Newline))) - -;;; Error tests - -(deftest fresh-line.error.1 - (signals-error - (with-output-to-string - (s) - (fresh-line s nil)) - program-error) - t) diff --git a/t/ansi-test/streams/get-output-stream-string.lsp b/t/ansi-test/streams/get-output-stream-string.lsp deleted file mode 100644 index 7fc390c..0000000 --- a/t/ansi-test/streams/get-output-stream-string.lsp +++ /dev/null @@ -1,32 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Feb 14 09:48:46 2004 -;;;; Contains: Tests of GET-OUTPUT-STREAM-STRING - -(in-package :cl-test) - -;; this function is used extensively elsewhere in the test suite - -(deftest get-output-stream-string.1 - (let ((s (make-string-output-stream))) - (values - (get-output-stream-string s) - (write-string "abc" s) - (write-string "def" s) - (get-output-stream-string s) - (get-output-stream-string s))) - "" "abc" "def" "abcdef" "") - -;;; Error cases - -(deftest get-output-stream-string.error.1 - (signals-error (get-output-stream-string) t) - t) - -(deftest get-output-stream-string.error.2 - (signals-error (get-output-stream-string (make-string-output-stream) nil) t) - t) - - - - diff --git a/t/ansi-test/streams/input-stream-p.lsp b/t/ansi-test/streams/input-stream-p.lsp deleted file mode 100644 index cc2aa11..0000000 --- a/t/ansi-test/streams/input-stream-p.lsp +++ /dev/null @@ -1,40 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Jan 13 19:39:27 2004 -;;;; Contains: Tests for INPUT-STREAM-P - -(in-package :cl-test) - -(deftest input-stream-p.1 - (notnot-mv (input-stream-p *standard-input*)) - t) - -(deftest input-stream-p.2 - (notnot-mv (input-stream-p *terminal-io*)) - t) - -(deftest input-stream-p.3 - (with-open-file (s "input-stream-p.txt" :direction :input) - (notnot-mv (input-stream-p s))) - t) - -(deftest input-stream-p.4 - (with-open-file (s "scratch/foo.txt" :direction :output - :if-exists :supersede) - (input-stream-p s)) - nil) - -;;; Error tests - -(deftest input-stream-p.error.1 - (signals-error (input-stream-p) program-error) - t) - -(deftest input-stream-p.error.2 - (signals-error (input-stream-p *standard-input* nil) - program-error) - t) - -(deftest input-stream-p.error.3 - (check-type-error #'input-stream-p #'streamp) - nil) diff --git a/t/ansi-test/streams/interactive-stream-p.lsp b/t/ansi-test/streams/interactive-stream-p.lsp deleted file mode 100644 index 2b497d7..0000000 --- a/t/ansi-test/streams/interactive-stream-p.lsp +++ /dev/null @@ -1,28 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Jan 13 19:47:59 2004 -;;;; Contains: Tests of INTERACTIVE-STREAM-P - -(in-package :cl-test) - -(deftest interactive-stream-p.1 - (let ((streams (list *debug-io* *error-output* *query-io* - *standard-input* *standard-output* - *trace-output* *terminal-io*))) - (mapc #'interactive-stream-p streams) - ;; no error should occur - nil) - nil) - -(deftest interactive-stream-p.error.1 - (check-type-error #'interactive-stream-p #'streamp) - nil) - -(deftest interactive-stream-p.error.2 - (signals-error (interactive-stream-p) program-error) - t) - -(deftest interactive-stream-p.error.3 - (signals-error (interactive-stream-p *terminal-io* nil) - program-error) - t) diff --git a/t/ansi-test/streams/listen.lsp b/t/ansi-test/streams/listen.lsp deleted file mode 100644 index e505372..0000000 --- a/t/ansi-test/streams/listen.lsp +++ /dev/null @@ -1,73 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Jan 27 21:16:39 2004 -;;;; Contains: Tests of LISTEN - -(in-package :cl-test) - -(deftest listen.1 - (with-input-from-string (s "") (listen s)) - nil) - -(deftest listen.2 - (with-input-from-string (s "x") (notnot-mv (listen s))) - t) - -(deftest listen.3 - (with-input-from-string (*standard-input* "") (listen)) - nil) - -(deftest listen.4 - (with-input-from-string (*standard-input* "A") (notnot-mv (listen))) - t) - -;;; (deftest listen.5 -;;; (when (interactive-stream-p *standard-input*) -;;; (clear-input) (listen)) -;;; nil) - -(deftest listen.6 - (with-input-from-string - (s "x") - (values - (read-char s) - (listen s) - (unread-char #\x s) - (notnot (listen s)) - (read-char s))) - #\x nil nil t #\x) - -(deftest listen.7 - (with-open-file - (s "listen.txt") - (values - (notnot (listen s)) - (handler-case - (locally (declare (optimize safety)) - (loop (read-char s))) - (end-of-file () (listen s))))) - t nil) - -(deftest listen.8 - (with-input-from-string - (is "abc") - (let ((*terminal-io* (make-two-way-stream is (make-broadcast-stream)))) - (notnot-mv (listen t)))) - t) - -(deftest listen.9 - (with-input-from-string - (*standard-input* "345") - (notnot-mv (listen nil))) - t) - -;;; Error tests - -(deftest listen.error.1 - :notes (:assume-no-simple-streams) - (signals-error (listen *standard-input* nil) program-error) - t) - -(deftest listen.error.2 - (signals-error (listen *standard-input* nil nil) program-error) - t) diff --git a/t/ansi-test/streams/load.lsp b/t/ansi-test/streams/load.lsp deleted file mode 100644 index 0e10f94..0000000 --- a/t/ansi-test/streams/load.lsp +++ /dev/null @@ -1,60 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Jan 13 19:38:10 2004 -;;;; Contains: Load files containing tests for section 21 (streams) - -(in-package #:cl-test) - -(let ((*default-pathname-defaults* - (make-pathname - :directory (pathname-directory *load-pathname*)))) - (load "input-stream-p.lsp") - (load "output-stream-p.lsp") - (load "interactive-stream-p.lsp") - (load "open-stream-p.lsp") - (load "stream-element-type.lsp") - (load "streamp.lsp") - (load "read-byte.lsp") - (load "peek-char.lsp") - (load "read-char.lsp") - (load "read-char-no-hang.lsp") - (load "terpri.lsp") - (load "fresh-line.lsp") - (load "unread-char.lsp") - (load "write-char.lsp") - (load "read-line.lsp") - (load "write-string.lsp") - (load "write-line.lsp") - (load "read-sequence.lsp") - (load "write-sequence.lsp") - (load "file-length.lsp") - (load "file-position.lsp") - (load "file-string-length.lsp") - (load "open.lsp") - (load "stream-external-format.lsp") - (load "with-open-file.lsp") - (load "with-open-stream.lsp") - (load "listen.lsp") - (load "clear-input.lsp") - (load "finish-output.lsp") - (load "force-output.lsp") - (load "clear-output.lsp") - (load "make-synonym-stream.lsp") - (load "synonym-stream-symbol.lsp") - (load "make-broadcast-stream.lsp") - (load "broadcast-stream-streams.lsp") - (load "make-two-way-stream.lsp") - (load "two-way-stream-input-stream.lsp") - (load "two-way-stream-output-stream.lsp") - (load "echo-stream-input-stream.lsp") - (load "echo-stream-output-stream.lsp") - (load "make-echo-stream.lsp") - (load "concatenated-stream-streams.lsp") - (load "make-concatenated-stream.lsp") - (load "get-output-stream-string.lsp") - (load "make-string-input-stream.lsp") - (load "make-string-output-stream.lsp") - (load "with-input-from-string.lsp") - (load "with-output-to-string.lsp") - (load "stream-error-stream.lsp") -) diff --git a/t/ansi-test/streams/make-broadcast-stream.lsp b/t/ansi-test/streams/make-broadcast-stream.lsp deleted file mode 100644 index 90b382e..0000000 --- a/t/ansi-test/streams/make-broadcast-stream.lsp +++ /dev/null @@ -1,99 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Jan 29 21:28:25 2004 -;;;; Contains: Tests of MAKE-BROADCAST-STREAM - -(in-package :cl-test) - -(deftest make-broadcast-stream.1 - (let ((s (make-broadcast-stream))) - (assert (typep s 'stream)) - (assert (typep s 'broadcast-stream)) - (assert (output-stream-p s)) - ;; (assert (not (input-stream-p s))) - (assert (open-stream-p s)) - (assert (streamp s)) - ;; (assert (eq (stream-element-type s) t)) - (values - (notnot (typep s 'stream)) - (notnot (typep s 'broadcast-stream)) - (notnot (output-stream-p s)) - (progn (write-char #\x s) nil) - )) - t t t nil) - -(deftest make-broadcast-stream.2 - (with-output-to-string - (s1) - (let ((s (make-broadcast-stream s1))) - (assert (typep s 'stream)) - (assert (typep s 'broadcast-stream)) - (assert (output-stream-p s)) - ;; (assert (not (input-stream-p s))) - (assert (open-stream-p s)) - (assert (streamp s)) - (assert (eql (stream-element-type s) - (stream-element-type s1))) - (write-char #\x s))) - "x") - -(deftest make-broadcast-stream.3 - (let ((s1 (make-string-output-stream)) - (s2 (make-string-output-stream))) - (let ((s (make-broadcast-stream s1 s2))) - (assert (typep s 'stream)) - (assert (typep s 'broadcast-stream)) - (assert (output-stream-p s)) - ;; (assert (not (input-stream-p s))) - (assert (open-stream-p s)) - (assert (streamp s)) - (assert (eql (stream-element-type s) - (stream-element-type s2))) - (format s "This is a test")) - (values - (get-output-stream-string s1) - (get-output-stream-string s2))) - "This is a test" - "This is a test") - -(deftest make-broadcast-stream.4 - (fresh-line (make-broadcast-stream)) - nil) - -(deftest make-broadcast-stream.5 - (file-length (make-broadcast-stream)) - 0) - -(deftest make-broadcast-stream.6 - (file-position (make-broadcast-stream)) - 0) - -(deftest make-broadcast-stream.7 - (file-string-length (make-broadcast-stream) "antidisestablishmentarianism") - 1) - -(deftest make-broadcast-stream.8 - (stream-external-format (make-broadcast-stream)) - :default) - - - -;;; FIXME -;;; Add tests for: close, -;;; peek-char, read-char-no-hang, terpri, fresh-line, unread-char, -;;; read-line, write-line, write-string, read-sequence, write-sequence, -;;; read-byte, write-byte, listen, clear-input, finish-output, force-output, -;;; clear-output, print, prin1 princ - -;;; Error tests - -(deftest make-broadcast-stream.error.1 - (check-type-error #'make-broadcast-stream - #'(lambda (x) (and (streamp x) (output-stream-p x)))) - nil) - -(deftest make-broadcast-stream.error.2 - (check-type-error #'make-broadcast-stream - #'(lambda (x) (and (streamp x) (output-stream-p x))) - *streams*) - nil) diff --git a/t/ansi-test/streams/make-concatenated-stream.lsp b/t/ansi-test/streams/make-concatenated-stream.lsp deleted file mode 100644 index ce6f6a6..0000000 --- a/t/ansi-test/streams/make-concatenated-stream.lsp +++ /dev/null @@ -1,323 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Feb 14 08:41:18 2004 -;;;; Contains: Tests of MAKE-CONCATENATED-STREAM - -(in-package :cl-test) - -(deftest make-concatenated-stream.1 - (let ((s (make-concatenated-stream))) - (read s nil :eof)) - :eof) - -(deftest make-concatenated-stream.2 - (let ((s (make-concatenated-stream))) - (notnot-mv (input-stream-p s))) - t) - -(deftest make-concatenated-stream.3 - (let ((s (make-concatenated-stream))) - (output-stream-p s)) - nil) - -(deftest make-concatenated-stream.4 - (let ((s (make-concatenated-stream))) - (notnot-mv (streamp s))) - t) - -(deftest make-concatenated-stream.5 - (let ((s (make-concatenated-stream))) - (notnot-mv (typep s 'stream))) - t) - -(deftest make-concatenated-stream.6 - (let ((s (make-concatenated-stream))) - (notnot-mv (typep s 'concatenated-stream))) - t) - -(deftest make-concatenated-stream.7 - (let ((s (make-concatenated-stream))) - (notnot-mv (open-stream-p s))) - t) - -(deftest make-concatenated-stream.8 - (let ((s (make-concatenated-stream *standard-input*))) - (notnot-mv (stream-element-type s))) - t) - -(deftest make-concatenated-stream.9 - (let ((pn #p"tmp.dat") - (element-type '(unsigned-byte 8))) - (with-open-file (s pn :direction :output :element-type element-type - :if-exists :supersede) - (dolist (b '(1 5 9 13)) (write-byte b s))) - (with-open-file - (s1 pn :direction :input :element-type element-type) - (with-open-file - (s2 pn :direction :input :element-type element-type) - (let ((s (make-concatenated-stream s1 s2))) - (loop repeat 8 collect (read-byte s)))))) - (1 5 9 13 1 5 9 13)) - -(deftest make-concatenated-stream.10 - (let ((s (make-concatenated-stream))) - (read-byte s nil :eof)) - :eof) - -(deftest make-concatenated-stream.11 - (let ((s (make-concatenated-stream))) - (peek-char nil s nil :eof)) - :eof) - -(deftest make-concatenated-stream.12 - (with-input-from-string - (s1 "a") - (with-input-from-string - (s2 "b") - (let ((s (make-concatenated-stream s1 s2))) - (values - (peek-char nil s) - (read-char s) - (peek-char nil s) - (read-char s) - (peek-char nil s nil :eof))))) - #\a #\a #\b #\b :eof) - -(deftest make-concatenated-stream.13 - (with-input-from-string - (s1 " a ") - (with-input-from-string - (s2 " b ") - (let ((s (make-concatenated-stream s1 s2))) - (values - (peek-char t s) - (read-char s) - (peek-char t s) - (read-char s) - (peek-char t s nil :eof))))) - #\a #\a #\b #\b :eof) - -(deftest make-concatenated-stream.14 - (with-input-from-string - (s1 "a") - (with-input-from-string - (s2 "b") - (let ((s (make-concatenated-stream s1 s2))) - (values - (read-char s) - (unread-char #\a s) - (read-char s) - (read-char s) - (unread-char #\b s) - (read-char s) - (read-char s nil :eof))))) - #\a nil #\a #\b nil #\b :eof) - -(deftest make-concatenated-stream.15 - (let ((s (make-concatenated-stream))) - (read-char-no-hang s nil :eof)) - :eof) - -(deftest make-concatenated-stream.16 - (with-input-from-string - (s1 "a") - (with-input-from-string - (s2 "b") - (let ((s (make-concatenated-stream s1 s2))) - (values - (read-char-no-hang s) - (read-char-no-hang s) - (read-char-no-hang s nil :eof))))) - #\a #\b :eof) - -(deftest make-concatenated-stream.17 - (with-input-from-string - (s1 "a") - (with-input-from-string - (s2 "b") - (let ((s (make-concatenated-stream s1 s2))) - (multiple-value-bind (str mnp) - (read-line s) - (values str (notnot mnp)))))) - "ab" t) - -(deftest make-concatenated-stream.18 - (with-input-from-string - (s1 "ab") - (with-input-from-string - (s2 "") - (let ((s (make-concatenated-stream s1 s2))) - (multiple-value-bind (str mnp) - (read-line s) - (values str (notnot mnp)))))) - "ab" t) - -(deftest make-concatenated-stream.19 - (with-input-from-string - (s1 "") - (with-input-from-string - (s2 "ab") - (let ((s (make-concatenated-stream s1 s2))) - (multiple-value-bind (str mnp) - (read-line s) - (values str (notnot mnp)))))) - "ab" t) - -(deftest make-concatenated-stream.20 - (with-input-from-string - (s1 "ab") - (with-input-from-string - (s2 (concatenate 'string (string #\Newline) "def")) - (let ((s (make-concatenated-stream s1 s2))) - (read-line s)))) - "ab" nil) - -(deftest make-concatenated-stream.21 - (with-input-from-string - (s1 "") - (with-input-from-string - (s2 "") - (let ((s (make-concatenated-stream s1 s2))) - (multiple-value-bind (str mnp) - (read-line s nil :eof) - (values str (notnot mnp)))))) - :eof t) - -(deftest make-concatenated-stream.22 - (let ((pn #p"tmp.dat") - (element-type '(unsigned-byte 8))) - (with-open-file (s pn :direction :output :element-type element-type - :if-exists :supersede) - (dolist (b '(1 5 9 13)) (write-byte b s))) - (with-open-file - (s1 pn :direction :input :element-type element-type) - (with-open-file - (s2 pn :direction :input :element-type element-type) - (let ((s (make-concatenated-stream s1 s2)) - (x (vector nil nil nil nil nil nil nil nil))) - (values - (read-sequence x s) - x))))) - 8 - #(1 5 9 13 1 5 9 13)) - -(deftest make-concatenated-stream.23 - (let ((pn #p"tmp.dat") - (element-type '(unsigned-byte 8))) - (with-open-file (s pn :direction :output :element-type element-type - :if-exists :supersede) - (dolist (b '(1 5 9 13)) (write-byte b s))) - (with-open-file - (s1 pn :direction :input :element-type element-type) - (with-open-file - (s2 pn :direction :input :element-type element-type) - (let ((s (make-concatenated-stream s1 s2)) - (x (vector nil nil nil nil nil nil))) - (values - (read-sequence x s) - x))))) - 6 - #(1 5 9 13 1 5)) - -(deftest make-concatenated-stream.24 - (let ((pn #p"tmp.dat") - (element-type '(unsigned-byte 8))) - (with-open-file (s pn :direction :output :element-type element-type - :if-exists :supersede) - (dolist (b '(1 5 9 13)) (write-byte b s))) - (with-open-file - (s1 pn :direction :input :element-type element-type) - (with-open-file - (s2 pn :direction :input :element-type element-type) - (let ((s (make-concatenated-stream s1 s2)) - (x (vector nil nil nil nil nil nil nil nil nil nil))) - (values - (read-sequence x s) - x))))) - 8 - #(1 5 9 13 1 5 9 13 nil nil)) - -(deftest make-concatenated-stream.25 - (close (make-concatenated-stream)) - t) - -(deftest make-concatenated-stream.26 - (let ((s (make-concatenated-stream))) - (values (prog1 (close s) (close s)) - (open-stream-p s))) - t nil) - -(deftest make-concatenated-stream.27 - (with-input-from-string - (s1 "abc") - (let ((s (make-concatenated-stream s1))) - (values - (notnot (open-stream-p s1)) - (notnot (open-stream-p s)) - (close s) - (notnot (open-stream-p s1)) - (open-stream-p s)))) - t t t t nil) - -(deftest make-concatenated-stream.28 - (with-input-from-string - (s1 "a") - (let ((s (make-concatenated-stream s1))) - (notnot-mv (listen s)))) - t) - -(deftest make-concatenated-stream.28a - (listen (make-concatenated-stream)) - nil) - -(deftest make-concatenated-stream.29 - (with-input-from-string - (s1 "") - (let ((s (make-concatenated-stream s1))) - (listen s))) - nil) - -(deftest make-concatenated-stream.30 - (with-input-from-string - (s1 "") - (with-input-from-string - (s2 "a") - (let ((s (make-concatenated-stream s1 s2))) - (notnot-mv (listen s))))) - t) - -(deftest make-concatenated-stream.31 - (with-input-from-string - (s1 "") - (with-input-from-string - (s2 "") - (let ((s (make-concatenated-stream s1 s2))) - (listen s)))) - nil) - -(deftest make-concatenated-stream.32 - (clear-input (make-concatenated-stream)) - nil) - -(deftest make-concatenated-stream.33 - (with-input-from-string - (s1 "abc") - (clear-input (make-concatenated-stream s1))) - nil) - -;;; Error cases - -(deftest make-concatenated-stream.error.1 - (loop for x in *mini-universe* - unless (or (and (streamp x) (input-stream-p x)) - (eval `(signals-error (make-concatenated-stream ',x) t))) - collect x) - nil) - -(deftest make-concatenated-stream.error.2 - (loop for x in *streams* - unless (or (and (streamp x) (input-stream-p x)) - (eval `(signals-error (make-concatenated-stream ',x) t))) - collect x) - nil) - diff --git a/t/ansi-test/streams/make-echo-stream.lsp b/t/ansi-test/streams/make-echo-stream.lsp deleted file mode 100644 index 8d73cea..0000000 --- a/t/ansi-test/streams/make-echo-stream.lsp +++ /dev/null @@ -1,332 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Feb 12 04:34:42 2004 -;;;; Contains: Tests of MAKE-ECHO-STREAM - -(in-package :cl-test) - -(deftest make-echo-stream.1 - (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-echo-stream is os))) - (values - (read-char s) - (get-output-stream-string os))) - #\f "f") - -(deftest make-echo-stream.2 - (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-echo-stream is os))) - (get-output-stream-string os)) - "") - -(deftest make-echo-stream.3 - (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-echo-stream is os))) - (values (read-line s nil) - (get-output-stream-string os))) - "foo" "foo") - -;;; Tests of READ-BYTE on echo streams - -(deftest make-echo-stream.4 - (let ((pn #p"tmp.dat") - (pn2 #p"tmp2.dat") - (element-type '(unsigned-byte 8))) - (with-open-file (os pn - :direction :output - :element-type element-type - :if-exists :supersede) - (loop for x in '(2 3 5 7 11) - do (write-byte x os))) - (with-open-file - (is pn :direction :input :element-type element-type) - (values - (with-open-file - (os pn2 :direction :output :if-exists :supersede - :element-type element-type) - (let ((s (make-echo-stream is os))) - (loop repeat 6 collect (read-byte s nil :eof1)))) - (with-open-file - (s pn2 :direction :input :element-type element-type) - (loop repeat 6 collect (read-byte s nil :eof2)))))) - (2 3 5 7 11 :eof1) - (2 3 5 7 11 :eof2)) - -(deftest make-echo-stream.5 - (let ((pn #p"tmp.dat") - (pn2 #p"tmp2.dat") - (element-type '(unsigned-byte 8))) - (with-open-file (os pn - :direction :output - :element-type element-type - :if-exists :supersede) - (loop for x in '(2 3 5 7 11) - do (write-byte x os))) - (with-open-file - (is pn :direction :input :element-type element-type) - (values - (with-open-file - (os pn2 :direction :output :if-exists :supersede - :element-type element-type) - (let ((s (make-echo-stream is os))) - (loop repeat 6 collect (read-byte s nil 100)))) - (with-open-file - (s pn2 :direction :input :element-type element-type) - (loop repeat 6 collect (read-byte s nil 200)))))) - (2 3 5 7 11 100) - (2 3 5 7 11 200)) - -(deftest make-echo-stream.6 - (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-echo-stream is os))) - (values (coerce (loop repeat 3 collect (read-char-no-hang s)) 'string) - (get-output-stream-string os))) - "foo" "foo") - -(deftest make-echo-stream.7 - (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-echo-stream is os))) - (values (coerce (loop repeat 4 collect (read-char-no-hang s nil '#\z)) - 'string) - (get-output-stream-string os))) - "fooz" "foo") - -;;; peek-char + echo streams is tested in peek-char.lsp -;;; unread-char + echo streams is tested in unread-char.lsp - -(deftest make-echo-stream.8 - (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-echo-stream is os)) - (x (copy-seq "xxxxxx"))) - (values - (read-sequence x s) - x - (get-output-stream-string os))) - 3 - "fooxxx" - "foo") - -(deftest make-echo-stream.9 - (let ((pn #p"tmp.dat") - (pn2 #p"tmp2.dat") - (element-type '(unsigned-byte 8))) - (with-open-file (os pn - :direction :output - :element-type element-type - :if-exists :supersede) - (loop for x in '(2 3 5 7 11) - do (write-byte x os))) - (with-open-file - (is pn :direction :input :element-type element-type) - (values - (with-open-file - (os pn2 :direction :output :if-exists :supersede - :element-type element-type) - (let ((s (make-echo-stream is os)) - (x (vector 0 0 0 0 0 0 0 0))) - (list (read-sequence x s) - x))) - (with-open-file - (s pn2 :direction :input :element-type element-type) - (loop repeat 8 collect (read-byte s nil nil)))))) - (5 #(2 3 5 7 11 0 0 0)) - (2 3 5 7 11 nil nil nil)) - -(deftest make-echo-stream.10 - (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-echo-stream is os))) - (values - (notnot (open-stream-p s)) - (close s) - (open-stream-p s) - (notnot (open-stream-p is)) - (notnot (open-stream-p os)))) - t t nil t t) - -(deftest make-echo-stream.11 - (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-echo-stream is os))) - (values - (notnot (listen s)) - (read-char s) - (notnot (listen s)) - (read-char s) - (notnot (listen s)) - (read-char s) - (listen s))) - t #\f t #\o t #\o nil) - -(deftest make-echo-stream.12 - (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-echo-stream is os))) - (values - (notnot (streamp s)) - (notnot (typep s 'stream)) - (notnot (typep s 'echo-stream)) - (notnot (input-stream-p s)) - (notnot (output-stream-p s)) - (notnot (stream-element-type s)))) - t t t t t t) - -;;; FIXME -;;; Add tests for clear-input, file-position(?) -;;; Also, add tests for output operations (since echo-streams are -;;; bidirectional) - -(deftest make-echo-stream.13 - (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-echo-stream is os))) - (values - (write-char #\0 s) - (close s) - (get-output-stream-string os))) - #\0 t "0") - -(deftest make-echo-stream.14 - (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-echo-stream is os))) - (values - (terpri s) - (close s) - (get-output-stream-string os))) - nil t #.(string #\Newline)) - -(deftest make-echo-stream.15 - (let ((pn #p"tmp.dat") - (pn2 #p"tmp2.dat") - (element-type '(unsigned-byte 8))) - (with-open-file (os pn - :direction :output - :element-type element-type - :if-exists :supersede)) - (with-open-file - (is pn :direction :input :element-type element-type) - (values - (with-open-file - (os pn2 :direction :output :if-exists :supersede - :element-type element-type) - (let ((s (make-echo-stream is os)) - (x (mapcar #'char-code (coerce "abcdefg" 'list)))) - (loop for b in x do - (assert (equal (list b) - (multiple-value-list (write-byte b s))))) - (close s))))) - (with-open-file - (is pn2 :direction :input :element-type element-type) - (let ((x (vector 0 0 0 0 0 0 0))) - (read-sequence x is) - (values - (read-byte is nil :done) - (map 'string #'code-char x))))) - :done - "abcdefg") - -(deftest make-echo-stream.16 - (let ((pn #p"tmp.dat") - (pn2 #p"tmp2.dat") - (element-type '(unsigned-byte 8))) - (with-open-file (os pn - :direction :output - :element-type element-type - :if-exists :supersede)) - (with-open-file - (is pn :direction :input :element-type element-type) - (values - (with-open-file - (os pn2 :direction :output :if-exists :supersede - :element-type element-type) - (let ((s (make-echo-stream is os)) - (x (map 'vector #'char-code "abcdefg"))) - (assert (equal (multiple-value-list (write-sequence x s)) (list x))) - (close s))))) - (with-open-file - (is pn2 :direction :input :element-type element-type) - (let ((x (vector 0 0 0 0 0 0 0))) - (read-sequence x is) - (values - (read-byte is nil :done) - (map 'string #'code-char x))))) - :done - "abcdefg") - -(deftest make-echo-stream.17 - (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-echo-stream is os))) - (values - (write-char #\X s) - (notnot (fresh-line s)) - (finish-output s) - (force-output s) - (close s) - (get-output-stream-string os))) - #\X t nil nil t #.(coerce '(#\X #\Newline) 'string)) - -(deftest make-echo-stream.18 - (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-echo-stream is os))) - (values - (write-string "159" s) - (close s) - (get-output-stream-string os))) - "159" t "159") - -(deftest make-echo-stream.20 - (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-echo-stream is os))) - (values - (write-string "0159X" s :start 1 :end 4) - (close s) - (get-output-stream-string os))) - "0159X" t "159") - -(deftest make-echo-stream.21 - (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-echo-stream is os))) - (values - (write-line "159" s) - (close s) - (get-output-stream-string os))) - "159" t #.(concatenate 'string "159" (string #\Newline))) - -(deftest make-echo-stream.22 - (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-echo-stream is os))) - (values - (write-char #\0 s) - (clear-output s))) - #\0 nil) - -;;; Error tests - -(deftest make-echo-stream.error.1 - (signals-error (make-echo-stream) program-error) - t) - -(deftest make-echo-stream.error.2 - (signals-error (make-echo-stream *standard-input*) program-error) - t) - -(deftest make-echo-stream.error.3 - (signals-error (make-echo-stream *standard-input* *standard-output* nil) - program-error) - t) - - - - diff --git a/t/ansi-test/streams/make-string-input-stream.lsp b/t/ansi-test/streams/make-string-input-stream.lsp deleted file mode 100644 index 63ca250..0000000 --- a/t/ansi-test/streams/make-string-input-stream.lsp +++ /dev/null @@ -1,93 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Feb 14 18:36:48 2004 -;;;; Contains: Tests for MAKE-STRING-INPUT-STREAM - -(in-package :cl-test) - -(deftest make-string-input-stream.1 - (let ((s (make-string-input-stream ""))) - (values - (notnot (typep s 'stream)) - (notnot (streamp s)) - (notnot (input-stream-p s)) - (output-stream-p s))) - t t t nil) - -(deftest make-string-input-stream.2 - (let ((s (make-string-input-stream "abcd"))) - (values - (notnot (typep s 'stream)) - (notnot (streamp s)) - (notnot (input-stream-p s)) - (output-stream-p s))) - t t t nil) - - -(deftest make-string-input-stream.3 - (let ((s (make-string-input-stream "abcd" 1))) - (values (read-line s))) - "bcd") - - -(deftest make-string-input-stream.4 - (let ((s (make-string-input-stream "abcd" 0 2))) - (values (read-line s))) - "ab") - -(deftest make-string-input-stream.5 - (let ((s (make-string-input-stream "abcd" 1 nil))) - (values (read-line s))) - "bcd") - -(deftest make-string-input-stream.6 - (let ((str1 (make-array 6 :element-type 'character - :initial-contents "abcdef" - :fill-pointer 4))) - (let ((s (make-string-input-stream str1))) - (values (read-line s) (read-char s nil :eof)))) - "abcd" :eof) - -(deftest make-string-input-stream.7 - (let* ((str1 (make-array 6 :element-type 'character - :initial-contents "abcdef")) - (str2 (make-array 4 :element-type 'character - :displaced-to str1))) - (let ((s (make-string-input-stream str2))) - (values (read-line s) (read-char s nil :eof)))) - "abcd" :eof) - -(deftest make-string-input-stream.8 - (let* ((str1 (make-array 6 :element-type 'character - :initial-contents "abcdef")) - (str2 (make-array 4 :element-type 'character - :displaced-to str1 - :displaced-index-offset 1))) - (let ((s (make-string-input-stream str2))) - (values (read-line s) (read-char s nil :eof)))) - "bcde" :eof) - -(deftest make-string-input-stream.9 - (let ((str1 (make-array 6 :element-type 'character - :initial-contents "abcdef" - :adjustable t))) - (let ((s (make-string-input-stream str1))) - (values (read-line s) (read-char s nil :eof)))) - "abcdef" :eof) - -(deftest make-string-input-stream.10 - :notes (:allow-nil-arrays :nil-vectors-are-strings) - (let ((s (make-string-input-stream - (make-array 0 :element-type nil)))) - (read-char s nil :eof)) - :eof) - -;;; Error tests - -(deftest make-string-input-stream.error.1 - (signals-error (make-string-input-stream) program-error) - t) - -(deftest make-string-input-stream.error.2 - (signals-error (make-string-input-stream "abc" 1 2 nil) program-error) - t) diff --git a/t/ansi-test/streams/make-string-output-stream.lsp b/t/ansi-test/streams/make-string-output-stream.lsp deleted file mode 100644 index 42c5664..0000000 --- a/t/ansi-test/streams/make-string-output-stream.lsp +++ /dev/null @@ -1,139 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Feb 14 19:42:07 2004 -;;;; Contains: Tests of MAKE-STRING-OUTPUT-STREAM - -(in-package :cl-test) - -(deftest make-string-output-stream.1 - (let ((s (make-string-output-stream))) - (values - (notnot (typep s 'stream)) - (notnot (typep s 'string-stream)) - (input-stream-p s) - (notnot (output-stream-p s)) - (notnot (open-stream-p s)))) - t t nil t t) - -(deftest make-string-output-stream.2 - (let ((s (make-string-output-stream :element-type 'character))) - (values - (notnot (typep s 'stream)) - (notnot (typep s 'string-stream)) - (input-stream-p s) - (notnot (output-stream-p s)) - (notnot (open-stream-p s)))) - t t nil t t) - -(deftest make-string-output-stream.3 - (let ((s (make-string-output-stream :element-type 'base-char))) - (values - (notnot (typep s 'stream)) - (notnot (typep s 'string-stream)) - (input-stream-p s) - (notnot (output-stream-p s)) - (notnot (open-stream-p s)))) - t t nil t t) - -(deftest make-string-output-stream.4 - :notes (:nil-vectors-are-strings) - (let ((s (make-string-output-stream :element-type nil))) - (values - (notnot (typep s 'stream)) - (notnot (typep s 'string-stream)) - (input-stream-p s) - (notnot (output-stream-p s)) - (notnot (open-stream-p s)))) - t t nil t t) - -(deftest make-string-output-stream.5 - (let ((s (make-string-output-stream :allow-other-keys nil))) - (values - (notnot (typep s 'stream)) - (notnot (typep s 'string-stream)) - (input-stream-p s) - (notnot (output-stream-p s)) - (notnot (open-stream-p s)))) - t t nil t t) - -(deftest make-string-output-stream.6 - (let ((s (make-string-output-stream :allow-other-keys t :foo 'bar))) - (values - (notnot (typep s 'stream)) - (notnot (typep s 'string-stream)) - (input-stream-p s) - (notnot (output-stream-p s)) - (notnot (open-stream-p s)))) - t t nil t t) - -(deftest make-string-output-stream.7 - (let ((s (make-string-output-stream :foo 'bar :allow-other-keys t - :allow-other-keys nil - :foo2 'x))) - (values - (notnot (typep s 'stream)) - (notnot (typep s 'string-stream)) - (input-stream-p s) - (notnot (output-stream-p s)) - (notnot (open-stream-p s)))) - t t nil t t) - -(deftest make-string-output-stream.8 - (let ((s (make-string-output-stream))) - (write-string "abc" s) - (write-string "def" s) - (get-output-stream-string s)) - "abcdef") - -(deftest make-string-output-stream.9 - (let ((s (make-string-output-stream :element-type 'character))) - (write-string "abc" s) - (write-string "def" s) - (get-output-stream-string s)) - "abcdef") - -(deftest make-string-output-stream.10 - (let ((s (make-string-output-stream :element-type 'base-char))) - (write-string "abc" s) - (write-string "def" s) - (get-output-stream-string s)) - "abcdef") - -(deftest make-string-output-stream.11 - :notes (:nil-vectors-are-strings) - (let ((s (make-string-output-stream :element-type nil))) - (get-output-stream-string s)) - "") - -(deftest make-string-output-stream.12 - :notes (:nil-vectors-are-strings) - (let ((s (make-string-output-stream :element-type nil))) - (typep #\a (array-element-type (get-output-stream-string s)))) - nil) - -(deftest make-string-output-stream.13 - (let ((s (make-string-output-stream))) - (values - (close s) - (open-stream-p s))) - t nil) - -;;; Error tests - -(deftest make-string-output-stream.error.1 - (signals-error (make-string-output-stream nil) program-error) - t) - -(deftest make-string-output-stream.error.2 - (signals-error (make-string-output-stream :foo nil) program-error) - t) - -(deftest make-string-output-stream.error.3 - (signals-error (make-string-output-stream :allow-other-keys nil - :foo 'bar) - program-error) - t) - - - - diff --git a/t/ansi-test/streams/make-synonym-stream.lsp b/t/ansi-test/streams/make-synonym-stream.lsp deleted file mode 100644 index b5bab2d..0000000 --- a/t/ansi-test/streams/make-synonym-stream.lsp +++ /dev/null @@ -1,97 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Jan 28 06:54:33 2004 -;;;; Contains: Tests of MAKE-SYNONYM-STREAM - -(in-package :cl-test) - -(deftest make-synonym-stream.1 - (with-input-from-string - (*s* "abcde") - (declare (special *s*)) - (let ((ss (make-synonym-stream '*s*))) - (assert (typep ss 'stream)) - (assert (typep ss 'synonym-stream)) - (assert (input-stream-p ss)) - (assert (not (output-stream-p ss))) - (assert (open-stream-p ss)) - (assert (streamp ss)) - (assert (stream-element-type ss)) - (values - (read-char *s*) - (read-char ss) - (read-char *s*) - (read-char ss) - (read-char ss)))) - #\a #\b #\c #\d #\e) - - -;;; This test was wrong (section 21.1.4) -#| -(deftest make-synonym-stream.2 - (let ((ss (make-synonym-stream '*s*))) - (with-input-from-string - (*s* "z") - (declare (special *s*)) - (assert (typep ss 'stream)) - (assert (typep ss 'synonym-stream)) - (assert (input-stream-p ss)) - (assert (not (output-stream-p ss))) - (assert (open-stream-p ss)) - (assert (streamp ss)) - (assert (stream-element-type ss)) - (read-char ss))) - #\z) -|# - -(deftest make-synonym-stream.3 - (with-output-to-string - (*s*) - (declare (special *s*)) - (let ((ss (make-synonym-stream '*s*))) - (assert (typep ss 'stream)) - (assert (typep ss 'synonym-stream)) - (assert (output-stream-p ss)) - (assert (not (input-stream-p ss))) - (assert (open-stream-p ss)) - (assert (streamp ss)) - (assert (stream-element-type ss)) - (write-char #\a *s*) - (write-char #\b ss) - (write-char #\x *s*) - (write-char #\y ss))) - "abxy") - -(deftest make-synonym-stream.4 - (let ((ss (make-synonym-stream '*terminal-io*))) - (assert (typep ss 'stream)) - (assert (typep ss 'synonym-stream)) - (assert (output-stream-p ss)) - (assert (input-stream-p ss)) - (assert (open-stream-p ss)) - (assert (streamp ss)) - (assert (stream-element-type ss)) - nil) - nil) - - -;;; FIXME -;;; Add tests for: close, -;;; peek-char, read-char-no-hang, terpri, fresh-line, unread-char, -;;; read-line, write-line, write-string, read-sequence, write-sequence, -;;; read-byte, write-byte, listen, clear-input, finish-output, force-output, -;;; clear-output, format, print, prin1, princ - -;;; Error cases - -(deftest make-synonym-stream.error.1 - (signals-error (make-synonym-stream) program-error) - t) - -(deftest make-synonym-stream.error.2 - (signals-error (make-synonym-stream '*standard-input* nil) program-error) - t) - -(deftest make-synonym-stream.error.3 - (check-type-error #'make-synonym-stream #'symbolp) - nil) diff --git a/t/ansi-test/streams/make-two-way-stream.lsp b/t/ansi-test/streams/make-two-way-stream.lsp deleted file mode 100644 index 53363c6..0000000 --- a/t/ansi-test/streams/make-two-way-stream.lsp +++ /dev/null @@ -1,244 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Jan 30 05:39:56 2004 -;;;; Contains: Tests for MAKE-TWO-WAY-STREAM - -(in-package :cl-test) - -(deftest make-two-way-stream.1 - (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-two-way-stream is os))) - (assert (typep s 'stream)) - (assert (typep s 'two-way-stream)) - (assert (streamp s)) - (assert (open-stream-p s)) - (assert (input-stream-p s)) - (assert (output-stream-p s)) - (assert (stream-element-type s)) - (values - (read-char s) - (write-char #\b s) - (read-char s) - (write-char #\a s) - (read-char s) - (write-char #\r s) - (get-output-stream-string os))) - #\f #\b #\o #\a #\o #\r "bar") - -(deftest make-two-way-stream.2 - (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-two-way-stream is os))) - (values - (close s) - (open-stream-p s) - (notnot (open-stream-p is)) - (notnot (open-stream-p os)) - (write-char #\8 os) - (get-output-stream-string os))) - t nil t t #\8 "8") - -(deftest make-two-way-stream.3 - (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-two-way-stream is os))) - (values - (peek-char nil s) - (read-char s) - (get-output-stream-string os))) - #\f #\f "") - -(deftest make-two-way-stream.4 - (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-two-way-stream is os))) - (values - (read-char-no-hang s) - (read-char-no-hang s nil) - (read-char-no-hang s t :eof) - (read-char-no-hang s nil :eof) - (get-output-stream-string os))) - #\f #\o #\o :eof "") - -(deftest make-two-way-stream.5 - (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-two-way-stream is os))) - (values - (terpri s) - (get-output-stream-string os))) - nil #.(string #\Newline)) - -(deftest make-two-way-stream.6 - (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-two-way-stream is os))) - (values - (write-char #\+ s) - (notnot (fresh-line s)) - (read-char s) - (get-output-stream-string os))) - #\+ t #\f #.(coerce (list #\+ #\Newline) 'string)) - -(deftest make-two-way-stream.7 - (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-two-way-stream is os))) - (values - (read-char s) - (unread-char #\f s) - (read-char s) - (read-char s) - (unread-char #\o s) - (get-output-stream-string os))) - #\f nil #\f #\o nil "") - -(deftest make-two-way-stream.8 - (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-two-way-stream is os))) - (values - (read-line s) - (get-output-stream-string os))) - "foo" "") - -(deftest make-two-way-stream.9 - (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-two-way-stream is os))) - (values - (write-string "bar" s) - (get-output-stream-string os))) - "bar" "bar") - -(deftest make-two-way-stream.10 - (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-two-way-stream is os))) - (values - (write-line "bar" s) - (get-output-stream-string os))) - "bar" #.(concatenate 'string "bar" '(#\Newline))) - -(deftest make-two-way-stream.11 - (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-two-way-stream is os))) - (let ((x (vector nil nil nil))) - (values - (read-sequence x s) - x - (get-output-stream-string os)))) - 3 #(#\f #\o #\o) "") - -(deftest make-two-way-stream.12 - (let ((pn1 #p"tmp.dat") - (pn2 #p"tmp2.dat") - (element-type '(unsigned-byte 8))) - (with-open-file (s pn1 :direction :output :if-exists :supersede - :element-type element-type) - (dolist (b '(3 8 19 41)) (write-byte b s))) - (with-open-file - (is pn1 :direction :input :element-type element-type) - (with-open-file - (os pn2 :direction :output :element-type element-type - :if-exists :supersede) - (let ((s (make-two-way-stream is os)) - (x (vector nil nil nil nil))) - (assert (eql (read-sequence x s) 4)) - (assert (equalp x #(3 8 19 41))) - (let ((y #(100 5 18 211 0 178))) - (assert (eql (write-sequence y s) y)) - (close s))))) - (with-open-file - (s pn2 :direction :input :element-type element-type) - (let ((x (vector nil nil nil nil nil nil nil))) - (values - (read-sequence x s) - x)))) - 6 - #(100 5 18 211 0 178 nil)) - -(deftest make-two-way-stream.13 - (let ((pn1 #p"tmp.dat") - (pn2 #p"tmp2.dat") - (element-type '(unsigned-byte 32))) - (with-open-file (s pn1 :direction :output :if-exists :supersede - :element-type element-type) - (dolist (b '(3 8 19 41)) (write-byte b s))) - (with-open-file - (is pn1 :direction :input :element-type element-type) - (with-open-file - (os pn2 :direction :output :element-type element-type - :if-exists :supersede) - (let ((s (make-two-way-stream is os)) - (x (vector nil nil nil nil))) - (assert (eql (read-sequence x s) 4)) - (assert (equalp x #(3 8 19 41))) - (let ((y #(100 5 18 211 0 178))) - (assert (eql (write-sequence y s) y)) - (close s))))) - (with-open-file - (s pn2 :direction :input :element-type element-type) - (let ((x (vector nil nil nil nil nil nil nil))) - (values - (read-sequence x s) - x)))) - 6 - #(100 5 18 211 0 178 nil)) - -(deftest make-two-way-stream.14 - (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-two-way-stream is os))) - (values - (write-string "abc" s) - (clear-input s) - (write-string "def" s) - (get-output-stream-string os))) - "abc" nil "def" "abcdef") - -;;; Error tests - -(deftest make-two-way-stream.error.1 - (signals-error (make-two-way-stream) program-error) - t) - -(deftest make-two-way-stream.error.2 - (signals-error (make-two-way-stream (make-string-input-stream "foo")) - program-error) - t) - -(deftest make-two-way-stream.error.3 - (signals-error (let ((os (make-string-output-stream))) - (make-two-way-stream (make-string-input-stream "foo") - os nil)) - program-error) - t) - -(deftest make-two-way-stream.error.4 - (check-type-error #'(lambda (x) (make-two-way-stream x (make-string-output-stream))) - #'(lambda (x) (and (streamp x) (input-stream-p x)))) - nil) - -(deftest make-two-way-stream.error.5 - (check-type-error #'(lambda (x) (make-two-way-stream x (make-string-output-stream))) - #'(lambda (x) (and (streamp x) (input-stream-p x))) - *streams*) - nil) - -(deftest make-two-way-stream.error.6 - (check-type-error #'(lambda (x) (make-two-way-stream (make-string-input-stream "foo") x)) - #'(lambda (x) (and (streamp x) (output-stream-p x)))) - nil) - -(deftest make-two-way-stream.error.7 - (check-type-error #'(lambda (x) (make-two-way-stream (make-string-input-stream "foo") x)) - #'(lambda (x) (and (streamp x) (output-stream-p x))) - *streams*) - nil) - - - - diff --git a/t/ansi-test/streams/open-stream-p.lsp b/t/ansi-test/streams/open-stream-p.lsp deleted file mode 100644 index fc8c7a6..0000000 --- a/t/ansi-test/streams/open-stream-p.lsp +++ /dev/null @@ -1,54 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Jan 13 19:52:30 2004 -;;;; Contains: Tests of OPEN-STREAM-P - -(in-package :cl-test) - -(deftest open-stream-p.1 - (loop for s in (list *debug-io* *error-output* *query-io* - *standard-input* *standard-output* - *trace-output* *terminal-io*) - for results = (multiple-value-list (open-stream-p s)) - unless (and (eql (length results) 1) - (car results)) - collect s) - nil) - -(deftest open-stream-p.2 - (with-open-file (s "open-stream-p.txt" :direction :input) - (notnot-mv (open-stream-p s))) - t) - -(deftest open-stream-p.3 - (with-open-file (s "scratch/foo.txt" :direction :output - :if-exists :supersede) - (notnot-mv (open-stream-p s))) - t) - -(deftest open-stream-p.4 - (let ((s (open "open-stream-p.txt" :direction :input))) - (close s) - (open-stream-p s)) - nil) - -(deftest open-stream-p.5 - (let ((s (open "scratch/foo.txt" :direction :output - :if-exists :supersede))) - (close s) - (open-stream-p s)) - nil) - -;;; error tests - -(deftest open-stream-p.error.1 - (signals-error (open-stream-p) program-error) - t) - -(deftest open-stream-p.error.2 - (signals-error (open-stream-p *standard-input* nil) program-error) - t) - -(deftest open-stream-p.error.3 - (check-type-error #'open-stream-p #'streamp) - nil) diff --git a/t/ansi-test/streams/open.lsp b/t/ansi-test/streams/open.lsp deleted file mode 100644 index 8ae6a7d..0000000 --- a/t/ansi-test/streams/open.lsp +++ /dev/null @@ -1,1238 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Jan 23 05:36:55 2004 -;;;; Contains: Tests of OPEN - -(in-package :cl-test) - -;;; Input streams - -(defun generator-for-element-type (type) - (etypecase type - ((member character base-char) - #'(lambda (i) (aref "abcdefghijklmnopqrstuvwxyz" (mod i 26)))) - ((member signed-byte unsigned-byte bit) - #'(lambda (i) (logand i 1))) - (cons - (let ((op (car type)) - (arg1 (cadr type)) - (arg2 (caddr type))) - (ecase op - (unsigned-byte - (let ((mask (1- (ash 1 arg1)))) - #'(lambda (i) (logand i mask)))) - (signed-byte - (let ((mask (1- (ash 1 (1- arg1))))) - #'(lambda (i) (logand i mask)))) - (integer - (let* ((lo arg1) - (hi arg2) - (lower-bound - (etypecase lo - (integer lo) - (cons (1+ (car lo))))) - (upper-bound - (etypecase hi - (integer hi) - (cons (1- (car hi))))) - (range (1+ (- upper-bound lower-bound)))) - #'(lambda (i) (+ lower-bound (mod i range)))))))))) - -(compile 'generator-for-element-type) - -(defmacro def-open-test (name args form expected - &key - (notes nil notes-p) - (build-form nil build-form-p) - (element-type 'character element-type-p) - (pathname #p"tmp.dat")) - - (when element-type-p - (setf args (append args (list :element-type `',element-type)))) - - (unless build-form-p - (let ((write-element-form - (cond - ((subtypep element-type 'integer) - `(write-byte - (funcall (the function - (generator-for-element-type ',element-type)) i) - os)) - ((subtypep element-type 'character) - `(write-char - (funcall (the function - (generator-for-element-type ',element-type)) i) - os))))) - (setq build-form - `(with-open-file - (os pn :direction :output - ,@(if element-type-p - `(:element-type ',element-type)) - :if-exists :supersede) - (assert (open-stream-p os)) - (dotimes (i 10) ,write-element-form) - (finish-output os) - )))) - - `(deftest ,name - ,@(when notes-p `(:notes ,notes)) - (let ((pn ,pathname)) - (delete-all-versions pn) - ,build-form - (let ((s (open pn ,@args))) - (unwind-protect - (progn - (assert (open-stream-p s)) - (assert (typep s 'file-stream)) - ,@ - (unless (member element-type '(signed-byte unsigned-byte)) - #-allegro - `((assert (subtypep ',element-type - (stream-element-type s)))) - #+allegro nil - ) - ,form) - (close s)))) - ,@expected)) - -;; (compile 'def-open-test) - -(def-open-test open.1 () (values (read-line s nil)) ("abcdefghij")) -(def-open-test open.2 (:direction :input) - (values (read-line s nil)) ("abcdefghij") :element-type character) -(def-open-test open.3 (:direction :input) - (values (read-line s nil)) ("abcdefghij")) -(def-open-test open.4 (:direction :input) - (values (read-line s nil)) ("abcdefghij") :element-type base-char) -(def-open-test open.5 (:if-exists :error) - (values (read-line s nil)) ("abcdefghij")) -(def-open-test open.6 (:if-exists :error :direction :input) - (values (read-line s nil)) ("abcdefghij")) -(def-open-test open.7 (:if-exists :new-version) - (values (read-line s nil)) ("abcdefghij")) -(def-open-test open.8 (:if-exists :new-version :direction :input) - (values (read-line s nil)) ("abcdefghij")) -(def-open-test open.9 (:if-exists :rename) - (values (read-line s nil)) ("abcdefghij")) -(def-open-test open.10 (:if-exists :rename :direction :input) - (values (read-line s nil)) ("abcdefghij")) -(def-open-test open.11 (:if-exists :rename-and-delete) - (values (read-line s nil)) ("abcdefghij")) -(def-open-test open.12 (:if-exists :rename-and-delete :direction :input) - (values (read-line s nil)) ("abcdefghij")) -(def-open-test open.13 (:if-exists :overwrite) - (values (read-line s nil)) ("abcdefghij")) -(def-open-test open.14 (:if-exists :overwrite :direction :input) - (values (read-line s nil)) ("abcdefghij")) -(def-open-test open.15 (:if-exists :append) - (values (read-line s nil)) ("abcdefghij")) -(def-open-test open.16 (:if-exists :append :direction :input) - (values (read-line s nil)) ("abcdefghij")) -(def-open-test open.17 (:if-exists :supersede) - (values (read-line s nil)) ("abcdefghij")) -(def-open-test open.18 (:if-exists :supersede :direction :input) - (values (read-line s nil)) ("abcdefghij")) -(def-open-test open.19 (:if-exists nil) - (values (read-line s nil)) ("abcdefghij")) -(def-open-test open.20 (:if-exists nil :direction :input) - (values (read-line s nil)) ("abcdefghij")) - -(def-open-test open.21 (:if-does-not-exist nil) - (values (read-line s nil)) ("abcdefghij")) -(def-open-test open.22 (:if-does-not-exist nil :direction :input) - (values (read-line s nil)) ("abcdefghij")) -(def-open-test open.23 (:if-does-not-exist :error) - (values (read-line s nil)) ("abcdefghij")) -(def-open-test open.24 (:if-does-not-exist :error :direction :input) - (values (read-line s nil)) ("abcdefghij")) -(def-open-test open.25 (:if-does-not-exist :create) - (values (read-line s nil)) ("abcdefghij")) -(def-open-test open.26 (:if-does-not-exist :create :direction :input) - (values (read-line s nil)) ("abcdefghij")) - -(def-open-test open.27 (:external-format :default) - (values (read-line s nil)) ("abcdefghij")) -(def-open-test open.28 (:external-format :default :direction :input) - (values (read-line s nil)) ("abcdefghij")) - -(def-open-test open.29 () - (let ((seq (make-array 10))) (read-sequence seq s) seq) - (#(0 1 0 1 0 1 0 1 0 1)) :element-type (unsigned-byte 1)) -(def-open-test open.30 (:direction :input) - (let ((seq (make-array 10))) (read-sequence seq s) seq) - (#(0 1 0 1 0 1 0 1 0 1)) :element-type (unsigned-byte 1)) - -(def-open-test open.31 () - (let ((seq (make-array 10))) (read-sequence seq s) seq) - (#(0 1 2 3 0 1 2 3 0 1)) :element-type (unsigned-byte 2)) -(def-open-test open.32 (:direction :input) - (let ((seq (make-array 10))) (read-sequence seq s) seq) - (#(0 1 2 3 0 1 2 3 0 1)) :element-type (unsigned-byte 2)) - -(def-open-test open.33 () - (let ((seq (make-array 10))) (read-sequence seq s) seq) - (#(0 1 2 3 4 5 6 7 0 1)) :element-type (unsigned-byte 3)) -(def-open-test open.34 (:direction :input) - (let ((seq (make-array 10))) (read-sequence seq s) seq) - (#(0 1 2 3 4 5 6 7 0 1)) :element-type (unsigned-byte 3)) - -(def-open-test open.35 () - (let ((seq (make-array 10))) (read-sequence seq s) seq) - (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 4)) -(def-open-test open.36 (:direction :input) - (let ((seq (make-array 10))) (read-sequence seq s) seq) - (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 4)) - -(def-open-test open.37 () - (let ((seq (make-array 10))) (read-sequence seq s) seq) - (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 5)) -(def-open-test open.38 (:direction :input) - (let ((seq (make-array 10))) (read-sequence seq s) seq) - (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 5)) - -(def-open-test open.39 () - (let ((seq (make-array 10))) (read-sequence seq s) seq) - (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 6)) -(def-open-test open.40 (:direction :input) - (let ((seq (make-array 10))) (read-sequence seq s) seq) - (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 6)) - -(def-open-test open.41 () - (let ((seq (make-array 10))) (read-sequence seq s) seq) - (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 7)) -(def-open-test open.42 (:direction :input) - (let ((seq (make-array 10))) (read-sequence seq s) seq) - (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 7)) - -(def-open-test open.43 () - (let ((seq (make-array 10))) (read-sequence seq s) seq) - (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 8)) -(def-open-test open.44 (:direction :input) - (let ((seq (make-array 10))) (read-sequence seq s) seq) - (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 8)) - -(def-open-test open.45 () - (let ((seq (make-array 10))) (read-sequence seq s) seq) - (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 9)) -(def-open-test open.46 (:direction :input) - (let ((seq (make-array 10))) (read-sequence seq s) seq) - (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 9)) - -(def-open-test open.47 () - (let ((seq (make-array 10))) (read-sequence seq s) seq) - (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 10)) -(def-open-test open.48 (:direction :input) - (let ((seq (make-array 10))) (read-sequence seq s) seq) - (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 10)) - -(def-open-test open.49 () - (let ((seq (make-array 10))) (read-sequence seq s) seq) - (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 20)) -(def-open-test open.50 (:direction :input) - (let ((seq (make-array 10))) (read-sequence seq s) seq) - (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 20)) - -(def-open-test open.51 () - (let ((seq (make-array 10))) (read-sequence seq s) seq) - (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 25)) -(def-open-test open.52 (:direction :input) - (let ((seq (make-array 10))) (read-sequence seq s) seq) - (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 25)) - -(def-open-test open.53 () - (let ((seq (make-array 10))) (read-sequence seq s) seq) - (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 30)) -(def-open-test open.54 (:direction :input) - (let ((seq (make-array 10))) (read-sequence seq s) seq) - (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 30)) - -(def-open-test open.55 () - (let ((seq (make-array 10))) (read-sequence seq s) seq) - (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 32)) -(def-open-test open.56 (:direction :input) - (let ((seq (make-array 10))) (read-sequence seq s) seq) - (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 32)) - -(def-open-test open.57 () - (let ((seq (make-array 10))) (read-sequence seq s) seq) - (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 33)) -(def-open-test open.58 (:direction :input) - (let ((seq (make-array 10))) (read-sequence seq s) seq) - (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 33)) - -(def-open-test open.59 () - (let ((seq (make-array 10))) (read-sequence seq s) seq) - (#(0 1 0 1 0 1 0 1 0 1)) :element-type unsigned-byte) -(def-open-test open.60 (:direction :input) - (let ((seq (make-array 10))) (read-sequence seq s) seq) - (#(0 1 0 1 0 1 0 1 0 1)) :element-type unsigned-byte) - -(def-open-test open.61 () - (let ((seq (make-array 10))) (read-sequence seq s) seq) - (#(0 1 0 1 0 1 0 1 0 1)) :element-type signed-byte) -(def-open-test open.62 (:direction :input) - (let ((seq (make-array 10))) (read-sequence seq s) seq) - (#(0 1 0 1 0 1 0 1 0 1)) :element-type signed-byte) - - -(def-open-test open.63 () - (values (read-line s nil)) ("abcdefghij") - :pathname "tmp.dat") - -(def-open-test open.64 () - (values (read-line s nil)) ("abcdefghij") - :pathname (logical-pathname "CLTEST:TMP.DAT")) - -;;; It works on recognizable subtypes. -(deftest open.65 - (let ((type '(or (integer 0 1) (integer 100 200))) - (pn #p"tmp.dat") - (vals '(0 1 100 120 130 190 200 1 0 150))) - (or - (not (subtypep type 'integer)) - (progn - (with-open-file - (os pn :direction :output - :element-type type - :if-exists :supersede) - (dolist (e vals) (write-byte e os))) - (let ((s (open pn :direction :input - :element-type type)) - (seq (make-array 10))) - (unwind-protect - (progn (read-sequence seq s) seq) - (close s)) - (notnot (every #'eql seq vals)))))) - t) - -;;; FIXME: Add -- tests for when the filespec is a stream - -(deftest open.66 - (let ((pn #p"tmp.dat")) - (delete-all-versions pn) - (with-open-file - (s pn :direction :io :if-exists :rename-and-delete - :if-does-not-exist :create) - (format s "some stuff~%") - (finish-output s) - (let ((is (open s :direction :input))) - (unwind-protect - (values - (read-char is) - (notnot (file-position s :start)) - (read-line is) - (read-line s)) - (close is))))) - #\s - t - "ome stuff" - "some stuff") - -(deftest open.67 - (let ((pn #p"tmp.dat")) - (delete-all-versions pn) - (let ((s (open pn :direction :output))) - (unwind-protect - (progn - (format s "some stuff~%") - (finish-output s) - (close s) - (let ((is (open s :direction :input))) - (unwind-protect - (values (read-line is)) - (close is)))) - (when (open-stream-p s) (close s))))) - "some stuff") - -;;; FIXME: Add -- tests for when element-type is :default - -;;; Tests of file creation - -(defmacro def-open-output-test - (name args form expected - &rest keyargs - &key - (element-type 'character) - (build-form - `(dotimes (i 10) - ,(cond - ((subtypep element-type 'integer) - `(write-byte - (funcall (the function - (generator-for-element-type ',element-type)) i) - s)) - ((subtypep element-type 'character) - `(write-char - (funcall (the function - (generator-for-element-type ',element-type)) i) - s))))) - &allow-other-keys) - `(def-open-test ,name (:direction :output ,@args) - (progn - ,build-form - (assert (output-stream-p s)) - ,form) - ,expected - :build-form nil - ,@keyargs)) - -;; (compile 'def-open-output-test) - -(def-open-output-test open.output.1 () - (progn (close s) - (with-open-file (is #p"tmp.dat") (values (read-line is nil)))) - ("abcdefghij")) - -(def-open-output-test open.output.2 () - (progn (close s) - (with-open-file (is "tmp.dat") (values (read-line is nil)))) - ("abcdefghij") - :pathname "tmp.dat") - -(def-open-output-test open.output.3 - () - (progn (close s) - (with-open-file (is (logical-pathname "CLTEST:TMP.DAT")) - (values (read-line is nil)))) - ("abcdefghij") - :pathname (logical-pathname "CLTEST:TMP.DAT")) - -(def-open-output-test open.output.4 () - (progn (close s) - (with-open-file (is #p"tmp.dat" :element-type 'character) - (values (read-line is nil)))) - ("abcdefghij") - :element-type character) - -(def-open-output-test open.output.5 () - (progn (close s) (with-open-file (is #p"tmp.dat" - :element-type 'base-char) - (values (read-line is nil)))) - ("abcdefghij") - :element-type base-char) - -(def-open-output-test open.output.6 () - (progn (close s) (with-open-file (is #p"tmp.dat" - :element-type '(integer 0 1)) - (let ((seq (make-array 10))) - (read-sequence seq is) - seq))) - (#(0 1 0 1 0 1 0 1 0 1)) - :element-type (integer 0 1)) - -(def-open-output-test open.output.7 () - (progn (close s) (with-open-file (is #p"tmp.dat" - :element-type 'bit) - (let ((seq (make-array 10))) - (read-sequence seq is) - seq))) - (#(0 1 0 1 0 1 0 1 0 1)) - :element-type bit) - -(def-open-output-test open.output.8 () - (progn (close s) (with-open-file (is #p"tmp.dat" - :element-type '(unsigned-byte 1)) - (let ((seq (make-array 10))) - (read-sequence seq is) - seq))) - (#(0 1 0 1 0 1 0 1 0 1)) - :element-type (unsigned-byte 1)) - -(def-open-output-test open.output.9 () - (progn (close s) (with-open-file (is #p"tmp.dat" - :element-type '(unsigned-byte 2)) - (let ((seq (make-array 10))) - (read-sequence seq is) - seq))) - (#(0 1 2 3 0 1 2 3 0 1)) - :element-type (unsigned-byte 2)) - -(def-open-output-test open.output.10 () - (progn (close s) (with-open-file (is #p"tmp.dat" - :element-type '(unsigned-byte 3)) - (let ((seq (make-array 10))) - (read-sequence seq is) - seq))) - (#(0 1 2 3 4 5 6 7 0 1)) - :element-type (unsigned-byte 3)) - -(def-open-output-test open.output.11 () - (progn (close s) (with-open-file (is #p"tmp.dat" - :element-type '(unsigned-byte 4)) - (let ((seq (make-array 10))) - (read-sequence seq is) - seq))) - (#(0 1 2 3 4 5 6 7 8 9)) - :element-type (unsigned-byte 4)) - - -(def-open-output-test open.output.12 () - (progn (close s) (with-open-file (is #p"tmp.dat" - :element-type '(unsigned-byte 6)) - (let ((seq (make-array 10))) - (read-sequence seq is) - seq))) - (#(0 1 2 3 4 5 6 7 8 9)) - :element-type (unsigned-byte 6)) - -(def-open-output-test open.output.13 () - (progn (close s) (with-open-file (is #p"tmp.dat" - :element-type '(unsigned-byte 8)) - (let ((seq (make-array 10))) - (read-sequence seq is) - seq))) - (#(0 1 2 3 4 5 6 7 8 9)) - :element-type (unsigned-byte 8)) - -(def-open-output-test open.output.14 () - (progn (close s) (with-open-file (is #p"tmp.dat" - :element-type '(unsigned-byte 12)) - (let ((seq (make-array 10))) - (read-sequence seq is) - seq))) - (#(0 1 2 3 4 5 6 7 8 9)) - :element-type (unsigned-byte 12)) - -(def-open-output-test open.output.15 () - (progn (close s) (with-open-file (is #p"tmp.dat" - :element-type '(unsigned-byte 16)) - (let ((seq (make-array 10))) - (read-sequence seq is) - seq))) - (#(0 1 2 3 4 5 6 7 8 9)) - :element-type (unsigned-byte 16)) - -(def-open-output-test open.output.16 () - (progn (close s) (with-open-file (is #p"tmp.dat" - :element-type '(unsigned-byte 24)) - (let ((seq (make-array 10))) - (read-sequence seq is) - seq))) - (#(0 1 2 3 4 5 6 7 8 9)) - :element-type (unsigned-byte 24)) - -(def-open-output-test open.output.17 () - (progn (close s) (with-open-file (is #p"tmp.dat" - :element-type '(unsigned-byte 32)) - (let ((seq (make-array 10))) - (read-sequence seq is) - seq))) - (#(0 1 2 3 4 5 6 7 8 9)) - :element-type (unsigned-byte 32)) - -(def-open-output-test open.output.18 () - (progn (close s) (with-open-file (is #p"tmp.dat" - :element-type '(unsigned-byte 64)) - (let ((seq (make-array 10))) - (read-sequence seq is) - seq))) - (#(0 1 2 3 4 5 6 7 8 9)) - :element-type (unsigned-byte 64)) - -(def-open-output-test open.output.19 () - (progn (close s) (with-open-file (is #p"tmp.dat" - :element-type '(unsigned-byte 100)) - (let ((seq (make-array 10))) - (read-sequence seq is) - seq))) - (#(0 1 2 3 4 5 6 7 8 9)) - :element-type (unsigned-byte 100)) - -(deftest open.output.20 - (let ((pn #p"tmp.dat")) - (with-open-file (s pn :direction :output :if-exists :supersede)) - (open pn :direction :output :if-exists nil)) - nil) - -(def-open-test open.output.21 (:if-exists :new-version :direction :output) - (progn (write-sequence "wxyz" s) - (close s) - (with-open-file - (s pn :direction :input) - (values (read-line s nil)))) - ("wxyz") - :notes (:open-if-exists-new-version-no-error) - ) - -(def-open-test open.output.22 (:if-exists :rename :direction :output) - (progn (write-sequence "wxyz" s) - (close s) - (with-open-file - (s pn :direction :input) - (values (read-line s nil)))) - ("wxyz")) - -(def-open-test open.output.23 (:if-exists :rename-and-delete - :direction :output) - (progn (write-sequence "wxyz" s) - (close s) - (with-open-file - (s pn :direction :input) - (values (read-line s nil)))) - ("wxyz")) - -(def-open-test open.output.24 (:if-exists :overwrite - :direction :output) - (progn (write-sequence "wxyz" s) - (close s) - (with-open-file - (s pn :direction :input) - (values (read-line s nil)))) - ("wxyzefghij")) - -(def-open-test open.output.25 (:if-exists :append - :direction :output) - (progn (write-sequence "wxyz" s) - (close s) - (with-open-file - (s pn :direction :input) - (values (read-line s nil)))) - ("abcdefghijwxyz")) - -(def-open-test open.output.26 (:if-exists :supersede - :direction :output) - (progn (write-sequence "wxyz" s) - (close s) - (with-open-file - (s pn :direction :input) - (values (read-line s nil)))) - ("wxyz")) - -(def-open-output-test open.output.27 (:if-does-not-exist :create - :direction :output) - (progn (close s) - (with-open-file - (is pn :direction :input) - (values (read-line is nil)))) - ("abcdefghij")) - -(deftest open.output.28 - (let ((pn #p"tmp.dat")) - (delete-all-versions pn) - (open pn :direction :output :if-does-not-exist nil)) - nil) - -(def-open-output-test open.output.28a (:external-format :default) - (progn (close s) - (with-open-file (is #p"tmp.dat") (values (read-line is nil)))) - ("abcdefghij")) - -(def-open-output-test open.output.29 - (:external-format (prog1 - (with-open-file (s "foo.dat" :direction :output - :if-exists :supersede) - (stream-external-format s)) - (delete-all-versions "foo.dat") - )) - (progn (close s) - (with-open-file (is #p"tmp.dat") (values (read-line is nil)))) - ("abcdefghij")) - -;;; Default behavior of open :if-exists is :create when the version -;;; of the filespec is :newest - -(deftest open.output.30 - :notes (:open-if-exists-new-version-no-error) - (let ((pn (make-pathname :name "tmp" :type "dat" :version :newest))) - (or (not (eql (pathname-version pn) :newest)) - (progn - ;; Create file - (let ((s1 (open pn :direction :output :if-exists :overwrite - :if-does-not-exist :create))) - (unwind-protect - ;; Now try again - (let ((s2 (open pn :direction :output))) - (unwind-protect - (write-line "abcdef" s2) - (close s2)) - (unwind-protect - (progn - (setq s2 (open s1 :direction :input)) - (equalt (read-line s2 nil) "abcdef")) - (close s2))) - (close s1) - (delete-all-versions pn) - ))))) - t) - -(def-open-output-test open.output.31 (:if-exists :rename - :direction :output) - (progn (close s) - (with-open-file - (is pn :direction :input) - (values (read-line is nil)))) - ("abcdefghij")) - -(def-open-output-test open.output.32 (:if-exists :rename-and-delete - :direction :output) - (progn (close s) - (with-open-file - (is pn :direction :input) - (values (read-line is nil)))) - ("abcdefghij")) - -(def-open-output-test open.output.33 (:if-exists :new-version - :direction :output) - (progn (close s) - (with-open-file - (is pn :direction :input) - (values (read-line is nil)))) - ("abcdefghij")) - -(def-open-output-test open.output.34 (:if-exists :supersede - :direction :output) - (progn (close s) - (with-open-file - (is pn :direction :input) - (values (read-line is nil)))) - ("abcdefghij")) - -(def-open-output-test open.output.35 (:if-exists nil - :direction :output) - (progn (close s) - (with-open-file - (is pn :direction :input) - (values (read-line is nil)))) - ("abcdefghij")) - -;;; Add -- tests for when the filespec is a stream - - -;;; Tests of bidirectional IO - -(defmacro def-open-io-test - (name args form expected - &rest keyargs - &key - (element-type 'character) - (build-form - `(dotimes (i 10) - ,(cond - ((subtypep element-type 'integer) - `(write-byte - (funcall (the function - (generator-for-element-type ',element-type)) i) - s)) - ((subtypep element-type 'character) - `(write-char - (funcall (the function - (generator-for-element-type ',element-type)) i) - s))))) - &allow-other-keys) - `(def-open-test ,name (:direction :io ,@args) - (progn - ,build-form - (assert (input-stream-p s)) - (assert (output-stream-p s)) - ,form) - ,expected - :build-form nil - ,@keyargs)) - -;; (compile 'def-open-io-test) - -(def-open-io-test open.io.1 () - (progn (file-position s :start) - (values (read-line s nil))) - ("abcdefghij")) - -(def-open-io-test open.io.2 () - (progn (file-position s :start) - (values (read-line s nil))) - ("abcdefghij") - :pathname "tmp.dat") - -(def-open-io-test open.io.3 - () - (progn (file-position s :start) - (values (read-line s nil))) - ("abcdefghij") - :pathname (logical-pathname "CLTEST:TMP.DAT")) - -(def-open-io-test open.io.4 () - (progn (file-position s :start) - (values (read-line s nil))) - ("abcdefghij") - :element-type character) - -(def-open-io-test open.io.5 () - (progn (file-position s :start) - (values (read-line s nil))) - ("abcdefghij") - :element-type base-char) - -(def-open-io-test open.io.6 () - (progn (file-position s :start) - (let ((seq (make-array 10))) - (read-sequence seq s) - seq)) - (#(0 1 0 1 0 1 0 1 0 1)) - :element-type (integer 0 1)) - -(def-open-io-test open.io.7 () - (progn (file-position s :start) - (let ((seq (make-array 10))) - (read-sequence seq s) - seq)) - (#(0 1 0 1 0 1 0 1 0 1)) - :element-type bit) - -(def-open-io-test open.io.8 () - (progn (file-position s :start) - (let ((seq (make-array 10))) - (read-sequence seq s) - seq)) - (#(0 1 0 1 0 1 0 1 0 1)) - :element-type (unsigned-byte 1)) - -(def-open-io-test open.io.9 () - (progn (file-position s :start) - (let ((seq (make-array 10))) - (read-sequence seq s) - seq)) - (#(0 1 2 3 0 1 2 3 0 1)) - :element-type (unsigned-byte 2)) - -(def-open-io-test open.io.10 () - (progn (file-position s :start) - (let ((seq (make-array 10))) - (read-sequence seq s) - seq)) - (#(0 1 2 3 4 5 6 7 0 1)) - :element-type (unsigned-byte 3)) - -(def-open-io-test open.io.11 () - (progn (file-position s :start) - (let ((seq (make-array 10))) - (read-sequence seq s) - seq)) - (#(0 1 2 3 4 5 6 7 8 9)) - :element-type (unsigned-byte 4)) - - -(def-open-io-test open.io.12 () - (progn (file-position s :start) - (let ((seq (make-array 10))) - (read-sequence seq s) - seq)) - (#(0 1 2 3 4 5 6 7 8 9)) - :element-type (unsigned-byte 6)) - -(def-open-io-test open.io.13 () - (progn (file-position s :start) - (let ((seq (make-array 10))) - (read-sequence seq s) - seq)) - (#(0 1 2 3 4 5 6 7 8 9)) - :element-type (unsigned-byte 8)) - -(def-open-io-test open.io.14 () - (progn (file-position s :start) - (let ((seq (make-array 10))) - (read-sequence seq s) - seq)) - (#(0 1 2 3 4 5 6 7 8 9)) - :element-type (unsigned-byte 12)) - -(def-open-io-test open.io.15 () - (progn (file-position s :start) - (let ((seq (make-array 10))) - (read-sequence seq s) - seq)) - (#(0 1 2 3 4 5 6 7 8 9)) - :element-type (unsigned-byte 16)) - -(def-open-io-test open.io.16 () - (progn (file-position s :start) - (let ((seq (make-array 10))) - (read-sequence seq s) - seq)) - (#(0 1 2 3 4 5 6 7 8 9)) - :element-type (unsigned-byte 24)) - -(def-open-io-test open.io.17 () - (progn (file-position s :start) - (let ((seq (make-array 10))) - (read-sequence seq s) - seq)) - (#(0 1 2 3 4 5 6 7 8 9)) - :element-type (unsigned-byte 32)) - -(def-open-io-test open.io.18 () - (progn (file-position s :start) - (let ((seq (make-array 10))) - (read-sequence seq s) - seq)) - (#(0 1 2 3 4 5 6 7 8 9)) - :element-type (unsigned-byte 64)) - -(def-open-io-test open.io.19 () - (progn (file-position s :start) - (let ((seq (make-array 10))) - (read-sequence seq s) - seq)) - (#(0 1 2 3 4 5 6 7 8 9)) - :element-type (unsigned-byte 100)) - -(deftest open.io.20 - (let ((pn #p"tmp.dat")) - (with-open-file (s pn :direction :io :if-exists :supersede)) - (open pn :direction :io :if-exists nil)) - nil) - -(def-open-test open.io.21 (:if-exists :new-version :direction :io) - (progn (write-sequence "wxyz" s) - (file-position s :start) - (values (read-line s nil))) - ("wxyz") - :notes (:open-if-exists-new-version-no-error) - ) - -(def-open-test open.io.22 (:if-exists :rename :direction :io) - (progn (write-sequence "wxyz" s) - (file-position s :start) - (values (read-line s nil))) - ("wxyz")) - -(def-open-test open.io.23 (:if-exists :rename-and-delete - :direction :io) - (progn (write-sequence "wxyz" s) - (file-position s :start) - (values (read-line s nil))) - ("wxyz")) - -(def-open-test open.io.24 (:if-exists :overwrite - :direction :io) - (progn (write-sequence "wxyz" s) - (file-position s :start) - (values (read-line s nil))) - ("wxyzefghij")) - -(def-open-test open.io.25 (:if-exists :append - :direction :io) - (progn (write-sequence "wxyz" s) - (file-position s :start) - (values (read-line s nil))) - ("abcdefghijwxyz")) - -(def-open-test open.io.26 (:if-exists :supersede - :direction :io) - (progn (write-sequence "wxyz" s) - (file-position s :start) - (values (read-line s nil))) - ("wxyz")) - -(def-open-io-test open.io.27 (:if-does-not-exist :create - :direction :io) - (progn (file-position s :start) - (values (read-line s nil))) - ("abcdefghij")) - -(deftest open.io.28 - (let ((pn #p"tmp.dat")) - (delete-all-versions pn) - (open pn :direction :io :if-does-not-exist nil)) - nil) - -(def-open-io-test open.io.28a (:external-format :default) - (progn (file-position s :start) - (values (read-line s nil))) - ("abcdefghij")) - -(def-open-io-test open.io.29 - (:external-format (prog1 - (with-open-file (s "foo.dat" :direction :io - :if-exists :supersede) - (stream-external-format s)) - (delete-all-versions "foo.dat") - )) - (progn (file-position s :start) - (values (read-line s nil))) - ("abcdefghij")) - -;;; Default behavior of open :if-exists is :create when the version -;;; of the filespec is :newest - -(deftest open.io.30 - :notes (:open-if-exists-new-version-no-error) - (let ((pn (make-pathname :name "tmp" :type "dat" :version :newest))) - (or (not (eql (pathname-version pn) :newest)) - (progn - ;; Create file - (let ((s1 (open pn :direction :io :if-exists :overwrite - :if-does-not-exist :create))) - (unwind-protect - ;; Now try again - (let ((s2 (open pn :direction :io))) - (unwind-protect - (write-line "abcdef" s2) - (close s2)) - (unwind-protect - (progn - (setq s2 (open s1 :direction :input)) - (equalt (read-line s2 nil) "abcdef")) - (close s2))) - (close s1) - (delete-all-versions pn) - ))))) - t) - -(def-open-io-test open.io.31 (:if-exists :rename - :direction :io) - (progn (file-position s :start) - (values (read-line s nil))) - ("abcdefghij")) - -(def-open-io-test open.io.32 (:if-exists :rename-and-delete - :direction :io) - (progn (file-position s :start) - (values (read-line s nil))) - ("abcdefghij")) - -(def-open-io-test open.io.33 (:if-exists :new-version - :direction :io) - (progn (file-position s :start) - (values (read-line s nil))) - ("abcdefghij")) - -(def-open-io-test open.io.34 (:if-exists :supersede - :direction :io) - (progn (file-position s :start) - (values (read-line s nil))) - ("abcdefghij")) - -(def-open-io-test open.io.35 (:if-exists nil - :direction :io) - (progn (file-position s :start) - (values (read-line s nil))) - ("abcdefghij")) - -;;;; :PROBE tests - -(defmacro def-open-probe-test - (name args form - &key (build-form nil build-form-p) - (pathname #p"tmp.dat")) - (unless build-form-p - (setf build-form - `(with-open-file (s pn :direction :output - :if-exists :supersede)))) - `(deftest ,name - (let ((pn ,pathname)) - (delete-all-versions pn) - ,build-form - (let ((s (open pn :direction :probe ,@args))) - (values - ,(if build-form - `(and - (typep s 'file-stream) - (not (open-stream-p s)) - ) - `(not s)) - ,form))) - t t)) - -(def-open-probe-test open.probe.1 () t) -(def-open-probe-test open.probe.2 (:if-exists :error) t) -(def-open-probe-test open.probe.3 (:if-exists :new-version) t) -(def-open-probe-test open.probe.4 (:if-exists :rename) t) -(def-open-probe-test open.probe.5 (:if-exists :rename-and-delete) t) -(def-open-probe-test open.probe.6 (:if-exists :overwrite) t) -(def-open-probe-test open.probe.7 (:if-exists :append) t) -(def-open-probe-test open.probe.8 (:if-exists :supersede) t) - -(def-open-probe-test open.probe.9 (:if-does-not-exist :error) t) -(def-open-probe-test open.probe.10 (:if-does-not-exist nil) t) -(def-open-probe-test open.probe.11 (:if-does-not-exist :create) t) - -(def-open-probe-test open.probe.12 () t :build-form nil) -(def-open-probe-test open.probe.13 (:if-exists :error) t :build-form nil) -(def-open-probe-test open.probe.14 (:if-exists :new-version) t :build-form nil) -(def-open-probe-test open.probe.15 (:if-exists :rename) t :build-form nil) -(def-open-probe-test open.probe.16 (:if-exists :rename-and-delete) t - :build-form nil) -(def-open-probe-test open.probe.17 (:if-exists :overwrite) t - :build-form nil) -(def-open-probe-test open.probe.18 (:if-exists :append) t - :build-form nil) -(def-open-probe-test open.probe.19 (:if-exists :supersede) t - :build-form nil) - -(def-open-probe-test open.probe.20 (:if-does-not-exist nil) t - :build-form nil) - -(deftest open.probe.21 - (let ((pn #p"tmp.dat")) - (delete-all-versions pn) - (let ((s (open pn :direction :probe :if-does-not-exist :create))) - (values - (notnot s) - (notnot (probe-file pn))))) - t t) - -(deftest open.probe.22 - (let ((pn #p"tmp.dat")) - (delete-all-versions pn) - (let ((s (open pn :direction :probe :if-does-not-exist :create - :if-exists :error))) - (values - (notnot s) - (notnot (probe-file pn))))) - t t) - -(def-open-probe-test open.probe.23 (:external-format :default) t) -(def-open-probe-test open.probe.24 (:element-type 'character) t) -(def-open-probe-test open.probe.25 (:element-type 'bit) t) -(def-open-probe-test open.probe.26 (:element-type '(unsigned-byte 2)) t) -(def-open-probe-test open.probe.27 (:element-type '(unsigned-byte 4)) t) -(def-open-probe-test open.probe.28 (:element-type '(unsigned-byte 8)) t) -(def-open-probe-test open.probe.29 (:element-type '(unsigned-byte 9)) t) -(def-open-probe-test open.probe.30 (:element-type '(unsigned-byte 15)) t) -(def-open-probe-test open.probe.31 (:element-type '(unsigned-byte 16)) t) -(def-open-probe-test open.probe.32 (:element-type '(unsigned-byte 17)) t) -(def-open-probe-test open.probe.33 (:element-type '(unsigned-byte 31)) t) -(def-open-probe-test open.probe.34 (:element-type '(unsigned-byte 32)) t) -(def-open-probe-test open.probe.35 (:element-type '(unsigned-byte 33)) t) -(def-open-probe-test open.probe.36 (:element-type '(integer -1002 13112)) t) - -;;;; Error tests - -(deftest open.error.1 - (signals-error (open) program-error) - t) - -(deftest open.error.2 - (signals-error-always - (let ((pn #p"tmp.dat")) - (close (open pn :direction :output :if-does-not-exist :create)) - (open pn :if-exists :error :direction :output)) - file-error) - t t) - -(deftest open.error.3 - (signals-error-always - (let ((pn #p"tmp.dat")) - (close (open pn :direction :output :if-does-not-exist :create)) - (open pn :if-exists :error :direction :io)) - file-error) - t t) - -(deftest open.error.4 - (signals-error-always - (let ((pn #p"tmp.dat")) - (delete-all-versions pn) - (open pn)) - file-error) - t t) - -(deftest open.error.5 - (signals-error-always - (let ((pn #p"tmp.dat")) - (delete-all-versions pn) - (open pn :if-does-not-exist :error)) - file-error) - t t) - -(deftest open.error.6 - (signals-error-always - (let ((pn #p"tmp.dat")) - (delete-all-versions pn) - (open pn :direction :input)) - file-error) - t t) - -(deftest open.error.7 - (signals-error-always - (let ((pn #p"tmp.dat")) - (delete-all-versions pn) - (open pn :if-does-not-exist :error :direction :input)) - file-error) - t t) - -(deftest open.error.8 - (signals-error-always - (let ((pn #p"tmp.dat")) - (delete-all-versions pn) - (open pn :direction :output :if-does-not-exist :error)) - file-error) - t t) - -(deftest open.error.9 - (signals-error-always - (let ((pn #p"tmp.dat")) - (delete-all-versions pn) - (open pn :direction :io :if-does-not-exist :error)) - file-error) - t t) - -(deftest open.error.10 - (signals-error-always - (let ((pn #p"tmp.dat")) - (delete-all-versions pn) - (open pn :direction :probe :if-does-not-exist :error)) - file-error) - t t) - -(deftest open.error.11 - (signals-error-always - (let ((pn #p"tmp.dat")) - (delete-all-versions pn) - (open pn :direction :output :if-exists :overwrite)) - file-error) - t t) - -(deftest open.error.12 - (signals-error-always - (let ((pn #p"tmp.dat")) - (delete-all-versions pn) - (open pn :direction :output :if-exists :append)) - file-error) - t t) - -(deftest open.error.13 - (signals-error-always - (let ((pn #p"tmp.dat")) - (delete-all-versions pn) - (open pn :direction :io :if-exists :overwrite)) - file-error) - t t) - -(deftest open.error.14 - (signals-error-always - (let ((pn #p"tmp.dat")) - (delete-all-versions pn) - (open pn :direction :io :if-exists :append)) - file-error) - t t) - -(deftest open.error.15 - (signals-error-always - (open (make-pathname :name :wild :type "lsp")) - file-error) - t t) - -(deftest open.error.16 - (signals-error-always - (open (make-pathname :name "open" :type :wild)) - file-error) - t t) - -(deftest open.error.17 - (signals-error-always - (let ((pn (make-pathname :name "open" :type "lsp" :version :wild))) - (if (wild-pathname-p pn) (open pn) - (error 'file-error))) - file-error) - t t) - -(deftest open.error.18 - (signals-error-always - (open #p"tmp.dat" :direction :output :if-exists :supersede - :external-form (gensym)) - error) - t t) - - -;;; FIXME -- add tests for :element-type :default - -;;; FIXME -- add tests for filespec being a specialized string diff --git a/t/ansi-test/streams/output-stream-p.lsp b/t/ansi-test/streams/output-stream-p.lsp deleted file mode 100644 index f6b0130..0000000 --- a/t/ansi-test/streams/output-stream-p.lsp +++ /dev/null @@ -1,39 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Jan 13 19:46:12 2004 -;;;; Contains: Tests of OUTPUT-STREAM-P - -(in-package :cl-test) - -(deftest output-stream-p.1 - (notnot-mv (output-stream-p *standard-output*)) - t) - -(deftest output-stream-p.2 - (notnot-mv (output-stream-p *terminal-io*)) - t) - -(deftest output-stream-p.3 - (with-open-file (s "output-stream-p.txt" :direction :input) - (output-stream-p s)) - nil) - -(deftest output-stream-p.4 - (with-open-file (s "scratch/foo.txt" :direction :output - :if-exists :supersede) - (notnot-mv (output-stream-p s))) - t) - -;;; Error tests - -(deftest output-stream-p.error.1 - (signals-error (output-stream-p) program-error) - t) - -(deftest output-stream-p.error.2 - (signals-error (output-stream-p *standard-output* nil) program-error) - t) - -(deftest output-stream-p.error.3 - (check-type-error #'output-stream-p #'streamp) - nil) diff --git a/t/ansi-test/streams/peek-char.lsp b/t/ansi-test/streams/peek-char.lsp deleted file mode 100644 index f6f5c75..0000000 --- a/t/ansi-test/streams/peek-char.lsp +++ /dev/null @@ -1,329 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Jan 17 21:02:13 2004 -;;;; Contains: Tests of PEEK-CHAR - -(in-package :cl-test) - -(deftest peek-char.1 - (with-input-from-string - (*standard-input* "abc") - (values - (peek-char) - (read-char) - (read-char) - (peek-char) - (read-char))) - #\a #\a #\b #\c #\c) - -(deftest peek-char.2 - (with-input-from-string - (*standard-input* " ab") - (values - (peek-char) - (read-char) - (peek-char t) - (read-char) - (peek-char t) - (read-char))) - #\Space #\Space #\a #\a #\b #\b) - -(deftest peek-char.3 - (with-input-from-string - (*standard-input* (concatenate 'string - (string #\Newline) - (string #\Newline) - " " - (string #\Newline) - "ab")) - (values - (peek-char) - (read-char) - (peek-char t) - (read-char) - (peek-char t) - (read-char))) - #\Newline #\Newline #\a #\a #\b #\b) - -(when (name-char "Linefeed") - (deftest peek-char.4 - (with-input-from-string - (*standard-input* (concatenate 'string - (string (name-char "Linefeed")) - (string (name-char "Linefeed")) - "abc")) - (values - (peek-char) - (read-char) - (peek-char t) - (read-char))) - #.(name-char "Linefeed") - #.(name-char "Linefeed") - #\a #\a)) - -(when (name-char "Page") - (deftest peek-char.5 - (with-input-from-string - (*standard-input* (concatenate 'string - (string (name-char "Page")) - (string (name-char "Page")) - "abc")) - (values - (peek-char) - (read-char) - (peek-char t) - (read-char))) - #.(name-char "Page") - #.(name-char "Page") - #\a #\a)) - -(when (name-char "Tab") - (deftest peek-char.6 - (with-input-from-string - (*standard-input* (concatenate 'string - (string (name-char "Tab")) - (string (name-char "Tab")) - "abc")) - (values - (peek-char) - (read-char) - (peek-char t) - (read-char))) - #.(name-char "Tab") - #.(name-char "Tab") - #\a #\a)) - -(when (name-char "Return") - (deftest peek-char.7 - (with-input-from-string - (*standard-input* (concatenate 'string - (string (name-char "Return")) - (string (name-char "Return")) - "abc")) - (values - (peek-char) - (read-char) - (peek-char t) - (read-char))) - #.(name-char "Return") - #.(name-char "Return") - #\a #\a)) - -(deftest peek-char.8 - (with-input-from-string - (s "a bcd") - (values - (peek-char nil s) - (read-char s) - (peek-char t s) - (read-char s) - (peek-char t s) - (read-char s))) - #\a #\a #\b #\b #\c #\c) - -(deftest peek-char.9 - (with-input-from-string - (*standard-input* " a bCcde") - (values - (peek-char #\c) - (read-char) - (read-char))) - #\c #\c #\d) - -(deftest peek-char.10 - (with-input-from-string - (*standard-input* " ; foo") - (values - (peek-char t) - (read-char))) - #\; #\;) - -(deftest peek-char.11 - (with-input-from-string - (s "") - (peek-char nil s nil)) - nil) - -(deftest peek-char.12 - (with-input-from-string - (s "") - (peek-char nil s nil 'foo)) - foo) - -(deftest peek-char.13 - (with-input-from-string - (s " ") - (peek-char t s nil)) - nil) - -(deftest peek-char.14 - (with-input-from-string - (s " ") - (peek-char t s nil 'foo)) - foo) - -(deftest peek-char.15 - (with-input-from-string - (s "ab c d") - (peek-char #\z s nil)) - nil) - -(deftest peek-char.16 - (with-input-from-string - (s "ab c d") - (peek-char #\z s nil 'foo)) - foo) - -;;; Interaction with echo streams - -(deftest peek-char.17 - (block done - (with-input-from-string - (is "ab") - (with-output-to-string - (os) - (let ((es (make-echo-stream is os))) - (let ((pos1 (file-position os))) - (unless (zerop pos1) (return-from done :good)) - (peek-char nil es nil) - (let ((pos2 (file-position os))) - (return-from done - (if (eql pos1 pos2) - :good - (list pos1 pos2))))))))) - :good) - -(deftest peek-char.18 - (block done - (with-input-from-string - (is " ab") - (with-output-to-string - (os) - (let ((es (make-echo-stream is os))) - (let ((pos1 (file-position os))) - (unless (zerop pos1) (return-from done :good)) - (peek-char t es nil) - (let ((pos2 (file-position os))) - (return-from done - (if (eql pos1 pos2) - pos1 - :good)))))))) - :good) - -(deftest peek-char.19 - (block done - (with-input-from-string - (is "abcde") - (with-output-to-string - (os) - (let ((es (make-echo-stream is os))) - (let ((pos1 (file-position os))) - (unless (zerop pos1) (return-from done :good)) - (peek-char #\c es nil) - (let ((pos2 (file-position os))) - (return-from done - (if (eql pos1 pos2) - pos1 - :good)))))))) - :good) - -;;; Interactions with the readtable - -(deftest peek-char.20 - (let ((*readtable* (copy-readtable))) - (set-syntax-from-char #\Space #\a) - (with-input-from-string - (*standard-input* " x") - (values - (peek-char) - (read-char) - (peek-char t) - (read-char)))) - #\Space #\Space - #\Space #\Space ; *not* #\x #\x - ) - -(deftest peek-char.21 - (let ((*readtable* (copy-readtable))) - (set-syntax-from-char #\x #\Space) - (with-input-from-string - (*standard-input* "xxa") - (values - (peek-char) - (read-char) - (peek-char t) - (read-char)))) - #\x #\x - #\a #\a ; *not* #\x #\x - ) - -;;; Stream designators are accepted for the stream argument - -(deftest peek-char.22 - (with-input-from-string - (is "!?*") - (let ((*terminal-io* (make-two-way-stream is (make-string-output-stream)))) - (peek-char nil t))) - #\!) - -(deftest peek-char.23 - (with-input-from-string - (*standard-input* "345") - (peek-char nil nil)) - #\3) - -;;; Error tests - -(deftest peek-char.error.1 - (signals-error - (with-input-from-string - (s "abc") - (peek-char s nil nil nil nil 'nonsense)) - program-error) - t) - - -(deftest peek-char.error.2 - (signals-error-always - (with-input-from-string - (*standard-input* "") - (peek-char)) - end-of-file) - t t) - -(deftest peek-char.error.3 - (signals-error-always - (with-input-from-string - (s "") - (peek-char nil s)) - end-of-file) - t t) - -(deftest peek-char.error.4 - (signals-error-always - (with-input-from-string - (s " ") - (peek-char t s)) - end-of-file) - t t) - -(deftest peek-char.error.5 - (signals-error-always - (with-input-from-string - (s "abcd") - (peek-char #\z s)) - end-of-file) - t t) - -;;; There was a consensus on comp.lang.lisp that the requirement -;;; that an end-of-file error be thrown in the following case -;;; is a spec bug -#| -(deftest peek-char.error.6 - (signals-error - (with-input-from-string - (s "") - (peek-char nil s nil nil t)) - end-of-file) - t) -|# diff --git a/t/ansi-test/streams/read-byte.lsp b/t/ansi-test/streams/read-byte.lsp deleted file mode 100644 index afbf2e1..0000000 --- a/t/ansi-test/streams/read-byte.lsp +++ /dev/null @@ -1,194 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Jan 17 17:30:49 2004 -;;;; Contains: Tests of READ-BYTE, WRITE-BYTE - -(in-package :cl-test) - -(deftest read-byte.1 - (let ((s (open "foo.txt" - :direction :output - :if-exists :supersede - :element-type '(unsigned-byte 8)))) - (values - (write-byte 17 s) - (close s) - (progn - (setq s (open "foo.txt" - :direction :input - :element-type '(unsigned-byte 8))) - (read-byte s)) - (close s))) - 17 t 17 t) - -(deftest read-byte.2 - (let ((s (open "foo.txt" - :direction :output - :if-exists :supersede - :element-type '(unsigned-byte 8)))) - (values - (close s) - (progn - (setq s (open "foo.txt" - :direction :input - :element-type '(unsigned-byte 8))) - (read-byte s nil 'foo)) - (read-byte s nil) - (close s))) - t foo nil t) - -(deftest read-byte.3 - (loop with b1 = 0 - and b2 = 0 - for i from 1 to 32 - do (let ((s (open "foo.txt" - :direction :output - :if-exists :supersede - :element-type `(unsigned-byte ,i)))) - (write-byte (1- (ash 1 i)) s) - (write-byte 1 s) - (close s)) - unless (let ((s (open "foo.txt" - :direction :input - :element-type `(unsigned-byte ,i)))) - (prog1 - (and (eql (setq b1 (read-byte s)) (1- (ash 1 i))) - (eql (setq b2 (read-byte s)) 1)) - (close s))) - collect (list i b1 b2)) - nil) - -(deftest read-byte.4 - (loop with b1 = 0 - and b2 = 0 - for i from 33 to 200 by 7 - do (let ((s (open "foo.txt" - :direction :output - :if-exists :supersede - :element-type `(unsigned-byte ,i)))) - (write-byte (1- (ash 1 i)) s) - (write-byte 1 s) - (close s)) - unless (let ((s (open "foo.txt" - :direction :input - :element-type `(unsigned-byte ,i)))) - (prog1 - (and (eql (setq b1 (read-byte s)) (1- (ash 1 i))) - (eql (setq b2 (read-byte s)) 1)) - (close s))) - collect (list i b1 b2)) - nil) - -;;; Error tests - -(deftest read-byte.error.1 - (signals-error (read-byte) program-error) - t) - -(deftest read-byte.error.2 - (progn - (let ((s (open "foo.txt" - :direction :output - :if-exists :supersede - :element-type `(unsigned-byte 8)))) - (close s)) - (signals-error - (let ((s (open "foo.txt" - :direction :input - :element-type '(unsigned-byte 8)))) - (read-byte s)) - end-of-file)) - t) - -(deftest read-byte.error.3 - (progn - (let ((s (open "foo.txt" - :direction :output - :if-exists :supersede))) - (close s)) - (signals-error - (let ((s (open "foo.txt" :direction :input))) - (unwind-protect - (read-byte s) - (close s))) - error)) - t) - -(deftest read-byte.error.4 - (signals-error-always - (progn - (let ((s (open "foo.txt" - :direction :output - :if-exists :supersede - :element-type '(unsigned-byte 8)))) - (close s)) - (let ((s (open "foo.txt" - :direction :input - :element-type '(unsigned-byte 8)))) - (unwind-protect - (read-byte s t) - (close s)))) - end-of-file) - t t) - -(deftest read-byte.error.5 - (check-type-error #'read-byte #'streamp) - nil) - -(deftest read-byte.error.6 - (progn - (let ((s (open "foo.txt" - :direction :output - :if-exists :supersede - :element-type '(unsigned-byte 8)))) - (close s)) - (signals-error - (let ((s (open "foo.txt" - :direction :input - :element-type '(unsigned-byte 8)))) - (unwind-protect - (read-byte s t t nil) - (close s))) - program-error)) - t) - - -(deftest write-byte.error.1 - (signals-error (write-byte) program-error) - t) - -(deftest write-byte.error.2 - (signals-error (write-byte 0) program-error) - t) - -(deftest write-byte.error.3 - (signals-error - (let ((s (open "foo.txt" - :direction :output - :if-exists :supersede - :element-type '(unsigned-byte 8)))) - (unwind-protect - (write 1 s nil) - (close s))) - program-error) - t) - -(deftest write-byte.error.4 - (check-type-error #'(lambda (x) (write-byte 0 x)) #'streamp) - nil) - -(deftest write-byte.error.5 - (signals-error - (let ((s (open "foo.txt" - :direction :output - :if-exists :supersede))) - (unwind-protect - (write 1 s) - (close s))) - error) - t) - - - - - diff --git a/t/ansi-test/streams/read-char-no-hang.lsp b/t/ansi-test/streams/read-char-no-hang.lsp deleted file mode 100644 index cea82c0..0000000 --- a/t/ansi-test/streams/read-char-no-hang.lsp +++ /dev/null @@ -1,123 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jan 18 20:32:38 2004 -;;;; Contains: Tests of READ-CHAR-NO-HANG - -(in-package :cl-test) - -(deftest read-char-no-hang.1 - (with-input-from-string - (*standard-input* "a") - (read-char-no-hang)) - #\a) - -(deftest read-char-no-hang.2 - (with-input-from-string - (*standard-input* "abc") - (values - (read-char-no-hang) - (read-char-no-hang) - (read-char-no-hang))) - #\a #\b #\c) - -(when (code-char 0) - (deftest read-char-no-hang.3 - (with-input-from-string - (*standard-input* (concatenate 'string - "a" - (string (code-char 0)) - "b")) - (values - (read-char-no-hang) - (read-char-no-hang) - (read-char-no-hang))) - #\a #.(code-char 0) #\b)) - -(deftest read-char-no-hang.4 - (with-input-from-string - (s "abc") - (values - (read-char-no-hang s) - (read-char-no-hang s) - (read-char-no-hang s))) - #\a #\b #\c) - -(deftest read-char-no-hang.5 - (with-input-from-string - (s "") - (read-char-no-hang s nil)) - nil) - -(deftest read-char-no-hang.6 - (with-input-from-string - (s "") - (read-char-no-hang s nil 'foo)) - foo) - -(deftest read-char-no-hang.7 - (with-input-from-string - (s "abc") - (values - (read-char-no-hang s nil nil) - (read-char-no-hang s nil nil) - (read-char-no-hang s nil nil))) - #\a #\b #\c) - -(deftest read-char-no-hang.8 - (with-input-from-string - (s "abc") - (values - (read-char-no-hang s nil t) - (read-char-no-hang s nil t) - (read-char-no-hang s nil t))) - #\a #\b #\c) - -(deftest read-char-no-hang.9 - (with-input-from-string - (is "!?*") - (let ((*terminal-io* (make-two-way-stream is (make-string-output-stream)))) - (read-char-no-hang t))) - #\!) - -(deftest read-char-no-hang.10 - (with-input-from-string - (*standard-input* "345") - (read-char-no-hang nil)) - #\3) - -;;; Need a test of the non-hanging. -;;; This is hard to do portably. - -;;; Error tests - -(deftest read-char-no-hang.error.1 - (signals-error - (with-input-from-string - (s "abc") - (read-char-no-hang s nil nil nil nil)) - program-error) - t) - -(deftest read-char-no-hang.error.2 - (signals-error-always - (with-input-from-string - (s "") - (read-char-no-hang s)) - end-of-file) - t t) - -(deftest read-char-no-hang.error.3 - (signals-error-always - (with-input-from-string - (s "") - (read-char-no-hang s t)) - end-of-file) - t t) - -(deftest read-char-no-hang.error.4 - (signals-error-always - (with-input-from-string - (s "") - (read-char-no-hang s t t)) - end-of-file) - t t) diff --git a/t/ansi-test/streams/read-char.lsp b/t/ansi-test/streams/read-char.lsp deleted file mode 100644 index 85a3775..0000000 --- a/t/ansi-test/streams/read-char.lsp +++ /dev/null @@ -1,121 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jan 18 08:53:56 2004 -;;;; Contains: Tests of READ-CHAR - -(in-package :cl-test) - -(deftest read-char.1 - (with-input-from-string - (*standard-input* "a") - (read-char)) - #\a) - -(deftest read-char.2 - (with-input-from-string - (*standard-input* "abc") - (values - (read-char) - (read-char) - (read-char))) - #\a #\b #\c) - -(when (code-char 0) - (deftest read-char.3 - (with-input-from-string - (*standard-input* (concatenate 'string - "a" - (string (code-char 0)) - "b")) - (values - (read-char) - (read-char) - (read-char))) - #\a #.(code-char 0) #\b)) - -(deftest read-char.4 - (with-input-from-string - (s "abc") - (values - (read-char s) - (read-char s) - (read-char s))) - #\a #\b #\c) - -(deftest read-char.5 - (with-input-from-string - (s "") - (read-char s nil)) - nil) - -(deftest read-char.6 - (with-input-from-string - (s "") - (read-char s nil 'foo)) - foo) - -(deftest read-char.7 - (with-input-from-string - (s "abc") - (values - (read-char s nil nil) - (read-char s nil nil) - (read-char s nil nil))) - #\a #\b #\c) - -(deftest read-char.8 - (with-input-from-string - (s "abc") - (values - (read-char s nil t) - (read-char s nil t) - (read-char s nil t))) - #\a #\b #\c) - -(deftest read-char.9 - (with-input-from-string - (is "!?*") - (let ((*terminal-io* (make-two-way-stream is (make-string-output-stream)))) - (read-char t))) - #\!) - -(deftest read-char.10 - (with-input-from-string - (*standard-input* "345") - (read-char nil)) - #\3) - - -;;; Error tests - -(deftest read-char.error.1 - (signals-error - (with-input-from-string - (s "abc") - (read-char s nil nil nil nil)) - program-error) - t) - -(deftest read-char.error.2 - (signals-error-always - (with-input-from-string - (s "") - (read-char s)) - end-of-file) - t t) - -(deftest read-char.error.3 - (signals-error-always - (with-input-from-string - (s "") - (read-char s t)) - end-of-file) - t t) - -(deftest read-char.error.4 - (signals-error-always - (with-input-from-string - (s "") - (read-char s t t)) - end-of-file) - t t) diff --git a/t/ansi-test/streams/read-line.lsp b/t/ansi-test/streams/read-line.lsp deleted file mode 100644 index 8f9c744..0000000 --- a/t/ansi-test/streams/read-line.lsp +++ /dev/null @@ -1,104 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jan 18 20:53:59 2004 -;;;; Contains: Tests of READ-LINE - -(in-package :cl-test) - -(deftest read-line.1 - (with-input-from-string - (*standard-input* " abcd ") - (let ((vals (multiple-value-list (read-line)))) - (assert (= (length vals) 2)) - (values (first vals) (notnot (second vals))))) - " abcd " t) - -(deftest read-line.2 - (with-input-from-string - (*standard-input* (string #\Newline)) - (read-line)) - "" nil) - -(deftest read-line.3 - (with-input-from-string - (s (concatenate 'string "abc" (string #\Newline))) - (read-line s)) - "abc" nil) - -(deftest read-line.4 - (with-input-from-string - (s "") - (let ((vals (multiple-value-list (read-line s nil)))) - (assert (= (length vals) 2)) - (values (first vals) (notnot (second vals))))) - nil t) - -(deftest read-line.5 - (with-input-from-string - (s "") - (let ((vals (multiple-value-list (read-line s nil 'foo)))) - (assert (= (length vals) 2)) - (values (first vals) (notnot (second vals))))) - foo t) - -(deftest read-line.6 - (with-input-from-string - (s " abcd ") - (let ((vals (multiple-value-list (read-line s t nil t)))) - (assert (= (length vals) 2)) - (values (first vals) (notnot (second vals))))) - " abcd " t) - -(deftest read-line.7 - (with-input-from-string - (is "abc") - (let ((*terminal-io* (make-two-way-stream is *standard-output*))) - (let ((vals (multiple-value-list (read-line t)))) - (assert (= (length vals) 2)) - (assert (second vals)) - (first vals)))) - "abc") - -(deftest read-line.8 - (with-input-from-string - (*standard-input* "abc") - (let ((vals (multiple-value-list (read-line nil)))) - (assert (= (length vals) 2)) - (assert (second vals)) - (first vals))) - "abc") - -;;; Error tests - -(deftest read-line.error.1 - (signals-error - (with-input-from-string - (s (concatenate 'string "abc" (string #\Newline))) - (read-line s t nil nil nil)) - program-error) - t) - -(deftest read-line.error.2 - (signals-error-always - (with-input-from-string - (s "") - (read-line s)) - end-of-file) - t t) - -(deftest read-line.error.3 - (signals-error-always - (with-input-from-string - (*standard-input* "") - (read-line)) - end-of-file) - t t) - -(deftest read-line.error.4 - (signals-error-always - (with-input-from-string - (s "") - (read-line s t)) - end-of-file) - t t) - diff --git a/t/ansi-test/streams/read-sequence.lsp b/t/ansi-test/streams/read-sequence.lsp deleted file mode 100644 index 1010f8b..0000000 --- a/t/ansi-test/streams/read-sequence.lsp +++ /dev/null @@ -1,300 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Jan 19 06:55:04 2004 -;;;; Contains: Tests of READ-SEQUENCE - -(in-package :cl-test) - -;;; Read into a string - -(defmacro def-read-sequence-test (name init args input &rest expected) - `(deftest ,name - (let ((s ,init)) - (with-input-from-string - (is ,input) - (values - (read-sequence s is ,@args) - s))) - ,@expected)) - -(def-read-sequence-test read-sequence.string.1 (copy-seq " ") - () "abcdefghijk" 5 "abcde") - -(def-read-sequence-test read-sequence.string.2 (copy-seq " ") - () "abc" 3 "abc ") - -(def-read-sequence-test read-sequence.string.3 (copy-seq " ") - (:start 1) "abcdefghijk" 5 " abcd") - -(def-read-sequence-test read-sequence.string.4 (copy-seq " ") - (:end 3) "abcdefghijk" 3 "abc ") - -(def-read-sequence-test read-sequence.string.5 (copy-seq " ") - (:start 1 :end 4) "abcdefghijk" 4 " abc ") - -(def-read-sequence-test read-sequence.string.6 (copy-seq " ") - (:start 0 :end 0) "abcdefghijk" 0 " ") - -(def-read-sequence-test read-sequence.string.7 (copy-seq " ") - (:end nil) "abcdefghijk" 5 "abcde") - -(def-read-sequence-test read-sequence.string.8 (copy-seq " ") - (:allow-other-keys nil) "abcdefghijk" 5 "abcde") - -(def-read-sequence-test read-sequence.string.9 (copy-seq " ") - (:allow-other-keys t :foo 'bar) "abcdefghijk" 5 "abcde") - -(def-read-sequence-test read-sequence.string.10 (copy-seq " ") - (:foo 'bar :allow-other-keys 'x) "abcdefghijk" 5 "abcde") - -(def-read-sequence-test read-sequence.string.11 (copy-seq " ") - (:foo 'bar :allow-other-keys 'x :allow-other-keys nil) - "abcdefghijk" 5 "abcde") - -(def-read-sequence-test read-sequence.string.12 (copy-seq " ") - (:end 5 :end 3 :start 0 :start 1) "abcdefghijk" 5 "abcde") - -;;; Read into a base string - -(def-read-sequence-test read-sequence.base-string.1 - (make-array 5 :element-type 'base-char) - () "abcdefghijk" 5 "abcde") - -(def-read-sequence-test read-sequence.base-string.2 - (make-array 5 :element-type 'base-char :initial-element #\Space) - () "abc" 3 "abc ") - -(def-read-sequence-test read-sequence.base-string.3 - (make-array 5 :element-type 'base-char :initial-element #\Space) - (:start 1) "abcdefghijk" 5 " abcd") - -(def-read-sequence-test read-sequence.base-string.4 - (make-array 5 :element-type 'base-char :initial-element #\Space) - (:end 3) "abcdefghijk" 3 "abc ") - -(def-read-sequence-test read-sequence.base-string.5 - (make-array 5 :element-type 'base-char :initial-element #\Space) - (:start 1 :end 4) "abcdefghijk" 4 " abc ") - -(def-read-sequence-test read-sequence.base-string.6 - (make-array 5 :element-type 'base-char :initial-element #\Space) - (:start 0 :end 0) "abcdefghijk" 0 " ") - -(def-read-sequence-test read-sequence.base-string.7 - (make-array 5 :element-type 'base-char :initial-element #\Space) - (:end nil) "abcdefghijk" 5 "abcde") - -;;; Read into a list - -(def-read-sequence-test read-sequence.list.1 (make-list 5) - () "abcdefghijk" 5 (#\a #\b #\c #\d #\e)) - -(def-read-sequence-test read-sequence.list.2 (make-list 5) - () "abc" 3 (#\a #\b #\c nil nil)) - -(def-read-sequence-test read-sequence.list.3 (make-list 5) - (:start 1) "abcdefghijk" 5 (nil #\a #\b #\c #\d)) - -(def-read-sequence-test read-sequence.list.4 (make-list 5) - (:end 3) "abcdefghijk" 3 (#\a #\b #\c nil nil)) - -(def-read-sequence-test read-sequence.list.5 (make-list 5) - (:end 4 :start 1) "abcdefghijk" 4 (nil #\a #\b #\c nil)) - -(def-read-sequence-test read-sequence.list.6 (make-list 5) - (:start 0 :end 0) "abcdefghijk" 0 (nil nil nil nil nil)) - -(def-read-sequence-test read-sequence.list.7 (make-list 5) - (:end nil) "abcdefghijk" 5 (#\a #\b #\c #\d #\e)) - -;;; Read into a vector - -(def-read-sequence-test read-sequence.vector.1 - (vector nil nil nil nil nil) - () "abcdefghijk" 5 #(#\a #\b #\c #\d #\e)) - -(def-read-sequence-test read-sequence.vector.2 - (vector nil nil nil nil nil) - () "abc" 3 #(#\a #\b #\c nil nil)) - -(def-read-sequence-test read-sequence.vector.3 - (vector nil nil nil nil nil) - (:start 2) "abcdefghijk" 5 #(nil nil #\a #\b #\c)) - -(def-read-sequence-test read-sequence.vector.4 - (vector nil nil nil nil nil) - (:start 1 :end 4) "abcdefghijk" 4 #(nil #\a #\b #\c nil)) - -(def-read-sequence-test read-sequence.vector.5 - (vector nil nil nil nil nil) - (:end 2) "abcdefghijk" 2 #(#\a #\b nil nil nil)) - -(def-read-sequence-test read-sequence.vector.6 - (vector nil nil nil nil nil) - (:end 0 :start 0) "abcdefghijk" 0 #(nil nil nil nil nil)) - -(def-read-sequence-test read-sequence.vector.7 - (vector nil nil nil nil nil) - (:end nil) "abcdefghijk" 5 #(#\a #\b #\c #\d #\e)) - -;;; Read into a vector with a fill pointer - -(def-read-sequence-test read-sequence.fill-vector.1 - (make-array 10 :initial-element nil :fill-pointer 5) - () "abcdefghijk" 5 #(#\a #\b #\c #\d #\e)) - -(def-read-sequence-test read-sequence.fill-vector.2 - (make-array 10 :initial-element nil :fill-pointer 5) - () "ab" 2 #(#\a #\b nil nil nil)) - -(def-read-sequence-test read-sequence.fill-vector.3 - (make-array 10 :initial-element nil :fill-pointer 5) - () "" 0 #(nil nil nil nil nil)) - -(def-read-sequence-test read-sequence.fill-vector.4 - (make-array 10 :initial-element nil :fill-pointer 5) - (:start 2) "abcdefghijk" 5 #(nil nil #\a #\b #\c)) - -(def-read-sequence-test read-sequence.fill-vector.5 - (make-array 10 :initial-element nil :fill-pointer 5) - (:start 1 :end 4) "abcdefghijk" 4 #(nil #\a #\b #\c nil)) - -(def-read-sequence-test read-sequence.fill-vector.6 - (make-array 10 :initial-element nil :fill-pointer 5) - (:end 2) "abcdefghijk" 2 #(#\a #\b nil nil nil)) - -(def-read-sequence-test read-sequence.fill-vector.7 - (make-array 10 :initial-element nil :fill-pointer 5) - (:end 0 :start 0) "abcdefghijk" 0 #(nil nil nil nil nil)) - -(def-read-sequence-test read-sequence.fill-vector.8 - (make-array 10 :initial-element nil :fill-pointer 5) - (:end nil) "abcdefghijk" 5 #(#\a #\b #\c #\d #\e)) - -;;; Nil vectors - -(deftest read-sequence.nil-vector.1 - :notes (:nil-vectors-are-strings) - (let ((s (make-array 0 :element-type nil))) - (with-input-from-string - (is "abcde") - (values - (read-sequence s is) - s))) - 0 "") - -;;; Read into a bit vector - -(defmacro def-read-sequence-bv-test (name init args &rest expected) - `(deftest ,name - ;; Create output file - (progn - (let (os) - (unwind-protect - (progn - (setq os (open "temp.dat" :direction :output - :element-type '(unsigned-byte 8) - :if-exists :supersede)) - (loop for i in '(0 1 1 0 0 1 1 0 1 0 1 1 1 0) - do (write-byte i os))) - (when os (close os)))) - (let (is (bv (copy-seq ,init))) - (unwind-protect - (progn - (setq is (open "temp.dat" :direction :input - :element-type '(unsigned-byte 8))) - (values - (read-sequence bv is ,@args) - bv)) - (when is (close is))))) - ,@expected)) - -(def-read-sequence-bv-test read-sequence.bv.1 #*00000000000000 () - 14 #*01100110101110) - -(def-read-sequence-bv-test read-sequence.bv.2 #*00000000000000 (:start 0) - 14 #*01100110101110) - -(def-read-sequence-bv-test read-sequence.bv.3 #*00000000000000 (:end 14) - 14 #*01100110101110) - -(def-read-sequence-bv-test read-sequence.bv.4 #*00000000000000 (:end nil) - 14 #*01100110101110) - -(def-read-sequence-bv-test read-sequence.bv.5 #*00000000000000 (:start 2) - 14 #*00011001101011) - -(def-read-sequence-bv-test read-sequence.bv.6 #*00000000000000 - (:start 2 :end 13) - 13 #*00011001101010) - -(def-read-sequence-bv-test read-sequence.bv.7 #*00000000000000 (:end 6) - 6 #*01100100000000) - -;;; Error cases - -(deftest read-sequence.error.1 - (signals-error (read-sequence) program-error) - t) - -(deftest read-sequence.error.2 - (signals-error (read-sequence (make-string 10)) program-error) - t) - -(deftest read-sequence.error.3 - (signals-error - (read-sequence (make-string 5) (make-string-input-stream "abc") :start) - program-error) - t) - -(deftest read-sequence.error.4 - (signals-error - (read-sequence (make-string 5) (make-string-input-stream "abc") :foo 1) - program-error) - t) - -(deftest read-sequence.error.5 - (signals-error - (read-sequence (make-string 5) (make-string-input-stream "abc") - :allow-other-keys nil :bar 2) - program-error) - t) - -(deftest read-sequence.error.6 - (check-type-error #'(lambda (x) (read-sequence x (make-string-input-stream "abc"))) - #'sequencep) - nil) - -(deftest read-sequence.error.7 - (signals-error - (read-sequence (cons 'a 'b) (make-string-input-stream "abc")) - type-error) - t) - -;;; This test appears to cause Allegro CL to crash -(deftest read-sequence.error.8 - (signals-type-error x -1 - (read-sequence (make-string 3) - (make-string-input-stream "abc") - :start x)) - t) - -(deftest read-sequence.error.9 - (check-type-error #'(lambda (s) - (read-sequence (make-string 3) (make-string-input-stream "abc") - :start s)) - (typef 'unsigned-byte)) - nil) - -(deftest read-sequence.error.10 - (signals-type-error x -1 - (read-sequence (make-string 3) (make-string-input-stream "abc") - :end x)) - t) - -(deftest read-sequence.error.11 - (check-type-error #'(lambda (e) - (read-sequence (make-string 3) (make-string-input-stream "abc") - :end e)) - (typef '(or unsigned-byte null))) - nil) diff --git a/t/ansi-test/streams/stream-element-type.lsp b/t/ansi-test/streams/stream-element-type.lsp deleted file mode 100644 index a114944..0000000 --- a/t/ansi-test/streams/stream-element-type.lsp +++ /dev/null @@ -1,102 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Jan 13 20:09:50 2004 -;;;; Contains: Tests for STREAM-ELEMENT-TYPE - -(in-package :cl-test) - -(deftest stream-element-type.1 - (loop for s in (list *debug-io* *error-output* *query-io* - *standard-input* *standard-output* - *trace-output* *terminal-io*) - for results = (multiple-value-list (stream-element-type s)) - unless (and (eql (length results) 1) - (car results)) - collect s) - nil) - -(deftest stream-element-type.2 - (let ((pn "foo.txt")) - (loop for i from 1 to 100 - for etype = `(unsigned-byte ,i) - for s = (progn (delete-all-versions pn) - (open pn :direction :output - :element-type etype)) - unless - (multiple-value-bind (sub good) - (subtypep etype (stream-element-type s)) - (close s) - (or sub (not good))) - collect i)) - nil) - -(deftest stream-element-type.3 - (let ((pn "foo.txt")) - (loop for i from 1 to 100 - for etype = `(signed-byte ,i) - for s = (progn (delete-all-versions pn) - (open pn :direction :output - :element-type etype)) - unless - (multiple-value-bind (sub good) - (subtypep etype (stream-element-type s)) - (close s) - (or sub (not good))) - collect i)) - nil) - -(deftest stream-element-type.4 - (let ((pn "foo.txt")) - (loop for i from 1 to 100 - for etype = `(integer 0 ,i) - for s = (progn (delete-all-versions pn) - (open pn :direction :output - :element-type etype)) - unless - (multiple-value-bind (sub good) - (subtypep etype (stream-element-type s)) - (close s) - (or sub (not good))) - collect i)) - nil) - - -(deftest stream-element-type.5 - :notes (:assume-no-simple-streams) - (let ((pn "foo.txt")) - (delete-all-versions pn) - (let ((s (open pn :direction :output))) - (let ((etype (stream-element-type s))) - (unwind-protect - (equalt (multiple-value-list (subtypep* 'character etype)) - '(nil t)) - (close s))))) - nil) - -(deftest stream-element-type.6 - :notes (:assume-no-simple-streams) - (let ((pn "foo.txt")) - (delete-all-versions pn) - (let ((s (open pn :direction :output - :element-type :default))) - (let ((etype (stream-element-type s))) - (unwind-protect - (multiple-value-bind (sub1 good1) (subtypep* etype 'integer) - (multiple-value-bind (sub2 good2) (subtypep* etype 'character) - (or (not good1) - (not good2) - sub1 sub2))) - (close s))))) - t) - -(deftest stream-element-type.error.1 - (signals-error (stream-element-type) program-error) - t) - -(deftest stream-element-type.error.2 - (signals-error (stream-element-type *standard-input* nil) program-error) - t) - -(deftest stream-element-type.error.3 - (check-type-error #'stream-element-type #'streamp) - nil) diff --git a/t/ansi-test/streams/stream-error-stream.lsp b/t/ansi-test/streams/stream-error-stream.lsp deleted file mode 100644 index 4d75ab3..0000000 --- a/t/ansi-test/streams/stream-error-stream.lsp +++ /dev/null @@ -1,34 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Feb 14 20:51:33 2004 -;;;; Contains: Tests of STREAM-ERROR-STREAM - -(in-package :cl-test) - -(deftest stream-error-stream.1 - (with-input-from-string - (s "") - (handler-case - (read-char s) - (stream-error (c) (eqlt (stream-error-stream c) s)))) - t) - -;;; Error tests - -(deftest stream-error-stream.error.1 - (signals-error (stream-error-stream) program-error) - t) - - -(deftest stream-error-stream.error.2 - (signals-error - (with-input-from-string - (s "") - (handler-case - (read-char s) - (stream-error (c) (stream-error-stream c nil)))) - program-error) - t) - - - diff --git a/t/ansi-test/streams/stream-external-format.lsp b/t/ansi-test/streams/stream-external-format.lsp deleted file mode 100644 index 528986c..0000000 --- a/t/ansi-test/streams/stream-external-format.lsp +++ /dev/null @@ -1,24 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Jan 27 20:53:21 2004 -;;;; Contains: Tests of STREAM-EXTERNAL-FORMAT - -(in-package :cl-test) - -;;; This is tested in open.lsp - -;;; Error tests - -(deftest stream-external-format.error.1 - (signals-error (stream-external-format) program-error) - t) - -(deftest stream-external-format.error.2 - (signals-error - (let ((pn #p"tmp.dat")) - (delete-all-versions pn) - (with-open-file - (s pn :direction :output :if-exists :supersede) - (stream-external-format s nil))) - program-error) - t) diff --git a/t/ansi-test/streams/streamp.lsp b/t/ansi-test/streams/streamp.lsp deleted file mode 100644 index 4d03331..0000000 --- a/t/ansi-test/streams/streamp.lsp +++ /dev/null @@ -1,44 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Jan 17 17:12:38 2004 -;;;; Contains: Tests for STREAMP - -(in-package :cl-test) - -(deftest streamp.1 - (loop for s in (list *debug-io* *error-output* *query-io* - *standard-input* *standard-output* - *trace-output* *terminal-io*) - unless (equal (multiple-value-list (notnot-mv (streamp s))) - '(t)) - collect s) - nil) - -(deftest streamp.2 - (check-type-predicate #'streamp 'stream) - nil) - -(deftest streamp.3 - (let ((s (open "foo.txt" :direction :output - :if-exists :supersede))) - (close s) - (notnot-mv (streamp s))) - t) - -(deftest streamp.4 - (let ((s (open "foo.txt" :direction :output - :if-exists :supersede))) - (unwind-protect - (notnot-mv (streamp s)) - (close s))) - t) - -;;; Error tests - -(deftest streamp.error.1 - (signals-error (streamp) program-error) - t) - -(deftest streamp.error.2 - (signals-error (streamp *standard-input* nil) program-error) - t) diff --git a/t/ansi-test/streams/synonym-stream-symbol.lsp b/t/ansi-test/streams/synonym-stream-symbol.lsp deleted file mode 100644 index c71c298..0000000 --- a/t/ansi-test/streams/synonym-stream-symbol.lsp +++ /dev/null @@ -1,23 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Jan 29 21:21:06 2004 -;;;; Contains: Tests of SYNONYM-STREAM-SYMBOL - -(in-package :cl-test) - -(deftest synonym-stream-symbol.1 - (synonym-stream-symbol (make-synonym-stream '*standard-input*)) - *standard-input*) - -(deftest synonym-stream-symbol.error.1 - (signals-error (synonym-stream-symbol) program-error) - t) - -(deftest synonym-stream-symbol.error.2 - (signals-error (synonym-stream-symbol - (make-synonym-stream '*terminal-io*) - nil) - program-error) - t) - - diff --git a/t/ansi-test/streams/terpri.lsp b/t/ansi-test/streams/terpri.lsp deleted file mode 100644 index 89a07f1..0000000 --- a/t/ansi-test/streams/terpri.lsp +++ /dev/null @@ -1,62 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jan 18 20:35:57 2004 -;;;; Contains: Tests of TERPRI - -(in-package :cl-test) - -(deftest terpri.1 - (let (result) - (values - (with-output-to-string - (*standard-output*) - (write-char #\a) - (setq result (terpri))) - result)) - #.(concatenate 'string "a" (string #\Newline)) - nil) - -(deftest terpri.2 - (let (result) - (values - (with-output-to-string - (s) - (write-char #\a s) - (setq result (terpri s))) - result)) - #.(concatenate 'string "a" (string #\Newline)) - nil) - -(deftest terpri.3 - (with-output-to-string - (s) - (write-char #\x s) - (terpri s) - (terpri s) - (write-char #\y s)) - #.(concatenate 'string "x" (string #\Newline) (string #\Newline) "y")) - -(deftest terpri.4 - (with-output-to-string - (os) - (let ((*terminal-io* (make-two-way-stream *standard-input* os))) - (terpri t) - (finish-output t))) - #.(string #\Newline)) - -(deftest terpri.5 - (with-output-to-string - (*standard-output*) - (terpri nil)) - #.(string #\Newline)) - -;;; Error tests - -(deftest terpri.error.1 - (signals-error - (with-output-to-string - (s) - (terpri s nil)) - program-error) - t) - diff --git a/t/ansi-test/streams/two-way-stream-input-stream.lsp b/t/ansi-test/streams/two-way-stream-input-stream.lsp deleted file mode 100644 index 139916e..0000000 --- a/t/ansi-test/streams/two-way-stream-input-stream.lsp +++ /dev/null @@ -1,26 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Feb 12 04:22:50 2004 -;;;; Contains: Tests of TWO-WAY-STREAM-INPUT-STREAM - -(in-package :cl-test) - -(deftest two-way-stream-input-stream.1 - (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-two-way-stream is os))) - (equalt (multiple-value-list (two-way-stream-input-stream s)) - (list is))) - t) - -(deftest two-way-stream-input-stream.error.1 - (signals-error (two-way-stream-input-stream) program-error) - t) - -(deftest two-way-stream-input-stream.error.2 - (signals-error (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-two-way-stream is os))) - (two-way-stream-input-stream s nil)) - program-error) - t) diff --git a/t/ansi-test/streams/two-way-stream-output-stream.lsp b/t/ansi-test/streams/two-way-stream-output-stream.lsp deleted file mode 100644 index 3fa39b1..0000000 --- a/t/ansi-test/streams/two-way-stream-output-stream.lsp +++ /dev/null @@ -1,26 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Feb 12 04:25:59 2004 -;;;; Contains: Tests off TWO-WAY-STREAM-OUTPUT-STREAM - -(in-package :cl-test) - -(deftest two-way-stream-output-stream.1 - (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-two-way-stream is os))) - (equalt (multiple-value-list (two-way-stream-output-stream s)) - (list os))) - t) - -(deftest two-way-stream-output-stream.error.1 - (signals-error (two-way-stream-output-stream) program-error) - t) - -(deftest two-way-stream-output-stream.error.2 - (signals-error (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-two-way-stream is os))) - (two-way-stream-output-stream s nil)) - program-error) - t) diff --git a/t/ansi-test/streams/unread-char.lsp b/t/ansi-test/streams/unread-char.lsp deleted file mode 100644 index 8cacd0d..0000000 --- a/t/ansi-test/streams/unread-char.lsp +++ /dev/null @@ -1,92 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jan 18 20:05:36 2004 -;;;; Contains: Tests of UNREAD-CHAR - -(in-package :cl-test) - -(deftest unread-char.1 - (with-input-from-string - (*standard-input* "abc") - (values - (read-char) - (unread-char #\a) - (read-char) - (read-char) - (unread-char #\b) - (read-char) - (read-char))) - #\a nil #\a #\b nil #\b #\c) - -(deftest unread-char.2 - (with-input-from-string - (s "abc") - (values - (read-char s) - (unread-char #\a s) - (read-char s) - (read-char s) - (unread-char #\b s) - (read-char s) - (read-char s))) - #\a nil #\a #\b nil #\b #\c) - -(deftest unread-char.3 - (with-input-from-string - (is "abc") - (with-output-to-string - (os) - (let ((s (make-echo-stream is os))) - (read-char s) - (unread-char #\a s) - (read-char s) - (read-char s) - (read-char s) - (unread-char #\c s) - (read-char s)))) - "abc") - -(deftest unread-char.4 - (with-input-from-string - (*standard-input* "abc") - (values - (read-char) - (unread-char #\a nil) - (read-char) - (read-char) - (unread-char #\b nil) - (read-char) - (read-char))) - #\a nil #\a #\b nil #\b #\c) - -(deftest unread-char.5 - (with-input-from-string - (is "abc") - (let ((*terminal-io* (make-two-way-stream - is (make-string-output-stream)))) - (values - (read-char t) - (unread-char #\a t) - (read-char t) - (read-char t) - (unread-char #\b t) - (read-char t) - (read-char t)))) - #\a nil #\a #\b nil #\b #\c) - -;;; Error tests - -(deftest unread-char.error.1 - (signals-error (unread-char) program-error) - t) - -(deftest unread-char.error.2 - (signals-error - (with-input-from-string - (s "abc") - (read-char s) - (unread-char #\a s nil)) - program-error) - t) - - diff --git a/t/ansi-test/streams/with-input-from-string.lsp b/t/ansi-test/streams/with-input-from-string.lsp deleted file mode 100644 index 9ffb65d..0000000 --- a/t/ansi-test/streams/with-input-from-string.lsp +++ /dev/null @@ -1,245 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Feb 14 20:13:02 2004 -;;;; Contains: Tests of WITH-INPUT-FROM-STRING - -(in-package :cl-test) - -(deftest with-input-from-string.1 - (with-input-from-string - (s "abc") - (values (read-char s) (read-char s) (read-char s) (read-char s nil :eof))) - #\a #\b #\c :eof) - -(deftest with-input-from-string.2 - (with-input-from-string (s "abc")) - nil) - -(deftest with-input-from-string.3 - (with-input-from-string (s "abc") (declare (optimize speed))) - nil) - -(deftest with-input-from-string.3a - (with-input-from-string (s "abc") - (declare (optimize speed)) - (declare (optimize space))) - nil) - -(deftest with-input-from-string.4 - (with-input-from-string - (s "abc") - (declare (optimize safety)) - (read-char s) - (read-char s)) - #\b) - -(deftest with-input-from-string.5 - (let ((i nil)) - (values - (with-input-from-string - (s "abc" :index i)) - i)) - nil 0) - -(deftest with-input-from-string.6 - (let ((i (list nil))) - (values - (with-input-from-string - (s "abc" :index (car i))) - i)) - nil (0)) - -(deftest with-input-from-string.7 - (let ((i nil)) - (values - (with-input-from-string - (s "abc" :index i) - (list i (read-char s) i (read-char s) i)) - i)) - (nil #\a nil #\b nil) 2) - -(deftest with-input-from-string.9 - (with-input-from-string - (s "abc") - (values - (notnot (typep s 'stream)) - (notnot (typep s 'string-stream)) - (notnot (open-stream-p s)) - (notnot (input-stream-p s)) - (output-stream-p s))) - t t t t nil) - -(deftest with-input-from-string.10 - :notes (:nil-vectors-are-strings) - (with-input-from-string - (s (make-array 0 :element-type nil)) - (values - (notnot (typep s 'stream)) - (notnot (typep s 'string-stream)) - (notnot (open-stream-p s)) - (notnot (input-stream-p s)) - (output-stream-p s))) - t t t t nil) - -(deftest with-input-from-string.11 - (with-input-from-string - (s (make-array 3 :element-type 'character :initial-contents "abc")) - (values - (notnot (typep s 'stream)) - (notnot (typep s 'string-stream)) - (notnot (open-stream-p s)) - (notnot (input-stream-p s)) - (output-stream-p s) - (read-line s))) - t t t t nil "abc") - -(deftest with-input-from-string.12 - (with-input-from-string - (s (make-array 3 :element-type 'base-char :initial-contents "abc")) - (values - (notnot (typep s 'stream)) - (notnot (typep s 'string-stream)) - (notnot (open-stream-p s)) - (notnot (input-stream-p s)) - (output-stream-p s) - (read-line s))) - t t t t nil "abc") - -(deftest with-input-from-string.13 - (with-input-from-string - (s "abcdef" :start 2) - (values - (notnot (typep s 'stream)) - (notnot (typep s 'string-stream)) - (notnot (open-stream-p s)) - (notnot (input-stream-p s)) - (output-stream-p s) - (read-line s))) - t t t t nil "cdef") - -(deftest with-input-from-string.14 - (with-input-from-string - (s "abcdef" :end 3) - (values - (notnot (typep s 'stream)) - (notnot (typep s 'string-stream)) - (notnot (open-stream-p s)) - (notnot (input-stream-p s)) - (output-stream-p s) - (read-line s))) - t t t t nil "abc") - -(deftest with-input-from-string.15 - (with-input-from-string - (s "abcdef" :start 1 :end 5) - (values - (notnot (typep s 'stream)) - (notnot (typep s 'string-stream)) - (notnot (open-stream-p s)) - (notnot (input-stream-p s)) - (output-stream-p s) - (read-line s))) - t t t t nil "bcde") - -(deftest with-input-from-string.16 - (with-input-from-string - (s "abcdef" :start 1 :end nil) - (values - (notnot (typep s 'stream)) - (notnot (typep s 'string-stream)) - (notnot (open-stream-p s)) - (notnot (input-stream-p s)) - (output-stream-p s) - (read-line s))) - t t t t nil "bcdef") - -(deftest with-input-from-string.17 - (let ((i 2)) - (values - (with-input-from-string - (s "abcdef" :index i :start i) - (read-char s)) - i)) - #\c 3) - -;;; Test that there is no implicit tagbody - -(deftest with-input-from-string.18 - (block done - (tagbody - (with-input-from-string - (s "abc") - (go 1) - 1 - (return-from done :bad)) - 1 - (return-from done :good))) - :good) - -;;; Free declaration scope - -(deftest with-input-from-string.19 - (block done - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) - (with-input-from-string (s (return-from done x)) - (declare (special x)))))) - :good) - -(deftest with-input-from-string.20 - (block done - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) - (with-input-from-string (s "abc" :start (return-from done x)) - (declare (special x)))))) - :good) - -(deftest with-input-from-string.21 - (block done - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) - (with-input-from-string (s "abc" :end (return-from done x)) - (declare (special x)))))) - :good) - -;;; index is not updated if the form exits abnormally - -(deftest with-input-from-string.22 - (let ((i nil)) - (values - (block done - (with-input-from-string (s "abcde" :index i) (return-from done (read-char s)))) - i)) - #\a nil) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest with-input-from-string.23 - (macrolet - ((%m (z) z)) - (with-input-from-string (s (expand-in-current-env (%m "123"))) - (read-char s))) - #\1) - -(deftest with-input-from-string.24 - (macrolet - ((%m (z) z)) - (with-input-from-string (s "123" :start (expand-in-current-env (%m 1))) - (read-char s))) - #\2) - -(deftest with-input-from-string.25 - (macrolet - ((%m (z) z)) - (with-input-from-string (s "123" :start 0 - :end (expand-in-current-env (%m 0))) - (read-char s nil nil))) - nil) - - -;;; FIXME: Add more tests on specialized strings. - diff --git a/t/ansi-test/streams/with-open-file.lsp b/t/ansi-test/streams/with-open-file.lsp deleted file mode 100644 index 94140de..0000000 --- a/t/ansi-test/streams/with-open-file.lsp +++ /dev/null @@ -1,98 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Jan 27 20:57:05 2004 -;;;; Contains: Tests of WITH-OPEN-FILE - -(in-package :cl-test) - -;;; For now, omit most of the options combinations, assuming they will -;;; be tested in OPEN. The tests of OPEN should be ported to here at some -;;; point. - -(deftest with-open-file.1 - (let ((pn #p"tmp.dat")) - (delete-all-versions pn) - (with-open-file (s pn :direction :output))) - nil) - -(deftest with-open-file.2 - (let ((pn #p"tmp.dat")) - (delete-all-versions pn) - (with-open-file - (s pn :direction :output) - (notnot-mv (output-stream-p s)))) - t) - -(deftest with-open-file.3 - (let ((pn #p"tmp.dat")) - (delete-all-versions pn) - (with-open-file - (s pn :direction :output) - (values)))) - -(deftest with-open-file.4 - (let ((pn #p"tmp.dat")) - (delete-all-versions pn) - (with-open-file - (s pn :direction :output) - (values 1 2 3 4 5 6 7 8))) - 1 2 3 4 5 6 7 8) - -(deftest with-open-file.5 - (let ((pn #p"tmp.dat")) - (delete-all-versions pn) - (with-open-file - (s pn :direction :output) - (declare (ignore s)) - (declare (optimize)))) - nil) - -(deftest with-open-file.6 - (let ((pn #p"tmp.dat")) - (delete-all-versions pn) - (with-open-file - (s pn (cdr '(nil . :direction)) (car '(:output))) - (format s "foo!~%")) - (with-open-file (s pn) (read-line s))) - "foo!" nil) - -;;; Free declaration scope tests - -(deftest with-open-file.7 - (block done - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) - (with-open-file (s (return-from done x)) - (declare (special x)))))) - :good) - -(deftest with-open-file.8 - (block done - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) - (with-open-file (s "with-open-file.lsp" (return-from done x) :input) - (declare (special x)))))) - :good) - -(deftest with-open-file.9 - (block done - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) - (with-open-file (s "with-open-file.lsp" :direction (return-from done x)) - (declare (special x)))))) - :good) - -;;; Test that explicit calls to macroexpand in subforms -;;; are done in the correct environment - -(deftest with-open-file.10 - (macrolet - ((%m (z) z)) - (let ((pn #p"tmp.dat")) - (delete-all-versions pn) - (with-open-file (s (expand-in-current-env (%m pn)) - :direction :output)))) - nil) diff --git a/t/ansi-test/streams/with-open-stream.lsp b/t/ansi-test/streams/with-open-stream.lsp deleted file mode 100644 index ba685b8..0000000 --- a/t/ansi-test/streams/with-open-stream.lsp +++ /dev/null @@ -1,77 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Dec 13 01:42:59 2004 -;;;; Contains: Tests of WITH-OPEN-STREAM - -(in-package :cl-test) - -(deftest with-open-stream.1 - (with-open-stream (os (make-string-output-stream))) - nil) - -(deftest with-open-stream.2 - (with-open-stream (os (make-string-output-stream)) - (declare (ignore os))) - nil) - -(deftest with-open-stream.3 - (with-open-stream (os (make-string-output-stream)) - (declare (ignore os)) - (declare (type string-stream os))) - nil) - -(deftest with-open-stream.4 - (with-open-stream (os (make-string-output-stream)) - (declare (ignore os)) - (values))) - -(deftest with-open-stream.5 - (with-open-stream (os (make-string-output-stream)) - (declare (ignore os)) - (values 'a 'b)) - a b) - -(deftest with-open-stream.6 - (let ((s (make-string-output-stream))) - (values - (with-open-stream (os s)) - (notnot (typep s 'string-stream)) - (open-stream-p s))) - nil t nil) - -(deftest with-open-stream.7 - (let ((s (make-string-input-stream "123"))) - (values - (with-open-stream (is s) (read-char s)) - (notnot (typep s 'string-stream)) - (open-stream-p s))) - #\1 t nil) - -(deftest with-open-stream.8 - (let ((s (make-string-output-stream))) - (values - (block done - (with-open-stream (os s) (return-from done nil))) - (notnot (typep s 'string-stream)) - (open-stream-p s))) - nil t nil) - -(deftest with-open-stream.9 - (let ((s (make-string-output-stream))) - (values - (catch 'done - (with-open-stream (os s) (throw 'done nil))) - (notnot (typep s 'string-stream)) - (open-stream-p s))) - nil t nil) - -;;; Free declaration scope - -(deftest with-open-stream.10 - (block done - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) - (with-open-stream (s (return-from done x)) - (declare (special x)))))) - :good) diff --git a/t/ansi-test/streams/with-output-to-string.lsp b/t/ansi-test/streams/with-output-to-string.lsp deleted file mode 100644 index ae20916..0000000 --- a/t/ansi-test/streams/with-output-to-string.lsp +++ /dev/null @@ -1,129 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Feb 14 20:33:51 2004 -;;;; Contains: Tests of WITH-OUTPUT-TO-STRING - -(in-package :cl-test) - - -(deftest with-output-to-string.1 - (with-output-to-string (s)) - "") - -(deftest with-output-to-string.2 - (with-output-to-string (s) (write-char #\3 s)) - "3") - -(deftest with-output-to-string.3 - (with-output-to-string (s (make-array 10 :fill-pointer 0 - :element-type 'character))) - nil) - -(deftest with-output-to-string.4 - :notes (:allow-nil-arrays :nil-vectors-are-strings) - (let ((str (make-array 10 :fill-pointer 0 :element-type 'character))) - (values - (with-output-to-string - (s str :element-type nil) - (write-string "abcdef" s)) - str)) - "abcdef" "abcdef") - -(deftest with-output-to-string.5 - (with-output-to-string (s (make-array 10 :fill-pointer 0 - :element-type 'character)) - (values))) - -(deftest with-output-to-string.6 - (with-output-to-string (s (make-array 10 :fill-pointer 0 - :element-type 'character)) - (values 'a 'b 'c 'd)) - a b c d) - -(deftest with-output-to-string.7 - (with-output-to-string (s nil :element-type 'character) - (write-char #\& s)) - "&") - -(deftest with-output-to-string.8 - (let ((str (with-output-to-string (s nil :element-type 'base-char) - (write-char #\8 s)))) - (assert (typep str 'simple-base-string)) - str) - "8") - -(deftest with-output-to-string.9 - :notes (:allow-nil-arrays :nil-vectors-are-strings) - (with-output-to-string (s nil :element-type nil)) - "") - -(deftest with-output-to-string.10 - (let* ((s1 (make-array 20 :element-type 'character - :initial-element #\.)) - (s2 (make-array 10 :element-type 'character - :displaced-to s1 - :displaced-index-offset 5 - :fill-pointer 0))) - - (values - (with-output-to-string - (s s2) - (write-string "0123456789" s)) - s1 - s2)) - "0123456789" - ".....0123456789....." - "0123456789") - -(deftest with-output-to-string.11 - (with-output-to-string (s) (declare (optimize safety))) - "") - -(deftest with-output-to-string.12 - (with-output-to-string (s) (declare (optimize safety)) - (declare (optimize (speed 0)))) - "") - -(deftest with-output-to-string.13 - (with-output-to-string - (s) - (write-char #\0 s) - (write-char #\4 s) - (write-char #\9 s)) - "049") - -(deftest with-output-to-string.14 - (let* ((str1 (make-array '(256) :element-type 'base-char :fill-pointer 0)) - (str2 (with-output-to-string - (s nil :element-type 'base-char) - (loop for i below 256 - for c = (code-char i) - when (typep c 'base-char) - do (progn (write-char c s) - (vector-push c str1)))))) - (if (string= str1 str2) :good - (list str1 str2))) - :good) - -;;; Free declaration scope - -(deftest with-output-to-string.15 - (block done - (let ((x :bad)) - (declare (special x)) - (let ((x :good)) - (with-output-to-string (s (return-from done x)) - (declare (special x)))))) - :good) - -(deftest with-output-to-string.16 - (block done - (let ((x :bad)) - (declare (special x)) - (let ((x :good) - (str (make-array '(10) :element-type 'character - :fill-pointer 0))) - (with-output-to-string (s str :element-type (return-from done x)) - (declare (special x)))))) - :good) - diff --git a/t/ansi-test/streams/write-char.lsp b/t/ansi-test/streams/write-char.lsp deleted file mode 100644 index e7804a2..0000000 --- a/t/ansi-test/streams/write-char.lsp +++ /dev/null @@ -1,51 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jan 18 20:50:31 2004 -;;;; Contains: Tests of WRITE-CHAR - -(in-package :cl-test) - -(deftest write-char.1 - (loop for i from 0 to 255 - for c = (code-char i) - when c - unless (string= (with-output-to-string - (*standard-output*) - (write-char c)) - (string c)) - collect c) - nil) - -(deftest write-char.2 - (with-input-from-string - (is "abcd") - (with-output-to-string - (os) - (let ((*terminal-io* (make-two-way-stream is os))) - (write-char #\$ t) - (close *terminal-io*)))) - "$") - -(deftest write-char.3 - (with-output-to-string - (*standard-output*) - (write-char #\: nil)) - ":") - -;;; Error tests - -(deftest write-char.error.1 - (signals-error (write-char) program-error) - t) - -(deftest write-char.error.2 - (signals-error - (with-output-to-string - (s) - (write-char #\a s nil)) - program-error) - t) - -;;; More tests in other files - - diff --git a/t/ansi-test/streams/write-line.lsp b/t/ansi-test/streams/write-line.lsp deleted file mode 100644 index 17f61d7..0000000 --- a/t/ansi-test/streams/write-line.lsp +++ /dev/null @@ -1,165 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Jan 19 06:49:26 2004 -;;;; Contains: Tests of WRITE-LINE - -(in-package :cl-test) - -(deftest write-line.1 - (let (result) - (values - (with-output-to-string - (*standard-output*) - (setq result (multiple-value-list (write-line "")))) - result)) - #.(string #\Newline) - ("")) - -(deftest write-line.2 - :notes (:nil-vectors-are-strings) - (let (result) - (values - (with-output-to-string - (*standard-output*) - (setq result - (multiple-value-list - (write-line (make-array '(0) :element-type nil))))) - result)) - #.(string #\Newline) - ("")) - -(deftest write-line.3 - (let (result) - (values - (with-output-to-string - (*standard-output*) - (setq result (multiple-value-list (write-line "abcde")))) - result)) - #.(concatenate 'string "abcde" (string #\Newline)) - ("abcde")) - -(deftest write-line.4 - (let (result) - (values - (with-output-to-string - (s) - (setq result (multiple-value-list (write-line "abcde" s :start 1)))) - result)) - #.(concatenate 'string "bcde" (string #\Newline)) - ("abcde")) - -(deftest write-line.5 - (let (result) - (values - (with-output-to-string - (s) - (setq result (multiple-value-list - (write-line "abcde" s :start 1 :end 3)))) - result)) - #.(concatenate 'string "bc" (string #\Newline)) - ("abcde")) - -(deftest write-line.6 - (let (result) - (values - (with-output-to-string - (s) - (setq result (multiple-value-list - (write-line "abcde" s :start 1 :end nil)))) - result)) - #.(concatenate 'string "bcde" (string #\Newline)) - ("abcde")) - -(deftest write-line.7 - (let (result) - (values - (with-output-to-string - (s) - (setq result (multiple-value-list (write-line "abcde" s :end 3)))) - result)) - #.(concatenate 'string "abc" (string #\Newline)) - ("abcde")) - -(deftest write-line.8 - (let (result) - (values - (with-output-to-string - (s) - (setq result (multiple-value-list - (write-line "abcde" s :end 3 :allow-other-keys nil)))) - result)) - #.(concatenate 'string "abc" (string #\Newline)) - ("abcde")) - -(deftest write-line.9 - (let (result) - (values - (with-output-to-string - (s) - (setq result - (multiple-value-list - (write-line "abcde" s :end 3 :allow-other-keys t :foo 'bar)))) - result)) - #.(concatenate 'string "abc" (string #\Newline)) - ("abcde")) - -(deftest write-line.10 - (let (result) - (values - (with-output-to-string - (s) - (setq result (multiple-value-list - (write-line "abcde" s :end 3 :end 2)))) - result)) - #.(concatenate 'string "abc" (string #\Newline)) - ("abcde")) - -(deftest write-line.11 - (with-input-from-string - (is "abcd") - (with-output-to-string - (os) - (let ((*terminal-io* (make-two-way-stream is os))) - (write-line "951" t) - (close *terminal-io*)))) - #.(concatenate 'string "951" (string #\Newline))) - -(deftest write-line.12 - (with-output-to-string - (*standard-output*) - (write-line "-=|!" nil)) - #.(concatenate 'string "-=|!" (string #\Newline))) - -;;; Specialized string tests - -(deftest write-line.13 - (do-special-strings - (s "abcde" nil) - (assert (equal - (with-output-to-string - (*standard-output*) - (multiple-value-list (write-line "abcde"))) - #.(concatenate 'string "abcde" (string #\Newline))))) - nil) - -;;; Error tests - -(deftest write-line.error.1 - (signals-error (write-line) program-error) - t) - -(deftest write-line.error.2 - (signals-error (write-line "" *standard-output* :start) program-error) - t) - -(deftest write-line.error.3 - (signals-error (write-line "" *standard-output* :foo nil) program-error) - t) - -(deftest write-line.error.4 - (signals-error (write-line "" *standard-output* - :allow-other-keys nil - :foo nil) - program-error) - t) - diff --git a/t/ansi-test/streams/write-sequence.lsp b/t/ansi-test/streams/write-sequence.lsp deleted file mode 100644 index ff3ab6f..0000000 --- a/t/ansi-test/streams/write-sequence.lsp +++ /dev/null @@ -1,225 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Jan 21 04:07:58 2004 -;;;; Contains: Tests of WRITE-SEQUENCE - -(in-package :cl-test) - -(defmacro def-write-sequence-test (name input args &rest expected) - `(deftest ,name - (let ((s ,input)) - (with-output-to-string - (os) - (assert (eq (write-sequence s os ,@args) s)))) - ,@expected)) - -;;; on strings - -(def-write-sequence-test write-sequence.string.1 "abcde" () "abcde") -(def-write-sequence-test write-sequence.string.2 "abcde" (:start 1) "bcde") -(def-write-sequence-test write-sequence.string.3 "abcde" (:end 3) "abc") -(def-write-sequence-test write-sequence.string.4 "abcde" - (:start 1 :end 4) "bcd") -(def-write-sequence-test write-sequence.string.5 "abcde" (:end nil) "abcde") -(def-write-sequence-test write-sequence.string.6 "abcde" (:start 3 :end 3) "") -(def-write-sequence-test write-sequence.string.7 "abcde" - (:end nil :start 1) "bcde") -(def-write-sequence-test write-sequence.string.8 "abcde" - (:allow-other-keys nil) "abcde") -(def-write-sequence-test write-sequence.string.9 "abcde" - (:allow-other-keys t :foo nil) "abcde") -(def-write-sequence-test write-sequence.string.10 "abcde" - (:allow-other-keys t :allow-other-keys nil :foo nil) "abcde") -(def-write-sequence-test write-sequence.string.11 "abcde" - (:bar 'x :allow-other-keys t) "abcde") -(def-write-sequence-test write-sequence.string.12 "abcde" - (:start 1 :end 4 :start 2 :end 3) "bcd") -(def-write-sequence-test write-sequence.string.13 "" () "") - -(defmacro def-write-sequence-special-test (name string args expected) - `(deftest ,name - (let ((str ,string) - (expected ,expected)) - (do-special-strings - (s str nil) - (let ((out (with-output-to-string - (os) - (assert (eq (write-sequence s os ,@args) s))))) - (assert (equal out expected))))) - nil)) - -(def-write-sequence-special-test write-sequence.string.14 "12345" () "12345") -(def-write-sequence-special-test write-sequence.string.15 "12345" (:start 1 :end 3) "23") - -;;; on lists - -(def-write-sequence-test write-sequence.list.1 (coerce "abcde" 'list) - () "abcde") -(def-write-sequence-test write-sequence.list.2 (coerce "abcde" 'list) - (:start 1) "bcde") -(def-write-sequence-test write-sequence.list.3 (coerce "abcde" 'list) - (:end 3) "abc") -(def-write-sequence-test write-sequence.list.4 (coerce "abcde" 'list) - (:start 1 :end 4) "bcd") -(def-write-sequence-test write-sequence.list.5 (coerce "abcde" 'list) - (:end nil) "abcde") -(def-write-sequence-test write-sequence.list.6 (coerce "abcde" 'list) - (:start 3 :end 3) "") -(def-write-sequence-test write-sequence.list.7 (coerce "abcde" 'list) - (:end nil :start 1) "bcde") -(def-write-sequence-test write-sequence.list.8 () () "") - - -;;; on vectors - -(def-write-sequence-test write-sequence.simple-vector.1 - (coerce "abcde" 'simple-vector) () "abcde") -(def-write-sequence-test write-sequence.simple-vector.2 - (coerce "abcde" 'simple-vector) (:start 1) "bcde") -(def-write-sequence-test write-sequence.simple-vector.3 - (coerce "abcde" 'simple-vector) (:end 3) "abc") -(def-write-sequence-test write-sequence.simple-vector.4 - (coerce "abcde" 'simple-vector) (:start 1 :end 4) "bcd") -(def-write-sequence-test write-sequence.simple-vector.5 - (coerce "abcde" 'simple-vector) (:end nil) "abcde") -(def-write-sequence-test write-sequence.simple-vector.6 - (coerce "abcde" 'simple-vector) (:start 3 :end 3) "") -(def-write-sequence-test write-sequence.simple-vector.7 - (coerce "abcde" 'simple-vector) (:end nil :start 1) "bcde") -(def-write-sequence-test write-sequence.simple-vector.8 #() () "") - -;;; on vectors with fill pointers - -(def-write-sequence-test write-sequence.fill-vector.1 - (make-array 10 :initial-contents "abcde " :fill-pointer 5) () "abcde") -(def-write-sequence-test write-sequence.fill-vector.2 - (make-array 10 :initial-contents "abcde " :fill-pointer 5) - (:start 1) "bcde") -(def-write-sequence-test write-sequence.fill-vector.3 - (make-array 10 :initial-contents "abcde " :fill-pointer 5) - (:end 3) "abc") -(def-write-sequence-test write-sequence.fill-vector.4 - (make-array 10 :initial-contents "abcde " :fill-pointer 5) - (:start 1 :end 4) "bcd") -(def-write-sequence-test write-sequence.fill-vector.5 - (make-array 10 :initial-contents "abcde " :fill-pointer 5) - (:end nil) "abcde") -(def-write-sequence-test write-sequence.fill-vector.6 - (make-array 10 :initial-contents "abcde " :fill-pointer 5) - (:start 3 :end 3) "") -(def-write-sequence-test write-sequence.fill-vector.7 - (make-array 10 :initial-contents "abcde " :fill-pointer 5) - (:end nil :start 1) "bcde") - -;;; on bit vectors - -(defmacro def-write-sequence-bv-test (name input args expected) - `(deftest ,name - (let ((s ,input) - (expected ,expected)) - (with-open-file - (os "tmp.dat" :direction :output - :element-type '(unsigned-byte 8) - :if-exists :supersede) - (assert (eq (write-sequence s os ,@args) s))) - (with-open-file - (is "tmp.dat" :direction :input - :element-type '(unsigned-byte 8)) - (loop for i from 0 below (length expected) - for e = (elt expected i) - always (eql (read-byte is) e)))) - t)) - -(def-write-sequence-bv-test write-sequence.bv.1 #*00111010 - () #*00111010) -(def-write-sequence-bv-test write-sequence.bv.2 #*00111010 - (:start 1) #*0111010) -(def-write-sequence-bv-test write-sequence.bv.3 #*00111010 - (:end 5) #*00111) -(def-write-sequence-bv-test write-sequence.bv.4 #*00111010 - (:start 1 :end 6) #*01110) -(def-write-sequence-bv-test write-sequence.bv.5 #*00111010 - (:start 1 :end nil) #*0111010) -(def-write-sequence-bv-test write-sequence.bv.6 #*00111010 - (:start 1 :end nil :end 4) #*0111010) - - -;;; Error tests - -(deftest write-sequence.error.1 - (signals-error (write-sequence) program-error) - t) - -(deftest write-sequence.error.2 - (signals-error (write-sequence "abcde") program-error) - t) - -(deftest write-sequence.error.3 - (signals-error (write-sequence '(#\a . #\b) *standard-output*) type-error) - t) - -(deftest write-sequence.error.4 - (signals-error (write-sequence #\a *standard-output*) type-error) - t) - -(deftest write-sequence.error.5 - (signals-error (write-sequence "ABC" *standard-output* :start -1) type-error) - t) - -(deftest write-sequence.error.6 - (signals-error (write-sequence "ABC" *standard-output* :start 'x) type-error) - t) - -(deftest write-sequence.error.7 - (signals-error (write-sequence "ABC" *standard-output* :start 0.0) - type-error) - t) - -(deftest write-sequence.error.8 - (signals-error (write-sequence "ABC" *standard-output* :end -1) - type-error) - t) - -(deftest write-sequence.error.9 - (signals-error (write-sequence "ABC" *standard-output* :end 'x) - type-error) - t) - -(deftest write-sequence.error.10 - (signals-error (write-sequence "ABC" *standard-output* :end 2.0) - type-error) - t) - -(deftest write-sequence.error.11 - (signals-error (write-sequence "abcde" *standard-output* - :foo nil) program-error) - t) - -(deftest write-sequence.error.12 - (signals-error (write-sequence "abcde" *standard-output* - :allow-other-keys nil :foo t) - program-error) - t) - -(deftest write-sequence.error.13 - (signals-error (write-sequence "abcde" *standard-output* :start) - program-error) - t) - -(deftest write-sequence.error.14 - (check-type-error #'(lambda (x) (write-sequence x *standard-output*)) - #'sequencep) - nil) - -(deftest write-sequence.error.15 - (check-type-error #'(lambda (x) (write-sequence "abcde" *standard-output* - :start x)) - (typef 'unsigned-byte)) - nil) - -(deftest write-sequence.error.16 - (check-type-error #'(lambda (x) (write-sequence "abcde" *standard-output* - :end x)) - (typef '(or null unsigned-byte))) - nil) - diff --git a/t/ansi-test/streams/write-string.lsp b/t/ansi-test/streams/write-string.lsp deleted file mode 100644 index e2b1c09..0000000 --- a/t/ansi-test/streams/write-string.lsp +++ /dev/null @@ -1,156 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jan 18 21:13:32 2004 -;;;; Contains: Tests of WRITE-STRING - -(in-package :cl-test) - -(deftest write-string.1 - (let (result) - (values - (with-output-to-string - (*standard-output*) - (setq result (multiple-value-list (write-string "")))) - result)) - "" ("")) - -(deftest write-string.2 - :notes (:nil-vectors-are-strings) - (let (result) - (values - (with-output-to-string - (*standard-output*) - (setq result - (multiple-value-list - (write-string (make-array '(0) :element-type nil))))) - result)) - "" ("")) - -(deftest write-string.3 - (let (result) - (values - (with-output-to-string - (*standard-output*) - (setq result (multiple-value-list (write-string "abcde")))) - result)) - "abcde" ("abcde")) - -(deftest write-string.4 - (let (result) - (values - (with-output-to-string - (s) - (setq result (multiple-value-list (write-string "abcde" s :start 1)))) - result)) - "bcde" ("abcde")) - -(deftest write-string.5 - (let (result) - (values - (with-output-to-string - (s) - (setq result (multiple-value-list - (write-string "abcde" s :start 1 :end 3)))) - result)) - "bc" ("abcde")) - -(deftest write-string.6 - (let (result) - (values - (with-output-to-string - (s) - (setq result (multiple-value-list - (write-string "abcde" s :start 1 :end nil)))) - result)) - "bcde" ("abcde")) - -(deftest write-string.7 - (let (result) - (values - (with-output-to-string - (s) - (setq result (multiple-value-list (write-string "abcde" s :end 3)))) - result)) - "abc" ("abcde")) - -(deftest write-string.8 - (let (result) - (values - (with-output-to-string - (s) - (setq result (multiple-value-list - (write-string "abcde" s :end 3 :allow-other-keys nil)))) - result)) - "abc" ("abcde")) - -(deftest write-string.9 - (let (result) - (values - (with-output-to-string - (s) - (setq result - (multiple-value-list - (write-string "abcde" s :end 3 :allow-other-keys t :foo 'bar)))) - result)) - "abc" ("abcde")) - -(deftest write-string.10 - (let (result) - (values - (with-output-to-string - (s) - (setq result (multiple-value-list - (write-string "abcde" s :end 3 :end 2)))) - result)) - "abc" ("abcde")) - -(deftest write-string.11 - (with-input-from-string - (is "abcd") - (with-output-to-string - (os) - (let ((*terminal-io* (make-two-way-stream is os))) - (write-string "951" t) - (close *terminal-io*)))) - "951") - -(deftest write-string.12 - (with-output-to-string - (*standard-output*) - (write-string "-=|!" nil)) - "-=|!") - -;;; Specialized string tests - -(deftest write-string.13 - (let (result) - (do-special-strings - (s "abcde" nil) - (assert (equal - (with-output-to-string - (*standard-output*) - (setq result (multiple-value-list (write-string "abcde")))) - "abcde")) - (assert (equal result '("abcde"))))) - nil) - -;;; Error tests - -(deftest write-string.error.1 - (signals-error (write-string) program-error) - t) - -(deftest write-string.error.2 - (signals-error (write-string "" *standard-output* :start) program-error) - t) - -(deftest write-string.error.3 - (signals-error (write-string "" *standard-output* :foo nil) program-error) - t) - -(deftest write-string.error.4 - (signals-error (write-string "" *standard-output* - :allow-other-keys nil - :foo nil) - program-error) - t) diff --git a/t/ansi-test/strings/base-string.lsp b/t/ansi-test/strings/base-string.lsp deleted file mode 100644 index 22d30d1..0000000 --- a/t/ansi-test/strings/base-string.lsp +++ /dev/null @@ -1,32 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Aug 29 17:26:57 2004 -;;;; Contains: Tests associated with BASE-STRING - -(in-package :cl-test) - -(deftest base-string.1 - (subtypep* 'base-string 'string) - t t) - -(deftest base-string.2 - (subtypep* 'base-string 'vector) - t t) - -(deftest base-string.3 - (subtypep* 'base-string 'array) - t t) - -(deftest base-string.4 - (subtypep* 'base-string 'sequence) - t t) - -(deftest base-string.5 - :notes (:allow-nil-arrays :nil-vectors-are-strings) - (subtypep* '(array nil (*)) 'base-string) - nil t) - -(deftest base-string.6 - :notes (:nil-vectors-are-strings) - (subtypep* 'string 'base-string) - nil t) diff --git a/t/ansi-test/strings/char-schar.lsp b/t/ansi-test/strings/char-schar.lsp deleted file mode 100644 index 79f04dd..0000000 --- a/t/ansi-test/strings/char-schar.lsp +++ /dev/null @@ -1,193 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Sep 29 21:04:44 2002 -;;;; Contains: Tests of CHAR and SCHAR accessors - -(in-package :cl-test) - -(deftest char.1 - (let ((s "abcd")) - (values (char s 0) (char s 1) (char s 2) (char s 3))) - #\a #\b #\c #\d) - -(deftest char.2 - (let ((s0 (copy-seq "abcd")) - (s1 (copy-seq "abcd")) - (s2 (copy-seq "abcd")) - (s3 (copy-seq "abcd"))) - (setf (char s0 0) #\X) - (setf (char s1 1) #\X) - (setf (char s2 2) #\X) - (setf (char s3 3) #\X) - (values s0 s1 s2 s3)) - "Xbcd" "aXcd" "abXd" "abcX") - -(deftest char.3 - (let ((s (make-array 6 :element-type 'character - :initial-contents '(#\a #\b #\c #\d #\e #\f)))) - (setf (char s 3) #\X) - s) - "abcXef") - -(deftest char.4 - (let ((s (make-array 6 :element-type 'character - :initial-contents '(#\a #\b #\c #\d #\e #\f) - :fill-pointer 4))) - (setf (char s 3) #\X) - s) - "abcX") - -(deftest char.5 - (let ((s (make-string 5 :initial-element #\a))) - (setf (char s 3) #\X) - s) - "aaaXa") - -(deftest char.6 - (let ((s (make-string 5 :initial-element #\a :element-type 'base-char))) - (setf (char s 3) #\X) - s) - "aaaXa") - -(deftest char.7 - (let ((s (make-string 5 :initial-element #\a :element-type 'character))) - (setf (char s 3) #\X) - s) - "aaaXa") - -(deftest char.8 - (let ((s (make-array 6 :element-type 'character - :initial-contents '(#\a #\b #\c #\d #\e #\f) - :fill-pointer 4))) - (setf (char s 5) #\X) - (setf (fill-pointer s) 6) - s) - "abcdeX") - -(deftest char.9 - (let ((s (make-string 5 :initial-element #\a - :element-type 'base-char))) - (setf (char s 3) #\X) - s) - "aaaXa") - -(deftest char.10 - (let ((s (make-string 5 :initial-element #\a - :element-type 'standard-char))) - (setf (char s 3) #\X) - s) - "aaaXa") - -(deftest char.order.1 - (let ((i 0) a b) - (values - (char (progn (setf a (incf i)) "abc") - (progn (setf b (incf i)) 1)) - i a b)) - #\b 2 1 2) - -(deftest char.order.2 - (let ((i 0) a b c (s (make-string 5 :initial-element #\z))) - (values - (setf - (char (progn (setf a (incf i)) s) - (progn (setf b (incf i)) 1)) - (progn (setf c (incf i)) #\a)) - s i a b c)) - #\a "zazzz" 3 1 2 3) - -;;; Error tests - -(deftest char.error.1 - (signals-error (char) program-error) - t) - -(deftest char.error.2 - (signals-error (char "abc") program-error) - t) - -(deftest char.error.3 - (signals-error (char "abc" 1 nil) program-error) - t) - -;;; Tests of schar - -(deftest schar.1 - (let ((s "abcd")) (values (schar s 0) (schar s 1) (schar s 2) (schar s 3))) - #\a #\b #\c #\d) - -(deftest schar.2 - (let ((s0 (copy-seq "abcd")) - (s1 (copy-seq "abcd")) - (s2 (copy-seq "abcd")) - (s3 (copy-seq "abcd"))) - (setf (schar s0 0) #\X) - (setf (schar s1 1) #\X) - (setf (schar s2 2) #\X) - (setf (schar s3 3) #\X) - (values s0 s1 s2 s3)) - "Xbcd" "aXcd" "abXd" "abcX") - -(deftest schar.3 - (let ((s (make-string 6 :initial-element #\x))) - (setf (schar s 2) #\X) - s) - "xxXxxx") - -(deftest schar.4 - (let ((s (make-string 6 :initial-element #\x :element-type 'character))) - (setf (schar s 2) #\X) - s) - "xxXxxx") - -(deftest schar.5 - (let ((s (make-string 6 :initial-element #\x :element-type 'standard-char))) - (setf (schar s 2) #\X) - s) - "xxXxxx") - -(deftest schar.6 - (let ((s (make-string 6 :initial-element #\x :element-type 'base-char))) - (setf (schar s 2) #\X) - s) - "xxXxxx") - -(deftest schar.7 - (let ((s (make-string 6 :initial-element #\x - :element-type 'standard-char))) - (setf (schar s 2) #\X) - s) - "xxXxxx") - -(deftest schar.order.1 - (let ((i 0) a b) - (values - (schar (progn (setf a (incf i)) "abc") - (progn (setf b (incf i)) 1)) - i a b)) - #\b 2 1 2) - -(deftest schar.order.2 - (let ((i 0) a b c (s (copy-seq "zzzzz"))) - (values - (setf - (schar (progn (setf a (incf i)) s) - (progn (setf b (incf i)) 1)) - (progn (setf c (incf i)) #\a)) - s i a b c)) - #\a "zazzz" 3 1 2 3) - -;;; Error tests - -(deftest schar.error.1 - (signals-error (schar) program-error) - t) - -(deftest schar.error.2 - (signals-error (schar "abc") program-error) - t) - -(deftest schar.error.3 - (signals-error (schar "abc" 1 nil) program-error) - t) - diff --git a/t/ansi-test/strings/load.lsp b/t/ansi-test/strings/load.lsp deleted file mode 100644 index 3647cb6..0000000 --- a/t/ansi-test/strings/load.lsp +++ /dev/null @@ -1,29 +0,0 @@ -;;; Tests of strings -(compile-and-load "ANSI-TESTS:AUX;string-aux.lsp") - -(in-package #:cl-test) - -(let ((*default-pathname-defaults* - (make-pathname - :directory (pathname-directory *load-pathname*)))) - (load "char-schar.lsp") - (load "string.lsp") - (load "base-string.lsp") - (load "simple-string.lsp") - (load "simple-base-string.lsp") - (load "simple-string-p.lsp") - (load "stringp.lsp") - (load "string-upcase.lsp") - (load "string-downcase.lsp") - (load "string-capitalize.lsp") - (load "nstring-upcase.lsp") - (load "nstring-downcase.lsp") - (load "nstring-capitalize.lsp") - (load "string-trim.lsp") - (load "string-left-trim.lsp") - (load "string-right-trim.lsp") - -;;; Tests of string comparison functions - (load "string-comparisons.lsp") - (load "make-string.lsp") -) diff --git a/t/ansi-test/strings/make-string.lsp b/t/ansi-test/strings/make-string.lsp deleted file mode 100644 index 074a6a2..0000000 --- a/t/ansi-test/strings/make-string.lsp +++ /dev/null @@ -1,179 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Oct 5 12:32:20 2002 -;;;; Contains: Tests for MAKE-STRING - -(in-package :cl-test) - -(deftest make-string.1 - (let ((s (make-string 10))) - (and (stringp s) - #+:ansi-tests-strict-initial-element - (string-all-the-same s) - (eqlt (length s) 10) - )) - t) - -(deftest make-string.2 - (let ((s (make-string 10 :initial-element #\a))) - (and (stringp s) - (eql (length s) 10) - s)) - "aaaaaaaaaa") - -(deftest make-string.3 - (let ((s (make-string 10 :initial-element #\a - :element-type 'character))) - (and (stringp s) - (eql (length s) 10) - s)) - "aaaaaaaaaa") - -(deftest make-string.4 - (let ((s (make-string 10 :initial-element #\a - :element-type 'standard-char))) - (and (stringp s) - (eql (length s) 10) - s)) - "aaaaaaaaaa") - -(deftest make-string.5 - (let ((s (make-string 10 :initial-element #\a - :element-type 'base-char))) - (and (stringp s) - (eql (length s) 10) - s)) - "aaaaaaaaaa") - -(deftest make-string.6 - (make-string 0) - "") - -(deftest make-string.7 - (let ((s (make-string 10 :element-type 'character))) - (and (stringp s) - (eqlt (length s) 10) - #+:ansi-tests-strict-initial-element - (string-all-the-same s) - )) - t) - -(deftest make-string.8 - (let ((s (make-string 10 :element-type 'standard-char))) - (and (stringp s) - (eqlt (length s) 10) - #+:ansi-tests-strict-initial-element - (string-all-the-same s) - )) - t) - -(deftest make-string.9 - (let ((s (make-string 10 :element-type 'base-char))) - (and (stringp s) - (eqlt (length s) 10) - #+:ansi-tests-strict-initial-element - (string-all-the-same s) - )) - t) - -(deftest make-string.10 - :notes (:nil-vectors-are-strings) - (let ((s (make-string 0 :element-type nil))) - (values - (notnot (stringp s)) - (eqlt (length s) 0) - (equalt s ""))) - t t t) - -(def-fold-test make-string.fold.1 (make-string 5 :initial-element #\a)) - -;;; Keyword tests -; -(deftest make-string.allow-other-keys.1 - (make-string 5 :allow-other-keys t :initial-element #\a) - "aaaaa") - -(deftest make-string.allow-other-keys.2 - (make-string 5 :initial-element #\a :allow-other-keys t) - "aaaaa") - -(deftest make-string.allow-other-keys.3 - (make-string 5 :initial-element #\a :allow-other-keys t - :bad t) - "aaaaa") - -(deftest make-string.allow-other-keys.4 - (make-string 5 :bad t :allow-other-keys t :allow-other-keys nil - :initial-element #\a) - "aaaaa") - -(deftest make-string.allow-other-keys.5 - (make-string 5 :allow-other-keys t :bad t :allow-other-keys nil - :initial-element #\a) - "aaaaa") - -(deftest make-string.allow-other-keys.6 - (make-string 5 :allow-other-keys t :allow-other-keys nil :bad nil - :initial-element #\a) - "aaaaa") - -(deftest make-string.keywords.7 - (make-string 5 :initial-element #\a :initial-element #\b) - "aaaaa") - -;; Error cases - -(deftest make-string.error.1 - (signals-error (make-string) program-error) - t) - -(deftest make-string.error.2 - (signals-error (make-string 10 :bad t) program-error) - t) - -(deftest make-string.error.3 - (signals-error (make-string 10 :bad t :allow-other-keys nil) - program-error) - t) - -(deftest make-string.error.4 - (signals-error (make-string 10 :initial-element) program-error) - t) - -(deftest make-string.error.5 - (signals-error (make-string 10 1 1) program-error) - t) - -(deftest make-string.error.6 - (signals-error (make-string 10 :element-type) program-error) - t) - -;;; Order of evaluation - -(deftest make-string.order.1 - (let ((i 0) a b) - (values - (make-string (progn (setf a (incf i)) 4) - :initial-element (progn (setf b (incf i)) #\a)) - i a b)) - "aaaa" 2 1 2) - -(deftest make-string.order.2 - (let ((i 0) a b c) - (values - (make-string (progn (setf a (incf i)) 4) - :initial-element (progn (setf b (incf i)) #\a) - :element-type (progn (setf c (incf i)) 'base-char)) - i a b c)) - "aaaa" 3 1 2 3) - -(deftest make-string.order.3 - (let ((i 0) a b c) - (values - (make-string (progn (setf a (incf i)) 4) - :element-type (progn (setf b (incf i)) 'base-char) - :initial-element (progn (setf c (incf i)) #\a)) - i a b c)) - "aaaa" 3 1 2 3) - - diff --git a/t/ansi-test/strings/nstring-capitalize.lsp b/t/ansi-test/strings/nstring-capitalize.lsp deleted file mode 100644 index b0fb456..0000000 --- a/t/ansi-test/strings/nstring-capitalize.lsp +++ /dev/null @@ -1,162 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Oct 3 21:38:49 2002 -;;;; Contains: Tests for NSTRING-CAPITALIZE - -(in-package :cl-test) - -(deftest nstring-capitalize.1 - (let* ((s (copy-seq "abCd")) - (s2 (nstring-capitalize s))) - (values (eqt s s2) s)) - t "Abcd") - -(deftest nstring-capitalize.2 - (let* ((s (copy-seq "0adA2Cdd3wXy")) - (s2 (nstring-capitalize s))) - (values (eqt s s2) s)) - t "0ada2cdd3wxy") - -(deftest nstring-capitalize.3 - (let* ((s (copy-seq "1a")) - (s2 (nstring-capitalize s))) - (values (eqt s s2) s)) - t "1a") - -(deftest nstring-capitalize.4 - (let* ((s (copy-seq "a1a")) - (s2 (nstring-capitalize s))) - (values (eqt s s2) s)) - t "A1a") - -(deftest nstring-capitalize.7 - (let ((s "ABCDEF")) - (loop for i from 0 to 5 - collect (nstring-capitalize (copy-seq s) :start i))) - ("Abcdef" "ABcdef" "ABCdef" "ABCDef" "ABCDEf" "ABCDEF")) - -(deftest nstring-capitalize.8 - (let ((s "ABCDEF")) - (loop for i from 0 to 5 - collect (nstring-capitalize (copy-seq s) :start i :end nil))) - ("Abcdef" "ABcdef" "ABCdef" "ABCDef" "ABCDEf" "ABCDEF")) - -(deftest nstring-capitalize.9 - (let ((s "ABCDEF")) - (loop for i from 0 to 6 - collect (nstring-capitalize (copy-seq s) :end i))) - ("ABCDEF" "ABCDEF" "AbCDEF" "AbcDEF" "AbcdEF" "AbcdeF" "Abcdef")) - -(deftest nstring-capitalize.10 - (let ((s "ABCDEF")) - (loop for i from 0 to 5 - collect (loop for j from i to 6 - collect (nstring-capitalize (copy-seq s) - :start i :end j)))) - (("ABCDEF" "ABCDEF" "AbCDEF" "AbcDEF" "AbcdEF" "AbcdeF" "Abcdef") - ("ABCDEF" "ABCDEF" "ABcDEF" "ABcdEF" "ABcdeF" "ABcdef") - ("ABCDEF" "ABCDEF" "ABCdEF" "ABCdeF" "ABCdef") - ("ABCDEF" "ABCDEF" "ABCDeF" "ABCDef") - ("ABCDEF" "ABCDEF" "ABCDEf") - ("ABCDEF" "ABCDEF"))) - -(deftest nstring-capitalize.11 - (nstring-capitalize "") - "") - -(deftest nstring-capitalize.12 - :notes (:nil-vectors-are-strings) - (nstring-capitalize (make-array '(0) :element-type nil)) - "") - -(deftest nstring-capitalize.13 - (loop for type in '(standard-char base-char character) - for s = (make-array '(10) :element-type type - :fill-pointer 5 - :initial-contents "aB0cDefGHi") - collect (list (copy-seq s) - (copy-seq (nstring-capitalize s)) - (copy-seq s) - (progn (setf (fill-pointer s) 10) (copy-seq s)) - )) - (("aB0cD" "Ab0cd" "Ab0cd" "Ab0cdefGHi") - ("aB0cD" "Ab0cd" "Ab0cd" "Ab0cdefGHi") - ("aB0cD" "Ab0cd" "Ab0cd" "Ab0cdefGHi"))) - -(deftest nstring-capitalize.14 - (loop for type in '(standard-char base-char character) - for s0 = (make-array '(10) :element-type type - :initial-contents "zZaB0cDefG") - for s = (make-array '(5) :element-type type - :displaced-to s0 - :displaced-index-offset 2) - collect (list (copy-seq s) - (nstring-capitalize s) - (copy-seq s) - s0)) - (("aB0cD" "Ab0cd" "Ab0cd" "zZAb0cdefG") - ("aB0cD" "Ab0cd" "Ab0cd" "zZAb0cdefG") - ("aB0cD" "Ab0cd" "Ab0cd" "zZAb0cdefG"))) - -(deftest nstring-capitalize.15 - (loop for type in '(standard-char base-char character) - for s = (make-array '(5) :element-type type - :adjustable t - :initial-contents "aB0cD") - collect (list (copy-seq s) - (nstring-capitalize s) - (copy-seq s))) - (("aB0cD" "Ab0cd" "Ab0cd") - ("aB0cD" "Ab0cd" "Ab0cd") - ("aB0cD" "Ab0cd" "Ab0cd"))) - -;;; Order of evaluation tests - - -(deftest nstring-capitalize.order.1 - (let ((i 0) a b c (s (copy-seq "abcdef"))) - (values - (nstring-capitalize - (progn (setf a (incf i)) s) - :start (progn (setf b (incf i)) 1) - :end (progn (setf c (incf i)) 4)) - i a b c)) - "aBcdef" 3 1 2 3) - -(deftest nstring-capitalize.order.2 - (let ((i 0) a b c (s (copy-seq "abcdef"))) - (values - (nstring-capitalize - (progn (setf a (incf i)) s) - :end (progn (setf b (incf i)) 4) - :start (progn (setf c (incf i)) 1)) - i a b c)) - "aBcdef" 3 1 2 3) - -;;; Error cases - -(deftest nstring-capitalize.error.1 - (signals-error (nstring-capitalize) program-error) - t) - -(deftest nstring-capitalize.error.2 - (signals-error (nstring-capitalize (copy-seq "abc") :bad t) program-error) - t) - -(deftest nstring-capitalize.error.3 - (signals-error (nstring-capitalize (copy-seq "abc") :start) program-error) - t) - -(deftest nstring-capitalize.error.4 - (signals-error (nstring-capitalize (copy-seq "abc") :bad t - :allow-other-keys nil) - program-error) - t) - -(deftest nstring-capitalize.error.5 - (signals-error (nstring-capitalize (copy-seq "abc") :end) program-error) - t) - -(deftest nstring-capitalize.error.6 - (signals-error (nstring-capitalize (copy-seq "abc") 1 2) program-error) - t) diff --git a/t/ansi-test/strings/nstring-downcase.lsp b/t/ansi-test/strings/nstring-downcase.lsp deleted file mode 100644 index 1475cb4..0000000 --- a/t/ansi-test/strings/nstring-downcase.lsp +++ /dev/null @@ -1,168 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Oct 3 21:33:16 2002 -;;;; Contains: Tests for NSTRING-DOWNCASE - -(in-package :cl-test) - -(deftest nstring-downcase.1 - (let* ((s (copy-seq "A")) - (s2 (nstring-downcase s))) - (values (eqt s s2) s)) - t "a") - -(deftest nstring-downcase.2 - (let* ((s (copy-seq "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")) - (s2 (nstring-downcase s))) - (values (eqt s s2) s)) - t - "abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz") - -(deftest nstring-downcase.3 - (let* ((s (copy-seq "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ ")) - (s2 (nstring-downcase s))) - (values (eqt s s2) s)) - t - "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ ") - -(deftest nstring-downcase.6 - (let* ((s (make-array 6 :element-type 'character - :initial-contents '(#\A #\B #\C #\D #\E #\F))) - (s2 (nstring-downcase s))) - (values (eqt s s2) s)) - t "abcdef") - -(deftest nstring-downcase.7 - (let* ((s (make-array 6 :element-type 'standard-char - :initial-contents '(#\A #\B #\7 #\D #\E #\F))) - (s2 (nstring-downcase s))) - (values (eqt s s2) s)) - t - "ab7def") - -;; Tests with :start, :end - -(deftest nstring-downcase.8 - (let ((s "ABCDEF")) - (loop for i from 0 to 6 - collect (nstring-downcase (copy-seq s) :start i))) - ("abcdef" "Abcdef" "ABcdef" "ABCdef" "ABCDef" "ABCDEf" "ABCDEF")) - -(deftest nstring-downcase.9 - (let ((s "ABCDEF")) - (loop for i from 0 to 6 - collect (nstring-downcase (copy-seq s) :start i :end nil))) - ("abcdef" "Abcdef" "ABcdef" "ABCdef" "ABCDef" "ABCDEf" "ABCDEF")) - -(deftest nstring-downcase.10 - (let ((s "ABCDE")) - (loop for i from 0 to 4 - collect (loop for j from i to 5 - collect (string-invertcase - (nstring-downcase (copy-seq s) - :start i :end j))))) - (("abcde" "Abcde" "ABcde" "ABCde" "ABCDe" "ABCDE") - ("abcde" "aBcde" "aBCde" "aBCDe" "aBCDE") - ("abcde" "abCde" "abCDe" "abCDE") - ("abcde" "abcDe" "abcDE") - ("abcde" "abcdE"))) - -(deftest nstring-downcase.11 - :notes (:nil-vectors-are-strings) - (nstring-downcase (make-array '(0) :element-type nil)) - "") - -(deftest nstring-downcase.12 - (loop for type in '(standard-char base-char character) - for s = (make-array '(10) :element-type type - :fill-pointer 5 - :initial-contents "aB0cDefGHi") - collect (list (copy-seq s) - (copy-seq (nstring-downcase s)) - (copy-seq s) - (progn (setf (fill-pointer s) 10) (copy-seq s)) - )) - (("aB0cD" "ab0cd" "ab0cd" "ab0cdefGHi") - ("aB0cD" "ab0cd" "ab0cd" "ab0cdefGHi") - ("aB0cD" "ab0cd" "ab0cd" "ab0cdefGHi"))) - -(deftest nstring-downcase.13 - (loop for type in '(standard-char base-char character) - for s0 = (make-array '(10) :element-type type - :initial-contents "zZaB0cDefG") - for s = (make-array '(5) :element-type type - :displaced-to s0 - :displaced-index-offset 2) - collect (list (copy-seq s) - (nstring-downcase s) - (copy-seq s) - s0)) - (("aB0cD" "ab0cd" "ab0cd" "zZab0cdefG") - ("aB0cD" "ab0cd" "ab0cd" "zZab0cdefG") - ("aB0cD" "ab0cd" "ab0cd" "zZab0cdefG"))) - -(deftest nstring-downcase.14 - (loop for type in '(standard-char base-char character) - for s = (make-array '(5) :element-type type - :adjustable t - :initial-contents "aB0cD") - collect (list (copy-seq s) - (nstring-downcase s) - (copy-seq s))) - (("aB0cD" "ab0cd" "ab0cd") - ("aB0cD" "ab0cd" "ab0cd") - ("aB0cD" "ab0cd" "ab0cd"))) - -;;; Order of evaluation tests - -(deftest nstring-downcase.order.1 - (let ((i 0) a b c (s (copy-seq "ABCDEF"))) - (values - (nstring-downcase - (progn (setf a (incf i)) s) - :start (progn (setf b (incf i)) 1) - :end (progn (setf c (incf i)) 4)) - i a b c)) - "AbcdEF" 3 1 2 3) - -(deftest nstring-downcase.order.2 - (let ((i 0) a b c (s (copy-seq "ABCDEF"))) - (values - (nstring-downcase - (progn (setf a (incf i)) s) - :end (progn (setf b (incf i)) 4) - :start (progn (setf c (incf i)) 1)) - i a b c)) - "AbcdEF" 3 1 2 3) - -;;; Error cases - -(deftest nstring-downcase.error.1 - (signals-error (nstring-downcase) program-error) - t) - -(deftest nstring-downcase.error.2 - (signals-error (nstring-downcase (copy-seq "abc") :bad t) program-error) - t) - -(deftest nstring-downcase.error.3 - (signals-error (nstring-downcase (copy-seq "abc") :start) program-error) - t) - -(deftest nstring-downcase.error.4 - (signals-error (nstring-downcase (copy-seq "abc") :bad t - :allow-other-keys nil) - program-error) - t) - -(deftest nstring-downcase.error.5 - (signals-error (nstring-downcase (copy-seq "abc") :end) program-error) - t) - -(deftest nstring-downcase.error.6 - (signals-error (nstring-downcase (copy-seq "abc") 1 2) program-error) - t) - - - - diff --git a/t/ansi-test/strings/nstring-upcase.lsp b/t/ansi-test/strings/nstring-upcase.lsp deleted file mode 100644 index 49d51f2..0000000 --- a/t/ansi-test/strings/nstring-upcase.lsp +++ /dev/null @@ -1,165 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Oct 3 21:12:40 2002 -;;;; Contains: Tests for NSTRING-UPCASE - -(in-package :cl-test) - -(deftest nstring-upcase.1 - (let* ((s (copy-seq "a")) - (s2 (nstring-upcase s))) - (values (eqt s s2) s)) - t "A") - -(deftest nstring-upcase.2 - (let* ((s (copy-seq "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")) - (s2 (nstring-upcase s))) - (values (eqt s s2) s)) - t - "ABCDEFGHIJKLMNOPQRSTUVWXYZABCDEFGHIJKLMNOPQRSTUVWXYZ") - -(deftest nstring-upcase.3 - (let* ((s (copy-seq "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ ")) - (s2 (nstring-upcase s))) - (values (eqt s s2) s)) - t - "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ ") - -(deftest nstring-upcase.6 - (let* ((s (make-array 6 :element-type 'character - :initial-contents '(#\a #\b #\c #\d #\e #\f))) - (s2 (nstring-upcase s))) - (values (eqt s s2) s)) - t "ABCDEF") - -(deftest nstring-upcase.7 - (let* ((s (make-array 6 :element-type 'standard-char - :initial-contents '(#\a #\b #\7 #\d #\e #\f))) - (s2 (nstring-upcase s))) - (values (eqt s s2) s)) - t "AB7DEF") - -;; Tests with :start, :end - -(deftest nstring-upcase.8 - (let ((s "abcdef")) - (loop for i from 0 to 6 - collect (nstring-upcase (copy-seq s) :start i))) - ("ABCDEF" "aBCDEF" "abCDEF" "abcDEF" "abcdEF" "abcdeF" "abcdef")) - -(deftest nstring-upcase.9 - (let ((s "abcdef")) - (loop for i from 0 to 6 - collect - (nstring-upcase (copy-seq s) :start i :end nil))) - ("ABCDEF" "aBCDEF" "abCDEF" "abcDEF" "abcdEF" "abcdeF" "abcdef")) - -(deftest nstring-upcase.10 - (let ((s "abcde")) - (loop for i from 0 to 4 - collect (loop for j from i to 5 - collect (nstring-upcase (copy-seq s) - :start i :end j)))) - (("abcde" "Abcde" "ABcde" "ABCde" "ABCDe" "ABCDE") - ("abcde" "aBcde" "aBCde" "aBCDe" "aBCDE") - ("abcde" "abCde" "abCDe" "abCDE") - ("abcde" "abcDe" "abcDE") - ("abcde" "abcdE"))) - -(deftest nstring-upcase.11 - :notes (:nil-vectors-are-strings) - (nstring-upcase (make-array '(0) :element-type nil)) - "") - -(deftest nstring-upcase.12 - (loop for type in '(standard-char base-char character) - for s = (make-array '(10) :element-type type - :fill-pointer 5 - :initial-contents "aB0cDefGHi") - collect (list (copy-seq s) - (copy-seq (nstring-upcase s)) - (copy-seq s) - (progn (setf (fill-pointer s) 10) (copy-seq s)) - )) - (("aB0cD" "AB0CD" "AB0CD" "AB0CDefGHi") - ("aB0cD" "AB0CD" "AB0CD" "AB0CDefGHi") - ("aB0cD" "AB0CD" "AB0CD" "AB0CDefGHi"))) - -(deftest nstring-upcase.13 - (loop for type in '(standard-char base-char character) - for s0 = (make-array '(10) :element-type type - :initial-contents "zZaB0cDefG") - for s = (make-array '(5) :element-type type - :displaced-to s0 - :displaced-index-offset 2) - collect (list (copy-seq s) - (nstring-upcase s) - (copy-seq s) - s0)) - (("aB0cD" "AB0CD" "AB0CD" "zZAB0CDefG") - ("aB0cD" "AB0CD" "AB0CD" "zZAB0CDefG") - ("aB0cD" "AB0CD" "AB0CD" "zZAB0CDefG"))) - -(deftest nstring-upcase.14 - (loop for type in '(standard-char base-char character) - for s = (make-array '(5) :element-type type - :adjustable t - :initial-contents "aB0cD") - collect (list (copy-seq s) - (nstring-upcase s) - (copy-seq s))) - (("aB0cD" "AB0CD" "AB0CD") - ("aB0cD" "AB0CD" "AB0CD") - ("aB0cD" "AB0CD" "AB0CD"))) - -;;; Order of evaluation tests - -(deftest nstring-upcase.order.1 - (let ((i 0) a b c (s (copy-seq "abcdef"))) - (values - (nstring-upcase - (progn (setf a (incf i)) s) - :start (progn (setf b (incf i)) 1) - :end (progn (setf c (incf i)) 4)) - i a b c)) - "aBCDef" 3 1 2 3) - -(deftest nstring-upcase.order.2 - (let ((i 0) a b c (s (copy-seq "abcdef"))) - (values - (nstring-upcase - (progn (setf a (incf i)) s) - :end (progn (setf b (incf i)) 4) - :start (progn (setf c (incf i)) 1)) - i a b c)) - "aBCDef" 3 1 2 3) - - -;;; Error cases - -(deftest nstring-upcase.error.1 - (signals-error (nstring-upcase) program-error) - t) - -(deftest nstring-upcase.error.2 - (signals-error (nstring-upcase (copy-seq "abc") :bad t) program-error) - t) - -(deftest nstring-upcase.error.3 - (signals-error (nstring-upcase (copy-seq "abc") :start) program-error) - t) - -(deftest nstring-upcase.error.4 - (signals-error (nstring-upcase (copy-seq "abc") :bad t - :allow-other-keys nil) - program-error) - t) - -(deftest nstring-upcase.error.5 - (signals-error (nstring-upcase (copy-seq "abc") :end) program-error) - t) - -(deftest nstring-upcase.error.6 - (signals-error (nstring-upcase (copy-seq "abc") 1 2) program-error) - t) - diff --git a/t/ansi-test/strings/simple-base-string.lsp b/t/ansi-test/strings/simple-base-string.lsp deleted file mode 100644 index 4e57921..0000000 --- a/t/ansi-test/strings/simple-base-string.lsp +++ /dev/null @@ -1,53 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Aug 29 17:30:40 2004 -;;;; Contains: Tests associated with SIMPLE-BASE-STRING - -(in-package :cl-test) - -(deftest simple-base-string.1 - (subtypep* 'simple-base-string 'string) - t t) - -(deftest simple-base-string.2 - (subtypep* 'simple-base-string 'vector) - t t) - -(deftest simple-base-string.3 - (subtypep* 'simple-base-string 'simple-array) - t t) - -(deftest simple-base-string.4 - (subtypep* 'simple-base-string 'array) - t t) - -(deftest simple-base-string.5 - (subtypep* 'simple-base-string 'sequence) - t t) - -(deftest simple-base-string.6 - (subtypep* 'simple-base-string 'base-string) - t t) - -(deftest simple-base-string.7 - (subtypep* 'simple-base-string 'simple-string) - t t) - -(deftest simple-base-string.8 - (subtypep* 'simple-base-string 'simple-vector) - nil t) - -(deftest simple-base-string.9 - :notes (:allow-nil-arrays :nil-vectors-are-strings) - (subtypep* '(simple-array nil (*)) 'simple-base-string) - nil t) - -(deftest simple-base-string.10 - :notes (:allow-nil-arrays :nil-vectors-are-strings) - (typep* (make-array '(0) :element-type nil) 'simple-base-string) - nil) - -(deftest simple-base-string.11 - :notes (:allow-nil-arrays :nil-vectors-are-strings) - (typep* (make-array '(12) :element-type nil) 'simple-base-string) - nil) diff --git a/t/ansi-test/strings/simple-string-p.lsp b/t/ansi-test/strings/simple-string-p.lsp deleted file mode 100644 index 46c47da..0000000 --- a/t/ansi-test/strings/simple-string-p.lsp +++ /dev/null @@ -1,74 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Aug 29 17:31:24 2004 -;;;; Contains: Tests of SIMPLE-STRING-P - -(in-package :cl-test) - -(deftest simple-string-p.1 - (check-type-predicate #'simple-string-p 'simple-string) - nil) - -(deftest simple-string-p.2 - (notnot-mv (simple-string-p "ancd")) - t) - -(deftest simple-string-p.3 - (simple-string-p 0) - nil) - -;;; (deftest simple-string-p.4 -;;; (simple-string-p (make-array 4 :element-type 'character -;;; :initial-contents '(#\a #\a #\a #\b) -;;; :fill-pointer t)) -;;; nil) - -(deftest simple-string-p.5 - (notnot-mv - (simple-string-p (make-array - 4 :element-type 'base-char - :initial-contents '(#\a #\a #\a #\b)))) - t) - -(deftest simple-string-p.6 - (notnot-mv - (simple-string-p (make-array - 4 :element-type 'standard-char - :initial-contents '(#\a #\a #\a #\b)))) - t) - -;;; (deftest simple-string-p.7 -;;; (let* ((s (make-array 10 :element-type 'character -;;; :initial-element #\a)) -;;; (s2 (make-array 4 :element-type 'character -;;; :displaced-to s -;;; :displaced-index-offset 2))) -;;; (simple-string-p s2)) -;;; nil) - -(deftest simple-string-p.8 - :notes (:nil-vectors-are-strings) - (notnot-mv (simple-string-p (make-array '(0) :element-type nil))) - t) - -(deftest simple-string-p.9 - :notes (:nil-vectors-are-strings) - (notnot-mv (simple-string-p (make-array '(37) :element-type nil))) - t) - -(deftest simple-string-p.10 - (let ((i 0)) - (values - (notnot (simple-string-p (progn (incf i) ""))) - i)) - t 1) - -;;; Error tests - -(deftest simple-string-p.error.1 - (signals-error (simple-string-p) program-error) - t) - -(deftest simple-string-p.error.2 - (signals-error (simple-string-p "" nil) program-error) - t) diff --git a/t/ansi-test/strings/simple-string.lsp b/t/ansi-test/strings/simple-string.lsp deleted file mode 100644 index 41cec19..0000000 --- a/t/ansi-test/strings/simple-string.lsp +++ /dev/null @@ -1,85 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Aug 29 17:27:46 2004 -;;;; Contains: Tests associated with SIMPLE-STRING - -(in-package :cl-test) - -(deftest simple-string.1 - (subtypep* 'simple-string 'string) - t t) - -(deftest simple-string.2 - (subtypep* 'simple-string 'vector) - t t) - -(deftest simple-string.3 - (subtypep* 'simple-string 'simple-array) - t t) - -(deftest simple-string.4 - (subtypep* 'simple-string 'array) - t t) - -(deftest simple-string.5 - (subtypep* 'simple-string 'sequence) - t t) - -(deftest simple-string.6 - (subtypep* 'simple-string '(simple-array * (*))) - t t) - -(deftest simple-string.7 - (subtypep* 'simple-string '(simple-array * 1)) - t t) - -(deftest simple-string.8 - :notes (:nil-vectors-are-strings) - (subtypep* 'simple-string '(simple-array character (*))) - nil t) - -(deftest simple-string.9 - :notes (:nil-vectors-are-strings) - (subtypep* 'simple-string '(simple-array base-char (*))) - nil t) - -(deftest simple-string.10 - :notes (:nil-vectors-are-strings) - (subtypep* 'simple-string 'simple-base-string) - nil t) - -(deftest simple-string.11 - :notes (:nil-vectors-are-strings) - (subtypep* '(simple-array nil (*)) 'simple-string) - t t) - -(deftest simple-string.12 - :notes (:nil-vectors-are-strings) - (typep* (make-array '(0) :element-type nil) 'simple-string) - t) - -(deftest simple-string.13 - :notes (:nil-vectors-are-strings) - (typep* (make-array '(12) :element-type nil) 'simple-string) - t) - -(deftest simple-string.14 - (typep* "abc" '(simple-string)) - t) - -(deftest simple-string.15 - (typep* "abc" '(simple-string *)) - t) - -(deftest simple-string.16 - (typep* "abc" '(simple-string 3)) - t) - -(deftest simple-string.17 - (typep* "abc" '(simple-string 2)) - nil) - -(deftest simple-string.18 - (typep* "abc" '(simple-string 4)) - nil) - diff --git a/t/ansi-test/strings/string-capitalize.lsp b/t/ansi-test/strings/string-capitalize.lsp deleted file mode 100644 index 38c6de5..0000000 --- a/t/ansi-test/strings/string-capitalize.lsp +++ /dev/null @@ -1,168 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Oct 3 20:08:26 2002 -;;;; Contains: Tests for STRING-CAPITALIZE - -(in-package :cl-test) - -(deftest string-capitalize.1 - (let ((s "abCd")) - (values (string-capitalize s) s)) - "Abcd" - "abCd") - - -(deftest string-capitalize.2 - (let ((s "0adA2Cdd3wXy")) - (values (string-capitalize s) s)) - "0ada2cdd3wxy" - "0adA2Cdd3wXy") - -(deftest string-capitalize.3 - (let ((s "1a")) - (values (string-capitalize s) s)) - "1a" - "1a") - -(deftest string-capitalize.4 - (let ((s "a1a")) - (values (string-capitalize s) s)) - "A1a" - "a1a") - -(deftest string-capitalize.5 - (let ((s #\a)) - (values (string-capitalize s) s)) - "A" - #\a) - -(deftest string-capitalize.6 - (let ((s '|abcDe|)) - (values (string-capitalize s) (symbol-name s))) - "Abcde" - "abcDe") - -(deftest string-capitalize.7 - (let ((s "ABCDEF")) - (values - (loop for i from 0 to 5 - collect (string-capitalize s :start i)) - s)) - ("Abcdef" "ABcdef" "ABCdef" "ABCDef" "ABCDEf" "ABCDEF") - "ABCDEF") - -(deftest string-capitalize.8 - (let ((s "ABCDEF")) - (values - (loop for i from 0 to 5 - collect (string-capitalize s :start i :end nil)) - s)) - ("Abcdef" "ABcdef" "ABCdef" "ABCDef" "ABCDEf" "ABCDEF") - "ABCDEF") - -(deftest string-capitalize.9 - (let ((s "ABCDEF")) - (values - (loop for i from 0 to 6 - collect (string-capitalize s :end i)) - s)) - ("ABCDEF" "ABCDEF" "AbCDEF" "AbcDEF" "AbcdEF" "AbcdeF" "Abcdef") - "ABCDEF") - -(deftest string-capitalize.10 - (let ((s "ABCDEF")) - (values - (loop for i from 0 to 5 - collect (loop for j from i to 6 - collect (string-capitalize s :start i :end j))) - s)) - (("ABCDEF" "ABCDEF" "AbCDEF" "AbcDEF" "AbcdEF" "AbcdeF" "Abcdef") - ("ABCDEF" "ABCDEF" "ABcDEF" "ABcdEF" "ABcdeF" "ABcdef") - ("ABCDEF" "ABCDEF" "ABCdEF" "ABCdeF" "ABCdef") - ("ABCDEF" "ABCDEF" "ABCDeF" "ABCDef") - ("ABCDEF" "ABCDEF" "ABCDEf") - ("ABCDEF" "ABCDEF")) - "ABCDEF") - -(deftest string-capitalize.11 - :notes (:nil-vectors-are-strings) - (string-capitalize (make-array '(0) :element-type nil)) - "") - -(deftest string-capitalize.12 - (loop for type in '(standard-char base-char character) - for s = (make-array '(10) :element-type type - :fill-pointer 5 - :initial-contents "aB0cDefGHi") - collect (list s (string-capitalize s))) - (("aB0cD" "Ab0cd") ("aB0cD" "Ab0cd") ("aB0cD" "Ab0cd"))) - - -(deftest string-capitalize.13 - (loop for type in '(standard-char base-char character) - for s0 = (make-array '(10) :element-type type - :initial-contents "zZaB0cDefG") - for s = (make-array '(5) :element-type type - :displaced-to s0 - :displaced-index-offset 2) - collect (list s (string-capitalize s))) - (("aB0cD" "Ab0cd") ("aB0cD" "Ab0cd") ("aB0cD" "Ab0cd"))) - -(deftest string-capitalize.14 - (loop for type in '(standard-char base-char character) - for s = (make-array '(5) :element-type type - :adjustable t - :initial-contents "aB0cD") - collect (list s (string-capitalize s))) - (("aB0cD" "Ab0cd") ("aB0cD" "Ab0cd") ("aB0cD" "Ab0cd"))) - -;;; Order of evaluation tests - -(deftest string-capitalize.order.1 - (let ((i 0) a b c (s (copy-seq "abcdef"))) - (values - (string-capitalize - (progn (setf a (incf i)) s) - :start (progn (setf b (incf i)) 1) - :end (progn (setf c (incf i)) 4)) - i a b c)) - "aBcdef" 3 1 2 3) - -(deftest string-capitalize.order.2 - (let ((i 0) a b c (s (copy-seq "abcdef"))) - (values - (string-capitalize - (progn (setf a (incf i)) s) - :end (progn (setf b (incf i)) 4) - :start (progn (setf c (incf i)) 1)) - i a b c)) - "aBcdef" 3 1 2 3) - -(def-fold-test string-capitalize.fold.1 (string-capitalize "ABCDE")) - -;;; Error cases - -(deftest string-capitalize.error.1 - (signals-error (string-capitalize) program-error) - t) - -(deftest string-capitalize.error.2 - (signals-error (string-capitalize (copy-seq "abc") :bad t) program-error) - t) - -(deftest string-capitalize.error.3 - (signals-error (string-capitalize (copy-seq "abc") :start) program-error) - t) - -(deftest string-capitalize.error.4 - (signals-error (string-capitalize (copy-seq "abc") :bad t - :allow-other-keys nil) program-error) - t) - -(deftest string-capitalize.error.5 - (signals-error (string-capitalize (copy-seq "abc") :end) program-error) - t) - -(deftest string-capitalize.error.6 - (signals-error (string-capitalize (copy-seq "abc") 1 2) program-error) - t) diff --git a/t/ansi-test/strings/string-comparisons.lsp b/t/ansi-test/strings/string-comparisons.lsp deleted file mode 100644 index 2035803..0000000 --- a/t/ansi-test/strings/string-comparisons.lsp +++ /dev/null @@ -1,1013 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Oct 4 06:32:41 2002 -;;;; Contains: Tests of string comparison functions - -(in-package :cl-test) - -(deftest string=.1 - (not (string= "abc" (copy-seq "abc"))) - nil) - -(deftest string=.2 - (string= "A" "a") - nil) - -(deftest string=.3 - (not (string= #\a "a")) - nil) - -(deftest string=.4 - (not (string= '|abc| (copy-seq "abc"))) - nil) - -(deftest string=.5 - (not (string= (copy-seq "abc") '#:|abc|)) - nil) - -;;; Test that it doesn't stop at null characters -(deftest string=.6 - (let ((s1 (copy-seq "abc")) - (s2 (copy-seq "abd")) - (c (or (code-char 0) #\a))) - (setf (char s1 1) c) - (setf (char s2 1) c) - (values (length s1) (length s2) (string= s1 s2))) - 3 3 nil) - -(deftest string=.7 - (loop for i from 0 to 3 - collect (not (string= "abc" "abd" :start1 0 :end1 i :end2 i))) - (nil nil nil t)) - -(deftest string=.8 - (loop for i from 0 to 3 - collect (not (string= "abc" "ab" :end1 i))) - (t t nil t)) - -(deftest string=.9 - (loop for i from 0 to 3 - collect (not (string= "abc" "abd" :start2 0 :end2 i :end1 i))) - (nil nil nil t)) - -(deftest string=.10 - (loop for i from 0 to 3 - collect (not (string= "ab" "abc" :end2 i))) - (t t nil t)) - -(deftest string=.11 - (loop for i from 0 to 3 - collect (not (string= "xyab" "ab" :start1 i))) - (t t nil t)) - -(deftest string=.12 - (loop for i from 0 to 3 - collect (not (string= "ab" "xyab" :start2 i))) - (t t nil t)) - -(deftest string=.13 - (loop for i from 0 to 3 - collect (not (string= "xyab" "ab" :start1 i :end1 nil))) - (t t nil t)) - -(deftest string=.14 - (loop for i from 0 to 3 - collect (not (string= "ab" "xyab" :start2 i :end2 nil))) - (t t nil t)) - -;;; Keyword argument processing - -(deftest string-comparison.allow-other-keys.1 - (loop for fn in '(string= string<= string>= string/= string< string> - string-equal string-not-greaterp string-not-lessp - string-not-equal string-lessp string-greaterp) - for expected in '(nil 0 nil 0 0 nil nil 0 nil 0 0 nil) - for result = (funcall fn "a" "b" :allow-other-keys t :foo nil) - unless (eql result expected) - collect (list fn expected result)) - nil) - -(deftest string-comparison.allow-other-keys.2 - (loop for fn in '(string= string<= string>= string/= string< string> - string-equal string-not-greaterp string-not-lessp - string-not-equal string-lessp string-greaterp) - for expected in '(nil nil 0 0 nil 0 nil nil 0 0 nil 0) - for result = (funcall fn "c" "b" :allow-other-keys t - :allow-other-keys nil :foo 1) - unless (eql result expected) - collect (list fn expected result)) - nil) - -(deftest string-comparison.allow-other-keys.3 - (loop for fn in '(string= string<= string>= string/= string< string> - string-equal string-not-greaterp string-not-lessp - string-not-equal string-lessp string-greaterp) - for expected in '(nil 0 nil 0 0 nil nil 0 nil 0 0 nil) - for result = (funcall fn "a" "b" :allow-other-keys nil) - unless (eql result expected) - collect (list fn expected result)) - nil) - - -;;; Order of evaluation - -(deftest string=.order.1 - (let ((i 0) x y) - (values - (string= (progn (setf x (incf i)) "abc") - (progn (setf y (incf i)) "abd")) - i x y)) - nil 2 1 2) - -(deftest string=.order.2 - (let ((i 0) a b c d e f) - (values - (string= (progn (setf a (incf i)) "abc") - (progn (setf b (incf i)) "abd") - :start1 (progn (setf c (incf i)) 0) - :start2 (progn (setf d (incf i)) 0) - :end1 (progn (setf e (incf i)) nil) - :end2 (progn (setf f (incf i)) nil) - ) - i a b c d e f)) - nil 6 1 2 3 4 5 6) - -(deftest string=.order.3 - (let ((i 0) a b c d e f) - (values - (string= (progn (setf a (incf i)) "abc") - (progn (setf b (incf i)) "abd") - :end2 (progn (setf c (incf i)) nil) - :end1 (progn (setf d (incf i)) nil) - :start2 (progn (setf e (incf i)) 0) - :start1 (progn (setf f (incf i)) 0) - ) - i a b c d e f)) - nil 6 1 2 3 4 5 6) - -(deftest string<=.order.1 - (let ((i 0) x y) - (values - (string<= (progn (setf x (incf i)) "abf") - (progn (setf y (incf i)) "abd")) - i x y)) - nil 2 1 2) - -(deftest string<=.order.2 - (let ((i 0) a b c d e f) - (values - (string<= (progn (setf a (incf i)) "abf") - (progn (setf b (incf i)) "abd") - :start1 (progn (setf c (incf i)) 0) - :start2 (progn (setf d (incf i)) 0) - :end1 (progn (setf e (incf i)) nil) - :end2 (progn (setf f (incf i)) nil) - ) - i a b c d e f)) - nil 6 1 2 3 4 5 6) - -(deftest string<=.order.3 - (let ((i 0) a b c d e f) - (values - (string<= (progn (setf a (incf i)) "abf") - (progn (setf b (incf i)) "abd") - :end2 (progn (setf c (incf i)) nil) - :end1 (progn (setf d (incf i)) nil) - :start2 (progn (setf e (incf i)) 0) - :start1 (progn (setf f (incf i)) 0) - ) - i a b c d e f)) - nil 6 1 2 3 4 5 6) - -(deftest string<.order.1 - (let ((i 0) x y) - (values - (string< (progn (setf x (incf i)) "abf") - (progn (setf y (incf i)) "abd")) - i x y)) - nil 2 1 2) - -(deftest string<.order.2 - (let ((i 0) a b c d e f) - (values - (string< (progn (setf a (incf i)) "abf") - (progn (setf b (incf i)) "abd") - :start1 (progn (setf c (incf i)) 0) - :start2 (progn (setf d (incf i)) 0) - :end1 (progn (setf e (incf i)) nil) - :end2 (progn (setf f (incf i)) nil) - ) - i a b c d e f)) - nil 6 1 2 3 4 5 6) - -(deftest string<.order.3 - (let ((i 0) a b c d e f) - (values - (string< (progn (setf a (incf i)) "abf") - (progn (setf b (incf i)) "abd") - :end2 (progn (setf c (incf i)) nil) - :end1 (progn (setf d (incf i)) nil) - :start2 (progn (setf e (incf i)) 0) - :start1 (progn (setf f (incf i)) 0) - ) - i a b c d e f)) - nil 6 1 2 3 4 5 6) - - -(deftest string/=.order.1 - (let ((i 0) x y) - (values - (string/= (progn (setf x (incf i)) "abc") - (progn (setf y (incf i)) "abc")) - i x y)) - nil 2 1 2) - -(deftest string/=.order.2 - (let ((i 0) a b c d e f) - (values - (string/= (progn (setf a (incf i)) "abc") - (progn (setf b (incf i)) "abc") - :start1 (progn (setf c (incf i)) 0) - :start2 (progn (setf d (incf i)) 0) - :end1 (progn (setf e (incf i)) nil) - :end2 (progn (setf f (incf i)) nil) - ) - i a b c d e f)) - nil 6 1 2 3 4 5 6) - -(deftest string/=.order.3 - (let ((i 0) a b c d e f) - (values - (string/= (progn (setf a (incf i)) "abc") - (progn (setf b (incf i)) "abc") - :end2 (progn (setf c (incf i)) nil) - :end1 (progn (setf d (incf i)) nil) - :start2 (progn (setf e (incf i)) 0) - :start1 (progn (setf f (incf i)) 0) - ) - i a b c d e f)) - nil 6 1 2 3 4 5 6) - -(deftest string>=.order.1 - (let ((i 0) x y) - (values - (string<= (progn (setf x (incf i)) "abf") - (progn (setf y (incf i)) "abd")) - i x y)) - nil 2 1 2) - -(deftest string>=.order.2 - (let ((i 0) a b c d e f) - (values - (string>= (progn (setf a (incf i)) "abc") - (progn (setf b (incf i)) "abd") - :start1 (progn (setf c (incf i)) 0) - :start2 (progn (setf d (incf i)) 0) - :end1 (progn (setf e (incf i)) nil) - :end2 (progn (setf f (incf i)) nil) - ) - i a b c d e f)) - nil 6 1 2 3 4 5 6) - -(deftest string>=.order.3 - (let ((i 0) a b c d e f) - (values - (string>= (progn (setf a (incf i)) "abc") - (progn (setf b (incf i)) "abd") - :end2 (progn (setf c (incf i)) nil) - :end1 (progn (setf d (incf i)) nil) - :start2 (progn (setf e (incf i)) 0) - :start1 (progn (setf f (incf i)) 0) - ) - i a b c d e f)) - nil 6 1 2 3 4 5 6) - -(deftest string>.order.1 - (let ((i 0) x y) - (values - (string> (progn (setf x (incf i)) "abc") - (progn (setf y (incf i)) "abd")) - i x y)) - nil 2 1 2) - -(deftest string>.order.2 - (let ((i 0) a b c d e f) - (values - (string> (progn (setf a (incf i)) "abc") - (progn (setf b (incf i)) "abd") - :start1 (progn (setf c (incf i)) 0) - :start2 (progn (setf d (incf i)) 0) - :end1 (progn (setf e (incf i)) nil) - :end2 (progn (setf f (incf i)) nil) - ) - i a b c d e f)) - nil 6 1 2 3 4 5 6) - -(deftest string>.order.3 - (let ((i 0) a b c d e f) - (values - (string> (progn (setf a (incf i)) "abc") - (progn (setf b (incf i)) "abd") - :end2 (progn (setf c (incf i)) nil) - :end1 (progn (setf d (incf i)) nil) - :start2 (progn (setf e (incf i)) 0) - :start1 (progn (setf f (incf i)) 0) - ) - i a b c d e f)) - nil 6 1 2 3 4 5 6) - - -(deftest string-equal.order.1 - (let ((i 0) x y) - (values - (string-equal (progn (setf x (incf i)) "abc") - (progn (setf y (incf i)) "abd")) - i x y)) - nil 2 1 2) - -(deftest string-equal.order.2 - (let ((i 0) a b c d e f) - (values - (string-equal (progn (setf a (incf i)) "abc") - (progn (setf b (incf i)) "abd") - :start1 (progn (setf c (incf i)) 0) - :start2 (progn (setf d (incf i)) 0) - :end1 (progn (setf e (incf i)) nil) - :end2 (progn (setf f (incf i)) nil) - ) - i a b c d e f)) - nil 6 1 2 3 4 5 6) - -(deftest string-equal.order.3 - (let ((i 0) a b c d e f) - (values - (string-equal (progn (setf a (incf i)) "abc") - (progn (setf b (incf i)) "abd") - :end2 (progn (setf c (incf i)) nil) - :end1 (progn (setf d (incf i)) nil) - :start2 (progn (setf e (incf i)) 0) - :start1 (progn (setf f (incf i)) 0) - ) - i a b c d e f)) - nil 6 1 2 3 4 5 6) - -(deftest string-not-greaterp.order.1 - (let ((i 0) x y) - (values - (string-not-greaterp (progn (setf x (incf i)) "abf") - (progn (setf y (incf i)) "abd")) - i x y)) - nil 2 1 2) - -(deftest string-not-greaterp.order.2 - (let ((i 0) a b c d e f) - (values - (string-not-greaterp (progn (setf a (incf i)) "abf") - (progn (setf b (incf i)) "abd") - :start1 (progn (setf c (incf i)) 0) - :start2 (progn (setf d (incf i)) 0) - :end1 (progn (setf e (incf i)) nil) - :end2 (progn (setf f (incf i)) nil) - ) - i a b c d e f)) - nil 6 1 2 3 4 5 6) - -(deftest string-not-greaterp.order.3 - (let ((i 0) a b c d e f) - (values - (string-not-greaterp (progn (setf a (incf i)) "abf") - (progn (setf b (incf i)) "abd") - :end2 (progn (setf c (incf i)) nil) - :end1 (progn (setf d (incf i)) nil) - :start2 (progn (setf e (incf i)) 0) - :start1 (progn (setf f (incf i)) 0) - ) - i a b c d e f)) - nil 6 1 2 3 4 5 6) - -(deftest string-lessp.order.1 - (let ((i 0) x y) - (values - (string-lessp (progn (setf x (incf i)) "abf") - (progn (setf y (incf i)) "abd")) - i x y)) - nil 2 1 2) - -(deftest string-lessp.order.2 - (let ((i 0) a b c d e f) - (values - (string-lessp (progn (setf a (incf i)) "abf") - (progn (setf b (incf i)) "abd") - :start1 (progn (setf c (incf i)) 0) - :start2 (progn (setf d (incf i)) 0) - :end1 (progn (setf e (incf i)) nil) - :end2 (progn (setf f (incf i)) nil) - ) - i a b c d e f)) - nil 6 1 2 3 4 5 6) - -(deftest string-lessp.order.3 - (let ((i 0) a b c d e f) - (values - (string-lessp (progn (setf a (incf i)) "abf") - (progn (setf b (incf i)) "abd") - :end2 (progn (setf c (incf i)) nil) - :end1 (progn (setf d (incf i)) nil) - :start2 (progn (setf e (incf i)) 0) - :start1 (progn (setf f (incf i)) 0) - ) - i a b c d e f)) - nil 6 1 2 3 4 5 6) - - -(deftest string-not-equal.order.1 - (let ((i 0) x y) - (values - (string-not-equal (progn (setf x (incf i)) "abc") - (progn (setf y (incf i)) "abc")) - i x y)) - nil 2 1 2) - -(deftest string-not-equal.order.2 - (let ((i 0) a b c d e f) - (values - (string-not-equal (progn (setf a (incf i)) "abc") - (progn (setf b (incf i)) "abc") - :start1 (progn (setf c (incf i)) 0) - :start2 (progn (setf d (incf i)) 0) - :end1 (progn (setf e (incf i)) nil) - :end2 (progn (setf f (incf i)) nil) - ) - i a b c d e f)) - nil 6 1 2 3 4 5 6) - -(deftest string-not-equal.order.3 - (let ((i 0) a b c d e f) - (values - (string-not-equal (progn (setf a (incf i)) "abc") - (progn (setf b (incf i)) "abc") - :end2 (progn (setf c (incf i)) nil) - :end1 (progn (setf d (incf i)) nil) - :start2 (progn (setf e (incf i)) 0) - :start1 (progn (setf f (incf i)) 0) - ) - i a b c d e f)) - nil 6 1 2 3 4 5 6) - -(deftest string-not-lessp.order.1 - (let ((i 0) x y) - (values - (string-not-lessp (progn (setf x (incf i)) "abc") - (progn (setf y (incf i)) "abd")) - i x y)) - nil 2 1 2) - -(deftest string-not-lessp.order.2 - (let ((i 0) a b c d e f) - (values - (string-not-lessp (progn (setf a (incf i)) "abc") - (progn (setf b (incf i)) "abd") - :start1 (progn (setf c (incf i)) 0) - :start2 (progn (setf d (incf i)) 0) - :end1 (progn (setf e (incf i)) nil) - :end2 (progn (setf f (incf i)) nil) - ) - i a b c d e f)) - nil 6 1 2 3 4 5 6) - -(deftest string-not-lessp.order.3 - (let ((i 0) a b c d e f) - (values - (string-not-lessp (progn (setf a (incf i)) "abc") - (progn (setf b (incf i)) "abd") - :end2 (progn (setf c (incf i)) nil) - :end1 (progn (setf d (incf i)) nil) - :start2 (progn (setf e (incf i)) 0) - :start1 (progn (setf f (incf i)) 0) - ) - i a b c d e f)) - nil 6 1 2 3 4 5 6) - -(deftest string-greaterp.order.1 - (let ((i 0) x y) - (values - (string-greaterp (progn (setf x (incf i)) "abc") - (progn (setf y (incf i)) "abd")) - i x y)) - nil 2 1 2) - -(deftest string-greaterp.order.2 - (let ((i 0) a b c d e f) - (values - (string-greaterp (progn (setf a (incf i)) "abc") - (progn (setf b (incf i)) "abd") - :start1 (progn (setf c (incf i)) 0) - :start2 (progn (setf d (incf i)) 0) - :end1 (progn (setf e (incf i)) nil) - :end2 (progn (setf f (incf i)) nil) - ) - i a b c d e f)) - nil 6 1 2 3 4 5 6) - -(deftest string-greaterp.order.3 - (let ((i 0) a b c d e f) - (values - (string-greaterp (progn (setf a (incf i)) "abc") - (progn (setf b (incf i)) "abd") - :end2 (progn (setf c (incf i)) nil) - :end1 (progn (setf d (incf i)) nil) - :start2 (progn (setf e (incf i)) 0) - :start1 (progn (setf f (incf i)) 0) - ) - i a b c d e f)) - nil 6 1 2 3 4 5 6) - - -;;; Random tests (of all the string comparson functions) - -(deftest random-string-comparison-tests - (loop for cmp in '(= /= < > <= >=) - append - (loop for case in '(nil t) - collect - (list cmp case - (random-string-compare-test 10 cmp case 1000)))) - ((= nil 0) (= t 0) (/= nil 0) (/= t 0) (< nil 0) (< t 0) - (> nil 0) (> t 0) (<= nil 0) (<= t 0) (>= nil 0) (>= t 0))) - -;;; Tests on nil arrays - -(deftest string=.nil-array.1 - :notes (:nil-vectors-are-strings) - (let ((s1 (make-array '(0) :element-type nil))) - (values - (notnot (string= s1 s1)) - (notnot (string= s1 (make-array '(0) :element-type nil))) - (notnot (string= s1 (make-array '(0) :element-type 'base-char))) - (notnot (string= s1 "")) - (notnot (string= "" s1)) - (string= s1 "a") - (string= "a" s1))) - t t t t t nil nil) - -(deftest string/=.nil-array.1 - :notes (:nil-vectors-are-strings) - (let ((s1 (make-array '(0) :element-type nil))) - (values - (string/= s1 s1) - (string/= s1 (make-array '(0) :element-type nil)) - (string/= s1 (make-array '(0) :element-type 'base-char)) - (string/= s1 "") - (string/= "" s1) - (string/= s1 "a") - (string/= "a" s1))) - nil nil nil nil nil 0 0) - -(deftest string<.nil-array.1 - :notes (:nil-vectors-are-strings) - (let ((s1 (make-array '(0) :element-type nil))) - (values - (string< s1 s1) - (string< s1 (make-array '(0) :element-type nil)) - (string< s1 (make-array '(0) :element-type 'base-char)) - (string< s1 "") - (string< "" s1) - (string< s1 "a") - (string< "a" s1))) - nil nil nil nil nil 0 nil) - -(deftest string<=.nil-array.1 - :notes (:nil-vectors-are-strings) - (let ((s1 (make-array '(0) :element-type nil))) - (values - (string<= s1 s1) - (string<= s1 (make-array '(0) :element-type nil)) - (string<= s1 (make-array '(0) :element-type 'base-char)) - (string<= s1 "") - (string<= "" s1) - (string<= s1 "a") - (string<= "a" s1))) - 0 0 0 0 0 0 nil) - -(deftest string>.nil-array.1 - :notes (:nil-vectors-are-strings) - (let ((s1 (make-array '(0) :element-type nil))) - (values - (string> s1 s1) - (string> s1 (make-array '(0) :element-type nil)) - (string> s1 (make-array '(0) :element-type 'base-char)) - (string> s1 "") - (string> "" s1) - (string> s1 "a") - (string> "a" s1))) - nil nil nil nil nil nil 0) - -(deftest string>=.nil-array.1 - :notes (:nil-vectors-are-strings) - (let ((s1 (make-array '(0) :element-type nil))) - (values - (string>= s1 s1) - (string>= s1 (make-array '(0) :element-type nil)) - (string>= s1 (make-array '(0) :element-type 'base-char)) - (string>= s1 "") - (string>= "" s1) - (string>= s1 "a") - (string>= "a" s1))) - 0 0 0 0 0 nil 0) - -(deftest string-equal.nil-array.1 - :notes (:nil-vectors-are-strings) - (let ((s1 (make-array '(0) :element-type nil))) - (values - (notnot (string-equal s1 s1)) - (notnot (string-equal s1 (make-array '(0) :element-type nil))) - (notnot (string-equal s1 (make-array '(0) :element-type 'base-char))) - (notnot (string-equal s1 "")) - (notnot (string-equal "" s1)) - (string-equal s1 "a") - (string-equal "a" s1))) - t t t t t nil nil) - -(deftest string-not-equal.nil-array.1 - :notes (:nil-vectors-are-strings) - (let ((s1 (make-array '(0) :element-type nil))) - (values - (string-not-equal s1 s1) - (string-not-equal s1 (make-array '(0) :element-type nil)) - (string-not-equal s1 (make-array '(0) :element-type 'base-char)) - (string-not-equal s1 "") - (string-not-equal "" s1) - (string-not-equal s1 "a") - (string-not-equal "a" s1))) - nil nil nil nil nil 0 0) - -(deftest string-lessp.nil-array.1 - :notes (:nil-vectors-are-strings) - (let ((s1 (make-array '(0) :element-type nil))) - (values - (string-lessp s1 s1) - (string-lessp s1 (make-array '(0) :element-type nil)) - (string-lessp s1 (make-array '(0) :element-type 'base-char)) - (string-lessp s1 "") - (string-lessp "" s1) - (string-lessp s1 "a") - (string-lessp "a" s1))) - nil nil nil nil nil 0 nil) - -(deftest string-not-greaterp.nil-array.1 - :notes (:nil-vectors-are-strings) - (let ((s1 (make-array '(0) :element-type nil))) - (values - (string-not-greaterp s1 s1) - (string-not-greaterp s1 (make-array '(0) :element-type nil)) - (string-not-greaterp s1 (make-array '(0) :element-type 'base-char)) - (string-not-greaterp s1 "") - (string-not-greaterp "" s1) - (string-not-greaterp s1 "a") - (string-not-greaterp "a" s1))) - 0 0 0 0 0 0 nil) - -(deftest string-greaterp.nil-array.1 - :notes (:nil-vectors-are-strings) - (let ((s1 (make-array '(0) :element-type nil))) - (values - (string-greaterp s1 s1) - (string-greaterp s1 (make-array '(0) :element-type nil)) - (string-greaterp s1 (make-array '(0) :element-type 'base-char)) - (string-greaterp s1 "") - (string-greaterp "" s1) - (string-greaterp s1 "a") - (string-greaterp "a" s1))) - nil nil nil nil nil nil 0) - -(deftest string-not-lessp.nil-array.1 - :notes (:nil-vectors-are-strings) - (let ((s1 (make-array '(0) :element-type nil))) - (values - (string-not-lessp s1 s1) - (string-not-lessp s1 (make-array '(0) :element-type nil)) - (string-not-lessp s1 (make-array '(0) :element-type 'base-char)) - (string-not-lessp s1 "") - (string-not-lessp "" s1) - (string-not-lessp s1 "a") - (string-not-lessp "a" s1))) - 0 0 0 0 0 nil 0) - -;;; Error cases - -(deftest string=.error.1 - (signals-error (string=) program-error) - t) - -(deftest string=.error.2 - (signals-error (string= "") program-error) - t) - -(deftest string=.error.3 - (signals-error (string= "a" "b" nil nil) program-error) - t) - -(deftest string=.error.4 - (signals-error (string= "a" "b" :start1) program-error) - t) - -(deftest string=.error.5 - (signals-error (string= "a" "b" 1 nil) program-error) - t) - -(deftest string=.error.6 - (signals-error (string= "a" "b" :allow-other-keys nil - :allow-other-keys t :foo 'bar) - program-error) - t) - -(deftest string/=.error.1 - (signals-error (string/=) program-error) - t) - -(deftest string/=.error.2 - (signals-error (string/= "") program-error) - t) - -(deftest string/=.error.3 - (signals-error (string/= "a" "b" nil nil) program-error) - t) - -(deftest string/=.error.4 - (signals-error (string/= "a" "b" :start1) program-error) - t) - -(deftest string/=.error.5 - (signals-error (string/= "a" "b" 1 nil) program-error) - t) - -(deftest string/=.error.6 - (signals-error (string/= "a" "b" :allow-other-keys nil - :allow-other-keys t :foo 'bar) - program-error) - t) - - -(deftest string<.error.1 - (signals-error (string<) program-error) - t) - -(deftest string<.error.2 - (signals-error (string< "") program-error) - t) - -(deftest string<.error.3 - (signals-error (string< "a" "b" nil nil) program-error) - t) - -(deftest string<.error.4 - (signals-error (string< "a" "b" :start1) program-error) - t) - -(deftest string<.error.5 - (signals-error (string< "a" "b" 1 nil) program-error) - t) - -(deftest string<.error.6 - (signals-error (string< "a" "b" :allow-other-keys nil - :allow-other-keys t :foo 'bar) - program-error) - t) - - -(deftest string<=.error.1 - (signals-error (string<=) program-error) - t) - -(deftest string<=.error.2 - (signals-error (string<= "") program-error) - t) - -(deftest string<=.error.3 - (signals-error (string<= "a" "b" nil nil) program-error) - t) - -(deftest string<=.error.4 - (signals-error (string<= "a" "b" :start1) program-error) - t) - -(deftest string<=.error.5 - (signals-error (string<= "a" "b" 1 nil) program-error) - t) - -(deftest string<=.error.6 - (signals-error (string<= "a" "b" :allow-other-keys nil - :allow-other-keys t :foo 'bar) - program-error) - t) - - -(deftest string>.error.1 - (signals-error (string>) program-error) - t) - -(deftest string>.error.2 - (signals-error (string> "") program-error) - t) - -(deftest string>.error.3 - (signals-error (string> "a" "b" nil nil) program-error) - t) - -(deftest string>.error.4 - (signals-error (string> "a" "b" :start1) program-error) - t) - -(deftest string>.error.5 - (signals-error (string> "a" "b" 1 nil) program-error) - t) - -(deftest string>.error.6 - (signals-error (string> "a" "b" :allow-other-keys nil - :allow-other-keys t :foo 'bar) - program-error) - t) - - -(deftest string>=.error.1 - (signals-error (string>=) program-error) - t) - -(deftest string>=.error.2 - (signals-error (string>= "") program-error) - t) - -(deftest string>=.error.3 - (signals-error (string>= "a" "b" nil nil) program-error) - t) - -(deftest string>=.error.4 - (signals-error (string>= "a" "b" :start1) program-error) - t) - -(deftest string>=.error.5 - (signals-error (string>= "a" "b" 1 nil) program-error) - t) - -(deftest string>=.error.6 - (signals-error (string>= "a" "b" :allow-other-keys nil - :allow-other-keys t :foo 'bar) - program-error) - t) - - -(deftest string-equal.error.1 - (signals-error (string-equal) program-error) - t) - -(deftest string-equal.error.2 - (signals-error (string-equal "") program-error) - t) - -(deftest string-equal.error.3 - (signals-error (string-equal "a" "b" nil nil) program-error) - t) - -(deftest string-equal.error.4 - (signals-error (string-equal "a" "b" :start1) program-error) - t) - -(deftest string-equal.error.5 - (signals-error (string-equal "a" "b" 1 nil) program-error) - t) - -(deftest string-equal.error.6 - (signals-error (string-equal "a" "b" :allow-other-keys nil - :allow-other-keys t :foo 'bar) - program-error) - t) - -(deftest string-not-equal.error.1 - (signals-error (string-not-equal) program-error) - t) - -(deftest string-not-equal.error.2 - (signals-error (string-not-equal "") program-error) - t) - -(deftest string-not-equal.error.3 - (signals-error (string-not-equal "a" "b" nil nil) program-error) - t) - -(deftest string-not-equal.error.4 - (signals-error (string-not-equal "a" "b" :start1) program-error) - t) - -(deftest string-not-equal.error.5 - (signals-error (string-not-equal "a" "b" 1 nil) program-error) - t) - -(deftest string-not-equal.error.6 - (signals-error (string-not-equal "a" "b" :allow-other-keys nil - :allow-other-keys t :foo 'bar) - program-error) - t) - -(deftest string-lessp.error.1 - (signals-error (string-lessp) program-error) - t) - -(deftest string-lessp.error.2 - (signals-error (string-lessp "") program-error) - t) - -(deftest string-lessp.error.3 - (signals-error (string-lessp "a" "b" nil nil) program-error) - t) - -(deftest string-lessp.error.4 - (signals-error (string-lessp "a" "b" :start1) program-error) - t) - -(deftest string-lessp.error.5 - (signals-error (string-lessp "a" "b" 1 nil) program-error) - t) - -(deftest string-lessp.error.6 - (signals-error (string-lessp "a" "b" :allow-other-keys nil - :allow-other-keys t :foo 'bar) - program-error) - t) - -(deftest string-greaterp.error.1 - (signals-error (string-greaterp) program-error) - t) - -(deftest string-greaterp.error.2 - (signals-error (string-greaterp "") program-error) - t) - -(deftest string-greaterp.error.3 - (signals-error (string-greaterp "a" "b" nil nil) program-error) - t) - -(deftest string-greaterp.error.4 - (signals-error (string-greaterp "a" "b" :start1) program-error) - t) - -(deftest string-greaterp.error.5 - (signals-error (string-greaterp "a" "b" 1 nil) program-error) - t) - -(deftest string-greaterp.error.6 - (signals-error (string-greaterp "a" "b" :allow-other-keys nil - :allow-other-keys t :foo 'bar) - program-error) - t) - -(deftest string-not-lessp.error.1 - (signals-error (string-not-lessp) program-error) - t) - -(deftest string-not-lessp.error.2 - (signals-error (string-not-lessp "") program-error) - t) - -(deftest string-not-lessp.error.3 - (signals-error (string-not-lessp "a" "b" nil nil) program-error) - t) - -(deftest string-not-lessp.error.4 - (signals-error (string-not-lessp "a" "b" :start1) program-error) - t) - -(deftest string-not-lessp.error.5 - (signals-error (string-not-lessp "a" "b" 1 nil) program-error) - t) - -(deftest string-not-lessp.error.6 - (signals-error (string-not-lessp "a" "b" :allow-other-keys nil - :allow-other-keys t :foo 'bar) - program-error) - t) - -(deftest string-not-greaterp.error.1 - (signals-error (string-not-greaterp) program-error) - t) - -(deftest string-not-greaterp.error.2 - (signals-error (string-not-greaterp "") program-error) - t) - -(deftest string-not-greaterp.error.3 - (signals-error (string-not-greaterp "a" "b" nil nil) program-error) - t) - -(deftest string-not-greaterp.error.4 - (signals-error (string-not-greaterp "a" "b" :start1) program-error) - t) - -(deftest string-not-greaterp.error.5 - (signals-error (string-not-greaterp "a" "b" 1 nil) program-error) - t) - -(deftest string-not-greaterp.error.6 - (signals-error (string-not-greaterp "a" "b" :allow-other-keys nil - :allow-other-keys t :foo 'bar) - program-error) - t) diff --git a/t/ansi-test/strings/string-downcase.lsp b/t/ansi-test/strings/string-downcase.lsp deleted file mode 100644 index 141879d..0000000 --- a/t/ansi-test/strings/string-downcase.lsp +++ /dev/null @@ -1,164 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Sep 30 21:41:59 2002 -;;;; Contains: Tests for STRING-DOWNCASE - -(in-package :cl-test) - -(deftest string-downcase.1 - (let ((s "A")) - (values (string-downcase s) s)) - "a" "A") - -(deftest string-downcase.2 - (let ((s "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")) - (values (string-downcase s) s)) - "abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz" - "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz") - -(deftest string-downcase.3 - (let ((s "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ ")) - (values (string-downcase s) s)) - "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ " - "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ ") - -(deftest string-downcase.4 - (string-downcase #\A) - "a") - -(deftest string-downcase.5 - (let ((sym '|A|)) - (values (string-downcase sym) sym)) - "a" |A|) - -(deftest string-downcase.6 - (let ((s (make-array 6 :element-type 'character - :initial-contents '(#\A #\B #\C #\D #\E #\F)))) - (values (string-downcase s) s)) - "abcdef" - "ABCDEF") - -(deftest string-downcase.7 - (let ((s (make-array 6 :element-type 'standard-char - :initial-contents '(#\A #\B #\7 #\D #\E #\F)))) - (values (string-downcase s) s)) - "ab7def" - "AB7DEF") - -;; Tests with :start, :end - -(deftest string-downcase.8 - (let ((s "ABCDEF")) - (values - (loop for i from 0 to 6 - collect (string-downcase s :start i)) - s)) - ("abcdef" "Abcdef" "ABcdef" "ABCdef" "ABCDef" "ABCDEf" "ABCDEF") - "ABCDEF") - -(deftest string-downcase.9 - (let ((s "ABCDEF")) - (values - (loop for i from 0 to 6 - collect (string-downcase s :start i :end nil)) - s)) - ("abcdef" "Abcdef" "ABcdef" "ABCdef" "ABCDef" "ABCDEf" "ABCDEF") - "ABCDEF") - -(deftest string-downcase.10 - (let ((s "ABCDE")) - (values - (loop for i from 0 to 4 - collect (loop for j from i to 5 - collect (string-invertcase - (string-downcase s :start i :end j)))) - s)) - (("abcde" "Abcde" "ABcde" "ABCde" "ABCDe" "ABCDE") - ("abcde" "aBcde" "aBCde" "aBCDe" "aBCDE") - ("abcde" "abCde" "abCDe" "abCDE") - ("abcde" "abcDe" "abcDE") - ("abcde" "abcdE")) - "ABCDE") - -(deftest string-downcase.11 - :notes (:nil-vectors-are-strings) - (string-downcase (make-array '(0) :element-type nil)) - "") - -(deftest string-downcase.12 - (loop for type in '(standard-char base-char character) - for s = (make-array '(10) :element-type type - :fill-pointer 5 - :initial-contents "aB0cDefGHi") - collect (list s (string-downcase s))) - (("aB0cD" "ab0cd") ("aB0cD" "ab0cd") ("aB0cD" "ab0cd"))) - - -(deftest string-downcase.13 - (loop for type in '(standard-char base-char character) - for s0 = (make-array '(10) :element-type type - :initial-contents "zZaB0cDefG") - for s = (make-array '(5) :element-type type - :displaced-to s0 - :displaced-index-offset 2) - collect (list s (string-downcase s))) - (("aB0cD" "ab0cd") ("aB0cD" "ab0cd") ("aB0cD" "ab0cd"))) - -(deftest string-downcase.14 - (loop for type in '(standard-char base-char character) - for s = (make-array '(5) :element-type type - :adjustable t - :initial-contents "aB0cD") - collect (list s (string-downcase s))) - (("aB0cD" "ab0cd") ("aB0cD" "ab0cd") ("aB0cD" "ab0cd"))) - -;;; Order of evaluation tests - -(deftest string-downcase.order.1 - (let ((i 0) a b c (s (copy-seq "ABCDEF"))) - (values - (string-downcase - (progn (setf a (incf i)) s) - :start (progn (setf b (incf i)) 1) - :end (progn (setf c (incf i)) 4)) - i a b c)) - "AbcdEF" 3 1 2 3) - -(deftest string-downcase.order.2 - (let ((i 0) a b c (s (copy-seq "ABCDEF"))) - (values - (string-downcase - (progn (setf a (incf i)) s) - :end (progn (setf b (incf i)) 4) - :start (progn (setf c (incf i)) 1)) - i a b c)) - "AbcdEF" 3 1 2 3) - -(def-fold-test string-downcase.fold.1 (string-downcase "ABCDE")) - -;;; Error cases - -(deftest string-downcase.error.1 - (signals-error (string-downcase) program-error) - t) - -(deftest string-downcase.error.2 - (signals-error (string-downcase (copy-seq "abc") :bad t) program-error) - t) - -(deftest string-downcase.error.3 - (signals-error (string-downcase (copy-seq "abc") :start) program-error) - t) - -(deftest string-downcase.error.4 - (signals-error (string-downcase (copy-seq "abc") :bad t - :allow-other-keys nil) program-error) - t) - -(deftest string-downcase.error.5 - (signals-error (string-downcase (copy-seq "abc") :end) program-error) - t) - -(deftest string-downcase.error.6 - (signals-error (string-downcase (copy-seq "abc") 1 2) program-error) - t) diff --git a/t/ansi-test/strings/string-left-trim.lsp b/t/ansi-test/strings/string-left-trim.lsp deleted file mode 100644 index f80bb0c..0000000 --- a/t/ansi-test/strings/string-left-trim.lsp +++ /dev/null @@ -1,231 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Oct 4 04:57:41 2002 -;;;; Contains: Tests for STRING-LEFT-TRIM - -(in-package :cl-test) - -(deftest string-left-trim.1 - (let* ((s (copy-seq "abcdaba")) - (s2 (string-left-trim "ab" s))) - (values s s2)) - "abcdaba" - "cdaba") - -(deftest string-left-trim.2 - (let* ((s (copy-seq "abcdaba")) - (s2 (string-left-trim '(#\a #\b) s))) - (values s s2)) - "abcdaba" - "cdaba") - -(deftest string-left-trim.3 - (let* ((s (copy-seq "abcdaba")) - (s2 (string-left-trim #(#\a #\b) s))) - (values s s2)) - "abcdaba" - "cdaba") - -(deftest string-left-trim.4 - (let* ((s (copy-seq "abcdaba")) - (s2 (string-left-trim (make-array 2 :initial-contents '(#\a #\b)) - s))) - (values s s2)) - "abcdaba" - "cdaba") - -(deftest string-left-trim.5 - (let* ((s (copy-seq "abcdaba")) - (s2 (string-left-trim (make-array 2 :initial-contents '(#\a #\b) - :element-type 'character) - s))) - (values s s2)) - "abcdaba" - "cdaba") - -(deftest string-left-trim.6 - (let* ((s (copy-seq "abcdaba")) - (s2 (string-left-trim (make-array 2 :initial-contents '(#\a #\b) - :element-type 'standard-char) - s))) - (values s s2)) - "abcdaba" - "cdaba") - -(deftest string-left-trim.7 - (let* ((s (copy-seq "abcdaba")) - (s2 (string-left-trim (make-array 2 :initial-contents '(#\a #\b) - :element-type 'base-char) - s))) - (values s s2)) - "abcdaba" - "cdaba") - -(deftest string-left-trim.8 - (let* ((s (copy-seq "abcdaba")) - (s2 (string-left-trim (make-array 4 :initial-contents '(#\a #\b #\c #\d) - :element-type 'character - :fill-pointer 2) - s))) - (values s s2)) - "abcdaba" - "cdaba") - -(deftest string-left-trim.9 - (let* ((s (make-array 7 :initial-contents "abcdaba" - :element-type 'character - )) - (s2 (string-left-trim "ab" s))) - (values s s2)) - "abcdaba" - "cdaba") - -(deftest string-left-trim.10 - (let* ((s (make-array 9 :initial-contents "abcdabadd" - :element-type 'character - :fill-pointer 7)) - (s2 (string-left-trim "ab" s))) - (values s s2)) - "abcdaba" - "cdaba") - -(deftest string-left-trim.10a - (let* ((s (make-array 9 :initial-contents "abcdabadd" - :element-type 'base-char - :fill-pointer 7)) - (s2 (string-left-trim "ab" s))) - (values s s2)) - "abcdaba" - "cdaba") - -(deftest string-left-trim.10b - (let* ((s (make-array 9 :initial-contents "abcdabadd" - :element-type 'base-char - :adjustable t - :fill-pointer 7)) - (s2 (string-left-trim "ab" s))) - (values s s2)) - "abcdaba" - "cdaba") - -(deftest string-left-trim.11 - (let* ((s (make-array 7 :initial-contents "abcdaba" - :element-type 'standard-char - )) - (s2 (string-left-trim "ab" s))) - (values s s2)) - "abcdaba" - "cdaba") - -(deftest string-left-trim.12 - (let* ((s (make-array 7 :initial-contents "abcdaba" - :element-type 'base-char - )) - (s2 (string-left-trim "ab" s))) - (values s s2)) - "abcdaba" - "cdaba") - -;;; Test that trimming is case sensitive -(deftest string-left-trim.13 - (let* ((s (copy-seq "aA")) - (s2 (string-left-trim "a" s))) - (values s s2)) - "aA" "A") - -(deftest string-left-trim.14 - (let* ((s '|abcdaba|) - (s2 (string-left-trim "ab" s))) - (values (symbol-name s) s2)) - "abcdaba" - "cdaba") - -(deftest string-left-trim.15 - (string-left-trim "abc" "") - "") - -(deftest string-left-trim.16 - (string-left-trim "a" #\a) - "") - -(deftest string-left-trim.17 - (string-left-trim "b" #\a) - "a") - -(deftest string-left-trim.18 - (string-left-trim "" (copy-seq "abcde")) - "abcde") - -(deftest string-left-trim.19 - (string-left-trim "abc" (copy-seq "abcabcabc")) - "") - -(deftest string-left-trim.20 - :notes (:nil-vectors-are-strings) - (string-left-trim "abcd" (make-array '(0) :element-type nil)) - "") - -(deftest string-left-trim.21 - :notes (:nil-vectors-are-strings) - (string-left-trim (make-array '(0) :element-type nil) "abcd") - "abcd") - -(deftest string-left-trim.22 - (let ((s (make-array '(6) :initial-contents "abcaeb" - :element-type 'base-char - :adjustable t))) - (values (string-left-trim "ab" s) s)) - "caeb" "abcaeb") - -(deftest string-left-trim.23 - (let ((s (make-array '(6) :initial-contents "abcaeb" - :element-type 'character - :adjustable t))) - (values (string-left-trim "ab" s) s)) - "caeb" "abcaeb") - -(deftest string-left-trim.24 - (let* ((etype 'base-char) - (s0 (make-array '(6) :initial-contents "abcaeb" - :element-type etype)) - (s (make-array '(3) :element-type etype - :displaced-to s0 - :displaced-index-offset 1))) - (values (string-left-trim "ab" s) s s0)) - "ca" "bca" "abcaeb") - -(deftest string-left-trim.25 - (let* ((etype 'character) - (s0 (make-array '(6) :initial-contents "abcaeb" - :element-type etype)) - (s (make-array '(3) :element-type etype - :displaced-to s0 - :displaced-index-offset 1))) - (values (string-left-trim "ab" s) s s0)) - "ca" "bca" "abcaeb") - - -(deftest string-left-trim.order.1 - (let ((i 0) x y) - (values - (string-left-trim (progn (setf x (incf i)) " ") - (progn (setf y (incf i)) - (copy-seq " abc d e f "))) - i x y)) - "abc d e f " 2 1 2) - -(def-fold-test string-left-trim.fold.1 (string-left-trim " " " abcd")) - -;;; Error cases - -(deftest string-left-trim.error.1 - (signals-error (string-left-trim) program-error) - t) - -(deftest string-left-trim.error.2 - (signals-error (string-left-trim "abc") program-error) - t) - -(deftest string-left-trim.error.3 - (signals-error (string-left-trim "abc" "abcdddabc" nil) program-error) - t) diff --git a/t/ansi-test/strings/string-right-trim.lsp b/t/ansi-test/strings/string-right-trim.lsp deleted file mode 100644 index e3b11a2..0000000 --- a/t/ansi-test/strings/string-right-trim.lsp +++ /dev/null @@ -1,230 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Oct 4 04:59:46 2002 -;;;; Contains: Tests of STRING-RIGHT-TRIM - -(in-package :cl-test) - -(deftest string-right-trim.1 - (let* ((s (copy-seq "abcdaba")) - (s2 (string-right-trim "ab" s))) - (values s s2)) - "abcdaba" - "abcd") - -(deftest string-right-trim.2 - (let* ((s (copy-seq "abcdaba")) - (s2 (string-right-trim '(#\a #\b) s))) - (values s s2)) - "abcdaba" - "abcd") - -(deftest string-right-trim.3 - (let* ((s (copy-seq "abcdaba")) - (s2 (string-right-trim #(#\a #\b) s))) - (values s s2)) - "abcdaba" - "abcd") - -(deftest string-right-trim.4 - (let* ((s (copy-seq "abcdaba")) - (s2 (string-right-trim (make-array 2 :initial-contents '(#\a #\b)) - s))) - (values s s2)) - "abcdaba" - "abcd") - -(deftest string-right-trim.5 - (let* ((s (copy-seq "abcdaba")) - (s2 (string-right-trim (make-array 2 :initial-contents '(#\a #\b) - :element-type 'character) - s))) - (values s s2)) - "abcdaba" - "abcd") - -(deftest string-right-trim.6 - (let* ((s (copy-seq "abcdaba")) - (s2 (string-right-trim (make-array 2 :initial-contents '(#\a #\b) - :element-type 'standard-char) - s))) - (values s s2)) - "abcdaba" - "abcd") - -(deftest string-right-trim.7 - (let* ((s (copy-seq "abcdaba")) - (s2 (string-right-trim (make-array 2 :initial-contents '(#\a #\b) - :element-type 'base-char) - s))) - (values s s2)) - "abcdaba" - "abcd") - -(deftest string-right-trim.8 - (let* ((s (copy-seq "abcdaba")) - (s2 (string-right-trim (make-array 4 :initial-contents '(#\a #\b #\c #\d) - :element-type 'character - :fill-pointer 2) - s))) - (values s s2)) - "abcdaba" - "abcd") - -(deftest string-right-trim.9 - (let* ((s (make-array 7 :initial-contents "abcdaba" - :element-type 'character - )) - (s2 (string-right-trim "ab" s))) - (values s s2)) - "abcdaba" - "abcd") - -(deftest string-right-trim.10 - (let* ((s (make-array 9 :initial-contents "abcdabadd" - :element-type 'character - :fill-pointer 7)) - (s2 (string-right-trim "ab" s))) - (values s s2)) - "abcdaba" - "abcd") - -(deftest string-right-trim.10a - (let* ((s (make-array 9 :initial-contents "abcdabadd" - :element-type 'base-char - :fill-pointer 7)) - (s2 (string-right-trim "ab" s))) - (values s s2)) - "abcdaba" - "abcd") - -(deftest string-right-trim.10b - (let* ((s (make-array 9 :initial-contents "abcdabadd" - :element-type 'base-char - :adjustable t - :fill-pointer 7)) - (s2 (string-right-trim "ab" s))) - (values s s2)) - "abcdaba" - "abcd") - -(deftest string-right-trim.11 - (let* ((s (make-array 7 :initial-contents "abcdaba" - :element-type 'standard-char - )) - (s2 (string-right-trim "ab" s))) - (values s s2)) - "abcdaba" - "abcd") - -(deftest string-right-trim.12 - (let* ((s (make-array 7 :initial-contents "abcdaba" - :element-type 'base-char - )) - (s2 (string-right-trim "ab" s))) - (values s s2)) - "abcdaba" - "abcd") - -;;; Test that trimming is case sensitive -(deftest string-right-trim.13 - (let* ((s (copy-seq "Aa")) - (s2 (string-right-trim "a" s))) - (values s s2)) - "Aa" "A") - -(deftest string-right-trim.14 - (let* ((s '|abcdaba|) - (s2 (string-right-trim "ab" s))) - (values (symbol-name s) s2)) - "abcdaba" - "abcd") - -(deftest string-right-trim.15 - (string-right-trim "abc" "") - "") - -(deftest string-right-trim.16 - (string-right-trim "a" #\a) - "") - -(deftest string-right-trim.17 - (string-right-trim "b" #\a) - "a") - -(deftest string-right-trim.18 - (string-right-trim "" (copy-seq "abcde")) - "abcde") - -(deftest string-right-trim.19 - (string-right-trim "abc" (copy-seq "abcabcabc")) - "") - -(deftest string-right-trim.20 - :notes (:nil-vectors-are-strings) - (string-right-trim "abcd" (make-array '(0) :element-type nil)) - "") - -(deftest string-right-trim.21 - :notes (:nil-vectors-are-strings) - (string-right-trim (make-array '(0) :element-type nil) "abcd") - "abcd") - -(deftest string-right-trim.22 - (let ((s (make-array '(6) :initial-contents "abcaeb" - :element-type 'base-char - :adjustable t))) - (values (string-right-trim "ab" s) s)) - "abcae" "abcaeb") - -(deftest string-right-trim.23 - (let ((s (make-array '(6) :initial-contents "abcaeb" - :element-type 'character - :adjustable t))) - (values (string-right-trim "ab" s) s)) - "abcae" "abcaeb") - -(deftest string-right-trim.24 - (let* ((etype 'base-char) - (s0 (make-array '(6) :initial-contents "abcaeb" - :element-type etype)) - (s (make-array '(3) :element-type etype - :displaced-to s0 - :displaced-index-offset 1))) - (values (string-right-trim "ab" s) s s0)) - "bc" "bca" "abcaeb") - -(deftest string-right-trim.25 - (let* ((etype 'character) - (s0 (make-array '(6) :initial-contents "abcaeb" - :element-type etype)) - (s (make-array '(3) :element-type etype - :displaced-to s0 - :displaced-index-offset 1))) - (values (string-right-trim "ab" s) s s0)) - "bc" "bca" "abcaeb") - -(deftest string-right-trim.order.1 - (let ((i 0) x y) - (values - (string-right-trim (progn (setf x (incf i)) " ") - (progn (setf y (incf i)) - (copy-seq " abc d e f "))) - i x y)) - " abc d e f" 2 1 2) - -(def-fold-test string-right-trim.fold.1 (string-right-trim " " "abcd ")) - -;;; Error cases - -(deftest string-right-trim.error.1 - (signals-error (string-right-trim) program-error) - t) - -(deftest string-right-trim.error.2 - (signals-error (string-right-trim "abc") program-error) - t) - -(deftest string-right-trim.error.3 - (signals-error (string-right-trim "abc" "abcdddabc" nil) program-error) - t) diff --git a/t/ansi-test/strings/string-trim.lsp b/t/ansi-test/strings/string-trim.lsp deleted file mode 100644 index 715935d..0000000 --- a/t/ansi-test/strings/string-trim.lsp +++ /dev/null @@ -1,231 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Oct 3 21:53:38 2002 -;;;; Contains: Tests for STRING-TRIM - -(in-package :cl-test) - -(deftest string-trim.1 - (let* ((s (copy-seq "abcdaba")) - (s2 (string-trim "ab" s))) - (values s s2)) - "abcdaba" - "cd") - -(deftest string-trim.2 - (let* ((s (copy-seq "abcdaba")) - (s2 (string-trim '(#\a #\b) s))) - (values s s2)) - "abcdaba" - "cd") - -(deftest string-trim.3 - (let* ((s (copy-seq "abcdaba")) - (s2 (string-trim #(#\a #\b) s))) - (values s s2)) - "abcdaba" - "cd") - -(deftest string-trim.4 - (let* ((s (copy-seq "abcdaba")) - (s2 (string-trim (make-array 2 :initial-contents '(#\a #\b)) - s))) - (values s s2)) - "abcdaba" - "cd") - -(deftest string-trim.5 - (let* ((s (copy-seq "abcdaba")) - (s2 (string-trim (make-array 2 :initial-contents '(#\a #\b) - :element-type 'character) - s))) - (values s s2)) - "abcdaba" - "cd") - -(deftest string-trim.6 - (let* ((s (copy-seq "abcdaba")) - (s2 (string-trim (make-array 2 :initial-contents '(#\a #\b) - :element-type 'standard-char) - s))) - (values s s2)) - "abcdaba" - "cd") - -(deftest string-trim.7 - (let* ((s (copy-seq "abcdaba")) - (s2 (string-trim (make-array 2 :initial-contents '(#\a #\b) - :element-type 'base-char) - s))) - (values s s2)) - "abcdaba" - "cd") - -(deftest string-trim.8 - (let* ((s (copy-seq "abcdaba")) - (s2 (string-trim (make-array 4 :initial-contents '(#\a #\b #\c #\d) - :element-type 'character - :fill-pointer 2) - s))) - (values s s2)) - "abcdaba" - "cd") - -(deftest string-trim.8a - (let* ((s (copy-seq "abcdaba")) - (s2 (string-trim (make-array 4 :initial-contents '(#\a #\b #\c #\d) - :element-type 'base-char - :fill-pointer 2) - s))) - (values s s2)) - "abcdaba" - "cd") - -(deftest string-trim.9 - (let* ((s (make-array 7 :initial-contents "abcdaba" - :element-type 'character - )) - (s2 (string-trim "ab" s))) - (values s s2)) - "abcdaba" - "cd") - -(deftest string-trim.10 - (let* ((s (make-array 9 :initial-contents "abcdabadd" - :element-type 'character - :fill-pointer 7)) - (s2 (string-trim "ab" s))) - (values s s2)) - "abcdaba" - "cd") - -(deftest string-trim.10a - (let* ((s (make-array 9 :initial-contents "abcdabadd" - :element-type 'base-char - :adjustable t - :fill-pointer 7)) - (s2 (string-trim "ab" s))) - (values s s2)) - "abcdaba" - "cd") - -(deftest string-trim.11 - (let* ((s (make-array 7 :initial-contents "abcdaba" - :element-type 'standard-char - )) - (s2 (string-trim "ab" s))) - (values s s2)) - "abcdaba" - "cd") - -(deftest string-trim.12 - (let* ((s (make-array 7 :initial-contents "abcdaba" - :element-type 'base-char - )) - (s2 (string-trim "ab" s))) - (values s s2)) - "abcdaba" - "cd") - -;;; Test that trimming is case sensitive -(deftest string-trim.13 - (let* ((s (copy-seq "Aa")) - (s2 (string-trim "a" s))) - (values s s2)) - "Aa" "A") - -(deftest string-trim.14 - (let* ((s '|abcdaba|) - (s2 (string-trim "ab" s))) - (values (symbol-name s) s2)) - "abcdaba" - "cd") - -(deftest string-trim.15 - (string-trim "abc" "") - "") - -(deftest string-trim.16 - (string-trim "a" #\a) - "") - -(deftest string-trim.17 - (string-trim "b" #\a) - "a") - -(deftest string-trim.18 - (string-trim "" (copy-seq "abcde")) - "abcde") - -(deftest string-trim.19 - (string-trim "abc" (copy-seq "abcabcabc")) - "") - -(deftest string-trim.20 - :notes (:nil-vectors-are-strings) - (string-trim "abcd" (make-array '(0) :element-type nil)) - "") - -(deftest string-trim.21 - :notes (:nil-vectors-are-strings) - (string-trim (make-array '(0) :element-type nil) "abcd") - "abcd") - -(deftest string-trim.22 - (let ((s (make-array '(6) :initial-contents "abcaeb" - :element-type 'base-char - :adjustable t))) - (values (string-trim "ab" s) s)) - "cae" "abcaeb") - -(deftest string-trim.23 - (let ((s (make-array '(6) :initial-contents "abcaeb" - :element-type 'character - :adjustable t))) - (values (string-trim "ab" s) s)) - "cae" "abcaeb") - -(deftest string-trim.24 - (let* ((etype 'base-char) - (s0 (make-array '(6) :initial-contents "abcaeb" - :element-type etype)) - (s (make-array '(3) :element-type etype - :displaced-to s0 - :displaced-index-offset 1))) - (values (string-trim "ab" s) s s0)) - "c" "bca" "abcaeb") - -(deftest string-trim.25 - (let* ((etype 'character) - (s0 (make-array '(6) :initial-contents "abcaeb" - :element-type etype)) - (s (make-array '(3) :element-type etype - :displaced-to s0 - :displaced-index-offset 1))) - (values (string-trim "ab" s) s s0)) - "c" "bca" "abcaeb") - -(deftest string-trim.order.1 - (let ((i 0) x y) - (values - (string-trim (progn (setf x (incf i)) " ") - (progn (setf y (incf i)) - (copy-seq " abc d e f "))) - i x y)) - "abc d e f" 2 1 2) - -(def-fold-test string-trim.fold.1 (string-trim " " " abcd ")) - -;;; Error cases - -(deftest string-trim.error.1 - (signals-error (string-trim) program-error) - t) - -(deftest string-trim.error.2 - (signals-error (string-trim "abc") program-error) - t) - -(deftest string-trim.error.3 - (signals-error (string-trim "abc" "abcdddabc" nil) program-error) - t) diff --git a/t/ansi-test/strings/string-upcase.lsp b/t/ansi-test/strings/string-upcase.lsp deleted file mode 100644 index ca10966..0000000 --- a/t/ansi-test/strings/string-upcase.lsp +++ /dev/null @@ -1,166 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Oct 1 07:51:00 2002 -;;;; Contains: Tests for STRING-UPCASE - -(in-package :cl-test) - -(deftest string-upcase.1 - (let ((s "a")) - (values (string-upcase s) s)) - "A" "a") - -(deftest string-upcase.2 - (let ((s "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")) - (values (string-upcase s) s)) - "ABCDEFGHIJKLMNOPQRSTUVWXYZABCDEFGHIJKLMNOPQRSTUVWXYZ" - "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz") - -(deftest string-upcase.3 - (let ((s "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ ")) - (values (string-upcase s) s)) - "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ " - "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ ") - -(deftest string-upcase.4 - (string-upcase #\a) - "A") - -(deftest string-upcase.5 - (let ((sym '|a|)) - (values (string-upcase sym) sym)) - "A" |a|) - -(deftest string-upcase.6 - (let ((s (make-array 6 :element-type 'character - :initial-contents '(#\a #\b #\c #\d #\e #\f)))) - (values (string-upcase s) s)) - "ABCDEF" - "abcdef") - -(deftest string-upcase.7 - (let ((s (make-array 6 :element-type 'standard-char - :initial-contents '(#\a #\b #\7 #\d #\e #\f)))) - (values (string-upcase s) s)) - "AB7DEF" - "ab7def") - -;; Tests with :start, :end - -(deftest string-upcase.8 - (let ((s "abcdef")) - (values - (loop for i from 0 to 6 - collect (string-upcase s :start i)) - s)) - ("ABCDEF" "aBCDEF" "abCDEF" "abcDEF" "abcdEF" "abcdeF" "abcdef") - "abcdef") - -(deftest string-upcase.9 - (let ((s "abcdef")) - (values - (loop for i from 0 to 6 - collect - (string-upcase s :start i :end nil)) - s)) - ("ABCDEF" "aBCDEF" "abCDEF" "abcDEF" "abcdEF" "abcdeF" "abcdef") - "abcdef") - -(deftest string-upcase.10 - (let ((s "abcde")) - (values - (loop for i from 0 to 4 - collect (loop for j from i to 5 - collect (string-upcase s :start i :end j))) - s)) - (("abcde" "Abcde" "ABcde" "ABCde" "ABCDe" "ABCDE") - ("abcde" "aBcde" "aBCde" "aBCDe" "aBCDE") - ("abcde" "abCde" "abCDe" "abCDE") - ("abcde" "abcDe" "abcDE") - ("abcde" "abcdE")) - "abcde") - -(deftest string-upcase.11 - :notes (:nil-vectors-are-strings) - (string-upcase (make-array '(0) :element-type nil)) - "") - -(deftest string-upcase.12 - (loop for type in '(standard-char base-char character) - for s = (make-array '(10) :element-type type - :fill-pointer 5 - :initial-contents "aB0cDefGHi") - collect (list s (string-upcase s))) - (("aB0cD" "AB0CD") ("aB0cD" "AB0CD") ("aB0cD" "AB0CD"))) - - -(deftest string-upcase.13 - (loop for type in '(standard-char base-char character) - for s0 = (make-array '(10) :element-type type - :initial-contents "zZaB0cDefG") - for s = (make-array '(5) :element-type type - :displaced-to s0 - :displaced-index-offset 2) - collect (list s (string-upcase s))) - (("aB0cD" "AB0CD") ("aB0cD" "AB0CD") ("aB0cD" "AB0CD"))) - -(deftest string-upcase.14 - (loop for type in '(standard-char base-char character) - for s = (make-array '(5) :element-type type - :adjustable t - :initial-contents "aB0cD") - collect (list s (string-upcase s))) - (("aB0cD" "AB0CD") ("aB0cD" "AB0CD") ("aB0cD" "AB0CD"))) - -;;; Order of evaluation tests - -(deftest string-upcase.order.1 - (let ((i 0) a b c (s (copy-seq "abcdef"))) - (values - (string-upcase - (progn (setf a (incf i)) s) - :start (progn (setf b (incf i)) 1) - :end (progn (setf c (incf i)) 4)) - i a b c)) - "aBCDef" 3 1 2 3) - -(deftest string-upcase.order.2 - (let ((i 0) a b c (s (copy-seq "abcdef"))) - (values - (string-upcase - (progn (setf a (incf i)) s) - :end (progn (setf b (incf i)) 4) - :start (progn (setf c (incf i)) 1)) - i a b c)) - "aBCDef" 3 1 2 3) - -;;; Const fold tests - -(def-fold-test string-upcase.fold.1 (string-upcase "abcde")) - -;;; Error tests - -(deftest string-upcase.error.1 - (signals-error (string-upcase) program-error) - t) - -(deftest string-upcase.error.2 - (signals-error (string-upcase (copy-seq "abc") :bad t) program-error) - t) - -(deftest string-upcase.error.3 - (signals-error (string-upcase (copy-seq "abc") :start) program-error) - t) - -(deftest string-upcase.error.4 - (signals-error (string-upcase (copy-seq "abc") :bad t - :allow-other-keys nil) program-error) - t) - -(deftest string-upcase.error.5 - (signals-error (string-upcase (copy-seq "abc") :end) program-error) - t) - -(deftest string-upcase.error.6 - (signals-error (string-upcase (copy-seq "abc") 1 2) program-error) - t) diff --git a/t/ansi-test/strings/string.lsp b/t/ansi-test/strings/string.lsp deleted file mode 100644 index 233eec7..0000000 --- a/t/ansi-test/strings/string.lsp +++ /dev/null @@ -1,154 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Sep 30 19:16:59 2002 -;;;; Contains: Tests for string related functions and classes - -(in-package :cl-test) - -(deftest string.1 - (subtypep* 'string 'array) - t t) - -(deftest string.2 - (subtypep* 'string 'vector) - t t) - -(deftest string.3 - (subtypep* 'string 'sequence) - t t) - -(deftest string.4 - (let ((s (string #\a))) - (values (notnot (stringp s)) s)) - t "a") - -(deftest string.5 - (let ((s (string ""))) - (values (notnot (stringp s)) s)) - t "") - -(deftest string.6 - (let ((s (string '|FOO|))) - (values (notnot (stringp s)) s)) - t "FOO") - -(deftest string.7 - (check-predicate - #'(lambda (x) - (handler-case (stringp (string x)) - (type-error () :caught)))) - nil) - -(deftest string.8 - :notes (:allow-nil-arrays :nil-vectors-are-strings) - (subtypep* '(array nil (*)) 'string) - t t) - -(deftest string.9 - :notes (:allow-nil-arrays :nil-vectors-are-strings) - (subtypep* '(array nil 1) 'string) - t t) - -(deftest string.10 - :notes (:allow-nil-arrays :nil-vectors-are-strings) - (string (make-array '(0) :element-type nil)) - "") - -(deftest string.11 - (typep* "abcd" 'string) - t) - -(deftest string.12 - :notes (:allow-nil-arrays :nil-vectors-are-strings) - (typep* (make-array '(17) :element-type nil) 'string) - t) - -(deftest string.13 - :notes (:allow-nil-arrays :nil-vectors-are-strings) - (typep* (make-array '(0) :element-type nil) 'string) - t) - -(deftest string.14 - (let ((count 0)) - (loop for i below (min char-code-limit 65536) - for c = (code-char i) - for s = (and c (string c)) - when (and c - (or (not (stringp s)) - (not (= (length s) 1)) - (not (eql c (char s 0))))) - collect (progn (incf count) (list i c s)) - until (>= count 100))) - nil) - -(deftest string.15 - (when (> char-code-limit 65536) - (loop for i = (random char-code-limit) - for c = (code-char i) - for s = (and c (string c)) - repeat 2000 - when (and c - (or (not (stringp s)) - (not (= (length s) 1)) - (not (eql c (char s 0))))) - collect (list i c s))) - nil) - -(deftest string.16 - (check-predicate #'(lambda (s) (or (not (stringp s)) (eq s (string s))))) - nil) - -(deftest string.17 - (typep* "abc" '(string)) - t) - -(deftest string.18 - (typep* "abc" '(string *)) - t) - -(deftest string.19 - (typep* "abc" '(string 3)) - t) - -(deftest string.20 - (typep* "abc" '(string 2)) - nil) - -(deftest string.21 - (typep* "abc" '(string 4)) - nil) - -(deftest string.22 - (do-special-strings (s "X") (assert (typep s 'string))) - nil) - -(deftest string.23 - (do-special-strings (s "X") (assert (typep s '(string)))) - nil) - -(deftest string.24 - (do-special-strings (s "X") (assert (typep s '(string *)))) - nil) - -(deftest string.25 - (do-special-strings (s "X") - (or (array-has-fill-pointer-p s) - (assert (typep s '(string 1))))) - nil) - -(deftest string.26 - (let ((i 0)) - (values (string (progn (incf i) "")) i)) - "" 1) - -(def-fold-test string.fold.1 (string #\A)) - -;;; Error tests - -(deftest string.error.1 - (signals-error (string) program-error) - t) - -(deftest string.error.2 - (signals-error (string nil nil) program-error) - t) diff --git a/t/ansi-test/strings/stringp.lsp b/t/ansi-test/strings/stringp.lsp deleted file mode 100644 index 0bc6079..0000000 --- a/t/ansi-test/strings/stringp.lsp +++ /dev/null @@ -1,97 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Aug 29 17:32:20 2004 -;;;; Contains: Tests of STRINGP - -(in-package :cl-test) - -(deftest stringp.1 - (check-type-predicate #'stringp 'string) - nil) - -(deftest stringp.2 - (notnot (stringp "abcd")) - t) - -(deftest stringp.3 - (notnot (stringp (make-array 4 :element-type 'character - :initial-contents '(#\a #\b #\c #\d)))) - t) - -(deftest stringp.4 - (notnot (stringp (make-array 4 :element-type 'base-char - :initial-contents '(#\a #\b #\c #\d)))) - t) - -(deftest stringp.5 - (notnot (stringp (make-array 4 :element-type 'standard-char - :initial-contents '(#\a #\b #\c #\d)))) - t) - -(deftest stringp.6 - (stringp 0) - nil) - -(deftest stringp.7 - (stringp #\a) - nil) - -(deftest stringp.8 - (let* ((s (make-array 10 :element-type 'character - :initial-element #\a)) - (s2 (make-array 4 :element-type 'character - :displaced-to s - :displaced-index-offset 2))) - (notnot (stringp s2))) - t) - -(deftest stringp.9 - :notes (:nil-vectors-are-strings) - (notnot-mv (stringp (make-array '(0) :element-type nil))) - t) - -(deftest stringp.10 - :notes (:nil-vectors-are-strings) - (notnot-mv (stringp (make-array '(37) :element-type nil))) - t) - -(deftest stringp.11 - (notnot (stringp (make-array 4 :element-type 'base-char - :fill-pointer 2 - :initial-contents '(#\a #\b #\c #\d)))) - t) - -(deftest stringp.12 - (notnot (stringp (make-array 4 :element-type 'base-char - :adjustable t - :initial-contents '(#\a #\b #\c #\d)))) - t) - -(deftest stringp.13 - (notnot (stringp (make-array 4 :element-type 'character - :fill-pointer 2 - :initial-contents '(#\a #\b #\c #\d)))) - t) - -(deftest stringp.14 - (notnot (stringp (make-array 4 :element-type 'character - :adjustable t - :initial-contents '(#\a #\b #\c #\d)))) - t) - -(deftest stringp.15 - (let ((i 0)) - (values - (notnot (stringp (progn (incf i) ""))) - i)) - t 1) - -;;; Error tests - -(deftest stringp.error.1 - (signals-error (stringp) program-error) - t) - -(deftest stringp.error.2 - (signals-error (stringp "" nil) program-error) - t) diff --git a/t/ansi-test/structures/load.lsp b/t/ansi-test/structures/load.lsp deleted file mode 100644 index f78244f..0000000 --- a/t/ansi-test/structures/load.lsp +++ /dev/null @@ -1,13 +0,0 @@ -;;; Tests of structures - -(in-package #:cl-test) - -(let ((*default-pathname-defaults* - (make-pathname - :directory (pathname-directory *load-pathname*)))) - (load "structure-00.lsp") - (load "structures-01.lsp") - (load "structures-02.lsp") - (load "structures-03.lsp") - (load "structures-04.lsp") -) diff --git a/t/ansi-test/structures/structure-00.lsp b/t/ansi-test/structures/structure-00.lsp deleted file mode 100644 index b0b26ac..0000000 --- a/t/ansi-test/structures/structure-00.lsp +++ /dev/null @@ -1,558 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat May 9 11:21:25 1998 -;;;; Contains: Common code for creating structure tests - -(in-package :cl-test) -(declaim (optimize (safety 3))) - -(defun make-struct-test-name (structure-name n) - ;; (declare (type (or string symbol character) structure-name) - ;; (type fixnum n)) - (assert (typep structure-name '(or string symbol character))) - ;; (assert (typep n 'fixnum)) - (setf structure-name (string structure-name)) - (intern (concatenate 'string - structure-name - "/" - (princ-to-string n)))) - -(defun make-struct-p-fn (structure-name) - (assert (typep structure-name '(or string symbol character))) - (setf structure-name (string structure-name)) - (intern (concatenate 'string - structure-name - (string '#:-p)))) - -(defun make-struct-copy-fn (structure-name) - (assert (typep structure-name '(or string symbol character))) - (setf structure-name (string structure-name)) - (intern (concatenate 'string - (string '#:copy-) - structure-name))) - -(defun make-struct-field-fn (conc-name field-name) - "Make field accessor for a field in a structure" - (cond - ((null conc-name) field-name) - (t - (assert (typep conc-name '(or string symbol character))) - (assert (typep field-name '(or string symbol character))) - (setf conc-name (string conc-name)) - (setf field-name (string field-name)) - (intern (concatenate 'string conc-name field-name))))) - -(defun make-struct-make-fn (structure-name) - "Make the make- function for a structure" - (assert (typep structure-name '(or string symbol character))) - (setf structure-name (string structure-name)) - (intern (concatenate 'string - (string '#:make-) structure-name))) - -(defun create-instance-of-type (type) - "Return an instance of a type. Signal an error if - it can't figure out a value for the type." - (cond - ((eqt type t) ;; anything - 'a) - ((eqt type 'symbol) - 'b) - ((eqt type 'null) nil) - ((eqt type 'boolean) t) - ((eqt type 'keyword) :foo) - ((eqt type nil) (error "Cannot obtain element of type ~S~%" type)) - ((eqt type 'cons) (cons 'a 'b)) - ((eqt type 'list) (list 1 2 3)) - ((eqt type 'fixnum) 17) - ((eqt type 'bignum) - (let ((x 1)) - (loop until (typep x 'bignum) - do (setq x (* 2 x))) - x)) - ((and (symbolp type) - (typep type 'structure-class)) - (let ((make-fn - (intern (concatenate 'string (string '#:make-) (symbol-name type)) - (symbol-package type)))) - (eval (list make-fn)))) - ((eqt type 'character) #\w) - ((eqt type 'base-char) #\z) - ((member type '(integer unsigned-byte signed-byte)) 35) - ((eqt type 'bit) 1) - ((and (consp type) - (consp (cdr type)) - (consp (cddr type)) - (null (cdddr type)) - (eqt (car type) 'integer) - (integerp (second type))) - (second type)) - ((member type '(float single-float long-float double-float short-float)) - 0.0) - ((and (consp type) - (eqt (car type) 'member) - (consp (cdr type))) - (second type)) - ((and (consp type) - (eqt (car type) 'or) - (consp (second type))) - (create-instance-of-type (second type))) - (t (error "Cannot generate element for type ~S~%" type)))) - -(defun find-option (option-list option &optional default) - (loop for opt in option-list - when (or (eq opt option) - (and (consp opt) - (eq (car opt) option))) - return opt - finally (return default))) - -(defvar *defstruct-with-tests-names* nil - "Names of structure types defined with DEFSRUCT-WITH-TESTS.") - -#| -(defvar *subtypep-works-with-classes* t - "Becomes NIL if SUBTYPEP doesn't work with classes. We test this first to avoid - repeated test failures that cause GCL to bomb.") - -(deftest subtypep-works-with-classes - (let ((c1 (find-class 'vector))) - ;; (setq *subtypep-works-with-classes* nil) - (subtypep c1 'vector) - (subtypep 'vector c1) - ;; (setq *subtypep-works-with-classes* t)) - t) - -(defvar *typep-works-with-classes* t - "Becomes NIL if TYPEP doesn't work with classes. We test this first to avoid - repeated test failures that cause GCL to bomb.") - -(deftest typep-works-with-classes - (let ((c1 (find-class 'vector))) - ;; (setq *typep-works-with-classes* nil) - (typep #(0 0) c1) - ;; (setq *typep-works-with-classes* t)) - t) -|# - -;; -;; There are a number of standardized tests for -;; structures. The following macro generates the -;; structure definition and the tests. -;; - -(defmacro defstruct-with-tests - (name-and-options &body slot-descriptions-and-documentation) -"Construct standardized tests for a defstruct, and also -do the defstruct." - (defstruct-with-tests-fun name-and-options - slot-descriptions-and-documentation)) - -(defun defstruct-with-tests-fun (name-and-options - slot-descriptions-and-documentation) - ;; Function called from macro defstruct-with-tests - (let* ( - ;; Either NIL or the documentation string for the structure - (doc-string - (when (and (consp slot-descriptions-and-documentation) - (stringp (car slot-descriptions-and-documentation))) - (car slot-descriptions-and-documentation))) - - ;; The list of slot descriptions that follows either the - ;; name and options or the doc string - (slot-descriptions - (if doc-string (cdr slot-descriptions-and-documentation) - slot-descriptions-and-documentation)) - - ;; The name of the structure (should be a symbol) - (name (if (consp name-and-options) - (car name-and-options) - name-and-options)) - - ;; The options list, or NIL if there were no options - (options (if (consp name-and-options) - (cdr name-and-options) - nil)) - - ;; List of symbols that are the names of the slots - (slot-names - (loop - for x in slot-descriptions collect - (if (consp x) (car x) x))) - - ;; List of slot types, if any - (slot-types - (loop - for x in slot-descriptions collect - (if (consp x) - (getf (cddr x) :type :none) - :none))) - - ;; read-only flags for slots - (slot-read-only - (loop - for x in slot-descriptions collect - (and (consp x) - (getf (cddr x) :read-only)))) - - ;; Symbol obtained by prepending MAKE- to the name symbol - (make-fn (make-struct-make-fn name)) - - ;; The type option, if specified - (type-option (find-option options :type)) - (struct-type (second type-option)) - - (named-option (find-option options :named)) - (include-option (find-option options :include)) - - ;; The :predicate option entry from OPTIONS, or NIL if none - (predicate-option (find-option options :predicate)) - - ;; The name of the -P function, either the default or the - ;; one specified in the :predicate option - (p-fn-default (make-struct-p-fn name)) - (p-fn (cond - ((and type-option (not named-option)) nil) - ((or (eq predicate-option :predicate) - (null (cdr predicate-option))) - p-fn-default) - ((cadr predicate-option) (cadr predicate-option)) - (t nil))) - - ;; The :copier option, or NIL if no such option specified - (copier-option (find-option options :copier)) - ;; The name of the copier function, either the default or - ;; one speciefied in the :copier option - (copy-fn-default (make-struct-copy-fn name)) - (copy-fn (cond - ((or (eq copier-option :copier) - (null (cdr copier-option))) - copy-fn-default) - ((cadr copier-option) (cadr copier-option)) - (t nil))) - - ;; The :conc-name option, or NIL if none specified - (conc-option (find-option options :conc-name)) - ;; String to be prepended to slot names to get the - ;; slot accessor function - (conc-prefix-default (concatenate 'string (string name) "-")) - (conc-prefix (cond - ((null conc-option) - conc-prefix-default) - ((or (eq conc-option :conc-name) - (null (cadr conc-option))) - nil) - (t (string (cadr conc-option))))) - - (initial-offset-option (find-option options :initial-offset)) - (initial-offset (second initial-offset-option)) - - ;; Accessor names - (field-fns - (loop for slot-name in slot-names - collect (make-struct-field-fn conc-prefix slot-name))) - - ;; a list of initial values - (initial-value-alist - (loop - for slot-desc in slot-descriptions - for slot-name in slot-names - for type in slot-types - for i from 1 - collect (if (not (eq type :none)) - (cons slot-name (create-instance-of-type type)) - (cons slot-name (defstruct-maketemp name "SLOTTEMP" i))))) - ) - (declare (ignorable initial-offset)) - ;; Build the tests in an eval-when form - `(eval-when (:load-toplevel :compile-toplevel :execute) - - (report-and-ignore-errors - (eval '(defstruct ,name-and-options - ,@slot-descriptions-and-documentation)) - ,(unless (or type-option include-option) - `(pushnew ',name *defstruct-with-tests-names*)) - nil) - - ;; Test that structure is of the correct type - (deftest ,(make-struct-test-name name 1) - (and (fboundp (quote ,make-fn)) - (functionp (function ,make-fn)) - (symbol-function (quote ,make-fn)) - (typep (,make-fn) (quote ,(if type-option struct-type - name))) - t) - t) - - ;; Test that the predicate exists - ,@(when p-fn - `((deftest ,(make-struct-test-name name 2) - (let ((s (,make-fn))) - (and (fboundp (quote ,p-fn)) - (functionp (function ,p-fn)) - (symbol-function (quote ,p-fn)) - (notnot (funcall #',p-fn s)) - (notnot-mv (,p-fn s)) - )) - t) - (deftest ,(make-struct-test-name name "ERROR.1") - (signals-error (,p-fn) program-error) - t) - (deftest ,(make-struct-test-name name "ERROR.2") - (signals-error (,p-fn (,make-fn) nil) program-error) - t) - )) - - ;; Test that the elements of *universe* are not - ;; of this type - ,@(when p-fn - `((deftest ,(make-struct-test-name name 3) - (count-if (function ,p-fn) *universe*) - 0))) - ,@(unless type-option - `((deftest ,(make-struct-test-name name 4) - (count-if (function (lambda (x) (typep x (quote ,name)))) - *universe*) - 0))) - - ;; Check that the fields can be read after being initialized - (deftest ,(make-struct-test-name name 5) - ,(let ((inits nil) - (tests nil) - (var (defstruct-maketemp name "TEMP-5"))) - (loop - for (slot-name . initval) in initial-value-alist - for field-fn in field-fns - do - (setf inits - (list* (intern (string slot-name) "KEYWORD") - (list 'quote initval) - inits)) - (push `(and - (eqlt (quote ,initval) - (,field-fn ,var)) - (eqlt (quote ,initval) - (funcall #',field-fn ,var))) - tests)) - `(let ((,var (,make-fn . ,inits))) - (and ,@tests t))) - t) - - (deftest ,(make-struct-test-name name "ERROR.3") - (remove nil - (list - ,@(loop - for (slot-name . initval) in initial-value-alist - for field-fn in field-fns - collect - `(multiple-value-bind - (x val) - (signals-error (,field-fn) program-error) - (unless x - (list ',slot-name ',field-fn val)))))) - nil) - - (deftest ,(make-struct-test-name name "ERROR.4") - (remove nil - (list - ,@(loop - for (slot-name . initval) in initial-value-alist - for field-fn in field-fns - collect - `(multiple-value-bind - (x val) - (signals-error (,field-fn (,make-fn) nil) - program-error) - (unless x - (list ',slot-name ',field-fn val)))))) - nil) - - ;; Check that two invocations return different structures - (deftest ,(make-struct-test-name name 6) - (eqt (,make-fn) (,make-fn)) - nil) - - ;; Check that we can setf the fields - (deftest ,(make-struct-test-name name 7) - ,(let* ((var (defstruct-maketemp name "TEMP-7-1")) - (var2 (defstruct-maketemp name "TEMP-7-2")) - (tests - (loop - for (slot-name . initval) in initial-value-alist - for read-only-p in slot-read-only - for slot-desc in slot-descriptions - for field-fn in field-fns - unless read-only-p - collect - `(let ((,var2 (quote ,initval))) - (setf (,field-fn ,var) ,var2) - (eqlt (,field-fn ,var) ,var2))))) - `(let ((,var (,make-fn))) - (and ,@tests t))) - t) - - ;; Check that the copy function exists - ,@(when copy-fn - `((deftest ,(make-struct-test-name name 8) - (and (fboundp (quote ,copy-fn)) - (functionp (function ,copy-fn)) - (symbol-function (quote ,copy-fn)) - t) - t) - (deftest ,(make-struct-test-name name "ERROR.5") - (signals-error (,copy-fn) program-error) - t) - (deftest ,(make-struct-test-name name "ERROR.6") - (signals-error (,copy-fn (,make-fn) nil) program-error) - t) - )) - - ;; Check that the copy function properly copies fields - ,@(when copy-fn - `((deftest ,(make-struct-test-name name 9) - ,(let* ((var 'XTEMP-9) - (var2 'YTEMP-9) - (var3 'ZTEMP-9)) - `(let ((,var (,make-fn - ,@(loop - for (slot-name . initval) - in initial-value-alist - nconc (list (intern (string slot-name) - "KEYWORD") - `(quote ,initval)))))) - (let ((,var2 (,copy-fn ,var)) - (,var3 (funcall #',copy-fn ,var))) - (and - (not (eqlt ,var ,var2)) - (not (eqlt ,var ,var3)) - (not (eqlt ,var2 ,var3)) - ,@(loop - for (slot-name . nil) in initial-value-alist - for fn in field-fns - collect - `(and (eqlt (,fn ,var) (,fn ,var2)) - (eqlt (,fn ,var) (,fn ,var3)))) - t)))) - t))) - - ;; When the predicate is not the default, check - ;; that the default is not defined. Tests should - ;; be designed so that this function name doesn't - ;; collide with anything else. - ,@(unless (eq p-fn p-fn-default) - `((deftest ,(make-struct-test-name name 10) - (fboundp (quote ,p-fn-default)) - nil))) - - ;; When the copy function name is not the default, check - ;; that the default function is not defined. Tests should - ;; be designed so that this name is not accidently defined - ;; for something else. - ,@(unless (eq copy-fn copy-fn-default) - `((deftest ,(make-struct-test-name name 11) - (fboundp (quote ,copy-fn-default)) - nil))) - - ;; When there are read-only slots, test that the SETF - ;; form for them is not FBOUNDP - ,@(when (loop for x in slot-read-only thereis x) - `((deftest ,(make-struct-test-name name 12) - (and - ,@(loop for slot-name in slot-names - for read-only in slot-read-only - for field-fn in field-fns - when read-only - collect `(not-mv (fboundp '(setf ,field-fn)))) - t) - t))) - - ;; When the structure is a true structure type, check that - ;; the various class relationships hold - ,@(unless type-option - `( - (deftest ,(make-struct-test-name name 13) - (notnot-mv (typep (,make-fn) (find-class (quote ,name)))) - t) - (deftest ,(make-struct-test-name name 14) - (let ((class (find-class (quote ,name)))) - (notnot-mv (typep class 'structure-class))) - t) - (deftest ,(make-struct-test-name name 15) - (notnot-mv (typep (,make-fn) 'structure-object)) - t) - (deftest ,(make-struct-test-name name 16) - (loop for type in *disjoint-types-list* - unless (and - (equalt (multiple-value-list - (subtypep* type (quote ,name))) - '(nil t)) - (equalt (multiple-value-list - (subtypep* (quote ,name) type)) - '(nil t))) - collect type) - nil) - (deftest ,(make-struct-test-name name 17) - (let ((class (find-class (quote ,name)))) - (loop for type in *disjoint-types-list* - unless (and - (equalt (multiple-value-list - (subtypep* type class)) - '(nil t)) - (equalt (multiple-value-list - (subtypep* class type)) - '(nil t))) - collect type)) - nil) - (deftest ,(make-struct-test-name name "15A") - (let ((class (find-class (quote ,name)))) - (notnot-mv (subtypep class 'structure-object))) - t t) - (deftest ,(make-struct-test-name name "15B") - (notnot-mv (subtypep (quote ,name) 'structure-object)) - t t) - - )) - - ;;; Documentation tests - - ,(when doc-string - `(deftest ,(make-struct-test-name name 18) - (let ((doc (documentation ',name 'structure))) - (or (null doc) (equalt doc ',doc-string))) - t)) - - ,(when (and doc-string (not type-option)) - `(deftest ,(make-struct-test-name name 19) - (let ((doc (documentation ',name 'type))) - (or (null doc) (equalt doc ',doc-string))) - t)) - - ;; Test that COPY-STRUCTURE works, if this is a structure - ;; type - ,@(unless type-option - `((deftest ,(make-struct-test-name name 20) - ,(let* ((var 'XTEMP-20) - (var2 'YTEMP-20)) - `(let ((,var (,make-fn - ,@(loop - for (slot-name . initval) - in initial-value-alist - nconc (list (intern (string slot-name) - "KEYWORD") - `(quote ,initval)))))) - (let ((,var2 (copy-structure ,var))) - (and - (not (eqlt ,var ,var2)) - ,@(loop - for (slot-name . nil) in initial-value-alist - for fn in field-fns - collect - `(eqlt (,fn ,var) (,fn ,var2))) - t)))) - t))) - nil - ))) - -(defun defstruct-maketemp (stem suffix1 &optional suffix2) - "Make a temporary variable for DEFSTRUCT-WITH-TESTS." - (intern (if suffix2 (format nil "~A-~A-~A" stem suffix1 suffix2) - (format nil "~A-~A" stem suffix1)))) diff --git a/t/ansi-test/structures/structures-01.lsp b/t/ansi-test/structures/structures-01.lsp deleted file mode 100644 index e5c67c7..0000000 --- a/t/ansi-test/structures/structures-01.lsp +++ /dev/null @@ -1,103 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat May 2 21:45:32 1998 -;;;; Contains: Test code for structures, part 01 - -(in-package :cl-test) -(declaim (optimize (safety 3))) - -;;; Tests for structures -;;; -;;; The CL Spec leaves undefined just what will happen when a structure is -;;; redefined. These tests don't redefine structures, but reloading a file -;;; with structure definition will do so. I assume that this leaves the -;;; structure type unchanged. - -;; Test simple defstruct (fields, no options) - -(defstruct s-1 - foo bar) - -;; Test that make-s-1 produces objects -;; of the correct type -(deftest structure-1-1 - (notnot-mv (typep (make-s-1) 's-1)) - t) - -;; Test that the -p predicate exists -(deftest structure-1-2 - (notnot-mv (s-1-p (make-s-1))) - t) - -;; Test that all the objects in the universe are -;; not of this type -(deftest structure-1-3 - (count-if #'s-1-p *universe*) - 0) - -(deftest structure-1-4 - (count-if #'(lambda (x) (typep x 's-1)) *universe*) - 0) - -;; Check that the fields can be read after being initialized -(deftest structure-1-5 - (s-1-foo (make-s-1 :foo 'a)) - a) - -(deftest structure-1-6 - (s-1-bar (make-s-1 :bar 'b)) - b) - -(deftest structure-1-7 - (let ((s (make-s-1 :foo 'c :bar 'd))) - (list (s-1-foo s) (s-1-bar s))) - (c d)) - -;; Can setf the fields -(deftest structure-1-8 - (let ((s (make-s-1))) - (setf (s-1-foo s) 'e) - (setf (s-1-bar s) 'f) - (list (s-1-foo s) (s-1-bar s))) - (e f)) - -(deftest structure-1-9 - (let ((s (make-s-1 :foo 'a :bar 'b))) - (setf (s-1-foo s) 'e) - (setf (s-1-bar s) 'f) - (list (s-1-foo s) (s-1-bar s))) - (e f)) - -;; copier function defined -(deftest structure-1-10 - (let ((s (make-s-1 :foo 'a :bar 'b))) - (let ((s2 (copy-s-1 s))) - (setf (s-1-foo s) nil) - (setf (s-1-bar s) nil) - (list (s-1-foo s2) - (s-1-bar s2)))) - (a b)) - -;; Make produces unique items -(deftest structure-1-11 - (eqt (make-s-1) (make-s-1)) - nil) - -(deftest structure-1-12 - (eqt (make-s-1 :foo 'a :bar 'b) - (make-s-1 :foo 'a :bar 'b)) - nil) - -;; More type and class checks - -(deftest structure-1-13 - (notnot-mv (typep (class-of (make-s-1)) 'structure-class)) - t) - -(deftest structure-1-14 - (notnot-mv (typep (make-s-1) 'structure-object)) - t) - -(deftest structure-1-15 - (subtypep* 's-1 'structure-object) - t t) diff --git a/t/ansi-test/structures/structures-02.lsp b/t/ansi-test/structures/structures-02.lsp deleted file mode 100644 index af29e2b..0000000 --- a/t/ansi-test/structures/structures-02.lsp +++ /dev/null @@ -1,524 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun May 3 22:46:54 1998 -;;;; Contains: Test code for structures, part 02 - -(in-package :cl-test) -(declaim (optimize (safety 3))) - -;; Test initializers for fields - -(defvar *s-2-f6-counter* 0) - -(defstruct s-2 - (f1 0) - (f2 'a) - (f3 1.21) - (f4 #\d) - (f5 (list 'a 'b)) - (f6 (incf *s-2-f6-counter*))) - -;; Standard structure tests - - -;; Fields have appropriate values -(deftest structure-2-1 - (let ((*s-2-f6-counter* 0)) - (let ((s (make-s-2))) - (and - (eqlt (s-2-f1 s) 0) - (eqt (s-2-f2 s) 'a) - (= (s-2-f3 s) 1.21) - (eqlt (s-2-f4 s) #\d) - (equalt (s-2-f5 s) '(a b)) - (eqlt (s-2-f6 s) *s-2-f6-counter*) - (eqlt *s-2-f6-counter* 1)))) - t) - -;; Two successive invocations of make-s-2 return different objects -(deftest structure-2-2 - (let ((*s-2-f6-counter* 0)) - (eqt (s-2-f5 (make-s-2)) - (s-2-f5 (make-s-2)))) - nil) - -;; Creation with various fields does the right thing -(deftest structure-2-3 - (let* ((*s-2-f6-counter* 0) - (s (make-s-2 :f1 17))) - (and - (eqlt (s-2-f1 s) 17) - (eqt (s-2-f2 s) 'a) - (= (s-2-f3 s) 1.21) - (eqlt (s-2-f4 s) #\d) - (equalt (s-2-f5 s) '(a b)) - (eqlt (s-2-f6 s) *s-2-f6-counter*) - (eqlt *s-2-f6-counter* 1))) - t) - -(deftest structure-2-4 - (let* ((*s-2-f6-counter* 0) - (s (make-s-2 :f2 'z))) - (and - (eqlt (s-2-f1 s) 0) - (eqt (s-2-f2 s) 'z) - (= (s-2-f3 s) 1.21) - (eqlt (s-2-f4 s) #\d) - (equalt (s-2-f5 s) '(a b)) - (eqlt (s-2-f6 s) *s-2-f6-counter*) - (eqlt *s-2-f6-counter* 1))) - t) - -(deftest structure-2-5 - (let* ((*s-2-f6-counter* 0) - (s (make-s-2 :f3 1.0))) - (and - (eqlt (s-2-f1 s) 0) - (eqt (s-2-f2 s) 'a) - (= (s-2-f3 s) 1.0) - (eqlt (s-2-f4 s) #\d) - (equalt (s-2-f5 s) '(a b)) - (eqlt (s-2-f6 s) *s-2-f6-counter*) - (eqlt *s-2-f6-counter* 1))) - t) - -(deftest structure-2-6 - (let* ((*s-2-f6-counter* 0) - (s (make-s-2 :f4 #\z))) - (and - (eqlt (s-2-f1 s) 0) - (eqt (s-2-f2 s) 'a) - (= (s-2-f3 s) 1.21) - (eqlt (s-2-f4 s) #\z) - (equalt (s-2-f5 s) '(a b)) - (eqlt (s-2-f6 s) *s-2-f6-counter*) - (eqlt *s-2-f6-counter* 1))) - t) - -(deftest structure-2-7 - (let* ((*s-2-f6-counter* 0) - (s (make-s-2 :f5 '(c d e)))) - (and - (eqlt (s-2-f1 s) 0) - (eqt (s-2-f2 s) 'a) - (= (s-2-f3 s) 1.21) - (eqlt (s-2-f4 s) #\d) - (equalt (s-2-f5 s) '(c d e)) - (eqlt (s-2-f6 s) *s-2-f6-counter*) - (eqlt *s-2-f6-counter* 1))) - t) - -(deftest structure-2-8 - (let* ((*s-2-f6-counter* 0) - (s (make-s-2 :f6 10))) - (and - (eqlt (s-2-f1 s) 0) - (eqt (s-2-f2 s) 'a) - (= (s-2-f3 s) 1.21) - (eqlt (s-2-f4 s) #\d) - (equalt (s-2-f5 s) '(a b)) - (eqlt (s-2-f6 s) 10) - (eqlt *s-2-f6-counter* 0))) - t) - -;;; Tests using the defstruct-with-tests infrastructure - -(defstruct-with-tests struct-test-03 a b c d) - -(defstruct-with-tests (struct-test-04) a b c) - -(defstruct-with-tests (struct-test-05 :constructor) a05 b05 c05) -(defstruct-with-tests (struct-test-06 (:constructor)) a06 b06 c06) - -(defstruct-with-tests (struct-test-07 :conc-name) a07 b07) -(defstruct-with-tests (struct-test-08 (:conc-name)) a08 b08) -(defstruct-with-tests (struct-test-09 (:conc-name nil)) a09 b09) -(defstruct-with-tests (struct-test-10 (:conc-name "")) a10 b10) -(defstruct-with-tests (struct-test-11 (:conc-name "BLAH-")) a11 b11) -(defstruct-with-tests (struct-test-12 (:conc-name BLAH-)) a12 b12) -(defstruct-with-tests (struct-test-13 (:conc-name #\X)) foo-a13 foo-b13) - -(defstruct-with-tests (struct-test-14 (:predicate)) a14 b14) -(defstruct-with-tests (struct-test-15 (:predicate nil)) a15 b15) -(defstruct-with-tests (struct-test-16 :predicate) a16 b16) -(defstruct-with-tests (struct-test-17 - (:predicate struct-test-17-alternate-pred)) - a17 b17) - -(defstruct-with-tests (struct-test-18 :copier) a18 b18) -(defstruct-with-tests (struct-test-19 (:copier)) a19 b19) -(defstruct-with-tests (struct-test-20 (:copier nil)) a20 b20) -(defstruct-with-tests (struct-test-21 (:copier struct-test-21-alt-copier)) - a21 b21) - -(defstruct-with-tests struct-test-22 (a22) (b22)) -(defstruct-with-tests struct-test-23 (a23 1) (b23 2)) -(defstruct-with-tests struct-test-24 - (a24 1 :type fixnum) - (b24 2 :type integer)) - -(defstruct-with-tests struct-test-25) -(defstruct-with-tests struct-test-26 - (a26 nil :read-only nil) - (b26 'a :read-only nil)) - -(defstruct-with-tests struct-test-27 - (a27 1 :read-only t) - (b27 1.4 :read-only a)) - -(defstruct-with-tests struct-test-28 - (a28 1 :type integer :read-only t) - (b28 'xx :read-only a :type symbol)) - -(defstruct-with-tests struct-test-29 - a29 - (b29 'xx :read-only 1) - c29) - -(defstruct-with-tests struct-test-30 #:a30 #:b30) -(defstruct-with-tests #:struct-test-31 a31 b31) - -(defpackage struct-test-package (:use)) - -(defstruct-with-tests struct-test-32 - struct-test-package::a32 struct-test-package::b32) - -;;; If the :conc-name option is given no argument or -;;; a nil argument, the accessor names are the same as -;;; slot names. Note that this is different from prepending -;;; an empty string, since that may get you a name in -;;; a different package. - -(defstruct-with-tests (struct-test-33 (:conc-name)) - struct-test-package::a33 struct-test-package::b33) -(defstruct-with-tests (struct-test-34 :conc-name) - struct-test-package::a34 struct-test-package::b34) -(defstruct-with-tests (struct-test-35 (:conc-name nil)) - struct-test-package::a35 struct-test-package::b35) - -(defstruct-with-tests (struct-test-36 (:conc-name "")) - struct-test-package::st36-a36 struct-test-package::st26-b36) - -;;; List and vector structures - -(defstruct-with-tests (struct-test-37 (:type list)) a37 b37 c37) - -(deftest structure-37-1 - (make-struct-test-37 :a37 1 :b37 2 :c37 4) - (1 2 4)) - -(defstruct-with-tests (struct-test-38 (:type list) :named) a38 b38 c38) - -(deftest structure-38-1 - (make-struct-test-38 :a38 11 :b38 12 :c38 4) - (struct-test-38 11 12 4)) - -(defstruct-with-tests (struct-test-39 (:predicate nil) - (:type list) :named) - a39 b39 c39) - -(deftest structure-39-1 - (make-struct-test-39 :a39 11 :b39 12 :c39 4) - (struct-test-39 11 12 4)) - -(defstruct-with-tests (struct-test-40 (:type vector)) a40 b40) -(defstruct-with-tests (struct-test-41 (:type vector) :named) a41 b41) -(defstruct-with-tests (struct-test-42 (:type (vector t))) a42 b42) -(defstruct-with-tests (struct-test-43 (:type (vector t)) :named) a43 b43) - -(defstruct-with-tests (struct-test-44 (:type list)) - (a44 0 :type integer) - (b44 'a :type symbol)) - -;;; Confirm that the defined structure types are all disjoint -(deftest structs-are-disjoint - (loop for s1 in *defstruct-with-tests-names* - sum (loop for s2 in *defstruct-with-tests-names* - unless (eq s1 s2) - count (not (equalt (multiple-value-list - (subtypep* s1 s2)) - '(nil t))))) - 0) - -(defstruct-with-tests (struct-test-45 (:type list) (:initial-offset 2)) - a45 b45) - -(deftest structure-45-1 - (cddr (make-struct-test-45 :a45 1 :b45 2)) - (1 2)) - -(defstruct-with-tests (struct-test-46 (:type list) - (:include struct-test-45)) - c46 d46) - -(deftest structure-46-1 - (cddr (make-struct-test-46 :a45 1 :b45 2 :c46 3 :d46 4)) - (1 2 3 4)) - -(defstruct-with-tests (struct-test-47 (:type list) - (:initial-offset 3) - (:include struct-test-45)) - c47 d47) - -(deftest structure-47-1 - (let ((s (make-struct-test-47 :a45 1 :b45 2 :c47 3 :d47 4))) - (values (third s) (fourth s) (eighth s) (ninth s))) - 1 2 3 4) - -(defstruct-with-tests (struct-test-48 (:type list) - (:initial-offset 0) - (:include struct-test-45)) - c48 d48) - -(deftest structure-48-1 - (cddr (make-struct-test-48 :a45 1 :b45 2 :c48 3 :d48 4)) - (1 2 3 4)) - -(defstruct-with-tests (struct-test-49 (:type (vector bit))) - (a49 0 :type bit) - (b49 0 :type bit)) - -(defstruct-with-tests (struct-test-50 (:type (vector character))) - (a50 #\g :type character) - (b50 #\k :type character)) - -(defstruct-with-tests (struct-test-51 (:type (vector (integer 0 255)))) - (a51 17 :type (integer 0 255)) - (b51 25 :type (integer 0 255))) - -(defstruct-with-tests (struct-test-52 (:type vector) - (:initial-offset 0)) - a52 b52) - -(defstruct-with-tests (struct-test-53 (:type vector) - (:initial-offset 5)) - "This is struct-test-53" - a53 b53) - -(deftest structure-53-1 - (let ((s (make-struct-test-53 :a53 10 :b53 'a))) - (values (my-aref s 5) (my-aref s 6))) - 10 a) - -(defstruct-with-tests (struct-test-54 (:type vector) - (:initial-offset 2) - (:include struct-test-53)) - "This is struct-test-54" - a54 b54) - -(deftest structure-54-1 - (let ((s (make-struct-test-54 :a53 8 :b53 'g :a54 10 :b54 'a))) - (values (my-aref s 5) (my-aref s 6) (my-aref s 9) (my-aref s 10))) - 8 g 10 a) - -(defstruct-with-tests (struct-test-55 (:type list) - (:initial-offset 2) - :named) - a55 b55 c55) - -(deftest structure-55-1 - (let ((s (make-struct-test-55 :a55 'p :c55 'q))) - (values (third s) (fourth s) (sixth s))) - struct-test-55 p q) - -(defstruct-with-tests (struct-test-56 (:type list) - (:initial-offset 3) - (:include struct-test-55) - :named) - d56 e56) - -(deftest structure-56-1 - (let ((s (make-struct-test-56 :a55 3 :b55 7 :d56 'x :e56 'y))) - (mapcar #'(lambda (i) (nth i s)) '(2 3 4 9 10 11))) - (struct-test-55 3 7 struct-test-56 x y)) - -(defstruct-with-tests (struct-test-57 (:include struct-test-22)) - c57 d57) - -(defstruct-with-tests struct-test-58 - "This is struct-test-58" a-58 b-58) - -(defstruct-with-tests (struct-test-59 (:include struct-test-58)) - "This is struct-test-59" a-59 b-59) - -;;; When a field name of a structure is also a special variable, -;;; the constructor must not bind that name. - -(defvar *st-60* 100) - -(defstruct-with-tests struct-test-60 - (a60 *st-60* :type integer) - (*st-60* 0 :type integer) - (b60 *st-60* :type integer)) - -(deftest structure-60-1 - (let ((*st-60* 10)) - (let ((s (make-struct-test-60 :*st-60* 200))) - (values (struct-test-60-a60 s) - (struct-test-60-*st-60* s) - (struct-test-60-b60 s)))) - 10 200 10) - - -;;; When default initializers of the wrong type are given, they do not -;;; cause an error unless actually invoked - -(defstruct struct-test-61 - (a nil :type integer) - (b 0 :type symbol)) - -(deftest structure-61-1 - (let ((s (make-struct-test-61 :a 10 :b 'c))) - (values (struct-test-61-a s) - (struct-test-61-b s))) - 10 c) - -;;; Initializer forms are evaluated only when needed, and are -;;; evaluated in the lexical environment in which they were defined - -(eval-when (:load-toplevel :execute) - (let ((x nil)) - (flet ((%f () x) - (%g (y) (setf x y))) - (defstruct struct-test-62 - (a (progn (setf x 'a) nil)) - (f #'%f) - (g #'%g))))) - -(deftest structure-62-1 - (let* ((s (make-struct-test-62 :a 1)) - (f (struct-test-62-f s))) - (assert (typep f 'function)) - (values - (struct-test-62-a s) - (funcall (the function f)))) - 1 nil) - -(deftest structure-62-2 - (let* ((s (make-struct-test-62)) - (f (struct-test-62-f s)) - (g (struct-test-62-g s))) - (assert (typep f 'function)) - (assert (typep g 'function)) - (locally - (declare (type function f g)) - (values - (struct-test-62-a s) - (funcall f) - (funcall g nil) - (funcall f)))) - nil a nil nil) - -;;; Keywords are allowed in defstruct -(defstruct-with-tests :struct-test-63 a63 b63 c63) -(defstruct-with-tests struct-test-64 :a63 :b63 :c63) - -(defstruct-with-tests struct-test-65 - array-dimension-limit - array-rank-limit - array-total-size-limit - boole-1 - boole-2 - boole-and - boole-andc1 - boole-andc2 - boole-c1 - boole-c2 - boole-clr - boole-eqv - boole-ior - boole-nand - boole-nor - boole-orc1 - boole-orc2 - boole-set - boole-xor - call-arguments-limit - char-code-limit - double-float-epsilon - double-float-negative-epsilon - internal-time-units-per-second - lambda-list-keywords - lambda-parameters-limit - least-negative-double-float - least-negative-long-float - least-negative-normalized-double-float - least-negative-normalized-long-float - least-negative-normalized-short-float - least-negative-normalized-single-float - least-negative-short-float - least-negative-single-float - least-positive-double-float - least-positive-long-float - least-positive-normalized-double-float - least-positive-normalized-long-float - least-positive-normalized-short-float - least-positive-normalized-single-float - least-positive-short-float - least-positive-single-float - long-float-epsilon - long-float-negative-epsilon - most-negative-double-float - most-negative-fixnum - most-negative-long-float - most-negative-short-float - most-negative-single-float - most-positive-double-float - most-positive-fixnum - most-positive-long-float - most-positive-short-float - most-positive-single-float - multiple-values-limit - pi - short-float-epsilon - short-float-negative-epsilon - single-float-epsilon - single-float-negative-epsilon - t) - -(defstruct-with-tests struct-test-66 nil) - -(defstruct-with-tests struct-test-67 - (a 0 :type (integer 0 (#.(ash 1 32)))) - (b nil)) - -(defstruct-with-tests (struct-test-68 (:include struct-test-67)) - c d) - -;;; Structure isn't named, but type is specified. No predicate is -;;; allowed *or* predicate must be NIL. -(defstruct-with-tests (struct-test-69 (:type (vector single-float)) - (:predicate nil))) - -(defstruct-with-tests (struct-test-70 (:type list) - (:predicate struct-test-70) - :named)) - -;;; Error tests - -(deftest copy-structure.error.1 - (signals-error (copy-structure) program-error) - t) - -(deftest copy-structure.error.2 - (signals-error (copy-structure (make-s-2) nil) program-error) - t) - -(deftest defstruct.error.3 - (signals-error - (eval (read-from-string - "(defstruct (struct-test.error.3 (:type (vector single-float)) - (:predicate struct-test.error.3)))")) - simple-error) - t) - -;;; If named option is supplied, then 0th element is vector type (a -;;; symbol), not the 1st one. -(deftest defstruct.error.4 - (signals-error - (eval (read-from-string - "(defstruct (struct-test.error.4 (:type (vector single-float)) - (:predicate struct-test.error.4) - :named))")) - simple-error) - t) diff --git a/t/ansi-test/structures/structures-03.lsp b/t/ansi-test/structures/structures-03.lsp deleted file mode 100644 index e432997..0000000 --- a/t/ansi-test/structures/structures-03.lsp +++ /dev/null @@ -1,421 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Dec 20 05:58:06 2002 -;;;; Contains: BOA Constructor Tests - -(in-package :cl-test) - -(defun sbt-slots (sname s &rest slots) - (loop for slotname in slots collect - (let ((fun (intern (concatenate 'string (string sname) - "-" (string slotname)) - :cl-test))) - (funcall (symbol-function fun) s)))) - -;;; See the DEFSTRUCT page, and section 3.4.6 (Boa Lambda Lists) - -(defstruct* (sbt-01 (:constructor sbt-01-con (b a c))) - a b c) - -(deftest structure-boa-test-01/1 - (let ((s (sbt-01-con 1 2 3))) - (values (sbt-01-a s) - (sbt-01-b s) - (sbt-01-c s))) - 2 1 3) - -(defstruct* (sbt-02 (:constructor sbt-02-con (a b c)) - (:constructor sbt-02-con-2 (a b)) - (:constructor sbt-02-con-3 ())) - (a 'x) (b 'y) (c 'z)) - -(deftest structure-boa-test-02/1 - (let ((s (sbt-02-con 1 2 3))) - (values (sbt-02-a s) - (sbt-02-b s) - (sbt-02-c s))) - 1 2 3) - -(deftest structure-boa-test-02/2 - (let ((s (sbt-02-con-2 'p 'q))) - (values (sbt-02-a s) - (sbt-02-b s) - (sbt-02-c s))) - p q z) - -(deftest structure-boa-test-02/3 - (let ((s (sbt-02-con-3))) - (values (sbt-02-a s) - (sbt-02-b s) - (sbt-02-c s))) - x y z) - -;;; &optional in BOA LL - -(defstruct* (sbt-03 (:constructor sbt-03-con (a b &optional c))) - c b a) - -(deftest structure-boa-test-03/1 - (let ((s (sbt-03-con 1 2))) - (values (sbt-03-a s) (sbt-03-b s))) - 1 2) - -(deftest structure-boa-test-03/2 - (let ((s (sbt-03-con 1 2 3))) - (values (sbt-03-a s) (sbt-03-b s) (sbt-03-c s))) - 1 2 3) - - -(defstruct* (sbt-04 (:constructor sbt-04-con (a b &optional c))) - (c nil) b (a nil)) - -(deftest structure-boa-test-04/1 - (let ((s (sbt-04-con 1 2))) - (values (sbt-04-a s) (sbt-04-b s) (sbt-04-c s))) - 1 2 nil) - -(deftest structure-boa-test-04/2 - (let ((s (sbt-04-con 1 2 4))) - (values (sbt-04-a s) (sbt-04-b s) (sbt-04-c s))) - 1 2 4) - - -(defstruct* (sbt-05 (:constructor sbt-05-con (&optional a b c))) - (c 1) (b 2) (a 3)) - -(deftest structure-boa-test-05/1 - (let ((s (sbt-05-con))) - (values (sbt-05-a s) (sbt-05-b s) (sbt-05-c s))) - 3 2 1) - -(deftest structure-boa-test-05/2 - (let ((s (sbt-05-con 'x))) - (values (sbt-05-a s) (sbt-05-b s) (sbt-05-c s))) - x 2 1) - -(deftest structure-boa-test-05/3 - (let ((s (sbt-05-con 'x 'y))) - (values (sbt-05-a s) (sbt-05-b s) (sbt-05-c s))) - x y 1) - -(deftest structure-boa-test-05/4 - (let ((s (sbt-05-con 'x 'y 'z))) - (values (sbt-05-a s) (sbt-05-b s) (sbt-05-c s))) - x y z) - - -(defstruct* (sbt-06 (:constructor sbt-06-con (&optional (a 'p) (b 'q) (c 'r)))) - (c 1) (b 2) (a 3)) - -(deftest structure-boa-test-06/1 - (let ((s (sbt-06-con))) - (values (sbt-06-a s) (sbt-06-b s) (sbt-06-c s))) - p q r) - -(deftest structure-boa-test-06/2 - (let ((s (sbt-06-con 'x))) - (values (sbt-06-a s) (sbt-06-b s) (sbt-06-c s))) - x q r) - -(deftest structure-boa-test-06/3 - (let ((s (sbt-06-con 'x 'y))) - (values (sbt-06-a s) (sbt-06-b s) (sbt-06-c s))) - x y r) - -(deftest structure-boa-test-06/4 - (let ((s (sbt-06-con 'x 'y 'z))) - (values (sbt-06-a s) (sbt-06-b s) (sbt-06-c s))) - x y z) - - -;;; Test presence flag in optional parameters - -(defstruct* (sbt-07 (:constructor sbt-07-con - (&optional (a 'p a-p) (b 'q b-p) (c 'r c-p) - &aux (d (list (notnot a-p) - (notnot b-p) - (notnot c-p)))))) - a b c d) - -(deftest structure-boa-test-07/1 - (sbt-slots 'sbt-07 (sbt-07-con) :a :b :c :d) - (p q r (nil nil nil))) - -(deftest structure-boa-test-07/2 - (sbt-slots 'sbt-07 (sbt-07-con 'x) :a :b :c :d) - (x q r (t nil nil))) - -(deftest structure-boa-test-07/3 - (sbt-slots 'sbt-07 (sbt-07-con 'x 'y) :a :b :c :d) - (x y r (t t nil))) - -(deftest structure-boa-test-07/4 - (sbt-slots 'sbt-07 (sbt-07-con 'x 'y 'z) :a :b :c :d) - (x y z (t t t))) - - -;;; Keyword arguments - -(defstruct* (sbt-08 (:constructor sbt-08-con - (&key ((:foo a))))) - a) - -(deftest structure-boa-test-08/1 - (sbt-slots 'sbt-08 (sbt-08-con :foo 10) :a) - (10)) - -(defstruct* (sbt-09 (:constructor sbt-09-con - (&key (a 'p a-p) - ((:x b) 'q) - (c 'r) - d - ((:y e)) - ((:z f) 's z-p) - &aux (g (list (notnot a-p) - (notnot z-p)))))) - a b c d e f g) - -(deftest structure-boa-test-09/1 - (sbt-slots 'sbt-09 (sbt-09-con) :a :b :c :f :g) - (p q r s (nil nil))) - -(deftest structure-boa-test-09/2 - (sbt-slots 'sbt-09 (sbt-09-con :d 1) :a :b :c :d :f :g) - (p q r 1 s (nil nil))) - -(deftest structure-boa-test-09/3 - (sbt-slots 'sbt-09 (sbt-09-con :a 1) :a :b :c :f :g) - (1 q r s (t nil))) - -(deftest structure-boa-test-09/4 - (sbt-slots 'sbt-09 (sbt-09-con :x 1) :a :b :c :f :g) - (p 1 r s (nil nil))) - -(deftest structure-boa-test-09/5 - (sbt-slots 'sbt-09 (sbt-09-con :c 1) :a :b :c :f :g) - (p q 1 s (nil nil))) - -(deftest structure-boa-test-09/6 - (sbt-slots 'sbt-09 (sbt-09-con :y 1) :a :b :c :e :f :g) - (p q r 1 s (nil nil))) - -(deftest structure-boa-test-09/7 - (sbt-slots 'sbt-09 (sbt-09-con :z 1) :a :b :c :f :g) - (p q r 1 (nil t))) - -;;; Aux variable overriding a default value - -(defstruct* (sbt-10 (:constructor sbt-10-con (&aux (a 10) - (b (1+ a))))) - (a 1) (b 2)) - -(deftest structure-boa-test-10/1 - (sbt-slots 'sbt-10 (sbt-10-con) :a :b) - (10 11)) - -;;; Aux variables with no value - -(defstruct* (sbt-11 (:constructor sbt-11-con (&aux a b))) - a (b 0 :type integer)) - -(deftest structure-boa-test-11/1 - (let ((s (sbt-11-con))) - (setf (sbt-11-a s) 'p) - (setf (sbt-11-b s) 10) - (sbt-slots 'sbt-11 s :a :b)) - (p 10)) - -;;; Arguments that correspond to no slots - -(defstruct* (sbt-12 (:constructor sbt-12-con (a &optional (b 1) - &rest c - &aux (d (list a b c))))) - d) - -(deftest structure-boa-12/1 - (sbt-12-d (sbt-12-con 'x)) - (x 1 nil)) - -(deftest structure-boa-12/2 - (sbt-12-d (sbt-12-con 'x 'y)) - (x y nil)) - -(deftest structure-boa-12/3 - (sbt-12-d (sbt-12-con 'x 'y 1 2 3)) - (x y (1 2 3))) - - -(defstruct* (sbt-13 (:constructor sbt-13-con - (&key (a 1) (b 2) c &aux (d (list a b c))))) - d) - -(deftest structure-boa-test-13/1 - (sbt-13-d (sbt-13-con)) - (1 2 nil)) - -(deftest structure-boa-test-13/2 - (sbt-13-d (sbt-13-con :a 10)) - (10 2 nil)) - -(deftest structure-boa-test-13/3 - (sbt-13-d (sbt-13-con :b 10)) - (1 10 nil)) - -(deftest structure-boa-test-13/4 - (sbt-13-d (sbt-13-con :c 10)) - (1 2 10)) - -(deftest structure-boa-test-13/5 - (sbt-13-d (sbt-13-con :c 10 :a 3)) - (3 2 10)) - -(deftest structure-boa-test-13/6 - (sbt-13-d (sbt-13-con :c 10 :b 3)) - (1 3 10)) - -(deftest structure-boa-test-13/7 - (sbt-13-d (sbt-13-con :a 10 :b 3)) - (10 3 nil)) - -(deftest structure-boa-test-13/8 - (sbt-13-d (sbt-13-con :a 10 :c 'a :b 3)) - (10 3 a)) - - -;;; Allow other keywords - -(defstruct* (sbt-14 (:constructor sbt-14-con (&key a b c &allow-other-keys))) - (a 1) (b 2) (c 3)) - -(deftest structure-boa-test-14/1 - (sbt-slots 'sbt-14 (sbt-14-con) :a :b :c) - (1 2 3)) - -(deftest structure-boa-test-14/2 - (sbt-slots 'sbt-14 (sbt-14-con :a 9) :a :b :c) - (9 2 3)) - -(deftest structure-boa-test-14/3 - (sbt-slots 'sbt-14 (sbt-14-con :b 9) :a :b :c) - (1 9 3)) - -(deftest structure-boa-test-14/4 - (sbt-slots 'sbt-14 (sbt-14-con :c 9) :a :b :c) - (1 2 9)) - -(deftest structure-boa-test-14/5 - (sbt-slots 'sbt-14 (sbt-14-con :d 9) :a :b :c) - (1 2 3)) - -;;; Keywords are in the correct package, and slot names are not -;;; keyword parameters if not specified. - -(defstruct* (sbt-15 (:constructor sbt-15-con - (&key ((:x a) nil) - ((y b) nil) - (c nil)))) - a b c) - -(deftest structure-boa-test-15/1 - (sbt-slots 'sbt-15 (sbt-15-con :x 1 'y 2 :c 3) :a :b :c) - (1 2 3)) - -(deftest structure-boa-test-15/2 - (signals-error (sbt-15-con :a 1) program-error) - t) - -(deftest structure-boa-test-15/3 - (signals-error (sbt-15-con :b 1) program-error) - t) - -(deftest structure-boa-test-15/4 - (signals-error (sbt-15-con 'x 1) program-error) - t) - -(deftest structure-boa-test-15/5 - (signals-error (sbt-15-con :y 1) program-error) - t) - -(deftest structure-boa-test-15/6 - (signals-error (sbt-15-con 'c 1) program-error) - t) - -(deftest structure-boa-test-15/7 - (signals-error (sbt-15-con 'a 1) program-error) - t) - -(deftest structure-boa-test-15/8 - (signals-error (sbt-15-con 'b 1) program-error) - t) - - -;;; Default constructor w. BOA constructor, and error cases - -(defstruct* (sbt-16 (:constructor) - (:constructor sbt-16-con (a b c))) - a b c) - -(deftest structure-boa-test-16/1 - (sbt-slots 'sbt-16 (make-sbt-16 :a 1 :b 2 :c 3) :a :b :c) - (1 2 3)) - -(deftest structure-boa-test-16/2 - (sbt-slots 'sbt-16 (sbt-16-con 4 5 6) :a :b :c) - (4 5 6)) - -(deftest structure-boa-test-16/3 - (signals-error (make-sbt-16 :d 1) program-error) - t) - -(deftest structure-boa-test-16/4 - (signals-error (make-sbt-16 :a) program-error) - t) - -(deftest structure-boa-test-16/5 - (signals-error (make-sbt-16 'a) program-error) - t) - -(deftest structure-boa-test-16/6 - (signals-error (make-sbt-16 1 1) program-error) - t) - -(deftest structure-boa-test-16/7 - (sbt-slots 'sbt-16 (make-sbt-16 :a 1 :b 2 :c 3 :d 5 :allow-other-keys t) - :a :b :c) - (1 2 3)) - -(deftest structure-boa-test-16/8 - (sbt-slots 'sbt-16 (make-sbt-16 :allow-other-keys t :a 1 :b 2 :c 3 :d 5) - :a :b :c) - (1 2 3)) - -;;; :allow-other-keys turns off keyword error checking, including -;;; invalid (nonsymbol) keyword arguments -;;;(deftest structure-boa-test-16/9 -;;; (sbt-slots 'sbt-16 (make-sbt-16 :allow-other-keys t -;;; :a 3 :b 6 :c 9 1000 1000) -;;; :a :b :c) -;;; (3 6 9)) - -;;; Repeated keyword arguments are allowed; the leftmost one is used -(deftest structure-boa-test-16/10 - (sbt-slots 'sbt-16 (make-sbt-16 :a 1 :a 2 :b 3 :b 4 :c 5 :c 6) :a :b :c) - (1 3 5)) - -(deftest structure-boa-test-16/11 - (sbt-slots 'sbt-16 (make-sbt-16 :allow-other-keys t - :allow-other-keys nil - :a 1 :b 2 :c 3 :d 5) - :a :b :c) - (1 2 3)) - -;; Checking of # of keywords is suppressed when :allow-other-keys is true -;;;(deftest structure-boa-test-16/12 -;;; (sbt-slots 'sbt-16 (make-sbt-16 :allow-other-keys t :a 3 :b 6 :c 9 :a) -;;; :a :b :c) -;;; (3 6 9)) - - -;;; Error test - -(def-macro-test struct.error.1 (defstruct nonexistent-structure-type a b c)) diff --git a/t/ansi-test/structures/structures-04.lsp b/t/ansi-test/structures/structures-04.lsp deleted file mode 100644 index 6c5fde8..0000000 --- a/t/ansi-test/structures/structures-04.lsp +++ /dev/null @@ -1,114 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon May 19 20:07:40 2003 -;;;; Contains: More tests of structures - -(in-package :cl-test) - -;;; I realized I had forgotten to test slot override in :include -;;; clauses in defstruct. - -(defstruct struct-include-01a - a (b 0)) - -(defstruct (struct-include-01b (:include struct-include-01a - (a 100) (b 'x))) - (c 200) d) - -(deftest struct-include.1 - (let ((obj (make-struct-include-01b))) - (values - (typep* obj 'struct-include-01a) - (typep* obj 'struct-include-01b) - (struct-include-01a-a obj) - (struct-include-01a-b obj) - (struct-include-01b-a obj) - (struct-include-01b-b obj) - (struct-include-01b-c obj))) - t t 100 x 100 x 200) - - -(deftest struct-include.2 - (let ((obj (make-struct-include-01b :a 1 :b 2 :c 3 :d 4))) - (values - (typep* obj 'struct-include-01a) - (typep* obj 'struct-include-01b) - (struct-include-01a-a obj) - (struct-include-01a-b obj) - (struct-include-01b-a obj) - (struct-include-01b-b obj) - (struct-include-01b-c obj) - (struct-include-01b-d obj) - )) - t t 1 2 1 2 3 4) - -(defstruct struct-include-02a - (a 0 :type number)) - -(defstruct (struct-include-02b (:include struct-include-02a - (a 10 :type integer)))) - -(deftest struct-include.3 - (let ((obj (make-struct-include-02b))) - (values - (typep* obj 'struct-include-02a) - (typep* obj 'struct-include-02b) - (struct-include-02a-a obj) - (struct-include-02b-a obj))) - t t 10 10) - -(deftest struct-include.4 - (let ((obj (make-struct-include-02a))) - (values - (typep* obj 'struct-include-02a) - (typep* obj 'struct-include-02b) - (struct-include-02a-a obj))) - t nil 0) - -(deftest struct-include.5 - (let ((obj (make-struct-include-02b :a 100))) - (values - (typep* obj 'struct-include-02a) - (typep* obj 'struct-include-02b) - (struct-include-02a-a obj) - (struct-include-02b-a obj))) - t t 100 100) - -(defstruct struct-include-03a - (a 0 :type number)) - -(defstruct (struct-include-03b (:include struct-include-03a (a)))) - -(deftest struct-include.5a - (let ((obj (make-struct-include-03b :a 100))) - (values - (typep* obj 'struct-include-03a) - (typep* obj 'struct-include-03b) - (struct-include-03a-a obj) - (struct-include-03b-a obj))) - t t 100 100) - -(defstruct struct-include-04a a b) - -(defstruct (struct-include-04b (:include struct-include-04a - (a 0 :read-only t)))) - -(deftest struct-include.6 - (let ((obj (make-struct-include-04b))) - (values - (typep* obj 'struct-include-04a) - (typep* obj 'struct-include-04b) - (struct-include-04a-a obj) - (struct-include-04b-a obj))) - t t 0 0) - -(deftest struct-include.7 - (let ((obj (make-struct-include-04b :a 1 :b 2))) - (values - (typep* obj 'struct-include-04a) - (typep* obj 'struct-include-04b) - (struct-include-04a-a obj) - (struct-include-04b-a obj) - (struct-include-04a-b obj) - (struct-include-04b-b obj))) - t t 1 1 2 2) diff --git a/t/ansi-test/symbols/boundp.lsp b/t/ansi-test/symbols/boundp.lsp deleted file mode 100644 index dd1e2b9..0000000 --- a/t/ansi-test/symbols/boundp.lsp +++ /dev/null @@ -1,67 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Jan 14 05:58:01 2003 -;;;; Contains: Tests for BOUNDP - -(in-package :cl-test) - -(deftest boundp.error.1 - (signals-error (boundp) program-error) - t) - -(deftest boundp.error.2 - (signals-error (boundp 'a 'a) program-error) - t) - -(deftest boundp.error.3 - (check-type-error #'boundp #'symbolp) - nil) - -(deftest boundp.error.4 - (signals-type-error x '(setf car) (boundp x)) - t) - -(deftest boundp.error.5 - (signals-type-error x "abc" (boundp x)) - t) - -(deftest boundp.error.6 - (signals-type-error x "abc" (locally (boundp x) t)) - t) - -;;; See other tests in cl-symbols.lsp - -(deftest boundp.1 - (notnot-mv (boundp 't)) - t) - -(deftest boundp.2 - (notnot-mv (boundp nil)) - t) - -(deftest boundp.3 - (notnot-mv (boundp :foo)) - t) - -(deftest boundp.4 - (boundp '#:foo) - nil) - -;;; See 11.1.2.1.1 -(deftest boundp.5 - (loop for x in *cl-non-variable-constant-symbols* - when (boundp x) - collect x) - nil) - -(deftest boundp.6 - (macrolet ((%m (z) z)) (boundp (expand-in-current-env (%m '#:foo)))) - nil) - -(deftest boundp.order.1 - (let ((i 0) x) - (values - (boundp (progn (setf x (incf i)) '#:foo)) - i x)) - nil 1 1) - diff --git a/t/ansi-test/symbols/cl-symbols.lsp b/t/ansi-test/symbols/cl-symbols.lsp deleted file mode 100644 index e5bc009..0000000 --- a/t/ansi-test/symbols/cl-symbols.lsp +++ /dev/null @@ -1,1195 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Mar 15 13:19:57 1998 -;;;; Contains: Test presence of symbols in the CL package, -;;;; and symbol-related functions - -(in-package :cl-test) - -(declaim (optimize (safety 3))) - -;;; Test for the presence of every darned symbol -;;; the standard says should be in the CL package. -;;; Also, test that they have no prohibited plist indicators (section 11.1.2.1.1) - -(deftest symbol-&allow-other-keys (test-if-not-in-cl-package "&allow-other-keys") nil) -(deftest symbol-&aux (test-if-not-in-cl-package "&aux") nil) -(deftest symbol-&body (test-if-not-in-cl-package "&body") nil) -(deftest symbol-&environment (test-if-not-in-cl-package "&environment") nil) -(deftest symbol-&key (test-if-not-in-cl-package "&key") nil) -(deftest symbol-&optional (test-if-not-in-cl-package "&optional") nil) -(deftest symbol-&rest (test-if-not-in-cl-package "&rest") nil) -(deftest symbol-&whole (test-if-not-in-cl-package "&whole") nil) -(deftest symbol-* (test-if-not-in-cl-package "*") nil) -(deftest symbol-** (test-if-not-in-cl-package "**") nil) -(deftest symbol-*** (test-if-not-in-cl-package "***") nil) -(deftest symbol-*break-on-signals* (test-if-not-in-cl-package "*break-on-signals*") nil) -(deftest symbol-*compile-file-pathname* (test-if-not-in-cl-package "*compile-file-pathname*") nil) -(deftest symbol-*compile-file-truename* (test-if-not-in-cl-package "*compile-file-truename*") nil) -(deftest symbol-*compile-print* (test-if-not-in-cl-package "*compile-print*") nil) -(deftest symbol-*compile-verbose* (test-if-not-in-cl-package "*compile-verbose*") nil) -(deftest symbol-*debug-io* (test-if-not-in-cl-package "*debug-io*") nil) -(deftest symbol-*debugger-hook* (test-if-not-in-cl-package "*debugger-hook*") nil) -(deftest symbol-*default-pathname-defaults* (test-if-not-in-cl-package "*default-pathname-defaults*") nil) -(deftest symbol-*error-output* (test-if-not-in-cl-package "*error-output*") nil) -(deftest symbol-*features* (test-if-not-in-cl-package "*features*") nil) -(deftest symbol-*gensym-counter* (test-if-not-in-cl-package "*gensym-counter*") nil) -(deftest symbol-*load-pathname* (test-if-not-in-cl-package "*load-pathname*") nil) -(deftest symbol-*load-print* (test-if-not-in-cl-package "*load-print*") nil) -(deftest symbol-*load-truename* (test-if-not-in-cl-package "*load-truename*") nil) -(deftest symbol-*load-verbose* (test-if-not-in-cl-package "*load-verbose*") nil) -(deftest symbol-*macroexpand-hook* (test-if-not-in-cl-package "*macroexpand-hook*") nil) -(deftest symbol-*modules* (test-if-not-in-cl-package "*modules*") nil) -(deftest symbol-*package* (test-if-not-in-cl-package "*package*") nil) -(deftest symbol-*print-array* (test-if-not-in-cl-package "*print-array*") nil) -(deftest symbol-*print-base* (test-if-not-in-cl-package "*print-base*") nil) -(deftest symbol-*print-case* (test-if-not-in-cl-package "*print-case*") nil) -(deftest symbol-*print-circle* (test-if-not-in-cl-package "*print-circle*") nil) -(deftest symbol-*print-escape* (test-if-not-in-cl-package "*print-escape*") nil) -(deftest symbol-*print-gensym* (test-if-not-in-cl-package "*print-gensym*") nil) -(deftest symbol-*print-length* (test-if-not-in-cl-package "*print-length*") nil) -(deftest symbol-*print-level* (test-if-not-in-cl-package "*print-level*") nil) -(deftest symbol-*print-lines* (test-if-not-in-cl-package "*print-lines*") nil) -(deftest symbol-*print-miser-width* (test-if-not-in-cl-package "*print-miser-width*") nil) -(deftest symbol-*print-pprint-dispatch* (test-if-not-in-cl-package "*print-pprint-dispatch*") nil) -(deftest symbol-*print-pretty* (test-if-not-in-cl-package "*print-pretty*") nil) -(deftest symbol-*print-radix* (test-if-not-in-cl-package "*print-radix*") nil) -(deftest symbol-*print-readably* (test-if-not-in-cl-package "*print-readably*") nil) -(deftest symbol-*print-right-margin* (test-if-not-in-cl-package "*print-right-margin*") nil) -(deftest symbol-*query-io* (test-if-not-in-cl-package "*query-io*") nil) -(deftest symbol-*random-state* (test-if-not-in-cl-package "*random-state*") nil) -(deftest symbol-*read-base* (test-if-not-in-cl-package "*read-base*") nil) -(deftest symbol-*read-default-float-format* (test-if-not-in-cl-package "*read-default-float-format*") nil) -(deftest symbol-*read-eval* (test-if-not-in-cl-package "*read-eval*") nil) -(deftest symbol-*read-suppress* (test-if-not-in-cl-package "*read-suppress*") nil) -(deftest symbol-*readtable* (test-if-not-in-cl-package "*readtable*") nil) -(deftest symbol-*standard-input* (test-if-not-in-cl-package "*standard-input*") nil) -(deftest symbol-*standard-output* (test-if-not-in-cl-package "*standard-output*") nil) -(deftest symbol-*terminal-io* (test-if-not-in-cl-package "*terminal-io*") nil) -(deftest symbol-*trace-output* (test-if-not-in-cl-package "*trace-output*") nil) -(deftest symbol-+ (test-if-not-in-cl-package "+") nil) -(deftest symbol-++ (test-if-not-in-cl-package "++") nil) -(deftest symbol-+++ (test-if-not-in-cl-package "+++") nil) -(deftest symbol-- (test-if-not-in-cl-package "-") nil) -(deftest symbol-/ (test-if-not-in-cl-package "/") nil) -(deftest symbol-// (test-if-not-in-cl-package "//") nil) -(deftest symbol-/// (test-if-not-in-cl-package "///") nil) -(deftest symbol-/= (test-if-not-in-cl-package "/=") nil) -(deftest symbol-1+ (test-if-not-in-cl-package "1+") nil) -(deftest symbol-1- (test-if-not-in-cl-package "1-") nil) -(deftest symbol-< (test-if-not-in-cl-package "<") nil) -(deftest symbol-<= (test-if-not-in-cl-package "<=") nil) -(deftest symbol-= (test-if-not-in-cl-package "=") nil) -(deftest symbol-> (test-if-not-in-cl-package ">") nil) -(deftest symbol->= (test-if-not-in-cl-package ">=") nil) -(deftest symbol-abort (test-if-not-in-cl-package "abort") nil) -(deftest symbol-abs (test-if-not-in-cl-package "abs") nil) -(deftest symbol-acons (test-if-not-in-cl-package "acons") nil) -(deftest symbol-acos (test-if-not-in-cl-package "acos") nil) -(deftest symbol-acosh (test-if-not-in-cl-package "acosh") nil) -(deftest symbol-add-method (test-if-not-in-cl-package "add-method") nil) -(deftest symbol-adjoin (test-if-not-in-cl-package "adjoin") nil) -(deftest symbol-adjust-array (test-if-not-in-cl-package "adjust-array") nil) -(deftest symbol-adjustable-array-p (test-if-not-in-cl-package "adjustable-array-p") nil) -(deftest symbol-allocate-instance (test-if-not-in-cl-package "allocate-instance") nil) -(deftest symbol-alpha-char-p (test-if-not-in-cl-package "alpha-char-p") nil) -(deftest symbol-alphanumericp (test-if-not-in-cl-package "alphanumericp") nil) -(deftest symbol-and (test-if-not-in-cl-package "and") nil) -(deftest symbol-append (test-if-not-in-cl-package "append") nil) -(deftest symbol-apply (test-if-not-in-cl-package "apply") nil) -(deftest symbol-apropos (test-if-not-in-cl-package "apropos") nil) -(deftest symbol-apropos-list (test-if-not-in-cl-package "apropos-list") nil) -(deftest symbol-aref (test-if-not-in-cl-package "aref") nil) -(deftest symbol-arithmetic-error (test-if-not-in-cl-package "arithmetic-error") nil) -(deftest symbol-arithmetic-error-operands (test-if-not-in-cl-package "arithmetic-error-operands") nil) -(deftest symbol-arithmetic-error-operation (test-if-not-in-cl-package "arithmetic-error-operation") nil) -(deftest symbol-array (test-if-not-in-cl-package "array") nil) -(deftest symbol-array-dimension (test-if-not-in-cl-package "array-dimension") nil) -(deftest symbol-array-dimension-limit (test-if-not-in-cl-package "array-dimension-limit") nil) -(deftest symbol-array-dimensions (test-if-not-in-cl-package "array-dimensions") nil) -(deftest symbol-array-displacement (test-if-not-in-cl-package "array-displacement") nil) -(deftest symbol-array-element-type (test-if-not-in-cl-package "array-element-type") nil) -(deftest symbol-array-has-fill-pointer-p (test-if-not-in-cl-package "array-has-fill-pointer-p") nil) -(deftest symbol-array-in-bounds-p (test-if-not-in-cl-package "array-in-bounds-p") nil) -(deftest symbol-array-rank (test-if-not-in-cl-package "array-rank") nil) -(deftest symbol-array-rank-limit (test-if-not-in-cl-package "array-rank-limit") nil) -(deftest symbol-array-row-major-index (test-if-not-in-cl-package "array-row-major-index") nil) -(deftest symbol-array-total-size (test-if-not-in-cl-package "array-total-size") nil) -(deftest symbol-array-total-size-limit (test-if-not-in-cl-package "array-total-size-limit") nil) -(deftest symbol-arrayp (test-if-not-in-cl-package "arrayp") nil) -(deftest symbol-ash (test-if-not-in-cl-package "ash") nil) -(deftest symbol-asin (test-if-not-in-cl-package "asin") nil) -(deftest symbol-asinh (test-if-not-in-cl-package "asinh") nil) -(deftest symbol-assert (test-if-not-in-cl-package "assert") nil) -(deftest symbol-assoc (test-if-not-in-cl-package "assoc") nil) -(deftest symbol-assoc-if (test-if-not-in-cl-package "assoc-if") nil) -(deftest symbol-assoc-if-not (test-if-not-in-cl-package "assoc-if-not") nil) -(deftest symbol-atan (test-if-not-in-cl-package "atan") nil) -(deftest symbol-atanh (test-if-not-in-cl-package "atanh") nil) -(deftest symbol-atom (test-if-not-in-cl-package "atom") nil) -(deftest symbol-base-char (test-if-not-in-cl-package "base-char") nil) -(deftest symbol-base-string (test-if-not-in-cl-package "base-string") nil) -(deftest symbol-bignum (test-if-not-in-cl-package "bignum") nil) -(deftest symbol-bit (test-if-not-in-cl-package "bit") nil) -(deftest symbol-bit-and (test-if-not-in-cl-package "bit-and") nil) -(deftest symbol-bit-andc1 (test-if-not-in-cl-package "bit-andc1") nil) -(deftest symbol-bit-andc2 (test-if-not-in-cl-package "bit-andc2") nil) -(deftest symbol-bit-eqv (test-if-not-in-cl-package "bit-eqv") nil) -(deftest symbol-bit-ior (test-if-not-in-cl-package "bit-ior") nil) -(deftest symbol-bit-nand (test-if-not-in-cl-package "bit-nand") nil) -(deftest symbol-bit-nor (test-if-not-in-cl-package "bit-nor") nil) -(deftest symbol-bit-not (test-if-not-in-cl-package "bit-not") nil) -(deftest symbol-bit-orc1 (test-if-not-in-cl-package "bit-orc1") nil) -(deftest symbol-bit-orc2 (test-if-not-in-cl-package "bit-orc2") nil) -(deftest symbol-bit-vector (test-if-not-in-cl-package "bit-vector") nil) -(deftest symbol-bit-vector-p (test-if-not-in-cl-package "bit-vector-p") nil) -(deftest symbol-bit-xor (test-if-not-in-cl-package "bit-xor") nil) -(deftest symbol-block (test-if-not-in-cl-package "block") nil) -(deftest symbol-boole (test-if-not-in-cl-package "boole") nil) -(deftest symbol-boole-1 (test-if-not-in-cl-package "boole-1") nil) -(deftest symbol-boole-2 (test-if-not-in-cl-package "boole-2") nil) -(deftest symbol-boole-and (test-if-not-in-cl-package "boole-and") nil) -(deftest symbol-boole-andc1 (test-if-not-in-cl-package "boole-andc1") nil) -(deftest symbol-boole-andc2 (test-if-not-in-cl-package "boole-andc2") nil) -(deftest symbol-boole-c1 (test-if-not-in-cl-package "boole-c1") nil) -(deftest symbol-boole-c2 (test-if-not-in-cl-package "boole-c2") nil) -(deftest symbol-boole-clr (test-if-not-in-cl-package "boole-clr") nil) -(deftest symbol-boole-eqv (test-if-not-in-cl-package "boole-eqv") nil) -(deftest symbol-boole-ior (test-if-not-in-cl-package "boole-ior") nil) -(deftest symbol-boole-nand (test-if-not-in-cl-package "boole-nand") nil) -(deftest symbol-boole-nor (test-if-not-in-cl-package "boole-nor") nil) -(deftest symbol-boole-orc1 (test-if-not-in-cl-package "boole-orc1") nil) -(deftest symbol-boole-orc2 (test-if-not-in-cl-package "boole-orc2") nil) -(deftest symbol-boole-set (test-if-not-in-cl-package "boole-set") nil) -(deftest symbol-boole-xor (test-if-not-in-cl-package "boole-xor") nil) -(deftest symbol-boolean (test-if-not-in-cl-package "boolean") nil) -(deftest symbol-both-case-p (test-if-not-in-cl-package "both-case-p") nil) -(deftest symbol-boundp (test-if-not-in-cl-package "boundp") nil) -(deftest symbol-break (test-if-not-in-cl-package "break") nil) -(deftest symbol-broadcast-stream (test-if-not-in-cl-package "broadcast-stream") nil) -(deftest symbol-broadcast-stream-streams (test-if-not-in-cl-package "broadcast-stream-streams") nil) -(deftest symbol-built-in-class (test-if-not-in-cl-package "built-in-class") nil) -(deftest symbol-butlast (test-if-not-in-cl-package "butlast") nil) -(deftest symbol-byte (test-if-not-in-cl-package "byte") nil) -(deftest symbol-byte-position (test-if-not-in-cl-package "byte-position") nil) -(deftest symbol-byte-size (test-if-not-in-cl-package "byte-size") nil) -(deftest symbol-caaaar (test-if-not-in-cl-package "caaaar") nil) -(deftest symbol-caaadr (test-if-not-in-cl-package "caaadr") nil) -(deftest symbol-caaar (test-if-not-in-cl-package "caaar") nil) -(deftest symbol-caadar (test-if-not-in-cl-package "caadar") nil) -(deftest symbol-caaddr (test-if-not-in-cl-package "caaddr") nil) -(deftest symbol-caadr (test-if-not-in-cl-package "caadr") nil) -(deftest symbol-caar (test-if-not-in-cl-package "caar") nil) -(deftest symbol-cadaar (test-if-not-in-cl-package "cadaar") nil) -(deftest symbol-cadadr (test-if-not-in-cl-package "cadadr") nil) -(deftest symbol-cadar (test-if-not-in-cl-package "cadar") nil) -(deftest symbol-caddar (test-if-not-in-cl-package "caddar") nil) -(deftest symbol-cadddr (test-if-not-in-cl-package "cadddr") nil) -(deftest symbol-caddr (test-if-not-in-cl-package "caddr") nil) -(deftest symbol-cadr (test-if-not-in-cl-package "cadr") nil) -(deftest symbol-call-arguments-limit (test-if-not-in-cl-package "call-arguments-limit") nil) -(deftest symbol-call-method (test-if-not-in-cl-package "call-method") nil) -(deftest symbol-call-next-method (test-if-not-in-cl-package "call-next-method") nil) -(deftest symbol-car (test-if-not-in-cl-package "car") nil) -(deftest symbol-case (test-if-not-in-cl-package "case") nil) -(deftest symbol-catch (test-if-not-in-cl-package "catch") nil) -(deftest symbol-ccase (test-if-not-in-cl-package "ccase") nil) -(deftest symbol-cdaaar (test-if-not-in-cl-package "cdaaar") nil) -(deftest symbol-cdaadr (test-if-not-in-cl-package "cdaadr") nil) -(deftest symbol-cdaar (test-if-not-in-cl-package "cdaar") nil) -(deftest symbol-cdadar (test-if-not-in-cl-package "cdadar") nil) -(deftest symbol-cdaddr (test-if-not-in-cl-package "cdaddr") nil) -(deftest symbol-cdadr (test-if-not-in-cl-package "cdadr") nil) -(deftest symbol-cdar (test-if-not-in-cl-package "cdar") nil) -(deftest symbol-cddaar (test-if-not-in-cl-package "cddaar") nil) -(deftest symbol-cddadr (test-if-not-in-cl-package "cddadr") nil) -(deftest symbol-cddar (test-if-not-in-cl-package "cddar") nil) -(deftest symbol-cdddar (test-if-not-in-cl-package "cdddar") nil) -(deftest symbol-cddddr (test-if-not-in-cl-package "cddddr") nil) -(deftest symbol-cdddr (test-if-not-in-cl-package "cdddr") nil) -(deftest symbol-cddr (test-if-not-in-cl-package "cddr") nil) -(deftest symbol-cdr (test-if-not-in-cl-package "cdr") nil) -(deftest symbol-ceiling (test-if-not-in-cl-package "ceiling") nil) -(deftest symbol-cell-error (test-if-not-in-cl-package "cell-error") nil) -(deftest symbol-cell-error-name (test-if-not-in-cl-package "cell-error-name") nil) -(deftest symbol-cerror (test-if-not-in-cl-package "cerror") nil) -(deftest symbol-change-class (test-if-not-in-cl-package "change-class") nil) -(deftest symbol-char (test-if-not-in-cl-package "char") nil) -(deftest symbol-char-code (test-if-not-in-cl-package "char-code") nil) -(deftest symbol-char-code-limit (test-if-not-in-cl-package "char-code-limit") nil) -(deftest symbol-char-downcase (test-if-not-in-cl-package "char-downcase") nil) -(deftest symbol-char-equal (test-if-not-in-cl-package "char-equal") nil) -(deftest symbol-char-greaterp (test-if-not-in-cl-package "char-greaterp") nil) -(deftest symbol-char-int (test-if-not-in-cl-package "char-int") nil) -(deftest symbol-char-lessp (test-if-not-in-cl-package "char-lessp") nil) -(deftest symbol-char-name (test-if-not-in-cl-package "char-name") nil) -(deftest symbol-char-not-equal (test-if-not-in-cl-package "char-not-equal") nil) -(deftest symbol-char-not-greaterp (test-if-not-in-cl-package "char-not-greaterp") nil) -(deftest symbol-char-not-lessp (test-if-not-in-cl-package "char-not-lessp") nil) -(deftest symbol-char-upcase (test-if-not-in-cl-package "char-upcase") nil) -(deftest symbol-char/= (test-if-not-in-cl-package "char/=") nil) -(deftest symbol-char< (test-if-not-in-cl-package "char<") nil) -(deftest symbol-char<= (test-if-not-in-cl-package "char<=") nil) -(deftest symbol-char= (test-if-not-in-cl-package "char=") nil) -(deftest symbol-char> (test-if-not-in-cl-package "char>") nil) -(deftest symbol-char>= (test-if-not-in-cl-package "char>=") nil) -(deftest symbol-character (test-if-not-in-cl-package "character") nil) -(deftest symbol-characterp (test-if-not-in-cl-package "characterp") nil) -(deftest symbol-check-type (test-if-not-in-cl-package "check-type") nil) -(deftest symbol-cis (test-if-not-in-cl-package "cis") nil) -(deftest symbol-class (test-if-not-in-cl-package "class") nil) -(deftest symbol-class-name (test-if-not-in-cl-package "class-name") nil) -(deftest symbol-class-of (test-if-not-in-cl-package "class-of") nil) -(deftest symbol-clear-input (test-if-not-in-cl-package "clear-input") nil) -(deftest symbol-clear-output (test-if-not-in-cl-package "clear-output") nil) -(deftest symbol-close (test-if-not-in-cl-package "close") nil) -(deftest symbol-clrhash (test-if-not-in-cl-package "clrhash") nil) -(deftest symbol-code-char (test-if-not-in-cl-package "code-char") nil) -(deftest symbol-coerce (test-if-not-in-cl-package "coerce") nil) -(deftest symbol-compilation-speed (test-if-not-in-cl-package "compilation-speed") nil) -(deftest symbol-compile (test-if-not-in-cl-package "compile") nil) -(deftest symbol-compile-file (test-if-not-in-cl-package "compile-file") nil) -(deftest symbol-compile-file-pathname (test-if-not-in-cl-package "compile-file-pathname") nil) -(deftest symbol-compiled-function (test-if-not-in-cl-package "compiled-function") nil) -(deftest symbol-compiled-function-p (test-if-not-in-cl-package "compiled-function-p") nil) -(deftest symbol-compiler-macro (test-if-not-in-cl-package "compiler-macro") nil) -(deftest symbol-compiler-macro-function (test-if-not-in-cl-package "compiler-macro-function") nil) -(deftest symbol-complement (test-if-not-in-cl-package "complement") nil) -(deftest symbol-complex (test-if-not-in-cl-package "complex") nil) -(deftest symbol-complexp (test-if-not-in-cl-package "complexp") nil) -(deftest symbol-compute-applicable-methods (test-if-not-in-cl-package "compute-applicable-methods") nil) -(deftest symbol-compute-restarts (test-if-not-in-cl-package "compute-restarts") nil) -(deftest symbol-concatenate (test-if-not-in-cl-package "concatenate") nil) -(deftest symbol-concatenated-stream (test-if-not-in-cl-package "concatenated-stream") nil) -(deftest symbol-concatenated-stream-streams (test-if-not-in-cl-package "concatenated-stream-streams") nil) -(deftest symbol-cond (test-if-not-in-cl-package "cond") nil) -(deftest symbol-condition (test-if-not-in-cl-package "condition") nil) -(deftest symbol-conjugate (test-if-not-in-cl-package "conjugate") nil) -(deftest symbol-cons (test-if-not-in-cl-package "cons") nil) -(deftest symbol-consp (test-if-not-in-cl-package "consp") nil) -(deftest symbol-constantly (test-if-not-in-cl-package "constantly") nil) -(deftest symbol-constantp (test-if-not-in-cl-package "constantp") nil) -(deftest symbol-continue (test-if-not-in-cl-package "continue") nil) -(deftest symbol-control-error (test-if-not-in-cl-package "control-error") nil) -(deftest symbol-copy-alist (test-if-not-in-cl-package "copy-alist") nil) -(deftest symbol-copy-list (test-if-not-in-cl-package "copy-list") nil) -(deftest symbol-copy-pprint-dispatch (test-if-not-in-cl-package "copy-pprint-dispatch") nil) -(deftest symbol-copy-readtable (test-if-not-in-cl-package "copy-readtable") nil) -(deftest symbol-copy-seq (test-if-not-in-cl-package "copy-seq") nil) -(deftest symbol-copy-structure (test-if-not-in-cl-package "copy-structure") nil) -(deftest symbol-copy-symbol (test-if-not-in-cl-package "copy-symbol") nil) -(deftest symbol-copy-tree (test-if-not-in-cl-package "copy-tree") nil) -(deftest symbol-cos (test-if-not-in-cl-package "cos") nil) -(deftest symbol-cosh (test-if-not-in-cl-package "cosh") nil) -(deftest symbol-count (test-if-not-in-cl-package "count") nil) -(deftest symbol-count-if (test-if-not-in-cl-package "count-if") nil) -(deftest symbol-count-if-not (test-if-not-in-cl-package "count-if-not") nil) -(deftest symbol-ctypecase (test-if-not-in-cl-package "ctypecase") nil) -(deftest symbol-debug (test-if-not-in-cl-package "debug") nil) -(deftest symbol-decf (test-if-not-in-cl-package "decf") nil) -(deftest symbol-declaim (test-if-not-in-cl-package "declaim") nil) -(deftest symbol-declaration (test-if-not-in-cl-package "declaration") nil) -(deftest symbol-declare (test-if-not-in-cl-package "declare") nil) -(deftest symbol-decode-float (test-if-not-in-cl-package "decode-float") nil) -(deftest symbol-decode-universal-time (test-if-not-in-cl-package "decode-universal-time") nil) -(deftest symbol-defclass (test-if-not-in-cl-package "defclass") nil) -(deftest symbol-defconstant (test-if-not-in-cl-package "defconstant") nil) -(deftest symbol-defgeneric (test-if-not-in-cl-package "defgeneric") nil) -(deftest symbol-define-compiler-macro (test-if-not-in-cl-package "define-compiler-macro") nil) -(deftest symbol-define-condition (test-if-not-in-cl-package "define-condition") nil) -(deftest symbol-define-method-combination (test-if-not-in-cl-package "define-method-combination") nil) -(deftest symbol-define-modify-macro (test-if-not-in-cl-package "define-modify-macro") nil) -(deftest symbol-define-setf-expander (test-if-not-in-cl-package "define-setf-expander") nil) -(deftest symbol-define-symbol-macro (test-if-not-in-cl-package "define-symbol-macro") nil) -(deftest symbol-defmacro (test-if-not-in-cl-package "defmacro") nil) -(deftest symbol-defmethod (test-if-not-in-cl-package "defmethod") nil) -(deftest symbol-defpackage (test-if-not-in-cl-package "defpackage") nil) -(deftest symbol-defparameter (test-if-not-in-cl-package "defparameter") nil) -(deftest symbol-defsetf (test-if-not-in-cl-package "defsetf") nil) -(deftest symbol-defstruct (test-if-not-in-cl-package "defstruct") nil) -(deftest symbol-deftype (test-if-not-in-cl-package "deftype") nil) -(deftest symbol-defun (test-if-not-in-cl-package "defun") nil) -(deftest symbol-defvar (test-if-not-in-cl-package "defvar") nil) -(deftest symbol-delete (test-if-not-in-cl-package "delete") nil) -(deftest symbol-delete-duplicates (test-if-not-in-cl-package "delete-duplicates") nil) -(deftest symbol-delete-file (test-if-not-in-cl-package "delete-file") nil) -(deftest symbol-delete-if (test-if-not-in-cl-package "delete-if") nil) -(deftest symbol-delete-if-not (test-if-not-in-cl-package "delete-if-not") nil) -(deftest symbol-delete-package (test-if-not-in-cl-package "delete-package") nil) -(deftest symbol-denominator (test-if-not-in-cl-package "denominator") nil) -(deftest symbol-deposit-field (test-if-not-in-cl-package "deposit-field") nil) -(deftest symbol-describe (test-if-not-in-cl-package "describe") nil) -(deftest symbol-describe-object (test-if-not-in-cl-package "describe-object") nil) -(deftest symbol-destructuring-bind (test-if-not-in-cl-package "destructuring-bind") nil) -(deftest symbol-digit-char (test-if-not-in-cl-package "digit-char") nil) -(deftest symbol-digit-char-p (test-if-not-in-cl-package "digit-char-p") nil) -(deftest symbol-directory (test-if-not-in-cl-package "directory") nil) -(deftest symbol-directory-namestring (test-if-not-in-cl-package "directory-namestring") nil) -(deftest symbol-disassemble (test-if-not-in-cl-package "disassemble") nil) -(deftest symbol-division-by-zero (test-if-not-in-cl-package "division-by-zero") nil) -(deftest symbol-do (test-if-not-in-cl-package "do") nil) -(deftest symbol-do* (test-if-not-in-cl-package "do*") nil) -(deftest symbol-do-all-symbols (test-if-not-in-cl-package "do-all-symbols") nil) -(deftest symbol-do-external-symbols (test-if-not-in-cl-package "do-external-symbols") nil) -(deftest symbol-do-symbols (test-if-not-in-cl-package "do-symbols") nil) -(deftest symbol-documentation (test-if-not-in-cl-package "documentation") nil) -(deftest symbol-dolist (test-if-not-in-cl-package "dolist") nil) -(deftest symbol-dotimes (test-if-not-in-cl-package "dotimes") nil) -(deftest symbol-double-float (test-if-not-in-cl-package "double-float") nil) -(deftest symbol-double-float-epsilon (test-if-not-in-cl-package "double-float-epsilon") nil) -(deftest symbol-double-float-negative-epsilon (test-if-not-in-cl-package "double-float-negative-epsilon") nil) -(deftest symbol-dpb (test-if-not-in-cl-package "dpb") nil) -(deftest symbol-dribble (test-if-not-in-cl-package "dribble") nil) -(deftest symbol-dynamic-extent (test-if-not-in-cl-package "dynamic-extent") nil) -(deftest symbol-ecase (test-if-not-in-cl-package "ecase") nil) -(deftest symbol-echo-stream (test-if-not-in-cl-package "echo-stream") nil) -(deftest symbol-echo-stream-input-stream (test-if-not-in-cl-package "echo-stream-input-stream") nil) -(deftest symbol-echo-stream-output-stream (test-if-not-in-cl-package "echo-stream-output-stream") nil) -(deftest symbol-ed (test-if-not-in-cl-package "ed") nil) -(deftest symbol-eighth (test-if-not-in-cl-package "eighth") nil) -(deftest symbol-elt (test-if-not-in-cl-package "elt") nil) -(deftest symbol-encode-universal-time (test-if-not-in-cl-package "encode-universal-time") nil) -(deftest symbol-end-of-file (test-if-not-in-cl-package "end-of-file") nil) -(deftest symbol-endp (test-if-not-in-cl-package "endp") nil) -(deftest symbol-enough-namestring (test-if-not-in-cl-package "enough-namestring") nil) -(deftest symbol-ensure-directories-exist (test-if-not-in-cl-package "ensure-directories-exist") nil) -(deftest symbol-ensure-generic-function (test-if-not-in-cl-package "ensure-generic-function") nil) -(deftest symbol-eq (test-if-not-in-cl-package "eq") nil) -(deftest symbol-eql (test-if-not-in-cl-package "eql") nil) -(deftest symbol-equal (test-if-not-in-cl-package "equal") nil) -(deftest symbol-equalp (test-if-not-in-cl-package "equalp") nil) -(deftest symbol-error (test-if-not-in-cl-package "error") nil) -(deftest symbol-etypecase (test-if-not-in-cl-package "etypecase") nil) -(deftest symbol-eval (test-if-not-in-cl-package "eval") nil) -(deftest symbol-eval-when (test-if-not-in-cl-package "eval-when") nil) -(deftest symbol-evenp (test-if-not-in-cl-package "evenp") nil) -(deftest symbol-every (test-if-not-in-cl-package "every") nil) -(deftest symbol-exp (test-if-not-in-cl-package "exp") nil) -(deftest symbol-export (test-if-not-in-cl-package "export") nil) -(deftest symbol-expt (test-if-not-in-cl-package "expt") nil) -(deftest symbol-extended-char (test-if-not-in-cl-package "extended-char") nil) -(deftest symbol-fboundp (test-if-not-in-cl-package "fboundp") nil) -(deftest symbol-fceiling (test-if-not-in-cl-package "fceiling") nil) -(deftest symbol-fdefinition (test-if-not-in-cl-package "fdefinition") nil) -(deftest symbol-ffloor (test-if-not-in-cl-package "ffloor") nil) -(deftest symbol-fifth (test-if-not-in-cl-package "fifth") nil) -(deftest symbol-file-author (test-if-not-in-cl-package "file-author") nil) -(deftest symbol-file-error (test-if-not-in-cl-package "file-error") nil) -(deftest symbol-file-error-pathname (test-if-not-in-cl-package "file-error-pathname") nil) -(deftest symbol-file-length (test-if-not-in-cl-package "file-length") nil) -(deftest symbol-file-namestring (test-if-not-in-cl-package "file-namestring") nil) -(deftest symbol-file-position (test-if-not-in-cl-package "file-position") nil) -(deftest symbol-file-stream (test-if-not-in-cl-package "file-stream") nil) -(deftest symbol-file-string-length (test-if-not-in-cl-package "file-string-length") nil) -(deftest symbol-file-write-date (test-if-not-in-cl-package "file-write-date") nil) -(deftest symbol-fill (test-if-not-in-cl-package "fill") nil) -(deftest symbol-fill-pointer (test-if-not-in-cl-package "fill-pointer") nil) -(deftest symbol-find (test-if-not-in-cl-package "find") nil) -(deftest symbol-find-all-symbols (test-if-not-in-cl-package "find-all-symbols") nil) -(deftest symbol-find-class (test-if-not-in-cl-package "find-class") nil) -(deftest symbol-find-if (test-if-not-in-cl-package "find-if") nil) -(deftest symbol-find-if-not (test-if-not-in-cl-package "find-if-not") nil) -(deftest symbol-find-method (test-if-not-in-cl-package "find-method") nil) -(deftest symbol-find-package (test-if-not-in-cl-package "find-package") nil) -(deftest symbol-find-restart (test-if-not-in-cl-package "find-restart") nil) -(deftest symbol-find-symbol (test-if-not-in-cl-package "find-symbol") nil) -(deftest symbol-finish-output (test-if-not-in-cl-package "finish-output") nil) -(deftest symbol-first (test-if-not-in-cl-package "first") nil) -(deftest symbol-fixnum (test-if-not-in-cl-package "fixnum") nil) -(deftest symbol-flet (test-if-not-in-cl-package "flet") nil) -(deftest symbol-float (test-if-not-in-cl-package "float") nil) -(deftest symbol-float-digits (test-if-not-in-cl-package "float-digits") nil) -(deftest symbol-float-precision (test-if-not-in-cl-package "float-precision") nil) -(deftest symbol-float-radix (test-if-not-in-cl-package "float-radix") nil) -(deftest symbol-float-sign (test-if-not-in-cl-package "float-sign") nil) -(deftest symbol-floating-point-inexact (test-if-not-in-cl-package "floating-point-inexact") nil) -(deftest symbol-floating-point-invalid-operation (test-if-not-in-cl-package "floating-point-invalid-operation") nil) -(deftest symbol-floating-point-overflow (test-if-not-in-cl-package "floating-point-overflow") nil) -(deftest symbol-floating-point-underflow (test-if-not-in-cl-package "floating-point-underflow") nil) -(deftest symbol-floatp (test-if-not-in-cl-package "floatp") nil) -(deftest symbol-floor (test-if-not-in-cl-package "floor") nil) -(deftest symbol-fmakunbound (test-if-not-in-cl-package "fmakunbound") nil) -(deftest symbol-force-output (test-if-not-in-cl-package "force-output") nil) -(deftest symbol-format (test-if-not-in-cl-package "format") nil) -(deftest symbol-formatter (test-if-not-in-cl-package "formatter") nil) -(deftest symbol-fourth (test-if-not-in-cl-package "fourth") nil) -(deftest symbol-fresh-line (test-if-not-in-cl-package "fresh-line") nil) -(deftest symbol-fround (test-if-not-in-cl-package "fround") nil) -(deftest symbol-ftruncate (test-if-not-in-cl-package "ftruncate") nil) -(deftest symbol-ftype (test-if-not-in-cl-package "ftype") nil) -(deftest symbol-funcall (test-if-not-in-cl-package "funcall") nil) -(deftest symbol-function (test-if-not-in-cl-package "function") nil) -(deftest symbol-function-keywords (test-if-not-in-cl-package "function-keywords") nil) -(deftest symbol-function-lambda-expression (test-if-not-in-cl-package "function-lambda-expression") nil) -(deftest symbol-functionp (test-if-not-in-cl-package "functionp") nil) -(deftest symbol-gcd (test-if-not-in-cl-package "gcd") nil) -(deftest symbol-generic-function (test-if-not-in-cl-package "generic-function") nil) -(deftest symbol-gensym (test-if-not-in-cl-package "gensym") nil) -(deftest symbol-gentemp (test-if-not-in-cl-package "gentemp") nil) -(deftest symbol-get (test-if-not-in-cl-package "get") nil) -(deftest symbol-get-decoded-time (test-if-not-in-cl-package "get-decoded-time") nil) -(deftest symbol-get-dispatch-macro-character (test-if-not-in-cl-package "get-dispatch-macro-character") nil) -(deftest symbol-get-internal-real-time (test-if-not-in-cl-package "get-internal-real-time") nil) -(deftest symbol-get-internal-run-time (test-if-not-in-cl-package "get-internal-run-time") nil) -(deftest symbol-get-macro-character (test-if-not-in-cl-package "get-macro-character") nil) -(deftest symbol-get-output-stream-string (test-if-not-in-cl-package "get-output-stream-string") nil) -(deftest symbol-get-properties (test-if-not-in-cl-package "get-properties") nil) -(deftest symbol-get-setf-expansion (test-if-not-in-cl-package "get-setf-expansion") nil) -(deftest symbol-get-universal-time (test-if-not-in-cl-package "get-universal-time") nil) -(deftest symbol-getf (test-if-not-in-cl-package "getf") nil) -(deftest symbol-gethash (test-if-not-in-cl-package "gethash") nil) -(deftest symbol-go (test-if-not-in-cl-package "go") nil) -(deftest symbol-graphic-char-p (test-if-not-in-cl-package "graphic-char-p") nil) -(deftest symbol-handler-bind (test-if-not-in-cl-package "handler-bind") nil) -(deftest symbol-handler-case (test-if-not-in-cl-package "handler-case") nil) -(deftest symbol-hash-table (test-if-not-in-cl-package "hash-table") nil) -(deftest symbol-hash-table-count (test-if-not-in-cl-package "hash-table-count") nil) -(deftest symbol-hash-table-p (test-if-not-in-cl-package "hash-table-p") nil) -(deftest symbol-hash-table-rehash-size (test-if-not-in-cl-package "hash-table-rehash-size") nil) -(deftest symbol-hash-table-rehash-threshold (test-if-not-in-cl-package "hash-table-rehash-threshold") nil) -(deftest symbol-hash-table-size (test-if-not-in-cl-package "hash-table-size") nil) -(deftest symbol-hash-table-test (test-if-not-in-cl-package "hash-table-test") nil) -(deftest symbol-host-namestring (test-if-not-in-cl-package "host-namestring") nil) -(deftest symbol-identity (test-if-not-in-cl-package "identity") nil) -(deftest symbol-if (test-if-not-in-cl-package "if") nil) -(deftest symbol-ignorable (test-if-not-in-cl-package "ignorable") nil) -(deftest symbol-ignore (test-if-not-in-cl-package "ignore") nil) -(deftest symbol-ignore-errors (test-if-not-in-cl-package "ignore-errors") nil) -(deftest symbol-imagpart (test-if-not-in-cl-package "imagpart") nil) -(deftest symbol-import (test-if-not-in-cl-package "import") nil) -(deftest symbol-in-package (test-if-not-in-cl-package "in-package") nil) -(deftest symbol-incf (test-if-not-in-cl-package "incf") nil) -(deftest symbol-initialize-instance (test-if-not-in-cl-package "initialize-instance") nil) -(deftest symbol-inline (test-if-not-in-cl-package "inline") nil) -(deftest symbol-input-stream-p (test-if-not-in-cl-package "input-stream-p") nil) -(deftest symbol-inspect (test-if-not-in-cl-package "inspect") nil) -(deftest symbol-integer (test-if-not-in-cl-package "integer") nil) -(deftest symbol-integer-decode-float (test-if-not-in-cl-package "integer-decode-float") nil) -(deftest symbol-integer-length (test-if-not-in-cl-package "integer-length") nil) -(deftest symbol-integerp (test-if-not-in-cl-package "integerp") nil) -(deftest symbol-interactive-stream-p (test-if-not-in-cl-package "interactive-stream-p") nil) -(deftest symbol-intern (test-if-not-in-cl-package "intern") nil) -(deftest symbol-internal-time-units-per-second (test-if-not-in-cl-package "internal-time-units-per-second") nil) -(deftest symbol-intersection (test-if-not-in-cl-package "intersection") nil) -(deftest symbol-invalid-method-error (test-if-not-in-cl-package "invalid-method-error") nil) -(deftest symbol-invoke-debugger (test-if-not-in-cl-package "invoke-debugger") nil) -(deftest symbol-invoke-restart (test-if-not-in-cl-package "invoke-restart") nil) -(deftest symbol-invoke-restart-interactively (test-if-not-in-cl-package "invoke-restart-interactively") nil) -(deftest symbol-isqrt (test-if-not-in-cl-package "isqrt") nil) -(deftest symbol-keyword (test-if-not-in-cl-package "keyword") nil) -(deftest symbol-keywordp (test-if-not-in-cl-package "keywordp") nil) -(deftest symbol-labels (test-if-not-in-cl-package "labels") nil) -(deftest symbol-lambda (test-if-not-in-cl-package "lambda") nil) -(deftest symbol-lambda-list-keywords (test-if-not-in-cl-package "lambda-list-keywords") nil) -(deftest symbol-lambda-parameters-limit (test-if-not-in-cl-package "lambda-parameters-limit") nil) -(deftest symbol-last (test-if-not-in-cl-package "last") nil) -(deftest symbol-lcm (test-if-not-in-cl-package "lcm") nil) -(deftest symbol-ldb (test-if-not-in-cl-package "ldb") nil) -(deftest symbol-ldb-test (test-if-not-in-cl-package "ldb-test") nil) -(deftest symbol-ldiff (test-if-not-in-cl-package "ldiff") nil) -(deftest symbol-least-negative-double-float (test-if-not-in-cl-package "least-negative-double-float") nil) -(deftest symbol-least-negative-long-float (test-if-not-in-cl-package "least-negative-long-float") nil) -(deftest symbol-least-negative-normalized-double-float (test-if-not-in-cl-package "least-negative-normalized-double-float") nil) -(deftest symbol-least-negative-normalized-long-float (test-if-not-in-cl-package "least-negative-normalized-long-float") nil) -(deftest symbol-least-negative-normalized-short-float (test-if-not-in-cl-package "least-negative-normalized-short-float") nil) -(deftest symbol-least-negative-normalized-single-float (test-if-not-in-cl-package "least-negative-normalized-single-float") nil) -(deftest symbol-least-negative-short-float (test-if-not-in-cl-package "least-negative-short-float") nil) -(deftest symbol-least-negative-single-float (test-if-not-in-cl-package "least-negative-single-float") nil) -(deftest symbol-least-positive-double-float (test-if-not-in-cl-package "least-positive-double-float") nil) -(deftest symbol-least-positive-long-float (test-if-not-in-cl-package "least-positive-long-float") nil) -(deftest symbol-least-positive-normalized-double-float (test-if-not-in-cl-package "least-positive-normalized-double-float") nil) -(deftest symbol-least-positive-normalized-long-float (test-if-not-in-cl-package "least-positive-normalized-long-float") nil) -(deftest symbol-least-positive-normalized-short-float (test-if-not-in-cl-package "least-positive-normalized-short-float") nil) -(deftest symbol-least-positive-normalized-single-float (test-if-not-in-cl-package "least-positive-normalized-single-float") nil) -(deftest symbol-least-positive-short-float (test-if-not-in-cl-package "least-positive-short-float") nil) -(deftest symbol-least-positive-single-float (test-if-not-in-cl-package "least-positive-single-float") nil) -(deftest symbol-length (test-if-not-in-cl-package "length") nil) -(deftest symbol-let (test-if-not-in-cl-package "let") nil) -(deftest symbol-let* (test-if-not-in-cl-package "let*") nil) -(deftest symbol-lisp-implementation-type (test-if-not-in-cl-package "lisp-implementation-type") nil) -(deftest symbol-lisp-implementation-version (test-if-not-in-cl-package "lisp-implementation-version") nil) -(deftest symbol-list (test-if-not-in-cl-package "list") nil) -(deftest symbol-list* (test-if-not-in-cl-package "list*") nil) -(deftest symbol-list-all-packages (test-if-not-in-cl-package "list-all-packages") nil) -(deftest symbol-list-length (test-if-not-in-cl-package "list-length") nil) -(deftest symbol-listen (test-if-not-in-cl-package "listen") nil) -(deftest symbol-listp (test-if-not-in-cl-package "listp") nil) -(deftest symbol-load (test-if-not-in-cl-package "load") nil) -(deftest symbol-load-logical-pathname-translations (test-if-not-in-cl-package "load-logical-pathname-translations") nil) -(deftest symbol-load-time-value (test-if-not-in-cl-package "load-time-value") nil) -(deftest symbol-locally (test-if-not-in-cl-package "locally") nil) -(deftest symbol-log (test-if-not-in-cl-package "log") nil) -(deftest symbol-logand (test-if-not-in-cl-package "logand") nil) -(deftest symbol-logandc1 (test-if-not-in-cl-package "logandc1") nil) -(deftest symbol-logandc2 (test-if-not-in-cl-package "logandc2") nil) -(deftest symbol-logbitp (test-if-not-in-cl-package "logbitp") nil) -(deftest symbol-logcount (test-if-not-in-cl-package "logcount") nil) -(deftest symbol-logeqv (test-if-not-in-cl-package "logeqv") nil) -(deftest symbol-logical-pathname (test-if-not-in-cl-package "logical-pathname") nil) -(deftest symbol-logical-pathname-translations (test-if-not-in-cl-package "logical-pathname-translations") nil) -(deftest symbol-logior (test-if-not-in-cl-package "logior") nil) -(deftest symbol-lognand (test-if-not-in-cl-package "lognand") nil) -(deftest symbol-lognor (test-if-not-in-cl-package "lognor") nil) -(deftest symbol-lognot (test-if-not-in-cl-package "lognot") nil) -(deftest symbol-logorc1 (test-if-not-in-cl-package "logorc1") nil) -(deftest symbol-logorc2 (test-if-not-in-cl-package "logorc2") nil) -(deftest symbol-logtest (test-if-not-in-cl-package "logtest") nil) -(deftest symbol-logxor (test-if-not-in-cl-package "logxor") nil) -(deftest symbol-long-float (test-if-not-in-cl-package "long-float") nil) -(deftest symbol-long-float-epsilon (test-if-not-in-cl-package "long-float-epsilon") nil) -(deftest symbol-long-float-negative-epsilon (test-if-not-in-cl-package "long-float-negative-epsilon") nil) -(deftest symbol-long-site-name (test-if-not-in-cl-package "long-site-name") nil) -(deftest symbol-loop (test-if-not-in-cl-package "loop") nil) -(deftest symbol-loop-finish (test-if-not-in-cl-package "loop-finish") nil) -(deftest symbol-lower-case-p (test-if-not-in-cl-package "lower-case-p") nil) -(deftest symbol-machine-instance (test-if-not-in-cl-package "machine-instance") nil) -(deftest symbol-machine-type (test-if-not-in-cl-package "machine-type") nil) -(deftest symbol-machine-version (test-if-not-in-cl-package "machine-version") nil) -(deftest symbol-macro-function (test-if-not-in-cl-package "macro-function") nil) -(deftest symbol-macroexpand (test-if-not-in-cl-package "macroexpand") nil) -(deftest symbol-macroexpand-1 (test-if-not-in-cl-package "macroexpand-1") nil) -(deftest symbol-macrolet (test-if-not-in-cl-package "macrolet") nil) -(deftest symbol-make-array (test-if-not-in-cl-package "make-array") nil) -(deftest symbol-make-broadcast-stream (test-if-not-in-cl-package "make-broadcast-stream") nil) -(deftest symbol-make-concatenated-stream (test-if-not-in-cl-package "make-concatenated-stream") nil) -(deftest symbol-make-condition (test-if-not-in-cl-package "make-condition") nil) -(deftest symbol-make-dispatch-macro-character (test-if-not-in-cl-package "make-dispatch-macro-character") nil) -(deftest symbol-make-echo-stream (test-if-not-in-cl-package "make-echo-stream") nil) -(deftest symbol-make-hash-table (test-if-not-in-cl-package "make-hash-table") nil) -(deftest symbol-make-instance (test-if-not-in-cl-package "make-instance") nil) -(deftest symbol-make-instances-obsolete (test-if-not-in-cl-package "make-instances-obsolete") nil) -(deftest symbol-make-list (test-if-not-in-cl-package "make-list") nil) -(deftest symbol-make-load-form (test-if-not-in-cl-package "make-load-form") nil) -(deftest symbol-make-load-form-saving-slots (test-if-not-in-cl-package "make-load-form-saving-slots") nil) -(deftest symbol-make-method (test-if-not-in-cl-package "make-method") nil) -(deftest symbol-make-package (test-if-not-in-cl-package "make-package") nil) -(deftest symbol-make-pathname (test-if-not-in-cl-package "make-pathname") nil) -(deftest symbol-make-random-state (test-if-not-in-cl-package "make-random-state") nil) -(deftest symbol-make-sequence (test-if-not-in-cl-package "make-sequence") nil) -(deftest symbol-make-string (test-if-not-in-cl-package "make-string") nil) -(deftest symbol-make-string-input-stream (test-if-not-in-cl-package "make-string-input-stream") nil) -(deftest symbol-make-string-output-stream (test-if-not-in-cl-package "make-string-output-stream") nil) -(deftest symbol-make-symbol (test-if-not-in-cl-package "make-symbol") nil) -(deftest symbol-make-synonym-stream (test-if-not-in-cl-package "make-synonym-stream") nil) -(deftest symbol-make-two-way-stream (test-if-not-in-cl-package "make-two-way-stream") nil) -(deftest symbol-makunbound (test-if-not-in-cl-package "makunbound") nil) -(deftest symbol-map (test-if-not-in-cl-package "map") nil) -(deftest symbol-map-into (test-if-not-in-cl-package "map-into") nil) -(deftest symbol-mapc (test-if-not-in-cl-package "mapc") nil) -(deftest symbol-mapcan (test-if-not-in-cl-package "mapcan") nil) -(deftest symbol-mapcar (test-if-not-in-cl-package "mapcar") nil) -(deftest symbol-mapcon (test-if-not-in-cl-package "mapcon") nil) -(deftest symbol-maphash (test-if-not-in-cl-package "maphash") nil) -(deftest symbol-mapl (test-if-not-in-cl-package "mapl") nil) -(deftest symbol-maplist (test-if-not-in-cl-package "maplist") nil) -(deftest symbol-mask-field (test-if-not-in-cl-package "mask-field") nil) -(deftest symbol-max (test-if-not-in-cl-package "max") nil) -(deftest symbol-member (test-if-not-in-cl-package "member") nil) -(deftest symbol-member-if (test-if-not-in-cl-package "member-if") nil) -(deftest symbol-member-if-not (test-if-not-in-cl-package "member-if-not") nil) -(deftest symbol-merge (test-if-not-in-cl-package "merge") nil) -(deftest symbol-merge-pathnames (test-if-not-in-cl-package "merge-pathnames") nil) -(deftest symbol-method (test-if-not-in-cl-package "method") nil) -(deftest symbol-method-combination (test-if-not-in-cl-package "method-combination") nil) -(deftest symbol-method-combination-error (test-if-not-in-cl-package "method-combination-error") nil) -(deftest symbol-method-qualifiers (test-if-not-in-cl-package "method-qualifiers") nil) -(deftest symbol-min (test-if-not-in-cl-package "min") nil) -(deftest symbol-minusp (test-if-not-in-cl-package "minusp") nil) -(deftest symbol-mismatch (test-if-not-in-cl-package "mismatch") nil) -(deftest symbol-mod (test-if-not-in-cl-package "mod") nil) -(deftest symbol-most-negative-double-float (test-if-not-in-cl-package "most-negative-double-float") nil) -(deftest symbol-most-negative-fixnum (test-if-not-in-cl-package "most-negative-fixnum") nil) -(deftest symbol-most-negative-long-float (test-if-not-in-cl-package "most-negative-long-float") nil) -(deftest symbol-most-negative-short-float (test-if-not-in-cl-package "most-negative-short-float") nil) -(deftest symbol-most-negative-single-float (test-if-not-in-cl-package "most-negative-single-float") nil) -(deftest symbol-most-positive-double-float (test-if-not-in-cl-package "most-positive-double-float") nil) -(deftest symbol-most-positive-fixnum (test-if-not-in-cl-package "most-positive-fixnum") nil) -(deftest symbol-most-positive-long-float (test-if-not-in-cl-package "most-positive-long-float") nil) -(deftest symbol-most-positive-short-float (test-if-not-in-cl-package "most-positive-short-float") nil) -(deftest symbol-most-positive-single-float (test-if-not-in-cl-package "most-positive-single-float") nil) -(deftest symbol-muffle-warning (test-if-not-in-cl-package "muffle-warning") nil) -(deftest symbol-multiple-value-bind (test-if-not-in-cl-package "multiple-value-bind") nil) -(deftest symbol-multiple-value-call (test-if-not-in-cl-package "multiple-value-call") nil) -(deftest symbol-multiple-value-list (test-if-not-in-cl-package "multiple-value-list") nil) -(deftest symbol-multiple-value-prog1 (test-if-not-in-cl-package "multiple-value-prog1") nil) -(deftest symbol-multiple-value-setq (test-if-not-in-cl-package "multiple-value-setq") nil) -(deftest symbol-multiple-values-limit (test-if-not-in-cl-package "multiple-values-limit") nil) -(deftest symbol-name-char (test-if-not-in-cl-package "name-char") nil) -(deftest symbol-namestring (test-if-not-in-cl-package "namestring") nil) -(deftest symbol-nbutlast (test-if-not-in-cl-package "nbutlast") nil) -(deftest symbol-nconc (test-if-not-in-cl-package "nconc") nil) -(deftest symbol-next-method-p (test-if-not-in-cl-package "next-method-p") nil) -(deftest symbol-nil (test-if-not-in-cl-package "nil") nil) -(deftest symbol-nintersection (test-if-not-in-cl-package "nintersection") nil) -(deftest symbol-ninth (test-if-not-in-cl-package "ninth") nil) -(deftest symbol-no-applicable-method (test-if-not-in-cl-package "no-applicable-method") nil) -(deftest symbol-no-next-method (test-if-not-in-cl-package "no-next-method") nil) -(deftest symbol-not (test-if-not-in-cl-package "not") nil) -(deftest symbol-notany (test-if-not-in-cl-package "notany") nil) -(deftest symbol-notevery (test-if-not-in-cl-package "notevery") nil) -(deftest symbol-notinline (test-if-not-in-cl-package "notinline") nil) -(deftest symbol-nreconc (test-if-not-in-cl-package "nreconc") nil) -(deftest symbol-nreverse (test-if-not-in-cl-package "nreverse") nil) -(deftest symbol-nset-difference (test-if-not-in-cl-package "nset-difference") nil) -(deftest symbol-nset-exclusive-or (test-if-not-in-cl-package "nset-exclusive-or") nil) -(deftest symbol-nstring-capitalize (test-if-not-in-cl-package "nstring-capitalize") nil) -(deftest symbol-nstring-downcase (test-if-not-in-cl-package "nstring-downcase") nil) -(deftest symbol-nstring-upcase (test-if-not-in-cl-package "nstring-upcase") nil) -(deftest symbol-nsublis (test-if-not-in-cl-package "nsublis") nil) -(deftest symbol-nsubst (test-if-not-in-cl-package "nsubst") nil) -(deftest symbol-nsubst-if (test-if-not-in-cl-package "nsubst-if") nil) -(deftest symbol-nsubst-if-not (test-if-not-in-cl-package "nsubst-if-not") nil) -(deftest symbol-nsubstitute (test-if-not-in-cl-package "nsubstitute") nil) -(deftest symbol-nsubstitute-if (test-if-not-in-cl-package "nsubstitute-if") nil) -(deftest symbol-nsubstitute-if-not (test-if-not-in-cl-package "nsubstitute-if-not") nil) -(deftest symbol-nth (test-if-not-in-cl-package "nth") nil) -(deftest symbol-nth-value (test-if-not-in-cl-package "nth-value") nil) -(deftest symbol-nthcdr (test-if-not-in-cl-package "nthcdr") nil) -(deftest symbol-null (test-if-not-in-cl-package "null") nil) -(deftest symbol-number (test-if-not-in-cl-package "number") nil) -(deftest symbol-numberp (test-if-not-in-cl-package "numberp") nil) -(deftest symbol-numerator (test-if-not-in-cl-package "numerator") nil) -(deftest symbol-nunion (test-if-not-in-cl-package "nunion") nil) -(deftest symbol-oddp (test-if-not-in-cl-package "oddp") nil) -(deftest symbol-open (test-if-not-in-cl-package "open") nil) -(deftest symbol-open-stream-p (test-if-not-in-cl-package "open-stream-p") nil) -(deftest symbol-optimize (test-if-not-in-cl-package "optimize") nil) -(deftest symbol-or (test-if-not-in-cl-package "or") nil) -(deftest symbol-otherwise (test-if-not-in-cl-package "otherwise") nil) -(deftest symbol-output-stream-p (test-if-not-in-cl-package "output-stream-p") nil) -(deftest symbol-package (test-if-not-in-cl-package "package") nil) -(deftest symbol-package-error (test-if-not-in-cl-package "package-error") nil) -(deftest symbol-package-error-package (test-if-not-in-cl-package "package-error-package") nil) -(deftest symbol-package-name (test-if-not-in-cl-package "package-name") nil) -(deftest symbol-package-nicknames (test-if-not-in-cl-package "package-nicknames") nil) -(deftest symbol-package-shadowing-symbols (test-if-not-in-cl-package "package-shadowing-symbols") nil) -(deftest symbol-package-use-list (test-if-not-in-cl-package "package-use-list") nil) -(deftest symbol-package-used-by-list (test-if-not-in-cl-package "package-used-by-list") nil) -(deftest symbol-packagep (test-if-not-in-cl-package "packagep") nil) -(deftest symbol-pairlis (test-if-not-in-cl-package "pairlis") nil) -(deftest symbol-parse-error (test-if-not-in-cl-package "parse-error") nil) -(deftest symbol-parse-integer (test-if-not-in-cl-package "parse-integer") nil) -(deftest symbol-parse-namestring (test-if-not-in-cl-package "parse-namestring") nil) -(deftest symbol-pathname (test-if-not-in-cl-package "pathname") nil) -(deftest symbol-pathname-device (test-if-not-in-cl-package "pathname-device") nil) -(deftest symbol-pathname-directory (test-if-not-in-cl-package "pathname-directory") nil) -(deftest symbol-pathname-host (test-if-not-in-cl-package "pathname-host") nil) -(deftest symbol-pathname-match-p (test-if-not-in-cl-package "pathname-match-p") nil) -(deftest symbol-pathname-name (test-if-not-in-cl-package "pathname-name") nil) -(deftest symbol-pathname-type (test-if-not-in-cl-package "pathname-type") nil) -(deftest symbol-pathname-version (test-if-not-in-cl-package "pathname-version") nil) -(deftest symbol-pathnamep (test-if-not-in-cl-package "pathnamep") nil) -(deftest symbol-peek-char (test-if-not-in-cl-package "peek-char") nil) -(deftest symbol-phase (test-if-not-in-cl-package "phase") nil) -(deftest symbol-pi (test-if-not-in-cl-package "pi") nil) -(deftest symbol-plusp (test-if-not-in-cl-package "plusp") nil) -(deftest symbol-pop (test-if-not-in-cl-package "pop") nil) -(deftest symbol-position (test-if-not-in-cl-package "position") nil) -(deftest symbol-position-if (test-if-not-in-cl-package "position-if") nil) -(deftest symbol-position-if-not (test-if-not-in-cl-package "position-if-not") nil) -(deftest symbol-pprint (test-if-not-in-cl-package "pprint") nil) -(deftest symbol-pprint-dispatch (test-if-not-in-cl-package "pprint-dispatch") nil) -(deftest symbol-pprint-exit-if-list-exhausted (test-if-not-in-cl-package "pprint-exit-if-list-exhausted") nil) -(deftest symbol-pprint-fill (test-if-not-in-cl-package "pprint-fill") nil) -(deftest symbol-pprint-indent (test-if-not-in-cl-package "pprint-indent") nil) -(deftest symbol-pprint-linear (test-if-not-in-cl-package "pprint-linear") nil) -(deftest symbol-pprint-logical-block (test-if-not-in-cl-package "pprint-logical-block") nil) -(deftest symbol-pprint-newline (test-if-not-in-cl-package "pprint-newline") nil) -(deftest symbol-pprint-pop (test-if-not-in-cl-package "pprint-pop") nil) -(deftest symbol-pprint-tab (test-if-not-in-cl-package "pprint-tab") nil) -(deftest symbol-pprint-tabular (test-if-not-in-cl-package "pprint-tabular") nil) -(deftest symbol-prin1 (test-if-not-in-cl-package "prin1") nil) -(deftest symbol-prin1-to-string (test-if-not-in-cl-package "prin1-to-string") nil) -(deftest symbol-princ (test-if-not-in-cl-package "princ") nil) -(deftest symbol-princ-to-string (test-if-not-in-cl-package "princ-to-string") nil) -(deftest symbol-print (test-if-not-in-cl-package "print") nil) -(deftest symbol-print-not-readable (test-if-not-in-cl-package "print-not-readable") nil) -(deftest symbol-print-not-readable-object (test-if-not-in-cl-package "print-not-readable-object") nil) -(deftest symbol-print-object (test-if-not-in-cl-package "print-object") nil) -(deftest symbol-print-unreadable-object (test-if-not-in-cl-package "print-unreadable-object") nil) -(deftest symbol-probe-file (test-if-not-in-cl-package "probe-file") nil) -(deftest symbol-proclaim (test-if-not-in-cl-package "proclaim") nil) -(deftest symbol-prog (test-if-not-in-cl-package "prog") nil) -(deftest symbol-prog* (test-if-not-in-cl-package "prog*") nil) -(deftest symbol-prog1 (test-if-not-in-cl-package "prog1") nil) -(deftest symbol-prog2 (test-if-not-in-cl-package "prog2") nil) -(deftest symbol-progn (test-if-not-in-cl-package "progn") nil) -(deftest symbol-program-error (test-if-not-in-cl-package "program-error") nil) -(deftest symbol-progv (test-if-not-in-cl-package "progv") nil) -(deftest symbol-provide (test-if-not-in-cl-package "provide") nil) -(deftest symbol-psetf (test-if-not-in-cl-package "psetf") nil) -(deftest symbol-psetq (test-if-not-in-cl-package "psetq") nil) -(deftest symbol-push (test-if-not-in-cl-package "push") nil) -(deftest symbol-pushnew (test-if-not-in-cl-package "pushnew") nil) -(deftest symbol-quote (test-if-not-in-cl-package "quote") nil) -(deftest symbol-random (test-if-not-in-cl-package "random") nil) -(deftest symbol-random-state (test-if-not-in-cl-package "random-state") nil) -(deftest symbol-random-state-p (test-if-not-in-cl-package "random-state-p") nil) -(deftest symbol-rassoc (test-if-not-in-cl-package "rassoc") nil) -(deftest symbol-rassoc-if (test-if-not-in-cl-package "rassoc-if") nil) -(deftest symbol-rassoc-if-not (test-if-not-in-cl-package "rassoc-if-not") nil) -(deftest symbol-ratio (test-if-not-in-cl-package "ratio") nil) -(deftest symbol-rational (test-if-not-in-cl-package "rational") nil) -(deftest symbol-rationalize (test-if-not-in-cl-package "rationalize") nil) -(deftest symbol-rationalp (test-if-not-in-cl-package "rationalp") nil) -(deftest symbol-read (test-if-not-in-cl-package "read") nil) -(deftest symbol-read-byte (test-if-not-in-cl-package "read-byte") nil) -(deftest symbol-read-char (test-if-not-in-cl-package "read-char") nil) -(deftest symbol-read-char-no-hang (test-if-not-in-cl-package "read-char-no-hang") nil) -(deftest symbol-read-delimited-list (test-if-not-in-cl-package "read-delimited-list") nil) -(deftest symbol-read-from-string (test-if-not-in-cl-package "read-from-string") nil) -(deftest symbol-read-line (test-if-not-in-cl-package "read-line") nil) -(deftest symbol-read-preserving-whitespace (test-if-not-in-cl-package "read-preserving-whitespace") nil) -(deftest symbol-read-sequence (test-if-not-in-cl-package "read-sequence") nil) -(deftest symbol-reader-error (test-if-not-in-cl-package "reader-error") nil) -(deftest symbol-readtable (test-if-not-in-cl-package "readtable") nil) -(deftest symbol-readtable-case (test-if-not-in-cl-package "readtable-case") nil) -(deftest symbol-readtablep (test-if-not-in-cl-package "readtablep") nil) -(deftest symbol-real (test-if-not-in-cl-package "real") nil) -(deftest symbol-realp (test-if-not-in-cl-package "realp") nil) -(deftest symbol-realpart (test-if-not-in-cl-package "realpart") nil) -(deftest symbol-reduce (test-if-not-in-cl-package "reduce") nil) -(deftest symbol-reinitialize-instance (test-if-not-in-cl-package "reinitialize-instance") nil) -(deftest symbol-rem (test-if-not-in-cl-package "rem") nil) -(deftest symbol-remf (test-if-not-in-cl-package "remf") nil) -(deftest symbol-remhash (test-if-not-in-cl-package "remhash") nil) -(deftest symbol-remove (test-if-not-in-cl-package "remove") nil) -(deftest symbol-remove-duplicates (test-if-not-in-cl-package "remove-duplicates") nil) -(deftest symbol-remove-if (test-if-not-in-cl-package "remove-if") nil) -(deftest symbol-remove-if-not (test-if-not-in-cl-package "remove-if-not") nil) -(deftest symbol-remove-method (test-if-not-in-cl-package "remove-method") nil) -(deftest symbol-remprop (test-if-not-in-cl-package "remprop") nil) -(deftest symbol-rename-file (test-if-not-in-cl-package "rename-file") nil) -(deftest symbol-rename-package (test-if-not-in-cl-package "rename-package") nil) -(deftest symbol-replace (test-if-not-in-cl-package "replace") nil) -(deftest symbol-require (test-if-not-in-cl-package "require") nil) -(deftest symbol-rest (test-if-not-in-cl-package "rest") nil) -(deftest symbol-restart (test-if-not-in-cl-package "restart") nil) -(deftest symbol-restart-bind (test-if-not-in-cl-package "restart-bind") nil) -(deftest symbol-restart-case (test-if-not-in-cl-package "restart-case") nil) -(deftest symbol-restart-name (test-if-not-in-cl-package "restart-name") nil) -(deftest symbol-return (test-if-not-in-cl-package "return") nil) -(deftest symbol-return-from (test-if-not-in-cl-package "return-from") nil) -(deftest symbol-revappend (test-if-not-in-cl-package "revappend") nil) -(deftest symbol-reverse (test-if-not-in-cl-package "reverse") nil) -(deftest symbol-room (test-if-not-in-cl-package "room") nil) -(deftest symbol-rotatef (test-if-not-in-cl-package "rotatef") nil) -(deftest symbol-round (test-if-not-in-cl-package "round") nil) -(deftest symbol-row-major-aref (test-if-not-in-cl-package "row-major-aref") nil) -(deftest symbol-rplaca (test-if-not-in-cl-package "rplaca") nil) -(deftest symbol-rplacd (test-if-not-in-cl-package "rplacd") nil) -(deftest symbol-safety (test-if-not-in-cl-package "safety") nil) -(deftest symbol-satisfies (test-if-not-in-cl-package "satisfies") nil) -(deftest symbol-sbit (test-if-not-in-cl-package "sbit") nil) -(deftest symbol-scale-float (test-if-not-in-cl-package "scale-float") nil) -(deftest symbol-schar (test-if-not-in-cl-package "schar") nil) -(deftest symbol-search (test-if-not-in-cl-package "search") nil) -(deftest symbol-second (test-if-not-in-cl-package "second") nil) -(deftest symbol-sequence (test-if-not-in-cl-package "sequence") nil) -(deftest symbol-serious-condition (test-if-not-in-cl-package "serious-condition") nil) -(deftest symbol-set (test-if-not-in-cl-package "set") nil) -(deftest symbol-set-difference (test-if-not-in-cl-package "set-difference") nil) -(deftest symbol-set-dispatch-macro-character (test-if-not-in-cl-package "set-dispatch-macro-character") nil) -(deftest symbol-set-exclusive-or (test-if-not-in-cl-package "set-exclusive-or") nil) -(deftest symbol-set-macro-character (test-if-not-in-cl-package "set-macro-character") nil) -(deftest symbol-set-pprint-dispatch (test-if-not-in-cl-package "set-pprint-dispatch") nil) -(deftest symbol-set-syntax-from-char (test-if-not-in-cl-package "set-syntax-from-char") nil) -(deftest symbol-setf (test-if-not-in-cl-package "setf") nil) -(deftest symbol-setq (test-if-not-in-cl-package "setq") nil) -(deftest symbol-seventh (test-if-not-in-cl-package "seventh") nil) -(deftest symbol-shadow (test-if-not-in-cl-package "shadow") nil) -(deftest symbol-shadowing-import (test-if-not-in-cl-package "shadowing-import") nil) -(deftest symbol-shared-initialize (test-if-not-in-cl-package "shared-initialize") nil) -(deftest symbol-shiftf (test-if-not-in-cl-package "shiftf") nil) -(deftest symbol-short-float (test-if-not-in-cl-package "short-float") nil) -(deftest symbol-short-float-epsilon (test-if-not-in-cl-package "short-float-epsilon") nil) -(deftest symbol-short-float-negative-epsilon (test-if-not-in-cl-package "short-float-negative-epsilon") nil) -(deftest symbol-short-site-name (test-if-not-in-cl-package "short-site-name") nil) -(deftest symbol-signal (test-if-not-in-cl-package "signal") nil) -(deftest symbol-signed-byte (test-if-not-in-cl-package "signed-byte") nil) -(deftest symbol-signum (test-if-not-in-cl-package "signum") nil) -(deftest symbol-simple-array (test-if-not-in-cl-package "simple-array") nil) -(deftest symbol-simple-base-string (test-if-not-in-cl-package "simple-base-string") nil) -(deftest symbol-simple-bit-vector (test-if-not-in-cl-package "simple-bit-vector") nil) -(deftest symbol-simple-bit-vector-p (test-if-not-in-cl-package "simple-bit-vector-p") nil) -(deftest symbol-simple-condition (test-if-not-in-cl-package "simple-condition") nil) -(deftest symbol-simple-condition-format-arguments (test-if-not-in-cl-package "simple-condition-format-arguments") nil) -(deftest symbol-simple-condition-format-control (test-if-not-in-cl-package "simple-condition-format-control") nil) -(deftest symbol-simple-error (test-if-not-in-cl-package "simple-error") nil) -(deftest symbol-simple-string (test-if-not-in-cl-package "simple-string") nil) -(deftest symbol-simple-string-p (test-if-not-in-cl-package "simple-string-p") nil) -(deftest symbol-simple-type-error (test-if-not-in-cl-package "simple-type-error") nil) -(deftest symbol-simple-vector (test-if-not-in-cl-package "simple-vector") nil) -(deftest symbol-simple-vector-p (test-if-not-in-cl-package "simple-vector-p") nil) -(deftest symbol-simple-warning (test-if-not-in-cl-package "simple-warning") nil) -(deftest symbol-sin (test-if-not-in-cl-package "sin") nil) -(deftest symbol-single-float (test-if-not-in-cl-package "single-float") nil) -(deftest symbol-single-float-epsilon (test-if-not-in-cl-package "single-float-epsilon") nil) -(deftest symbol-single-float-negative-epsilon (test-if-not-in-cl-package "single-float-negative-epsilon") nil) -(deftest symbol-sinh (test-if-not-in-cl-package "sinh") nil) -(deftest symbol-sixth (test-if-not-in-cl-package "sixth") nil) -(deftest symbol-sleep (test-if-not-in-cl-package "sleep") nil) -(deftest symbol-slot-boundp (test-if-not-in-cl-package "slot-boundp") nil) -(deftest symbol-slot-exists-p (test-if-not-in-cl-package "slot-exists-p") nil) -(deftest symbol-slot-makunbound (test-if-not-in-cl-package "slot-makunbound") nil) -(deftest symbol-slot-missing (test-if-not-in-cl-package "slot-missing") nil) -(deftest symbol-slot-unbound (test-if-not-in-cl-package "slot-unbound") nil) -(deftest symbol-slot-value (test-if-not-in-cl-package "slot-value") nil) -(deftest symbol-software-type (test-if-not-in-cl-package "software-type") nil) -(deftest symbol-software-version (test-if-not-in-cl-package "software-version") nil) -(deftest symbol-some (test-if-not-in-cl-package "some") nil) -(deftest symbol-sort (test-if-not-in-cl-package "sort") nil) -(deftest symbol-space (test-if-not-in-cl-package "space") nil) -(deftest symbol-special (test-if-not-in-cl-package "special") nil) -(deftest symbol-special-operator-p (test-if-not-in-cl-package "special-operator-p") nil) -(deftest symbol-speed (test-if-not-in-cl-package "speed") nil) -(deftest symbol-sqrt (test-if-not-in-cl-package "sqrt") nil) -(deftest symbol-stable-sort (test-if-not-in-cl-package "stable-sort") nil) -(deftest symbol-standard (test-if-not-in-cl-package "standard") nil) -(deftest symbol-standard-char (test-if-not-in-cl-package "standard-char") nil) -(deftest symbol-standard-char-p (test-if-not-in-cl-package "standard-char-p") nil) -(deftest symbol-standard-class (test-if-not-in-cl-package "standard-class") nil) -(deftest symbol-standard-generic-function (test-if-not-in-cl-package "standard-generic-function") nil) -(deftest symbol-standard-method (test-if-not-in-cl-package "standard-method") nil) -(deftest symbol-standard-object (test-if-not-in-cl-package "standard-object") nil) -(deftest symbol-step (test-if-not-in-cl-package "step") nil) -(deftest symbol-storage-condition (test-if-not-in-cl-package "storage-condition") nil) -(deftest symbol-store-value (test-if-not-in-cl-package "store-value") nil) -(deftest symbol-stream (test-if-not-in-cl-package "stream") nil) -(deftest symbol-stream-element-type (test-if-not-in-cl-package "stream-element-type") nil) -(deftest symbol-stream-error (test-if-not-in-cl-package "stream-error") nil) -(deftest symbol-stream-error-stream (test-if-not-in-cl-package "stream-error-stream") nil) -(deftest symbol-stream-external-format (test-if-not-in-cl-package "stream-external-format") nil) -(deftest symbol-streamp (test-if-not-in-cl-package "streamp") nil) -(deftest symbol-string (test-if-not-in-cl-package "string") nil) -(deftest symbol-string-capitalize (test-if-not-in-cl-package "string-capitalize") nil) -(deftest symbol-string-downcase (test-if-not-in-cl-package "string-downcase") nil) -(deftest symbol-string-equal (test-if-not-in-cl-package "string-equal") nil) -(deftest symbol-string-greaterp (test-if-not-in-cl-package "string-greaterp") nil) -(deftest symbol-string-left-trim (test-if-not-in-cl-package "string-left-trim") nil) -(deftest symbol-string-lessp (test-if-not-in-cl-package "string-lessp") nil) -(deftest symbol-string-not-equal (test-if-not-in-cl-package "string-not-equal") nil) -(deftest symbol-string-not-greaterp (test-if-not-in-cl-package "string-not-greaterp") nil) -(deftest symbol-string-not-lessp (test-if-not-in-cl-package "string-not-lessp") nil) -(deftest symbol-string-right-trim (test-if-not-in-cl-package "string-right-trim") nil) -(deftest symbol-string-stream (test-if-not-in-cl-package "string-stream") nil) -(deftest symbol-string-trim (test-if-not-in-cl-package "string-trim") nil) -(deftest symbol-string-upcase (test-if-not-in-cl-package "string-upcase") nil) -(deftest symbol-string/= (test-if-not-in-cl-package "string/=") nil) -(deftest symbol-string< (test-if-not-in-cl-package "string<") nil) -(deftest symbol-string<= (test-if-not-in-cl-package "string<=") nil) -(deftest symbol-string= (test-if-not-in-cl-package "string=") nil) -(deftest symbol-string> (test-if-not-in-cl-package "string>") nil) -(deftest symbol-string>= (test-if-not-in-cl-package "string>=") nil) -(deftest symbol-stringp (test-if-not-in-cl-package "stringp") nil) -(deftest symbol-structure (test-if-not-in-cl-package "structure") nil) -(deftest symbol-structure-class (test-if-not-in-cl-package "structure-class") nil) -(deftest symbol-structure-object (test-if-not-in-cl-package "structure-object") nil) -(deftest symbol-style-warning (test-if-not-in-cl-package "style-warning") nil) -(deftest symbol-sublis (test-if-not-in-cl-package "sublis") nil) -(deftest symbol-subseq (test-if-not-in-cl-package "subseq") nil) -(deftest symbol-subsetp (test-if-not-in-cl-package "subsetp") nil) -(deftest symbol-subst (test-if-not-in-cl-package "subst") nil) -(deftest symbol-subst-if (test-if-not-in-cl-package "subst-if") nil) -(deftest symbol-subst-if-not (test-if-not-in-cl-package "subst-if-not") nil) -(deftest symbol-substitute (test-if-not-in-cl-package "substitute") nil) -(deftest symbol-substitute-if (test-if-not-in-cl-package "substitute-if") nil) -(deftest symbol-substitute-if-not (test-if-not-in-cl-package "substitute-if-not") nil) -(deftest symbol-subtypep (test-if-not-in-cl-package "subtypep") nil) -(deftest symbol-svref (test-if-not-in-cl-package "svref") nil) -(deftest symbol-sxhash (test-if-not-in-cl-package "sxhash") nil) -(deftest symbol-symbol (test-if-not-in-cl-package "symbol") nil) -(deftest symbol-symbol-function (test-if-not-in-cl-package "symbol-function") nil) -(deftest symbol-symbol-macrolet (test-if-not-in-cl-package "symbol-macrolet") nil) -(deftest symbol-symbol-name (test-if-not-in-cl-package "symbol-name") nil) -(deftest symbol-symbol-package (test-if-not-in-cl-package "symbol-package") nil) -(deftest symbol-symbol-plist (test-if-not-in-cl-package "symbol-plist") nil) -(deftest symbol-symbol-value (test-if-not-in-cl-package "symbol-value") nil) -(deftest symbol-symbolp (test-if-not-in-cl-package "symbolp") nil) -(deftest symbol-synonym-stream (test-if-not-in-cl-package "synonym-stream") nil) -(deftest symbol-synonym-stream-symbol (test-if-not-in-cl-package "synonym-stream-symbol") nil) -(deftest symbol-t (test-if-not-in-cl-package "t") nil) -(deftest symbol-tagbody (test-if-not-in-cl-package "tagbody") nil) -(deftest symbol-tailp (test-if-not-in-cl-package "tailp") nil) -(deftest symbol-tan (test-if-not-in-cl-package "tan") nil) -(deftest symbol-tanh (test-if-not-in-cl-package "tanh") nil) -(deftest symbol-tenth (test-if-not-in-cl-package "tenth") nil) -(deftest symbol-terpri (test-if-not-in-cl-package "terpri") nil) -(deftest symbol-the (test-if-not-in-cl-package "the") nil) -(deftest symbol-third (test-if-not-in-cl-package "third") nil) -(deftest symbol-throw (test-if-not-in-cl-package "throw") nil) -(deftest symbol-time (test-if-not-in-cl-package "time") nil) -(deftest symbol-trace (test-if-not-in-cl-package "trace") nil) -(deftest symbol-translate-logical-pathname (test-if-not-in-cl-package "translate-logical-pathname") nil) -(deftest symbol-translate-pathname (test-if-not-in-cl-package "translate-pathname") nil) -(deftest symbol-tree-equal (test-if-not-in-cl-package "tree-equal") nil) -(deftest symbol-truename (test-if-not-in-cl-package "truename") nil) -(deftest symbol-truncate (test-if-not-in-cl-package "truncate") nil) -(deftest symbol-two-way-stream (test-if-not-in-cl-package "two-way-stream") nil) -(deftest symbol-two-way-stream-input-stream (test-if-not-in-cl-package "two-way-stream-input-stream") nil) -(deftest symbol-two-way-stream-output-stream (test-if-not-in-cl-package "two-way-stream-output-stream") nil) -(deftest symbol-type (test-if-not-in-cl-package "type") nil) -(deftest symbol-type-error (test-if-not-in-cl-package "type-error") nil) -(deftest symbol-type-error-datum (test-if-not-in-cl-package "type-error-datum") nil) -(deftest symbol-type-error-expected-type (test-if-not-in-cl-package "type-error-expected-type") nil) -(deftest symbol-type-of (test-if-not-in-cl-package "type-of") nil) -(deftest symbol-typecase (test-if-not-in-cl-package "typecase") nil) -(deftest symbol-typep (test-if-not-in-cl-package "typep") nil) -(deftest symbol-unbound-slot (test-if-not-in-cl-package "unbound-slot") nil) -(deftest symbol-unbound-slot-instance (test-if-not-in-cl-package "unbound-slot-instance") nil) -(deftest symbol-unbound-variable (test-if-not-in-cl-package "unbound-variable") nil) -(deftest symbol-undefined-function (test-if-not-in-cl-package "undefined-function") nil) -(deftest symbol-unexport (test-if-not-in-cl-package "unexport") nil) -(deftest symbol-unintern (test-if-not-in-cl-package "unintern") nil) -(deftest symbol-union (test-if-not-in-cl-package "union") nil) -(deftest symbol-unless (test-if-not-in-cl-package "unless") nil) -(deftest symbol-unread-char (test-if-not-in-cl-package "unread-char") nil) -(deftest symbol-unsigned-byte (test-if-not-in-cl-package "unsigned-byte") nil) -(deftest symbol-untrace (test-if-not-in-cl-package "untrace") nil) -(deftest symbol-unuse-package (test-if-not-in-cl-package "unuse-package") nil) -(deftest symbol-unwind-protect (test-if-not-in-cl-package "unwind-protect") nil) -(deftest symbol-update-instance-for-different-class (test-if-not-in-cl-package "update-instance-for-different-class") nil) -(deftest symbol-update-instance-for-redefined-class (test-if-not-in-cl-package "update-instance-for-redefined-class") nil) -(deftest symbol-upgraded-array-element-type (test-if-not-in-cl-package "upgraded-array-element-type") nil) -(deftest symbol-upgraded-complex-part-type (test-if-not-in-cl-package "upgraded-complex-part-type") nil) -(deftest symbol-upper-case-p (test-if-not-in-cl-package "upper-case-p") nil) -(deftest symbol-use-package (test-if-not-in-cl-package "use-package") nil) -(deftest symbol-use-value (test-if-not-in-cl-package "use-value") nil) -(deftest symbol-user-homedir-pathname (test-if-not-in-cl-package "user-homedir-pathname") nil) -(deftest symbol-values (test-if-not-in-cl-package "values") nil) -(deftest symbol-values-list (test-if-not-in-cl-package "values-list") nil) -(deftest symbol-variable (test-if-not-in-cl-package "variable") nil) -(deftest symbol-vector (test-if-not-in-cl-package "vector") nil) -(deftest symbol-vector-pop (test-if-not-in-cl-package "vector-pop") nil) -(deftest symbol-vector-push (test-if-not-in-cl-package "vector-push") nil) -(deftest symbol-vector-push-extend (test-if-not-in-cl-package "vector-push-extend") nil) -(deftest symbol-vectorp (test-if-not-in-cl-package "vectorp") nil) -(deftest symbol-warn (test-if-not-in-cl-package "warn") nil) -(deftest symbol-warning (test-if-not-in-cl-package "warning") nil) -(deftest symbol-when (test-if-not-in-cl-package "when") nil) -(deftest symbol-wild-pathname-p (test-if-not-in-cl-package "wild-pathname-p") nil) -(deftest symbol-with-accessors (test-if-not-in-cl-package "with-accessors") nil) -(deftest symbol-with-compilation-unit (test-if-not-in-cl-package "with-compilation-unit") nil) -(deftest symbol-with-condition-restarts (test-if-not-in-cl-package "with-condition-restarts") nil) -(deftest symbol-with-hash-table-iterator (test-if-not-in-cl-package "with-hash-table-iterator") nil) -(deftest symbol-with-input-from-string (test-if-not-in-cl-package "with-input-from-string") nil) -(deftest symbol-with-open-file (test-if-not-in-cl-package "with-open-file") nil) -(deftest symbol-with-open-stream (test-if-not-in-cl-package "with-open-stream") nil) -(deftest symbol-with-output-to-string (test-if-not-in-cl-package "with-output-to-string") nil) -(deftest symbol-with-package-iterator (test-if-not-in-cl-package "with-package-iterator") nil) -(deftest symbol-with-simple-restart (test-if-not-in-cl-package "with-simple-restart") nil) -(deftest symbol-with-slots (test-if-not-in-cl-package "with-slots") nil) -(deftest symbol-with-standard-io-syntax (test-if-not-in-cl-package "with-standard-io-syntax") nil) -(deftest symbol-write (test-if-not-in-cl-package "write") nil) -(deftest symbol-write-byte (test-if-not-in-cl-package "write-byte") nil) -(deftest symbol-write-char (test-if-not-in-cl-package "write-char") nil) -(deftest symbol-write-line (test-if-not-in-cl-package "write-line") nil) -(deftest symbol-write-sequence (test-if-not-in-cl-package "write-sequence") nil) -(deftest symbol-write-string (test-if-not-in-cl-package "write-string") nil) -(deftest symbol-write-to-string (test-if-not-in-cl-package "write-to-string") nil) -(deftest symbol-y-or-n-p (test-if-not-in-cl-package "y-or-n-p") nil) -(deftest symbol-yes-or-no-p (test-if-not-in-cl-package "yes-or-no-p") nil) -(deftest symbol-zerop (test-if-not-in-cl-package "zerop") nil) - -;;; Standardized packages have the right names, nicknames - -(deftest keyword-package-nicknames - :notes :standardized-package-nicknames - (package-nicknames (find-package "KEYWORD")) - nil) - -(deftest common-lisp-package-nicknames - :notes :standardized-package-nicknames - (package-nicknames (find-package "COMMON-LISP")) - ("CL")) - -(deftest common-lisp-user-package-nicknames - :notes :standardized-package-nicknames - (package-nicknames (find-package "COMMON-LISP-USER")) - ("CL-USER")) - - -;;; Test there are no extra exported symbols - -(deftest no-extra-symbols-exported-from-common-lisp - (let ((ht (make-hash-table :test 'equal))) - (loop for n in *cl-symbol-names* do (setf (gethash n ht) t)) - (let ((extras nil)) - (do-external-symbols (s "CL") - (unless (gethash (symbol-name s) ht) - (push s extras))) - extras)) - nil) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Test that all keywords have themselves as their value, -;;; are external if present in KEYWORD, and have themselves -;;; as their values (and are constant). Symbols that are -;;; merely used in KEYWORD but not present there are exempt. - -(deftest keyword-behavior - (let ((result nil) - (keyword-package (find-package "KEYWORD"))) - (do-symbols (s keyword-package result) - (multiple-value-bind (sym status) - (find-symbol (symbol-name s) keyword-package) - (cond - ((not (eqt s sym)) (push (list s sym) result)) - ((eqt status :internal) - (push (list s status) result)) - ((eqt status :external) - (unless (and (eqt (symbol-value s) s) - (constantp s)) - (push (list s sym 'not-constant) result))))))) - nil) - -;;;;;;;;;;;;;;;;;;;; - -;;; Tests of CL package constraints from section 11.1.2.1.1 - -;;; Check that all symbols listed as 'functions' or 'accessors' -;;; are indeed functions. - -(deftest cl-function-symbols.1 - (loop - for s in (append *cl-function-symbols* *cl-accessor-symbols*) - when (or (not (fboundp s)) - (macro-function s) - (special-operator-p s) - (not (symbol-function s))) - collect s) - nil) - -;;; Check that all symols listed as 'macros' are macros. - -(deftest cl-macro-symbols.1 - (loop - for s in *cl-macro-symbols* - when (or (not (fboundp s)) - (not (macro-function s))) - collect s) - nil) - -;;; Check that all constants are indeed constant - -(deftest cl-constant-symbols.1 - (loop - for s in *cl-constant-symbols* - when (or (not (boundp s)) - (not (constantp s))) - collect s) - nil) - -;;; Check that all global variables have values - -(deftest cl-variable-symbols.1 - (loop - for s in *cl-variable-symbols* - when (not (boundp s)) - collect s) - nil) - -;;; Check that all types that are classes name classes. - -;;; "Many but not all of the predefined type specifiers have -;;; a corresponding class with the same proper name as the type. -;;; These type specifiers are listed in Figure 4-8." -- section 4.3.7 - -(deftest cl-types-that-are-classes.1 - ;; Collect class names that violate the condition in the - ;; above quotation. - (loop - for s in *cl-types-that-are-classes-symbols* - for c = (find-class s nil) - unless (and c - (eq (class-name c) s) - (typep c 'class)) - collect s) - nil) - - -(deftest cl-types-that-are-classes.2 - ;; The same as cl-types-that-are-classes.1 - ;; with an environment argument - (loop - for s in *cl-types-that-are-classes-symbols* - for c = (find-class s nil nil) - unless (and c - (eq (class-name c) s) - (typep c 'class)) - collect s) - nil) - -(deftest cl-types-that-are-classes.3 - ;; The same as cl-types-that-are-classes.1, - ;; with an environment argument - (loop - for s in *cl-types-that-are-classes-symbols* - for c = (eval `(macrolet ((%foo (&environment env) - (list 'quote - (find-class ',s nil env)))) - (%foo))) - unless (and c - (eq (class-name c) s) - (typep c 'class)) - collect s) - nil) - -;;; Various error cases for symbol-related functions - -(deftest symbol-package.error.1 - (signals-error (symbol-package) program-error) - t) - -(deftest symbol-package.error.2 - (signals-error (symbol-package 'cons nil) program-error) - t) - -(deftest symbol-package.error.3 - (check-type-error #'symbol-package #'symbolp) - nil) - - -(deftest symbol-plist.error.1 - (signals-error (symbol-plist) program-error) - t) - -(deftest symbol-plist.error.2 - (signals-error (symbol-plist 'cons nil) program-error) - t) - -(deftest symbol-plist.error.3 - (check-type-error #'symbol-plist #'symbolp) - nil) - -(deftest symbol-plist.error.4 - (check-type-error #'(lambda (x) (setf (symbol-plist x) nil)) - #'symbolp) - nil) - - - -(deftest symbol-value.error.1 - (signals-error (symbol-value) program-error) - t) - -(deftest symbol-value.error.2 - (signals-error (symbol-value '*package* nil) program-error) - t) - -(deftest symbol-value.error.3 - (check-type-error #'symbol-value #'symbolp) - nil) - -(deftest symbol-value.error.4 - (check-type-error #'(lambda (x) (setf (symbol-value x) nil)) #'symbolp) - nil) - -(deftest symbol-value.error.5 - (let ((sym (gensym))) - (declare (optimize safety)) - (handler-case (progn (symbol-value sym) :bad) - (unbound-variable (c) - (assert (eq (cell-error-name c) sym)) - :good))) - :good) diff --git a/t/ansi-test/symbols/copy-symbol.lsp b/t/ansi-test/symbols/copy-symbol.lsp deleted file mode 100644 index 6020b2a..0000000 --- a/t/ansi-test/symbols/copy-symbol.lsp +++ /dev/null @@ -1,95 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Jun 14 05:44:41 2003 -;;;; Contains: Tests of COPY-SYMBOL - -(in-package :cl-test) - -(deftest copy-symbol.1 - (notnot-mv - (every - #'(lambda (x) - (let ((y (copy-symbol x))) - (and (null (symbol-plist y)) - (symbolp y) - (not (boundp y)) - (not (fboundp y)) - (null (symbol-package y)) - (string= (symbol-name x) (symbol-name y)) - (symbolp (copy-symbol y)) - ))) - '(nil t a b |a| |123|))) - t) - -(deftest copy-symbol.2 - (progn - (setf (symbol-plist '|foo|) '(a b c d)) - (makunbound '|foo|) - (notnot-mv - (every - #'(lambda (x) - (let ((y (copy-symbol x t))) - (and - (equal (symbol-plist y) (symbol-plist x)) - (symbolp y) - (if (boundp x) - (boundp y) - (not (boundp y))) - (if (fboundp x) (fboundp y) (not (fboundp y))) - (null (symbol-package y)) - (string= (symbol-name x) (symbol-name y)) - ))) - '(nil t a b |foo| |a| |123|)))) - t) - -(deftest copy-symbol.3 - (progn - (setf (symbol-plist '|foo|) '(a b c d)) - (setf (symbol-value '|a|) 12345) - (notnot-mv - (every - #'(lambda (x) - (let ((y (copy-symbol x t))) - (and - (eql (length (symbol-plist y)) - (length (symbol-plist x))) - ;; Is a list copy - (every #'eq (symbol-plist y) (symbol-plist x)) - (symbolp y) - (if (boundp x) - (eqt (symbol-value x) - (symbol-value y)) - (not (boundp y))) - (if (fboundp x) (fboundp y) (not (fboundp y))) - (null (symbol-package y)) - (string= (symbol-name x) (symbol-name y)) - (eql (length (symbol-plist x)) - (length (symbol-plist y))) - ))) - '(nil t a b |foo| |a| |123|)))) - t) - -(deftest copy-symbol.4 - (eqt (copy-symbol 'a) (copy-symbol 'a)) - nil) - -(deftest copy-symbol.5 - (let ((i 0) x y (s '#:|x|)) - (let ((s2 (copy-symbol - (progn (setf x (incf i)) s) - (progn (setf y (incf i)) nil)))) - (values - (symbol-name s2) - (eq s s2) - i x y))) - "x" nil 2 1 2) - -;;; Error tests - -(deftest copy-symbol.error.1 - (signals-error (copy-symbol) program-error) - t) - -(deftest copy-symbol.error.2 - (signals-error (copy-symbol 'a t 'foo) program-error) - t) diff --git a/t/ansi-test/symbols/gensym.lsp b/t/ansi-test/symbols/gensym.lsp deleted file mode 100644 index d3b0f99..0000000 --- a/t/ansi-test/symbols/gensym.lsp +++ /dev/null @@ -1,116 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Jun 14 05:43:47 2003 -;;;; Contains: Tests of GENSYM - -(in-package :cl-test) - -;;; Gensym returns unique symbols -(deftest gensym.1 - (equal (gensym) (gensym)) - nil) - -;;; Gensym returns symbols with distinct print names -(deftest gensym.2 - (string= (symbol-name (gensym)) - (symbol-name (gensym))) - nil) - -;;; Gensym uses the *gensym-counter* special variable, -;;; but does not increment it until after the symbol -;;; has been created. -(deftest gensym.3 - (let ((*gensym-counter* 1)) - (symbol-name (gensym))) - #.(string '#:g1)) - -;;; Gensym uses the string argument instead of the default -(deftest gensym.4 - (let ((*gensym-counter* 1327)) - (symbol-name (gensym "FOO"))) - "FOO1327") - -;;; The symbol returned by gensym should be unbound -(deftest gensym.5 - (boundp (gensym)) - nil) - -;;; The symbol returned by gensym should have no function binding -(deftest gensym.6 - (fboundp (gensym)) - nil) - -;;; The symbol returned by gensym should have no property list -(deftest gensym.7 - (symbol-plist (gensym)) - nil) - -;;; The symbol returned by gensym should be uninterned -(deftest gensym.8 - (symbol-package (gensym)) - nil) - -;;; *gensym-counter* is incremented by gensym -(deftest gensym.9 - (let ((*gensym-counter* 12345)) - (gensym) - *gensym-counter*) - 12346) - -;;; Gensym works when *gensym-counter* is Really Big -;;; (and does not increment the counter until after creating -;;; the symbol.) -(deftest gensym.10 - (let ((*gensym-counter* 1234567890123456789012345678901234567890)) - (symbol-name (gensym))) - #.(string '#:g1234567890123456789012345678901234567890)) - -;;; gensym increments Really Big values of *gensym-counter* -(deftest gensym.11 - (let ((*gensym-counter* 12345678901234567890123456789012345678901234567890)) - (gensym) - *gensym-counter*) - 12345678901234567890123456789012345678901234567891) - -;;; Gensym uses an integer argument instead of the counter -(deftest gensym.12 - (let ((*gensym-counter* 10)) - (symbol-name (gensym 123))) - #.(string '#:g123)) - -;;; When given an integer argument, gensym does not increment the -;;; *gensym-counter* -(deftest gensym.13 - (let ((*gensym-counter* 10)) - (gensym 123) - *gensym-counter*) - 10) - -;;; GENSYM counter is a non-negative integer -(deftest gensym-counter.1 - (and (integerp *gensym-counter*) - (>= *gensym-counter* 0) - t) - t) - -;;; Check response to erroneous arguments -;;; Note! NIL is not the same as no argument -;;; gensym should be implemented so that its only -;;; argument defaults to "G", with NIL causing an error. - -(deftest gensym.error.1 - (check-type-error #'gensym #'(lambda (x) (typep x '(or string unsigned-byte)))) - nil) - -(deftest gensym.error.7 - (signals-error (gensym 10 'foo) program-error) - t) - -(deftest gensym.error.8 - (signals-error (locally (gensym t) t) type-error) - t) - -(deftest gensym.error.9 - (signals-error (gensym "FOO" nil) program-error) - t) - diff --git a/t/ansi-test/symbols/gentemp.lsp b/t/ansi-test/symbols/gentemp.lsp deleted file mode 100644 index 5f8176f..0000000 --- a/t/ansi-test/symbols/gentemp.lsp +++ /dev/null @@ -1,126 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jun 22 09:32:09 2003 -;;;; Contains: Tests of GENTEMP - -(in-package :cl-test) - -(deftest gentemp.1 - (let* ((package-name "GENTEMP-TEST-PACKAGE")) - (unwind-protect - (let* ((pkg (make-package package-name :use nil)) - (gcounter *gensym-counter*) - (sym (let ((*package* pkg)) (gentemp))) - (sym-name (symbol-name sym))) - (values - (=t gcounter *gensym-counter*) ;; wasn't changed - (eqlt (aref sym-name 0) #\T) - (notnot (every #'digit-char-p (subseq sym-name 1))) - (eql (symbol-package sym) pkg) - ;; Not external - (do-external-symbols (s pkg t) (when (eql s sym) (return nil))) - )) - (delete-package package-name))) - t t t t t) - -(deftest gentemp.2 - (let* ((package-name "GENTEMP-TEST-PACKAGE")) - (unwind-protect - (let* ((pkg (make-package package-name :use nil)) - (gcounter *gensym-counter*) - (sym (let ((*package* pkg)) (gentemp "X"))) - (sym-name (symbol-name sym))) - (values - (=t gcounter *gensym-counter*) ;; wasn't changed - (eqlt (aref sym-name 0) #\X) - (notnot (every #'digit-char-p (subseq sym-name 1))) - (eql (symbol-package sym) pkg) - ;; Not external - (do-external-symbols (s pkg t) (when (eql s sym) (return nil))) - )) - (delete-package package-name))) - t t t t t) - -(deftest gentemp.3 - (let* ((package-name "GENTEMP-TEST-PACKAGE")) - (unwind-protect - (let* ((pkg (make-package package-name :use nil)) - (gcounter *gensym-counter*) - (sym (gentemp "X" package-name)) - (sym-name (symbol-name sym))) - (values - (=t gcounter *gensym-counter*) ;; wasn't changed - (eqlt (aref sym-name 0) #\X) - (notnot (every #'digit-char-p (subseq sym-name 1))) - (eql (symbol-package sym) pkg) - ;; Not external - (do-external-symbols (s pkg t) (when (eql s sym) (return nil))) - )) - (delete-package package-name))) - t t t t t) - -(deftest gentemp.4 - (let* ((package-name "GENTEMP-TEST-PACKAGE")) - (unwind-protect - (let* ((pkg (make-package package-name :use nil)) - (gcounter *gensym-counter*) - (sym (gentemp "" (make-symbol package-name))) - (sym-name (symbol-name sym))) - (values - (=t gcounter *gensym-counter*) ;; wasn't changed - (notnot (every #'digit-char-p sym-name)) - (eql (symbol-package sym) pkg) - ;; Not external - (do-external-symbols (s pkg t) (when (eql s sym) (return nil))) - )) - (delete-package package-name))) - t t t t) - -(deftest gentemp.5 - (let* ((package-name "Z")) - (safely-delete-package package-name) - (unwind-protect - (let* ((pkg (make-package package-name :use nil)) - (gcounter *gensym-counter*) - (sym (gentemp "Y" #\Z)) - (sym-name (symbol-name sym))) - (values - (=t gcounter *gensym-counter*) ;; wasn't changed - (eqlt (aref sym-name 0) #\Y) - (notnot (every #'digit-char-p (subseq sym-name 1))) - (eql (symbol-package sym) pkg) - ;; Not external - (do-external-symbols (s pkg t) (when (eql s sym) (return nil))) - )) - (delete-package package-name))) - t t t t t) - -(deftest gentemp.6 - (let* ((package-name "GENTEMP-TEST-PACKAGE")) - (unwind-protect - (let* ((*package* (make-package package-name :use nil)) - (syms (loop repeat 100 collect (gentemp)))) - (=t (length syms) (length (remove-duplicates syms)))) - (delete-package package-name))) - t) - -;;; Error tests - -(deftest gentemp.error.1 - (loop for x in *mini-universe* - unless (or (stringp x) - (eql (eval `(signals-type-error x ',x (gentemp x))) t)) - collect x) - nil) - -(deftest gentemp.error.2 - (loop for x in *mini-universe* - unless (or (typep x 'package) - (string-designator-p x) - (eql (eval `(signals-type-error x ',x (gentemp "T" x))) t)) - collect x) - nil) - -(deftest gentemp.error.3 - (signals-error (gentemp "" *package* nil) program-error) - t) diff --git a/t/ansi-test/symbols/get.lsp b/t/ansi-test/symbols/get.lsp deleted file mode 100644 index ec5a6cc..0000000 --- a/t/ansi-test/symbols/get.lsp +++ /dev/null @@ -1,113 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Jul 13 07:01:47 2004 -;;;; Contains: Tests of GET - -(in-package :cl-test) - -(deftest get.1 - (let ((sym (gensym))) (get sym :foo)) - nil) - -(deftest get.2 - (let ((sym (gensym))) (get sym :foo :bar)) - :bar) - -(deftest get.3 - (let ((sym (gensym))) (get sym :foo (values :bar nil))) - :bar) - -(deftest get.4 - (let ((sym (gensym))) - (setf (symbol-plist sym) (list :foo 1 :bar 2 :foo 3)) - (values (get sym :foo) (get sym :bar))) - 1 2) - -(deftest get.5 - (let ((evaluated nil) - (sym (gensym))) - (assert (equal (multiple-value-list (setf (get sym :foo) 1)) - '(1))) - (values - (get sym :foo (progn (setf evaluated t) nil)) - evaluated)) - 1 t) - -(deftest get.6 - (let ((evaluated nil) - (sym (gensym))) - (assert (equal (multiple-value-list - (setf (get sym :foo - (progn (setf evaluated t) nil)) - 1)) - '(1))) - (values - (get sym :foo) - evaluated)) - 1 t) - -;;; Order of evaluation - -(deftest get.order.1 - (let (a b (i 0) (sym (gensym))) - (setf (get sym :foo) t) - (values - (get (progn (setf a (incf i)) sym) - (progn (setf b (incf i)) :foo)) - a b i)) - t 1 2 2) - -(deftest get.order.2 - (let (a b (i 0) (sym (gensym))) - (values - (setf (get (progn (setf a (incf i)) sym) - (progn (setf b (incf i)) :foo)) - t) - a b i - (get sym :foo) - )) - t 1 2 2 t) - -(deftest get.order.3 - (let (a b c (i 0) (sym (gensym))) - (setf (get sym :foo) t) - (values - (get (progn (setf a (incf i)) sym) - (progn (setf b (incf i)) :foo) - (progn (setf c (incf i)) nil)) - a b c i)) - t 1 2 3 3) - -(deftest get.order.4 - (let (a b c (i 0) (sym (gensym))) - (values - (setf (get (progn (setf a (incf i)) sym) - (progn (setf b (incf i)) :foo) - (progn (setf c (incf i)) nil)) - t) - a b c i - (get sym :foo) - )) - t 1 2 3 3 t) - -;;; Error tests - -(deftest get.error.1 - (signals-error (get) program-error) - t) - -(deftest get.error.2 - (signals-error (get nil) program-error) - t) - -(deftest get.error.3 - (signals-error (get nil nil nil nil) program-error) - t) - -(deftest get.error.4 - (check-type-error #'(lambda (x) (get x :foo)) #'symbolp) - nil) - -(deftest get.error.5 - (check-type-error #'(lambda (x) (setf (get x :foo) nil)) #'symbolp) - nil) diff --git a/t/ansi-test/symbols/keywordp.lsp b/t/ansi-test/symbols/keywordp.lsp deleted file mode 100644 index 2f4a43e..0000000 --- a/t/ansi-test/symbols/keywordp.lsp +++ /dev/null @@ -1,41 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Jun 14 05:46:51 2003 -;;;; Contains: Tests of KEYWORDP - -(in-package :cl-test) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; keywordp - -(deftest keywordp.1 (keywordp 'hefalump) nil) -(deftest keywordp.2 (keywordp 17) nil) -(deftest keywordp.3 (notnot-mv (keywordp :stream)) t) -(deftest keywordp.4 (notnot-mv (keywordp ':stream)) t) -(deftest keywordp.5 (keywordp nil) nil) -(deftest keywordp.6 (notnot-mv (keywordp :nil)) t) -(deftest keywordp.7 (keywordp '(:stream)) nil) -(deftest keywordp.8 (keywordp "rest") nil) -(deftest keywordp.9 (keywordp ":rest") nil) -(deftest keywordp.10 (keywordp '&body) nil) -;;; This next test was busted. ::foo is not portable syntax -;;(deftest keywordp.11 (notnot-mv (keywordp ::foo)) t) -(deftest keywordp.12 (keywordp t) nil) - -(deftest keywordp.13 - (let ((kwp (find-package "KEYWORD")) - (bad nil)) - (do-symbols (s "KEYWORD" bad) - (when (and (not (eq (symbol-package s) kwp)) - (keywordp s)) - (push s bad)))) - nil) - -(deftest keywordp.order.1 - (let ((i 0)) - (values (keywordp (progn (incf i) nil)) i)) - nil 1) - -(deftest keywordp.error.1 (signals-error (keywordp) program-error) t) -(deftest keywordp.error.2 (signals-error (keywordp :x :x) program-error) t) diff --git a/t/ansi-test/symbols/load.lsp b/t/ansi-test/symbols/load.lsp deleted file mode 100644 index 5ff13d0..0000000 --- a/t/ansi-test/symbols/load.lsp +++ /dev/null @@ -1,23 +0,0 @@ -;;; Tests of symbols -(compile-and-load "ANSI-TESTS:AUX;cl-symbols-aux.lsp") - -(in-package #:cl-test) - -(let ((*default-pathname-defaults* - (make-pathname - :directory (pathname-directory *load-pathname*)))) - (load "cl-symbols.lsp") - (load "symbolp.lsp") - (load "keywordp.lsp") - (load "make-symbol.lsp") - (load "copy-symbol.lsp") - (load "gensym.lsp") - (load "gentemp.lsp") - (load "symbol-function.lsp") - (load "symbol-name.lsp") - (load "boundp.lsp") - (load "special-operator-p.lsp") - (load "makunbound.lsp") - (load "set.lsp") - (load "remprop.lsp") - (load "get.lsp")) diff --git a/t/ansi-test/symbols/make-symbol.lsp b/t/ansi-test/symbols/make-symbol.lsp deleted file mode 100644 index c06cb26..0000000 --- a/t/ansi-test/symbols/make-symbol.lsp +++ /dev/null @@ -1,134 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Jun 14 05:45:21 2003 -;;;; Contains: Tests of MAKE-SYMBOL - -(in-package :cl-test) - -(deftest make-symbol.1 - (notnot-mv (symbolp (make-symbol "FOO"))) - t) - -(deftest make-symbol.2 - (symbol-package (make-symbol "BAR")) - nil) - -(deftest make-symbol.3 - (symbol-package (make-symbol "CL::FOO")) - nil) - -(deftest make-symbol.4 - (symbol-package (make-symbol "CL:FOO")) - nil) - -(deftest make-symbol.5 - (symbol-name (make-symbol "xyz")) - "xyz") - -(deftest make-symbol.6 - (eqt (make-symbol "A") - (make-symbol "A")) - nil) - -(deftest make-symbol.7 - (boundp (make-symbol "B")) - nil) - -(deftest make-symbol.8 - (symbol-plist (make-symbol "C")) - nil) - -(deftest make-symbol.9 - (fboundp (make-symbol "D")) - nil) - -(deftest make-symbol.10 - (symbol-name (make-symbol "")) - "") - -(deftest make-symbol.11 - :notes (:nil-vectors-are-strings) - (symbol-name (make-symbol (make-array '(0) :element-type nil))) - "") - -(deftest make-symbol.12 - (let* ((name (make-array '(4) :initial-contents '(#\A #\B #\C #\D) - :element-type 'base-char)) - (s (make-symbol name)) - (name2 (symbol-name s))) - (values - (symbol-package s) - (string=t name2 "ABCD"))) - nil t) - -(deftest make-symbol.13 - (let* ((name (make-array '(6) :initial-contents '(#\A #\B #\C #\D #\E #\F) - :element-type 'character - :fill-pointer 4)) - (s (make-symbol name)) - (name2 (symbol-name s))) - (values - (symbol-package s) - (string=t name2 "ABCD"))) - nil t) - -(deftest make-symbol.14 - (let* ((name (make-array '(4) :initial-contents '(#\A #\B #\C #\D) - :adjustable t - :element-type 'character)) - (s (make-symbol name)) - (name2 (symbol-name s))) - (values - (symbol-package s) - (string=t name2 "ABCD"))) - nil t) - -(deftest make-symbol.15 - (let* ((name0 (make-array '(6) :initial-contents '(#\0 #\A #\B #\C #\D #\E) - :element-type 'character)) - (name (make-array '(4) :element-type 'character - :displaced-to name0 - :displaced-index-offset 1)) - (s (make-symbol name)) - (name2 (symbol-name s))) - (values - (symbol-package s) - (string=t name2 "ABCD"))) - nil t) - -(deftest make-symbol.16 - (let* ((name0 (make-array '(6) :initial-contents '(#\0 #\A #\B #\C #\D #\E) - :element-type 'base-char)) - (name (make-array '(4) :element-type 'base-char - :displaced-to name0 - :displaced-index-offset 1)) - (s (make-symbol name)) - (name2 (symbol-name s))) - (values - (symbol-package s) - (string=t name2 "ABCD"))) - nil t) - - -(deftest make-symbol.order.1 - (let ((i 0)) - (values - (symbol-name (make-symbol (progn (incf i) "ABC"))) - i)) - "ABC" 1) - -(deftest make-symbol.error.1 - (check-type-error #'make-symbol #'stringp) - nil) - -(deftest make-symbol.error.9 - (signals-error (make-symbol) program-error) - t) - -(deftest make-symbol.error.10 - (signals-error (make-symbol "a" "a") program-error) - t) - -(deftest make-symbol.error.11 - (signals-type-error x '(#\a #\b #\c) (make-symbol x)) - t) diff --git a/t/ansi-test/symbols/makunbound.lsp b/t/ansi-test/symbols/makunbound.lsp deleted file mode 100644 index 2508642..0000000 --- a/t/ansi-test/symbols/makunbound.lsp +++ /dev/null @@ -1,45 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Jul 13 07:55:05 2004 -;;;; Contains: Add tests for MAKUNBOUND - -(in-package :cl-test) - -(deftest makunbound.1 - (let ((sym (gensym))) - (values - (boundp sym) - (equalt (multiple-value-list (makunbound sym)) (list sym)) - (boundp sym) - (setf (symbol-value sym) nil) - (notnot (boundp sym)) - (equalt (multiple-value-list (makunbound sym)) (list sym)) - (boundp sym))) - nil t nil nil t t nil) - -(deftest makunbound.2 - (let ((sym (gensym))) - (values - (boundp sym) - (setf (symbol-value sym) :foo) - (equalt (multiple-value-list (makunbound sym)) (list sym)) - (boundp sym) - (handler-case (symbol-value sym) - (unbound-variable (c) - (if (eq (cell-error-name c) sym) :good - (list :bad sym (cell-error-name c))))))) - nil :foo t nil :good) - -;;; Error cases - -(deftest makunbound.error.1 - (signals-error (makunbound) program-error) - t) - -(deftest makunbound.error.2 - (signals-error (makunbound (gensym) nil) program-error) - t) - -(deftest makunbound.error.3 - (check-type-error #'makunbound #'symbolp) - nil) diff --git a/t/ansi-test/symbols/remprop.lsp b/t/ansi-test/symbols/remprop.lsp deleted file mode 100644 index 8a535be..0000000 --- a/t/ansi-test/symbols/remprop.lsp +++ /dev/null @@ -1,73 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Jul 12 18:25:53 2004 -;;;; Contains: Tests for REMPROP - -(in-package :cl-test) - -(deftest remprop.1 - (let ((sym (gensym))) - (values - (symbol-plist sym) - (multiple-value-list (remprop sym :foo)) - (symbol-plist sym))) - nil (nil) nil) - -(deftest remprop.2 - (let ((sym (gensym))) - (values - (symbol-plist sym) - (copy-list (setf (symbol-plist sym) '(:foo 0))) - (multiple-value-list (notnot-mv (remprop sym :foo))) - (symbol-plist sym))) - nil (:foo 0) (t) nil) - -(deftest remprop.3 - (let ((sym (gensym))) - (values - (symbol-plist sym) - (copy-list (setf (symbol-plist sym) (list :bar 1 :foo 0 :baz 2))) - (multiple-value-list (notnot-mv (remprop sym :foo))) - (copy-list (symbol-plist sym)) - (multiple-value-list (notnot-mv (remprop sym :foo))) - (symbol-plist sym))) - nil - (:bar 1 :foo 0 :baz 2) - (t) - (:bar 1 :baz 2) - (nil) - (:bar 1 :baz 2)) - -(deftest remprop.4 - (let ((sym (gensym))) - (values - (symbol-plist sym) - (copy-list (setf (symbol-plist sym) (list :bar 1 :foo 0 :baz 2 :foo 3))) - (multiple-value-list (notnot-mv (remprop sym :foo))) - (copy-list (symbol-plist sym)) - (multiple-value-list (notnot-mv (remprop sym :foo))) - (symbol-plist sym))) - nil - (:bar 1 :foo 0 :baz 2 :foo 3) - (t) - (:bar 1 :baz 2 :foo 3) - (t) - (:bar 1 :baz 2)) - -;;; Error tests - -(deftest remprop.error.1 - (signals-error (remprop) program-error) - t) - -(deftest remprop.error.2 - (signals-error (remprop (gensym)) program-error) - t) - -(deftest remprop.error.3 - (signals-error (remprop (gensym) nil nil) program-error) - t) - -(deftest remprop.error.4 - (check-type-error #'(lambda (x) (remprop x nil)) #'symbolp) - nil) diff --git a/t/ansi-test/symbols/set.lsp b/t/ansi-test/symbols/set.lsp deleted file mode 100644 index 991dbe0..0000000 --- a/t/ansi-test/symbols/set.lsp +++ /dev/null @@ -1,55 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Jun 21 22:35:48 2003 -;;;; Contains: Tests of SET - -(in-package :cl-test) - -(deftest set.1 - (let ((*var-used-in-set-tests* 'a) - (var '*var-used-in-set-tests*)) - (declare (special *var-used-in-set-tests*)) - (values - *var-used-in-set-tests* - (set var 'b) - *var-used-in-set-tests*)) - a b b) - -(deftest set.2 - (let ((*var-used-in-set-tests* 'a) - (var '*var-used-in-set-tests*)) - (declare (special *var-used-in-set-tests*)) - (values - (let ((*var-used-in-set-tests* 'c)) - (list (set var 'b) *var-used-in-set-tests* (symbol-value var))) - *var-used-in-set-tests*)) - (b c b) - b) - -(deftest set.error.1 - (signals-error (set) program-error) - t) - -(deftest set.error.2 - (signals-error - (let ((*var-used-in-set-tests* 'a)) - (declare (special *var-used-in-set-tests*)) - (set '*var-used-in-set-tests*)) - program-error) - t) - -(deftest set.error.3 - (signals-error - (let ((*var-used-in-set-tests* 'a)) - (declare (special *var-used-in-set-tests*)) - (set '*var-used-in-set-tests* nil nil)) - program-error) - t) - -(deftest set.error.4 - (signals-error - (let ((*var-used-in-set-tests* 'a) (*y* 'b)) - (declare (special *var-used-in-set-tests*)) - (set '*var-used-in-set-tests* nil '*y* nil)) - program-error) - t) diff --git a/t/ansi-test/symbols/special-operator-p.lsp b/t/ansi-test/symbols/special-operator-p.lsp deleted file mode 100644 index 09d7227..0000000 --- a/t/ansi-test/symbols/special-operator-p.lsp +++ /dev/null @@ -1,53 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Jun 14 05:51:41 2003 -;;;; Contains: Tests fo SPECIAL-OPERATOR-P - -(in-package :cl-test) - -;;; See section 3.1.2.1.2.1 -(defparameter +special-operators+ - '(block let* return-from catch load-time-value setq eval-when - locally symbol-macrolet flet macrolet tagbody function - multiple-value-call the go multiple-value-prog1 throw if - progn unwind-protect labels progv let quote)) - - -;;; All the symbols in +special-operators+ are special operators -(deftest special-operator-p.1 - (loop for s in +special-operators+ - unless (special-operator-p s) - collect s) - nil) - -;;; None of the standard symbols except those in +special-operators+ -;;; are special operators, unless they have a macro function -;;; (See the page for MACRO-FUNCTION) - -(deftest special-operator-p.2 - (let ((p (find-package "CL"))) - (loop for name in *cl-symbol-names* - unless (or (member name +special-operators+ :test #'string=) - (let ((sym (find-symbol name p))) - (or (not (special-operator-p sym)) - (macro-function sym)))) - collect name)) - nil) - -(deftest special-operator-p.order.1 - (let ((i 0)) - (values (notnot (special-operator-p (progn (incf i) 'catch))) - i)) - t 1) - -(deftest special-operator-p.error.1 - (check-type-error #'special-operator-p #'symbolp) - nil) - -(deftest special-operator-p.error.2 - (signals-error (special-operator-p) program-error) - t) - -(deftest special-operator-p.error.3 - (signals-error (special-operator-p 'cons 'cons) program-error) - t) diff --git a/t/ansi-test/symbols/symbol-function.lsp b/t/ansi-test/symbols/symbol-function.lsp deleted file mode 100644 index 19659a8..0000000 --- a/t/ansi-test/symbols/symbol-function.lsp +++ /dev/null @@ -1,45 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Jul 13 07:38:43 2004 -;;;; Contains: Tests of SYMBOL-FUNCTION - -(in-package :cl-test) - -(deftest symbol-function.1 - (let ((sym (gensym)) - (f #'(lambda () (values 1 2 3)))) - (values - (eqt (setf (symbol-function sym) f) f) - (multiple-value-list (eval (list sym))))) - t (1 2 3)) - -;;; Error cases - -(deftest symbol-function.error.1 - (signals-error (symbol-function) program-error) - t) - -(deftest symbol-function.error.2 - (signals-error (symbol-function 'cons nil) program-error) - t) - -(deftest symbol-function.error.3 - (check-type-error #'symbol-function #'symbolp) - nil) - -(deftest symbol-function.error.4 - (check-type-error #'(lambda (x) (setf (symbol-function x) #'identity)) - #'symbolp) - nil) - -(deftest symbol-function.error.5 - (let ((sym (gensym))) - (handler-case (progn (symbol-function sym) nil) - (undefined-function - (c) - (assert (eq (cell-error-name c) sym)) - :good))) - :good) - - - diff --git a/t/ansi-test/symbols/symbol-name.lsp b/t/ansi-test/symbols/symbol-name.lsp deleted file mode 100644 index 65d7bb3..0000000 --- a/t/ansi-test/symbols/symbol-name.lsp +++ /dev/null @@ -1,34 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Jun 14 05:45:55 2003 -;;;; Contains: Tests of SYMBOL-NAME - -(in-package :cl-test) - -(deftest symbol-name.1 - (symbol-name '|ABCD|) - "ABCD") - -(deftest symbol-name.2 - (symbol-name '|1234abcdABCD|) - "1234abcdABCD") - -(deftest symbol-name.3 - (symbol-name :|abcdefg|) - "abcdefg") - -;;; Error tests - -(deftest symbol-name.error.1 - (signals-error (symbol-name) program-error) - t) - -(deftest symbol-name.error.2 - (signals-error (symbol-name 'a 'b) program-error) - t) - -(deftest symbol-name.error.3 - (check-type-error #'symbol-name #'symbolp) - nil) - - diff --git a/t/ansi-test/symbols/symbolp.lsp b/t/ansi-test/symbols/symbolp.lsp deleted file mode 100644 index c56329c..0000000 --- a/t/ansi-test/symbols/symbolp.lsp +++ /dev/null @@ -1,28 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jun 22 08:59:12 2003 -;;;; Contains: Tests for SYMBOLP - -(in-package :cl-test) - -(deftest symbolp.1 - (notnot-mv (symbolp nil)) - t) - -(deftest symbolp.2 - (check-predicate #'symbolp nil *symbols*) - nil) - -(deftest symbolp.3 - (check-predicate (complement #'symbolp) #'(lambda (x) (member x *symbols*))) - nil) - -;;; Error cases - -(deftest symbolp.error.1 - (signals-error (symbolp) program-error) - t) - -(deftest symbolp.error.2 - (signals-error (symbolp nil nil) program-error) - t) diff --git a/t/ansi-test/system-construction/compile-file.lsp b/t/ansi-test/system-construction/compile-file.lsp deleted file mode 100644 index 7a60efa..0000000 --- a/t/ansi-test/system-construction/compile-file.lsp +++ /dev/null @@ -1,233 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 9 08:25:25 2005 -;;;; Contains: Tests of COMPILE-FILE - -(in-package :cl-test) - -(defun compile-file-test (file funname &rest args &key - expect-warnings - expect-style-warnings output-file - (print nil print-p) - (verbose nil verbose-p) - (*compile-print* nil) - (*compile-verbose* nil) - external-format) - (declare (ignorable external-format)) - (let* ((target-pathname (or output-file - (compile-file-pathname file))) - (actual-warnings-p nil) - (actual-style-warnings-p nil)) - (when (probe-file target-pathname) - (delete-file target-pathname)) - (fmakunbound funname) - (let* ((str (make-array '(0) :element-type 'character :adjustable t :fill-pointer 0)) - (vals (multiple-value-list - (handler-bind - ((style-warning #'(lambda (c) - (declare (ignore c)) - (setf actual-style-warnings-p t) - nil)) - ((or error warning) - #'(lambda (c) - (unless (typep c 'style-warning) - (setf actual-warnings-p t)) - nil))) - (with-output-to-string - (*standard-output* str) - (apply #'compile-file file :allow-other-keys t args)))))) - (assert (= (length vals) 3)) - (destructuring-bind - (output-truename warnings-p failure-p) - vals - (print (namestring (truename target-pathname))) - (print (namestring output-truename)) - (values - (let ((v1 (or print verbose - (and (not print-p) *compile-print*) - (and (not verbose-p) *compile-verbose*) - (string= str ""))) - (v2 (or (and verbose-p (not verbose)) - (and (not verbose-p) (not *compile-verbose*)) - (position #\; str))) - (v3 (if actual-warnings-p failure-p t)) - (v4 (if expect-warnings failure-p t)) - (v5 (if expect-style-warnings warnings-p t)) - (v6 (or (null output-truename) (pathnamep output-truename))) - (v7 (equalpt-or-report (namestring (truename target-pathname)) - (namestring output-truename))) - (v8 (not (fboundp funname)))) - (if (and v1 v2 v3 v4 v5 v6 (eql v7 t) v8) t - (list v1 v2 v3 v4 v5 v6 v7 v8))) - (progn - (load output-truename) - (funcall funname))))))) - -(deftest compile-file.1 - (compile-file-test "compile-file-test-file.lsp" - 'compile-file-test-fun.1) t nil) - -(deftest compile-file.2 - (compile-file-test "compile-file-test-file-2.lsp" - 'compile-file-test-fun.2 - :expect-style-warnings t) - t nil) - -(deftest compile-file.2a - (compile-file-test "compile-file-test-file-2a.lsp" - 'compile-file-test-fun.2a - :expect-warnings t) - t nil) - -(deftest compile-file.3 - (let ((*package* (find-package "CL-TEST"))) - (compile-file-test "compile-file-test-file-3.lsp" - 'compile-file-test-fun.3)) t nil) - -(deftest compile-file.4 - (let ((*package* (find-package "CL-USER"))) - (compile-file-test "compile-file-test-file-3.lsp" - 'cl-user::compile-file-test-fun.3)) t nil) - -(deftest compile-file.5 - (compile-file-test #p"compile-file-test-file.lsp" - 'compile-file-test-fun.1) t nil) - -(deftest compile-file.6 - (compile-file-test "compile-file-test-file.lsp" - 'compile-file-test-fun.1 - :output-file "foo.fasl") - t nil) - -(deftest compile-file.6a - (compile-file-test "compile-file-test-file.lsp" - 'compile-file-test-fun.1 - :output-file "foo.ufsl") - t nil) - -(deftest compile-file.7 - (compile-file-test "compile-file-test-file.lsp" - 'compile-file-test-fun.1 - :external-format :default) - t nil) - -(deftest compile-file.8 - (compile-file-test "compile-file-test-file.lsp" - 'compile-file-test-fun.1 - :output-file #p"foo.fasl") - t nil) - -(deftest compile-file.9 - (compile-file-test "compile-file-test-file.lsp" - 'compile-file-test-fun.1 - :print t) - t nil) - -(deftest compile-file.10 - (compile-file-test "compile-file-test-file.lsp" - 'compile-file-test-fun.1 - :verbose t) - t nil) - -(deftest compile-file.11 - (compile-file-test "compile-file-test-file.lsp" - 'compile-file-test-fun.1 - :print nil) - t nil) - -(deftest compile-file.12 - (compile-file-test "compile-file-test-file.lsp" - 'compile-file-test-fun.1 - :verbose nil) - t nil) - -;;; A file stream is a pathname designator -(deftest compile-file.13 - (with-open-file (s "compile-file-test-file.lsp" :direction :input) - (compile-file-test s 'compile-file-test-fun.1)) - t nil) - -(deftest compile-file.14 - (let ((s (open "foo.fasl" :direction :output :if-exists :supersede - :if-does-not-exist :create))) - (close s) - (compile-file-test "compile-file-test-file.lsp" - 'compile-file-test-fun.1 - :output-file s)) - t nil) - -(deftest compile-file.15 - (let ((*readtable* (copy-readtable nil))) - (set-macro-character #\! (get-macro-character #\')) - (compile-file-test "compile-file-test-file-4.lsp" - 'compile-file-test-fun.4)) t foo) - -;;; Tests for *compile-file-truename*, *compile-file-pathname* - -(deftest compile-file.16 - (let* ((file #p"compile-file-test-file-5.lsp") - (target-pathname (compile-file-pathname file)) - (*compile-print* nil) - (*compile-verbose* nil)) - (when (probe-file target-pathname) - (delete-file target-pathname)) - (compile-file file) - (load target-pathname) - (values - (equalpt-or-report (truename file) (funcall 'compile-file-test-fun.5)) - (equalpt-or-report (pathname (merge-pathnames file)) - (funcall 'compile-file-test-fun.5a)))) - t t) - -;;; Add tests of logical pathnames - -(deftest compile-file.17 - (let ((file (logical-pathname "CLTEST:COMPILE-FILE-TEST-LP.LSP"))) - (with-open-file - (s file :direction :output :if-exists :supersede :if-does-not-exist :create) - (format s "(in-package :cl-test)~%(defun compile-file-test-lp.fun () nil)~%")) - (compile-file-test file 'compile-file-test-lp.fun)) - t nil) - -(deftest compile-file.18 - (let ((file (logical-pathname "CLTEST:COMPILE-FILE-TEST-LP.OUT"))) - (with-open-file - (s file :direction :output :if-exists :supersede :if-does-not-exist :create)) - (compile-file-test "compile-file-test-file.lsp" - 'compile-file-test-fun.1 - :output-file file)) - t nil) - -(deftest compile-file.19 - (compile-file-test "compile-file-test-file.lsp" - 'compile-file-test-fun.1 - :*compile-verbose* t) - t nil) - -(deftest compile-file.20 - (compile-file-test "compile-file-test-file.lsp" - 'compile-file-test-fun.1 - :*compile-print* t) - t nil) - -(deftest compile-file-pathname.1 - *compile-file-pathname* - nil) - -(deftest compile-file-truename.1 - *compile-file-truename* - nil) - -;;; Error cases - -(deftest compile-file.error.1 - (signals-error (compile-file "nonexistent-file-to-compile.lsp") - file-error) t) - -(deftest compile-file.error.2 - (signals-error (compile-file) program-error) - t) - - - - diff --git a/t/ansi-test/system-construction/features.lsp b/t/ansi-test/system-construction/features.lsp deleted file mode 100644 index 2862afe..0000000 --- a/t/ansi-test/system-construction/features.lsp +++ /dev/null @@ -1,26 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon Dec 2 07:44:40 2002 -;;;; Contains: Tests of *FEATURES* - -(in-package :cl-test) - -(deftest features.1 - (let ((f *features*)) - (or (not (member :draft-ansi-cl f)) - (not (intersection '(:draft-ansi-cl-2 :ansi-cl) f)))) - t) - -(deftest features.2 - (let ((f *features*)) - (or (not (intersection '(:x3j13 :draft-ansi-cl :ansi-cl) f)) - (notnot (member :common-lisp f)))) - t) - -(deftest features.3 - (not (member :cltl2 *features*)) - t) - -(deftest features.4 - (notnot (every #'symbolp *features*)) - t) diff --git a/t/ansi-test/system-construction/load-file.lsp b/t/ansi-test/system-construction/load-file.lsp deleted file mode 100644 index f017a88..0000000 --- a/t/ansi-test/system-construction/load-file.lsp +++ /dev/null @@ -1,232 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Apr 12 21:51:49 2005 -;;;; Contains: Tests of LOAD - -(defun load-file-test (file funname &rest args &key - if-does-not-exist - (print nil print-p) - (verbose nil verbose-p) - (*load-print* nil) - (*load-verbose* nil) - external-format) - (declare (ignorable external-format if-does-not-exist - print print-p verbose verbose-p)) - (fmakunbound funname) - (let* ((str (make-array '(0) :element-type 'character :adjustable t - :fill-pointer 0)) - (vals (multiple-value-list - (with-output-to-string - (*standard-output* str) - (apply #'load file :allow-other-keys t args)))) - (print? (if print-p print *load-print*)) - (verbose? (if verbose-p verbose *load-verbose*))) - (values - (let ((v1 (car vals)) - (v2 (or (and verbose-p (not verbose)) - (and (not verbose-p) (not *load-verbose*)) - (position #\; str))) - (v3 (or (and print-p (not print)) - (and (not print-p) (not *load-print*)) - (> (length str) 0))) - (v4 (if (or print? verbose?) - (> (length str) 0) - t))) - (if (and (= (length vals) 1) v1 v2 v3 v4) t (list vals v2 v3 v4 str))) - (funcall funname)))) - -(deftest load.1 - (load-file-test "compile-file-test-file.lsp" - 'compile-file-test-fun.1) t nil) - -(deftest load.2 - (load-file-test #p"compile-file-test-file.lsp" - 'compile-file-test-fun.1) t nil) - -(deftest load.3 - (with-input-from-string - (s "(in-package :cl-test) (defun load-file-test-fun.2 () 'good)") - (load-file-test s 'load-file-test-fun.2)) - t good) - -(deftest load.4 - (load-file-test "compile-file-test-file.lsp" - 'compile-file-test-fun.1 - :external-format :default) - t nil) - -(deftest load.5 - (load-file-test "compile-file-test-file.lsp" - 'compile-file-test-fun.1 - :verbose t) - t nil) - -(deftest load.6 - (load-file-test "compile-file-test-file.lsp" - 'compile-file-test-fun.1 - :*load-verbose* t) - t nil) - -(deftest load.7 - (load-file-test "compile-file-test-file.lsp" - 'compile-file-test-fun.1 - :*load-verbose* t :verbose nil) - t nil) - -(deftest load.8 - (with-input-from-string - (s "(in-package :cl-test) (defun load-file-test-fun.2 () 'good)") - (load-file-test s 'load-file-test-fun.2 :verbose t)) - t good) - -(deftest load.9 - (load-file-test "compile-file-test-file.lsp" - 'compile-file-test-fun.1 - :print t) - t nil) - -(deftest load.10 - (load-file-test "compile-file-test-file.lsp" - 'compile-file-test-fun.1 - :*load-print* t) - t nil) - -(deftest load.11 - (load-file-test "compile-file-test-file.lsp" - 'compile-file-test-fun.1 - :*load-print* t :print nil) - t nil) - -(deftest load.12 - (load-file-test "compile-file-test-file.lsp" - 'compile-file-test-fun.1 - :*load-print* nil :print t) - t nil) - -(deftest load.13 - (with-input-from-string - (s "(in-package :cl-test) (defun load-file-test-fun.2 () 'good)") - (load-file-test s 'load-file-test-fun.2 :print t)) - t good) - -(deftest load.14 - (load "nonexistent-file.lsp" :if-does-not-exist nil) - nil) - -(defpackage LOAD-TEST-PACKAGE (:use "COMMON-LISP")) - -(deftest load.15 - (let ((*package* (find-package "LOAD-TEST-PACKAGE"))) - (with-input-from-string - (s "(defun f () 'good)") - (load-file-test s 'load-test-package::f))) - t load-test-package::good) - -(deftest load.15a - (let ((*package* (find-package "CL-TEST"))) - (values - (with-input-from-string - (s "(eval-when (:load-toplevel :execute) (setq *package* (find-package \"LOAD-TEST-PACKAGE\"))) - (defun f () 'good)") - (multiple-value-list (load-file-test s 'load-test-package::f))) - (read-from-string "GOOD"))) - (t load-test-package::good) good) - -(deftest load.16 - (let ((*readtable* (copy-readtable nil))) - (set-macro-character #\! (get-macro-character #\')) - (with-input-from-string - (s "(in-package :cl-test) (defun load-file-test-fun.3 () !good)") - (load-file-test s 'load-file-test-fun.3))) - t good) - -(deftest load.16a - (let ((*readtable* *readtable*) - (*package* (find-package "CL-TEST"))) - (values - (with-input-from-string - (s "(in-package :cl-test) - (eval-when (:load-toplevel :execute) - (setq *readtable* (copy-readtable nil)) - (set-macro-character #\\! (get-macro-character #\\'))) - (defun load-file-test-fun.3 () !good)") - (multiple-value-list - (load-file-test s 'load-file-test-fun.3))) - (read-from-string "!FOO"))) - (t good) !FOO) - -(deftest load.17 - (let ((file #p"load-test-file.lsp")) - (fmakunbound 'load-file-test-fun.1) - (fmakunbound 'load-file-test-fun.2) - (values - (notnot (load file)) - (let ((p1 (pathname (merge-pathnames file))) - (p2 (funcall 'load-file-test-fun.1))) - (equalpt-or-report p1 p2)) - (let ((p1 (truename file)) - (p2 (funcall 'load-file-test-fun.2))) - (equalpt-or-report p1 p2)))) - t t t) - -;;; Test that the load pathname/truename variables are bound -;;; properly when loading compiled files - -(deftest load.18 - (let* ((file "load-test-file-2.lsp") - (target (enough-namestring (compile-file-pathname file)))) - (declare (special *load-test-var.1* *load-test-var.2*)) - (compile-file file) - (makunbound '*load-test-var.1*) - (makunbound '*load-test-var.2*) - (load target) - (values - (let ((p1 (pathname (merge-pathnames target))) - (p2 *load-test-var.1*)) - (equalpt-or-report p1 p2)) - (let ((p1 (truename target)) - (p2 *load-test-var.2*)) - (equalpt-or-report p1 p2)))) - t t) - -(deftest load.19 - (let ((file (logical-pathname "CLTEST:LDTEST.LSP")) - (fn 'load-test-fun-3) - (*package* (find-package "CL-TEST"))) - (with-open-file - (s file :direction :output :if-exists :supersede - :if-does-not-exist :create) - (format s "(in-package :cl-test) (defun ~a () :foo)" fn)) - (fmakunbound fn) - (values - (notnot (load file)) - (funcall fn))) - t :foo) - -;;; Defaults of the load variables - -(deftest load-pathname.1 - *load-pathname* - nil) - -(deftest load-truename.1 - *load-truename* - nil) - -(deftest load-print.1 - *load-print* - nil) - -;;; Error tests - -(deftest load.error.1 - (signals-error (load "nonexistent-file.lsp") - file-error) t) - -(deftest load.error.2 - (signals-error (load) program-error) - t) - -(deftest load.error.3 - (signals-error (load "compile-file-test-file.lsp" :bad-key-arg - t) program-error) t) diff --git a/t/ansi-test/system-construction/load.lsp b/t/ansi-test/system-construction/load.lsp deleted file mode 100644 index cbc5fc9..0000000 --- a/t/ansi-test/system-construction/load.lsp +++ /dev/null @@ -1,15 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Dec 12 19:44:29 2004 -;;;; Contains: Load tests for system construction (section 24) - -(in-package :cl-test) - -(let ((*default-pathname-defaults* - (make-pathname - :directory (pathname-directory *load-pathname*)))) - (load "compile-file.lsp") - (load "load-file.lsp") - (load "with-compilation-unit.lsp") - (load "features.lsp") - (load "modules.lsp")) diff --git a/t/ansi-test/system-construction/modules.lsp b/t/ansi-test/system-construction/modules.lsp deleted file mode 100644 index 4fb6bee..0000000 --- a/t/ansi-test/system-construction/modules.lsp +++ /dev/null @@ -1,95 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 30 19:51:06 2005 -;;;; Contains: Tests of *MODULES*, PROVIDE, and REQUIRE - -(in-package :cl-test) - -(deftest modules.1 - (notnot (every #'stringp *modules*)) - t) - -(deftest modules.2 - (let ((*modules* *modules*)) - (provide "FOO") - (notnot (member "FOO" *modules* :test #'string=))) - t) - -(deftest modules.3 - (let ((*modules* *modules*)) - (provide "FOO") - (provide "FOO") - (count "FOO" *modules* :test #'string=)) - 1) - -(deftest modules.4 - (let ((*modules* *modules*)) - (provide "FOO") - (require "FOO") - (values))) - -(deftest modules.5 - (let ((*modules* *modules*)) - (provide :|FOO|) - (notnot (member "FOO" *modules* :test #'string=))) - t) - -(deftest modules.6 - (let ((*modules* *modules*)) - (provide "FOO") - (require :|FOO|) - (values))) - -(deftest modules.7 - (let ((*modules* *modules*) - (fn 'modules7-fun)) - (when (fboundp fn) (fmakunbound fn)) - (require "MODULES-7" #p"modules7.lsp") - (funcall fn)) - :good) - -(deftest modules.8 - (let ((*modules* *modules*) - (fns '(modules8a-fun modules8b-fun))) - (dolist (fn fns) - (when (fboundp fn) (fmakunbound fn))) - (require "MODULES-8" '(#p"modules8a.lsp" - #p"modules8b.lsp")) - (mapcar #'funcall fns)) - (:good :also-good)) - -(deftest modules.9 - (signals-error (require "AB7djaCgaaL") error) - t) - -(deftest modules.10 - (do-special-strings - (s "FOO") - (let ((*modules* *modules*)) - (provide s) - (assert (member "FOO" *modules* :test #'string=)))) - nil) - -(deftest modules.11 - (do-special-strings - (s "FOO") - (let ((*modules* *modules*)) - (provide "FOO") - (require s) - (values))) - nil) - -(deftest modules.12 - (unless (member "Z" *modules* :test #'string=) - (let ((*modules* *modules*)) - (provide #\Z) - (not (member "Z" *modules* :test #'string=)))) - nil) - -(deftest modules.13 - (unless (member "Z" *modules* :test #'string=) - (let ((*modules* *modules*)) - (provide "Z") - (require #\Z) - nil)) - nil) diff --git a/t/ansi-test/system-construction/with-compilation-unit.lsp b/t/ansi-test/system-construction/with-compilation-unit.lsp deleted file mode 100644 index fdc19bd..0000000 --- a/t/ansi-test/system-construction/with-compilation-unit.lsp +++ /dev/null @@ -1,49 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Apr 30 07:36:26 2005 -;;;; Contains: Tests of WITH-COMPILATION-UNIT - -;;; WITH-COMPILATION-UNIT doesn't have much in the way of standardized -;;; semantics, so there's not much to test. - -(in-package :cl-test) - -(deftest with-compilation-unit.1 - (with-compilation-unit ()) - nil) - -(deftest with-compilation-unit.2 - (with-compilation-unit () t) - t) - -(deftest with-compilation-unit.3 - (with-compilation-unit () (values))) - -(deftest with-compilation-unit.4 - (with-compilation-unit () (values 1 2 3 4 5)) - 1 2 3 4 5) - -(deftest with-compilation-unit.5 - (with-compilation-unit (:override nil) :foo) - :foo) - -(deftest with-compilation-unit.6 - (with-compilation-unit (:override t) (values 10 17)) - 10 17) - -(deftest with-compilation-unit.7 - (let ((x nil)) - (values - (block done - (with-compilation-unit - (:override nil) - (setq x 1) - (return-from done 2) - (setq x 2))) - x)) - 2 1) - -;;; Add a test that (1) checks if the compiler normally delays -;;; warnings until the end of a file and, if so, (2) checks that -;;; with-compilation-unit delays the warnings for more than one -;;; file compilation until the end of the unit. diff --git a/t/ansi-test/types-and-classes/class-precedence-lists.lsp b/t/ansi-test/types-and-classes/class-precedence-lists.lsp deleted file mode 100644 index 96a728a..0000000 --- a/t/ansi-test/types-and-classes/class-precedence-lists.lsp +++ /dev/null @@ -1,174 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Jun 4 20:18:29 2003 -;;;; Contains: Tests that builtin classes have the right CPLs - -(in-package :cl-test) - -(eval-when (:load-toplevel :compile-toplevel :execute) - (unless #| (fboundp 'class-precedence-list-foo) |# nil - (report-and-ignore-errors - (defgeneric class-precedence-list-foo (x) - (:method-combination list) - . - #.(loop for s in *cl-types-that-are-classes-symbols* - collect - `(:method list ((x ,s)) ',s)))))) - -(defmacro def-cpl-test (objform expected-cpl &optional name) - (let* ((ordered (loop for e = expected-cpl then (cdr e) - for x = (car e) - for y = (cadr e) - while y - always (subtypep x y)))) - `(deftest ,(or name - (intern (concatenate 'string - (symbol-name (first expected-cpl)) - "-CPL") - :cl-test)) - (let* ((obj ,objform) - (cpl (class-precedence-list-foo obj))) - (or ,(if ordered - nil - `(and (not (eql (class-of obj) (find-class ',(first expected-cpl)))) - (progn (format t "~%Note: ~S not a direct instance of ~A~%" - ',objform ',(first expected-cpl)) - t))) - (and ,(if ordered t `(eql (first cpl) ',(first expected-cpl))) - (is-noncontiguous-sublist-of ',expected-cpl cpl)))) - t))) - -;;; Condition types - -(defmacro def-cond-cpl-test (expected-cpl) - `(def-cpl-test (make-condition ',(first expected-cpl)) ,expected-cpl)) - -(def-cond-cpl-test (arithmetic-error error serious-condition condition t)) -(def-cond-cpl-test (cell-error error serious-condition condition t)) -(def-cond-cpl-test (condition t)) -(def-cond-cpl-test (control-error error serious-condition condition t)) -(def-cond-cpl-test (division-by-zero arithmetic-error error - serious-condition condition t)) -(def-cond-cpl-test (end-of-file stream-error error serious-condition condition t)) -(def-cond-cpl-test (error serious-condition condition t)) -(def-cond-cpl-test (file-error error serious-condition condition t)) -(def-cond-cpl-test (floating-point-inexact arithmetic-error error - serious-condition condition t)) -(def-cond-cpl-test (floating-point-invalid-operation - arithmetic-error error serious-condition condition t)) -(def-cond-cpl-test (floating-point-overflow arithmetic-error error - serious-condition condition t)) -(def-cond-cpl-test (floating-point-underflow arithmetic-error error - serious-condition condition t)) -(def-cond-cpl-test (package-error error serious-condition condition t)) -(def-cond-cpl-test (parse-error error serious-condition condition t)) -(def-cond-cpl-test (print-not-readable error serious-condition condition t)) -(def-cond-cpl-test (program-error error serious-condition condition t)) -(def-cond-cpl-test (reader-error parse-error stream-error - error serious-condition condition t)) -(def-cond-cpl-test (serious-condition condition t)) -(def-cond-cpl-test (simple-condition condition t)) -(def-cond-cpl-test (simple-error simple-condition error serious-condition - condition t)) -(def-cond-cpl-test (simple-type-error simple-condition type-error - error serious-condition condition t)) -(def-cond-cpl-test (simple-warning simple-condition warning condition t)) -(def-cond-cpl-test (storage-condition serious-condition condition t)) -(def-cond-cpl-test (stream-error error serious-condition condition t)) -(def-cond-cpl-test (style-warning warning condition t)) -(def-cond-cpl-test (type-error error serious-condition condition t)) -(def-cond-cpl-test (unbound-slot cell-error error serious-condition condition t)) -(def-cond-cpl-test (unbound-variable cell-error error serious-condition condition t)) -(def-cond-cpl-test (undefined-function cell-error error serious-condition condition t)) -(def-cond-cpl-test (warning condition t)) - -(def-cpl-test (make-array '(2 3 4)) (array t)) -(def-cpl-test (make-array '(10) :element-type 'bit :adjustable t :fill-pointer 5) - (bit-vector vector array sequence t)) -(def-cpl-test (make-broadcast-stream) (broadcast-stream stream t)) -(def-cpl-test (class-of 'symbol) (built-in-class class standard-object t)) -(def-cpl-test #\a (character t) character-cpl.1) -(def-cpl-test #c(1.0 2.0) (complex number t) complex-cpl.1) -(def-cpl-test #c(1 2) (complex number t) complex-cpl.2) -(def-cpl-test #c(1/2 2/3) (complex number t) complex-cpl.3) -(def-cpl-test (make-concatenated-stream) (concatenated-stream stream t)) -(def-cpl-test '(a b c) (cons list sequence t)) -(def-cpl-test (let ((out (make-string-output-stream))) - (make-echo-stream (make-string-input-stream "foo") out)) - (echo-stream stream t)) - -(def-cpl-test (open "class-precedence-lists.txt" :direction :probe) - (file-stream stream t)) - -(def-cpl-test 1.0s0 (float real number t) float-cpl.1) -(def-cpl-test 1.0f0 (float real number t) float-cpl.2) -(def-cpl-test 1.0d0 (float real number t) float-cpl.3) -(def-cpl-test 1.0l0 (float real number t) float-cpl.4) - -(def-cpl-test #'car (function t)) -;; (def-cpl-test #'make-instance (generic-function function t)) - -(def-cpl-test (make-hash-table) (hash-table t) hash-table-cpl.1) -(def-cpl-test (make-hash-table :test 'eq) (hash-table t) hash-table-cpl.2) -(def-cpl-test (make-hash-table :test 'equal) (hash-table t) hash-table-cpl.3) - -(def-cpl-test 0 (integer rational real number t) integer-cpl.1) -(def-cpl-test (1+ most-positive-fixnum) (integer rational real number t) integer-cpl.2) -(def-cpl-test (1- most-negative-fixnum) (integer rational real number t) integer-cpl.3) - -(def-cpl-test nil (list sequence t) list-cpl.1) -(def-cpl-test '(a b c) (list sequence t) list-cpl.2) - -;;; Insert a test for LOGICAL-PATHNAME here -;;; (def-cpl-test ????? (logical-pathname pathname t)) - -;;; (def-cpl-test (find-method #'class-name nil (list (find-class 'class))) -;;; (method t)) - -;;; Insert test for METHOD-COMBINATION here - -(def-cpl-test nil (null symbol list sequence t)) - -(def-cpl-test (find-package "CL") (package t)) -(def-cpl-test #p"foo" (pathname t)) -(def-cpl-test *random-state* (random-state t)) -(def-cpl-test 5/3 (ratio rational real number t)) -(def-cpl-test *readtable* (readtable t)) - -(defclass cpl-example-class () ()) - -(def-cpl-test (find-class 'cpl-example-class) - (standard-class class standard-object t)) - -(defgeneric cpl-example-gf (x y)) - -(def-cpl-test #'cpl-example-gf (standard-generic-function generic-function function t)) - -(def-cpl-test (eval '(defmethod cpl-example-gf ((x t) (y t)) (list y x))) - (standard-method method standard-object t)) - -(def-cpl-test (make-array '(10) :element-type 'character :initial-element #\a - :fill-pointer t :adjustable t) - (string vector array sequence t) string-cpl.1) - -(def-cpl-test "abcd" (string vector array sequence t) string-cpl.2) - -(def-cpl-test (make-string-input-stream "abcdef") (string-stream stream t)) - -(defstruct cpl-example-structure-class a b c) - -;;; No test for STRUCTURE-OBJECT - -(def-cpl-test 'a (symbol t)) - -(defparameter *cpl-input-stream* (make-string-input-stream "foofoofoofoo")) - -(def-cpl-test (make-synonym-stream '*cpl-input-stream*) (synonym-stream stream t)) - -(defparameter *cpl-output-stream* (make-string-output-stream)) - -(def-cpl-test (make-two-way-stream *cpl-input-stream* *cpl-output-stream*) - (two-way-stream stream t)) - -(def-cpl-test (make-array '(10) :fill-pointer t :adjustable t :initial-element '(a b c)) - (vector array sequence t)) diff --git a/t/ansi-test/types-and-classes/coerce.lsp b/t/ansi-test/types-and-classes/coerce.lsp deleted file mode 100644 index 2cfa58f..0000000 --- a/t/ansi-test/types-and-classes/coerce.lsp +++ /dev/null @@ -1,207 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Fri Dec 13 20:48:04 2002 -;;;; Contains: Tests for COERCE - -(in-package :cl-test) - -(deftest coerce.1 - (check-predicate #'(lambda (x) - (let ((type (type-of x))) - (or (and (consp type) (eqt (car type) 'function)) - (eql (coerce x type) x))))) - nil) - -(deftest coerce.2 - (check-predicate #'(lambda (x) (eql (coerce x t) x))) - nil) - -(deftest coerce.3 - (check-predicate - #'(lambda (x) - (let ((class (class-of x))) - (eql (coerce x class) x)))) - nil) - -(deftest coerce.4 - (loop for x in '(() #() #*) - never (coerce x 'list)) - t) - -(deftest coerce.5 - (loop for x in '((1 0) #(1 0) #*10) - always (equal (coerce x 'list) '(1 0))) - t) - -(deftest coerce.6 - (loop for x in '(() #() #*) - always (equalp (coerce x 'vector) #())) - t) - -(deftest coerce.7 - (loop for x in '((1 0) #(1 0) #*10) - for y = (coerce x 'vector) - always (and (equalp y #(1 0)) - (vectorp y))) - t) - -(deftest coerce.8 - (loop for x in '((1 0) #(1 0) #*10) - for y = (coerce x '(vector *)) - always (and (equalp y #(1 0)) - (vectorp y))) - t) - -(deftest coerce.9 - (loop for x in '((1 0) #(1 0) #*10) - for y = (coerce x '(vector * 2)) - always (and (equalp y #(1 0)) - (vectorp y))) - t) - -(deftest coerce.10 - (values (coerce #\A 'character) - (coerce '|A| 'character) - (coerce "A" 'character)) - #\A #\A #\A) - -(deftest coerce.11 - (loop with class = (find-class 'vector) - for x in '((1 0) #(1 0) #*10) - for y = (coerce x class) - always (and (equalp y #(1 0)) - (vectorp y))) - t) - -(deftest coerce.12 - (loop for x in '((1 0) #(1 0) #*10) - for y = (coerce x 'bit-vector) - always (and (equalp y #*10) - (bit-vector-p y))) - t) - -(deftest coerce.13 - (loop for x in '((#\a #\b #\c) "abc") - for y = (coerce x 'string) - always (and (stringp y) - (string= y "abc"))) - t) - -(deftest coerce.14 - (loop for x in '((#\a #\b #\c) "abc") - for y = (coerce x 'simple-string) - always (and (typep y 'simple-string) - (string= y "abc"))) - t) - -(deftest coerce.15 - (loop for x in '((1 0) #(1 0) #*10) - for y = (coerce x 'simple-vector) - always (and (equalp y #(1 0)) - (simple-vector-p y))) - t) - -(deftest coerce.16 - (coerce 0 'integer) - 0) - -(deftest coerce.17 - (coerce 0 'complex) - 0) - -(deftest coerce.18 - (coerce 3 'complex) - 3) - -(deftest coerce.19 - (coerce 5/3 'complex) - 5/3) - -(deftest coerce.20 - (coerce 1.0 'complex) - #c(1.0 0.0)) - -(deftest coerce.21 - (eqt (symbol-function 'car) - (coerce 'car 'function)) - t) - -(deftest coerce.22 - (funcall (coerce '(lambda () 10) 'function)) - 10) - -(deftest coerce.order.1 - (let ((i 0) a b) - (values - (coerce (progn (setf a (incf i)) 10) - (progn (setf b (incf i)) 'single-float)) - i a b)) - 10.0f0 2 1 2) - -;;; Constant folding test -;;; If the coerce call is folded to a constant, this will fail -;;; when that constant is modified. - -(def-fold-test coerce.fold.1 (coerce '(1 2 3) 'vector)) -(def-fold-test coerce.fold.2 (coerce '(1 0 1) 'bit-vector)) -(def-fold-test coerce.fold.3 (coerce '(#\a #\b #\c) 'string)) - -;;; Error tests - -;;; (deftest coerce.error.1 -;;; (signals-error (coerce -1 '(integer 0 100)) type-error) -;;; t) - -(deftest coerce.error.2 - (signals-error (coerce '(a b c) '(vector * 2)) type-error) - t) - -(deftest coerce.error.3 - (signals-error (coerce '(a b c) '(vector * 4)) type-error) - t) - -(deftest coerce.error.4 - (signals-error (coerce nil 'cons) type-error) - t) - -(deftest coerce.error.5 - (handler-case - (eval '(coerce 'not-a-bound-function 'function)) - (error () :caught)) - :caught) - -(deftest coerce.error.6 - (signals-error (coerce) program-error) - t) - -(deftest coerce.error.7 - (signals-error (coerce t) program-error) - t) - -(deftest coerce.error.8 - (signals-error (coerce 'x t 'foo) program-error) - t) - -(deftest coerce.error.9 - (signals-error (locally (coerce nil 'cons) t) type-error) - t) - -(deftest coerce.error.10 - :notes (:result-type-element-type-by-subtype) - (let* ((tp1 '(vector character)) - (tp2 `(vector t)) - (tp3 `(or ,tp1 ,tp2))) - (if (not (subtypep tp3 'vector)) - t - (handler-case - (eval `(coerce '(#\a #\b #\c) ',tp3)) - (type-error (c) - (cond - ((typep (type-error-datum c) - (type-error-expected-type c)) - `((typep ',(type-error-datum c) - ',(type-error-expected-type c)) - "==>" true)) - (t t))) - (error (c) (declare (ignore c)) t)))) - t) diff --git a/t/ansi-test/types-and-classes/deftype.lsp b/t/ansi-test/types-and-classes/deftype.lsp deleted file mode 100644 index 43b555f..0000000 --- a/t/ansi-test/types-and-classes/deftype.lsp +++ /dev/null @@ -1,249 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Apr 20 12:56:56 2003 -;;;; Contains: Tests of DEFTYPE - -(in-package :cl-test) - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; deftype - -(deftest deftype.1 - (typep 1 '(even-array integer (10))) - nil) - -(deftest deftype.2 - (typep nil '(even-array t (*))) - nil) - -(deftest deftype.3 - (notnot-mv (typep (make-array '(10)) '(even-array t (*)))) - t) - -(deftest deftype.4 - (typep (make-array '(5)) '(even-array t (*))) - nil) - -(deftest deftype.5 - (notnot-mv (typep (make-string 10) '(even-array character (*)))) - t) - -(deftest deftype.6 - (notnot-mv - (typep (make-array '(3 5 6) :element-type '(unsigned-byte 8)) - '(even-array (unsigned-byte 8)))) - t) - -(deftest deftype.7 - (let ((sym (gensym))) - (assert (eq (eval `(deftype ,sym () '(integer 0 10))) sym)) - (documentation sym 'type)) - nil) - -(deftest deftype.8 - (let ((sym (gensym))) - (assert (eq (eval `(deftype ,sym () "FOO" '(integer 0 10))) sym)) - (or (documentation sym 'type) "FOO")) - "FOO") - -(deftest deftype.9 - (let* ((sym (gensym)) - (form `(deftype ,sym (&optional x) `(integer 0 ,x)))) - (values - (eqlt (eval form) sym) - (multiple-value-list (subtypep* `(,sym) 'unsigned-byte)) - (multiple-value-list (subtypep* 'unsigned-byte `(,sym))) - (multiple-value-list (subtypep* `(,sym 4) '(integer 0 4))) - (multiple-value-list (subtypep* '(integer 0 4) `(,sym 4))) - (loop for x in '(a -1 0 1 2 3 4 5 b) - collect (notnot (typep x sym))) - (loop for x in '(a -1 0 1 2 3 4 5 b) - collect (notnot (typep x `(,sym 4)))) - )) - t (t t) (t t) (t t) (t t) - (nil nil t t t t t t nil) - (nil nil t t t t t nil nil)) - -(deftest deftype.10 - (let* ((sym (gensym)) - (form `(deftype ,sym (&optional (x 14)) `(integer 0 ,x)))) - (values - (eqlt (eval form) sym) - (multiple-value-list (subtypep* `(,sym) '(integer 0 14))) - (multiple-value-list (subtypep* '(integer 0 14) `(,sym))) - (multiple-value-list (subtypep* `(,sym 4) '(integer 0 4))) - (multiple-value-list (subtypep* '(integer 0 4) `(,sym 4))) - (loop for x in '(a -1 0 1 2 3 4 5 14 15 b) - collect (notnot (typep x sym))) - (loop for x in '(a -1 0 1 2 3 4 5 14 15 b) - collect (notnot (typep x `(,sym 4)))) - )) - t (t t) (t t) (t t) (t t) - (nil nil t t t t t t t nil nil) - (nil nil t t t t t nil nil nil nil)) - -(deftest deftype.11 - (let* ((sym (gensym)) - (form `(deftype ,sym (&key foo bar) `(integer ,foo ,bar)))) - (values - (eqlt (eval form) sym) - (multiple-value-list (subtypep* `(,sym) 'integer)) - (multiple-value-list (subtypep* 'integer `(,sym))) - - (multiple-value-list (subtypep* `(,sym :allow-other-keys nil) 'integer)) - (multiple-value-list (subtypep* 'integer `(,sym :allow-other-keys nil))) - (multiple-value-list (subtypep* `(,sym :xyz 17 :allow-other-keys t) 'integer)) - (multiple-value-list (subtypep* 'integer `(,sym :allow-other-keys t abc nil))) - - (multiple-value-list (subtypep* `(,sym :foo 3) '(integer 3))) - (multiple-value-list (subtypep* '(integer 3) `(,sym :foo 3))) - (multiple-value-list (subtypep* `(,sym :bar 10) '(integer * 10))) - (multiple-value-list (subtypep* '(integer * 10) `(,sym :bar 10))) - - (multiple-value-list (subtypep* `(,sym :foo 3 :foo 4 :bar 6) '(integer 3 6))) - (multiple-value-list (subtypep* '(integer 3 6) `(,sym :foo 3 :foo 4 :bar 6))) - (multiple-value-list (subtypep* `(,sym :bar * :foo (1)) '(integer 2))) - (multiple-value-list (subtypep* '(integer 2) `(,sym :bar * :foo (1)))) - )) - t - (t t) (t t) - (t t) (t t) (t t) (t t) - (t t) (t t) (t t) (t t) - (t t) (t t) (t t) (t t) - ) - -(deftest deftype.12 - (let* ((sym (gensym)) - (form `(deftype ,sym (&key foo bar &allow-other-keys) `(integer ,foo ,bar)))) - (values - (eqlt (eval form) sym) - (multiple-value-list (subtypep* `(,sym :xyz t) 'integer)) - (multiple-value-list (subtypep* 'integer `(,sym :xyz t))) - - (multiple-value-list (subtypep* `(,sym :allow-other-keys nil abc t) 'integer)) - (multiple-value-list (subtypep* 'integer `(,sym :allow-other-keys nil abc t))) - (multiple-value-list (subtypep* `(,sym :foo -10 :bar 20) '(integer -10 20))) - (multiple-value-list (subtypep* '(integer -10 20) `(,sym :foo -10 :bar 20))) - )) - t - (t t) (t t) - (t t) (t t) (t t) (t t) - ) - -(deftest deftype.13 - (let* ((sym (gensym)) - (form `(deftype ,sym (&rest args) (if args `(member ,@args) nil)))) - (values - (eqlt (eval form) sym) -;; (multiple-value-list (subtypep* sym nil)) -;; (multiple-value-list (subtypep* nil sym)) - (multiple-value-list (subtypep* `(,sym) nil)) - (multiple-value-list (subtypep* nil `(,sym))) - (notnot (typep 'a `(,sym a))) - (notnot (typep 'b `(,sym a))) - (notnot (typep '* `(,sym a))) - (notnot (typep 'a `(,sym a b))) - (notnot (typep 'b `(,sym a b))) - (notnot (typep 'c `(,sym a b))))) - t - (t t) (t t) - t nil nil t t nil) - -;;; I've removed this test, because EVAL can cause implicit compilation, -;;; and the semantic constraints on compilation forbid redefinition of -;;; of the types produced by DEFTYPE at runtime. -#| -(deftest deftype.14 - (let* ((sym (gensym)) - (*f* nil) - (form `(let ((x 1)) - (declare (special *f*)) - (setf *f* #'(lambda (y) (setf x y))) - (deftype ,sym () `(integer 0 ,x))))) - (declare (special *f*)) - (values - (eqlt (eval form) sym) - (loop for i from -1 to 3 collect (typep* i sym)) - (funcall *f* 2) - (loop for i from -1 to 3 collect (typep* i sym)))) - t (nil t t nil nil) 2 (nil t t t nil)) -|# - -(deftest deftype.15 - (let* ((sym (gensym)) - (form `(let ((a 1)) - (deftype ,sym (&optional (x a)) - (declare (special a)) - `(integer 0 ,x))))) - (values - (eqlt (eval form) sym) - (let ((a 2)) - (declare (special a)) - (loop for i from -1 to 3 collect (typep* i `(,sym 1)))) - (let ((a 2)) - (declare (special a)) - (loop for i from -1 to 3 collect (typep* i sym))))) - t - (nil t t nil nil) - (nil t t nil nil)) - -(deftest deftype.16 - (let* ((sym (gensym)) - (form `(deftype ,sym () (return-from ,sym 'integer)))) - (values - (eqlt (eval form) sym) - (subtypep* sym 'integer) - (subtypep* 'integer sym))) - t t t) - -(deftest deftype.17 - (let* ((sym (gensym)) - (form `(deftype ,sym () (values 'integer t)))) - (values - (eqlt (eval form) sym) - (subtypep* sym 'integer) - (subtypep* 'integer sym))) - t t t) - -(deftest deftype.18 - (let* ((sym (gensym)) - (form `(deftype ,sym ()))) - (values - (eqlt (eval form) sym) - (subtypep* sym nil) - (subtypep* nil sym))) - t t t) - -(deftest deftype.19 - (let* ((sym (gensym)) - (form `(deftype ,sym () - (declare (optimize speed safety debug compilation-speed space)) - 'integer))) - (values - (eqlt (eval form) sym) - (subtypep* sym 'integer) - (subtypep* 'integer sym))) - t t t) - -;;; Error tests - -(deftest deftype.error.1 - (signals-error (funcall (macro-function 'deftype)) - program-error) - t) - -(deftest deftype.error.2 - (signals-error (funcall (macro-function 'deftype) - '(deftype nonexistent-type () nil)) - program-error) - t) - -(deftest deftype.error.3 - (signals-error (funcall (macro-function 'deftype) - '(deftype nonexistent-type () nil) - nil nil) - program-error) - t) - diff --git a/t/ansi-test/types-and-classes/load.lsp b/t/ansi-test/types-and-classes/load.lsp deleted file mode 100644 index 94ed31d..0000000 --- a/t/ansi-test/types-and-classes/load.lsp +++ /dev/null @@ -1,28 +0,0 @@ -;;; Tests of types and classes -(compile-and-load "ANSI-TESTS:AUX;types-aux.lsp") - -(in-package #:cl-test) - -(let ((*default-pathname-defaults* - (make-pathname - :directory (pathname-directory *load-pathname*)))) - (load "types-and-class.lsp") - (load "types-and-class-2.lsp") - (load "coerce.lsp") - (load "subtypep.lsp") - (load "subtypep-integer.lsp") - (load "subtypep-float.lsp") - (load "subtypep-rational.lsp") - (load "subtypep-real.lsp") - #-lispworks (load "subtypep-cons.lsp") - (load "subtypep-member.lsp") - (load "subtypep-eql.lsp") - (load "subtypep-array.lsp") - (load "subtypep-function.lsp") - (load "subtypep-complex.lsp") - - (load "deftype.lsp") - (load "standard-generic-function.lsp") - (load "type-of.lsp") - (load "typep.lsp") - (load "class-precedence-lists.lsp")) diff --git a/t/ansi-test/types-and-classes/standard-generic-function.lsp b/t/ansi-test/types-and-classes/standard-generic-function.lsp deleted file mode 100644 index c13ca75..0000000 --- a/t/ansi-test/types-and-classes/standard-generic-function.lsp +++ /dev/null @@ -1,45 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue May 20 06:47:20 2003 -;;;; Contains: Additional tests for class STANDARD-GENERIC-FUNCTION - -(in-package :cl-test) - -;;; Most tests of this are elsewhere - -(unless (typep #'cons 'generic-function) - -(deftest standard-generic-function.1 - (progn - (eval - '(defgeneric sgf-cpl-gf.1 (x) - (:method ((x generic-function)) 1) - (:method ((x function)) 2) - (:method ((x t)) 3))) - (values - (sgf-cpl-gf.1 #'make-instance) - (sgf-cpl-gf.1 #'cons) - (sgf-cpl-gf.1 'a))) - 1 2 3) - -(deftest standard-generic-function.2 - (progn - (eval - '(defgeneric sgf-cpl-gf.2 (x) - (:method ((x standard-generic-function)) 1) - (:method ((x function)) 2) - (:method ((x t)) 3))) - (values - (sgf-cpl-gf.2 #'make-instance) - (sgf-cpl-gf.2 #'cons) - (sgf-cpl-gf.2 'a))) - 1 2 3) - - -) - - - - - - diff --git a/t/ansi-test/types-and-classes/subtypep-array.lsp b/t/ansi-test/types-and-classes/subtypep-array.lsp deleted file mode 100644 index fcfdcec..0000000 --- a/t/ansi-test/types-and-classes/subtypep-array.lsp +++ /dev/null @@ -1,291 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Mar 1 16:23:57 2003 -;;;; Contains: Tests of SUBTYPEP on array types - -(in-package :cl-test) - - - -;;; *array-element-types* is defined in ansi-aux.lsp - -(deftest subtypep.array.1 - (let ((array-types (cons (find-class 'array) - '(array (array) (array *) (array * *))))) - (loop for tp1 in array-types append - (loop for tp2 in array-types - unless (subtypep tp1 tp2) - collect (list tp1 tp2)))) - nil) - -(deftest subtypep.array.2 - (and (subtypep* '(array t) '(array t *)) - (subtypep* '(array t *) '(array t)) - t) - t) - -(deftest subtypep.array.3 - (loop for i from 0 below (min 16 array-rank-limit) - for type = `(array * ,i) - for type2 = `(array * ,(make-list i :initial-element '*)) - unless (and (subtypep type 'array) - (subtypep type '(array)) - (subtypep type '(array *)) - (subtypep type '(array * *)) - (subtypep type type2)) - collect type) - nil) - -(deftest subtypep.array.4 - (loop for i from 0 below (min 16 array-rank-limit) - for type = `(array t ,i) - for type2 = `(array t ,(make-list i :initial-element '*)) - unless (and (subtypep type '(array t)) - (subtypep type '(array t *)) - (subtypep type type2)) - collect type) - nil) - -(deftest subtypep.array.5 - (loop - for element-type in (cons '* *array-element-types*) - nconc - (loop for i from 0 below (min 16 array-rank-limit) - for type = `(array ,element-type ,i) - for type2 = `(array ,element-type ,(make-list i :initial-element '0)) - for type3 = `(array ,element-type ,(make-list i :initial-element '1)) - unless - (and (subtypep type2 type) - (subtypep type3 type) - (loop for j from 0 to i - always - (and - (subtypep - `(array ,element-type - (,@(make-list j :initial-element '*) - ,@(make-list (- i j) :initial-element 2))) - type) - (subtypep - `(array ,element-type - (,@(make-list j :initial-element 2) - ,@(make-list (- i j) :initial-element '*))) - type)))) - collect type)) - nil) - -(deftest subtypep.array.6 - (loop - for etype in (cons '* *array-element-types*) - append - (check-equivalence - `(and (array ,etype (* 10 * * *)) - (array ,etype (* * * 29 *))) - `(array ,etype (* 10 * 29 *)))) - nil) - -(deftest subtypep.array.7 - (let ((etypes *array-element-types*)) - (loop - for etp1 in etypes - for uaetp1 = (upgraded-array-element-type etp1) - append - (loop for etp2 in etypes - for uaetp2 = (upgraded-array-element-type etp2) - when (equal (multiple-value-list (subtypep* uaetp1 uaetp2)) - '(nil t)) - append (check-disjointness `(array ,etp1) `(array ,etp2))))) - nil) - -(deftest subtypep.array.8 - (let ((limit (min 16 array-rank-limit))) - (loop for i below limit - for type1 = `(array t ,i) - nconc - (loop for j below limit - for type2 = `(array t ,j) - when (and (/= i j) - (subtypep type1 type2)) - collect (list type1 type2)))) - nil) - -(deftest subtypep.array.9 - (let ((limit (min 16 array-rank-limit))) - (loop for i below limit - for type1 = `(array t ,(make-list i :initial-element 1)) - nconc - (loop for j below limit - for type2 = `(array t ,(make-list j :initial-element 1)) - when (and (/= i j) - (subtypep type1 type2)) - collect (list type1 type2)))) - nil) - -(deftest subtypep.array.10 - (subtypep* '(array t nil) 'integer) - nil t) - -(deftest subtypep.array.11 - (subtypep* '(array t nil) '(array t (*))) - nil t) - -(deftest subtypep.array.12 - (subtypep* '(array t nil) '(array t 1)) - nil t) - -(deftest subtypep.array.13 - (subtypep* '(array bit nil) '(array bit 1)) - nil t) - -;;;; Tests on the definitions of various vector types - -(deftest string-is-not-vector-of-character.1 - :notes (:nil-vectors-are-strings) - (or (subtypep* 'string '(vector character)) - (subtypep* 'string '(vector base-char)) - (subtypep* 'string '(vector extended-char))) - nil t) - -(deftest vector-of-character-is-string.2 - (subtypep* '(vector character) 'string) - t t) - -(deftest string-is-not-vector-of-character.3 - :notes (:nil-vectors-are-strings) - (subtypep* '(string *) '(vector character)) - nil t) - -(deftest vector-of-character-is-string.4 - (subtypep* '(vector character) '(string *)) - t t) - -(deftest string-is-not-vector-of-character.5 - :notes (:nil-vectors-are-strings) - (subtypep* '(string 17) '(vector character 17)) - nil t) - -(deftest vector-of-character-is-string.6 - (subtypep* '(vector character 17) '(string 17)) - t t) - -(deftest base-string-is-vector-of-base-char.1 - (subtypep* 'base-string '(vector base-char)) - t t) - -(deftest base-string-is-vector-of-base-char.2 - (subtypep* '(vector base-char) 'base-string) - t t) - -(deftest base-string-is-vector-of-base-char.3 - (subtypep* '(base-string *) '(vector base-char)) - t t) - -(deftest base-string-is-vector-of-base-char.4 - (subtypep* '(vector base-char) '(base-string *)) - t t) - -(deftest base-string-is-vector-of-base-char.5 - (subtypep* '(base-string 17) '(vector base-char 17)) - t t) - -(deftest base-string-is-vector-of-base-char.6 - (subtypep* '(vector base-char 17) '(base-string 17)) - t t) - -(deftest simple-base-string-is-simple-1d-array-of-base-char.1 - (subtypep* 'simple-base-string '(simple-array base-char (*))) - t t) - -(deftest simple-base-string-is-simple-1d-array-of-base-char.2 - (subtypep* '(simple-array base-char (*)) 'simple-base-string) - t t) - -(deftest simple-base-string-is-simple-1d-array-of-base-char.3 - (subtypep* '(simple-base-string *) '(simple-array base-char (*))) - t t) - -(deftest simple-base-string-is-simple-1d-array-of-base-char.4 - (subtypep* '(simple-array base-char (*)) '(simple-base-string *)) - t t) - -(deftest simple-base-string-is-simple-1d-array-of-base-char.5 - (subtypep* '(simple-base-string 17) '(simple-array base-char (17))) - t t) - -(deftest simple-base-string-is-simple-1d-array-of-base-char.6 - (subtypep* '(simple-array base-char (17)) '(simple-base-string 17)) - t t) - -(deftest simple-string-is-not-simple-1d-array-of-character.1 - :notes (:nil-vectors-are-strings) - (subtypep* 'simple-string '(simple-array character (*))) - nil t) - -(deftest simple-1d-array-of-character-is-simple-string.2 - (subtypep* '(simple-array character (*)) 'simple-string) - t t) - -(deftest simple-string-is-not-simple-1d-array-of-character.3 - :notes (:nil-vectors-are-strings) - (subtypep* '(simple-string *) '(simple-array character (*))) - nil t) - -(deftest simple-1d-array-of-character-is-simple-string.4 - (subtypep* '(simple-array character (*)) '(simple-string *)) - t t) - -(deftest simple-string-is-not-simple-1d-array-of-character.5 - :notes (:nil-vectors-are-strings) - (subtypep* '(simple-string 17) '(simple-array character (17))) - nil t) - -(deftest simple-1d-array-of-character-is-simple-string.6 - (subtypep* '(simple-array character (17)) '(simple-string 17)) - t t) - -(deftest vector-is-1d-array.1 - (subtypep* 'vector '(array * (*))) - t t) - -(deftest vector-is-1d-array.2 - (subtypep* '(array * (*)) 'vector) - t t) - -(deftest vector-is-1d-array.3 - (subtypep* '(vector *) '(array * (*))) - t t) - -(deftest vector-is-1d-array.4 - (subtypep* '(array * (*)) '(vector *)) - t t) - -(deftest vector-is-1d-array.5 - (subtypep* '(vector * 17) '(array * (17))) - t t) - -(deftest vector-is-1d-array.6 - (subtypep* '(array * (17)) '(vector * 17)) - t t) - -(deftest simple-vector-is-simple-1d-array.1 - (subtypep* 'simple-vector '(simple-array t (*))) - t t) - -(deftest simple-vector-is-simple-1d-array.2 - (subtypep* '(simple-array t (*)) 'simple-vector) - t t) - -(deftest simple-vector-is-simple-1d-array.3 - (subtypep* '(simple-vector *) '(simple-array t (*))) - t t) - -(deftest simple-vector-is-simple-1d-array.4 - (subtypep* '(simple-array t (*)) '(simple-vector *)) - t t) - -(deftest simple-vector-is-simple-1d-array.5 - (subtypep* '(simple-vector 17) '(simple-array t (17))) - t t) - -(deftest simple-vector-is-simple-1d-array.6 - (subtypep* '(simple-array t (17)) '(simple-vector 17)) - t t) diff --git a/t/ansi-test/types-and-classes/subtypep-complex.lsp b/t/ansi-test/types-and-classes/subtypep-complex.lsp deleted file mode 100644 index b34dd43..0000000 --- a/t/ansi-test/types-and-classes/subtypep-complex.lsp +++ /dev/null @@ -1,116 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sun Jan 23 07:12:38 2005 -;;;; Contains: Tests of SUBTYPEP on complex types - -(in-package :cl-test) - - - -(deftest subtypep-complex.1 - (subtypep* 'complex 'number) - t t) - -(deftest subtypep-complex.2 - (subtypep* 'number 'complex) - nil t) - -(defun check-not-complex-type (type) - (let ((result1 (multiple-value-list (subtypep* type 'complex))) - (result2 (multiple-value-list (subtypep* 'complex type)))) - (if (and (equal result1 '(nil t)) - (equal result2 '(nil t))) - nil - (list (list type result1 result2))))) - -(deftest subtypep-complex.3 - (mapcan #'check-not-complex-type - '(bit unsigned-byte integer rational ratio real float short-float - single-float double-float long-float fixnum bignum)) - nil) - -(deftest subtypep-complex.4 - (loop for i from 1 to 100 - nconc (check-not-complex-type `(unsigned-byte ,i))) - nil) - -(deftest subtypep-complex.5 - (loop for i from 1 to 100 - nconc (check-not-complex-type `(signed-byte ,i))) - nil) - -(deftest subtypep-complex.7 - (let ((types '(complex (complex) (complex *)))) - (loop for tp1 in types - nconc (loop for tp2 in types - for result = (multiple-value-list (subtypep* tp1 tp2)) - unless (equal result '(t t)) - collect (list tp1 tp2 result)))) - nil) - -(defun check-complex-upgrading (t1 t2) - (let* ((ucpt1 (upgraded-complex-part-type t1)) - (ucpt2 (upgraded-complex-part-type t2)) - (result (multiple-value-list - (subtypep* `(complex ,t1) `(complex ,t2))))) - (cond - ((or (equal ucpt1 ucpt2) - (subtypep t1 t2)) - (unless (equal result '(t t)) - (list (list :case1 t1 t2 ucpt1 ucpt2 result)))) - (t - (multiple-value-bind - (ucpt-sub1? good1?) - (subtypep* ucpt1 ucpt2) - (multiple-value-bind - (ucpt-sub2? good2?) - (subtypep* ucpt2 ucpt1) - (cond - ;; the second is not a subtype of the first - ((and good2? ucpt-sub1? (not ucpt-sub2?)) - (assert good1?) - (unless (equal result '(nil t)) - (list (list :case2 t1 t2 ucpt1 ucpt2 result)))) - ;; the first is not a subtype of the second - ((and good1? (not ucpt-sub1?) ucpt-sub2?) - (assert good2?) - (unless (equal result '(nil t)) - (list (list :case3 t1 t2 ucpt1 ucpt2 result)))) - ;; they are both subtypes of each other, and so represent - ;; the same set of objects - ((and ucpt-sub1? ucpt-sub2?) - (assert good1?) - (assert good2?) - (unless (equal result '(t t)) - (list (list :case4 t1 t2 ucpt1 ucpt2 result))))))))))) - -(deftest subtypep-complex.8 - (let ((types (reverse - '(bit fixnum bignum integer unsigned-byte rational ratio - short-float single-float double-float long-float - float real))) - (float-types - (remove-duplicates '(short-float single-float double-float long-float) - :test #'(lambda (t1 t2) - (eql (coerce 0 t1) (coerce 0 t2)))))) - (loop for i in '(1 2 3 4 6 8 13 16 17 28 29 31 32 48 64) - do (push `(unsigned-byte ,i) types) - do (push `(signed-byte ,i) types) - do (loop for ftp in float-types - do (push `(,ftp ,(coerce 0 ftp) - ,(coerce i ftp)) - types) - do (push `(,ftp (,(coerce (- i) ftp)) - ,(coerce i ftp)) - types)) - do (push `(float ,(coerce 0 'single-float) - ,(coerce i 'single-float)) - types)) - (setq types (reverse types)) - (let ((results - (mapcan #'(lambda (t1) - (mapcan #'(lambda (t2) (check-complex-upgrading t1 t2)) - types)) - types))) - (subseq results 0 (min 100 (length results))))) - nil) diff --git a/t/ansi-test/types-and-classes/subtypep-cons.lsp b/t/ansi-test/types-and-classes/subtypep-cons.lsp deleted file mode 100644 index 991fa0e..0000000 --- a/t/ansi-test/types-and-classes/subtypep-cons.lsp +++ /dev/null @@ -1,376 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Feb 15 11:57:03 2003 -;;;; Contains: Tests for subtype relationships on cons types - -(in-package :cl-test) - - - -;;; SUBTYPEP on CONS types - -(defvar *cons-types* - '(cons (cons) (cons *) (cons * *) (cons t) (cons t t) - (cons t *) (cons * t))) - -(deftest subtypep.cons.1 - (loop for t1 in *cons-types* - append (loop for t2 in *cons-types* - unless (equal (mapcar #'notnot - (multiple-value-list - (subtypep t1 t2))) - '(t t)) - collect (list t1 t2))) - nil) - -(deftest subtypep.cons.2 - (loop for t1 in '((cons nil) (cons nil *) (cons nil t) - (cons * nil) (cons t nil) (cons nil nil)) - unless (subtypep t1 nil) - collect t1) - nil) - -(deftest subtypep.cons.3 - (check-equivalence '(and (cons symbol *) (cons * symbol)) - '(cons symbol symbol)) - nil) - -(deftest subtypep.cons.4 - (check-equivalence '(and (cons (integer 0 10) *) - (cons (integer 5 15) (integer 10 20)) - (cons * (integer 15 25))) - '(cons (integer 5 10) (integer 15 20))) - nil) - -(deftest subtypep.cons.5 - (check-equivalence - '(and cons (not (cons symbol symbol))) - '(or (cons (not symbol) *) - (cons * (not symbol)))) - nil) - -(deftest subtypep.cons.6 - (check-equivalence - '(or (cons integer symbol) (cons integer integer) - (cons symbol integer) (cons symbol symbol)) - '(cons (or integer symbol) (or integer symbol))) - nil) - -(deftest subtypep.cons.7 - (check-equivalence - '(or (cons (integer 0 8) (integer 5 15)) - (cons (integer 0 7) (integer 0 6)) - (cons (integer 6 15) (integer 0 9)) - (cons (integer 3 15) (integer 4 15))) - '(cons (integer 0 15) (integer 0 15))) - nil) - -(deftest subtypep.cons.8 - (check-equivalence - '(or - (cons integer (cons symbol integer)) - (cons symbol (cons integer symbol)) - (cons symbol (cons symbol integer)) - (cons symbol (cons integer integer)) - (cons integer (cons integer symbol)) - (cons symbol (cons symbol symbol)) - (cons integer (cons integer integer)) - (cons integer (cons symbol symbol))) - '(cons (or symbol integer) - (cons (or symbol integer) (or symbol integer)))) - nil) - -(deftest subtypep.cons.9 - (check-equivalence - '(or - (cons (integer 0 (3)) (integer 0 (6))) - (cons (integer 3 (9)) (integer 0 (3))) - (cons (integer 0 (6)) (integer 6 (9))) - (cons (integer 6 (9)) (integer 3 (9))) - (cons (integer 3 (6)) (integer 3 (6)))) - '(cons (integer 0 (9)) (integer 0 (9)))) - nil) - -(deftest subtypep.cons.10 - (check-equivalence - '(or - (cons (rational 0 (3)) (rational 0 (6))) - (cons (rational 3 (9)) (rational 0 (3))) - (cons (rational 0 (6)) (rational 6 (9))) - (cons (rational 6 (9)) (rational 3 (9))) - (cons (rational 3 (6)) (rational 3 (6)))) - '(cons (rational 0 (9)) (rational 0 (9)))) - nil) - -(deftest subtypep.cons.11 - (check-equivalence - '(or - (cons (real 0 (3)) (real 0 (6))) - (cons (real 3 (9)) (real 0 (3))) - (cons (real 0 (6)) (real 6 (9))) - (cons (real 6 (9)) (real 3 (9))) - (cons (real 3 (6)) (real 3 (6)))) - '(cons (real 0 (9)) (real 0 (9)))) - nil) - -;;; Test suggested by C.R. -(deftest subtypep.cons.12 - (check-all-not-subtypep - '(cons (or integer symbol) - (or integer symbol)) - '(or (cons integer symbol) - (cons symbol integer))) - nil) - -(deftest subtypep.cons.13 - (check-all-not-subtypep '(not list) 'cons) - nil) - - -;;; a -> b, a ==> b -(deftest subtypep.cons.14 - (check-all-subtypep - '(and (or (cons (not symbol)) (cons * integer)) - (cons symbol)) - '(cons * integer)) - nil) - -;;; a -> b, not b ==> not a -(deftest subtypep.cons.15 - (check-all-subtypep - '(and (or (cons (not symbol)) (cons * integer)) - (cons * (not integer))) - '(cons (not symbol))) - nil) - -;;; (and (or a b) (or (not b) c)) ==> (or a c) -(deftest subtypep.cons.16 - (check-all-subtypep - '(and (or (cons symbol (cons * *)) - (cons * (cons integer *))) - (or (cons * (cons (not integer) *)) - (cons * (cons * float)))) - '(or (cons symbol (cons * *)) - (cons * (cons * float)))) - nil) - -(deftest subtypep.cons.17 - (check-all-subtypep - '(and (or (cons symbol (cons * *)) - (cons * (cons integer *))) - (or (cons * (cons (not integer))) - (cons * (cons * float))) - (or (cons * (cons * (not float))) - (cons symbol (cons * *)))) - '(cons symbol)) - nil) - -(deftest subtypep.cons.18 - (check-all-subtypep - '(cons symbol) - '(or (cons symbol (not integer)) - (cons * integer))) - nil) - -(deftest subtypep.cons.19 - (check-equivalence - '(or - (cons (eql a) (eql x)) - (cons (eql b) (eql y)) - (cons (eql c) (eql z)) - (cons (eql a) (eql y)) - (cons (eql b) (eql z)) - (cons (eql c) (eql x)) - (cons (eql a) (eql z)) - (cons (eql b) (eql x)) - (cons (eql c) (eql y))) - '(cons (member a b c) (member x y z))) - nil) - -(deftest subtypep.cons.20 - (check-equivalence - '(or - (cons (eql a) (eql x)) - (cons (eql b) (eql y)) - (cons (eql a) (eql y)) - (cons (eql b) (eql z)) - (cons (eql c) (eql x)) - (cons (eql a) (eql z)) - (cons (eql b) (eql x)) - (cons (eql c) (eql y))) - '(and (cons (member a b c) (member x y z)) - (not (cons (eql c) (eql z))))) - nil) - -;;; Test case that came up in SBCL -(deftest subtypep.cons.21 - (check-all-subtypep - '(cons integer single-float) - '(or (cons fixnum single-float) (cons bignum single-float))) - nil) - -(deftest subtypep.cons.22 - (check-all-subtypep - '(cons single-float integer) - '(or (cons single-float fixnum) (cons single-float bignum))) - nil) - -;;; More test cases from SBCL, CMUCL, culled from random test failures - -(deftest subtype.cons.23 - (let ((t1 '(cons t (cons (not long-float) symbol))) - (t2 '(not (cons symbol (cons integer integer))))) - (subtypep-and-contrapositive-are-consistent t1 t2)) - t) - -(deftest subtype.cons.24 - (let ((t1 '(cons (eql 3671) (cons short-float (eql -663423073525)))) - (t2 '(not (cons t (cons (not complex) (cons integer t)))))) - (subtypep-and-contrapositive-are-consistent t1 t2)) - t) - -(deftest subtype.cons.25 - (let ((t1 '(cons t (cons (not long-float) (integer 44745969 61634129)))) - (t2 '(not (cons (eql -3) (cons short-float (cons t float)))))) - (subtypep-and-contrapositive-are-consistent t1 t2)) - t) - -(deftest subtype.cons.26 - (let ((t1 '(cons integer (cons single-float (cons t t)))) - (t2 '(cons t (cons (not complex) (not (eql 8)))))) - (subtypep-and-contrapositive-are-consistent t1 t2)) - t) - -(deftest subtype.cons.27 - (let ((t1 '(cons (not (integer -27 30)) - (cons rational (cons integer integer)))) - (t2 '(not (cons integer (cons integer (eql 378132631)))))) - (subtypep-and-contrapositive-are-consistent t1 t2)) - t) - -(deftest subtype.cons.28 - (let ((t1 '(cons (integer -1696888 -1460338) - (cons single-float symbol))) - (t2 '(not (cons (not (integer -14 20)) - (cons (not integer) cons))))) - (subtypep-and-contrapositive-are-consistent t1 t2)) - t) - -(deftest subtypep.cons.29 - (let ((t2 '(or (not (cons unsigned-byte cons)) - (not (cons (integer -6 22) rational))))) - (subtypep-and-contrapositive-are-consistent 'cons t2)) - t) - -(deftest subtypep.cons.30 - (let ((t1 '(not (cons t (cons t (cons cons t))))) - (t2 '(or (or (cons (cons t integer) t) - (not (cons t (cons t cons)))) - (not (cons (cons (eql -27111309) t) - (cons t (eql 1140730))))))) - (subtypep-and-contrapositive-are-consistent t1 t2)) - t) - -(deftest subtypep.cons.31 - (let ((t2 '(or - (not - (cons (or (cons t ratio) (cons short-float t)) - (cons (cons (eql -7418623) (integer -9 53)) - (cons cons t)))) - (not - (cons (cons t (eql -265039)) - (cons (cons t cons) t)))))) - (subtypep-and-contrapositive-are-consistent 'cons t2)) - t) - -(deftest subtypep.cons.32 - (let ((t2 '(cons t - (or (not (cons integer (eql 0))) - (not (cons (or float (eql 0)) cons)))))) - (subtypep-and-contrapositive-are-consistent 'cons t2)) - t) - -(deftest subtypep.cons.33 - (let ((t2 '(or (not (cons (cons t cons) (cons t (cons unsigned-byte t)))) - (not (cons (cons integer t) (cons t (cons cons t))))))) - (subtypep-and-contrapositive-are-consistent 'cons t2)) - t) - -(deftest subtypep.cons.34 - (let ((t2 '(or (not (cons (or (eql 0) ratio) (not cons))) - (not (cons integer cons))))) - (subtypep-and-contrapositive-are-consistent 'cons t2)) - t) - -(deftest subtypep.cons.35 - (notnot-mv (subtypep '(cons nil t) 'float)) - t t) - -(deftest subtypep.cons.36 - (notnot-mv (subtypep '(cons t nil) 'symbol)) - t t) - -(deftest subtypep.cons.37 - (notnot-mv (subtypep '(cons nil nil) 'real)) - t t) - -(deftest subtypep.cons.38 - (let ((t1 '(cons t (complex (real -32 0)))) - (t2 `(not (cons t (complex (integer * -500)))))) - (subtypep-and-contrapositive-are-consistent t1 t2)) - t) - -;;; From GCL - -(deftest subtypep.cons.39 - (values (subtypep t '(and (not (cons cons (cons cons t))) (not (cons t cons))))) - nil) - -(deftest subtypep.cons.40 - (let ((type1 '(cons (eql 0) cons)) - (type2 '(cons unsigned-byte symbol))) - (values - (subtypep* type1 type2) - (subtypep* `(not ,type2) `(not ,type1)))) - nil nil) - -;;; From sbcl 0.9.5.31 - -(deftest subtypep.cons.41 - (let ((type1 '(cons t (complex (real -10 -4)))) - (type2 '(not (cons t (complex (integer -200 -100)))))) - (multiple-value-bind (sub1 success1) - (subtypep* type1 type2) - (multiple-value-bind (sub2 success2) - (subtypep* `(not ,type2) `(not ,type1)) - (if (and success1 success2 (not (eq sub1 sub2))) - (values sub1 sub2) - nil)))) - nil) - -(deftest subtypep.cons.42 - (let ((t1 '(cons (cons (cons (real -744833699 -744833699) cons) (integer -234496 215373)) - integer)) - (t2 '(cons (cons (cons integer integer) (integer -234496 215373)) t))) - (values (subtypep `(not ,t2) `(not ,t1)))) - nil) - -;;;; From sbcl 0.9.6.57 - -(deftest subtypep.cons.43 - (let* ((n -3.926510009989861d7) - (t1 '(not (cons float t))) - (t2 `(or (not (cons (eql 0) (real ,n ,n))) - (not (cons t (eql 0)))))) - (multiple-value-bind - (sub1 good1) - (subtypep* t1 t2) - (multiple-value-bind - (sub2 good2) - (subtypep* `(not ,t2) `(not ,t1)) - (or (not good1) - (not good2) - (and sub1 sub2) - (and (not sub1) (not sub2)))))) - t) - diff --git a/t/ansi-test/types-and-classes/subtypep-eql.lsp b/t/ansi-test/types-and-classes/subtypep-eql.lsp deleted file mode 100644 index 47079b2..0000000 --- a/t/ansi-test/types-and-classes/subtypep-eql.lsp +++ /dev/null @@ -1,56 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Feb 15 11:58:43 2003 -;;;; Contains: Tests for subtype relationships on EQL types - -(in-package :cl-test) - - - -(deftest subtypep.eql.1 - (let ((s1 (copy-seq "abc")) - (s2 (copy-seq "abc"))) - (let ((t1 `(eql ,s1)) - (t2 `(eql ,s2))) - (cond - ((subtypep t1 t2) "T1 is subtype of T2") - ((subtypep t2 t1) "T2 is subtype of T1") - (t (check-disjointness t1 t2))))) - nil) - -(deftest subtypep.eql.2 - (let ((s1 (copy-seq '(a b c))) - (s2 (copy-seq '(a b c)))) - (let ((t1 `(eql ,s1)) - (t2 `(eql ,s2))) - (cond - ((subtypep t1 t2) "T1 is subtype of T2") - ((subtypep t2 t1) "T2 is subtype of T1") - (t (check-disjointness t1 t2))))) - nil) - -(deftest subtypep.eql.3 - (let ((i1 (1+ most-positive-fixnum)) - (i2 (1+ most-positive-fixnum))) - (check-equivalence `(eql ,i1) `(eql ,i2))) - nil) - -(deftest subtypep.eql.4 - (check-equivalence '(and (eql a) (eql b)) nil) - nil) - -(deftest subtypep.eql.5 - (check-all-subtypep '(eql a) '(satisfies symbolp)) - nil) - -(deftest subtypep.eql.6 - (check-disjointness '(eql 17) '(satisfies symbolp)) - nil) - -(deftest subtypep.eql.7 - (check-all-subtypep '(eql nil) '(satisfies symbolp)) - nil) - -(deftest subtypep.eql.8 - (check-all-not-subtypep '(satisfies symbolp) '(eql a)) - nil) diff --git a/t/ansi-test/types-and-classes/subtypep-float.lsp b/t/ansi-test/types-and-classes/subtypep-float.lsp deleted file mode 100644 index 95e60b2..0000000 --- a/t/ansi-test/types-and-classes/subtypep-float.lsp +++ /dev/null @@ -1,411 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Feb 15 11:55:37 2003 -;;;; Contains: Tests for subtype relationships on float types - -(in-package :cl-test) - - - -;;;;;;; - -(deftest subtypep.float.1 - (loop for tp in +float-types+ - append (check-subtypep tp 'float t t)) - nil) - -(deftest subtypep.float.2 - (if (subtypep 'short-float 'long-float) - (loop for tp in +float-types+ - append - (loop for tp2 in +float-types+ - append (check-subtypep tp tp2 t t))) - nil) - nil) - -(deftest subtypep.float.3 - (if (and (not (subtypep 'short-float 'single-float)) - (subtypep 'single-float 'long-float)) - (append - (check-equivalence 'single-float 'double-float) - (check-equivalence 'single-float 'long-float) - (check-equivalence 'double-float 'long-float) - (classes-are-disjoint 'short-float 'single-float) - (classes-are-disjoint 'short-float 'double-float) - (classes-are-disjoint 'short-float 'long-float)) - nil) - nil) - -(deftest subtypep.float.4 - (if (and (subtypep 'single-float 'short-float) - (subtypep 'double-float 'long-float) - (not (subtypep 'short-float 'double-float))) - (append - (check-equivalence 'short-float 'single-float) - (check-equivalence 'double-float 'long-float) - (loop for tp in '(short-float single-float) - append - (loop for tp2 in '(double-float long-float) - append (classes-are-disjoint tp tp2)))) - nil) - nil) - -(deftest subtypep.float.5 - (if (and (not (subtypep 'single-float 'short-float)) - (not (subtypep 'single-float 'double-float)) - (subtypep 'double-float 'long-float)) - (append - (classes-are-disjoint 'short-float 'single-float) - (classes-are-disjoint 'short-float 'double-float) - (classes-are-disjoint 'short-float 'long-float) - (classes-are-disjoint 'single-float 'double-float) - (classes-are-disjoint 'single-float 'long-float) - (check-equivalence 'double-float 'long-float)) - nil) - nil) - -(deftest subtypep.float.6 - (if (and (subtypep 'single-float 'short-float) - (not (subtypep 'single-float 'double-float)) - (not (subtypep 'double-float 'long-float))) - (append - (check-equivalence 'short-float 'single-float) - (classes-are-disjoint 'single-float 'double-float) - (classes-are-disjoint 'single-float 'long-float) - (classes-are-disjoint 'double-float 'long-float)) - nil) - nil) - -(deftest subtypep.float.7 - (if (and (not (subtypep 'single-float 'short-float)) - (not (subtypep 'single-float 'double-float)) - (not (subtypep 'double-float 'long-float))) - (loop for tp in +float-types+ - append - (loop for tp2 in +float-types+ - unless (eq tp tp2) - append (classes-are-disjoint tp tp2))) - nil) - nil) - -(deftest subtypep.float.8 - (subtypep* '(short-float 0.0s0 10.0s0) '(short-float 0.0s0 11.0s0)) - t t) - -(deftest subtypep.float.9 - (subtypep* '(single-float 0.0f0 10.0f0) '(single-float 0.0f0 11.0f0)) - t t) - -(deftest subtypep.float.10 - (subtypep* '(double-float 0.0d0 10.0d0) '(double-float 0.0d0 11.0d0)) - t t) - -(deftest subtypep.float.11 - (subtypep* '(long-float 0.0l0 10.0l0) '(long-float 0.0l0 11.0l0)) - t t) - -(deftest subtypep.float.12 - (subtypep* '(short-float 0.0s0 11.0s0) '(short-float 0.0s0 10.0s0)) - nil t) - -(deftest subtypep.float.13 - (subtypep* '(single-float 0.0f0 11.0f0) '(single-float 0.0f0 10.0f0)) - nil t) - -(deftest subtypep.float.14 - (subtypep* '(double-float 0.0d0 11.0d0) '(double-float 0.0d0 10.0d0)) - nil t) - -(deftest subtypep.float.15 - (subtypep* '(long-float 0.0l0 11.0l0) '(long-float 0.0l0 10.0l0)) - nil t) - -(deftest subtypep.float.16 - (subtypep* '(short-float 0.0s0 (10.0s0)) '(short-float 0.0s0 10.0s0)) - t t) - -(deftest subtypep.float.17 - (subtypep* '(single-float 0.0f0 (10.0f0)) '(single-float 0.0f0 10.0f0)) - t t) - -(deftest subtypep.float.18 - (subtypep* '(double-float 0.0d0 (10.0d0)) '(double-float 0.0d0 10.0d0)) - t t) - -(deftest subtypep.float.19 - (subtypep* '(long-float 0.0l0 (10.0l0)) '(long-float 0.0l0 10.0l0)) - t t) - -(deftest subtypep.float.20 - (subtypep* '(short-float 0.0s0 10.0s0) '(short-float 0.0s0 (10.0s0))) - nil t) - -(deftest subtypep.float.21 - (subtypep* '(single-float 0.0f0 10.0f0) '(single-float 0.0f0 (10.0f0))) - nil t) - -(deftest subtypep.float.22 - (subtypep* '(double-float 0.0d0 10.0d0) '(double-float 0.0d0 (10.0d0))) - nil t) - -(deftest subtypep.float.23 - (subtypep* '(long-float 0.0l0 10.0l0) '(long-float 0.0l0 (10.0l0))) - nil t) - -(deftest subtypep.float.24 - (check-equivalence '(and (short-float 0.0s0 2.0s0) - (short-float 1.0s0 3.0s0)) - '(short-float 1.0s0 2.0s0)) - nil) - -(deftest subtypep.float.25 - (check-equivalence '(and (single-float 0.0f0 2.0f0) - (single-float 1.0f0 3.0f0)) - '(single-float 1.0f0 2.0f0)) - nil) - -(deftest subtypep.float.26 - (check-equivalence '(and (double-float 0.0d0 2.0d0) - (double-float 1.0d0 3.0d0)) - '(double-float 1.0d0 2.0d0)) - nil) - -(deftest subtypep.float.27 - (check-equivalence '(and (long-float 0.0l0 2.0l0) - (long-float 1.0l0 3.0l0)) - '(long-float 1.0l0 2.0l0)) - nil) - -;;; Signed zero tests - -(deftest subtypep.short-float.zero.1 - (check-equivalence '(short-float 0.0s0 *) - '(or (short-float (0.0s0) *) - (member -0.0s0 0.0s0))) - nil) - -(unless (eql 0.0s0 -0.0s0) - (deftest subtypep.short-float.zero.2a - (values (subtypep '(short-float 0.0s0) - '(or (short-float (0.0s0)) (member 0.0s0)))) - nil) - (deftest subtypep.short-float.zero.2b - (values (subtypep '(short-float 0.0s0) - '(or (short-float (0.0s0)) (member -0.0s0)))) - nil)) - -(deftest subtypep.short-float.zero.3 - (subtypep* '(short-float -0.0s0 *) '(short-float 0.0s0 *)) - t t) - -(deftest subtypep.short-float.zero.4 - (subtypep* '(short-float * -0.0s0) '(short-float * 0.0s0)) - t t) - -(deftest subtypep.short-float.zero.5 - (subtypep* '(short-float (-0.0s0) *) '(short-float (0.0s0) *)) - t t) - -(deftest subtypep.short-float.zero.6 - (subtypep* '(short-float * (-0.0s0)) '(short-float * (0.0s0))) - t t) - -(deftest subtypep.short-float.zero.7 - (subtypep* '(short-float 0.0s0 *) '(short-float -0.0s0 *)) - t t) - -(deftest subtypep.short-float.zero.8 - (subtypep* '(short-float * 0.0s0) '(short-float * -0.0s0)) - t t) - -(deftest subtypep.short-float.zero.9 - (subtypep* '(short-float (0.0s0) *) '(short-float (-0.0s0) *)) - t t) - -(deftest subtypep.short-float.zero.10 - (subtypep* '(short-float * (0.0s0)) '(short-float * (-0.0s0))) - t t) - -;;; - -(deftest subtypep.float.zero.3 - (subtypep* '(float -0.0 *) '(float 0.0 *)) - t t) - -(deftest subtypep.float.zero.4 - (subtypep* '(float * -0.0) '(float * 0.0)) - t t) - -(deftest subtypep.float.zero.5 - (subtypep* '(float (-0.0) *) '(float (0.0) *)) - t t) - -(deftest subtypep.float.zero.6 - (subtypep* '(float * (-0.0)) '(float * (0.0))) - t t) - -(deftest subtypep.float.zero.7 - (subtypep* '(float 0.0 *) '(float -0.0 *)) - t t) - -(deftest subtypep.float.zero.8 - (subtypep* '(float * 0.0) '(float * -0.0)) - t t) - -(deftest subtypep.float.zero.9 - (subtypep* '(float (0.0) *) '(float (-0.0) *)) - t t) - -(deftest subtypep.float.zero.10 - (subtypep* '(float * (0.0)) '(float * (-0.0))) - t t) - -;;; - -(deftest subtypep.single-float.zero.1 - (check-equivalence '(single-float 0.0f0 *) - '(or (single-float (0.0f0) *) - (member -0.0f0 0.0f0))) - nil) - -(unless (eql 0.0f0 -0.0f0) - (deftest subtypep.single-float.zero.2a - (values (subtypep '(single-float 0.0f0) - '(or (single-float (0.0f0)) (member 0.0f0)))) - nil) - (deftest subtypep.single-float.zero.2b - (values (subtypep '(single-float 0.0f0) - '(or (single-float (0.0f0)) (member -0.0f0)))) - nil)) - -(deftest subtypep.single-float.zero.3 - (subtypep* '(single-float -0.0f0 *) '(single-float 0.0f0 *)) - t t) - -(deftest subtypep.single-float.zero.4 - (subtypep* '(single-float * -0.0f0) '(single-float * 0.0f0)) - t t) - -(deftest subtypep.single-float.zero.5 - (subtypep* '(single-float (-0.0f0) *) '(single-float (0.0f0) *)) - t t) - -(deftest subtypep.single-float.zero.6 - (subtypep* '(single-float * (-0.0f0)) '(single-float * (0.0f0))) - t t) - -(deftest subtypep.single-float.zero.7 - (subtypep* '(single-float 0.0f0 *) '(single-float -0.0f0 *)) - t t) - -(deftest subtypep.single-float.zero.8 - (subtypep* '(single-float * 0.0f0) '(single-float * -0.0f0)) - t t) - -(deftest subtypep.single-float.zero.9 - (subtypep* '(single-float (0.0f0) *) '(single-float (-0.0f0) *)) - t t) - -(deftest subtypep.single-float.zero.10 - (subtypep* '(single-float * (0.0f0)) '(single-float * (-0.0f0))) - t t) - -;;; - -(deftest subtypep.long-float.zero.1 - (check-equivalence '(long-float 0.0l0 *) - '(or (long-float (0.0l0) *) - (member -0.0l0 0.0l0))) - nil) - -(unless (eql 0.0l0 -0.0l0) - (deftest subtypep.long-float.zero.2a - (values (subtypep '(long-float 0.0l0) - '(or (long-float (0.0l0)) (member 0.0l0)))) - nil) - (deftest subtypep.long-float.zero.2b - (values (subtypep '(long-float 0.0l0) - '(or (long-float (0.0l0)) (member -0.0l0)))) - nil)) - -(deftest subtypep.long-float.zero.3 - (subtypep* '(long-float -0.0l0 *) '(long-float 0.0l0 *)) - t t) - -(deftest subtypep.long-float.zero.4 - (subtypep* '(long-float * -0.0l0) '(long-float * 0.0l0)) - t t) - -(deftest subtypep.long-float.zero.5 - (subtypep* '(long-float (-0.0l0) *) '(long-float (0.0l0) *)) - t t) - -(deftest subtypep.long-float.zero.6 - (subtypep* '(long-float * (-0.0l0)) '(long-float * (0.0l0))) - t t) - -(deftest subtypep.long-float.zero.7 - (subtypep* '(long-float 0.0l0 *) '(long-float -0.0l0 *)) - t t) - -(deftest subtypep.long-float.zero.8 - (subtypep* '(long-float * 0.0l0) '(long-float * -0.0l0)) - t t) - -(deftest subtypep.long-float.zero.9 - (subtypep* '(long-float (0.0l0) *) '(long-float (-0.0l0) *)) - t t) - -(deftest subtypep.long-float.zero.10 - (subtypep* '(long-float * (0.0l0)) '(long-float * (-0.0l0))) - t t) - -;;; - -(deftest subtypep.double-float.zero.1 - (check-equivalence '(double-float 0.0d0 *) - '(or (double-float (0.0d0) *) - (member -0.0d0 0.0d0))) - nil) - -(unless (eql 0.0d0 -0.0d0) - (deftest subtypep.double-float.zero.2a - (values (subtypep '(double-float 0.0d0) - '(or (double-float (0.0d0)) (member 0.0d0)))) - nil) - (deftest subtypep.double-float.zero.2b - (values (subtypep '(double-float 0.0d0) - '(or (double-float (0.0d0)) (member -0.0d0)))) - nil)) - -(deftest subtypep.double-float.zero.3 - (subtypep* '(double-float -0.0d0 *) '(double-float 0.0d0 *)) - t t) - -(deftest subtypep.double-float.zero.4 - (subtypep* '(double-float * -0.0d0) '(double-float * 0.0d0)) - t t) - -(deftest subtypep.double-float.zero.5 - (subtypep* '(double-float (-0.0d0) *) '(double-float (0.0d0) *)) - t t) - -(deftest subtypep.double-float.zero.6 - (subtypep* '(double-float * (-0.0d0)) '(double-float * (0.0d0))) - t t) - -(deftest subtypep.double-float.zero.7 - (subtypep* '(double-float 0.0d0 *) '(double-float -0.0d0 *)) - t t) - -(deftest subtypep.double-float.zero.8 - (subtypep* '(double-float * 0.0d0) '(double-float * -0.0d0)) - t t) - -(deftest subtypep.double-float.zero.9 - (subtypep* '(double-float (0.0d0) *) '(double-float (-0.0d0) *)) - t t) - -(deftest subtypep.double-float.zero.10 - (subtypep* '(double-float * (0.0d0)) '(double-float * (-0.0d0))) - t t) diff --git a/t/ansi-test/types-and-classes/subtypep-function.lsp b/t/ansi-test/types-and-classes/subtypep-function.lsp deleted file mode 100644 index e4d8a34..0000000 --- a/t/ansi-test/types-and-classes/subtypep-function.lsp +++ /dev/null @@ -1,24 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Dec 15 21:57:44 2004 -;;;; Contains: Tests of SUBTYPEP on FUNCTION types - -(in-package :cl-test) - - - -(deftest subtypep-function.1 - (check-all-not-subtypep t '(function (t) t)) - nil) - -(deftest subtypep-function.2 - (check-all-subtypep nil '(function (t) t)) - nil) - -(deftest subtypep-function.3 - (check-all-subtypep '(function (t) t) 'function) - nil) - -(deftest subtypep-function.4 - (check-all-subtypep '(function (t) integer) '(function (t) real)) - nil) diff --git a/t/ansi-test/types-and-classes/subtypep-integer.lsp b/t/ansi-test/types-and-classes/subtypep-integer.lsp deleted file mode 100644 index effaa89..0000000 --- a/t/ansi-test/types-and-classes/subtypep-integer.lsp +++ /dev/null @@ -1,436 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Feb 15 11:54:05 2003 -;;;; Contains: Tests for subtype relationships on integer types - -(in-package :cl-test) - - - -(deftest subtypep.fixnum-or-bignum - (check-equivalence '(or fixnum bignum) 'integer) - nil) - -(deftest subtypep.fixnum.integer - (check-equivalence `(integer ,most-negative-fixnum ,most-positive-fixnum) - 'fixnum) - nil) - -(deftest subtypep.bignum.integer - (check-equivalence - `(or (integer * (,most-negative-fixnum)) - (integer (,most-positive-fixnum) *)) - 'bignum) - nil) - -;;;;;;; - -(deftest subtypep.integer.1 - (subtypep* '(integer 0 10) '(integer 0 20)) - t t) - -(deftest subtypep.integer.2 - (subtypep* '(integer 0 10) '(integer 0 (10))) - nil t) - -(deftest subtypep.integer.3 - (subtypep* '(integer 10 100) 'integer) - t t) - -(deftest subtypep.integer.3a - (subtypep* '(integer 10 100) '(integer)) - t t) - -(deftest subtypep.integer.3b - (subtypep* '(integer 10 100) '(integer *)) - t t) - -(deftest subtypep.integer.3c - (subtypep* '(integer 10 100) '(integer * *)) - t t) - -(deftest subtypep.integer.4 - (subtypep* 'integer '(integer 10 100)) - nil t) - -(deftest subtypep.integer.4a - (subtypep* '(integer) '(integer 10 100)) - nil t) - -(deftest subtypep.integer.4b - (subtypep* '(integer *) '(integer 10 100)) - nil t) - -(deftest subtypep.integer.4c - (subtypep* '(integer * *) '(integer 10 100)) - nil t) - -(deftest subtypep.integer.5 - (subtypep* '(integer 10 *) 'integer) - t t) - -(deftest subtypep.integer.5a - (subtypep* '(integer 10 *) '(integer)) - t t) - -(deftest subtypep.integer.5b - (subtypep* '(integer 10 *) '(integer *)) - t t) - -(deftest subtypep.integer.5c - (subtypep* '(integer 10 *) '(integer * *)) - t t) - -(deftest subtypep.integer.6 - (subtypep* 'integer '(integer 10 *)) - nil t) - -(deftest subtypep.integer.6a - (subtypep* '(integer) '(integer 10 *)) - nil t) - -(deftest subtypep.integer.6b - (subtypep* '(integer *) '(integer 10 *)) - nil t) - -(deftest subtypep.integer.6c - (subtypep* '(integer * *) '(integer 10 *)) - nil t) - -(deftest subtypep.integer.7 - (subtypep* '(integer 10) 'integer) - t t) - -(deftest subtypep.integer.7a - (subtypep* '(integer 10) '(integer)) - t t) - -(deftest subtypep.integer.7b - (subtypep* '(integer 10) '(integer *)) - t t) - -(deftest subtypep.integer.7c - (subtypep* '(integer 10) '(integer * *)) - t t) - -(deftest subtypep.integer.8 - (subtypep* 'integer '(integer 10)) - nil t) - -(deftest subtypep.integer.8a - (subtypep* '(integer) '(integer 10)) - nil t) - -(deftest subtypep.integer.8b - (subtypep* '(integer *) '(integer 10)) - nil t) - -(deftest subtypep.integer.8c - (subtypep* '(integer * *) '(integer 10)) - nil t) - -(deftest subtypep.integer.9 - (subtypep* '(integer * 10) 'integer) - t t) - -(deftest subtypep.integer.9a - (subtypep* '(integer * 10) '(integer)) - t t) - -(deftest subtypep.integer.9b - (subtypep* '(integer * 10) '(integer *)) - t t) - -(deftest subtypep.integer.9c - (subtypep* '(integer * 10) '(integer * *)) - t t) - -(deftest subtypep.integer.10 - (subtypep* 'integer '(integer * 10)) - nil t) - -(deftest subtypep.integer.10a - (subtypep* '(integer) '(integer * 10)) - nil t) - -(deftest subtypep.integer.10b - (subtypep* '(integer *) '(integer * 10)) - nil t) - -(deftest subtypep.integer.10c - (subtypep* '(integer * *) '(integer * 10)) - nil t) - -(deftest subtypep.integer.11 - (subtypep* '(integer 10) '(integer 5)) - t t) - -(deftest subtypep.integer.12 - (subtypep* '(integer 5) '(integer 10)) - nil t) - -(deftest subtypep.integer.13 - (subtypep* '(integer 10 *) '(integer 5)) - t t) - -(deftest subtypep.integer.14 - (subtypep* '(integer 5) '(integer 10 *)) - nil t) - -(deftest subtypep.integer.15 - (subtypep* '(integer 10) '(integer 5 *)) - t t) - -(deftest subtypep.integer.16 - (subtypep* '(integer 5 *) '(integer 10)) - nil t) - -(deftest subtypep.integer.17 - (subtypep* '(integer 10 *) '(integer 5 *)) - t t) - -(deftest subtypep.integer.18 - (subtypep* '(integer 5 *) '(integer 10 *)) - nil t) - -(deftest subtypep.integer.19 - (subtypep* '(integer * 5) '(integer * 10)) - t t) - -(deftest subtypep.integer.20 - (subtypep* '(integer * 10) '(integer * 5)) - nil t) - -(deftest subtypep.integer.21 - (subtypep* '(integer 10 *) '(integer * 10)) - nil t) - -(deftest subtypep.integer.22 - (subtypep* '(integer * 10) '(integer 10 *)) - nil t) - -(deftest subtypep.integer.23 - (check-equivalence '(integer (9)) '(integer 10)) - nil) - -(deftest subtypep.integer.24 - (check-equivalence '(integer * (11)) '(integer * 10)) - nil) - -(deftest subtypep.integer.25 - (check-equivalence - '(and (or (integer 0 10) (integer 20 30)) - (or (integer 5 15) (integer 25 35))) - '(or (integer 5 10) (integer 25 30))) - nil) - -(deftest subtypep.integer.26 - (check-equivalence - '(and (integer 0 10) (integer 5 15)) - '(integer 5 10)) - nil) - -(deftest subtypep.integer.27 - (check-equivalence - '(or (integer 0 10) (integer 5 15)) - '(integer 0 15)) - nil) - -(deftest subtypep.integer.28 - (check-equivalence - '(and integer (not (eql 10))) - '(or (integer * 9) (integer 11 *))) - nil) - -(deftest subtypep.integer.29 - (check-equivalence - '(and integer (not (integer 1 10))) - '(or (integer * 0) (integer 11 *))) - nil) - -(deftest subtypep.integer.30 - (check-equivalence - '(and (integer -100 100) (not (integer 1 10))) - '(or (integer -100 0) (integer 11 100))) - nil) - -;;; Relations between integer and real types - -(deftest subtypep.integer.real.1 - (check-equivalence - '(and integer (real 4 10)) - '(integer 4 10)) - nil) - -(deftest subtypep.integer.real.2 - (check-equivalence - '(and (integer 4 *) (real * 10)) - '(integer 4 10)) - nil) - -(deftest subtypep.integer.real.3 - (check-equivalence - '(and (integer * 10) (real 4)) - '(integer 4 10)) - nil) - -(deftest subtypep.integer.real.4 - (loop for int-type in '(integer (integer) (integer *) (integer * *)) - append (loop for real-type in '(real (real) (real *) (real * *)) - unless (equal (multiple-value-list - (subtypep* int-type real-type)) - '(t t)) - collect (list int-type real-type))) - nil) - -(deftest subtypep.integer.real.5 - (loop for int-type in '((integer 10) (integer 10 *)) - append (loop for real-type in '(real (real) (real *) (real * *) - (real 10.0) (real 10.0 *) - (real 10) (real 10 *)) - unless (equal (multiple-value-list - (subtypep* int-type real-type)) - '(t t)) - collect (list int-type real-type))) - nil) - -(deftest subtypep.integer.real.6 - (loop for int-type in '((integer * 10) (integer * 5)) - append (loop for real-type in '(real (real) (real *) (real * *) - (real * 10.0) - (real * 10) (real * 1000000000000)) - unless (equal (multiple-value-list - (subtypep* int-type real-type)) - '(t t)) - collect (list int-type real-type))) - nil) - -(deftest subtypep.integer.real.7 - (loop for int-type in '((integer 0 10) (integer 2 5)) - append (loop for real-type in '(real (real) (real *) (real * *) - (real * 10) (real * 1000000000000) - (real -10) (real -10.0) - (real -10 *) (real -10.0 *) - (real 0) (real 0.0) - (real 0 10) (real * 10) - (real 0 *) (real 0 10)) - unless (equal (multiple-value-list - (subtypep* int-type real-type)) - '(t t)) - collect (list int-type real-type))) - nil) - -(deftest subtypep.integer.real.8 - (check-equivalence - '(and (integer 4) (real * 10)) - '(integer 4 10)) - nil) - -(deftest subtypep.integer.real.9 - (check-equivalence - '(and (integer * 10) (real 4)) - '(integer 4 10)) - nil) - -(deftest subtypep.integer.real.10 - (check-equivalence - '(and (integer 4) (real * (10))) - '(integer 4 9)) - nil) - -(deftest subtypep.integer.real.11 - (check-equivalence - '(and (integer * 10) (real (4))) - '(integer 5 10)) - nil) - - -;;; Between integer and rational types - -(deftest subtypep.integer.rational.1 - (check-equivalence - '(and integer (rational 4 10)) - '(integer 4 10)) - nil) - -(deftest subtypep.integer.rational.2 - (check-equivalence - '(and (integer 4 *) (rational * 10)) - '(integer 4 10)) - nil) - -(deftest subtypep.integer.rational.3 - (check-equivalence - '(and (integer * 10) (rational 4)) - '(integer 4 10)) - nil) - - - -(deftest subtypep.integer.rational.4 - (loop for int-type in '(integer (integer) (integer *) (integer * *)) - append (loop for rational-type - in '(rational (rational) (rational *) (rational * *)) - unless (equal (multiple-value-list - (subtypep* int-type rational-type)) - '(t t)) - collect (list int-type rational-type))) - nil) - -(deftest subtypep.integer.rational.5 - (loop for int-type in '((integer 10) (integer 10 *)) - append (loop for rational-type - in '(rational (rational) (rational *) (rational * *) - (rational 19/2) (rational 19/2 *) - (rational 10) (rational 10 *)) - unless (equal (multiple-value-list - (subtypep* int-type rational-type)) - '(t t)) - collect (list int-type rational-type))) - nil) - -(deftest subtypep.integer.rational.6 - (loop for int-type in '((integer * 10) (integer * 5)) - append (loop for rational-type - in '(rational (rational) (rational *) (rational * *) - (rational * 21/2) - (rational * 10) (rational * 1000000000000)) - unless (equal (multiple-value-list - (subtypep* int-type rational-type)) - '(t t)) - collect (list int-type rational-type))) - nil) - -(deftest subtypep.integer.rational.7 - (loop for int-type in '((integer 0 10) (integer 2 5)) - append (loop for rational-type in - '(rational (rational) (rational *) (rational * *) - (rational * 10) (rational * 1000000000000) - (rational -1) (rational -1/2) - (rational -1 *) (rational -1/2 *) - (rational 0) - (rational 0 10) (rational * 10) - (rational 0 *) (rational 0 10)) - unless (equal (multiple-value-list - (subtypep* int-type rational-type)) - '(t t)) - collect (list int-type rational-type))) - nil) - -(deftest subtypep.integer.rational.8 - (check-equivalence - '(and integer (rational (4) 10)) - '(integer 5 10)) - nil) - -(deftest subtypep.integer.rational.9 - (check-equivalence - '(and (integer 4 *) (rational * (10))) - '(integer 4 9)) - nil) - -(deftest subtypep.integer.rational.10 - (check-equivalence - '(and (integer * 10) (rational (4))) - '(integer 5 10)) - nil) diff --git a/t/ansi-test/types-and-classes/subtypep-member.lsp b/t/ansi-test/types-and-classes/subtypep-member.lsp deleted file mode 100644 index 5e35bbe..0000000 --- a/t/ansi-test/types-and-classes/subtypep-member.lsp +++ /dev/null @@ -1,231 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Feb 15 11:58:06 2003 -;;;; Contains: Tests for subtype relationships on member types - -(in-package :cl-test) - - - -;;; SUBTYPEP on MEMBER types - -(deftest subtypep.member.1 - (check-all-subtypep '(member a b c) '(member a b c d)) - nil) - -(deftest subtypep.member.2 - (check-all-not-subtypep '(member a b c) '(member a b)) - nil) - -(deftest subtypep.member.3 - (check-equivalence '(member) nil) - nil) - -(deftest subtypep.member.4 - (check-all-subtypep '(eql b) '(member a b c)) - nil) - -(deftest subtypep.member.5 - (check-all-subtypep '(member a b c d e) 'symbol) - nil) - -(deftest subtypep.member.6 - (check-all-not-subtypep '(member a b 10 d e) 'symbol) - nil) - -(deftest subtypep.member.7 - (check-all-subtypep 'null '(member a b nil c d e)) - nil) - -(deftest subtypep.member.8 - (check-all-not-subtypep 'null '(member a b c d e)) - nil) - -(deftest subtypep.member.9 - (let ((b1 (1+ most-positive-fixnum)) - (b2 (1+ most-positive-fixnum))) - (check-all-subtypep `(member 10 ,b1 20) `(member 10 20 ,b2))) - nil) - -(deftest subtypep.member.10 - (check-all-subtypep '(member :a :b :c) 'keyword) - nil) - -(deftest subtypep.member.11 - (let ((b1 (copy-list '(a))) - (b2 (copy-list '(a)))) - (check-all-not-subtypep `(member 10 ,b1 20) `(member 10 20 ,b2))) - nil) - -(deftest subtypep.member.12 - (let ((b1 '(a))) - (check-all-subtypep `(member 10 ,b1 20) `(member 10 20 ,b1))) - nil) - -(deftest subtypep.member.13 - (check-all-subtypep '(member 10 20 30) '(integer 0 100)) - nil) - -(deftest subtypep.member.14 - (check-all-subtypep '(integer 3 6) '(member 0 1 2 3 4 5 6 7 8 100)) - nil) - -(deftest subtypep.member.15 - (check-all-not-subtypep '(integer 3 6) '(member 0 1 2 3 5 6 7 8)) - nil) - -(deftest subtypep.member.16 - (check-equivalence '(integer 2 5) '(member 2 5 4 3)) - nil) - -(deftest subtypep.member.17 - (let ((s1 (copy-seq "abc")) - (s2 (copy-seq "abc"))) - (let ((t1 `(member ,s1)) - (t2 `(member ,s2))) - (cond - ((subtypep t1 t2) "T1 is subtype of T2") - ((subtypep t2 t1) "T2 is subtype of T1") - (t (check-disjointness t1 t2))))) - nil) - -(deftest subtypep.member.18 - (let ((s1 (copy-seq '(a b c))) - (s2 (copy-seq '(a b c)))) - (let ((t1 `(member ,s1)) - (t2 `(member ,s2))) - (cond - ((subtypep t1 t2) "T1 is subtype of T2") - ((subtypep t2 t1) "T2 is subtype of T1") - (t (check-disjointness t1 t2))))) - nil) - -(deftest subtypep.member.19 - (let ((i1 (1+ most-positive-fixnum)) - (i2 (1+ most-positive-fixnum))) - (check-equivalence `(member 0 ,i1) `(member 0 ,i2))) - nil) - -(deftest subtypep.member.20 - (check-equivalence '(and (member a b c d) (member e d b f g)) - '(member b d)) - nil) - -(deftest subtypep.member.21 - (check-equivalence '(and (member a b c d) (member e d f g)) - '(eql d)) - nil) - -(deftest subtypep.member.22 - (check-equivalence '(and (member a b c d) (member e f g)) - nil) - nil) - -(deftest subtypep.member.23 - (check-equivalence '(or (member a b c) (member z b w)) - '(member z a b w c)) - nil) - -(deftest subtypep.member.24 - (check-equivalence '(or (member a b c) (eql d)) - '(member d c b a)) - nil) - -(deftest subtypep.member.25 - (check-equivalence 'boolean '(member nil t)) - nil) - -(deftest subtypep.member.26 - (check-equivalence '(or (eql a) (eql b)) - '(member a b)) - nil) - -(deftest subtypep.member.27 - (check-all-subtypep '(member a b c d) '(satisfies symbolp)) - nil) - -(deftest subtypep.member.28 - (check-all-subtypep '(member a b c d) t) - nil) - -(deftest subtypep.member.29 - (check-all-not-subtypep '(member a b 10 z) '(satisfies symbolp)) - nil) - -(deftest subtypep.member.30 - (check-disjointness '(member 1 6 10) '(satisfies symbolp)) - nil) - -(deftest subtypep.member.31 - (check-equivalence '(member a b c d) '(member c d b a)) - nil) - -(deftest subtypep.member.32 - (check-all-not-subtypep '(not (member a b 10 z)) '(satisfies symbolp)) - nil) - -(deftest subtypep.member.33 - (check-all-not-subtypep '(satisfies symbolp) '(member a b 10 z)) - nil) - -(deftest subtypep.member.34 - (check-all-not-subtypep '(member a b 10 z) '(not (satisfies symbolp))) - nil) - -(deftest subtypep.member.35 - (check-all-not-subtypep '(satisfies symbolp) '(member a b c d)) - nil) - -(deftest subtypep.member.36 - (check-disjointness '(eql a) '(or (member b c d) (eql e))) - nil) - -(deftest subtypep.member.37 - (check-equivalence - '(and (member a b c d) (not (eql c))) - '(member a b d)) - nil) - -(deftest subtypep.member.38 - (check-equivalence - '(and (member a b c d e f g) - (not (member b f))) - '(member a c d e g)) - nil) - -(deftest subtypep.member.39 - (check-equivalence - '(and (not (member b d e f g)) - (not (member x y b z d))) - '(not (member b d e f g x y z))) - nil) - -(deftest subtypep.member.40 - (check-equivalence - '(and (not (eql a)) (not (eql b))) - '(not (member a b))) - nil) - -(deftest subtypep.member.41 - (check-equivalence - '(and (not (eql a)) (not (eql b)) (not (eql c))) - '(not (member c b a))) - nil) - -(deftest subtypep.member.42 - (check-equivalence - '(and (not (member a b)) (not (member b c))) - '(not (member c b a))) - nil) - -(deftest subtypep.member.43 - (check-equivalence - '(and (not (member a g b k e)) (not (member b h k c f))) - '(not (member c b k a e f g h))) - nil) - -(deftest subtypep.member.44 - (check-equivalence - '(and (integer 0 30) (not (member 3 4 5 9 10 11 17 18 19))) - '(or (integer 0 2) (integer 6 8) (integer 12 16) (integer 20 30))) - nil) diff --git a/t/ansi-test/types-and-classes/subtypep-rational.lsp b/t/ansi-test/types-and-classes/subtypep-rational.lsp deleted file mode 100644 index a6c1e2d..0000000 --- a/t/ansi-test/types-and-classes/subtypep-rational.lsp +++ /dev/null @@ -1,175 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Sat Feb 15 11:56:19 2003 -;;;; Contains: Tests for subtype relationships on rational types - -(in-package :cl-test) - - - -;;; SUBTYPEP on rational types - -(deftest subtypep.rational.1 - (loop for tp1 in '((rational 10) (rational 10 *) - (rational 10 20) - (rational (10) 20) - (rational 10 (20)) - (rational (10) (20)) - (rational 10 1000000000000000) - (rational (10)) (rational (10) *)) - append - (loop for tp2 in '(rational (rational) (rational *) - (rational * *) (rational 10) (rational 10 *) - (rational 0) (rational 0 *) - (rational 19/2) (rational 19/2 *) - (rational -1000000000000000) - real (real) (real *) - (real * *) (real 10) (real 10 *) - (real 0) (real 0 *) - (real 19/2) (real 19/2 *) - (real -1000000000000000)) - unless (equal (multiple-value-list - (subtypep* tp1 tp2)) - '(t t)) - collect (list tp1 tp2))) - nil) - -(deftest subtypep.rational.2 - (loop for tp1 in '((rational * 10) - (rational 0 10) - (rational 0 (10)) - (rational (0) 10) - (rational (0) (10)) - (rational -1000000000000000 10) - (rational * (10))) - append - (loop for tp2 in '(rational (rational) (rational *) - (rational * *) (rational * 10) - (rational * 21/2) - (rational * 1000000000000000) - real (real) (real *) - (real * *) (real * 10) - (real * 21/2) - (real * 1000000000000000)) - unless (equal (multiple-value-list - (subtypep* tp1 tp2)) - '(t t)) - collect (list tp1 tp2))) - nil) - -(deftest subtypep.rational.3 - (loop for tp1 in '((rational 10) (rational 10 *) - (rational 10 20) - (rational 10 (21)) - (rational 10 1000000000000000)) - append - (loop for tp2 in '((rational 11) (rational 11 *) - (rational (10)) (rational (10) *) - (integer 10) (integer 10 *) - (real 11) - (real (10)) - (real 11 *) - (real (10) *) - (rational * (20)) - (rational * 19) - (real * (20)) - (real * 19)) - unless (equal (multiple-value-list - (subtypep* tp1 tp2)) - '(nil t)) - collect (list tp1 tp2))) - nil) - -(deftest subtypep.rational.4 - (loop for tp1 in '((rational * 10) - (rational 0 10) - (rational (0) 10) - (rational -1000000000000000 10)) - append - (loop for tp2 in '((rational * 9) - (rational * (10)) - (integer * 10) - (real * 9) - (real * (10))) - unless (equal (multiple-value-list - (subtypep* tp1 tp2)) - '(nil t)) - collect (list tp1 tp2))) - nil) - -(deftest subtypep.rational.5 - (check-equivalence - '(or (rational 0 0) (rational (0))) - '(rational 0)) - nil) - -(deftest subtypep.rational.6 - (check-equivalence - '(and (rational 0 10) (rational 5 15)) - '(rational 5 10)) - nil) - -(deftest subtypep.rational.7 - (check-equivalence - '(and (rational (0) 10) (rational 5 15)) - '(rational 5 10)) - nil) - -(deftest subtypep.rational.8 - (check-equivalence - '(and (rational 0 (10)) (rational 5 15)) - '(rational 5 (10))) - nil) - -(deftest subtypep.rational.9 - (check-equivalence - '(and (rational (0) (10)) (rational 5 15)) - '(rational 5 (10))) - nil) - -(deftest subtypep.rational.10 - (check-equivalence - '(and (rational 0 10) (rational (5) 15)) - '(rational (5) 10)) - nil) - -(deftest subtypep.rational.11 - (check-equivalence - '(and (rational 0 (10)) (rational (5) 15)) - '(rational (5) (10))) - nil) - -(deftest subtypep.rational.12 - (check-equivalence - '(and integer (rational 0 10) (not (rational (0) (10)))) - '(member 0 10)) - nil) - -(deftest subtypep.rational.13 - (check-equivalence '(and integer (rational -1/2 1/2)) - '(integer 0 0)) - nil) - -(deftest subtypep.rational.14 - (check-equivalence '(and integer (rational -1/2 1/2)) - '(eql 0)) - nil) - -(deftest subtypep.rational.15 - (check-equivalence '(and integer (rational (-1/2) 1/2)) - '(integer 0 0)) - nil) - -(deftest subtypep.rational.16 - (check-equivalence '(and integer (rational (-1/2) (1/2))) - '(integer 0 0)) - nil) - -(deftest subtypep.rational.17 - (check-all-subtypep '(not (rational -1/2 1/2)) '(not (integer 0 0))) - nil) - -(deftest subtypep.rational.18 - (check-all-subtypep '(not (rational -1/2 1/2)) '(not (eql 0))) - nil) - diff --git a/t/ansi-test/types-and-classes/subtypep-real.lsp b/t/ansi-test/types-and-classes/subtypep-real.lsp deleted file mode 100644 index 2b937e7..0000000 --- a/t/ansi-test/types-and-classes/subtypep-real.lsp +++ /dev/null @@ -1,201 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Tue Feb 18 18:38:55 2003 -;;;; Contains: Tests of SUBTYPEP on REAL types. - -(in-package :cl-test) - - - -;;; SUBTYPEP on real types - -(deftest subtypep.real.1 - (loop for tp1 in '((real 10) (real 10 *) - (real 10 20) - (real (10) 20) - (real 10 (20)) - (real (10) (20)) - (real 10 1000000000000000) - (real (10)) (real (10) *)) - append - (loop for tp2 in '(real (real) (real *) - (real * *) (real 10) (real 10 *) - (real 0) (real 0 *) - (real 19/2) (real 19/2 *) - (real 9.5) (real 9.5 *) - (real -1000000000000000)) - unless (equal (multiple-value-list - (subtypep* tp1 tp2)) - '(t t)) - collect (list tp1 tp2))) - nil) - -(deftest subtypep.real.2 - (loop for tp1 in '((real * 10) - (real 0 10) - (real 0 (10)) - (real (0) 10) - (real (0) (10)) - (real -1000000000000000 10) - (real * (10))) - append - (loop for tp2 in '(real (real) (real *) - (real * *) (real * 10) - (real * 21/2) - (real * 10.5) - (real * 1000000000000000)) - unless (equal (multiple-value-list - (subtypep* tp1 tp2)) - '(t t)) - collect (list tp1 tp2))) - nil) - -(deftest subtypep.real.3 - (loop for tp1 in '((real 10) (real 10 *) - (real 10 20) - (real 10 (21)) - (real 10 1000000000000000)) - append - (loop for tp2 in '((real 11) (real 11 *) - (real (10)) (real (10) *) - (integer 10) (integer 10 *) - (real 11) - (real (10)) - (real 11 *) - (real (10) *) - (real * (20)) - (real * 19) - (real * (20)) - (real * 19)) - unless (equal (multiple-value-list - (subtypep* tp1 tp2)) - '(nil t)) - collect (list tp1 tp2))) - nil) - -(deftest subtypep.real.4 - (loop for tp1 in '((real * 10) - (real 0 10) - (real (0) 10) - (real -1000000000000000 10)) - append - (loop for tp2 in '((real * 9) - (real * (10)) - (integer * 10) - (real * 9) - (real * (10))) - unless (equal (multiple-value-list - (subtypep* tp1 tp2)) - '(nil t)) - collect (list tp1 tp2))) - nil) - -(deftest subtypep.real.5 - (check-equivalence - '(or (real 0 0) (real (0))) - '(real 0)) - nil) - -(deftest subtypep.real.6 - (check-equivalence - '(and (real 0 10) (real 5 15)) - '(real 5 10)) - nil) - -(deftest subtypep.real.7 - (check-equivalence - '(and (real (0) 10) (real 5 15)) - '(real 5 10)) - nil) - -(deftest subtypep.real.8 - (check-equivalence - '(and (real 0 (10)) (real 5 15)) - '(real 5 (10))) - nil) - -(deftest subtypep.real.9 - (check-equivalence - '(and (real (0) (10)) (real 5 15)) - '(real 5 (10))) - nil) - -(deftest subtypep.real.10 - (check-equivalence - '(and (real 0 10) (real (5) 15)) - '(real (5) 10)) - nil) - -(deftest subtypep.real.11 - (check-equivalence - '(and (real 0 (10)) (real (5) 15)) - '(real (5) (10))) - nil) - -(deftest subtypep.real.12 - (check-equivalence - '(and integer (real 0 10) (not (real (0) (10)))) - '(member 0 10)) - nil) - -(deftest subtypep.real.13 - (check-equivalence '(and integer (real -1/2 1/2)) - '(integer 0 0)) - nil) - -(deftest subtypep.real.14 - (check-equivalence '(and integer (real -1/2 1/2)) - '(eql 0)) - nil) - -(deftest subtypep.real.15 - (check-equivalence '(and integer (real (-1/2) 1/2)) - '(integer 0 0)) - nil) - -(deftest subtypep.real.16 - (check-equivalence '(and integer (real (-1/2) (1/2))) - '(integer 0 0)) - nil) - -(deftest subtypep.real.17 - (check-equivalence '(real 0 10) '(real 0.0 10.0)) - nil) - -(deftest subtypep.real.18 - (check-equivalence '(and rational (real 0 10)) - '(rational 0 10)) - nil) - -(deftest subtypep.real.19 - (check-equivalence '(and rational (real 0 (10))) - '(rational 0 (10))) - nil) - -(deftest subtypep.real.20 - (check-equivalence '(and rational (real (0) (10))) - '(rational (0) (10))) - nil) - -(deftest subtypep.real.21 - (check-equivalence '(and rational (real 1/2 7/3)) - '(rational 1/2 7/3)) - nil) - -(deftest subtypep.real.22 - (check-equivalence '(and rational (real (1/11) (8/37))) - '(rational (1/11) (8/37))) - nil) - -(deftest subtypep.real.23 - (check-all-subtypep '(not (real -1/2 1/2)) '(not (integer 0 0))) - nil) - -(deftest subtypep.real.24 - (check-all-subtypep '(not (real -1/2 1/2)) '(not (eql 0))) - nil) - -(deftest subtypep.real.25 - (check-all-subtypep t '(or (not (real 0 10)) (not (real -100 -50)))) - nil) - diff --git a/t/ansi-test/types-and-classes/subtypep.lsp b/t/ansi-test/types-and-classes/subtypep.lsp deleted file mode 100644 index 2663ceb..0000000 --- a/t/ansi-test/types-and-classes/subtypep.lsp +++ /dev/null @@ -1,217 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Jan 29 17:28:19 2003 -;;;; Contains: Tests of SUBTYPEP - -(in-package :cl-test) - - - -;;; More subtypep tests are in types-and-class.lsp - -(deftest subtypep.order.1 - (let ((i 0) x y) - (values - (notnot (subtypep (progn (setf x (incf i)) t) - (progn (setf y (incf i)) t))) - i x y)) - t 2 1 2) - -(deftest simple-base-string-is-sequence - (subtypep* 'simple-base-string 'sequence) - t t) - -(deftest subtype.env.1 - (mapcar #'notnot - (multiple-value-list (subtypep 'bit 'integer nil))) - (t t)) - -(deftest subtype.env.2 - (macrolet - ((%foo (&environment env) - (list 'quote - (mapcar #'notnot - (multiple-value-list - (subtypep 'bit 'integer env)))))) - (%foo)) - (t t)) - -(deftest subtype.env.3 - (macrolet - ((%foo (&environment env) - (multiple-value-bind (sub good) - (subtypep nil (type-of env)) - (or (not good) (notnot sub))))) - (%foo)) - t) - -(deftest subtype.env.4 - (macrolet - ((%foo (&environment env) - (multiple-value-bind (sub good) - (subtypep (type-of env) (type-of env)) - (or (not good) (notnot sub))))) - (%foo)) - t) - -(deftest subtype.env.5 - (macrolet - ((%foo (&environment env) - (multiple-value-bind (sub good) - (subtypep (type-of env) t) - (or (not good) (notnot sub))))) - (%foo)) - t) - -(deftest subtypep.error.1 - (signals-error (subtypep) program-error) - t) - -(deftest subtypep.error.2 - (signals-error (subtypep t) program-error) - t) - -(deftest subtypep.error.3 - (signals-error (subtypep t t nil nil) program-error) - t) - -;;; Special cases of types-6 that are/were causing problems in CMU CL - -(deftest keyword-is-subtype-of-atom - (subtypep* 'keyword 'atom) - t t) - -(deftest ratio-is-subtype-of-atom - (subtypep* 'ratio 'atom) - t t) - -(deftest extended-char-is-subtype-of-atom - (subtypep* 'extended-char 'atom) - t t) - -(deftest string-is-not-simple-vector - (subtypep* 'string 'simple-vector) - nil t) - -(deftest base-string-is-not-simple-vector - (subtypep* 'base-string 'simple-vector) - nil t) - -(deftest simple-string-is-not-simple-vector - (subtypep* 'simple-string 'simple-vector) - nil t) - -(deftest simple-base-string-is-not-simple-vector - (subtypep* 'simple-base-string 'simple-vector) - nil t) - -(deftest bit-vector-is-not-simple-vector - (subtypep* 'bit-vector 'simple-vector) - nil t) - -(deftest simple-bit-vector-is-not-simple-vector - (subtypep* 'simple-bit-vector 'simple-vector) - nil t) - -;;; Extended characters - -(deftest subtypep.extended-char.1 - (if (subtypep* 'character 'base-char) - (subtypep* 'extended-char nil) - (values t t)) - t t) - -(deftest subtypep.extended-char.2 - (if (subtypep* 'extended-char nil) - (subtypep* 'character 'base-char) - (values t t)) - t t) - -(deftest subtypep.extended-char.3 - (check-equivalence 'extended-char '(and character (not base-char))) - nil) - - -;;; Some and, or combinations - -(deftest subtypep.and/or.1 - (check-equivalence - '(and (or symbol (integer 0 15)) - (or symbol (integer 10 25))) - '(or symbol (integer 10 15))) - nil) - -(deftest subtypep.and/or.2 - (check-equivalence - '(and (or (not symbol) (integer 0 10)) - (or symbol (integer 11 25))) - '(integer 11 25)) - nil) - -(deftest subtypep.and.1 - (loop for type in *types-list3* - append (check-equivalence `(and ,type ,type) type)) - nil) - -(deftest subtypep.or.1 - (loop for type in *types-list3* - append (check-equivalence `(or ,type ,type) type)) - nil) - -(deftest subtypep.and.2 - (check-equivalence t '(and)) - nil) - -(deftest subtypep.or.2 - (check-equivalence nil '(or)) - nil) - -(deftest subtypep.and.3 - (loop for type in *types-list3* - append (check-equivalence `(and ,type) type)) - nil) - -(deftest subtypep.or.3 - (loop for type in *types-list3* - append (check-equivalence `(or ,type) type)) - nil) - -(deftest subtypep.and.4 - (let* ((n (length *types-list3*)) - (a (make-array n :initial-contents *types-list3*))) - (trim-list - (loop for i below 1000 - for tp1 = (aref a (random n)) - for tp2 = (aref a (random n)) - append (check-equivalence `(and ,tp1 ,tp2) - `(and ,tp2 ,tp1))) - 100)) - nil) - -(deftest subtypep.or.4 - (let* ((n (length *types-list3*)) - (a (make-array n :initial-contents *types-list3*))) - (trim-list - (loop for i below 1000 - for tp1 = (aref a (random n)) - for tp2 = (aref a (random n)) - append (check-equivalence `(or ,tp1 ,tp2) - `(or ,tp2 ,tp1))) - 100)) - nil) - -;;; Check that types that are supposed to be nonempty are -;;; not subtypes of NIL - -(deftest subtypep.nil.1 - (loop for (type) in *subtype-table* - unless (member type '(nil extended-char)) - append (check-all-not-subtypep type nil)) - nil) - -(deftest subtypep.nil.2 - (loop for (type) in *subtype-table* - for class = (find-class type nil) - unless (or (not class) (member type '(nil extended-char))) - append (check-all-not-subtypep class nil)) - nil) diff --git a/t/ansi-test/types-and-classes/type-of.lsp b/t/ansi-test/types-and-classes/type-of.lsp deleted file mode 100644 index 662f6dd..0000000 --- a/t/ansi-test/types-and-classes/type-of.lsp +++ /dev/null @@ -1,123 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Jun 4 21:15:05 2003 -;;;; Contains: Tests of TYPE-OF - -(in-package :cl-test) - -;;; It turns out I left out an important test of type-of: -;;; (type-of x) must be a recognizable subtype of every builtin type -;;; of which x is a member. - -(deftest type-of.1 - :notes :type-of/strict-builtins - (loop for x in *universe* - for tp = (type-of x) - for failures = (loop for tp2 in *cl-all-type-symbols* - when (and (typep x tp2) - (not (subtypep tp tp2))) - collect tp2) - when failures collect (list x failures)) - nil) - -;;; Some have objected to that (in type-of.1) interpretation -;;; of req. 1.a in the TYPE-OF page, saying that it need hold -;;; for only *one* builtin type that the object is an element of. -;;; This test tests the relaxed requirement. - -(deftest type-of.1-relaxed - (loop for x in *universe* - for builtins = (remove x *cl-all-type-symbols* - :test (complement #'typep)) - for tp = (type-of x) - when (and builtins - (not (loop for tp2 in builtins - thereis (subtypep tp tp2)))) - collect x) - nil) - -;;; 1. For any object that is an element of some built-in type: -;;; b. the type returned does not involve and, eql, member, not, -;;; or, satisfies, or values. -;;; -;;; Since every object is an element of the built-in type T, this -;;; applies universally. - -(deftest type-of.2 - (loop for x in *universe* - for tp = (type-of x) - when (and (consp tp) - (member (car tp) '(and eql member not or satisfies values - function))) - collect x) - nil) - -(deftest type-of.3 - (loop for x in *universe* - unless (typep x (type-of x)) - collect x) - nil) - -(deftest type-of.4 - (loop for x in *universe* - for tp = (type-of x) - for class = (class-of x) - unless (equal (multiple-value-list (subtypep* tp class)) '(t t)) - collect x) - nil) - -(deftest type-of.5 - (loop for x in *cl-condition-type-symbols* - for cnd = (make-condition x) - for tp = (type-of cnd) - unless (eq x tp) - collect x) - nil) - -(defstruct type-of.example-struct a b c) - -(deftest type-of.6 - (type-of (make-type-of.example-struct)) - type-of.example-struct) - -(defclass type-of.example-class () ()) - -(deftest type-of.7 - (type-of (make-instance 'type-of.example-class)) - type-of.example-class) - -(deftest type-of.8 - (let ((class (eval '(defclass type-of.example-class-2 () ((a) (b) (c)))))) - (setf (class-name class) nil) - (eqt (type-of (make-instance class)) class)) - t) - -(deftest type-of.9 - (let ((class (eval '(defclass type-of.example-class-3 () ((a) (b) (c)))))) - (setf (find-class 'type-of.example-class-3) nil) - (eqt (type-of (make-instance class)) class)) - t) - -(deftest type-of.10 - (let* ((class (eval '(defclass type-of.example-class-4 () ((a) (b) (c))))) - (obj (make-instance class))) - (setf (class-name class) nil) - (notnot-mv (typep obj class))) - t) - -(deftest type-of.11 - (let* ((c #c(-1 1/2)) - (type (type-of c))) - (notnot (typep c type))) - t) - -;;; Error tests - -(deftest type-of.error.1 - (signals-error (type-of) program-error) - t) - -(deftest type-of.error.2 - (signals-error (type-of nil nil) program-error) - t) - diff --git a/t/ansi-test/types-and-classes/typep.lsp b/t/ansi-test/types-and-classes/typep.lsp deleted file mode 100644 index 12ee7bb..0000000 --- a/t/ansi-test/types-and-classes/typep.lsp +++ /dev/null @@ -1,175 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Mon May 23 07:13:32 2005 -;;;; Contains: Tests of TYPEP - -(in-package :cl-test) - -(deftest typep.error.1 - (signals-error (typep) program-error) - t) - -(deftest typep.error.2 - (signals-error (typep nil) program-error) - t) - -(deftest typep.error.3 - (signals-error (typep nil t nil nil) program-error) - t) - -(deftest typep.error.4 - (signals-error-always (typep nil 'values) error) - t t) - -(deftest typep.error.5 - (signals-error-always (typep nil '(values)) error) - t t) - -(deftest typep.error.6 - (signals-error-always (typep nil '(values t t t t)) error) - t t) - -(deftest typep.error.7 - (signals-error-always (typep nil '(function () t)) error) - t t) - -;;; Non-error tests -;;; Many more tests use typep when testing other functions - -(deftest typep-nil-null - (notnot-mv (typep nil 'null)) - t) - -(deftest typep-t-null - (typep t 'null) - nil) - -;;; Tests of env arguments to typep - -(deftest typep.env.1 - (notnot-mv (typep 0 'bit nil)) - t) - -(deftest typep.env.2 - (macrolet ((%foo (&environment env) - (notnot-mv (typep 0 'bit env)))) - (%foo)) - t) - -(deftest typep.env.3 - (macrolet ((%foo (&environment env) - (notnot-mv (typep env (type-of env))))) - (%foo)) - t) - -;;; Other typep tests - -(deftest typep.1 - (notnot-mv (typep 'a '(eql a))) - t) - -(deftest typep.2 - (notnot-mv (typep 'a '(and (eql a)))) - t) - -(deftest typep.3 - (notnot-mv (typep 'a '(or (eql a)))) - t) - -(deftest typep.4 - (typep 'a '(eql b)) - nil) - -(deftest typep.5 - (typep 'a '(and (eql b))) - nil) - -(deftest typep.6 - (typep 'a '(or (eql b))) - nil) - -(deftest typep.7 - (notnot-mv (typep 'a '(satisfies symbolp))) - t) - -(deftest typep.8 - (typep 10 '(satisfies symbolp)) - nil) - -(deftest typep.9 - (let ((class (find-class 'symbol))) - (notnot-mv (typep 'a class))) - t) - -(deftest typep.10 - (let ((class (find-class 'symbol))) - (notnot-mv (typep 'a `(and ,class)))) - t) - -(deftest typep.11 - (let ((class (find-class 'symbol))) - (typep 10 class)) - nil) - -(deftest typep.12 - (let ((class (find-class 'symbol))) - (typep 10 `(and ,class))) - nil) - -(deftest typep.13 - (typep 'a '(and symbol integer)) - nil) - -(deftest typep.14 - (notnot-mv (typep 'a '(or symbol integer))) - t) - -(deftest typep.15 - (notnot-mv (typep 'a '(or integer symbol))) - t) - -(deftest typep.16 - (let ((c1 (find-class 'number)) - (c2 (find-class 'symbol))) - (notnot-mv (typep 'a `(or ,c1 ,c2)))) - t) - -(deftest typep.17 - (let ((c1 (find-class 'number)) - (c2 (find-class 'symbol))) - (notnot-mv (typep 'a `(or ,c2 ,c1)))) - t) - -(deftest typep.18 - (let ((i 0)) - (values - (notnot (typep (incf i) '(and (integer 0 10) (integer -5 6)))) - i)) - t 1) - -(defun typep.19-fn (reps &optional (prob .5)) - (let* ((vec "abcdefghijklmnopqrstuvwxyz")) - (flet ((%make-random-type - () - `(and character (member ,@(loop for e across vec - when (< (random 1.0) prob) - collect e))))) - (loop - for t1 = (%make-random-type) - for t2 = (%make-random-type) - for t3 = `(and ,t1 ,t2) - for result1 = (loop for e across vec - when (if (typep e t3) - (or (not (typep e t1)) (not (typep e t2))) - (and (typep e t1) (typep e t2))) - collect e) - repeat reps - when result1 - nconc (list result1 t1 t2 t3))))) - -(eval-when (:load-toplevel) (compile 'typep.19-fn)) - -(deftest typep.19 (typep.19-fn 1000) nil) - - - diff --git a/t/ansi-test/types-and-classes/types-and-class-2.lsp b/t/ansi-test/types-and-classes/types-and-class-2.lsp deleted file mode 100644 index 2c47f0b..0000000 --- a/t/ansi-test/types-and-classes/types-and-class-2.lsp +++ /dev/null @@ -1,199 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Wed Feb 5 21:20:05 2003 -;;;; Contains: More tests of types and classes - -(in-package :cl-test) - - - -;;; Union of a type with its complement is universal - -(deftest type-or-not-type-is-everything - (loop for l in *disjoint-types-list2* - append - (loop - for type in l - append (check-subtypep t `(or ,type (not ,type)) t) - append (check-subtypep t `(or (not ,type) ,type) t))) - nil) - -(defclass tac-1-class () (a b c)) -(defclass tac-1a-class (tac-1-class) (d e)) -(defclass tac-1b-class (tac-1-class) (f g)) - -(deftest user-class-disjointness - (loop for l in *disjoint-types-list2* - append - (loop - for type in l - append (classes-are-disjoint type 'tac-1-class))) - nil) - -(deftest user-class-disjointness-2 - (check-disjointness 'tac-1a-class 'tac-1b-class) - nil) - -(defstruct tac-2-struct a b c) -(defstruct (tac-2a-struct (:include tac-2-struct)) d e) -(defstruct (tac-2b-struct (:include tac-2-struct)) f g) - -(deftest user-struct-disjointness - (loop for l in *disjoint-types-list2* - append - (loop - for type in l - append (check-disjointness type 'tac-2-struct))) - nil) - -(deftest user-struct-disjointness-2 - (check-disjointness 'tac-2a-struct 'tac-2b-struct) - nil) - -(defclass tac-3-a () (x)) -(defclass tac-3-b () (y)) -(defclass tac-3-c () (z)) - -(defclass tac-3-ab (tac-3-a tac-3-b) ()) -(defclass tac-3-ac (tac-3-a tac-3-c) ()) -(defclass tac-3-bc (tac-3-b tac-3-c) ()) - -(defclass tac-3-abc (tac-3-ab tac-3-ac tac-3-bc) ()) - -(deftest tac-3.1 - (subtypep* 'tac-3-ab 'tac-3-a) - t t) - -(deftest tac-3.2 - (subtypep* 'tac-3-ab 'tac-3-b) - t t) - -(deftest tac-3.3 - (subtypep* 'tac-3-ab 'tac-3-c) - nil t) - -(deftest tac-3.4 - (subtypep* 'tac-3-a 'tac-3-ab) - nil t) - -(deftest tac-3.5 - (subtypep* 'tac-3-b 'tac-3-ab) - nil t) - -(deftest tac-3.6 - (subtypep* 'tac-3-c 'tac-3-ab) - nil t) - -(deftest tac-3.7 - (subtypep* 'tac-3-abc 'tac-3-a) - t t) - -(deftest tac-3.8 - (subtypep* 'tac-3-abc 'tac-3-b) - t t) - -(deftest tac-3.9 - (subtypep* 'tac-3-abc 'tac-3-c) - t t) - -(deftest tac-3.10 - (subtypep* 'tac-3-abc 'tac-3-ab) - t t) - -(deftest tac-3.11 - (subtypep* 'tac-3-abc 'tac-3-ac) - t t) - -(deftest tac-3.12 - (subtypep* 'tac-3-abc 'tac-3-bc) - t t) - -(deftest tac-3.13 - (subtypep* 'tac-3-ab 'tac-3-abc) - nil t) - -(deftest tac-3.14 - (subtypep* 'tac-3-ac 'tac-3-abc) - nil t) - -(deftest tac-3.15 - (subtypep* 'tac-3-bc 'tac-3-abc) - nil t) - -(deftest tac-3.16 - (check-equivalence '(and tac-3-a tac-3-b) 'tac-3-ab) - nil) - -(deftest tac-3.17 - (check-equivalence '(and (or tac-3-a tac-3-b) - (or (not tac-3-a) (not tac-3-b)) - (or tac-3-a tac-3-c) - (or (not tac-3-a) (not tac-3-c)) - (or tac-3-b tac-3-c) - (or (not tac-3-b) (not tac-3-c))) - nil) - nil) - -;;; -;;; Check that disjointness of types in *disjoint-types-list* -;;; is respected by all the elements of *universe* -;;; -(deftest universe-elements-in-at-most-one-disjoint-type - (loop for e in *universe* - for types = (remove-if-not #'(lambda (x) (typep e x)) - *disjoint-types-list*) - when (> (length types) 1) - collect (list e types)) - nil) - - - -;;;;; - -(deftest integer-and-ratio-are-disjoint - (classes-are-disjoint 'integer 'ratio) - nil) - -(deftest bignum-and-ratio-are-disjoint - (classes-are-disjoint 'bignum 'ratio) - nil) - -(deftest bignum-and-fixnum-are-disjoint - (classes-are-disjoint 'bignum 'fixnum) - nil) - -(deftest fixnum-and-ratio-are-disjoint - (classes-are-disjoint 'fixnum 'ratio) - nil) - -(deftest byte8-and-ratio-are-disjoint - (classes-are-disjoint '(unsigned-byte 8) 'ratio) - nil) - -(deftest bit-and-ratio-are-disjoint - (classes-are-disjoint 'bit 'ratio) - nil) - -(deftest integer-and-float-are-disjoint - (classes-are-disjoint 'integer 'float) - nil) - -(deftest ratio-and-float-are-disjoint - (classes-are-disjoint 'ratio 'float) - nil) - -(deftest complex-and-float-are-disjoint - (classes-are-disjoint 'complex 'float) - nil) - -(deftest integer-subranges-are-disjoint - (classes-are-disjoint '(integer 0 (10)) '(integer 10 (20))) - nil) - -(deftest keyword-and-null-are-disjoint - (classes-are-disjoint 'keyword 'null) - nil) - -(deftest keyword-and-boolean-are-disjoint - (classes-are-disjoint 'keyword 'boolean) - nil) diff --git a/t/ansi-test/types-and-classes/types-and-class.lsp b/t/ansi-test/types-and-classes/types-and-class.lsp deleted file mode 100644 index c2d5792..0000000 --- a/t/ansi-test/types-and-classes/types-and-class.lsp +++ /dev/null @@ -1,299 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Mar 19 21:48:39 1998 -;;;; Contains: Data for testing type and class inclusions - -;; We should check for every type that NIL is a subtype, and T a supertype - -(in-package :cl-test) - - - -(declaim (optimize (safety 3))) - -(deftest boolean-type.1 - (notnot-mv (typep nil 'boolean)) - t) - -(deftest boolean-type.2 - (notnot-mv (typep t 'boolean)) - t) - -(deftest boolean-type.3 - (check-type-predicate 'is-t-or-nil 'boolean) - nil) - -(deftest types.3 - (loop - for (t1 t2) in *subtype-table* - for m1 = (check-subtypep t1 t2 t t) - for m2 = (check-subtypep `(and ,t1 ,t2) t1 t) - for m3 = (check-subtypep `(and ,t2 ,t1) t1 t) - for m4 = (check-subtypep `(and ,t1 (not ,t2)) nil t) - for m5 = (check-subtypep `(and (not ,t2) ,t1) nil t) - when m1 collect m1 - when m2 collect m2 - when m3 collect m3 - when m4 collect m4 - when m5 collect m5) - nil) - -(declaim (special +float-types+ *subtype-table*)) - -;;; This next test is all screwed up. Basically, it assumes -;;; incorrectly that certain subtype relationships that are -;;; not specified in the spec cannot occur. -#| -(defun types.4-body () - (let ((parent-table (make-hash-table :test #'equal)) - (types nil)) - (loop - for p in *subtype-table* do - (let ((tp (first p)) - (parent (second p))) - (pushnew tp types) - (pushnew parent types) - (let ((parents (gethash tp parent-table))) - (pushnew parent parents) - ;; (format t "~S ==> ~S~%" tp parent) - (loop - for pp in (gethash parent parent-table) do - ;; (format t "~S ==> ~S~%" tp pp) - (pushnew pp parents)) - (setf (gethash tp parent-table) parents)))) - ;; parent-table now contains lists of ancestors - (loop - for tp in types sum - (let ((parents (gethash tp parent-table))) - (loop - for tp2 in types sum - (cond - ((and (not (eqt tp tp2)) - (not (eqt tp2 'standard-object)) - (not (eqt tp2 'structure-object)) - (not (member tp2 parents)) - (subtypep* tp tp2) - (not (and (member tp +float-types+) - (member tp2 +float-types+))) - (not (and (eqt tp2 'structure-object) - (member 'standard-object parents)))) - (format t "~%Improper subtype: ~S of ~S" - tp tp2) - 1) - (t 0))))) - )) - -(deftest types.4 - (types.4-body) - 0) -|# - -(deftest types.6 - (types.6-body) - nil) - -(declaim (special *disjoint-types-list*)) - -;;; Check that the disjoint types really are disjoint - -(deftest types.7b - (loop for e on *disjoint-types-list* - for tp1 = (first e) - append - (loop for tp2 in (rest e) - append (classes-are-disjoint tp1 tp2))) - nil) - -(deftest types.7c - (loop for e on *disjoint-types-list2* - for list1 = (first e) - append - (loop for tp1 in list1 append - (loop for list2 in (rest e) - append - (loop for tp2 in list2 append - (classes-are-disjoint tp1 tp2))))) - nil) - -(deftest types.8 - (loop - for tp in *disjoint-types-list* count - (cond - ((and (not (eqt tp 'cons)) - (not (subtypep* tp 'atom))) - (format t "~%Should be atomic, but isn't: ~S" tp) - t))) - 0) - -(declaim (special *type-list* *supertype-table*)) - -;;; -;;; TYPES.9 checks the transitivity of SUBTYPEP on pairs of types -;;; occuring in *SUBTYPE-TABLE*, as well as the types KEYWORD, ATOM, -;;; and LIST (the relationships given in *SUBTYPE-TABLE* are not used -;;; here.) -;;; - -(deftest types.9 - (types.9-body) - nil) - -;;; -;;; TYPES.9A takes the supertype relationship computed by test TYPE.9 -;;; and checks that TYPEP respects it for all elements of *UNIVERSE*. -;;; That is, if T1 and T2 are two types, and X is an element of *UNIVERSE*, -;;; then if (SUBTYPEP T1) then (TYPEP X T1) implies (TYPEP X T2). -;;; -;;; The function prints error messages when this fails, and returns the -;;; number of occurences of failure. -;;; -;;; Test TYPES.9 must be run before this test. -;;; - -(deftest types.9a - (types.9a-body) - 0) - - -;;; All class names in CL denote classes that are subtypep -;;; equivalent to themselves -(deftest all-classes-are-type-equivalent-to-their-names - (loop for sym being the external-symbols of "COMMON-LISP" - for class = (find-class sym nil) - when class - append (check-equivalence sym class)) - nil) - -(deftest all-classes-are-type-equivalent-to-their-names.2 - (loop for x in *universe* - for cl = (class-of x) - for name = (class-name cl) - when name - append (check-equivalence name cl)) - nil) - -;;; Check that all class names in CL that name standard-classes or -;;; structure-classes are subtypes of standard-object and structure-object, -;;; respectively - -(deftest all-standard-classes-are-subtypes-of-standard-object - (loop for sym being the external-symbols of "COMMON-LISP" - for class = (find-class sym nil) - when (and class - (typep class 'standard-class) - (or (not (subtypep sym 'standard-object)) - (not (subtypep class 'standard-object)))) - collect sym) - nil) - -(deftest all-standard-classes-are-subtypes-of-standard-object.2 - (loop for x in *universe* - for class = (class-of x) - when (and (typep class 'standard-class) - (not (subtypep class 'standard-object))) - collect x) - nil) - -(deftest all-structure-classes-are-subtypes-of-structure-object - (loop for sym being the external-symbols of "COMMON-LISP" - for class = (find-class sym nil) - when (and class - (typep class 'structure-class) - (or (not (subtypep sym 'structure-object)) - (not (subtypep class 'structure-object)))) - collect sym) - nil) - -(deftest all-structure-classes-are-subtypes-of-structure-object.2 - (loop for x in *universe* - for cl = (class-of x) - when (and (typep cl 'structure-class) - (not (subtypep cl 'structure-object))) - collect x) - nil) - -;;; Confirm that only the symbols exported from CL that are supposed -;;; to be types are actually classes (see section 11.1.2.1.1) - -(deftest all-exported-cl-class-names-are-valid - (loop for sym being the external-symbols of "COMMON-LISP" - when (and (find-class sym nil) - (not (member sym *cl-all-type-symbols* :test #'eq))) - collect sym) - nil) - -;;; Confirm that all standard generic functions are instances of -;;; the class standard-generic-function. - -(deftest all-standard-generic-functions-are-instances-of-that-class - (loop for sym in *cl-standard-generic-function-symbols* - for fun = (and (fboundp sym) (symbol-function sym)) - unless (and (typep fun 'generic-function) - (typep fun 'standard-generic-function)) - collect (list sym fun)) - nil) - -;;; Canonical metaobjects are in the right classes - -(deftest structure-object-is-in-structure-class - (notnot-mv (typep (find-class 'structure-object) 'structure-class)) - t) - -(deftest standard-object-is-in-standard-class - (notnot-mv (typep (find-class 'standard-object) 'standard-class)) - t) - - -;; This should be greatly expanded - -(defparameter *type-and-class-fns* - '(coerce subtypep type-of typep type-error-datum type-error-expected-type)) - -(deftest type-and-class-fns - (remove-if #'fboundp *type-and-class-fns*) - nil) - -(deftest type-and-class-macros - (notnot-mv (macro-function 'deftype)) - t) - -;;; TYPE-ERROR accessors - -(deftest type-error-datum.1 - (let ((c (make-condition 'type-error :datum 'a :expected-type 'integer))) - (type-error-datum c)) - a) - -(deftest type-error-expected-type.1 - (let ((c (make-condition 'type-error - :datum 'a :expected-type 'integer))) - (type-error-expected-type c)) - integer) - -;;; Error checking of type-related functions - -(deftest type-error-datum.error.1 - (signals-error (type-error-datum) program-error) - t) - -(deftest type-error-datum.error.2 - (signals-error - (let ((c (make-condition 'type-error :datum nil - :expected-type t))) - (type-error-datum c nil)) - program-error) - t) - -(deftest type-error-expected-type.error.1 - (signals-error (type-error-expected-type) - program-error) - t) - -(deftest type-error-expected-type.error.2 - (signals-error - (let ((c (make-condition 'type-error :datum nil - :expected-type t))) - (type-error-expected-type c nil)) - program-error) - t) - diff --git a/t/ansi-test/universe.lsp b/t/ansi-test/universe.lsp deleted file mode 100644 index e0f00e3..0000000 --- a/t/ansi-test/universe.lsp +++ /dev/null @@ -1,538 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Author: Paul Dietz -;;;; Created: Thu Apr 9 19:32:56 1998 -;;;; Contains: A global variable containing a list of -;;;; as many kinds of CL objects as we can think of -;;;; This list is used to test many other CL functions - -(in-package :cl-test) - -(defparameter *condition-types* - '(arithmetic-error - cell-error - condition - control-error - division-by-zero - end-of-file - error - file-error - floating-point-inexact - floating-point-invalid-operation - floating-point-underflow - floating-point-overflow - package-error - parse-error - print-not-readable - program-error - reader-error - serious-condition - simple-condition - simple-error - simple-type-error - simple-warning - storage-condition - stream-error - style-warning - type-error - unbound-slot - unbound-variable - undefined-function - warning)) - -(defparameter *condition-objects* - (locally (declare (optimize safety)) - (loop for tp in *condition-types* append - (handler-case (list (make-condition tp)) - (error () nil))))) - -(defparameter *standard-package-names* - '("COMMON-LISP" "COMMON-LISP-USER" "KEYWORD")) - -(defparameter *package-objects* - (locally (declare (optimize safety)) - (loop for pname in *standard-package-names* append - (handler-case (let ((pkg (find-package pname))) - (and pkg (list pkg))) - (error () nil))))) - -(defparameter *integers* - (remove-duplicates - `( - 0 - ;; Integers near the fixnum/bignum boundaries - ,@(loop for i from -5 to 5 collect (+ i most-positive-fixnum)) - ,@(loop for i from -5 to 5 collect (+ i most-negative-fixnum)) - ;; Powers of two, negatives, and off by one. - ,@(loop for i from 1 to 64 collect (ash 1 i)) - ,@(loop for i from 1 to 64 collect (1- (ash 1 i))) - ,@(loop for i from 1 to 64 collect (ash -1 i)) - ,@(loop for i from 1 to 64 collect (1+ (ash -1 i))) - ;; A big integer - ,(expt 17 50) - ;; Some arbitrarily chosen integers - 12387131 1272314 231 -131 -561823 23713 -1234611312123 444121 991))) - -(defparameter *floats* - (append - (loop for sym in '(pi - most-positive-short-float - least-positive-short-float - least-positive-normalized-short-float - most-positive-double-float - least-positive-double-float - least-positive-normalized-double-float - most-positive-long-float - least-positive-long-float - least-positive-normalized-long-float - most-positive-single-float - least-positive-single-float - least-positive-normalized-single-float - most-negative-short-float - least-negative-short-float - least-negative-normalized-short-float - most-negative-single-float - least-negative-single-float - least-negative-normalized-single-float - most-negative-double-float - least-negative-double-float - least-negative-normalized-double-float - most-negative-long-float - least-negative-long-float - least-negative-normalized-long-float - short-float-epsilon - short-float-negative-epsilon - single-float-epsilon - single-float-negative-epsilon - double-float-epsilon - double-float-negative-epsilon - long-float-epsilon - long-float-negative-epsilon) - when (boundp sym) collect (symbol-value sym)) - (list - 0.0 1.0 -1.0 313123.13 283143.231 -314781.9 - 1.31283d2 834.13812D-45 - 8131238.1E14 -4618926.231e-2 - -37818.131F3 81.318231f-19 - 1.31273s3 12361.12S-7 - 6124.124l0 13123.1L-23))) - -(defparameter *ratios* - '(1/3 1/1000 1/1000000000000000 -10/3 -1000/7 -987129387912381/13612986912361 - 189729874978126783786123/1234678123487612347896123467851234671234)) - -(defparameter *complexes* - '(#C(0.0 0.0) - #C(1.0 0.0) - #C(0.0 1.0) - #C(1.0 1.0) - #C(-1.0 -1.0) - #C(1289713.12312 -9.12681271) - #C(1.0D100 1.0D100) - #C(-1.0D-100 -1.0D-100) - #C(10.0s0 20.0s0) - #C(100.0l0 200.0l0) - #C(1.0s0 2.0f0) - #C(1.0s0 3.0d0) - #C(1.0s0 4.0l0) - #C(1.0f0 5.0d0) - #C(1.0f0 6.0l0) - #C(1.0d0 7.0l0) - #C(1.0f0 2.0s0) - #C(1.0d0 3.0s0) - #C(1.0l0 4.0s0) - #C(1.0d0 5.0f0) - #C(1.0l0 6.0f0) - #C(1.0l0 7.0d0) - #C(1/2 1/3) - )) - -(defparameter *numbers* - (append *integers* - *floats* - *ratios* - *complexes*)) - -(defparameter *reals* (append *integers* *floats* *ratios*)) - -(defparameter *rationals* (append *integers* *ratios*)) - -(defun try-to-read-chars (&rest namelist) - (declare (optimize safety)) - (loop - for name in namelist append - (handler-case - (list (read-from-string - (concatenate 'string "\#\\" name))) - (error () nil)))) - -(defparameter *characters* - (remove-duplicates - `(#\Newline - #\Space - ,@(try-to-read-chars "Rubout" - "Page" - "Tab" - "Backspace" - "Return" - "Linefeed" - "Null") - #\a #\A #\0 #\9 #\. #\( #\) #\[ #\] - ))) - - -(defparameter *strings* - (append - (and (code-char 0) - (list - (make-string 1 :initial-element (code-char 0)) - (make-string 10 :initial-element (code-char 0)))) - (list - "" "A" "a" "0" "abcdef" - "~!@#$%^&*()_+`1234567890-=<,>.?/:;\"'{[}]|\\ abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWYXZ" - (make-string 100000 :initial-element #\g) - (let ((s (make-string 256))) - (loop - for i from 0 to 255 - do (let ((c (code-char i))) - (when c - (setf (elt s i) c)))) - s) - ;; Specialized strings - (make-array 3 - :element-type 'character - :displaced-to (make-array 5 :element-type 'character - :initial-contents "abcde") - :displaced-index-offset 1) - (make-array 10 :initial-element #\x - :fill-pointer 5 - :element-type 'character) - (make-array 10 :initial-element #\x - :element-type 'base-char) - (make-array 3 :initial-element #\y - :adjustable t - :element-type 'base-char) - ))) - -(defparameter *conses* - (list - (list 'a 'b) - (list nil) - (list 1 2 3 4 5 6))) - -(defparameter *circular-conses* - (list - (let ((s (copy-list '(a b c d)))) - (nconc s s) - s) - (let ((s (list nil))) - (setf (car s) s) - s) - (let ((s (list nil))) - (setf (car s) s) - (setf (cdr s) s)))) - -(defparameter *booleans* '(nil t)) -(defparameter *keywords* '(:a :b :|| :|a| :|1234|)) -(defparameter *uninterned-symbols* - (list '#:nil '#:t '#:foo '#:||)) -(defparameter *cl-test-symbols* - `(,(intern "a" :cl-test) - ,(intern "" :cl-test) - ,@(and (code-char 0) - (list (intern (make-string 1 :initial-element (code-char 0)) :cl-test))) - ,@(and (code-char 0) - (let* ((s (make-string 10 :initial-element (code-char 0))) - (s2 (copy-seq s)) - (s3 (copy-seq s))) - (setf (subseq s 3 4) "a") - (setf (subseq s2 4 5) "a") - (setf (subseq s3 4 5) "a") - (setf (subseq s3 7 8) "b") - (list (intern s :cl-test) - (intern s2 :cl-test) - (intern s3 :cl-test)))) - )) - -(defparameter *cl-user-symbols* - '(cl-user::foo - cl-user::x - cl-user::cons - cl-user::lambda - cl-user::*print-readably* - cl-user::push)) - -(defparameter *symbols* - (append *booleans* *keywords* *uninterned-symbols* - *cl-test-symbols* - *cl-user-symbols*)) - -(defparameter *array-dimensions* - (loop - for i from 0 to 8 collect - (loop for j from 1 to i collect 2))) - -(defparameter *default-array-target* (make-array '(300))) - -(defparameter *arrays* - (append - (list (make-array '10)) - (mapcar #'make-array *array-dimensions*) - - ;; typed arrays - (loop for tp in '(fixnum float bit character base-char - (signed-byte 8) (unsigned-byte 8)) - for element in '(18 16.0f0 0 #\x #\y 127 200) - append - (loop - for d in *array-dimensions* - collect (make-array d :element-type tp - :initial-element element))) - - ;; More typed arrays - (loop for i from 1 to 64 - append - (list (make-array 10 :element-type `(unsigned-byte ,i) - :initial-element 1) - (make-array 10 :element-type `(signed-byte ,i) - :initial-element 0))) - - ;; adjustable arrays - (loop - for d in *array-dimensions* - collect (make-array d :adjustable t)) - - ;; Displaced arrays - (loop - for d in *array-dimensions* - for i from 1 - collect (make-array d :displaced-to *default-array-target* - :displaced-index-offset i)) - - (list - #() - #* - #*00000 - #*1010101010101101 - (make-array 10 :element-type 'bit - :initial-contents '(0 1 1 0 1 1 1 1 0 1) - :fill-pointer 8) - (make-array 5 :element-type 'bit - :displaced-to #*0111000110 - :displaced-index-offset 3) - (make-array 10 :element-type 'bit - :initial-contents '(1 1 0 0 1 1 1 0 1 1) - :adjustable t) - ) - - ;; Integer arrays - (list - (make-array '(10) :element-type '(integer 0 (256)) - :initial-contents '(8 9 10 11 12 1 2 3 4 5)) - (make-array '(10) :element-type '(integer -128 (128)) - :initial-contents '(8 9 -10 11 -12 1 -2 -3 4 5)) - (make-array '(6) :element-type '(integer 0 (#.(ash 1 16))) - :initial-contents '(5 9 100 1312 23432 87)) - (make-array '(4) :element-type '(integer 0 (#.(ash 1 28))) - :initial-contents '(100000 231213 8123712 19)) - (make-array '(4) :element-type '(integer 0 (#.(ash 1 32))) - :initial-contents '(#.(1- (ash 1 32)) 0 872312 10000000)) - - (make-array nil :element-type '(integer 0 (256)) - :initial-element 14) - (make-array '(2 2) :element-type '(integer 0 (256)) - :initial-contents '((34 98)(14 119))) - ) - - ;; Float arrays - (list - (make-array '(5) :element-type 'short-float - :initial-contents '(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0)) - (make-array '(5) :element-type 'single-float - :initial-contents '(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0)) - (make-array '(5) :element-type 'double-float - :initial-contents '(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0)) - (make-array '(5) :element-type 'long-float - :initial-contents '(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0)) - ) - - ;; The ever-popular NIL array - (locally (declare (optimize safety)) - (handler-case - (list (make-array '(0) :element-type nil)) - (error () nil))) - - ;; more kinds of arrays here later? - )) - -(defparameter *hash-tables* - (list - (make-hash-table) - (make-hash-table :test #'eq) - (make-hash-table :test #'eql) - (make-hash-table :test #'equal) - #-(or CMU ECL) (make-hash-table :test #'equalp) - )) - -(defparameter *pathnames* - (locally - (declare (optimize safety)) - (loop for form in '((make-pathname :name "foo") - (make-pathname :name "FOO" :case :common) - (make-pathname :name "bar") - (make-pathname :name "foo" :type "txt") - (make-pathname :name "bar" :type "txt") - (make-pathname :name "XYZ" :type "TXT" :case :common) - (make-pathname :name nil) - (make-pathname :name :wild) - (make-pathname :name nil :type "txt") - (make-pathname :name :wild :type "txt") - (make-pathname :name :wild :type "TXT" :case :common) - (make-pathname :name :wild :type "abc" :case :common) - (make-pathname :directory :wild) - (make-pathname :type :wild) - (make-pathname :version :wild) - (make-pathname :version :newest)) - append (ignore-errors (eval `(list ,form)))))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (locally - (declare (optimize safety)) - (ignore-errors - (setf (logical-pathname-translations "CLTESTROOT") - `(("**;*.*.*" ,(merge-pathnames - "sandbox/" - (make-pathname :directory '(:absolute :wild-inferiors) - :name :wild :type :wild)))))) - (ignore-errors - (setf (logical-pathname-translations "CLTEST") - `(("**;*.*.*" ,(merge-pathnames - "sandbox/" - (make-pathname - :directory (append - (pathname-directory - (truename (make-pathname))) - '(:wild-inferiors)) - :name :wild :type :wild)))))) - )) - -(defparameter *logical-pathnames* - (locally - (declare (optimize safety)) - (append - (ignore-errors (list (logical-pathname "CLTESTROOT:"))) - ))) - -(defparameter *streams* - (remove-duplicates - (remove-if - #'null - (list - *debug-io* - *error-output* - *query-io* - *standard-input* - *standard-output* - *terminal-io* - *trace-output*)))) - -(defparameter *readtables* - (list *readtable* - (copy-readtable))) - -(defstruct foo-structure - x y z) - -(defstruct bar-structure - x y z) - -(defparameter *structures* - (list - (make-foo-structure :x 1 :y 'a :z nil) - (make-foo-structure :x 1 :y 'a :z nil) - (make-bar-structure :x 1 :y 'a :z nil) - )) - -(defun meaningless-user-function-for-universe (x y z) - (list (+ x 1) (+ y 2) (+ z 3))) - -(defgeneric meaningless-user-generic-function-for-universe (x y z) - #+(or (not :gcl) :ansi-cl) (:method ((x integer) (y integer) (z integer)) (+ x y z))) - -(eval-when (:load-toplevel :execute) - (compile 'meaningless-user-function-for-universe) - ;; Conditionalize to avoid a cmucl bug - #-(or cmu gcl ecl) (compile 'meaningless-user-generic-function-for-universe) - ) - -(defparameter *functions* - (list #'cons #'car #'append #'values - (macro-function 'cond) - #'meaningless-user-function-for-universe - #'meaningless-user-generic-function-for-universe - #'(lambda (x) x) - (compile nil '(lambda (x) x)))) - -(defparameter *methods* - (list - #+(or (not :gcl) :ansi-cl ) - (find-method #'meaningless-user-generic-function-for-universe nil - (mapcar #'find-class '(integer integer integer))) - ;; Add more methods here - )) - - -(defparameter *random-states* - (list (make-random-state))) - -(defparameter *universe* - (remove-duplicates - (append - *symbols* - *numbers* - *characters* - (mapcar #'copy-seq *strings*) - *conses* - *condition-objects* - *package-objects* - *arrays* - *hash-tables* - *pathnames* - *logical-pathnames* - *streams* - *readtables* - *structures* - *functions* - *random-states* - *methods* - nil))) - -(defparameter *mini-universe* - (remove-duplicates - (append - (mapcar #'first - (list *symbols* - *numbers* - *characters* - (list (copy-seq (first *strings*))) - *conses* - *condition-objects* - *package-objects* - *arrays* - *hash-tables* - *pathnames* - *logical-pathnames* - *streams* - *readtables* - *structures* - *functions* - *random-states* - *methods*)) - '(;;; Others to fill in gaps - 1.2s0 1.3f0 1.5d0 1.8l0 3/5 10000000000000000000000)))) - -(defparameter *classes* - (remove-duplicates (mapcar #'class-of *universe*))) - -(defparameter *built-in-classes* - (remove-if-not #'(lambda (x) (typep x 'built-in-class)) - *classes*)) diff --git a/t/baby2015/Makefile b/t/baby2015/Makefile deleted file mode 100644 index 476fea9..0000000 --- a/t/baby2015/Makefile +++ /dev/null @@ -1,28 +0,0 @@ -ROOTNAME = Babylon -VERSION = 2.3 -PACKAGE = $(ROOTNAME)-$(VERSION) - -SUBDIRS = kernel mac mcs samples tty - -all: - @echo "== START LISP AND LOAD THE make.cl FILE ==" - -install: - @echo "== START LISP AND LOAD THE make.cl FILE ==" - -clean: - rm -f $(PACKAGE).tar $(PACKAGE).tar.Z - rm -f *.dribble - rm -f `find . -name '*.cl~' -print` - rm -f babylon.mem - rm -f `find . -name '*.lib' -print` - rm -f `find . -name '*.fas' -print` - rm -f babylon - rm -f `find . -name '*.fasl' -print` - rm -f babylon.core - rm -f `find . -name '*.cmu' -print` - rm -f babylon.kcl - rm -f `find . -name '*.o' -print` - rm -f `find . -name '*.bin' -print` - - diff --git a/t/baby2015/README b/t/baby2015/README deleted file mode 100644 index 81b5549..0000000 --- a/t/baby2015/README +++ /dev/null @@ -1,225 +0,0 @@ -BABYLON Version 2.3 - -***************************************************************************** -What is BABYLON -***************************************************************************** - -BABYLON is a modular, configurable, hybrid environment for developing expert -systems. It provides the following knowledge representation formalisms: - frames, - rules, - logic (Prolog) and - constraints. -BABYLON is implemented and embedded in Common Lisp. - -The archive contains all the sources that are needed to compile -and run BABYLON on different hard and software platforms (Mac, Sun, ...). - -Version 2.3 is a maintenance release of 2.2 with some reworking to make it -more portable. To this end, the whole babylon implementation is put into the -:babylon package. So put your knowledge bases into the :babylon package or use -the :babylon package. Also included is some documentation (in the doc -directory) in RTF (Rich Text Format) and some more complex examples (see -axtra sample kb and the texi and model-k directories). - -***************************************************************************** -More details about BABYLON can be found in: -***************************************************************************** - -Christaller, T., Di Primio, F., Voss, A. (Hrsg.). -Die KI-Werkbank Babylon. -Eine offene und portable Entwicklungsumgebung fuer Expertensysteme. -Addison-Wesley, 1989, ISBN 3-89319-155-0 -(in German) - -or - - -Christaller, T., Di Primio, F., Voss, A. (eds). -The AI-Workbench BABYLON. -An open and portable development environment for expert systems. -Academic Press, London, 1992, ISBN 0-12-174235-0; - -and - -Guesgen, H.-W., -CONSAT: A system for constraint satisfaction. -Research Notes in Artificial Intelligence, Morgan Kaufman, San Mateo, 1989. - -***************************************************************************** -Lisp implementations supported -***************************************************************************** - -In principle, babylon should run on any Common Lisp implementation. -The current version 2.3 has actually been tested with - -Macintosh Common Lisp 2.0.1 and 3.0 on Apple Macintosh and - -Allegro Common Lisp 4.1 and 4.2, -CLisp (january 1994), -CMU (version 16e) and -AKCL 1.615 on SUN. - -Support for Lispmachines has been stopped. I do not have one available -any more. - -***************************************************************************** -how to get babylon -***************************************************************************** - -You can get babylon from http://www.gmd.de/ using one of the Mosaic versions -for example or by anonymous ftp from ftp.gmd.de - - - FTP the distribution from ftp.gmd.de: - - ftp ftp.gmd.de - Name: anonymous - Password: - cd GMD/ai-research/Software/Babylon - get Babylon-2.3.sit.hqx <- for macintosh users or - binary - get Babylon-2.3.tar.Z <- for unix users - quit - - - untar the distribution file (unix): - - zcat Babylon-2.3.tar.Z | tar -xvf - - - - or unstuff Babylon-2.3.sit.hqx (Stuffit Expander) on your Macintosh. - -This will create a directory "Babylon-2.3" with all the subdirectories. - - -***************************************************************************** -how to install babylon -***************************************************************************** - -On an Apple Macintosh: -***************************************************************************** -Start MCL (Macintosh Common Lisp) and load the make.cl file. - -You will be asked: -Use development options for compiling files? (y or n) -Answer y if you want to record source files, documentation strings etc. -This will cost some space in the saved babylon image but makes developing much -easier. Type n otherwise. - -After some time a dialog will pop up. Select which versions of the diffent -processors you want to have included in the babylon image. Preselected are all -the normal versions of the processors. Now push the Save as... button to get -a File Selection Dialog. Choose a name and place for the babylon image and -click the Save button. You will need about 3MB for the complete babylon image. -If you click the Abort button, you will find a Cinfigure Image ... menu entry -in the Babylon menu. You may use this menu entry to continue making the image -after doing some other customization of your lisp environment (compile and/or -load some files etc.). - -After some time you will be asked: -Load graphic frame browser? (y or n) -Answer y if you want to have a graphic oriented browser of the babylon frame -inheritance structures. Make sure your MCL examples folder does contain -the file scrolling-windows and the library the file scrollers, because both -are used by the implementation of the frame browser. Compile both files -if you have not done this already. -;Loading #P"IHD:Applications:MCL 2.0:examples:SCROLLING-WINDOWS.fasl"... -;Loading #P"IHD:Applications:MCL 2.0:library:SCROLLERS.fasl"... - -After compiling and loading all you wanted you will be asked: -Is your AntiVirus software temporarily disabled? (y or n) -Answer y after temporary switching off Gatekeeper in the Gatekeepe Controls -for example or allow MCL to write the resource fork of other files. -Do whatever you have to, to disallow your virus preventing software to intervene. -Answer y now. - -After some time the babylon image (application) will appear on disk and MCL -will quit. You can start babylon now by double clicking the babylon image. - -In the MCL 3.0 version you use the Save Application item from the Tools menu -to create the Babylon image. Use the defaults but do not excise the compiler. - -Do not forget to work (in-package :babylon) or any other you define. - -On any other systems: -***************************************************************************** - -Edit the make.cl file and change the following: - -(defvar *babylon-root-directory* - #-:MCL "/home/juergen/Babylon/Babylon-2.3/" ; <--- change the pathname string here!!!! - #+:MCL (namestring - (make-pathname :directory (pathname-directory *loading-file-source-file*)))) - -and edit the make-sun.cl file and change the following: - -(defbabylon-translation "babhome^" ">home>juergen>Babylon>Babylon-2.3>") ; <--- change!!! - -(Note: use ">" as the pathname seperators here!!!) - - -After having edited both files to set the babylon home directory you should compile -and make a babylon image. - -If you have one of the Lisp implementations mentioned above, do the following: - -1: change to the Babylon-2.3 directory -> cd Babylon-2.3 - -2. start your lisp -> clisp - -3. load the make.cl file -> (load "make.cl") - -4: go into the "BABYLON" package -> (in-package "BABYLON") - -5. make the babylon image -> (make-babylon-image) - -6. quit (or exit or cntl-d) your Lisp -> (quit) - - -Lisp image name start by typing (for exsample) ------------------------------------------------------------------------ -MCL Babylon doupleclick Babylon -Allegro babylon babylon -CLisp babylon.mem clisp -M babylon.mem -CMU babylon.core cmu -core babylon.core -AKCL babylon.kcl babylon.kcl ------------------------------------------------------------------------ - -Copy a (modified to your needs) version of the bab-init.cl (and a copy of -extra.kb if you want to try out the extra sample) into your home directory. -The bab-init.cl file will be loaded after starting the babylon image. - -***************************************************************************** -known problems -***************************************************************************** - -CLisp (january 1994) does have problems with the optional line feed format -option "~&". Add a force-output or wait for the next release of CLisp. - - -If your Lisp implementation does not provide 'declaim' and 'defpackage' try -to use those within the clII directory. - -***************************************************************************** -Copyright -***************************************************************************** - -BABYLON is publicly available under similar terms as the X Window System. - -***************************************************************************** -In case of problems get in touch with: -***************************************************************************** - -Juergen Walther -AI Research Division -GMD - German National Research Center for Information Technology -D-53754 Sankt Augustin -Germany -e-mail: Juergen.Walther@gmd.de - -;;; eof - diff --git a/t/baby2015/bab-init.cl b/t/baby2015/bab-init.cl deleted file mode 100644 index ad353e8..0000000 --- a/t/baby2015/bab-init.cl +++ /dev/null @@ -1,26 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Base: 10; Package: BABYLON -*- - -(in-package "BABYLON") - -;; Copyright 1991 BY -;; G M D -;; Postfach 1240 -;; D-5205 St. Augustin -;; FRG - -;; AUTHOR: Juergen Walther - -;;; this file is loaded after starting an babylon image - -(progn - (terpri) - (princ ";;; Loading babylon init file ...") - (setf *recompile* nil)) - -;;; do not know do do that in non MCL implementations!? - -#+:MCL(eval-enqueue `(in-package "BABYLON")) - - -;;; eof - diff --git a/t/baby2015/clII/defpackage.cl b/t/baby2015/clII/defpackage.cl deleted file mode 100644 index cde20d4..0000000 --- a/t/baby2015/clII/defpackage.cl +++ /dev/null @@ -1,242 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Base: 10; Package: (DEFPACKAGE :COLON-MODE :EXTERNAL) -*- -;;; -;;; THE BOEING COMPANY -;;; BOEING COMPUTER SERVICES -;;; RESEARCH AND TECHNOLOGY -;;; COMPUTER SCIENCE -;;; P.O. BOX 24346, MS 7L-64 -;;; SEATTLE, WA 98124-0346 -;;; -;;; -;;; Copyright (c) 1990, 1991 The Boeing Company, All Rights Reserved. -;;; -;;; Permission is granted to any individual or institution to use, -;;; copy, modify, and distribute this software, provided that this -;;; complete copyright and permission notice is maintained, intact, in -;;; all copies and supporting documentation and that modifications are -;;; appropriately documented with date, author and description of the -;;; change. -;;; -;;; Stephen L. Nicoud (snicoud@boeing.com) provides this software "as -;;; is" without express or implied warranty by him or The Boeing -;;; Company. -;;; -;;; This software is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY. No author or distributor accepts -;;; responsibility to anyone for the consequences of using it or for -;;; whether it serves any particular purpose or works at all. -;;; -;;; Author: Stephen L. Nicoud -;;; -;;; ----------------------------------------------------------------- -;;; -;;; Read-Time Conditionals used in this file. -;;; -;;; #+LISPM -;;; #+EXCL -;;; #+SYMBOLICS -;;; #+TI -;;; -;;; ----------------------------------------------------------------- - -;;; ----------------------------------------------------------------- -;;; -;;; DEFPACKAGE - This files attempts to define a portable -;;; implementation for DEFPACKAGE, as defined in "Common LISP, The -;;; Language", by Guy L. Steele, Jr., Second Edition, 1990, Digital -;;; Press. -;;; -;;; Send comments, suggestions, and/or questions to: -;;; -;;; Stephen L Nicoud -;;; -;;; An early version of this file was tested in Symbolics Common -;;; Lisp (Genera 7.2 & 8.0 on a Symbolics 3650 Lisp Machine), -;;; Franz's Allegro Common Lisp (Release 3.1.13 on a Sun 4, SunOS -;;; 4.1), and Sun Common Lisp (Lucid Common Lisp 3.0.2 on a Sun 3, -;;; SunOS 4.1). -;;; -;;; 91/5/23 (SLN) - Since the initial testing, modifications have -;;; been made to reflect new understandings of what DEFPACKAGE -;;; should do. These new understandings are the result of -;;; discussions appearing on the X3J13 and Common Lisp mailing -;;; lists. Cursory testing was done on the modified version only -;;; in Allegro Common Lisp (Release 3.1.13 on a Sun 4, SunOS 4.1). -;;; -;;; ----------------------------------------------------------------- - -(lisp:in-package :DEFPACKAGE) - -(eval-when (compile load eval) - #-lispm - (unless (member :loop *features*) - (require :loop #+excl (merge-pathnames "loop" excl::*library-code-fasl-pathname*))) - - (unless (find-package :common-lisp) - (rename-package :lisp :common-lisp (union '("CL" "LISP") (package-nicknames (find-package :lisp)) :test #'string=))) - (unless (find-package :common-lisp-user) - (rename-package :user :common-lisp-user (union '("CL-USER" "USER") (package-nicknames (find-package :user)) :test #'string=))) - - #+lispm - (shadow (intern "DEFPACKAGE" #+symbolics :scl #+ti :ticl) 'defpackage) - (proclaim '(declaration values arglist)) - (export 'defpackage 'defpackage) - ) - -(defmacro DEFPACKAGE (name &rest options) - (declare (type (or symbol string) name) - (arglist defined-package-name &rest options) - (values package)) - "DEFPACKAGE - DEFINED-PACKAGE-NAME {OPTION}* [Macro] - - This creates a new package, or modifies an existing one, whose name is - DEFINED-PACKAGE-NAME. The DEFINED-PACKAGE-NAME may be a string or a - symbol; if it is a symbol, only its print name matters, and not what - package, if any, the symbol happens to be in. The newly created or - modified package is returned as the value of the DEFPACKAGE form. - - Each standard OPTION is a list of keyword (the name of the option) - and associated arguments. No part of a DEFPACKAGE form is evaluated. - Except for the :SIZE and :DOCUMENTATION options, more than one option - of the same kind may occur within the same DEFPACKAGE form. - - Valid Options: - (:documentation string) - (:size integer) - (:nicknames {package-name}*) - (:shadow {symbol-name}*) - (:shadowing-import-from package-name {symbol-name}*) - (:use {package-name}*) - (:import-from package-name {symbol-name}*) - (:intern {symbol-name}*) - (:export {symbol-name}*) - (:export-from {package-name}*) - - [Note: :EXPORT-FROM is an extension to DEFPACKAGE. - If a symbol is interned in the package being created and - if a symbol with the same print name appears as an external - symbol of one of the packages in the :EXPORT-FROM option, - then the symbol is exported from the package being created. - - :DOCUMENTATION is an extension to DEFPACKAGE. - - :SIZE is used only in Genera and Allegro.]" - - (loop for (option) in options - unless (member option '(:documentation :size :nicknames :shadow :shadowing-import-from :use :import-from :intern :export :export-from)) - do (cerror "Proceed, ignoring this option." "~s is not a valid DEFPACKAGE option." option)) - (labels ((option-test (arg1 arg2) (when (consp arg2) (equal (car arg2) arg1))) - (option-values-list (option options) - (loop for result first (member option options ':test #'option-test) - then (member option (rest result) ':test #'option-test) - until (null result) when result collect (rest (first result)))) - (option-values (option options) - (loop for result first (member option options ':test #'option-test) - then (member option (rest result) ':test #'option-test) - until (null result) when result append (rest (first result))))) - (loop for option in '(:size :documentation) - when (<= 2 (count option options ':key #'car)) - do (warn "DEFPACKAGE option ~s specified more than once. The first value \"~a\" will be used." option (first (option-values option options)))) - (setq name (string name)) - (let ((nicknames (mapcar #'string (option-values ':nicknames options))) - (documentation (first (option-values ':documentation options))) - (size (first (option-values ':size options))) - (shadowed-symbol-names (mapcar #'string (option-values ':shadow options))) - (interned-symbol-names (mapcar #'string (option-values ':intern options))) - (exported-symbol-names (mapcar #'string (option-values ':export options))) - (shadowing-imported-from-symbol-names-list (loop for list in (option-values-list ':shadowing-import-from options) - collect (cons (string (first list)) (mapcar #'string (rest list))))) - (imported-from-symbol-names-list (loop for list in (option-values-list ':import-from options) - collect (cons (string (first list)) (mapcar #'string (rest list))))) - (exported-from-package-names (mapcar #'string (option-values ':export-from options)))) - (flet ((find-duplicates (&rest lists) - (let (results) - (loop for list in lists - for more on (cdr lists) - for i from 1 - do - (loop for elt in list - as entry = (find elt results :key #'car :test #'string=) - unless (member i entry) - do - (loop for l2 in more - for j from (1+ i) - do - (if (member elt l2 :test #'string=) - (if entry - (nconc entry (list j)) - (setq entry (car (push (list elt i j) results)))))))) - results))) - (loop for duplicate in (find-duplicates shadowed-symbol-names interned-symbol-names - (loop for list in shadowing-imported-from-symbol-names-list append (rest list)) - (loop for list in imported-from-symbol-names-list append (rest list))) - do - (error "The symbol ~s cannot coexist in these lists:~{ ~s~}" (first duplicate) - (loop for num in (rest duplicate) - collect (case num (1 ':SHADOW)(2 ':INTERN)(3 ':SHADOWING-IMPORT-FROM)(4 ':IMPORT-FROM))))) - (loop for duplicate in (find-duplicates exported-symbol-names interned-symbol-names) - do - (error "The symbol ~s cannot coexist in these lists:~{ ~s~}" (first duplicate) - (loop for num in (rest duplicate) collect (case num (1 ':EXPORT)(2 ':INTERN)))))) - `(eval-when (load eval compile) - (if (find-package ,name) - (progn (rename-package ,name ,name) - ,@(when nicknames `((rename-package ,name ,name ',nicknames))) - #+(or symbolics excl) - ,@(when size - #+symbolics `((when (> ,size (pkg-max-number-of-symbols (find-package ,name))) - (pkg-rehash (find-package ,name) ,size))) - #+excl `((let ((tab (excl::package-internal-symbols (find-package ,name)))) - (when (hash-table-p tab) - (setf (excl::ha_rehash-size tab) ,size))))) - ,@(when (not (null (member ':use options ':key #'car))) - `((unuse-package (package-use-list (find-package ,name)) ,name)))) - (make-package ,name ':use 'nil ':nicknames ',nicknames ,@(when size #+lispm `(:size ,size) #+excl `(:internal-symbols ,size)))) - ,@(when documentation `((setf (get ',(intern name :keyword) #+excl 'excl::%package-documentation #-excl ':package-documentation) ,documentation))) - (let ((*package* (find-package ,name))) - ,@(when SHADOWed-symbol-names `((SHADOW (mapcar #'intern ',SHADOWed-symbol-names)))) - ,@(when SHADOWING-IMPORTed-from-symbol-names-list - (mapcar #'(lambda (list) - `(SHADOWING-IMPORT (mapcar #'(lambda (symbol) (intern symbol ,(first list))) ',(rest list)))) - SHADOWING-IMPORTed-from-symbol-names-list)) - (USE-PACKAGE ',(or (mapcar #'string (option-values ':USE options)) "CL")) - ,@(when IMPORTed-from-symbol-names-list - (mapcar #'(lambda (list) `(IMPORT (mapcar #'(lambda (symbol) (intern symbol ,(first list))) ',(rest list)))) - IMPORTed-from-symbol-names-list)) - ,@(when INTERNed-symbol-names `((mapcar #'INTERN ',INTERNed-symbol-names))) - ,@(when EXPORTed-symbol-names `((EXPORT (mapcar #'intern ',EXPORTed-symbol-names)))) - ,@(when EXPORTed-from-package-names - `((dolist (package ',EXPORTed-from-package-names) - (do-external-symbols (symbol (find-package package)) - (when (nth 1 (multiple-value-list (find-symbol (string symbol)))) - (EXPORT (list (intern (string symbol))))))))) - ) - (find-package ,name))))) - -#+excl -(excl::defadvice cl:documentation (look-for-package-type :around) - (let ((symbol (first excl::arglist)) - (type (second excl::arglist))) - (if (or (eq ':package (intern (string type) :keyword)) - (eq ':defpackage (intern (string type) :keyword))) - (or (get symbol 'excl::%package-documentation) - (get (intern (string symbol) :keyword) 'excl::%package-documentation)) - (values :do-it)))) - -#+symbolics -(scl::advise cl:documentation :around look-for-package-type nil - (let ((symbol (first scl::arglist)) - (type (second scl::arglist))) - (if (or (eq ':package (intern (string type) :keyword)) - (eq ':defpackage (intern (string type) :keyword))) - (or (get symbol ':package-documentation) - (get (intern (string symbol) :keyword) ':package-documentation)) - (values :do-it)))) - -(provide :defpackage) -(pushnew :defpackage *features*) - -;;;; ------------------------------------------------------------ -;;;; End of File -;;;; ------------------------------------------------------------ - diff --git a/t/baby2015/clII/extens.cl b/t/baby2015/clII/extens.cl deleted file mode 100644 index 80a8980..0000000 --- a/t/baby2015/clII/extens.cl +++ /dev/null @@ -1,11 +0,0 @@ -(in-package "LISP") - -(defmacro declaim (&rest decl-specs) - `(PROGN - ,@(mapcar #'(lambda (decl-spec) - `(PROCLAIM (QUOTE ,decl-spec))) decl-specs))) - -(export 'declaim) - -;;; eof - diff --git a/t/baby2015/clII/loop.cl b/t/baby2015/clII/loop.cl deleted file mode 100644 index ed5e114..0000000 --- a/t/baby2015/clII/loop.cl +++ /dev/null @@ -1,1459 +0,0 @@ -;;; -*- Mode:LISP; Syntax:Common-Lisp; Package:LOOP; Base:10; Lowercase:T -*- -;;; ************************************************************************* -;;; ******* Common Lisp ******** LOOP Iteration Macro *********************** -;;; ************************************************************************* -;;; ***** (C) COPYRIGHT 1980, 1981 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **** -;;; ********* THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *************** -;;; ************************************************************************* - -;;;; LOOP Iteration Macro - -;;; This is the "officially sanctioned" version of LOOP for running in -;;; Common Lisp. It is a conversion of LOOP 829, which is fairly close to -;;; that released with Symbolics Release 6.1 (803). This conversion was -;;; made by Glenn Burke (one of the original author/maintainers); the -;;; work was performed at Palladian Software, in Cambridge MA, April 1986. -;;; -;;; The current version of this file will be maintained at MIT, available -;;; for anonymous FTP on MC.LCS.MIT.EDU from the file "LSB1;CLLOOP >". This -;;; location will no doubt change sometime in the future. -;;; -;;; This file, like the LOOP it is derived from, has unrestricted -;;; distribution -- anyone may take it and use it. But for the sake of -;;; consistency, bug reporting, compatibility, and users' sanity, PLEASE -;;; PLEASE PLEASE don't go overboard with fixes or changes. Remember that -;;; this version is supposed to be compatible with the Maclisp/Zetalisp/NIL -;;; LOOP; it is NOT intended to be "different" or "better" or "redesigned". -;;; Report bugs and propose fixes to BUG-LOOP@MC.LCS.MIT.EDU; -;;; announcements about LOOP will be made to the mailing list -;;; INFO-LOOP@MC.LCS.MIT.EDU. Mail concerning those lists (such as requests -;;; to be added) should be sent to the BUG-LOOP-REQUEST and -;;; INFO-LOOP-REQUEST lists respectively. Note the Change History page -;;; below... -;;; -;;; LOOP documentation is still probably available from the MIT Laboratory -;;; for Computer Science publications office: -;;; LCS Publications -;;; 545 Technology Square -;;; Cambridge, MA 02139 -;;; It is Technical Memo 169, "LOOP Iteration Macro", and is very old. The -;;; most up-to-date documentation on this version of LOOP is that in the NIL -;;; Reference Manual (TR-311 from LCS Publications); while you wouldn't -;;; want to get that (it costs nearly $15) just for LOOP documentation, -;;; those with access to a NIL manual might photocopy the chapter on LOOP. -;;; That revised documentation can be reissued as a revised technical memo -;;; if there is sufficient demand. -;;; - - -;;;; Change History - -;;; [gsb@palladian] 30-apr-86 00:26 File Created from NIL's LOOP version 829 -;;; [gsb@palladian] 30-oct-86 18:23 don't generate (type notype var) decls, special-case notype into T. -;;; (The NOTYPE type keyword needs to be around for compatibility.) -;;; [gsb@palladian] 30-oct-86 18:48 bogus case clause in loop-do-collect. Syntax:common-lisp in file -;;; attribute list, for symbolics gratuitousness. -;;;------------------------------------------------------------------------ -;;;------- End of official change history -- note local fixes below ------- -;;;------------------------------------------------------------------------ - - -;;;; Package setup - - -(provide 'loop) - - -;;;The following symbols are documented as being available via SI:. Far be -;;;it for us to define a package by that name, however we can do the -;;;following. We will create a "loop-si-kludge" package (sounds like a -;;;fairly safe name), import the SI: symbols from there into LOOP, export -;;;them, define that people (use-package 'loop), and if they want to -;;;maintain source compatibility they can add the SI nickname the -;;;loop-si-kludge package. How's that? - -;(in-package 'loop-si-kludge) - -;(export '(loop-tequal loop-tassoc loop-tmember loop-use-system-destructuring? -; loop-named-variable loop-simplep loop-simplep-1 -; loop-sequencer loop-sequence-elements-path)) - -(in-package 'loop) - -;(use-package '(loop-si-kludge)) - -;shadow? - -(export '(loop loop-finish define-loop-macro define-loop-path - define-loop-sequence-path)) - -(export '(loop-tequal loop-tassoc loop-tmember loop-use-system-destructuring? - loop-named-variable loop-simplep loop-simplep-1 - loop-sequencer loop-sequence-elements-path)) - -;require? - - -;;;; Macro Environment Setup - - -; Hack up the stuff for data-types. DATA-TYPE? will always be a macro -; so that it will not require the data-type package at run time if -; all uses of the other routines are conditionalized upon that value. -(eval-when (eval compile) - ; Crock for DATA-TYPE? derives from DTDCL. We just copy it rather - ; than load it in, which requires knowing where it comes from (sigh). - ; - (defmacro data-type? (frob) - (let ((foo (gensym))) - `((lambda (,foo) - ;; NIL croaks if nil given to GET... No it doesn't any more! But: - ;; Every Lisp should (but doesn't) croak if randomness given to GET - ;; LISPM croaks (of course) if randomness given to get-pname - (and (symbolp ,foo) - (or (get ,foo ':data-type) - (and (setq ,foo (find-symbol (symbol-name ,foo) 'keyword)) - (get ,foo ':data-type))))) - ,frob)))) - - -;;; The uses of this macro are retained in the CL version of loop, in case they are -;;; needed in a particular implementation. Originally dating from the use of the -;;; Zetalisp COPYLIST* function, this is used in situations where, were cdr-coding -;;; in use, having cdr-NIL at the end of the list might be suboptimal because the -;;; end of the list will probably be RPLACDed and so cdr-normal should be used instead. -(defmacro loop-copylist* (l) - `(copy-list ,l)) - - -;;;; Random Macros - -(defmacro loop-simple-error (unquoted-message &optional (datum nil datump)) - `(error ,(if datump "LOOP: ~S ~A" "LOOP: ~A") - ',unquoted-message ,@(and datump (list datum)))) - - -(defmacro loop-warn (unquoted-message &optional (datum nil datump)) - (if datump - `(warn ,(concatenate 'string "LOOP: " unquoted-message " -- ~{~S~^ ~}") - ,datum) - `(warn ',(concatenate 'string "LOOP: " unquoted-message)))) - - -(defmacro loop-pop-source () '(pop loop-source-code)) - -(defmacro loop-gentemp (&optional (pref ''loopvar-)) - `(gentemp (symbol-name ,pref))) - - -;;;; Setq Hackery - -; Note: LOOP-MAKE-PSETQ is NOT flushable depending on the existence -; of PSETQ, unless PSETQ handles destructuring. Even then it is -; preferable for the code LOOP produces to not contain intermediate -; macros, especially in the PDP10 version. - -(defun loop-make-psetq (frobs) - (and frobs - (loop-make-setq - (list (car frobs) - (if (null (cddr frobs)) (cadr frobs) - `(prog1 ,(cadr frobs) - ,(loop-make-psetq (cddr frobs)))))))) - - -(defvar loop-use-system-destructuring? - nil) - -(defvar loop-desetq-temporary) - -; Do we want this??? It is, admittedly, useful... -;(defmacro loop-desetq (&rest x) -; (let ((loop-desetq-temporary nil)) -; (let ((setq-form (loop-make-desetq x))) -; (if loop-desetq-temporary -; `((lambda (,loop-desetq-temporary) ,setq-form) nil) -; setq-form)))) - - -(defun loop-make-desetq (x) - (if loop-use-system-destructuring? - (cons (do ((l x (cddr l))) ((null l) 'setq) - (or (and (not (null (car l))) (symbolp (car l))) - (return 'desetq))) - x) - (do ((x x (cddr x)) (r nil) (var) (val)) - ((null x) (and r (cons 'setq r))) - (setq var (car x) val (cadr x)) - (cond ((and (not (atom var)) - (not (atom val)) - (not (and (member (car val) '(car cdr cadr cddr caar cdar)) - (atom (cadr val))))) - (setq x (list* (or loop-desetq-temporary - (setq loop-desetq-temporary - (loop-gentemp 'loop-desetq-))) - val var loop-desetq-temporary (cddr x))))) - (setq r (nconc r (loop-desetq-internal (car x) (cadr x))))))) - - -(defun loop-desetq-internal (var val) - (cond ((null var) nil) - ((atom var) (list var val)) - (t (nconc (loop-desetq-internal (car var) `(car ,val)) - (loop-desetq-internal (cdr var) `(cdr ,val)))))) - - -(defun loop-make-setq (pairs) - (and pairs (loop-make-desetq pairs))) - - -(defparameter loop-keyword-alist ;clause introducers - '( (named loop-do-named) - (initially loop-do-initially) - (finally loop-do-finally) - (nodeclare loop-nodeclare) - (do loop-do-do) - (doing loop-do-do) - (return loop-do-return) - (collect loop-do-collect list) - (collecting loop-do-collect list) - (append loop-do-collect append) - (appending loop-do-collect append) - (nconc loop-do-collect nconc) - (nconcing loop-do-collect nconc) - (count loop-do-collect count) - (counting loop-do-collect count) - (sum loop-do-collect sum) - (summing loop-do-collect sum) - (maximize loop-do-collect max) - (minimize loop-do-collect min) - (always loop-do-always nil) ;Normal, do always - (never loop-do-always t) ; Negate the test on always. - (thereis loop-do-thereis) - (while loop-do-while nil while) ; Normal, do while - (until loop-do-while t until) ; Negate the test on while - (when loop-do-when nil when) ; Normal, do when - (if loop-do-when nil if) ; synonymous - (unless loop-do-when t unless) ; Negate the test on when - (with loop-do-with))) - - -(defparameter loop-iteration-keyword-alist - `((for loop-do-for) - (as loop-do-for) - (repeat loop-do-repeat))) - - -(defparameter loop-for-keyword-alist ;Types of FOR - '( (= loop-for-equals) - (first loop-for-first) - (in loop-list-stepper car) - (on loop-list-stepper nil) - (from loop-for-arithmetic from) - (downfrom loop-for-arithmetic downfrom) - (upfrom loop-for-arithmetic upfrom) - (below loop-for-arithmetic below) - (to loop-for-arithmetic to) - (being loop-for-being))) - -(defvar loop-prog-names) - - -(defvar loop-macro-environment) ;Second arg to macro functions, - ;passed to macroexpand. - -(defvar loop-path-keyword-alist nil) ; PATH functions -(defvar loop-named-variables) ; see LOOP-NAMED-VARIABLE -(defvar loop-variables) ;Variables local to the loop -(defvar loop-declarations) ; Local dcls for above -(defvar loop-nodeclare) ; but don't declare these -(defvar loop-variable-stack) -(defvar loop-declaration-stack) -(defvar loop-desetq-crocks) ; see loop-make-variable -(defvar loop-desetq-stack) ; and loop-translate-1 -(defvar loop-prologue) ;List of forms in reverse order -(defvar loop-wrappers) ;List of wrapping forms, innermost first -(defvar loop-before-loop) -(defvar loop-body) ;.. -(defvar loop-after-body) ;.. for FOR steppers -(defvar loop-epilogue) ;.. -(defvar loop-after-epilogue) ;So COLLECT's RETURN comes after FINALLY -(defvar loop-conditionals) ;If non-NIL, condition for next form in body - ;The above is actually a list of entries of the form - ;(cond (condition forms...)) - ;When it is output, each successive condition will get - ;nested inside the previous one, but it is not built up - ;that way because you wouldn't be able to tell a WHEN-generated - ;COND from a user-generated COND. - ;When ELSE is used, each cond can get a second clause - -(defvar loop-when-it-variable) ;See LOOP-DO-WHEN -(defvar loop-never-stepped-variable) ; see LOOP-FOR-FIRST -(defvar loop-emitted-body?) ; see LOOP-EMIT-BODY, - ; and LOOP-DO-FOR -(defvar loop-iteration-variables) ; LOOP-MAKE-ITERATION-VARIABLE -(defvar loop-iteration-variablep) ; ditto -(defvar loop-collect-cruft) ; for multiple COLLECTs (etc) -(defvar loop-source-code) -(defvar loop-duplicate-code nil) ; see LOOP-OPTIMIZE-DUPLICATED-CODE-ETC - - -;;;; Construct a value return - - -(defun loop-construct-return (form) - (if loop-prog-names - `(return-from ,(car loop-prog-names) ,form) - `(return ,form))) - -;;;; Token Hackery - -;Compare two "tokens". The first is the frob out of LOOP-SOURCE-CODE, -;the second a symbol to check against. - -(defun loop-tequal (x1 x2) - (and (symbolp x1) (string= x1 x2))) - - -(defun loop-tassoc (kwd alist) - (and (symbolp kwd) (assoc kwd alist :test #'string=))) - - -(defun loop-tmember (kwd list) - (and (symbolp kwd) (member kwd list :test #'string=))) - - - -(defmacro define-loop-macro (keyword) - "Makes KEYWORD, which is a LOOP keyword, into a Lisp macro that may -introduce a LOOP form. This facility exists mostly for diehard users of -a predecessor of LOOP. Unconstrained use is not advised, as it tends to -decrease the transportability of the code and needlessly uses up a -function name." - (or (eq keyword 'loop) - (loop-tassoc keyword loop-keyword-alist) - (loop-tassoc keyword loop-iteration-keyword-alist) - (loop-simple-error "not a loop keyword - define-loop-macro" keyword)) - `(let (#+:ccl (ccl::*warn-if-redefine-kernel* nil)) - (defmacro ,keyword (&whole whole-form &rest keywords-and-forms &environment env) - (declare (ignore keywords-and-forms)) - (loop-translate whole-form env)))) - - -(define-loop-macro loop) - - -(defmacro loop-finish () - "Causes the iteration to terminate \"normally\", the same as implicit -termination by an iteration driving clause, or by use of WHILE or -UNTIL -- the epilogue code (if any) will be run, and any implicitly -collected result will be returned as the value of the LOOP." - '(go end-loop)) - - -(defun loop-translate (x loop-macro-environment) - (loop-translate-1 x)) - - -(defun loop-end-testify (list-of-forms) - (if (null list-of-forms) nil - `(when ,(if (null (cdr (setq list-of-forms (nreverse list-of-forms)))) - (car list-of-forms) - (cons 'or list-of-forms)) - (go end-loop)))) - -(defun loop-optimize-duplicated-code-etc (&aux before after groupa groupb a b - lastdiff) - (do ((l1 (nreverse loop-before-loop) (cdr l1)) - (l2 (nreverse loop-after-body) (cdr l2))) - ((equal l1 l2) - (setq loop-body (nconc (delete nil l1) (nreverse loop-body)))) - (push (car l1) before) (push (car l2) after)) - (cond ((not (null loop-duplicate-code)) - (setq loop-before-loop (nreverse (delete nil before)) - loop-after-body (nreverse (delete nil after)))) - (t (setq loop-before-loop nil loop-after-body nil - before (nreverse before) after (nreverse after)) - (do ((bb before (cdr bb)) (aa after (cdr aa))) - ((null aa)) - (cond ((not (equal (car aa) (car bb))) (setq lastdiff aa)) - ((not (loop-simplep (car aa))) ;Mustn't duplicate - (return nil)))) - (cond (lastdiff ;Down through lastdiff should be duplicated - (do nil (nil) - (and (car before) (push (car before) loop-before-loop)) - (and (car after) (push (car after) loop-after-body)) - (setq before (cdr before) after (cdr after)) - (and (eq after (cdr lastdiff)) (return nil))) - (setq loop-before-loop (nreverse loop-before-loop) - loop-after-body (nreverse loop-after-body)))) - (do ((bb (nreverse before) (cdr bb)) - (aa (nreverse after) (cdr aa))) - ((null aa)) - (setq a (car aa) b (car bb)) - (cond ((and (null a) (null b))) - ((equal a b) - (loop-output-group groupb groupa) - (push a loop-body) - (setq groupb nil groupa nil)) - (t (and a (push a groupa)) (and b (push b groupb))))) - (loop-output-group groupb groupa))) - (and loop-never-stepped-variable - (push `(setq ,loop-never-stepped-variable nil) loop-after-body)) - nil) - - -(defun loop-output-group (before after) - (and (or after before) - (let ((v (or loop-never-stepped-variable - (setq loop-never-stepped-variable - (loop-make-variable - (loop-gentemp 'loop-iter-flag-) t nil))))) - (push (cond ((not before) - `(unless ,v (progn ,@after))) - ((not after) - `(when ,v (progn ,@before))) - (t `(cond (,v ,@before) (t ,@after)))) - loop-body)))) - - -(defun loop-translate-1 (loop-source-code) - (and (eq (car loop-source-code) 'loop) - (setq loop-source-code (cdr loop-source-code))) - (do ((loop-iteration-variables nil) - (loop-iteration-variablep nil) - (loop-variables nil) - (loop-nodeclare nil) - (loop-named-variables nil) - (loop-declarations nil) - (loop-desetq-crocks nil) - (loop-variable-stack nil) - (loop-declaration-stack nil) - (loop-desetq-stack nil) - (loop-prologue nil) - (loop-wrappers nil) - (loop-before-loop nil) - (loop-body nil) - (loop-emitted-body? nil) - (loop-after-body nil) - (loop-epilogue nil) - (loop-after-epilogue nil) - (loop-conditionals nil) - (loop-when-it-variable nil) - (loop-never-stepped-variable nil) - (loop-desetq-temporary nil) - (loop-prog-names nil) - (loop-collect-cruft nil) - (keyword) - (tem) - (progvars)) - ((null loop-source-code) - (and loop-conditionals - (loop-simple-error "Hanging conditional in loop macro" - (caadar loop-conditionals))) - (loop-optimize-duplicated-code-etc) - (loop-bind-block) - (and loop-desetq-temporary (push loop-desetq-temporary progvars)) - (setq tem `(block ,(car loop-prog-names) - (let ,progvars - (tagbody - ,@(nreverse loop-prologue) - ,@loop-before-loop - next-loop - ,@loop-body - ,@loop-after-body - (go next-loop) - (go end-loop) - end-loop - ,@(nreverse loop-epilogue) - ,@(nreverse loop-after-epilogue))))) - (do ((vars) (dcls) (crocks)) - ((null loop-variable-stack)) - (setq vars (car loop-variable-stack) - loop-variable-stack (cdr loop-variable-stack) - dcls (car loop-declaration-stack) - loop-declaration-stack (cdr loop-declaration-stack) - tem (list tem)) - (and (setq crocks (pop loop-desetq-stack)) - (push (loop-make-desetq crocks) tem)) - (and dcls (push (cons 'declare dcls) tem)) - (cond ((do ((l vars (cdr l))) ((null l) nil) - (and (not (atom (car l))) - (or (null (caar l)) (not (symbolp (caar l)))) - (return t))) - (setq tem `(let ,(nreverse vars) ,@tem))) - (t (let ((lambda-vars nil) (lambda-vals nil)) - (do ((l vars (cdr l)) (v)) ((null l)) - (cond ((atom (setq v (car l))) - (push v lambda-vars) - (push nil lambda-vals)) - (t (push (car v) lambda-vars) - (push (cadr v) lambda-vals)))) - (setq tem `((lambda ,lambda-vars ,@tem) - ,@lambda-vals)))))) - (do ((l loop-wrappers (cdr l))) ((null l)) - (setq tem (append (car l) (list tem)))) - tem) - ;;The following commented-out code is what comes from the newest source - ;; code in use in NIL. The code in use following it comes from about version - ;; 803, that in use in symbolics release 6.1, for instance. To turn on the - ;; implicit DO feature, switch them and fix loop-get-form to just pop the source. - (if (symbolp (setq keyword (car loop-source-code))) - (loop-pop-source) - (setq keyword 'do)) - (if (setq tem (loop-tassoc keyword loop-keyword-alist)) - (apply (cadr tem) (cddr tem)) - (if (setq tem (loop-tassoc - keyword loop-iteration-keyword-alist)) - (loop-hack-iteration tem) - (if (loop-tmember keyword '(and else)) - ; Alternative is to ignore it, ie let it go around to the - ; next keyword... - (loop-simple-error - "secondary clause misplaced at top level in LOOP macro" - (list keyword (car loop-source-code) - (cadr loop-source-code))) - (loop-simple-error - "unknown keyword in LOOP macro" keyword)))) - ;; (if (symbolp (setq keyword (loop-pop-source))) - ;; (if (setq tem (loop-tassoc keyword loop-keyword-alist)) - ;; (apply (cadr tem) (cddr tem)) - ;; (if (setq tem (loop-tassoc - ;; keyword loop-iteration-keyword-alist)) - ;; (loop-hack-iteration tem) - ;; (if (loop-tmember keyword '(and else)) - ;; ; Alternative is to ignore it, ie let it go around to the - ;; ; next keyword... - ;; (loop-simple-error - ;; "secondary clause misplaced at top level in LOOP macro" - ;; (list keyword (car loop-source-code) - ;; (cadr loop-source-code))) - ;; (loop-simple-error - ;; "unknown keyword in LOOP macro" keyword)))) - ;; (loop-simple-error - ;; "found where keyword expected in LOOP macro" keyword)) -)) - - -(defun loop-bind-block () - (cond ((not (null loop-variables)) - (push loop-variables loop-variable-stack) - (push loop-declarations loop-declaration-stack) - (setq loop-variables nil loop-declarations nil) - (push loop-desetq-crocks loop-desetq-stack) - (setq loop-desetq-crocks nil)))) - - -;Get FORM argument to a keyword. Read up to atom. PROGNify if necessary. -(defun loop-get-progn-1 () - (do ((forms (list (loop-pop-source)) (cons (loop-pop-source) forms)) - (nextform (car loop-source-code) (car loop-source-code))) - ((atom nextform) (nreverse forms)))) - -(defun loop-get-progn () - (let ((forms (loop-get-progn-1))) - (if (null (cdr forms)) (car forms) (cons 'progn forms)))) - -(defun loop-get-form (for) - ;; Until implicit DO is installed, use the following. Then, replace it with - ;; just loop-pop-source. - (let ((forms (loop-get-progn-1))) - (cond ((null (cdr forms)) (car forms)) - (t (loop-warn -"The use of multiple forms with an implicit PROGN in this context -is considered obsolete, but is still supported for the time being. -If you did not intend to use multiple forms here, you probably omitted a DO. -If the use of multiple forms was intentional, put a PROGN in your code. -The offending clause" - (if (atom for) (cons for forms) (append for forms))) - (cons 'progn forms))))) - - -;;;This function takes a substitutable expression containing generic arithmetic -;;; of some form or another, and a data type name, and substitutes for the function -;;; any type-specific functions for that type in the implementation. -(defun loop-typed-arith (substitutable-expression data-type) - (declare (ignore data-type)) - substitutable-expression) - -(defvar loop-floating-point-types - '(flonum float short-float single-float double-float long-float)) - -(defun loop-typed-init (data-type) - (let ((tem nil)) - (cond ((data-type? data-type) (initial-value data-type)) - ((loop-tmember data-type '(fixnum integer number)) 0) - ((setq tem (car (loop-tmember - data-type loop-floating-point-types))) - (cond ((member tem '(flonum float)) 0.0) - (t (coerce 0 tem))))))) - - -(defun loop-make-variable (name initialization dtype) - (cond ((null name) - (cond ((not (null initialization)) - (push (list (setq name (loop-gentemp 'loop-ignore-)) - initialization) - loop-variables) - (push `(ignore ,name) loop-declarations)))) - ((atom name) - (cond (loop-iteration-variablep - (if (member name loop-iteration-variables) - (loop-simple-error - "Duplicated iteration variable somewhere in LOOP" - name) - (push name loop-iteration-variables))) - ((assoc name loop-variables) - (loop-simple-error - "Duplicated var in LOOP bind block" name))) - (or (symbolp name) - (loop-simple-error "Bad variable somewhere in LOOP" name)) - (loop-declare-variable name dtype) - ; We use ASSOC on this list to check for duplications (above), - ; so don't optimize out this list: - (push (list name (or initialization (loop-typed-init dtype))) - loop-variables)) - (initialization - (cond (loop-use-system-destructuring? - (loop-declare-variable name dtype) - (push (list name initialization) loop-variables)) - (t (let ((newvar (loop-gentemp 'loop-destructure-))) - (push (list newvar initialization) loop-variables) - ; LOOP-DESETQ-CROCKS gathered in reverse order. - (setq loop-desetq-crocks - (list* name newvar loop-desetq-crocks)) - (loop-make-variable name nil dtype))))) - (t (let ((tcar nil) (tcdr nil)) - (if (atom dtype) (setq tcar (setq tcdr dtype)) - (setq tcar (car dtype) tcdr (cdr dtype))) - (loop-make-variable (car name) nil tcar) - (loop-make-variable (cdr name) nil tcdr)))) - name) - - -(defun loop-make-iteration-variable (name initialization dtype) - (let ((loop-iteration-variablep t)) - (loop-make-variable name initialization dtype))) - - -(defun loop-declare-variable (name dtype) - (cond ((or (null name) (null dtype)) nil) - ((symbolp name) - (cond ((member name loop-nodeclare)) - ((data-type? dtype) - (setq loop-declarations - (append (variable-declarations dtype name) - loop-declarations))) - (t (push `(type ,(if (loop-tequal dtype 'notype) t dtype) ,name) loop-declarations)))) - ((consp name) - (cond ((consp dtype) - (loop-declare-variable (car name) (car dtype)) - (loop-declare-variable (cdr name) (cdr dtype))) - (t (loop-declare-variable (car name) dtype) - (loop-declare-variable (cdr name) dtype)))) - (t (loop-simple-error "can't hack this" - (list 'loop-declare-variable name dtype))))) - - -(defun loop-constantp (form) - (constantp form)) - -(defun loop-maybe-bind-form (form data-type?) - ; Consider implementations which will not keep EQ quoted constants - ; EQ after compilation & loading. - ; Note FUNCTION is not hacked, multiple occurences might cause the - ; compiler to break the function off multiple times! - ; Hacking it probably isn't too important here anyway. The ones that - ; matter are the ones that use it as a stepper (or whatever), which - ; handle it specially. - (if (loop-constantp form) form - (loop-make-variable (loop-gentemp 'loop-bind-) form data-type?))) - - -(defun loop-optional-type () - (let ((token (car loop-source-code))) - (and (not (null token)) - (or (not (atom token)) - (data-type? token) - (loop-tmember token '(fixnum integer number notype)) - (loop-tmember token loop-floating-point-types)) - (loop-pop-source)))) - - -;Incorporates conditional if necessary -(defun loop-make-conditionalization (form) - (cond ((not (null loop-conditionals)) - (rplacd (last (car (last (car (last loop-conditionals))))) - (list form)) - (cond ((loop-tequal (car loop-source-code) 'and) - (loop-pop-source) - nil) - ((loop-tequal (car loop-source-code) 'else) - (loop-pop-source) - ;; If we are already inside an else clause, close it off - ;; and nest it inside the containing when clause - (let ((innermost (car (last loop-conditionals)))) - (cond ((null (cddr innermost))) ;Now in a WHEN clause, OK - ((null (cdr loop-conditionals)) - (loop-simple-error "More ELSEs than WHENs" - (list 'else (car loop-source-code) - (cadr loop-source-code)))) - (t (setq loop-conditionals (cdr (nreverse loop-conditionals))) - (rplacd (last (car (last (car loop-conditionals)))) - (list innermost)) - (setq loop-conditionals (nreverse loop-conditionals))))) - ;; Start a new else clause - (rplacd (last (car (last loop-conditionals))) - (list (list 't))) - nil) - (t ;Nest up the conditionals and output them - (do ((prev (car loop-conditionals) (car l)) - (l (cdr loop-conditionals) (cdr l))) - ((null l)) - (rplacd (last (car (last prev))) (list (car l)))) - (prog1 (car loop-conditionals) - (setq loop-conditionals nil))))) - (t form))) - -(defun loop-pseudo-body (form &aux (z (loop-make-conditionalization form))) - (cond ((not (null z)) - (cond (loop-emitted-body? (push z loop-body)) - (t (push z loop-before-loop) (push z loop-after-body)))))) - -(defun loop-emit-body (form) - (setq loop-emitted-body? t) - (loop-pseudo-body form)) - - -(defun loop-do-named () - (let ((name (loop-pop-source))) - (unless (and name (symbolp name)) - (loop-simple-error "Bad name for your loop construct" name)) - ;If this don't come first, LOOP will be confused about how to return - ; from the prog when it tries to generate such code - (when (or loop-before-loop loop-body loop-after-epilogue) - (loop-simple-error "NAMED clause occurs too late" name)) - (when (cdr (setq loop-prog-names (cons name loop-prog-names))) - (loop-simple-error "Too many names for your loop construct" - loop-prog-names)))) - -(defun loop-do-initially () - (push (loop-get-progn) loop-prologue)) - -(defun loop-nodeclare (&aux (varlist (loop-pop-source))) - (or (null varlist) - (consp varlist) - (loop-simple-error "Bad varlist to nodeclare loop clause" varlist)) - (setq loop-nodeclare (append varlist loop-nodeclare))) - -(defun loop-do-finally () - (push (loop-get-progn) loop-epilogue)) - -(defun loop-do-do () - (loop-emit-body (loop-get-progn))) - -(defun loop-do-return () - (loop-pseudo-body (loop-construct-return (loop-get-form 'return)))) - - -(defun loop-do-collect (type) - (let ((var nil) (form nil) (tem nil) (tail nil) (dtype nil) (cruft nil) (rvar nil) - (ctype (case type - ((max min) 'maxmin) - ((nconc list append) 'list) - ((count sum) 'sum) - (t (error "LOOP internal error: ~S is an unknown collecting keyword." - type))))) - (setq form (loop-get-form type) dtype (loop-optional-type)) - (cond ((loop-tequal (car loop-source-code) 'into) - (loop-pop-source) - (setq rvar (setq var (loop-pop-source))))) - ; CRUFT will be (varname ctype dtype var tail (optional tem)) - (cond ((setq cruft (assoc var loop-collect-cruft)) - (cond ((not (eq ctype (car (setq cruft (cdr cruft))))) - (loop-simple-error - "incompatible LOOP collection types" - (list ctype (car cruft)))) - ((and dtype (not (eq dtype (cadr cruft)))) - ;Conditional should be on data-type reality - (error "~A and ~A Unequal data types into ~A" - dtype (cadr cruft) (car cruft)))) - (setq dtype (car (setq cruft (cdr cruft))) - var (car (setq cruft (cdr cruft))) - tail (car (setq cruft (cdr cruft))) - tem (cadr cruft)) - (and (eq ctype 'maxmin) - (not (atom form)) (null tem) - (rplaca (cdr cruft) - (setq tem (loop-make-variable - (loop-gentemp 'loop-maxmin-) - nil dtype))))) - (t (unless dtype - (setq dtype (case type - (count 'fixnum) - ((min max sum) 'number)))) - (unless var - (push (loop-construct-return (setq var (loop-gentemp))) - loop-after-epilogue)) - (loop-make-iteration-variable var nil dtype) - (cond ((eq ctype 'maxmin) - ;Make a temporary. - (unless (atom form) - (setq tem (loop-make-variable - (loop-gentemp) nil dtype))) - ;Use the tail slot of the collect database to hold a - ; flag which says we have been around once already. - (setq tail (loop-make-variable - (loop-gentemp 'loop-maxmin-fl-) t nil))) - ((eq ctype 'list) - ;For dumb collection, we need both a tail and a flag var - ; to tell us whether we have iterated. - (setq tail (loop-make-variable (loop-gentemp) nil nil) - tem (loop-make-variable (loop-gentemp) nil nil)))) - (push (list rvar ctype dtype var tail tem) - loop-collect-cruft))) - (loop-emit-body - (case type - (count (setq tem `(setq ,var (,(loop-typed-arith '1+ dtype) - ,var))) - (if (or (eq form t) (equal form ''t)) - tem - `(when ,form ,tem))) - (sum `(setq ,var (,(loop-typed-arith '+ dtype) ,form ,var))) - ((max min) - (let ((forms nil) (arglist nil)) - ; TEM is temporary, properly typed. - (and tem (setq forms `((setq ,tem ,form)) form tem)) - (setq arglist (list var form)) - (push (if (loop-tmember dtype '(fixnum flonum)) - ; no contagious arithmetic - `(when (or ,tail - (,(loop-typed-arith - (if (eq type 'max) '< '>) - dtype) - ,@arglist)) - (setq ,tail nil ,@arglist)) - ; potentially contagious arithmetic -- must use - ; MAX or MIN so that var will be contaminated - `(setq ,var (cond (,tail (setq ,tail nil) ,form) - (t (,type ,@arglist))))) - forms) - (if (cdr forms) (cons 'progn (nreverse forms)) (car forms)))) - (t (case type - (list (setq form (list 'list form))) - (append (or (and (not (atom form)) (eq (car form) 'list)) - (setq form `(copy-list ,form))))) - (let ((q `(if ,tail (cdr (rplacd ,tail ,tem)) - (setq ,var ,tem)))) - (if (and (not (atom form)) (eq (car form) 'list) (cdr form)) - `(setq ,tem ,form ,tail ,(loop-cdrify (cddr form) q)) - `(when (setq ,tem ,form) (setq ,tail (last ,q)))))))))) - - -(defun loop-cdrify (arglist form) - (do ((size (length arglist) (- size 4))) - ((< size 4) - (if (zerop size) form - (list (cond ((= size 1) 'cdr) ((= size 2) 'cddr) (t 'cdddr)) - form))) - (declare (type fixnum size)) - (setq form (list 'cddddr form)))) - - - -(defun loop-do-while (negate? kwd &aux (form (loop-get-form kwd))) - (and loop-conditionals (loop-simple-error - "not allowed inside LOOP conditional" - (list kwd form))) - (loop-pseudo-body `(,(if negate? 'when 'unless) - ,form (go end-loop)))) - - -(defun loop-do-when (negate? kwd) - (let ((form (loop-get-form kwd)) (cond nil)) - (cond ((loop-tequal (cadr loop-source-code) 'it) - ;WHEN foo RETURN IT and the like - (setq cond `(setq ,(loop-when-it-variable) ,form)) - (setq loop-source-code ;Plug in variable for IT - (list* (car loop-source-code) - loop-when-it-variable - (cddr loop-source-code)))) - (t (setq cond form))) - (and negate? (setq cond `(not ,cond))) - (setq loop-conditionals (nconc loop-conditionals `((cond (,cond))))))) - -(defun loop-do-with () - (do ((var) (equals) (val) (dtype)) (nil) - (setq var (loop-pop-source) equals (car loop-source-code)) - (cond ((loop-tequal equals '=) - (loop-pop-source) - (setq val (loop-get-form (list 'with var '=)) dtype nil)) - ((or (loop-tequal equals 'and) - (loop-tassoc equals loop-keyword-alist) - (loop-tassoc equals loop-iteration-keyword-alist)) - (setq val nil dtype nil)) - (t (setq dtype (loop-optional-type) equals (car loop-source-code)) - (cond ((loop-tequal equals '=) - (loop-pop-source) - (setq val (loop-get-form (list 'with var dtype '=)))) - ((and (not (null loop-source-code)) - (not (loop-tassoc equals loop-keyword-alist)) - (not (loop-tassoc - equals loop-iteration-keyword-alist)) - (not (loop-tequal equals 'and))) - (loop-simple-error "Garbage where = expected" equals)) - (t (setq val nil))))) - (loop-make-variable var val dtype) - (if (not (loop-tequal (car loop-source-code) 'and)) (return nil) - (loop-pop-source))) - (loop-bind-block)) - -(defun loop-do-always (negate?) - (let ((form (loop-get-form 'always))) - (loop-emit-body `(,(if negate? 'when 'unless) ,form - ,(loop-construct-return nil))) - (push (loop-construct-return t) loop-after-epilogue))) - -;THEREIS expression -;If expression evaluates non-nil, return that value. -(defun loop-do-thereis () - (loop-emit-body `(when (setq ,(loop-when-it-variable) - ,(loop-get-form 'thereis)) - ,(loop-construct-return loop-when-it-variable)))) - - -;;;; Hacks - -(defun loop-simplep (expr) - (if (null expr) 0 - (catch 'loop-simplep - (let ((ans (loop-simplep-1 expr))) - (declare (fixnum ans)) - (and (< ans 20.) ans))))) - -(defvar loop-simplep - '(> < <= >= /= + - 1+ 1- ash equal atom setq prog1 prog2 and or = aref char schar sbit svref)) - -(defun loop-simplep-1 (x) - (let ((z 0)) - (declare (fixnum z)) - (cond ((loop-constantp x) 0) - ((atom x) 1) - ((eq (car x) 'cond) - (do ((cl (cdr x) (cdr cl))) ((null cl)) - (do ((f (car cl) (cdr f))) ((null f)) - (setq z (+ (loop-simplep-1 (car f)) z 1)))) - z) - ((symbolp (car x)) - (let ((fn (car x)) (tem nil)) - (cond ((setq tem (get fn 'loop-simplep)) - (if (typep tem 'fixnum) (setq z tem) - (setq z (funcall tem x) x nil))) - ((member fn '(null not eq go return progn))) - ((member fn '(car cdr)) (setq z 1)) - ((member fn '(caar cadr cdar cddr)) (setq z 2)) - ((member fn '(caaar caadr cadar caddr - cdaar cdadr cddar cdddr)) - (setq z 3)) - ((member fn '(caaaar caaadr caadar caaddr - cadaar cadadr caddar cadddr - cdaaar cdaadr cdadar cdaddr - cddaar cddadr cdddar cddddr)) - (setq z 4)) - ((member fn loop-simplep) (setq z 2)) - (t (multiple-value-bind (new-form expanded-p) - (macroexpand-1 x loop-macro-environment) - (if expanded-p - (setq z (loop-simplep-1 new-form) x nil) - (throw 'loop-simplep nil))))) - (do ((l (cdr x) (cdr l))) ((null l)) - (setq z (+ (loop-simplep-1 (car l)) 1 z))) - z)) - (t (throw 'loop-simplep nil))))) - - -;;;; The iteration driver -(defun loop-hack-iteration (entry) - (do ((last-entry entry) - (source loop-source-code loop-source-code) - (pre-step-tests nil) - (steps nil) - (post-step-tests nil) - (pseudo-steps nil) - (pre-loop-pre-step-tests nil) - (pre-loop-steps nil) - (pre-loop-post-step-tests nil) - (pre-loop-pseudo-steps nil) - (tem) (data) (foo) (bar)) - (nil) - ; Note we collect endtests in reverse order, but steps in correct - ; order. LOOP-END-TESTIFY does the nreverse for us. - (setq tem (setq data (apply (cadr entry) (cddr entry)))) - (and (car tem) (push (car tem) pre-step-tests)) - (setq steps (nconc steps (loop-copylist* (car (setq tem (cdr tem)))))) - (and (car (setq tem (cdr tem))) (push (car tem) post-step-tests)) - (setq pseudo-steps - (nconc pseudo-steps (loop-copylist* (car (setq tem (cdr tem)))))) - (setq tem (cdr tem)) - (and (or loop-conditionals loop-emitted-body?) - (or tem pre-step-tests post-step-tests pseudo-steps) - (let ((cruft (list (car entry) (car source) - (cadr source) (caddr source)))) - (if loop-emitted-body? - (loop-simple-error - "Iteration is not allowed to follow body code" cruft) - (loop-simple-error - "Iteration starting inside of conditional in LOOP" - cruft)))) - (or tem (setq tem data)) - (and (car tem) (push (car tem) pre-loop-pre-step-tests)) - (setq pre-loop-steps - (nconc pre-loop-steps (loop-copylist* (car (setq tem (cdr tem)))))) - (and (car (setq tem (cdr tem))) (push (car tem) pre-loop-post-step-tests)) - (setq pre-loop-pseudo-steps - (nconc pre-loop-pseudo-steps (loop-copylist* (cadr tem)))) - (cond ((or (not (loop-tequal (car loop-source-code) 'and)) - (and loop-conditionals - (not (loop-tassoc (cadr loop-source-code) - loop-iteration-keyword-alist)))) - (setq foo (list (loop-end-testify pre-loop-pre-step-tests) - (loop-make-psetq pre-loop-steps) - (loop-end-testify pre-loop-post-step-tests) - (loop-make-setq pre-loop-pseudo-steps)) - bar (list (loop-end-testify pre-step-tests) - (loop-make-psetq steps) - (loop-end-testify post-step-tests) - (loop-make-setq pseudo-steps))) - (cond ((not loop-conditionals) - (setq loop-before-loop (nreconc foo loop-before-loop) - loop-after-body (nreconc bar loop-after-body))) - (t ((lambda (loop-conditionals) - (push (loop-make-conditionalization - (cons 'progn (delete nil foo))) - loop-before-loop)) - (mapcar #'(lambda (x) ;Copy parts that will get rplacd'ed - (cons (car x) - (mapcar #'(lambda (x) (loop-copylist* x)) (cdr x)))) - loop-conditionals)) - (push (loop-make-conditionalization - (cons 'progn (delete nil bar))) - loop-after-body))) - (loop-bind-block) - (return nil))) - (loop-pop-source) ; flush the "AND" - (setq entry (cond ((setq tem (loop-tassoc - (car loop-source-code) - loop-iteration-keyword-alist)) - (loop-pop-source) - (setq last-entry tem)) - (t last-entry))))) - - -;FOR variable keyword ..args.. -(defun loop-do-for () - (let ((var (loop-pop-source)) - (data-type? (loop-optional-type)) - (keyword (loop-pop-source)) - (first-arg nil) - (tem nil)) - (setq first-arg (loop-get-form (list 'for var keyword))) - (or (setq tem (loop-tassoc keyword loop-for-keyword-alist)) - (loop-simple-error - "Unknown keyword in FOR or AS clause in LOOP" - (list 'for var keyword))) - (apply (cadr tem) var first-arg data-type? (cddr tem)))) - - -(defun loop-do-repeat () - (let ((var (loop-make-variable - (loop-gentemp 'loop-repeat-) - (loop-get-form 'repeat) 'fixnum))) - `((not (,(loop-typed-arith 'plusp 'fixnum) ,var)) - () () - (,var (,(loop-typed-arith '1- 'fixnum) ,var))))) - - -; Kludge the First -(defun loop-when-it-variable () - (or loop-when-it-variable - (setq loop-when-it-variable - (loop-make-variable (loop-gentemp 'loop-it-) nil nil)))) - - - -(defun loop-for-equals (var val data-type?) - (cond ((loop-tequal (car loop-source-code) 'then) - ;FOR var = first THEN next - (loop-pop-source) - (loop-make-iteration-variable var val data-type?) - `(() (,var ,(loop-get-form (list 'for var '= val 'then))) () () - () () () ())) - (t (loop-make-iteration-variable var nil data-type?) - (let ((varval (list var val))) - (cond (loop-emitted-body? - (loop-emit-body (loop-make-setq varval)) - '(() () () ())) - (`(() ,varval () ()))))))) - -(defun loop-for-first (var val data-type?) - (or (loop-tequal (car loop-source-code) 'then) - (loop-simple-error "found where THEN expected in FOR ... FIRST" - (car loop-source-code))) - (loop-pop-source) - (loop-make-iteration-variable var nil data-type?) - `(() (,var ,(loop-get-form (list 'for var 'first val 'then))) () () - () (,var ,val) () ())) - - -(defun loop-list-stepper (var val data-type? fn) - (let ((stepper (cond ((loop-tequal (car loop-source-code) 'by) - (loop-pop-source) - (loop-get-form (list 'for var - (if (eq fn 'car) 'in 'on) - val 'by))) - (t '(function cdr)))) - (var1 nil) (stepvar nil) (step nil) (et nil) (pseudo nil)) - (setq step (if (or (atom stepper) - (not (member (car stepper) '(quote function)))) - `(funcall ,(setq stepvar (loop-gentemp 'loop-fn-))) - (list (cadr stepper)))) - (cond ((and (atom var) - ;; (eq (car step) 'cdr) - (not fn)) - (setq var1 (loop-make-iteration-variable var val data-type?))) - (t (loop-make-iteration-variable var nil data-type?) - (setq var1 (loop-make-variable - (loop-gentemp 'loop-list-) val nil)) - (setq pseudo (list var (if fn (list fn var1) var1))))) - (rplacd (last step) (list var1)) - (and stepvar (loop-make-variable stepvar stepper nil)) - (setq stepper (list var1 step) et `(null ,var1)) - (if (not pseudo) `(() ,stepper ,et () () () ,et ()) - (if (eq (car step) 'cdr) `(,et ,pseudo () ,stepper) - `((null (setq ,@stepper)) () () ,pseudo ,et () () ,pseudo))))) - - -(defun loop-for-arithmetic (var val data-type? kwd) - ; Args to loop-sequencer: - ; indexv indexv-type variable? vtype? sequencev? sequence-type - ; stephack? default-top? crap prep-phrases - (loop-sequencer - var (or data-type? 'fixnum) nil nil nil nil nil nil `(for ,var ,kwd ,val) - (cons (list kwd val) - (loop-gather-preps - '(from upfrom downfrom to upto downto above below by) - nil)))) - - -(defun loop-named-variable (name) - (let ((tem (loop-tassoc name loop-named-variables))) - (cond ((null tem) (loop-gentemp)) - (t (setq loop-named-variables (delete tem loop-named-variables)) - (cdr tem))))) - - -; Note: path functions are allowed to use loop-make-variable, hack -; the prologue, etc. -(defun loop-for-being (var val data-type?) - ; FOR var BEING something ... - var = VAR, something = VAL. - ; If what passes syntactically for a pathname isn't, then - ; we trap to the DEFAULT-LOOP-PATH path; the expression which looked like - ; a path is given as an argument to the IN preposition. Thus, - ; by default, FOR var BEING EACH expr OF expr-2 - ; ==> FOR var BEING DEFAULT-LOOP-PATH IN expr OF expr-2. - (let ((tem nil) (inclusive? nil) (ipps nil) (each? nil) (attachment nil)) - (if (or (loop-tequal val 'each) (loop-tequal val 'the)) - (setq each? 't val (car loop-source-code)) - (push val loop-source-code)) - (cond ((and (setq tem (loop-tassoc val loop-path-keyword-alist)) - (or each? (not (loop-tequal (cadr loop-source-code) - 'and)))) - ;; FOR var BEING {each} path {prep expr}..., but NOT - ;; FOR var BEING var-which-looks-like-path AND {ITS} ... - (loop-pop-source)) - (t (setq val (loop-get-form (list 'for var 'being))) - (cond ((loop-tequal (car loop-source-code) 'and) - ;; FOR var BEING value AND ITS path-or-ar - (or (null each?) - (loop-simple-error - "Malformed BEING EACH clause in LOOP" var)) - (setq ipps `((of ,val)) inclusive? t) - (loop-pop-source) - (or (loop-tmember (setq tem (loop-pop-source)) - '(its his her their each)) - (loop-simple-error - "found where ITS or EACH expected in LOOP path" - tem)) - (if (setq tem (loop-tassoc - (car loop-source-code) - loop-path-keyword-alist)) - (loop-pop-source) - (push (setq attachment - `(in ,(loop-get-form - `(for ,var being \.\.\. in)))) - ipps))) - ((not (setq tem (loop-tassoc - (car loop-source-code) - loop-path-keyword-alist))) - ; FOR var BEING {each} a-r ... - (setq ipps (list (setq attachment (list 'in val))))) - (t ; FOR var BEING {each} pathname ... - ; Here, VAL should be just PATHNAME. - (loop-pop-source))))) - (cond ((not (null tem))) - ((not (setq tem (loop-tassoc 'default-loop-path - loop-path-keyword-alist))) - (loop-simple-error "Undefined LOOP iteration path" - (cadr attachment)))) - (setq tem (funcall (cadr tem) (car tem) var data-type? - (nreconc ipps (loop-gather-preps (caddr tem) t)) - inclusive? (caddr tem) (cdddr tem))) - (and loop-named-variables - (loop-simple-error "unused USING variables" loop-named-variables)) - ; For error continuability (if there is any): - (setq loop-named-variables nil) - ;; TEM is now (bindings prologue-forms . stuff-to-pass-back) - (do ((l (car tem) (cdr l)) (x)) ((null l)) - (if (atom (setq x (car l))) - (loop-make-iteration-variable x nil nil) - (loop-make-iteration-variable (car x) (cadr x) (caddr x)))) - (setq loop-prologue (nconc (reverse (cadr tem)) loop-prologue)) - (cddr tem))) - - -(defun loop-gather-preps (preps-allowed crockp) - (do ((token (car loop-source-code) (car loop-source-code)) (preps nil)) - (nil) - (cond ((loop-tmember token preps-allowed) - (push (list (loop-pop-source) - (loop-get-form `(for \... being \... ,token))) - preps)) - ((loop-tequal token 'using) - (loop-pop-source) - (or crockp (loop-simple-error - "USING used in illegal context" - (list 'using (car loop-source-code)))) - (do ((z (car loop-source-code) (car loop-source-code)) (tem)) - ((atom z)) - (and (or (atom (cdr z)) - (not (null (cddr z))) - (not (symbolp (car z))) - (and (cadr z) (not (symbolp (cadr z))))) - (loop-simple-error - "bad variable pair in path USING phrase" z)) - (cond ((not (null (cadr z))) - (and (setq tem (loop-tassoc - (car z) loop-named-variables)) - (loop-simple-error - "Duplicated var substitition in USING phrase" - (list tem z))) - (push (cons (car z) (cadr z)) loop-named-variables))) - (loop-pop-source))) - (t (return (nreverse preps)))))) - -(defun loop-add-path (name data) - (setq loop-path-keyword-alist - (cons (cons name data) - (delete (loop-tassoc name loop-path-keyword-alist) - loop-path-keyword-alist - :test #'eq))) - nil) - - -(defmacro define-loop-path (names &rest cruft) - "(DEFINE-LOOP-PATH NAMES PATH-FUNCTION LIST-OF-ALLOWABLE-PREPOSITIONS -DATUM-1 DATUM-2 ...) -Defines PATH-FUNCTION to be the handler for the path(s) NAMES, which may -be either a symbol or a list of symbols. LIST-OF-ALLOWABLE-PREPOSITIONS -contains a list of prepositions allowed in NAMES. DATUM-i are optional; -they are passed on to PATH-FUNCTION as a list." - (setq names (if (atom names) (list names) names)) - (let ((forms (mapcar #'(lambda (name) `(loop-add-path ',name ',cruft)) - names))) - `(eval-when (eval load compile) ,@forms))) - - -(defun loop-sequencer (indexv indexv-type - variable? vtype? - sequencev? sequence-type? - stephack? default-top? - crap prep-phrases) - (let ((endform nil) (sequencep nil) (test nil) - (step ; Gross me out! - (1+ (or (loop-typed-init indexv-type) 0))) - (dir nil) (inclusive-iteration? nil) (start-given? nil) (limit-given? nil)) - (and variable? (loop-make-iteration-variable variable? nil vtype?)) - (do ((l prep-phrases (cdr l)) (prep) (form) (odir)) ((null l)) - (setq prep (caar l) form (cadar l)) - (cond ((loop-tmember prep '(of in)) - (and sequencep (loop-simple-error - "Sequence duplicated in LOOP path" - (list variable? (car l)))) - (setq sequencep t) - (loop-make-variable sequencev? form sequence-type?)) - ((loop-tmember prep '(from downfrom upfrom)) - (and start-given? - (loop-simple-error - "Iteration start redundantly specified in LOOP sequencing" - (append crap l))) - (setq start-given? t) - (cond ((loop-tequal prep 'downfrom) (setq dir 'down)) - ((loop-tequal prep 'upfrom) (setq dir 'up))) - (loop-make-iteration-variable indexv form indexv-type)) - ((cond ((loop-tequal prep 'upto) - (setq inclusive-iteration? (setq dir 'up))) - ((loop-tequal prep 'to) - (setq inclusive-iteration? t)) - ((loop-tequal prep 'downto) - (setq inclusive-iteration? (setq dir 'down))) - ((loop-tequal prep 'above) (setq dir 'down)) - ((loop-tequal prep 'below) (setq dir 'up))) - (and limit-given? - (loop-simple-error - "Endtest redundantly specified in LOOP sequencing path" - (append crap l))) - (setq limit-given? t) - (setq endform (loop-maybe-bind-form form indexv-type))) - ((loop-tequal prep 'by) - (setq step (if (loop-constantp form) form - (loop-make-variable - (loop-gentemp 'loop-step-by-) - form 'fixnum)))) - (t ; This is a fatal internal error... - (loop-simple-error "Illegal prep in sequence path" - (append crap l)))) - (and odir dir (not (eq dir odir)) - (loop-simple-error - "Conflicting stepping directions in LOOP sequencing path" - (append crap l))) - (setq odir dir)) - (and sequencev? (not sequencep) - (loop-simple-error "Missing OF phrase in sequence path" crap)) - ; Now fill in the defaults. - (setq step (list indexv step)) - (cond ((member dir '(nil up)) - (or start-given? - (loop-make-iteration-variable indexv 0 indexv-type)) - (and (or limit-given? - (cond (default-top? - (loop-make-variable - (setq endform (loop-gentemp - 'loop-seq-limit-)) - nil indexv-type) - (push `(setq ,endform ,default-top?) - loop-prologue)))) - (setq test (if inclusive-iteration? '(> . args) - '(>= . args)))) - (push '+ step)) - (t (cond ((not start-given?) - (or default-top? - (loop-simple-error - "Don't know where to start stepping" - (append crap prep-phrases))) - (loop-make-iteration-variable indexv 0 indexv-type) - (push `(setq ,indexv - (,(loop-typed-arith '1- indexv-type) - ,default-top?)) - loop-prologue))) - (cond ((and default-top? (not endform)) - (setq endform (loop-typed-init indexv-type) - inclusive-iteration? t))) - (and (not (null endform)) - (setq test (if inclusive-iteration? '(< . args) - '(<= . args)))) - (push '- step))) - (and (and (numberp (caddr step)) (= (caddr step) 1)) ;Generic arith - (rplacd (cdr (rplaca step (if (eq (car step) '+) '1+ '1-))) - nil)) - (rplaca step (loop-typed-arith (car step) indexv-type)) - (setq step (list indexv step)) - (setq test (loop-typed-arith test indexv-type)) - (setq test (subst (list indexv endform) 'args test)) - (and stephack? (setq stephack? `(,variable? ,stephack?))) - `(() ,step ,test ,stephack? - () () ,test ,stephack?))) - - -(defun loop-sequence-elements-path (path variable data-type - prep-phrases inclusive? - allowed-preps data) - allowed-preps ; unused - (let ((indexv (loop-named-variable 'index)) - (sequencev (loop-named-variable 'sequence)) - (fetchfun nil) (sizefun nil) (type nil) (default-var-type nil) - (crap `(for ,variable being the ,path))) - (cond ((not (null inclusive?)) - (rplacd (cddr crap) `(,(cadar prep-phrases) and its ,path)) - (loop-simple-error "Can't step sequence inclusively" crap))) - (setq fetchfun (car data) - sizefun (car (setq data (cdr data))) - type (car (setq data (cdr data))) - default-var-type (cadr data)) - (list* nil nil ; dummy bindings and prologue - (loop-sequencer - indexv 'fixnum - variable (or data-type default-var-type) - sequencev type - `(,fetchfun ,sequencev ,indexv) `(,sizefun ,sequencev) - crap prep-phrases)))) - - - -(defmacro define-loop-sequence-path (path-name-or-names fetchfun sizefun - &optional sequence-type element-type) - "Defines a sequence iiteration path. PATH-NAME-OR-NAMES is either an -atomic path name or a list of path names. FETCHFUN is a function of -two arguments, the sequence and the index of the item to be fetched. -Indexing is assumed to be zero-origined. SIZEFUN is a function of -one argument, the sequence; it should return the number of elements in -the sequence. SEQUENCE-TYPE is the name of the data-type of the -sequence, and ELEMENT-TYPE is the name of the data-type of the elements -of the sequence." - `(define-loop-path ,path-name-or-names - loop-sequence-elements-path - (of in from downfrom to downto below above by) - ,fetchfun ,sizefun ,sequence-type ,element-type)) - - -;;;; Setup stuff - - -(mapc #'(lambda (x) - (mapc #'(lambda (y) - (setq loop-path-keyword-alist - (cons `(,y loop-sequence-elements-path - (of in from downfrom to downto - below above by) - ,@(cdr x)) - (delete (loop-tassoc - y loop-path-keyword-alist) - loop-path-keyword-alist - :test #'eq :count 1)))) - (car x))) - '( ((element elements) elt length sequence) - ;The following should be done by using ELEMENTS and type dcls... - ((vector-element - vector-elements - array-element ;; Backwards compatibility -- DRM - array-elements) - aref length vector) - ((simple-vector-element simple-vector-elements - simple-general-vector-element simple-general-vector-elements) - svref simple-vector-length simple-vector) - ((bits bit bit-vector-element bit-vector-elements) - bit bit-vector-length bit-vector bit) - ((simple-bit-vector-element simple-bit-vector-elements) - sbit simple-bit-vector-length simple-bit-vector bit) - ((character characters string-element string-elements) - char string-length string string-char) - ((simple-string-element simple-string-elements) - schar simple-string-length simple-string string-char) - ) - ) - - -(pushnew 'loop *features*) ;; Common-Lisp says this is correct. -(pushnew :loop *features*) ;; But Lucid only understands this one. - -(defun initial-value (x) x nil) -(defun variable-declarations (type &rest vars) type vars nil) diff --git a/t/baby2015/doc/.~lock.overview.pdf# b/t/baby2015/doc/.~lock.overview.pdf# deleted file mode 100644 index 13c8961..0000000 --- a/t/baby2015/doc/.~lock.overview.pdf# +++ /dev/null @@ -1 +0,0 @@ -,jdaugherty,specialtt-ThinkPad-Edge-E531,19.01.2015 05:40,file:///home/jdaugherty/.config/libreoffice/4; \ No newline at end of file diff --git a/t/baby2015/doc/.~lock.overview.rtf# b/t/baby2015/doc/.~lock.overview.rtf# deleted file mode 100644 index b317276..0000000 --- a/t/baby2015/doc/.~lock.overview.rtf# +++ /dev/null @@ -1 +0,0 @@ -,jdaugherty,specialtt-ThinkPad-Edge-E531,18.01.2015 09:02,file:///home/jdaugherty/.config/libreoffice/4; \ No newline at end of file diff --git a/t/baby2015/doc/babspec.pdf b/t/baby2015/doc/babspec.pdf deleted file mode 100644 index db711b2..0000000 Binary files a/t/baby2015/doc/babspec.pdf and /dev/null differ diff --git a/t/baby2015/doc/macdoc.pdf b/t/baby2015/doc/macdoc.pdf deleted file mode 100644 index 6271363..0000000 Binary files a/t/baby2015/doc/macdoc.pdf and /dev/null differ diff --git a/t/baby2015/doc/macdoc.rtf b/t/baby2015/doc/macdoc.rtf deleted file mode 100644 index 90a38ae..0000000 --- a/t/baby2015/doc/macdoc.rtf +++ /dev/null @@ -1,1095 +0,0 @@ -{\rtf1\mac \deff8\deflang1033{\fonttbl{\f3\fnil\fcharset77\fprq2 Courier;}{\f8\fnil\fcharset77\fprq2 Times;}{\f13\fnil\fcharset77\fprq2 Geneva;}{\f118\fnil\fcharset77\fprq2 Monaco;}}{\colortbl;\red0\green0\blue0; -\red0\green0\blue212;\red2\green171\blue234;\red31\green183\blue20;\red242\green8\blue132;\red221\green8\blue6;\red252\green243\blue5;\red255\green255\blue255;\red0\green0\blue128;\red0\green128\blue128;\red0\green100\blue17;\red128\green0\blue128; -\red128\green0\blue0;\red128\green128\blue0;\red128\green128\blue128;\red192\green192\blue192;}{\stylesheet{\widctlpar \f8\lang1031 \snext0 Normal;}{\s1\li360\sb240\sa240\keepn\nowidctlpar\brdrb\brdrs\brdrw15 \b\f8\fs48\lang1031 \sbasedon20\snext20 -heading 1;}{\s2\li180\sb120\sa120\keepn\nowidctlpar\brdrb\brdrs\brdrw15 \b\f8\fs36\lang1031 \sbasedon20\snext20 heading 2;}{\s3\li360\sb120\sa120\keepn\nowidctlpar \b\f8\fs28\lang1031 \sbasedon20\snext20 heading 3;}{ -\s4\li360\sb120\sa120\keepn\nowidctlpar \b\f8\fs28\lang1031 \sbasedon20\snext20 heading 4;}{\s5\li360\sb120\sa120\keepn\nowidctlpar \b\f8\fs28\lang1031 \sbasedon20\snext20 heading 5;}{\s6\li360\sb120\sa120\keepn\nowidctlpar \b\f8\fs28\lang1031 -\sbasedon20\snext20 heading 6;}{\*\cs10 \additive Default Paragraph Font;}{\*\cs15 \additive\f8 \sbasedon10 page number;}{\s16\li360\sa120\nowidctlpar\tqc\tx4252\tqr\tx8504 \f8\lang1031 \sbasedon20\snext16 footer;}{ -\s17\li360\sa120\nowidctlpar\tqc\tx4252\tqr\tx8504 \f8\lang1031 \sbasedon20\snext17 header;}{\*\cs18 \additive\f8\fs18\up6 \sbasedon10 footnote reference;}{\s19\li360\sa120\nowidctlpar \f8\fs20\lang1031 \sbasedon20\snext20 footnote text;}{ -\s20\li360\sa120\nowidctlpar \f8\lang1031 \snext20 Standardift 1p\'1c\'04ipt\'04.\'a2\'aa\'02;}{\s21\fi-540\li900\sa120\nowidctlpar\tx900 \f8\lang1031 \sbasedon20\snext21 numbered list;}{\s22\fi-540\li1440\sa120\nowidctlpar\tx1440 \f8\lang1031 -\sbasedon20\snext22 numbered list 1;}{\s23\fi-540\li1980\sa120\nowidctlpar\tx1980 \f8\lang1031 \sbasedon20\snext23 numbered list 2;}{\s24\fi-280\li900\sa120\nowidctlpar\tx900 \f8\lang1031 \sbasedon21\snext24 bullet list;}{ -\s25\fi-280\li1440\sa120\nowidctlpar\tx1440 \f8\lang1031 \sbasedon22\snext25 bullet list 1;}{\s26\fi-280\li1980\sa120\nowidctlpar\tx1980 \f8\lang1031 \sbasedon23\snext26 bullet list 2;}{\s27\fi-3960\li4320\sa120\nowidctlpar\tx4320 \f8\lang1031 -\sbasedon20\snext27 glossary;}{\s28\fi-3960\li4860\sa120\nowidctlpar\tx4860 \f8\lang1031 \sbasedon27\snext28 glossary 1;}{\s29\keep\nowidctlpar\tx880\tx1740\tx2620\tx3480\tx4320\tx5220\tx6060\tx6940\tx7780 \f3\fs20\lang1031 \sbasedon20\snext29 pre;}{ -\s30\li360\sa120\nowidctlpar \i\f8\lang1031 \sbasedon20\snext30 address;}{\s31\li1440\ri1440\sa120\nowidctlpar \i\f8\lang1031 \sbasedon20\snext31 blockquote;}{\s32\sb120\sa120\nowidctlpar\brdrb\brdrth\brdrw15 \f8\lang1031 \sbasedon20\snext20 hr;}{ -\s33\fi360\nowidctlpar\tx360\tx3600\tx4320\tx7200\tx10700 \f8\lang1031 \sbasedon20\snext33 dir;}{\s34\fi360\li360\nowidctlpar\tx720\tx3960\tx4320\tx7560\tx10700 \f8\lang1031 \sbasedon20\snext34 dir 1;}{ -\s35\fi360\li720\nowidctlpar\tx1080\tx4320\tx7920\tx10700 \f8\lang1031 \sbasedon20\snext35 dir 2;}{\s36\fi-720\li1440\nowidctlpar\tx1440 \f8\lang1031 \sbasedon30\snext36 menu 1;}{\s37\fi-720\li1080\nowidctlpar\tx1080 \f8\lang1031 \sbasedon36\snext37 -menu;}{\s38\fi-720\li1800\nowidctlpar\tx1800 \f8\lang1031 \sbasedon20\snext38 menu 2;}{\s39\fi-3960\li5400\sa120\nowidctlpar\tx5400 \f8\lang1031 \sbasedon28\snext39 glossary 2;}{\s40\li360\nowidctlpar \f3\lang1031 \sbasedon20\snext40 HTML;}}{\info -{\title macdoc}{\subject babylon on the macintosh}{\author J\'fcrgen Walther}{\creatim\yr1995\mo6\dy30\hr16\min4}{\version1}{\edmins0}{\nofpages0}{\nofwords0}{\nofchars0}{\vern49221}}\paperw11906\paperh16838\margl1416\margr1416\margt1702\margb1702 -\deftab708\widowctrl\ftnbj\aenddoc\hyphhotz425\hyphcaps0 \fet0\sectd \sbknone\linex0\headery709\footery709\colsx709\endnhere {\header \pard\plain \s17\qr\li360\sa120\nowidctlpar\tqc\tx4252\tqr\tx8504\pvpg\phpg\posx10610\posy720\absw576 \f8\lang1031 -{\field{\*\fldinst {\cs15 PAGE }}{\fldrslt {\cs15 4}}}{\cs15 -\par }\pard \s17\li360\sa120\nowidctlpar\tqc\tx4252\tqr\tx8504 -\par }{\*\pnseclvl1\pnucrm\pnstart1\pnindent720\pnhang{\pntxta .}}{\*\pnseclvl2\pnucltr\pnstart1\pnindent720\pnhang{\pntxta .}}{\*\pnseclvl3\pndec\pnstart1\pnindent720\pnhang{\pntxta .}}{\*\pnseclvl4\pnlcltr\pnstart1\pnindent720\pnhang{\pntxta )}}{\*\pnseclvl5 -\pndec\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta )}}{\*\pnseclvl6\pnlcltr\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta )}}{\*\pnseclvl7\pnlcrm\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta )}}{\*\pnseclvl8\pnlcltr\pnstart1\pnindent720\pnhang -{\pntxtb (}{\pntxta )}}{\*\pnseclvl9\pnlcrm\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta )}}\pard\plain \s1\qc\li360\sb240\sa240\keepn\nowidctlpar\brdrb\brdrs\brdrw15 \b\f8\fs48\lang1031 Installing and Using the Hybrid Knowledge Representation\line - and \line Inference Environment \line BABYLON \line on the Apple Macintosh\line -\par \pard\plain \s30\qc\li360\sa120\nowidctlpar \i\f8\lang1031 \line J\'9frgen Walther \line AI Research Division\line German National Research Center for Computer Science (GMD) \line P.O.Box 1316 53731 Sankt Augustin Germany \line juergen.walther@gmd.de - -\par \pard\plain \s20\li360\ri8\sa120\widctlpar \f8\lang1031 \line \line This section focusses on the installation and use of BABYLON release 2.3 on Apple Macintosh. For more information on BABYLON see {\i The AI Workbench BABYLON} -; Christaller,T., DiPrimio, F., and Vo\'a7, A. (eds), Academic Press 1992. -\par \pard\plain \s2\li180\sb120\sa120\keepn\widctlpar\brdrb\brdrs\brdrw15 \b\f8\fs36\lang1031 1.\tab Hardware and Software Requirements -\par \pard\plain \s20\li360\sa120\widctlpar \f8\lang1031 -To run BABYLON on a Macintosh computer you should have at least 6 MB of RAM and 5 MB of free disk capacity. On the software side you need Macintosh Commaon Lisp 2.0.1 (MCL). This allows you to create an application of BABYLON 2.3., called {\i BABYLON} - if you load the file called {\i make.cl};. All the sources that you need are in the folder BABYLON-2.3.{\b -\par }\pard\plain \s2\li180\sb120\sa120\keepn\widctlpar\brdrb\brdrs\brdrw15 \b\f8\fs36\lang1031 2.\tab Getting BABYLON -\par \pard\plain \s20\li360\sa120\widctlpar \f8\lang1031 You can get BABYLON by anonymous ftp - from ftp.gmd.de. Change to directory gmd/ai-research/Software/Babylon and get the Babylon-2.3.sit.hqx file. Decode the file for example with Stuffit Expander and start the resulting self extracting archive to get the Babylon-2.3 folder. You are now ready - to generate the Babylon image. -\par \pard\plain \s2\li180\sb120\sa120\keepn\widctlpar\brdrb\brdrs\brdrw15 \b\f8\fs36\lang1031 3.\tab Creating an Image File -\par \pard\plain \s20\li360\sa120\widctlpar \f8\lang1031 If you want to create an image file (or an application) start your Lisp and then load{\i make-cl}. While loading the make file, there will be some y-or-n questions in the lisp listener -\par \pard \s20\fi-560\li560\sa120\widctlpar\tx560 \bullet \tab Use development options for compiling files?\line -Aswer y, if you want to record source files, save documentation strings and similar development options This cost some space but eases development work. Answer n if you do not want to explore the implementation. -\par \pard \s20\li360\sa120\widctlpar \tab Load graphic frame browser?\line \tab Its worth it! -\par \pard \s20\fi-560\li560\sa120\widctlpar\tx560 \bullet \tab Is your AntiVirus software temporarily disabled?\line -Lisp will try to install a program on your hard disk. Thus, you have to either disable programs like Gatekeeper, or give MCL the Privileges File Other. -\par \pard \s20\li360\sa120\widctlpar After the system has lo -aded a few basic BABYLON system files, you will see a dialog window (cf. Figure 1), which the programmer can use to specify an interpreter configuration. This configuration will be loaded and subsequently stored as an image file. -\par \pard \s20\qc\li360\sa120\keepn\widctlpar {\fs20 {\pict\macpict\picw437\pich301\picwgoal8740\pichgoal6020 -1ab600000000012d01b5001102ff0c00fffe0000004800000048000000000000012d01b5000000000001000a00000000012d01b50099803800000000012d01b50000000000000000004800000048000000000001000100010000000000324ecc0000000000005c36000000010000ffffffffffff0001000000000000000000 -00012d01b500000000012d01b50040000a00000000012d01b505cbff01f800070080cc00010800070080cc0001080007009fccff01c80007009fccff01c800070098cc0001c800070098cc0001c800070098cc0001c800070098cc0001c800070098cc0001c800070098cc0001c800070098cc0001c800070098cc0001c800 -070098cc0001c800070098cc0001c8000d0098e7000207ff80e90001c800190098e70003060180e0fe0007300000c00000c00cf50001c800150098e7000305028180fe0003300000c0f10001c8001a0098e7000f048483cd9e1e0078f199e00ff8ccccf8f60001c8001f079800180001800180ee000b0448818e3333003199 -98c00cfdccf60001c8001e079800180001800180ee000a0430818c33333e319998c7fcccf60001c8002107980018f871998f8fee000f0430818c3f3f0031f8f0c00cccc78cccf60001c8002004980018ccc9fe990080ef000b0448818c303000318198c00cfdccf60001c8002004980018ccc1fe990080ef000b0484818c31 -3100318998c00cfdccf60001c8002008980018ccc199999f80ef000b0502818c1e1e0018f198600cfdccf60001c8001407980018ccc1999998ee0002060180e90001c8001508980018ccc999999880ef000207ff80e90001c8000d04980018cc71fe8fd30001c800070098cc0001c800070098cc0001c800070098cc0001c8 -00070098cc0001c800070098cc0001c800070098cc0001c800070098cc0001c8000b0098e6000078e80001c800260098fd0000f8fd000203000cfd000003f80008018603000006000070fb00013003f70001c8001f0098fd0000c0fd000203000cfd000003f80002020103fc0000c0ef0001c8002e0098fd000ec1b3c7fc3c -031f1e3c6df1b3c78f1bfa0011020103e1e1c63801e6cf1ff0f003fe33333ef80001c8002c0098fd0001c1c4fe660903198c667199c663199cfa000d0400833233266400c71199999803fd33f80001c8002c0098fd000ef183e6666603198c66619986631998fa000904008331f38660f8c60ffe9900f3fd33f80001c8002e -0098fd000ec18666667e03198c7e619987e31f98fa00110400833331c66000c6199999f8033331e333f80001c8002c0098fd000ec18666666003198c60619986031818fa000d0400833330e66000c61999998003fd33f80001c8002c0098fd000ec18666666203198c62619986231898fa000d0201033332666400c6199999 -8803fd33f80001c8002c0098fd000ec183e6663c0319863c61f183c18f18fa000d020103e1f1c63800c60f9998f003fd33f80001c800110098f400010180f600010186e80001c800100098f400010180f5000078e80001c800070098cc0001c800070098cc0001c800070098cc0001c8000f0098fa0000f0ee000078e80001 -c8001d0098fb0001030cef0007018600003003001cfb00020c00c0f70001c800150098fb00010402ef00010201fc000030ee0001c800240098fb0004040207c3c0f20011020103fe33e30079b3c7fc3c00ff8ccccf80f80001c800230098fb00040801066660f20002040083fe33020031c4fe660000fdcc00c0f80001c800 -230098fb00040801066660f20002040083fe33063e3183e666667cfdcc00c0f80001c800240098fb00040801066660f20002040083fe330b00318666667e00cccc78ccc0f80001c800230098fb00040801066660f20002040083fe330600318666666000fdcc00c0f80001c800230098fb00040402066660f20002020103fe -330600318666666200fdcc00c0f80001c800230098fb000404020663c0f20002020103fe3306003183e6663c00fdcc00c0f80001c800110098fb0001030cef00010186e80001c8000f0098fa0000f0ee000078e80001c800070098cc0001c800070098cc0001c800070098cc0001c8000b0098e6000078e80001c800170098 -e700010186fb0001c007fb0002030030f90001c800110098e700010201fb0001c00cf00001c8001e0098e70013027903e1e36ff878c01e6cf1ff0f003fe33333e0fa0001c8001d0098e7000e04fc8333338ccc8cc00c7119999980fd330030fa0001c8001d0098e7000e04fc8333330ccc7ccf8c60f999999ffd330030fa00 -01c8001e0098e7001304fc8333330cccccc00c6199999f8033331e3330fa0001c8001d0098e7000e04fc8333330cccccc00c6199999800fd330030fa0001c8001d0098e7000e02790333330cccccc00c6199999880fd330030fa0001c8001d0098e7000e02010331e30ccc7cc00c60f9998f00fd330030fa0001c8000c0098 -e700010186e80001c8000b0098e6000078e80001c800070098cc0001c800070098cc0001c800070098cc0001c8000b0098e6000078e80001c800280098fd0006f800c000600180fd000060f70005018603000006fe000006fe00020c00c0f60001c8001f0098fd0006cc00c000600180fd000060f70002020103fb000006f0 -0001c8002c0098fd000dccccc78063e3c78dbe3678f1e360f90010020103e1e1c63801b6663c00ff8ccccf80f70001c8002a0098fd00fecc0ac063318cce3338cc633380f9000b0400833233266401c6666600fdcc00c0f70001c8002a0098fd000cf8ccccc063318ccc3330cc6333f8000b04008331f38660f98666667cfd -cc00c0f70001c8002b0098fd000ccccccfc063318fcc3330fc63f3f800100400833331c6600186667e00cccc78ccc0f70001c800290098fd00fecc090063318c0c3330c06303f8000b0400833330e6600186666000fdcc00c0f70001c800290098fd00fecc094063318c4c3330c46313f8000b020103333266640186666200 -fdcc00c0f70001c8002a0098fd000ccc7cc7806330c78c3e307831e3f8000b020103e1f1c6380183e63c00fdcc00c0f70001c800100098f5000030f400010186e80001c8000f0098f5000030f3000078e80001c800070098cc0001c800070098cc0001c800070098cc0001c8000f0098fa0000f0ee000078e80001c8001e00 -98fb0001030cef000e018600003003000001800000030030f50001c800160098fb00010402ef00010201fb00010180f00001c800220098fb0004040207c3c0f2000f020103fe33e3006d998f003fe33333e0f60001c800210098fb00040801066660f20002040083fe33040071999980fd330030f60001c800210098fb0004 -0801066660f20002040083fe33043e6199999ffd330030f60001c800220098fb00040801066660f20002040083fe33090061999f8033331e3330f60001c800210098fb00040801066660f20002040083fe33040061999800fd330030f60001c800210098fb00040402066660f20002020103fe33040061999880fd330030f6 -0001c800210098fb000404020663c0f20002020103fe33040060f98f00fd330030f60001c800110098fb0001030cef00010186e80001c8000f0098fa0000f0ee000078e80001c800070098cc0001c800070098cc0001c800070098cc0001c8000b0098e6000078e80001c800180098e700010186fb0003c0000060fe0001c0 -0cf70001c800130098e700010201fb0003c0000060f20001c8001c0098e70011027903e1e36ff878c01b6663c00ff8ccccf8f80001c8001a0098e7000d04fc8333338ccc8cc01c6666600cfdccf80001c800190098e7000c04fc8333330ccc7ccf98666667fcccf80001c8001c0098e7001104fc8333330cccccc0186667e0 -0cccc78cccf80001c8001a0098e7000d04fc8333330cccccc0186666000cfdccf80001c8001a0098e7000d02790333330cccccc0186666200cfdccf80001c8001a0098e7000d02010331e30ccc7cc0183e63c00cfdccf80001c8000c0098e700010186e80001c8000b0098e6000078e80001c800070098cc0001c800070098 -cc0001c800070098cc0001c800070098cc0001c800070098cc0001c800070098cc0001c800070098cc0001c800070098cc0001c800070098cc0001c800070098cc0001c800070098cc0001c800070098cc0001c800070098cc0001c8000b0098e6000078e80001c8002a0098fd0007f800030000018006fd00010180f90005 -018603000006fd000006fd00020c00c0f80001c800210098fd0007cc00030000018006fd00010180f90002020103fa000006f10001c800300098fd000fccd9e31e1f018f8f1e36f8d9e3c78d80fb0012020103e1e1c63801f1b3c63c3e00ff8ccccf80f90001c8002e0098fd0001cce3fe3309018cc63338cce3318ccefa00 -09040083323326640199c6fe660000fdcc00c0f90001c8002e0098fd0001f8c3fe3309018cc63330ccc3318cccfa000904008331f38660f99986fe66007cfdcc00c0f90001c8002f0098fd0001c0c3fe3309018cc63f30ccc3f18fccfa00090400833331c660019986fe660500cccc78ccc0f90001c8002e0098fd0001c0c3 -fe3309018cc63030ccc3018c0cfa00090400833330e660019986fe660000fdcc00c0f90001c8002e0098fd0001c0c3fe3309018cc63130ccc3118c4cfa000902010333326664019986fe660000fdcc00c0f90001c8002e0098fd000ec0c1e31e1f018cc31e30f8c1e0c78cfa000d020103e1f1c63801f183c63c3e00fdcc00 -c0f90001c8001d0098f9000003fc0000c0f600010186fc00010180fe000006f30001c8001c0098f9000023fc0000c0f5000078fc00010180fe000046f30001c8000f0098f900001ee400003cf30001c800070098cc0001c800070098cc0001c8000f0098fa0000f0ee000078e80001c800200098fb0001030cef0005018600 -003003fe00010180fe0002030030f70001c800160098fb00010402ef00010201fa00010180f10001c800240098fb0004040207c3c0f20011020103fe33e3007c6cf18f0f803fe33333e0f80001c800230098fb00040801066660f20002040083fe3302006671fe990080fd330030f80001c800230098fb00040801066660f2 -0002040083fe33023e6661fe99009ffd330030f80001c800240098fb00040801066660f20002040083fe3302006661fe99058033331e3330f80001c800230098fb00040801066660f20002040083fe3302006661fe990080fd330030f80001c800230098fb00040402066660f20002020103fe3302006661fe990080fd3300 -30f80001c800230098fb000404020663c0f20002020103fe3306007c60f18f0f80fd330030f80001c8001a0098fb0001030cef00010186fc000060fe00010180f30001c800180098fa0000f0ee000078fc000060fe00011180f30001c8000b0098dc00000ff20001c800070098cc0001c800070098cc0001c8000b0098e600 -0078e80001c800190098e700010186fb0000c0fe000060fd0001c00cf90001c800140098e700010201fb0000c0fe000060f30001c8001e0098e70013027903e1e36ff878c01f1b3c63c3e00ff8ccccf8fa0001c8001c0098e7000a04fc8333338ccc8cc0199cfe6601600cfdccfa0001c8001b0098e7000a04fc8333330ccc -7ccf9998fe660067fcccfa0001c8001e0098e7000a04fc8333330cccccc01998fe6605600cccc78cccfa0001c8001c0098e7000a04fc8333330cccccc01998fe6601600cfdccfa0001c8001c0098e7000a02790333330cccccc01998fe6601600cfdccfa0001c8001c0098e7000f02010331e30ccc7cc01f183c63c3e00cfd -ccfa0001c800140098e700010186fa000018fd000060f50001c800140098e6000078fa000018fe00010460f50001c8000c0098da000103c0f50001c800070098cc0001c800070098cc0001c800070098cc0001c800070098cc0001c800070098cc0001c800070098cc0001c800070098cc0001c800070098cc0001c8000700 -98cc0001c800070098cc0001c800070098cc0001c800070098cc0001c8000b0098e6000078e80001c800300098fd000078fe0007c0001800c03000c0fd000030fc0005018603000006fc000903000060030000030030fb0001c800280098fd0000c4fe0000c0fe0003c03000c0fd000030fc0002020103f9000003fe000003 -f60001c800360098fd0012c078f871e6cf19f1e031f1e3c6df1b3c78f1b0fe0015020103e1e1c63800e1e3e1c79b3c67c7803fe33333e0fc0001c800350098fd0012c0ccccc8c7119998c03198c667199c663199c0fe00100400833233266401933333231c46666300fd330030fc0001c800350098fd0012c0cccce0c60f99 -98c03198c666199866319980fe001004008331f38660f983333383183e66631ffd330030fc0001c800360098fd0012c0cccc70c6199998c03198c7e619987e31f980fe00150400833331c66001833331c3186666630033331e3330fc0001c800350098fd0012c0cccc38c6199998c03198c606199860318180fe0010040083 -3330e66001833330e31866666300fd330030fc0001c800350098fd0012c4cccc98c6199998c03198c626199862318980fe00100201033332666401933332631866666300fd330030fc0001c800350098fd00127878cc70660f999860319863c61f183c18f180fe0010020103e1f1c63800e1e331c1983e666180fd330030fc -0001c800100098f0000018f900010186e80001c8000f0098f0000018f8000078e80001c800070098cc0001c800070098cc0001c800070098cc0001c8000f0098fa0000f0ee000078e80001c800210098fb0001030cef0005018600003003fc0008c0001800c00000c00cfa0001c800190098fb00010402ef00010201f80000 -c0fe0000c0f60001c800270098fb0004040207c3c0f20014020103fe33e3003878f871e6cf19f1e00ff8ccccf8fb0001c800250098fb00040801066660f20002040083fe330a0064ccccc8c7119998c00cfdccfb0001c800240098fb00040801066660f20002040083fe33093e60cccce0c60f9998c7fcccfb0001c8002700 -98fb00040801066660f20002040083fe330e0060cccc70c6199998c00cccc78cccfb0001c800250098fb00040801066660f20002040083fe330a0060cccc38c6199998c00cfdccfb0001c800250098fb00040402066660f20002020103fe330a0064cccc98c6199998c00cfdccfb0001c800250098fb000404020663c0f200 -02020103fe330a003878cc70660f9998600cfdccfb0001c800110098fb0001030cef00010186e80001c8000f0098fa0000f0ee000078e80001c800070098cc0001c800070098cc0001c800070098cc0001c8000b0098e6000078e80001c8001c0098e700010186fb0000c0fd0008300006003000003003fc0001c800180098 -e700010201fb0000c0fd000030fe000030f80001c800210098e70016027903e1e36ff878c00e1e3e1c79b3c67c7803fe33333efd0001c8001f0098e7001204fc8333338ccc8cc01933333231c466663003fd33fd0001c8001f0098e7001204fc8333330ccc7ccf983333383183e66631f3fd33fd0001c800210098e7001604 -fc8333330cccccc01833331c3186666630033331e333fd0001c8001f0098e7001204fc8333330cccccc01833330e318666663003fd33fd0001c8001f0098e7001202790333330cccccc019333326318666663003fd33fd0001c8001f0098e7001202010331e30ccc7cc00e1e331c1983e6661803fd33fd0001c8000c0098e7 -00010186e80001c8000b0098e6000078e80001c800070098cc0001c800070098cc0001c800070098cc0001c800070098cc0001c800070098cc0001c800070098cc0001c800070098cc0001c800070098cc0001c800070098cc0001c800070098cc0001c800070098cc0001c800070098cc0001c800070098cc0001c8000700 -98cc0001c800070098cc0001c800070098cc0001c800070098cc0001c800070098cc0001c800070098cc0001c800070098cc0001c800070098cc0001c800070098cc0001c800130098e3000001f7ff02c0007ffaff030000c800130098e3000007f7ff02f00180fa0003c000c800120098e300000ff7ff01f803f900036000 -c800120098e300001ff700017c02f900032000c800130098e300011c7ff8ff011c04f900031000c800130098e300013d80f80001de04f900031000c800120098e3000039f700014e04f900031000c8001a08980003c000000c0003eb00003af700012e04f900031000c8001f089800062000000c0003fa00010ffff400003a -f700012e04f900031000c800311198000606cf0f1e3c031ff0f0f8f180000801f700056000003a0070fe00000ffd00042e04000780fe000518001000c80032119800060719918c6603199919999980000801f700056000003a00c8fe00011980fe00042e04000c40fe000518001000c800392698000606198f8c66031998f9 -99980000080103878ff8f8d9e1c38783e000003a00c0f198f0198efe000d2e04000c078f870f18001000c8003909980006061f998c7e0319fe9906f800000801064cfecc0fe333264ce66000003a00e11999981999fe000d2e04000c08cccc9998001000c80039099800060618198c600319fe99068000000801060cfecc0f -c333870ce66000003a0070f999981f9cfe000d2e04000c07cccc1998001000c80039099800062618998c620319fe99068980000801060cfecc0fc3f1c38fe66000003a00399999f8198efe000d2e04000c0ccccc1f98001000c8003913980003c60f0f863c031998f8f8f180000801060cfecc0fc300e1cc066000003a0019 -9999801987fe000d2e04000c0ccccc1818001000c800310098f6000018fe00030801064cfecc20c31264cc666000003a009999918819930333002e04000c4ccccc9898001000c800320098f700010118fe0027080103878cccf8c1e1c38783e000003a0070f9e0f0198e0333002e04000787ccc70f18001000c8001f0098f6 -0000f0fe00010801fd0000c0f900003af700012e04f900031000c8001b0098f200010ffffd0000c0f900003af700012e04f900031000c800120098e300003af700012e04f900031000c800120098e3000039f700014e04f900031000c800130098e300013d80f80001de04f900031000c800130098e300011c7ff8ff011c02 -f900032000c800120098e300001ff700017c03f900036000c800130098e300000ff7ff02f80180fa0003c000c800130098e3000007f7ff02f0007ffaff030000c8000f0098e3000001f7ff00c0f60001c800070098cc0001c800070098cc0001c800070098cc0001c800070098cc0001c800070098cc0001c800070098cc00 -01c800070098cc0001c800070098cc0001c800070098cc0001c800070098cc0001c800070098cc0001c800070098cc0001c800070098cc0001c800070098cc0001c80007009fccff01c80007009fccff01c800070080cc00010800070080cc0001080005cbff01f80000ff0000}} -\par \pard \s20\qc\fi200\ri-40\sa120\keep\keepn\widctlpar\tqr\tx1600 Fig. 1: Creating an image file. -\par \pard \s20\li360\sa120\widctlpar If you should terminate the configuration dialog by clicking on {\i Cancel}, no image file will be created at that point. Instead, you will find a special menu entry in the BABYLON main menu called {\i Configure Image} -, which enables you to restart the configuration dialog. The menu entry {\i Load-KB} - is still deactivated, with the result that no expert system can be loaded. But you can perform modifications of your Lisp environment, which you can store in your image data file. In order to store the new Lisp environment as an image file you will have -to resume the configuration dialog. -\par After storing the Babylon image MCL will quit and you find an application icon named Babylon in the Babylon folder. You can now start Babylon by double-clicking this icon. -\par \pard\plain \s2\li180\sb120\sa120\keepn\widctlpar\brdrb\brdrs\brdrw15 \b\f8\fs36\lang1031 4.\tab Menus -\par \pard\plain \s20\li360\sa120\widctlpar \f8\lang1031 The menu bar of Macintosh Common Lisp is extended by BABYLON menus. At present, BABYLON provides five menus. A main menu, which offers general commands to operate expert systems (such as {\i Start}, {\i -Kill}, ..) and four menus that provide interpreter-specific operations. One such menu is assigned to each of the four interpreters ({\i Frame}, {\i Rule}, {\i Prolog}, {\i Consat} -). Which of the operations can be selected in these menus depends on the interpreter version. Those operations appearing in a grey tone cannot be selected. The operation {\i Explore Rule Terms} from the {\i rule} - menu, for example, is only provided by the normal rule interpreter. -\par \pard \s20\qc\li360\sa120\widctlpar {\fs20 {\pict\macpict\picw527\pich24\picwgoal10540\pichgoal480 \picscalex83\picscaley83 -035a000000000018020f001102ff0c00fffe00000048000000480000000000000018020f000000000001000a000000000018020f00998042000000000018020f000000000000000000480000004800000000000100010001000000000032500c0000000000005d0d888800010000ffffffffffff0001000000000000000000 -000018020f000000000018020f0040000a000000000018020f04c0ff00fe04c0ff00fe060080c100000207018030c200000207018060c2000002401b80400007ccc000007c0cc60001f000030003f0000600000cccc000c0fd00040f800c000cfe00010540fc00080a8008000002800008fe00010280fe000108023f1b83b8 -000600c00000600c0600018000030000c0000600000ccc0000c0fd00040cc00c000cfe000002fb0008044004000004400010fe00010440fe00010402434187fc00060cc78000607ccf00018331e30000c3c3c638000ccccf87c78ccc70000cc78f8ccc78f80004051415a0a000088888280002228a08a0a80008028a820a0a -023e1787f000060cccc00060ccc600018332330000c6666664000cfbcc03c8000cc8fccc0800020a222211100004fe4402000445fe11081000040444441104023e1787f000078cccc00078ccc60001e331f30000c6666670000cfbcc03e0000f87fccc0800050415118888000afe880300028208fe8807000808888a0a8802 -3d1787fc00060ccfc00060ccc600018333330000c6666638000cfbcc0270000cfbcc0e000208222211500004444454000404fe11081000040444451104023d1787fc00060ccc000060ccc600018333330000c666661c000cfbcc0238000cfbcc0f00040411118880000888888000020208fe880700080888828888023f1883 -f800060ccc400060ccc600018323330000c666664c000cc8fdcc03c898000cfbcc08000208222211000004fe4402000404fe1108100004444441110402434181b000060cc780007c7cc30001f3c1f30000c3c3c638000ff0ccc7c78ff070000f87cf87cc78cc000404151188a000088288280002020a08a0a800028288820a -82020e0080de0000c0ed000010fa0000020f0080df000108c0ed000008fa0000020f0080df00010780ed000050fa000002060080c1000002060080c1000002060080c1000002060080c1000002060080c100000204c0ff00fe04c0ff00fe00ff0000}} -\par \pard \s20\qc\fi200\ri-40\sa120\keep\keepn\widctlpar\tqr\tx1600 Fig. 2: The menu bar on the MAC II. -\par \pard \s20\qc\li360\sa120\widctlpar {\fs20 {\pict\macpict\picw437\pich51\picwgoal8740\pichgoal1020 -052600000000003301b5001102ff0c00fffe0000004800000048000000000000003301b5000000000001000a00000000003301b50099803800000000003301b50000000000000000004800000048000000000001000100010000000000324fc40000000000005d61000000010000ffffffffffff0001000000000000000000 -00003301b500000000003301b50040000a00000000003301b505cbff01f800070080cc0001080008018060cd00010800080180c0cd0001080036108080001f33000001f03318000666600060fd000407c0060006fe000102a0fc00080a8008000002800008fe00010280fe0002080800351087700018030000018030180006 -66000060fd00040660060006fe000001fb0008044004000004400010fe00010440fe000204080039378ff80018331e000181f33c00066667c3e3c66638000663c7c6663c7c0002028a0aa0a000088888280002228a08a0a80008028a820a0a0800340c8fe00018333300018333180006fb660364000664fc6602000105fe11 -02100004fe4402000445fe110910000404444411040800350c8fe0001e33330001e333180006fb6604700007c3e6fd66030002820afe8801000afe880300028208fe8808000808888a0a880800330c8ff80018333f00018333180006fb6602380006fb6602000104fe1108500004444454000404fe11091000040444451104 -0800330c8ff80018333000018333180006fb66021c0006fb660f00020208888880000888888000020208fe8808000808888288880800350d87f0001833310001833318000664fd6603644c0006fb6602000104fe1102000004fe4402000404fe110910000444444111040800393783600018331e0001f1f30c0007f86663e3 -c7f8380007c3e7c3e63c660002020a8888a000088288280002020a08a0a800028288820a8208000f0080e9000060ed000010fa00010800100080ea00010460ed000008fa00010800100080ea000103c0ed000050fa00010800070080cc00010800070080cc0001080009f6ff00fbd7ff01f80002c90002c90002c90002c900 -02c90002c90002c90002c90002c90002c90002c90002c9000afa000003daff00c0f9000afa000002da000040f9000afa000002da000040f9000bfa00010203db000040f9000bfa00010206db000040f9002cfa001b020400007ccc000007c0cc60001f000030003f000060000066660006fc00077c00600060000040f9002c -fa001b023b8000600c00000600c0600018000030000c000060000066600006fc00076600600060000040f9002efa0028027fc00060cc78000607ccf00018331e30000c3c3c63800066667c3e3c66638000663c7c6663c7c040f90029fa0012027f000060cccc00060ccc600018332330000cfe66014000fa660340006646fd -66016040f9002afa0017027f000078cccc00078ccc60001e331f30000c6666670000fb66046700007c3efd66016040f90028fa0017027fc00060ccfc00060ccc600018333330000c6666638000fb6602638000fb66016040f90028fa0017027fc00060ccc000060ccc600018333330000c666661c000fb660261c000fb6601 -6040f9002afa0019023f800060ccc400060ccc600018323330000c666664c0006646fd660244c000fb66016040f9002efa0028021b000060cc780007c7cc30001f3c1f30000c3c3c6380007f86663e3c7f8380007c3e7c3e63c66040f9000efa000002de000006fe000040f9000efa000002de000046fe000040f9000efa00 -0002de00003cfe000040f9000afa000002da000040f9000afa000002da000040f9000afa000003daff00c0f9000000ff0000}} -\par \pard \s20\qc\fi200\ri-40\sa120\keep\keepn\widctlpar\tqr\tx1600 Fig. 3: Alternating menu bars on the MAC SE. -\par \pard \s20\li360\sa120\widctlpar -These menus and the five Macintosh Common Lisp menus combine to provide a menu bar consisting of ten entries. The screen of the Macintosh II accomodates the whole menu bar (cf. Figure 2), while the smaller screen of the Macintosh SE cannot contain all men -us at the same time. For this reason, the Macintosh SE provides two menu bars (cf. Figure 3), which can be switched by using the Command-T key. This toggling operation is a menu entry in the BABYLON main menu. The first menu bar contains the {\i File}, { -\i Edit} and {\i Windows} menu of Macintosh Common Lisp and the five BABYLON menus, while the second one contains all Macintosh Common Lisp menus and the BABYLON main menu. -\par After starting BABYLON, and before loading an expert system, only the main menu of the five BABYLON menus is activated. The four interpreter-specific menus are de -activated, which is indicated by the grey color of the menu name. These menus are only activated, when an expert system with corresponding interpreters is loaded. You should also note that the name of the BABYLON main menu, which is initially {\i Babylon} -, will be changed when loading an expert system; it will then be that of the expert system. -\par The following subsections will explain the BABYLON menus and their operations. -\par \pard\plain \s3\li360\sb120\sa120\keepn\widctlpar \b\f8\fs28\lang1031 4.1\tab The BABYLON Main Menu -\par \pard\plain \s20\li360\sa120\keepn\widctlpar \f8\lang1031 The BABYLON main menu basically contains general commands to operate expert systems. -\par -\par \pard \s20\qc\li360\sa120\widctlpar {\fs20 {\pict\macpict\picw169\pich189\picwgoal3380\pichgoal3780 -09500000000000bd00a9001102ff0c00fffe000000480000004800000000000000bd00a9000000000001000a0000000000bd00a9009980160000000000bd00a90000000000000000004800000048000000000001000100010000000000324f700000000000005e08010000010000ffffffffffff0001000000000000000000 -0000bd00a90000000000bd00a90040000a0000000000bd00a906f8ff0080f50006f8ff0080f50006f8ff0080f50006f8ff0080f50006f8ff0080f50006f8ff0080f50006f8ff0080f5000d05ff81ffcfffc7feff0080f5000d05ff9cffcfffe7feff0080f5000d09ff9ce1c1cce78707ff80f5000d01ff81fecc04e73313ff -80f5000d09ff9ce0cccce73333ff80f5000d01ff9cfecc04e73333ff80f5000d01ff9cfecc04e73333ff80f5000d01ff9cfecc04e73333ff80f5000d09ff81e0c1e0e78733ff80f5000afdff00fcfdff0080f5000afdff00ccfdff0080f5000afdff00e1fdff0080f50006f8ff0080f50006f8ff0080f50006f8ff0080f500 -06f8ff0080f50006f8ff0080f50004ecff0080060080ed000080060080ed000080060080ed000080060080ed000080060080ed000080060080ed000080100680003e18000060f7000401ce3e0080100680006318000060f70004037a63008010068000603c3c7ef0f70004037a600080100680006018667060f7000401fe60 -00800f0680003e183e6060f60003783e0080100680000318666060f7000401fe030080100680000318666060f70004037a030080100680006318666060f70004037a630080100680003e0e3e6038f7000401ce3e0080060080ed000080060080ed000080060080ed000080060080ed000080060080ed000080060080ed0000 -80110280007cfd00013180f9000401ce7c00801102800066fd00010180f90004037a6600801302800063fe1e033f71f0f0fa0004037a6300801302800063fe330338319998fa000401fe630080120380006333fe3002319998f900037863008013098000633f1e30303199f8fa000401fe6300801309800063300330303199 -80fa0004037a6300801302800066fe330330319998fa0004037a660080130280007cfe1e033031f0f0fa000401ce7c0080060080ed000080060080ed000080060080ed000080060080ed000080060080ed000080060080ed000080060080ed00008008028000ffef0000800802800018ef0000800b038000183ffe3cf30000 -800b0380001838fe66f30000800c06800018303e6066f30000800c068000183066607ef30000800c0680001830666060f30000800b0380001830fe66f30000800c06800018303e3c3cf3000080060080ed000080060080ed000080060080ed000080060080ed000080060080ed000080060080ed000080060080ed00008010 -0280007efe000018f7000401ce7e00801002800063fe000018f70004037a6300801002800063fe1e003cf70004037a6300801002800063fe330018f7000401fe6300800f0680007e33303318f60003787e008010068000783f1e3f18f7000401fe780080100680006c30033018f70004037a6c00801002800066fe330018f7 -0004037a6600801002800063fe1e000ef7000401ce630080060080ed000080060080ed000080060080ed000080060080ed000080060080ed000080060080ed000080060080ed0000800b0580006318e380f20000800b05800066006180f20000800b0580006c386180f20000800b05800078186180f20000800b0580007018 -6180f20000800b05800078186180f20000800b0580006c186180f20000800b05800066186180f20000800b05800063186180f2000080060080ed000080060080ed000080060080ed000080060080ed000080060080ed000080060080ed000080060080ed000080060080ed00008004ecff0080060080ed000080060080ed00 -0080060080ed000080060080ed000080060080ed000080060080ed0000800e0880006000000600633ff50000800f0980006000000600663180f60000800f098000603c3c3e006c3180f60000800e02800060fe660200783ff50000800f09800060663e667e703180f60000800f02800060fe660300783180f60000800f0280 -0060fe6603006c3180f60000800f02800060fe660300663180f60000800e0880007e3c3e3e00633ff5000080060080ed000080060080ed000080060080ed000080060080ed000080060080ed000080060080ed000080060080ed000080100a80003e0038000060018cfcf7000080100a80006300180000600198c6f7000080 -100a8000601e187878f001b0c6f7000080100a8000603318cccc6001e0fcf7000080100a80003e3318ccc061f9c0c6f7000080100a8000033f18fcc06001e0c6f7000080100a8000033018c0c06001b0c6f7000080100a8000633318cccc600198c6f7000080100a80003e1e18787838018cfcf7000080060080ed00008006 -0080ed000080060080ed000080060080ed000080060080ed00008004ecff0080060080ed000080060080ed000080060080ed000080060080ed000080060080ed000080060080ed000080110580007e000070fe00020f8006f80000801105800060000030fe000218c006f8000080120c800060667c30f1f9e018cf8f0ff900 -0080130d80006066663199c33018ccc61980fa000080120c80007c3c663199833018ccc618f9000080120c8000601866319983f018ccc60ff9000080130d8000603c663199830018ccc60180fa000080130d80006066663199833018ccc61980fa000080140e80007e667c30f181e00f8f838f1998fb0000800e0080fe0000 -60fc00000cf70000800e0080fe000060fc00000cf7000080060080ed000080060080ed000080060080ed000080060080ed000080060080ed000080160d80007f8000001c00061800000180fd0003e77f8080170280000cfe00070c00073800000180fe000401bd0c0080171580000c0f0f8f8c1e07f8f1f199f0f1f80001bd -0c0080170b80000c1999998c3306d999d9fe9906c00000ff0c0080170980000c1999998c330619fe990898f98000003c0c0080160a80000c1999998c3f0619f9fd9906800000ff0c0080160a80000c1999998c30061981fd9906800001bd0c0080171580000c1999998c3306199999b99999800001bd0c0080171580000c0f -0f8f8c1e0618f198f9f0f9800000e70c00800c0080fe0002018180f30000800c0080fe0002199980f30000800b0080fe00010f0ff2000080060080ed000080060080ed000080060080ed000080060080ed000080060080ed00008004ecff008000ff0000}} -\par \pard \s20\qc\fi200\ri-40\sa120\keep\keepn\widctlpar\tqr\tx1600 Fig. 4: The BABYLON main menu. -\par \pard \s20\li360\sa120\widctlpar \page Start -\par \pard \s20\fi-280\li280\sa120\widctlpar \tab -serves to start the current expert system. This is a confirmation menu that informs the programmer about the setting of the trace mode. If this confirmation menu is positively acknowledged, the expert system begins to interpret its instruction part. -\par \pard \s20\li360\sa120\widctlpar Describe -\par \pard \s20\fi-280\li280\sa120\widctlpar \tab yields some statistical information about the current expert system such as the number of frames, the number of instances and the number of rule sets, etc. -\par -\par \pard \s20\qc\li360\sa120\widctlpar {\fs20 {\pict\macpict\picw412\pich214\picwgoal8240\pichgoal4280 -11060000000000d6019c001102ff0c00fffe000000480000004800000000000000d6019c000000000001000a0000000000d6019c009980340000000000d6019c00000000000000000048000000480000000000010001000100000000003250e80000000000005ea0000000010000ffffffffffff0001000000000000000000 -0000d6019c0000000000d6019c0040000a0000000000d6019c06007fcfff00e0060040cf000030060040cf000030060040cf00003013025fbffbefff00f8fa000001efff03fdffdfb01202402008ee00030c180180eb00030104403017025fa00befff04f80c000180fe000001efff03fd045fb01602402008ee00070c18e3 -c78f878d80ef00030104403017025fa00befff08f80c19918cccccce01efff03fd045fb01402402008ee00030c19c18cfeccee00030104403017025fa00befff08f80c18e18fcccfcc01efff03fdfc5fb01502402008ee00060c18718c0ccc0cee00030100403017025fa00befff08f80c19318c4ccc4c01efff03fd005fb0 -1502402008ee00060f98e0c78cc78cee00030100403013025fbffbefff00f8fa000001efff03fdffdfb00600c0cf000030060040cf000030060040cf00003006007fcfff00f0080040d10002100030080040d10002102030080040d10002105030080040d10002108830080040d10002110430080040d10002120230080040 -d10002140130080040d100021f07b0080040d10002110430080040d10002110430080040d10002110430080040d1000211fc30080040d100021000302a1440820820820070800800000602200000800200003cfe000afbc73ef887002082082080f30002100030280042fdaa0f80888008000008024000008002000022fe00 -052228a0808880fdaa00a0f300021ffff02a2241c71c71c70081c79c70071c028b1ca8871e79c02279e7002228a080880071c71c71c0f300021888b0280042fdaa018070fe88130888030ca2a888a28a203c8a088023cfbcf08800fdaa00a0f300021222302a22408208208200088888f808880288a2a88fa28be02289cf80 -2228a08088002082082080f300021888b0230040fc00178889888008880248a2a888228a00229828002228a0808880ee0002122230220040fc001670668678070802289c50879e79e03c6bc7802228a08087ed00021888b00c0040f0000008e300021222300c0040f0000070e300021888b0080040d10002122230080040d1 -00021888b0080040d10002122230080040d100021888b0080040d10002122230080040d100021888b0080040d10002122230080040d100021888b0080040d10002122230080040d100021888b0080040d10002122230080040d100021888b0080040d1000212223019044000220008fe00050603ef1c8be7f200001cee0002 -1888b01a044000320008fe0006080208a2da0880f3000022ee00021222301a0e40002a8bcf1cb0071c0208a2aa0808f3000002ee00021888b0190d43e0268aa8a2c8088803cf3e8bc7f200000cee00021222301a0e4000228aa8be8008880208a28a0080f3000002ee00021888b01a0e4000229aa8a08008880208a28a0880 -f3000022ee00021222301a0e4000226aaf1e8007080208a28be708f300001cee00021888b0080040d10002122230080040d100021888b0080040d10002122230080040d100021888b01c044000220008fe00080600889cf9c89cf9c0f500003eee00021222301c044000320008fe000808008ca2222ca28220f5000020ee00 -021888b01c1040002a8bcf1cb0071c008aa0222aa08202f500003cee00021222301c1043e0268aa8a2c8088800899c23e9a0f1c0f5000002ee00021888b01c104000228aa8be8008880088822228a08020f5000002ee00021222301c104000229aa8a08008880088a22228a28220f5000022ee00021888b01c104000226aaf -1e80070800889c22289cf9c2f500001cee0002122230080040d100021888b0080040d10002122230080040d100021888b0080040d100021222301c044000220008fe00080603c8a0f8073ef9c0f500001cee00021888b01c044000320008fe0008080228a08008a02220f5000022ee00021222301c1040002a8bcf1cb0071c -0228a08008202202f5000002ee00021888b01c1043e0268aa8a2c8088803c8a0f0073c21c0f5000004ee00021222301c104000228aa8be8008880228a08000a02020f5000008ee00021888b01c104000229aa8a08008880228a08008a02220f5000010ee00021222301c104000226aaf1e80070802273ef8073e21c2f50000 -3eee00021888b0080040d10002122230080040d100021888b0080040d10002122230080040d100021888b01f0640000002200080fe0009603c8a0f9c0080000002fe000008e800021222301e0640000003200080fe000480228a0822fd000002fe000008e800021888b01f1740000002a8bcf1cb0071c0228a0820008b00b2 -221c01e71ce800021222301f1740003e0268aa8a2c8088803c8a0f1c008c80ca2222020888e800021888b01f174000000228aa8be8008880228a080200888082223e01cf88e800021222301f174000000229aa8a08008880228a0822008880826220002808e800021888b01f174000000226aaf1e80070802273ef9c008880 -81a21e03c786e80002122230080040d100021888b0080040d10002122230080040d100021888b0080040d100021222301e0040fe000e022223e21c808fbe03efa201c722f0f700001cee00021888b01e0040fe000e02322082228080a00202220228b288f7000022ee00021222301e0040fe000e822a20822280812003c222 -0020aa88f7000002ee00021888b01e0040fe000e022620823e80823cf8223ef8c12688f7000004ee00021222301e0040fe000e022220822280842000222200222288f7000008ee00021888b01e0040fe000e022220822280882002222202242288f7000010ee00021222301e0040fe000e8222208222f88fbe01c22201cfa2 -f0f700003eee00021888b0080040d10002122230080040d100021888b0080040d10002122230080040d100021888b01f0640000002200080fe0009603c8a0f9c0080000002fe000008e800021222301e0640000003200080fe000480228a0822fd000002fe000008e800021888b01f1740000002a8bcf1cb0071c0228a0820 -008b00b2221c01e71ce800021222301f1740003e0268aa8a2c8088803c8a0f1c008c80ca2222020888e800021888b01f174000000228aa8be8008880228a080200888082223e01cf88e800021222301f174000000229aa8a08008880228a0822008880826220002808e800021888b01f174000000226aaf1e80070802273ef -9c00888081a21e03c786e80002122230080040d100021888b0080040d10002122230080040d100021888b0080040d100021222301c0040fe000c071c8bef1c800fbe88071c8bc0f500001cee00021888b01c0040fe000c08a2c888a28008088808a2ca20f5000022ee00021222301c0040fe000c8822a888a2800f08880082 -aa20f5000022ee00021888b01c0040fe000c0822988f2283e088fbe3049a20f500001cee00021222301c0040fe000c08228888a28000888800888a20f5000022ee00021888b01c0040fe000c08a28888a28008888808908a20f5000022ee00021222301c0040fe000c871c88889cf8070888073e8bc0f500001cee00021888 -b0080040d10002122230080040d100021888b0080040d10002122230080040d100021888b01e0540003e008008fe000080fe0004603c8a0f9cf600010470ef00021222301e05400008008008fe000080fe000480228a0822f600010c88ef00021888b01f1240000871c78802c8bcf1cb0071c0228a082020f700010488ef00 -021222301e0243e008fe880b0328aa8a2c8088803c8a0f1cf600010488ef00021888b01e02400008fe880b0228aa8be8008880228a0802f600010488ef00021222301e114000088889880229aa8a08008880228a0822f600010488ef00021888b01f124000087066880226aaf1e80070802273ef9c20f700010470ef000212 -2230080040d100021888b0080040d10002122230080040d100021888b0080040d1000212223025044000220008fe00110603cf08888f888be01c72273ef1c222f9c0fe00001cee00021888b025044000320008fe001108022888d882088a00228b28888a22322220fe000022ee0002122230251940002a8bcf1cb0071c0228 -88a882088a00208aa8088a222a2202fe000002ee00021888b0251943e0268aa8a2c8088803cf088882088bc0208a6708f3e22621c0fe000004ee000212223025194000228aa8be8008880208888882088a00208a20888a22222020fe000008ee00021888b025154000229aa8a08008880208888882085200228a28888afe22 -0020fe000010ee000212223025194000226aaf1e80070802088888820823e01c7227088a222221c2fe00003eee00021888b0080040d10002122230080040d100021888b0080040d10002122230080040d100021888b020044000220008fe000c0601c72273ef1c222f808bef9cf900001cee000212223020044000320008fe -000c080228b28888a2232200ca0222f9000022ee00021888b0211540002a8bcf1cb0071c0208aa8088a222a200aa022020fa000022ee0002122230201443e0268aa8a2c808880208a6708f3e2262009bc21cf9000022ee00021888b020144000228aa8be8008880208a20888a22222008a0202f9000022ee00021ffff02014 -4000229aa8a08008880228a28888a22222008a0222f9000022ee000218007021154000226aaf1e80070801c7227088a22222008be21c20fa00001cee0002180070080040d10002180070080040d10002180070080040d10002180070080040d1000218007021044000220008fe000d0603cf9cfbc21c23e722022fbe70fa00 -0004ee000218007020044000320008fe0002080228fd22062088b203280888fa00000cee0002180070221640002a8bcf1cb0071c0228202222202088aa02a8088080fb000004ee0002180070211543e0268aa8a2c8088803cf1c23c2202088a6026f0870fa000004ee000218007021154000228aa8be800888022802222220 -2088a202280808fa000004ee0002180070200a4000229aa8a08008880228fd22062088a202280888fa000004ee000218007022164000226aaf1e800708022f9c22221c208722022f887080fb000004ee0002180070080040d10002180070080040d100021ffff0080040d10002122230080040d100021888b01c0440002200 -08fe00080603cfa073e21c89c0f500003eee00021222301c04c000320008fe000808022820888222ca20f5000020ee00021888b01c1040002a8bcf1cb0071c022820888222aa02f500003cee00021222301c1043e0268aa8a2c8088803cf20f8822299c0f5000002ee00021888b01c104000228aa8be800888022820888222 -8820f5000002ee00021222301c104000229aa8a08008880228208882228a20f5000022ee00021888b01c104000226aaf1e800708022fbe88821c89c2f500001cee00021ffff0080040d10002100030080040d10002100030080040d1000211fc30080040d10002110430080040d10002110430080040d10002110430080040 -d100021f07b0080040d10002140130080040d10002120230080040d10002110430080040d10002108830080040d100021050300800c0d10002102030080040d1000210003006007fcfff00f00e044080ffffa2d7220428081000300c034180c000d588030c1000300e044280c000a2d72204280a13f8300c0344f8c000d588 -03f91208300e044808c000a2d722042880920fb00c035008c000d58803805208b00e046008c000a2d7220428803208b00c035008c000d58803805208b00e044808c000a2d72204288093f8b00c0344f8c000d58803f91080b00e044280c000a2d72204280a1080b00c034180c000d588030c1080b00e044080c000a2d72204 -280810ffb00c034000ffffd588030010003006007fcfff00f006003fcfff00f005cf0001100000ff0000}} -\par \pard \s20\qc\fi-708\li708\ri-40\sa120\keep\keepn\widctlpar\tqr\tx1600 Fig. 5: The information provided by {\i\caps Describe}. -\par \pard \s20\li360\sa120\widctlpar Trace -\par \pard \s20\fi-280\li280\sa120\widctlpar \tab activates or deactivates the system trace. When the menu entry is marked with a hook, then the system trace has been activated. -\par \pard \s20\li360\sa120\widctlpar Reset -\par \pard \s20\fi-280\li280\sa120\widctlpar \tab -restores the initial state of the current expert system. This means that the modifications brought about during the dialog session with the expert system are reset. Such modifications can refer to changes in the slot values of objects, new entries in the - free text data base etc. The resetting process is only started, when the user positively acknowledges a confirmation menu. -\par \pard \s20\li360\sa120\widctlpar Kill -\par \pard \s20\fi-280\li280\sa120\widctlpar \tab -presents to the user all the expert systems known to BABYLON. The expert system that has been selected will be deleted from the Lisp environment, as soon as the user confirms this command. If this was the current expert system, a different expert system -(if available) will be selected to be the current one. -\par \pard \s20\li360\sa120\widctlpar Load-KB -\par \pard \s20\fi-280\li280\sa120\widctlpar \tab presents to the user a menu containing files from the folder {\b babylon:samples:kbs}; these files store the external expert systems. Wh -en the user selects one expert system, it will be loaded, thus creating an instance of the referenced configuration and an editor window, which will display the source code of the expert system. Additionally, a trace window and an explanation window, whic -h will at first be covered by the editor window, are created. At the same time the newly loaded expert system will be the current one, thus changing the name of the main menu, which will now contain the name of the new expert system. -\par {\i Select-KB} -\par \tab presents to the user a menu containing all loaded expert systems. When he/she selects an expert system, this one will be the current expert system, which will be reflected in the changed name of the main menu. -\par -\par {\i Explore Opts}... -\par \tab yields a dialog box for the user to adjust a few parameters of the exploration options (cf. Figure 4). -\par \pard \s20\qc\li360\sa120\widctlpar {\fs20 {\pict\macpict\picw497\pich246\picwgoal9940\pichgoal4920 \picscalex88\picscaley89 -116a0000000000f601f1001102ff0c00fffe000000480000004800000000000000f601f100000000001e0001000a0000000000f601f1009980400000000000f601f10000000000000000004800000048000000000001000100010000000000b94f0000000000000007c0000000010000ffffffffffff000100000000000000 -00000000f601f10000000000f601f10040000a0000000000f601f105c3ff010000080080c50002010000080080c5000201000008009fc5ff02f9000008009fc5ff02f90000080098c50002190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000080098c5 -0002198000080098c50002190000080098c50002190000080098c50002190000100098f7000001eeff00e0e40002190000100098f7000001ee000020e40002190000100098f7000001ee000020e40002190000110098f700010120ef000020e40002190000110098f700010120ef000020e40002190000130098f700010120 -ef0002200fffe600021900001a0398000f80fa00010120ef0006200c0303800018ea0002190000190298000cf900010120ef0006200a0506400018ea00021900001e0c98000c1b3c7fc3c38c00000120ef000620090906078dbcea00021900001e0498000c1c46fe66044c00000120ef0006200891070cce18ea0002190000 -1e0798000f183e666667fe00010120ef0006200861038ccc18ea00021900001e0c98000c18666667e38000000120ef000620086101cccc18ea00021900001e0398000c18fe660501c000000120ef000620089100cccc18ea00021900001e0398000c18fe660524cc00000120ef000620090904cccc18ea00021900001e0c98 -000c183e6663c38c00000120ef0006200a0503878c0cea0002190000130098f700010120ef0002200c03e60002190000130098f700010120ef0002200fffe60002190000110098f700010120ef000020e40002190000110098f700010120ef000020e40002190000100098f7000001ee000020e40002190000100098f70000 -01ee000020e40002190000100098f7000001eeff00e0e40002190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000 -080098c50002190000080098c50002190000120098e200010ffff60001fff0f300021900001a02980007e400050c0303800018fa000380103c66f500021900001b0398000c80e500050a0506400018fa000380106666f50002190000200898000c199f0f1b38c0ea0005090906078dbcfa000380106666f500021900002008 -98000e1999999c64c0ea00050891070cce18fa000380106666f500021900001f079800071999999870e900050861038ccc18fa000380107e66f500021900001f0798000399999f9838e90005086101cccc18fa000380106666f500021900001f07980001999998181ce90005089100cccc18fa000380106666f50002190000 -2008980009999998984cc0ea0005090904cccc18fa000380106666f5000219000020089800070f9f0f1838c0ea00050a0503878c0cfa000380106666f50002190000160098fe000018e600010c03f600018010f30002190000160098fe000018e600010ffff60001fff0f30002190000080098c50002190000080098c50002 -190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000100098f7000001eeff00e0e40002190000100098f7000001ee -000020e40002190000100098f7000001ee000020e40002190000100098f7000001ee000020e40002190000100098f7000001ee000020e40002190000170098f7000001ee0002200ffff60001fff0f300021900002205980006000030fc000001ee0006200c0303800018fa000380103c66f500021900002205980006000030 -fc000001ee0006200a0506400018fa000380106666f50002190000240b9800063e1c78f1f0e1e1c601ee000620090906078dbcfa000380106666f50002190000240b980006333231199993332601ee0006200891070cce18fa000380106666f50002190000240b980006333830f99983338001ee0006200861038ccc18fa00 -0380107e66f50002190000240b980006331c31999983f1c001ee000620086101cccc18fa000380106666f50002190000240b980006330e3199998300e001ee000620089100cccc18fa000380106666f50002190000240b980006332631999993126601ee000620090904cccc18fa000380106666f50002190000240b980006 -331c18f998e1e1c601ee0006200a0503878c0cfa000380106666f50002190000170098f7000001ee0002200c03f600018010f30002190000170098f7000001ee0002200ffff60001fff0f30002190000100098f7000001ee000020e40002190000100098f7000001ee000020e40002190000100098f7000001ee000020e400 -02190000100098f7000001ee000020e40002190000100098f7000001eeff00e0e40002190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000080098c500021900 -00080098c50002190000080098c50002198000080098c50002190000120098e200010ffff60001fff0f300021900001d059800071800c0e700050c0303800018fa0003c0303c66f500021900001d0598000c9800c0e700050a0506400018fa0003a0506666f500021900001e0698000c18f1e38ce80005090906078dbcfa00 -0390906666f500021900001e0698000e1998c64ce800050891070cce18fa000389106666f500021900001d059800071998c7e700050861038ccc18fa000386107e66f500021900001e069800039998c380e80005086101cccc18fa000386106666f500021900001e069800019998c1c0e80005089100cccc18fa0003891066 -66f500021900001e069800099998c4cce80005090904cccc18fa000390906666f500021900001e0698000718f0638ce800050a0503878c0cfa0003a0506666f50002190000120098e200010c03f60001c030f30002190000120098e200010ffff60001fff0f30002190000080098c50002190000080098c500021900000800 -98c50002190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000100098f7000001eeff00e0e40002190000100098f7000001ee000020e400 -02190000100098f7000001ee000020e40002190000100098f7000001ee000020e40002190000100098f7000001ee000020e40002190000120098f7000001ee0002200fffe600021900001d0b98000f800c0007000c000001ee000620080103800018ea00021900001d0b98000cc00c000c800c000001ee0006200801064000 -18ea00021900001d0b98000ccccc780c0f1e38c001ee000620080106078dbcea00021900001d0298000cfecc050e198c64c001ee0006200801070cce18ea00021900001d0b98000f8ccccc07198c700001ee0006200801038ccc18ea00021900001d0b98000cccccfc039f8c380001ee000620080101cccc18ea0002190000 -1d0b98000cccccc001980c1c0001ee000620080100cccc18ea00021900001d0b98000cccccc409988c4cc001ee000620080104cccc18ea00021900001d0b98000cc7cc78070f0638c001ee000620080103878c0cea0002190000120098f7000001ee0002200801e60002190000120098f7000001ee0002200fffe600021900 -00100098f7000001ee000020e40002190000100098f7000001ee000020e40002190000100098f7000001ee000020e40002190000100098f7000001ee000020e40002190000100098f7000001eeff00e0e40002190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000080098c500 -02190000080098c50002190000080098c50002190000080098c50002190000100098f7000001eeff00e0e40002190000100098f7000001ee000020e40002190000100098f7000001ee000020e40002190000100098f7000001ee000020e40002190000100098f7000001ee000020e40002190000120098f7000001ee000220 -0fffe600021900001a0498000f800cfb000001ee000620080103800018ea00021900001a0498000cc00cfb000001ee000620080106400018ea00021900001d0798000ccccc787180fe000001ee000620080106078dbcea00021900001d0298000cfecc01c980fe000001ee0006200801070cce18ea00021900001c0698000f -8ccccce0fd000001ee0006200801038ccc18ea00021900001c0698000cccccfc70fd000001ee000620080101cccc18ea00021900001c0698000cccccc038fd000001ee000620080100cccc18ea00021900001d0798000cccccc49980fe000001ee000620080104cccc18ea00021900001d0798000cc7cc787180fe000001ee -000620080103878c0cea0002190000120098f7000001ee0002200801e60002190000120098f7000001ee0002200fffe60002190000100098f7000001ee000020e40002190000100098f7000001ee000020e40002190000100098f7000001ee000020e40002190000100098f7000001ee000020e40002190000100098f70000 -01eeff00e0e40002190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000080098c500021900 -00080098c50002190000080098c50002190000080098c50002190000080098c50002190000100098ed00007ffdff0080df0002190000100098ee000001fcff00e0df0002190000100098ee000003fcff00f0df0002190000110098ee000107c0fd0000f8df0002190000170098ee0001073ffdff0038fb000003fcffeb0002 -190000190098ee00010f40fd0000bcfb000004fc000080ec0002190000190098ee00010e80fd00005cfb000008fc000040ec00021900001c0098ee00060e83e00018605cfb0006081e3000006040ec00021900001c0098ee00060e83300018605cfb000608333000006040ec00021900001c0098ee00060e8331e018f05cfb -000608333e1e36f040ec00021900001c0098ee00060e83333018605cfb000008fe3302386040ec00021900001c0098ee00060e83333018605cfb0006083f3333306040ec00021900001c0098ee00060e83333018605cfb000008fe3302306040ec00021900001c0098ee00060e83333018605cfb000008fe3302306040ec00 -021900001c0098ee00060e83333018605cfb000008fe3302306040ec00021900001c0098ee00060683e1e018305cfb000608333e1e303040ec0002190000190098ee00010e80fd00005cfb000008fc000040ec0002190000190098ee00010e80fd00005cfb000008fc000040ec0002190000190098ee00010f40fd0000bcfb -000004fc000080ec0002190000170098ee0001073ffdff0038fb000003fcffeb0002190000110098ee000107c0fd0000f8df0002190000100098ee000003fcff00f0df0002190000100098ee000001fcff00e0df0002190000100098ed00007ffdff0080df0002190000080098c50002190000080098c50002190000080098 -c50002190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000080098c50002190000080098c5000219000008009fc5ff02f9000008009fc5ff02f90000080080c50002010000080080c5 -000201000005c3ff01000000ff0000}} -\par \pard \s20\qc\fi200\ri-40\sa120\keep\keepn\widctlpar\tqr\tx1600 Fig. 6: Specifying the exploration options. -\par \pard \s20\li360\sa120\widctlpar -\par \pard \s20\fi-280\li280\sa120\widctlpar The text fields of the dialog box can be used to enter patterns by using {\i jokers} or {\i wild cards}. The following jokers are admitted: -\par \tab ? stands for an arbitrary character -\par \tab * stands for a sequence of one or several characters -\par The pattern b*o?, for example, accepts the following character strings (using upper or lower case letters is irrelevant): -\par \page \bullet \tab {\i BOOK} -\par \bullet \tab {\i BARITONE} -\par \bullet \tab and of course {\i BABYLON} -\par -\par The meaning of the various parameters will be explained in detail, when we discuss {\i Explore} of the {\i Frame} or {\i Rule} menu. -\par {\i Toggle menu bar} -\par \tab is only available and necessary on computers of the Macintosh SE type. This command is used to alternate between the two menu bars. For this purpose, the Command-T key can also be used. -\par \pard\plain \s3\li360\sb120\sa120\keepn\widctlpar \b\f8\fs28\lang1031 4.2\tab The Frame Menu -\par \pard\plain \s20\li360\sa120\widctlpar \f8\lang1031 When the configuration of the current expert system contains a frame interpreter, then the {\i Frame} - menu will be activated. It provides operations for object and instance exploration as well as a facility to control the syntax check behavior. -\par -\par \pard \s20\qc\li360\sa120\widctlpar {\fs20 {\pict\macpict\picw188\pich70\picwgoal3760\pichgoal1400 -044600000000004600bc001102ff0c00fffe0000004800000048000000000000004600bc000000000001000a00000000004600bc0099801800000000004600bc000000000000000000480000004800000000000100010001000000000032537000000000000061be010100010000ffffffffffff0001000000000000000000 -00004600bc00000000004600bc0040000a00000000004600bc06f8ff00fef300080080f9000003f300080080f9000003f300080080f9000003f3000a02807ff0fb000003f3000c0480401003e0fd000003f3000b0380401003fc000003f3000d098040100306cf1ff0f003f3000d0980401003071199999803f3000d098040 -1003c60f99999803f3000d098040100306199999f803f3000d0980401003061999998003f3000d0980401003061999998803f3000d0980401003060f9998f003f3000a02807ff0fb000003f300080080f9000003f300080080f9000003f300080080f9000003f30004eaff00e0060080eb000030060080eb000030060080eb -0000300c06800078c0000180f10000300c068000c4c0000180f10000300c068000c0f8787198f10000300c068000c0ccccc9b0f10000300c068000c0ccccc1e0f10000300c068000c0ccfcc1c0f10000300c068000c0ccc0c1e0f10000300c068000c4ccc4c9b0f10000300c06800078cc787198f1000030060080eb000030 -060080eb000030060080eb000030060080eb000030060080eb000030060080eb000030060080eb000030060080eb000030130d8000f8000180000003c60180000cf800003013098000c000018000000666fe00000cf8000030140e8000c199f18f1b3c0667c18f871e38f900003014028000c1fe99089c6606666198cc8c64 -f900003014028000f1fe9908986606666198cc0c70f9000030140e8000c0f19999987e0666619fcc0c38f900003014028000c1fe99089860066661980c0c1cf900003014028000c1fe99089862066661984c8c4cf9000030140e8000f999f18f183c03c7c18f870638f90000300f048000000180fc00010180f60000300f04 -8000000180fc00010980f60000300a0080f8000007f5000030060080eb000030060080eb000030060080eb000030060080eb00003017028000f8fd000603001800003180fd0005f0000006003018028000c0fd000603001800000180fe00060188000006003019178000c1b3c7fc3c031f1f0f19b3c78f870f0181b3c7c7c0 -3019038000c1c4fe6610031999999e3188cccc998181c46666603019178000f183e6666603199999983187cccc1981b983e666603019178000c18666667e0319999f98318ccccc1f8199866666603019178000c1866666600319999818318ccccc180199866666603019178000c1866666620319999898318ccccc98819986 -6666603019178000c183e6663c0319998f1830c7ccc70f00f183e7c66030090080ee000306000030090080ee000306000030060080eb000030060080eb00003004eaff00f006007febff00f000ff0000}} -\par \pard \s20\qc\fi200\ri-40\sa120\keep\keepn\widctlpar\tqr\tx1600 Fig. 7: The frame menu. -\par \pard \s20\fi-280\li280\sa120\widctlpar {\i Check} -\par \tab In order to support the development of expe -rt systems the frame interpreter provides a choice of plausibility checks. For example, it checks whether the initial values of instance slots match the specification of their possible values. This menu entry allows the programmer to activate or deactivat -e the plausibiltity checks. Whether they are activated or not is reflected by the the hook before the menu entry. -\par As the plausibility checks require a lot of loading and resetting time, they are deactivated in the initial state and should only be activated during the development of an expert system. -\par {\i Explore Objects} -\par \tab provides a screen-oriented exploration option for the objects of the current expert system (cf. Figure 8). The screen will display six selection fields and one display field. -\par -\par \pard \s20\qc\li360\sa120\widctlpar {\fs20 {\pict\macpict\picw509\pich321\picwgoal10180\pichgoal6420 \picscalex89\picscaley89 -1a2600000000014101fd001102ff0c00fffe0000004800000048000000000000014101fd000000000001000a00000000014101fd0099804000000000014101fd0000000000000000004800000048000000000001000100010000000000325428000000000000624c000000010000ffffffffffff0001000000000000000000 -00014101fd00000000014101fd0040000a00000000014101fd04c2ff00f0060080c3000018060080c3000018060080c30000180e02bf7ff7efffec00000fedff00d81c02804010ef000101f0fd000b0f8000180000031800001008e90000182002bf4017efff010180fd00060c000018000003fe00011818fe00000fedff00 -d82002804010ef00140183678ff8780c199f18f1b3c798f1f01c38f1f198ec0000182102bf4017efff02018388fecc010c19fe990ac4631999981e799999980fedff00d82002804010ef000201e307fecc010f19fe990983e319999817d9999998ec0000182102bf4017efff1501830cccccfc0c0f19999986631999981399 -f999980fedff00d82002804010ef000701830cccccc00c19fe990986631999981119819998ec0000182102bf4017efff0701830cccccc40c19fe990a866319999810198999980fedff00d82002804010ef0014018307cccc780f999f18f183e198f1981018f198f8ec0000181202bf7ff7effff9000018f500000fedff00d8 -0a0080e5000018e0000018060080c3000018060080c300001804c2ff00f8060080c3000018060080c3000018060080c3000018060080c3000018140183e0ed0002800020f0000301c20020f0000018130082ec0002800020f0000302220020f00000181d05820b1ef1c780f100068b1e71eb1c71e0f4000402021c71e0f100 -00181a0483cca2aa28f000058ca0222ca28af3000301c22222f00000181b04820822abe7f00006889c2228a0f9c0f30003222221c0f10000181d05820826aa0080f1000688822268a08020f400040222222020f10000181c0482081aa9eff0000688bc19a89e7bc0f4000401c21c1bc0f1000018060080c3000018060080c3 -0000180600bfc3ff00d81400bfefff02e0007fefff02e00060ef00022000581400bfefff02e0407fefff02e04060ef00022040582a06be30e38e3ddd8ff5ff0de0a07c105dfe3741fe38dd0ff8c1faff07e0a061c8be8a2f80f4000220a0582906bdd75d75ddcd77f5ff0de1107dfdddfdd75ffdd74d77f777faff06e11062 -28a0ca28f300022110582906bdf75d7dfdd57ff5ff0de2087c3dddfdd75fffdf5577f7f7faff06e2086228a0aa28f300022208582906bdf0dd8e3dd967f5ff0de4047fddc1041743073ed97418f7faff06e40463e8bc9a2ff300022404582906bdf75df7dddd77f5ff0de8027fddddfdd75fffdddd77ff77faff06e8026228 -a08a28f300022802582906bdd75d75dddd77f5ff0dfe0f7dddddfddadffddbdd77f777faff06fe0f6225208a28f300023e0f582a06be37638e3ddd8ff5ff0de2087e3dddfdddc1fe305d0ff8f7faff07e20862223e89cf80f400022208581400bfefff02e2087fefff02e20860ef00022208581400bfefff02e2087fefff02 -e20860ef00022208581400bfefff02e3f87fefff02e3f860ef000223f8581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002200060ef00022000582d05a22fa221c83ef4000e3fffe3cf1c73c89c880f3e73cfa2f0fb000a3fffe2071cf8072272273ef700023fffd82d05a22822222820f4 -000e20006228a28a28a28808a08a283288fb000a20006208a22008a28b28a0f700022000582d05a22822220820f4000e20006228a28a28a28808a08a282a88fb000a20006208a02008228aa820f700022000582d05a22f3e22083cf4000e200063cf22fa28be53e8bcfa2f2688fb000a2000620f9c23e83efa69bcf7000220 -00582d05a22822220820f4000e20006228a28a2aa22008a08a282288fb000a20006208822008228a28a0f700022000582d05a14822222820f4000e20006228a28a2da22008a08a282288fb000a20006208a22008a28a28a0f700022000582d05a08fa221cfbef4000e200063c89c8bc8a2200f3e8bcfa2f0fb000a200063e8 -9c2007228a273ef700022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002200060ef00022000581b02a22722f1000220 -0060ef0007200061cfbcfbef80f400022000581a02a228a2f10002200060ef000620006222228202f300022000581a02a228a2f10002200060ef000620006202228202f300022000581a02a22f94f10002200060ef0006200061c23cf3c2f300022000581a02a2a888f10002200060ef000620006022228202f30002200058 -1a02a36888f10002200060ef000620006222228202f300022000581a02a22888f10002200060ef0006200061c222fbe2f300022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef -000220007fefff02e000581400a0ef0002200060ef000220007fefff02e000581a00a0ef0002200060ef000820007c17ff8dd07f77f5ff02e000581a00a0ef0002200060ef000820007f77ff75d7ff37f5ff02e000581a00a0ef0002200060ef000820007f77ff75d7ff57f5ff02e000581a00a0ef0002200060ef00082000 -7f77c105d0c167f5ff02e000581a00a0ef0002200060ef000820007f77ff75d7ff77f5ff02e000581a00a0ef0002200060ef000820007f77ff76b7ff77f5ff02e000581a00a0ef0002200060ef000820007f707f77707f77f5ff02e000581400a0ef0002200060ef000220007fefff02e000581400a0ef0002200060ef0002 -20007fefff02e000581400a0ef0002200060ef000220007fefff02e000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002200060ef00022000581a00a0ef0002200060ef0008200063e800722f8070f500022000581a00a0ef0002200060ef000820006088008a280088f500022000581a -00a0ef0002200060ef000820006088008a280080f500022000581a00a0ef0002200060ef0008200060883efa2f3e70f500022000581a00a0ef0002200060ef000820006088008a280008f500022000581a00a0ef0002200060ef0008200060880089480088f500022000581a00a0ef0002200060ef00082000608f80888f80 -70f500022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002200060ef00022000581900a0ef0002200060ef0007200063 -e80073e03ef400022000581900a0ef0002200060ef00072000608800888020f400022000581900a0ef0002200060ef00072000608800808020f400022000581900a0ef0002200060ef0007200060883e708fbcf400022000581900a0ef0002200060ef00072000608800088020f400022000581900a0ef0002200060ef0007 -2000608800888020f400022000581900a0ef0002200060ef00072000608f8070803ef400022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002200060ef00022000581400a0 -ef0002200060ef0002200060ef00022000581900a0ef0002200060ef0007200063e80073e022f400022000581900a0ef0002200060ef00072000608800888022f400022000581900a0ef0002200060ef00072000608800808022f400022000581900a0ef0002200060ef0007200060883e708fa2f400022000581900a0ef00 -02200060ef0007200060880008802af400022000581900a0ef0002200060ef00072000608800888036f400022000581900a0ef0002200060ef00072000608f80708022f400022000581400a0ef00023fffe0ef00023fffe0ef00023fffd81400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002 -200060ef00022000581400a0ef000223f860ef000223f860ef000223f8581400a0ef0002220860ef0002220860ef00022208581d00a0ef0002220860ef000b220863ef1cfbe21c03ef1c88f800022208581d00a0ef0002220860ef000b22086088a28202220208a2d8f800022208581d00a0ef00023e0f60ef000b3e0f6088 -a28202200208a2a8f800023e0f581d00a0ef0002280260ef000b2802608f3ef3c220fbcf2288f800022802581d00a0ef0002240460ef000b24046088a28202200208a288f800022404581d00a0ef0002220860ef000b22086088a28202220208a288f800022208581d00a0ef0002211060ef000b21106088a282021c02089c -88f800022110581400a0ef000220a060ef000220a060ef000220a0581400a0ef0002204060ef0002204060ef00022040581400a0ef0002200060ef0002200060ef00022000580600bfc3ff00d8060080c3000018060080c3000018060080c3000018060080c3000018060080c30000181d0181c0fe00003ef2000403c02000 -02f1000103c0fe00010820f30000181a018220fe000020f20002022020ef00010220fe000008f200001826098208bc72c020b1ef1c78f6000702273c7a221cb1e0f40008022b1cf1cb1c21c780f5000018240981c8a28b203cca2aa280f6000603c8a28a2222caf3000703cca28a2c882228f400001825098028a2fa002082 -2abe70f60007022fa28a222281c0f400070208228be80823e7f400001826098229a2820020826aa008f600070228229942228020f400080208228a0808220080f5000018250981c6bc7a002081aa9ef0f6000703c7a268821c83c0f4000702081cf1e80621eff40000180c02800020d7000080f00000180c02800020d70000 -80f00000180600bfc3ff00d81400a0ef0002200060ef0002200060ef00022000581400a0ef0002204060ef0002204060ef00022040581f00a0ef000920a061cfbe01cf3efa20f6000620a06227208be0f3000220a0581e00a0ef000921106228080228a08320f6000521106228a08af200022110581e00a0ef000922086208 -080208a082a0f6000522086228a08af200022208581f00a0ef0009240461cf08fa6f3cf260f600062404622fa08bc0f300022404581e00a0ef000928026028080228a08220f6000528026228a08af200022802581e00a0ef00093e0f6228080228a08220f600053e0f6148a08af200023e0f581f00a0ef0009220861cf8801 -c8befa20f6000622086088be73e0f300022208581400a0ef0002220860ef0002220860ef00022208581400a0ef0002220860ef0002220860ef00022208581400a0ef000223f860ef000223f860ef000223f8581400a0ef0002200060ef000220007fefff02e000581400a0ef0002200060ef000220007fefff02e000582100 -a0ef00063fffe1cfbefbc0f3000d3ffffc38e38f70df07f7637dd063f8ff00d82300a0ef000620006228088220f3000d20007dd75d77775f7ff75d7dd7ddfaff02e000582300a0ef000620006228088220f3000d20007dd75f7f775f7ff75d7dd7dffaff02e000582300a0ef0006200063ef08f3c0f3000d20007c37638f70 -df0c17417dd0e3faff02e000582300a0ef000620006228088220f3000d20007df77df7775f7ff75d7dd7fdfaff02e000582300a0ef000620006228088220f3000d20007df75d77775f7ffadd7dd7ddfaff02e000582300a0ef00062000622808fa20f3000d20007df8e38f70c107fddd063063faff02e000581400a0ef0002 -200060ef000220007fefff02e000581400a0ef0002200060ef000220007fefff02e000581400a0ef0002200060ef000220007fefff02e000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002200060ef00022000582300a0ef0017200063e222f8070889cf8081c73e01c89c89cf800020 -0060ef00022000582300a0ef00172000608236800888ca28008228880228a2ca280000200060ef00022000582300a0ef0017200060822a800808aa08008228080208a2aa080000200060ef00022000582300a0ef00172000608222f3e7089a0f3e83e708fa0fbe9a6f0000200060ef00022000582300a0ef00172000608222 -8000888a08008220880208a28a280000200060ef00022000582300a0ef001720006082228008888a28008228880228a28a280000200060ef00022000582300a0ef00172000608222f8070889cf80fa270801c8a289cf8000200060ef00022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060 -ef0002200060ef00022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002200060ef00022000581a00a0ef0008200063c89c8808be88f50002200060ef00022000581a00a0ef000820006228a2880ca088f50002200060ef000220 -00581a00a0ef000820006228a0880aa088f50002200060ef00022000581a00a0ef0008200063c89cfbe9bc88f50002200060ef00022000581a00a0ef000820006208828808a0a8f50002200060ef00022000581a00a0ef000820006208a28808a0d8f50002200060ef00022000581a00a0ef0008200062071c8808be88f500 -02200060ef00022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002 -200060ef00022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef000220 -0060ef00022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef00022000 -60ef00022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002200060 -ef00022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002200060ef -00022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002200060ef00 -022000581400a0ef00023fffe0ef00023fffe0ef00023fffd81400a0ef0002200060ef0002200060ef00022000581400a0ef0002200060ef0002200060ef00022000581400a0ef000223f860ef000223f860ef000223f8581400a0ef0002220860ef0002220860ef00022208581400a0ef0002220860ef0002220860ef0002 -2208581400a0ef0002220860ef0002220860ef00022208581400a0ef00023e0f60ef00023e0f60ef00023e0f581400a0ef0002280260ef0002280260ef00022802581400a0ef0002240460ef0002240460ef00022404581400a0ef0002220860ef0002220860ef00022208581400a0ef0002211060ef0002211060ef000221 -10581400a0ef000220a060ef000220a060ef000220a0581400a0ef0002204060ef0002204060ef00022040581400a0ef0002200060ef0002200060ef00022000580600bfc3ff00d8060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018140e8100722f -8073e03cfbc01cf3efa220d1000018140e82008b28008a00228220228a083210d1000018140e84088aa8008a00228220208a082a08d1000018140e84008a6f3e8bc03cf22026f3cf2608d1000018140e84008a28008a00228220228a082208d1000018140e82008a28008a00228220228a082210d1000018140e8108722f80 -720022fbc01c8befa220d1000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c300001806 -0080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c30000180600 -80c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080 -c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c300001804c2ff00f808ccff003ff8ff00f800ff0000}} -\par \pard \s20\qc\fi200\ri-40\sa120\keep\keepn\widctlpar\tqr\tx1600 Fig. 8: The screen during the object exploration. -\par \pard \s20\li360\sa120\widctlpar -\par The selection field {\i Frames} lists all frame names that correspond to the reference pattern specified in the main menu (cf. {\i Explore Opts}...). -\par When the programmer selects a frame, the selection field {\i Super Frames} will display the corresponding superframes. If the option {\i All} - is specified, not only the direct superframes will be displayed, but all frames preceding this frame in the inheritance hierarchy. The selection field {\i Instances} will display the instances of the selected frame. When choosing the option {\i All} - the instances of the subframes will also be considered. The instance names must match the specified reference pattern. -\par The behaviors of the selected frame will be displayed in the selection field {\i Behaviors}. -\par When an instance is selected, its slots will be listed in the selection field {\i Slots}. The option {\i All} ensures that the slots inherited from the superframes are also considered. -\par The slot properties will be displayed in the selection field {\i Properties}. -\par The display field can present the parameter list and the documentation text of a behavior or the value of a slot property. -\par If specified, the frames, superframes, instances and slots are displayed in an alphabetical order. -\par Next to the titles of the selection fields {\i Frames}, {\i Instances} and {\i Behaviors} a button marked with {\b >} - will appear. If the programmer clicks on one of these buttons, the knowledge base editor will be automatically activated. The editor will be automatically positioned to the construct that is selected in the corresponding selection field. If, for example, - the programmer clicked on the button next to {\i Instances} in Figure 8, the system would position the editor to the line -\par {\f13 (definstance 5th-ave-32nd-st of crossing .......} -\par \pard \s20\fi-280\li280\sa120\widctlpar {\i Frame Inheritance Graph} -\par \tab provides a tree ori -ented display of the inheritance structure of the objects of the current expert system (cf. Figure 9). Selecting this menu entry will pop up a selection dialog of all the frames of the current knowledge base and as a first entry *ROOT*. Selecting *ROOT* w -ill show a window with {\b all} - the known frames, selecting a frame name will show this frame as the root and all it's subframes. Double clicking on a frame in this window will position to the frame definition in the editor buffer and option double clicking will - pop up an exploration dialog for this frame (cf. Figure 10). If you want to change the root of the inheritance graph displayed, close the display window and select the {\i Frame Inheritance Graph }menu again. -\par \pard \s20\li360\sa120\widctlpar -\par \pard \s20\qc\fi200\ri-40\sa120\keep\keepn\widctlpar\tqr\tx1600 {\fs20 {\pict\macpict\picw515\pich226\picwgoal10300\pichgoal4520 \picscalex88\picscaley88 -12ea0000000000e20203001102ff0c00fffe000000480000004800000000000000e20203000000000001000a0000000000e20203009980420000000000e2020300000000000000000048000000480000000000010001000100000000003252a400000000000063ba804200010000ffffffffffff0001000000000000000000 -0000e202030000000000e202030040000a0000000000e2020305c1ff01e000070080c200016000070080c200016000070080c2000160001902bf7ff7feff00c0ec000010e600010200feff04fbffbf60003d02804010fd00007cfd000601800c00003180fd000ef0000006002030000003000006600cfc000d18c000000c00 -00c0c00001980301fd000402088060004002bf4017feff01c060fd000601800c00000180fe000f0188000006002030000003000006000cfc000018fe000a0c0000c0c0000180030100feff04fa08bf60004102804010fd003160d9e3fe1e018f8f878db3c78f870f0181b3c7c7c021f1e333e31e01c6638cc078d81e3e3cc7 -8f807c78ccf8c7807198e331fd000402088060003f02bf4017feff02c060e2fe3310018cccccce3188cccc998181c466666023fc330c0326664d80cce0333318ccccc0fccc05c0c999936100feff04fa08bf60003e02804010fd000678c1f33333018cfecc0b3187cccc1981b983e6666043fc330c0306660f00ccc0333318 -ccccc0fccc05c0c19983c080fe000402088060004102bf4017feff16c060c333333f018ccccfcc318ccccc1f81998666666023fd330d3f0306660e00ccc0333318ccccc0fdcc06cfc0c199838100feff04fbf8bf60003e02804010fd001560c3333330018ccccc0c318ccccc1801998666666023fd330d300306660f00ccc0 -333318ccccc0fccc0400c19983c1fd000402008060004002bf4017feff16c060c3333331018ccccc4c318ccccc9881998666666023fd330d310326664d80ccc0333318ccccc0fccc0540c999936100feff04fa00bf60004102804010fd003160c1f3331e018cccc78c30c7ccc70f00f183e7c66021f1e1f3e31e01c6638cc0 -78c01e3e0cc78cc07c787cf8c7807198e331fd000402008060002302bf7ff7feff00c0ef000606000010000003f7000030f400010200feff04fbffbf6000130080e9000006fc000003f7000030ec00016000070080c200016000070080c20001600005c1ff01e000090080c4000320006000090080c4000320406000090080 -c4000320a06000090080c4000321106000090080c4000322086000090080c4000324046000090080c4000328026000090080c400033e0f6000090080c4000322086000090080c4000322086000090080c4000322086000090080c4000323f86000090080c4000320006000090080c4000320006000090080c400033fffe000 -090080c400033fffe000090080c400033000e000090080c400033000e000090080c400033000e000090080c400033000e000090080c400033000e000090080c400033000e000090080c400033000e000090080c400033000e000090080c400033000e000090080c400033000e000110080f5000007f4ff00fcdf00033000e0 -00110080f5000004f4000004df00033000e0001b0080f5000e042311e7f13f90bf803e7c08209f04df00033000e0001b0080f5000e042312108104108400204208319004df00033000e0001b0080f5000e0422920081041084002042142a9004df00033fffe0001b0080f5000e042292008104108400204214249004df0003 -311160001b0080f5000e042251e0810410841f3c7c22209e04df0003244460001b0080f5000e042250108104108400205022209004df0003311160001b0080f5000e04223010810410840020487f209004df0003244460001b0080f5000e042232108104108400204441209004df0003311160001b0080f5000e042211e081 -040f0400204241209f04df000324446000110080f5000004f4000004df000331116000110080f5000004f4000004df000324446000110080f5000004f4000004df000331116000110080f5000004f4000004df000324446000110080f5000007f4ff00fcdf0003311160000d0080f000000cd60003244460000d0080f00000 -30d60003311160000d0080f00000c0d60003244460000d0080f1000003d50003311160000d0080f100000cd50003244460000d0080f1000070d50003311160000e0080f200010180d50003244460000d0080f2000006d40003311160000d0080f2000018d40003244460000d0080f2000060d4000331116000170080f50000 -07f1ff00fcfe00000fedfffa000324446000190080f5000004f1000004fe000008ee000001fa000331116000360080f50004044113f820fef8099fcf9f003e7c08209f04fe0014081062fe7c081e003cfe7c8103e7c00f9f020827c1fa000324446000360080f50011046310402084848082081080204208319004fe001408 -10621042082100421040810204200810820c6401fa000331116000360080f500110455104050848480820810802042142a9004fe00140828521042142000401040810204200810850aa401fa000324446000360080f50011044910405084f88082081080204214249004fe0014082852104214200040104081020420081085 -092401fa000331116000360080f500110441104088f884f0820f1f1f3c7c22209e04fe001408444a107c22273e3c10788103c7c7cf1f08882781fa000324446000360080f500110441104088a0848082081400205022209004fe001408444a105022210002104081020500081408882401fa000331116000360080f5001104 -411041fc9084808208120020487f209007feff14f8fe4610487f21000210408102048008121fc82401fa000324446000360080f500110c4110410488848082081100204441209004fe0014088246104441210042104081020440081110482401fa000331116000360080f50011344110410484f8f8820f9080204241209f04 -fe00140882421042411e003c107cf9f3e4200810904827c1fa000324446000190080f50000c4f1000004fe000008ee000001fa0003311160001a0080f600010704f1000004fe000008ee000001fa0003244460001a0080f600011804f1000004fe000008ee000001fa0003311160001a0080f600016004f1000004fe000008 -ee000001fa000324446000190080f70002018007f1ff00fcfe00000fedfffa000331116000110080f7000006fc00003ed5000324446000120080f7000018fd000107c0d5000331116000110080f7000060fd000078d4000324446000130080f800010180fe00010f80d4000331116000120080f8000006fe000101f0d30003 -24446000110080f8000038fe00001ed2000331116000110080f80004c0000003e0d2000324446000110080f9000003fe00007cd1000331116000110080f900040c00000780d1000324446000100080f90003300000f8d0000331116000180380000001fcff04fe001f0007edff00f8e6000324446000180380000001fc0004 -0201e00004ed000008e60003311160002b22800000011f3e04104f823e000004427c4010427c3c001062fe7c081e007cf810413e08e60003244460002b118000000110210418c803c000000442424010fe420d0010621042082100408410632008e60003311160002b098000000110210a154802fe00150442424028424240 -0028521042142000408428552008e60003244460002b098000000110210a124802fe00150442424028427c400028521042142000408428492008e60003311160002b09800000011e3e11104f02fe001504427c404442423c7c444a107c22273e78f844413c08e60003244460002b0980000001102811104802fe0015044250 -404442420200444a105022210040a044412008e60003311160002b098000000110243f904803feff15fc424840fe42420200fe4610487f21004090fe412008e60003244460002b0980000001102220904802fe00040442444082fe420d0082461044412100408882412008e60003311160002b0980000001102120904f82fe -0015043c427c823c7c3c0082421042411e00408482413e08e6000324446000180380000001fc000002fe000004ed000008e6000331116000180380000001fc000002fe000004ed000008e6000324446000180380000001fc000002fe000004ed000008e6000331116000180380000001fc000403e0000004ed000008e60003 -24446000180380000001fcff04fe1e000007edff00f8e6000331116000100080fa000301c001f0cf0003244460000f0080f9000230000fcf000331116000100080f900030c0000f0d0000324446000110080f900040300000f80d1000331116000100080f80003c0000078d1000324446000110080f800043800000780d200 -0331116000110080f8000006fe000078d2000324446000120080f800050180000007c0d3000331116000110080f7000060fe00003cd3000324446000120080f7000018fe000103c0d4000331116000130080f70002070007f3ff0080e0000324446000120080f60001c004f3000080e00003311160001d0080f6001030047c -4623c08311e1e007cf810413e080e00003244460001d0080f600100c04404624208312121004084106320080e00003311160001d0080f600100304404524014292020004084285520080e00003244460001c0080f5000fe4404524014292020004084284920080e00003311160001c0080f5000f1c7844a4e2225271e3e78f -844413c080e00003244460001c0080f5000f044044a42222521010040a0444120080e00003311160001c0080f5000f0440446427f232101004090fe4120080e00003244460001c0080f5000f04404464241232121004088824120080e00003311160001c0080f5000f047c4423c41211e1e00408482413e080e00003244460 -00110080f5000004f3000080e0000331116000110080f5000004f3000080e0000324446000110080f5000004f3000080e0000331116000110080f5000004f3000080e0000324446000110080f5000007f3ff0080e00003311160000d0080f20000e0d40003244460000d0080f2000018d40003311160000d0080f2000006d4 -0003244460000e0080f200010180d50003311160000d0080f1000060d50003244460000d0080f100001cd50003311160000d0080f1000003d50003244460000d0080f00000c0d60003311160000d0080f0000030d60003244460000d0080f000000cd6000331116000110080f5000007f3ff00fce0000324446000110080f5 -000004f3000004e00003311160001c0080f5000f0408211e1e04188f0f003e7c08209f04e00003244460001c0080f500010408fe210a0418909080204208319004e00003311160001c0080f5000f04142120200a149010002042142a9004e00003244460001c0080f5000f04142120200a14901000204214249004e0000331 -1160001c0080f5000f0422211e271112938f1f3c7c22209e04e00003244460001c0080f5000f04222101211112908080205022209004e00003311160001c0080f5000f047f2101213f9190808020487f209004e00003244460001c0080f500010441fe210a2091909080204441209004e00003311160001c0080f500010441 -fe1e0a20908f0f00204241209f04e0000324446000110080f5000004f3000004e0000331116000110080f5000004f3000004e0000324446000110080f5000004f3000004e0000331116000110080f5000004f3000004e0000324446000110080f5000007f3ff00fce0000331116000090080c4000324446000090080c40003 -31116000090080c4000324446000090080c4000331116000090080c4000324446000090080c4000331116000090080c4000324446000090080c4000331116000090080c4000324446000090080c4000331116000090080c4000324446000090080c4000331116000090080c4000324446000090080c4000331116000090080 -c4000324446000090080c4000331116000090080c4000324446000090080c4000331116000090080c4000324446000090080c4000331116000090080c4000324446000090080c4000331116000090080c4000324446000090080c4000331116000090080c4000324446000090080c4000331116000090080c4000324446000 -090080c4000331116000090080c4000324446000090080c400033fffe000090080c4000320006000090080c4000320006000090080c4000323f86000090080c4000322086000090080c4000322086000090080c4000322086000090080c400033e0f6000090080c4000328026000090080c4000324046000090080c4000322 -086000090080c4000321106000090080c4000320a06000090080c4000320406000090080c400032000600005c1ff01e0000e038101ffffc911051010200060000e0383018001c944055018200060000e0385018001c91105101427f060000e0389f18001c9440551f2241060000d0390118001c8110401241f60000e03a011 -8001c944055100a41160000d03c0118001c8110400641160000e03a0118001c944055100a41160000d0390118001c811040127f160000e0389f18001c9440551f2210160000e0385018001c911051014210160000e0383018001c944055018210160000e0381018001c91105101021ff60000e038001ffffc9440550002000 -600005c1ff01e00005c1ff01e00000ff0000}}{\fs20 -\par }Fig. 9: The Frame Inheritance Graph Window. -\par \pard \s20\li360\sa120\widctlpar -\par \pard \s20\qc\li360\sa120\widctlpar {\fs20 {\pict\macpict\picw273\pich257\picwgoal5460\pichgoal5140 \picscalex94\picscaley94 -11de0000000001010111001102ff0c00fffe000000480000004800000000000001010111000000000001000a0000000001010111009980240000000001010111000000000000000000480000004800000000000100010001000000000032555800000000000064c3000000010000ffffffffffff0001000000000000000000 -000101011100000000010101110040000a000000000101011105dfff018000080080e10002018000080080e10002018000080080e100020180001202bf7ff7faff00c0f5000007f8ff02fd80001502804010f900007cfd000303f00003f400020180001a02bf4017faff01c060fd000303800003fe000007f8ff02fd800019 -02804010f9000b60d9e3fe1e038333e31e3678f700020180001b02bf4017faff02c060e2fe33010383fe330238cc07f8ff02fd80001902804010f9000678c1f3333303e3fe330130ccf700020180001b02bf4017faff0dc060c333333f0381e3333330fc07f8ff02fd80001902804010f9000660c33333300383fe330130c0 -f700020180001b02bf4017faff07c060c33333310383fe330230c407f8ff02fd80001902804010f9000b60c1f3331e03f333e31e3078f700020180001602bf7ff7faff00c0fa000003fd000007f8ff02fd80000c0080f0000003f30002018000080080e10002018000080080e1000201800005dfff018000080080e1000201 -8000080080e10002018000080080e10002018000080080e10002018000080080e10002018000080080e10002018000080080e10002018000080080e1000201800021028003e0fc001307882fdf0f0f001cfdf98307cf801f3e1e2013e0fc00020180001f018003fb00120ccc23199998803231c183060cc01833333033fb00 -02018000221a800306cf1ff0f1800cce23199998003031c183060cc01833333873fb0002018000220380030711fe9913800ccf23199998003831c183060cc01833333cf3fb0002018000231b8003c60f999998000fcba31f1f9b9f1c31f183078f8f9e3e3f2fb3c0fc0002018000221a800306199999f8000cc9e319999980 -0e31c183060cc01833332733fb0002018000221a80030619999980000cc8e3199999800631c183060cc01833332233fb0002018000221a80030619999989800cc863199999802631c183060cc01833332033fb0002018000231b8003060f9998f1800cc82319998f001c31f9f3e7ccc01833332033e0fc0002018000080080 -e10002018000080080e10002018000080080e10002018000080080e10002018000080080e10002018000080080e10002018000080080e10002018000080080e10002018000080080e10002018000080080e10002018000080080e100020180000e02800078f10000f0f400020180001e0380018603fe00040c071800c0fb00 -07030c03c66038c006fa00020180001e0380020103fe00040c0c9800c0fb0007040206666064c006fa0002018000200c8002010303c3878c0c18f1e380fc000804f206666060c78f1cfb0002018000200c80040083066648cc0e1998c640fc000809f906666070ccc632fb00020180001f0b80040083066607cc071998c7fb -000809f907e66038ccc638fb0002018000200c8004008306660ccc039998c380fc000809f90666601cccc61cfb0002018000200c8004008306660ccc019998c1c0fc000809f90666600cccc60efb0002018000200c8002010306664ccc099998c4c0fc000804f20666604cccc626fb0002018000200c80020103e3c387cc07 -18f06380fc0008040206666038c7831cfb00020180000f02800186f20001030cf400020180000e02800078f10000f0f40002018000080080e10002018000080080e10002018000080080e10002018000080080e100020180000e02800078f10000f0f40002018000230380018603fe00060c0f800c00000cfd000a030c03c6 -607c0060000060fd00020180001d0380020103fe00030c0cc00cfa00070402066660660060fa000201800025238002010303c3878c0cc78f878ccc78d9c0000402066660663c7c3c6663c6ce0000018000250b80040083066648cc0cccccc8fecc07e320000801066660fe660946666667190000018000250b800400830666 -07cc0f8cccc7fecc0bc38000080107e6607c66663efe66051c000001800021098004008306660ccc0ccffccc09c1c0000801066660667efc66050e0000018000220a8004008306660ccc0ccc0cfdcc09c0e00008010666606660fc660507000001800025238002010306664ccc0ccc4ccccc8cccc260000402066660666266 -66646666130000018000252380020103e3c387cc0f878cc7cf0c78c1c00004020666607c3c663e7863c60e00000180000f02800186f20001030cf400020180000e02800078f10000f0f40002018000080080e10002018000080080e10002018000080080e10002018000080080e100020180000e02800078f10000f0f40002 -018000200480018603e3fe0004c030000180fc0008030c03c66030000180fb000201800020048002010330fe0004c030000180fc0008040206666030000180fb000201800025238002010333367871e031f0e3c78f870f0e00040206666031f0e3c78f870f0e00000180002523800400833338ccc8c031999188cccc999980 -080106666031999188cccc999900000180002523800400833330ccc0c03199c187cccc199c00080107e6603199c187cccc199c00000180002523800400833330fcc0c03198e18ccccc1f8e0008010666603198e18ccccc1f8e00000180002505800400833330fec01a3198718ccccc18078008010666603198718ccccc1807 -00000180002523800201033330c4c8c03199318ccccc98938004020666603199318ccccc98930000018000252380020103e3307870603198e0c7ccc70f0e0004020666603198e0c7ccc70f0e00000180000f02800186f20001030cf400020180000e02800078f10000f0f40002018000080080e10002018000080080e10002 -018000080080e10002018000080080e10002018000080080e10002018000080080e10002018000080087e1ff02e180000a0084e3000410002180000a0084e300041020218000251b8408e45f78e38039f7d041f7807de3917c022f20722f1c022722f9c2fe00041050218000251b8411164445144044441041044041145b40 -0228a08a28a20248b22221fe00041088218000252384211544451400404410410440411455400228a08a28a00288aa2220800000110421800025238421f4c479f4df38479041e79f79e7d178022f20fa2f1cfb08a622208000001202218000252384211444451440044410410440411451400228a08a28820288a222208000 -001401218000251b84111444451440444410410440411451400228a08a28a20248a22221fe00041f07a18000251b840914444513803847df7df4404114517c01c8be89cf1c02272221c2fe000411042180000a0084e3000411042180000a0084e3000411042180000a0084e3000411fc2180000a0084e3000410002180000a -0084e3000410002180001c128409111f39e79f11f7de01f78e45f011398be2f500041fffe180001c128411b1044514501044110104516d001945da01f5000410002180001d138421510445145010441101045155001545aa0080f6000410002180001d13842111047de79e10479e7de79f45e0137d8bc080f6000410002180 -001d1384211104451450104411010451450011458a0080f6000410002180001c1284111104451450104411010451450011458a01f5000410002180001c128409110445179f1047d101045145f011458be2f5000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e300 -0410002180000a0084e3000410002180001f158409111f39e79f11f7de01f78e45f01f7d83ef9c8880f8000410002180001f158411b1044514501044110104516d000441820822c840f8000410002180001f158421510445145010441101045155000441820822a820f8000410002180001f15842111047de79e10479e7de7 -9f45e0047983cf229820f8000410002180001f15842111047de79e10479e7de79f45e0047983cf229820f8000410002180001f1584211104451450104411010451450004418208228820f8000410002180001f1584111104451450104411010451450004418208228840f8000410002180001f158409110445179f1047d101 -045145f0047dfbe81c8880f8000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180001f158409111f39e79f11f7de01f78e45f0044473e23e8be2f8000410002180001f158411b1044514501044110104516d0004658882 -088881f80004100021800020168421510445145010441101045155000455808208888080f9000410002180002016842111047de79e10479e7de79f45e0044c708208888080f90004100021800020168421110445145010441101045145000444088208888080f9000410002180001f15841111044514501044110104514500 -04458882088881f8000410002180001f158409110445179f1047d101045145f004447082087082f8000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084 -e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e30004100021 -80000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3 -000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180 -000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e300 -0410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e300041000218000 -0a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e30004 -10002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a -0084e3000410002180000a0084e3000410002180000a0084e3000410002180000a0084e300041fffe180000a0084e3000410002180000a0084e3000410002180000a0084e3000411fc2180000a0084e3000411042180000a0084e3000411042180000a0084e3000411042180000a0084e300041f07a180000a0084e3000414 -012180000a0084e3000412022180000a0084e3000411042180000a0084e3000410882180000a0084e3000410502180000a0084e3000410202180000a0084e300041000218000080087e1ff02e18000080080e10002018000080080e10002018000080080e10002018000080080e1000201800005dfff01800005dfff018000 -00ff0000}} -\par \pard \s20\qc\fi200\ri-40\sa120\keep\keepn\widctlpar\tqr\tx1600 Fig. 10: The Frame Explore Dialog. -\par \pard \s20\fi-280\li280\sa120\widctlpar \tab -The Frame Exploration Dialog shows local or global features of the selected frame. Use the push buttons to select the features you are interested in. Selecting an entry will position to the apropriate definition in the ed -itor buffer. If you select a slot this will be the frame definition, containing the slot definition. Use option double click in the Frame Inheritance window to change the frame explored. -\par \pard\plain \s3\li360\sb120\sa120\keepn\widctlpar \b\f8\fs28\lang1031 4.3\tab The Rule Menu -\par \pard\plain \s20\li360\sa120\widctlpar \f8\lang1031 When an expert system with a rule interpreter as part of its configuration is current , the {\i Rule} menu from the menu bar can be selected. It contains operations to inspect the rule part ({\i -Explore Rules}, {\i Explore Rule Terms}), to manipulate the trace behavior ({\i Trace}, {\i Set Rule} {\i Trace Options}) and to explain the consultation results ({\i Explore Facts}, {\i Hypotheses}, {\i Explain}). -\par \pard \s20\qc\li360\sa120\widctlpar {\fs20 {\pict\macpict\picw161\pich148\picwgoal3220\pichgoal2960 -083000000000009400a1001102ff0c00fffe0000004800000048000000000000009400a1000000000001000a00000000009400a10099801600000000009400a100000000000000000048000000480000000000010001000100000000003255080000000000006544018000010000ffffffffffff0001000000000000000000 -00009400a100000000009400a10040000a00000000009400a106fbff0080f20006fbff0080f20006fbff0080f20006fbff0080f20006fbff0080f20006fbff0080f20006fbff0080f2000a06ff81ffc7ffff80f2000a06ff9cffe7ffff80f2000a06ff9ccce787ff80f2000a06ff9ccce733ff80f2000a06ff81cce733ff80 -f2000a06ff87cce703ff80f2000a06ff93cce73fff80f2000a06ff99c8e733ff80f2000a06ff9ce0e787ff80f20006fbff0080f20006fbff0080f20006fbff0080f20006fbff0080f20006fbff0080f20006fbff0080f20006fbff0080f20006fbff0080f20005edff018000070080ee00018000070080ee00018000070080 -ee00018000070080ee00018000070080ee00018000070080ee0001800009028000fff0000180000902800018f0000180000c038000183ffe3cf4000180000c0380001838fe66f4000180000d06800018303e6066f4000180000d068000183066607ef4000180000d0680001830666060f4000180000c0380001830fe66f400 -0180000d06800018303e3c3cf400018000070080ee00018000070080ee00018000070080ee00018000070080ee00018000070080ee00018000070080ee00018000070080ee00018000070080ee00018000140680003e001807f8fd00030f80060cfc000180001306800063001800c0fd000218c006fb000180001715800060 -1e3c00c1f9e1e1e018cf8f1c3c7c3c000080001715800060331800c1c333333018ccc60c66766600008000171580003e331800c181f3033018ccc60c6666600000800017158000033f1800c1833303f018ccc60c66663c000080001715800003301800c18333030018ccc60c66660600008000170e800063331800c1833333 -3018ccc60cfe660300008000171580003e1e0e00c181f1e1e00f8f838c3c663c000080000b0080f600000cfa000180000b0080f600000cfa00018000070080ee00018000070080ee00018000070080ee00018000070080ee00018000070080ee00018000070080ee00018000070080ee00018000120580007e000070fe0002 -1f800ef9000180001205800060000030fe000218c006f900018000140d800060667c30f1f9e018ccc61e1efb00018000140d80006066663199c33018ccc63333fb00018000140d80007c3c66319983301f8cc63330fb00018000140d8000601866319983f01e0cc63f1efb00018000140d8000603c66319983001b0cc63003 -fb00018000140d800060666631998330198dc63333fb00018000140d80007e667c30f181e018c7c61e1efb000180000b0080fe000060f2000180000b0080fe000060f200018000070080ee00018000070080ee00018000070080ee00018000070080ee00018000070080ee00018000150580007e000070fe00051f800e0003 -fcfc000180001505800060000030fe000518c006000060fc000180001715800060667c30f1f9e018ccc61e006078fdf70f008000171580006066663199c33018ccc6330060cce1dd99808000171580007c3c66319983301f8cc6330060ccc1999800800017158000601866319983f01e0cc63f0060fcc1998f008000171580 -00603c66319983001b0cc6300060c0c199818080001715800060666631998330198dc6330060ccc19999808000171580007e667c30f181e018c7c61e006078c1998f0080000b0080fe000060f2000180000b0080fe000060f200018000070080ee00018000070080ee00018000070080ee00018000070080ee000180000700 -80ee00018000130580007e000070fe00031f80000cfa000180001305800060000030fe00031800000cfa00018000140d800060667c30f1f9e0180f0f1e1efb00018000140d80006066663199c3301819998c33fb00018000140d80007c3c66319983301f0f980c30fb00018000140d8000601866319983f01819980c1efb00 -018000140d8000603c66319983001819980c03fb00018000140d8000606666319983301819998c33fb00018000140d80007e667c30f181e0180f8f071efb000180000b0080fe000060f2000180000b0080fe000060f200018000070080ee00018000070080ee00018000070080ee00018000070080ee00018000070080ee00 -0180000f08800063000030001860f6000180000f08800063000030001860f6000180001108800063333e3e1e3c7cfd3cfa00018000110880006333333b331876fd66fa00018000120280007ffd3305186666606660fa000180001202800063fd330518667e3c7e3cfa000180001202800063fd3305186660066006fa000180 -000f02800063fd330018fc66fa0001800011088000631f3e331e0e66fd3cfa000180000b048000000330f2000180000b048000003330f2000180000a038000001ef100018000070080ee00018000070080ee00018000070080ee00018000070080ee000180000e0780007e00007000c0f5000180000c05800060000030f300 -0180000f08800060667c30f1c7c0f6000180000f0880006066663198c760f6000180000f0880007c3c6630f8c660f6000180000f0880006018663198c660f6000180000f088000603c663198c660f6000180000f0880006066663198c660f6000180000f0880007e667c30f8c660f6000180000b0080fe000060f200018000 -070080ee00018000070080ee00018000070080ee00018000070080ee00018000070080ee00018000070080ee00018000070080ee0001800005edff01800000ff0000}} -\par \pard \s20\qc\fi200\ri-40\sa120\keep\keepn\widctlpar\tqr\tx1600 Fig. 9: The rule menu. -\par \pard \s20\fi-280\li280\sa120\widctlpar {\i Trace} -\par \tab activates or deactivates the rule trace. If the menu entry is marked with a hook, the rule trace is deactivated. All operations that have been set by selecting the menu entry {\i Set Trace Options} will remain. -\par {\i Set Rule Trace Options} -\par \tab when this menu entry is selected, a pop-up menu to regulate the rule trace behavior will appear on the screen. By using {\i - Exit -} it is possible to leave the menu. -\par \pard \s20\qc\li360\sa120\widctlpar {\fs20 {\pict\macpict\picw306\pich191\picwgoal6120\pichgoal3820 -0ba40000000000bf0132001102ff0c00fffe000000480000004800000000000000bf0132000000000001000a0000000000bf0132009980280000000000bf013200000000000000000048000000480000000000010001000100000000003254a400000000000065b4802700010000ffffffffffff0001000000000000000000 -0000bf01320000000000bf01320040000a0000000000bf013208000fddff02f8000008001fddff02fc000008003fddff02fe000007007fdcff01000007007fdcff01800019f8ff091ffcffffcfe0ffe7ffc0fdff03e1ffe73ff6ff01c00019f9ff0afe6ffcffffcfe67fe7fff3fdff02ccffe7f5ff01c0001df9ff14fe7e1c -e1e387e666670ff3930f1e1fccc1c3387078f8ff01c0001ef9ff11fe3ccccccdcfe6666667f38ee66ccfcccce7fe33007ff9ff01c0001cf8ff131ccccccfcfe0e66667f39f067ccfcccce7333331f8ff01c0001cf8ff138c0cc0cfcfe6666607f39e667c0fcccce7333338f8ff01c0001df8ff01ccfcfecf0fe666667ff39e -667cffcccce733333c7ff9ff01c0001ef9ff15fecceccecdcfe6666677f39e666cefcccce73333367ff9ff01c0001cf8ff131e1ce1e3e7e670670ff39f071e1fe1c1f3387338f8ff01c00009e9ff00cff4ff01c00009e9ff00cff4ff01c00005dbff01c00005dbff01c00005dbff01c000070080dc000140000700bfdcff01 -40000900a0de0003800140000900a0de0003810140000d04a0003e0082e20003828140000d04a000200002e20003844140000d04a000208887e20003882140000f06a3e03c508200f8e40003901140000d04a000202082e20003a00940000d04a000205082e20003f83d40000e05a0003e888180e30003882140000900a0de -0003882140000900a0de0003882140000900a0de00038fe140000900a0de0003800140000900a0de0003800140001108a0800000220020003ee60003ffff40001108a08000002000200008e60003ffff4000140ba08f3c71e21e71c008b1e71ce90003c00340001403a08aaa8afe22042008ca28a2e90003c0034000140ba0 -8aaafa222223e00882283ee90003c0034000140ba08aaa822226220008826820e90003c0034000140ba08aaa79e21a19e00881a79ee90003c00340000900a0de0003c00340000900a0de0003c00340000900a0de0003c00340000900a0de0003c00340000900a0de0003c00340001103a3c00080fd000180f8e70003c00340 -001103a2200080fd00018020e70003c0034000150ca2279c91eb1c8ac78022c79c70ea0003c0034000150ca3c8a2a22ca28b28802328a288ea0003c0034000150ca228a0e228228a28802208a0f8ea0003ffff4000150ca229a09228229a28802209a080ea000391114000150ca3c69e89e81c6a278022069e78ea0003c445 -40000d00a0fe000020e20003911140000d04a0000001c0e20003c44540000900a0de0003911140000900a0de0003c44540000900a0de0003911140001108a1c000808000080f80e60003c44540001007a220008000000802e5000391114000130aa2073cf08b1c78022c79c7e80003c4454000140ba208aa888ca28802328a -2880e9000391114000140ba208aa8888be8802208a0f80e90003c4454000130aa228aa8888a08802209a08e8000391114000140ba1c72af0889e78022069e780e90003c44540000900a0de0003911140000900a0de0003c44540000900a0de0003911140000900a0de0003c44540000900a0de0003911140000900a0de0003 -c44540000900a0de0003911140000900a0de0003c44540000900a0de0003911140000900a0de0003c44540000900a0de0003911140000900a0de0003c44540000900a0de0003911140000900a0de0003c44540000900a0de0003911140000900a0de0003c44540000900a0de0003911140001209a22000800008200f0020e7 -0003c44540001209a3600080000820088020e7000391114000140ba2a7ac9007882008a221c780e90003c4454000130aa228b2a00888200f222228e8000391114000130aa228a0e008882008a223e7e80003c4454000140ba229a09009882008a6220080e9000391114000130aa226a088068820089a21efe80003c4454000 -0900a0de0003911140000900a0de0003c44540000900a0de0003911140000900a0de0003c44540000900a0de0003911140001007a1c008000200f002e50003c44540001007a220080002008802e50003911140001209a2070871c7008a221c78e70003c44540001209a1c8888a2200f2222280e70003911140001209a02f88 -fa02008a223e70e70003c44540001209a228088202008a622008e70003911140001209a1c78879e18089a21ef0e70003c44540000900a0de0003911140000900a0de0003c44540000900a0de0003911140000900a0de0003c44540000900a0de000391114000130aa220022060007002000082e80003c4454000130aa36002 -0080008802000080e8000391114000150ca2a71e21c88081c21c71c21cb0ea0003c4454000150ca228a2208880722222888222c8ea000391114000150ca228a22088800be23e80822288ea0003c4454000150ca228a22088808a022080822288ea000391114000150ca2271e20878071e21e78621c88ea0003c44540000d00 -a0fd000080e30003911140000d00a0fe000007e20003c44540000900a0de0003911140000900a0de0003c44540000900a0de0003911140000900a0de0003c44540000900a0de0003911140000900a0de0003c44540000900a0de0003911140000900a0de0003c44540000900a0de0003911140000900a0de0003c445400009 -00a0de0003911140000900a0de0003c44540000900a0de0003911140000900a0de0003c44540000900a0de0003911140001108a1c000008008000f80e60003c44540001007a220000080080002e5000391114000130aa2073cf0871c70022c79c7e80003c44540001302a208aafd880402328a2880e9000391114000140ba2 -08aa888f88f802208a0f80e90003c4454000130aa228aa8888088002209a08e8000391114000140ba1c72af0878678022069e780e90003c44540000c03a0000080e10003911140000c03a0000080e10003c44540000900a0de0003911140000900a0de0003c44540000900a0de0003911140001108a3c008000022000080e6 -0003c44540001108a22008000022000080e60003911140001108a2288871e02279c780e60003c44540001108a3c8888a0022822880e60003911140001108a22888f9c02273e880e60003c44540001108a229888020220a0880e60003911140001108a226887bc01cf1e780e60003c44540000900a0de0003911140000900a0 -de0003c44540000900a0de0003911140000900a0de0003c44540000900a0de0003911140001108a3c00800003e008002e60003c44540001108a22008000008000002e60003911140001108a2288871e008b0871ee60003c44540001108a3c8888a0008c888a2e60003911140001108a22888f9c008808fa2e60003c4454000 -1108a22988802008808822e60003911140001108a226887bc00880879ee60003c44540000900a0de0003911140000900a0de0003c44540000900a0de0003911140000900a0de0003c44540000900a0de0003911140000900a0de0003c44540000900a0de0003911140000900a0de0003c44540001a11a3efbefbefbefbefbe -fbefbefbefbefbefbeef0003911140000900a0de0003c44540000900a0de0003911140000900a0de0003ffff40000900a0de0003800140000900a0de0003800140000900a0de00038fe140000900a0de0003882140000900a0de000388214000140ba3c20000800003c008000f80e9000388214000130aa220000080000220 -080002e80003f83d4000160da2221ef087a202288870022c79c7eb0003a0094000170ea222208888a203c8888802328a2880ec000390114000170ea2221c8888a2022888f802208a0f80ec000388214000160da222028889a20229888002209a08eb000384414000170ee3c23cf0869e02268878022069e780ec00038281c0 -000e05600000800002e30003810180000e0560000080001ce300038001800007003fdcff01800008001cdd00020f0000080007ddff00f8ff0000ff0000}} -\par \pard \s20\qc\fi200\ri-40\sa120\keep\keepn\widctlpar\tqr\tx1600 Fig. 10: Setting the rule trace behavior. -\par \pard \s20\li360\sa120\widctlpar The trace can be directly, i.e. interactively, displayed in the trace window or stored in an internal data structure. In order to set this behavior the first three menu entries are used: -\par -\par \pard \s20\fi-280\li280\sa120\widctlpar {\i Immediate Trace} -\par \tab the trace will only appear in the trace window. This is done interactively, i.e. during a dialog session with an expert system. -\par {\i Background Trace\}} -\par \tab the trace will only be stored in an internal data structure, which can be updated after the dialog by using the menu entries {\i Complete Trace}, {\i Rules Used}, {\i Rules Tried} and {\i Display Rule Trace} and displayed in the trace window. -\par {\i Combined Trace} -\par \tab the trace can be displayed interactively as well as stored in internal data structures. -\par \pard \s20\li360\sa120\widctlpar The rules that are to be included in the trace can be specified by the menu entries {\i Mark all Rules}, {\i Select Rules} and {\i Modify Selection}. -\par \pard \s20\fi-280\li280\sa120\widctlpar {\i Mark all Rules} -\par \tab marks all rules of all rule sets to be included in the trace. -\par {\i Select Rules} -\par \tab this menu entry serves to mark the rules to be included in the trace. At the beginning, the progra -mmer will find a menu containing all rule sets from which to choose one rule set. If only one rule set is known to the system, this menu will be omitted. Subsequently, the menu illustrated in Figure 11 will appear. -\par \pard \s20\qc\li360\sa120\widctlpar {\fs20 {\pict\macpict\picw306\pich80\picwgoal6120\pichgoal1600 -05880000000000500132001102ff0c00fffe000000480000004800000000000000500132000000000001000a00000000005001320099802800000000005001320000000000000000004800000048000000000001000100010000000000325648000000000000665a888000010000ffffffffffff0001000000000000000000 -000050013200000000005001320040000a000000000050013208000fddff02f8000008001fddff02fc000008003fddff02fe000007007fdcff01000005dbff018000270bffeff7fff9fffffe7fffff1ffcff003ffeff123fc3c3be8107873ffc08133fe070efb07fc000270bffe7e7fff9fffffe7ffffe7ffcff003ffeff12 -3f9d999ee733333ffcfe733ffcee67b33fc0002927ffe3c70e499f926670f1fc3261c01fc933387f8f0e1f9f998ee733333ffcfe733ff9fe63b33fc0002906ffe186e6393f8efe661dfe71cccccfc733333f36673f9f9986e733333ffc1e733ff0fe61b33fc0002927ffe82706787f9e666663fe73cccccfcf33333f1e673f -9f99a2e707333e0fce70307e7ce8b33fc0002927ffec666678ff9e666071fe73cccccfcf33303f8e073f9f99b0e733333fffce733ffe79ec333fc0002927ffeee666787f9e6667f8fe73cccccfcf3333ffc67f3f9f99b8e733333fffce733ffe73ee333fc0002927ffefe666793f9e66676cfe73cccccfcf3333bf66773f9d -99bce733333ffdce733fee67ef333fc0002927ffefe706799f9f0670f1fe73e1cccfcf83387f8f0f9fc3c3bee7338707fe1e733ff0e06fb07fc00005dbff01c00005dbff01c00005dbff01c00005dbff01c00005dbff01c000070080dc000140000700bfdcff0140000900a0de0003800140000900a0de0003810140000f01 -a1c8fe00010820e40003828140000f01a228fe00010820e40003844140000f06a20f1ca8078820e40003882140000f06a1c8a2a8088820e40003901140000f06a028a2a8088820e40003a00940000f06a228a2a8098820e40003f83d40000f06a1c89c50068820e40003882140000900a0de0003882140000900a0de000388 -2140000900a0de00038fe140000900a0de0003800140000900a0de0003800140000f06a2220200000820e40003ffff40000f06a2200200000820e40003800140000f06a2221e70078820e40003800140001209a3e22288088820000008e70003800140001209a22222f808882000000ce70003800140001209a22222800988 -2000000ee70003800140001209a2221e7806882000000fe70003800140000e00a0f900010f80e80003800140000e00a0f900010fc0e80003800140000e00a0f900010fe0e80003800140000e00a0f900010ff0e80003800140000e00a0f900010f80e80003800140001304a3e0000080fe0002200d80e80003800140001304 -a080000080fe00022008c0e8000380014000130aa0871e788700f1eb2400c0e8000380014000130aa088a2888880aa2ca80060e8000380014000130aa088a2888f80aa28380060e80003800140001108a088a2888800aa6824e60003800140001108a0871e788780a9a822e60003800140000c03a0000208e1000380014000 -0c03a0001c70e10003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140000c03a3e00820e10003800140000c03a2000020e10003800140000c03a2088870e10003800140000c03a3c50820e10003ffff40000c03a2020820e10003800140000c03a2050820e10003800140000c03a3e88818 -e100038fe140000900a0de0003882140000900a0de0003882140000900a0de0003882140000900a0de0003f83d40000900a0de0003a00940000900a0de0003901140000900a0de0003882140000900a0de0003844140000900e0de00038281c000090060de00038101c000090060de00038001800007003fdcff0100000800 -1cdd00020e0000080007ddff00fcff000000ff0000}} -\par \pard \s20\qc\fi200\ri-40\sa120\keep\keepn\widctlpar\tqr\tx1600 Fig. 11: The menu to mark rule sets. -\par \pard \s20\fi-280\li280\sa120\widctlpar \bullet \tab {\b\i Show all: }all rules of the rule set previously selected are marked. -\par \bullet \tab {\b\i Hide all:} the marks of all rules of the rule set previously selected are removed. -\par \bullet \tab {\b\i Toggle mark:} provides a menu that lists all rules of the rule set previously selected (cf. Figure 12). -\par \pard \s20\qc\li360\sa120\widctlpar {\fs20 {\pict\macpict\picw306\pich162\picwgoal6120\pichgoal3240 -0b3c0000000000a20132001102ff0c00fffe000000480000004800000000000000a20132000000000001000a0000000000a20132009980280000000000a2013200000000000000000048000000480000000000010001000100000000003255e400000000000066dd000000010000ffffffffffff0001000000000000000000 -0000a201320000000000a201320040000a0000000000a20132080007ddff02fc000008001fddff02fe000007003fdcff01000007007fdcff01800007007fdcff0180002800f3feff009ffdff02e7ff8ffeff04f9fffffc7ffeff1087877d020f0e7ff810267fc0e1df60c0002700f3feff009ffdff02e7ff3ffeff03f9ffff -f9fdff103b333dce66667ff9fce67ff9dccf6640002927e1c3c1c19c3f803c39267e1c393e4999c3c7f0c987007f3f331dce66667ff9fce67ff3fcc76640002800f3fd99229f999b98e4ff3998fe3999999bf9c733333f3f330dce66667ff83ce67fe1fcc36640002800f3fd99229f999c19e1ff3999fe7999998ff9cf3333 -3f3f3345ce0e667c1f9ce060fcf9d16640002900f3fe9901981ffe991ee3ff3999fe799981c7f9cf33333f3f3361ce66667fff9ce67ffcf3d86640002800f3fd9900fffe991ee1ff3999fe79999fe3f9cf33333f3f3371ce66667fff9ce67ffce7dc6640002800f3fd9900dffe991ee4ff3999fe79999db3f9cf33333f3b33 -79ce66667ffb9ce67fdccfde6640002927f9c3c1c19c3f999c19e67f3c39fe7c19c3c7f9cf87333f87877dce670e0ffc3ce67fe1c0df60c0000a03fffff9f9dfff01c0000a03ffffb9b9dfff01c0000a03ffffc3c3dfff01c00005dbff01c00005dbff01c000070080dc00014000070080dc00014000070080dc000140000d -02800003faff00f0e6000140000d0280000ffaff00fce6000140000d0280001ffaff00fee6000140000d0280003efa00001fe600014000130280003bfaff00f7fd00003ffafff200014000160280007cfa00010f80fe000040fa000080f3000140001e0b8000740003c0002080000b80fe000840001c800008000080f30001 -40001e0b800074000220002080000b80fe0008400022800008000080f3000140001e0b8000740002270021c0000b80fe0008400022f1cb1c000080f3000140001e0b800074000228802080000b80fe000840003e8a2c88000080f3000140001e0b800074000228802080000b80fe00084000228a2808000080f3000140001e -0b800074000228802080000b80fe00084000228a2808000080f3000140001e0b8000740003c7002060000b80fe0008400022f1c806000080f300014000160280007cfa00010f80fe000040fa000080f300014000130280003bfaff00f7fd00003ffafff2000140000d0280003efa00001fe6000140000d0280001ffaff00fe -e6000140000d0280000ffaff00fce6000140000d02800003faff00f0e600014000070080dc00014000070080dc000140000700bfdcff0140000900a0de0003800140000900a0de0003810140001f02a3c008fd000908000808000140002082fc000302000080f70003828140001c02a22008fd0009080008080003e0000082 -f9000080f7000384414000251ca2288871e03c7ac91c780f2201402a20820071c722b0022c01cb1e71c0fa000388214000251ca3c8888a002a8b2a228808a203e02a2082008a28a2c80232008ca28a20fa000390114000251ca22888f9c02a8a0e3e8808a201402a2082008a082280022200882283e0fa0003a0094000241b -a2298880202a9a09208808a200002a2082008a082680022200882682f90003f83d4000251ca226887bc02a6a089e780f1e00001420820071e79a80022200681a79e0fa0003882140000d00a0f7000002e90003882140000d00a0f700001ce90003882140000900a0de00038fe140000900a0de0003800140000900a0de0003 -800140001108a0003c8a0f8071c884e60003ffff40001108a000228a08008a2c8ce60003800140001108a000228a0800822a84e60003800140001108a0003c8a0f3e822984e60003800140001108a000228a0800822884e60003800140001108a000228a08008a2884e60003800140001108a0002273ef8071c884e6000380 -0140000900a0de0003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140001108a0003c8a0f8071c89ce60003800140001108a000228a08008a2ca2e60003800140001108a000228a0800822a82e60003800140001108a0003c8a0f3e822984e60003800140001108 -a000228a0800822888e60003800140001108a000228a08008a2890e60003800140001108a0002273ef8071c8bee60003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140001108a0003c8a0f8071c89ce60003800140001108a000228a08 -008a2ca2e60003800140001108a000228a0800822a82e60003800140001108a0003c8a0f3e82298ce60003800140001108a000228a0800822882e60003800140001108a000228a08008a28a2e60003800140001108a0002273ef8071c89ce60003800140000900a0de0003800140000900a0de0003800140000900a0de0003 -800140000900a0de0003800140000900a0de0003800140001108a0003c8a0f8071c884e60003800140001108a000228a08008a2c8ce60003800140001108a000228a0800822a94e60003800140001108a0003c8a0f3e8229a4e60003800140001108a000228a08008228bee60003800140001108a000228a08008a2884e600 -03800140001108a0002273ef8071c884e60003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140001108a0003c8a0f8071c8bee60003800140001108a000228a08008a2ca0e60003800140001108a000228a0800822abce6000380014000 -1108a0003c8a0f3e822982e60003800140001108a000228a0800822882e60003800140001108a000228a08008a28a2e60003800140001108a0002273ef8071c89ce60003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140001108a0003c -8a0f8071c89ce60003800140001108a000228a08008a2ca0e60003800140001108a000228a0800822abce60003800140001108a0003c8a0f3e8229a2e60003800140001108a000228a08008228a2e60003800140001108a000228a08008a28a2e60003800140001108a0002273ef8071c89ce60003800140000900a0de0003 -800140000900a0de0003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140001108a0003c8a0f8071c8bee60003800140001108a000228a08008a2c82e60003800140001108a000228a0800822a82e60003800140001108a0003c8a0f3e822984e60003800140001108a000228a0800822888 -e60003800140001108a000228a08008a2888e60003800140001108a0002273ef8071c888e60003800140000900a0de0003ffff40000900a0de0003800140000900a0de0003800140000900a0de00038fe140000900a0de0003882140001108a0003c8a0f8071c89ce60003882140001108a000228a08008a2ca2e600038821 -40001108a000228a0800822aa2e60003f83d40001108a0003c8a0f3e82299ce60003a00940001108a000228a08008228a2e60003901140001108a000228a08008a28a2e60003882140001108a0002273ef8071c89ce60003844140000900a0de0003828140000900a0de0003810140000900a0de0003800140000700bfdcff -014000070080dc00014000070080dc00014000070080dc000140000700c0dc0001c000070040dc0001c000080060dd0002018000080030dd000203000008001cdd00020e0000080007ddff00fcff000000ff0000}} -\par \pard \s20\qc\fi200\ri-40\sa120\keep\keepn\widctlpar\tqr\tx1600 Fig. 12: Menu to mark rules. -\par \pard \s20\li360\sa120\widctlpar -\par The menu in Figure 12 can be used to select an arbitrary number of rules, whose marks are to be toggled. Rules not marked will be marked and those marked will lose theirs. -\par \pard \s20\fi-280\li280\sa120\widctlpar \bullet \tab {\b\i Exit:} to leave the menu. -\par {\b Note:} When selecting this menu entry all marks will {\b automatically} be removed. -\par {\i Modify Selection} -\par \tab this menu entry can be used to modify the marks of rules. The dialog with the programmer will take place as described under {\i Select Rules}. When choosing this menu entry all the marks will {\b not} be deleted. -\par The next menu entries serve to filter and display the trace information internally stored. -\par {\i Complete Trace} -\par \tab the trace information will be displayed unfiltered. -\par {\i Rules Used} -\par \tab the trace will be filtered, with the result that the system will display only those rules that have been applied during the consultation. -\par {\i Rules Tried} -\par \tab the trace will be filtered, with the result that the system will display only those rules that have been tested during the consultation. -\par {\i Display Rule Trace} -\par \tab the trace will be displayed in the trace window. For this purpose, it will be filtered as previously chosen (cf. also {\i Complete Trace}, {\i Rules Used}, {\i Rules Tried}). -\par {\i Explore Rules} -\par \tab provides the option of a screen-oriented exploration of rule parts (cf. Figure 13). The exploration window is divided into two selection fields and one display field. -\par \pard \s20\qc\li360\sa120\keepn\widctlpar {\fs20 {\pict\macpict\picw510\pich322\picwgoal10200\pichgoal6440 \picscalex71\picscaley71 -15cc00000000014201fe001102ff0c00fffe0000004800000048000000000000014201fe000000000001000a00000000014201fe0099804000000000014201fe000000000000000000480000004800000000000100010001000000000032576c0000000000006779804000010000ffffffffffff0001000000000000000000 -00014201fe00000000014201fe0040000a00000000014201fe04c2ff00fc060080c300000c060080c300000c060080c300000c1002bf7ff7efff00fcee000003ecff00ec1b02804010ee000707c0060007c0000cfe0004c600000402e800000c2002bf4017efff08fc066006000600000cfe0004c000000606fe000003ecff -00ec1e02804010ee00120666663c060ccf8c78d8f1e63c7c070e3c7c66eb00000c2002bf4017efff01fc06fe6601060cfecc06e118c66666079efe660003ecff00ec1d02804010ee000507c66666078cfecc06c0f8c6666605f6fe66eb00000c2002bf4017efff14fc0666667e06078cccccc198c6666604e67e666603ecff -00ec1e02804010ee000506666660060cfecc09c198c666660446606666eb00000c2002bf4017efff06fc06666662060cfecc0ac198c66666040662666603ecff00ec1e02804010ee00120663e63c07cccf8c78c0f8663c6604063c663eeb00000c1402bf7ff7efff00fcfb00000cf5000003ecff00ec0a0080e600000cdf00 -000c060080c300000c060080c300000c04c2ff00fc060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c1301801ffeff00e0e7000003feff00fce700000c13018020fe000010e7000004fe000002e700000c13018040fe000008e7000008fe000001e700000c1e0c8043 -c00fc00807c00600038006ee0008087801f80100f800c0eb00000c1e0c80462003000806600600064006ee000808c400600100cc00c0eb00000c1f0c804603c30f080666663c06078fee000908c07861e100ccccc780ec00000c1f0680460663198806fe6602070cc6ee000508c0cc633100fecc00c0ec00000c1f0c8046e6 -63198807c66666038cc6ee000908dccc633100f8ccccc0ec00000c1f0c8046666319880666667e01cfc6ee000908cccc633100cccccfc0ec00000c1d0c8046666319880666666000cc06ee000508cccc633100fecceb00000c1f0c8046666319880666666204cc46ee000508cccc633100fecc0040ec00000c1f0c8043c3c3 -0f080663e63c038783ee000908787861e100cc7cc780ec00000c13018040fe000008e7000008fe000001e700000c13018020fe000010e7000004fe000002e700000c1301801ffeff00e0e7000003feff00fce700000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c0600bfc3ff00 -ec0e00a0e50002020007e4000210002c0e00a0e50002020407e4000210202c230ea08888f8872023ef80fbe88071c8bcf30009020a071e4507c038e442eb000210502c230ea08c882088a02028008088808a2ca2f3000902110711450400451646eb000210882c230ea08a882088a0204800f08880082aa2f3000902208711 -450400411542eb000211042c230ea08988208fa0208f3e088fbe3049a2f300090240471e45079f4114c2eb000212022c230ea088882088a02108000888800888a2f3000902802711450400411442eb000214012c230ea088882088a02208008888808908a2f3000903e0f711450400451442eb00021f07ac230ea088882088 -be23ef8070888073e8bcf300090220871139f7c038e442eb000211042c0e00a0e50002022087e4000211042c0e00a0e50002022087e4000211042c0e00a0e50002023f87e4000211fc2c0e00bfe5ff02fe0007e4000210002c0e00bfe5ff02fe0007e4000210002c1e0cbe38dd0438dffc105dfe38dd0feeff061e4507c038 -e44eeb00021fffec210cbdd74dddd75ffdfdddfdd74d77f1ff09fe000711450400451651eb000210002c210cbdf755ddd75ffc3dddffdf5577f1ff09fe000711450400411541eb000210002c210cbdf759dc375f07ddc1073ed977f1ff09fe00071e45079f4114c2eb000210002c210cbdf75dddd75fffddddffdddd77f1ff -09fe000711450400411444eb000210002c210cbdd75dddd75ffdddddfddbdd77f1ff09fe000711450400451448eb000210002c210cbe38ddddd8c1fe3dddfe305d0ff1ff09fe00071139f7c038e45feb000210002c0e00bfe5ff02fe0007e4000210002c0e00bfe5ff02fe0007e4000210002c0e00bfe5ff02fe0007e40002 -10002c0e00a0e50002020007e4ff02f0002c0e00a0e50002020007e4ff02f0002c1500a0e50009020007e1baf83fc71bb1ebff02f0002c1500a0e50009020007eebafbffbae9aeebff02f0002c1500a0e50009020007eebafbffbeeabeebff02f0002c1500a0e50009020007e1baf860beeb39ebff02f0002c1500a0e50009 -020007eebafbffbeebbeebff02f0002c1500a0e50009020007eebafbffbaebaeebff02f0002c1500a0e50009020007eec6083fc71bb1ebff02f0002c0e00a0e50002020007e4ff02f0002c0e00a0e50002020007e4ff02f0002c0e00a0e50002020007e4ff02f0002c0e00a0e50002020007e4000210002c0e00a0e5000202 -0007e4000210002c1500a0e500090200071e4507c038e042eb000210002c1500a0e5000902000711450400451446eb000210002c1500a0e500090200071145040041164aeb000210002c1500a0e500090200071e45079f411752eb000210002c1500a0e500090200071145040041179feb000210002c1500a0e50009020007 -114504004517c2eb000210002c1500a0e500090200071139f7c038e7e2eb000210002c1300a0e50002020007fc000107f0eb000210002c1300a0e50002020007fc000107f8eb000210002c1300a0e50002020007fc000107c0eb000210002c1300a0e50002020007fc000106c0eb000210002c1300a0e50002020007fc0001 -0460eb000210002c1500a0e500090200071e4507c038e06feb000210002c1500a0e5000902000711450400451630eb000210002c1500a0e5000902000711450400411536eb000210002c1500a0e500090200071e45079f4114c1eb000210002c1500a0e5000902000711450400411441eb000210002c1500a0e50009020007 -11450400451451eb000210002c1500a0e500090200071139f7c038e44eeb000210002c0e00a0e50002020007e4000210002c0e00a0e50002020007e4000210002c0e00a0e50002020007e4000210002c0e00a0e50002020007e4000210002c0e00a0e50002020007e4000210002c1500a0e500090200071e4507c038e44eeb -000210002c1500a0e5000902000711450400451650eb000210002c1500a0e500090200071145040041155eeb000210002c1500a0e500090200071e45079f4114d1eb000210002c1500a0e5000902000711450400411451eb000210002c1500a0e5000902000711450400451451eb000210002c1500a0e500090200071139f7 -c038e44eeb000210002c0e00a0e50002020007e4000210002c0e00a0e50002020007e4000210002c0e00a0e50002020007e4000210002c0e00a0e50002020007e4000210002c0e00a0e50002020007e4000210002c1500a0e500090200071e4507c038e45feb000210002c1500a0e5000902000711450400451641eb000210 -002c1500a0e5000902000711450400411541eb000210002c1500a0e500090200071e45079f4114c2eb000210002c1500a0e5000902000711450400411444eb000210002c1500a0e5000902000711450400451444eb000210002c1500a0e500090200071139f7c038e444eb000210002c0e00a0e5000203ffffe400021fffec -0e00a0e50002020007e4000210002c0e00a0e50002020007e4000210002c0e00a0e50002023f87e4000211fc2c0e00a0e50002022087e4000211042c1500a0e500090220871e4507c038e44eeb000211042c1500a0e5000902208711450400451651eb000211042c1500a0e5000903e0f711450400411551eb00021f07ac15 -00a0e500090280271e45079f4114ceeb000214012c1500a0e5000902404711450400411451eb000212022c1500a0e5000902208711450400451451eb000211042c1500a0e500090211071139f7c038e44eeb000210882c0e00a0e50002020a07e4000210502c0e00a0e50002020407e4000210202c0e00a0e50002020007e4 -000210002c0600bfc3ff00ec060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c0d07804f2283e01c7227ca00000c0e088088a28200228b2880cb00000c0e088108a28200208aa080cb00000c0d07810f2283cfa08a63ca00000c0e088108a28200208a2080cb00000c0e088088a28200 -228a2880cb00000c0d0780489cfbe01c7227ca00000c060080c300000c060080c300000c060080c300000c0802800008c500000c251f80011c722f0011cf3cf1c71c88889c01c73c03efa201c8be01c722f0073e03e1e200000c251f80011c722f0011cf3cf1c71c88889c01c73c03efa201c8be01c722f0073e03e1e20000 -0c262080022a8b28802228a28a28a2888ca20228a20202220228a00228b2880888020080e300000c26208004288aa8804228a28a28a0888aa00208a203c2220228a00020aa880808020040e300000c262080041cfa688043ef3cf22fa0f889a6fa0fbc00223efbe8bcf8c1268be70803c040e300000c262080040a8a288042 -28208a28a08888a20208a20022220228a0002222880088020040e300000c262080022a8a28802228208a28a28888a20228a2022222022520022422880888020080e300000c251f80011c8a2f0012282089c89c88889c01c8a201c22202223e01cfa2f0070803e1e200000c0802800008c500000c060080c300000c060080c3 -00000c060080c300000c210080fc0017108700f3ef00fbe880722f8071c8bc01cf80fa001cf80f88e000000c210080fc00172088808a08808088808a28008a2ca2022200220022200804e000000c210080fc00174088008a0880f088808a2800082aa2020200220020200802e000000c210080fc001740873ef3c880088fbe -fa2f3e3049a2f9c200220f9c23ef02e000000c210080fc00174080808a08800888808a28000888a2002200220002200802e000000c210080fc00172088808a08808888808948008908a2022200220022200804e000000c210080fc00171087008bef00708880888f8073e8bc01c20023e01c200f88e000000c060080c30000 -0c060080c300000c060080c300000c060080c300000c280080fc001e12273e00473cf3c71c72222270071cf00fbe880722f8071c8bc00e7c044410e700000c280080fc001e2328880088a28a28a28a22328808a28808088808a28008a2ca201110064208e700000c280080fc001e42a8880108a28a28a282222a800822880f -088808a2800082aa201010054104e700000c280080fc001e426888010fbcf3c8be83e2269be83ef00088fbefa2f3e3049a2fce1004c104e700000c280080fc001e4228880108a08228a28222228808228800888808a28000888a200110044104e700000c280080fc001e2228880088a08228a28a22228808a2880888880894 -8008908a201110044208e700000c280080fc001e1227080048a0822722722222700722880708880888f8073e8bc00e10044410e700000c060080c300000c060080c300000c060080c300000c060080c300000c290080fc001f12273e00473cf3c71c72222270071cf00fbe880722f8071c8bc00e7c03841040e800000c2900 -80fc001f2328880088a28a28a28a22328808a28808088808a28008a2ca20111004420820e800000c290080fc001f42a8880108a28a28a282222a800822880f088808a2800082aa20101004010410e800000c290080fc001f426888010fbcf3c8be83e2269be83ef00088fbefa2f3e3049a2fce1003810410e800000c290080 -fc001f4228880108a08228a28222228808228800888808a28000888a20011000410410e800000c290080fc001f2228880088a08228a28a22228808a28808888808948008908a20111004420820e800000c290080fc001f1227080048a0822722722222700722880708880888f8073e8bc00e1003841040e800000c060080c3 -00000c060080c300000c060080c300000c0802800008c500000c2e2880011cfa2f9c8bef80100000fbe880722f8071c8bc01cf8001cfbe01cf3efa20047d000e7c07c41040eb00000c2e2880022a8148228888002040008088808a28008a2ca20222000228080228a08320041100111004020820eb00000c2e288004288088 -20888800408000f088808a2800082aa20202002208080208a082a0001100101004010410eb00000c2e2880041cf08f20888f00410f80088fbefa2f3e3049a2f9c20001cf08fa6f3cf260001107ce11f7810410eb00000c2e2880040a8088208888004080000888808a28000888a20022000028080228a08220001100011004 -010410eb00000c2e2880022a8148228888002040008888808948008908a20222000228080228a08220001100111004020820eb00000c2e2880011cfa2f9c708f80100000708880888f8073e8bc01c20021cf8801c8befa200011f00e1007c41040eb00000c0802800008c500000c060080c300000c060080c300000c060080 -c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c3 -00000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300 -000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c30000 -0c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c -060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c06 -0080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c0600c0c300000c04c2ff00fc0000ff0000}} -\par \pard \s20\qc\fi200\ri-40\sa120\keep\keepn\widctlpar\tqr\tx1600 Fig. 13: The screen during the rule exploration. -\par \pard \s20\li360\sa120\widctlpar The selection field {\i Rule Sets} will display the names of all rule sets. The selection field {\i Rules} will display all rule names of the rule set selected in {\i Rule Sets} -. A rule once selected will be represented in the display field. -\par There is one button entitled {\i GoTo} for each of the two selection fields. When the programmer clicks on one of these buttons, the editor will be activated. It will be positioned at the definition of the construct that is seclected in t -he corresponding selection field. When pressing the {\i GoTo} button in the {\i Rule} selection field (cf. Figure 13), the editor is positioned at the definition of the rule {\f118 RULE-CON3}. -\par \pard \s20\fi-280\li280\sa120\widctlpar {\i Explore Rule Terms} -\par \tab enables a screen-oriented exploration of the rule part about the search for terms and elements (cf. Figure 14). Terms in this context correspond to conditions in the condition part of a rule. The rule -\par \pard\plain \s29\ri-565\keep\widctlpar\tx880\tx1740\tx2620\tx3480\tx4320\tx5220\tx6060\tx6940\tx7780 \f3\fs20\lang1031 \tab (rule-2 -\par \tab ($and -\par \tab (holiday-application number-days > (applicant holiday-entitlement))) -\par \tab ($conclude -\par \tab (holiday-application status = not-granted) -\par \tab (holiday-application :add-status -\par \tab "~%Days applied for > holiday-entitlement."))) -\par \pard\plain \s20\li360\sa120\widctlpar \f8\lang1031 -\par for example, contains the three terms -\par \pard\plain \s29\ri-424\keep\widctlpar\tx880\tx1740\tx2620\tx3480\tx4320\tx5220\tx6060\tx6940\tx7780 \f3\fs20\lang1031 \tab (holiday-application number-days > (applicant holiday-entitlement))) -\par \tab (holiday-application status = not-granted) -\par \tab (holiday-application :add-status -\par \tab "~%Days applied for > holiday-entitlement."))) -\par \pard\plain \s20\li360\sa120\widctlpar \f8\lang1031 -\par and the elements -\par \pard\plain \s29\keep\widctlpar\tx880\tx1740\tx2620\tx3480\tx4320\tx5220\tx6060\tx6940\tx7780 \f3\fs20\lang1031 \tab holiday-application -\par \tab number-days -\par \tab status -\par \tab ... -\par \pard\plain \s20\li360\sa120\widctlpar \f8\lang1031 -\par The exploration window has five selection fields, one display field and one option switch consisting of three alternatives. -\par \pard \s20\qc\li360\sa120\widctlpar {\fs20 {\pict\macpict\picw510\pich325\picwgoal10200\pichgoal6500 \picscalex84\picscaley85 -1fdc00000000014501fe001102ff0c00fffe0000004800000048000000000000014501fe000000000001000a00000000014501fe0099804000000000014501fe00000000000000000048000000480000000000010001000100000000003256fc00000000000068bf7fff00010000ffffffffffff0001000000000000000000 -00014501fe00000000014501fe0040000a00000000014501fe04c2ff00fc060080c300000c060080c300000c060080c300000c1002bf7ff7f1ff0080e900000fefff00ec1f02804010f00004f800c001f8fd000b1f0000180000031800001008eb00000c2402bf4017f1ff0580cc00c00060fd000618000018000003fe0001 -1818fe00000fefff00ec2302804010f00017ccccc78061e36ff87018333f18f1b3c798f1f01c38f1f198ee00000c2502bf4017f1ff0080fecc15c063338cccc81833319999c4631999981e799999980fefff00ec2302804010f00017f8ccccc063330ccce01e3331999983e319999817d9999998ee00000c2502bf4017f1ff -1980cccccfc063f30ccc70181e31999986631999981399f999980fefff00ec2202804010f000fecc140063030ccc38183331999986631999981119819998ee00000c2502bf4017f1ff0080fecc154063130ccc981833319999866319999810198999980fefff00ec2302804010f00017cc7cc78061e30ccc701f333f18f183 -e198f1981018f198f8ee00000c1402bf7ff7f1ff0080f6000030f500000fefff00ec0a0080e3000030e200000c060080c300000c060080c300000c04c2ff00fc060080c300000c060080c300000c060080c300000c060080c300000c310b81c008000200f0020001c008f8000103e2fe000008fe0000f8f6000101f0fc0006 -400400400001f1fe000004fe00000c2f0b822008000200880200022008f800010202fe000008fe000020f5000040fc000040fd00010101fe000004fe00000c340b82070871c7008a221c02071cf8000b02021cf1cb1c01cb0021c99ef70010439678038e58e3c458458f01010e78e58efe00000c340b81c8888a2200f22222 -01c888f8000b03c222aa2c88022c80222e55f70010445954045164444464465101e111551644fe00000c320b802f88fa02008a223e002f88f8000b02023eabe88802280023e815f7000447d0540411fc44065101011f55f444fe00000c340b8228088202008a6220022808f8000b020220aa0888022800220815f700104410 -5404114444c4444451010110550444fe00000c340b81c78879e18089a21e01c786f8000b03e21ea9e88601c80021e815f7000643d05403ce4433fe44064f01f10f54f443fe00000c0a0080cd000001f800000c0a0080cd00000ef800000c0600bfc3ff00ec1400a0ef0002200060ef000210003fefff02f0002c1400a0ef00 -02204060ef000210203fefff02f0202c3c0ea08888f8872023ef80fbe88071c8bcfd000d20a061cf3cf1c71c88889c01c79efa001710503fd820bbfc6e83fc71ba1ff183f83bba0ff1eef0502c3c0ea08c882088a02028008088808a2ca2fd000d21106228a28a28a2888ca2022851fa001710883fbbfbbbfbaebffbae9aef -eeeffefb92ffeeee70882c3c0ea08a882088a0204800f08880082aa2fd000d22086228a28a28a0888aa0020851fa000b11043f787bbbfbaebfffbeaafeef08fefbaaffefeeb1042c3c0ea08988208fa0208f3e088fbe3049a2fd000d240463ef3cf22fa0f889a6fa0fdefa001712023f7fbb82082e860e7db2e831effefbba -1831eed2022c3c0ea088882088a02108000888800888a2fd000d28026228208a28a08888a2020851fa001714013f7fbbbbfbaebfffbbbaeffeeffefbbafffeeef4012c3c0ea088882088a02208008888808908a2fd000d3e0f6228208a28a28888a2022851fa00021f07bffebb11fbb5bffbb7baefeeeffefbbaffeeeeff07 -ac3c0ea088882088be23ef8070888073e8bcfd000d220862282089c89c88889c01c851fa001711043fdc7bbbfbbb83fc60ba1ff1effefbba0ff1eef1042c1400a0ef0002220860ef000211043fefff02f1042c1400a0ef0002220860ef000211043fefff02f1042c1400a0ef000223f860ef000211fc3fefff02f1fc2c1400 -bfefff02e00060ef0002100030ef000210002c1400bfefff02e00060ef0002100030ef000210002c310cbe38dd0438dffc105dfe38dd0ff9ff04e08700f3eff300171ffff027df4403917c038e45e00e7c07c445f00e111fffec340cbdd74dddd75ffdfdddfdd74d77fbff07e0006088808a0880f400171000304404440451 -4004516510111001046d00111190002c340cbdf755ddd75ffc3dddffdf5577fbff07e0006088008a0880f4000b100030878444045140004155fe100801045500101150002c340cbdf759dc375f07ddc1073ed977fbff07e00060873ef3c880f4001710003080447df7d179f1824d17ce10010445e7ce1130002c340cbdf75d -ddd75fffddddffdddd77fbff07e0006080808a0880f4001710003080444404514000444510011001044500011110002c340cbdd75dddd75ffdddddfddbdd77fbff07e0006088808a0880f40002100030fe4411044a4004484510111001044500111110002c330cbe38ddddd8c1fe3dddfe305d0ffbff06e0006087008beff3 -001710003023844404447c039f45e00e10010445f00e1110002c1400bfefff02e00060ef0002100030ef000210002c1400bfefff02e00060ef0002100030ef000210002c1400bfefff02e00060ef0002100030ef000210002c1400a0ef0002200060ef0002100030ef000210002c1400a0ef0002200060ef0002100030ef00 -0210002c1400a0ef0002200060ef0002100030ef000210002c1400a0ef0002200060ef0002100030ef000210002c1500a0ef000320006040f00002100030ef000210002c1500a0ef000320006080f00002100030ef000210002c1600a0ef00042000610f80f10002100030ef000210002c1500a0ef000320006080f0000210 -0030ef000210002c1500a0ef000320006040f00002100030ef000210002c1400a0ef0002200060ef0002100030ef000210002c1400a0ef0002200060ef0002100030ef000210002c1400a0ef0002200060ef0002100030ef000210002c1400a0ef0002200060ef0002100030ef000210002c1400a0ef000220007fefff02f0 -0030ef000210002c1400a0ef000220007fefff02f00030ef000210002c1f00a0ef000d20007c105dfe3741fe38dd0ff860faff02f00030ef000210002c1f00a0ef000d20007dfdddfdd75ffdd74d77f7bbfaff02f00030ef000210002c1f00a0ef000d20007c3dddfdd75fffdf5577f7fbfaff02f00030ef000210002c1f00 -a0ef000d20007fddc1041743073ed974187bfaff02f00030ef000210002c1f00a0ef000d20007fddddfdd75fffdddd77ffbbfaff02f00030ef000210002c1f00a0ef000d20007dddddfddadffddbdd77f7bbfaff02f00030ef000210002c1f00a0ef000d20007e3dddfdddc1fe305d0ff87bfaff02f00030ef000210002c14 -00a0ef000220007fefff02f00030ef000210002c1400a0ef000220007fefff02f00030ef000210002c1400a0ef000220007fefff02f00030ef000210002c1400a0ef0002200060ef0002100030ef000210002c1400a0ef0002200060ef0002100030ef000210002c1400a0ef0002200060ef0002100030ef000210002c1400 -a0ef0002200060ef0002100030ef000210002c1400a0ef0002200060ef0002100030ef000210002c1400a0ef0002200060ef0002100030ef000210002c1400a0ef0002200060ef0002100030ef000210002c1400a0ef0002200060ef0002100030ef000210002c1400a0ef0002200060ef0002100030ef000210002c1400a0 -ef0002200060ef0002100030ef000210002c1400a0ef0002200060ef0002100030ef000210002c1400a0ef0002200060ef0002100030ef000210002c1400a0ef0002200060ef0002100030ef000210002c1400a0ef0002200060ef0002100030ef000210002c1400a0ef0002200060ef0002100030ef000210002c1400a0ef -0002200060ef0002100030ef000210002c1400a0ef0002200060ef0002100030ef000210002c1400a0ef0002200060ef0002100030ef000210002c1400a0ef0002200060ef0002100030ef000210002c1400a0ef0002200060ef0002100030ef000210002c1400a0ef0002200060ef0002100030ef000210002c1400a0ef00 -02200060ef0002100030ef000210002c1400a0ef0002200060ef0002100030ef000210002c1400a0ef0002200060ef0002100030ef000210002c1400a0ef0002200060ef0002100030ef000210002c1400a0ef0002200060ef0002100030ef000210002c1400a0ef0002200060ef0002100030ef000210002c1400a0ef0002 -200060ef0002100030ef000210002c1400a0ef0002200060ef0002100030ef000210002c1400a0ef0002200060ef0002100030ef000210002c1400a0ef0002200060ef0002100030ef000210002c1400a0ef0002200060ef0002100030ef000210002c1400a0ef0002200060ef0002100030ef000210002c1400a0ef000220 -0060ef0002100030ef000210002c1400a0ef00023fffe0ef00021ffff0ef00021fffec1400a0ef0002200060ef0002100030ef000210002c1400a0ef0002200060ef0002100030ef000210002c1400a0ef000223f860ef000211fc30ef000211fc2c1400a0ef0002220860ef0002110430ef000211042c1400a0ef00022208 -60ef0002110430ef000211042c1400a0ef0002220860ef0002110430ef000211042c1400a0ef00023e0f60ef00021f07b0ef00021f07ac1400a0ef0002280260ef0002140130ef000214012c1400a0ef0002240460ef0002120230ef000212022c1400a0ef0002220860ef0002110430ef000211042c1400a0ef0002211060 -ef0002108830ef000210882c1400a0ef000220a060ef0002105030ef000210502c1400a0ef0002204060ef0002102030ef000210202c1400a0ef0002200060ef0002100030ef000210002c0600bfc3ff00ec060080c300000c060080c300000c060080c300000c0a0081feff00fec700000c0a0082fe000001c700000c2b00 -84fd000080ef000008fc0005088104000004fe000010fc000004fd00040410000010fe000040fd00000c2405843c00fc0080ef000008fc00010801fa000010fc000004fd000004fa000040fd00000c3505846200300080f2002602279c78079e01c72c78878439600458059110e0000113ce3c03cf00f38e10e58011601644 -4380fe00000c350584603c30f080f200260228228808a00228b2888104459004640651111000011411440450011444111640119019444440fe00000c3505846066319880f2002602273e88089c0208a288810445100444041111f00001139f44044e0114041114401110104447c0fe00000c3405846e66319880f200250260 -a08809820208a28881044510044404131100000130504404c10134041114401110104c44fd00000c3505846666319880f2002601af1e7806bc01e7227880c439100444040d10f00000d78f3c035e00d3c310e4401110103443c0fe00000c0b05846666319880c800000c0b05846666319880c800000c0f05843c3c30f080f2 -00003fd8ff00ec1b0084fd000080f7000007feff01f83fefff02f00030ef000210002c1b0082fe000001f6000008fe0001043fefff02f02030ef000210202c220081feff00fef6000010fe0008023c375f07f8e3741ff6ff02f05030ef000210502c1d0080f2000b10f003f0023dd75f7ff75d35f5ff02f08830ef00021088 -2c1e0080f2000c118800c0023dd75f7ff7dd543ff6ff02f10430ef000211042c1e0080f2000c1180f0c3c23c375f0c17dd67dff6ff02f20230ef000212022c1e0080f2000c118198c6623dd75f7ff7dd77dff6ff02f40130ef000214012c1d0080f2000c11b998c6623dd75f7ff75d75dff5ff0107b0ef00021f07ac1e0080 -f2000c119998c6623dd8c107f8e3763ff6ff02f10430ef000211042c170080f20005119998c6623fefff02f10430ef000211042c170080f20005119998c6623fefff02f10430ef000211042c170080f2000510f0f0c3c23fefff02f1fc30ef000211fc2c170080f2000010fe00010220ef0002100030ef000210002c170080 -f2000008fe00010420ef0002100030ef000210002c1e0080f2000007feff08f823c8a0f8071c89c0f600021ffff0ef00021fffec180080ed00062228a08008a2caf50002100030ef000210002c190080ed00072228a0800822abc0f60002100030ef000210002c190080ed000723c8a0f3e8229a20f60002100030ef000210 -002c190080ed00072228a08008228a20f60002100030ef000210002c190080ed00072228a08008a28a20f60002100030ef000210002c190080ed000722273ef8071c89c0f60002100030ef000210002c120080ed000020ef0002100030ef000210002c15038000001ef0000020ef0002100030ef000210002c15038000001e -f0000020ef0002100030ef000210002c1a08800000618078cc1f80f5000020ef0002100030ef000210002c19078000008040cccc06f4000020ef0002100030ef000210002c1d0b8000008040cccc061e36ff87f8000020ef0002100030ef000210002c1e0c8000010020cccc063338cccc80f9000020ef0002100030ef0002 -10002c1d0b8000010020fccc063330cccef8000020ef0002100030ef000210002c1d0b8000010020cccc063f30ccc7f8000020ef0002100030ef000210002c1e0c8000010020cccc063030ccc380f9000020ef0002100030ef000210002c1e0c8000008040cccc063130ccc980f9000020ef0002100030ef000210002c1d0b -8000008040cccc061e30ccc7f8000020ef0002100030ef000210002c16048000006180f1000020ef0002100030ef000210002c15038000001ef0000020ef0002100030ef000210002c120080ed000020ef0002100030ef000210002c120080ed000020ef0002100030ef000210002c120080ed000020ef0002100030ef0002 -10002c120080ed000020ef0002100030ef000210002c120080ed000020ef0002100030ef000210002c120080ed000020ef0002100030ef000210002c120080ed000020ef0002100030ef000210002c120080ed000020ef0002100030ef000210002c15038000001ef0000020ef0002100030ef000210002c200a8000006180 -f98000603e60fd000030fc000020ef0002100030ef000210002c200a8000008040c00000603060fd000030fc000020ef0002100030ef000210002c210f8000009e40c19b38f03063c7fc3c7c78fc000020ef0002100030ef000210002c1f098000013f20c19c646030fc660030fc000020ef0002100030ef000210002c1f09 -8000013f20f19870603cfc660030fc000020ef0002100030ef000210002c210f8000013f20c19838603067e6667e6630fc000020ef0002100030ef000210002c210f8000013f20c1981c6030660666606630fc000020ef0002100030ef000210002c210f8000009e40c1984c6030662666626630fc000020ef0002100030ef -000210002c210f8000008040c19838303e63c6663c6618fc000020ef0002100030ef000210002c16048000006180f1000020ef0002100030ef000210002c15038000001ef0000020ef0002100030ef000210002c160080ed000020fc000010f50002100030ef000210002c160080ed000020fc000018f50002100030ef0002 -10002c160080ed000020fc00001cf50002100030ef000210002c160080ed000020fc00001ef50002100030ef000210002c160080ed000020fc00001ff50002100030ef000210002c170080ed000020fc00011f80f60002100030ef000210002c170080ed000020fc00011fc0f60002100030ef000210002c170080ed000020 -fc00011fe0f60002100030ef000210002c19038000001ef0000020fc00001ff50002100030ef000210002c2505800000618070fd0002303e60fd000030fe000020fc00001bf50002100030ef000210002c26058000008040c8fd0002303060fd000030fe000020fc00011180f60002100030ef000210002c28118000008040 -c0f0e1e3e1f03063c7fc3c7c78fe000020fc00010180f60002100030ef000210002c250b8000010020e1999333333030fc660030fe000020fb0000c0f60002100030ef000210002c250b80000100207199833333303cfc660030fe000020fb0000c0f60002100030ef000210002c2311800001002039f9833333303067e666 -7e6630fe000020ef0002100030ef000210002c2311800001002019818333333030660666606630fe000020ef0002100030ef000210002c2311800000804099899333333030662666626630fe000020ef0002100030ef000210002c2311800000804070f0e1e331f03e63c6663c6618fe000020ef0002100030ef000210002c -16048000006180f1000020ef0002100030ef000210002c15038000001ef0000020ef0002100030ef000210002c120080ed000020ef0002100030ef000210002c120080ed000020ef0002100030ef000210002c120080ed000020ef0002100030ef000210002c120080ed000020ef0002100030ef000210002c120080ed0000 -20ef0002100030ef000210002c120080ed000020ef0002100030ef000210002c120080ed000020ef0002100030ef000210002c120080ed000020ef00021ffff0ef00021fffec120080ed000020ef0002100030ef000210002c120080ed000020ef0002100030ef000210002c120080ed000020ef000211fc30ef000211fc2c -120080ed000020ef0002110430ef000211042c120080ed000020ef0002110430ef000211042c120080ed000020ef0002110430ef000211042c120080ed000020ef00021f07b0ef00021f07ac120080ed000020ef0002140130ef000214012c120080ed000020ef0002120230ef000212022c120080ed000020ef0002110430 -ef000211042c120080ed000020ef0002108830ef000210882c120080ed000020ef0002105030ef000210502c120080ed000020ef0002102030ef000210202c120080ed000020ef0002100030ef000210002c0a0080ed00003fd8ff00ec060080c300000c060080c300000c060080c300000c060080c300000c060080c30000 -0c060080c300000c060080c300000c0d07813c8a0f8071c8beca00000c0d0782228a08008a2ca0ca00000c0d0784228a0800822abcca00000c0d07843c8a0f3e822982ca00000c0d0784228a0800822882ca00000c0d0782228a08008a28a2ca00000c0d07812273ef8071c89cca00000c060080c300000c060080c300000c -060080c300000c0802800020c500000c251f800471c8bc00473cf3c71c72222270071cf00fbe880722f8071c8bc01cf80888e200000c251f8008aa2ca20088a28a28a28a22328808a28808088808a28008a2ca2022200c86e200000c251a8010a22aa20108a28a28a282222a800822880f088808a2800082aafe20010a81e2 -00000c251f801073e9a2010fbcf3c8be83e2269be83ef00088fbefa2f3e3049a2f9c200981e200000c251f80102a28a20108a08228a28222228808228800888808a28000888a2002200881e200000c251f8008aa28a20088a08228a28a22228808a28808888808948008908a2022200886e200000c251f80047228bc0048a0 -822722722222700722880708880888f8073e8bc01c200888e200000c0802800020c500000c060080c300000c060080c300000c060080c300000c220080fc0018421c03cfbc03efa201c8be01c722f0073e03e800722f808880e100000c220080fc001882220228220202220228a00228b28808880088008a2800c840e10000 -0c230080fd001901022002282203c2220228a00020aa8808080088008a2800a820e100000c230080fd001901021cfbcf2200223efbe8bcf8c1268be70800883efa2f3e9820e100000c230080fd000001fe021528220022220228a00022228800880088008a28008820e100000c220080fc0018822202282202222202252002 -24228808880088008948008840e100000c220080fc0018421c022fbc01c22202223e01cfa2f00708008f80888f808880e100000c060080c300000c060080c300000c060080c300000c060080c300000c2d0080fc00234fbe880722f8071c8bc01cf8003e222f8070889cf8081c73e01e44e44e7c010000e38410ec00000c2d -0080fc002388088808a28008a2ca2022200008236800888ca280082288802145165140010801144208ec00000c2e0080fd0009010f088808a2800082aafe2017020822a800808aa080082280802045155040000400144104ec00000c2e0080fd0024010088fbefa2f3e3049a2f9c200008222f3e7089a0f3e83e708fa07df4 -d378000200644104ec00000c2e0080fd00240100888808a28000888a20022000082228000888a080082208802045145140000400144104ec00000c2c0080fc00fe882008948008908a20222000082228008888a280082288802145145140000801144208ec00000c2d0080fc001d4708880888f8073e8bc01c200208222f80 -70889cf80fa270801e45144e7cfe0002e38410ec00000c060080c300000c060080c300000c060080c300000c0802800020c500000c2e28800473e8be722fbe00400003efa201c8be01c722f0073e00073ef8073cfbe88011f4003917c0444104eb00000c2e288008aa05208a22200081000202220228a00228b28808880008 -a02008a2820c80104400451400642082eb00000c2e288010a2022082222001020003c2220228a00020aa880808008820200822820a80004400451400541041eb00000c2e28801073c23c82223c01043e00223efbe8bcf8c1268be70800073c23e9bcf3c98000441f7d179f4c1041eb00000c2e2880102a0220822220010200 -0022220228a00022228800880000a02008a2820880004400451400441041eb00000c2e288008aa05208a22200081000222220225200224228808880008a02008a282088000440044a400442082eb00000c2e28800473e8be71c23e00400001c22202223e01cfa2f0070800873e200722fbe8800047c04447c0444104eb0000 -0c0802800020c500000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300 -000c060080c300000c060080c300000c04c2ff00fc04c2ff00fc00ff0000}} -\par \pard \s20\qc\fi200\ri-40\sa120\keep\keepn\widctlpar\tqr\tx1600 Fig. 14: The screen during the rule term exploration. -\par \pard \s20\li360\sa120\widctlpar -\par The three options have the following meaning: -\par \pard \s20\fi-280\li280\sa120\widctlpar \bullet \tab {\b\i all terms:} All terms within the rule set can be selected by the programmer. -\par \bullet \tab {\b\i first elements:} - All elements that appear in the first position of a rule term can be selected by the programmer. When one element has been selected, a second menu will appear. This menu contains the terms, where the element figures in the first position (can - be used to search for instance names in rule terms). -\par \bullet \tab {\b\i second elements:} Like {\i first elements}, with the only difference being that the second element is considered in this case (can be used to search for slot names of instances in rule terms). -\par \pard \s20\li360\sa120\widctlpar The selection field {\i Rule Sets} will display the names of all rule sets, {\i Element or Term} all terms (with the option {\i All Terms} - being activated) or all elements that appear as the first element (with the option {\i First Element }) or as the second one (with the option {\i Second Element } -) in the term of a rule of the selected rule set. In the last two cases, the respective terms will be displayed in the selection field {\i Term containing Element}. -\par When a term has been selected, the rules that contain this one in their condition part will be displayed in the selection field {\i used as condition in rule}, and those that contain it in their action part will be represented in the selection field {\i -used as action in rule}. Selecting one rule from one of the last two selection fields leads to this one being shown in the display field. -\par The selection field {\i Select Rule Set} has a {\i GoTo} - button. It is located below the field. When this one is clicked on, the editor with the knowledge base will appear. In this process, it is positioned to the definition of the selected rule set. The two selection fields {\i used as condition in rule} and -{\i used as action in rule} have one common {\i GoTo} button, which is situated to the left of the field {\i used as condition in rule}. When clicking on this button the knowledge base editor -will be activated and positioned to the definition of the selected rule. -\par \pard \s20\fi-280\li280\sa120\widctlpar {\i \page Explore Facts} -\par \tab enables the screen-oriented exploration of the dynamic data base after the consultation of an expert system (cf. Figure 15). The exploration window consists of two selection fields and one display field. -\par \pard \s20\qc\li360\sa120\widctlpar {\fs20 {\pict\macpict\picw511\pich243\picwgoal10220\pichgoal4860 \picscalex85\picscaley85 -0f100000000000f301ff001102ff0c00fffe000000480000004800000000000000f301ff000000000001000a0000000000f301ff009980400000000000f301ff00000000000000000048000000480000000000010001000100000000003258980000000000006986804100010000ffffffffffff0001000000000000000000 -0000f301ff0000000000f301ff0040000a0000000000f301ff040080c20002c1aa06007fc3ff00fc0600c0c300000e060040c300000c0600c0c300000e10025fbffbefff00f0ed00003fedff00ec1c02c02008ee00101f000030003e00006000000c6000004020e900000e21025fa00befff0cf01800003000300000600000 -0cfe00016060fe00003fedff00ec1f02c02008ee0013181e1c78e030667c63c6cf1e63c7c070e3c7c660ec00000e21025fa00befff06f0182332319030fe660b67118c66666079e66666603fedff00ec1e02c02008ee00051e1f3031c03cfd66050f8c6666605ffe660060ec00000e21025fa00befff07f018333030e0303c -fe660a198c6666604e67e666603fedff00ec1e02c02008ee0005183330307030fd6609198c6666604466066660ec00000e20025fa00befff06f0183332313030fd660a198c66666040662666603fedff00ec1f02c02008ee0013181f1c18e03e667c63c60f8663c6604063c663e0ec00000e14025fbffbefff00f0fa000060 -f500003fedff00ec0a00c0e5000060e000000e060040c300000c0600c0c300000e06007fc3ff00fc0600c0c300000e060040c300000c0600c0c300000e060040c300000c1b07c1f0000007c00040e9000011fd000604040007c00040ee00000e1b074040000004000040e9000011fd000604040004000040ee00000c1e08c0 -459138040f38e3c0ea000c1159e58e44f78438040f38e3c0ef00000e1c074046514407914444e9000b116516514514444407914444ee00000c1e08c044117c0411404380ea000c114514114514447c0411404380ef00000e1c05404413400413fe40ea000911451411293444400413fe40ef00000c1e08c0440d3c040d3c37 -80ea000c0e45e40e10d7843c040d3c3780ef00000e0a0040e1000001e400000c0a00c0e1000001e400000e0b005fefff01febfd7ff00ec1200dfefff01fedff8ff010003e4000210002e12005fefff01feeff8ff010203e4000210202c271fdfdffffe082eff1ba0ff1c6e87fc60fe1ba0ffbaf1c60ff1bb1bb183ffff0503 -e4000210502e271f5fbf7ffefeeefeebaffeeba6bbfbbbfeebbbffbafabbbfeebae9aebfffff0883e4000210882c271fdf7efffe1eeefeebafffefaabbfbfbfeebbbfffafcbfbfefbaeaafbfffff1043e4000211042e271f5f7de0ffeee0820ba1839f6cba0c7bfe1bbbfffafec7b82f820b2c87ffff2023e4000212022c27 -1fdf7effffeeeefeebafffeeeebbffbbfefbbbfffaff7bbfefbaebaebfffff4013e4000214012e271f5fbf7ffeeeeefeed6ffeedeebbfbbbfefbbbfffaf83bbfeebaebaebffffff07be400021f07ac271fdfdfffff1eeefeeee0ff182e87fc7bfefc7bfff8dac7bff1baebb183fabf1043e4000211042e12005fefff01fead -f8ff011043e4000211042c1200dfefff01fe6df8ff011043e4000211042e12005fefff01fef6f8ff011fc3e4000211fc2c1200d0ee000006f90002010003e4000210002e0e0050e50002010003e4000210002c1a0cd027d110e00438038079f44e10f1000201ffffe400021fffee1a0c5041111110044404404506d108f100 -02010003e4000210002c1a0cd0811111000440044045055104f10002010003e4000210002e1a0c50811f10e0043807c045e45104f10002010003e4000210002c1a04d081111010fe04044045045104f10002010003e4000210002e1a0c50411111100444044045045108f10002010003e4000210002c1a0cd0211110e00438 -044079f44e10f10002010003e4000210002e0e0050e50002010003e4000210002c0e00d0e50002010003e4000210002e0e0050e50002010003e4000210002c0e00d0e50002010003e4000210002e0e0050e50002010003e4000210002c0e00d0e50002010003e4000210002e0e0050e50002010003e4000210002c0e00d0e5 -0002010003e4000210002e0e0050e50002010003e4000210002c0e00d0e50002010003e4000210002e0e0050e50002010003e4000210002c0e00d0e50002010003e4000210002e0e0050e50002010003e4000210002c0e00d0e50002010003e4000210002e0e0050e50002010003e4000210002c0e00d0e50002010003e400 -0210002e0e0050e50002010003e4000210002c0e00d0e50002010003e4000210002e0e0050e50002010003e4000210002c0e00d0e50002010003e4000210002e0e0050e50002010003e4000210002c0e00d0e50002010003e4000210002e0e0050e50002010003e4000210002c0e00d0e50002010003e4000210002e0e0050 -e50002010003e4000210002c0e00d0e50002010003e4000210002e0e0050e50002010003e4000210002c0e00d0e50002010003e4000210002e0e0050e50002010003e4000210002c0e00d0e50002010003e4000210002e0e0050e50002010003e4000210002c0e00d0e50002010003e4000210002e0e0050e50002010003e4 -000210002c0e00d0e50002010003e4000210002e0e0050e50002010003e4000210002c0e00d0e50002010003e4000210002e0e0050e50002010003e4000210002c0e00d0e50002010003e4000210002e0e0050e50002010003e4000210002c0e00d0e50002010003e4000210002e0e0050e50002010003e4000210002c0e00 -d0e50002010003e4000210002e0e0050e50002010003e4000210002c0e00d0e50002010003e4000210002e0e0050e50002010003e4000210002c0e00d0e50002010003e4000210002e0e0050e50002010003e4000210002c0e00d0e50002010003e4000210002e0e0050e50002010003e4000210002c0e00d0e50002010003 -e4000210002e0e0050e50002010003e4000210002c0e00d0e50002010003e4000210002e0e0050e50002010003e4000210002c0e00d0e50002010003e4000210002e0e0050e50002010003e4000210002c0e00d0e50002010003e4000210002e0e0050e50002010003e4000210002c0e00d0e50002010003e4000210002e0e -0050e50002010003e4000210002c0e00d0e50002010003e4000210002e0e0050e5000201ffffe400021fffec0e00d0e50002010003e4000210002e0e0050e50002010003e4000210002c0e00d0e50002011fc3e4000211fc2e0e0050e50002011043e4000211042c0e00d0e50002011043e4000211042e0e0050e500020110 -43e4000211042c0e00d0e5000201f07be400021f07ae0e0050e50002014013e4000214012c0e00d0e50002012023e4000212022e0e0050e50002011043e4000211042c0e00d0e50002010883e4000210882e0e0050e50002010503e4000210502c0e00d0e50002010203e4000210202e0e0050e50002010003e4000210002c -0600dfc3ff00ee060040c300000c0600c0c300000e060040c300000c0600c0c300000e060040c300000c0600c0c300000e0a0040d7000004ee00000c3827c0800007df4403917c038e45e00e7c001e45f00440e39f00e44e44e7c008e39f44e4007c445f1040fe00070e7d17ce45f7c101f500000e38274102000404440451 -4004516510111000114440044114440114516514001114444514001046d00820fe00071540a41144440101f500000c3a0bc20400078444045140004155fe102501114440004114040104515504002114044514001045500410153cf01440441044440f01e440f700000e3a3442087c00447df7d179f1824d17ce10001e4440 -0041f3847d07df4d378021f40445f41f10445e04101545000e784790444791011440f700000c3a34c20400004444045140004445100110001044400041104401045145140021140445140010445004101544e005404410444411011440f700000e3a34410200044444044a4004484510111000104440004114440114514514 -001114444514001044500820154c101540a411444411011440f700000c3a34c0800003844404447c039f45e00e1001103840007d138400e45144e7c00913843917c010445f10400a35e00e7d17ce3847cf01e3c0f700000e0e0040d7000004f9000040f700000c0b00c0cf00010380f700000e060040c300000c0600c0c300 -000e1c1640044447c439011f7c07df44038e45e01e4507c0111102d900000c1c16c004644104450101400404440451651011450400119106d900000e1c164104544104450102400784440041551011450400115102d900000c1c16c0044c41047d010479f0447df1824d101e45079f113102d900000e1c1640044441044501 -08400044440044451011450400111102d900000c1c16c004444104450110400444440448451011450400111102d900000e1d17410444410445f11f7c038444039f45e01139f7c011110210da00000c0600c0c300000e060040c300000c0600c0c300000e060040c300000c0600c0c300000e060040c300000c0600c0c30000 -0e060040c300000c0600c0c300000e060040c300000c0600c0c300000e060040c300000c0600c0c300000e060040c300000c0600c0c300000e060040c300000c0600c0c300000e060040c300000c0600c0c300000e060040c300000c0600c0c300000e060040c300000c0600c0c300000e060040c300000c0600c0c300000e -060040c300000c0600c0c300000e060040c300000c0600c0c300000e060040c300000c0600c0c300000e060040c300000c0600c0c300000e060040c300000c0600c0c300000e060040c300000c0600c0c300000e060040c300000c0600c0c300000e060040c300000c0600c0c300000e060040c300000c0600c0c300000e06 -0040c300000c0600c0c300000e060040c300000c0600c0c300000e060040c300000c0600c0c300000e060040c300000c0600c0c300000e060040c300000c0600c0c300000e060040c300000c0600c0c300000e060040c300000c0600c0c300000e060040c300000c0600c0c300000e060040c300000c0600c0c300000e0600 -40c300000c0600c0c300000e060040c300000c0600c0c300000e060040c300000c0600c0c300000e060040c300000c0600c0c300000e060040c300000c0600c0c300000e060040c300000c0600c0c300000e060040c300000c0600c0c300000e060040c300000c0600c0c300000e060040c300000c0600c0c300000e060040 -c300000c0600c0c300000e060040c300000c0600c0c300000e060040c300000c04c2ff00fe06007fc3ff00fc00ff0000}} -\par \pard \s20\qc\fi200\ri-40\sa120\keep\keepn\widctlpar\tqr\tx1600 Fig. 15: The screen during the fact exploration. -\par \pard \s20\li360\sa120\widctlpar The selection field {\i True Facts} shows the facts that have been evaluated to true during the last consultation, while the selection field {\i Unprovable Facts} displays the f -acts that cannot be proved. For the facts evaluated to true the display field can show the action that has led to the verification. An explanation as to why the listed hypotheses are not provable cannot be provided for the time being. -\par \pard \s20\fi-280\li280\sa120\widctlpar {\i Hypotheses} -\par \tab displays all hypotheses that have been verified during the last consultation in the dialog window. -\par {\i Explain} -\par \tab exposes the explanation window displaying all the facts that have been evaluated to true during the last dialog session. Subsequently, the programmer will find a menu providing the following options: -\par {\i No} -\par \tab terminates the menu without performing an action. -\par {\i How?} -\par \tab presents a menu consisting of the facts evaluated to true. When selecting a fact the explanation window will display the reason as to why this fact has been evaluated to true. -\par {\i How all?} -\par \tab presents a menu consisting of all the facts that have been verified or falsified. When selecting a fact the explanation window will display the reason behind its evaluation. -\par {\i Print Rule} -\par \tab Like {\i Show Rule} -, but the rule is presented in a pop-up menu, with the result that its terms can be selected. When a term is selected from the condition part, the system will display a menu with rules that contain this term in its action part, provided it finds some. Ter -ms from the action part will undergo the reverse process. -\par \pard\plain \s3\li360\sb120\sa120\keepn\widctlpar \b\f8\fs28\lang1031 4.4\tab The Prolog Menu -\par \pard\plain \s20\li360\sa120\widctlpar \f8\lang1031 When the current expert system contains a Prolog interpreter in its configuration, then the menu {\i Prolog} can be selected from the menu bar. It contains operations that can be used -to manipulate the trace behavior ({\i Trace}, {\i Set Trace Options}), to inspect axiom sets ({\i Explore Axset)}, to load and add or remove axiom sets ({\i Load Axset,} {\i Select Axset}) and to verify a Prolog hypothesis ({\i Prove}, {\i Next}). -\par \pard \s20\qc\li360\sa120\widctlpar {\fs20 {\pict\macpict\picw147\pich136\picwgoal2940\pichgoal2720 -07420000000000880093001102ff0c00fffe000000480000004800000000000000880093000000000001000a000000000088009300998014000000000088009300000000000000000048000000480000000000010001000100000000003258140000000000006a3d010100010000ffffffffffff0001000000000000000000 -000088009300000000008800930040000a000000000088009306faff00c0f50006faff00c0f50006faff00c0f50006faff00c0f5000b07fe07fffe3fffffc0f5000b07fe73ffff3fffffc0f5000b07fe73030f3c3c1fc0f5000b07fe731e6739999fc0f5000b07fe073e6739999fc0f5000b07fe7f3e6739999fc0f5000b07 -fe7f3e6739999fc0f5000b07fe7f3e6739999fc0f5000b07fe7f3f0f3c3c1fc0f50007fbff019fc0f50008fcff02f99fc0f50008fcff02fc3fc0f50006faff00c0f50006faff00c0f50005efff01e000070080f000012000070080f000012000070080f000012000070080f00001200009028007f8f20001200009028000c0 -f2000120000d068000c1f9e1e1e0f6000120000d068000c1c3333330f6000120000d068000c181f30330f6000120000d068000c1833303f0f6000120000c058000c1833303f5000120000d068000c183333330f6000120000d068000c181f1e1e0f600012000070080f000012000070080f000012000070080f00001200007 -0080f000012000070080f000012000070080f000012000070080f00001200014068001f000c03fc0fd00037c003060fe00012000120580031800c006fc0002c60030fd000120001513800300f1e0060fcf0f0f00c67c78e1e3e1e02000151380030198c0060e19999980c666306333b330200015138001f198c0060c0f9819 -80c666306333330020001513800019f8c0060c19981f80c66630633331e02000151380001980c0060c19981800c66630633330302000151380031998c0060c19999980c6663063333330200015138001f0f070060c0f8f0f007c7c1c61e331e020000b0080f6000060fc000120000b0080f6000060fc00012000070080f000 -012000070080f000012000070080f000012000070080f000012000070080f00001200014058003f0000380fe000018fe000018fd000120001405800300000180fe000018fe000018fd00012000140d80030333e1878fcf003c331e1e3cfd00012000140980030333318cce19803cfe330018fd00012000140d8003e1e3318c -cc1980661e303318fd00012000140d800300c3318ccc1f80660c1e3f18fd00012000140d800301e3318ccc1800ff1e033018fd00012000140980030333318ccc1980c3fe330018fd00012000140d8003f333e1878c0f00c3331e1e0efd000120000a0380000003f3000120000a0380000003f300012000070080f000012000 -070080f000012000070080f000012000070080f000012000070080f00001200011018003fe00013003fe000003fa0001200011018003fe00013003fe000003fa00012000120b800301e1e1f0078663c3c780fb00012000110a8003033333300786666663fa00012000110a80030331f3300cc3c60663fa00012000110a8003 -033333300cc183c7e3fa00012000110a8003033333301fe3c06603fa00012000110680030333333018fe660063fa00012000120b8003f1e1f1f0186663c3c1c0fb00012000070080f000012000070080f000012000070080f000012000070080f000012000070080f000012000070080f000012000070080f0000120001308 -8001f001c00003000cfe00000cfc00012000130880031800c00003000cfe00000cfc00012000130c800300f0c3c3c7801e198f0f1efc00012000130c80030198c66663001e1999998cfc00012000130c8001f198c6660300330f18198cfc00012000130c800019f8c7e6030033060f1f8cfc00012000130c80001980c60603 -007f8f01980cfc00012000130880031998c666630061fe99008cfc00012000130c8001f0f0c3c3c1c061998f0f07fc00012000070080f000012000070080f000012000070080f000012000070080f000012000070080f000012000070080f000012000070080f00001200009028003f0f2000120000902800318f200012000 -0d06800319f9e331e0f6000120000d06800319c3333330f6000120000d068003f183333330f6000120000d068003018331e3f0f6000120000c058003018331e3f5000120000d068003018330c330f6000120000d0680030181e0c1e0f600012000070080f000012000070080f000012000070080f000012000070080f00001 -2000070080f000012000070080f000012000070080f0000120000c058003980000c0f5000120000c058003980000c0f5000120000c058003d8f199e0f5000120000c058003d99998c0f5000120000c0580037998f0c0f5000120000c05800379f860c0f5000120000c0580033980f0c0f5000120000c058003399998c0f500 -0120000c05800318f19870f500012000070080f000012000070080f000012000070080f000012000070080f000012000070080f000012000070080f000012000070080f00001200005efff01e00000ff0000}} -\par \pard \s20\qc\fi200\ri-40\sa120\keep\keepn\widctlpar\tqr\tx1600 Fig. 16: The Prolog menu. -\par \pard \s20\fi-280\li280\sa120\widctlpar {\i Trace} -\par \tab activates or deactivates the Prolog trace. When the menu entry is marked with a hook, then the Prolog trace is deactivated. All operations that have been set by selecting the menu entry {\i Set Trace Options} will remain. -\par {\i Set Trace Options} -\par \tab produces another menu that can be left by using {\i Exit} (cf. Figure 17). -\par \pard \s20\qc\li360\sa120\widctlpar {\fs20 {\pict\macpict\picw306\pich150\picwgoal6120\pichgoal3000 -08b60000000000960132001102ff0c00fffe000000480000004800000000000000960132000000000001000a000000000096013200998028000000000096013200000000000000000048000000480000000000010001000100000000003257b00000000000006aab000000010000ffffffffffff0001000000000000000000 -000096013200000000009601320040000a000000000096013208000fddff02f8000008001fddff02fe000007003fdcff01000007007fdcff01000005dbff0180001bf9ff0b8ffe7fffe7f07fffcfffff81fdff03c3ffce7ff7ff0180001af9ff0b37fe7fffe7f33fffcfffffe7fdff0299ffcff6ff0180001ef9ff153f0e70 -f1c3f33261ce1e0fe7261e3c3f99838670e0f1f9ff01c0001df9ff001efe6602e7f331fecc08cfe71dccd99f9999cefe66f9ff01c0001ef9ff068e666667e7f073fecc0bcfe73e0cf99f9999ce666663f9ff01c0001ef9ff06c6066067e7f3f3fecc0bcfe73cccf81f9999ce666671f9ff01c0001ef9ff06e67e67e7e7f3f3 -fecc0bcfe73cccf9ff9999ce666678f9ff01c0001ef9ff0666766766e7f3f3fecc0bcfe73cccd9df9999ce66666cf9ff01c0001ef9ff038f0e70f1fef30ee1ce1e0fe73e0e3c3fc383e670e671f9ff01c0000defff00cffbff009ff5ff01c0000ef0ff01fdcffbff009ff5ff01c0000af0ff01fe1feeff01c00005dbff01c0 -0005dbff01c000070080dc000140000700bfdcff0140000900a0de0003800140000900a0de0003810140000d04a0003e0082e20003828140000d04a000200002e20003844140000d04a000208887e20003882140000f06a3e03c508200f8e40003901140000d04a000202082e20003a00940000d04a000205082e20003f83d -40000e05a0003e888180e30003882140000900a0de0003882140000900a0de0003882140000900a0de00038fe140000900a0de0003800140000900a0de0003800140000f06a3e00820088008e40003ffff40000f06a20008200d8008e40003800140001007a20888200a9c79c0e50003800140001007a3c8882008a28a20e5 -0003800140001007a208882008a28be0e50003800140000f06a209882008a28ae40003800140001007a2068820089c79e0e50003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140001108a22000000200880080e60003800140001108a3 -2000000200d80080e60003800140001108a2a72cf1e200a9c79ce60003800140001108a268b2aa22008a28a2e60003800140001108a228a0aa22008a28bee60003800140001108a228a0aa62008a28a0e60003800140001108a22720a9a20089c79ee60003800140000900a0de0003800140000900a0de0003800140000900 -a0de0003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140 -000900a0de0003800140000900a0de0003800140001001a3e0fe00021c2080e50003800140001001a080fe0002222080e50003800140001007a08b1e71c0222080e50003800140001007a08ca28a203e2080e50003800140001007a0882283e0222080e50003800140001007a088268200222080e50003800140001007a088 -1a79e0222080e50003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140000900a0de000380014000140ba1c008000200f00002200008e9000380014000140ba22008000200880002000008e9000380014000160da2070871c7008ac71e21c79c71e0eb0003800140 -00150ca1c8888a2200f328a22228888aea000380014000160da02f88fa0200820fa2220888f9c0eb000380014000160da228088202008208222209888020eb000380014000160da1c78879e18082079e21e6867bc0eb0003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140000900a0de00 -03800140000900a0de000380014000130aa220022060007002000082e8000380014000130aa360020080008802000080e8000380014000150ca2a71e21c88081c21c71c21cb0ea000380014000150ca228a2208880722222888222c8ea000380014000150ca228a22088800be23e80822288ea000380014000150ca228a220 -88808a022080822288ea000380014000150ca2271e20878071e21e78621c88ea0003800140000d00a0fd000080e30003800140000d00a0fe000007e20003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140000900a0de00038001400009 -00a0de0003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140001007a1c8000007080080e50003800140001007a228000008880080e50003800140001108a20f -1ca8081c79c89ee60003800140001108a1c8a2a807088888a0e60003800140001104a028a2a800fe88009ce60003800140001108a228a2a80888988982e60003800140001108a1c89c5007066866bce60003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140000900a0de00038001400009 -00a0de0003800140000900a0de0003800140000900a0de0003ffff40000900a0de0003800140000900a0de0003800140000900a0de00038fe140000900a0de0003882140000900a0de0003882140000900a0de0003882140000900a0de0003f83d40000900a0de0003a00940000900a0de0003901140000900a0de00038821 -40000900a0de0003844140000900e0de000382814000090060de000381014000090060de00038001400007003fdcff01400008001cdd00020e0000080007ddff00fcff000000ff0000}} -\par \pard \s20\qc\fi200\ri-40\sa120\keep\keepn\widctlpar\tqr\tx1600 Fig. 17: The menu with Prolog trace options. -\par \pard \s20\li360\sa120\widctlpar The operations that are provided by the subsequent menu are as follows: -\par \pard \s20\fi-280\li280\sa120\widctlpar {\i Full Mode} -\par \tab modifies the trace to provide detailed information. -\par {\i Normal Mode} -\par \tab modifies the trace to provide brief information. -\par {\i Trace All} -\par \tab includes all predicates in the trace. -\par {\i -\par Select Predicates} -\par \tab This menu entry serves to mark predicates to be traced. At first, the programmer finds a menu with all axiom sets from which one can be chosen. If -only one axiom set is known to the system, this choose menu will be omitted. Then the menu illustrated in Figure 18 will appear. -\par -\par \pard \s20\qc\li360\sa120\widctlpar {\fs20 {\pict\macpict\picw306\pich80\picwgoal6120\pichgoal1600 -05520000000000500132001102ff0c00fffe000000480000004800000000000000500132000000000001000a000000000050013200998028000000000050013200000000000000000048000000480000000000010001000100000000003259680000000000006b2c802800010000ffffffffffff0001000000000000000000 -000050013200000000005001320040000a000000000050013208000fddff02fc000008001fddff02fe000007003fdcff01000007007fdcff01800007007fdcff01800020faff0699ffff9fffffe3fcff00f9fcff0e9810787060e787ff0e7e1cce38c0001cfaff069fffff9fffffcff6ff0e9e733333e7e73bfe767cccccd9 -c00029279878f0fe0e4c3c19c7870e1e3f864c3803fc3999c3803fc7870e733333e7e73ffe7e7cccccf9c0002811f733667e663999999b739cccdfce399999fbfd99119f9b339e733333e7e73ffe7e7ccccc79c0002912f833e67e667999999f839ccc7fce799999fc19fe99119f8f339e707030e1e73f067e7c0cce384000 -2927f333e07e667819999f339c0e3fce799999f99c3999999fc7039e733333e7e73ffe7e7ccccf19c0002811f333e7fe6679f9999f339cff1fce799999f9fd99119fe33f9e733333e7e73ffe7e7ccccf99c0002811f333677e6679d9999b339ced9fce799999f9fd99119fb33b9e733333e7e73bfe767ccccd99c0002927f8 -38f0fe0e7c3c19c783ce1e3fce7c3999fc1999c3999fc787ce733333e7e787ff0e0cce1e3840000afeff01fe7fe0ff01c0000afeff01fe7fe0ff01c00005dbff01c00005dbff01c00005dbff01c000070080dc000140000700bfdcff0140000900a0de0003800140000900a0de0003810140000f01a3e0fd00012080e50003 -828140000f01a080fd00012080e50003844140001007a08b1e71c01e2080e50003882140001007a08ca28a20222080e50003901140001007a0882283e0222080e50003a00940001007a088268200262080e50003f83d40001007a0881a79e01a2080e50003882140000900a0de0003882140000900a0de0003882140000900 -a0de00038fe140000900a0de0003800140000900a0de0003800140000a01a3e0df0003ffff40000a01a080df0003800140001007a08b1e71c02c72c7e50003800140001108a08ca28a20328b2880e60003800140001108a0882283e0228a2f80e60003800140001007a088268200228a28e50003800140001108a0881a79e0 -22722780e60003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140000f06a3e00000800020e40003800140000f06a0800000800020e40003800140001209a0871e78870072c79c70e70003800140001209a088a28888802328a288e70003 -800140001209a088a2888f802208a0f8e70003800140001209a088a28888002209a080e70003800140001209a0871e7887801a069e78e70003800140000c03a0000208e10003800140000c03a0001c70e10003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140000c03a3e00820e1000380 -0140000c03a2000020e10003800140000c03a2088870e10003800140000c03a3c50820e10003ffff40000c03a2020820e10003800140000c03a2050820e10003800140000c03a3e88818e100038fe140000900a0de0003882140000900a0de0003882140000900a0de0003882140000900a0de0003f83d40000900a0de0003 -a00940000900a0de0003901140000900a0de0003882140000900a0de0003844140000900e0de00038281c000090060de00038101c000090060de00038001800007003fdcff01000008001cdd00020e0000080007ddff02fc000000ff0000}} -\par \pard \s20\qc\fi200\ri-40\sa120\keep\keepn\widctlpar\tqr\tx1600 Fig. 18: The menu to mark axiom sets. -\par \pard \s20\fi-280\li280\sa120\widctlpar \bullet \tab {\b\i Trace all:} All predicates of the axiom set previously selected are marked. -\par \bullet \tab {\b\i Trace none:} The marks of all predicates of the axiom set previously selected are removed. -\par \bullet \tab {\b\i Toggle trace:} presents a menu that lists all predicates of the axiom set previously -\par selected (cf. Figure 19). -\par -\par \pard \s20\qc\li360\sa120\widctlpar {\fs20 {\pict\macpict\picw306\pich114\picwgoal6120\pichgoal2280 -08c40000000000720132001102ff0c00fffe000000480000004800000000000000720132000000000001000a000000000072013200998028000000000072013200000000000000000048000000480000000000010001000100000000003259040000000000006c0d000000010000ffffffffffff0001000000000000000000 -000072013200000000007201320040000a0000000000720132080007ddff02fc000008001fddff02fe000007003fdcff01000007007fdcff01800005dbff0180002703fff9fffcfeff033fffffc7fcff06ccffffcffffff1feff0df810787060e787ff0e7e1ccec0002403fff9fffcfbff009ffcff06cfffffcfffffe7feff -0dfe733333e7e73bfe767cccccc00029279c19c3f864c3c730783f0e1c9f07261e0ce3c3870f1fc3261c01fe733333e7e73ffe7e7cccccc00028fe9924fce3b99b33333f9ccc7f331ccccccdb9ce666fe71cccccfe733333e7e73ffe7e7ccccc400028fe9924fce7c19f33333f9cccff333ccccccfc1ce663fe73cccccfe70 -7030e1e73f067e7c0cce40002927999981fce7999f33333f9cccff333c0ccccf99ce071fe73cccccfe733333e7e73ffe7e7ccccf4000292799999ffce7999f33333f9cccff333cfccccf99ce7f8fe73cccccfe733333e7e73ffe7e7ccccfc000292799999dfce7999b33333f9cccff333ceccccd99ce76cfe73cccccfe7333 -33e7e73bfe767ccccdc00029279c19c3fe67c1c733383f9e1cff073e1e0ce3c1e70f1fe73e1cccfe733333e7e787ff0e0cce1e400010019f9ffaff003ffeff003fe9ff01c00011019b9ffbff01f73ffeff003fe9ff01c0000d01bc3ffbff01f87fe5ff01c00005dbff01c00005dbff01c000070080dc00014000070080dc00 -014000070080dc000140000d02800003faff00f0e6000140000d0280000ffaff00fce6000140000d0280001ffaff00fee6000140000d0280003efa00001fe600014000130280003bfaff00f7fd00003ffafff200014000160280007cfa00010f80fe000040fa000080f3000140001e0b8000740003c0002080000b80fe0008 -40001c800008000080f3000140001e0b800074000220002080000b80fe0008400022800008000080f3000140001e0b8000740002270021c0000b80fe0008400022f1cb1c000080f3000140001e0b800074000228802080000b80fe000840003e8a2c88000080f3000140001e0b800074000228802080000b80fe0008400022 -8a2808000080f3000140001e0b800074000228802080000b80fe00084000228a2808000080f3000140001e0b8000740003c7002060000b80fe0008400022f1c806000080f300014000160280007cfa00010f80fe000040fa000080f300014000130280003bfaff00f7fd00003ffafff2000140000d0280003efa00001fe600 -0140000d0280001ffaff00fee6000140000d0280000ffaff00fce6000140000d02800003faff00f0e600014000070080dc00014000070080dc000140000700bfdcff0140000900a0de0003800140000900a0de0003810140002206a3c00008800020fd000920002020000500008208fc0002080002fa0003828140002006a2 -200008000020fd000920002020000f80000208fa000002fa000384414000281fa22b1c78871e71c780f1eb2471e03c880500a8820801c71c8ac008b0072c79c7fd0003882140002920a3cca28888a2222800aa2ca88a2022880f80a882080228a28b2008c802328a2880fe0003901140002920a2083e88882223e700aa2838 -fa2022880500a882080228208a00088802208a0f80fe0003a0094000281fa20820888826220080aa6824822022880000a882080228209a00088802209a08fd0003f83d40002920a2081e78879a19ef00a9a82279e03c78000050820801c79e6a00088801a069e780fe0003882140000d00a0f3000008ed0003882140000d00 -a0f3000070ed0003882140000900a0de00038fe140000900a0de0003800140000900a0de0003800140000f06a00022fa2f3ef0e40003ffff40000f06a000368368a088e40003800140000f06a0002a82a8a088e40003800140000f06a00022f22f3cf0e40003800140000f06a000228228a088e40003800140000f06a00022 -8228a088e40003800140000f06a00022fa2f3e88e40003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140000900a0de000380014000150ca0000870022223e21c808fbef0ea000380014000150ca000088802322082228080a088ea000380014000150ca0000880 -022a20822280812088ea000380014000150ca0000873e22620823e80823c88ea000380014000150ca0000808022220822280842088ea000380014000150ca0000888022220822280882088ea000380014000150ca00008700222208222f88fbef0ea0003800140000900a0de0003800140000900a0de0003800140000900a0 -de0003800140000900a0de0003800140000900a0de000380014000160da0001cf3cf1c71c88889c01c73c0eb000380014000160da000228a28a28a2888ca20228a20eb000380014000160da000228a28a28a0888aa00208a20eb000380014000160da0003ef3cf22fa0f889a6fa0fbc0eb000380014000160da000228208a2 -8a08888a20208a20eb000380014000160da000228208a28a28888a20228a20eb000380014000160da0002282089c89c88889c01c8a20eb0003800140000900a0de0003ffff40000900a0de0003800140000900a0de0003800140000900a0de00038fe140000900a0de0003882140000f06a00008700f3ef0e4000388214000 -0f06a000088808a088e40003882140000f06a000088008a088e40003f83d40000f06a0000873ef3c88e40003a00940000f01a000fe0801a088e40003901140000f06a000088808a088e40003882140000f06a000087008bef0e40003844140000900a0de0003828140000900a0de0003810140000900a0de00038001400007 -00bfdcff014000070080dc00014000070080dc00014000070080dc000140000700c0dc0001c000070040dc00018000080060dd0002018000080030dd000203000008001cdd00020e0000080007ddff02f8000000ff0000}} -\par \pard \s20\qc\fi200\ri-40\sa120\keep\keepn\widctlpar\tqr\tx1600 Fig. 19: The menu to mark predicates. -\par \pard \s20\li360\sa120\widctlpar This can be used to select predicates: those not marked will be marked, and those marked will lose their marks. -\par \pard \s20\fi-280\li280\sa120\widctlpar \bullet \tab {\b\i Exit:} to leave the menu. -\par {\b Note: }When choosing this menu entry all marks made so far will {\b automatically} be removed. -\par {\i Modify Selection} -\par \tab This menu entry can be used to modify the marks of predicates. The dialog with the programmer will take place as described for Select Predicates. When choosing this menu entry the marks made so far will {\b not} be deleted. -\par {\i Show Status} -\par \tab describes the current trace behavior. -\par {\i Explore Axset} -\par \tab provides a screen-oriented exploration option for the Prolog part of the current expert system (cf. Figure 20). The screen will display two selection fields and one display field. -\par -\par \pard \s20\qc\li360\sa120\widctlpar {\fs20 {\pict\macpict\picw509\pich321\picwgoal10180\pichgoal6420 \picscalex79\picscaley79 -122e00000000014101fd001102ff0c00fffe0000004800000048000000000000014101fd000000000001000a00000000014101fd0099804000000000014101fd0000000000000000004800000048000000000001000100010000000000325aa80000000000006ce9803900010000ffffffffffff0001000000000000000000 -00014101fd00000000014101fd0040000a00000000014101fd04c2ff00f8060080c3000018060080c3000018060080c30000181002bf7ff7f1ff00fcea000003eeff00d81f02804010f0000b03c006000003800603e00006fe0004c600000402ea0000182402bf4017f1ff02fc0660fe000606400603000006fe0004c00000 -0606fe000003eeff00d82202804010f000160666663c7fc6078f030667c63c6cf1e63c7c070e3c7c66ed0000182302bf4017f1ff01fc06fd6604670cc60306fe66067118c66666079efe660003eeff00d82102804010f0000107e6fe6604638cc603c6fe660660f8c6666605f6fe66ed0000182402bf4017f1ff18fc0663c6 -666661cfc60303c666666198c6666604e67e666603eeff00d82102804010f0000006fd660460cc060306fe66096198c666660446606666ed0000182302bf4017f1ff01fc06fd660464cc460306fe660a6198c66666040662666603eeff00d82202804010f000160666663c6663878303e667c63c60f8663c6604063c663eed -0000181402bf7ff7f1ff00fcf7000006f5000003eeff00d80a0080e4000006e1000018060080c3000018060080c300001804c2ff00f8060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c30000181301801ffeff00e0e7000007feff00f8e700001813018020fe000010e70000 -08fe000004e700001813018040fe000008e7000010fe000002e7000018230d8043c00fc00803c0060000038006ef000c10f003f00201f0000066000060ef00001823078046200300080660fe0002064006ef000c118800c0020198000060000060ef000018240d804603c30f080666663c7fc6078fef000d1180f0c3c20199 -b3c3e63878f1e0f0000018230680460663198806fd6602670cc6ef000d118198c6620199c66666648c6330f000001824078046e663198807e6fe6602638cc6ef000d11b998c66201f1866666607c6330f0000018240d8046666319880663c6666661cfc6ef000d119998c662018187e66660cc63f0f0000018220680466663 -198806fd660260cc06ef000c119998c662018186066660cc63ef000018230680466663198806fd660264cc46ef000d119998c662018186266664cc6310f0000018240d8043c3c30f080666663c66638783ef000d10f0f0c3c2018183c3e6387c31e0f000001813018040fe000008e7000010fe000002e700001813018020fe -000010e7000008fe000004e70000181301801ffeff00e0e7000007feff00f8e7000018060080c3000018060080c3000018060080c3000018060080c3000018060080c30000180600bfc3ff00d80e00bfe5ff02fe0006e400022000580e00bfe5ff02fe0406e400022040581e0bbc10e3041de3fe37e3763063f0ff07fe0a06 -22fa2f3ef0e9000220a0581e0bbf775d7dfdddfdd7dd75d7ddf0ff07fe1106368368a088e900022110581e0bbf775d7dfddffdf7dd75f7dff0ff07fe20862a82a8a088e900022208581e0bbf70c10c3ddf05f7c17630e3f0ff07fe404622f22f3cf0e900022404581e0bbf775d7dfddffdf7dd77d7fdf0ff07fe8026228228 -a088e900022802581d0bbf775d7dfdddfdd7dd75d7ddefff06e0f6228228a088e900023e0f581e0bbf775d7dfde3fe305d8e3063f0ff07fe208622fa2f3e88e900022208580e00bfe5ff02fe2086e400022208580e00bfe5ff02fe2086e400022208580e00bfe5ff02fe3f86e4000223f8580e00a0e50002020007e4ff02e0 -00580e00a0e50002020007e4ff02e000581700a0e5000d03fffff78ffddddc1de37f70410fedff00d81900a0e5000d020007f777fdcddf7ddd7f7f5f77efff02e000581900a0e5000d020007f77ffdd5df7ddd7f7edf77efff02e000581900a0e5000d020007f78c1dd9df7dc17f7dc377efff02e000581900a0e5000d0200 -07f7f7fddddf7ddd7f7bdf77efff02e000581900a0e5000d020007f777fddddf7ddd7f77df77efff02e000581900a0e5000d020007f78ffddddf7ddd0770410fefff02e000580e00a0e50002020007e4ff02e000580e00a0e50002020007e4ff02e000580e00a0e50002020007e4ff02e000580e00a0e50002020006e40002 -2000580e00a0e50002020006e400022000581a00a0e5000e0200061cf3cf1c71c88889c01c73c0f000022000581a00a0e5000e020006228a28a28a2888ca20228a20f000022000581a00a0e5000e020006228a28a28a0888aa00208a20f000022000581a00a0e5000e0200063ef3cf22fa0f889a6fa0fbc0f000022000581a -00a0e5000e020006228208a28a08888a20208a20f000022000581a00a0e5000e020006228208a28a28888a20228a20f000022000581a00a0e5000e0200062282089c89c88889c01c8a20f000022000580e00a0e50002020006e400022000580e00a0e50002020006e400022000580e00a0e50002020006e400022000580e00 -a0e50002020006e400022000580e00a0e50002020006e400022000581300a0e5000702000608700f3ef0e900022000581300a0e50007020006088808a088e900022000581300a0e50007020006088008a088e900022000581300a0e500070200060873ef3c88e900022000581300a0e50002020006fe0801a088e900022000 -581300a0e50007020006088808a088e900022000581300a0e50007020006087008bef0e900022000580e00a0e50002020006e400022000580e00a0e50002020006e400022000580e00a0e50002020006e400022000580e00a0e50002020006e400022000580e00a0e50002020006e400022000580e00a0e50002020006e400 -022000580e00a0e50002020006e400022000580e00a0e50002020006e400022000580e00a0e50002020006e400022000580e00a0e50002020006e400022000580e00a0e50002020006e400022000580e00a0e50002020006e400022000580e00a0e50002020006e400022000580e00a0e50002020006e400022000580e00a0 -e50002020006e400022000580e00a0e50002020006e400022000580e00a0e50002020006e400022000580e00a0e50002020006e400022000580e00a0e50002020006e400022000580e00a0e50002020006e400022000580e00a0e50002020006e400022000580e00a0e50002020006e400022000580e00a0e50002020006e4 -00022000580e00a0e50002020006e400022000580e00a0e50002020006e400022000580e00a0e50002020006e400022000580e00a0e50002020006e400022000580e00a0e50002020006e400022000580e00a0e50002020006e400022000580e00a0e50002020006e400022000580e00a0e50002020006e400022000580e00 -a0e50002020006e400022000580e00a0e50002020006e400022000580e00a0e50002020006e400022000580e00a0e50002020006e400022000580e00a0e50002020006e400022000580e00a0e5000203fffee400023fffd80e00a0e50002020006e400022000580e00a0e50002020006e400022000580e00a0e50002023f86 -e4000223f8580e00a0e50002022086e400022208580e00a0e50002022086e400022208580e00a0e50002022086e400022208580e00a0e5000203e0f6e400023e0f580e00a0e50002028026e400022802580e00a0e50002024046e400022404580e00a0e50002022086e400022208580e00a0e50002021106e400022110580e -00a0e50002020a06e4000220a0580e00a0e50002020406e400022040580e00a0e50002020006e400022000580600bfc3ff00d8060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c30000 -18060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018181280410870022223e21c808fbef0001cf1c71c20d500001819138082088802322082228080a08800228a28a21001d6000018191381040880022a2082228081208800208a28200802d60000181a1481040873e22620823e80823c -880020f2271c08043ed700001819138104080802222082228084208800208a20820802d600001819138082088802222082228088208800228a28a21001d60000181812804108700222208222f88fbef00fdc89c71c20d5000018060080c3000018060080c3000018060080c3000018060080c3000018160080fe000c011cf1 -c71c22270001cf1c71c2d3000018160080fe000c02228a28a22328800228a28a21d3000018170080fe000d04208a282022a8000208a2820080d4000018170080fe000d0420f2271c226980020f2271c080d4000018170080fe000d04208a20822228800208a2082080d4000018160080fe000c02228a28a22228800228a28a -21d3000018160080fe000c011c89c71c222700fdc89c71c2d3000018060080c3000018060080c3000018060080c30000180a0080d9000001ec0000182f0080fe0020012273e00421c00000400000073c71c70001cfbe00881c73e01c89c89cf8820820fd00010180ed0000182f0080fe002002328880082220000081000008 -a28a28800228080088228880228a2ca280410410fd000101c0ed0000182f0080fe0020042a8880102200000102000008228a08002208080008228080208a2aa080208208fd000101e0ed0000182f0080fe0020042688801021c03e01043e00083c89c700026f0800083e708fa0fbe9a6f0208208fd000101f0ed0000182f00 -80fe002004228880102020000102000008228820800228080008220880208a28a280208208fd000101f8ed0000182f0080fe002002228880082220000081000008a28a28800228080008228880228a28a280410410fd000101fced0000182f0080fe0020012270800421c00000400003f72271c70021cf88000fa270801c8a -289cf8820820fd000101feed0000180b0080d9000101f0ed0000180b0080d9000101b0ed0000180b0080d900010118ed0000180a0080d8000018ed0000180a0080d800000ced0000180a0080d800000ced000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c300001806 -0080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c30000180600 -80c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080 -c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3 -000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c300 -0018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c30000 -18060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018 -060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c3000018060080c300001804c2ff00f804c2ff00f800ff0000}} -\par \pard \s20\qc\fi200\ri-40\sa120\keep\keepn\widctlpar\tqr\tx1600 Fig. 20: The screen during the Prolog exploration. -\par \pard \s20\li360\sa120\widctlpar The selection field {\i AxiomSet }will display all axiom set names. When selecting an axiom set the names of the predicates contained in it will be shown in the selection window {\i Predicate}. -\par When the programmer selects a predicate, its definition will be shown in the display field. -\par Both selection fields have one {\i GoTo} button each. When the programmer clicks on the button in the selection field {\i AxiomSet} -, then the knowledge base editor will appear. This one is positioned to the definition of the selected axiom set. The same applies to the button in the selection field {\i Predicate}. -\par \pard \s20\fi-280\li280\sa120\widctlpar {\i Load Axset} -\par \tab presents a data choose menu with the data files of the folder {\b babylon:samples:axsets}. The files contain predicate definitions. The definitions from the selected file are loaded. In order to make them k -nown to the Prolog interpreter, they will have to be activated by using the Select operation (cf. the next menu entry). -\par {\i Select Axset} -\par \tab -it is possible to select one or several axiom sets that are to be introduced to the Prolog interpreter from a given menu. But note that afterwards all axiom sets that have not been selected are unknown to the interpreter, i.e. they are deactivated, even -if they were activated before. -\par {\i Prove} -\par \tab enables the programmer to enter a Prolog hypothesis to be verified into the dialog window, and yields the first proof that has been established. To compute further solutions, please, use the {\i Next} operation (cf. the following menu entry). -\par \pard \s20\li360\sa120\widctlpar For example, load and select ({\i Load}, {\i Select }) the axiom set {\i set-ax} and verify the hypothesis: -\par \tab {\f13\fs20 ((member _x (1 2 3 4))(member _x (3 4 5 6))) -\par }But note the Lisp-oriented notation. -\par \pard \s20\fi-280\li280\sa120\widctlpar {\i Next} -\par \tab yields the next proof of the hypothesis that is being verified. -\par \pard\plain \s3\li360\sb120\sa120\keepn\widctlpar \b\f8\fs28\lang1031 4.4\tab The Consat Menu -\par \pard\plain \s20\li360\sa120\widctlpar \f8\lang1031 Supposing an expert system with a constraint interpreter as part of its configuration is the current one, the menu {\i Consat} - can be selected from the menu bar. It contains operations to manipulate the trace behavior ({\i Trace}), to define and display constraints ({\i Define Constraint}, {\i Explore Constraint}) and to satisfy constraints locally and globally ({\i -Satisfy Locally}, {\i Satisfy Globally}). -\par -\par \pard \s20\qc\li360\sa120\widctlpar {\fs20 {\pict\macpict\picw161\pich113\picwgoal3220\pichgoal2260 -06d600000000007100a1001102ff0c00fffe0000004800000048000000000000007100a1000000000001000a00000000007100a10099801600000000007100a10000000000000000004800000048000000000001000100010000000000325a440000000000006dac000000010000ffffffffffff0001000000000000000000 -00007100a100000000007100a10040000a00000000007100a106f9ff0080f40006f9ff0080f40006f9ff0080f40006f9ff0080f40006f9ff0080f40006f9ff0080f40006f9ff0080f4000b01ffc1fdff02e7ff80f4000b01ff9cfdff02e7ff80f4000c08ff9fe1c1e1e1c3ff80f4000c08ff9fccc4cccce7ff80f4000c08ff -9fcccccfe0e7ff80f4000c08ff9fcccce1cce7ff80f4000c08ff9fccccfccce7ff80f4000b01ff9cfdcc02e7ff80f4000c08ffc1e1cce1e0f1ff80f40006f9ff0080f40006f9ff0080f40006f9ff0080f40006f9ff0080f40006f9ff0080f40006f9ff0080f40006f9ff0080f40006f9ff0080f40005edff018000070080ee -00018000070080ee00018000070080ee00018000070080ee00018000070080ee00018000070080ee0001800009028000fff0000180000902800018f0000180000c038000183ffe3cf4000180000c0380001838fe66f4000180000d06800018303e6066f4000180000d068000183066607ef4000180000d0680001830666060 -f4000180000c0380001830fe66f4000180000d06800018303e3c3cf400018000070080ee00018000070080ee00018000070080ee00018000070080ee00018000070080ee00018000070080ee00018000070080ee00018000170580007e000070fe000c0f8000000600003000c00080001605800060000030fe000418c00000 -06fd0003c00080001715800060667c30f1f9e018078f878f1e3c71f1e1e08000171580006066663199c330180cceccc61c6631d8c3308000171580007c3c6631998330180ccccc06183e3198c300800017158000601866319983f0180cccc78618663198c1e0800017158000603c6631998300180cccc0c618663198c03080 -00170980006066663199833018fecc08c618663198c3308000171580007e667c30f181e00f878cc783983e319871e080000b0080fe000060f2000180000b0080fe000060f200018000070080ee00018000070080ee00018000070080ee00018000070080ee00018000070080ee00018000170980007c000e30000001f0fe00 -08c00003000c0000800017048000660018fe00010318fe0000c0fe00040c0000800017158000631e3c71f0f00300f1f0f1e3f3c71f1e000080001715800063331831d998030199d998c386631d8c00008000171580006333183199980301999980c303e3198c0000800017158000633f183199f803019998f0c30663198c00 -008000171580006330183199800301999818c30663198c00008000171580006633183199980319999998c30663198c00008000171580007c1e183198f001f0f198f07303e3198700008000070080ee00018000070080ee00018000070080ee00018000070080ee00018000070080ee00018000070080ee00018000070080ee -00018000150980003e00183000700018fe00011c70fc00018000150980006300180000c00018fe00010c30fc0001800016098000601e3c70f1e33018fe0f020c3198fd00018000160f80006033183198c330181999998c3198fd00018000160f80003e1f183180c3301819980f8c3198fd00018000160f800003331830f0c3 -30181998198c3198fd00018000160f80000333183018c330181998198c3198fd00018000160f80006333183198c330181999998c3198fd00018000160f80003e1f0e30f0c1f01f8f0f0f8c30f8fd000180000f0080fa000030fb000018fd00018000110080fb00010330fc00010198fd00018000100080fb000101e0fb0000 -f0fd00018000070080ee00018000070080ee00018000070080ee00018000070080ee00018000160f80003e0018300070000f8e00300038e0fd00018000160f80006300180000c00018c60030001860fd0001800017108000601e3c70f1e33018061e3e1e186330fe00018000170a80006033183198c3301806fe3302186330 -fe00018000171080003e1f183180c3301bc633331f186330fe00018000170a800003331830f0c33018c6fe3302186330fe00018000170a80000333183018c33018c6fe3302186330fe00018000170a80006333183198c33018c6fe3302186330fe00018000171080003e1f0e30f0c1f00f861e3e1f1861f0fe000180000f00 -80fa000030fa000030fe00018000110080fb00010330fb00010330fe00018000110080fb000101e0fb000101e0fe00018000070080ee00018000070080ee00018000070080ee00018000070080ee00018000070080ee0001800005edff0180000000ff0000}} -\par \pard \s20\qc\fi200\ri-40\sa120\keep\keepn\widctlpar\tqr\tx1600 Fig. 21: The Consat menu. -\par \pard \s20\fi-280\li280\sa120\widctlpar {\i Trace} -\par \tab presents a new menu that can be exited by using {\i do nothing}. It contains operations to select constraints that are to be included in the trace. -\par -\par \pard \s20\qc\li360\sa120\widctlpar {\fs20 {\pict\macpict\picw306\pich80\picwgoal6120\pichgoal1600 -047a0000000000500132001102ff0c00fffe000000480000004800000000000000500132000000000001000a000000000050013200998028000000000050013200000000000000000048000000480000000000010001000100000000003259e00000000000006e14000000010000ffffffffffff0001000000000000000000 -000050013200000000005001320040000a000000000050013208000fddff02fc000008001fddff02fe000007003fdcff01000007007fdcff01800005dbff0180000df2ff003ffdff00f3f0ff01c0000df2ff003ffdff00f3f0ff01c00012f3ff09c70787878f0fe19983c3f3ff01c00011f3ff009bfe33023667f3fe99f3ff -01c00011f3ff009ffe33021e67f3fe99f3ff01c00012f3ff009ffe33058e07f3999981f3ff01c00012f3ff009ffe3305c67ff399999ff3ff01c00012f3ff009bfe33056677f399999df3ff01c00012f3ff09c73387878f0ff9c183c3f3ff01c0000aecff01f99ff2ff01c0000aecff01b99ff2ff01c00009ecff00c3f1ff01 -c00005dbff01c00005dbff01c000070080dc000140000700bfdcff0140000900a0de0003800140000900a0de0003810140000f06a0200000022020e40003828140000e05a02000000220e30003844140001108a1e700b1c73c22c780e60003882140001108a22880ca2222232880e60003901140001103a228808afe220128 -80e60003a00940001103a228808afe22012880e60003f83d40001108a1e70089c1a2222780e60003882140000d00a0fa000080e60003882140000d00a0fb000007e50003882140000900a0de00038fe140000900a0de0003800140000900a0de0003800140000900a0de0003ffff40000900a0de0003800140000900a0de00 -03800140000900a0de0003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140000900a0de0003800140000e05a00008008208e30003800140000d00a0fe000002e20003800140001007a3 -cb08f0870889c0e50003800140001007a22c88a882088a20e50003800140001007a22808a882088be0e50003800140000f06a22808a8820852e40003800140001007a3c808a8818821e0e50003800140000900a2de0003800140000900a2de0003800140000900a0de0003800140000900a0de0003800140000900a0de0003 -800140000d00a0fc000008e40003800140000d00a0fc000008e40003800140000f06a1c73cf1c8ac78e40003800140000f06a228aa8a28b288e40003ffff40000f06a208aa8a28a288e40003800140000f06a208aa8a29a288e40003800140000f06a1e72af1c6a278e400038fe140000c03a0000080e10003882140000c03 -a0000080e10003882140000900a0de0003882140000900a0de0003f83d40000900a0de0003a00940000900a0de0003901140000900a0de0003882140000900a0de0003844140000900e0de00038281c000090060de00038101c000090060de00038001800007003fdcff01000008001cdd00020e0000080007ddff02fc0000 -0000ff0000}} -\par \pard \s20\qc\fi200\ri-40\sa120\keep\keepn\widctlpar\tqr\tx1600 Fig. 22: Menu with Consat trace options. -\par \pard \s20\fi-280\li280\sa120\widctlpar {\i primitive} -\par \tab It is possible to select one or several constraints that are to be traced from the menu of all primitive constraints. -\par {\i compound} -\par \tab It is possible to select one or several constraints that are to be traced from the menu of all compound constraints. -\par {\i Explore Constraints} -\par \tab enables a screen-oriented exploration of the constraint part (cf. Figure 23). The exploration window is divided into a selection field, two option switches with two alternatives each and one display field. -\par \pard \s20\qc\li360\sa120\widctlpar {\fs20 {\pict\macpict\picw510\pich322\picwgoal10200\pichgoal6440 \picscalex84\picscaley84 -140e00000000014201fe001102ff0c00fffe0000004800000048000000000000014201fe000000000001000a00000000014201fe0099804000000000014201fe0000000000000000004800000048000000000001000100010000000000325b840000000000006e82804000010000ffffffffffff0001000000000000000000 -00014201fe00000000014201fe0040000a00000000014201fe04c2ff00fc060080c300000c060080c300000c060080c300000c1002bf7ff7f1ff00c0e900001fefff00ec2002804010f000003cfe001060000c00603e0000300000063000002010eb00000c2502bf4017f1ff01c062fe000060fe00076030000030000006fe -00013030fe00001fefff00ec2302804010f00017603c7c38f3678cf8f030667e31e3678f31e3e03871e3e330ee00000c2502bf4017f1ff19c0606666646388cccc60306667333388c63333303cf33333301fefff00ec2302804010f00017606666706307cccc603c6667333307c63333302fb3333330ee00000c2502bf4017 -f1ff19c060666638630ccccc60303c6733330cc63333302733f333301fefff00ec2302804010f000176066661c630ccccc6030666733330cc63333302233033330ee00000c2502bf4017f1ff19c06266664c630ccccc6030666733330cc633333020331333301fefff00ec2302804010f000173c3c66383307cccc303e667e -31e307c331e3302031e331f0ee00000c1402bf7ff7f1ff00c0f6000060f500001fefff00ec0a0080e3000060e200000c060080c300000c060080c300000c04c2ff00fc060080c300000c060080c300000c060080c300000c060080c300000c110080e200070e00000400010010ea00000c110080e2000311000004fe000010 -ea00000c120080e20008103963ce58f11638f0eb00000c110080e200071045940465111911ea00000c120080e200081045138441111110e0eb00000c120080e20008114510444131111010eb00000c120080e200080e39178340d1110de0eb00000c060080c300000c060080c300000c0a0080e3000001e2ff00ec110080e9 -000001fdff01e001e4ff02f0002c110080e9000002fd00011001e4ff02f0202c150080e9000004fd00050801e0c6ec6fe8ff02f0502c160080e9000a040f003f000801efbaebafe8ff02f0882c160080e9000a0418800c000801efbaebafe8ff02f1042c160080e9000a04180f0c3c0801e1bae82fe8ff02f2022c160080e9 -000a0418198c660801efbaebafe8ff02f4012c150080e9000a041b998c660801efbaebafe7ff0107ac19038000001eec000a0419998c660801e0c71ba0e8ff02f1042c1f0b8000006180f80000c018018cf400080419998c660801fffbe6ff02f1042c1d0b8000008040cc0000c0000180f400060419998c660801e4ff02f1 -042c200e8000008040cc7871e6d8e3cc78f870f70006040f0f0c3c0801e4ff02f1fc2c1f0e8000010020ccccc8c719918cccccc8f7000004fd00010801e4000210002c1f0e8000010020f8cce0c619818ccccce0f7000004fd00010801e4000210002c240e8000010020ccfc70c619818ccccc70f7000002fd000610011145 -f39139e900021fffec240e8000010020ccc038c619818ccccc38f7000001fdff06e0011165045145e9000210002c1f0e8000008040ccc498c619918ccccc98f10005011155045145e9000210002c1f0e8000008040cc78706618e0cc78cc70f1000501114de4517de9000210002c15048000006180e70005011145045145e9 -000210002c14038000001ee60005011145045145e9000210002c170080e9000001fdff07f8010e45f38e45f0ea000210002c150080e9000002fd00010401fe000040e8000210002c110080e9000004fd00010201e4000210002c120080e90001040ffe00010201e4000210002c120080e9000604188000000201e400021000 -2c120080e9000604180f1f198201e4000210002c120080e9000604181999998201e4000210002c120080e9000604181999998201e4000210002c15038000001eec000604181999998201e4000210002c1f05800000618078fe0004c0001800c0f6000604181999998201e4000210002c1f058000008040c4fe0000c0fe0000 -c0f600010418fe99018201e4000210002c200e8000009e40c078f871e6cf19f1e380f70006040f0f1f0f8201e4000210002c200e8000013f20c0ccccc8c7119998c640f7000604000018018201e4000210002c1f0d8000013f20c0cccce0c60f9998c7f6000604000018118201e4000210002c200e8000013f20c0cccc70c6 -199998c380f7000002fe00020f0401e4000210002c1f0e8000013f20c0cccc38c6199998c1c0f7000001fdff01f801e4000210002c1a0e8000009e40c4cccc98c6199998c4c0f1000001e4000210002c1a0e80000080407878cc70660f99986380f1000001e4000210002c10048000006180e7000001e4000210002c0f0380 -00001ee6000001e4000210002c0c0080e3000001e4000210002c0c0080e3000001e4000210002c0c0080e3000001e4000210002c0c0080e3000001e4000210002c0c0080e3000001e4000210002c0c0080e3000001e4000210002c0c0080e3000001e4000210002c0c0080e3000001e4000210002c0c0080e3000001e40002 -10002c0c0080e3000001e4000210002c0c0080e3000001e4000210002c0c0080e3000001e4000210002c0c0080e3000001e4000210002c0c0080e3000001e4000210002c110080fd000101e0e9000001e4000210002c220080fd001206180f803000318c0000078000000c0001800cfa000001e4000210002c220080fd000e -08040cc00000018000000c4000000cfe00000cfa000001e4000210002c230080fd001309e40ccdb3fe33cccc780c078f871e6cf19f1e38fb000001e4000210002c230080fd001313f20cce3333318ccccc0c0ccccc8c7119998c64fb000001e4000210002c230080fd001313f20f8c3333318ccccc0c0cccce0c60f9998c70 -fb000001e4000210002c230080fd001313f20c0c3333318cccfc0c0cccc70c6199998c38fb000001e4000210002c230080fd001313f20c0c3333318cccc00c0cccc38c6199998c1cfb000001e4000210002c230080fd001309e40c0c3333318cc8c40c4cccc98c6199998c4cfb000001e4000210002c230080fd001308040c -0c333330ccf07807878cc70660f9998638fb000001e4000210002c110080fd00010618e9000001e4000210002c110080fd000101e0e9000001e4000210002c0c0080e3000001e4000210002c0c0080e3000001e4000210002c0c0080e3000001e4000210002c0c0080e3000001e4000210002c0c0080e3000001e400021000 -2c0c0080e3000001e4000210002c0c0080e3000001e4000210002c0c0080e3000001e4000210002c110080fd000101e0e9000001e4000210002c210080fd000306180780fb00020c0078fe0004c0001800c0fc000001e4000210002c210080fd000308040c40fb00020c00c4fe0000c0fe0000c0fc000001e4000210002c25 -0080fd001508040c078ff8f878ccf87c00c078f871e6cf19f1e380fd000001e4000210002c210080fd000310020c0cfacc0a00c0ccccc8c7119998c640fd000001e4000210002c200080fd000310020c0cfacc0900c0cccce0c60f9998c7fc000001e4000210002c210080fd000310020c0cfacc0a00c0cccc70c6199998c3 -80fd000001e4000210002c210080fd000310020c0cfacc0a00c0cccc38c6199998c1c0fd000001e400021fffec210080fd000308040c4cfacc0a00c4cccc98c6199998c4c0fd000001e4000210002c250080fd0015080407878cccf8787ccc7c007878cc70660f99986380fd000001e4000210002c150080fd00010618fd00 -00c0ee000001e4000211fc2c150080fd000101e0fd0000c0ee000001e4000211042c0c0080e3000001e4000211042c0c0080e3000001e4000211042c0c0080e3000001e400021f07ac0c0080e3000001e4000214012c0c0080e3000001e4000212022c0c0080e3000001e4000211042c0c0080e3000001e4000210882c0c00 -80e3000001e4000210502c0c0080e3000001e4000210202c0c0080e3000001e4000210002c0a0080e3000001e2ff00ec060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c0600 -80c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c0a0080e4000004e100000c0a0080e4000006e100000c0a0080e4000007e100000c0b0080e400010780e200000c -0b0080e4000107c0e200000c0b0080e4000107e0e200000c190e813cfbe71c89cfbc7088be03e72272f2000107f0e200000c190e813cfbe71c89cfbc7088be03e72272f2000107f0e200000c190e82228208a2ca2222888c880208a28af2000107f8e200000c190e8422820822aa0222888a880208a28af2000107c0e20000 -0c190e8422f3c82299c23cf8898803c8a2faf2000106c0e200000c19078422820822882222fe88030208a28af200010460e200000c180782228208a28a2222fe88030208a28af1000060e200000c1907813cfa071c89c222fe880403e71c8be0f2000030e200000c0e0080f5000080f0000030e200000c060080c300000c06 -0080c300000c060080c300000c160080f6000c403e8bcf80f3c22223e222f880db00000c160080f6000c80088a28008a22362082228040db00000c170080f7000d0102088a28008a222a2082228020db00000c170080f7000d01000853cf00f3c222208222f020db00000c170080f7000d0100082208008222222082228020 -db00000c160080f6000c80082208008222222082148040db00000c160080f6000c4208220f80822222208208f880db00000c060080c300000c060080c300000c060080c300000c060080c300000c160080f6000c40088befbcf9c73e01c10071c2db00000c160080f6000c8008c888228228a00223008a21db00000c180080 -f7000e010208a88822822820020100802080dc00000c180080f7000e010008988f3cf3e83c020100804080dc00000c170080f7000b010008888822822820020100fe80dc00000c160080f6000c80088888228228a00221008901db00000c160080f6000c4208888fa282273e01c10073e2db00000c060080c300000c060080 -c300000c060080c300000c060080c300000c310080f60027403cfa073e21c880100fa2f20f8013cfbc03cfbe10400201f45e41f00239e7df44039e7df4441040f600000c310080f600278022820888222c802002228a08002228220228210820040044514100044514106404514106420820f600000c320080f70028010222 -820888222a804082228a08004228220228210410081044514100084114105404114105410410f600000c320080f7002801003cf20f88222980400222f20f0043cf2203cf2104100800445e41e0084de79e4c04de79e4c10410f600000c320080f7002801002282088822288040022282080042282202282104100800445041 -00084514104404514104410410f600000c310080f6002780228208882228802002228208002228220228210820040044504100044514104404514104420820f600000c310080f600274222fbe88821c88010821c83ef80122fbc022fbe1040021043907df0023917df4403917df4441040f600000c060080c300000c060080 -c300000c060080c300000c060080c300000c140080f6000a401c722f08f8872203e208d900000c140080f6000a80228b28882088b2008104d900000c150080f7000b0102208aa8882088aa008082d900000c150080f7000b0100208a68882088a6008082d900000c150080f7000b0100208a28882088a2008082d900000c14 -0080f6000a80228a28882088a2008104d900000c140080f6000a421c722f08208722008208d900000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c0600 -80c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080 -c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c3 -00000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300 -000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c30000 -0c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c -060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c060080c300000c04c2ff00fc04c2ff00fc00ff0000}} -\par \pard \s20\qc\fi200\ri-40\sa120\keep\keepn\widctlpar\tqr\tx1600 Fig. 23: The screen during the constraint exploration. -\par \pard \s20\li360\sa120\widctlpar The selection field {\i Constraints} can list names of constraints or restrictions. This depends on the first option switch. When this option switch is set to {\i Constraints} -, the second option switch can be used to choose between primitive and compound constraints. When a restriction or a constraint is selected, its representation will be shown in the display field. -\par In addition, there is a {\i GoTo} and a {\i Copy} button. Clicking on the first one activates the knowledge base editor and positions it to the definition of the selected construct. -\par The second button can be used to copy the text shown in the display field into the kill-buffer of the knowledge base editor. Then, the text can be transferred and copied into the knowledge base by means of the editor (emacs) (which is usually achieved by -pressing the Control-Y key). This is necessary, when new constraints are created by using the operation {\i Define Constraint }(cf. the next menu entry). These constraints are only kno -wn in the internal, but not in the external representation of the knowledge base, which is stored in the corresponding file. -\par \pard \s20\fi-280\li280\sa120\widctlpar {\i Define Constraint} -\par \tab enables the interactive definition of constraints. The definition process is supported by menus and input requests. -\par {\i Satisfy Locally} -\par \tab When the programmer has selected a constraint (primitive or compound), he/she will be successively asked to enter its initial values. Afterwards the system will try to find a locally consistent solution. -\par {\i Satisfy Globally} -\par \tab -When the programmer has selected a constraint (primitive or compound) and specified the maximum number of global solutions that are to be computed, he/she will successively be asked to enter its initial values. Afterwards, the system will try to find glob -ally consistent solutions. -\par \pard\plain \s2\li180\sb120\sa120\keepn\widctlpar\brdrb\brdrs\brdrw15 \b\f8\fs36\lang1031 5.\tab The Interface Mixin -\par \pard\plain \s20\li360\sa120\widctlpar \f8\lang1031 -The user-interface described here is usually based on the normal-interface-mixin, which is also available on other computers. In the configuration of an expert system it must be specified by the option :interface. For example: -\par \pard\plain \s29\keep\widctlpar\tx880\tx1740\tx2620\tx3480\tx4320\tx5220\tx6060\tx6940\tx7780 \f3\fs20\lang1031 \tab (def-kb-configuration crossingc -\par \tab (:procs normal-frame-mixin -\par \tab normal-rule-mixin -\par \tab normal-constraint-mixin -\par \tab lisp-mixin -\par \tab normal-prolog-mixin -\par \tab free-text-mixin) -\par \tab (:interface normal-interface-mixin)) -\par \pard\plain \s20\li360\sa120\widctlpar \f8\lang1031 -\par The normal-interface-mixin mainly provides menus and windows. -\par \pard\plain \s3\li360\sb120\sa120\keepn\widctlpar \b\f8\fs28\lang1031 5.1\tab Menus -\par \pard\plain \s20\li360\sa120\widctlpar \f8\lang1031 There are two types of menus: -\par \pard \s20\fi-280\li280\sa120\widctlpar \bullet \tab menus to select {\b one} node, which is activated by the selection. -\par \bullet \tab menus to select {\b several} nodes, which are individually selected and then activated by clicking on the confirmation field {\i Do It}. When selecting entries the Shift and Command keys play an important role: -\par \tab {\b Shift:} all entries from the first one to the last one are selected. -\par \tab {\b Command:} the last entry is toggled. This means that the entry is selected, if it has not been selected yet, otherwise the selection will be annuled. -\par \pard \s20\li360\sa120\widctlpar A lot of menus also provide additional information in the form of menu entries that are not to be selected. To this end, other computers provide such entries with a {\i :no-select} - property. The Macintosh pop-up menus do not have such a property. Thus, these entries can be selected, but yield nil. -\par {\b 5.2\tab Windows} -\par The {\b normal-interface-mixin} creates three windows for any expert system: -\par \pard \s20\fi-280\li280\sa120\widctlpar \bullet \tab a trace window as an instance of the editor window (*fred-window*), which displays the system, the rule, the Prolog as well as the constraint trace. -\par \bullet \tab an explanation window as an instance of the editor window (*fred-window*), which displays all explanations. -\par \bullet \tab and an editor window, which can edit the knowledge base of the expert system. -\par \pard \s20\li360\sa120\widctlpar The dialog window of all expert systems is mapped to the Top Lisp Listener. -\par \pard\plain \s2\li180\sb120\sa120\keepn\widctlpar\brdrb\brdrs\brdrw15 \b\f8\fs36\lang1031 \page 6.\tab Additional Information -\par \pard\plain \s20\li360\sa120\widctlpar \f8\lang1031 -You can adjust BABYLON in different ways to meet your requirements. You can develop new interpreters or user-interfaces or modify the supplied source code. Apart from this rather time-consuming method there are also a few global variables, which can be mo -dified in the file {\b babylon:bab-init.cl}. -\par A few crucial variables are the keyboard functions for special actions. For example, after an input request you can ask for a context explanation during a BABYLON consultation by pressing the {\b Help } -key (bound to the ?-key), and for information about the possible answers by pressing the {\b Control-Help} key (bound to the Escape-key, but note that this one is internally described as Clear!). -\par In addition, you can vary the maximum length of menu entries (initially set to 50) and define the maximum number of menu entries (initially set to 20). -\par \pard\plain \s29\keep\widctlpar\tx880\tx1740\tx2620\tx3480\tx4320\tx5220\tx6060\tx6940\tx7780 \f3\fs20\lang1031 \tab (setf *help-key* #\\? -\par \tab *c-help-key* #\\escape -\par \tab *end-key* #\\return -\par \tab *item-width* 50 -\par \tab *max-menu-entries* 20) -\par \pard\plain \s20\li360\sa120\widctlpar \f8\lang1031 -\par In order to change other important system parameters refer to the documentation in the book or the sources of the implementation. -\par -\par -\par } \ No newline at end of file diff --git a/t/baby2015/doc/overview.pdf b/t/baby2015/doc/overview.pdf deleted file mode 100644 index 1cd94ee..0000000 Binary files a/t/baby2015/doc/overview.pdf and /dev/null differ diff --git a/t/baby2015/doc/overview.rtf b/t/baby2015/doc/overview.rtf deleted file mode 100644 index 2536278..0000000 --- a/t/baby2015/doc/overview.rtf +++ /dev/null @@ -1,748 +0,0 @@ -{\rtf1\mac\deff2 {\fonttbl{\f0\fswiss Chicago;}{\f2\froman New York;}{\f3\fswiss Geneva;}{\f4\fmodern Monaco;}{\f5\fscript Venice;}{\f6\fdecor London;}{\f7\fdecor Athens;}{\f8\fdecor San Francisco;}{\f11\fnil Cairo;}{\f12\fnil Los Angeles;} -{\f13\fnil Zapf Dingbats;}{\f14\fnil Bookman;}{\f15\fnil N Helvetica Narrow;}{\f16\fnil Palatino;}{\f18\fnil Zapf Chancery;}{\f20\froman Times;}{\f21\fswiss Helvetica;}{\f22\fmodern Courier;}{\f23\ftech Symbol;}{\f24\fnil Mobile;}{\f33\fnil Avant Garde;} -{\f34\fnil New Century Schlbk;}{\f203\fnil GrayChicago;}{\f1038\fnil lcirclew10;}{\f1855\fnil lcmssb8;}{\f2296\fnil lcircle10;}{\f2444\fnil lcmss8;}{\f2515\fnil MT Extra;}{\f2977\fnil lcmssi8;}{\f7400\fnil cmb10;}{\f7401\fnil cmbsy10;}{\f7402\fnil cmbx5;} -{\f7403\fnil cmbx6;}{\f7404\fnil cmbx7;}{\f7405\fnil cmbx8;}{\f7406\fnil cmbx9;}{\f7407\fnil cmbx10;}{\f7408\fnil cmbx12;}{\f7409\fnil cmbxsl10;}{\f7410\fnil cmbxti10;}{\f7411\fnil cmcsc10;}{\f7412\fnil cmdunh10;}{\f7413\fnil cmex10;}{\f7414\fnil cmff10;} -{\f7415\fnil cmfi10;}{\f7416\fnil cmfib8;}{\f7417\fnil cminch;}{\f7418\fnil cmitt10;}{\f7419\fnil cmmi5;}{\f7420\fnil cmmi6;}{\f7421\fnil cmmi7;}{\f7422\fnil cmmi8;}{\f7423\fnil cmmi9;}{\f7424\fnil cmmi10;}{\f7425\fnil cmmi12;}{\f7426\fnil cmmib10;} -{\f7427\fnil cmr5;}{\f7428\fnil cmr6;}{\f7429\fnil cmr7;}{\f7430\fnil cmr8;}{\f7431\fnil cmr9;}{\f7432\fnil cmr10;}{\f7433\fnil cmr12;}{\f7434\fnil cmr17;}{\f7435\fnil cmsl8;}{\f7436\fnil cmsl9;}{\f7437\fnil cmsl10;}{\f7438\fnil cmsl12;} -{\f7439\fnil cmsltt10;}{\f7440\fnil cmss8;}{\f7441\fnil cmss9;}{\f7442\fnil cmss10;}{\f7443\fnil cmss12;}{\f7444\fnil cmss17;}{\f7445\fnil cmssbx10;}{\f7446\fnil cmssdc10;}{\f7447\fnil cmssi8;}{\f7448\fnil cmssi9;}{\f7449\fnil cmssi10;} -{\f7450\fnil cmssi12;}{\f7451\fnil cmssi17;}{\f7452\fnil cmssq8;}{\f7453\fnil cmssqi8;}{\f7454\fnil cmsy5;}{\f7455\fnil cmsy6;}{\f7456\fnil cmsy7;}{\f7457\fnil cmsy8;}{\f7458\fnil cmsy9;}{\f7459\fnil cmsy10;}{\f7460\fnil cmtcsc10;}{\f7461\fnil cmtex8;} -{\f7462\fnil cmtex9;}{\f7463\fnil cmtex10;}{\f7464\fnil cmti7;}{\f7465\fnil cmti8;}{\f7466\fnil cmti9;}{\f7467\fnil cmti10;}{\f7468\fnil cmti12;}{\f7469\fnil cmtt8;}{\f7470\fnil cmtt9;}{\f7471\fnil cmtt10;}{\f7472\fnil cmtt12;}{\f7473\fnil cmu10;} -{\f7474\fnil cmvtt10;}{\f7477\fnil lasy5;}{\f7478\fnil lasy6;}{\f7479\fnil lasy7;}{\f7480\fnil lasy8;}{\f7481\fnil lasy9;}{\f7482\fnil lasy10;}{\f7483\fnil lasyb10;}{\f7484\fnil line10;}{\f7485\fnil linew10;}{\f12899\fnil AppleGaramond LtIt;} -{\f12900\fnil AppleGaramond BkIt;}{\f12901\fnil AppleGaramond BdIt;}{\f12902\fnil AppleGaramond Lt;}{\f12903\fnil AppleGaramond Bk;}{\f12904\fnil AppleGaramond Bd;}}{\colortbl\red0\green0\blue0;\red0\green0\blue255;\red0\green255\blue255; -\red0\green255\blue0;\red255\green0\blue255;\red255\green0\blue0;\red255\green255\blue0;\red255\green255\blue255;}{\stylesheet{\s242\li360\sa120 \f20 \sbasedon0\snext0 page number;}{\s243\li360\sa120\tqc\tx4252\tqr\tx8504 \f20 \sbasedon0\snext0 footer;}{ -\s245\li360\sa120 \f20\fs18\up6 \sbasedon0\snext0 footnote reference;}{\s246\li360\sa120 \f20\fs20 \sbasedon0\snext0 footnote text;}{\s250\li360\sb120\sa120\keepn \b\f20\fs28 \sbasedon0\snext0 heading 6;}{\s251\li360\sb120\sa120\keepn \b\f20\fs28 -\sbasedon0\snext0 heading 5;}{\s252\li360\sb120\sa120\keepn \b\f20\fs28 \sbasedon0\snext0 heading 4;}{\s253\li360\sb120\sa120\keepn \b\f20\fs28 \sbasedon0\snext0 heading 3;}{\s254\li180\sb120\sa120\keepn\brdrb\brdrs \b\f20\fs36 \sbasedon0\snext0 -heading 2;}{\s255\li360\sb240\sa240\keepn\brdrb\brdrs \b\f20\fs48 \sbasedon0\snext0 heading 1;}{\li360\sa120 \f20 \sbasedon222\snext0 Normal;}{\s1\fi-540\li900\sa120\tx900 \f20 \sbasedon0\snext1 numbered list;}{\s2\fi-540\li1440\sa120\tx1440 \f20 -\sbasedon0\snext2 numbered list 1;}{\s3\fi-540\li1980\sa120\tx1980 \f20 \sbasedon0\snext3 numbered list 2;}{\s4\fi-280\li900\sa120\tx900 \f20 \sbasedon1\snext4 bullet list;}{\s5\fi-280\li1440\sa120\tx1440 \f20 \sbasedon2\snext5 bullet list 1;}{ -\s6\fi-280\li1980\sa120\tx1980 \f20 \sbasedon3\snext6 bullet list 2;}{\s7\fi-3960\li4320\sa120\tx4320 \f20 \sbasedon0\snext7 glossary;}{\s8\fi-3960\li4860\sa120\tx4860 \f20 \sbasedon7\snext8 glossary 1;}{ -\s9\keep\tx880\tx1740\tx2620\tx3480\tx4320\tx5220\tx6060\tx6940\tx7780 \f22\fs20 \sbasedon0\snext9 pre;}{\s10\li360\sa120 \i\f20 \sbasedon0\snext10 address;}{\s11\li1440\ri1440\sa120 \i\f20 \sbasedon0\snext11 blockquote;}{\s12\sb120\sa120\brdrb\brdrth -\f20 \sbasedon0\snext0 hr;}{\s13\fi360\tx360\tx3600\tx4320\tx7200\tx10700 \f20 \sbasedon0\snext13 dir;}{\s14\fi360\li360\tx720\tx3960\tx4320\tx7560\tx10700 \f20 \sbasedon0\snext14 dir 1;}{\s15\fi360\li720\tx1080\tx4320\tx7920\tx10700 \f20 -\sbasedon0\snext15 dir 2;}{\s16\fi-720\li1440\tx1440 \f20 \sbasedon10\snext16 menu 1;}{\s17\fi-720\li1080\tx1080 \f20 \sbasedon16\snext17 menu;}{\s18\fi-720\li1800\tx1800 \f20 \sbasedon0\snext18 menu 2;}{\s19\fi-3960\li5400\sa120\tx5400 \f20 -\sbasedon8\snext19 glossary 2;}{\s20\li360 \f22 \sbasedon0\snext20 HTML;}}{\info{\title overview}{\subject babylon overview}{\author J¸rgen Walther}}\paperw11880\paperh16820\margl1418\margr1418\margt1447\margb1447\deftab709\widowctrl\ftnbj\ftnrestart -\sectd \linemod0\linex0\cols1\colsx0\endnhere \pard\plain \s255\li-20\sb240\sa240\keepn\brdrb\brdrs \tx440 \b\f20\fs48 The AI-Workbench BABYLON\par -\pard \s255\li-20\sb240\sa240\keepn\brdrb\brdrs \tx440 A Short Description\par -\pard\plain \qc\li-20\sa120\tx440 \f20 {\fs36 \par -}\pard \qc\li-20\sa120\tx440 {{\pict\macpict\picw415\pich388 -411200a60004022a01a31101a0008201000a0000000002d0024098003600a60000022a01a800a60004022a01a300a60004022a01a3000002cb0002cb0002cb0002cb0002cb0002cb0002cb0002cb0002cb0002cb0002cb0002cb0002cb0002cb0002cb0002cb0002cb0002cb0002cb0002cb0002cb0002cb0002cb0007fe00 -010303d00009fd000303033210d30009fe000301000070d2000dfd0003444488c0fe000030d7000efd000320000848fc00012220da000efe00040400332230fb000080da0009fd0003084c0820d30015fe000310100cc8fe000002ea000044fb000018f5000ffe0002400012e7000340ccccc0ef0014fe000210400ce80004 -414fffc750fc000018f5001dfe000514c00c400020ec0005028157331710fc000018fd00018008fb001ffe000616408808000020ed00050a02fbb36750fc000018fe000280c008fb001afe0002152102e900051a807afdc518fc000008fc00010648fc001efe00010cfbfe000020ec0005102ab6ffe038fc00022c0004fd00 -0008fc001cfe000204c880eb0007301059403a0368f8fc00003cfa00010460fe001efe000302000080fe000002f000077311d00a80ccc3f0fe0002020018f50013e5000736001040701ce1e4fe00020200dcf50018e600080c24015405700862ccfe0002060064fc000020fb0014e600080e84dcd170315075e4fe00020606 -ecf50019fc00012808ed00080477fdc4549dc7f8e6fe0002020b98f50024fb0002088008f6000004fc00100777b6fa00189cd579e78000402a0fbf80f9000040ff0025fc000302000028f800000afa001005e82c00281a00541dd7800000226e2fc0fa000001fe0026fb0002800008f9000318020055fc000f03a80a88140d -d015541662006aab9839f8000004ff001bed00012410fd00100500010b010481c11c0fc20006fbfc7bc0f60022fd00018004f60004a80aa00a90fc000f50cbb33a00f8c5dc15c00082666266c0f6002302000004f4000504400000a010fd001015d8d5139046b0cb9cf1870094ee82efc0f6002405000001a00028f5000340 -000e10fd00100158c59a31ceb0e39ef3e2a1c3baa7efc0f6002d08000002200088000008fa0005110004001408fd00100393d5da44def2ef9ef9e2efe7da1b9dc0fb000004fd0024fe0002200020f70004010800103dfc00100113451e151a00a280f3e8eee6fdef7fc0f60031fe0005888000800020fb000601550550150d -b0fd0018500dc05cc1130aa02a61f9998159187ec00000080000040040fe002cfe00018a8af900081000002000c0002510fd001093008023573300a101b9f9ffe6337cffc0fb00010140fe002d05000002026660fa00084000402a013015445cfd00102a02a075455581d90ba862666036fb9320fd000080fb002dfd000126 -62f8001baa00a8010051031440000082a802a05501449140bb9bfeea2666ddc0fd000040fd0001200028fe0002088919f900080200a1040854055b40fe0010e02a800c0d504540020ff9b99bb3c5ddc0f6002905000002a8a898f90008010003a000000409fcfe001042a00a80000148944209e9ffffb381e760f6002c0600 -000202462618fc001e040000102102a3020458554000004002802a84020181570860edeefbc1e320f6002ffe000380810e60fd002219100001a00aa42c00501540500000ca80aa02a6076666c75899989bb3e0ccc0000004f9002d0600000280200280fd001f154000051011061700040830180001c00194141e4fffffbb0e -effcffd3f1ffe0f6002cfe000360669980fd001f400000015001823a02ac0adc4c00007772aab9a80b9897e666766eefd3b37320f60028fe00024220e9f900140800550350003caadc9ff001746576ff800a2aaaf6feee04fffff7b320f6002bfe0002802064fe000010fc001480214000002f6afe3fddcc8d50356e00cae0 -8ab2b9feff03f5ddefc4f6002cfe000688786000000451fd001c0880000150055a61febfdddcaa90305640556083bab9bbffffefcfdbc4f60028fe000689989400000440fd0002081210fe000e04e9fe3ffffa8838100717c064c693faff00f8f6002efe00044664640001fb001c0807415501542668fc99d99ab855055605 -6e3b9bbbbbbffffcfccedee0fe000004fa0025fe00028381c0f9001108300008030026e9fe3ffff8981030030869f7ff00e0fe000004fa002bfe00011980f8001c1a12a00400540158e726666aa81a1155153077436eefdff6f333316fc0fb000008fd0028fe00010101f8001d10a212af03025209501aae6282f03a830305 -704bfffdfffdff7f777be380f70029fd000054f8001508023045030105481037bffa88a8380f17456bdfffbffcff02f9ffb8fc000020fd0029fd000014f800120800310503000a88001fffffc81038080a50f7fdff00fefcff01fec0fe000002fc0028fe00011014f800120e023007810a2e0c680feff9585da7fae777fdfe -ff01f7f7fdff02fbbba0f80029fe0001664cf8001e0802aa0ae607015899599988f206ac2e07f6fd3f3f7fdef5fccddffe667ee0f8001ffe00015710f800100a0333850800000cfc3f7bdcfa8934471ff4ff00e0f80029fe00011910f8001e1763171aa80ab00a6766674f9909a9ab7f7ecec6cdffe53fb37edffb9999a0f8 -0029fe00011410f8001e0226077400001ab0fe0ae81f7ddf81ffffbffffffdfbfef7ff7deffffbbba0f80022fe00011554f800020fb21cfe00091035bf93e0a77d8f9ff7f7ff04effeffffc0f80022fe0001045cf800010aa0fe000a141011fff2ebe6ff8bfffdfcff00fdf9ff00c0f80029fe00010140f8000e0bbc010154 -101002fbb20eaf7dbfeffeff0cf7fffdfff7fffff6ffbbb9ffe0f80028fe000001f7001e2414205415400c01bb2aa46eecefffaff3d3fdfddcddccdeff7ee466efff30f80021fe000001f700032a000180fe000443f72001effcff00effcff00f7fbff00f0f80024f30013382a882805401548530099abbff6fccdcdcff733 -fe7707ffd999dbbbfeecc0f80024f3001e8aa00a80281550554555ffbbbbbf2ffb5fdccfdfff777f77fff7df9bbb3370f80023f2001dae22b700001505540766feefeffffb37f7fffffd7bdbdffef6adeeffff70f80021f4000e010200280ea8008053015507ffffdffefffe7ffcff05ef7feeffddd0f80024f4000b014000 -20a86aa0000360157bfdff0abdff7bfff7777fffef7fbbfeff01ddc0f80024f3001e0500a80ab82a9050454bdadff3b1ade5fbdbddb7ddffee66f676effb333330f80016f200083000e1000014063a97f9ff00eff6ff00f0f80024f3001e15405600a82a90aa32b5bffffbdbdf97bf3dbf7b7bffd9999d8b7fecccccd8f800 -23f2001d15055528501c82bfefb7fed7f7b5efff7ff737f7ffffdbbbbbfeffddddd8f80023f2001d0174c130000eabeffb5fdff7bdff7ffbfefffffdffafdeeefff7ffff7770f80024f3001a801021d03140000fdfffadbfff7b7fdaf7b7ffefffffdffffefdeffeff00f0f80022f2000d0800c55001005ef7fd7ffffbdffd -fdff037ffffffbfeff04fbffddfff8f80025f4001f0c015015015400e3d2f7bddf7b5356b7b7ffdf7bf8fefe6666676edeb3337370f80015f30007100c0080000007eff0ff00bffdff00f8f80025f4001f1a4228060154053d2f7b77ffb7efefdf7eff76edef6fff9999bbbffdcccdddd8f80025f4000f0151028cc2a0177a -def7777f6f7bdedefeff0877dffff7fbbbbbfffbfedd00d8f80022f3000cc2a82b00000bddf6f5ffff7fdefcff0cbfdeffffedeefffefff77777f8f80024f3000d1002a52bbc57bfbdffdffef7ffbdfeff05feffbbfdfffefeff00f7feff00fcf80023f3000802000aa0bfb5b7fb7ffdff026bffdffeff0beffffbbfbfffff -dfdddffbfcf80026f400200100aa22b837b56c6a4dfff56f776b7edbddb9f9edfe66e66eefbfbb737777f880f90016f1000320f07fdff8ff00effeff00f7f7ff01fec0f90026f4002005588400c77e5ef7b5effddfdfd6bdffed6beefefbb9b9bbbbff9ec7cdddfdae40f90026f400200201d40576f7bdf76bdffdddddef7b -fbcef6adfd7b79dbb6f7ffffcf5ddfdbee40f90026f4002001111561f5ddef6ffffef7ffef7bfffeffbffdeffffeefefbdbfff7f7ffffffb80f90026f4000e03110231ff7bdad6f7bdeff3f6d7f7feff0e7bfef7b7efef7ffff67ef77ffffba0f90025f3001f0b8e2b7bdef6b7ffef7fffffbffeef7fffdeffbfedfffbdede -ffbfbfffffeee0f90025f3001f1a94dc5ff7b7af6f6adefefdede999bffee5eeeffbfbdbdf37b73d9ddfdffba0f90019f3000b1880bfffff7bfffff7ffef7ff3ff00dffdff00e0f90029f70023c000000302aff76f6b1af6f6bdef6bde6ef7bdbd89dbdbfeecbeed4cdfd7d3f66ffffb90f90027f500210c0d050f7ffed6f5 -fdcd7bdad7b42da77afffb9fb7bffffeeccccdfffff67fefeff0f90026f400202882eb1dd7b5fded6bded6bffded5bfbfbfeedbdffffdbb3337fffdff9bfffffe0f90026f50015032015d6ffbdef7f7bdef7bfff7bdbbbffbffffffbeffeff0277777ffdff01bbf0f90022f5000e05f006b5fffffbfed6ffbdffffded7fdff -06bffef7ffffddddfaff00f0f90027f50015061574ad9d6bdefed5bded5bdadeb5bbfeeedeeee7b7fe330837fffffddbffffeee0f9000cf300fbff007fe9ff00f0f90028f5001b02076adef4bdedef5bfed7bdadfb7b9abbb7bbbffefbccecddff777ffeff03fbbbb002fa0027f400212ef7bdadfb5b9af7b5af7b7afef7f5 -eb6ffbbffef7ccedcdffff7fffe7ffffbbb002fa0028f500180217bdef6b7adef7ffbfff7bdff7b7abff6fcfdefffdf77777feff06dfbffffffec040fa0022f5001002ef7f5bdeffbdefff7bdef7ffefefffdffdff03fbfff7f7f9ff01f040fa001cf50011037bfed6f7ffef6fffdeffbdffffdfffffbff2ff01f002fa0028 -f5002202dfded7bfe56bdbde93bdbb7f5bceeeacefdf33777ff77fcffddffdbfffffefccc042fa0010f5000507ffff7ffffee6ff01f040fa0027f5002107adeff99bd597bfef7fdbf7f7bdbbb33b37ffcccccffdfff7ff7766efffffbbb330f90026f50014077bdef7ffadef3b7efefdfdef7ffffa3737fffdfdfcff087f76 -efffffbbb37002fa0021f5001503ded7b7feef7bdefff7bdef7bdfffffdffffff77ff7f7ff02dff802fa0024f5000b07b7fdef7bdff6f7bdef7bdefdff01dffbfeff00f7fcff00bbfdff02ddd802fa0019f5000f05ef7ffc9ef7bdefff7bdef7fdffef7ff0ff00f9f90028f5001201ef5bdef7b5bd3b7b52f7b7ef6c7addf6 -7bb7fdff0cddd9dfbee667ffffdff7712240fb0014f5000906ffffefffffdffffffdeaff01fd20fa0029f5001306b1bdaf3b5ad6f7f5afeb7afef37feffdcfdcddfdff0477ffffbb9bfeff04dccc81802cfc0026f5001307ab7f5efeb7adefebdff6bdf5f777ffffdfdddffaff01bfbbfeff04dddd8180fefc0025f5001107 -7edff7f5bdef7b5efff7bdef7ffbfffff7f9ff02feefeffeff047777a4effefc0028f5000e06f6f5bfff7fdff6b7bdef7bfafddffeff01777ffdff04fbbbffffeffdff03f766eeeefc0022f5000a07bfefff7bdef7f5bfff5bfdff01fddff7ff05bfbffffffdddfeff00eefc002af5002407ed6f7f76f737a7ff6bced6dddf -ff73373777ffddfdfdfffefe7e7feefffffb337766fbbbfc0016f5000c03ffffb7bffffb7ffff7ffef7eeaff00fefc002af500240233f6b5ed6fdadef6b5bd6f73fddcdddddffff7f66ffefff99ffbbfbffeefdccddffee66efc002af50024053ffd6f5fdef7fdbd6b7bd6b377fffdffdddfffff67fe7feffffbbffbbffffd -ddd99bbffefc002af5002407ec6fdfdef73dbdff7bccefddfffff777777ffff999ffbfffeeeeffefffff7f7776efffbbfc0024f5000d1bfdcef5f7af6f7bf2f7f7bfddddf8ff06bbbbfffeffeeddfeff0376eeeffffc0027f5000b3a97f73ded7bffdcffbfff77feff02fddfdffcff03efffffbbfdff05fddddbbffffcfc00 -2af5001326d5df6d8bdb1eb7bdaddd6fdfffff6b7777ffdffeff0dbfe666effeedf3f3337766ffbbb3fc0012f5000a3fff5ffef7ffff6ffffbf7e7fffc002bf60025023b23bfdecdbdaddff373f77ffffffddd99ffffe7fe677efff99bbbbbbfdccfecdd9bbeeeccfc002bf6000c033b3b37bded79da5cfefff77ffeff15dd -d9ffbffffe667effffbbbfbbb77fddfcd99bbffeccfc002802000226f9000a0c56f7fdff7f7f5ff7b5bff7ff01fbbbfeff0bfeefffddfff7fb76eeffff73fc002c03001a6662fa000a0ccdefebdadef7b7ed6b7ffaff13feeffffbb9fdbffffecfeceddfff7f6666effff3fc002604083bb99980fb0009156ffbdbfef5bdff -fb5bf6ff00fefbff057fffffedeffbfeff00fcfc0031040666666590fb001209dbfadfb7b72f7b7b5fff9fffffee667f7ffffe990f9bffeeeefeffff733337266efb9bf333fc0025050bbb88f7d540fc000806fd6deffedfffffbffcff00bff3ff03dfffffeffeff01fdfffc003515099999b6664ccccd30000013b56deb4a -5cfeb7afff7ffeff1899b9fffffe7ffe666ffffb33f33ffdcccccdd99aeeeecccc80fd0035150999999fe44cccccd500000f2bf2dec6bded6bffff7ffeff18f999bffffeffeeeeef7fdbb3fb37ffddddcdd9bbefeecccc80fd00310706666ff991333375fecc078b5b76f7b5ad6f5bfbff01e666feff01fbbbfeff0deecced -ddff7737776efffffb3337fc002e120eae6667fdf13333375cccd6d7bded3f7bfed7faff00eefdff07bfffbffffffdfdddfdff05eeeefffff773fc003307099bbbf6244ccdf7fe330737edefcb5bfcf7bffcff09bfbbbbfffffeeefefffbfeff0c777fffdddfffbffffefddddf80fd003307066667999b33331cfecc13c56f -6b0b6ef675fffffdffbffffbe6667fdffffdfdff0dceccecdff7337ffe6efb9b3333b3fc0024100abbb85fd54ddcfff737333ff7b7f7fffdfaff00bff6ff02f7777ff9ff02ddff80fd0033060999644644c4d3fd33093ef6d4addd6a5bfeffeffeff079ffbf7ffffeefffdfeff0dbff377cccedd9ffffe66ececcdfefc002b -08099999860cc4ccccb3fe3306fde9fb5bd3fffefcff00bff6ff0df3337ff6df99fdb9bffcccccfd80fd00341406666d903330330cc84cccdde9efeac267bfffff9ffdff02efffeffeff12fbfffffdfffccddbf737e6677fffb33733fe60fd00371106664644d530333200288ccfcbfefee4acfefeff06fbffffbffffffefe -ff14fbfff37ffffdcdddffffaeef7f6efffff7fe666640ff002d11099819d55ccc44808232223ad7fff59f6fbff4ff16ccffddfffff77777febfb9bfbffffdddddfbbbaefe40003714066411133333320c8c8888968575ed6b5fffffebdffeff1dfef7feffbfff7d333f5ccffffccdff766e7e67ef3b73373376e9999fa000 -280f0fec35555141202aaa8aaaab2fffefbff2ff02f7ff77fbff01eefefeff08f7fffffeebbfffe0003735099844ccc8040233222022ab1b99db95bff6f67fe7effffdbdfbdfffff7efccdef3337ff737fccff99999ffeedfdccd9bae667ffe000373509199154cc0cc0002020003ef6f5bd999fbbfeffe7eeffffbfdbfffb -fffffcccffddffff73337fffbbf99ffbffffdddd99bbffffe000330f06455553333020080080803ef5bfee6ffdff00bffdff00dffdff0b7f777f5dfffffdfffffee7eefdff07f7feeffbbbbb2000310f0664555333322228808888bd2bfbceeffdff009ffdff00dffdff037f777f7ffcff02feefeefdff0777faeeffbfff20 -0032120004040cccc8a222222008ab1adab7ffeffffefcff00bffcff04fddf7f737ffeff03d9ff9bbffdff01ddfbfeee02edc000370604411310132288fe992b8a3b5276f66fffbffffbffffeffffff7efbb7ff73f35d5cccffffff66666677fffb33fff366eb9999b3320002c0f044440400222202aaaaa8abdadffdeeff4 -ff04f7ff777f77fdff0ababbbfffffdffffffeeeeefeff01e00035120404ccc4c8122226662899a99f9b3eeffffffefcff1dbdfffeffdfffff333f333fffffdd99bb9bbfeeecfdfddefe66666efdc0003612000400cccc8a2226666200e99f95bfbffffffefdff1e7fb7ffffdcdffffdf77f333ffffffd99fb9bbffffcedfd -dbfeee66ecfdc0002c0d011103330888888008a2027e76b7fcff007ff6ff02ddffddfdff05fefefffffbf7feff06bfbbbfbfffe000340e0111033322280800900002777c267ffdff007ffdff00ddfdff0ef77fffffddfffffbfffe7eeedffbf7feff06febbbbb3ffe000350f044400302220200008009029aa7eeeeffeff00 -7ffdff00ddfdff03f77f337ffeff0cf9bbfbfeeeefdddfffff7feeeefeff01e000373501330320888999800662606f6af99fb57b3df6fec7eefffff7b3ffbfdfbffcccffc9bffe7e67fe7ffffbff3fffff99df999b17ffe0003413000400002022a880180000b777ffffd7fffff777fdff00ddfcff177ffffffbfffffbeffe -ff6ffffd7fffff7efffff777f7e00037350cccc0022226600189981190bfe66fcffefff73f37df3ffdddedfefdfff73f337f6b9fffb9bbfbef6eecdcddff7666f666cd7337e000370f044c000222200000010011a97ff77fdffeff227fb7ff7ffdddfdfffdfff77f337f7afffff9bbffffeecccdddf7f66ef6eff77777a000 -3302010000fd8806000244626fffbffbff00dffeff1df7f7fff7dffffc89ffbbfffffeefffbf99fdff7fffffbffbbf77edddc000372a010022088888090044446477fffff7bf7b7fffdecffddffffff7ffb7fffffccdbfbbfffffeeffbff5bb77ffeff07bfdbbff77ddde00037010000fe2030000998110115577f6f46ff7f -f37fbff7fffefefdffffb3ffff3faaff999fffffeffe6f7ccddffbf7267fefff33b33fe0003735000cc080080066644404519abd3f35d4efcffedcdff3f35fb37ffaddfdffdfa27e666ff7ff9999bfbf354ddcfdd9fffeefcdccdfe0002a02000808fe000b6000011015775f5fd5fddf7ff4ff05affefbfffffbfcff00ddfe -ff00fefdff027fe0003735023022260019980011444a7ecccd537733b3bd7ccdc7ffdf7f73ffb337ffbdb99f99dfeffe6ee6ffdff3f3fb77f6ffdfbbb3f37fe00037350c80000600640181111115fffeaeccdf73333b3777fd5eddecdffff7377ff67ffffdfffbfffeefffcfeffff377fe7feffb3f3b3f6000350603200880 -999104fe4400bffeff04737f7ffcdcfdff0177f7feff06dddd9bbffffefefdff08bfb3f7fffddfffbbfbfeff02de80002e05022000800980fd440077feff01777ffaff0073fbff049bbffffeeefdff07bffff77fffdfffbbfeff03dddfa0001f02008a22fb0001017ffeff00f5f4ff02feffaef9ff03ddffdddff8ff01a000 -35040c80800004fd001d03fffedcccfef7ffffdbbffdf37ffffffddddfb767ee6666fb99ffbbbbbffdcc0adffffff76ffeff733fe0001d010022fc0006010001dfffdfdff2ff01affbfebbfbff00dff6ff01e000371c0222898909000400c083dfffbeff33f7ddeffd7ffffff7ff7ff777fdabfe9915be66667ee6ffbb3373 -f337ffdbbfb9fbf7fdcddf800037350002000010000330040fdafddfefd3fffdfffff7fffffcfffff777ffffb99999ff99bffee6fededffffb337f66fbbbff33fff7df8000341200008002644400400303ffbf7fdffcffefdff3fbff00fdfeff18f66666fffb99df9fffffdfffdccddfee6666eecdfff376e0003313008980 -0800004c000003ffff3ffbfdffefdfffeffaff079fdfbbae667e666ffeff0ffbfffffdccdd9fffffefccfdddfee00031fd001401103114000fddffff3bf3f7f7ffffdff9feffff7ffdff069d9999fffee7effbff01f77bfeff0633377fcddfe00034fe001240440453323133bffedf7ffcffb7ff57a7fffafcff1ae7f77e66 -6fff99999fbfffffdfeffddb3f6f66f7ef733ff366600021fc000910000c000ffdfdfffff7fbff00fefaff02bfbbbbf2ff06777fffffeaa00037130228999910004ccccc0fdd7f3ef1f3ffddfff97efeff0cf767fffb9fffb9999eee6666effeff0e7fff7ffd9dfb99fbb74cfdcd998000320e02620911100320cccc0ff8ff -bff3f3fdff00f7fdff006ffdff06b9999bfe6666effcff0c77fff9d999fbb35dfdcc998000361208980444440402131337bbfcffdffcffbbff77fdff1eefbffffbffe67e666effb99bffbfffffddfddfdfefe67effcddf7ff6e66000371508919104440c8c802237bbbffffffcfdfffffbffef7ffeff06fdfbffbffe6666fe -ff01dfbffeff0dfddfdffbeff6f7cdcdffeae6600032120000111110002880088fbbbfbb77f6ffffdffbfdff00effdff06bfbbbbffffeeeffbff0cfeeffb9bb9f7d7dffdcbbaa000373500004444cc02222002279cfcddfffbe7ee7f77b7fdf9ffffbfbfe67e7f766f99fb9bbb37fdfcffdffdfe6666e7fec5b3b33f667620 -00340300000101fe000b88802fbbbfffeffeeffffffbfdff0defffffeffbffbbbfffff7ffdfff7fcff0bcbebfbbbd5d7ffffeaba800037010018fe013000c088888fbb3fbb6572efddfffbdfefffffef7fff999fbf999e667ecccddffbbb7ffffffed999fb9915ccccdf9999a00037130000011003000088008ff9bf7a6372 -fefffffbdffeff00effeff09febf99999ffe66cddffdfeff0df7ffefbbfbbb33f7dddfb9998000340300044004fe000a02020fb9befeeffaeeffeffbff1dbffffffeffe6fdd5ff33ff7ffdffffdfffffeeefe664d5b7777efeee20003102000040fe000b2022020fbafefeeffaeeffeff8ff07feff67ffddff55fdfeff00ef -feff0beeefee7555bfbfbefefbc00036150011110010080880022fbabfffeffadcffbffffeff7efeff0dbfbbfffff766447f5f7ff7f77feffdff0adfbf755d9dffbbfae7600037240644440113022200809fd9bcbb6ef6666eeffbddffbdffef77ee7e7fff99b3333f17cededdfeff0df76f6e6e59133bb3ff6af999a0002e -010010fd000c2200800ffafefbeffeeeffeffbfdff0aeff7fffeffffdd15577f7ff7ff09dd555fbfffeefbb96000373509001044c8088880223f7e5ffbfdf9dffdfff7fe7f7effffbf9f9ffb7e4ccccfdffffb33fbbfffdff9ffff99c64ccccfffeefe6e4000350f0000100480088808222f7a7efbfffddffeff02eeff7efd -ff09bffffe5dcfcffffffbf7fdff0dfbffffbbd754dddffffffeee400030010004fd0008a028009ffafeaafffefeff01fbbbf8ff01577ffeff02fdfffdfeff0befffeef7d5557bfffbffbfffff0037140444000002202008808ff8faaaeff6ffffeffbf99ffeff00f7feff01fd57feff035ffdffddfeff06efffeefdd5733b -feff03bbff80002c0e0004040008000022221efafe9b9fbff8ff05f7ffff7fff57faff00bffdff0bef74d455fbffffeff7fde00036130011332020008191811ee3ef7e66f6fdfdffbbdffdff1277fff9bfbf3f3ffccffffccfb7b7676fe7ffbffe33073ffffdd999f360002d0001fc00088000002eebfbbeefbff8ff067fff -f5fff75d5ffeff03fbfffdbffcff047555557feffeff02f56000372a0040c4c088220604467bff99b9ffbbe67ffe77ffffbfffff3ffef4dcecdd57fff3fffb2bdf9dfbbfffff6cfecc07dfffff6e6e55600037350100088089988204661eae29fbffbdd9bffe77ffff7fffff33fffddfccdccfdff7ffff3b6ebf9ff9bfbf36 -4cdccccdffff66feccc000371b0440020222220089999dffae666767e67fdfbdbfff7ffdfff7ffff7ffe3316fffffdfcc98eaaefe7efff7f533b3332feffbfff33200037350440880222026600199df9fdb6ef6ee67ffffd93ff7ffdffd7ffffdfd73333fb77fdfc89df99bfefefffccdd573362767fffff332000372a0000 -088888802260667ce8edbddff9db7fef76ffff7fffff37f7ffdfccdccffb37ff7e62eab99bbbffffedfecc078afafffe6efd40003705013312200008fe99119fe667ff7eedb9f99fb397df7cfdffd7f3bffe33175fcccffcf8ea667e67efdfff7333333228f99fb933f44000320001f9002a2fe4effeffddfffdff77d57f75 -7fff5777ffdd5d5ddffffffefeeaaabbbbffdfff75f5dceaaafafff557f4ff00371a00c8c8888026602266a9dddbbd9ddffe7fceec793f737fff37ccddfecc17b7bffff7fee9999bf9bfb5ecccfcccc8a677e66cccf320003735000080088000006657c4ddf9b99fdffe7fdefcfd7f737fff37fddcfccdccffbffffffefb99 -9bffbfb7fdccfdfdc8f276664c7cd4200037010002fe202e0000017ff644667f7fddddfffff77d7f7cfdefdffff7ff7733bf9ffffffdfafee6ffeffdd7ff7ffffeffb999393f50ff0037330002222020000001bfffc466ff7fcdfdfffff73f7ffcffffddfff7ff7337bfbffffffdfafee67feedddfff7ffffeffbb9d793770 -ff0033fb002404057fffd511ff7fddfd7fdfe57f7ff777ffddffdddffffffe3ffffffbb3bffbfff77fffdffeff07afff7ef75f722000372d0230020999998113fafdc4645d1bff333bbfecdcfffcefff7bf7f3ffffdffdbdfffff7667ffe7f97fffff7fffd99fe9f0416fffc80002afa000c03ffffd57fd5ddfd5575dff57f -f7ff01febffeff04ebfffdfff7fdff09faaaafbfd557ffe8a00037350880020666644115f9f991ffafccfcccc573f3337f37cfefeccfcdfb3ffff67feffffb9d999e4eceffeffdb22666676fc517bf3220003735080000022264444773f391fffdceffcdcdf7f37fff7fffdfeccfcdfffff362bfefffbb9d999b7fffffeffd -9aa267e7e7c5573f2220003735000008089911004ee7cc43ffffdf3fffffefedfecffff3f37f777fffcdcddbbfeffe766ee4df3ffff37ffda989ffdbf9f4ccdf888000350e020000089911111dcfddcc6fffbfbffcff06fdfffff73ff777feff17fb9bffff7666644f7fff733ffebb88fddbf1f554cfb88000320d00002002 -4000111dbfb9dcd5fffef9ff0afdccdffff7f7bffffeefbffeff11c447fdcccdfffe3be67ec7f173333fb22000360e000880999904004d7c75f3eb73ffbbfdff00dffeff00fbfeff0addd99fbef7ff7ee6e6e193fe33013ffffe990793e7eccccd9880002f02000220fe00091017fd75f5fff7fdf77ff6ff1afbbfbfffffbf -ffefe6e5d55557ff7fffaabab1d7f775154f9880003616020220460111101fbd7efddffffcff737fffff7ffffffdfdff1a626eeebddfbfd9dde644ccccffff3fe7677a65d3b3333337b880003735020220660010113fbd7fcddffffdffff33fffbfffefddfffff3f7ff66beebddf9fd9ddee4ccdccffff3fe7677e6793b333 -732bb88000320d008880800004445f7d3fb3fffff7fbff01eff7fcff1afbbfbafefef7effdbf1fff777fff9dbf999f7547efecdcabee200035fe000a988004445ffcffb3fffff3fdff00dffeff1f67fefffffdbd9bbbeefff7f6e5ffdffffff7febdbf99993155effccc8bee200031fc000910013f7fffcdfffff7fbfeff00 -bffbff1cfb7effeabbdbfbfbbff4c6cddffff7777eff6edb9133b3f37a89dd8000373500898800404c4cdf3b3f37f3ffecffffedffbfefffefeffebfff99ffee67fefffff9d1f337f7fffcffbdff9967c4cfcfdce22fe66000360600020000400011fe7f03dfdffffdfdff00bffeff07effebffffbffeeabfeff14fdf57557 -dffffefffeffe645d55fd7f362afea8000370e020209911111106cdefeefff3ff33ffeff239fdfffffeffe7fe7ebffb999fffbe6fef4eccfd7ffff67fe7f9999333737dceb9db9c0003508020264001113337ffdfdff05d3fff7ffffbffdff1efe7e67e7ffeb99fd9999fff4eccfcffffe27fe77e611373773b23b89bd8000 -350e088800004444c47fbf3f33bfffccfdfeff0067fcff1d9fb99bffe667fe7edfd3b3b333d7eccc99bfbbe644c4ccfdb263e67e60003735088998100400ccfce67f733f7feaf8ffdfffafffe7ffefffbf9f999dffeffe7f6f6ff5b333f7f37a899ffb991644ccfcdcc9a27e6000373502200010011111dcecfffffefff3e7 -7f6fff9ff9dfffefff67eeffbfdd9bdfbf7e6fecfccdd7b332666eff9117337332c88999f9800037350082004444c013fff33f67eeffd9dfbefbff7fe67eb9ffff9fdfff67e66667df7333f37314cdccbf99bff7e4cfccece36266667e400034fd0012010001ddf8feebeeffeeeffeffffbfbbffffeffdff18fbfd9fffd7f5 -7fc5f555f3b23eaaeff7d1155572eaea88aab8ff003733008019100104cdcdccfee3677fe6fffdffdf9f99fe666fff7fffbbbdbf99feefccffcc8d3333b27e66fff3933333608d9d999990ff00370d000011100310cbddcefea3667fe2feff24df9fb9fe667fff6fbd99fdff99ffefccffccd53373b27e62ffb393333329fd -dd999b904000370e02000444000323bbfefd8ffeffcddffeff216f67b999ffdf9fe666ef7667f7ff7f3ff354ccec88be8afe77c4ccccf3ffee666761ff0037330000044408c003b3f6ff23feff99ddfbffef7f667d59ffdf9bbbe6ef7666c7f73f37b33344ec889f99fffdc4ccccf8bfee766674ff00370000fe1131004c49 -bbfeff3f7ef7aebdf9dfdf9ffe7e667fffdfb9fbffbf5544f4efdfd5333322a23e89fffbd11744b88f9e988a644000372106604411333223b3d9fd9bffff26feffefe79fbbb9117fef67eefe67ff133bb7fddffecc0ec8823e66f7ffc533333267aeb99991ff003702000001fe002d1fbbfdfcfffeff2ebefbff9b1f7d7d55 -7fef57ffffdff7577fd7ffdffc0282222a3ea8f7fff11131eaafaab08114ff00373508000040ccccbbebfffe6f7eff999df9dfef7e7ffc55739f99b91d5c474cffc7ff3f33332208899f99f7ffecccddf88a2666664c4000373508000100ccccfdebb3fe6676ff9d9ff9ff9f7e7ffc44f59f13311d15475cffcecc57333222 -22089f99fffbf44cccb99f9fa6665fc0003735060040033323f36bf9f9dfffff66fffff65f1f7b3b317fcf44fc4d57133b3f3314ccecc8888a327e667fcdf1332276663f99993bc0003729004044408023ff67fbf89fffff9dbffffffe567739337fff55fc45ffc4511333373374888889999f047ffecc0882367e6f664933 -4000372200011000c88bf8efe7ff767eff9d9fd9fffe467ffcdcffff11ff13ffc6cc4ccccd337afe220f899f99fb9144cc88b99e8f266e44c0003725040001333223f8efb9f99fdeff6effffd7ff3f7bbb14ecceccffc5bf33b33b68ccccfd8888a2fe660a7dd9333322762e99999f33ff0034fc00150ffeef23faae7fff1d -9fff57ff5e75fd55755f557f55fed715587d78027222a22a080e01f5d9300088b88e8b005654ff003735000044cc089dffe767fe765d9f999ff947fececcfc137b3f337bc4ccefcfdcf3f332366e2089999f9159ccdcc889998667644cccc0003724000044c8888cb7ff677e661dff99bff947fececcfc137f7b337bc4ceff -efdcd3f226367e20fe990d1151cccc8888988766647ccc6000373504000222222fffff9bb99f5dff4cfffd57ff3f733b0cfeffccfd5333b7ff3762f9889ffd8826664444459172222676431111373360003735044400022237ffaf9bf99fddff4cffff4fff3f733b33dcffccfccfd1b37fffb3f3889ff999980444444dcce2 -2226766747113737200035fd0021889bff8e7ffc465dff11b97b57fe4eccf886f7b7337b2f8cecc9ffcfe6a2ffe62000fe110c139ec88888999305c44fffc00037230033320000dfffdfffc4666dff4dfb7b37f73f4cfccedfcf8373b7bb7368ffffdf99fbe7fe660e441133bf322228999913333fffe00034fc00258edfff -ffe5cd5df751bdff5fffdeccfabfffb33333b788ece8ffeffaabffefe22111111911ddfe8807999f7c57cfffe00035fd0031027e6ffffff3ff39ff15fcffcfdedf733b3b7f3fccdfcccceae62eef6667ffff999991144ccccdc88aa6666efccff7ffe000373000008808027e67fffff7fb9bff337dffcfdedecb32337fff29 -dfcccee88eee7fe67fffff99999111144ccdc9999ae66efcfeff01e000362f0003222201f99dbff7f7fcd5ffcdbb7b37ff3eccf8dfdefb33333f36e3acc9bff9ffbee6666444451333336266a9999ffdff01e000372b0c02222626e5b9bffffbfdc5fecdfcff37ff3f73fadb9dffc88abff267fe62bf99ffb999944444cccc -cd2222fe66065ffff7773ee00037140088888980e7fc7fddff33b3bf33fcffcfdeceeabafeff0c288b89c88bbee776e7feeeb991fe110d544cc889999a67fcfffcdffea000373503222289999fd1375deecfcdff33b7fb3ffe8edf9ddfdfff26676322899dff99dbeee66666444513333332279b9d993b73fccf9fe0003606 -000888800307d5fdff2af7ff11befffffeaabfbafffffbaaadaaabaabfefaaffeeeff5d5111551f401c88fbfbf955ff5dfffafe000370700888826666747dffeff2abffecccefffffe22777eefbffb999f998a227ffffffeffdb999111144ccccdc8eabe6fe4ffccdf7e67e000370808088806666e4ffff3feff06feccceff -fffe22feff1f3fbb889b889aa27ffefffeffdf999111144eccccedeabe67fdfffddf7a67e00037260200209997ff1ffffcfffffeff33333bbffe88ff99dfbfe7a677a22cc9bdf9fff3f76e64c44451fe330be7aa9f9bbff33fdffd998000373502002001073d3f7ffedffffedc23223a3ffeafffdbd99fb3a3f7a67eeafbfb -fffbffe644c44cc5513332fee63e9bbff33ffffff98000361108882000027c5f7fffbbffffccc88888afeefdff1fdfb98babaabe26f7fffffbff91111155444ccc88fffa7e645fdd5ff7f7f6e00037350009910013745dfcdccffbbf33622228889fdbff9bff6ff7672b99bdb9fbdfeffee66444411333333222bffff9b13f -46cfeff9dba00037210088000003f45dfcaf33ff372220bcaaaebffbfffaffffbb2aabaabfabffefffeff5fe55105fdd7e0088affffbf55f5757ffffab600037350026664445e13bf333ff7fefcc888c8a26667ffff39fdfbb9b8ba67666ff67fff9f93131147ffdfec888a7ff67f7fed633f7ff67e00037210880244401e4 -7bf33b7fffffcc8888baab72ffeff7ffbf9b9b99ae7667ff7fff3d79fe11107ffffcc888abff67fffec513f7f76740003511000101100110ffc8ed9fffffa222227a9bfbfdff14e67fe762bd9999ffbb7e7c7c444cc5ffffbf22222bfdff04344ffed99bff003611066400110133ffa8dd8fffff822222727ff2fdff15ee7f -e6666e7ffbffbbf91f584c44cdffffbf222223fefeff0633276af99920003735000004444040ff237727bffe888a88cadffbfe6ffff9ff9f999fef7ff7ef747517911f339ffdc9bf88888aaef7ffffcc072227e66000373501191132100dfe8998bebffa666622089ff99999fe667f77e66bff9d9b9b344444fecccd5ff33b -b72228999dfbf7f74dcf9999db800037010011fe00300ffe89bf3effbb6aae8888affbaaa7f6667fff99abbf9d57df56454557555557f53eba8c8888bff7ffffcd8bbaabc740003735044444ccc07ffe667a7ffe99e9988266666e6663f9999fbf9e776e7ee7cd5f133333f37cfdccccd88a26666667edf733226667e5e000 -370004fe4431c07bfa227afffef9e8888226666e6663f9999fbfbf77e767e7dd7f11333ffb5dfccccc888aa2666644d7d732226667f5e000373501101100007ff888eafffe7ae222a8888fe988bfe67e6f7fdffbfbd1ff5dfe44445ffdfffb73e62aaa99b9f91777de88fe8bbff5e000373501111112003ff888a8fefa7a62 -22a8999d999afff67eeffeff39bfd9379ffe44cccffddff333b722aa99a9f917774c8cfe99fff5e000370004fe0031203ff288e9fff8fab22222262fda89f9f11ffffe7f7fffd5575bff55555fcccfec8faba227f7eed57f77323ebaabfffd6000370c000108c8881df82667f7f6fff9fe99259fee666ee67ffbffbddff154 -4ffffcccd53f3337f333899999fbdf94fedccd998a6ffffce00036fe002a80801fe202e3f7faffe889833667fe677ff5fffffbfffff5555ff7f9d5557fb77fecf68aaaaaffdf55fffffeaa04effffd6000371500000222600f41b9fbffb9fbf666667667d999fff17ffeff08decdd137f3f33354fefecc0bca2a666efe6f13 -ff3336222bfeff01200035fe00120224066674fbffb9ff9926667667f6557df1f9fdff1bccccdf73f37333bfdccccce898ae6e764e4dfff3b676667fffff200037010020fe0007810056e7e7e67ed9fe99259fe4476eecfddffbbf3f39554ecdeccccdbe3333627eab999f999fdffffcd999bbe7fffee00036010020fd0017 -0111e7e7e67ef7d999bd9ff957ceecefdfffff3f33337ffefecc14dff337667fffeb9f9b9bf7fffddf9fbbbffffec000370b0480000400000119ff9ffffefe66265f7ff9bbbf7fffcffffdfdf7737f33f7ffcccddddfdbffffe66effffdffff77feffbdfffff60003735044000181000026eefeff9b9f9b9997efef6cccdff -bf3ff3b3ffefcddecfdfff3333777fef9ffff99bfffeeffffddffee77fffffc000120307200020fe00007fe5ff00eff2ff01e000370303200604fe00183bbfffe6f6766d5b7b3bf333ffecdceffffff33333ff77fccffedd12ffe767e66eefffbb73fff7fff9bbbfff7fc000320304000206fe000b1f3fbffffff66e6fffff -fb33fcff15eddfff777ff7fffffdddddffffefee6eeffffff7fff7fbff0160002f0302080080fe000b4fef7ffffffbbfff7fffffddfcff04f7ffffdfdffdff0a777fffffbbfbfbbfffffdff9ff01e000310300200980fe00014eeefeff07fbbb3337ffffccdffeff07f777777fffdffdddfeff0876e6e7e7fffbbbff7ff8ff -01c000250300200660fe000037fcff05fddffffff777fcff00dff9ff06bfffbfe3e6feeef5ff01e000370300011990fe00234fdfff33fff3f5ccccdfccdff7333337ffdcdccccffffff7776667ffb98181bbfffccccefeff02effeeffeff01e00012fa000057fbff00f7ecff01e0e7f3ff01e00036fe00281980001001eecf -cdfcfdf333333b77ffceeccedffff3333377ffffd999999fee6660026efff333337ffeff01fbbffeff01c000360a0002403910000003ffeecdfeff06b3333ff7ffffecfeff00f7fe770fffffdd99d9bffee7e6026ffff773777ffeff00fbfdff01c000351a0889822440000001fb3f37fffffcccecdfffff7ff777ffffdddd -dffeff0ce6666efffb9f91003ffffcddddfdff00fefdff01e000340a0889819444000004ffff37feff07dceccffdfffff777feff00ddfdff0cf66e66ffffbf9000bbfffefdddfdff00fefdff01e0002d12020a001910100000fffedffffd7337777ffffdfcff01f77ffdff0bdbbfbfffee7ee604fff77777f7ff01e0003628 -008a6626404000203fff33ffecccccedfff33333fb7fffddcddffffffe7f666efb99f919900feecccdfdff02feeffefeff027fe0001d03000a8911fe00000cfcff01f777f0ff06fefffc7f840f7ff4ff01e00035010000fe100f0000449decdfffff333337ffcedccddffeff167777ffff999b99fee767666604413b33337f -fffff9ffbbfcff01e00033fe000010fe000c400dffdfffff333377fffdddddfdff16777fffffd99b9bffee6666260007bb33337ffffffbffbbfcff01e00026010002fb000603fffffdfddddffeff007ff8ff0ceeeeefffbb9bb800101dccdcddf6ff01e00024010002fe000944000003ff7ffffdccddf4fffeee09effb9990 -00103fdddcddf6ff01e0002afe000a1000000c0405ffff77fb77f4ff10fbfbbbbfeee66e40001033337777ffffbbfcff04ddffffc0003202000202fd00080202fffcfcfdcfff37fbff00fdfdff09f7fe6fb9989999800000fecc04dff7e667fefeff05bf777fffc0001d0300020010fe00010400edff0abfff30fff8400001 -5dff7ff5ff01c00033010001fc0007060033fb33ffccddfcff1c7ffffffd9fffdffbfe666660e640010003333fdcdddd99bbffffccedcdfeff01c000310d0001191010000004001ffb33fb3bf9ff01fe77feff10d9999bbe066600404003333b3377fff9f9fdff05ddfdffffc0002a0b0006000010000002000fccddf3ff10 -fefeeffb99899100004000ccdddfffff66fcff00f7feff01c000290e08062000040000020003effdffdfdff8ff10fbfffefe666e0e9800000311015dccddddf6ff01c0002805080181100444fe00020373f3f5ff12fbfffffbbf806664000041500137777ffffffbf8ff01c000340006fe000d020300000800cefcfff33fff -7f7ffbff1dfe7ffe76ef099990001000c0084ccdff767e7e6effff3333f777ffffc00021040801110004fe00022800befbff00bff6ff0803ff1000000140005ff3ff01c000370d09899000ccc800802200333b7ffcfeff0ddfbeff7e6ffffff99999f98c4066fe000901200313337fd9bf99bffeff06cddf9fffffc000360c -099991114ccc04c88200333b77fdff049fbfff7e6ffeff12b9bdf990004400404400000313337fffbfb9bffeff06dddddfffffc0002c0b06664c1573030332a08008cdfdff05feffefffffbffeff0dfefee6604580000010000004dddff4ff01c0002c0c06644485df0302320280008ceffeff00fefdff00bffeff0dfeee26 -6853080100101000009ddff4ff01c000220c0ffd5415ddca02aa8200003faff4ff03f83fe515fe000010fe00001ff3ff01c0003602066550fe332900080800000ba2767fffffdf99ff999bffe67e6660391810001004000004804df7fe66666ffffbb3fff7fdff01c0002e0d0ffd5c1dc4fe080a02000009abfbfeff04efef -ffd3e7fdff06e0380040000001fe0004304ffffffbf6ff01c000370d09984c0cc0cc08024600000a1d99feff0cef666e22037ff9999980000068fe000e0100023327fffd99999bbffeeeffdffeff02fec0002e0e0980d44c80cc880a022000000209fdfeff0be66e00021ff9991980000044fb00060367ffff99bbbbf8ff01 -c0002e0906404033003288080880fe001003e7effffb9998000c0006400e20041110fc0006080dc2fffeeeeef7ff01c0002e090740c37300222a9b0880fe000601e6fffffbb998fc00066e600491100010fe00060805c27ffeeeeff7ff01c0002e09071044cc0020232626a8fd000481fefee666fe0009180001f840064054 -4050fe00051005ec5ffbbbf6ff01c0003511050101320000199999980260020000599999fe00174024000260019930911540c000c00803322666666ffb9bf3fcff03fbffc0002e0c0605c596000028eaa2b800a002fe0001eeecfd001210000340015c10d057417000c01000dc0bbefef6ff01c000332c0404cc8c00022466 -666a0019908000006660000001001801980000cc40c4573331313337804c00999bbfeefecffaff01c0002f1104004c8c00022262662e00001800b0002060fe0013401001990400440045dd37717077378000003bbbf6ff01c0002d10040117b8000028383e0e00002009b80013fd00124000410100001000115dddcdd1d09f -e0000002f5ff01c0002f170000133800019018be0e020026e581001000050000400001fc0007014dccc4c1dc7772fe00febb00bff9ff01c0002e160000dff000620408b9199999a682020004105300011010fb000d0103377701044ccc80000006eeeef8ff01c0003312000036c8001988066426006665001900181440fe00 -0054fb000088fecc0a00031302002000019999b3feff00fbfdff01c0002f0c00004cc8002a8a006c80000118fe0002040050fe0001d401fd000301405706fe0006020000208800bff7ff01c00036180400432000666c819980000060600004000111002001540cc8fe00130320332200480c1000182a4400626ccdff7ff6ef -fdff01c000300e040000880006666065800010000040fb00090100375000c80cc80033fe000a0c8888180180006044ccdffaff018000330e000002280019919876400046200101fc001a040000d5520132130004cc484800002262662060009900133ffffbfcff01c000320e000002200019919999800006244055fd001910 -000100cddd577712000700480080c80082060664605d00137ffaff0180003417000002a80066627575000101b4145404400011500001037dfedd13c0080002302000800080090abe60440045dffffefcffff003616030004990090106664206605111333033040c0c0000003fd3308404cc0048c80022002fe000e19101011 -00cfdfd9f9bbfdfeccc0003309040002a880407dff5101fe551515554550d5504000000377777ffff0ffe000aa000220fd00063f041005401fbffbff01800035060c080262004441fd110b15444ccccc4d51000032003cfecc0ecdd333323230220888000900202604fd00062e66666ef73337ff0035160c080a2200446151 -11101133744ccccccdd0000033103ffecc0dcddff33230200008880008000066fc000601e6666fff7373ff00352700222891001510d44440445d5533333057080000ccdc3373333377ffdccc88800020066660000001fc00080819bbbffd00d08000373500002ea10010117d40444cddd577333012200000ccdc7ff777377f -7fffcc880800000e6660000044000030100000819bbf7fcdd08000372b0c00aee2004551557103757555dddddc407602037ffcfdcdcddffffbbfa20608000079a20008006400004010fe00040c1ff77770ff00350a00009991011440ccc8cc55fd3305344cccc008cffd331a37fccddd9982800000644000099bb1003144c8 -010180100cccccd8ff0031130800aee60114017151415dd5d5ddd77477f7400ff8ff16baa00080003800001fff55005555300a00003107547ff0ff00350a080066660053013330335cfecc06cdf3333330333cfdcc19df7336666660000001991000066ec400dd732224060041010233fe0033fc002d01c1333033775dcccc -dddff3331037fffecccdddffffb2266ee200001999b80006640401dc4000200600c1000001fe002df500290677fccccccdc07fb3333377ffffc999bbbaae06002eeff000091100005c00009809014440c00000800028f000030cc87ffffe331d7ffff8889abbae8644666ef019003000001400009999014040440000800024 -ee00133fddf9ffffbfa222eaaeabbb9999bbfee0444404fe0007222266ed01005033fd0023ed00001ffeff05fdd999999ba6fd6603f9998132fd0009cd999994008000080020ff0017e500f9ff0ac1540040000023aa8b9004fe00012080ff000fd7000b3266000002022000898080000fd7000103fefe0006030000298180 -0009d1000520000001800002cb0002cb00a00083ff}}\par -\pard\plain \s10\li-20\sa120\tx440 \i\f20 {\plain \b\f20\fs36 \par -}\pard \s10\li-20\sa120\tx440 GMD\par -Institute for Applied Information Technology\par -AI Research Division\par -PO Box 1316\par -D-53731 Sankt Augustin\par -Germany\par -\pard \s10\li-20\sa120\tx440 Juergen.Walther@gmd.de\par -\pard\plain \qc\li-20\sa120\tx440 \f20 {\plain \sect }\sectd \linemod0\linex0\cols1\colsx0\endnhere {\footer \pard\plain \s243\qc\li360\sa120\tqc\tx4252\tqr\tx8504 \f20 {\chpgn }{\fs20 \par -}}\pard\plain \qc\li-20\sa120\tx440 \f20 {\b\fs28 \par -}\pard\plain \s254\li-20\sb120\sa120\keepn\brdrb\brdrs \tx440 \b\f20\fs36 THE AI-WORKBENCH {\fs48 BABYLON} ON THE {\fs48 MACINTOSH}{\fs28 \par -}\pard\plain \li-20\sa120\tx440 \f20 BABYLON is a modular, confi -gurable, hybrid environment for developing expert systems. The following knowledge representation formalisms are provided: objects, rules with forward and backward chaining, Prolog and constraints. BABYLON is implemented and embedded in Macintosh Common Li -sp.\par -\pard \li-20\sa120\tx440 At Cebit'89 the book {\i Die KI-Werkbank BABYLON - eine offene und portable Entwicklungsumgebung f\'9fr Expertensysteme,} was published by Addison-Wesley. The english version of the book : {\i The AI Workbench BABYLON } - is currently (January 1992) being published b -y Academic Press. Both books begin with a brief introduction to the foundations of expert systems. Then the knowledge representation formalisms of BABYLON and their interaction are explained. A large, commented example demonstrates how to use the formalism -s in a real application. A language extension for component descriptions and diagnosis is presented. Next, the object-oriented implementation is explained so that a systems programmer can adapt BABYLON to his/her special needs. \par -\pard \li-20\sa120\tx440 System requirements: 4MByte main storage, Macintosh Common Lisp 2.0.1 (MCL 2.0.1).{\b\fs36 \par -}\pard\plain \s254\li-20\sb120\sa120\keepn\brdrb\brdrs \tx440 \b\f20\fs36 The AI-workbench BABYLON\par -\pard\plain \li-20\sa120\tx440 \f20 BABYLON is a hybrid tool system for implementing and operating expert systems. It provides the knowledge engineer with different integrated knowledge representation formalisms and different user interfaces.\par -\pard\plain \s254\li-20\sb120\sa120\keepn\brdrb\brdrs \tx440 \b\f20\fs36 BABYLON is configurable:\par -\pard\plain \li-20\sa120\tx440 \f20 Interpreters and user interfaces are available in different versions, configurable in any combination to obtain problem-specific tools.\par -\pard\plain \s254\li-20\sb120\sa120\keepn\brdrb\brdrs \tx440 \b\f20\fs36 BABYLON is an open tool system:\par -\pard\plain \li-20\sa120\tx440 \f20 If the user develops his own knowledge representation formalisms or changes existing ones, he can easily integrate them in BABYLON. The BABYLON architecture is open for such extensions.\par -\pard\plain \s254\li-20\sb120\sa120\keepn\brdrb\brdrs \tx440 \b\f20\fs36 BABYLON is portable:\par -\pard\plain \li-20\sa120\tx440 \f20 -We modularized BABYLON in a strictly functional way, factored out the I/O-operations, and extended the implementation language Common Lisp by our own, small, efficient and portable object system. Thus BABYLON became an easily portable system, as is demonst -rated by more than a dozen successful portations to seven different Lisp systems.\par -\pard\plain \s254\li-20\sb120\sa120\keepn\brdrb\brdrs \tx440 \b\f20\fs36 Target group:\par -\pard\plain \li-20\sa120\tx440 \f20 Version 2.3 of BABYLON is primarily designed as a system for research and development,\par -teaching and training. \par -\pard\plain \s254\li-20\sb120\sa120\keepn\brdrb\brdrs \tx440 \b\f20\fs36 \page Knowledge representation in BABYLON:\par -\pard\plain \li-20\sa120\tx440 \f20 BABYLON offers the following languages for knowledge representation:\par -\pard\plain \s4\li-20\sa120\tx440\tx900 \f20 \bullet \tab Prolog\par -\bullet \tab objects\par -\bullet \tab production rules\par -\bullet \tab onstraints\par -\pard\plain \s254\li-20\sb120\sa120\keepn\brdrb\brdrs \tx440 \b\f20\fs36 The BABYLON paradigm:\par -\pard\plain \li-20\sa120\tx440 \f20 BABYLON provides an independent specialist for each formalism, i.e. in metaphoric terms: \par -\pard\plain \s4\li-20\sa120\tx440\tx900 \f20 \bullet \tab a logician accustomed to proceed analytically, to decompose goals into subgoals and \tab problems into subproblems; \par -\pard \s4\li-20\sa120\tx440\tx900 \bullet \tab a stockkeeper possessing information on well-known things (objects), managing this \tab information and thus rousing expectations. Of course, the stockkeeper can extend the \tab -stock, update old information etc.; \par -\pard \s4\li-20\sa120\tx440\tx900 \bullet \tab a pragmatist living fully in present-day reality, being concentrated on the concrete and r\tab ecommending actions to be performed in accordance with the specific situation; \par -\bullet \tab a supervisor controlling the performance of actions, asking for future consequences \tab and tracing back the reasons for current situations. \par -\pard\plain \li-20\sa120\tx440 \f20 The interaction of the specialists follows the principle of distributed problem solving. There is an other specialist for coordination: \par -\pard\plain \s4\li-20\sa120\tx440\tx900 \f20 \bullet \tab the manager receiving tasks to be accomplished, selecting the suitable specialist, \tab delegating the task and securing the delivery of the result to the correct place. \par -\pard\plain \qc\li-20\sa120\tx440 \f20 {{\pict\macpict\picw392\pich211 -109a0000000000d30188001102ff0c00fffe000000480000004800000000000000d3018800000000001e0001000a0000000000d30188009980320000000000d301880000000000000000004800000048000000000001000100010000000000b94d900000000000002272038a00010000ffffffffffff000100000000000000 -00000000d301880000000000d301880040000a0000000000d3018805d1ff01c00005d10001400005d10001400005d10001400005d10001400005d10001400005d10001400005d10001400005d10001400005d10001400005d1000140000def00007ff7ff00c0ef000140000ef000010180f7000030ef000140000df0000006 -f600000cef000140000df0000008f6000002ef000140000df0000010f6000001ef000140000df0000020f5000080f0000140000df0000040f5000040f0000140000df0000040f5000040f0000140000df0000080f5000020f0000140000df0000080f5000020f0000140000df1000001f4000010f0000140000df1000001f4 -000010f0000140000df1000001f4000010f0000140000df1000001f4000010f00001400017f1000a01000001fb8f3f3c3ff3f0fe000010f00001400017f1000001fe0006eed99de66799f0fe000010f00001400017f1000001fe0006ccc7999e679980fe000010f00001400017f1000001fe0006cccd99b667f980fe000010 -f00001400017f1000001fe0006ccd999e63d8180fe000010f00001400017f1000001fe0006ccdb99ee619980fe000010f00001400016f00009800001ffefffff7cf3c0fe000020f00001400011f0000080fb0000c6fc000020f00001400011f0000040fb0000c6fc000040f00001400011f0000040fb00007cfc000040f000 -0140000df0000020f5000080f0000140000df0000010f6000001ef000140000df0000008f6000002ef000140000df0000006f600000cef000140000ef000010180f7000030ef0001400012f2000303ff007ff7ff02c00ffcf1000140000ff2000103fef400010ffcf1000140000ff2000103fcf4000107fcf1000140000ff2 -000101f8f4000103f8f1000140000ff2000107f0f4000101f8f1000140000ef2000118e0f30000f6f10001400016f20001e0c0fd000302000002fb000171c0f20001400016f3000003fb00040600000380fc00012030f20001400015f300000cfb00041e000003e0fb00000cf20001400015f3000070fb00043e000003f8fb -000003f20001400016f400010180fb0004fe000001fcfa0000c0f30001400015f400000efa0004fe000001fcfa000038f30001400015f4000030fa00047e000001f8fa000006f30001400017f5000101c0fa00043c000001e8fa00010180f40001400015f5000006f9000044fe000084f9000060f40001400015f5000038f9 -000040fe000004f9000018f40001400015f50000c0f9000080fe000002f9000006f40001400016f6000007f8000080fe000001f9000101c0f50001400015f6000018f9000001fc000080f9000030f50001400015f6000060f9000002fc000080f900000cf50001400016f700010380f9000002fc000040f9000003f5000140 -0017f80001300cf8000004fc000020f80001c020f70001400017f800017070f8000008fc000020f800013830f70001400017f80001f980f8000008fc000010f800010678f70001400017f9000101fef7000010fc000008f8000101fcf70001400016f9000103fcf7000020fc000004f70000fef70001400016f9000107fcf7 -000020fc000004f70000fff70001400017f900010ffcf7000040fc000002f70001ff80f80001400012f900010ffcf7000040fc000001ec000140000ded000080fb000080ed000140000dee000001fa000080ed000140000dee000001fa000040ed000140000dee000002fa000020ed000140000dee000004fa000010ed0001 -40001a0200000ff7ff00f8fc000004fa000010fc00f5ff04f0000040001c02000030f7000006fc000008fa000008fd000003f500040c000040001d020000c0f700010180fd000010fa000004fd00000cf5000403000040001a010001f5000040fd000010fa000004fd000010f40003800040001a010002f5000020fd000020 -fa000002fd000020f40003400040001a010004f5000010fd000020fa000001fd000040f40003200040001a010008f5000008fd000040f9000080fe000080f40003100040001a010008f5000008fd000080f9000080fe000080f400031000400019010010f5000004fd000080f9000340000001f300030800400019010010f5 -000004fe000001f8000320000001f30003080040002008002000001800060180fc000002fe000002f8000310000002f300030400400021040020000038f8000002fe000002f8000310000002fa00010180fc0003040040001c040020000018f8000002fe000004f8000308000002f300030400400021090020000018e1fe79 -9e7efd000002fe000008f8000304000002f30003040040002c090020000019b33edfb33bfd000002fe000008f8000e02000002000001fdcf8f7fff9e73f0fe0003040040002c09002000001b1b36c18f33fd000002fe000010f8000e020000020000036cdcd9becfb6d9f0fe0003040040002c09002000001b1b36c19b33fd -000002fe000010f8000e010000020000030cccd9b0cdb18d80fe0003040040002b09002000001b19e6c1b333fd000002fe000020f7000d800002000001ccccdfb0799d8d80fe0003040040002b090020000019b306cdb733fd000002fe000040f70002800002fe00076cccd83079878d80fe0003040040002c0a001000003c -e3ef7bdfff80fe000004fe000040f7000d4000010000036dccd9b031b6d980fe00030800400028010010fe00010630fa000004fe000080f7000d200001000003c7ef8f7833fc73c0fe00030800400021010008fe00010630fa000308000001f6000310000080fe00000cf800031000400021010008fe000103e0fa00030800 -0001f6000310000080fe00000cf80003100040001c010004f5000310000002f6000308000040fe00001ef800032000400018010002f5000320000004f6000304000020f400034000400018010001f5000340000004f6000302000010f40003800040001b020000c0f700040180000008f600030200000cf500040300004000 -1b02000030f7000006fe000008f6000301000003f500040c000040001a0200000ff7ff00f8fe000010f50002800000f5ff04f0000040000df0000020f5000040f0000140000df0000020f5000040f0000140000df0000040f5000020f0000140000df0000080f5000010f0000140000df0000080f5000010f0000140000df1 -000001f4000008f0000140000df1000002f4000004f0000140000df1000002f4000002f0000140000df1000004f4000002f0000140000df1000004f4000001f0000140000df1000008f3000080f1000140000df1000010f3000040f1000140000df1000010f3000040f1000140000df1000020f3000020f1000140000df100 -0040f3000010f1000140000df1000040f3000008f1000140000df1000080f3000008f1000140000df2000001f2000004f1000140000df2000001f2000002f1000140000df2000002f2000002f1000140000df2000002f2000001f1000140000df2000004f1000080f2000140000df2000008f1000040f2000140000df20000 -c8f1000040f2000140000df20000f0f1000026f2000140000df20000fcf100001ff2000140000ef3000101fef100003ff2000140000ef3000101fef100003ff2000140000ef3000101fcf100007ff2000140000ff3000101f0f100013f80f3000140000ff3000101e0f100010f80f3000140000ff300010180f100010380f3 -000140000df3000001ef000080f30001400005d10001400005d10001400005d10001400005d10001400005d10001400005d100014000130200000feeff0080fc000003f4fffb000140001502000030ee000060fc00000cf40000c0fc0001400015020000c0ee000018fc000030f4000030fc0001400014010001ed000004fc -000040f4000008fc0001400014010002ed000002fc000080f4000004fc0001400014010004ed000001fd000001f3000002fc0001400014010008ec000080fe000002f3000001fc0001400014010008ec000080fe000002f3000001fc0001400014010010ec000040fe000004f2000080fd0001400014010010ec000040fe00 -0004f2000080fd000140001d010020f900016060f6000020fe000008f8000060fc000040fd0001400022010020fc0004018000e0e0f6000020fe000008f90002060018fd000040fd0001400022010020fc00040180006060f6000020fe000008f90002060018fd000040fd000140002b010020fc00083fc71e7e7ef1e7c7bf -fa000020fe000b08000003e7ef0ffee3cf67bcfd000040fd000140002b010020fc00086d8db76c6d9b3e6cdffa000020fe000b0800000733f999bbb666ed98fd000040fd000140002b010020fc00086198f078799b366cd8fa000020fe000b08000003330799b331e66c18fd000040fd000140002b010020fc00083998f070 -71fbf66fd8fa000020fe000b08000003330d99b333666718fd000040fd000140002b010020fc00080d98f0787983066c18fa000020fe000b0800000333198f3336666198fd000040fd000140002b010020fc00086dedb36c6d9b366cd8fa000020fe000b08000003331b983336e7ed9cfd000040fd000140002b010010fc00 -0878c71efefef1e7c7bcfa000040fe000b04000003e78fdf7ffbf3ff0cfd000080fd000140001f010010f6000006f8000040fe00070400000300003180f9000080fd000140001f010008f6000006f8000080fe00070200000300003180fa000001fc000140001e010008f600000ff8000080fe00060200000780001ff90000 -01fc0001400014010004ed000001fd000001f3000002fc0001400014010002ed000002fc000080f4000004fc0001400014010001ed000004fc000040f4000008fc0001400015020000c0ee000018fc000030f4000030fc000140001502000030ee000060fc00000cf40000c0fc00014000130200000feeff0080fc000003f4 -fffb0001400005d10001400005d10001400005d10001400005d10001400005d10001400005d10001400005d10001400005d10001400005d10001400005d1000140ff05d1ff01c00005d10001400005d10001400005d10001400005d10001400005d10001400005d10001400005d10001400005d10001400005d10001400005 -d1000140001cf40006600001800000c0f900091c7f030fe79e780f0e3cf7000140001ef2000830000001c006000003fd000936318306330c3039c718f7000140001ef2000030fe0004c006000003fd00093030c78619983030c718f70001400026f9001d01cfcffcfc6fde798e7e78c0ff7fdcf7bbbf780e7c318786319830 -606798f70001400026f9001d0367d9e676ecf3339b3bccc1b63ecdbb199fcc1b303f0cc7e0f0306066d8f70001400026f9001d0636199e66618f31b1b33cc18630cd831998cc31b0318cc630f0306066d8f70001400026f9001d063619b666631b31b1b36cc0e630cd831998fc31b030cfc6186030606678f70001400026f9 -000206360ffe66173331b1b3ccc03630cd831998c031b030d86618603030c638f70001400026f9001d0366186e666cf73d9b33dcc1b7b0dd9bdb98cc1b30319866306031b9c638f70001400026f9001d01cf1f3fffffdf9bce7fffe1e3787ef18ffc780e787f3cffe0f07f8f0f18f7000140000af700013180dd000140000a -f700013180dd0001400009f700001fdc0001400005d10001400005d10001400005d10001400005d10001400005d1000140ff05d1ff01c0000000ff}} \par -\pard \li-20\sa120\tx440 The very point of this division of labor is that the specialists do not know each other. This makes it very easy to omit specialist groups or to compose new ones. \par -\pard\plain \s254\li-20\sb120\sa120\keepn\brdrb\brdrs \tx440 \b\f20\fs36 The architectural concept \par -\pard\plain \li-20\sa120\tx440 \f20 -The BABYLON architecture is a processing model for the organizational structure described above. The specialists are software modules responsible for the interpretation of different formalisms: as a stockkeeper, the frame interpreter interprets the object -constructs (frames), the rule interpreter interprets the production rules as a pragmatist, the Prolog interpreter interprets the Horn clauses as a logician and the constraint interpreter the constraints as a supervisor. The metainterpreter coordinates th -e four language interpreters and manages the references made to expressions of other formalisms within a formalism. \par -\pard \li-20\sa120\tx440 \par -\pard \qc\li-20\sa120\tx440 {{\pict\macpict\picw398\pich352 -1dee000000000160018e001102ff0c00fffe00000048000000480000000000000160018e000000000001000a000000000160018e00998032000000000160018e000000000000000000480000004800000000000100010001000000000031b8c4000000000000515c000000010000ffffffffffff0001000000000000000000 -000160018e000000000160018e0040000a000000000160018e04d0ff00fc060080d1000004060080d1000004060080d1000004060080d1000004060080d1000004060080d1000004060080d1000004060080d1000004060080d1000004060080d1000004120080f1000018fe0004300180000cea000004120080f1000070fe -0004e007000038ea000004120080f1000030fe00046003000018ea000004150080f1000b7ff873ffcf3e3ff03e78f780ed000004150080f1000b6cecd9e6d9e6679833cdbcc0ed000004150080f1000bf19b1bcdb3cccf30667b1980ed000004150080f1000be19b19f9bfcccff066d9df80ed000004150080f2000b01e336 -33f36198f600cf30f0ec000004150080f2000b01b33361e367998660cf76f3ec000004150080f2000b07fff383cf79fbe780f3ff3cec0000040b0080ec00010630e80000040b0080ec00010c60e80000040b0080ec000107c0e8000004060080d1000004060080d1000004060080d1000004060080d1000004060080d10000 -04060080d1000004060080d1000004060080d10000040b02800007d6ff03fe0000040b02800007d6ff03fe0000041702800006f8000002f8000080f5000010f70003060000041702800006f8000002f8000080f5000010f70003060000041702800006f8000002f8000080f5000010f70003060000041702800006f8000002 -f8000080f5000010f70003060000041702800006f8000002f8000080f5000010f70003060000041702800006f8000002f8000080f5000010f70003060000041702800006f8000002f8000080f5000010f70003060000041702800006f8000002f8000080f5000010f70003060000041702800006f8000002f8000080f50000 -10f70003060000041702800006f8000002f8000080f5000010f70003060000041702800006f8000002f8000080f5000010f70003060000041702800006f8000002f8000080f5000010f70003060000041702800006f8000002f8000080f5000010f70003060000041702800006f8000002f8000080f5000010f70003060000 -041702800006f8000002f8000080f5000010f70003060000041702800006f8000002f8000080f5000010f70003060000041702800006f8000002f8000080f5000010f70003060000041e02800006f8000002f8000080fd0003c0060060fd000010f70003060000041e02800006f8000002f8000080fe000301c00e0cfc0000 -10f70003060000042005800006001ef0fb000002f8000080fd0002c0060cfc000010f70003060000042305800006000c60fb000002f8000d8000f9f9c7cee7fe639f8f000010f70003060000042305800006000c60fb000002f8000d8001ccfb6cc666cce6cedb000010f70003060000042608800006000c60e7ff80fe0000 -02f8000d8000ccc63cc6678c6c6cd8000010f70003060000042e08800006000fe1b3eec0fe000302000038fb000d8000ccc63cc6670c6c6cce000010fc00010180fe0003060000043008800006000c631b0cc0fe00030200006cfb000d8000ccc63cc6678c6c6cc3000010fe000006fe000618000006000004300880000600 -0c631b0cc0fe000302000060fb000d8000ccc36cc6e6cf66ccdb000010fe000006fe0006180000060000043308800006000c631b0cc0fe0025020000ffef3f73c780008000f9e1c7e3ffe6f39ffe0000101e39f8ff7ef1bf3cf000060000042c08800006000c61b30cc0fe000c02000063f99dde6d80008000c0f7000e1037 -6cedb63f9b9d99b000060000042c08800006001ef0e79fe0fe000c0200006307999e6c00008000c0f7000e1030c6cd86307999998000060000042602800006f8000c020000630d999fe700008001e0f7000e1030c6cce630d99998e000060000042402800006f8000a0200006319999e01800080f5000e1030c6cc36319999 -983000060000042402800006f8000a020000631b999e6d800080f5000e10336ccdb7b1b9999fb000060000042802800006f8000a020000f78fffffcf000080fc000006fb000e101e39ffe378ffffcde000060000041b02800006f8000002f8000080fc00000efb000010f70003060000041e05800006000030fb000002f800 -0080fc000006fb000010f70003060000042205800006000070fb000002f8000080fe000403fee679e0fd000010f70003060000042205800006000030fb000002f8000080fe000401f666cf60fd000010f7000306000004240c800006000f33cee7bcf0000002f8000080fe0003018666cffc000010f7000306000004250c80 -0006001bb6666de7b0000002f8000080fe0004018666fdc0fd000010f7000306000004250c800006001831e66c6780000002f8000080fe0004018666c060fd000010f7000306000004250c80000600183366677ee0000002f8000080fe00040186e6cf60fd000010f7000306000004250c8000060018366661e030000002f8 -000080fe000403c3ff7bc0fd000010f70003060000041d0c8000060019b6e6ede7b0000002f8000080f5000010f70003060000041d0c800006000f7bf3ff3de0000002f8000080f5000010f70003060000041702800006f8000002f8000080f5000010f70003060000041702800006f8000002f8000080f5000010f7000306 -0000041702800006f8000002f8000080f5000010f70003060000041702800006f8000002f8000080f5000010f70003060000041702800006f8000002f8000080f5000010f70003060000041702800006f8000002f8000080f5000010f70003060000041702800006f8000002f8000080f5000010f700030600000417028000 -06f8000002f8000080f5000010f70003060000041702800006f8000002f8000080f5000010f70003060000041702800006f8000002f8000080f5000010f70003060000041702800006f8000002f8000080f5000010f70003060000041702800006f8000002f8000080f5000010f70003060000041702800006f8000002f800 -0080f5000010f70003060000041702800006f8000002f8000080f5000010f70003060000041702800006f8000002f8000080f5000010f70003060000041702800006f8000002f8000080f5000010f70003060000041702800006f8000002f8000080f5000010f70003060000041702800006f8000002f8000080f5000010f7 -0003060000041702800006f8000002f8000080f5000010f70003060000041702800006f8000002f8000080f5000010f70003060000041702800006f8000002f8000080f5000010f70003060000041702800006f8000002f8000080f5000010f70003060000041702800006f8000002f8000080f5000010f700030600000417 -02800006f8000002f8000080f5000010f70003060000041702800006f8000002f8000080f5000010f70003060000041702800006f8000002f8000080f5000010f70003060000041702800006f8000002f8000080f5000010f70003060000041702800006f8000002f8000080f5000010f70003060000041702800006f80000 -02f8000080f5000010f70003060000040b02800007d6ff03fe0000040b02800007d6ff03fe0000040a0080ea000040e90000040a0080ea000040e90000040a0080ea0000e0e90000040a0080ea0000e0e90000040b0080eb000101f0e90000040b0080eb000101f0e90000040b0080eb000103f8e90000040b0080eb000103 -f8e90000040b0080eb000107fce90000040b0080eb000107fce90000040b0080eb000107fce90000040b0080eb00010ffee90000040b0080eb00010ffee90000040b0080eb000103fce90000040a0080ea0000c0e90000040a0080ea0000c0e90000040a0080ea0000c0e90000040a0080ea0000c0e90000040a0080ea0000 -c0e90000040a0080ea0000c0e90000040a0080ea0000c0e90000040a0080ea0000c0e90000040a0080ea0000c0e90000040a0080ea0000c0e90000040a0080ea0000c0e90000040a0080ea0000c0e90000040a0080ea0000c0e90000040a0080ea0000c0e90000040a0080ea0000c0e90000040b0080eb000103fce9000004 -0b0080eb00011fffe90000040b0080eb00010ffee90000040b0080eb00010ffee90000040b0080eb000107fce90000040b0080eb000107fce90000040b0080eb000107fce90000040b0080eb000103f8e90000040b0080eb000103f8e90000040b0080eb000101f0e90000040b0080eb000101f0e90000040a0080ea0000e0 -e90000040a0080ea0000e0e90000040a0080f000f5ffee0000040e0080f1000003f5ff00c0ef000004100080f100010fc0f7400141f0ef0000040e0080f100001cf5000038ef0000040e0080f1000038f500001cef0000040e0080f1000070f500000eef0000040e0080f10000e4f5040007ef0000040e0080f10000c0f500 -0003ef000004100080f200010180f500010180f0000004100080f200010180f500010180f0000004100080f2000103c0f5400141c0f00000040e0080f2000003f30000c0f00000040e0080f2000003f30000c0f00000040e0080f2000003f30000c0f00000040e0080f2000003f30400c0f00000040e0080f2000003f30000 -c0f00000040e0080f2000003f30000c0f00000040e0080f2000003f30000c0f00000040e0080f2000003f34000c0f00000040e0080f2000003f30000c0f0000004120080f2000003fa000018fb0000c0f0000004120080f2000003fa000018fb0000c0f0000004150080f2000003fc0403fdc7bcf4fc0400c0f00000041500 -80f2000003fc0003776cd998fc0000c0f0000004150080f2000003fc0003666cd878fc0000c0f0000004160080f2000003fc0004666fd8dbe0fd0000c0f0000004150080f2000003fc4003666c59d8fc4000c0f0000004150080f2000003fc0003666cdfb8fc0000c0f0000004150080f2000003fc0003fff78cfcfc0000c0 -f00000040e0080f2000003f30000c0f00000040e0080f2000003f30400c0f00000040e0080f2000003f30000c0f00000040e0080f2000003f30000c0f00000040e0080f2000003f30000c0f0000004120080f2000403404041c0f74000c0f0000004170080f2000003fd000030fe00010180fd0000c0f0000004170080f200 -0003fd000030fe00010180fd0000c0f0000004190080f2000b03000001fe79efdf3f7bcf7efe0000c0f0000004190080f2000b03040407bf3737fd9fcd9dbefe0400c0f0000004190080f2000b03000001b333361998cd99b0fe0000c0f0000004190080f2000b03000001b333f61998fd9fb0fe0000c0f0000004190080f2 -000b03000001b333061998c19830fe0000c0f0000004190080f2000b03404041f37f7659d8cdf9f0fe4000c0f0000004190080f2000b03000003ff99ef1f3c78cf78fe0000c0f0000004120080f2000003fb000018fa0000c0f0000004120080f2000003fb000018fa0000c0f0000004120080f2000003fb04003cfa0400c0 -f00000040e0080f2000003f30000c0f00000040e0080f2000003f30000c0f0000004100080f200010380f5000101c0f0000004100080f2000101c0f540014180f0000004100080f200010180f500010180f00000040e0080f10000c0f5000003ef000004110080f3000201ffe0f5000107fef0000004110080f3000201ff74 -f504010ffef0000004110080f3000201fe38f500011ffef0000004100080f20001fc1cf5000139fcf0000004130080f3000301f80f80f7000201f0fcf0000004120080f30002067003f5ff02c07b80f1000004120080f30002186000f5ff02003860f1000004170080f30000e0fe000001fa000004fe00011018f100000416 -0080f4000003fd000001fa000004fd000007f1000004170080f400000cfd00010380fb00000efc0000c0f2000004170080f4000030fd00010380fb00000efc000030f2000004170080f40000c0fd000107c0fb00001ffc00000ef2000004180080f5000003fc000107c0fb00001ffc00010180f3000004180080f500000cfc -00010fe0fb00013f80fc000060f3000004180080f5000070fc00010fe0fb00013f80fc00001cf3000004190080f600010180fc000107e0fb00011f80fc000003f3000004160080f6000006fb000001fa000004fa0000c0f4000004160080f6000018fb000001fa000004fa000038f4000004160080f6000060fb000001fa00 -0004fa000006f4000004180080f700010180fb000001fa000004fa00010180f5000004160080f7000006fa000001fa000004f9000070f5000004160080f7000038fa000001fa000004f900000cf5000004160080f70000c0fa000001fa000004f9000003f5000004160080f8000003f9000001fa000004f80000e0f6000004 -180080f800000cf9000107e0fb00011f80f9000018f6000004180080f8000030f900011ff0fb00017fc0f9000006f6000004190080f80000c0f900010fe0fb00013f80f9000101c0f70000041a0080fa00010603f800010fe0fb00013f80f800013008f8000004190080fa00010e1cf8000107c0fb00001ff700010c0cf800 -0004190080fa00011f60f8000107c0fb00001ff70001039ef8000004180080fa00013f80f800010380fb00000ef600007ff8000004190080fa00017f80f800010380fb00000ef600013f80f90000041c0080fa0001ff80f8000001fc00007ff8ff00fcfe00013fc0f90000041d0280000ffaff03fe000001f9ff02c00001f6 -ff02000007f9ff028000041e0280003ff9ff02800007f9ff03f00007c0f8000307c0001ff9ff02e000041d028000f8fa000303e0001ff900027c000ef60002e0007cf90002f800041c028001c0f90002700038f900020e001cf600027000e0f900021c00041c02800380f90002380070f90002070038f600023801c0f90002 -0e00041b018007f800021c00e0f90002038070f600021c0380f900020700041a01800ef800020e01c0f9000201c060f600010c07f800020380041901800cf80002060180f80001c0c0f600010606f8000201800417018018f800010303f7000160c0f60001060cf70001c00417018018f800010303f7000161c0f60001070c -f70001c00417018038f800010387f700017180f60001031cf70001e00417018030f800010186f700013180f600010318f70001600417018030f800010186f700013180f600010318f70001600417018030f800010186f700013180f600010318f7000160041e018030f800010186f700013180fd000360030030fe00010318 -f7000160041d018030f800010186f700013180fd0002e00706fd00010318f7000160041d018030f800010186f700013180fd0002600306fd00010318f7000160041f018030f800010186f7000e3180007cfce3e773ff31cfc0000318f700016004270680300007e0000cfd00040186000007fa000e318000e67db663336673 -6760000318f70001600428068030000330001cfd0005018600000d80fb000e31800066631e6333c6363660000318f7000160042b068030000318000cfd0004018600000cfa000e31800066631e633386363660000318fb000018fe000160043213803000031bf38c70f80000018600001ff9e7ee78fe000e31800066631e63 -33c6363660000318fd0007600000018000600432138030000331f6ccd9980000018600000cfb33bbccfe000e3180006661b6637367b36660000318fd00076000000180006004331380300003e18c6d8d980000018600000cc0f333ccfe001a3180007cf0e3f1fff379cff000031801e39f8ff7ef1bf3c00060042d13803000 -03018c6d8d980000018600000cc1b333fcfe000331800060f8000d03180376cedb63f9b9d9800060042d1380300003018c6d8cf00000018600000cc33333c0fe000331800060f8000d0318030c6cd863079999800060042d13803000030186ccd9800000018600000cc37333ccfe0003318000f0f8000d0318030c6cce630d -9999800060042b1380300007c3c39e71f00000018600001fe1fffff8fe00013180f6000d0318030c6cc3631999998000600422018030fc0005031800000186f700013180f6000d03180336ccdb7b1b9999c000600426018030fc0005031800000186f700013180fc000003fc000d031801e39ffe378ffffcc00060041f0180 -30fc000501f000000186f700013180fc000007fc00010318f7000160041b018030f800010186f700013180fc000003fc00010318f7000160041e018030f800010186f700013180fe000301ff733cfd00010318f7000160041f028030c0f90002018618f800013180fd0002fb3366fd00010318f700016004290380300018fd -00076000000186000180fe00000cfe00013180fd0002c33366fd00010318f7000160042a0380300018fd00076000000186000180fe00000cfe00013180fd0002c3337efd000203180cf80001600431188030dfbcf7ef9fbcf7bf0001861bf3cf7ef9fbde7bf0003180fd0002c33360fd000403180000c0fe000006fe000160 -0431188031ced99bfccfe66cdf00018639d999bfccfe6ccdf0003180fd0002c37366fd000403180000c0fe000006fe0001600432188030ccd99b0ccc666cd8000186199999b0ccc66ccd80003180fe000301e1ffbcfd000d03180df9e7bf7cfdef3df80060042b188030ccd9fb0ccc7e6fd800018619999fb0ccc7ecfd8000 -3180f6000d03181cecccdfe67f3666f80060042b188030ccd9830ccc606c1800018619999830ccc60cc180003180f6000d03180cccccd866633666c00060042b188030ccdf9b0ccc667cd80001861999f9b0ccc66fcd80003180f6000d03180ccccfd86663f67ec00060042b188031ffecf78f9e3c37bc0001863ffccf78f9 -e3c67bc0003180f6000d03180ccccc1866630660c000600426018030fe00000cfc00010186fd0000c0fc00013180f6000d03180cccfcd8666337e6c000600428018030fe00000cfc00010186fd0000c0fc000331800060f8000d03181ffe67bc7cf1e33de00060042b018030fe00001efc00010186fe000101e0fc00043180 -00000cfd000030fe00010318fd000060fc0001600422018030f800010186f70004318000000cfd000030fe00010318fd000060fc0001600423018030f800010186f7000e3180006fde7bf3efcf7bcfc0000318fd0000f0fc000160041f018038f800010387f7000e71c000e76ccdf737d9b667c000071cf70001e0041f0180 -18f800010303f7000e60c000666ccd833619b6660000060cf70001c0041f018018f800010303f7000e60c000666cfd83361fb7e60000060cf70001c0042101800cf80002060180f8000ec06000666cc1833618360600000c06f800020180042201800ef800020e01c0f9000f01c07000666fcd833619be6600001c07f80002 -03800423018007f800021c00e0f9001003803800fff67bc3ef0f1bcf0000380380f900020700042002800380f90002380070f9000207001cfd000003fb00027001c0f900020e000420028001c0f90002700038f900020e000efd000003fb0002e000e0f900021c000424028000f8fa000303e0001ff900037c0007c0fe0001 -0780fd000307c0007cf90002f800041c0280003ff9ff02800007f9ff02f00001f6ff0200001ff9ff02e000041f0280000ffaff03fe000001f9ff03c000007ff8ff03fc000007f9ff02800004060080d1000004060080d1000004060080d1000004060080d1000004060080d1000004060080d1000004060080d10000040600 -80d1000004060080d1000004060080d1000004060080d1000004060080d1000004060080d1000004060080d1000004060080d1000004060080d100000404d0ff00fc060080d1000004060080d1000004060080d1000004060080d1000004060080d1000004060080d1000004060080d1000004060080d1000004060080d100 -0004060080d1000004170080f5000d07f030fe3cf780f0e3c000003030eb0000041a0080f50010031830631863039c718000007003000180ee0000041a0080f50010030c78618cc3030c718000003003000180ee0000041c0080f50012031878630cc306067981e7ef3e37bc7bddff3cf00000041c0080f5001203f0cc7e07 -8306066d8333fbbb7366dd8cdf66f00000041c0080f500120318cc63078306066d80f318333366c18cd866f00000041c0080f50012030cfc61830306066781b31833337ec18cd87ef00000041c0080f50012030d86618303030c63833318333360c18cd860f00000041c0080f500120319866303031b9c63837319b333e6cd -edd866f00000041c0080f5001207f3cffe0787f8f0f181ff8f7ff9bc78c7fc3cf0000004060080d1000004060080d1000004060080d1000004060080d1000004060080d1000004060080d1000004060080d1000004060080d1000004060080d1000004060080d1000004060080d1000004060080d1000004060080d1000004 -060080d1000004060080d1000004060080d1000004060080d1000004060080d100000404d0ff00fc00ff}}\par -\pard \li-20\sa120\tx440 -The arrows show the communication paths (data and control flow). The arrow connecting the metainterpreter with the knowledge base is also to be regarded as a data and control flow channel. It is used for transmitting the contents of the knowledge base part -s to the responsible interpreters. Such a part which is not represented in the figure is the so-called instruction part where the control statements for the metainterpreteritself are filed. \par -\pard \li-20\sa120\tx440 -The integration is achieved by the fact that, for example, the left-hand side of production rules may consist of logical expressions or references to objects. The interaction is realized as follows. If the rule interpreter wants to apply such a rule, it ac -tivates the metainterpreter by sending it a condition from the left-hand side of the rule, and requests the interpretation of the condition. The metainterpreter then identifies the type of the conditio -n. If it is a reference to an object state, it forwards it to the frame interpreter which can find out whether the object concerned is in the respective state or not. Via the metainterpreter, the reply is then returned to the rule interpreter thus enabling - it to continue its work. If the first reply is positive and if the left-hand side is a conjunction of conditions, the remaining conditions are handled in the same way. \par -\pard \qc\li-20\sa120\tx440 {{\pict\macpict\picw423\pich269 -1de000000000010d01a7001102ff0c00fffe0000004800000048000000000000010d01a7000000000001000a00000000010d01a70099803600000000010d01a7000000000000000000480000004800000000000100010001000000000031b8c4000000000000536e000000010000ffffffffffff0001000000000000000000 -00010d01a700000000010d01a70040000a00000000010d01a706d4ff00fcf90006d4ff00fcf9000800e0d520002cf9000800c0d500000cf9000800c0d500000cf9000800c0d500000cf9000800c2d502000cf9000800c0d500000cf9000800c0d500000cf9000800c0d500000cf9000800e0d520002cf9000800c0d500000c -f9000800c0d500000cf9000800c0d500000cf9000800c2d502000cf9000800c0d500000cf9000800c0d500000cf9000800c0d500000cf9000800e0d520002cf9000f00c0ee00033ffffff8ec00000cf9001100c0ef00057fc0000007fced00000cf9001200c0f000011f80fd000103f0ee00000cf9001100c2f1020103e0fb -00000fee02000cf9001000c0f100001ef90000f0ef00000cf9001000c0f10000e0f900000eef00000cf9001100c0f2000007f8000101c0f000000cf9001000e0f2200038f7000030f020002cf9001000c0f2000060f700000cf000000cf9001100c0f300010180f7000003f000000cf9001000c0f3000002f5000080f10000 -0cf9001000c2f302000cf5000062f102000cf9001000c0f3000010f5000010f100000cf9001000c0f3000030f5000018f100000cf9001000c0f3000020f5000008f100000cf9001500e0f32005400000060020fa000004f120002cf9001900c0f3000940000002000010000001fe000004f100000cf9001900c0f3000d4000 -17b2606b3b17e5b3b1600004f100000cf9001900c0f3000d4000089290249488924948800004f100000cf9001900c2f3020d40000892f0249788927978800006f102000cf9001900c0f3000d2000089280249408924140800008f100000cf9001900c0f3000d3000089290249488924948800018f100000cf9001900c0f300 -0d10001c6f607ecb1ce730b1c00010f100000cf9001400e0f320002cfa000080fd000060f120002cf9001500c0f3000002fb000101c0fd000080f100000cf9001100c0f300010180f7000003f000000cf9001000c0f2000060f700000cf000000cf9001000c2f2020018f7000032f002000cf9001100c0f2000007f8000101 -c0f000000cf9001000c0f10000e0f900000eef00000cf9001000c0f100001ef90000f0ef00000cf9001100e0f1200121e0fb00000fee20002cf9001200c0f000011f80fd000103f0ee00000cf9001100c0ef00057fc0000007fced00000cf9000f00c0ee00033ffffff8ec00000cf9000800c2d502000cf9000800c0d50000 -0cf9000800c0d500000cf9000800c0d500000cf9000800e0d520002cf9000f03c0000003f7ff00e0e300000cf9000f03c0000002f7000020e300000cf9000f03c0000002f7000020e300000cf9000e00c2fe02f7000022e302000cf9000f03c0000002f7000020e300000cf9000f03c0000002f7000020e300000cf9001b03 -c0000002f70002200007f7ff00fefe00000ff6ff02f8000cf9001b03e0202022f70002202024f7000002fe200028f6000208202cf9001b03c0000002f70002200004f7000002fe000008f6000208000cf9001b03c0000002f70002200004f7000002fe000008f6000208000cf9001b03c0000002f70002200004f7000002fe -000008f6000208000cf9001800c2fe02f70002220204f700fd020008f600020a020cf9001b03c0000002f70002200004f7000002fe000008f6000208000cf9001b03c0000002f70002200004f7000002fe000008f6000208000cf9001b03c0000002f70002200004f7000002fe000008f6000208000cf9003006e020246200 -3040fe0000c0fe000720202c030001000cfd0008010220232028000c10fe0007018868000408202cf9002e09c0000082001000010001fd000320000401fe000004fc00120200090008000400004000008080002008000cf900312dc0000dc2071ccc3b8b63996cb1c620cb1c011c6b398419b796c73b3b601dc62c01c7331c -e2d8e399d9cc7ced800cf900312dc000048208925249049124924a492124a40122914a4424a2492949469009291a022494a4412514888a52251a400cf900312dc202068208925e4104f13c9e4a0f22e6a401229141c43c4249e63146920b2f1a022497a0412514888a0e251a420cf900312dc000048208925041048120904a -082124a401226142442042490109469009281a02249420412514888a12251a400cf900312dc000048208925249049124924a492124a40122814a4424a2492949469009291a022494a4412514888a52251a400cf900312dc0000fc2070c4c308e6399cced8620dede039c73b1ae19b39cce73bbd807763b01c31318236ee3dd -dd8d1eef600cf9002806e0202022000040fa0005202024000088fe000002fe000002fe200328000010f9000208202cf9002806c0000002000080fa0005200004000070fe000007fe000002fe000308000020f9000208000cf9001b03c0000002f70002200004f7000002fe000008f6000208000cf9001b03c0000002f70002 -200004f7000002fe000008f6000208000cf9001800c2fe02f70002220204f700fd020008f600020a020cf9001b03c0000002f70002200004f7000002fe000008f6000208000cf9001b03c0000002f70002200004f7000002fe000008f6000208000cf9001b03c0000002f70002200004f7000002fe000008f6000208000cf9 -001b03e0202022f70002202024f7000002fe200028f6000208202cf9001b03c0000002f70002200004f7000002fe000008f6000208000cf9001b03c0000002f70002200004f7000002fe000008f6000208000cf9001b03c0000002f70002200004f7000002fe000008f6000208000cf9001800c2fe02f70002220204f700fd -020008f600020a020cf9001b03c0000002f70002200004f7000002fe000008f6000208000cf9001b03c0000002f70002200004f7000002fe000008f6000208000cf9001afeff00fef700023ffffcf7000003feff00f8f600020ffffcf9001afeff00fef700023ffffcf7000003feff00f8f600020ffffcf90018fe000002f7 -0002200004f7000002fe000008f6000008f70018fe000002f70002200004f7000002fe000008f6000008f70018fe000002f70002200004f7000002fe000008f6000008f70018fe000002f70002200004f7000002fe000008f6000008f70018fe000002f70002200004f7000002fe000008f6000008f70018fe000002f70002 -200004f7000002fe000008f6000008f70018fe000002f70002200004f7000002fe000008f6000008f70018fe000002f70002200004f7000002fe000008f6000008f70018fe000002f70002200004f7000002fe000008f6000008f70018fe000002f70002200004f7000002fe000008f6000008f70018fe000002f700022000 -04f7000002fe000008f6000008f70018fe000002f70002200004f7000002fe000008f6000008f70018fe000002f70002200004f7000002fe000008f6000008f70018fe000002f70002200004f7000002fe000008f6000008f70018fe000002f70002200004f7000002fe000008f6000008f70018fe000002f70002200004f7 -000002fe000008f6000008f70018fe000002f70002200004f7000002fe000008f6000008f70018fe000002f70002200004f7000002fe000008f6000008f70018fe000002f70002200004f7000002fe000008f6000008f70018fe000002f70002200004f7000002fe000008f6000008f70018fe000002f70002200004f70000 -02fe000008f6000008f70018fe000003f7ff02e00004f7000002fe000008f6000008f70016fc000001f7000004f7000002fe000008f6000008f7001afc000001fd000040fc000004f7000002fe000008f6000008f7001afc000001fd000040fc000004f7000002fe000008f6000008f7001afc000001fd0000e0fc000004f7 -000002fe000008f6000008f7001afc000001fd0000e0fc000004f7000002fe000008f6000008f7001bfc000001fe000101f0fc000004f7000002fe000008f6000008f7001efc000001fe000101f0fc000304000010fa000002fe00000ff6ff00f8f70022fc000001fe000103f8fc000304000010fe000004fe000002fa0000 -04fe000001f30022fc000001fe000103f8fc000304000010fe000004fe000002fa000004fe000001f30023fc000001fe000101f8fc000304000010fe00000efe000002fa000004fe00010380f4001bfc000001fd000040fc000007f7ff00fefa000004fe00010380f4001bfc000001fd000040f9000010fe00001ff6000004 -fe000107c0f4001bfc000001fd000040f9000010fe00001ff6000004fe000107c0f4001cfc000001fd000040f9000010fe00013f80f7000004fe00010fe0f4001cfc000001fd000040f9000010fe00013f80f7000004fe00010fe0f4001cfc000001fd000040f9000010fe00011f80f7000004fe000107e0f4001afc000001 -fd000040f9000010fe000004f6000004fe000001f3001afc000001fd000040f9000010fe000004f6000004fe000001f3001afc000001fd000040f9000010fe000004f6000004fe000001f3001afc000001fd000040f9000010fe000004f6000004fe000001f3001afc000001fd000040f9000010fe000004f6000004fe0000 -01f3001afc000001fd000040f9000010fe000004f6000004fe000001f3001afc000001fd000040f9000010fe000004f6000004fe000001f3001afc000001fd000040f9000010fe000004f6000004fe000001f3001bfc000107e0fe000040f9000010fe000004f6000004fe000001f3001bfc00011ff0fe000040f9000010fe -000004f6000004fe000001f3001bfc00010fe0fe000040f9000010fe000004f6000004fe000001f3001bfc00010fe0fe000040f9000010fe000004f6000004fe000001f3001bfc000107c0fe000040f9000010fe000004f6000004fe000001f3001bfc000107c0fe000040f9000010fe000004f6000004fe000001f3001bfc -00010380fe000040f900007efe000004f600041f80000001f3001cfc00010380fe000040fa000101fffe000004f600047fc0000001f3001afc000001fd000040f90000fefe000004f600043f80000001f3001afc000001fd000040f90000fefe000004f600043f80000001f3001afb00040fffff0040f900007cfe000004f6 -00001ffe000001f3001afc000407f00000fef800007cfe000004f600001ffe000001f3001afc0000f0fd0000f0f9000038fe000004f600000efe000001f3001afd00000ffc00000ff9000038fe000004f600000efe000001f3001afd000070fb0000e0fa000010fe000004f6000004fe000001f3001bfe00010180fb000018 -fa000010fe000004f6000004fe000001f30018fe000006fa000006f9000307ffff84f500033ffffc01f3001bfe000018fa00010180fb000403f800007ff600041fc00003f8f3001cfe000060f9000060fb000078fd000078f8000103c0fe000103c0f4001cfe000080f9000010fc00010780fd00010780f900003cfc00003c -f4001c02000001f8000008fc000038fb000070fa000101c0fc00010380f5001a02000002f8000004fc0000c0fb00000cfa000006fa000060f5001a02000004f8000002fd000003fa000003fa000018fa000018f5001a02000008f8000001fd00000cf90000c0fb000060fa000006f5001c02000008f8000001fd000030f900 -0030fc00010180fa00010180f6002102000010fe000020fb000080fe000340000008fc000008fc000002f8000040f60026070000100000200008fe0002800080fe00048000080002fe00012004fc000004f8000020f600261a0000102d8c76659d97e5b1d960800000010b631d996765f96c765afc000008f8000010f60026 -1a000010125229224a489248a4808000000204948a48929224922921fc000010f8000008f600271b000010125e27224bc89278bc8080000004049789c892f2249e2f2080fd000020f8000004f600270c000008125029224a089240a081fe000b0404940a4892822490282080fd000020f8000004f6002b0c00000812522922 -4a489248a481fe000b0804948a4892922492292040fd000040fe000080fc000002f6002d0c00000436ec16f7659ce73059c2fe000b080dbb05bdd96739cc167040fd000a4000008000200000020002f6002702000002fb000380000004fe000008fb000020fe000040fd000a40b631d996765f96c76582f6002802000001fc -000401c0000008fe000008fb000070fe000040fd000a404948a489292249229202f60020fe000080f9000010fe000008f7000040fd000a4049789c892f2249e2f202f60020fe000060f9000060fe000004f7000080fd000a204940a489282249028204f60021fe000018fa00010180fe000004f7000080fd000a204948a489 -292249229204f60020fe000006fa000006fd000002f8000001fc000a10dbb05bdd96739cc16708f6001ffe00010180fb000018fd000001f8000002fc000008fc000002fe000010f6001efd000070fb0000e0fc000080f9000004fc000004fc000007fe000020f6001afd00000ffc00000ffb000040f9000008fc000002f800 -0040f6001cfc0000f0fd0000f0fb000030f9000030fc00010180fa00010180f6001afc000407f00000fefa00000cf90000c0fb000060fa000006f50019fc0003010ffffff9000003fa000003fa000018fa000018f5001bfc000001fd000040fa0000c0fb00000cfa000006fa00016040f6001dfc000001fd000040fa000038 -fb000070fa000101c0fc0002038070f6001efc000001fd0000e0fa00010780fd00010780f900003cfc00023c007cf6001efc000001fd0000e0f9000078fd000078f8000103c0fe000303c0007ef6001ffc000001fe000101f0f9000403f800007ff600081fc00003f800003f80f70020fc000001fe000101f0f900041007ff -ff80f7000920003ffffc0004003f80f7001ffc000001fe000103f8f9000010fe000004f70002200010fe000202003ff6001ffc000001fe000103f8f9000010fe000004f70002400030fe000201003df6001ffc000001fe000101f8f9000010fe00000ef70002400070fe0002010031f6001efc000001fd000040f9000010fe -00000ef700024000f0fd0002800080f7001efc000001fd000040f9000010fe00001ff700028001f0fd0002400040f7001efc000001fd000040f9000010fe00001ff700028003f0fd0002200020f7001ffc000001fd000040f9000010fe00013f80f800028007f0fd0002200020f7001ffc000001fd000040f9000010fe0001 -3f80f800028001f0fd0002100010f70020fc000001fd000040f9000010fe00011f80f90003010000f0fd0002080008f7001ffc000001fd000040f9000010fe000004f8000301000080fd0002080008f7001ffc000001fd000040f9000010fe000004f8000301000080fd0002040004f7001efc000001fd000040f9000010fe -000004f80002020001fc0002020002f7001efc000001fd000040f9000010fe000004f80002020001fc0002020001f7001efc000001fd000040f9000010fe000004f80002020001fc0002010001f7001efc000001fd000040f9000010fe000004f80002020002fb0002800080f8001efc000001fd000040f9000010fe000004 -f80002040002fb0002800040f8001efc000001fd000040f9000010fe000004f80002040002fb0002400040f8001ffc000107e0fe000040f9000010fe000004f80002040004fb0002200020f8001ffc00011ff0fe000040f9000010fe000004f80002080004fb0002100010f8001ffc00010fe0fe000040f9000010fe000004 -f80002080004fb0002100010f8001ffc00010fe0fe000040f9000010fe000004f80002080008fb0002080008f8001ffc000107c0fe000040f9000010fe000004f80002100008fb0002040004f8001ffc000107c0fe000040f9000010fe000004f80002100008fb0002040002f8001ffc00010380fe000040f900007efe0000 -04f80002100010fb0002020002f80020fc00010380fe000040fa000101fffe000004f80002100010fb0002010001f8001ffc000001fd000040f90000fefe000004f80002200010fb000301000080f9001efc000001fd000040f90000fefe000004f80002200020fa0002800080f9001efb00040ffffff840f900007cfe0000 -04f80002200020fa0002400040f90020fc00050ff0000007f8f900007cfe000004f9000303e00020fa0002200020f90021fd000103e0fd000103e0fa000038fe000004f9000303f80040fa0002270010f9001ffd00003cfb00001efa000038fe000004f9000303fc0040fa00021f0010f90020fe00010380fa0000e0fb0000 -10fe000004f9000301f80040fa00023f0008f9001ffe00001cf900001cfb000010fe000004f9000301f80080fa00023f0004f90023fe0000e0f900010380fb00030fffffe4f9000401f07ffff8fb00057f00043ffff8fc002602000003f7000060fc00050ff000001fe0fa000501ff800007e0fc00061f801fc00007f0fd00 -280200000cf7000018fd000103f0fd00011f80fb000103e0fe00001ffc00020f83e0fe00010f80fe002402000010f7000004fd00003cfb000078fb00011d80fd0000e0fd0001039cfc000070fe002302000060f7000003fe000101c0fb000007fb0000e1fc00001cfc0000e0fc00000efe002302000080f600038000000ef9 -0000e0fd000007fb00010380fe000003fb00010180ff0020010001f5000340000030f9000018fd000018fa000060fe00001cfa000070ff0020010002f50003200000c0f9000006fd000060fa000018fe000020fa000008ff0020010002f50002200003f800010180fe0000c0fa00000cfe0000c0fa000006ff002803000400 -0cfe000020fb000210000cf7000360000003fc0008400000030000030180fb00020180002a0300040010fd0008100000010000100010f7000310000006fe000908000020000180000602f90001c0002e100004003ad96c306b3997e5b39960100020f7001308000008038e58fd6cd6700000400008075b2d8cfc000120002e -100004001124924824924892492480100040f700130400001004912528924920000020001002249252fc000110002e10000400111c92782493c892793c80100080f7001302000030041124c88e492000003000300223925efc000118002e100002001124924024920892412080200080f70013020000200411242892492000 -0010002002249250fc0001080033150002001124924824924892492480200103e001800020fc00130100004004912528924920000008004002249252fc00010400352e0001003b9bb7307ec99ce73099c04001011000800000100000010001000040030e77c5cdfd900000080040077376ecfc000104002702000080fa0000 -80fe001080010115b89c686b3997e5b39961000080f80002040080f8000102002802000060fb001501c00000030001011244a29024924892492481000080f80002040080f8000102002402000010f7001104000101e244a2902493c892793c81000080f80002040080f800010200240200000cf70011180000810244a26024 -920892412082000080f80002040080f8000102002602000003f70012600000810244a2802492489249248200008002f9000304008002f90001020031fe0000e0f9001403800000438739dc707ec99ce73099c40000800001fe000010fe00040400800001fe000010fe0001020031fe00001cf900001cfe000020fe000088fe -001d8000000800004006b3b17e5b3b16000008004006b3b17e5b3b2c0000040032fe00010380fa0000e0fe000010fe002170000001c000001000004002494889249488000008004002494889249490000004002afd00003cfb00001efd00000cf7001a6000002002497889279788000010002002497889279790000008002d -fd000103e0fd000103e0fd000003f8001b018000003002494089241408000030003002494089241410000018002cfc00050ff0000007f8fb0000c0f9000006fe00171002494889249488000020001002494889249490000010002afb00030ffffff8fa000030f9000018fe00170807ecb1ce730b1c000040000807ecb1ce73 -0b380000200020f000000ef90000e0fe000006fe000008fd000301800006fe000008fc0001c00022f0000101c0fb000007fd000003fe00001cfd000303000003fe00001cfd00020180001aef00003cfb000078fc0000c0fa00000cfe0000c0fa000006ff001cef000103f0fd00011f80fc000060fa000018fe000020fa0000 -08ff001bee00050ff000001fe0fb000018fa000060fe00001cfa000070ff001bed00030fffffe0fa000007fb00010380fe000003fb00010180ff0012e10000e0fc00001cfc0000e0fc00000efe0012e100001cfc0000e0fc00001cfc000070fe0015e1000103e0fe00001ffb000103e0fe00010f80fe0012e000041f800007 -e0fa00041fc00007f0fd000edf00027ffff8f800023ffff8fc0000ff}}\par -\pard \li-20\sa120\tx440 However, if a condition on the left-hand side is a predicate expression, the metaint -erpreter activates the Prolog interpreter. It checks the expression by searching for Horn clauses allowing its proof. The reply of the Prolog interpreter is then returned by the metainterpreter to the rule interpreter as described above. If, eventually, th -e evaluation of the left-hand side of the rule terminates positively, the rule interpreter begins with the evaluation of the actions of the rule in question. For this purpose, it proceeds analogously to the evaluation of the conditions, i.e. the actions ar -e forwarded to the metainterpreter. Actions may, for example, modify object states. Before effecting the modification, the metainterpreter activates the constraint interpreter. The latter checks whether the modification of the objects is consistent with po -ssibly available constraints. If there are no conflicts from the viewpoint of the constraints, the frame interpreter is requested via the metainterpreter to modify the state of the object in question in accordance with the action. \par -\pard\plain \s254\li-20\sb120\sa120\keepn\brdrb\brdrs \tx440 \b\f20\fs36 Architectural characteristics: \par -\pard\plain \li-20\sa120\tx440 \f20 -The basic idea, common to all hybrid systems is that the various integrated formalisms are not provided alternatively, but in a complementary way. The architectural concept distinguishes between several processing levels. At the basic level, which is split - into several modules according to the principle of distributing competence and tasks, problem solving processes operate that are coordinated at a higher level (the metalevel). This horizontal and vertical distribution of functionality provides var -ious advantages of openness from the point of view of system technology: openness in depth since the components of the lower level can in principle be put onto any software or hardware basis; openness in breadth since the various basic components can be de -veloped separately and can thus be exchanged or added at any time; openness in height since additional components can be realized by bootstrapping.\par -\pard\plain \s254\li-20\sb120\sa120\keepn\brdrb\brdrs \tx440 \b\f20\fs36 BABYLON expert systems: \par -\pard\plain \li-20\sa120\tx440 \f20 A BABYLON expert system is divided into a configuration part and a knowledge base. \par -\pard \li-20\sa120\tx440 -The configuration part determines the configuration of the interpreters for the knowledge base. It consists of the metainterpreter, interpreters for different knowledge representation formalisms and the user interface. The knowledge base itself consists of - different parts. They contain programs and data for the various interpreters of the configuration. For example, the rule part contains rule packages for the rule interpreter or the instruction part contains instructions for the metainterpreter. \par -\pard \qc\li-20\sa120\tx440 {{\pict\macpict\picw180\pich287 -0f9000000000011f00b4001102ff0c00fffe0000004800000048000000000000011f00b4000000000001000a00000000011f00b40099801800000000011f00b4000000000000000000480000004800000000000100010001000000000031b7b00000000000005539000000010000ffffffffffff0001000000000000000000 -00011f00b400000000011f00b40040000a00000000011f00b4070007ecff010000070007ecff010000080006ed0002030000080006ed0002030000080006ed0002030000080006ed0002030000150006fe00090180000180c000600001fa0002030000180006fd000680000080400020fe0008800000400000030000180006 -fd0012be0dec8cc21839ce6371cdbcd6e6d000030000180006fd0012a512a49345242432912892d269496000030000180006fd0012c512a89f453c24e8f1289e924f4f4000030000180006fd0012c512a891432025268128909248484000030000180006fd0012a512a893442425329128929249494000030000190006fe00 -1301bf8c51cce79838fc63fc4ddce626e000030000110006f900010480fc000010fd0002030000100006f9000007fb000038fd0002030000080006ed0002030000080006ed0002030000080006ed0002030000080006ed00020300000e0006f8000201fff8f900020300000e0006f80002010008f900020300000e0006f800 -02010008f900020300000e0006f80002010008f900020300000e0006f80002010008f900020300000e0006f80002010008f900020300000e0006f80002010008f900020300000e0006f80002010008f900020300000e0006f80002010008f900020300000e0006f8000201fff8f900020300000e0006f80002020088f90002 -0300000e0006f80002040086f900020300000e0006f80002180081f900020300000f0006f80003600080c0fa00020300000f0006f8000380008030fa0002030000100006f900040300008008fa0002030000100006f900040c00008006fa0002030000110006f90005100000800180fb0002030000110006f9000560000080 -0040fb0002030000120006fa000601800000800030fb0002030000120006fa000002fe000280000cfb0002030000120006fa00000cfe0002800003fb0002030000130006fa000030fe000380000080fc0002030000130006fa000040fe000380000060fc0002030000140006fb00010180fe000380000018fc000203000013 -0006fb000006fd000380000004fc0002030000130006fb000008fd000380000003fc0002030000180006fd00020ffff0fe0001fffefe0001fffefe0002030000180006fd0002080020fe00018002fe00014002fe0002030000180006fd0002080020fe00018002fe00014002fe0002030000180006fd0002080020fe000180 -02fe00014002fe0002030000180006fd0002080020fe00018002fe00014002fe0002030000180006fd0002080020fe00018002fe00014002fe0002030000180006fd0002080020fe00018002fe00014002fe0002030000180006fd00070800200022408002fe00014002fe0002030000180006fd0002080020fe00018002fe -00014002fe0002030000180006fd00020fffe0fe0001fffefe00017ffefe0002030000080006ed0002030000080006ed0002030000080006ed0002030000080006ed0002030000080006ed0002030000080006ed0002030000080006ed0002030000080006ed0002030000080006ed0002030000080006ed00020300000800 -06ed0002030000080006ed0002030000080006ed0002030000080006ed0002030000080006ed0002030000070007ecff010000060007ecffff0006f1000040fa0006f10000c0fa0006f10000c0fa0006f10000e0fa0007f2000101e0fa0007f2000101e0fa0007f2000101f0fa0007f2000103f0fa0007f2000103f0fa0007 -f2000103f8fa0007f2000107f8fa0007f2000107f8fa0006f1000040fa0006f1000040fa0006f1000040fa0006f1000040fa0006f1000040fa0006f1000040fa0006f1000040fa0006f1000040fa0006f1000040fa0006f1000040fa0006f1000040fa0006f1000040fa0006f1000040fa0006f1000040fa0008f300021803 -80fa0007f300010804f90009f3000318cfb867fb0009f3000329249499fb0009f3000329e494f4fb0009f3000329049483fb0009f3000329249499fb0009f300031ccffe6efb0002e90002e90006f1000040fa0006f1000040fa0006f1000040fa0006f1000040fa0006f1000040fa0006f1000040fa0006f1000040fa0006 -f1000040fa0006f1000040fa0006f1000040fa0006f1000040fa0006f1000040fa0006f1000040fa0006f1000040fa0006f1000040fa0006f1000040fa0006f1000040fa0005ebff01f00005ebff01f0000b00c0f2000040fc000130000b00c0f2000040fc000130000b00c0f2000040fc000130000b00c0f2000040fc0001 -30000b00c0f2000040fc000130000b00c0f2000040fc000130000b00c0f2000040fc000130000b00c0f2000040fc000130000b00c0f2000040fc000130000b00c0f2000040fc000130000b00c0f2000040fc000130000b00c0f2000040fc000130000b00c0f2000040fc000130000b00c0f2000040fc000130001100c0fe00 -02400008f8000040fc000130001308c036fc3de1f6fcdb60fa000040fc000130001308c04a924e4255292da0fa000040fc000130001308c079927c411489e920fa000040fc000130001308c041124440cc690920fa000040fc000130001308c04a924c4249292920fa000040fc000130001308c036dc3e2389c4ddb0fa0000 -40fc000130001005c00010000010f7000040fc000130001005c00038000030f7000040fc000130000b00c0f2000040fc000130000b00c0f2000040fc000130000b00c0f2000040fc000130000b00c0f2000040fc000130000b00c0f2000040fc000130000b00c0f2000040fc000130000b00c0f2000040fc000130000b00c0 -f2000040fc000130000a01c00fefff03f80030000e01c008f3000040fe0003080030000e01c008f3000040fe0003080030000e01c008f3000040fe0003080030000e01c008f3000040fe0003080030000e01c008f3000040fe0003080030000e01c008f3000040fe0003080030000e01c008f3000040fe0003080030000e01 -c008f3000040fe0003080030000e01c008f3000040fe0003080030000e01c008f3000040fe0003080030001101c008fe00030e000001f60003080030001501c008fe000310000008fe000004fa000308003000150cc008001cce3e27b5df1b83cedefa000308003000150cc0080025251252982925412164fa000308003000 -150cc008002125125290e925412744fa000308003000150cc0080021251232912925412944fa000308003000150cc0080025251242912925412944fa000308003000150cc0080018cfbf79f8f79be1c7e2fa0003080030001201c008fd000048fe000001f80003080030001301c008fd000070fe00010380f9000308003000 -0a01c008ef0003080030000a01c008ef0003080030001101c008f600030e000001fe0003080030001101c008f6000310000008fe0003080030001301c008f8000c0e6e3e279bdf1b8000080030001301c008f8000c129512528c29254000080030001301c008f8000c1095125288e9254000080030001301c008f8000c1095 -12328929254000080030001301c008f8000c129512428929254000080030001301c008f8000c0c6fbf79dcf79be000080030000e01c008f5000048fc0003080030000e01c008f5000070fc0003080030000a01c008ef0003080030000a01c008ef0003080030000a01c00fefff03f80030000a01c00fefff03f80030000a01 -c008ef0003080030000a01c008ef0003080030000a01c008ef0003080030000a01c008ef0003080030001209c0080060000060180018f70003080030001209c0080020000020080008f7000308003000140bc008002f837b2318860e7398f9000308003000140bc008002944a924a949090ca4f9000308003000140bc00800 -3144aa27a94f093a3cf9000308003000140bc008003144aa2428c80949a0f9000308003000140bc008002944aa24a909094ca4f9000308003000140bc008006fe314731de60e3f18f90003080030000f01c008fc00010120f60003080030000f01c008fc000101c0f60003080030000a01c008ef0003080030000a01c008ef -0003080030000a01c008ef0003080030000a01c008ef0003080030000a01c008ef0003080030000a01c008ef0003080030000a01c008ef0003080030000a01c008ef0003080030000a01c008ef0003080030000a01c008ef0003080030000a01c008ef0003080030000a01c008ef0003080030000a01c008ef000308003000 -0a01c008ef0003080030000a01c008ef0003080030000e01c008fa000003f7ff03f80030000a01c008ef0003080030000a01c008ef0003080030000a01c008ef0003080030000a01c008ef0003080030000a01c008ef0003080030000a01c008ef0003080030000a01c008ef0003080030000a01c008ef0003080030000a01 -c008ef0003080030000e01c008fa000003f7ff03f80030000c03c0080020f10003080030001007c008000020000008f50003080030001108c008006e736fb4dcf4f60003080030001108c008002524b2592938f60003080030001108c008002527a251e9f0f60003080030001209c0080025242251091380f7000308003000 -1108c008002524a2512930f60003080030001108c008007f9373b8c4f8f60003080030000e01c008fe000002f30003080030001201c008fe000007fe000003f7ff03f80030000a01c008ef0003080030000f01c008fe00010218f40003080030000e01c008fd000020f40003080030001007c008003bc63e78e0f500030800 -30001007c0080049294a2920f50003080030000f06c00800212f4229f40003080030000f06c0080019284229f40003080030001007c0080049294a2920f50003080030001007c0080071c6377cc0f50003080030000c03c0080001f10003080030001104c008000380fd000003f7ff03f80030000a01c008ef000308003000 -0e01c008fe000080f30003080030000e05c0080079dbdcf30003080030000e05c00800242ca4f30003080030000e05c0080024e890f30003080030000e05c0080025288cf30003080030000e05c008002528a4f30003080030000e05c0080038fc78f30003080030001003c0080020fc000003f7ff03f80030000c03c00800 -70f10003080030000a01c008ef0003080030000a01c008ef0003080030000a01c008ef0003080030000a01c008ef0003080030000a01c00fefff03f80030000700c0ec000130000700c0ec000130000700c0ec000130000700c0ec000130000700c0ec000130000700c0ec000130000700c0ec000130000700c0ec00013000 -0700c0ec000130000700c0ec000130000700c0ec000130000700c0ec0001300005ebff01f00005ebff01f0000000ff}}\par -\pard\plain \s254\li-20\sb120\sa120\keepn\brdrb\brdrs \tx440 \b\f20\fs36 BABYLON languages: \par -\pard\plain \li-20\sa120\tx440 \f20 -The following knowledge representation formalisms are available: objects, rules, Prolog and constraints. Each of them occupies a specific part in the BABYLON knowledge base. The global flow of control is defined separately in the instruction part. All form -alisms allow to access the implementation language Common Lisp.\par -\pard \qc\li-20\sa120\tx440 {{\pict\macpict\picw173\pich196 -08140000000000c400ad001102ff0c00fffe000000480000004800000000000000c400ad000000000001000a0000000000c400ad009980160000000000c400ad000000000000000000480000004800000000000100010001000000000031b67c00000000000055e6000000010000ffffffffffff0001000000000000000000 -0000c400ad0000000000c400ad0040000a0000000000c400ad04ecff00f804ecff00f80600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180e08c06000000c03000060f50000180e08c020000004 -01000020f5000018100ac02d639f74c71a6038c730f7000018100ac028944a25292490252948f7000018100ac030944545e924f024e678f7000018100ac028944545091880252140f7000018100ac024944285292090252948f7000018100ac06fdb828ec79c6018de30f70000180a00c0fc000022f30000180a00c0fc0000 -1cf30000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0 -ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180a00c0fb00001ff4ff00f80600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed000018 -0a00c0f70000c1f80000180f00c0f70005400004000010fd0000181000c0f800061c7330ee3c62f8fd0000181000c0f8000622494924129110fd0000181000c0f8000622497904127110fd0000181000c0f8000622494104129110fd0000181000c0f8000622494924129110fd0000181000c0f800061c3130c21c6b88fd00 -00180d00c0f7000301000010fb0000180d00c0f7000302000038fb0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180a00c0fb00001ff4ff00f80600c0ed0000180600c0ed0000180600c0ed0000180600 -c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180a00c0f7000006f80000180e00c0f7000002fe000040fc0000180f00c0f8000517b26078cbe0fc0000180f00c0f80005089290252440fc0000180f00c0f800050892f024e440fc0000180f00c0f80005089280252440fc0000180f00c0f8 -0005089290252440fc0000180f00c0f800051c6f6038de20fc0000180a00c0f5000020fa0000180a00c0f5000070fa0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180a00c0fb00001ff4ff00f80600c0 -ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180c00c0f800021f000cf90000181000c0f80002088004fe000001fd0000181100c0f8000708adc4e343c62f80fe0000181000c0f8000608922514812911fd0000181000c0f800060f122514812711fd0000181000c0f8000608122513012911 -fd0000181000c0f8000608122514012911fd0000181100c0f800071c39cee381c6b880fe0000180b00c0f500010441fb0000180c00c0f50002038380fc0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180a00c0fb00001ff4ff00f80600c0 -ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180a00c0f5000008fa0000181000c0f7000601000004000010fe0000181200c0f9000873963bdb1ace3c62f8fe0000181200c0f90008 -944949248924129110fe0000181200c0f90008844931238924127110fe0000181200c0f90008844909248924129110fe0000181200c0f90008944949248924129110fe0000181200c0f90008639df0f35fb21c6b88fe0000180a00c0f3000010fc0000180a00c0f3000038fc0000180600c0ed0000180600c0ed0000180600 -c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180a00c0fb00001ff4ff00f80600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000 -180600c0ed0000180600c0ed0000180600c0ed0000180e00c0f9000080fe000008fa0000181100c0f8000302000040fe000002fe0000181300c0fa000901ac77bd9cf9cb078c5ffe0000181200c0f90008929244a44a24825222fe0000181200c0f90008926244a04a24824e22fe0000181200c0f90008921244a04a248252 -22fe0000181200c0f90008929244a44a24825222fe0000181300c0fa000901fbe1e3583dcec38d71fe0000180a00c0f3000002fc0000180a00c0f3000007fc0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed0000180600c0ed00 -00180600c0ed0000180600c0ed0000180600c0ed00001804ecff00f804ecff00f80000ff}}\par -\pard\plain \s253\li-20\sb120\sa120\keepn\tx440 \b\f20\fs28 Objects: \par -\pard\plain \li-20\sa120\tx440 \f20 The object part is often the basis for the other parts of the knowledge base: the rule, logic and constraint parts. Nevertheless, the frame interpreter is not super -ior to the rule, Prolog, or constraint interpreter. The object-oriented form of knowledge representation in BABYLON adopts the following main characteristics of the flavor system, a widespread\par -\pard \li-20\sa120\tx440 -object-oriented extension of various Lisp dialects. Objects are instances or occurrences of object types which are called frames in BABYLON (and flavors in the flavor system). A frame defines the attributes (or slots) of its instances (in the flavor system -, these are the instance variables) and determines which behavi -ors are invoked by which messages to its instances. Such a behavior describes the actions which are performed when an instance receives a corresponding message (in the flavor system, these are the (primary) methods). \par -\pard \li-20\sa120\tx440 -Frames can be organized in an inheritance graph and then contain as components frames whose characteristics they inherit. The direct predecessors are referred to as superframes or superior frames. Since a frame may possess several superframes, we speak of -multiple inheritance. The algorithm ac -cording to which attributes and behaviors are inherited which occur in more than one superframe corresponds to that of the flavor system, i.e. mainly depth first and from left to right. Inherited behaviors can be modified by :after or :before encapsulation -s. Other forms of method combinations of the flavor system are not supported. \par -\pard \li-20\sa120\tx440 In the following aspects, the frame concept of BABYLON goes beyond the flavor concept: \par -\pard \li-20\sa120\tx440 Attributes can be connected with metainformation which can be evaluated automatically if -required. This metainformation is stored in annotations. The user is able to define his/her own annotations in addition to those provided by the system. Furthermore, BABYLON admits active values as attribute values. They can be used as demons monitoring at -tribute values. \par -\pard\plain \s253\li-20\sb120\sa120\keepn\tx440 \b\f20\fs28 Rules: \par -\pard\plain \li-20\sa120\tx440 \f20 -Knowledge representation by means of production rules is one of the oldest formalisms used in the construction of expert systems. In the definition of the rule-oriented formalism in BABYLON, maximum power was not of primary importa -nce, but rather a useful delimitation of characteristics with respect to other formalisms. In the rule formalism, the rules can be divided into packages which can be evaluated separately. The evaluation strategy of a rule-package is not defined in the pack -age, but it is defined by the caller of the package. Forward and backward chaining with different control strategies are supported. Rules contain references both to constructs of other formalisms and to constructs realized in the underlying programming lan -guage. References to such constructs are forwarded to the metainterpreter for evaluation. The rule interpreter itself has no language of its own to represent facts and operands. \par -\pard\plain \s253\li-20\sb120\sa120\keepn\tx440 \b\f20\fs28 Prolog: \par -\pard\plain \li-20\sa120\tx440 \f20 -BABYLON provides a specific Prolog version for logic-oriented knowledge representation. Prolog is a programming language representing knowledge in form of Horn clauses. A Horn clause consists of an atomic formula, the conclusion, and an arbitrary number of - further formulas, the premises. It denotes an implication from the -premises to the conclusion. The Horn clauses are processed according to a fixed strategy (depth-first search with backward chaining) to prove hypotheses, i.e. arbitrary atomic formulas. The reference manual for standard Prolog is (Clocksin & Mellish 1984). -\par -\pard \li-20\sa120\tx440 -The special feature of BABYLON Prolog is its integration into the overall system. Prolog hypotheses can be used in other formalisms as conditions or for data inquiry. Conversely, BABYLON Prolog can use constructs from other formalisms, such as Lisp expres -sions or attribute and behavior references as premises. In particular, there are metapredicates defined on the constructs of other formalisms allowing to draw metaconclusions. As a side-effect, the number of system predicates can be reduced if compared wit -h other Prolog implementations. \par -\pard \li-20\sa120\tx440 For modularization, the clauses in BABYLON Prolog can be combined to clause sets. The Prolog part of the knowledge base forms the first clause set, further clause sets can be located in separate files. The current clause se -ts are used for proving hypotheses. \par -\pard \li-20\sa120\tx440 BABYLON Prolog uses a Lisp-oriented syntax instead of the standard Prolog syntax.\par -\pard\plain \s253\li-20\sb120\sa120\keepn\tx440 \b\f20\fs28 Constraints:\par -\pard\plain \li-20\sa120\tx440 \f20 -Constraints can be used to model marginal conditions or constraints, such as physical laws or logical contexts. In metaphoric terms, we can regard the constraints as nodes of a network which interconnect variables thus establishing a connection between the - variables. The following figure shows such a constraint connecting three variables A, B and C such that\par -\pard \li-20\sa120\tx440 A+B is equal to C. \par -\pard \qc\li-20\sa120\tx440 {{\pict\macpict\picw238\pich119 -059c00000000007700ee001102ff0c00fffe0000004800000048000000000000007700ee000000000001000a00000000007700ee0099801e00000000007700ee000000000000000000480000004800000000000100010001000000000031b5b0000000000000576e65c900010000ffffffffffff0001000000000000000000 -00007700ee00000000007700ee0040000a00000000007700ee06fd000001e80002e30006e8000010fd0006e8000010fd0006e8000010fd0002e30006fd000001e80006fd000001e80006fd000001e80002e30006e8000010fd0006e8000010fd0006e8000010fd0002e30006fd000001e80006fd000001e80006fd000001e8 -0002e30006e8000010fd0006e8000010fd0006e8000010fd0002e30006fd000001e80006fd000001e80006fd000001e80002e30006e8000010fd0006e8000010fd0006e8000010fd0002e30006fd000001e80006fd000001e80006fd000001e8000bfd00011fe0fa00001ff10010fd00017038fa000110f0f7000010fd0010 -fd00018004fa0001100ef7000010fd0012fe0002030003fa0002100180f8000010fd000ffe000306000180fb0002100060f3000ffe000304000080fb0002100030f3000ffe000308020040fb0002100008f3000ffe000308020040fb0002100006f3000ffe000310050020fb0002100003f30014fe000310050020fb000310 -000180f9000010fd0014fe000310088020fb000310000080f9000010fd0013fd700208803ffbff03f0000040f9000010fd0010fe0003100f8020fb000310000020f40010fe000310104020fb000310000030f40010fe000310104020fb000310000010f40010fe00030838e040fb000310000008f40010fe000308000040fb -000310000008f40014fe000304000080fb000310000004f90000fefd0016fe000306000180fb000310000004fa0002030180fe0015fe0002030003fa000310000006fa00020c0060fe0014fd00018004fa000310000002fa0002180030fe0014fd00017038fa000310000002fa0002300018fe0014fd00011fe0fa00031000 -0002fa0002200008fe000ff4000310000001fa0002406804fe000ff4000310040001fa0002419804fe000ff4000310040001fa0002810802fe000ff4000310040001fa0002820002fe000ff40003103f8001fa0002820002fe000ff4000310040001faff02820002fee00ff4000310040001fa0002820002fe000ff4000310 -040001fa0002810002fe000ff4000310000001fa0002818802fe000ff4000310000001fa0002407004fe000ff4000310000001fa0002400004fe0014fd00011fe0fa000310000002fa0002200008fe0014fd00017038fa000310000002fa0002300018fe0014fd00018004fa000310000002fa0002180030fe0015fe000203 -0003fa000310000006fa00020c0060fe0016fe000306000180fb000310000004fa0002030180fe0014fe000304000080fb000310000004f90000fefd0010fe0003083f0040fb000310000008f40010fe000308108040fb000310000008f40010fe000310104020fb000310000010f40010fe000310108020fb000310000030 -f40010fe0003101f0020fb000310000020f40010fec103d010803ffbff03f0000040f40010fe000310104020fb000310000080f40010fe000310104020fb000310000180f4000ffe000310108020fb0002100003f3000ffe0003083f0040fb0002100006f3000ffe000308000040fb0002100008f3000ffe000304000080fb -0002100030f3000ffe000306000180fb0002100060f3000efe0002030003fa0002100180f3000cfd00018004fa0001100ef2000cfd00017038fa000110f0f2000bfd00011fe0fa00001ff10002e30002e30002e30002e30002e30002e30002e30002e30002e30002e30002e30002e30002e30002e30002e30002e30002e300 -02e30002e30002e30002e30002e30002e30002e30002e30002e30002e30002e30002e3000000ff}}\par -\pard \li-20\sa120\tx440 The following table demonstrates the various effects of this constraint:\par -\pard\plain \s9\li-20\keep\tx440\tx880\tx1740\tx2620\tx3480\tx4320\tx5220\tx6060\tx6940\tx7780 \f22\fs20 {\f4\fs14 start values\tab \tab \tab \tab values filtered by the constraint \par -\par -A\tab \tab B\tab \tab C\tab \tab A\tab \tab B\tab \tab C\par -3\tab \tab 4\tab \tab -\tab \tab 3\tab \tab 4\tab \tab 7\par -4, 5\tab \tab 3, 4\tab \tab -\tab \tab 4, 5\tab \tab 3, 4\tab \tab 7, 8, 9\par -1, 2\tab \tab 3, 4\tab \tab 6, 7\tab \tab 2\tab \tab 4\tab \tab 6\par -3, 4\tab \tab 5, 6\tab \tab 1, 2\tab \tab \'bf\tab \tab \'bf\tab \tab \'bf\par -}\pard\plain \li-20\sa120\tx440 \f20 \par -\pard \li-20\sa120\tx440 -Formally, a constraint consists of a set of variables and a relation on these variables. Using common variables between different constraints, we can compose constraint networks. If we predefine values or sets of possible values for a subset of the variabl -es, a constraint network can be used as follows: \par -\pard\plain \s4\li-20\sa120\tx440\tx900 \f20 \bullet \tab to check the consistency of values and \par -\bullet \tab to compute values for unknown variables; \par -\bullet \tab to filter sets of possible values, i.e. to eliminate inconsistent values. \par -\pard\plain \li-20\sa120\tx440 \f20 -The constraint interpreter of BABYLON is based on CONSAT, a domain-independent constraint system. The constraint language combines the simplicity of extensional constraint descriptions with the power of intensional descriptions. Hierarchies of constraints -and (recursive) constraint networks can be constructed. Various control strategies are provided: apart from local propagation, there is a method combining this strategy with backtracking. \par -\pard\plain \s253\li-20\sb120\sa120\keepn\tx440 \b\f20\fs28 Lisp:\par -\pard\plain \li-20\sa120\tx440 \f20 -Common Lisp is the implementation language of BABYLON, but it can also be used for knowledge representation. In a knowledge base, Lisp can be used between all BABYLON expressions. Many BABYLON expressions admit or require Lisp at specific syntactic positio -ns. The reference manual for Common Lisp is (Steele 1984).\par -\pard \li-20\sa120\tx440 To keep the knowledge bases portable, one should confine oneself to a subset\par -\pard \li-20\sa120\tx440 of Common Lisp. There is an abstract interface to the flavor system and a portable inhouse development of flavors. \par -\pard\plain \s253\li-20\sb120\sa120\keepn\tx440 \b\f20\fs28 Instructions:\par -\pard\plain \li-20\sa120\tx440 \f20 -Instructions define the global flow of control through the expert system. They are Lisp expressions which typically handle rule packages according to a specific strategy, make Prolog inquiries, activate behaviors or functions directly programmed in Lisp (e -.g. input/output). \par -\pard\plain \s254\li-20\sb120\sa120\keepn\brdrb\brdrs \tx440 \b\f20\fs36 Integration of formalisms:\par -\pard\plain \li-20\sa120\tx440 \f20 The following table shows the integration of the knowledge representation languages into BABYLON. A formalism X is usable in another formalism Y as described in column X and line Y: \par -\pard \qc\li-20\sa120\tx440 {{\pict\macpict\picw384\pich249 -16d20000000000f90180001102ff0c00fffe000000480000004800000000000000f90180000000000001000a0000000000f90180009980300000000000f90180000000000000000000480000004800000000000100010001000000000031b6cc00000000000058d5000000010000ffffffffffff0001000000000000000000 -0000f901800000000000f901800040000a0000000000f9018006fa000006d9000efa000006f3000002f3000020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020f7000efa000006 -f3000002f3000020f7000efa000006f3000002f3000020f70013fa000006f30002020302f5000320000180fa0017fa0002063840f500040201000020f7000320030080fa0017fa00010610f40004021d66c77ef7000420017699c0fb0018fa00030610dda0f600040223932928f70003200192a5fa0019fa0003061050d0f6 -0004022313e824f70004200112bc80fb0019fa000306104890f600040223130822f70004200116a040fb0019fa000306124490f60004021ce2e71ef7000420019a9dc0fb0013fa0003063e5ce0f60002020002f5000020f70013fa000306000080f60002020004f5000020f70011fa000306000080f6000002f3000020f700 -0efa000006f3000002f3000020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020f70004000fd2ff04000fd2ff0efa000006f3000002f3000020f7000efa000006f3000002f3000020f7000efa000006f3000002f30000 -20f70010fa000006f30002020080f5000020f7000efa000006f3000002f3000020f70016fa000006f300080237b036d9dd8f3380fb000020f70015fa000006f300070222881b65104a4afa000020f70015fa000006f300070214b8127c89c679fa000020f70016fa000006f300080214a8126045484080fb000020f70016fa -000006f300080208941b5ddca73b80fb000020f70012fa000006f3000002fc000009f9000020f70012fa000006f3000002fc00000ef9000020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020f7001efa000006f300040200003040fe000003fb000a200000060001000003000021010708fc0000 -06f30008021000100004000001fb000a2000000200100000040000200002fb000006f30008023f8396cc7fe06367fb000a20019bc2db3f3b60ee00002202021bb4fd000006f300080214445952948011a9fb000a20025122489145a11400002202020a1afd000006f30008021444515e84407129fb000a2003cae24b914521 -1400002702020912fd000006fe00017fc0f80008021444515084205129fb000a20020aa25a9145211400002302024892fd000006f30009020f838e4e73e8292780fc000a2001c452694d3920ee0000180207cb9cfd000006f3000002fe0002400008f9000020f7001602000010fd000006f3000002fe000080f7000020f700 -1202000010fd000006f3000002f3000020f7001efa000006f3000a020c000040000180006040fd0006200000c0000030fd001ffa000006f3000b021000020000020300200004fe000620030040000010fd0021fa000006f30019023edb3fce6f873943acccefc000002001764c34c3978f33800021fa000006f3000b02124d -4a5136024584725325fe0008200192521a24944a4aff0021fa000006f30017021249425125024504625f048000002001125e12e419c679ff0021fa000006f300190212c94251248245046251044000002001165012a4154840800021fa000006f30019023b4939ce278739839c4ee3c0000020019a4e1c5392a73b800019fa -000006f3000002f8000040fd000020fe000310000009fe0019fa000006f3000002f8000080fd000020fe00031000000efe000efa000006f3000002f3000020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020f7000400 -07d2ff0efa000006f3000002f3000020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020f70013fa000006f3000002f3000020fc00011c18fe001dfa000006fd0000e0fe000030fc000002f300072000002000000408fe -002302003040fd000906000004982002000010fc000002f3000820036779a3bbb58980ff00260300100002fe000b0618e18febadb7e0de16cdc0fe000002f3000a2001a8a0d462164a4000002a1101d6cc77e00000060480448cb29290891253fd000002fe000107eef8000a200128a09451144bc000002512023952928000 -00061c41c488a292f057125e80fe000002f30007200128a09448944afe00261202315e824000000614214488a2b2805512d040fe000002f3000a20012718e3bb9389c00000221202315082200000060ae0a36c9cd1f022934fd0fe000002f3000020fe000080fb001b0701ce4e71e0000006f7000010fe000002f3000020fe -000080fb001202000040fd000006f3000002f3000020f7001202000080fd000006f3000002f3000020f7000efa000006f3000002f3000020f70014fa000606080600600020f9000002f3000020f70015fa00070600020020000060fa000002f3000020f70015fa0007061b62c62d8de72ffa000002f3000020f70015fa0007 -0609a3293448a8b4fa000002f3000020f70015fa00070609222f25c528a2fa000002f3000020f70015fa000706092228254528a1fa000002f3000020f70015fa0007060921c724a22737fa000002f3000020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020 -f7000efa000006f3000002f3000020f70004d2ff00f00efa000006f3000002f3000020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020f700 -18fa000006f3000302000018fd0007c600600040000020f7001efa000006fd00016408f9000f02009308004000004200200000600020f70022020000c0fd000006fd00012080f9000f0231fd7b36fc18d9c2c62f1bce280020f7002502030040fd00080618e0ee6cedfb9b70fb000f0208919c9252046a4329349151300020 -f700260301764ce0fe00080604813135248c4d40fb000f02389118925e1c4a422f278a51200020f700260301925280fe0008061c411125248c4920fb000f022891189650144a4228268a51200020f700260301125e40fe00080614211125248c4910fb000f02146d971a3e0a49e1c725444e300020f7001b0301165020fe00 -08060ae0ee24f46b8974fb000002f3000020f7001703019a4ee0fe000006fa000004fb000002f3000020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020f70019fa000006fe000004f70002020006fa0005018820000020f70019fa000006fe000040f7000302300818fa000081fe000020f7001f -fa00060618e187fcedb8f9000f02159d8acdb99c31c39db39be76dc020f7001ffa0006060480494516a0f9000f021a4a4d26ca500904a2d48928b50020f70024fa0006061c41c8451490f9000f0213cbc9e4c3c8388422948928a48020fe00017fc0fc001ffa000606142148451488f9000f02120a0904c204284422948928 -a44020f7001ffa0006060ae0a734e4b8f9000f0219ddcce4b9dc15c39c93c8e725c020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020f70013fa000006f30005020001800010f8000020f70013fa000006f30005020000800080f8000020f70014fa000006 -f300060231b3861df3b6f9000020f70014fa000006f300060208d48124945af9000020f70014fa000006f3000602389487209452f9000020f70014fa000006f3000602289485209452f9000020f70014fa000006f30006021493c29c7392f9000020f7000efa000006f3000002f3000020f7000efa000006f3000002f30000 -20f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020f70004d2ff00f00efa000006f3000002f3000020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020f7 -000efa000006f3000002f3000020f7000efa000006f3000002f3000020f70018fa000006f300030200001cfd0007c300600020000020f7001ffa0002063840fc000040fb000f02008b04004000004100200000600020f700230207800cfd00010610fe00010180f9000f0231ff759bf618d9c1662d8de7280020f700260202 -5804fd00090610dda06de8aceeced8fc000f020889964949046a41993448a8b00020f7002703024ae4effe0009061050d09534d2885168fc000f02388914494f1c4a411f25c528a00020f7002703024d151afe00090610489cf2249e445148fc000f022889144b48144a4118254528a00020f700270303891516fe00090612 -4490852490225148fc000f021467938d370a49e0e724a227300020f7001c0302091518fe0009063e5ce07db8ceee4e48fc000002f3000020f7001803070ce4e7fe0005060000800020f8000002f3000020f70017fe000009fe0005060000800020f8000002f3000020f70012fe00000efe000006f3000002f3000020f70019 -fa000006fd000001f80002020006f5000020fc00010c40fe001cfa00030600000cf6000302300818f60008200000080030040002ff0023fa00070618e1a536db7737fa000602159d8acd9d9cf9000a20036cdf8d159ccec7e70023fa0007060480d64b69444cfa0006021a4a4d26a650f9000a2001b528469a645222940023 -fa0007061c40947a49227afa00060213cbc9e4a3c8f9000a200125e9c493e450e2f20023fa00070614209442491141fa000602120a0904a204f9000a2001250944922450a2810023fa0007060ae0e63b69773ffa00060219ddcce49dddf9000a2001b4e6a719de4e51f70019fa000306000080f6000002fc000001f9000020 -fe000004fb0015fa000306000080f6000002f3000020fe000004fb000efa000006f3000002f3000020f70012fa000006f3000002fc0000c4f9000020f70016fa000006f30008020000800600400040fb000020f70017fa000006f300090236d9f1a2b1ccf8fce0fc000020f70017fa000006f30009021b6488d34a45245280 -fc000020f70017fa000006f3000902127cb8927a451c5e40fc000020f70017fa000006f30009021260a8924245145020fc000020f70017fa000006f30009021b5c74e339e4ea3ee0fc000020f70012fa000006f3000002fe000080f7000020f70012fa000006f3000002fe000080f7000020f7000efa000006f3000002f300 -0020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020f70004d2ff00f00efa000006f3000002f3000020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020 -f7000efa000006f3000002f3000020f70014fa000006f30002020182fe000030f9000020f70015fa000006f300070200800020c04060fa000020f70018fa000006f3000a021cb663f856e62b6ce670fd000020f70018fa000006f3000a0222ca94a0694934b52940fd000020f70018fa000006f3000a02228af4204f4f27a5 -0f20fd000020f70018fa000006f3000a02228a8420484824250810fd000020f70018fa000006f3000a021c72739867e733a4e770fd000020f70010fa000006f30002020002f5000020f70010fa000006f30002020004f5000020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020f70021fa000206 -3840fc000040fb000202000cfd00028e0002fc000020fc00011c18fe0026fd00040100000610fe00010180f90002020004fd0002100020fc00072000002000000408fe0030fe000f160000800610dda066f4a6eece6f8638fe000b023785b60ed19dbe767e76dcfe000a20036779a3bbb589800000311201cedbbeb36dfc06 -1050d0929ac98851360120fe000b02224499086a649291228b50fe000a2001a8a0d462164a400000311202516a130934900610489ef1128f4451250710fe000b0215c49f044be09287228a48fe000a200128a09451144bc00000301202114912392488061244908292882251248508fe000b021544b8024a209285228a44fe -0007200128a09448944afe00311202114892292484063e5ce076dcc7ee4e2782b8fe000b0208a4d70e71dcba729a725dfe000a20012718e3bb9389c00000240c01ce4b8f15247c060000800010f8000002fd000040fc000001fe000020fe000080fb001bfa0005060000800010f8000002fd000040f8000020fe000080fb00 -0efa000006f3000002f3000020f70018fa000006f30005020000800040fe00013104fd000020f70020fa0002060006fd000323800080fd00040200040004fd00011020fd000020f70021fa0002060002fd0002040008fc000f0230efb78fced873b6737cedb8000020f70024fa000b061bc2d983b4cf6f9f1fb9b7fe000f02 -0924a2445168945a912516a0000020f70024fa000b0611224a421b2224a488c4d4fe000f02390495c45148845291251490000020f70024fa000b060ae24bc113e424a388c492fe000f02290495445148845291251488000020f70024fa000b060aa25a00930824a288c491fe000f0214e388a34e487392791ce4ba000020f7 -001cfa000f06045269c39cef2e9d46b89740000002f6000302000020f70015fa000006fd000010fb000340000002f3000020f70012fa000006fd000010f8000002f3000020f7000ffa000006f300010210f4000020f7001dfa0005060000400040fe00011882fd000002fe0001480cf8000020f7001dfa00040600020002fd -00010820fd00060236c698fec5dff9000020f7001ffa0015061877dbc7ce6c39db39fe76dc00000213434449266cf9000020f7001ffa0015060492512251344a2d48a28b5000000212425c49e44af9000020f7001ffa0015061c824ae25124422948a28a48000002124254490449f9000020f7001ffa00150614824aa25124 -422948a28a4400000212438a36e64ff9000020f7001bfa0011060a71c451ce2439c93c9a725d0000020002f5000020f70013fa000006f60005010000020002f5000020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020f7000ffa00010608f4000002f3000020f70013fa000006fe00011206f800 -0002f3000020f70015fa0007061b61a63fe2edc0fa000002f3000020f70014fa00060609a0d1129335f9000002f3000020f70015fa00070609209712f22480fa000002f3000020f70015fa00070609209512822440fa000002f3000020f70015fa0007060920e28df325c0fa000002f3000020f70011fa000306000080f600 -0002f3000020f70011fa000306000080f6000002f3000020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020f7000efa000006f3000002f300 -0020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020f7000efa000006f3000002f3000020f7000000ff} -}\par -\pard \qc\li-20\sa120\tx440 {{\pict\macpict\picw269\pich199 -0d020000000000c7010d001102ff0c00fffe000000480000004800000000000000c7010d000000000001000a0000000000c7010d009980220000000000c7010d0000000000000000004800000048000000000001000100010000000000316f940000000000005957802300010000ffffffffffff0001000000000000000000 -0000c7010d0000000000c7010d0040000a0000000000c7010d0afb000001f4000040f4000afb000001f4000040f4000afb000001f4000040f4000afb000001f4000040f4000afb000001f4000040f4000afb000001f4000040f4000afb000001f4000040f4000afb000001f4000040f40011fb00030107c030f7000040fc00 -0020fa0014fb000301027010f7000040fe000301600020fb0015fb0004010254d19ef8000740000336dfa96df7fb0015fb00040103993254f800074000054b5133a6a4fb0015fb0004010211324cf800074000054a4d22a4a3fb0015fb0004010738f99ef8000740000337fcf17fd7fb000efb000001fe000012f8000040f4 -000efb000001fe00001cf8000040f4000afb000001f4000040f4000afb000001f4000040f4000afb000001f4000040f4000afb000001f4000040f4000afb000001f4000040f40007000fe2ff01fe0007000fe2ff01fe000afb000001f4000040f4000afb000001f4000040f4000afb000001f4000040f40016fb000001fe00 -0080f8000840000180e02000000cfc0013fb0002010030f6000340000081fd000004fc0017fb0005010794dbb6f0f900084000038ffb7b784d9cfc0017fb00050102592a9aa0f900084000049f2d2d50e6a4fc0017fb00050102512a9260f9000840000491292930a4a4fc0017fb00050103b8c5fff0f90008400007cfffff -f85ffefc0013fb00010102fe000090f9000040fc000048fa0013fb00010107fe0000e0f9000040fc000070fa000afb000001f4000040f40013fb0004010600000cf8000040fe00018182f90012fb00040102000024f800044000000402f8001b010390fd00070102f3e3759f9f80fb00074000074fbfcfb3c0fb00190001fc -000601035294a6be3efa0007400004e4a24ad280fb001c020133f8fe000701025494a4a1a180fb0007400003a49a529180fb001c02011224fe00070107e8e31fdf9f80fb000740000753ff27fbc0fb0017020131a4fe000301000880f7000040fd0002200240fb00170203fbb8fe0003010031c0f7000040fd0002c00380fb -000e02000020fe000001f4000040f4001202000070fe000001f4000040fc000040fa0011fb000001f4000040fe000302c00040fb0011fb000001f400074000033d9f52dbeefb0011fb000001f400074000054e92674d48fb0011fb000001f400074000054c8e454946fb0011fb000001f400074000033fdde2ffaefb000afb -000001f4000040f4000afb000001f4000040f4000afb000001f4000040f4000afb000001f4000040f4000afb000001f4000040f4000afb000001f4000040f40004e0ff00000afb000001f4000040f4000afb000001f4000040f4000afb000001f4000040f4000afb000001f4000040f4000afb000001f4000040f40012fb00 -0001fd000102c6fa000340000040f70010fb000601000080000042fa000040f4001d02003080fe00070106cdcf19de7a38fb000840000dc43fddd1eee0fc001d0d00100010000001035284a5124a78fb00084000054e127d395e80fc001d0d00df8efb800001025284a4ce4a40fb00084000054a1260e8d060fc001d0d0132 -9f5200000107ec4719df3738fb0008400002e53ffdd5eee0fc00160901329151800001000004f7000040fc00010120fb00160900cc8ecb80000100000ef7000040fc000101c0fb000e02000080fe000001f4000040f4000d010001fd000001f4000040f4000afb000001f4000040f4000afb000001f4000040f4000afb0000 -01f4000040f4000afb000001f4000040f4000afb000001f4000040f4000afb000001f4000040f4000afb000001f4000040f4000afb000001f4000040f4000afb000001f4000040f4000afb000001f4000040f4000afb000001f4000040f4000afb000001f4000040f4000afb000001f4000040f4000afb000001f4000040f4 -0004e0ff00000afb000001f4000040f4000afb000001f4000040f4001afb00010102fe0001d040fa000040fe000281a030fd000004ff0017fb000001fd000042f9000940000004020010000006fd002002000180fe00070107b066d9f7cdb7fb000d4000072f9f6771e07af2bbfc7b382002030080fe00070102d0a96a5252 -d4fb000d40000474922f9690fc4b7a449d20200d017c9dc00000010290a94a525293fb000d400003548e2890908c4a41b4991820020194bdfe00070107f866fff9edfffb000d4000072bdf77f8e07e773bfe7fb814060116a0c0000001f4000040fb0002800040fd001506039dddc0000001f4000040fc000301c000e0fd00 -0afb000001f4000040f4000afb000001f4000040f40013fb0005010000600020f9000040fc000008fa0012fb00040100002001f8000040fe00000cf80019fb000701016ce08fe36dc0fb000840000239e53ff9f9f8fc0018fb00060103b521d524b5fa000840000720967c9923e0fc0019fb00070102a5215524a4c0fb0008 -40000518944498da18fc0019fb000701017ff0acf37fc0fb0008400002b8ee3ffdf9f8fc000efb000001f4000040fe000080f8000efb000001f4000440000001c0f8000afb000001f4000040f4000afb000001f4000040f4000afb000001f4000040f4000afb000001f4000040f4000afb000001f4000040f40004e0ff0000 -0afb000001f4000040f4000afb000001f4000040f4000afb000001f4000040f4000afb000001f4000040f4000afb000001f4000040f4000e0203e018fe000001f4000040f4000e02013808fe000001f4000040f4000e06012a68cf000001f4000040f4000e0601cc992a000001f4000040f4000e0601089926000001f40000 -40f4000e06039c7ccf000001f4000040f4000dfe000309000001f4000040f4000dfe00030e000001f4000040f40014fb000001f4000040fe000281c030fd000004ff0013fb000001f4000940000004020010000006fd0015fb000001f4000d4000072f9fc771e07be2bbfcdb7015fb000001f4000d40000474924f9c90fc93 -7a452d4015fb000001f4000d400003548e4890908c9241b5293015fb000001f4000d4000072bdfe7f8e07ee73bfedff010fb000001f4000040fb0002800080fd0011fb000001f4000040fc000301c001c0fd000afb000001f4000040f4000efb000001f4000040fc000008fa000efb000001f4000040fe00000cf80012fb00 -0001f4000840000273c57ff9f9f8fc0017fb000001fe00011b60f900084000074126f49923e0fc0012fb000001f4000840000531248498da18fc0012fb000001f40008400002f1ce7ffdf9f8fc000dfb000001f4000340000001f7000efb000001f400044000000380f8000afb000001f4000040f40012fb000001f4000040 -fe00048000003460fc0013fb000001f4000340000060fe0002102040fd0013fb000001f4000940000329ec19367ce2e7fd0013fb000001f40009400004b0b42b9a95274ffd0013fb000001f40009400004a0a42a92952548fd0013fb000001f4000940000371fe197ffff2a7fd000afb000001f4000040f4000afb000001f4 -000040f4000afb000001f4000040f4000afb000001f4000040f40004e0ff00000afb000001f4000040f4000afb000001f4000040f4000afb000001f4000040f4000afb000001f4000040f4000afb000001f4000040f4000afb000001f4000040f4000afb000001f4000040f4000afb000001f4000040f4000cfd0002080001 -f4000040f4000dfe000358000801f4000040f400130600cdb7ea5b7dc1f4000040fe0001036cf9000e060152d44ce9a901f4000040f4000e0601529348a928c1f4000040f4000e0600cdff3c5ff5c1f4000040f4000afb000001f4000040f4000afb000001f4000040f40011fb00030107c030fd000002fc000040f40010fb -000601026010000003fa000040f40014fb000e010269933c3ef94fde36dc27000040f40014fb000e0103b254ae7b259f124b5074000040f40014fb000e0102225498432510ce4a4c53000040f40014fb000e010771bb3c3fbb8fdf37fc2f000040f40010fb000001fe0002240020fa000040f40010fb000001fe0002380070 -fa000040f4000afb000001f4000040f40014fb000a010000400080000001a080fe000040f40012fb00040100020004fd000084fd000040f40014fb000e01011fdb2f8f60cdb3ef8f6e000040f40014fb000e0103aa4a7493a152d4a493a8000040f40014fb000e0102aa4a5493215294a49326000040f40014fb000e010159 -e42bcff0cdfff3cffe000040f4000afb000001f4000040f4000afb000001f4000040f4000afb000001f4000040f4000afb000001f4000040f4000afb000001f4000040f4000afb000001f4000040f4000afb000001f4000040f4000afb000001f4000040f4000afb000001f4000040f4000afb000001f4000040f4000afb00 -0001f4000040f4000afb000001f4000040f40006fb000001e60000ff}} \par -\pard\plain \s254\li-20\sb120\sa120\keepn\brdrb\brdrs \tx440 \b\f20\fs36 BABYLON configurations:\par -\pard\plain \li-20\sa120\tx440 \f20 -Since all parts of a BABYLON knowledge base are optional, the knowledge base interpreter needs not always comprise all basic interpreters (specialists). Therefore, the interpreters for BABYLON knowledge bases are configurable. In addition to the metainterp -reter which is absolutely necessary as a manager in each configuration, a configuration may - consist of interpreters for Lisp, objects, rules, Prolog or constraints. Custom interpreters are also possible. Another component is the user interface. The last four interpreters and the user interface are available in three versions of different comfort -. \par -\pard \li-20\sa120\tx440 \par -\pard \qc\li-20\sa120\tx440 {{\pict\macpict\picw445\pich418 -2aaa0000000001a201bd001102ff0c00fffe000000480000004800000000000001a201bd000000000001000a0000000001a201bd009980380000000001a201bd0000000000000000004800000048000000000001000100010000000000324f380000000000005a3f000000010000ffffffffffff0001000000000000000000 -0001a201bd0000000001a201bd0040000a0000000001a201bd0af000000ff2ff0080eb000af0000008f2000080eb000af0000008f2000080eb000af0000008f2000080eb000af0000008f2000080eb000af0000008f2000080eb000af0000008f2000080eb000af0000008f2000080eb000af0000008f2000080eb000af000 -0008f2000080eb000af0000008f2000080eb000af0000008f2000080eb000af0000008f2000080eb000af0000008f2000080eb000af0000008f2000080eb000af0000008f2000080eb000af0000008f2000080eb000af0000008f2000080eb000af0000008f2000080eb000af0000008f2000080eb000af0000008f2000080 -eb000af0000008f2000080eb000af0000008f2000080eb000af0000008f2000080eb000ef0000008fc000002f8000080eb0014f0000008fd0002020001fe000020fd000080eb0016f0000c08000001b63776e39b7cd37368fe000080eb0016f0000008fe0008da4a0a51259264a4b0fe000080eb0016f0000008fe0008927a -3a513d1247a7a0fe000080eb0016f0000008fe000892424a512112442420fe000080eb0016f0000008fe0008924a4a51251244a4a0fe000080eb0016f0000c08000001db313ff89b9ce31370fe000080eb000ef0000008f9000010fb000080eb000ef0000008f9000038fb000080eb000af0000008f2000080eb000af00000 -08f2000080eb000af0000008f2000080eb000af0000008f2000080eb000af0000008f2000080eb000af0000008f2000080eb000af0000008f2000080eb000af0000008f2000080eb000af0000008f2000080eb000af0000008f2000080eb000af0000008f2000080eb000af0000008f2000080eb000af0000008f2000080eb -000af0000008f2000080eb000af0000008f2000080eb000af0000008f2000080eb000af0000008f2000080eb000af0000008f2000080eb000af0000008f2000080eb000af0000008f2000080eb000af0000008f2000080eb000af0000008f2000080eb000af000000ff2ff0080eb0006e9000074e20007ea00010396e20007 -ea00010c23e20008ea0002702280e30009eb000303802340e30009eb00030c0049a0e30009eb000370004990e3000aec00040180008948e3001101007ff7ff00fef900040e00008944e300100001f5ff0080fa000470000108a2e30013010780f7000101e0fb00050180000108a1e30012000ef5000070fb00060e00000210 -9080e40012001cf5000038fb000670000002109040e400130038f500001cfc00070180000002104820e400130030f500000cfc00000efe000304104810e400130060f5000006fc000070fe000304104408e400140060f5000006fd00010180fe000308104404e4001300c0f5000003fd00000efd000308102202e4001300c0 -f5000003fd000070fd000310102101e4001500c0f5000003fe00010180fd00041010210080e5001400c0f5000003fe00000efc00042010208040e5001400c0f5000003fe000030fc00042010108020e5001400c0f5000403000001c0fc00042020104010e5001300c0f500030300000efb00044020104008e5001300c0f500 -0303002030fb00044020102004e5001300c0f50003030071c0fb00048020082002e5001200c0f500020300fefa00048020081001e5001400c0f500020301f8fb000601002008100080e6001400c0f500020303f8fb000601002008080040e6001400c0f500020307f8fb000602002004040030e6001400c0f50002030ff8fb -000602002004040008e6001200c0f5000003f9000602002004020004e6001200c0f5000003f9000604002004020002e6001200c0f5000003f9000604004002010001e6001300c0f5000003f900070800400201000080e7001300c0f5000003f900070800400200800040e7001300c0f5000003f900071000400200800020e7 -001300c0f5000003f900071000400100400010e7001300c0f5000003f900072000400100400008e7001300c0f5000003f900072000400100200004e7001300c0f5000003f900072000400100100002e7001300c0f5000003f900074000400080100001e7001500c0f6ff01fc03f90008400040008008000080e8001601c080 -f700010403f90008800040008008000040e8001d07c0c0008008000018fe0002402403f90008800080004004000020e8001d01c0c0fe0002040020fd00010403fa000901000080004004000010e8001e0dc0f1cf8e1b8e6d771cc1b6db6e03fa000901000080004002000008e8001e0dc0c8329209449620a520da4a2503fa -000902000080004002000004e8001e0dc0c8e8900944f423a1e092462503fa000902000080002001000002e8001e0dc0c92691c9448424a11c92442503fa000904000080002001000001e8001f0dc0c9329209449424a520924a2503fa000a0400008000200080000080e9001f0dc0f0fdcc1fe26e73d8c1dbfb7f83fa000a -0400008000200080000040e9001801c080f700010403fa000a0800008000100040000020e9001801c080f700010403fa000a0800008000100020000010e9001801c080f700010403fa000a1000008000100020000008e9001801c080f700010403fa000a1000010000100010000004e9001801c080f700010403fa000a2000 -010000080010000002e9001801c080f700010403fa000a2000010000080008000001e9001901c080f700010403fa00074000010000080008fe0000c0ea001901c080f700010403fa00074000010000080004fe000020ea001901c080f700010403fa00074000010000040004fe000010ea001800c0f6ff01fc03fa00078000 -010000040002fe000008ea001700c0f5000003fa00078000010000040002fe000004ea001800c0f5000003fb0008010000010000040001fe000002ea001800c0f5000003fb000c01000001000002000080000001ea001900c0f5000003fb000902000001000002000080fe000080eb001900c0f5000003fb00090200000100 -0002000040fe000040eb001900c0f5000003fb000904000002000002000040fe000020eb001900c0f5000003fb000904000002000001000020fe000010eb001900c0f5000003fb000904000002000001000020fe000008eb001900c0f5000003fb000908000002000001000010fe000004eb001900c0f5000003fb00090800 -0002000001000010fe000002eb001900c0f5000003fb000310000002fe0002800008fe000001eb001900c0f5000003fb000310000002fe0002800008fd000080ec001900c0f5000003fb000320000002fe0002800004fd000040ec001900c0f5000003fb000320000002fe0002800002fd000020ec000d00c1f6ff01fc03f4 -000040e5000d00c1f600010403f4000040e5000d00c1f600010403f4000040e500260dc100201020000060000001008403fc000b670600019c18000040003383fe0002067060ee002400c1fd0002100080fd00010403fc0011928900024a24000020004944800000092890ee00260dc1db6e306e39b5dc7306db6dbc03fc00 -11928f00024a3c0000200049478000000928f0ee00260dc16d251025125882948369289403fc000b928800024a20000020004944fe0002092880ee00260dc14925102513d08e878249189403fc0011928900024a24000020004944800000092890ee00260dc149251725121092847249109403fc000b67c600019f18000010 -0033e3fe0002067c60ee00150dc149251025125092948249289403f4000010e500150dc1edffb87f89b9cf63076fedfe03f4000010e5001c00c1f600010403fc000004fe000004fe000310000008fd000002ed001d00c1f600010403fc000008fe000004fe000308000004fd00010180ee001c00c1f600010403fc000008fe -000008fe000308000004fc000040ee001c00c1f600010403fc000010fe000008fe000308000002fc000020ee001c00c1f600010403fc000010fe000008fe000308000002fc000010ee001c00c1f600010403fc000020fe000008fe000304000001fc000008ee001c00c1f600010403fc000020fe000008fe000304000001fc -000004ee001d00c1f600010403fc000040fe000008fe000004fe000080fd000002ee001d00c1f600010403fc000040fe000008fe000004fe000080fd000001ee001d00c1f600010403fc000040fe000008fe000002fe000040fc000080ef001d00c1f6ff01fc03fc000080fe000008fe000002fe000040fc000040ef001c00 -c0f5000003fc000080fe000008fe000002fe000020fc000020ef001c00c0f5000003fd000001fd000008fe000002fe000010fc000010ef001c00c0f5000003fd000001fd000010fe000001fe000010fc000008ef001c00c0f5000003fd000002fd000010fe000001fe000008fc000004ef001c00c0f5000003fd000002fd00 -0010fe000001fe000008fc000002ef001c00c0f5000003fd000004fd000010fe000001fe000004fc000001ef001b00c0f5000003fd000004fd000010fd000380000004fb000080f0001b00c0f5000003fd000004fd000010fd000380000002fb000040f0001b00c0f5000003fd000008fd000010fd000380000002fb000020 -f0001b00c0f5000003fd000008fd000010fd000380000001fb000010f0001b00c0f5000003fd000010fd000010fd000340000001fb000008f0001c00c0f5000003fd000010fd000010fd000040fe000080fc000004f0001c00c0f5000003fd000020fd000010fd000040fe000040fc000002f0001c00c0f5000003fd000020 -fd000020fd000040fe000040fc000001f0001c00c0f5000003fd000040fd000020fd000020fe000020fb000080f1001a00c1f4fffd000040fd000020fd000020fe000020fb000040f1001c00c1f5000007fd000040fd000020fd000020fe000010fb000020f1001c00c1f5000007fd000080fd000020fd000020fe000010fb -000010f1002500c1fe00040302000006fe0001100ffd000080fd000020fd000010fe000008fb000008f1002400c1fe00040100010008fd000007fe000001fc000020fd000010fe000008fb000006f1002511c1e0cddb3906e39b5dc7306db6df80000001fc000020fd000010fe000004fb000001f1002511c151266d050251 -2588294836928f40000002fc000020fd000010fe000004fa000080f2002511c15124491d02513d08e87824918f40000002fc000020fd000008fe000002fa000040f2002511c15124492572512109284724910f40000004fc000020fd000008fe000002fa000020f2002511c15124492502512509294824928f40000004fc00 -0020fd000008fe000001fa000010f2002511c1f8ceed9f87f89b9cf63076fedfe0000004fc000040fd000008fd000080fb000008f2001c00c1f5000007fe000008fc000040fd000004fd000080fb000004f2001c00c1f5000007fe000008fc000040fd000004fd000040fb000002f2001c00c1f5000007fe000010fc000040 -fd000004fd000040fb000001f2001c00c1f5000007fe000010fc000040fd000004fd000020fa000080f3001c00c1f5000007fe000020fc000040fd000002fd000020fa000040f3001c00c1f5000007fe000020fc000040fd000002fd000010fa000020f3001c00c1f5000007fe000040fc000040fd000002fd000010fa0000 -10f3001c00c1f5000007fe000040fc000040fd000001fd000008fa000008f3001c00c1f5000007fe000080fc000040fd000001fd000008fa000004f3001c00c1f5000007fe000080fc000040fd000001fd000004fa000002f3001a00c1f4fffe000080fc000080fd000001fd000002fa000001f3001b00c0f5000303000001 -fb000080fc000080fe000002f9000080f4001b00c0f5000303000001fb000080fc000080fe000001f9000040f4001b00c0f5000303000002fb000080fc000080fe000001f9000020f4001b00c0f5000303000002fb000080fc000080fd000080fa000010f4001b00c0f5000303000004fb000080fc000040fd000080fa0000 -08f4001b00c0f5000303000004fb000080fc000040fd000040fa000004f4001b00c0f5000303000008fb000080fc000040fd000040fa000002f4001b00c0f5000303000008fb000080fc000040fd000020fa000001f4001b00c0f5000303000008fb000080fc000020fd000020f9000080f5001b00c0f5000303000010fb00 -0080fc000020fd000010f9000040f5001b00c0f5000303000010fc000001fb000020fd000008f9000020f5001b00c0f5000303000020fc000001fb000020fd000008f9000010f5001b00c0f5000303000020fc000001fb000010fd000004f900000cf5001b00c0f5000303000040fc000001fb000010fd000004f9000002f5 -001b00c0f5000303000040fc000001fb000010fd000002f9000001f5001b00c0f5000303000080fc000001fb000010fd000002f8000080f6001b0060f5000306000080fc000001fb000008fd000001f8000040f6001b0060f5000306000080fc000001fb000008fd000001f8000020f6001a0030f500020c0001fb000001fb -000008fc000080f9000010f6001a0038f500021c0001fb000001fb000008fc000080f9000008f6001a001cf50002380002fb000001fb000004fc000040f9000004f6001a000ef50002700002fb000002fb000004fc000040f9000002f6001c010780f7000301e00004fb000002fb000004fc000020f9000001f6001a0001f5 -ff02800004fb000002fb000004fc000010f8000080f7001c01007ff7ff03fe000008fb000002fb000002fc000010f8000040f70016f2000008fb000002fb000002fc000008f8000020f70016f2000008fb000002fb000002fc000008f8000010f70016f2000010fb000002fb000002fc000004f8000008f70016f2000010fb -000002fb000001fc000004f8000004f70016f2000020fb000002fb000001fc000002f8000002f70016f2000020fb000002fb000001fc000002f8000001f70016f2000040fb000002fb000001fc000001f7000080f80016f2000040fb000004fa000080fd000001f7000040f80016f2000080fb000004fa000080fc000080f8 -000020f80016f2000080fb000004fa000080fc000040f8000010f80016f2000080fb000004fa000080fc000040f8000008f80016f300000ffa00003ffa000078fc00002cf8000004f8001af300010f80fb00013f80fc000101f8fc00003cf800010208f90019f300010fc0fb00003ffb000103f8fc00007cf80001011cf900 -18f300010fc0fb00003ffb000101f8fc0000fcf70000bcf90018f300010f80fb00001efa0000f0fd000101fcf700007cf90016f300000ffa00001efa0000f0fc00007cf700007ef90016f300000efa00001cfa000070fc00003cf70000fef90018f300000cfa00000cfd00fcff00f0fe00000cf700001ff90022fb00003ffa -ff02080003faff02f80003fcff03fc00001ffaff02c00001f9ff01f00020fb00f9ff02c0000ffaff02fe000ffc00030f00007ffaff02f00007f9ff01fc0023fc000103c0fa0002f0003cfa000207801cfc0003038001e0fa00023c001ef900010f0022fc000007f90002380070fa000201c038fc000301c00380fa00020e00 -38f9000103801ffc00000ef900021c00e0f90001e070fb0001e007f90002070070f9000101c01ffc00001ffaff02fe0e01f9ff02f07060fb0001600ff9ff028380eff8ff00e020fc00001ffaff03fe0601bffaff02f030c0fb0001300df9ff028180cff8ff006024fc000036fa000306030330fa00033018c01ffcff023019 -80fb00030180c18cf90001033025fc000036fa000306030330fa000330198010fd000301181980fb00030180c18cf90001033033fc001666018001000600000601863001800100000c00300d8010fd000f01183180c000800000180180630d8001fc000208031833fc000d6600800000080000060186300080fe0006040030 -0d8010c8fe00040118318040fd0005080180630c80fc00038000071836fc00176600e39f1c1f5db63601863000e39f1c37c460300d801040fe00170118318071cf8e1e6988c380630ce39f1c0e670ff5db8f1836fc003266009065240982da4e01863000906524194490300d801059fc000001183180483292093249258063 -0c9065241292929829471836fc0032660091d120090e927e0186300091d1201144f0300d80104a5200000118318048e8900922492580630c91d12010928890e9471836fc00326600924d238912924701863000924d2391448e300d80104912000001183180492691c9224923b8630c924d23909286912947d836fc00326600 -9265240912924e01863000926524114490300d801048d2e000011831804932920922492580630c9265241292929129471836fc00326600e1fb981f8fdb3601863000e1fb9838ee60300d80104a5200000118318070fdcc0e719cc780630ce1fb980c67dc78ffe31829fc000066fa000306018630fa000b300d8010ff9c0000 -01183180fe00060800000580630cf90001031829fc000066fa000306018630fa000b300d80100010000001183180fe00061c00000780630cf90001031826fc000066fa000306018630fa000b300d80100038000001183180fb00030180630cf90001031831fc000366000201fd000606018630000201fd000e300d80100020 -100001183180010080fe00050180630c0201fb0001031825fc000066fa000306018630fa0003300d8010fd000301183180fb00030180630cf90001031834fc0004660db6db70fe0007060186300db6db70fe000e300d8010db6db70001183186db6db8fe00060180630db6db70fc0001031834fc00046606d25128fe000706 -01863006d25128fe000e300d80106d25128001183183692894fe00060180630ed25128fc0001031834fc00046604923128fe00070601863004923128fe000e300d80104923128001183182491894fe00060180630c923128fc0001031834fc00046604922128fe00070601863004922128fe000e300d801049221280011831 -82491094fe00060180630c922128fc0001031834fc00046604925128fe00070601863004925128fe000e300d80104925128001183182492894fe00060180630c925128fc0001031834fc0004660edfdbfcfe0007060186300edfdbfcfe000e300d8010edfdbfc0011831876fedfefe00060180630edfdbfcfc0001031825fc -000066fa000306018630fa0003300d8010fd000301183180fb00030180630cf90001031825fc000066fa000306018630fa0003300d8010fd000301183180fb00030180630cf90001031825fc000066fa000306018630fa0003300d8010fd000301183180fb00030180630cf90001031822fc000067faff03fe01863ffaff03 -f00d8010fd0002011831f9ff0280630ff8ff001822fc000067faff03fe01863ffaff03f00d8010fd0002011831f9ff0280630ff8ff00181dfc000060f900010186f800020d8010fd0002011830f8000063f70000181dfc000060f900010186f800020d8010fd0002011830f8000063f70000181dfc000060f900010186f800 -020d8010fd0002011830f8000063f70000181dfc000060f900010186f800020d8010fd0002011830f8000063f70000181dfc000060f900010186f800020d8010fd0002011830f8000063f70000181dfc000060f900010186f800020d8010fd0002011830f8000063f70000181dfc000060f900010186f800020d8010fd0002 -011830f8000063f70000181dfc000060f900010186f800020d8010fd0002011830f8000063f700001822fc000067faff03fe01863ffaff03f00d8010fd0002011831f9ff0280630ff8ff001822fc000067faff03fe01863ffaff03f00d8010fd0002011831f9ff0280630ff8ff001824fc000066fa000306018630fa000330 -0d801ffcff02183180fb00030180630cf90001031823fc000066fa000306018630fa0002300cc0fb0002303180fb00030180630cf90001031832fc00156600020100c000000601863000201000180000300cc0fb000f3031800100800003000180630c001008fd00020803182efc000066fe000001fe000306018630fd0005 -080000300c60fb0002603180fd000501000180630cfb00038000071833fc0015660db6e303ebb6c606018630db6e306f88c000300c70fb0016e03186db7183cd31184180630c6db7180e670ff5db8f1834fc00156606d25101305b49060186306d251032892000300c38fc001701c03183692881264924a180630c36928812 -92929829471834fc0015660492510121d24f060186304925102289e000300c1cfc001703803182492881244924a180630c24928810928890e9471834fc00156604925171225248e601863049251722891c00300c0ffc00170f0031824928b92449246780630c24928b909286912947d834fc00156604925101225249060186 -3049251022892000300c03fcff17fc0031824928812449248180630c2492881292929129471834fc0015660edffb83f1fb6606018630edffb871dcc000300c00fcff17f00031876ffdc1ce3398f180630c76ffdc0c67dc78ffe31824fc000066fa000306018630fa0001300cf900043180000001fe00039180630cf9000103 -1824fc000066fa000306018630fa0001300cf9000b3180000003800000e180630cf90001031821fc000066fa000306018630fa0001300cf900013180fb00030180630cf9000103182dfc000366000201fd000606018630002010fd0001300cf900043180010080fe00060180630c001008fc0001031821fc000066fa000306 -018630fa0001300cf900013180fb00030180630cf9000103182ffc0004660db6db70fe000606018630db6db7fd0001300cf900043186db6db8fe00070180630c6db6db80fd0001031830fc00046606d25128fe0007060186306d251280fe0001300cf900043183692894fe00070180630c36928940fd0001031830fc000466 -04923128fe00070601863049231280fe0001300cf900043182491894fe00070180630c24918940fd0001031830fc00046604922128fe00070601863049221280fe0001300cf900043182491094fe00070180630c24910940fd0001031830fc00046604925128fe00070601863049251280fe0001300cf900043182492894fe -00070180630c24928940fd0001031830fc0004660edfdbfcfe000706018630edfdbfc0fe0001300cf9000431876fedfefe00070180630c76fedfe0fd0001031821fc000066fa000306018630fa0001300cf900013180fb00030180630cf90001031821fc000066fa000306018630fa0001300cf900013180fb00030180630c -f9000103181efc000067faff03fe01863ffaff01f00cf9000031f9ff0280630ff8ff00181efc000067faff03fe01863ffaff01f00cf9000031f9ff0280630ff8ff001819fc000060f900010186f800000cf9000030f8000063f700001819fc000060f900010186f800000cf9000030f8000063f700001819fc000060f90001 -0186f800000cf9000030f8000063f700001819fc000060f900010186f800000cf9000030f8000063f700001819fc000060f900010186f800000cf9000030f8000063f700001819fc000060f900010186f800000cf9000030f8000063f700001819fc000060f900010186f800000cf9000030f8000063f700001819fc000060 -f900010186f800000cf9000030f8000063f700001819fc000060f900010186f800000cf9000030f8000063f700001819fc000060f900010186f800000cf9000030f8000063f700001819fc000060f900010186f800000cf9000030f8000063f700001819fc000060f900010186f800000cf9000030f8000063f700001819fc -000060f900010186f800000cf9000030f8000063f700001819fc000060f900010186f800000cf9000030f8000063f70000181efc000067faff03fe01863ffaff01f00cf9000031f8ff01e30ff9ff01c0181efc000067faff03fe01863ffaff01f00cf9000031f8ff01e30ff9ff01c0182ffc000066fd0006300c0006018630 -fe0005018000c0300cf900013180fe00060c00001801e30cfd0000c0fe0001c0182efc000066fd000610100006018630fd0004800040300cf900013180fe00060400000801e30cfd000040fe0001c01831fc0014660e0cddb3903ebb6e6186307066ed9c837c46300cf90010318383376ce41e6988c3e30c383376ce40fe00 -01c01831fc001466051266d0501305b691863028933682819449300cf9001031814499b41409324925e30c14499b4140fe0001c01831fc00146605124491d0121d26f186302892248e81144f300cf9001031814491247409224925e30c1449124740fe0001c01831fc00146605124492571225268f863028922492b91448f0 -0cf90010318144912495c9224923fb0c144912495cfe0001c01831fc001466051244925012252691863028922492811449300cf9001031814491249409224925e30c1449124940fe0001c01831fc0014660f8ceed9f83f1fb66186307c6776cfc38ee6300cf900103183e33bb67e0e719cc7e30c3e33bb67e0fe0001c01823 -fc000066fa000306018630fa0001300cf900013180fd000508000005e30cf90001c01823fc000066fa000306018630fa0001300cf900013180fd00051c000007e30cf90001c01820fc000066fa000306018630fa0001300cf900013180fa000201e30cf90001c0182dfc000366000201fd000606018630001008fd0001300c -f900043180008040fd000201e30cfd000008fe0001c01825fc000066fa000306018630fa0001300cf900013180fa000201e30cfe00068000040000c01830fc0004660db6db70fe0007060186306db6db80fe0001300cf9000431836db6dcfd000c01e30c0e670ff5db8e0000c01830fc00046606d25128fe00070601863036 -928940fe0001300cf900043181b4944afd000c01e30c1292929829440000c01830fc00046604923128fe00070601863024918940fe0001300cf900043181248c4afd000c01e30c10928890e9440000c01830fc00046604922128fe00070601863024910940fe0001300cf90004318124884afd000c01e30c109286912945c0 -00c01830fc00046604925128fe00070601863024928940fe0001300cf90004318124944afd000c01e30c1292929129440000c01830fc0004660edfdbfcfe00070601863076fedfe0fe0001300cf900043183b7f6fffd000c01e30c0c67dc78ffe20000c01820fc000066fa000306018630fa0001300cf900013180fa000201 -e30cf90001c01820fc000066fa000306018630fa0001300cf900013180fa000201e30cf90001c01820fc000066fa000306018630fa0001300cf900013180fa000201e30cf90001c01823fc000066fa000306018630fa0001300cf900013180fa000501e30c000804fc0001c01820fc000066fa000306018630fa0001300cf9 -00013180fa000201e30cf90001c01822fc000067faff03fe01863ffaff01f00cf9000031f8ff05e30c36db6dc0fd0001c01822fc000067faff03fe01863ffaff01f00cf9000031f8ff05e30c1b4944a0fd0001c0181ffc000060f900010186f800000cf9000030f80005630c1248c4a0fd0001c0181ffc000060f900010186 -f800000cf9000030f80005630c124884a0fd0001c0181ffc000060f900010186f800000cf9000030f80005630c124944a0fd0001c0181ffc000060f900010186f800000cf9000030f80005630c3b7f6ff0fd0001c0181bfc000060f900010186f800000cf9000030f80001630cf90001c0181bfc000060f900010186f80000 -0cf9000030f80001630cf90001c0181bfc000060f900010186f800000cf9000030f80001630cf90001c0181bfc000030f900010303f8000018f9000018f80001c18cf90001c0301bfc000030f900010303f8000018f9000018f80001c18ff9ff01c0301dfc000018f90002060180f9000030f900000cf900020180cff9ff01 -c0601cfc00001cf900020e01c0f9000070f900000ef900020380e0f80000e01dfc00000ef900021c00e0f90000e0f9000007f90002070070f9000101c01ffc000007f90002380070fa000101c0f900010380fa00020e0038f90001038020fc000103c0fa0002f0003cfa00010780f9000101e0fa00023c001ef900010f001b -fb00f9ff02c0000ffaff00fef700007ffaff02f00007f9ff01fc001dfb00003ffaff02000003faff00f8f700001ffaff02c00001f9ff01f00002c90002c90002c90002c90002c90002c90002c90002c90002c90002c90002c90002c90002c90002c90002c90002c90002c90002c90002c90002c90002c90002c90002c9000a -f3000001feff00f0dc000af3000007feff00fcdc000af300001efe00000fdc000bf3000038fe00010380dd000bf3000070fe000101c0dd000af30000e0fd0000e0dd000af30000c0fd000060dd000bf400010180fd000030dd000bf400010180fd000030dd000af4000003fc000018dd000af4000003fc000018dd000af400 -0003fc000018dd000af4000003fc000018dd000af4000003fc000018dd0017f4000003fc000018fd0005010000188660fd000001ec0012f4000003fc000018fa00040808800001e9001cf4000003fc00121800399b6f37399c199dcda6e38d9b5f19c380ef001cf4000003fc001218004a4da4994a64288892c9510525a524 -a480ef001bf4000003fc001118004249249123d028889e8f51053d1124a2ee001cf4000003fc00121800424924911a0c288890885105210d24a180ef001cf4000003fc001218004a4924914a64288892895102252524a480ef001bf4000003fc00111800319db73bf1b81dddcdc6f8821bbb99f7ee000ef4000003fc000018 -fe000004e1000ef4000003fc000018fe00000ee1000bf400010180fd000030dd000bf400010180fd000030dd000af30000c0fd000060dd000af30000e0fd0000e0dd000bf3000070fe000101c0dd000bf3000038fe00010380dd000af300001efe00000fdc000af3000007feff00fcdc000af3000001feff00f0dc000000ff} -}\par -\pard\plain \s253\li-20\sb120\sa120\keepn\tx440 \b\f20\fs28 User interface versions: \par -\pard\plain \s4\li-20\sa120\tx440\tx900 \f20 \bullet \tab Basic user interface with a TTY-oriented interface. \par -\bullet \tab Mini user interface extended by a command loop and command menus. \par -\pard \s4\li-20\sa120\tx440\tx900 \bullet \tab Normal user interface with more comfortable command menus. This is the interface to \tab be used by the knowledge engineer normally. Though this user interface is within the \tab -standard delivery, its realization is machine-dependent. \par -\pard\plain \s253\li-20\sb120\sa120\keepn\tx440 \b\f20\fs28 Frame interpreter versions: \par -\pard\plain \s4\li-20\sa120\tx440\tx900 \f20 \bullet \tab Basic version with frames, behaviors, instances, inheritance and annotations. \par -\bullet \tab Mini version with additional possible values specification. \par -\bullet \tab Normal version with additional active values. \par -\pard\plain \s253\li-20\sb120\sa120\keepn\tx440 \b\f20\fs28 Rule interpreter versions:\par -\pard\plain \s4\li-20\sa120\tx440\tx900 \f20 \bullet \tab Basic version with forward and backward evaluation, various junctors and action \tab types. \par -\bullet \tab Mini version with an additional protocol component. \par -\bullet \tab Normal version with an additional explanation component . \par -\pard\plain \s253\li-20\sb120\sa120\keepn\tx440 \b\f20\fs28 Prolog interpreter versions: \par -\pard\plain \s4\li-20\sa120\tx440\tx900 \f20 \bullet \tab Basic version with clauses, clause sets and system predicates.\par -\bullet \tab Mini version with an additional protocol component. \par -\bullet \tab Normal version with an additional explanation component. \par -\pard\plain \s253\li-20\sb120\sa120\keepn\tx440 \b\f20\fs28 Constraint interpreter versions: \par -\pard\plain \s4\li-20\sa120\tx440\tx900 \f20 \bullet \tab Basic version with constraints, constraint networks and various evaluation \tab algorithms. \par -\bullet \tab Mini version with an additional protocol component. \par -\bullet \tab Normal version with an additional connection to the frame formalism. \par -\pard\plain \s254\li-20\sb120\sa120\keepn\brdrb\brdrs \tx440 \b\f20\fs36 System size: \par -\pard\plain \s9\li-20\keep\tx440\tx880\tx1740\tx2620\tx3480\tx4320\tx5220\tx6060\tx6940\tx7780 \f22\fs20 {\f4 \tab frame interpreter: \tab \tab 123 KByte \par -\tab rule interpreter: \tab \tab 128 KByte \par -\tab Prolog interpreter:\tab \tab 168 KByte \par -}\pard \s9\li-20\keep\tx440\tx880\tx1740\tx2620\tx3480\tx4320\tx5220\tx6060\tx6940\tx7780 {\f4\ul \tab constraint interpreter:\tab \tab 121 KByte \par -}\pard \s9\li-20\keep\tx440\tx880\tx1740\tx2620\tx3480\tx4320\tx5220\tx6060\tx6940\tx7780 {\f4 \tab total core system: \tab \tab 650 KByte \par -for machine-specific user interfaces: \par - \tab Macintosh: \tab \tab \tab 47 KByte \par - \tab Lisp machines: \tab \tab \tab 73 KByte \par -}\pard\plain \s254\li-20\sb120\sa120\keepn\brdrb\brdrs \tx440 \b\f20\fs36 References: \par -\pard\plain \li-20\sa120\tx440 \f20 Christaller, Th., Di Primio, F., Vo\'a7, A.(eds.), Die KI-Werkbank BABYLON, Addison-Wesley, Bonn 1989\par -Christaller, Th., Di Primio, F., Vo\'a7, A.(eds.), The AI Workbench BABYLON, Academic Press 1992\par -\pard \li-20\sa120\tx440 Clocksin, W.F.; Mellish, C.S.: {\i Programming in Prolog.} 2. edition, Berlin: Springer, 1984.\par -\pard \li-20\sa120\tx440 Fidelak, M.; H\'9affgen, K.U.; Vo\'a7, H.: {\i Spezifikation der K3-Mechanismen. }GMD-TEX-I-Bericht, GMD, Sankt Augustin, April 1987.\par -\pard \li-20\sa120\tx440 Fr\'9fchtenicht, H.W.; G\'9fsgen, H.W.; Hrycej, T.; M\'9arler, G.; Struss, P. ( eds.): {\i Technische Expertensysteme: Wissensrepr\'8asentation und Schlu\'a7folgerungsverfahren. }Oldenbourg, M\'9fnchen, 1988.\par -\pard \li-20\sa120\tx440 Gaines, B.R., Linster, M.: Integrating a Knowledge Acquisition Tool, an Expert System Shell and a Hypermedia System. {\i International Journal of Expert Systems} {\b 3} (2), 1990, 105 \endash 129.\par -G\'9fsgen, H.W.: {\i Constraints, eine Wissensrepr\'8asentationsform -- \'86berblick. }Arbeitspapiere der GMD 173, Sankt Augustin, 1985.\par -G\'9fsgen, H.W.; Junker, U.; Vo\'a7, A.: Constraints in a Hybrid Knowledge Representation System. In: {\i Proceedings of the IJCAI-87}, Milan, Italy, 1987, 30-33.\par -\pard \li-20\sa120\tx440 G\'9fsgen, H.W.: CONSAT: Foundations of a System for Constraint Satisfaction. In: H.W. Fr\'9fchtenicht et al. (eds.), {\i Technische Expertensysteme: Wissensrepr\'8asentation und Schlu\'a7-folgerungsverfahren}, 415-440.\par -\pard \li-20\sa120\tx440 M\'9fller, B.S.: {\i Lehrmaterialien BABYLON: Die Beispielswissensbasen zur Pilzbestimmung. }Arbeitspapiere der GMD Nr. 221, GMD, Sankt Augustin, September 1986.\par -\pard \li-20\sa120\tx440 di Primio, F.; Wittur,K.: BABYLON: A meta-interpretation-model for handling mixed knowledge representations. In: {\i Proceedings of the seventh International Workshop on Expert Systems and their Applications, Avignon,} - 1987, 821-833.\par -\pard \li-20\sa120\tx440 Steele, G.L., jr.: {\i COMMON LISP: The Language,} Digital Press, 1984.\par -} \ No newline at end of file diff --git a/t/baby2015/extra.kb b/t/baby2015/extra.kb deleted file mode 100644 index d8229c3..0000000 --- a/t/baby2015/extra.kb +++ /dev/null @@ -1,15 +0,0 @@ - -(DEFINSTANCE SESSION OF SESSIONFRAME WITH SESSIONTIME = ("20.6.1994, 15:29:21")) -(DEFINSTANCE EXTRA OF EXTRAFRAME WITH LOOPEND = (-) LASTSESSIONTIME = ("20.6.1994, 15:15:44" :ASK ("~% Date and time of last session")) DEFAULTTIME = ("12.8.88, 8:00") HOURS.SINCE = (0) DAYS.SINCE = (0) DATASOURCE = (FILE :ASK ("~% Source of Session Data (TTY or FILE) ? ")) HYPOTHESES.GENERATING = (FROM-RULES)) -(DEFINSTANCE PATIENT OF PATIENTFRAME WITH SESSIONTIME = (-) NAME = (SMITH) FIRSTNAME = (THEODORE) DIAGNOSIS.CERTAIN = ((ACTIVE-VALUE - :DEFAULT-GET-BEHAVIOR :SET-OLD-DEFAULT-TIME) :DELTATIME 0 :OLD ("20.6.1994, 15:29:21" -)) DIAGNOSIS.CERTAIN.POSEVIDENCE = ((ACTIVE-VALUE 0.5 :DEFAULT-GET-BEHAVIOR :SET-OLD-DEFAULT-TIME) :DELTATIME 0 :OLD ("20.6.1994, 15:15:44" 0.5)) DIAGNOSIS.POSSIBLE = ((ACTIVE-VALUE - :DEFAULT-GET-BEHAVIOR :SET-OLD-DEFAULT-TIME) :DELTATIME 0 :OLD ("20.6.1994, 15:29:21" -)) WEIGHT = ((ACTIVE-VALUE 60 :DEFAULT-GET-BEHAVIOR :SET-OLD-ASK-TIME) :DELTATIME 0 :OLD ("12.8.1988, 8:0:0" 60) :VARIABEL -) DRYWEIGHT = ((ACTIVE-VALUE 67 :DEFAULT-GET-BEHAVIOR :SET-OLD-ASK-TIME) :DELTATIME 0 :OLD ("1.8.1988, 8:0:0" 67) :VARIABEL -)) -(DEFINSTANCE ANAMNESIS OF ANAMNESISFRAME WITH SESSIONTIME = (-) TIMEOFTRANSPLANTATION = ("1.8.1988, 0:0:0") TIMEOFTRANSPLANTATION.SINCE = (2149.6453) REOPERATION = ((ACTIVE-VALUE NO :DEFAULT-GET-BEHAVIOR :SET-OLD-ASK-TIME) :DELTATIME 0 :OLD ("12.8.1966, 8:0:0" NO) :VARIABEL -)) -(DEFINSTANCE THERAPY OF THERAPYFRAME WITH SESSIONTIME = (-) DIALYSIS = ((ACTIVE-VALUE NO :DEFAULT-GET-BEHAVIOR :SET-OLD-ASK-TIME) :DELTATIME 0 :OLD ("12.8.1988, 8:0:0" NO) :VARIABEL -) ANTILYMPHOCYTESERA = ((ACTIVE-VALUE - NIL :SET-OLD-ASK-TIME) :DELTATIME - :OLD - :VARIABEL -)) -(DEFINSTANCE IMMUNOSUPPRESSION OF IMMUNOSUPPRESSIONFRAME WITH SESSIONTIME = (-) METHYLPREDNISOLONE = ((ACTIVE-VALUE - NIL :SET-OLD-ASK-TIME) :DELTATIME - :OLD - :VARIABEL -)) -(DEFINSTANCE CLINICALFINDINGS OF CLINICALFINDINGSFRAME WITH SESSIONTIME = (-) SPONTANEOUSGRAFTPAIN = ((ACTIVE-VALUE - NIL :SET-OLD-ASK-TIME) :DELTATIME - :OLD - :VARIABEL -) GRAFTPAINBYPALPATION = ((ACTIVE-VALUE - NIL :SET-OLD-ASK-TIME) :DELTATIME - :OLD - :VARIABEL -) GRAFTTENDERNESS = ((ACTIVE-VALUE - NIL :SET-OLD-ASK-TIME) :DELTATIME - :OLD - :VARIABEL -) ENLARGEMENTOFGRAFT = ((ACTIVE-VALUE - NIL :SET-OLD-ASK-TIME) :DELTATIME - :OLD - :VARIABEL -) REANIMATION = (-) TEMPERATURE = ((ACTIVE-VALUE 38.6 :DEFAULT-GET-BEHAVIOR :SET-OLD-ASK-TIME) :DELTATIME 0 :OLD ("12.8.1966, 8:0:0" 38.6) :VARIABEL -) SYSTOLICBLOODPRESSURE = ((ACTIVE-VALUE 90 :DEFAULT-GET-BEHAVIOR :SET-OLD-ASK-TIME) :DELTATIME 0 :OLD ("12.8.1988, 8:0:0" 90) :VARIABEL -)) -(DEFINSTANCE IMMUNOLOGICDATA OF IMMUNOLOGICDATAFRAME WITH SESSIONTIME = (-) IMMUNOLOGICRISK = (-) NUMBERTRANSPLANTATION = (1) FORMERTRANSPLANTATIONCOURSE = (CHRONIC.REJECTION) ANTIBODYLEVEL = ((ACTIVE-VALUE 25 :DEFAULT-GET-BEHAVIOR :SET-OLD-ASK-TIME) :DELTATIME 0 :OLD ("12.8.1966, 8:0:0" 25) :VARIABEL -)) -(DEFINSTANCE LABFINDINGS OF LABFINDINGSFRAME WITH SESSIONTIME = (-) DIURESIS = ((ACTIVE-VALUE 120 :DEFAULT-GET-BEHAVIOR :SET-OLD-ASK-TIME) :DELTATIME 0 :OLD ("12.8.1988, 8:0:0" 120) :VARIABEL -) RESTDIURESIS = ((ACTIVE-VALUE 40 :DEFAULT-GET-BEHAVIOR :SET-OLD-ASK-TIME) :DELTATIME 0 :OLD ("12.8.1988, 8:0:0" 40) :VARIABEL -) CYALEVEL = ((ACTIVE-VALUE - NIL :SET-OLD-ASK-TIME) :DELTATIME - :OLD - :VARIABEL -)) -(DEFINSTANCE TECHNICALINVESTIGATIONS OF TECHNICALINVESTIGATIONSFRAME WITH SESSIONTIME = (-) KIDNEYGRAFTBIOPSY = ((ACTIVE-VALUE - NIL :SET-OLD-DEFAULT-TIME) :DELTATIME - :OLD - :VARIABEL -) KGB.DIAGNOSIS.POSEVIDENCE = ((ACTIVE-VALUE - NIL :SET-OLD-DEFAULT-TIME) :DELTATIME - :OLD -)) -(DEFINSTANCE BLOODLAB OF BLOODLABFRAME WITH SESSIONTIME = (-) HAEMODIALYSIS = (-) CREATININE = ((ACTIVE-VALUE - NIL :SET-OLD-ASK-TIME) :DELTATIME - :OLD - :VARIABEL -)) -(DEFINSTANCE FIRSTCONCLUSIONS OF FIRSTCONCLUSIONSFRAME WITH SESSIONTIME = (-) IMMUNOLOGICRISK = (LOW) IMMUNOLOGICRISK.CALCULATION = (-) IMMUNOSUPRESSIONLEVEL = (-) FEVER = (LOW) DIURESIS.H = (1) DIURESIS24 = ((ACTIVE-VALUE 0 :DEFAULT-GET-BEHAVIOR :SET-OLD-DEFAULT-TIME) :DELTATIME 0 :OLD ("20.6.1994, 15:29:21" 0)) DIFFWEIGHT = (-7) DELTACREATININE = (-8)) -(DEFINSTANCE DONOR OF DONORFRAME WITH KIDNEYGRAFTBIOPSY = (-) PARALLELKIDNEYDIAGNOSIS = (-)) -(DEFINSTANCE HYPOTHESES OF HYPOTHESESFRAME WITH CALCULATION = (NO) ATN = (CONSIDERED) ATN.POSEVIDENCE = ((ACTIVE-VALUE 0 NIL :PUT-NUMERIC-EVIDENCE)) ATN.NEGEVIDENCE = ((ACTIVE-VALUE 1.0 :DEFAULT-GET-BEHAVIOR :PUT-NUMERIC-EVIDENCE)) ATN.SUBCLASSIFICATION = (-) REJECTION = (CONSIDERED) REJECTION.POSEVIDENCE = ((ACTIVE-VALUE 0 NIL :PUT-NUMERIC-EVIDENCE)) REJECTION.NEGEVIDENCE = ((ACTIVE-VALUE 0 NIL :PUT-NUMERIC-EVIDENCE)) REJECTION.SUBCLASSIFICATION = (-)) \ No newline at end of file diff --git a/t/baby2015/fmcs/mcs-core.cl b/t/baby2015/fmcs/mcs-core.cl deleted file mode 100644 index 72263a2..0000000 --- a/t/baby2015/fmcs/mcs-core.cl +++ /dev/null @@ -1,595 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Base: 10; Package: FMCS -*- - -(in-package "FMCS") - -;;; This is the kernel of a Meta Class System (MCS), based on -;;; ObjVlisp by Pierre Cointe and Micro Flavor System by Thomas Christaller. - -;;; Author: Harry Bretthauer -;;; Juergen Kopp - -;;; -------------------------------------------------------------------------- -;;; Global variables -;;; -------------------------------------------------------------------------- - -(defvar *save-combined-methods* T) - -(defvar STANDARD-OBJECT nil) -(defvar STANDARD-CLASS nil) - -(defvar STANDARD-ACCESSORS nil) ; will be set below - -;;; -------------------------------------------------------------------------- -;;; Data structure for objects of the Meta Class System -;;; -------------------------------------------------------------------------- - -;;; An object of the Meta Class System is represented as a structure. -;;; Its slots are represented as a vector called environment (env) - -(defstruct (MCSOBJECT (:conc-name mcs-) - (:print-function print-mcs)) ; print-mcs defined below - env) - -(declaim (simple-vector mcs-env)) - -;;; -------------------------------------------------------------------------- -;;; Slot access functions -;;; -------------------------------------------------------------------------- - -;;; Slots of each class object are: -;;; isit name supers cplist all-slots all-slot-defaults own-slots -;;; methods basicnew-fn slot-accessor-fn subclasses - -;;; Slots indices in all classes - -(defmacro index-of-isit () 0) -(defmacro index-of-name () 1) -(defmacro index-of-supers () 2) -(defmacro index-of-cplist () 3) -(defmacro index-of-all-slots () 4) -(defmacro index-of-all-slot-defaults () 5) -(defmacro index-of-own-slots () 6) -(defmacro index-of-methods () 7) -(defmacro index-of-basicnew-fn () 8) -(defmacro index-of-slot-accessor-fn () 9) -(defmacro index-of-subclasses () 10) - -;;; Systems internal slot access functions - -(defmacro MCS-GET-SLOT (vector slot-position) - `(svref ,vector ,slot-position)) - -(defmacro MCS-SLOT-VALUE (object slot-position) - `(svref (mcs-env ,object) ,slot-position)) - -;;; Slot access function to use in methods - -(defmacro GET-CLASS () ;added e.gross - `(svref inst-env (index-of-isit))) - -(defmacro GET-SLOT (slot) ;changed e.gross - `(svref inst-env - (funcall (svref class-env (index-of-slot-accessor-fn)) ,slot))) - -;(defmacro SET-SLOT (slot new-value) -; `(setf (svref inst-env -; (funcall (svref class-env (index-of-slot-accessor-fn)) ,slot)) -; ,new-value)) - -(defmacro GET-CLASS-SLOT (slot) - (case (eval slot) - (isit `(svref class-env (index-of-isit))) - (name `(svref class-env (index-of-name))) - (supers `(svref class-env (index-of-supers))) - (cplist `(svref class-env (index-of-cplist))) - (methods `(svref class-env (index-of-methods))) - (basicnew-fn `(svref class-env (index-of-basicnew-fn))) - (all-slots `(svref class-env (index-of-all-slots))) - (t `(slot-value (mcs-get-slot inst-env (index-of-isit)) ,slot)) - )) - -;(defmacro SET-CLASS-SLOT (slot new-value) -; `(set-slot-value (mcs-get-slot inst-env (index-of-isit)) ,slot ,new-value) -; ) - -;;; universal (public) slot access functions - -(defun SLOT-VALUE (object slot) - (let ((object-env (mcs-env object))) - (svref object-env - (funcall (svref (mcs-env (svref object-env (index-of-isit))) - (index-of-slot-accessor-fn)) - slot)))) - -(defun SET-SLOT-VALUE (object slot value) - (let ((object-env (mcs-env object))) - (setf (svref object-env - (funcall (svref (mcs-env (svref object-env (index-of-isit))) - (index-of-slot-accessor-fn)) - slot)) - value))) - -(defsetf slot-value set-slot-value) - -;;; -------------------------------------------------------------------------- -;;; Data structure for method entries -;;; -------------------------------------------------------------------------- - -(defstruct METHOD-ENTRY - type - methods-list - combined-method) - -;;; methods-list = ((:before . before-fn) ... (:after . after-fn)) -;;; methods lambda list: -;;; of around and primary methods: -;;; (self class-env inst-env next-methods args arg1 arg2 ...) -;;; of before and after methods: -;;; (self class-env inst-env arg1 arg2 ...) - - -(defmacro GET-SELECTOR-ENTRY (a_selector) - `(gethash ,a_selector (get-class-slot 'methods)) - ) - -(defmacro GET-QUALIFIED-METHOD (qualifier list-of-methods) - `(assoc ,qualifier ,list-of-methods :test #'eq)) - -(defmacro QUALIFIER-OF (method) - `(first ,method)) - -(defmacro LAMBDA-EXPR-OF (method) - `(rest ,method)) - -(defmacro add-qualified-method (qualifier method-entry new-fn) - `(let ((qualified-method - (get-qualified-method ,qualifier (method-entry-methods-list ,method-entry)))) - (if qualified-method - (rplacd qualified-method ,new-fn) - (setf (method-entry-methods-list ,method-entry) - (acons ,qualifier - ,new-fn - (method-entry-methods-list ,method-entry) - ))) - )) - -(defmacro around-of (applicable-methods) - `(first ,applicable-methods)) - -(defmacro demons-of (applicable-methods) - `(rest ,applicable-methods)) - -(defmacro before-of (applicable-methods) - `(second ,applicable-methods)) - -(defmacro primary-of (applicable-methods) - `(third ,applicable-methods)) - -(defmacro after-of (applicable-methods) - `(fourth ,applicable-methods)) - - -;;; -------------------------------------------------------------------------- -;;; Method combination functions -;;; -------------------------------------------------------------------------- - -(declaim (inline DEMON-METHOD-COMBINATION)) - -(defun DEMON-METHOD-COMBINATION (self class-env inst-env selector applicable-methods args) - (declare (ignore selector)) - (let ((before-methods (before-of applicable-methods)) - (primary-methods (primary-of applicable-methods)) - (after-methods (after-of applicable-methods))) - (prog2 - (loop - (if (null before-methods) (return ())) - (apply (pop before-methods) - self class-env inst-env args)) - (apply (first primary-methods) - self class-env inst-env :primary-caller (rest primary-methods) - args args) - (loop - (if (null after-methods) (return ())) - (apply (pop after-methods) - self class-env inst-env args)) - ))) - -(declaim (inline STANDARD-METHOD-COMBINATION)) - -(defun STANDARD-METHOD-COMBINATION (self class-env inst-env selector applicable-methods - args) - (let ((around-methods (around-of applicable-methods))) - (if around-methods - (apply (first around-methods) - self class-env inst-env - :around-caller (cons (rest around-methods) - (demons-of applicable-methods)) - args - args) - (demon-method-combination self class-env inst-env selector applicable-methods args) - ))) - - -(declaim (inline SIMPLE-METHOD-COMBINATION)) - -(defun SIMPLE-METHOD-COMBINATION (self class-env inst-env selector applicable-methods - args) - (declare (ignore selector)) - (let ((primary-methods (primary-of applicable-methods))) - (apply (first primary-methods) - self class-env inst-env :primary-caller (rest primary-methods) - args args) - )) - - -;;; -------------------------------------------------------------------------- -;;; General message handler -;;; -------------------------------------------------------------------------- - -(defmacro GET-COMBINED-METHOD (a_selector) - `(let ((method-entry (gethash ,a_selector (get-class-slot 'methods)))) - (if method-entry (method-entry-combined-method method-entry)))) - -(declaim (inline STANDARD-MESSAGE-HANDLER)) - -(defun STANDARD-MESSAGE-HANDLER (self class-env inst-env selector args) - (let ((combined-method (get-combined-method selector))) - (if combined-method - (funcall (svref combined-method 0) - self class-env inst-env selector (svref combined-method 1) args) - (multiple-value-bind - (method-combination-fn applicable-methods) - (standard-method-lookup class-env selector) - (if applicable-methods - (progn - (if *save-combined-methods* - (save-combined-method class-env selector - method-combination-fn applicable-methods)) - (funcall method-combination-fn - self class-env inst-env selector applicable-methods args)) - (standard-message-handler self class-env inst-env - :default-handler (cons selector args))) - )))) - - -;;; -------------------------------------------------------------------------- -;;; Send functions and macros -;;; -------------------------------------------------------------------------- - - -(defun SEND-MESSAGE (self selector &rest args) - (if (typep self 'mcsobject) - (let* ((inst-env (mcs-env self)) - (class-env (mcs-env (svref inst-env (index-of-isit))))) - (standard-message-handler self class-env inst-env selector args)) - (format nil "ERROR in SEND: SEND can't be applied on ~S" self))) - -(defun SEND-FAST (self sel &rest args) - (let* ((inst-env (mcs-env self)) - (class-env (mcs-env (svref inst-env (index-of-isit))))) - (standard-message-handler self class-env inst-env sel args))) - -(defmacro SEND-SELF (sel &rest args) - `(standard-message-handler self class-env inst-env ,sel (list ,@args))) - - -; ++++++ - -;;; -------------------------------------------------------------------------- -;;; Compile method functions -;;; -------------------------------------------------------------------------- - -(defun SAVE-COMBINED-METHOD (class-env selector method-combination-fn - applicable-methods) - (let ((method-entry (gethash selector (get-class-slot 'methods)))) - (if method-entry - (setf (method-entry-combined-method (gethash selector (get-class-slot 'methods))) - (vector method-combination-fn applicable-methods)) - (setf (gethash selector (get-class-slot 'methods)) - (make-method-entry :type 'standard - :methods-list nil - :combined-method - (vector method-combination-fn applicable-methods))) - ))) - -(defun COMBINE-CLASS-METHOD (a_class a_selector) - (let ((class-env (mcs-env a_class))) - (multiple-value-bind - (method-combination-fn applicable-methods) - (standard-method-lookup class-env a_selector) - (if applicable-methods - (let ((method-entry (gethash a_selector (get-class-slot 'methods)))) - (if method-entry - (setf (method-entry-combined-method - (gethash a_selector (get-class-slot 'methods))) - (vector method-combination-fn applicable-methods)) - (setf (gethash a_selector (get-class-slot 'methods)) - (make-method-entry - :type 'standard :methods-list nil - :combined-method - (vector method-combination-fn applicable-methods)))) - (format nil "Method ~S of class ~S has been combined" a_selector a_class)) - (format nil "No Method ~S of class ~S could been combined" a_selector a_class) - )))) - -(defmacro COMBINE-CLASS-METHODS (&rest classes) - `(let ((list-of-classes ',classes)) - (loop - (if (null list-of-classes) (return ())) - (let* ((class (eval (pop list-of-classes))) - (all-methods-list (send-message class :get-protocol))) - (loop - (if (null all-methods-list) (return ())) - (combine-class-method class (pop all-methods-list))))) - )) - - -;;; -------------------------------------------------------------------------- -;;; Call-next-method macro and functions -;;; -------------------------------------------------------------------------- - -;;; CALL-NEXT-METHOD can be used in :around and :primary methods -;;; If (call-next-method) occurs in an :around method, the next :around method -;;; is called, if there is one. If no, procede with :before, primary and :after -;;; methods. If (call-next-method) occurs in a :primary method the next -;;; :primary method is called, if there is one. If no, an error message is send. - -(defun CALL-NEXT-METHOD-FN (self class-env inst-env caller next-methods args) - (if (eq caller :primary-caller) - (let ((next-method (first next-methods))) - (if next-method - (apply next-method - self class-env inst-env - :primary-caller (rest next-methods) args - args) - (error "Can't call next method from primary method."))) - (let ((around-methods (around-of next-methods))) - (if around-methods - (apply (first around-methods) - self class-env inst-env - :around-caller (cons (rest around-methods) - (demons-of next-methods)) - args args) - (demon-method-combination self class-env inst-env - :dummy-selector - next-methods - args))) - )) - -(defmacro CALL-NEXT-METHOD (&rest changed-args) - (if changed-args - `(call-next-method-fn self class-env inst-env mcs%caller mcs%next-methods - ',changed-args) - `(call-next-method-fn self class-env inst-env mcs%caller mcs%next-methods mcs%args) - )) - -;;; -------------------------------------------------------------------------- -;;; Method lookup functions -;;; -------------------------------------------------------------------------- - -(declaim (inline GET-METHOD-ENTRY)) - -(defun GET-METHOD-ENTRY (a_class a_selector) - (gethash a_selector (mcs-slot-value a_class (index-of-methods)))) - -(defun STANDARD-METHOD-LOOKUP (class-env a_selector) - (let ((r-class-precedence-list (reverse (get-class-slot 'cplist))) - (around-methods nil) (before-methods nil) (primary-methods nil) - (after-methods nil)) - (loop - (if (null r-class-precedence-list) - (return - (if primary-methods - (values (if around-methods - 'standard-method-combination - (if (or before-methods after-methods) - 'demon-method-combination - 'simple-method-combination)) - (list around-methods before-methods - primary-methods (reverse after-methods))) - (if (or after-methods before-methods around-methods) - (error "Method combination error: missing primary method for ~S." - a_selector) - (values nil nil))))) - (let ((method (get-method-entry (pop r-class-precedence-list) a_selector))) - (if method - (let ((own-methods-list (method-entry-methods-list method))) - (let ((around-method (get-qualified-method :around own-methods-list)) - (before-method (get-qualified-method :before own-methods-list)) - (primary-method (get-qualified-method :primary own-methods-list)) - (after-method (get-qualified-method :after own-methods-list)) - ) - (if before-method - (setq before-methods (cons (lambda-expr-of before-method) before-methods))) - (if after-method - (setq after-methods (cons (lambda-expr-of after-method) after-methods))) - (if primary-method - (setq primary-methods (cons (lambda-expr-of primary-method) primary-methods))) - (if around-method - (setq around-methods (cons (lambda-expr-of around-method) around-methods))) - ))))))) - - -;;; -------------------------------------------------------------------------- -;;; Defmethod macro and helps -;;; -------------------------------------------------------------------------- - -(defun modify-body (body add-parameter-list &optional result) - (let ((f (first body)) - (r (rest body))) - (cond ((typep f 'string) - (modify-body r add-parameter-list (list f))) - ((and (listp f) (eq (first f) 'declare)) - (modify-body r add-parameter-list (append result (list f)))) - (t (append result - #+(or :MCL :EXCL) - '((declare (ignore-if-unused self class-env inst-env - mcs%caller mcs%next-methods mcs%args))) - #-(or :MCL :EXCL) - add-parameter-list - body))))) - -(defun MAKE-LAMBDA-EXPR (qualifier parameter-list body) - (let ((add-parameter-list - (if (member qualifier '(:around :primary) :test #'eq) - `(self class-env inst-env mcs%caller mcs%next-methods mcs%args) - `(self class-env inst-env)))) - `(lambda (,@add-parameter-list ,@parameter-list) - ,@(modify-body body add-parameter-list)))) - - -(defun REMOVE-INVALID-COMBINED-METHODS (a_class selector) - (let ((method-entry (gethash selector - (mcs-slot-value a_class (index-of-methods))))) - (if method-entry (setf (method-entry-combined-method method-entry) nil))) - (let ((subclasses (mcs-slot-value a_class (index-of-subclasses)))) - (loop - (if (null subclasses) (return ())) - (remove-invalid-combined-methods (pop subclasses) selector)))) - -(defmacro DEFMETHOD ((a_class . qualifier-and-selector) parameter-list - &rest body) - (let ((qualifier (if (second qualifier-and-selector) - (first qualifier-and-selector) - :primary)) - (selector (if (second qualifier-and-selector) - (second qualifier-and-selector) - (first qualifier-and-selector)))) - `(let ((method-entry - (gethash ,selector (mcs-slot-value ,a_class (index-of-methods)))) - (new-method-fn - (function ,(make-lambda-expr qualifier parameter-list body)))) - (if method-entry - (add-qualified-method ,qualifier method-entry new-method-fn) - (setf (gethash ,selector (mcs-slot-value ,a_class (index-of-methods))) - (make-method-entry :type 'standard - :methods-list - (acons ,qualifier new-method-fn ()) - :combined-method nil) )) - (remove-invalid-combined-methods ,a_class ,selector) - (format nil "~:[~S~;~S ~S~] of ~S" (second ',qualifier-and-selector) - ,@qualifier-and-selector ',a_class)))) - -;;;------------------------------------------------------------------------ -;;; Basic slot access methods -;;;------------------------------------------------------------------------ - -(eval-when (compile eval load) - - (defun gen-get-slot-method (index) - (let ((call-next-parms '(mcs%caller mcs%next-methods mcs%args))) - `(lambda (self class-env inst-env . ,call-next-parms) - (declare (ignore self class-env . ,call-next-parms)) - (svref inst-env ,index)))) - - (defun gen-set-slot-method (index) - (let ((call-next-parms '(mcs%caller mcs%next-methods mcs%args))) - `(lambda (self class-env inst-env ,@call-next-parms value) - (declare (ignore self class-env ,@call-next-parms)) - (setf (svref inst-env ,index) value)))) - ) - -(defun gen-get-slot-closure (index) - #'(lambda (self class-env inst-env mcs%caller mcs%next-methods mcs%args) - (declare (ignore self class-env mcs%caller mcs%next-methods mcs%args)) - (svref inst-env index))) - -(defun gen-set-slot-closure (index) - #'(lambda (self class-env inst-env mcs%caller mcs%next-methods mcs%args value) - (declare (ignore self class-env mcs%caller mcs%next-methods mcs%args)) - (setf (svref inst-env index) value))) - - -(defmacro generate-standard-accessors (nr &aux result) - `(let ((array (make-array ,nr :adjustable t))) - (declare (vector array)) - ,@(dotimes (i nr (nreverse result)) - (declare (fixnum i nr)) - (setf result - (cons `(setf (aref array ,i) - (cons (function ,(gen-get-slot-method i)) - (function ,(gen-set-slot-method i)))) - result))) - array)) - -(defun adjust-standard-accessors (array nr) - (declare (vector array) - (fixnum nr)) - (let ((i (length array))) - (declare (fixnum i)) - (multiple-value-bind (x y) (ceiling nr 16) - (declare (ignore x)) - (setq nr (- nr y)) - ; x nil) ; because x should be ignored - (adjust-array array nr) - (loop - (if (>= i nr) - (return array)) - (setf (aref array i) - (cons (gen-get-slot-closure i) - (gen-set-slot-closure i))) - (setq i (1+ i)))))) - -;;; Generate 48 standard slot access methods - -(setq STANDARD-ACCESSORS (generate-standard-accessors 64)) - -;;; ---------------------------------------------------------------- -;;; -*- USER INTERFACE -*- -;;; ---------------------------------------------------------------- - -(defun PRINT-MCS (object stream depth) - (declare (ignore depth)) - (let ((class-env (mcs-env (mcs-slot-value object (index-of-isit))))) - (if (member 'supers (mcs-get-slot class-env (index-of-all-slots))) - (format stream "#" - (mcs-slot-value object (index-of-name))) - (format stream "#" - (mcs-get-slot class-env (index-of-name)))))) - -(defun DESCRIBE-MCS (object &optional (stream t)) - (if (typep object 'mcsobject) - (let* ((inst-env (mcs-env object)) - (class-env (mcs-env (mcs-get-slot inst-env (index-of-isit)))) - ) - (format stream "~&~S, an object of class ~S,~% has instance variable values:~%" - object (mcs-get-slot class-env (index-of-name))) - (dolist (ivar (mcs-get-slot class-env (index-of-all-slots))) - (format stream "~% ~S:~27T~S" ivar (slot-value object ivar)))) - (describe object))) - -;;; DEFMETHOD macro already defined - -(defmacro DEFCLASS (a_class a_list-of-instance-variables a_list-of-superclasses - &key (metaclass 'standard-class)) - `(setq ,a_class - (funcall (mcs-slot-value ,metaclass (index-of-basicnew-fn)) - ,metaclass - :name ',a_class - :supers (if ',a_list-of-superclasses - (list ,@a_list-of-superclasses) - (list standard-object)) - :own-slots ',a_list-of-instance-variables - ))) - -(defmacro DEFMETACLASS (a_class a_list-of-instance-variables a_list-of-superclasses - &key (metaclass 'standard-class)) - `(setq ,a_class - (funcall (mcs-slot-value ,metaclass (index-of-basicnew-fn)) - ,metaclass - :name ',a_class - :supers (if ',a_list-of-superclasses - (list ,@a_list-of-superclasses) - (list standard-class)) - :own-slots ',a_list-of-instance-variables - ))) - -(defmacro MAKE-INSTANCE (a_class &rest initializations) - `(let ((class ,(if (and (listp a_class) (eq (first a_class) 'quote)) - (second a_class) - `(eval ,a_class)))) - (funcall (mcs-slot-value class (index-of-basicnew-fn)) - class ,@initializations))) - - -;;; eof diff --git a/t/baby2015/fmcs/mcs-map.cl b/t/baby2015/fmcs/mcs-map.cl deleted file mode 100644 index 3902142..0000000 --- a/t/baby2015/fmcs/mcs-map.cl +++ /dev/null @@ -1,374 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Base: 10; Package: FMCS -*- - -(in-package "FMCS") - -;; Copyright 1989, 1988, 1987, 1986, 1985 and 1984 BY -;; G M D -;; Postfach 1240 -;; D-5205 St. Augustin -;; FRG - -;; Authors: Harry Bretthauer, Eckehard Gross, Juergen Kopp, Juergen Walther - -;; -;; Abbildung auf das zugrundeliegende Flavor System MCS -;; - -;;;(export 'self) - -(defvar flavor-class nil) - -; ------------------------------------------------------------------- -; $send self wird durch send-self substituiert -; ------------------------------------------------------------------- - - -(defun subst-$send-self (form) - (cond ((atom form) form) - ((eq (first form) '$send) - (when (eq (second form) 'self) - (rplaca form 'send-self) - (rplacd form (cddr form))) - (subst-$send-self (cdr form))) - (t (subst-$send-self (car form)) - (subst-$send-self (cdr form)))) - form) - - -; ------------------------------------------------------------------- -; Instanzvariablen werden in Methoden wie freie Variablen referiert -; ------------------------------------------------------------------- - -(defun SUBLIS-SELECT (a_list tree &optional (test #'eql) - (filter #'(lambda (expr) - (declare (ignore expr)) - t))) - (declare (list a_list)) - (cond ((atom tree) tree) - ((funcall (the function filter) tree) - (let ((pair (assoc (first tree) a_list :test test))) - (cond (pair (rplaca tree (cdr pair)) - (sublis-select a_list (cdr tree) test filter)) - (t (sublis-select a_list (car tree) test filter) - (sublis-select a_list (cdr tree) test filter))))) - (t ())) - tree) - -(defun COMPILE-SLOT-REFERENCES (slot-names lambda-body - &optional (slot-access-fn 'get-slot)) - ; (print "in compile-slot-ref.") - (sublis-select (mapcar #'(lambda (a_slot) - (cons a_slot (list slot-access-fn (list 'quote a_slot)))) - slot-names) - lambda-body - #'eql - #'(lambda (x) - (and (listp x) - (not (eql (car x) slot-access-fn)) - (not (eq (car x) 'quote)))))) - -;;; ------------------------------------------------------------------ -;;; -;;; ------------------------------------------------------------------ - -(defun GET-ALL-REQUIRED-SLOT-NAMES (class) - (append (mcs-slot-value class (index-of-all-slots)) - (slot-value class 'req-inst-vars))) - -(defun required-instance-variables (options) - (dolist (option options) - (if (and (consp option) - (equal (car option) :required-instance-variables)) - (return (cdr option))))) - -(defmetaclass flavor-class (req-inst-vars) ()) - -(setf (mcs-slot-value flavor-class (index-of-basicnew-fn)) - #'(lambda (isit &key (name nil) (supers nil) (own-slots nil) - (req-inst-vars nil)) - (send-fast - (make-mcsobject - :env (vector isit name supers nil nil nil own-slots - (make-hash-table :test #'eq) - nil nil nil req-inst-vars)) - :basic-init))) - -(defmethod (flavor-class :basic-init) () - (send-self :compute-cplist) - (send-self :inherit-slots-with-defaults) - self) - -(defmethod (flavor-class :init) (&rest inits) - (declare (ignore inits)) - (send-self :compute-slot-accessor-fn) - (send-self :extend-subclasses-of-supers) - (send-self :compute-slot-access-methods) - (send-self :compute-basicnew-fn) - self) - - -;;; ------------------------------------------------------------------ -;;; Definition von Flavors -;;; ------------------------------------------------------------------ - -;;;(export 'def$flavor) -(defmacro def$flavor (a_class a_list-of-instance-variables - a_list-of-superclasses &rest options) - `(progn - (eval-when (compile) - (defvar ,a_class) ; um compiler warnings zu unterdruecken - (setq ,a_class - (funcall (mcs-slot-value flavor-class (index-of-basicnew-fn)) - flavor-class - :name ',a_class - :supers (if ',a_list-of-superclasses - (list ,@a_list-of-superclasses) - (list standard-object)) - :own-slots ',a_list-of-instance-variables - :req-inst-vars ',(required-instance-variables options)))) - ; warum das im kontext von def-kb-konfiguration in gclisp komilierbar ist - ; und die alte version mit let nicht, the lord knows - (eval-when (load) - (defvar ,a_class) - (setq ,a_class - (send-fast (funcall (mcs-slot-value flavor-class (index-of-basicnew-fn)) - flavor-class - :name ',a_class - :supers (if ',a_list-of-superclasses - (list ,@a_list-of-superclasses) - (list standard-object)) - :own-slots ',a_list-of-instance-variables - :req-inst-vars ',(required-instance-variables options)) - :init))) - (eval-when (eval) - (defvar ,a_class) ; um compiler warnings zu unterdruecken - (let ((new-class (funcall (mcs-slot-value flavor-class (index-of-basicnew-fn)) - flavor-class - :name ',a_class - :supers (if ',a_list-of-superclasses - (list ,@a_list-of-superclasses) - (list standard-object)) - :own-slots ',a_list-of-instance-variables - :req-inst-vars ',(required-instance-variables options)))) - (if (flavorp ',a_class) - (redefine-class ,a_class new-class) - (setq ,a_class (send-fast new-class :init))))) - )) - - -;;; Waehrend der Entwicklung eines Systems will man Flavors aendern, also -;;; redefinieren. Wird ein Flavor redefiniert, so werden entsprechende -;;; Teile der Vererbungshierarchie dem neuen Stand angepasst. - -;;; Das heisst: - das Flavor muss aus den Subklassenlisten ihrer -;;; ehemaligen Superklassen entfernt werden; -;;; - die ehemaligen Subklassen des Flavor muessen redefiniert werden. - -;;; Die Instanzen von geaenderten Flavors bleiben unveraendert, muessen also -;;; vom Programmierer selbst neu erzeugt werden, d.h. Programmteile, die Instanzen -;;; erzeugen bzw. verwenden muessen neu ausgewertet werden. -;;; Deswegen wird eine entsprechende Warnung an den Benutzer ausgegeben! - -;;;(export '*redefine-warnings*) -(defvar *redefine-warnings* nil) - -(defun redefine-class (old-class new-class) - (let ((old-supers (mcs-slot-value old-class (index-of-supers))) - (old-methods (mcs-slot-value old-class (index-of-methods))) - (old-subclasses (mcs-slot-value old-class (index-of-subclasses))) - (new-cplist (cons old-class (rest (slot-value new-class 'cplist))))) - (remove-subclass old-class old-supers) - (setf (mcs-env old-class) (mcs-env new-class)) - (setf (slot-value old-class 'cplist) new-cplist) - (send-fast old-class :init) - (let ((new-methods (mcs-slot-value old-class (index-of-methods)))) - (maphash #'(lambda (key value) - (if (not (gethash key new-methods)) - (setf (gethash key new-methods) value))) - old-methods)) - (if *redefine-warnings* - (warn "~&~S has been redefined. Instances may be invalid now!" old-class)) - (redefine-subclasses old-subclasses) - old-class)) - -(defun remove-subclass (class superclasses) - (dolist (super superclasses) - (setf (mcs-slot-value super (index-of-subclasses)) - (remove class (mcs-slot-value super (index-of-subclasses)) :test #'eq)))) - -(defun redefine-subclasses (list-of-classes) - (dolist (subclass list-of-classes) - (eval - `(def$flavor ,(slot-value subclass 'name) - ,(slot-value subclass 'own-slots) - ,(mapcar #'(lambda (class) - (slot-value class 'name)) - (slot-value subclass 'supers)) - (:required-instance-variables ,@(slot-value subclass 'req-inst-vars)) - )))) - -;;;(export 'def$frame) -(defmacro def$frame (name instance-vars components &rest options) - `(def$flavor ,name ,instance-vars ,components ,@options)) - - - -;;; ------------------------------------------------------------------ -;;; Definition von Methoden -;;; ------------------------------------------------------------------ - -;;;(export 'def$method) -(defmacro def$method ((name . type&selector) varlist . body) - (let ((new-body - (compile-slot-references (get-all-required-slot-names (symbol-value name)) - (subst-$send-self body)))) - `(defmethod (,name ,@type&selector) ,varlist ,@new-body))) - -;;;(export 'def$behavior) -(defmacro def$behavior ((name . type&selector) varlist . body) - (let ((new-body (subst-$send-self body))) - `(defmethod (,name ,@type&selector) ,varlist ,@new-body))) - -;;;(export 'undef$method) -(defmacro undef$method ((name . type&selector)) ; for testing only - `(undefmethod (,name . ,type&selector))) - -;;;(export 'trace$method) -(defmacro trace$method ((flav-name selector)) - "traces a method on *trace-output*" - `(mcs-trace ,flav-name ,selector)) - -;;;(export 'untrace$method) -(defmacro untrace$method ((flav-name selector)) - "untraces a method" - `(mcs-untrace ,flav-name ,selector)) - -;;;(export 'is-traced$method) -(defmacro is-traced$method ((flav-name selector)) - "untraces a method" - `(mcs-is-traced ,flav-name ,selector)) - -;;;(export 'compile-$flavor-$methods) -(defmacro compile-$flavor-$methods (&rest flavors) - `(eval-when (load) - (combine-class-methods ,@flavors))) - -;;; ------------------------------------------------------------------ -;;; WHOPPER = :AROUND method combination -;;; ------------------------------------------------------------------ - -;;;(export 'defwhopper) -(defmacro defwhopper ((flavor-name operation) arglist &body body) - `(def$method (,flavor-name :around ,operation) (,@arglist) - ,@body)) - -;;;(export 'continue-whopper) -(defmacro continue-whopper (&rest changed-args) - (if changed-args - `(call-next-method-fn self class-env inst-env mcs%caller mcs%next-methods - (list ,@changed-args)) - `(call-next-method-fn self class-env inst-env mcs%caller mcs%next-methods - mcs%args) - )) - -;;; ------------------------------------------------------------------ -;;; Senden von Nachrichten -;;; ------------------------------------------------------------------ - -; (send-message (object selector &rest message) is provided by mcs - -;;;(export '$send) -(defmacro $send (object message &rest args) - `(send-message ,object ,message ,@args)) - -;;;(export 'lexpr-$send) -(defmacro lexpr-$send (object message &rest args) - `(apply #'send-message ,object ,message ,@args)) - -;;; ------------------------------------------------------------------ -;;; Funktionen bzw. Makros fuer Flavors und Instanzen -;;; ------------------------------------------------------------------ - -;;; the typep function of different lisp implementations behave differently -;;; in case of unknown type specifiers, -;;; it may warn you, give an error, or return nil -;;; what a horror - -;;;(export 'flavorp) -(defun flavorp (object) - (if (and (boundp object)(typep (symbol-value object) 'mcsobject)) - (send-fast (symbol-value object) :class-p))) - -;;;(export 'flavor-instancep) -(defun flavor-instancep (object) - (typep object 'mcsobject)) - -;;;(export 'flavor-typep) -(defun flavor-typep (object type) - (if (typep object 'mcsobject) - (if (and (boundp type) - (member (symbol-value type) - (mcs-slot-value (mcs-slot-value object (index-of-isit)) - (index-of-cplist)) - :test #'eq)) - t) - (unless (flavorp type) - (typep object type)))) - - -;;;(export 'flavor-type-of) -(defun flavor-type-of (object) - (if (typep object 'mcsobject) - (mcs-slot-value (mcs-slot-value object (index-of-isit)) (index-of-name)) - (type-of object))) - -;;; ------------------------------- - -;;;(export 'get-flavor-instance-slots) -(defun get-flavor-instance-slots (instance) - (remove 'isit (mcs-slot-value (mcs-slot-value instance (index-of-isit)) - (index-of-all-slots)))) - -;;;(export 'symbol-value-in-$instance) -(defmacro symbol-value-in-$instance (instance slot-name) - `(slot-value ,instance ,slot-name)) - -;;;(export '$slot) -(defmacro $slot (slot-name) - `(get-slot ,slot-name)) - -;;; ------------------------------------------------------------------ -;;; Definition von Flavorinstanzen -;;; ------------------------------------------------------------------ - -;; (defmacro make-$instance (flavor &rest init-plist) -;; `(send (eval ,flavor) :new ,@init-plist)) - -;; 3.1.89 - -;;;(export 'MAKE-$INSTANCE) -(defmacro MAKE-$INSTANCE (flavor &rest initializations) - `(let ((class (symbol-value ,flavor))) - (funcall (mcs-slot-value class (index-of-basicnew-fn)) - class ,@initializations))) - -;;;(export 'make-window-or-instance) -(defmacro make-window-or-instance (flavor &rest initializations) - `(MAKE-$INSTANCE ,flavor ,@initializations)) - - -;;; ------------------------------------------------------------------- -;;; Methoden fuer alle Instanzen -;;; ------------------------------------------------------------------- - -;;; sind vorhanden in mcs - -; :describe -; :which-operations -; :apropos -; :operation-handled-p -; :send-if-handles -; :how-combined - -;; eof - diff --git a/t/baby2015/fmcs/mcs-meth.cl b/t/baby2015/fmcs/mcs-meth.cl deleted file mode 100644 index 1a667af..0000000 --- a/t/baby2015/fmcs/mcs-meth.cl +++ /dev/null @@ -1,202 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Base: 10; Package: FMCS -*- - -(in-package "FMCS") - - -;;; ------------------------------------------------------------------ -;;; Inheritance methods -;;; ------------------------------------------------------------------ - -(defmethod (standard-class :compute-cplist) () - (let ((result ()) - (r-supers (reverse (mcs-get-slot inst-env (index-of-supers))))) - (loop - (if (null r-supers) (return ())) - (setf result - (append (mcs-slot-value (pop r-supers) (index-of-cplist)) - result))) - (setf (mcs-get-slot inst-env (index-of-cplist)) - (remove-duplicates (cons self result) - :test #'eq)))) - -(defmethod (standard-class :inherit-slots-with-defaults) () - (let* ((own-slots-specification - (mcs-get-slot inst-env (index-of-own-slots))) - (slots-result (mapcar #'(lambda (el) (if (listp el) (first el) el)) - own-slots-specification)) - (defaults-result (mapcar #'(lambda (el) (if (listp el) - el - (list el nil))) - own-slots-specification)) - (components (rest (mcs-get-slot inst-env (index-of-cplist))))) - (loop - (if (null components) (return ())) - (setq slots-result - (append (mcs-slot-value (first components) (index-of-all-slots)) - slots-result)) - (setq defaults-result - (append defaults-result - (mcs-slot-value (first components) - (index-of-all-slot-defaults)))) - (pop components)) - (setf (mcs-get-slot inst-env (index-of-all-slots)) - (remove-duplicates slots-result :test #'eq :from-end t)) - (setf (mcs-get-slot inst-env (index-of-all-slot-defaults)) - (remove-duplicates defaults-result :test #'eq :key #'car :from-end t)))) - -(defmethod (standard-class :compute-slot-access-methods) () - (let* ((slots (rest (mcs-get-slot inst-env (index-of-all-slots)))) - (nr (1+ (length slots))) - (counter (1+ (index-of-isit))) - (array standard-accessors)) - (declare (fixnum nr counter) - (vector array) - (list slots)) - (if (> nr (length array)) - (setq standard-accessors (adjust-standard-accessors array nr))) - (loop - (if (null slots) (return ())) - (let ((slot-name (pop slots)) - (fn-pair (aref array counter))) - (setf (gethash (intern (string slot-name) :keyword) - (mcs-get-slot inst-env (index-of-methods))) - (make-method-entry :type 'standard - :methods-list - (acons :primary (car fn-pair) ()) - :combined-method nil)) - (setf (gethash (intern (concatenate 'string "SET-" (string slot-name)) - :keyword) - (mcs-get-slot inst-env (index-of-methods))) - (make-method-entry :type 'standard - :methods-list - (acons :primary (cdr fn-pair) ()) - :combined-method nil)) - (setq counter (1+ counter)))))) - -(defmethod (standard-class :compute-slot-accessor-fn) () - (setf (mcs-get-slot inst-env (index-of-slot-accessor-fn)) - (compile - nil - `(lambda (slot) - (case slot - ,@(let ((slots (mcs-get-slot inst-env (index-of-all-slots))) - (list-of-var-pos-pairs nil) - (counter (index-of-isit))) - (declare (fixnum counter)) - (loop - (if (null slots) (return list-of-var-pos-pairs)) - (setq list-of-var-pos-pairs - (append list-of-var-pos-pairs - (list (cons (pop slots) (list counter))))) - (setq counter (1+ counter))) - list-of-var-pos-pairs) - (t (error "No slot ~S in instances of ." - slot ',(mcs-get-slot inst-env (index-of-name))))))))) - -(defmethod (standard-class :extend-subclasses-of-supers) () - (dolist (super (mcs-get-slot inst-env (index-of-supers))) - (setf (mcs-slot-value super (index-of-subclasses)) - (cons self (mcs-slot-value super (index-of-subclasses))) - ))) - -(defmethod (standard-class :compute-basicnew-fn) (&rest keys) - (let ((key-list (rest (mcs-get-slot inst-env (index-of-all-slots)))) - (slot-list (rest (mcs-get-slot inst-env (index-of-all-slots)))) - (keys+defaults (mcs-get-slot inst-env (index-of-all-slot-defaults)))) - (when keys - (setq key-list keys) - (setq slot-list (mapcar #'(lambda (slot) - (if (member slot key-list :test #'eq) - slot - (second (assoc slot keys+defaults - :test #'eq)))) - slot-list)) - (setq keys+defaults (mapcar #'(lambda (key) - (assoc key keys+defaults :test #'eq)) - key-list))) - (setf (mcs-get-slot inst-env (index-of-basicnew-fn)) - (compile nil - `(lambda (isit &key ,@keys+defaults) - (send-fast - (make-mcsobject - :env (vector isit ,@slot-list)) - :init ,@key-list)))))) - -#| -(defmethod (standard-class :recompute-cplist) () - (setf (mcs-get-slot inst-env (index-of-cplist)) - (send-self :inheritance-algorithm))) - - -(defmethod (standard-class :inheritance-algorithm) () - (labels - ((traverse-node (a_class result) - (if (member a_class result :test #'eq) - result - (cons a_class - (traverse-list - (reverse (mcs-slot-value a_class - (index-of-supers))) - result)) - )) - (traverse-list (r-supers result) - (if (null r-supers) - result - (traverse-list - (rest r-supers) - (traverse-node (first r-supers) result)) - ))) - (cons self - (traverse-list (reverse (mcs-get-slot inst-env (index-of-supers))) - nil)))) -|# - -;;; ------------------------------------------------------------------ -;;; Object protocol methods -;;; ------------------------------------------------------------------ - -(defmethod (standard-object :isit) () - (mcs-get-slot inst-env (index-of-isit))) - -(defmethod (standard-object :class-name) () - (mcs-get-slot class-env (index-of-name))) - -(defmethod (standard-object :class-p) () - (if (member 'supers (get-class-slot 'all-slots) :test #'eq) - t nil)) - -(defmethod (standard-object :metaclass-p) () - (if (and (member 'cplist (get-class-slot 'all-slots) :test #'eq) - (member standard-class (mcs-get-slot inst-env (index-of-cplist)) - :test #'eq)) - t)) - -(defmethod (standard-object :default-handler) (&rest message) - (send-self :error-handler (first message))) - -(defmethod (standard-object :error-handler) (selector) - (error "~S can not handle this message: ~S" - (mcs-get-slot class-env (index-of-name)) selector)) - -(defmethod (standard-object :operation-handled-p) (operation) - (let ((opened (mcs-get-slot class-env (index-of-cplist)))) - (loop - (if (null opened) (return ())) - (let ((a-class (pop opened))) - (if (get-method-entry a-class operation) - (return T)))))) - -(defmethod (standard-object :send-if-handles) (operation &rest arguments) - (let ((opened (mcs-get-slot class-env (index-of-cplist)))) - (loop - (if (null opened) (return ())) - (let ((a-class (pop opened))) - (if (get-method-entry a-class operation) - (return (standard-message-handler self class-env inst-env operation - arguments))))))) - -;; eof - - - - diff --git a/t/baby2015/fmcs/mcs-root.cl b/t/baby2015/fmcs/mcs-root.cl deleted file mode 100644 index 7be266f..0000000 --- a/t/baby2015/fmcs/mcs-root.cl +++ /dev/null @@ -1,115 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Base: 10; Package: FMCS -*- - -(in-package "FMCS") - -;;; -------------------------------------------------------------------------- -;;; Hand coded object standard-class -;;; -------------------------------------------------------------------------- - -(setq STANDARD-CLASS - (make-mcsobject - :env - (vector - 'isit ; :isit will be set below - 'standard-class ; :name - nil ; :supers - nil ; :cplist - '(isit ; :all-slots - name supers cplist all-slots all-slot-defaults own-slots - methods basicnew-fn slot-accessor-fn subclasses) - '((name nil) ; :all-slot-defaults - (supers nil)(cplist nil)(all-slots nil)(all-slot-defaults nil) - (own-slots nil)(methods (make-hash-table :test #'eq)) - (basicnew-fn nil)(slot-accessor-fn nil) (subclasses nil)) - '(name ; :own-slots - supers cplist all-slots all-slot-defaults own-slots - methods basicnew-fn slot-accessor-fn subclasses) - (make-hash-table :test #'eq) ; :methods - ; :basicnew-fn - #'(lambda (isit &key (name nil) (supers nil) (own-slots nil)) - (send-fast - (make-mcsobject - :env - (vector isit name supers nil nil nil own-slots - (make-hash-table :test #'eq) - nil nil nil)) - :init name supers own-slots)) - ; :slot-accessor-fn - #'(lambda (slot) - (case slot - (isit (index-of-isit)) - (name (index-of-name)) - (supers (index-of-supers)) - (cplist (index-of-cplist)) - (all-slots (index-of-all-slots)) - (own-slots (index-of-own-slots)) - (all-slot-defaults (index-of-all-slot-defaults)) - (methods (index-of-methods)) - (basicnew-fn (index-of-basicnew-fn)) - (slot-accessor-fn (index-of-slot-accessor-fn)) - (subclasses (index-of-subclasses)) - (t (error "no slot")))) - nil ; :subclasses - ))) - - -;;; Slot 'isit of standard-class have to be set to itself - -(setf (svref (mcs-env standard-class) (index-of-isit)) standard-class) - - -;;; ---- INSTANCE CREATOR METHOD ---- - -(defmethod (standard-class :new) (&rest inits) - (apply (mcs-get-slot inst-env (index-of-basicnew-fn)) - self inits)) - -;;; ---- INITIALIZE METHOD ---- - -(defmethod (standard-class :init) (&rest inits) - (declare (ignore inits)) - (send-self :compute-cplist) - (send-self :inherit-slots-with-defaults) - (send-self :compute-slot-accessor-fn) - (send-self :extend-subclasses-of-supers) - (send-self :compute-slot-access-methods) - (send-self :compute-basicnew-fn) - self) - - -;;; -------------------------------------------------------------------------- -;;; Hand coded object standard-object -;;; -------------------------------------------------------------------------- - -(setq STANDARD-OBJECT - (make-mcsobject - :env - (vector - standard-class ; :isit - 'standard-object ; :name - nil ; :supers - nil ; :cplist - '(isit) ; :all-slots - nil ; :all-slot-defaults - '(isit) ; :own-slots - (make-hash-table :test #'eq) ; :methods - #'(lambda (isit) ; :basicnew-fn - (send-fast - (make-mcsobject :env (vector isit)) - :init)) - #'(lambda (slot) ; :slot-accessor-fn - (case slot - (isit (index-of-isit)) - (t (error "no slot")))) - (list standard-class) ; :subclasses - ))) - -(setf (slot-value standard-object 'cplist) (list standard-object)) -(setf (slot-value standard-class 'supers) (list standard-object)) -(setf (slot-value standard-class 'cplist) (list standard-class standard-object)) - -;;; ---- INITIALIZE METHOD ---- - -(defmethod (standard-object :init) (&rest inits) - (declare (ignore inits)) - self) diff --git a/t/baby2015/fmcs/mcs-util.cl b/t/baby2015/fmcs/mcs-util.cl deleted file mode 100644 index 2f9cc10..0000000 --- a/t/baby2015/fmcs/mcs-util.cl +++ /dev/null @@ -1,238 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Base: 10; Package: FMCS -*- - -(in-package "FMCS") - -;;; -------------------------------------------------------------------------- -;;; Trace utilities -;;; -------------------------------------------------------------------------- - -(defvar *indent-for-methods-trace* 0.) -(declaim (fixnum *indent-for-methods-trace*)) - -(defun increment-indent-for-methods-trace () - (setq *indent-for-methods-trace* (+ (the fixnum *indent-for-methods-trace*) 2.))) - -(defun decrement-indent-for-methods-trace () - (setq *indent-for-methods-trace* (- (the fixnum *indent-for-methods-trace*) 2.))) - -(defun TRACED-DEMON-COMBINATION - (self class-env inst-env selector applicable-methods args) - (let ((before-methods (before-of applicable-methods)) - (primary-methods (primary-of applicable-methods)) - (after-methods (after-of applicable-methods)) - (class-name (mcs-get-slot class-env (index-of-name))) - (result nil)) - (declare (list before-methods primary-methods after-methods)) - (format *trace-output* "~%~V@T Entering method ~S of class ~S" - (increment-indent-for-methods-trace) selector class-name) - (format *trace-output* "~%~V@T Executing ~S before methods" - *indent-for-methods-trace* (length before-methods)) - (loop - (if (null before-methods) (return ())) - (apply (pop before-methods) - self class-env inst-env args)) - (setq result - (apply (first primary-methods) - self class-env inst-env :primary-caller (rest primary-methods) - args args)) - (format *trace-output* "~%~V@T Executing ~S after methods" - *indent-for-methods-trace* (length after-methods)) - (loop - (if (null after-methods) (return ())) - (apply (pop after-methods) - self class-env inst-env args)) - (format *trace-output* "~%~V@T Exiting method ~S of class ~S with result: ~S" - *indent-for-methods-trace* selector class-name result) - (decrement-indent-for-methods-trace) - result)) - -(defun TRACED-SIMPLE-COMBINATION - (self class-env inst-env selector applicable-methods args) - (let ((primary-methods (primary-of applicable-methods)) - (class-name (mcs-get-slot class-env (index-of-name))) - result) - (increment-indent-for-methods-trace) - (format *trace-output* "~%~V@T Entering method ~S of class ~S" - *indent-for-methods-trace* selector class-name) - (setq result - (apply (first primary-methods) - self class-env inst-env :primary-caller (rest primary-methods) - args args)) - (format *trace-output* "~%~V@T Exiting method ~S of class ~S with result: ~S" - *indent-for-methods-trace* selector class-name result) - (decrement-indent-for-methods-trace) - result)) - - -;;;(export 'MCS-TRACE) -(defun MCS-TRACE (a_class selector) - (let* ((class-env (mcs-env a_class)) - (combined-method (get-combined-method selector))) - (if combined-method - (let ((combination-fn (svref combined-method 0))) - (setf (svref combined-method 0) - (case combination-fn - (simple-method-combination 'traced-simple-combination) - (demon-method-combination 'traced-demon-combination) - (standard-method-combination 'traced-standard-combination) - (t combination-fn)))) - (progn - (combine-class-method a_class selector) - (if (get-combined-method selector) - (mcs-trace a_class selector)))))) - -;;;(export 'MCS-UNTRACE) -(defun MCS-UNTRACE (a_class selector) - (let* ((class-env (mcs-env a_class)) - (combined-method (get-combined-method selector))) - (if combined-method - (let ((combination-fn (svref combined-method 0))) - (setf (svref combined-method 0) - (case combination-fn - (traced-simple-combination 'simple-method-combination) - (traced-demon-combination 'demon-method-combination) - (traced-standard-combination 'standard-method-combination) - (t combination-fn) - )) - )))) - -;;;(export 'MCS-IS-TRACED) -(defun MCS-IS-TRACED (a_class selector) - (let* ((class-env (mcs-env a_class)) - (combined-method (get-combined-method selector))) - (if combined-method - (case (svref combined-method 0) - (traced-simple-combination t) - (traced-demon-combination t) - (traced-standard-combination t) - (t nil))))) - -(defmethod (standard-class :trace-methods) (&rest selectors) - (dolist (selector selectors 'done) - (mcs-trace self selector))) - -(defmethod (standard-class :untrace-methods) (&rest selectors) - (dolist (selector selectors 'done) - (mcs-untrace self selector))) - - -;;; -------------------------------------------------------------------------- -;;; Protocol utilities -;;; -------------------------------------------------------------------------- - -(defmethod (standard-class :get-local-protocol) () - (let ((protocol ())) - (maphash #'(lambda (key val) - (if (method-entry-methods-list val) - (setq protocol (cons key protocol)))) - (mcs-get-slot inst-env (index-of-methods))) - protocol)) - -(defmethod (standard-class :get-protocol) () - (let ((protocol ()) - (opened (mcs-get-slot inst-env (index-of-cplist)))) - (loop - (if (null opened) (return ())) - (maphash #'(lambda (key val) - (declare (ignore val)) - (setq protocol (cons key protocol))) - (mcs-slot-value (pop opened) (index-of-methods)))) - (remove-duplicates protocol :test #'eq))) - -;;; -------------------------------------------------------------------------- -;;; Other utilities -;;; -------------------------------------------------------------------------- - - -(defun WHERE-METHOD-LOOKUP (class-env a_selector) - (declare (inline GET-METHOD-ENTRY)) - (let ((r-class-precedence-list - (reverse (mcs-get-slot class-env (index-of-cplist)))) - (around-methods nil) (before-methods nil) - (primary-methods nil) (after-methods nil)) - (loop - (if (null r-class-precedence-list) - (return - (values (if primary-methods - (if around-methods - 'standard-method-combination - (if (or before-methods after-methods) - 'demon-method-combination - 'simple-method-combination)) - (if (or after-methods before-methods around-methods) - 'missing-primary-method)) - (list around-methods before-methods - primary-methods (reverse after-methods))))) - (let* ((c-class (pop r-class-precedence-list)) - (method (get-method-entry c-class a_selector))) - (if method - (let ((own-methods-list (method-entry-methods-list method))) - (let ((around-method (get-qualified-method :around own-methods-list)) - (before-method (get-qualified-method :before own-methods-list)) - (primary-method (get-qualified-method :primary own-methods-list)) - (after-method (get-qualified-method :after own-methods-list)) - (c-class-name (slot-value c-class 'name))) - (if before-method - (setq before-methods (cons c-class-name before-methods))) - (if after-method - (setq after-methods (cons c-class-name after-methods))) - (if primary-method - (setq primary-methods (cons c-class-name primary-methods))) - (if around-method - (setq around-methods (cons c-class-name around-methods))))))) - ))) - -(defmethod (standard-object :how-combined) (selector) - (multiple-value-bind - (method-combination-fn where-defined-list) - (where-method-lookup class-env selector) - (if (null method-combination-fn) - (progn - (format t "~%no method, :default-handler is called") - (send-self :how-combined :default-handler)) - (progn - (if (eq method-combination-fn 'missing-primary-method) - (format t "~%illegal combination, missing primary method") - (format t "~%selector ~S has combination type: ~S" - selector method-combination-fn)) - (if (first where-defined-list) - (format t "~%around methods are defined in class: ~{~% ~s ~}" - (first where-defined-list))) - (if (second where-defined-list) - (format t "~%before methods are defined in class: ~{~% ~s ~}" - (second where-defined-list))) - (if (third where-defined-list) - (format t "~%primary methods are defined in class: ~{~% ~s ~}" - (third where-defined-list))) - (if (fourth where-defined-list) - (format t "~%after methods are defined in class: ~{~% ~s ~}" - (fourth where-defined-list))))))) - - -(defmethod (standard-object :which-operations) () - (send-fast (get-slot 'isit) :get-protocol)) - -(defmethod (standard-object :describe) () - (format t "~&~S, an object of class ~S,~% has instance variable values:~%" - self (get-class-slot 'name)) - (dolist (ivar (get-class-slot 'all-slots)) - (format t "~% ~S:~27T~S" ivar (slot-value self ivar)))) - -(defmethod (standard-object :describe-short) () - (format t "an object of class ~S with instance variable values:~%~S" - (get-class-slot 'name) - (rest (mapcar #'(lambda (ivar) - `(,ivar ,(slot-value self ivar))) - (get-class-slot 'all-slots))))) - -(defmethod (standard-object :apropos) (substring) - (remove nil - (mapcar #'(lambda (method) - (if (search substring (string method) - :test #'char-equal) method)) - (send-fast (get-slot 'isit) :get-protocol)) - :test #'eq)) - - -;;; eof - diff --git a/t/baby2015/kernel/babtrans.cl b/t/baby2015/kernel/babtrans.cl deleted file mode 100644 index 8e2981e..0000000 --- a/t/baby2015/kernel/babtrans.cl +++ /dev/null @@ -1,66 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: BABYLON -*- - -(in-package "BABYLON") - -;; Copyright 1988 BY -;; G M D -;; Postfach 1240 -;; D-5205 St. Augustin -;; FRG - - -;; AUTHORS: J.Walther, E. Gross -;; DATE: April 1994, June 1988 - - -;; complete the following list in your load file -;; by setting "babhome^" z.B. -;; (defbabylon-translation "babhome^" "babylon>" "babhome^bin>") -;; and adding names for interface-modules - -;;------------------------------------------------------------------------ -;; logical pathnames -;;------------------------------------------------------------------------ - -(defbabylon-translation "kernel^" "babhome^kernel>") - -(defbabylon-translation "common^" "kernel^common>") -(defbabylon-translation "meta^" "kernel^meta>") - -(defbabylon-translation "freetext^" "kernel^freetext>") -(defbabylon-translation "frames^" "kernel^frames>") -(defbabylon-translation "consat^" "kernel^consat>") -(defbabylon-translation "rules^" "kernel^rules>") -(defbabylon-translation "prolog^" "kernel^prolog>") - -(defbabylon-translation "modules^" "kernel^modules>") -(defbabylon-translation "patches^" "kernel^patches>") - -(defbabylon-translation "samples^" "babhome^samples>") -(defbabylon-translation "configs^" "samples^configs>") -(defbabylon-translation "axsets^" "samples^axsets>") -(defbabylon-translation "kbs^" "samples^kbs>") - -;;------------------------------------------------------------------------ -;; short names for modules -;;------------------------------------------------------------------------ - -(defbabylon-translation "free-text-mixin" "freetext") - -(defbabylon-translation "basic-frame-mixin" "b-frame") -(defbabylon-translation "mini-frame-mixin" "m-frame") -(defbabylon-translation "normal-frame-mixin" "n-frame") - -(defbabylon-translation "basic-constraint-mixin" "b-consat") -(defbabylon-translation "mini-constraint-mixin" "m-consat") -(defbabylon-translation "normal-constraint-mixin" "n-consat") - -(defbabylon-translation "basic-rule-mixin" "b-rule") -(defbabylon-translation "mini-rule-mixin" "m-rule") -(defbabylon-translation "normal-rule-mixin" "n-rule") - -(defbabylon-translation "basic-prolog-mixin" "b-prolog") -(defbabylon-translation "mini-prolog-mixin" "m-prolog") -(defbabylon-translation "normal-prolog-mixin" "n-prolog") - -;;; eof diff --git a/t/baby2015/kernel/common/c-fns.cl b/t/baby2015/kernel/common/c-fns.cl deleted file mode 100644 index a2713f4..0000000 --- a/t/baby2015/kernel/common/c-fns.cl +++ /dev/null @@ -1,258 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Base: 10; Package: BABYLON -*- - -(in-package "BABYLON") - -;; Copyright 1986, 1985 and 1984 BY -;; G M D -;; Postfach 1240 -;; D-5205 St. Augustin -;; FRG - -(unless (fboundp 'neq) - (defun neq (o1 o2) - (not (eq o1 o2)))) - -;; AUTHOR: Juergen Walther, Erich Rome, Franco di Primio - - -;;----------------------------------------------------------------- -;; all the string-handling stuff -;;----------------------------------------------------------------- - -; Defined in file global-variables -;(defvar *language* 'engl) - -(defmacro defbabylon-table (name lang &rest options) - `(unless (typep (get ',name ',lang) 'hash-table) - (setf (get ',name ',lang) (make-hash-table ,@options)))) - -(defmacro defbabylon-entry (key table lang value) - `(let ((*language* ',lang)) - (setf (gethash ',key (get ',table ',lang)) ,value))) - -(defmacro getentry (key table) - `(values (gethash ',key (get ',table *language*)))) - - -(defmacro getentry2 (key table) - `(quote ,(gethash key (get table *language*)))) - -(defmacro is-entry (key table) - `(multiple-value-bind (value sw z) - (gethash ',key (get ',table *language*)) - (declare (ignore value z)) - sw)) - -;(defmacro get-string (key table) -; `(gethash ',key ,table)) - -;;----------------------------------------------------------------- - -(defun send-kb (selector &rest args) - (lexpr-$send *current-knowledge-base* selector args)) - -(defun send-current-knowledge-base (selector &rest args) - (lexpr-$send *current-knowledge-base* selector args)) - -(defun send-bab (selector &rest args) - (lexpr-$send *babylon* selector args)) - -(defun send-babylon (selector &rest args) - (lexpr-$send *babylon* selector args)) - -(defun current-p (kb) - (eq kb *current-knowledge-base*)) - -(defun current-kb-typep (flavor-type &optional string) - (cond ((flavor-typep *current-knowledge-base* flavor-type)) - (*current-knowledge-base* - (format *default-dialog-stream* "~%=> ~A" - (or string (getentry kb-of-wrong-type-str babylon-io-table)))) - (t (format *default-dialog-stream* "~%=>~A" - (getentry none-kb-current-str babylon-io-table))))) - - -;;----------------------------------------------------------------- -;; -;;----------------------------------------------------------------- - -;;(defrequest frame-reference :recall :eval-frame-reference ....) - -(defmacro defrequest (name &rest plist) - "Defines methods to be used for a request type." - `(do ((rlist ',plist (rest (rest rlist)))) - ((null rlist) ',name) - (setf (get ',name (first rlist)) (second rlist)))) - -(defmacro assign-typefkt (fkt mixin) - "Assigns a type predicate to the processor mixin." - `(setf (get ,mixin :typefkt) ,fkt)) - - -;;----------------------------------------------------------------- -;; -;;----------------------------------------------------------------- - - -(defun make-blanks (nr) - (if (< nr 1) - "" - (make-sequence 'string nr :initial-element #\space))) - - -(defun make-string-of-length (nr &optional (z #\space)) - (declare (fixnum nr)) - (if (< nr 1) - "" - (make-sequence 'string nr :initial-element (character z)))) - - -(defun complete-to-n (str nr) - "verlaengert str um nr blanks bzw. kuerzt str um nr+3" - (declare (fixnum nr) (simple-string str)) - (if (< nr 0) - (concatenate 'string (subseq str 0 (+ (length str) nr -3)) "...") - (concatenate 'string str (make-sequence 'string nr :initial-element #\space)))) - - - -;;----------------------------------------------------------------- - -(defun is-simple-list (l) - (and (listp l) - (every 'atom l))) - - -(defun is-true-list (x) - (and (not (atom x)) - (null (cdr (last x))))) - - -(defun from-list-to-string (list) - (let ((*print-pretty* nil)) - (format nil "~S" list))) - - -(defun remove-doubles (list &optional result) - (cond ((null list) (nreverse result)) - ((member (first list) result :test 'equal) - (remove-doubles (rest list) result)) - (t (remove-doubles (rest list) (cons (first list) result))))) - - -;;----------------------------------------------------------------- - -; -;(defmacro declare-lisp-fns (&rest fns) -; `(mapc #'(lambda (fn) -; (setf (get fn 'LISP) t)) -; ',fns)) -; -;(defmacro undeclare-lisp-fns (&rest fns) -; `(mapc #'(lambda (fn) -; (remprop fn 'LISP)) -; ',fns)) -; -;(declare-lisp-fns stop-execution stop-kb-execution ask-for -; say find-implications test-hypotheses obtain) - -(defmacro lisp (&rest formlist) - `(progn . ,formlist)) - -;;----------------------------------------------------------------- - -(defun make-multiple-value (x) - (cond ((atom x) x) - ((null (cdr x)) (first x)) - (t `(:MULTIPLE-VALUE . ,x)))) - -(defun make-multiple-answer (x) - (cond ((atom x) x) - ((null (cdr x)) (first x)) - (t `(:MULTIPLE-VALUE . ,x)))) - -(defun is-multiple-value (x) - (and (listp x) (eq (first x) :MULTIPLE-VALUE))) - -(defun is-multiple-answer (x) - (and (listp x) (eq (first x) :MULTIPLE-VALUE))) - -;;----------------------------------------------------------------- - -(defun compute-term (term) - (if (is-negated-term term) - (get-positive-term term) - term)) - -(defun is-negated-term (term) - (and (listp term) (eq (first term) 'NOT))) - -(defun get-positive-term (negated-term) - (second negated-term)) - -(defun get-negation (term) - (first term)) - -;;----------------------------------------------------------------- - -(defun undetermined () - "initial content of :value facet (localstate)" - '-) - -(defun undetermined-2 () - "for use in rules" - '(UNDETERMINED UNBESTIMMT)) - - -(defun is-undetermined (x) - (or (eq x (undetermined)) - (member x (undetermined-2)))) - -(defun unknown () - "standard possible answer of USER" - 'UNKNOWN) - -(defun unknown-2 () - '(UNBEKANNT)) - -(defun is-unknown (x) - (or (eq x (UNKNOWN)) - (member x (unknown-2)))) - -(defun is-help (x) - (eq x 'HELP)) - -;;------------------------------------------------------------------------------- - -(defun is-variable (x) - (and (symbolp x) - (char-equal (aref (string x) 0) #\_))) - -(defun contains-vars (exp) - "Yields true if is resp. contains a prolog variable." - (cond ((is-variable exp) t) - ((atom exp) nil) - ((contains-vars (car exp)) t) - ((contains-vars (cdr exp)) t) - (t nil))) - -;;-------------------------------------------------------------------------------- - -(defun say (string &rest args) - (lexpr-$send *current-knowledge-base* :babylon-format string args)) - -;;-------------------------------------------------------------------------------- - -;; normalize-answer -;; --------------- - -(defun normalize-answer (answer) - (or (cdr (assoc answer (getentry possible-answers babylon-io-table))) - answer)) - -(defun translate-answer (answer) - (or (car (rassoc answer (getentry possible-answers babylon-io-table))) - answer)) - -;;; eof - diff --git a/t/baby2015/kernel/common/p-core.cl b/t/baby2015/kernel/common/p-core.cl deleted file mode 100644 index a9916c3..0000000 --- a/t/baby2015/kernel/common/p-core.cl +++ /dev/null @@ -1,27 +0,0 @@ -;;; -*- Mode: Lisp; Base:10; Syntax: Common-Lisp; Package: BABYLON -*- - -(in-package "BABYLON") - -;; Copyright 1986, 1985 and 1984 BY -;; G M D -;; Postfach 1240 -;; D-5205 St. Augustin -;; FRG - - -;; AUTHOR: J. W A L T H E R, E. G R O S S - -(def$flavor processor-core - ((meta-processor nil) - (alternate-meta-processor nil)) - () - :settable-instance-variables - (:documentation "This is the standard processor-core flavor. -It provides the interface to the meta-processor or meta-processor-stub.")) - -(def$method (processor-core :switch-mode) () - "Switch between standalone and integrated application of the processor." - (let ((temp alternate-meta-processor)) - (when temp - (setf alternate-meta-processor meta-processor) - (setf meta-processor temp)))) diff --git a/t/baby2015/kernel/common/vars.cl b/t/baby2015/kernel/common/vars.cl deleted file mode 100644 index 8fabdd6..0000000 --- a/t/baby2015/kernel/common/vars.cl +++ /dev/null @@ -1,97 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: BABYLON -*- - -(in-package "BABYLON") - -(defvar *babylon-version* "2.3") - -(defvar *babylon* nil) - -(defvar *current-knowledge-base* nil) - -(defvar *language* 'english) - -(defvar *known-knowledge-bases* nil) - - - -(defvar *axiom-sets* nil) ;from prolog-processor - -(defvar *maxvar* 0) - -(defvar *prolog-syspreds* nil) - -(defvar *prolog-preds-traced* nil) - - - -(defvar *font-menu* nil) ;from interface - ; muss bleiben, da auch im autonomen - ; tree editor verwendet. er -(defvar *first-ped-interface-call* t) - -(defvar *current-ted* nil ;from ted-interface - "the unique current tree editor which can ~@ - be controlled via function calls in a lisp listener.") - - -; -;(defvar *crashing-item* nil) ;from frame-constraints -; -;(defvar *relations-for-create-rule* nil) ;from frame-processor - - - -(defvar *meta-preds* - '(not call and or)) - -(defvar *frame-meta-predicates* - '(frame frame-def super has-super instance instance-def has-slot slot - has-property property)) - -(defvar *free-text-meta-predicates* - '(free-text)) - -(defvar *rule-meta-predicates* - '(rule-set rule-set-def has-rule rule)) - -(defvar *prolog-junctor-for-rules* - '(and or)) - - - - -;;---------------------------------------------------------------------------------------- - - -(defvar *default-language* 'english) - -(defvar *default-procs* - '(mini-frame-mixin - mini-rule-mixin - mini-prolog-mixin - free-text-mixin - lisp-mixin)) - -(defvar *default-interface* '(mini-interface-mixin)) - -(defvar *default-kb-configuration* 'mini-frplx-mini) - - -(defvar *default-dialog-stream* *standard-output*) - -(defvar *help-key* #\?) - -(defvar *c-help-key* #\$) - -(defvar *end-key* #\return) - -(defvar *bab-prompt* "===>") - -(defvar *var-prefix* #\_) - -(defvar *max-menu-entries* 20) - -(defvar *item-width* 50) - -;;; eof - diff --git a/t/baby2015/kernel/consat/basic/bc-fns.cl b/t/baby2015/kernel/consat/basic/bc-fns.cl deleted file mode 100644 index 0b5981a..0000000 --- a/t/baby2015/kernel/consat/basic/bc-fns.cl +++ /dev/null @@ -1,500 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-lisp; Package: BABYLON; Base: 10 -*- - -(in-package "BABYLON") - -; MAKROS FUER ASSOZIATIONSLISTEN -; - - -; -; value association: -; -; ( . ) -; -; mit ::= list( ) | unconstrained -; - - -(defmacro make-value-assoc (var value-spec) - `(cons ,var ,value-spec)) - -(defmacro get-var (value-assoc) - `(car ,value-assoc)) - -(defmacro get-value-spec (value-assoc) - `(cdr ,value-assoc)) - - -; -; simple value association: -; -; ( ) -; -; mit ::= | unconstrained - -(defmacro make-simple-val-assoc (var value) - `(list ,var ,value)) - -(defmacro get-simple-value (simple-value-assoc) - `(second ,simple-value-assoc)) - - - - -(defstruct (var-info) - (constraints nil) - (values 'unconstrained) - (init-values 'unconstrained)) - - - - -; -; variable association: -; -; ( . ) -; - -(defmacro make-var-assoc (local global) - `(cons ,local ,global)) - -(defmacro get-local-var (var-assoc) - `(car ,var-assoc)) - -(defmacro get-global-var (var-assoc) - `(cdr ,var-assoc)) - - -; -; constraint-expression: -; -; ( . list( ) ) -; - -(defmacro make-c-expr (c-name var-alist) - `(cons ,c-name ,var-alist)) - -(defmacro get-constr-name (c-expr) - `(car ,c-expr)) - -(defmacro get-parameters (c-expr) - `(cdr ,c-expr)) - - -; -; trace-element: Ergebnis einer Constraint-Aktivierung -; -; ( list( ) ) -; - -(defmacro make-trace-elem (c-expr value-alist) - `(list ,c-expr ,value-alist)) - -(defmacro get-trace-constr (trace-elem) - `(first ,trace-elem)) - -(defmacro get-trace-value-ass (trace-elem) - `(second ,trace-elem)) - - - -; -; constraint-association: Zuordnung Name zu Constraint -; -; ( . ) -; - -(defmacro make-constraint-assoc (name constraint) - `(cons ,name ,constraint)) - -(defmacro get-name-of-c-assoc (constraint-assoc) - `(car ,constraint-assoc)) - -(defmacro get-object-of-c-assoc (constraint-assoc) - `(cdr ,constraint-assoc)) - - - -; -; LISTEN MIT WERT-ZUWEISUNGEN -; -; -; Die folgenden Funktionen fuehren Operationen auf -; Assoziationslisten durch, die Wertzuweisungen an -; Variablen beschreiben. -; -; Dabei treten folgende Typen von Listen auf: -; -; ::= list( ( ) ) -; ::= unconstrained | -; ::= list( . ) -; ::= unconstrained | list( ) -; - - -(defun select-some-value-ass (list-of-value-ass number-of-results - &optional (new-list-of-value-ass nil)) - - ;;; falls number-of-results nicht nil ist, werden die ersten - ;;; number-of-results verschiedenen Wertebelegungen aus - ;;; list-of-value-ass zurueckgeliefert - - (cond ((null list-of-value-ass) - (reverse new-list-of-value-ass)) - ((enough-results number-of-results) - (reverse new-list-of-value-ass)) - ((member (first list-of-value-ass) - new-list-of-value-ass - :test 'equal) - (select-some-value-ass (rest list-of-value-ass) - number-of-results - new-list-of-value-ass)) - (t (select-some-value-ass (rest list-of-value-ass) - (decr-number-of-results number-of-results) - (cons (first list-of-value-ass) - new-list-of-value-ass))))) - - -(defun enough-results (number-of-results) - (and (not (null number-of-results)) - (<= number-of-results 0))) - - -(defun decr-number-of-results (number-of-results) - (if (null number-of-results) - nil - (1- number-of-results))) - - -(defun convert-simple-to-multiple (simple-val-ass) - - ;;; erzeugt aus einer simplen Wertzuweisung eine multiple, - ;;; in dem (var unconstrained) durch (var . unconstrained) ersetzt wird - - (mapcar (function - (lambda (simple-val-assoc) - (if (eq (get-simple-value simple-val-assoc) - 'unconstrained) - (make-value-assoc - (get-var simple-val-assoc) - 'unconstrained) - simple-val-assoc))) - simple-val-ass)) - - -(defun empty-alist (variables) - - ;;; erzeugt eine Wertzuweisung fuer die angegebenen Variablen; - ;;; jede Variable in variables erhaelt als wert die leere Menge - - (mapcar (function - (lambda (var) - (make-value-assoc var nil))) - variables)) - - -(defun adjust-value-ass (variables value-ass) - - ;;; ermittelt eine Wertebelegung der Variablen in variables; - ;;; falls value-ass der Variablen v eine Wertemenge zuordnet, - ;;; wird diese als Wert fuer v gewaehlt; - ;;; ansonsten wird mit unconstrained vorbesetzt - - (if (null variables) - nil - (cons (make-value-assoc - (first variables) - (let ((value-assoc (assoc (first variables) - value-ass - :test 'equal))) - (if (null value-assoc) - 'unconstrained - (get-value-spec value-assoc)))) - (adjust-value-ass - (rest variables) - value-ass)))) - - -(defun some-new-restrictions-p (val-ass1 val-ass2) - - ;;; t, falls es eine Variable gibt, deren Wertemenge in val-ass2 durch - ;;; die Wertemenge in val-ass1 staerker eingeschraenkt wird - - (if (null val-ass1) nil - (let ((val-assoc2 (assoc (get-var (first val-ass1)) - val-ass2 - :test 'equal))) - (if (and val-assoc2 - (more-constrained-p - (get-value-spec (first val-ass1)) - (get-value-spec val-assoc2))) - t - (some-new-restrictions-p - (rest val-ass1) - val-ass2))))) - - -; -; VEREINIGUNG VON LISTEN MIT WERTZUWEISUNGEN -; - - -(defun combine-variable-alists (list-of-val-ass variables) - - ;;; Eingabe: eine Liste multipler Wertzuweisungen - ;;; - ;;; Ausgabe: eine multiple Wertzuweisung, die die Vereinigung - ;;; der eingegebenen Wertzuweisungen dastellt - - (if (null list-of-val-ass) - (empty-alist variables) - (combine-two-alists - (first list-of-val-ass) - (combine-variable-alists - (rest list-of-val-ass) - variables)))) - - -(defun combine-two-alists (val-ass1 val-ass2) - - ;;; Eingabe: Zwei multiple Wertzuweisungen val-ass1, val-ass2 - ;;; - ;;; Ausgabe: Neues multiple-value-assignment, die eine Vereinigung - ;;; von val-ass1 und val-ass2 darstellt; - ;;; dabei werden Wertemengen doppelt auftretender Variablen - ;;; zu einer vereinigt - - (cond ((null val-ass1) val-ass2) - ((null val-ass2) val-ass1) - (t (mapcar (function - (lambda (variable) - (make-value-assoc - variable - (combine-values - (get-value-spec (assoc variable val-ass1 - :test 'equal)) - (get-value-spec (assoc variable val-ass2 - :test 'equal)))))) - (union-sets (mapcar (function - (lambda (val-assoc) - (get-var val-assoc))) - val-ass1) - (mapcar (function - (lambda (val-assoc) - (get-var val-assoc))) - val-ass2)))))) - - -(defun combine-values (value-set1 value-set2) - - ;;; vereinigt zwei Wertemengen, wobei zu beachten ist, - ;;; dass unconstrained eine allgemeine Obermenge darstellt - - (if (or (eq value-set1 'unconstrained) - (eq value-set2 'unconstrained)) - 'unconstrained - (union-sets value-set1 value-set2))) - - -(defun cons-if-not-nil (x y) - (if (null x) y - (cons x y))) - - -; -; KREUZPRODUKT BILDEN -; - - -(defun split-variable-alist (val-ass) - - ;;; Eingabe: multiple-value-assignment val-ass - ;;; - ;;; Ausgabe: bildet die Menge aller eindeutigen (bis auf unconstrained) - ;;; Wertezuordnungen gemaess val-ass - ;;; (es wird im Prinzip das Kreuzprodukt der einzelnen - ;;; Wertemengen gebildet); - ;;; das Ergebnis ist eine Liste von value-assignments - ;;; - - (if (null val-ass) - (list nil) - (split-and-put-association - (first val-ass) - (split-variable-alist - (rest val-ass))))) - - -(defun split-and-put-association (value-assoc list-of-val-ass) - - ;;; Eingabe: Wert/Variable-Assoziation (v . (w1 w2 ... wn)) - ;;; Liste von value-assignments (l1 l2 ... lm), - ;;; in denen v nicht vorkommt - ;;; - ;;; Ausgabe: Liste von value-assignments - ;;; - ;;; (((v.w1).l1) ((v.w1).l2) ... ((v.w1).lm) - ;;; ... - ;;; ((v.wn).l1) ((v.wn).l2) ... ((v.wn).lm)) - - (cond ((eq (get-value-spec value-assoc) - 'unconstrained) - (mapcar (function - (lambda (simple-val-ass) - (cons (make-simple-val-assoc - (get-var value-assoc) - 'unconstrained) - simple-val-ass))) - list-of-val-ass)) - - ((member 'unconstrained - (get-value-spec value-assoc)) - (baberror (getentry wrong-unconstrained constraint-io-table) - value-assoc)) - - (t (mapcan (function - (lambda (value) - (mapcar (function - (lambda (simple-val-ass) - (cons (make-simple-val-assoc - (get-var value-assoc) - value) - simple-val-ass))) - list-of-val-ass))) - (get-value-spec value-assoc))))) - - - -; -; BEHANDLUNG VON WERTEMENGEN -; - - -(defun more-constrained-p (value-spec1 value-spec2) - - ;;; t, falls value-spec2 durch value-spec1 staerker eingeschraenkt wird - - (cond ((eq value-spec1 'unconstrained) nil) - ((eq value-spec2 'unconstrained) t) - ((not (difference-empty-p value-spec2 value-spec1))))) - - -(defun new-association (variable value) - - ;;; erzeugt neue Variable-Wert-Assoziation unter besonderer - ;;; Beachtung von 'unconstrained - - (make-value-assoc - variable - (if (eq value 'unconstrained) - value - (list value)))) - - -(defun compatible-value-p (value variable simple-val-ass) - - ;;; t, falls value Wert von variable in val-ass ist - - (let ((ass-value (get-simple-value - (assoc variable simple-val-ass - :test 'equal)))) - (or (equal ass-value 'unconstrained) - (equal ass-value value)))) - - - -; -; MENGEN -; - - -;(defun remove-duplicates (liste) -; -; ;;; entfernt alle Duplikate -; -; (cond ((null liste) nil) -; ((member (car liste) (cdr liste) :test 'equal) -; (remove-duplicates (cdr liste))) -; (t (cons (car liste) -; (remove-duplicates (cdr liste)))))) - - -(defun union-sets (set1 set2) - - ;;; vereinigt zwei Mengen mit beliebigen Elementen - ;;; (Zetalisp-union benutzt nur eq zum Elementvergleich) - - (union set1 set2 :test 'equal)) - - -(defun intersect-sets (set1 set2) - - ;;; bildet die Schnittmenge zweier Mengen mit - ;;; beliebigen Elementen (intersection benutzt dagegen eq !) - - (intersection set1 set2 :test 'equal)) - - -(defun difference-empty-p (set1 set2) - - ;;; berechnet set1 \ set2 = 0 - - (null (set-difference set1 set2 :test 'equal))) - - -; -; MENGENOPERATIONEN UNTER BERUECKSICHTIGUNG VON UNCONSTRAINED -; - - -(defun extended-intersection (value-spec1 value-spec2) - - ;;; bildet die Schnittmenge von value-spec1 und value-spec2 - ;;; unter Beruecksichtigung von 'unconstrained - - (cond ((eq value-spec1 'unconstrained) value-spec2) - ((eq value-spec2 'unconstrained) value-spec1) - (t (intersect-sets value-spec1 value-spec2)))) - - -(defun extended-member (value value-spec) - - (or (eq value-spec 'unconstrained) - (member value value-spec :test 'equal))) - - -; -; macros fuer Relationen-Element -; - - -(defmacro get-keyword (rel-elem) - `(first ,rel-elem)) - -(defmacro get-tupel (rel-elem) - `(second ,rel-elem)) - -(defmacro get-expressions (rel-elem) - `(second ,rel-elem)) - -(defmacro get-condition (rel-elem) - `(fourth ,rel-elem)) - - -(defun send-constraint-processor (selector &rest args) - "sendet Nachricht an aktuellen Constraint-Processor" - (lexpr-$send (send-kb :constraint-processor) selector args)) - -(defun get-constraint (constraint-name) - " ermittelt das zugehoerige primitive oder - zusammengesetzte Constraint - liefert Fehlermeldung, falls Constraint nicht definiert ist" - (let ((constraint (send-constraint-processor :get constraint-name))) - (if (null constraint) - (baberror (getentry unknown-constraint constraint-io-table) - constraint-name) - constraint))) - - -;;; eof - diff --git a/t/baby2015/kernel/consat/basic/bc-mixin.cl b/t/baby2015/kernel/consat/basic/bc-mixin.cl deleted file mode 100644 index 75c5f4d..0000000 --- a/t/baby2015/kernel/consat/basic/bc-mixin.cl +++ /dev/null @@ -1,512 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: BABYLON; Base: 10 -*- - - -(in-package "BABYLON") - -; -; CONSTRAINT-MIXIN -; - -(defun choose-special-constraint (constraint-liste) - - "bittet den Benutzer, eines der Constraints in Constraint-Liste auszuwaehlen." - - (constraint-input-test - (send-kb :choose-from-menu - (append - (getentry do-nothing-items constraint-io-table) - (mapcar (function - (lambda (constraint-assoc) - (list (get-name-of-c-assoc constraint-assoc) - :value constraint-assoc))) - constraint-liste)) - (getentry choose-name constraint-io-table)))) - - -(defun constraint-input-test (expr) - - "Abbruch, falls expr gleich nil ist" - - (if (null expr) - (throw 'no-select nil) - expr)) - - -(defun transform-constraint-type (constraint-type) - - (case constraint-type - (primitive :constraints) - (compound :constraint-nets))) - - -(defun read-expr-from-window (text) - (let ((input (send-kb :prompt-for-input text))) - (declare (simple-string input)) - (if (= (length input) 0) - (read-expr-from-window text) - (read-from-string input)))) - - -;;; - -(def$flavor basic-constraint-mixin - (constraint-processor) - (constraint-base) - - :settable-instance-variables - (:required-instance-variables procs kb-name) - (:documentation "Anteil des Constraint-Systems am Metaprozessor") - ) - - -(def$method (basic-constraint-mixin :after :init) (&rest plist) - - "wird nach dem Erzeugen eines Metaprozessors aufgerufen: - erzeugt einen zugehoerigen Constraint-Prozessor - und kettet ihn an den Metaprozessor" - - (declare (ignore plist)) - ($send self :generate-constraint-processor) - (setf procs (cons constraint-processor procs))) - - -(def$method (basic-constraint-mixin :generate-constraint-processor) () - - "erzeugt einen Constraint-Prozessor" - - (setf constraint-processor - (make-$instance 'basic-constraint-processor - :meta-processor self))) - - -(def$method (basic-constraint-mixin :set-up-constraint-cmds) () - (let ((table (get 'cmd-table ($send self :language)))) - (when (and table ($send self :operation-handled-p :add-operations)) - ($send self :add-sub-operations - :top (gethash 'consat table) - :consat (gethash 'consat-commands table))))) - - - -(def$method (basic-constraint-mixin :after :new&delete) (&rest ignore) - - "runterreichen der definierten Constraints" - - (declare (ignore ignore)) - ($send constraint-processor :set-constraints constraints) - ($send constraint-processor :set-constraint-nets constraint-nets)) - -; -; FESTLEGUNG DER KONSTRUKTE -; -; -; -; - Constraint Aktivierung -; -; (activate ) | -; (activate with -; = -; ... -; = ) -; -; - Konsistenztest -; -; (consistent-p ) | -; (consistent-p with -; = -; ... -; = ) - - -(defmacro constraint-type (expression) - - "ermittelt den Typ von expression und fuehrt einen Syntaxtest durch" - - `(if (atom ,expression) nil - (case (car ,expression) - (satisfy - 'satisfy-request) - (satisfied-p - 'satisfied-p-request) - (t nil)))) - - -(assign-typefkt 'constraint-type 'basic-constraint-mixin) - - -(defrequest satisfy-request - :lisp :eval-satisfy - :recall :eval-satisfy) - - -(defrequest satisfied-p-request - :lisp :eval-satisfied-p - :recall :eval-satisfied-p - :prolog :eval-satisfied-p) - - -(def$method (basic-constraint-mixin :eval-satisfy) (expression &rest ignore) - - (declare (ignore ignore)) - ($send constraint-processor - :satisfy - (remove-request-key expression))) - - -(def$method (basic-constraint-mixin :eval-satisfied-p) (expression &rest ignore) - - (declare (ignore ignore)) - ($send constraint-processor - :satisfied-p - (remove-request-key expression))) - - -(defun remove-request-key (expression) - (rest expression)) - - -; -; LISP-SCHNITTSTELLE -; - - -(defmacro satisfy (&rest expression) - - "ermoeglicht Verwendung von Satisfy-Konstrukten in Lisp-Ausdruecken" - - `(send-kb :eval - '(satisfy . ,expression) - :lisp - 'lisp-processor)) - - -(defmacro satisfied-p (&rest expression) - - "ermoeglicht Verwendung von Satisfied-p-Konstrukten in Lisp-Ausdruecken" - - `(send-kb :eval - '(satisfied-p . ,expression) - :lisp - 'lisp-processor)) - -; -; EXTERNE SYNTAX -; - - -(defun external-value-ass-p (expression) - - "ueberprueft die Syntax der externen Darstellung einer Variablenbelegung" - - (cond ((null expression) t) - ((and (rest (rest expression)) - (atom (first expression)) - (eq (second expression) '=) - (external-value-ass-p (rest (rest (rest expression)))))) - (t nil))) - - -(defun get-list-of-choices (expression value-ass) - - " Eingabe: eine Zuordnung von Prolog-Variablen zu - lokalen Constraint-Variablen, - eine Wertebelegung der lokalen Variablen - - Ausgabe: eine Liste von Wertemengen , so dass gilt: - das i-te Element ist die Wertemenge der mit dem - i-ten Prolog-Term assoziierten Variable" - - (cond ((null expression) nil) - ((and (rest (rest expression)) - (eq (second expression) '=)) - (let ((value-assoc (assoc (third expression) - value-ass))) - (if (null value-assoc) - (baberror (getentry wrong-prolog-term - constraint-io-table) - (third expression) - value-ass) - (cons (get-value-spec value-assoc) - (get-list-of-choices - (rest (rest (rest expression))) - value-ass))))) - (t (baberror (getentry candidate-expr-error - constraint-io-table) - expression)))) - - -; -; CONSTRAINT ANZEIGEN -; - - -(defun display-constraint (&rest ignore) - (declare (ignore ignore)) - (catch 'no-select - (send-kb :display))) - - -(def$method (basic-constraint-mixin :display) () - - "ermoeglicht die Auswahl eines Constraints, das daraufhin ausgegeben wird" - - (let ((c-assoc ($send self :choose-constraint))) - - ($send (get-object-of-c-assoc c-assoc) - :print - (get-name-of-c-assoc c-assoc) - ($send self :dialog-stream)))) - -; -; CONSTRAINT LESEN -; - - -;;; der folgende Programmteil zur Eingabe von Constraints ist -;;; sehr unkomfortabel und faengt kaum Eingabefehler ab -;;; -;;; VORSICHT bei BENUTZUNG !!!! - -(defun read-constraint (&rest ignore) - (declare (ignore ignore)) - (catch 'no-select - (send-kb :read))) - - -(defun choose-element-type () - (send-kb :choose-from-menu - (getentry rel-elem-items constraint-io-table) - (getentry choose-rel-elem constraint-io-table))) - - -(defun choose-relation () - (let ((elem-type (choose-element-type))) - (case elem-type - (tuple - (cons (list ':tuple - (read-expr-from-window - (getentry choose-tuple constraint-io-table))) - (choose-relation))) - (pattern - (cons (list ':pattern - (read-expr-from-window - (getentry choose-pattern constraint-io-table))) - (choose-relation))) - (conditional-pattern - (cons (list ':pattern - (read-expr-from-window - (getentry choose-pattern constraint-io-table)) - 'if - (read-expr-from-window - (getentry choose-pattern-condition - constraint-io-table))) - (choose-relation))) - (exit nil)))) - - -(def$method (basic-constraint-mixin :read) () - - "liest die Komponenten einer Constraint-Definition aus Pop-Up-Menus" - - (let ((c-type ($send self :choose-from-menu - (getentry choose-type-items constraint-io-table) - (getentry choose-type constraint-io-table)))) - (if (member c-type '(primitive compound)) - ($send self - :new&delete - c-type - (read-expr-from-window - (getentry choose-name constraint-io-table)) - (read-expr-from-window - (case c-type - (primitive (getentry choose-variables - constraint-io-table)) - (compound (getentry choose-interface - constraint-io-table)))) - - (case c-type - (primitive (choose-relation)) - (compound (read-expr-from-window - (getentry choose-expressions - constraint-io-table)))) - (read-expr-from-window - (getentry choose-condition constraint-io-table) - ))))) - - -; CONSTRAINT AKTIVIEREN -; - - -(defun satisfy-constraint-locally () - (catch 'no-select - (send-kb :activate-interactive - 'local-consistency))) - - -(defun satisfy-constraint-globally () - (catch 'no-select - (send-kb :activate-interactive - 'global-consistency))) - - -(def$method (basic-constraint-mixin :activate-interactive) (consistency-level) - - "ermoeglicht die Aktivierung eines Constraints" - - (let* ((c-assoc ($send self :choose-constraint)) - (number-of-results (if (eq consistency-level - 'global-consistency) - (choose-number-of-results))) - (value-ass (choose-value-assignment - ($send (get-object-of-c-assoc c-assoc) - :interface)))) - - ($send self :print-enter - (get-name-of-c-assoc c-assoc) - value-ass - consistency-level - number-of-results - ($send self :dialog-stream)) - ($send self :print-exit - (get-name-of-c-assoc c-assoc) - ($send (get-object-of-c-assoc c-assoc) - :activate - value-ass - 'initialize - consistency-level - number-of-results) - consistency-level - ($send self :dialog-stream)))) - - -(defun choose-value-assignment (interface) - - "liest eine Wertebelegung der Interface-Variablen schrittweise ein" - - (mapcar (function - (lambda (variable) - (make-value-assoc - variable - (choose-value-spec variable)))) - interface)) - - -(defun choose-value-spec (variable) - - "liest eine Wertemenge fuer diese Variable ein" - - (convert-to-consat-value - (read-expr-from-window (format nil "~S" variable)) - 'no-eval)) - - -(defun choose-number-of-results () - - " liest die Anzahl der global konsistenten - Loesungen ein, die berechnet werden sollen" - - (do ((input (read-expr-from-window - (getentry choose-number-of-results - constraint-io-table)) - (read-expr-from-window - (getentry choose-number-of-results - constraint-io-table)))) - ((or (null input) - (numberp input)) input))) - - -(def$method (basic-constraint-mixin :print-enter) - (c-name value-ass consistency-level number-of-results - &optional (stream nil)) - - (terpri stream) - (princ "SATISFY " stream) - (princ c-name stream) - (princ (case consistency-level - (local-consistency " :LOCALLY ") - (global-consistency " :GLOBALLY ")) - stream) - (if (not (null number-of-results)) - (princ number-of-results stream)) - (princ " :WITH " stream) - (print-value-ass value-ass stream)) - - -(def$method (basic-constraint-mixin :print-exit) - (c-name one-or-list-of-value-ass consistency-level - &optional (stream nil)) - - (declare (ignore c-name)) - (terpri stream) - (cond ((eq consistency-level 'local-consistency) - (print-result one-or-list-of-value-ass stream)) - ((null one-or-list-of-value-ass) - (format stream "--> ~A" - (getentry no-solutions constraint-io-table)) - (terpri stream)) - (t (mapc #'(lambda (value-ass) - (print-result value-ass stream)) - one-or-list-of-value-ass)))) - - -(defun print-result (value-ass stream) - - (princ "--> " stream) - (print-value-ass value-ass stream) - (terpri stream)) - - -(defun print-value-ass (value-ass stream) - - (mapc (function - (lambda (value-assoc) - (princ (get-var value-assoc) stream) - (princ " = " stream) - (princ (get-value-spec value-assoc) stream) - (princ " " stream))) - value-ass)) - - -; -; AUSWAHL VON CONSTRAINTS -; -; -; -; Beachte: Falls der Benutzer keine Wahl trifft (z.B. das -; Menu verlaesst oder "do nothing" anklickt, -; erfolgt ein Abbruch zu Label 'no-select -; - - -(def$method (basic-constraint-mixin :choose-constraint) () - - "bittet den Beutzer, ein Constraint unter den in - der aktuellen Wissensbasis definierten auszuwaehlen" - - (choose-special-constraint - ($send self :choose-c-type))) - - -(def$method (basic-constraint-mixin :choose-c-type) () - - "bittet den Benutzer, einen Constraint-Typ auszuwaehlen - Ergebnis: Selektor fuer Constraint-Liste" - - (constraint-input-test - ($send - self - :send-if-handles - (constraint-input-test - (transform-constraint-type - ($send self - :choose-from-menu - (append - (getentry do-nothing-items constraint-io-table) - (getentry choose-type-items constraint-io-table)) - (getentry choose-type constraint-io-table))))))) - - - -;;; eof - diff --git a/t/baby2015/kernel/consat/basic/bc-proc.cl b/t/baby2015/kernel/consat/basic/bc-proc.cl deleted file mode 100644 index f06ddee..0000000 --- a/t/baby2015/kernel/consat/basic/bc-proc.cl +++ /dev/null @@ -1,87 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: BABYLON; Base: 10 -*- - - -(in-package "BABYLON") - -; -; -; constraint processor -; -; - - -; -; CONSTRAINT-PROCESSOR -; - - -(def$flavor basic-constraint-processor - (meta-processor) - (constraint-base - processor-core) - :gettable-instance-variables - :settable-instance-variables - :initable-instance-variables - (:documentation "Umgebung fuer Constraint-Prozessor: - enthaelt eine Liste mit primitiven und - mit zusammengesetzten Constraints")) - - -(def$method (basic-constraint-processor :reset-proc) () - - "setzt alle Constraint-Netze zurueck." - - (mapc (function - (lambda (constraint-assoc) - ($send (get-object-of-c-assoc constraint-assoc) - :reset-state))) - constraint-nets)) - - -(def$method (basic-constraint-processor :print) - (&optional (stream *default-dialog-stream*)) - - "gibt alle definierten Constraints in wiedereinlesbarer Form aus." - - (terpri stream) - (princ ";; ************ C O N S T R A I N T S ************" stream) - (terpri stream) - (terpri stream) - (print-constraint-list constraints stream) - (print-constraint-list constraint-nets stream)) - - -(def$method (basic-constraint-processor :kb-inform) (stream) - - "gibt die Zahl der primitiven und zusammengesetzten Constraints aus." - - (terpri stream) - (format stream (getentry number-of-primitives constraint-io-table) - (length constraints)) - (terpri stream) - (format stream (getentry number-of-nets constraint-io-table) - (length constraint-nets))) - - - - -(def$method (basic-constraint-processor :get) (c-name) - - " ermittelt das primitive oder zusammengesetzte Constraint mit - dem angegebenen Namen - (Beachte: ein Netz und ein primitives Constraint duerfen nicht - den gleichen Namen besitzen)" - - (let ((primitive-c-assoc (assoc c-name constraints)) - (compound-c-assoc (assoc c-name constraint-nets))) - - (cond ((get-object-of-c-assoc primitive-c-assoc)) - ((get-object-of-c-assoc compound-c-assoc)) - (t nil)))) - - -#-:FMCS(compile-$flavor-$methods basic-constraint-processor) - - -;;; eof - diff --git a/t/baby2015/kernel/consat/basic/cp-tab-e.cl b/t/baby2015/kernel/consat/basic/cp-tab-e.cl deleted file mode 100644 index 7db7076..0000000 --- a/t/baby2015/kernel/consat/basic/cp-tab-e.cl +++ /dev/null @@ -1,236 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: BABYLON; Base:10 -*- - -(in-package "BABYLON") - -;;; TABELLE FUER CONSTRAINT-MELDUNGEN (english) -;;; - - - -(defbabylon-table constraint-io-table english :size 30) - - -; -; HAUPTKOMMANDOMENU -; - - -(defbabylon-entry main-constraint-item constraint-io-table english - '("Constraint Operations" - :funcall constraint-operations - #+:LISPM :font #+:LISPM fonts:hl12b - :documentation "a menue of constraint operations")) - - -(defbabylon-entry read-constraint-item constraint-io-table english - '((" " - :no-select nil) - ("Define Constraint" - :funcall read-constraint - :documentation "defines a new constraint") - ("Display Constraint" - :funcall display-constraint - :documentation "displays description of a defined constraint") - ("Satisfy Constraint Locally" - :funcall satisfy-constraint-locally - :documentation "computes the maximal locally consistent solution") - ("Satisfy Constraint Globally" - :funcall satisfy-constraint-globally - :documentation "computes globally consistent solutions") - ("Trace Mode" - :funcall trace-constraints - :documentation "choose trace mode") - (" " - :no-select nil))) - - -(defbabylon-entry exit constraint-io-table english - '("exit" - :value nil)) - - -(defbabylon-entry number-of-primitives constraint-io-table english - "- Number of PRIMITIVE CONSTRAINTS: ~A") - -(defbabylon-entry number-of-nets constraint-io-table english - "- Number of CONSTRAINT NETS: ~A") - -(defbabylon-entry number-of-restrictions constraint-io-table english - "- Number of RESTRICITON NETS: ~A") - -; -; EINTRAEGE FUER INTERAKTIVEN MODUS -; - - -(defbabylon-entry do-nothing-items constraint-io-table english - '(("do nothing" - :value nil - :documentation "abort command") - (" " - :no-select nil))) - - -(defbabylon-entry choose-name constraint-io-table english - "enter constraint name") - - -(defbabylon-entry choose-type constraint-io-table english - "choose type") - -(defbabylon-entry choose-type-items constraint-io-table english - '(("primitive" - :value primitive - :documentation "choose primitive constraint") - ("compound" - :value compound - :documentation "choose compound constraint"))) - - -(defbabylon-entry choose-trace-modes constraint-io-table english - "set trace mode") - -(defbabylon-entry trace-on-item constraint-io-table english - '((trace-on "Trace On"))) - -(defbabylon-entry choose-variables constraint-io-table english - "enter list of variables") - -(defbabylon-entry choose-interface constraint-io-table english - "enter list of interface variables") - -(defbabylon-entry choose-relation constraint-io-table english - "enter constraint relation") - -(defbabylon-entry choose-expressions constraint-io-table english - "enter list of constraint expressions") - -(defbabylon-entry choose-condition constraint-io-table english - "enter activation condition") - -(defbabylon-entry rel-elem-items constraint-io-table english - '(("tuple" - :value tuple - :documentation "enter a tuple of values") - ("pattern" - :value pattern - :documentation "enter a list of lisp expressions") - ("conditional-pattern" - :value conditional-pattern - :documentation "enter a pattern and a condition") - ("exit" - :value exit - :documentation "relation is complete"))) - -(defbabylon-entry choose-rel-elem constraint-io-table english - "choose type") - -(defbabylon-entry choose-tuple constraint-io-table english - "enter a list of values") - -(defbabylon-entry choose-pattern constraint-io-table english - "enter a list of expressions") - -(defbabylon-entry choose-pattern-condition constraint-io-table english - "enter a conditional expression") - -(defbabylon-entry read-value-ass constraint-io-table english - "enter variable assignment") - -(defbabylon-entry choose-number-of-results constraint-io-table english - "enter number of solutions (or NIL for all solutions)") - -(defbabylon-entry no-solutions constraint-io-table english - "NO GLOBALLY CONSISTENT SOLUTIONS") - -(defbabylon-entry fail constraint-io-table english - " FAIL: no more values for variable ~A") - - - -; -; FEHLERMELDUNGEN -; - -(defbabylon-entry restriction-error constraint-io-table english - "slot reference and restriction net are incompatible") - -(defbabylon-entry net-spec-access constraint-io-table english - "CONSAT SYSTEM ERROR: wrong net-specification access") - -(defbabylon-entry no-name constraint-io-table english - "no constraint name specified") - -(defbabylon-entry no-type constraint-io-table english - "no constraint type specified") - -(defbabylon-entry wrong-type constraint-io-table english - "~A is not a constraint type") - -(defbabylon-entry no-variables constraint-io-table english - "no variables specified") - -(defbabylon-entry no-interface constraint-io-table english - "no interface-variables specified") - -(defbabylon-entry no-relation constraint-io-table english - "no constraint-relation specified") - -(defbabylon-entry wrong-relation constraint-io-table english - "syntax error in ~A") - -(defbabylon-entry wrong-condition constraint-io-table english - "error in length of ~A") - -(defbabylon-entry no-expressions constraint-io-table english - "no constraint-expressions specified") - -(defbabylon-entry wrong-unconstrained constraint-io-table english - "wrong occurence of unconstrained in ~A") - -(defbabylon-entry restore-error constraint-io-table english - "CONSAT SYSTEM ERROR: cannot restore state while stack is empty") - -(defbabylon-entry length-error constraint-io-table english - "CONSAT SYSTEM ERROR: ~A and ~A differ in length") - -(defbabylon-entry unknown-variable constraint-io-table english - "CONSAT SYSTEM ERROR: variable ~A doesn't occur in ~A") - -(defbabylon-entry unknown-constraint constraint-io-table english - "~A is not a name of a defined constraint") - -(defbabylon-entry wrong-prolog-term constraint-io-table english - "error in candidate expression: ~A doesn't occurs in ~A") - -(defbabylon-entry candidate-expr-error constraint-io-table english - "syntax error in ~A") - -(defbabylon-entry no-restrictions constraint-io-table english - "no restrictions specified in ~A") - -(defbabylon-entry slot-description-error constraint-io-table english - "no slot references specified") - -(defbabylon-entry value-spec-error constraint-io-table english - "~A is not a consat value specification") - - -; HIER HOEREN ULI'S MELDUNGEN AUF UND HWG'S BEGINNEN - - -(defbabylon-entry invalid-external-value-ass constraint-io-table english - "syntax error in value assignment") - - -(defbabylon-entry invalid-consistency-level constraint-io-table english - "invalid consistency level") - - - -(defbabylon-entry mark-explain-item constraint-io-table english - '(nil "constraints marked by # are traced")) - -(defbabylon-entry toggle-trace-modes constraint-io-table english - "select constraints to toggle trace mode") - diff --git a/t/baby2015/kernel/consat/basic/cp-tab-g.cl b/t/baby2015/kernel/consat/basic/cp-tab-g.cl deleted file mode 100644 index e2be4d3..0000000 --- a/t/baby2015/kernel/consat/basic/cp-tab-g.cl +++ /dev/null @@ -1,236 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: BABYLON; Base:10 -*- - -(in-package "BABYLON") - -;;; TABELLE FUER CONSTRAINT-MELDUNGEN (deutsch) D. FUCHS -;;; - - - -(defbabylon-table constraint-io-table german :size 30) - - -; -; HAUPTKOMMANDOMENU -; - - -(defbabylon-entry main-constraint-item constraint-io-table german - '("Constraint-Operationen" - :funcall constraint-operations - #+:LISPM :font #+:LISPM fonts:hl12b - :documentation "Ein Menue der Constraint-Operationen")) - - -(defbabylon-entry read-constraint-item constraint-io-table german - '((" " - :no-select nil) - ("Constraint-Definition" - :funcall read-constraint - :documentation "definiere ein neues Constraint") - ("Constraint-Beschreibung" - :funcall display-constraint - :documentation "zeigt die Beschreibung eines definierten Constraints an") - ("Lokale Constraint-Erfuellbarkeit" - :funcall satisfy-constraint-locally - :documentation "ermittelt die maximale, lokale, konsistente Loesung") - ("Globale Constraint-Erfuellbarkeit" - :funcall satisfy-constraint-globally - :documentation "ermittelt die globale, konsistente Loesung") - ("Trace-Modus" - :funcall trace-constraints - :documentation "einschalten des Trace-Modus") - (" " - :no-select nil))) - - -(defbabylon-entry exit constraint-io-table german - '("Beende" - :value nil)) - - -(defbabylon-entry number-of-primitives constraint-io-table german - "- Anzahl der PRIMITIVEN CONSTRAINTS: ~A") - -(defbabylon-entry number-of-nets constraint-io-table german - "- Anzahl der CONSTRAINT-NETZE: ~A") - -(defbabylon-entry number-of-nets constraint-io-table german - "- Anzahl der RESTRICTION-NETZE: ~A") - -; -; EINTRAEGE FUER INTERAKTIVEN MODUS -; - - -(defbabylon-entry do-nothing-items constraint-io-table german - '(("Ignoriere" - :value nil - :documentation "Abbruch") - (" " - :no-select nil))) - - -(defbabylon-entry choose-name constraint-io-table german - "Eingabe eines Constraint-Namen") - - -(defbabylon-entry choose-type constraint-io-table german - "Wahl des Typs") - -(defbabylon-entry choose-type-items constraint-io-table german - '(("einfach" - :value primitive - :documentation "Wahl eines einfachen Constraints") - ("zusammengesetzt" - :value compound - :documentation "Wahl eines zusammengesetzten Constraints"))) - - -(defbabylon-entry choose-trace-modes constraint-io-table german - "Setze Trace-Modus") - -(defbabylon-entry trace-on-item constraint-io-table german - '((trace-on "Trace-Modus eingeschaltet"))) - -(defbabylon-entry choose-variables constraint-io-table german - "Eingabe der Variablenliste") - -(defbabylon-entry choose-interface constraint-io-table german - "Eingabe der Liste von Interface-Variablen") - -(defbabylon-entry choose-relation constraint-io-table german - "Eingabe der Constraint-Relation") - -(defbabylon-entry choose-expressions constraint-io-table german - "Eingabe der Liste von Constraint-Ausdruecken") - -(defbabylon-entry choose-condition constraint-io-table german - "Eingabe der Aktivierungsbedingung") - -(defbabylon-entry rel-elem-items constraint-io-table german - '(("tuple" - :value tuple - :documentation "Eingabe der Tupel") - ("pattern" - :value pattern - :documentation "Eingabe der Liste von Lisp-Ausdruecken") - ("conditional-pattern" - :value conditional-pattern - :documentation "Eingabe eines 'pattern' und einer 'condition'") - ("Beende" - :value exit - :documentation "Die Relation ist vollstaendig"))) - -(defbabylon-entry choose-rel-elem constraint-io-table german - "Wahl des Typs") - -(defbabylon-entry choose-tuple constraint-io-table german - "Eingabe einer Liste von Werten") - -(defbabylon-entry choose-pattern constraint-io-table german - "Eingabe einer Liste von Ausdruecken") - -(defbabylon-entry choose-pattern-condition constraint-io-table german - "Eingabe eines bedingten Ausdrucks") - -(defbabylon-entry read-value-ass constraint-io-table german - "Eingabe einer Wertzuweisung an eine Variable") - -(defbabylon-entry choose-number-of-results constraint-io-table german - "Angabe der Anzahl der Loesungen (ansonsten Null fuer alle Loesungen)") - -(defbabylon-entry no-solutions constraint-io-table german - "KEINE GLOBALEN, KONSISTENTEN LOESUNGEN") - -(defbabylon-entry Misserfolg constraint-io-table german - " MISSERFOLG: keine weiteren Variablenwerte ~A") - - - -; -; FEHLERMELDUNGEN -; - -(defbabylon-entry restriction-error constraint-io-table german - "die Slot-Referenzen und das eingeschraenkte Netz stimmen nicht ueberein") - -(defbabylon-entry net-spec-access constraint-io-table german - "CONSAT SYSTEM FEHLER: Zugriff mittels falscher Netz-Spezifikation") - -(defbabylon-entry no-name constraint-io-table german - "fehlender Constraint-Name") - -(defbabylon-entry no-type constraint-io-table german - "fehlender Constraint-Typ") - -(defbabylon-entry wrong-type constraint-io-table german - "~A ist kein Constraint-Typ") - -(defbabylon-entry no-variables constraint-io-table german - "Variablen-Spezifikation fehlt") - -(defbabylon-entry no-interface constraint-io-table german - "Spezifikation der Interface-Variablen fehlt") - -(defbabylon-entry no-relation constraint-io-table german - "Spezifikation der Constraint-Relation fehlt") - -(defbabylon-entry wrong-relation constraint-io-table german - "Syntaxfehler in ~A") - -(defbabylon-entry wrong-condition constraint-io-table german - "falsche Wortlaenge bei ~A") - -(defbabylon-entry no-expressions constraint-io-table german - "Spezifikation der 'constraint-expressions' fehlt") - -(defbabylon-entry wrong-unconstrained constraint-io-table german - "falsches Auftreten von 'unconstrained' in ~A") - -(defbabylon-entry restore-error constraint-io-table german - "CONSAT SYSTEM FEHLER :speichern des Zustands auf leeren Stack nicht erlaubt") - -(defbabylon-entry length-error constraint-io-table german - "CONSAT SYSTEM FEHLER: ~A und ~A sind von unterschiedlicher Laenge") - -(defbabylon-entry unknown-variable constraint-io-table german - "CONSAT SYSTEM FEHLER: Variable ~A nicht in ~A enthalten") - -(defbabylon-entry unknown-constraint constraint-io-table german - "~A ist kein Name eines definierten Constraints") - -(defbabylon-entry wrong-prolog-term constraint-io-table german - "Fehler im 'candidate'-Ausdruck : ~A gehoert nicht zu ~A") - -(defbabylon-entry candidate-expr-error constraint-io-table german - "Syntaxfehler in ~A") - -(defbabylon-entry no-restrictions constraint-io-table german - "keine Einschraenkungen vorgesehen in~A") - -(defbabylon-entry slot-description-error constraint-io-table german - "keine Slot-Referenzen vorgesehen") - -(defbabylon-entry value-spec-error constraint-io-table german - "bei ~A handelt es sich um keine Consat-Wertspezifikation") - - -; HIER HOEREN ULI'S MELDUNGEN AUF UND HWG'S BEGINNEN - - -(defbabylon-entry invalid-external-value-ass constraint-io-table german - "Syntaxfehler in der Wertzuweisung") - - -(defbabylon-entry invalid-consistency-level constraint-io-table german - "ungueltiger 'consistency level'") - - -(defbabylon-entry mark-explain-item constraint-io-table german - '(nil "Mit # markierte Constraints werden protokolliert")) - - -(defbabylon-entry toggle-trace-modes constraint-io-table german - "Waehle Constraints deren Trace-Modus wechseln soll") - diff --git a/t/baby2015/kernel/consat/basic/cstrbase.cl b/t/baby2015/kernel/consat/basic/cstrbase.cl deleted file mode 100644 index aff6a07..0000000 --- a/t/baby2015/kernel/consat/basic/cstrbase.cl +++ /dev/null @@ -1,536 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: BABYLON; Base: 10 -*- - - -(in-package "BABYLON") - - -; -; Verwaltung von Constraints -; - -; 3.6. 1987 Anpassung an GENERA 7; R. Lopatta -; - -(def$flavor constraint-base - ((constraints nil) - (constraint-nets nil)) - () - - :settable-instance-variables - :initable-instance-variables) - - -; -; ZUGRIFF AUF CONSTRAINTS -; - - -(def$method (constraint-base :get) (c-name) - - " ermittelt das primitive oder zusammengesetzte Constraint mit - dem angegebenen Namen - (Beachte: ein Netz und ein primitives Constraint duerfen nicht - den gleichen Namen besitzen)" - - (let ((primitive-c-assoc (assoc c-name constraints)) - (compound-c-assoc (assoc c-name constraint-nets))) - - (cond ((get-object-of-c-assoc primitive-c-assoc)) - ((get-object-of-c-assoc compound-c-assoc)) - (t nil)))) - - -(def$method (constraint-base :put-primitive) (c-name c-primitive) - - " traegt ein neues primitives Constraint ein" - - ($send self - :set-constraints - (cons (make-constraint-assoc - c-name - c-primitive) - constraints))) - - -(def$method (constraint-base :delete) (c-name) - - " Loeschen des angegebenen Constraints" - - (let ((primitive-c-assoc (assoc c-name constraints)) - (compound-c-assoc (assoc c-name constraint-nets))) - - (cond (primitive-c-assoc - ($send self :set-constraints - (remove primitive-c-assoc - constraints))) - (compound-c-assoc - ($send self :set-constraint-nets - (remove compound-c-assoc - constraint-nets)))))) - - -(def$method (constraint-base :put-compound) (c-name c-net) - - " traegt ein neues Constraintnetz ein" - - ($send self - :set-constraint-nets - (cons (make-constraint-assoc - c-name - c-net) - constraint-nets))) - - -(defun print-constraint-list (constraint-list stream) - - " druckt alle Constraints in der Liste in wiedereinlesbarer - Form nach stream" - - (mapc (function - (lambda (c-assoc) - ($send (get-object-of-c-assoc c-assoc) - :print - (get-name-of-c-assoc c-assoc) - stream))) - constraint-list)) - - -; -; AKTIVIERUNG VON CONSTRAINTS -; - - - -(def$method (constraint-base :satisfied-p) (expression) - - " T, falls die Wertebelegung konsistent ist; - NIL, sonst - - der Konsistenzlevel und die Anzahl der - geforderten Ergebnisse werden beruecksichtigt" - - (catch 'error - ($send self :activate-and-adapt-result - (get-constraint (get-constr-name expression)) - (eval-value-ass (get-external-value-ass expression)) - (determine-consistency-level expression) - (determine-number-of-results expression) - 'boolean))) - - -(def$method (constraint-base :satisfy) (expression) - - " aktiviert den in expression angegebenen Constraint, wobei - die Argumente in die interne Darstellung ueberfuehrt werden" - - (catch 'error - ($send self :activate-and-adapt-result - (get-constraint (get-constr-name expression)) - (eval-value-ass (get-external-value-ass expression)) - (determine-consistency-level expression) - (determine-number-of-results expression) - 'value-assignment))) - - -(def$method (constraint-base :activate-and-adapt-result) - (constraint multiple-value-ass consistency-level - number-of-results result-type) - - " aktiviert den Constraint und passt das Ergebnis - dem geforderten Typ an" - - (case result-type - (value-assignment ($send constraint - :activate - multiple-value-ass - 'initialize - consistency-level - number-of-results)) - (boolean (value-assignment-to-boolean-value - ($send constraint - :activate - multiple-value-ass - 'initialize - consistency-level - number-of-results) - consistency-level - number-of-results)))) - - -(defun value-assignment-to-boolean-value - (value-assignment consistency-level number-of-results) - - " macht aus dem Ergebnis einer Constraint-Aktivierung - einen boolschen Wert" - - (declare (list value-assignment)) - (case consistency-level - (local-consistency (if (consistent-value-ass-p value-assignment) - t - nil)) - (global-consistency (if (null number-of-results) - (if (null value-assignment) - nil - t) - (if (= (length value-assignment) - number-of-results) - t - nil))))) - - -(defun get-external-value-ass (expression) - (rest (member ':with expression))) - - -(defun eval-value-ass (externel-value-ass) - - " berechnet die Wertebelegung der Constraint-Variablen - aus der externen Darstellung der Wertebelegung" - - (if (null externel-value-ass) nil - (cons (eval-first-value-ass externel-value-ass) - (eval-value-ass (rest (rest (rest externel-value-ass))))))) - - -(defun eval-first-value-ass (external-value-ass) - - " berechnet die Wertebelegung der ersten Constraint-Variablen" - - (if (eq (second external-value-ass) '=) - (make-value-assoc (first external-value-ass) - (convert-to-consat-value (third external-value-ass) - 'eval)) - (baberror (getentry invalid-external-value-ass constraint-io-table)))) - - -(defun convert-to-consat-value - (expression &optional (mode 'no-eval)) - - " ueberfuehrt expression in eine Consat-Wertemenge" - - (cond ((eq expression 'unconstrained) 'unconstrained) - ((eq expression '-) 'unconstrained) - ((atom expression) (list expression)) - ((eq (first expression) :one-of) - (rest expression)) - (t - (case mode - (eval - (value-spec-test (evaluate-funcall expression))) - (no-eval - (value-spec-test expression)))))) - - -(defun value-spec-test (expression) - - " falls expression keine Consat-Wertemenge - ist, erfolgt Fehlermeldung" - - (if (is-value-spec expression) - expression - (baberror (getentry value-spec-error - constraint-io-table) - expression))) - - -(defun is-value-spec (expr) - - " ueberprueft, ob Consat-Wertemenge vorliegt - (laesst u.a. keine Dotted-Pairs zu)" - - (or (eq expr 'unconstrained) - (null expr) - (and (listp expr) - (is-value-spec (rest expr))))) - - -(defun determine-consistency-level (expression) - - (cond ((or (null (rest expression)) ; Default-Fall - (eq (second expression) ':with)) - 'local-consistency) - ((and (eq (second expression) ':locally) ; lokale Konsistenz - (or (null (rest (rest expression))) - (eq (third expression) ':with))) - 'local-consistency) - - ((and (eq (second expression) ':globally) ; globale Konsistenz - (or (null (rest (rest expression))) - (null (rest (rest (rest expression)))) - (eq (third expression) ':with) - (eq (fourth expression) ':with))) - 'global-consistency) - - (t (baberror (getentry invalid-consistency-level - constraint-io-table))))) - - -(defun determine-number-of-results (expression) - - (if (and (eq (second expression) :globally) - (not (null (rest (rest expression)))) - (not (eq (third expression) :with))) - (evaluate-funcall (third expression)))) - - - -; -; DEFINITION VON CONSTRAINTS -; - - -(def$method (constraint-base :new&delete) (c-type c-name c-variables c-body - &optional (c-condition t)) - - " Ueberschreiben der alten Definition" - - ($send self :delete c-name) - ($send self - (case c-type - (primitive :new-primitive) - (compound :new-compound)) - c-name - c-variables - c-body - c-condition)) - - -(def$method (constraint-base :new-primitive) (c-name c-variables c-relation - &optional (c-condition t)) - - " Definition eines primitiven Constraints" - - (catch 'error - (if ($send self :get c-name) - nil - (let ((new-constraint - (make-$instance 'constraint))) - ($send self - :put-primitive - c-name new-constraint) - ($send new-constraint - :set-interface - c-variables) - ($send new-constraint - :set-relation - c-relation) - ($send new-constraint - :set-condition - (compile-condition c-condition c-relation)) - ($send new-constraint - :set-compiled-condition-flag - (abbreviated-condition c-condition)) - t)))) - - -(def$method (constraint-base :new-compound) (c-name interface c-expressions - &rest ignore) - - " Definition eines Constraint-Netz" - (declare (ignore ignore)) - (catch 'error - (if ($send self :get c-name) - nil - (let ((new-net (make-$instance 'constraint-net))) - ($send self :put-compound c-name new-net) - ($send new-net :set-interface interface) - ($send new-net :set-net-spec (create-net-spec c-expressions)) - t)))) - - -; -; KONSTRUKTOR -; - - - ;;; benutzerfreundliches Defconstraint - ;;; - ;;; Syntax: - ;;; ::= | - ;;; - ;;; ::= (DEFCONSTRAINT . list( p-def-elem> ) ) - ;;; ::= (DEFCONSTRAINT . list( c-def-elem> ) ) - ;;; - ;;; ::= (:RELATION . ) | - ;;; (:INTERFACE . list( ) ) | - ;;; (:CONDITION ) | - ;;; ::= (:CONSTRAINT-EXPRESSIONS . - ;;; list( ) ) | - ;;; (:INTERFACE . list( ) - ;;; ::= (:TYPE ) - ;;; ::= symbol - - -(defmacro defconstraint (def-name &rest def-body) - (catch 'error - (case (get-def-typ def-body) - (primitive - `(send-kb - :new&delete - 'primitive - ',def-name - ',(get-def-interface def-body) - ',(get-def-relation def-body) - ',(get-def-condition def-body))) - (compound - `(send-kb - :new&delete - 'compound - ',def-name - ',(get-def-interface def-body) - ',(get-def-expressions def-body)))))) - - - -; -; FUNKTIONEN FUER CONSTRAINT-DEFINITION -; - -(defun get-def-typ (def-body) - - " sucht in def-body einen Ausdruck der Form (:type ) - - mit ::= primitive | compound" - - (let ((typ-pair (assoc ':type def-body))) - (cond ((null typ-pair) - (baberror (getentry no-type constraint-io-table))) - ((not (member (second typ-pair) - '(compound primitive))) - (baberror (getentry wrong-type constraint-io-table) - (second typ-pair))) - (t (second typ-pair))))) - - - - -(defun get-def-interface (def-body) - - " sucht in def-body einen Ausdruck der Form - (:interface )" - - (let ((var-pair (assoc ':interface def-body))) - (if (null var-pair) - (baberror (getentry no-interface constraint-io-table)) - (cdr var-pair)))) - - -(defun get-def-relation (def-body) - - " sucht in def-body einen Ausdruck der Form (:relation ) - und ueberprueft die Syntax von " - - (let ((rel-pair (assoc ':relation def-body))) - (cond ((null rel-pair) - (baberror (getentry no-relation constraint-io-table))) - ((not (parse-relation (cdr rel-pair))) - (baberror (getentry wrong-relation constraint-io-table)) - (cdr rel-pair)) - (t (cdr rel-pair))))) - - -(defun get-def-condition (def-body) - - " sucht in def-body einen Ausdruck der Form - (:condition )" - - (let ((cond-pair (assoc ':condition def-body))) - (cond ((null cond-pair) t) - ((/= (length cond-pair) 2) - (baberror (getentry wrong-condition constraint-io-table) - cond-pair)) - (t (second cond-pair))))) - - -(defun get-def-expressions (def-body) - - " sucht in def-body einen Ausdruck der Form - (:constraint-expressions . list( )" - - (let ((expr-pair (assoc ':constraint-expressions def-body))) - (if (null expr-pair) - (baberror (getentry no-expressions constraint-io-table)) - (cdr expr-pair)))) - - -(defun compile-condition (condition relation) - - " falls :OR als condition angegeben ist, wird die - Disjunktion der :IF's genommen" - - (if (abbreviated-condition condition) - (cons 'or (select-local-conditions relation)) - condition)) - - -(defun abbreviated-condition (condition) - - " T, falls condition gleich :OR ist" - - (if (eql condition :or) t)) - - -(defun select-local-conditions (relation) - - " selektiert die lokalen Bedingungen (IF's)" - - (cond ((null relation) nil) - ((has-condition-p (first relation)) - (cons (get-local-condition (first relation)) - (select-local-conditions (rest relation)))) - (t (select-local-conditions (rest relation))))) - - -(defun has-condition-p (relation-element) - (member :if relation-element)) - - -(defun get-local-condition (relation-element) - (second (member :if relation-element))) - - -; -; SYNTAXTEST FUER -; -; -; -; -; Eine Constraint-Relation ist folgendermassen aufgebaut: -; -; ::= list( ) -; ::= | -; ::= ( :tuple list( ) ) -; ::= ( :pattern list( ) ) | -; ( :pattern list( ) -; :if ) - - -(defun parse-relation (relation) - (cond ((null relation) t) - ((atom relation) nil) - ((and (parse-rel-elem (first relation)) - (parse-relation (rest relation)))))) - - -(defun parse-rel-elem (rel-elem) - (if (atom rel-elem) - nil - (case (get-keyword rel-elem) - (:tuple (and (= (length rel-elem) 2) - (is-liste (get-tupel rel-elem)))) - (:pattern (and (if (= (length rel-elem) 4) - (eq (third rel-elem) ':if) - (= (length rel-elem) 2)) - (is-liste (get-expressions - rel-elem)))) - (otherwise nil)))) - - -(defun is-liste (liste) - (cond ((null liste) t) - ((atom liste) nil) - ((is-liste (cdr liste))))) - - -;;; eof - diff --git a/t/baby2015/kernel/consat/basic/cstrnet.cl b/t/baby2015/kernel/consat/basic/cstrnet.cl deleted file mode 100644 index 2abd26b..0000000 --- a/t/baby2015/kernel/consat/basic/cstrnet.cl +++ /dev/null @@ -1,308 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: BABYLON; Base: 10 -*- - - -(in-package "BABYLON") - - -; -; Constraint-Netz -; - -; 3.6. 1987 Anpassung an GENERA 7; R. Lopatta -; - -; -; CONSTRAINT-NETZ -; - - -; variable infos: Angaben zu einer globalen Variablen -; -; Structure mit folgenden Komponenten -; constraints: list( ) -; {constraints, in denen diese Variable auftritt} -; values: -; init-values: - -; agenda-element: -; -; Structure mit folgenden Komponenten -; queue: list( ) -; trace: list( ) -; init-trace: list( ) -; filtered-p: T | nil -; {wurde Vorpropagierung bereits durchgefuehrt ?} -; -; - -(defstruct (agenda-elem) - (queue nil) - (trace nil) - (init-trace nil) - (filtered-p nil)) - - -; stack-element: -; -; Structure mit folgenden Komponenten -; values: list( ) -; queue: list( ) -; trace: list( ) - -(defstruct (stack-elem) - (values nil) - (queue nil) - (trace nil)) - - -; Constraint-Netz: -; -; Flavor mit folgenden Variablen -; interface: list( ) -; net-spec: list( ) -; {Liste der globalen Variablen -; mit weiteren Angaben} -; agenda: list( ) -; stack: list( ) -; - -(def$flavor constraint-net - - ((interface nil) - (net-spec nil) - (agenda (make-agenda-elem)) - (stack nil)) - () - - :gettable-instance-variables - :settable-instance-variables - :initable-instance-variables - ) - - -(def$method (constraint-net :print) (name stream) - - ;;; Ausgabe des Constraint-Netzes - - (princ " " stream) - (terpri stream) - (babpprint - `(defconstraint ,name - (:type compound) - (:interface . ,interface) - (:constraint-expressions . ,(select-all-constraints net-spec))) - stream) - (terpri stream)) - - - - -; -; NETZSPEZIFIKATION ERMITTELN -; - - -(defun create-net-spec (c-expressions) - - (create-var-info-alist - (determine-net-variables c-expressions) - c-expressions)) - - -(defun create-var-info-alist (net-vars c-expressions) - - ;;; erzeugt eine Assoziationsliste, die fuer jede - ;;; Netzvariable die noetigen Angaben enthaelt - - (mapcar (function - (lambda (net-var) - (make-info-assoc - net-var - (make-var-info - :constraints (get-associated-constraints - c-expressions - net-var))))) - net-vars)) - - -(defun get-associated-constraints (c-expressions net-var) - - ;;; ermittelt eine Liste der extended-constraints, - ;;; in denen net-var als globale Variable vorkommt - - (cond ((null c-expressions) nil) - ((member - net-var - (get-parameters (first c-expressions)) - :test 'equal) - (cons (first c-expressions) - (get-associated-constraints - (rest c-expressions) - net-var))) - (t (get-associated-constraints - (rest c-expressions) - net-var)))) - - -(defun determine-net-variables (c-expressions) - - ;;; ermittelt mit Hilfe der Variablenassoziationen der - ;;; constraint-expressions die Variablen des Netzes - - (if (null c-expressions) - nil - (union-sets - (remove-duplicates - (get-parameters (first c-expressions)) - :test #'equal) - (determine-net-variables - (rest c-expressions))))) - - -; -; NETZSPEZIFIKATION AKTUALISIEREN -; - - -(defun update-net-value-ass (new-value-ass net-spec) - - ;;; ergaenzt die Wertemengen der Variablen in variables - ;;; um die neuen Wertemengen aus new-value-ass - ;;; (Bildung der Schnittmenge) - - (mapc (function - (lambda (new-value-assoc) - (add-var-info-values - (assoc (get-var new-value-assoc) - net-spec - :test 'equal) - (get-value-spec new-value-assoc)))) - new-value-ass)) - - -(defun modify-net-value-ass (new-value-ass net-spec) - - ;;; die Variablen-Werte-Assoziationen in new-value-ass ersetzen - ;;; entsprechende Eintraege in net-spec - ;;; (die var-info-values-Komponenten werden durch - ;;; SEITENEFFEKTE geaendert) - - (mapc (function - (lambda (new-value-assoc) - (replace-var-info-values - (assoc (get-var new-value-assoc) - net-spec - :test 'equal) - (get-value-spec new-value-assoc)))) - new-value-ass)) - - -; -; CONSTRAINT-AUSDRUECKE AUSWAEHLEN -; - - -(defun select-all-constraints (net-spec) - - ;;; bestimmt die Menge aller Constraint-Ausdruecke, - - (cond ((null net-spec) nil) - (t (union-sets - (get-var-info-constraints (first net-spec)) - (select-all-constraints (rest net-spec)))))) - - -(defun select-relevant-constraints (net-spec value-ass) - - ;;; bestimmt die Menge aller Constraint-Ausdruecke, - ;;; in denen eine globale Variable auftritt, - ;;; der durch value-ass eine Wertemenge ungleich 'unconstrained - ;;; zugeordnet wird - - (cond ((null value-ass) nil) - ((eq (get-value-spec (first value-ass)) - 'unconstrained) - (select-relevant-constraints net-spec - (rest value-ass))) - (t (union-sets - (get-var-info-constraints - (assoc (get-var (first value-ass)) - net-spec - :test 'equal)) - (select-relevant-constraints net-spec - (rest value-ass)))))) - - -; -; FUNKTIONEN FUER CHOICE-POINT -; - - -(defun state-of-net-spec (net-spec &optional (state 'single-valued)) - - ;;; ueberprueft zustand der variablenbelegung - - (if (null net-spec) state - (let ((value-spec (get-var-info-values - (first net-spec)))) - (declare (list value-spec)) - (cond ((null value-spec) 'inconsistent) - ((eq value-spec 'unconstrained) - (state-of-net-spec (rest net-spec) - 'unconstrained)) - ((= (length value-spec) 1) - (state-of-net-spec (rest net-spec) state)) - (t (state-of-net-spec (rest net-spec) - (if (eq state 'unconstrained) - 'unconstrained - 'multiple-valued))))))) - - -(defun state-of-value-ass (value-ass &optional (state 'single-valued)) - - ;;; ueberprueft Zustand der variablenbelegung - - (if (null value-ass) state - (let ((value-spec (get-value-spec (first value-ass)))) - (declare (list value-spec)) - (cond - ((null value-spec) 'inconsistent) - ((eq value-spec 'unconstrained) - (state-of-value-ass (rest value-ass) - 'unconstrained)) - ((= (length value-spec) 1) - (state-of-value-ass (rest value-ass) - state)) - (t (state-of-value-ass (rest value-ass) - 'multiple-valued)))))) - - -(defun select-multiple-valued-variable (net-spec &optional candidate) - - ;;; liefert eine Netzvariable (mit Zusatzangaben) - ;;; mit der kleinsten mehrelementigen Wertemenge - - (if (null net-spec) candidate - (let ((new-length (length (the list (get-var-info-values (first net-spec)))))) - (select-multiple-valued-variable - (rest net-spec) - (if (or (<= new-length 1) - (and candidate - (<= (length (the list (get-var-info-values candidate))) - new-length))) - candidate - (first net-spec)))))) - - -(defun consistent-value-ass-p (value-ass) - - ;;; liefert nil, falls eine Variable existiert, - ;;; die mit der leeren Liste markiert ist; - ;;; - ;;; ansonsten wird value-ass oder T zurueckgegeben - - (cond ((null value-ass) T) - ((null (get-value-spec (car value-ass))) nil) - ((consistent-value-ass-p (cdr value-ass)) - value-ass) - (T nil))) diff --git a/t/baby2015/kernel/consat/basic/net-prop.cl b/t/baby2015/kernel/consat/basic/net-prop.cl deleted file mode 100644 index 136c00d..0000000 --- a/t/baby2015/kernel/consat/basic/net-prop.cl +++ /dev/null @@ -1,468 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: BABYLON; Base: 10 -*- - - -(in-package "BABYLON") - -; -; Constraint Propagierung -; - -; 3.6. 1987 Anpassung an GENERA 7; R. Lopatta -; - -; -; PROPAGIERUNG -; - - -(def$method (constraint-net :activate) - (multiple-value-ass &optional - (init-option 'initialize) - (consistency-level 'local-consistency) - (number-of-results nil)) - - - ;;; Eingabe: multiple Wertebelegung der Interfacevariablen, - ;;; Option: Variablen und Trace mit Defaultwert - ;;; initialisieren - ;;; Option: nach Propagierung Konsistenztest - ;;; durchfuehren - ;;; Option: Anzahl der global konsistenten Ergebnisse - ;;; - ;;; Ausgabe: multiple Wertebelegung nach Propagierung, - ;;; falls consistency-level = local-consistency, - ;;; Liste mit global konsistenten Wertebelegungen, - ;;; falls consistency-level = global-consistency - - (catch 'error - ($send self :initialize multiple-value-ass init-option) - ($send self :propagate consistency-level) - ($send self :result consistency-level number-of-results))) - - - -(def$method (constraint-net :initialize) (multiple-value-ass init-option) - - ;;; initialisiert das Netz - ;;; - ;;; falls init-option = 'initialize werden die Variablen mit der - ;;; Defaultwertmenge belegt und der Default-Trace uebernommen - - ($send self :store-state) - ($send self :filter) - (if (eq init-option 'initialize) - ($send self :get-initiale-state)) - ($send self :initialize-variables multiple-value-ass) - ($send self :initialize-agenda multiple-value-ass)) - - - -(def$method (constraint-net :result) (consistency-level number-of-results) - - ;;; fuehrt evtl. einen Konsistenztest durch - ;;; - ;;; Ergebnis: Belegung der Interface-Variablen - - (prog1 - (case consistency-level - (global-consistency - ($send self :consistent-p number-of-results)) - (local-consistency - ($send self :interface-assignment)) - (global-consistency-if-single-valued - ($send self :test-consistency-if-single-valued))) - ($send self :restore-state))) - - - -(def$method (constraint-net :filter) () - - ;;; fuehrt Vorpropagierung durch: - ;;; alle Constraint-Ausdruecke werden mindestens einmal - ;;; aktiviert - - (cond ((not (agenda-elem-filtered-p agenda)) - - (setf (agenda-elem-filtered-p agenda) t) - ($send self :total-init-queue) - ($send self :propagate 'local-consistency) - ($send self :freeze-state)))) - - - -(def$method (constraint-net :propagate) (consistency-level) - - ;;; fuehrt lokale Propagierung durch - ;;; bis Agenda leer ist - - (do () - ((null (agenda-elem-queue agenda)) - ()) - - (let* ((constraint-expr (first (agenda-elem-queue agenda))) - (new-value-ass ($send (get-constraint - (get-constr-name constraint-expr)) - :evaluate-expression - constraint-expr - net-spec - consistency-level))) - - ($send self :update-variables - new-value-ass) - ($send self :update-agenda - constraint-expr - new-value-ass)))) - - - -(def$method (constraint-net :evaluate-expression) - (constraint-expr global-net-spec consistency-level) - - ;;; fuehrt Umsetzung globaler in lokale Variablen durch - ;;; und umgekehrt - - (local-to-global-subst - constraint-expr - ($send self - :activate - (global-to-local-subst - constraint-expr - global-net-spec) - 'initialize - (adapt-consistency-level consistency-level)))) - - -(defun adapt-consistency-level (consistency-level) - - ;;; bei Test auf globale Konsistenz wird solange wie - ;;; moeglich lokales Propagieren ausgefuehrt; - ;;; nur bei eindeutiger Belegung der Interfacevariablen - ;;; wird in dem zu aktivierenden teilnetz ein - ;;; globaler Konsistenztest durchgefuehrt - - (if (eq consistency-level 'global-consistency) - 'global-consistency-if-single-valued - consistency-level)) - - -; -; KONSISTENZTEST DURCHFUEHREN -; - - -(def$method (constraint-net :consistent-p) - (&optional (number-of-results nil)) - - ;;; ueberprueft die globale konsistenz des netzwerks - ;;; mittels backtracking + lokaler propagierung - - (case (state-of-net-spec net-spec) - (inconsistent nil) - (unconstrained - (list ($send self :interface-assignment))) ;;; ??? - (single-valued - (list ($send self :interface-assignment))) - (multiple-valued - (let ((info-assoc (select-multiple-valued-variable - net-spec))) - ($send self :test-choices - (get-net-var info-assoc) - (get-var-info-values info-assoc) - number-of-results))))) - - -(def$method (constraint-net :test-choices) - (variable value-set number-of-results) - - ;;; fuer alle Werte w aus value-set wird das aktuelle - ;;; Constraint-Netz aktiviert mit (variable = w) - ;;; bis number-of-results Belegungen gefunden sind - ;;; - ;;; tritt dies nicht ein, werden die gefundenen Belegungen - ;;; zurueckgeliefert (nil, falls das Netz inkonsistent ist) - - (cond ((null value-set) nil) ;;; Inkonsistenz - ((and (not (null number-of-results)) - (<= number-of-results 0)) nil) ;;; hinreichend viele Belegungen gefunden - - (t (let ((list-of-value-ass ($send self :activate - (list (make-value-assoc - variable - (list (first value-set)))) - 'continue - 'global-consistency - number-of-results))) - (append list-of-value-ass - ($send self :test-choices - variable - (rest value-set) - (compute-new-number-of-results - number-of-results - list-of-value-ass))))))) - - -(defun compute-new-number-of-results (number-of-results list-of-value-ass) - - ;;; berechnet die Anzahl der Belegungen, die noch - ;;; ermittelt werden muessen - - (declare (list list-of-value-ass)) - (if (null number-of-results) nil - (- number-of-results (the fixnum (length list-of-value-ass))))) - - -(def$method (constraint-net :test-consistency-if-single-valued) () - - ;;; falls alle Interface-Variablen einen eindeutigen Wert besitzen, - ;;; wird zusaetzlich ein konsistenztest durchgefuehrt - - (if (eq (state-of-value-ass - ($send self :interface-assignment)) - 'single-valued) - ($send self :adapt-to-local-consistency ($send self :consistent-p 1)) - ($send self :interface-assignment))) - - -(def$method (constraint-net :adapt-to-local-consistency) (list-of-value-ass) - - ;;; gleicht list-of-value-ass dem Ergebnis an, das - ;;; bei einer lokalen Propagierung entstehen wuerde - - (if (null list-of-value-ass) - (empty-alist interface) - (first list-of-value-ass))) - - -; -; OPERATIONEN AUF NETZ-VARIABLEN -; - - -(def$method (constraint-net :initialize-variables) (multiple-value-ass) - - ;;; ergaenzt die Wertebelegung jeder Interface-Variablen - ;;; in multiple-value-ass um die Wertemenge, die ihr - ;;; multiple-value-ass zuordnet - - (update-net-value-ass multiple-value-ass - net-spec)) - - -(def$method (constraint-net :update-variables) (multiple-value-ass) - - ;;; aktualisiert die Wertebelegung der Netzvariablen durch - ;;; die Wertebelegung von multiple-value-ass - - (modify-net-value-ass multiple-value-ass - net-spec)) - - -(def$method (constraint-net :interface-assignment) () - - ;;; liefert die Wertebelegung der Interface-Variablen - - (mapcar (function - (lambda (interface-var) - (make-value-assoc - interface-var - (get-var-info-values - (assoc interface-var net-spec - :test 'equal))))) - interface)) - - -(def$method (constraint-net :net-variables) () - - ;;; liefert eine Liste aller Netzvariablen - - (mapcar (function - (lambda (info-assoc) - (get-net-var info-assoc))) - net-spec)) - - -; -; AGENDA-OPERATIONEN -; - - -(def$method (constraint-net :initialize-agenda) (multiple-value-ass) - - ;;; alle Constraint-Ausdruecke mit Variablen, denen eine Menge ungleich - ;;; 'unconstrained zugeordnet wurde, werden in die queue gefuegt - - (setf (agenda-elem-queue agenda) - (select-relevant-constraints - net-spec multiple-value-ass))) - - -(def$method (constraint-net :total-init-queue) () - - ;;; initialisiert die Queue mit allen Constraint-Ausdruecken - - (setf (agenda-elem-queue agenda) - (select-all-constraints net-spec))) - - -(def$method (constraint-net :update-agenda) (constraint-expr multiple-value-ass) - - ;;; - fuege (constraint-expr multiple-value-ass) auf den Trace - ;;; - ;;; - Bilde die Menge aller Constraint-Ausdruecke, in denen globale - ;;; Variablen aus multiple-value-ass vorkommen, deren Wertemenge - ;;; ungleich 'unconstrained ist - ;;; - ;;; - Aktualisiere die queue mit Hilfe dieser Menge - - (setf (agenda-elem-trace agenda) - (cons (make-trace-elem - constraint-expr - multiple-value-ass) - (agenda-elem-trace agenda))) - - (setf (agenda-elem-queue agenda) - (update-queue - (rest (agenda-elem-queue agenda)) - (remove-duplicates - (select-relevant-constraints - net-spec - multiple-value-ass) - :test #'equal) - (agenda-elem-trace agenda) - multiple-value-ass))) - - -(defun update-queue (old-queue list-of-constr-expr - trace new-value-ass) - - ;;; Fuer jeden constraint-Ausdruck in list-of-constr-expr Tue: - ;;; - ;;; - falls er bereits aktiviert wurde, pruefe, - ;;; ob es in new-value-ass eine Variable gibt, - ;;; die in dem Constraint-Ausdruck auftritt und - ;;; jetzt eine kleinere Wertemenge als damals besitzt - ;;; - ;;; - falls diese Bedingung gilt oder der Constraint-Ausdruck - ;;; noch nicht aktiviert wurde, - ;;; fuege ihn in die Queue (falls noch nicht vorhanden) - - (cond ((null list-of-constr-expr) - old-queue) - ((and (trace-test - (assoc (first list-of-constr-expr) trace - :test 'equal) - new-value-ass) - (not (member (first list-of-constr-expr) - old-queue - :test 'equal))) - (cons (first list-of-constr-expr) - (update-queue old-queue - (rest list-of-constr-expr) - trace - new-value-ass))) - (t (update-queue old-queue - (rest list-of-constr-expr) - trace - new-value-ass)))) - - -(defun trace-test (associated-trace-element new-value-ass) - - (if (null associated-trace-element) t - (some-new-restrictions-p - new-value-ass - (get-trace-value-ass - associated-trace-element)))) - - -; -; STACK-OPERATIONEN -; - - -(def$method (constraint-net :store-state) () - - ;;; rettet die Variablenbelegung und die Agenda auf den Stack; - - (setf stack - (cons (make-stack-elem - :values (mapcar - (function - (lambda (info-assoc) - (make-value-assoc - (get-net-var info-assoc) - (get-var-info-values info-assoc)))) - net-spec) - - :queue (agenda-elem-queue agenda) - :trace (agenda-elem-trace agenda)) - stack))) - - -(def$method (constraint-net :restore-state) () - - ;;; stellt Zustand gemaess des obersten Stackelements wieder her - ;;; und entfernt das oberste Stackelement vom Stack - - (cond ((null stack) - (baberror (getentry restore-error constraint-io-table))) - (t (modify-net-value-ass (stack-elem-values (first stack)) - net-spec) - (setf (agenda-elem-queue agenda) - (stack-elem-queue (first stack))) - (setf (agenda-elem-trace agenda) - (stack-elem-trace (first stack))) - ($send self :set-stack - (rest stack))))) - - -(def$method (constraint-net :forget-state) () - - ;;; loescht das oberste Stackelement: - ;;; dieser Zustand wird also vergessen - - (setf stack (rest stack))) - - -(def$method (constraint-net :freeze-state) () - - ;;; "friert" die aktuelle Variablenbelegung und den - ;;; aktuellen Trace dauerhaft ein - - (mapc (function freeze-var-info-values) - net-spec) - - (setf (agenda-elem-init-trace agenda) - (agenda-elem-trace agenda))) - - -(def$method (constraint-net :get-initiale-state) () - - ;;; initialisiert die Variablen und den trace mit den - ;;; entsprechenden Defaultwerten - - (mapc (function init-var-info-values) - net-spec) - - (setf (agenda-elem-trace agenda) - (agenda-elem-init-trace agenda))) - - -(def$method (constraint-net :reset-state) () - - ;;; setzt die Variablen-Defaultwerte auf 'unconstrained - ;;; und init-trace auf nil - - (mapc (function reset-var-info-values) - net-spec) - - (setf (agenda-elem-init-trace agenda) - nil) - - (setf (agenda-elem-filtered-p agenda) - nil)) - -;;; eof - - - diff --git a/t/baby2015/kernel/consat/basic/primcstr.cl b/t/baby2015/kernel/consat/basic/primcstr.cl deleted file mode 100644 index b50cb80..0000000 --- a/t/baby2015/kernel/consat/basic/primcstr.cl +++ /dev/null @@ -1,565 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: BABYLON; Base: 10 -*- - - -(in-package "BABYLON") - - -; -; Evaluierung primitiver Constraints -; -; -; 3.6. 1987 Anpassung an GENERA 7; R. Lopatta -; - -; -; PRIMITIVES CONSTRAINT -; -; -; Flavor mit folgenden Variablen -; interface: list( ) -; relation: -; condition: -; - -; -; Consat-SCHNITTSTELLE -; - - -(defun evaluate-funcall (expression &optional (simple-value-ass nil)) - - "Zugriff von consat auf andere Prozessoren" - - (send-kb :eval - (substitute-constraint-variables - expression - simple-value-ass) - :recall - 'constraint-processor)) - - -(defun evaluate-condition (expression simple-value-ass) - - "Zugriff von consat auf andere Prozessoren" - - (or (eq expression 't) - (send-kb :eval - (substitute-constraint-variables - expression - simple-value-ass) - :recall - 'constraint-processor))) - - -(defun substitute-constraint-variables (expr simple-value-ass) - - "ersetzt in expression alle Symbole, die in simple-value-ass auftreten, - durch quote und den Wert, den ihnen simple-value-ass zuweist" - - (cond ((null expr) nil) - ((atom expr) - (substitute-if-possible - expr (assoc expr simple-value-ass))) - (t - (cons (substitute-constraint-variables - (car expr) - simple-value-ass) - (substitute-constraint-variables - (cdr expr) - simple-value-ass))))) - - -(defun substitute-if-possible (symbol value-assoc) - (if (null value-assoc) - symbol - `(quote ,(get-simple-value value-assoc)))) - - - -; -; BEHANDLUNG DER PARAMETER -; - - -(defun global-to-local-subst (c-expr net-spec) - - ;;; ermittelt Wertebelegung fuer Variablen des Constraints von c-expr - - (make-local-value-ass (get-parameters c-expr) - ($send (get-constraint - (get-constr-name c-expr)) - :interface) - net-spec)) - - -(defun local-to-global-subst (c-expr local-value-ass) - - ;;; ersetzt in local-value-ass die lokalen durch die in c-expr - ;;; zugeordneten Variablen - - (make-determined-value-ass - (remove-duplicates (get-parameters c-expr) - :test #'equal) - (make-global-value-ass (get-parameters c-expr) - ($send (get-constraint - (get-constr-name c-expr)) - :interface) - local-value-ass))) - - -(defun make-local-value-ass (global-vars local-vars net-spec) - - ;;; die i-te Variable in global-vars sei mit der i-ten Variablen - ;;; in local-vars assoziiert; - ;;; jede lokale Variable erhaelt die Wertemenge, die der entsprechenden - ;;; globalen Variablen in net-spec zugeordnet ist - - (cond ((null global-vars) - (if (null local-vars) nil - (baberror (getentry length-error constraint-io-table) - global-vars local-vars))) - ((null local-vars) - (baberror (getentry length-error constraint-io-table) - global-vars local-vars)) - - (t (cons (make-value-assoc - (first local-vars) - (get-var-info-values - (assoc (first global-vars) net-spec - :test 'equal))) - (make-local-value-ass - (rest global-vars) - (rest local-vars) - net-spec))))) - - -(defun make-global-value-ass (global-vars local-vars local-value-ass) - - ;;; die i-te Variable in global-vars sei mit der i-ten Variablen - ;;; in local-vars assoziiert; - ;;; jede globale Variable erhaelt die Wertemenge, die der entsprechenden - ;;; lokalen Variablen in local-value-ass zugeordnet ist - - (cond ((null global-vars) - (if (null local-vars) nil - (baberror (getentry length-error constraint-io-table) - global-vars local-vars))) - ((null local-vars) - (baberror (getentry length-error constraint-io-table) - global-vars local-vars)) - - (t (let ((val-assoc (assoc (first local-vars) local-value-ass - :test 'equal))) - (if (null val-assoc) - (baberror (getentry unknown-variable constraint-io-table) - (first local-vars) - local-value-ass) - (cons (make-value-assoc - (first global-vars) - (get-value-spec val-assoc)) - (make-global-value-ass - (rest global-vars) - (rest local-vars) - local-value-ass))))))) - - -(defun make-determined-value-ass (variables value-ass) - - ;;; erzeugt eine eindeutige Assoziationsliste : - ;;; jede Variable in variables erhaelt als Wert die Schnittmenge - ;;; ihrer Werte in value-ass - - (mapcar (function - (lambda (variable) - (make-value-assoc - variable - (intersect-associated-value-specs - variable - value-ass)))) - variables)) - - -(defun intersect-associated-value-specs (variable value-ass) - - (cond ((null value-ass) 'unconstrained) - ((equal variable (get-var (first value-ass))) - (extended-intersection - (get-value-spec (first value-ass)) - (intersect-associated-value-specs - variable - (rest value-ass)))) - (t (intersect-associated-value-specs - variable - (rest value-ass))))) - -;;; - - -(def$flavor constraint - - ((interface nil) - (relation nil) - (condition t) - (compiled-condition-flag nil)) - () - - :gettable-instance-variables - :settable-instance-variables -; :initable-instance-variables - ) - - -(def$method (constraint :print) (name stream) - - ;;; Ausgabe des Constraints - - (princ " " stream) - (terpri stream) - (babpprint - `(defconstraint ,name - (:type primitive) - (:interface . ,interface) - (:relation . ,relation) - (:condition ,(if compiled-condition-flag - :or condition))) - stream) - (terpri stream)) - - -; -; EVALUATION -; - - -(def$method (constraint :activate) (new-value-ass - &optional - init-option - (consistency-level 'local-consistency) - (number-of-results nil)) - - ;;; Eingabe: Zuweisung von Wertemengen an die Constraint-Variablen - ;;; - ;;; Ausgabe: neue Wertemengenzuweisung, - ;;; falls consistency-level = local-consistency; - ;;; Liste von Zuweisungen, die den Variablen einzelne Werte - ;;; zuordnen, falls consistency-level = global-consistency - ;;; - ;;; falls fuer eine Wertebelegung die activation-Bedingung - ;;; nicht erfuellt ist, wird die alte Wertebelegung als Ergebnis - ;;; zurueckgeliefert (bei local-consistency) bzw. die Liste aller - ;;; moeglichen Einzelwertzuweisungen (bei global-consistency) - ;;; - ;;; der Parameter init-option ist ohne Bedeutung, muss wegen - ;;; des Compilers jedoch mindestens einmal benutzt werden: - - init-option - - (catch 'error - (let* ((multiple-value-ass (adjust-value-ass - interface - new-value-ass)) - (list-of-value-ass (split-variable-alist - multiple-value-ass))) - - (case consistency-level - - ((local-consistency global-consistency-if-single-valued) - (if (activation-p condition list-of-value-ass) - (combine-variable-alists - (multiple-evaluation relation interface list-of-value-ass) - interface) - multiple-value-ass)) - - (global-consistency - (select-some-value-ass - (if (activation-p condition list-of-value-ass) - (multiple-evaluation relation interface - list-of-value-ass) - (mapcar #'convert-simple-to-multiple - list-of-value-ass)) - number-of-results)))))) - - -(def$method (constraint :evaluate-expression) - (constraint-expr global-net-spec &rest ignore) - - ;;; fuehrt Umsetzung globaler in lokale Variablen durch - ;;; und umgekehrt - (declare (ignore ignore)) - (local-to-global-subst - - constraint-expr - ($send self - :activate - (global-to-local-subst - constraint-expr - global-net-spec)))) - - -(defun multiple-evaluation (relation variables list-of-value-ass) - - ;;; falls keine einwertige Variablenbelegung existiert, - ;;; wird die leere Liste geliefert; - ;;; - ;;; ansonsten wird fuer jede Wertebelegung die Relation - ;;; evaluiert - - (if (null list-of-value-ass) - nil - (append - (evaluate-relation relation - variables - (first list-of-value-ass)) - (multiple-evaluation relation - variables - (rest list-of-value-ass))))) - - -(defun activation-p (condition list-of-value-ass) - - ;;; ueberprueft die Bedingung fuer jede Wertebelegung in - ;;; list-of-value-ass und bildet die Konjunktion der - ;;; Ergebnisse - - (or (null list-of-value-ass) - (and (evaluate-condition condition - (first list-of-value-ass)) - (activation-p condition - (rest list-of-value-ass))))) - - -(defun evaluate-relation (relation variables simple-val-ass) - - ;;; Eingabe: eine Liste von Relationenelemente, - ;;; eine Liste der Variablen, - ;;; eine Wertzuweisung - ;;; - ;;; Ausgabe: neue (multiple) Wertezuweisung, in der im Vergleich zu - ;;; simple-val-ass uneingeschraenkte Variablen einen oder - ;;; mehrere neue Werte erhalten haben - - (if (null relation) - nil - (cons-if-not-nil - (evaluate-relation-element (first relation) - variables - simple-val-ass) - (evaluate-relation (rest relation) - variables - simple-val-ass)))) - - -(defun evaluate-relation-element (rel-element variables simple-val-ass) - - ;;; Eingabe: ein Relationenelement, - ;;; eine Liste der Variablen, - ;;; eine Wertzuweisung - ;;; - ;;; Ausgabe: nil, falls simple-val-ass inkonsistent ist, - ;;; oder neue (multiple) Wertezuweisung, sonst - - (declare (list rel-element variables)) - (case (get-keyword rel-element) - (:tuple (evaluate-tupel (get-tupel rel-element) - variables - simple-val-ass)) - (:pattern (if (or (= (length rel-element) 2) - (evaluate-condition (get-condition rel-element) - simple-val-ass)) - (evaluate-pattern (get-expressions rel-element) - variables - simple-val-ass) - nil)))) - - -(defun evaluate-tupel (tupel variables simple-val-ass - &optional (new-val-ass nil)) - - ;;; Eingabe: eine Liste von Konstanten, - ;;; eine Liste von Variablen und eine Wertzuweisung an diese Variablen - ;;; - ;;; Ausgabe: nil, falls einer der Werte aus tupel nicht mit dem Wert der - ;;; entsprechenden Variable in simple-val-ass vertraeglich ist - ;;; neue Wertzuweisung, sonst - - (cond ((null tupel) new-val-ass) - ((compatible-value-p (first tupel) - (first variables) - simple-val-ass) - (evaluate-tupel (rest tupel) - (rest variables) - simple-val-ass - (cons (new-association - (first variables) - (first tupel)) - new-val-ass))) - (t nil))) - - -(defun evaluate-pattern (pattern variables simple-val-ass - &optional (new-val-ass nil)) - - ;;; Eingabe: eine Liste von Lisp-Ausdruecken, - ;;; eine Liste von Variablen und eine Wertzuweisung an diese Variablen - ;;; - ;;; Ausgabe: es werden nacheinander alle Lisp-Ausdruecke in der Umgebung - ;;; simple-val-ass evaluiert; - ;;; falls dabei ein Wert ermittelt wird, der mit der Wertebelegung - ;;; der entsprechenden Variablen in simple-val-ass nicht - ;;; uebereinstimmt, wird mit nil abgebrochen; - ;;; ansonsten wird eine neue Wertebelgung ermittelt - - (if (null pattern) - (reverse new-val-ass) - (let ((new-value (evaluate-funcall (first pattern) - simple-val-ass))) - (if (compatible-value-p new-value - (first variables) - simple-val-ass) - (evaluate-pattern (rest pattern) - (rest variables) - simple-val-ass - (cons (new-association - (first variables) - new-value) - new-val-ass)) - nil)))) - - -; -; TEST -; - - -(defun constrained-p (&rest variables) - - ;;; Eingabe: Liste von Variablen der aktuellen Lisp-Umgebung - ;;; - ;;; Ausgabe: T, falls keine der Variablen den Wert 'unconstrained - ;;; besitzt - - (cond ((null variables)) - ((eq (car variables) - 'unconstrained) - nil) - (t (apply (function constrained-p) - (cdr variables))))) - - -(defun unconstrained-p (&rest variables) - - ;;; Eingabe: Liste von Variablen der aktuellen Lisp-Umgebung - ;;; - ;;; Ausgabe: T, falls keine der Variablen den Wert 'constrained - ;;; besitzt - - (cond ((null variables)) - ((not (eq (car variables) - 'unconstrained)) - nil) - (t (apply (function unconstrained-p) - (cdr variables))))) - -; -; OPERATIONEN FUER INFO ASSOCIATION -; - - -; info association: -; -; ( . ) -; - -(defmacro make-info-assoc (var var-info) - `(cons ,var ,var-info)) - -(defmacro get-net-var (info-assoc) - `(car ,info-assoc)) - -(defmacro get-var-info (info-assoc) - `(cdr ,info-assoc)) - - -(defun get-var-info-constraints (info-assoc) - - ;;; ermittelt die Constraint-Ausdruecke, die der Variablen in - ;;; info-assoc zugeordnet sind - - (if (null info-assoc) - nil - (var-info-constraints - (get-var-info info-assoc)))) - - -(defun get-var-info-values (info-assoc) - - ;;; ermittelt die Wertemenge, die der Variablen in info-assoc - ;;; zugeordnet sind - - (if (null info-assoc) - (baberror (getentry net-spec-access constraint-io-table)) - (var-info-values - (get-var-info info-assoc)))) - - -(defun add-var-info-values (info-assoc value-spec) - - ;;; ergaenzt die Wertemenge der Variablen in info-assoc - ;;; durch value-spec (Schnittbildung) - - (if info-assoc - (replace-var-info-values - info-assoc - (extended-intersection - (var-info-values - (get-var-info info-assoc)) - value-spec)))) - - -(defun replace-var-info-values (info-assoc value-spec) - - ;;; ersetzt die Wertemenge der Variablen in info-assoc - ;;; durch value-spec (Seiteneffekt !) - - (if info-assoc - (setf (var-info-values - (get-var-info info-assoc)) - value-spec))) - - -(defun freeze-var-info-values (info-assoc) - - ;;; speichert die aktuelle Wertemenge als - ;;; Init-Value - - (if info-assoc - (setf (var-info-init-values - (get-var-info info-assoc)) - (var-info-values - (get-var-info info-assoc))))) - - -(defun init-var-info-values (info-assoc) - - ;;; initialisiert die Values-Komponente mit dem - ;;; Default-Wert - - (if info-assoc - (setf (var-info-values - (get-var-info info-assoc)) - (var-info-init-values - (get-var-info info-assoc))))) - - -(defun reset-var-info-values (info-assoc) - - ;;; setzt Defaultwert auf 'unconstrained - - (if info-assoc - (setf (var-info-init-values - (get-var-info info-assoc)) - 'unconstrained))) - - -;;; eof - diff --git a/t/baby2015/kernel/consat/mini/mc-mixin.cl b/t/baby2015/kernel/consat/mini/mc-mixin.cl deleted file mode 100644 index 643f500..0000000 --- a/t/baby2015/kernel/consat/mini/mc-mixin.cl +++ /dev/null @@ -1,136 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: BABYLON; Base: 10 -*- - - -(in-package "BABYLON") - -; -; MINI-CONSTRAINT-MIXIN -; - - -(def$flavor mini-constraint-mixin - ((consat-trace-window nil)) - (basic-constraint-mixin) - - :settable-instance-variables - (:required-instance-variables procs kb-name) - (:documentation "Anteil des Constraint-Systems am Metaprozessor") - ) - - - -(def$method (mini-constraint-mixin :generate-constraint-processor) () - - "erzeugt einen Constraint-Prozessor " - - (setf constraint-processor - (make-$instance 'mini-constraint-processor - :meta-processor self))) - - -(def$method (mini-constraint-mixin :set-up-constraint-cmds) () - (let ((table (get 'cmd-table ($send self :language)))) - (when (and table ($send self :operation-handled-p :add-operations)) - ($send self :add-sub-operations - :top (gethash 'consat table) - :consat (gethash 'consat-commands table)) - ($send self :add-operations - :consat (gethash 'consat-trace-commands table))))) - - -(assign-typefkt 'constraint-type 'mini-constraint-mixin) - - - -(def$method (mini-constraint-mixin :send-consat-trace-window) (selector &rest args) - "passes messages to consat-trace-window." - (lexpr-$send consat-trace-window selector args)) - - - -(defun trace-constraints () - - (catch 'no-select - (send-kb :choose-trace-mode))) - - -(def$method (mini-constraint-mixin :choose-trace-mode) () - - "ermoeglicht dem Benutzer das An- und Ausschalten von trace-Modes" - - (let ((constr ($send self :choose-c-type))) - (update-constraint-trace-mode - (choose-constraint-trace-mode - (build-constraint-trace-item-list - constr)) - constr))) - - -(defun constraint-assoc-tracedp (constraint-assoc) - ($send (get-object-of-c-assoc constraint-assoc) - :send-if-handles :traced-p)) - - -(def$method (mini-constraint-mixin :update-constraint-trace) () - ($send constraint-processor :set-trace - (or (some #'constraint-assoc-tracedp constraints) - (some #'constraint-assoc-tracedp constraint-nets)))) - - -(defun build-constraint-trace-item-list (constraint-list) - (cons (getentry mark-explain-item constraint-io-table) - (mapcar #'(lambda (constraint-assoc) - `(,constraint-assoc - ,(format nil "~A ~S" - (if (constraint-assoc-tracedp constraint-assoc) - "#" - " ") - (get-name-of-c-assoc constraint-assoc)) - (t))) - constraint-list))) - - -(defun choose-constraint-trace-mode (trace-item-list) - - "bittet den Benutzer um die Wahl der Constraints, - deren Trace-Modes umgeschaltet werden sollen" - - (send-kb :mult-choose-from-menu - trace-item-list - (getentry toggle-trace-modes constraint-io-table))) - - -(defun update-constraint-trace-mode (result-item-list constraints) - - "alle Constraints in result-item-list erhalten die Nachricht :trace-on, -falls sie nicht protokolliert werden, bzw. :trace-off im entgegengesetzten Fall." - - (declare (ignore constraints)) - (when result-item-list - (mapc #'(lambda (constraint-assoc) - (setf (get-object-of-c-assoc constraint-assoc) - ($send (get-object-of-c-assoc constraint-assoc) - (if (constraint-assoc-tracedp constraint-assoc) - :trace-off - :trace-on) - (get-name-of-c-assoc constraint-assoc)))) - result-item-list) - (send-kb :update-constraint-trace))) - - -(def$method (mini-constraint-mixin :protocol) (expr-type expr) - - " Eingabe: expr-type = :enter, :exit, :choice" - - ($send self :send-consat-trace-window :format "~A" - (case expr-type - (:enter (format nil " enter: ~S" expr)) - (:exit (format nil " exit: ~S" expr)) - (:choice (format nil "CHOICE: ~S = ~S" - (get-var expr) (first (get-value-spec expr)))) - (:fail (format nil (getentry fail constraint-io-table) expr))))) - - - -;;; eof - diff --git a/t/baby2015/kernel/consat/mini/mc-proc.cl b/t/baby2015/kernel/consat/mini/mc-proc.cl deleted file mode 100644 index 7685b7b..0000000 --- a/t/baby2015/kernel/consat/mini/mc-proc.cl +++ /dev/null @@ -1,28 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: BABYLON; Base: 10 -*- - - -(in-package "BABYLON") - - -(def$flavor mini-constraint-processor - ((trace nil)) - (basic-constraint-processor) - :gettable-instance-variables - :settable-instance-variables - :initable-instance-variables - (:required-instance-variables meta-processor) - (:documentation " Version des Constraint-Prozessors der Trace unterstuetzt")) - - -(def$method (mini-constraint-processor :trace-status) () - (if trace - (format nil (getentry trace-on-fstr babylon-io-table) "Consat") - (format nil (getentry trace-off-fstr babylon-io-table) "Consat"))) - - - -#-:FMCS(compile-$flavor-$methods mini-constraint-processor) - - -;;; eof - diff --git a/t/baby2015/kernel/consat/mini/mc-trace.cl b/t/baby2015/kernel/consat/mini/mc-trace.cl deleted file mode 100644 index 90cb11d..0000000 --- a/t/baby2015/kernel/consat/mini/mc-trace.cl +++ /dev/null @@ -1,172 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: BABYLON; Base: 10 -*- - - -(in-package "BABYLON") - -; -; TRACER -; - - -; -; TRACE-MIXIN -; - - -(def$flavor constraint-trace-mixin - (name) - () - :settable-instance-variables - :initable-instance-variables - (:documentation "Flavor mit spezifischen Trace-Operationen")) - - -(def$method (constraint-trace-mixin :traced-p) () - "dient zum Test, ob ein gegebenes Constraint den trace-Mode besitzt oder nicht" - t) - - -(def$method (constraint-trace-mixin :evaluate-expression) - (constraint-expr global-net-spec consistency-level) - - "sendet vor und nach der Evaluierung eine entsprechende -Protokollierungsnachricht an den Constraint-Prozessor - -leider konnte kein :after-daemon benutzt werden, -da dieser nicht auf das Ergebnis der aufgerufenen -Funktion zugreifen kann" - - (send-kb :protocol :enter - (cons name (make-local-value-ass - (get-parameters constraint-expr) - (get-parameters constraint-expr) - global-net-spec))) - - (let* ((local-value-ass (global-to-local-subst - constraint-expr - global-net-spec)) - (new-value-ass - (local-to-global-subst - constraint-expr - ($send self - :activate - local-value-ass - 'initialize - (adapt-consistency-level consistency-level))))) - - (send-kb :protocol :exit (cons name new-value-ass)) - new-value-ass)) - - - -(def$method (constraint-trace-mixin :before :test-choices) - (variable value-set number-of-results) - - "sendet Protokollnachricht darueber, welche Wahl fuer die -Variable getroffen wurde" - - (declare (ignore number-of-results)) - (if (null value-set) - (send-kb :protocol :fail variable) - (send-kb :protocol :choice - (make-value-assoc variable value-set)))) - - -; -; TRACED CONSTRAINTS -; - - -(def$flavor traced-constraint - () - (constraint-trace-mixin - constraint) - (:documentation "primitives Constraint mit Trace-Mixin")) - - -(def$flavor traced-constraint-net - () - (constraint-trace-mixin - constraint-net) - (:documentation "Constraint-Netz mit Trace-Mixin") - ) - - -(def$method (constraint :trace-on) (c-name) - - "erzeugt ein Traced-Constraint, dass mit dem -Empfaenger in allen Komponenten (ausser name) uebereinstimmt" - - (make-$instance - 'traced-constraint - :name c-name - :interface interface - :relation relation - :condition condition)) - - -(def$method (constraint :trace-off) (c-name) - (declare (ignore c-name)) - self) - - -(def$method (traced-constraint :trace-on) (c-name) - (declare (ignore c-name)) - self) - - -(def$method (traced-constraint :trace-off) (c-name) - - "erzeugt ein Constraint, dass mit dem Empfaenger in allen -Komponenten (ausser name) uebereinstimmt" - - (declare (ignore c-name)) - (make-$instance - 'constraint - :interface interface - :relation relation - :condition condition)) - - -(def$method (constraint-net :trace-on) (c-name) - - "erzeugt ein Traced-Constraint-Netz, dass mit dem -Empfaenger in allen Komponenten (ausser name) uebereinstimmt" - - (make-$instance - 'traced-constraint-net - :name c-name - :interface interface - :net-spec net-spec - :agenda agenda - :stack stack)) - - -(def$method (constraint-net :trace-off) (c-name) - (declare (ignore c-name)) - self) - - -(def$method (traced-constraint-net :trace-on) (c-name) - (declare (ignore c-name)) - self) - - -(def$method (traced-constraint-net :trace-off) (c-name) - - "erzeugt ein Constraint-Netz, dass mit dem -Empfaenger in allen Komponenten (ausser name) uebereinstimmt" - - (declare (ignore c-name)) - (make-$instance - 'constraint-net - :interface interface - :net-spec net-spec - :agenda agenda - :stack stack)) - - - - -;;; eof - diff --git a/t/baby2015/kernel/consat/normal/nc-mixin.cl b/t/baby2015/kernel/consat/normal/nc-mixin.cl deleted file mode 100644 index 5a2b6bd..0000000 --- a/t/baby2015/kernel/consat/normal/nc-mixin.cl +++ /dev/null @@ -1,40 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: BABYLON; Base: 10 -*- - - -(in-package "BABYLON") - -; -; mini-constraint-mixin -; - - -(def$flavor normal-constraint-mixin - () - (restriction-base mini-constraint-mixin) - - :settable-instance-variables - (:required-instance-variables procs kb-name) -; (:required-flavors kb-processor-core) - (:documentation "Anteil des Constraint-Systems am Metaprozessor") - ) - - - -(def$method (normal-constraint-mixin :generate-constraint-processor) () - - " erzeugt einen Constraint-Prozessor " - - (setf constraint-processor - (make-$instance 'normal-constraint-processor - :meta-processor self))) - -(def$method (normal-constraint-mixin :after :new&delete-restriction) (&rest ignore) - "runterreichen der definierten Restrictions " - (declare (ignore ignore)) - ($send constraint-processor :set-restriction-nets restriction-nets)) - -(assign-typefkt 'constraint-type 'normal-constraint-mixin) - - -;;; eof - diff --git a/t/baby2015/kernel/consat/normal/nc-proc.cl b/t/baby2015/kernel/consat/normal/nc-proc.cl deleted file mode 100644 index bf54d3a..0000000 --- a/t/baby2015/kernel/consat/normal/nc-proc.cl +++ /dev/null @@ -1,70 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: BABYLON; Base: 10 -*- - - -(in-package "BABYLON") - - - - -(def$flavor normal-constraint-processor - () - (restriction-base mini-constraint-processor) - :gettable-instance-variables - :settable-instance-variables - :initable-instance-variables - (:required-instance-variables meta-processor) - (:documentation " Version des Constraint-Prozessors - der Restrictions unterstuetzt")) - - - -(def$method (normal-constraint-processor :after :reset-proc) () - - "setzt alle Restrictions zurueck" - - (mapc (function - (lambda (constraint-assoc) - ($send (get-object-of-c-assoc constraint-assoc) - :redefine-one))) - restriction-nets)) - - - -(def$method (normal-constraint-processor :after :print) - (&optional (stream *default-dialog-stream*)) - - "gibt alle definierten Restrictions in wiedereinlesbarer Form aus." - - (print-constraint-list restriction-nets stream)) - - -(def$method (normal-constraint-processor :after :kb-inform) (stream) - - "gibt die Zahl der Restrictions aus" - - (terpri stream) - (format stream (getentry number-of-restrictions - constraint-io-table) - (length restriction-nets))) - - - -(def$method (normal-constraint-processor :get) (c-name) - - "ermittelt das primitive oder zusammengesetzte Constraint mit - dem angegebenen Namen - (Beachte: ein Netz und ein primitives Constraint duerfen nicht - den gleichen Namen besitzen)" - - (let ((primitive-c-assoc (assoc c-name constraints)) - (compound-c-assoc (assoc c-name constraint-nets))) - - (cond ((get-object-of-c-assoc primitive-c-assoc)) - ((get-object-of-c-assoc compound-c-assoc)) - (($send self :get-restrictions c-name)) - (t nil)))) - -#-:FMCS(compile-$flavor-$methods normal-constraint-processor) - -;;; eof - diff --git a/t/baby2015/kernel/consat/normal/restrict.cl b/t/baby2015/kernel/consat/normal/restrict.cl deleted file mode 100644 index eeb5d15..0000000 --- a/t/baby2015/kernel/consat/normal/restrict.cl +++ /dev/null @@ -1,381 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: BABYLON; Base: 10 -*- - - -(in-package "BABYLON") - - -; -; HILFSFUNKTIONEN FUER RESTRICTION NETS -; - - - -; -; BESCHREIBUNG DES RESTRICTION-NETZES -; - - -(def$flavor restriction-definition - - ((restrictions nil) - (protected nil) - (guarded nil)) - () - - :settable-instance-variables - :initable-instance-variables - (:documentation "generische Beschreibung des Netzes noetig fuer Neugenerierung.") - ) - - -(def$method (restriction-definition :store-definition) - (new-restrictions new-guarded new-protected) - - " speichert generische Beschreibung des Netzes" - - (setf restrictions new-restrictions) - (setf guarded new-guarded) - (setf protected new-protected)) - - -(def$method (restriction-definition :print) (name stream) - - " Ausgabe des Restriction-Net" - - (princ " " stream) - (terpri stream) - (babpprint - `(defrestriction ,name - (:guarded-slots . ,guarded) - (:protected-slots . ,protected) - (:restrictions . ,restrictions)) - stream) - (terpri stream)) - - - -; -; FLAVOR RESTRICTION-NET -; - - -(def$flavor restriction-net - - ((changed-slots nil) - (more-restricted-slots nil)) - (restriction-definition - constraint-net) - - :settable-instance-variables - :initable-instance-variables - (:documentation "Constraintnetz auf Slots")) - - - -; -; MACROS -; - - -(defmacro make-slot-ref (object slot) - `(list ,object ,slot)) - - -(defmacro get-object-of-slot-ref (slot-ref) - - " liefert Instanz oder Variable der Slot-referenz" - - `(first ,slot-ref)) - - -(defmacro get-slot-of-slot-ref (slot-ref) - `(second ,slot-ref)) - - - - -; -; TRACER-ANTEILE AN RESTRICTION-NET -; - - -; -;(def$flavor traced-restriction-net -; -; ;;; Restriction-Netz mit Trace-Mixin -; -; () -; (constraint-trace-mixin -; restriction-net) -; ) - -; -;(def$method (restriction-net :trace-on) -; (c-name) -; (declare(ignore c-name)) -; -; ;;; erzeugt ein Traced-Restriction-Netz, dass mit dem -; ;;; Empfaenger in allen Komponenten (ausser name) uebereinstimmt -; -; (make-$instance -; 'traced-restriction-net -; :name c-name -; :interface interface -; :net-spec net-spec -; :agenda agenda -; :stack stack -; :restrictions restrictions -; :protected protected -; :guarded guarded -; :changed-slots changed-slots -; :more-restricted-slots more-restricted-slots -; )) -; -; -;(def$method (restriction-net :trace-off) -; (c-name) -; (declare(ignore c-name)) -; self) -; -; -;(def$method (traced-restriction-net :trace-on) -; (c-name) -; (declare(ignore c-name)) -; self) -; -; -;(def$method (traced-restriction-net :trace-off) -; (c-name) -; (declare(ignore c-name)) -; ;;; erzeugt ein Restriction-Netz, dass mit dem -; ;;; Empfaenger in allen Komponenten (ausser name) uebereinstimmt -; -; (make-$instance -; 'restriction-net -; :interface interface -; :net-spec net-spec -; :agenda agenda -; :stack stack -; :restrictions restrictions -; :protected protected -; :guarded guarded -; :changed-slots changed-slots -; :more-restricted-slots more-restricted-slots -; )) -; -; - -; -; BEWACHUNG VON SLOTS -; - - -(def$flavor restricted-slot - ((value -) - (restriction-net nil) - (protected nil) - (guarded nil)) - () - :settable-instance-variables - :initable-instance-variables - (:documentation "Flavor fuer Active-Value. -Jeder Slot in einem Restriction-Net erhaelt einen solchen.")) - - - -(def$method (restricted-slot :put) - (instance slot new-value &optional (test nil)) - - ;;; if the option test isn't equal :test - ;;; the specified slot is added to the list of modified slots and - ;;; the slot value is set to new-value; - ;;; - ;;; otherwise it is tested if all atteched constraints are satisfied - ;;; after assigning new-value to slot; - ;;; - ;;; if an inconsistency is detected the write access is refused - ;;; - ;;; a call of this method yields - ;;; - t, if a write access has been performed - ;;; - nil, otherwise - - (cond ((not (eq test :test)) - ($send restriction-net - :update-slot-state - (make-slot-ref ($send instance :object-name) - slot) - value) - (setf value new-value) - t) - (($send restriction-net - :demon - (list (make-value-assoc - (make-slot-ref - ($send instance :object-name) - slot) - (slot-value-to-value-spec new-value)))) - (setf value new-value) - t) - (t nil))) - - -;(def$method (restricted-slot :put) -; (instance slot new-value) ;;; ????? -; -; ;;; falls ein bewachter Slot vorliegt, wird Aktivierung -; ;;; des Netzes ausgeloest, -; ;;; -; ;;; ansonsten wird der Slot in die Liste der geaenderten -; ;;; Slots eingefuegt -; ;;; -; ;;; Ergebnis: T, falls Schreibvorgang durchgefuehrt -; ;;; nil, falls Wert verweigert wird -; -; (cond ((not guarded) -; ($send restriction-net -; :update-slot-state -; (make-slot-ref ($send instance :object-name) -; slot) -; value) -; (setf value new-value) -; t) -; (($send restriction-net -; :demon -; (list (make-value-assoc -; (make-slot-ref -; ($send instance :object-name) -; slot) -; (slot-value-to-value-spec new-value)))) -; (setf value new-value) -; t) -; (t nil))) - - -(def$method (restricted-slot :try-put) (new-value) ;;; ????? - - ;;; fuehrt Schreibvorgang durch, falls Slot nicht geschuetzt ist - - (if (not protected) - (setf value new-value))) - - - -(def$method (restricted-slot :get) () - - ;;; liefert Wert des Slot - - value) - - - -; -; ERZEUGUNG DER BEWACHTEN SLOTS -; - - -(def$method (restriction-net :make-active-values) (guarded-slots protected-slots) - - ;;; erzeugt Active-Values fuer alle Slots - - (mapc (function - (lambda (slot-ref) - ($send self :make-slot-restriction - (get-instance - (get-object-of-slot-ref slot-ref)) - (get-slot-of-slot-ref slot-ref)))) - interface) - - (mapc (function - (lambda (slot-ref) - ($send self :make-guarded-slot - (get-instance - (get-object-of-slot-ref slot-ref)) - (get-slot-of-slot-ref slot-ref)))) - guarded-slots) - - (mapc (function - (lambda (slot-ref) - ($send self :make-protected-slot - (get-instance - (get-object-of-slot-ref slot-ref)) - (get-slot-of-slot-ref slot-ref)))) - protected-slots)) - - - -(def$method (restriction-net :make-slot-restriction) (instance slot) - - ;;; erzeugt aktiven Wert fuer diesen Slot - - (if ($send self :correct-restriction-net instance slot) - - ($send instance - :replace - slot - (make-$instance - 'restricted-slot - :value ($send instance :get slot) - :restriction-net self)) - - (baberror (getentry restriction-error constraint-io-table)))) - - - -(def$method (restriction-net :make-guarded-slot) (instance slot) - - ;;; markiert den Slot als bewacht - - (if ($send self :correct-restriction-net - instance slot) - ($send ($send instance :get-value-only slot) - :set-guarded - t))) - - -(def$method (restriction-net :make-protected-slot) (instance slot) - - ;;; markiert den Slot als bewacht - - (if ($send self :correct-restriction-net - instance slot) - ($send ($send instance :get-value-only slot) - :set-protected - t))) - - -(def$method (restriction-net :correct-restriction-net) (instance slot) - - ;;; falls der Slot bereits einem (noch existierendem !) Netz - ;;; zugeordnet ist und dieses mit demjenigen uebereinstimmt, - ;;; an das die Nachricht ge$sendet wurde, - ;;; wird t als Ergebnis geliefert; - ;;; falls der Slot noch zu keinem Netz gehoert oder dieses nicht mehr - ;;; definiert ist, wird ebenfalls t geliefert; - - (let ((value ($send instance :get-value-only slot))) - (cond ((not (flavor-typep value 'restricted-slot)) t) - ((send-kb - :is-defined-p ($send value :restriction-net)) - (eql ($send value :restriction-net) self)) - (t t)))) - - ;;; ($send - ;;; ($send instance :send-if-handles - ;;; :get-value-only slot) - ;;; :restriction-net)) - -(defun undetermined-slot-value-p (slot-value) - (member slot-value '(- unknown))) - - -(defun slot-value-to-value-spec (slot-value) - - " ueberfuehrt slot-value in eine Consat-Wertemenge" - - (cond ((undetermined-slot-value-p slot-value) - 'unconstrained) - (T (list slot-value)))) - - -;;; eof - diff --git a/t/baby2015/kernel/consat/normal/rstrbase.cl b/t/baby2015/kernel/consat/normal/rstrbase.cl deleted file mode 100644 index e66437c..0000000 --- a/t/baby2015/kernel/consat/normal/rstrbase.cl +++ /dev/null @@ -1,485 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: BABYLON; Base: 10 -*- - - -(in-package "BABYLON") - -; -; KONSTRUKTOR FUER RESTRICTIONS -; - - - -(defmacro defrestriction (name &rest expr) - - `(send-kb - :new&delete-restriction - ',name - ',(get-guarded-slots expr) - ',(get-protected-slots expr) - ',(get-restrictions expr))) - - -; -; HILFSFUNKTIONEN -; - - -(defun get-guarded-slots (expr) - - (let ((entry (assoc :guarded-slots expr :test 'equal))) - (if (null entry) nil - (cdr entry)))) - - -(defun get-protected-slots (expr) - - (let ((entry (assoc :protected-slots expr :test 'equal))) - (if (null entry) nil - (cdr entry)))) - - -(defun get-restrictions (expr) - - (let ((entry (assoc :restrictions expr :test 'equal))) - (if (null entry) - (baberror (getentry no-restrictions constraint-io-table) - expr) - (cdr entry)))) - - -(defmacro get-inst-assignment (generic-restriction) - - `(cdr ,generic-restriction)) - - -(defmacro inst-assignment-p (inst-ass) - - " ueberprueft, ob der Anfang der Liste inst-ass eine - Belegung einer variablen darstellt" - - `(and (> (length ,inst-ass) 2) - (atom (first ,inst-ass)) - (eq (second ,inst-ass) '=) - (not (eq (first ,inst-ass) :if)))) - - -(defmacro get-var-of-inst-ass (inst-ass) - - `(first ,inst-ass)) - - -(defmacro get-set-of-instances (inst-ass) - - `(third ,inst-ass)) - - -(defmacro next-inst-assignment (inst-ass) - - `(rest (rest (rest ,inst-ass)))) - - -(defun get-instance-condition (expr) - - (cond ((null (rest expr)) T) - ((eq (first expr) :if) - (second expr)) - (t (get-instance-condition (rest expr))))) - - -(defun get-uninstantiated-restriction (restriction) - - (car (last restriction))) - - -(defun get-slot-refs (expr) - - (cond ((generic-expr-p expr) - (get-slot-refs (get-inst-assignment expr))) - ((inst-assignment-p expr) - (get-slot-refs (next-inst-assignment expr))) - ((null expr) - (baberror (getentry slot-description-error constraint-io-table))) - (T expr))) - - - -; -; INSTANTIIERUNG VON RESTRICTIONS -; - - -(defun instantiate-restrictions (list-of-restriction) - - " ermittelt Menge aller Restrictions, die durch - list-of-restrictions beschrieben werden" - - (if (null list-of-restriction) nil - (union-sets - (inst-restriction - (first list-of-restriction)) - (instantiate-restrictions - (rest list-of-restriction))))) - - -(defun inst-restriction (restriction) - - " ermittelt Menge aller Restrictions, die durch - list-of-restrictions beschrieben werden" - - (if (generic-expr-p restriction) - (inst-generic-restriction restriction) - (inst-simple-restriction restriction))) - - -(defun generic-expr-p (restriction) - (eq (first restriction) :for-all)) - - -(defun inst-simple-restriction (restriction) - (list restriction)) - - -(defun inst-generic-restriction (restriction) - - " fuer alle Wertekombinationen der Variablen wird - die eingeschlossene uninstantiierte Restriction - instantiiert, falls die Variablen die angegebene - Bedingung erfuellen" - - (mapcar (function - (lambda (simple-alist) - (inst-uninstantiated-restriction - (get-uninstantiated-restriction - restriction) - simple-alist))) - (get-instance-combinations - restriction))) - - -(defun inst-uninstantiated-restriction (restriction simple-alist) - - " ersetzt die Variablen in restriction durch die Instanz, - die ihnen simple-alist zuweist" - - (make-c-expr - (get-constr-name restriction) - (inst-slot-ref-list (get-parameters restriction) - simple-alist))) - - -(defun inst-slot-ref-list (slot-ref-list simple-alist) - - " instantiiert alle Slots in slot-ref-list" - - (mapcar (function - (lambda (slot-ref) - (inst-slot-ref slot-ref simple-alist))) - slot-ref-list)) - - -(defun inst-slot-ref (slot-ref simple-alist) - - " falls die erste Komponente von slot-ref in simple-alist - auftritt, wird sie durch die entsprechende Instanz ersetzt" - - (let ((instance-assoc (assoc (get-object-of-slot-ref - slot-ref) - simple-alist :test 'equal))) - (if (null instance-assoc) - slot-ref - (make-slot-ref - (get-simple-value instance-assoc) - (get-slot-of-slot-ref slot-ref))))) - - -; -; ERMITTLE INSTANZENKOMBINATIONEN -; - - -(defun get-instance-combinations (restriction) - - " liefert die Menge von Assoziationslisten, - fuer die die eingeschlossene restriction - instantiiert werden soll" - - (select-instance-combinations - (split-variable-alist - (purge-instance-alist - (make-$instance-alist - (get-inst-assignment restriction)) - (get-parameters - (get-uninstantiated-restriction restriction)))) - (get-instance-condition restriction))) - - -(defun make-$instance-alist (inst-ass) - - " baut eine Assoziationsliste fuer die variablen - des for-all-Konstrukts" - - (if (not (inst-assignment-p inst-ass)) nil - (cons (make-value-assoc - (get-var-of-inst-ass inst-ass) - (determine-set-of-instances - (get-set-of-instances inst-ass))) - (make-$instance-alist - (next-inst-assignment inst-ass))))) - - -(defun purge-instance-alist (alist slot-ref-list) - - " entfernt alle Variablen aus alist, die nicht in - slot-ref-list auftreten" - - (cond ((null alist) nil) - ((occurs-in-restriction (get-var (first alist)) - slot-ref-list) - (cons (first alist) - (purge-instance-alist (rest alist) - slot-ref-list))) - (T - (purge-instance-alist (rest alist) - slot-ref-list)))) - - -(defun occurs-in-restriction (variable slot-ref-list) - - " ueberprueft, ob die Variable auch tatsaechlich in - slot-ref-list auftritt" - - (and slot-ref-list - (or (equal variable - (get-object-of-slot-ref - (first slot-ref-list))) - (occurs-in-restriction variable - (rest slot-ref-list))))) - - -(defun select-instance-combinations (list-of-alists condition) - - " waehlt all diejenigen alists aus, die die Bedingung - erfuellen" - - (cond ((null list-of-alists) nil) - ((evaluate-condition condition - (first list-of-alists)) - (cons (first list-of-alists) - (select-instance-combinations - (rest list-of-alists) - condition))) - (T (select-instance-combinations - (rest list-of-alists) - condition)))) - - -(defun determine-set-of-instances (expr) - - " ermittelt eine Menge von Instanzen" - - (case (first expr) - (:instance-of - (get-all-instances (second expr))) - (:one-of - (cdr expr)))) - - -; -; Slot-Mengen instantiieren -; - - -(defun determine-slots (set-of-slots all-slots) - - " instantiiert alle Slot-Referenzen in set-of-slots" - - (case (car set-of-slots) - (:none nil) - (:all all-slots) - (otherwise - (instantiate-slots set-of-slots)))) - - -(defun instantiate-slots (set-of-slots) - - (if (null set-of-slots) nil - (union-sets - (if (generic-expr-p (first set-of-slots)) - (inst-slot-set (first set-of-slots)) - (list (first set-of-slots))) - (instantiate-slots (rest set-of-slots))))) - - -(defun inst-slot-set (slot-description) - - " instantiiert die eingeschlossenen Slot-Referenzen" - - (remove-duplicates - (mapcan (function - (lambda (simple-alist) - (inst-slot-ref-list - (get-slot-refs slot-description) - simple-alist))) - (split-variable-alist - (make-$instance-alist - (get-inst-assignment slot-description)))))) - - -; -; Constraintausdruecke auf Slots: DEFINITION -; - - - - -(def$flavor restriction-base - ((restriction-nets nil)) - () - - :settable-instance-variables - :initable-instance-variables) - - - -; -; ZUGRIFF AUF RESTRICTION NETS -; - - -(def$method (restriction-base :get-restrictions) (name) - - " Zugriff auf Restriction-Net ueber Name" - - (let ((c-assoc (assoc name restriction-nets :test 'equal))) - (if c-assoc - (get-object-of-c-assoc c-assoc)))) - - -(def$method (restriction-base :put-restrictions) (name net) - - " Eintrag eines neuen Restriction-Nets" - - (setf restriction-nets - (cons (make-constraint-assoc - name net) - restriction-nets))) - - -(def$method (restriction-base :is-defined-p) (r-net) - - " testet, ob das Restriction-Net r-net definiert, d.h. in der - restriction-base eingetragen ist" - - (rassoc r-net restriction-nets)) - - -(def$method (restriction-base :delete-restrictions) (name) - - " Loeschen eines Restriction-net" - - (let ((c-assoc (assoc name restriction-nets :test 'equal))) - (if c-assoc - (setf restriction-nets - (remove c-assoc restriction-nets :test 'equal))))) - - -; -; DEFINITION EINES NETZES -; - - -(def$method (restriction-base :new-restriction) - (name guarded-slots protected-slots restrictions) - - " Definition eines neuen Restriction-Netzes" - - (if (or ($send self :get name) - ($send self :get-restrictions name)) - nil - (let ((new-net - (make-$instance 'restriction-net))) - - ($send self :put-restrictions - name new-net) - - ($send new-net :store-definition - restrictions - guarded-slots - protected-slots) - - ($send new-net :set-net-spec - (create-net-spec - (instantiate-restrictions restrictions))) - - ($send new-net :set-interface - ($send new-net :net-variables)) - - ($send new-net :make-active-values - (determine-slots guarded-slots - ($send new-net :net-variables)) - (determine-slots protected-slots - ($send new-net :net-variables)))))) - - - -(def$method (restriction-base :redefine) (name) - - (let ((r-net ($send self :get-restrictions name))) - (if (null r-net) nil - ($send r-net :redefine-one)))) - - -(def$method (restriction-base :redefine-all) () - - " erzeugt alle Restriction-Netze neu" - - (mapc (function - (lambda (constraint-assoc) - ($send (get-object-of-c-assoc - constraint-assoc) - :redefine-one))) - restriction-nets)) - - -(def$method (restriction-net :redefine-one) () - - " Erzeugen eines neuen Netzes mit Hilfe der generischen - Beschreibung - (noetig bei Aenderung von Wissensbasiskomponenten, - die in der Definition des Netzes benutzt werden" - - ($send self :set-net-spec - (create-net-spec - (instantiate-restrictions - ($send self :restrictions)))) - - ($send self :set-interface - ($send self :net-variables)) - - ($send self :make-active-values - (determine-slots - ($send self :guarded) - ($send self :net-variables)) - (determine-slots - ($send self :protected) - ($send self :net-variables))) - - ($send self :set-agenda - (make-agenda-elem)) - ($send self :set-stack nil)) - - -(def$method (restriction-base :new&delete-restriction) - (name guarded-slots protected-slots restrictions) - - ($send self :delete-restrictions name) - ($send self :new-restriction - name - guarded-slots - protected-slots - restrictions)) - - - -;;; eof - diff --git a/t/baby2015/kernel/consat/normal/rstreval.cl b/t/baby2015/kernel/consat/normal/rstreval.cl deleted file mode 100644 index e6c0185..0000000 --- a/t/baby2015/kernel/consat/normal/rstreval.cl +++ /dev/null @@ -1,407 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-lisp; Package: BABYLON; Base: 10 -*- - - - -(in-package "BABYLON") - - -; -; ABARBEITUNG VON RESTRICTION NETS -; - - - - -; -; NACHRICHTEN FUER RESTRICTION-NET -; - -(defun admissible-net-p (list-of-slots net-spec) - - " liefert t, falls die Wertebelegung der Netzvariablen - noch zulaessig ist" - - (if (null list-of-slots) t - (and (admissible-slot-value-p - (first list-of-slots) - net-spec) - (admissible-net-p - (rest list-of-slots) - net-spec)))) - - -(defun admissible-slot-value-p (slot-ref net-spec) - - " liefert t, falls fuer den Slot gilt - - { sv( slot ) } = cv( slot )" - - (equal (slot-value-to-value-spec - (get-value-of-referenced-slot - slot-ref)) - (get-var-info-values - (assoc slot-ref net-spec :test 'equal)))) - - -(defun further-slot-restriction-p (slot-ref net-spec) - - " liefert T, falls der Slotwert im Vergleich zum Wert im - Constraint-Netz eine neue Restriction darstellt, also falls gilt - - { sv( slot) } -= cv( slot) und - sv( slot) -= undetermined " - - (let ((slot-value (get-value-of-referenced-slot - slot-ref))) - - (and (not (undetermined-slot-value-p slot-value)) - (not (equal (slot-value-to-value-spec - slot-value) - (get-var-info-values - (assoc slot-ref net-spec :test 'equal))))))) - - -(defun make-value-ass-of-posted-slots (list-of-slots net-spec) - - " liefert Wertebelegung derjenigen Slots, die seit dem - letzten stabilen Zustand staerker eingeschraenkt wurden" - - (cond ((null list-of-slots) nil) - ((further-slot-restriction-p - (first list-of-slots) - net-spec) - (cons (make-value-assoc - (first list-of-slots) - (copy-slot-value (first list-of-slots))) - (make-value-ass-of-posted-slots - (rest list-of-slots) - net-spec))) - (t (make-value-ass-of-posted-slots - (rest list-of-slots) - net-spec)))) - - - -; -; ABBILDUNG DER SLOTWERTE AUF CONSAT -; - - - -(defun copy-slot-value (slot-ref) - - " liest einen Slotwert und passt seine Repraesentation an" - - (slot-value-to-value-spec - ($send ($send (get-instance - (get-object-of-slot-ref slot-ref)) - :get-value-only - (get-slot-of-slot-ref slot-ref)) - :get))) - - - -(defun copy-possible-values (slot-ref) - - " liest die Possible-Values des Slots und - transformiert die Repraesentation" - - (possible-values-to-value-spec - ($send (get-instance - (get-object-of-slot-ref slot-ref)) - :get - (get-slot-of-slot-ref slot-ref) - :possible-values))) - - - -(defun replace-slot-value (slot-ref value-spec) - - " fuehrt einen Schreibversuch auf den Slot durch, - falls value-spec einelementig ist" - - (if (and (not (eq value-spec 'unconstrained)) - (= (length value-spec) 1)) - ($send ($send (get-instance - (get-object-of-slot-ref slot-ref)) - :get-value-only - (get-slot-of-slot-ref slot-ref)) - :try-put - (first value-spec)))) - - - -(defun replace-possible-values (slot-ref value-spec) - - " ersetzt possible-values, falls value-spec ungleich - unconstrained ist" - - (if (not (eq value-spec 'unconstrained)) - ($send (get-instance - (get-object-of-slot-ref slot-ref)) - :put - (get-slot-of-slot-ref slot-ref) - (cons :one-of value-spec) - :possible-values))) - - - -(defun possible-values-to-value-spec (possible-values) - - " ueberfuehrt die Possible-Values-Beschreibung in eine - Consat-Wertemenge" - - (cond ((null possible-values) 'unconstrained) - ((atom possible-values) - (case possible-values - (:any 'unconstrained) - (:symbol 'unconstrained) - (:number 'unconstrained) - (:list 'unconstrained) - (:string 'unconstrained) - (:boolean '(t nil)))) - - (t (case (first possible-values) - - (:interval 'unconstrained) - (:instance-of 'unconstrained) - (:not 'unconstrained) - - (:one-of (rest possible-values)) - - (otherwise - (baberror "keine multiple-values erlaubt")))))) - - -(defun get-value-of-referenced-slot (slot-ref) - - " ermittelt Wert des Slots" - - ($send (get-instance - (get-object-of-slot-ref slot-ref)) - :get - (get-slot-of-slot-ref slot-ref))) - -;;; - -(def$method (restriction-net :test-values) () - - " ueberprueft die aktuellen Slotwerte auf Konsistenz" - - ($send self :get-stable-state) - ($send self :consistent-p)) - - -(def$method (restriction-net :modify-values) () - - " ueberprueft die Konsistenz der aktuellen Slotwerte; - evtl. erhalten Slots ohne Wert einen Wert zugewiesen" - - ($send self :get-stable-state) - (cond (($send self :consistent-p) - ($send self :replace-values) - t) - (t nil))) - - -(def$method (restriction-net :test-possible-values) () - - " ueberprueft die Possible-Values der Slots auf - Konsistenz und aendert die Defaultwerte - entsprechend" - - ($send self :filter-possible-values) - ($send self :consistent-p)) - - -(def$method (restriction-net :modify-possible-values) () - - " wie :test-possible-values; - zusaetzlich werden die :possible-values aktualisiert" - - ($send self :filter-possible-values) - ($send self :replace-possible-values) - ($send self :consistent-p)) - - - -(def$method (restriction-net :demon) (value-ass) - - " ueberfuehrt Netz in einen stabilen Zustand; - danach wird Netz versuchsweise mit value-assignment - aktiviert; - bei Konsistenz wird das Ergebnis der Propagierung beibehalten - und Slotwerte angepasst" - - ($send self :get-stable-state) - ($send self :store-state) - ($send self :initialize-variables value-ass) - ($send self :initialize-agenda value-ass) - - ($send self :propagate 'local-consistency) - - (cond (($send self :consistent-p) - ($send self :replace-values) - ($send self :forget-state) - t) - (t ($send self :restore-state) - (if ($send self :consistent-p) - ($send self :replace-values)) - nil))) - - - -; -; ZUSTAND DES NETZES -; - - - -(def$method (restriction-net :filter-possible-values) () - - " ueberfuehrt das Netz (falls noch nicht geschehen) vom Anfangszustand - in einen Zustand, in dem - - - das Netz gefiltert und die possible-values propagiert wurden - - alle Slots in die changed-Liste eingefuegt werden" - - (cond ((not (agenda-elem-filtered-p agenda)) - ($send self :copy-possible-values) - ($send self :total-init-queue) - (setf (agenda-elem-trace agenda) nil) - - ($send self :propagate 'local-consistency) - - ($send self :freeze-state) - ($send self :init-slot-state) - - (setf (agenda-elem-filtered-p agenda) t)))) - - - -(def$method (restriction-net :get-stable-state) () - - " ueberfuehrt das Netz in einem Zustand, in dem - - - alle inzwischen durchgefuehrten Slotwertaenderungen propagiert - werden und das Netz somit wieder mit den Slotwerten uebereinstimmt" - - ($send self :filter-possible-values) - - (cond ((admissible-net-p changed-slots net-spec) - (let ((value-ass (make-value-ass-of-posted-slots - more-restricted-slots - net-spec))) - ($send self :initialize-variables value-ass) - ($send self :initialize-agenda value-ass))) - - (t ($send self :get-initiale-state) - ($send self :copy-values) - ($send self :total-init-queue))) - - ($send self :propagate 'local-consistency) - ($send self :reset-slot-state)) - - - -; -; PROTOKOLLIERUNG DER GEAENDERTEN SLOTS -; - - -(def$method (restriction-net :init-slot-state) () - - " initialisiert die Slot-Listen, um die - Herstellung eines ersten stabilen Zustands - zu ermoeglichen" - - (setf changed-slots interface) - (setf more-restricted-slots interface)) - - -(def$method (restriction-net :reset-slot-state) () - - " loescht alle protokollierten Schreibvorgaenge" - - (setf changed-slots nil) - (setf more-restricted-slots nil)) - - -(def$method (restriction-net :update-slot-state) (slot-ref old-value) - - " protokolliert Schreibvorgang auf Slot" - - (cond ((or (member slot-ref changed-slots :test 'equal) - (member slot-ref more-restricted-slots :test 'equal))) - - ((undetermined-slot-value-p old-value) - (setf more-restricted-slots - (cons slot-ref more-restricted-slots))) - (t - (setf changed-slots - (cons slot-ref changed-slots))))) - - -; -; ABBILDUNG DER SLOTS AUF NETZVARIABLEN -; - - - -(def$method (restriction-net :copy-values) () - - " kopiere die Werte aller Slots auf die Netzvariablen" - - (mapc (function - (lambda (info-assoc) - (add-var-info-values - info-assoc - (copy-slot-value - (get-net-var info-assoc))))) - net-spec)) - - -(def$method (restriction-net :copy-possible-values) () - - " kopiere :possible-values auf Netzvariablen" - - (mapc (function - (lambda (info-assoc) - (add-var-info-values - info-assoc - (copy-possible-values - (get-net-var info-assoc))))) - net-spec)) - - -(def$method (restriction-net :replace-values) () - - ;;; fuehrt fuer jede Netzvariable mit einelementiger - ;;; Wertemenge einen Schreibversuch auf die Slots durch - - (mapc (function - (lambda (info-assoc) - (replace-slot-value - (get-net-var info-assoc) - (get-var-info-values info-assoc)))) - net-spec)) - - -(def$method (restriction-net :replace-possible-values) () - - " ersetzt die :possible-values-Komponente der Slots - durch die Wertebelgung der entsprechenden - Netzvariablen" - - (mapc (function - (lambda (info-assoc) - (replace-possible-values - (get-net-var info-assoc) - (get-var-info-values info-assoc)))) - net-spec)) - - - - -;;; eof - diff --git a/t/baby2015/kernel/frames/basic/bf-inter.cl b/t/baby2015/kernel/frames/basic/bf-inter.cl deleted file mode 100644 index f1777ff..0000000 --- a/t/baby2015/kernel/frames/basic/bf-inter.cl +++ /dev/null @@ -1,107 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Base: 10; Package: BABYLON -*- - -(in-package "BABYLON") - -;; Copyright 1986, 1985 and 1984 BY -;; G M D -;; Postfach 1240 -;; D-5205 St. Augustin -;; FRG - - -;; DATE: uralt -;; AUTHOR: Franco di Primio, Eckehard Gross - -;; This file depends on: common>* -;; frames>basic>frames -;; -;; Contents: a frame interpreter - - -(def$flavor frame-interpreter - ()() - (:required-instance-variables meta-processor) - (:documentation "flavor providing access and modification methods for frames.")) - - -(def$method (frame-interpreter :get-value-only) - (instance-name slot-name &optional (prop-name :value)) - "basic access method for a property of a slot of an instance." - ($send (get-instance instance-name) :get-value-only slot-name prop-name)) - -(def$method (frame-interpreter :get) - (instance-name slot-name &optional (prop-name :value)) - "access method for a property of a slot of an instance." - ($send (get-instance instance-name) :get slot-name prop-name)) - - -(def$method (frame-interpreter :replace) - (instance-name slot-name value &optional (prop-name :value)) - "basic modification method for a property of a slot of an instance." - ($send (get-instance instance-name) :replace slot-name value prop-name)) - -(def$method (frame-interpreter :set) - (instance-name slot-name value &optional (prop-name :value)) - "modification method for a property of a slot of an instance." - ($send (get-instance instance-name) :set slot-name value prop-name)) - -(def$method (frame-interpreter :put) - (instance-name slot-name value &optional (prop-name :value)) - "modification method for a property of a slot of an instance." - ($send (get-instance instance-name) :put slot-name value prop-name)) - - -(def$method (frame-interpreter :delete-property) - (instance-name slot-name prop-name) - "deletes a property of a slot of an instance." - ($send (get-instance instance-name) :delete-property slot-name prop-name)) - -(def$method (frame-interpreter :type) (instance-name &optional a-frame-name) - "provides the type of an instance or checks whether the instance is of specified type." - ($send (get-instance instance-name) :type a-frame-name)) - - -(def$method (frame-interpreter :ask) - (frame-reference &optional (negation-flag nil)) - "asks the user for the value (of a property) of a slot of an instance." - (let ((instance-name (first frame-reference)) - (slot-name (second frame-reference)) - (args (rest (rest frame-reference)))) - (if (not slot-name) - ($send (get-instance instance-name) :ask-for-slot-values) - (if (listp slot-name) - ($send (get-instance instance-name) - :ask-for-slot-values slot-name) - ($send (get-instance instance-name) - :ask slot-name args negation-flag))))) - -(def$method (frame-interpreter :eval-reference) - (frame-reference &optional (mode :recall)) - "generic method to get or set a property of a slot of an instance." - (let ((instance-name (first frame-reference)) - (slot-or-method (second frame-reference)) - (args (rest (rest frame-reference)))) - (cond ((is-user-defined-method slot-or-method) - (lexpr-$send (get-instance instance-name) slot-or-method - (eval `(list ,@args ,mode)))) ; to evaluate args - ((null (rest args)) - ($send (get-instance instance-name) :get - slot-or-method (or (first args) :value))) - (t (let ((normed-args (normalize-args args))) - (case mode - ((:recall :remember) - ($send (get-instance instance-name) mode - slot-or-method - (internal-relation-name (second normed-args)) - (third normed-args) - (first normed-args))) ; property - (:store - ($send (get-instance instance-name) mode - slot-or-method - (third normed-args) - (first normed-args))) ; property - (t (baberror (getentry mode-error-fstr frame-io-table) - mode)))))))) - -;;; eof - diff --git a/t/baby2015/kernel/frames/basic/bf-mixin.cl b/t/baby2015/kernel/frames/basic/bf-mixin.cl deleted file mode 100644 index 3ef3c17..0000000 --- a/t/baby2015/kernel/frames/basic/bf-mixin.cl +++ /dev/null @@ -1,564 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; BASE: 10. ;Package: BABYLON -*- - -(in-package "BABYLON") - - -;; Copyright 1986, 1985 and 1984 BY -;; G M D -;; Postfach 1240 -;; D-5205 St. Augustin -;; FRG - - -;; DATE: April 1987 -;; AUTHORS: Franco di Primio, Eckehard Gross - -;; This file depends on: common>* -;; frames>basic>frames -;; - -;; contents: a mixin making the facilities of basic-frame-processor available -;; for a knowledge base. - -;;-------------------------------------------------------------------------- -;; FLAVOR BASIC-FRAME-MIXIN -;;-------------------------------------------------------------------------- - -(def$flavor basic-frame-mixin - (frame-processor - (pkg nil) ;; the package where to put frames and instances - ;; just as a hash table - (frames nil) - (instances nil)) - () - :settable-instance-variables - (:required-instance-variables - procs kb-name active-proc system-trace system-trace-window) - (:documentation "This mixin makes the facilities of basic-frame-processor available.")) - - -(def$method (basic-frame-mixin :after :init) (&rest plist) - (declare (ignore plist)) - ($send self :set-up-prefix) - ($send self :generate-frame-processor) - (setf procs (cons frame-processor procs))) - -(def$method (basic-frame-mixin :set-up-prefix) () - "generates a package for the names of frames and instances." - (let ((pkg-name (or pkg kb-name))) - (setf pkg (or (find-package pkg-name) - (make-package pkg-name :use nil #+:lispm :size #+:lispm 200.))))) - -(def$method (basic-frame-mixin :generate-frame-processor) () - "generates an instance of basic-frame-processor associated with the kb." - (setf frame-processor (make-$instance 'basic-frame-processor - :meta-processor self))) - - -(def$method (basic-frame-mixin :set-up-frame-cmds) () - (let ((table (get 'cmd-table ($send self :language)))) - (when (and table ($send self :operation-handled-p :add-operations)) - ($send self :add-sub-operations - :top (gethash 'frame table) - :frame (gethash 'frame-commands table))))) - - -(def$method (basic-frame-mixin :toggle-frcheck) () - #-:FMCS ($send frame-processor :toggle-frcheck) - #+:FMCS (setf *redefine-warnings* ($send frame-processor :toggle-frcheck))) - -;;-------------------------------------------------------------------------- -;; METHODS FOR FRAME OR INSTANCE CONSTRUCTION -;;-------------------------------------------------------------------------- - - -(def$method (basic-frame-mixin :add-to-frames) (a-frame-name) - (cond ((null frames) - (setf frames `(,a-frame-name)) - ($send frame-processor :set-frames-list frames)) - ((member a-frame-name frames)) - (t (setf frames (nconc frames `(,a-frame-name)))))) - - -(defmacro defframe (frame-name &body body) - (and (current-kb-typep 'basic-frame-mixin) - ($send (send-kb :frame-processor) :new-frame-form frame-name body))) - - -(defmacro defbehavior (behavior-spec lambda-list &body behavior-body) - (and (current-kb-typep 'basic-frame-mixin) - ($send (send-kb :frame-processor) - :new-behavior-form behavior-spec lambda-list behavior-body))) - - -(def$method (basic-frame-mixin :add-to-instances) (an-instance-name) - (cond ((null instances) - (setf instances `(,an-instance-name)) - ($send frame-processor :set-instances-list instances)) - ((member an-instance-name instances)) - (t (setf instances (nconc instances `(,an-instance-name)))))) - - -(defmacro definstance (instance-name of frame-name &body body) - (declare (ignore of)) - `(let () - (declare (special ,instance-name)) - (and (current-kb-typep 'basic-frame-mixin) - ($send (send-kb :frame-processor) :new-instance - ',instance-name ',frame-name ',body)))) - -;; Diese Funktion sollte in die Dokumentation aufgenommen werden. -;; changed: Franco 23.10. - -(defmacro create-unnamed-instance - (instance-name frame-name &optional with-specification) - (and (current-kb-typep 'basic-frame-mixin) - ($send (send-kb :frame-processor) :new-unnamed-instance - instance-name frame-name with-specification))) - -(defun create-instance-of (frame-name &optional with-specification) - "Diese Funktion erlaubt, Instanzen dynamisch zu definieren. - Die Instanzen, die damit kreiert werden, koennen nur mit SEND - angesprochen werden. Sie sind fuer die Wissensbasis und den Frame - nicht zugaenglich. In der Umgebung der Instanz ist object-name - wie self gebunden. - frame-name muss der name eines Frames sein (wird evaluiert) - with-specification (wird evaluiert) und ermoeglicht eine Initialisierung - mit der gleichen Syntax und Semantik wie DEFINSTANCE." - (and (current-kb-typep 'basic-frame-mixin) - ($send (send-kb :frame-processor) :new-unnamed-instance - (gensym) frame-name with-specification))) - - -;;-------------------------------------------------------------------------- -;; METHODS FOR REQUEST EVALUATION -;;-------------------------------------------------------------------------- - - -(defun %is-frame-name (name prefix) - ;returns nil if x is not a symbol - (let ((object-internal-name (%get-object-name name prefix))) - (if object-internal-name - (frame-definition object-internal-name)))) - - -(defun %is-instance-name (name prefix) - (let ((instance-internal-name (%get-object-name name prefix))) - (if instance-internal-name - (instance-definition instance-internal-name)))) - - -(defun %is-behavior (selector instance prefix) - (and (keywordp selector) - ($send (get (%get-object-name instance prefix) :instance) - :operation-handled-p selector))) - -(defun %is-slot (slot instance prefix) - (member slot ($send (get (%get-object-name instance prefix) :instance) :slots))) - - - -#+:SABN(defmacro frame-type (request) - `(if (is-true-list ,request) - (cond ((%is-instance-name (first ,request) pkg) - 'frame-reference) - ((is-frame-meta-predicate (first ,request)) - 'frame-meta-predicate-reference) - ((%is-frame-name (first ,request) pkg) - 'frame-class-reference) - ((and (%is-instance-name (second ,request) pkg) - (%is-slot (first ,request) (second ,request) pkg)) - 'frame-predicate-reference) - ((and (%is-instance-name (third ,request) pkg) - (%is-slot (second ,request) (third ,request) pkg)) - 'frame-predicate-reference) - ((and (%is-instance-name (second ,request) pkg) - (%is-behavior (first ,request) (second ,request) pkg)) - 'behavior-reference)))) - -#-:SABN(defmacro frame-type (request) - `(if (is-true-list ,request) - (cond ((%is-instance-name (first ,request) ($slot 'pkg)) - 'frame-reference) - ((is-frame-meta-predicate (first ,request)) - 'frame-meta-predicate-reference) - ((%is-frame-name (first ,request) ($slot 'pkg)) - 'frame-class-reference) - ((and (%is-instance-name (second ,request) ($slot 'pkg)) - (%is-slot (first ,request) (second ,request) ($slot 'pkg))) - 'frame-predicate-reference) - ((and (%is-instance-name (third ,request) ($slot 'pkg)) - (%is-slot (second ,request) (third ,request) ($slot 'pkg))) - 'frame-predicate-reference) - ((and (%is-instance-name (second ,request) ($slot 'pkg)) - (%is-behavior (first ,request) (second ,request) ($slot 'pkg))) - 'behavior-reference)))) - -(assign-typefkt 'frame-type 'basic-frame-mixin) - - -(defrequest frame-reference - :recall :eval-frame-reference - :recall-immediate :eval-frame-reference - :remember :eval-frame-reference - :store :eval-frame-reference - :ask :ask-eval-frame-reference - :prolog :eval-prolog-frame-reference) - - - -;;-------------------------------------------------------------------------- - - -(def$method (basic-frame-mixin :eval-frame-reference) (frame-reference mode) - "evaluates a frame reference." - (when system-trace - ($send self :send-system-trace-window :format - (getentry meta-frame-trace-fstr frame-io-table) mode frame-reference)) - (setf active-proc frame-processor) - ($send frame-processor :eval-reference - frame-reference - (if (eq mode :recall-immediate) :recall mode))) - -;;-------------------------------------------------------------------------- - -(def$method (basic-frame-mixin :ask-with-help) - (request &optional (negation-flag nil)) - (let ((answer ($send frame-processor :ask request negation-flag))) - (cond ((is-help answer) - (case ($send self :help) - (why 'why) - (t ($send self :ask-with-help request negation-flag)))) - (t answer)))) - -(def$method (basic-frame-mixin :ask-eval-frame-reference) - (frame-reference mode &optional (negation-flag nil)) - "evaluates a frame reference after asking the user." - (when system-trace - ($send self :send-system-trace-window :format - (getentry meta-frame-trace-fstr frame-io-table) mode frame-reference)) - (setf active-proc frame-processor) - (let ((answer ($send self :ask-with-help frame-reference negation-flag))) - (case answer - (why 'why) - (t (setq answer - ($send frame-processor :eval-reference frame-reference :recall)) - (if answer - 'true - 'false))))) - -;;-------------------------------------------------------------------------- - -(def$method (basic-frame-mixin :eval-prolog-frame-reference) (frame-reference mode) - "evaluates frame references used in prolog clauses." - (when system-trace - ($send self :send-system-trace-window :format - (getentry meta-frame-trace-fstr frame-io-table) mode frame-reference)) - (setf active-proc frame-processor) - (prog (answer) - A (setq answer - ($send frame-processor :eval-reference frame-reference :recall)) - (cond ((is-undetermined answer) - (setq answer ($send self :ask-with-help frame-reference nil)) - (if (eq answer 'why) - ($send self :prolog-why)) ;indirect prolog-ref - (go A)) - ((null answer) (return nil)) - ((eq answer 'unknown) (return nil)) - (t (return t))))) - - -;;-------------------------------------------------------------------------- - -(defrequest frame-meta-predicate-reference - :prolog :eval-frame-meta-predicate-reference) - - -;(defvar *frame-meta-predicates* '(and or)) - -(defun is-frame-meta-predicate (x) - (member x *frame-meta-predicates*)) - - -(def$method (basic-frame-mixin :eval-frame-meta-predicate-reference) (goal mode) - "evaluates references of a special type used in prolog. -goal := ( . )" - (when system-trace - ($send self :send-system-trace-window :format - (getentry meta-frame-trace-fstr frame-io-table) mode goal)) - (setf active-proc frame-processor) - (let ((result nil)) - (case (first goal) - (FRAME (let ((the-frames ($send frame-processor :frames-list))) - (if (IS-VARIABLE (second goal)) - (dolist (a-frame the-frames (nreverse result)) - (setf result (cons `((,(first goal) ,a-frame)) result))) - (if (member (second goal) the-frames) - t - nil)))) - (FRAME-DEF (let ((the-frames ($send frame-processor :frames-list))) - (dolist (a-frame the-frames (nreverse result)) - (setf result - (cons `((,(first goal) ,(get-frame-def a-frame))) result))))) - ((HAS-SUPER SUPER) - (if (IS-VARIABLE (second goal)) - nil - (let ((supercls (GET-ALL-SUPERS (second goal)))) - (cond ((IS-VARIABLE (third goal)) - (dolist (a-superc supercls (nreverse result)) - (setf result - (cons `((,(first goal) ,(second goal) ,a-superc)) result)))) - (t (if (member (third goal) supercls) - t - nil)))))) - (INSTANCE (let ((the-instances ($send frame-processor :instances-list))) - (if (IS-VARIABLE (second goal)) - (dolist (an-instance the-instances (nreverse result)) - (setf result (cons `((,(first goal) ,an-instance)) result))) - (if (member (second goal) the-instances) - t - nil)))) - (INSTANCE-DEF (let ((the-instances ($send frame-processor :instances-list))) - (dolist (an-instance the-instances (nreverse result)) - (setf result - (cons `((,(first goal) ,(get-instance-def an-instance))) - result))))) - ((HAS-SLOT SLOT) - (if (IS-VARIABLE (second goal)) - nil - (let ((slots ($send (get-instance (second goal)) :slots))) - (if (IS-VARIABLE (third goal)) - (dolist (a-slot slots (nreverse result)) - (setf result (cons `((,(first goal) ,(second goal) ,a-slot)) result))) - (if (member (third goal) slots) - t - nil))))) - ((HAS-PROPERTY PROPERTY) - (if (or (IS-VARIABLE (second goal)) - (IS-VARIABLE (third goal))) - nil - (let ((instance-name (third goal)) - (slot-name (second goal)) - (desired-value (fourth goal))) - (let ((prop-names - ($send (get-instance instance-name) :GET-PROPERTIES slot-name))) - (if (IS-VARIABLE desired-value) - (dolist (a-prop-name prop-names (nreverse result)) - (setf result - (cons `((,(first goal) ,slot-name ,instance-name ,a-prop-name)) - result))) - (if (member desired-value prop-names) t nil)))))) - - (t ;; signal error !! - nil)))) - - -;;-------------------------------------------------------------------------- - - -(defrequest frame-class-reference - :prolog :eval-frame-class-reference) - -(def$method (basic-frame-mixin :eval-frame-class-reference) - (goal mode) - "evaluates references of a special type used in prolog. -goal = ( ) | ( )" - (when system-trace - ($send self :send-system-trace-window :format - (getentry meta-frame-trace-fstr frame-io-table) mode goal)) - (setf active-proc frame-processor) - (cond ((IS-VARIABLE (second goal)) - ;; Hier werden CLAUSES der Form (( )) - ;; uebergeben. - ;; Es findet eine Uebersetzung statt! (Nicht so effizient!) - (let ((result nil)) - (dolist (an-instance (GET-ALL-INSTANCES (first goal)) (nreverse result)) - (setf result (cons `((,(first goal) ,an-instance)) result))))) - ((IS-INSTANCE (second goal)) - ;; Hier kann ein direkter Typecheck gemacht werden (effizient!) - ;; Der prolog-processor versteht T und NIL. - ;; Man beachte, dass an dieser Stelle der FRAME-PROZESSOR umgangen wird. - ;; Es wird aber etwas benutzt (die Nachricht :TYPE), was in jeder - ;; sogenannten Wissensbasis auch benutzt werden kann. - (if ($send (GET-INSTANCE (second goal)) :type (first goal)) - t - nil)))) - -;;-------------------------------------------------------------------------- - -(defrequest frame-predicate-reference - :prolog :eval-frame-predicate-reference) - -(def$method (basic-frame-mixin :get-ask) (object slot prop-name) - (when system-trace - ($send self :send-system-trace-window :format - (getentry meta-frame-trace-one-fstr frame-io-table) - `(:get ,object ,slot ,prop-name))) - (setf active-proc frame-processor) - (prog (answer) - A (setq answer ($send frame-processor :get object slot prop-name)) - (cond ((is-undetermined answer) - (setq answer ($send self :ask-with-help - `(,object ,slot ,prop-name) nil)) - (if (eq answer 'why) - ($send self :prolog-why)) ;indirect prolog-ref - (go A)) - (t (return answer))))) - - -(defun make-clauses (pred an-instance-name values &rest prop-name) - "make clauses according to Prolog syntax." - (cond ((IS-MULTIPLE-VALUE values) - (mapcar #'(lambda (a-value) - `((,@prop-name ,pred ,an-instance-name ,a-value)) ) - (rest values))) - (t `(((,@prop-name ,pred ,an-instance-name ,values)))))) - -(def$method (basic-frame-mixin :eval-frame-predicate-reference) (goal mode) - "evaluates frame references of a syntactical form used by prolog. -goal:= ( ) | ( )" - (declare (ignore mode)) - (let* ((normalized-goal (cond ((keywordp (first goal)) goal) - (t `(:value . ,goal)))) - (prop-name (first normalized-goal)) - (slot (second normalized-goal)) - (object (third normalized-goal)) - (desired-value (fourth normalized-goal))) - (cond ((IS-VARIABLE desired-value) - (let ((value ($send self :get-ask object slot prop-name))) - (if (eq normalized-goal goal) - (make-clauses slot object value prop-name) - (make-clauses slot object value)))) - (t (let ((premise `(,object ,slot ,prop-name = ,desired-value))) - ($send self :eval-prolog-frame-reference premise :RECALL)))))) - - -;;-------------------------------------------------------------------------- - - -(defrequest behavior-reference - :prolog :eval-behavior-reference) - - -(def$method (basic-frame-mixin :eval-behavior-reference) (goal mode) - "evaluates behavior references of a syntactical form used by prolog." - (when system-trace - ($send self :send-system-trace-window :format - (getentry meta-frame-trace-fstr frame-io-table) mode goal)) - (setf active-proc frame-processor) - (let ((behavior (first goal)) - (the-instance (second goal)) - (args (butlast (cddr goal))) - (result (first (last goal)))) - (if (CONTAINS-VARS args) - nil - (let ((call-result - (lexpr-$send (GET-INSTANCE the-instance) behavior args))) - (if (IS-VARIABLE result) ;; gives a list of clauses as result - `(((,behavior ,the-instance ,@args ,call-result))) - ;; else T or NIL - (equal result call-result)))))) - - -;;-------------------------------------------------------------------------- -;; METHODS FOR HANDLING OBJECTS -;;-------------------------------------------------------------------------- - - -(def$method (basic-frame-mixin :describe-frame) - (frame-name &optional window) - "describes the frame named on . -if is not specified the dialog-stream is used instead." - - (setf window (or window self)) - ($send window :format "~%Frame: ~S" frame-name) - ($send window :format - "~%Slots: ~{~S ~}" - (compute-slot-names (get-frame-slots frame-name))) - ($send window :format - "~%Supers: ~{~S ~}" - (get-supers frame-name)) - ($send window :format - "~%Behaviors: ~{~{~* ~S ~^ ~S~} ~}" - (get-frame-behavior-specs frame-name)) - ($send window :format - "~%Instances: ~{~S ~}" - (get-instance-list frame-name)) - ($send window :format "~%")) - - -(def$method (basic-frame-mixin :select-describe-frame) (&optional window) - "describes a frame selected via menu on . -if is not specified the dialog-stream is used instead." - - (do* ((items (append frames `(,(getentry exit-select-item frame-io-table)))) - (label (format nil - (getentry describe-which-question-str frame-io-table) - 'frame)) - (frame-name ($send self :choose-from-menu items label) - ($send self :choose-from-menu items label))) - ((eq frame-name 'exit) t) - (if (not (null frame-name)) - ($send self :describe-frame frame-name window)))) - - -(def$method (basic-frame-mixin :inspect-frames) () - ($send self :select-describe-frame)) - - - -(def$method (basic-frame-mixin :describe-instance) - (instance-name &optional (all-properties t) window) - "describes the instance named on . -the value of each slot and all its properties are shown unless is nil. -if is not specified the dialog-stream is used instead." - - (let ((unparsed-instance ($send (get-instance instance-name) - :unparse-instance nil all-properties))) - (setf window (or window self)) - ($send window :format "~%Instance: ~S of Frame: ~S" - instance-name (second unparsed-instance)) - (mapc #'(lambda (unparsed-slot) - (cond (all-properties - ($send window :format - "~%Slot: ~S" (first unparsed-slot)) - ($send window :format - "~{~% ~S ~S~}" (rest unparsed-slot))) - (t ($send window :format - "~%Slot: ~{~S ~S ~S~}" unparsed-slot)))) - (cddr unparsed-instance)) - ($send window :format "~%"))) - - -(def$method (basic-frame-mixin :select-describe-instance) - (&optional (all-properties t) window) - "describes an instance selected via menu on . -the value of each slot and all its properties are shown unless is nil. -if is not specified the dialog-stream is used instead." - - (do* ((items (append instances `(,(getentry toggle-mode-item frame-io-table) - ,(getentry exit-select-item frame-io-table)))) - (label (format nil - (getentry describe-which-question-str frame-io-table) - 'instance)) - (instance-name ($send self :choose-from-menu items label) - ($send self :choose-from-menu items label))) - ((eq instance-name 'exit) t) - (cond ((eq instance-name 'mode) - (setq all-properties (if (null all-properties) t))) - ((not (null instance-name)) - ($send self :describe-instance - instance-name all-properties window))))) - - -(def$method (basic-frame-mixin :inspect-instances) () - ($send self :select-describe-instance nil)) - - - -;;-------------------------------------------------------------------------- -;; AUX STUFF -;;-------------------------------------------------------------------------- - -(defun send-fp (message &rest args) - (lexpr-$send (send-kb :frame-processor) message args)) diff --git a/t/baby2015/kernel/frames/basic/bf-proc.cl b/t/baby2015/kernel/frames/basic/bf-proc.cl deleted file mode 100644 index 27e127c..0000000 --- a/t/baby2015/kernel/frames/basic/bf-proc.cl +++ /dev/null @@ -1,88 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Base: 10; Package: BABYLON -*- - -(in-package "BABYLON") - -;; Copyright 1986, 1985 and 1984 BY -;; G M D -;; Postfach 1240 -;; D-5205 St. Augustin -;; FRG - - -;; DATE: April 1987 -;; AUTHORS: Franco di Primio, Eckehard Gross - -;; This file depends on: common>* -;; frames>basic>frames -;; frames>basic>bf-inter -;; -;; Contents: a minimal version of a frame processor - - -;;----------------------------------------------------------------------------- -;; FLAVOR BASIC-FRAME-PROCESSOR -;;----------------------------------------------------------------------------- - -(def$flavor basic-frame-processor - () - (frame-interpreter frame-base) - (:documentation "This flavor represents a minimal version of a frame processor.")) - - -;; reset-slot-value problematisch - -;(def$method (basic-frame-processor :reset-instances) (&optional (completely t)) -; (mapc #'(lambda (an-instance-name) -; (if completely -; (eval (get-instance-def an-instance-name)) -; ;; resets only :VALUE property -; ($send (get-instance an-instance-name) :reset-slots-value))) -; instances-list)) - - -(def$method (basic-frame-processor :reset-proc) () - "resets the processor to initial state." - (mapcar #'(lambda (an-instance-name) - ;(eval (get-instance-def an-instance-name))) - (<- an-instance-name :reset-yourself)) - ; now you can specialize the reset-yourself method per frame - instances-list)) - -; -;(def$method (basic-frame-processor :reset-pointer) () -; "synchronizes the lists of frames and instances maintained -;by the knowledge-base and the frame-processor." -; (setf frames-list ($send meta-processor :frames)) -; (setf instances-list ($send meta-processor :instances))) - - -(def$method (basic-frame-processor :kb-inform) (&optional (stream *default-dialog-stream*)) - "prints statistics on frames and instances." - (let ((frames ($send meta-processor :frames)) - (instances ($send meta-processor :instances))) - (declare (list frames instances)) - (format stream (getentry no-of-frames-fstr frame-io-table) (length frames)) - (format stream (getentry no-of-instances-fstr frame-io-table) (length instances)) - t)) - - -(def$method (basic-frame-processor :print) (&optional (stream *default-dialog-stream*)) - "prints all definitions of frames and instances." - (let ((frames ($send meta-processor :frames))) - (format stream (getentry object-header-str frame-io-table)) - (cond (frames - (mapc #'(lambda (a-frame-name) - (format stream - (getentry frame-header-fstr frame-io-table) - a-frame-name) - (PRINT-FRAME a-frame-name stream) - (PRINT-INSTANCES a-frame-name stream)) - frames))) - t)) - - -#-:FMCS(compile-$flavor-$methods basic-frame-processor) - - -;;; eof - diff --git a/t/baby2015/kernel/frames/basic/fp-tab-e.cl b/t/baby2015/kernel/frames/basic/fp-tab-e.cl deleted file mode 100644 index 09220be..0000000 --- a/t/baby2015/kernel/frames/basic/fp-tab-e.cl +++ /dev/null @@ -1,245 +0,0 @@ -;;; -*- Mode: Lisp; Base:10; Syntax: Common-Lisp; Package: BABYLON -*- - -(in-package "BABYLON") - -;; Copyright 1986, 1985 and 1984 BY -;; G M D -;; Postfach 1240 -;; D-5205 St. Augustin -;; FRG - - -;; AUTHOR: J. W A L T H E R - - -; -;This is the English version of all the strings and menu-item-lists of -;the frame processor. - - - -(defbabylon-table frame-io-table english :size 100) - - - -(defbabylon-entry no-delete-permit-error-fstr frame-io-table english - "~%:VALUE property cannot be deleted in instances.~@ - in (~S :DELETE-PROPERTY ~S ~S)") - -(defbabylon-entry no-update-permit-error-fstr frame-io-table english - "~%You are trying to update the ~S ~S of ~S with ~S,~@ - but no update is permitted.") - -(defbabylon-entry unknown-frame-error-fstr frame-io-table english - "~S is not the name of a known frame of knowledge base ~S.") - -(defbabylon-entry unknown-method-error-fstr frame-io-table english - "No such behavior for ~S: ~S") - -(defbabylon-entry no-kb-error-fstr frame-io-table english - "~%Trying to define the frame ~S outside a knowledge-base.") - -(defbabylon-entry frame-spec-error-fstr frame-io-table english - "~%Wrong frame specification for frame ~S.~@ - Expected definition format is: ~A.") - -(defbabylon-entry supers-spec-error-fstr frame-io-table english - "~%~S : wrong supers specification in frame ~S.~@ - The expected format is: ~A.") - -(defbabylon-entry slot-spec-error-fstr frame-io-table english - "~%~S : wrong slot specification in frame ~S.~@ - The expected slot format is: ~A.") - -(defbabylon-entry unknown-frame-for-behavier-error-fstr frame-io-table english - "while defining BEHAVIOR ~S,~@ - ~S is not a known frame of knowledge base ~S.") - -(defbabylon-entry behavior-spec-error-fstr frame-io-table english - "~S wrong BEHAVIOR specification.") - -(defbabylon-entry unknown-instance-error-fstr frame-io-table english - "~S is not the name~@ - of a known instance of knowledge base ~S.") - -(defbabylon-entry no-kb-for-instance-error-fstr frame-io-table english - "~%Trying to define the instance ~S of frame ~S ~@ - outside a knowledge base.") - -(defbabylon-entry of-keyword-expect-error-fstr frame-io-table english - "~S: wrong keyword in ~A. The expected keyword is OF.") - -(defbabylon-entry slot-initialization-error-fstr frame-io-table english - "~S: wrong slot initialization in ~A.~@ - The expected format for instance defintions is: ~A.") - -(defbabylon-entry instance-spec-error-fstr frame-io-table english - "~S: wrong instance definition.~@ - The expected format for instance defintions i ~A.") - -(defbabylon-entry default-value-error-fstr frame-io-table english - "~%The default value ~S for slot ~S of frame ~S~@ - does not satisfy the possible values ~S.") - -(defbabylon-entry mode-error-fstr frame-io-table english - "Wrong mode in compute-slot-message: ~S.") - -(defbabylon-entry expect-relation-fstr frame-io-table english - "Relation = is expected instead of ~S.") - -(defbabylon-entry constraints-spec-error-fstr frame-io-table english - "~%==> ~S : Wrong constraints specification~@ - in slot ~S of instance ~S of frame ~S.") - - - -(defbabylon-entry constraints-violation-fstr frame-io-table english - "The value ~S does not satisfy the constraints ~S ~@[ ~S~] ~@ - for slot ~S of instance ~S of frame ~S.") - - -(defbabylon-entry unknown-poss-val-method-fstr frame-io-table english - "~S unknown possible value method ~@ - in slot ~S of instance ~S of frame ~S.") - - -(defbabylon-entry other-value-question-str frame-io-table english - "~%Do you want to give another value ? (Y or N) ") - -(defbabylon-entry new-value-question-fstr frame-io-table english - "~%New value for ~S ~S: ") - -(defbabylon-entry explain-answers-spec-error-fstr frame-io-table english - "~S:~%wrong :EXPLAIN-ANSWERS specification~@ - in slot ~S of instance ~S of frame ~S.~@ - ~S is not a possible value.") - -(defbabylon-entry wrong-arg-type-error-fstr frame-io-table english - "~S: wrong argument type in ~@ - ... ~S :ASK ~S ~S).") - -(defbabylon-entry whats-the-value-of-fstr frame-io-table english - "~%~3TWhat's the value of ~S ~S ? ") - -(defbabylon-entry explain-fstr frame-io-table english - "~%To get explanations for: ~{~S ~} or about the context ~@ - enter a value or help ") - - -(defbabylon-entry explain-answers-fstr frame-io-table english - "~2&For explanations on possible answers ~ - ~:[enter Space. ~;enter one of the values: ~% ~{~S ~} ~]") - -(defbabylon-entry explain-context-fstr frame-io-table english - "~%For context explanations enter ~:C (continue with ~:C) : ") - -(defbabylon-entry no-explain-answers-fstr frame-io-table english - "~2&There are no explanations on possible answers.") - -(defbabylon-entry next-value-fstr frame-io-table english - "~%Next value (continue with ~:C) : ") - - -(defbabylon-entry please-enter-fstr frame-io-table english - "~%~3TPlease enter ~S for ~S ~S: ") - -(defbabylon-entry a-slot-of-fstr frame-io-table english - "a slot of ~S ~S") - -(defbabylon-entry slot-spec-example-str frame-io-table english - " |~@ - ~@T( : ... )") - -(defbabylon-entry frame-spec-example-str frame-io-table english - "(DEFFRAME ~@ - ~5@T(SUPERS ... )~@ - ~5@T(SLOTS ( : ...)~@ - ~12@T... ))") - -(defbabylon-entry supers-spec-example-str frame-io-table english - "(SUPERS ... )") - -(defbabylon-entry instance-spec-example-str frame-io-table english - "(DEFINSTANCE OF ~@ - ~4@TWITH = ~@ - ~9@T...~@ - ~9@T = )~@ - ~@ - ~@T := ATOM~@ - ~@T := ( : ...)") - -(defbabylon-entry definstance-spec-fstr frame-io-table english - "(DEFINSTANCE ~S ~S ~S ...)") - -(defbabylon-entry all-properties-item-str frame-io-table english - " All properties ") - -(defbabylon-entry value-property-only-item-str frame-io-table english - " :VALUE property only ") - -(defbabylon-entry which-property-header-str frame-io-table english - " Describe which slot properties of ~S ") - -(defbabylon-entry expect-restricted-value-fstr frame-io-table english - "~%The value is expected to satisfy the restriction ~S ~ - ~:[~;with arguments ~S.~] ") - -(defbabylon-entry expected-value-not-str frame-io-table english - "~%EXPECTED VALUE NOT ~S ") - -(defbabylon-entry expected-value-str frame-io-table english - "~%EXPECTED VALUE ~S ") - -(defbabylon-entry expect-no-restricted-value-fstr frame-io-table english - "~%There is no restriction for the value.") - -(defbabylon-entry no-instance-error-msg-fstr frame-io-table english - "~%====>> ~S is no instance.~%") - -(defbabylon-entry object-header-str frame-io-table english - "~3%;; ************* O B J E C T S ***********~3%") - -(defbabylon-entry frame-header-fstr frame-io-table english - ";; ************* FRAME ~S ***********~2%") - -(defbabylon-entry no-of-frames-fstr frame-io-table english - "~%- Number of FRAMES: ~38T~D") - -(defbabylon-entry no-of-instances-fstr frame-io-table english - "~%- Number of INSTANCES: ~38T~D") - -(defbabylon-entry describe-which-question-str frame-io-table english - " Describe which ~S ? ") - - -(defbabylon-entry meta-frame-trace-fstr frame-io-table english - " META -> FRAME ~S ~S") - -(defbabylon-entry meta-frame-trace-one-fstr frame-io-table english - " META -> FRAME ~S") - - -(defbabylon-entry exit-select-item frame-io-table english - '("-- exit select --" :value exit - #+:lispm :font #+:lispm fonts:cptfontb - )) - - -(defbabylon-entry toggle-mode-item frame-io-table english - '("-- toggle mode --" :value mode - #+:lispm :font #+:lispm fonts:cptfontb - )) - - -(defbabylon-entry unknown-frame-while-defining-fstr frame-io-table english - "While defining ~A ~S:~%~A is not a known frame of knowledge base ~S") - - -(defbabylon-entry ask-slot-prop-fstr frame-io-table english - "~%~3TWhat's the value of ~S for ~S of ~S: ") - -(defbabylon-entry ask-slot-fstr frame-io-table english - "~%~3TWhat's the value of ~S of ~S: ") - -;;; eof - diff --git a/t/baby2015/kernel/frames/basic/fp-tab-g.cl b/t/baby2015/kernel/frames/basic/fp-tab-g.cl deleted file mode 100644 index 556c509..0000000 --- a/t/baby2015/kernel/frames/basic/fp-tab-g.cl +++ /dev/null @@ -1,245 +0,0 @@ -;;; -*- Mode: Lisp; Base:10; Syntax: Common-Lisp; Package: BABYLON -*- - -(in-package "BABYLON") - -;; Copyright 1986, 1985 and 1984 BY -;; G M D -;; Postfach 1240 -;; D-5205 St. Augustin -;; FRG - - -;; AUTHOR: J. W A L T H E R - - -; -;This is the German version of all the strings and menu-item-lists of -;the frame processor. - - - -(defbabylon-table frame-io-table german :size 100) - - - -(defbabylon-entry no-delete-permit-error-fstr frame-io-table german - "~%:VALUE Property kann in Instanzen nicht geloescht werden.~@ - In (~S :DELETE-PROPERTY ~S ~S)") - - -(defbabylon-entry no-update-permit-error-fstr frame-io-table german - "~%Sie versuchen ~S ~S von ~S in ~S zu aendern,~@ - aber Aenderungen sind nicht erlaubt.") - -(defbabylon-entry unknown-frame-error-fstr frame-io-table german - "~S ist kein bekannter Name eines Frames der Wissensbasis ~S.") - -(defbabylon-entry unknown-method-error-fstr frame-io-table german - "Dieses Behavior gibt es nicht in ~S: ~S") - -(defbabylon-entry no-kb-error-fstr frame-io-table german - "~%Sie versuchen den Frame ~S ausserhalb einer Wissensbasis zu definieren.") - -(defbabylon-entry frame-spec-error-fstr frame-io-table german - "~%Inkorrekte Frame-Spezifikation fuer ~S.~@ - Erwartetes Format ist: ~A.") - -(defbabylon-entry supers-spec-error-fstr frame-io-table german - "~%~S : Inkorrekte Supers-Spezifikation in Frame ~S.~@ - Erwartetes Format ist: ~A.") - -(defbabylon-entry slot-spec-error-fstr frame-io-table german - "~%~S : Inkorrekte Slot-Spezifikation in Frame ~S.~@ - Erwartetes Format ist: ~A.") - -(defbabylon-entry unknown-frame-for-behavier-error-fstr frame-io-table german - "In der Definition von BEHAVIOR ~S,~@ - ~S ist unbekannter Frame der Wissensbasis ~S.") - -(defbabylon-entry behavior-spec-error-fstr frame-io-table german - "~S: inkorrekte BEHAVIOR Spezifikation.") - -(defbabylon-entry unknown-instance-error-fstr frame-io-table german - "~S: ist nicht Name~@ - einer bekannten Instanz der Wissensbasis ~S.") - -(defbabylon-entry no-kb-for-instance-error-fstr frame-io-table german - "~%Sie versuchen die Instanz ~S von Frame ~S ~@ - ausserhalb einer Wissensbasis zu definieren.") - -(defbabylon-entry of-keyword-expect-error-fstr frame-io-table german - "~S: Falsches Schluesselwort in ~A. Erwartet wird OF.") - -(defbabylon-entry slot-initialization-error-fstr frame-io-table german - "~S: Inkorrekte Slot Initialisierung in ~A.~@ - Erwartetes Format ist: ~A.") - -(defbabylon-entry instance-spec-error-fstr frame-io-table german - "~S: Inkorrekte Instance Definition.~@ - Erwartetes Format ist: ~A.") - -(defbabylon-entry default-value-error-fstr frame-io-table german - "~%Der Default-Wert ~S des Slot ~S von Frame ~S~@ - erfuellt nicht die Possible Values ~S.") - -(defbabylon-entry mode-error-fstr frame-io-table german - "Inkorrekter Mode in compute-slot-message: ~S.") - -(defbabylon-entry expect-relation-fstr frame-io-table german - "Relation = wird anstelle von ~S erwartet.") - -(defbabylon-entry constraints-spec-error-fstr frame-io-table german - "~%==> ~S : Inkorrekte Constraints-Spezifikation~@ - in Slot ~S der Instanz ~S von Frame ~S.") - - -(defbabylon-entry constraints-violation-fstr frame-io-table german - "Der Wert ~S verletzt die Constraints ~S ~@[ ~S~] ~@ - fuer Slot ~S der Instanz ~S von Frame ~S.") - - -(defbabylon-entry unknown-poss-val-method-fstr frame-io-table german - "~S unbekannte Possible Value Methode ~@ - im Slot ~S der Instanz ~S von Frame ~S.") - - -(defbabylon-entry other-value-question-str frame-io-table german - "Moechten Sie einen anderen Wert geben ? (Y or N) ") - -(defbabylon-entry new-value-question-fstr frame-io-table german - "~%Neuer Wert fuer ~S ~S: ") - - -(defbabylon-entry explain-answers-spec-error-fstr frame-io-table german - "~S:~%inkorrekte :EXPLAIN-ANSWERS Specification~@ - in Slot ~S der Instanz ~S von Frame ~S.~@ - ~S ist kein erlaubter Wert.") - -(defbabylon-entry wrong-arg-type-error-fstr frame-io-table german - "~S: Inkorrekter Argument-Typ in~@ - ... ~S :ASK ~S ~S).") - -(defbabylon-entry whats-the-value-of-fstr frame-io-table german - "~%~3TWelchen Wert hat ~S ~S ? ") - -(defbabylon-entry explain-fstr frame-io-table german - "~%Um Erlaeuterungen fuer: ~{~S ~} oder zum Kontext zu erhalten,~@ - geben Sie einen Wert oder help ein ") - - -(defbabylon-entry explain-answers-fstr frame-io-table german - "~2&Fuer Erlaeuterungen zu moeglichen Antworten ~ - ~:[geben Sie Leertaste ein. ~;geben Sie einen der folgenden Werte ein: ~% ~{~S ~} ~]") - -(defbabylon-entry explain-context-fstr frame-io-table german - "~%Fuer Erlaeuterungen zum Kontext geben Sie ~:C ein (weiter mit ~:C) : ") - -(defbabylon-entry no-explain-answers-fstr frame-io-table german - "~2&Erlaeuterungen zu moeglichen Antworten liegen nicht vor.") - -(defbabylon-entry next-value-fstr frame-io-table german - "~%Naechster Wert (weiter mit ~:C) : ") - - -(defbabylon-entry please-enter-fstr frame-io-table german - "~%~3TBitte ~S fuer ~S ~S eingeben: ") - -(defbabylon-entry a-slot-of-fstr frame-io-table german - "ein Slot von ~S ~S") - -(defbabylon-entry slot-spec-example-str frame-io-table german - " |~@ - ~@T( : ... )") - -(defbabylon-entry frame-spec-example-str frame-io-table german - "(DEFFRAME ~@ - ~5@T(SUPERS ... )~@ - ~5@T(SLOTS ( : ...)~@ - ~12@T... ))") - -(defbabylon-entry supers-spec-example-str frame-io-table german - "(SUPERS ... )") - -(defbabylon-entry instance-spec-example-str frame-io-table german - "(DEFINSTANCE OF ~@ - ~4@TWITH = ~@ - ~9@T...~@ - ~9@T = )~@ - ~@ - ~@T := ATOM~@ - ~@T := ( : ...)") - -(defbabylon-entry definstance-spec-fstr frame-io-table german - "(DEFINSTANCE ~S ~S ~S ...)") - -(defbabylon-entry all-properties-item-str frame-io-table german - " Alle Properties ") - -(defbabylon-entry value-property-only-item-str frame-io-table german - " nur :VALUE Property ") - -(defbabylon-entry which-property-header-str frame-io-table german - " Welche Properties von Slots von ~S sollen beschrieben werden ") - -(defbabylon-entry expect-restricted-value-fstr frame-io-table german - "~%Der Wert verletzt die Restriktion ~S ~ - ~:[~;mit den Argumenten ~S.~] ") - -(defbabylon-entry expected-value-not-str frame-io-table german - "~%ERWARTETER WERT NICHT ~S ") - -(defbabylon-entry expected-value-str frame-io-table german - "~%ERWARTETER WERT ~S ") - -(defbabylon-entry expect-no-restricted-value-fstr frame-io-table german - "~%Fuer diesen Wert existiert keine Einschraenkung.") - -(defbabylon-entry no-instance-error-msg-fstr frame-io-table german - "~%====>> ~S ist keine Instanz.~%") - -(defbabylon-entry object-header-str frame-io-table german - "~3%;; ************* O B J E K T E ***********~3%") - -(defbabylon-entry frame-header-fstr frame-io-table german - ";; ************* FRAME ~S ***********~2%") - -(defbabylon-entry no-of-frames-fstr frame-io-table german - "~%- Anzahl der FRAMES: ~38T~D") - -(defbabylon-entry no-of-instances-fstr frame-io-table german - "~%- Anzahl der INSTANZEN: ~38T~D") - -(defbabylon-entry describe-which-question-str frame-io-table german - " Beschreibe ~S ? ") - -(defbabylon-entry meta-frame-trace-fstr frame-io-table german - " META -> FRAME ~S ~S") - -(defbabylon-entry meta-frame-trace-one-fstr frame-io-table german - " META -> FRAME ~S") - - -(defbabylon-entry exit-select-item frame-io-table german - '("-- Ende Auswahl --" :value exit - #+:lispm :font #+:lispm fonts:cptfontb - )) - -(defbabylon-entry toggle-mode-item frame-io-table german - '("-- Aendere Modus --" :value mode - #+:lispm :font #+:lispm fonts:cptfontb - )) - - -(defbabylon-entry unknown-frame-while-defining-fstr frame-io-table german - "Bei der Definition von ~A ~S:~%~A ist kein bekannter Frame der Wissensbasis ~S") - - -(defbabylon-entry ask-slot-prop-fstr frame-io-table german - "~%~3TWelchen Wert hat ~S fuer ~S von ~S: ") - -(defbabylon-entry ask-slot-fstr frame-io-table german - "~%~3TWelchen Wert hat ~S von ~S: ") - - -;;; eof - diff --git a/t/baby2015/kernel/frames/basic/fr-core.cl b/t/baby2015/kernel/frames/basic/fr-core.cl deleted file mode 100644 index 6cb71a1..0000000 --- a/t/baby2015/kernel/frames/basic/fr-core.cl +++ /dev/null @@ -1,598 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Base: 10; Package: BABYLON -*- - -(in-package "BABYLON") - -;; Copyright 1986, 1985 and 1984 BY -;; G M D -;; Postfach 1240 -;; D-5205 St. Augustin -;; FRG - - -;; DATE: April 1987 -;; AUTHORS: Franco di Primio, Eckehard Gross - -;; This file depends on: common>* -;; -;; Contents: a flavor used as base component of each frame. -;; it provides methods common to all frames. - -;;-------------------------------------------------------------------- -;; BASE FLAVOR OF FRAME -;;-------------------------------------------------------------------- - -(def$flavor frame-core - (slots - object-name) - () - :initable-instance-variables - :gettable-instance-variables - (:documentation "flavor to be used as base component of each frame. -methods common to all frames are implemented as methods of this flavor.")) - - -(defun get-slots (instance) - (remove 'slots ;; internal use - (remove 'object-name ;; internal use - (get-flavor-instance-slots instance)))) - -(def$method (frame-core :after :init) (&rest plist) - "stores user defined slots in instance variable slots." - (declare (ignore plist)) - (setf slots (get-slots self))) - -;;; modified to be able to define reset-yourself methods/demons for frames -(def$method (frame-core :reset-yourself) () - "resets instance to initial values of the definstance form." - (eval (get-instance-def object-name))) - -(def$method (frame-core :%set-object-name) (x) - (setf object-name x)) - -;;-------------------------------------------------------------------- -;; BASIC ACCESS METHODS -;;-------------------------------------------------------------------- - - -#+:SABN(defmacro get-slot-plist (slot-name) ;using symbol-value-in-$instance macro - `(progn (assert (member ,slot-name slots) - (,slot-name) - "~S is not a slot of instance ~S ~@ - the slots are: ~{~S ~}" ;assert does not evaluate this arg - ,slot-name object-name slots) - (symbol-value-in-$instance self ,slot-name))) - - -#-:SABN(defmacro get-slot-plist (slot-name) ;using $slot macro - `(progn (assert (member ,slot-name ($slot 'slots)) - (,slot-name) - "~S is not a slot of instance ~S ~@ - the slots are: ~{~S ~}" ;assert does not evaluate this arg - ,slot-name ($slot 'object-name) ($slot 'slots)) - ($slot ,slot-name))) - -(defun get-value-only (slot-plist prop-name) - (cond ((is-value prop-name) (first slot-plist)) - ((keywordp prop-name) - (getf (rest slot-plist) prop-name)))) - -(defun set-value-only (slot-plist value prop-name) - (cond ((is-value prop-name) (setf (first slot-plist) value)) - ((keywordp prop-name) - (setf (getf (rest slot-plist) prop-name) value)))) - -(def$method (frame-core :get-value-only) - (slot-name &optional (prop-name :value)) - "basic access method to a property of a slot." - (get-value-only (get-slot-plist slot-name) prop-name)) - -(def$method (frame-core :get) - (slot-name &optional (prop-name :value)) - "access method to a property of a slot. intended to be specialized." - (get-value-only (get-slot-plist slot-name) prop-name)) - - - -(def$method (frame-core :get-properties) (slot-name) - "provides all properties of a slot." - (do ((plist (rest (get-slot-plist slot-name)) - (cddr plist)) - (result (list :VALUE))) - ((null plist) (nreverse result)) - (setf result (cons (first plist) result)))) - - -(def$method (frame-core :set-value-only) - (slot-name value &optional (prop-name :value)) - "basic modification method for a property of a slot." - (set-value-only (get-slot-plist slot-name) value prop-name)) - -(def$method (frame-core :replace) - (slot-name value &optional (prop-name :value)) - "basic modification method for a property of a slot." - (set-value-only (get-slot-plist slot-name) value prop-name)) - -(def$method (frame-core :set) - (slot-name value &optional (prop-name :value)) - "modification method for a property of a slot. intended to be specialized." - (set-value-only (get-slot-plist slot-name) value prop-name)) - -(def$method (frame-core :put) - (slot-name value &optional (prop-name :value)) - "modification method for a property of a slot. intended to be specialized." - (set-value-only (get-slot-plist slot-name) value prop-name)) - - -;;;;; sehr problematisch !!!!!!! - -(def$method (frame-core :reset-slots) (&optional (prop-name :value)) - "sets all user defined slots to undetermined." - (mapc #'(lambda (a-slot-name) - (let ((slot-plist (get-slot-plist a-slot-name))) - (set-value-only slot-plist (undetermined) prop-name))) - slots)) - -;;-------------------------------------------------------------------- - - -(def$method (frame-core :delete-property) - (a-slot-name prop-name) - "deletes a property of a slot. :value property can't be deleted." - (if (is-value prop-name) - (baberror (getentry no-delete-permit-error-fstr frame-io-table) - object-name - a-slot-name - prop-name) - (remf (rest (get-slot-plist a-slot-name)) prop-name))) - - -(def$method (frame-core :type) (&optional a-frame-name) - "provides the type of the receiver or checks whether the receiver is of specified type." - (if a-frame-name - (flavor-typep self (get-frame-name-with-check a-frame-name)) - (%get-frame-name (flavor-type-of self)))) - -;;-------------------------------------------------------------------- -;; GET-VALUE, PUT-VALUE, $VALUE -;;-------------------------------------------------------------------- - -(defmacro GET-VALUE (instance-name slot-name - &optional (prop-name :value)) - `($send (get-instance ,instance-name) :get ,slot-name ,prop-name)) - -(defmacro PUT-VALUE (instance-name slot-name new-value - &optional (prop-name :value)) - `($send (get-instance ,instance-name) :put ,slot-name ,new-value ,prop-name)) - -;; FUER SETF -;; anstatt: -;; (put-value {}) -;; (setf (get-value {}) ) - - -(defsetf get-value (object-name slot-name &optional (prop-name :VALUE)) - (new-value) - `(put-value ,object-name ,slot-name ,new-value ,prop-name)) - - -(defmacro $VALUE (slot-name &optional (prop-name :value)) - ;; das ist zu gebrauchen innerhalb von Behaviors - `($send self :GET ,slot-name ,prop-name)) - - -(defmacro $SETF-VALUE (slot-name new-value &optional (prop-name :value)) - `($send self :SET ,slot-name ,new-value ,prop-name)) - - -;; FUER SETF - -(defsetf $VALUE (slot-name &optional (prop-name :value)) - (new-value) - `($send self :SET ,slot-name ,new-value ,prop-name)) - - - -;;-------------------------------------------------------------------- -;; INITIALISATION -;;-------------------------------------------------------------------- - - -(def$method (frame-core :check-your-self) () - "dummy method called on initialization. -intended to be specialized by the user." - t) - - -(defun normalize-plist (plist) - (cond ((null plist) plist) - ((atom plist) `(:value ,plist)) - ((is-multiple-value plist) `(:value ,plist)) - ((is-value (first plist)) plist) - (t `(:value . ,plist)))) - -(def$method (frame-core :init-slot) (slot-name slot-spezification check) - (declare (ignore check)) - (do ((plist (normalize-plist slot-spezification) - (rest (rest plist)))) - ((null plist)) - ($send self :set slot-name (second plist) (first plist)))) - -(def$method (frame-core :init-all-slots) (slot-specifications &optional (check nil)) - "initializes all user defined slots using slot-specifications." - (unless (null slot-specifications) - ($send self :init-slot - (first slot-specifications) (second slot-specifications) check) - ($send self :init-all-slots (rest (rest slot-specifications)) check))) - - -(def$method (frame-core :initialize) (with-specification) - "dummy method. to be used as basic method for user defined daemons." - with-specification) - -;;----------------------------------------------------------------------------- -;; UNPARSING INSTANCES -;;----------------------------------------------------------------------------- - -(def$method (frame-core :internal-properties) () - nil) - -(def$method (frame-core :unparse-slot) - (slot-name &optional (all-properties t) internal-properties) - (let ((header `(,slot-name :value ,($send self :get-value-only slot-name)))) - (setf internal-properties (or internal-properties - ($send self :internal-properties))) - (cond ((null all-properties) header) - (t (append header - (do ((plist (rest (get-slot-plist slot-name)) - (cddr plist)) - (result nil)) - ((null plist) (reverse result)) - (unless (member (first plist) internal-properties) - (setf result (cons (second plist) - (cons (first plist) - result)))))))))) - -(def$method (frame-core :unparse-instance) - (&optional slot-list (all-properties t) internal-properties) - (setf internal-properties (or internal-properties - ($send self :internal-properties))) - (append `(,object-name ,(%get-frame-name (flavor-type-of self))) - (mapcar #'(lambda (slot) - ($send self :unparse-slot - slot all-properties internal-properties)) - (or slot-list slots)))) - -;;----------------------------------------------------------------------------- -;; ASKING FOR SLOT VALUES -;;----------------------------------------------------------------------------- - - -(def$method (frame-core :ask-for-slot-values) (&optional list) - (do ((rslots (or list slots) (rest rslots))) - ((null rslots)) - ($send self :ask (first rslots)))) - -(def$method (frame-core :ask) - (slot &optional arg negation-flag (standard-option nil)) - "asks the user for the value (of a property) of a slot." - (if (and (atom arg) - (not (null arg))) - (if (is-facet arg) - (setq arg (list arg)) - (baberror (getentry wrong-arg-type-error-fstr frame-io-table) - arg object-name slot arg))) - (if (and (not (null arg)) - (is-facet (first arg))) - ;; Dies erlaubt jetzt, beliebige property zu erfragen - ($send self :ask-for-slot-property - slot - (first arg) ; a property - (rest arg) ; the desired value - negation-flag - standard-option) - ($send self :ask-for-slot-value - slot arg negation-flag standard-option))) - -(defun format-expectations (desired-value negation-flag restrict-method args) - (concatenate 'string - (if restrict-method - (format nil - (getentry expect-restricted-value-fstr frame-io-table) - restrict-method args args) - (format nil (getentry expect-no-restricted-value-fstr frame-io-table))) - (if desired-value - (if negation-flag - (format nil - (getentry expected-value-not-str frame-io-table) - desired-value) - (format nil - (getentry expected-value-str frame-io-table) - desired-value)) - ""))) - -(def$method (frame-core :ask-for-slot-property) - (slot prop-name &optional desired-value negation-flag standard-option) - "asks the user for the value of a property of a slot." - (cond ((is-value prop-name) - ($send self :ask-for-slot-value - slot desired-value negation-flag standard-option)) - (t (send-kb :babylon-format - (getentry ask-slot-prop-fstr frame-io-table) - prop-name slot object-name) - (let ((result (send-kb :babylon-read (list *c-help-key*)))) - (cond ((eql result *c-help-key*) - (send-kb :babylon-format - (format-expectations desired-value negation-flag nil nil)) - ($send self :ask-for-slot-property - slot - prop-name - desired-value - negation-flag - standard-option)) - ((is-help result) result) - (t ($send self :set slot result prop-name))))))) - -(defun substitute-o-and-s (object-name slot-name list) - (sublis `((O . ,object-name) (S . ',slot-name)) list)) - -;(defun format-translate (slot object-name) -; (let ((ask-declaration ($send (get-instance object-name) :get slot :ask))) -; (if ask-declaration ;; ( . ) -; ;; := O "Der Name des Objektes" -; ;; := S "Der Name des Slots" -; (apply #'format nil (substitute-o-and-s object-name slot ask-declaration)) -; (format nil -; (getentry whats-the-value-of-fstr frame-io-table) -; object-name slot)))) - -(def$method (frame-core :prompt-for-value) (slot) - (let* ((ask-declaration ($send self :get slot :ask)) - ;; ( . ) - ;; := O "Der Name des Objektes" - ;; := S "Der Name des Slots" - (prompt (substitute-o-and-s object-name slot ask-declaration))) - (if prompt - (send-kb :babylon-format "~?" (first prompt) (eval `(list ,@(rest prompt)))) - (send-kb :babylon-format - (getentry ask-slot-fstr frame-io-table) - slot object-name)))) - -(def$method (frame-core :ask-for-slot-value) - (slot &optional desired-value negation-flag (standard-option nil)) - "asks the user for the value of ." - ($send self :prompt-for-value slot) - (let ((result (send-kb :babylon-read (list *c-help-key*)))) - (cond ((eql result *c-help-key*) - (send-kb :babylon-format - (format-expectations desired-value negation-flag nil nil)) - ($send self :ask-for-slot-value - slot desired-value negation-flag standard-option)) - ((is-help result) 'help) - (t ($send self :set slot result))))) - - -;;----------------------------------------------------------------------------- -;; HANDLING OF SLOT MESSAGES -;;----------------------------------------------------------------------------- - - -;; (<- : . args) -;; (<- {} {}) -;; -;; defaults to :value -;; -;; := atom | frame-reference | behavior-reference | lisp-expression -;; -;; frame-reference := ( {} ) -;; -;; behavior-reference := ( . ) - - -(defmacro normalize-args (args) - `(cond ((is-facet (first ,args)) ,args) - ((is-path (first ,args)) ,args) - (t (cons :value ,args)))) - - -(defmacro check-for-equal-relation (relation) - `(or (member ,relation '(= is)) - (baberror (getentry expect-relation-fstr frame-io-table) ,relation))) - - -(defmacro <-- (instance-name slot-or-method &rest args) - (cond ((is-user-defined-method slot-or-method) - `($send (get-instance-or-self ,instance-name) ,slot-or-method ,@args)) - ((null (rest args)) - `($send (get-instance-or-self ,instance-name) :get - ',slot-or-method ,(or (first args) :value))) - (t (let* ((normed-args (normalize-args args)) - (relation (second normed-args)) - (mode (or (fourth normed-args) :recall))) - (case mode - (:recall `($send (get-instance-or-self ,instance-name) ,mode - ',slot-or-method - ',(internal-relation-name relation) - ',(third normed-args) - ,(first normed-args))) ; property - (:remember - (if (check-for-equal-relation relation) - `($send (get-instance-or-self ,instance-name) ,mode - ',slot-or-method - ',(internal-relation-name relation) - ',(third normed-args) - ,(first normed-args)))) ; property - (:store - (if (check-for-equal-relation relation) - `($send (get-instance-or-self ,instance-name) ,mode - ',slot-or-method - ',(third normed-args) - ,(first normed-args)))) ; property - (t (baberror (getentry mode-error-fstr frame-io-table) mode))))))) - -(defmacro <- (instance-name slot-or-method &rest args) - `(<-- ,instance-name ,slot-or-method ,@args)) - -(defun compute-list-expr (expr self) - (let ((first-expr (first expr))) - (cond ((eq first-expr 'SELF) - (if (is-user-defined-method (second expr)) - (lexpr-$send self (second expr) (eval `(list ,@(cddr expr)))) - (lexpr-$send self :get (rest expr)))) - ((is-instance first-expr) - (if (is-user-defined-method (second expr)) - (lexpr-$send (get-instance first-expr) (second expr) - (eval `(list ,@(cddr expr)))) - (lexpr-$send (get-instance first-expr) :get (rest expr)))) - ((member first-expr '($E $EVAL)) - (eval (second expr))) - (t expr)))) - -(def$method (frame-core :slot-message) (slot-name &rest args) - "generic method to get or set a property of a slot. -args := {} {}" - (let* ((normed-args (normalize-args args)) - (prop-name (first normed-args)) - (relation (second normed-args)) - (expr (third normed-args)) - (mode (or (fourth normed-args) :recall))) - (cond ((null relation) - ($send self :get slot-name prop-name)) - ((eq mode :recall) - ($send self :recall slot-name relation expr prop-name)) - ((eq mode :remember) - (and (check-for-equal-relation relation) - ($send self :remember slot-name relation expr prop-name))) - ((eq mode :store) - (and (check-for-equal-relation relation) - ($send self :store slot-name expr prop-name))) - (t (baberror (getentry mode-error-fstr frame-io-table) mode))))) - -(def$method (frame-core :recall) (slot-name relation expr &optional (prop-name :value)) - "compares a property of a slot with the specified expr using relation." - (let ((old-value ($send self :get slot-name prop-name)) - (new-value (cond ((atom expr) expr) - (t (compute-list-expr expr self)))) - (int-rel-name (internal-relation-name relation))) - (cond ((is-undetermined old-value) - (if (and (is-equality-relation int-rel-name) - ($send self int-rel-name old-value new-value)) - ;; Dies ist notwendig, falls gerade auf UNDETERMINED - ;; gecheckt wird - t - old-value)) - (t ($send self int-rel-name old-value new-value))))) - -(def$method (frame-core :remember) (slot-name relation expr &optional (prop-name :value)) - "sets a property of a slot to the specified expr. -returns nil, if the specified expr is identical to the old value." - (let ((old-value ($send self :get slot-name prop-name)) - (new-value (cond ((atom expr) expr) - (t (compute-list-expr expr self)))) - (int-rel-name (internal-relation-name relation))) - (cond ((is-undetermined old-value) - ($send self :put slot-name new-value prop-name)) - (($send self int-rel-name old-value new-value) nil) - (t ($send self :put slot-name new-value prop-name))))) - -(def$method (frame-core :store) (slot-name expr &optional (prop-name :value)) - "sets a property of a slot to the specified expr." - (let ((new-value (cond ((atom expr) expr) - (t (compute-list-expr expr self))))) - ($send self :put slot-name new-value prop-name))) - - -;;----------------------------------------------------------------------------- -;; RELATIONS FOR SLOT MESSAGES -;;----------------------------------------------------------------------------- - - -(defun internal-relation-name (relation) - (if (keywordp relation) - relation - (intern (concatenate 'string (string relation) "-REL") :keyword))) - -(defun is-equality-relation (relation-name) - (member relation-name '(:=-rel :is-rel :/=-rel :one-of-rel :all-of-rel))) - -(defmacro DEFINE-RELATION-METHOD ((flavor-name relation-name) lambda-list &body body) - (let ((internal-rel-name - (if (keywordp relation-name) - relation-name - (intern (concatenate 'string (string relation-name) "-REL") :keyword)))) - `(progn (def$method - (,flavor-name ,internal-rel-name) - ,lambda-list . ,body) - '(,flavor-name ,relation-name)))) - -;; for the user - -(defmacro DEFINE-RELATION-BEHAVIOR ((frame-name relation-name) lambda-list &body body) - `(define-relation-method (,(get-frame-name-or-signal-error - `(,frame-name ,relation-name)) - ,relation-name) - ,lambda-list - . ,body)) - - -;;----------------------------------------------------------------------------- -;; STANDARD RELATIONS -;;----------------------------------------------------------------------------- - -(DEFINE-RELATION-METHOD (frame-core =) (facet-value expr-value) - (cond ((IS-MULTIPLE-ANSWER facet-value) - ; This in case that cfs are not handled - (member expr-value (rest facet-value))) - (t (equal facet-value expr-value)))) - -(DEFINE-RELATION-METHOD (frame-core /=) (facet-value expr-value) - (cond ((IS-MULTIPLE-ANSWER facet-value) - ; This in case that cfs are not handled - (not (member expr-value (rest facet-value)))) - (t (not (equal facet-value expr-value))))) - -(DEFINE-RELATION-METHOD (frame-core is) (facet-value expr-value) - (cond ((IS-MULTIPLE-ANSWER facet-value) - ; This in case that cfs are not handled - (member expr-value (rest facet-value))) - (t (equal facet-value expr-value)))) - -(DEFINE-RELATION-METHOD (frame-core >=) (facet-value expr-value) - (>= facet-value expr-value)) - -(DEFINE-RELATION-METHOD (frame-core >) (facet-value expr-value) - (> facet-value expr-value)) - -(DEFINE-RELATION-METHOD (frame-core <=) (facet-value expr-value) - (<= facet-value expr-value)) - -(DEFINE-RELATION-METHOD (frame-core <) (facet-value expr-value) - (< facet-value expr-value)) - - -(defun is-interval-specification (list) - (and (numberp (first list)) - (numberp (second list)) - (null (rest (rest list))))) - -(defun is-in-interval (x interval) - (or (<= (first interval) x (second interval)) - (>= (first interval) x (second interval)))) - - -(DEFINE-RELATION-METHOD (frame-core between) (facet-value interval) - (and (numberp facet-value) - (is-interval-specification interval) - (is-in-interval facet-value interval))) - -(DEFINE-RELATION-METHOD (frame-core one-of) (facet-value expr-value) - (some #'(lambda (a-value) - ($send self ':=-rel facet-value a-value)) - expr-value)) - -(DEFINE-RELATION-METHOD (frame-core all-of) (facet-value expr-value) - (every #'(lambda (a-value) - ($send self ':=-rel facet-value a-value)) - expr-value)) - -;;; eof - diff --git a/t/baby2015/kernel/frames/basic/frames.cl b/t/baby2015/kernel/frames/basic/frames.cl deleted file mode 100644 index d61e774..0000000 --- a/t/baby2015/kernel/frames/basic/frames.cl +++ /dev/null @@ -1,707 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Base: 10; Package: BABYLON -*- - -(in-package "BABYLON") - -;; Copyright 1986, 1985 and 1984 BY -;; G M D -;; Postfach 1240 -;; D-5205 St. Augustin -;; FRG - - -;; DATE: April 1987 -;; AUTHORS: Franco di Primio, Eckehard Gross - -;; This file depends on: common>* -;; -;; Contents: a handler to mantain frames, behaviors and instances - - - -;;-------------------------------------------------------------------- -;; COMMON FUNCTIONS AND MACROS -;;-------------------------------------------------------------------- - - -(defmacro is-facet (x) - `(keywordp ,x)) - -(defmacro is-path (x) - `(and (consp ,x) - (every #'keywordp ,x))) - -;; (is-facet :possible-values) ==> T -;; (is-facet 'possible-values) ==> NIL -;; (is-path nil) ==> NIL - -;; BEHAVIOR-Namen (d.h. Benutzer-definierte Methoden fuer die FRAMES) -;; muessen keywords sein !!!!! - -(defmacro is-user-defined-method (x) - `(keywordp ,x)) - -(defmacro is-value (prop-name) - `(eq ,prop-name :VALUE)) - -;;-------------------------------------------------------------------- -;; frames and instances are interned in a package assoziated with the kb -;;-------------------------------------------------------------------- - -(defun %make-object-name (name &optional (kb-pkg nil)) - (intern (symbol-name name) (or kb-pkg (send-kb :pkg)))) - -(defun %get-object-name (object-name &optional (kb-pkg nil)) - ;; Hier wird NIL zurueckgegeben, falls die Suche erfolglos ist. - (if (symbolp object-name) - (find-symbol (symbol-name object-name) (or kb-pkg (send-kb :pkg))))) - -;;-------------------------------------------------------------------- -;; falls packages nicht zur verfuegung stehen -;; frames und instances werden mit einem mit der *CURRENT-KNOWLEDGE-BASE* -;; assoziierten prefix versehen -;;-------------------------------------------------------------------- -; -;(defun %make-object-name (name &optional (kb-prefix nil)) -; (intern (concatenate 'string (or kb-prefix (send-kb :pkg))) -; (symbol-name name))))) -; -;(defun %get-object-name (object-name &optional (kb-prefix nil)) -; ;; Hier wird NIL zurueckgegeben, falls die Suche erfolglos ist. -; (if (symbolp object-name) -; (find-symbol (concatenate 'string (or kb-prefix (send-kb :pkg)) -; (symbol-name name)))) - -;;-------------------------------------------------------------------- -;; FLAVOR OF FRAME-PROCESSOR -;;-------------------------------------------------------------------- - -(def$flavor frame-base - ((instances-list nil) - (frames-list nil) - (frame-type 'frame-core) - (frcheck nil)) - (processor-core) - :settable-instance-variables - (:documentation "frame-base creates frames, behaviors and instances.")) - - -(def$method (frame-base :toggle-frcheck) () - (cond ((null frcheck) - (setf frcheck t)) - (t (setf frcheck nil)))) - - -;;-------------------------------------------------------------------- -;; FRAMES -;;-------------------------------------------------------------------- - -;; (DEFFRAME -;; (SUPERS . ) -;; (SLOTS . )) -;; -;; := | -;; ( ...) -;; -;; := - - -;;-------------------------------------------------------------------- - -(defun make-frame-name (frame-name) - (%make-object-name frame-name)) - -(defun get-frame-name (frame-name) - (let ((frame-internal-name (%get-object-name frame-name))) - (or frame-internal-name - (baberror (getentry unknown-frame-error-fstr frame-io-table) - frame-name - (send-kb :kb-name))))) - -(defun get-frame-name-with-check (frame-name) - (let ((frame-internal-name (%get-object-name frame-name))) - (if (and frame-internal-name - (%is-frame frame-internal-name)) - frame-internal-name - (baberror (getentry unknown-frame-error-fstr frame-io-table) - frame-name - (send-kb :kb-name))))) - - -(defun signal-unknown-frame (frame-name when spez) - (unless (is-frame frame-name) - (baberror (getentry unknown-frame-while-defining-fstr frame-io-table) - when - spez - frame-name - (send-kb :kb-name)))) - - -(defmacro frame-definition (frame-internal-name) - `(get ,frame-internal-name :FRAME-DEFINITION)) - -(defun get-frame-def (frame-name) - ;checks for frame-name - (frame-definition (get-frame-name-with-check frame-name))) - -(defun %get-frame-name (frame-internal-name) - (second (frame-definition frame-internal-name))) - -(defun %is-frame (object-internal-name) - (not (null (frame-definition object-internal-name)))) - - -(defun is-frame (name) - ;returns nil if x is not a symbol - (let ((object-internal-name (%get-object-name name))) - (if object-internal-name - (not (null (frame-definition object-internal-name)))))) - -;;-------------------------------------------------------------------- -;; HANDLING SLOTS -;;-------------------------------------------------------------------- - - -(defmacro frame-slots (frame-body) - `(assoc 'SLOTS ,frame-body)) - -(defun get-frame-slots (frame-name) - (rest (frame-slots (cddr (get-frame-def frame-name))))) - -(defun compute-slot-names (slot-specs) - (mapcar #'(lambda (a-slot-spec) - (if (atom a-slot-spec) - a-slot-spec - (first a-slot-spec))) - slot-specs)) - -(defun get-frame-slot-names (frame-name) - (compute-slot-names (get-frame-slots frame-name))) - -;;-------------------------------------------------------------------- -;; HANDLING SUBCLASSES -;;-------------------------------------------------------------------- - - -(defmacro frame-subclasses (frame-internal-name) - `(get ,frame-internal-name :SUBCLASSES)) - -(defun add-subframe (frame-name super-frame-name) - (let* ((super-frame-internal-name (get-frame-name-with-check super-frame-name)) - (subs-so-far (frame-subclasses super-frame-internal-name))) - (if (not (member frame-name subs-so-far)) - (setf (frame-subclasses super-frame-internal-name) - (cons frame-name subs-so-far))))) - -(defun install-subframe (frame-name supers) - (mapcar #'(lambda (a-super) - (add-subframe frame-name a-super)) - supers)) - - -(defun get-subframes (frame-name) - (frame-subclasses (get-frame-name-with-check frame-name))) - -(defun get-all-subframes (frame-name) - (do ((open (get-subframes frame-name)) - (closed nil)) - ((null open) closed) - (let ((a-frame-name (pop open))) - (cond ((member a-frame-name closed) nil) - (t (push a-frame-name closed) - (setq open (append (get-subframes a-frame-name) open))))))) - -;;-------------------------------------------------------------------- -;; HANDLING SUPERCLASSES -;;-------------------------------------------------------------------- - - -(defmacro frame-supers (frame-body) - `(assoc 'SUPERS ,frame-body)) - -(defun get-supers (frame-name) - (let ((supers-specification - (frame-supers (cddr (get-frame-def frame-name))))) - (if supers-specification - (rest supers-specification)))) - -(defun get-all-supers (frame-name) - (do ((open (get-supers frame-name)) - (closed nil)) - ((null open) closed) - (let ((a-frame-name (pop open))) - (cond ((member a-frame-name closed) nil) - (t (push a-frame-name closed) - (setq open (append (get-supers a-frame-name) open))))))) - -;;-------------------------------------------------------------------- -;; CHECKING IF FRAME DEFINITION IS CORRECT -;;-------------------------------------------------------------------- - - -(defmacro frame-options (frame-body) - `(assoc 'OPTIONS ,frame-body)) - - -(defun make-slot-specification-example () - (format nil (getentry slot-spec-example-str frame-io-table))) - -(defun make-frame-definition-example () - (format nil (getentry frame-spec-example-str frame-io-table))) - -(defun make-supers-specification-example () - (format nil (getentry supers-spec-example-str frame-io-table))) - - -(defun check-frame-definition (frame-name body) - (if (not (every #'listp body)) - (baberror (getentry frame-spec-error-fstr frame-io-table) - frame-name - (make-frame-definition-example))) - (let ((slots (frame-slots body)) - (supers (frame-supers body)) - (options (frame-options body))) - (if (and supers - (not (is-simple-list supers))) - (baberror (getentry supers-spec-error-fstr frame-io-table) - supers - frame-name - (make-supers-specification-example))) - (mapc #'(lambda (a-slot-specification) - (cond ((symbolp a-slot-specification)) - ((and (is-true-list a-slot-specification) - (symbolp (first a-slot-specification)) - (evenp (length a-slot-specification)))) - (t (baberror (getentry slot-spec-error-fstr frame-io-table) - a-slot-specification - frame-name - (make-slot-specification-example))))) - (rest slots)) - (if (not (null (remove options (remove slots (remove supers body))))) - (baberror (getentry frame-spec-error-fstr frame-io-table) - frame-name - (make-frame-definition-example))))) - - - -;;-------------------------------------------------------------------- -;; THE FRAME CONSTRUCTOR -;;-------------------------------------------------------------------- - - - -(defun compute-slots (slot-specs) - (mapcar #'(lambda (x) - (if (atom x) - `(,x (list (undetermined))) - `(,(first x) (list . ,(mapcar #'(lambda ($x) - (list 'quote $x)) - (cdr x)))))) - slot-specs)) - -(defun compute-slots2 (slot-specs) - (mapcar #'(lambda (x) - (if (atom x) - `(,x '(,(undetermined))) - `(,(first x) ',(cdr x)))) - slot-specs)) - - -(def$method (frame-base :new-frame-form) (frame-name body) - "transforms a frame definition into a flavor definition." - (if frcheck - (check-frame-definition frame-name body)) - (let ((frame-internal-name (make-frame-name frame-name)) - (frame-internal-supers - (mapcar #'get-frame-name (rest (frame-supers body))))) - `(progn - (dolist (a-super ',(rest (frame-supers body))) - (signal-unknown-frame a-super "FRAME" ',frame-name)) - (def$frame ,frame-internal-name - ,(compute-slots (rest (frame-slots body))) - ,(or frame-internal-supers (list frame-type)) - :initable-instance-variables - ,@(rest (frame-options body))) - (setf (frame-definition ',frame-internal-name) - '(defframe ,frame-name . ,body)) - (install-subframe ',frame-name ',(rest (frame-supers body))) - (send-kb :add-to-frames ',frame-name) - ',frame-name))) - - -;;-------------------------------------------------------------------- -;; BEHAVIOR DEFINITION -;;-------------------------------------------------------------------- - -;; (DEFBEHAVIOR ( {} ) -;; -;; . ) - -;; Innerhalb von kann der Zugriff auf slot-werte -;; folgendermassen erfolgen: - -;; ($VALUE ) ==> liefert Wert der :VALUE property -;; ($VALUE ) ==> liefert Wert der property - -;; Modifikation von slot-werten erfolgt durch den allgemeinen -;; Zuweisungsoperator SETF -;; (s. Lispmachinen-Manual) - -;; (setf ($VALUE ) ) -;; ==> Setzt :VALUE property auf - -;; (setf ($VALUE ) ) -;; ==> Setzt property auf - - - -(defmacro frame-behaviors (frame-internal-name) - `(get ,frame-internal-name :BEHAVIORS)) - -(defun get-frame-behaviors (frame-name) - (frame-behaviors (get-frame-name-with-check frame-name))) - - -(defun get-frame-behavior-specs (frame-name) - (mapcar #'car (get-frame-behaviors frame-name))) - - -(defun add-to-behaviors (frame-name behavior-def) - (let* ((frame-internal-name (get-frame-name frame-name)) - (behavior-specification (first behavior-def)) - (behaviors-so-far (frame-behaviors frame-internal-name)) - (previous-def (assoc behavior-specification behaviors-so-far :test #'equal))) - (if previous-def - (setf (rest previous-def) (rest behavior-def)) - (setf (frame-behaviors frame-internal-name) - `(,@behaviors-so-far ,behavior-def))))) - -(defun get-frame-name-or-signal-error - (behavior-specification) - (let ((frame-name (%get-object-name (first behavior-specification)))) - (if (or (null frame-name) - (not (%is-frame frame-name))) - (baberror (getentry unknown-frame-for-behavier-error-fstr frame-io-table) - behavior-specification - (first behavior-specification) - (send-kb :kb-name)) - frame-name))) - -;;-------------------------------------------------------------------- -;; BEHAVIOR CONSTRUCTOR -;;-------------------------------------------------------------------- - -;;;;;; die substitution von $value eruebgrigt macro-expansion - - -(def$method (frame-base :new-behavior-form) - (behavior-specification lambda-list behavior-body) - "transforms a behavior definition into a method definition." - (if (not (listp behavior-specification)) - (baberror (getentry behavior-spec-error-fstr frame-io-table) - behavior-specification)) - (if (not (every #'keywordp (rest behavior-specification))) - (baberror (getentry behavior-spec-error-fstr frame-io-table) - behavior-specification)) - (let ((frame-name (first behavior-specification))) - `(progn - (signal-unknown-frame ',frame-name - "BEHAVIOR" - ',behavior-specification) - (def$behavior (,(get-frame-name frame-name) ,@(rest behavior-specification)) - ,lambda-list - ,@behavior-body) - (add-to-behaviors ',frame-name - '(,behavior-specification ,lambda-list ,@behavior-body)) - ',behavior-specification))) - - - -;;-------------------------------------------------------------------- -;; INSTANCES OF FRAMES -;;-------------------------------------------------------------------- - -(defun make-instance-name (instance-name) - (%make-object-name instance-name)) - -(defun get-instance-name (instance-name) - (let ((instance-internal-name (%get-object-name instance-name))) - (or instance-internal-name - (baberror (getentry unknown-instance-error-fstr frame-io-table) - instance-name - (send-kb :kb-name))))) - -(defun get-instance-name-with-check (instance-name) - (let ((instance-internal-name (%get-object-name instance-name))) - (if (and instance-internal-name - (%is-instance instance-internal-name)) - instance-internal-name - (baberror (getentry unknown-instance-error-fstr frame-io-table) - instance-name - (send-kb :kb-name))))) - - -(defmacro instance-definition (instance-internal-name) - `(get ,instance-internal-name :INSTANCE-DEFINITION)) - -(defun get-instance-def (instance-name) - (instance-definition (get-instance-name-with-check instance-name))) - - -(defun %is-instance (object-internal-name) - (not (null (instance-definition object-internal-name)))) - -(defun is-instance (name) - (let ((instance-internal-name (%get-object-name name))) - (if instance-internal-name - (not (null (instance-definition instance-internal-name)))))) - - -;; Das muss ein macro sein, wegen SETF in ADD-INSTANCE-TO-FRAME: - -(defmacro frame-instances (frame-internal-name) - `(get ,frame-internal-name :INSTANCES)) - -;;; falls frames importiert sind, instances aber nicht -(defun get-instance-list (frame-name) - (intersection - (get (get-frame-name-with-check frame-name) :INSTANCES) - (send-kb :instances))) - -(defun get-all-instances (frame-name) - (do ((frames (cons frame-name (get-all-subframes frame-name)) - (rest frames)) - (result nil)) - ((null frames) result) - (setf result (append result (get-instance-list (first frames)))))) - -(defun add-instance-to-frame (frame-name instance-name) - (let* ((frame-internal-name (get-frame-name-with-check frame-name)) - (instances-so-far (frame-instances frame-internal-name))) - (if (not (member instance-name instances-so-far)) - (setf (frame-instances frame-internal-name) - `(,@instances-so-far ,instance-name))))) - -;;-------------------------------------------------------------------- -;; INITIALIZING SLOTS -;;-------------------------------------------------------------------- - -;; Actually merging of default and explicit slot specification is only made -;; for instances, not between FRAMES -;; (this is the case in LOOPS). This may be changed in future. - -;; (DEFINSTANCE OF -;; WITH = -;; ... -;; = ) - -;; := " ist init-wert von :VALUE property" -;; := ( ...) - - -(defun make-definstance-example () - (format nil (getentry instance-spec-example-str frame-io-table))) - -(defun check-instance-definition (instance-name of frame-name body) - (if (not (send-kb :kb-name)) - (baberror (getentry no-kb-for-instance-error-fstr frame-io-table) - instance-name - frame-name)) - (if (not (eq of 'OF)) - (baberror (getentry of-keyword-expect-error-fstr frame-io-table) - 'of - (format nil (getentry definstance-spec-fstr frame-io-table) - instance-name of frame-name))) - (cond ((null body)) - ((and (is-true-list body) - (eq (first body) 'WITH)) - (do ((b (rest body) (cdddr b))) - ((null b) t) - (if (not (and (symbolp (first b)) - (eq (second b) '=) - (or (atom (third b)) - (is-true-list (third b))))) - (baberror (getentry slot-initialization-error-fstr frame-io-table) - (first b) - (format nil - (getentry definstance-spec-fstr frame-io-table) - instance-name of frame-name) - (make-definstance-example))))) - (t (baberror (getentry instance-spec-error-fstr frame-io-table) - `(definstance ,instance-name ,of ,frame-name . ,body) - (make-definstance-example))))) - -;;-------------------------------------------------------------------- -;; INSTANCE CONSTRUCTOR -;;-------------------------------------------------------------------- - - -(defun remove-noisy-words (args) - (remove 'WITH (remove '= args))) - -(def$method (frame-base :new-instance) - (instance-name frame-name with-specification) - "generates an instance of frame-name." - (if frcheck - (check-instance-definition instance-name 'of frame-name with-specification)) - (let* ((internal-instance-name (make-instance-name instance-name)) - (instance (make-$instance (get-frame-name-with-check frame-name) - :object-name instance-name))) - (setf (get internal-instance-name :instance) instance) - (setf (get internal-instance-name :instance-definition) - `(definstance ,instance-name of ,frame-name . ,with-specification)) - (if frcheck - ($send instance :check-your-self)) - ($send instance :init-all-slots (remove-noisy-words with-specification) frcheck) - ($send meta-processor :add-to-instances instance-name) - (add-instance-to-frame frame-name instance-name) - ($send instance :initialize with-specification) - (setf (symbol-value instance-name) instance-name))) - - -;; create-unnamed-instance wird benoetigt fuer create-instance-of -;; added: Franco 23.10. - -(def$method (frame-base :new-unnamed-instance) - (instance-name frame-name &optional with-specification) - "generates an unnamed instance of frame-name." - (if frcheck - (check-instance-definition instance-name 'of frame-name with-specification)) - (let ((instance (make-$instance (get-frame-name-with-check frame-name) - :object-name instance-name))) - (if frcheck - ($send instance :check-your-self)) - ($send instance :init-all-slots (remove-noisy-words with-specification) frcheck) - ($send instance :initialize with-specification) - instance)) - - -;;-------------------------------------------------------------------- -;; GETTING INSTANCES -;;-------------------------------------------------------------------- - - -(defmacro get-instance (instance-name) - `(get (get-instance-name ,instance-name) :instance)) - -;; Das wird gebraucht mit <- . Da wird ein voller Check gemacht. - -(defmacro get-instance-with-check (instance-name) - `(get (get-instance-name-with-check ,instance-name) :instance)) - -(defmacro $INST (instance-name) - `(get (get-instance-name-with-check ,instance-name) :instance)) - -(defmacro get-instance-or-self (instance-name) - (if (eq instance-name 'SELF) - `,instance-name - `(get-instance-with-check ,instance-name))) - -;; Das ist anstelle von SETQ zu gebrauchen. -;; Es erlaubt, eine Instanz ueber einen Variablennamen -;; referenzierbar zu machen. - - -(defmacro set-instance-pointer (variable-name instance-name) - `(let ((variable-internal-name (make-instance-name ',variable-name)) - (instance-internal-name (get-instance-name-with-check ,instance-name))) - (setq ,variable-name ',variable-name) - (setf (get variable-internal-name :instance) - (get instance-internal-name :instance)) - (setf (instance-definition variable-internal-name) - (instance-definition instance-internal-name)) - ',variable-name)) - - -;;-------------------------------------------------------------------- -;; RESETTING INSTANCES -;;-------------------------------------------------------------------- - - -(defmacro reset-instance (instance-name) - `(let ((instance-def (get-instance-def ',instance-name))) - (if (not instance-def) - (send-kb :babylon-format - (getentry no-instance-error-msg-fstr frame-io-table) - ',instance-name) - (eval instance-def)))) - - -(defmacro reset-instances (&rest list-of-instance-names) - `(progn ,@(mapcar #'(lambda (an-instance-name) - `(reset-instance ,an-instance-name)) - list-of-instance-names) - t)) - - -;;------------------------------------------------------------------------- -;; SIMPLE PRINTING FUNCTIONS FOR FRAMES, BEHAVIORS, INSTANCES -;;------------------------------------------------------------------------- - -(defun print-frame-definition (frame-name &optional (stream *default-dialog-stream*)) - (babpprint (get-frame-def frame-name) stream)) - - - -(defun make-behavior-def (behavior-body) - `(DEFBEHAVIOR . ,behavior-body)) - -(defun print-frame-behavior (behavior-body &optional (stream *default-dialog-stream*)) - (babpprint (make-behavior-def behavior-body) stream)) - - -(defun print-frames (frame-names &optional (stream *default-dialog-stream*)) - (mapc #'(lambda (a-frame-name) - (print-frame-definition a-frame-name stream) - (format stream "~2%") - (mapc #'(lambda (a-behavior-def) - (print-frame-behavior a-behavior-def stream) - (format stream "~2%")) - (frame-behaviors a-frame-name))) - frame-names) - T) - -(defun print-frame (frame-name &optional (stream *default-dialog-stream*)) - (print-frames (list frame-name) stream)) - - -(defun print-instance-def (instance-name &optional (stream *default-dialog-stream*)) - (babpprint (get-instance-def instance-name) stream)) - -(defun print-instances (frame-name &optional (stream *default-dialog-stream*)) - (mapc #'(lambda (an-instance-name) - (print-instance-def an-instance-name stream) - (format stream "~2%")) - (get-instance-list frame-name)) - t) - - -(def$method (frame-base :inspect-frame) - (frame-name &optional (stream *default-dialog-stream*)) - "describes frame named on ." - (format stream "~%Frame: ~S" frame-name) - (format stream - "~%Slots: ~{~S ~}" - (compute-slot-names (get-frame-slots frame-name))) - (format stream - "~%Supers: ~{~S ~}" - (get-supers frame-name)) - (format stream - "~%Behaviors: ~{~{~* ~S ~^ ~S~} ~}" - (get-frame-behavior-specs frame-name)) - (format stream - "~%Instances: ~{~S ~} ~%" - (get-instance-list frame-name))) - -(def$method (frame-base :inspect-instance) - (instance-name &optional (stream *default-dialog-stream*)) - "describes instance named on ." - (let ((instance (get-instance instance-name))) - (format stream "~%Instance: ~S" instance-name) - (mapc #'(lambda (a-slot) - (format stream - "~%Slot: ~S Value: ~S Properties: ~{~S ~}" - a-slot - ($send instance :get a-slot) - (rest ($send instance :get-properties a-slot)))) - ($send instance :slots)) - (format stream "~%"))) \ No newline at end of file diff --git a/t/baby2015/kernel/frames/mini/ask-supp.cl b/t/baby2015/kernel/frames/mini/ask-supp.cl deleted file mode 100644 index e8c0b7c..0000000 --- a/t/baby2015/kernel/frames/mini/ask-supp.cl +++ /dev/null @@ -1,229 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: BABYLON; Base: 10 -*- - - -(in-package "BABYLON") - - - -(defbabylon-entry explanation-str frame-io-table english - " Show Explanations on ") - -(defbabylon-entry explanation-str frame-io-table german - " Gib Erlaeuterungen fuer ") - -(defun build-mult-choose-item-list (list) - (mapcar #'(lambda (element) - `(,element ,(format nil " ~S" element) (t))) - list)) - - -(defun build-explain-item-list (choices explanations) - (cond (choices - (append '((help "CONTEXT " (t)) - (nil " " nil)) - (build-mult-choose-item-list choices))) - (explanations '((help " CONTEXT " (t)) - (slot " SLOT " (t)))) - (t '((help " CONTEXT " (t)))))) - - - -(def$method (poss-val-mixin :provide-local-help) - (slot &optional (window *current-knowledge-base*)) - (let* ((explanations ($send self :get slot :explain-answers)) - (choices (explain-answers-choices explanations)) - (item-list (build-explain-item-list choices explanations)) - (selections (send-kb :mult-choose-from-menu - item-list - (getentry explanation-str frame-io-table)))) - (cond ((null selections) nil) - ((member 'help selections) 'help) - ((and (null choices) (member 'slot selections)) - (lexpr-$send window :format - (substitute-o-and-s object-name slot explanations))) - (t (dolist (choice selections) - (let ((explanation - (rest (assoc choice explanations :test 'equal)))) - (lexpr-$send window :format - (substitute-o-and-s object-name slot explanation)))))))) - - -;;------------------------------------------------------------------------------- - - -(defbabylon-entry choose-one-of-header-str frame-io-table english - " Choose one of: ") - -(defbabylon-entry choose-one-of-header-str frame-io-table german - " Waehle einen Eintrag aus ") - - -(defbabylon-entry expect-fstr frame-io-table english - " Expected Value ~:[~;NOT~] ~S ~S ") - -(defbabylon-entry expect-fstr frame-io-table german - " Erwarteter Wert ~:[~;NICHT~] ~S ~S ") - -(defun menu-choose-translate (desired-value negation-flag) - (if desired-value - `((,(format nil - (getentry expect-fstr frame-io-table) - negation-flag - (first desired-value) - (second desired-value)) - :no-select t) - ("" :no-select t)))) - - -(def$method (poss-val-mixin :one-of-read-method) - (slot desired-value negation-flag standard-option) - "method presenting a menu to select a value for a slot of type :one-of." - (let* ((possible-values ($send self :get slot :possible-values)) - (items (append `((" EXPLAIN " :value :explain)) - (or (menu-choose-translate desired-value negation-flag) - `((" " :no-select t))) - standard-option - (get-poss-val-args possible-values))) - (header (getentry choose-one-of-header-str frame-io-table))) - (do ((result (send-kb :choose-from-menu items header) - (send-kb :choose-from-menu items header))) - ((and (not (null result)) - (not (eq result :explain))) - (send-kb :babylon-format "~S" result) - result) - (when (eq result :explain) - (cond ((eql ($send self :provide-local-help slot) 'help) - (send-kb :babylon-format "~:C" *help-key*) - (return 'help)) - (t ($send self :prompt-for-value slot))))))) - -(setf (get :one-of :supp-method) :one-of-read-method) - -;;------------------------------------------------------------------------------- - -(defbabylon-entry choose-some-fstr frame-io-table english - " Choose some of: ") - -(defbabylon-entry choose-some-fstr frame-io-table german - " Waehle einige Eintraege ") - - -(defun menu-mult-choose-translate (desired-value negation-flag) - (if desired-value - `((nil ,(format nil (getentry expect-fstr frame-io-table) - negation-flag - (first desired-value) - (second desired-value)) - nil) - (nil " " nil)))) - -(def$method (poss-val-mixin :some-of-read-method) - (slot desired-value negation-flag standard-option) - "method presenting a menu to select some values for a slot of type :some-of." - ;;standard-option i.e. unknown undetermined - (let* ((possible-values ($send self :get slot :possible-values)) - (items (append - `((explain " EXPLAIN " (t))) - (or (menu-mult-choose-translate desired-value negation-flag) - '((nil " " nil))) - (build-mult-choose-item-list - `(,@standard-option . ,(get-poss-val-args possible-values))))) - (header (getentry choose-some-fstr frame-io-table))) - (do ((result (send-kb :mult-choose-from-menu items header) - (send-kb :mult-choose-from-menu items header))) - ((not (member 'explain result)) - (setf result - (cond ((member 'help result) 'help) - ((null result) - ($send self :get-value-only slot)) - ((and (not (null standard-option )) - (member (first standard-option) result)) - (first standard-option)) - (t (make-multiple-answer result)))) - (send-kb :babylon-format "~S" result) - result) - (cond ((eql ($send self :provide-local-help slot) 'help) - (send-kb :babylon-format "~:C" *help-key*) - (return 'help)) - (t ($send self :prompt-for-value slot)))))) - - -(setf (get :some-of :supp-method) :some-of-read-method) - -;;------------------------------------------------------------------------------- -;; entspricht fast default-read-method ; ruft :provide-local-help - -(defbabylon-entry for-explain-fstr frame-io-table english - "~%For explanations enter ~:C ") - -(defbabylon-entry for-explain-fstr frame-io-table german - "~%Fuer Erlaeuterungen gib ~:C ein") - -(def$method (poss-val-mixin :any-read-method) - (slot desired-value negation-flag standard-option) - "default method to support the user entering a value for slot." - (let ((possible-values ($send self :get slot :possible-values))) - (send-kb :babylon-format - (format-expectations desired-value - negation-flag - (get-poss-val-type possible-values) - (get-poss-val-args possible-values))) - (send-kb :babylon-format - (getentry for-explain-fstr frame-io-table) *help-key*) - ($send self :prompt-for-value slot) - (let ((result (send-kb :babylon-read (list *help-key* *c-help-key*)))) - (cond ((eql result *c-help-key*) - ($send self :any-read-method - slot desired-value negation-flag standard-option)) - ((or (eq result 'help) - (eql result *help-key*)) - (cond ((eql ($send self :provide-local-help slot) 'help) - (send-kb :babylon-format "~:C" *help-key*) - 'help) - (t ($send self :any-read-method - slot desired-value negation-flag standard-option)))) - (t (let ((check-result ($send self :check-value slot result))) - (if check-result - (get-check-result check-result) - ($send self :any-read-method - slot - desired-value - negation-flag - standard-option)))))))) - -(setf (get :any :supp-method) :any-read-method) - -;;------------------------------------------------------------------------------- - -(def$method (poss-val-mixin :instance-of-read-method) - (slot desired-value negation-flag standard-option) - "method presenting a menu to select an instance for a slot of type :instance-of." - (let* ((possible-value-args - (get-poss-val-args ($send self :get slot :possible-values))) - (frame-name - (get-frame-name-with-check (first possible-value-args))) - (items (append `((" EXPLAIN " :value :explain)) - (or (menu-choose-translate desired-value negation-flag) - `((" " :no-select t))) - standard-option - (get-all-instances frame-name))) - (header (getentry choose-one-of-header-str frame-io-table))) - (do ((result (send-kb :choose-from-menu items header) - (send-kb :choose-from-menu items header))) - ((and (not (null result)) - (not (eq result :explain))) - (send-kb :babylon-format "~S" result) - result) - (when (eq result :explain) - (cond ((eql ($send self :provide-local-help slot) 'help) - (send-kb :babylon-format "~:C" *help-key*) - (return 'help)) - (t ($send self :prompt-for-value slot))))))) - -(setf (get :instance-of :supp-method) :instance-of-read-method) - - -;;; eof - - - diff --git a/t/baby2015/kernel/frames/mini/mf-mixin.cl b/t/baby2015/kernel/frames/mini/mf-mixin.cl deleted file mode 100644 index 3231192..0000000 --- a/t/baby2015/kernel/frames/mini/mf-mixin.cl +++ /dev/null @@ -1,45 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; BASE: 10. ;Package: BABYLON -*- - - -(in-package "BABYLON") - -;; Copyright 1986, 1985 and 1984 BY -;; G M D -;; Postfach 1240 -;; D-5205 St. Augustin -;; FRG - - -;; DATE: April 1987 -;; AUTHORS: Franco di Primio, Eckehard Gross - -;; This file depends on: common>* -;; frames>basic>frames -;; frames>basic>bf-mixin -;; frames>mini>mf-proc -;; - -;; contents: a mixin making the facilities of mini-frame-processor available -;; for a knowledge base. -;; mini-frame-processor is a specialization of basic-frame-processor -;; generating frames which allow that possible values are specified -;; for the :value property of their slots. - -;;-------------------------------------------------------------------------- -;; FLAVOR MINI-FRAME-MIXIN -;;-------------------------------------------------------------------------- - - -(def$flavor mini-frame-mixin - () - (basic-frame-mixin) - (:documentation "This mixin makes the facilities of mini-frame-processor available, -which is a specialization of basic-frame-processor generating frames which allow -that possible values are specified for the :value property of their slots.")) - -(def$method (mini-frame-mixin :generate-frame-processor) () - "generates an instance of mini-frame-processor." - (setf frame-processor (make-$instance 'mini-frame-processor - :meta-processor self))) - -(assign-typefkt 'frame-type 'mini-frame-mixin) diff --git a/t/baby2015/kernel/frames/mini/mf-proc.cl b/t/baby2015/kernel/frames/mini/mf-proc.cl deleted file mode 100644 index 16d264a..0000000 --- a/t/baby2015/kernel/frames/mini/mf-proc.cl +++ /dev/null @@ -1,55 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Base: 10; Package: BABYLON -*- - -(in-package "BABYLON") - -;; Copyright 1986, 1985 and 1984 BY -;; G M D -;; Postfach 1240 -;; D-5205 St. Augustin -;; FRG - - -;; DATE: April 1987 -;; AUTHORS: Franco di Primio, Eckehard Gross - -;; This file depends on: common>* -;; frames>basic>* -;; frames>mini>mf-proc -;; -;; Contents: a specialization of basic-frame-processor generating frames -;; which allow that possible values are specified for the -;; :value property of their slots. - - -;;-------------------------------------------------------------------- -;; MINI-FRAME-PROCESSOR -;;-------------------------------------------------------------------- - -(def$flavor mini-frame-processor - () - (basic-frame-processor) - (:documentation "specialization of basic-frame-processor generating frames -with possible value feature.")) - - -(def$method (mini-frame-processor :after :init) (&rest plist) - (declare (ignore plist)) - (setf frame-type 'poss-val-frame-core)) - -;;-------------------------------------------------------------------- -;; BASE FLAVOR POSS-VAL-FRAME-CORE -;;-------------------------------------------------------------------- - - -(def$flavor poss-val-frame-core - () - (poss-val-mixin frame-core) - (:documentation "flavor to be used as base flavor of each frame -instead of frame-core, if possible values are to be supported.")) - - - -#-:FMCS(compile-$flavor-$methods mini-frame-processor) - -;;; eof - diff --git a/t/baby2015/kernel/frames/mini/pos-vals.cl b/t/baby2015/kernel/frames/mini/pos-vals.cl deleted file mode 100644 index 54c04a6..0000000 --- a/t/baby2015/kernel/frames/mini/pos-vals.cl +++ /dev/null @@ -1,430 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Base: 10; Package: BABYLON -*- - -(in-package "BABYLON") - -;; Copyright 1987, 1986, 1985 and 1984 BY -;; G M D -;; Postfach 1240 -;; D-5205 St. Augustin -;; FRG - - -;; DATE: April 1987 -;; AUTHORS: Eckehard Gross - -;; This file depends on: common>* -;; frames>basic>* -;; -;; Contents: a mixin which allows to specify possible values for the -;; :value property of a slot. -;; a possible value specification has the form: -;; -;; :possible-values := -;; | (:interval ) -;; | (:one-of ... ) -;; | (:some-of ... ) -;; -;; := :NUMBER | :STRING | :LIST ... - - -;;------------------------------------------------------------------------------- -;; POSSIBLE VALUE MIXIN -;;------------------------------------------------------------------------------- - - -(def$flavor poss-val-mixin - ()() - (:required-instance-variables slots object-name) - (:documentation "mixin providing means to introduce possible values for slots.")) - - -;;------------------------------------------------------------------------------- -;; CONSTRUCTOR FOR POSSIBLE VALUES METHODS -;;------------------------------------------------------------------------------- - - -(defmacro define-possible-values-method - ((flavor-name method-name) lambda-list form) - "macro to create the method which is used to check a new value. -lambda-list := ( )." - `(progn ;'COMPILE - (def$method (,flavor-name ,method-name) - ,lambda-list - (if (or (is-undetermined ,(first lambda-list)) - ;; Dies wird automatisch ergaenzt - (is-unknown ,(first lambda-list)) - ;; Dies wird automatisch ergaenzt - ,form) - (list ,(first lambda-list)))) - '(,flavor-name ,method-name))) - -;; Das ist fuer den Benutzer: - -(defmacro define-possible-values-behavior - ((frame-name method-name) lambda-list form) - `(define-possible-values-method - (,(get-frame-name-or-signal-error `(,frame-name ,method-name)) ,method-name) - ,lambda-list - ,form)) - - -;;------------------------------------------------------------------------------- -;; STANDARD POSSIBLE VALUES METHODS -;;------------------------------------------------------------------------------- - - - -(define-possible-values-method (poss-val-mixin :interval) (x interval) - (and (numberp x) - (is-in-interval x interval))) - -(define-possible-values-method (poss-val-mixin :boolean) (x) - (or (member x '(y yes)) - (member x '(n no)) - (null x) - (eq x t))) - -(define-possible-values-method (poss-val-mixin :number) (x) - (numberp x)) - -(define-possible-values-method (poss-val-mixin :string) (x) - (stringp x)) - -(define-possible-values-method (poss-val-mixin :list) (x) - ;; in cl (listp nil) => t - (listp x)) - -(define-possible-values-method (poss-val-mixin :symbol) (x) - (symbolp x)) - -(define-possible-values-method (poss-val-mixin :one-of) (x list) - (member x list :test 'equal)) - -(define-possible-values-method (poss-val-mixin :some-of) (x list) - (cond ((is-multiple-value x) - (every #'(lambda (an-item) - (member an-item list :test 'equal)) - (rest x))) - (t (member x list :test 'equal)))) - -(define-possible-values-method (poss-val-mixin :any) (x) - (or x t)) - -(define-possible-values-method (poss-val-mixin :instance-of) (instance-name list) - ;; das erste element von list ist ein frame-name, - ;; der rest koennten angaben ueber slots-belegungen sein - ;; (das kann spaeter implementiert werden). - (and (is-instance instance-name) - (let ((frame-name (get-frame-name-with-check (first list)))) - (if frame-name - (flavor-typep (get-instance instance-name) frame-name))))) - - - -(DEFINE-POSSIBLE-VALUES-METHOD (poss-val-mixin :and) - (x list-of-possible-values-specifications) - (if (every #'(lambda (a-possible-values-specification) - (let ((poss-val-method - (get-poss-val-type a-possible-values-specification)) - (poss-val-args - (get-poss-val-args a-possible-values-specification))) - (if (null poss-val-args) - ($send self poss-val-method x) - ($send self poss-val-method x poss-val-args)))) - list-of-possible-values-specifications) - (list x))) - -(DEFINE-POSSIBLE-VALUES-METHOD (poss-val-mixin :or) - (x list-of-possible-values-specifications) - (if (some #'(lambda (a-possible-values-specification) - (let ((poss-val-method - (get-poss-val-type a-possible-values-specification)) - (poss-val-args - (get-poss-val-args a-possible-values-specification))) - (if (null poss-val-args) - ($send self poss-val-method x) - ($send self poss-val-method x poss-val-args)))) - list-of-possible-values-specifications) - (list x))) - -(DEFINE-POSSIBLE-VALUES-METHOD (poss-val-mixin :not) - (x list-with-possible-values-specification) - (let ((poss-val-method - (get-poss-val-type (first list-with-possible-values-specification))) - (poss-val-args - (get-poss-val-args (first list-with-possible-values-specification)))) - (unless (if (null poss-val-args) - ($send self poss-val-method x) - ($send self poss-val-method x poss-val-args)) - (list x)))) - - -;;------------------------------------------------------------------------------- -;; CHECKING THE FORMAT OF POSSIBLE VALUES -;;------------------------------------------------------------------------------- - - -(defun get-check-result (check-result) - (first check-result)) - - -(defun is-method-of (self possible-values-type) - (and (symbolp possible-values-type) - (keywordp possible-values-type) - ($send self :operation-handled-p possible-values-type))) - - -(defun get-poss-val-type (possible-values) - (if (atom possible-values) - possible-values - (first possible-values))) - -(defun get-poss-val-args (possible-values) - (if (atom possible-values) - nil - (rest possible-values))) - - -(def$method (poss-val-mixin :check-value) (slot value &optional possible-values) - "checks whether value is a possible value for slot." - (let* ((poss-vals (or possible-values - ($send self :get slot :possible-values))) - (poss-val-method (get-poss-val-type poss-vals)) - (poss-val-args (get-poss-val-args poss-vals))) - (cond ((or (null poss-val-method) - (eq poss-val-method :any)) `(,value)) - ;; the result must be a list whose CAR is A-VALUE - ;; to remain consistent with the results of possible-values-methods - ((null poss-val-args) - ($send self poss-val-method value)) - (t ($send self poss-val-method value poss-val-args))))) - -(def$method (poss-val-mixin :check-correct-value) (slot value) - "checks whether value is a possible value for slot allowing to correct the value." - (let* ((possible-values - ($send self :get slot :possible-values)) - (check-result - ($send self :check-value slot value (or possible-values :any)))) - (cond ((not (null check-result)) check-result) - (t (send-kb :babylon-format "~%~?" - (getentry constraints-violation-fstr frame-io-table) - (list value - (get-poss-val-type possible-values) - (get-poss-val-args possible-values) - slot - object-name - (flavor-type-of self))) - (send-kb :babylon-format - (getentry other-value-question-str frame-io-table)) - (let ((answer (send-kb :babylon-read '(#\y #\n)))) - (send-kb :babylon-format "~C~%" answer) - (cond ((char-equal answer #\y) ; char-equal statt eql - ; (cond ((eql answer #\y) - (send-kb :babylon-format - (getentry new-value-question-fstr frame-io-table) - object-name - slot) - ($send self :check-correct-value - slot (send-kb :babylon-read))) - (t '$ABORT$))))))) - - -(def$method (poss-val-mixin :put) - (slot-name new-value &optional (prop-name :value)) - "sets the value of a slot checking whether the value is a possible value for the slot." - (if (is-value prop-name) ;; do constraints check - (let ((check-result - ($send self :check-correct-value slot-name new-value))) - (if (not (eq '$ABORT$ check-result)) - ($send self :set slot-name (get-check-result check-result) prop-name))) - ($send self :set slot-name new-value prop-name))) - -;;------------------------------------------------------------------------------- -;; INITIALIZATION WITH POSSIBLE VALUES METHODS -;;------------------------------------------------------------------------------- - - -(def$method (poss-val-mixin :check-init-value) (slot value) - "checks whether the default value is a possible value for slot." - (let ((possible-values ($send self :get slot :possible-values))) - (cond ((null possible-values)) - ((not (is-method-of self (get-poss-val-type possible-values))) - (baberror (getentry unknown-poss-val-method-fstr frame-io-table) - possible-values - slot - object-name - (flavor-type-of self))) - (($send self :check-value slot value possible-values)) - (t (baberror (getentry constraints-violation-fstr frame-io-table) - value - (get-poss-val-type possible-values) - (get-poss-val-args possible-values) - slot - object-name - (flavor-type-of self)))))) - - -(def$method (poss-val-mixin :init-slot) (slot-name slot-spezification check) - "initializes a slot with values from slot-spezification." - ;;reverse bewirkt, dass :possible-values vor :value initialisiert wird - ;;allerdings sollten :possible-values per frame definition eingefuehrt werden - (do ((plist (reverse (normalize-plist slot-spezification)) - (rest (rest plist)))) - ((null plist)) - (if (and check (eq (second plist) :value)) - ($send self :check-init-value slot-name (first plist))) - ($send self :set slot-name (first plist) (second plist)))) - - -(defun explain-answers-choices (answer-explanations) - (cond ((null answer-explanations) nil) - ((is-simple-list answer-explanations) nil) - (t (mapcar #'first answer-explanations)))) - -(def$method (poss-val-mixin :check-format-of-explain-answers) (slot) - "checks whether all values for which explanations are provided by the -:explain-answers property are possible values." - (let* ((answer-explanations ($send self :get slot :explain-answers)) - (choices (explain-answers-choices answer-explanations))) - (cond ((null answer-explanations) t) - ((null choices) t) - (t (mapc #'(lambda (choice) - (if (not ($send self :check-value slot choice)) - (baberror (getentry explain-answers-spec-error-fstr - frame-io-table) - (assoc choice answer-explanations :test 'equal) - slot - object-name - (flavor-type-of self) - choice))) - choices))))) - - -(def$method (poss-val-mixin :check-your-self) () - "checks whether some values of the frame definition are possible values: -1. default values 2. all values for which explanations are provided by the -:explain-answers property." - (mapc #'(lambda (a-slot-name) - (let ((default-value ($send self :get-value-only a-slot-name))) - ($send self :check-init-value a-slot-name default-value))) - slots) - (mapc #'(lambda (a-slot-name) - ($send self :check-format-of-explain-answers a-slot-name)) - slots)) - - -;;------------------------------------------------------------------------------- -;; ASKING VOR VALUES -;;------------------------------------------------------------------------------- - - -(def$method (poss-val-mixin :provide-local-help) - (slot &optional window) - "displays an explanation from the :explain-answers property. -returns help if no explanation is available." - (declare (ignore window)) - (let* ((answer-explanations ($send self :get slot :explain-answers)) - (choices (explain-answers-choices answer-explanations))) - (if answer-explanations - (send-kb :babylon-format - (getentry explain-answers-fstr frame-io-table) - choices choices) - (send-kb :babylon-format - (getentry no-explain-answers-fstr frame-io-table))) - (send-kb :babylon-format - (getentry explain-context-fstr frame-io-table) *help-key* *end-key*) - (do ((choice (send-kb :babylon-read (list *end-key* *help-key* '#\space)) - (send-kb :babylon-read (list *end-key* *help-key* '#\space)))) - ((eql choice *end-key*) (send-kb :babylon-format "~:C ~%" *end-key*) nil) - (cond ((eql choice *help-key*) - (send-kb :babylon-format "~:C ~%" *help-key*) (return 'help)) - ((and answer-explanations - (eql choice '#\space)) - (apply #'send-kb :babylon-format - (substitute-o-and-s object-name slot answer-explanations))) - ((member choice choices) - (let ((explanation - (rest (assoc choice answer-explanations :test 'equal)))) - (apply #'send-kb :babylon-format - (substitute-o-and-s object-name slot explanation))))) - (send-kb :babylon-format (getentry next-value-fstr frame-io-table) *end-key*)))) - - - -(def$method (poss-val-mixin :ask-for-slot-value) - (slot &optional desired-value negation-flag (standard-option nil)) - "asks the user for the value of a slot providing explanations if asked for. -invokes a special method on demand to support the user entering a value." - ($send self :prompt-for-value slot) - (let ((result (send-kb :babylon-read (list *help-key* *c-help-key*)))) - (cond ((eql result *c-help-key*) - ($send self :ask-guided - slot desired-value negation-flag standard-option)) - ((or (eql result 'help) - (eql result *help-key*)) - (or ($send self :provide-local-help slot) - ($send self :ask-for-slot-value - slot desired-value negation-flag standard-option))) - (t (let ((check-result ($send self :check-value slot result))) - (if check-result - ($send self :set slot (get-check-result check-result)) - ($send self :ask-guided - slot desired-value negation-flag standard-option))))))) - - -(def$method (poss-val-mixin :ask-guided) - (slot desired-value negation-flag standard-option) - "asks the user for the value of a slot. -invokes a special method attached to the :supp-method property -of the possible value type of the slot (or a default method) -to support the user entering a value." - (let* ((read-method ($send self :get-read-method slot)) - ;; read-method is assumed to return a correct value - (result ($send self read-method - slot desired-value negation-flag standard-option))) - (cond ((eq result 'help) 'help) - (t ($send self :set slot result))))) - - -(def$method (poss-val-mixin :get-read-method) (slot) - "fetches the special method to support the user entering a value for slot." - (let* ((possible-values ($send self :get slot :possible-values)) - (poss-val-method (get-poss-val-type possible-values))) - (or (get poss-val-method :supp-method) - (get :any :supp-method)))) - -;;------------------------------------------------------------------------------- - -(setf (get :any :supp-method ) :default-read-method) - -(def$method (poss-val-mixin :default-read-method) - (slot desired-value negation-flag standard-option) - "default method to support the user entering a value for slot." - (let ((possible-values ($send self :get slot :possible-values))) - (send-kb :babylon-format - (format-expectations desired-value - negation-flag - (get-poss-val-type possible-values) - (get-poss-val-args possible-values))) - ($send self :prompt-for-value slot) - (let ((result (send-kb :babylon-read (list *help-key* *c-help-key*)))) - (cond ((eql result *c-help-key*) - ($send self :default-read-method - slot desired-value negation-flag standard-option)) - ((or (eq result 'help) - (eql result *help-key*)) - (or ($send self :provide-local-help slot) - ($send self :default-read-method - slot desired-value negation-flag standard-option))) - (t (let ((check-result ($send self :check-value slot result))) - (if check-result - (get-check-result check-result) - ($send self :default-read-method - slot - desired-value - negation-flag - standard-option)))))))) - - -;;; eof - diff --git a/t/baby2015/kernel/frames/normal/act-vals.cl b/t/baby2015/kernel/frames/normal/act-vals.cl deleted file mode 100644 index 097497c..0000000 --- a/t/baby2015/kernel/frames/normal/act-vals.cl +++ /dev/null @@ -1,298 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: BABYLON; Base: 10 -*- - -(in-package "BABYLON") - -;; Copyright 1986, 1985 and 1984 BY -;; G M D -;; Postfach 1240 -;; D-5205 St. Augustin -;; FRG - - -;; AUTHOR: H.W. Guesgen - - -;;; -;;; ACTIVE VALUES (combined with ACCESS TO ATTACHED CONSTRAINTS) - -;;; Beyond the facilities in file attachment-access, -;;; -;;; - this file contains modified access methods for slots -;;; with active values -;;; -;;; - to use this new methods include the frame active-value-frame -;;; into the supers-list of your frames - - -;;; Since there is no adequate method combination facility provided -;;; by the flavor system, the following code is a little bit tricky. -;;; (Should be revisited when a new BABYLON frame formalism is implemented) - -;;------------------------------------------------------------------------------- -;; LISP stuff -;;------------------------------------------------------------------------------- - -(defun is-active-value (value) - (and (listp value) - (eql (first value) 'active-value))) - - -(defun send-to-instance-or-self - (self instance-name method-name &rest args) - (if (eq instance-name 'SELF) - (lexpr-$send self method-name args) - (lexpr-$send (get-instance instance-name) method-name args))) - -;;------------------------------------------------------------------------------- -;; FRAME -;;------------------------------------------------------------------------------- - -(def$flavor active-value-mixin - () - (poss-val-mixin) - (:required-instance-variables object-name) - (:documentation "flavor to be used as basic flavor of each frame -instead of basic-frame, if possible values are to be supported.")) - - -;;------------------------------------------------------------------------------- -;; :GET stuff -;;------------------------------------------------------------------------------- - -(def$method (active-value-mixin :get) - (slot-name &optional (prop-name :value)) - ":get method that regards active values and constraint attachments." - - (if (and (is-value prop-name) - (eq (flavor-type-of ($send self :get-value-only slot-name)) - 'restricted-slot)) - ($send self :active-value-get - ($send ($send self :get-value-only slot-name) :get) - slot-name :value) ; constraint attachment - ($send self :active-value-get - (get-value-only (get-slot-plist slot-name) prop-name) - slot-name prop-name))) - - -(def$method (active-value-mixin :active-value-get) - (value slot-name prop-name) - "evaluates an active-value construct recursively." - - (if (is-active-value value) - ($send self ($send self :get-behavior value) - ($send self :active-value-get ($send self :local-value value) - slot-name prop-name) - value prop-name slot-name) - value)) - - -(def$method (active-value-mixin :get-behavior) - (active-value) - "selects the :get behavior." - - (if (null (third active-value)) - :default-get-behavior - (third active-value))) - - -(def$method (active-value-mixin :default-get-behavior) - (old-local-value active-value prop-name slot-name) - (declare (ignore active-value prop-name slot-name)) - old-local-value) - - -(def$method (active-value-mixin :local-value) - (active-value) - "selects the local value." - - (second active-value)) - -;;------------------------------------------------------------------------------- -;; :SET AND :PUT STUFF -;;------------------------------------------------------------------------------- - -(def$method (active-value-mixin :set) - (slot-name new-value &optional (prop-name :value) (test nil)) - "sets the value of a slot without checking - whether the value is a possible value for the slot. - active values are regarded - furthermore it is checked whether all attached constraints are satisfied - if the option test is equal to :test" - - (cond ((is-value prop-name) - (cond ((eq (flavor-type-of ($send self :get-value-only slot-name)) - 'restricted-slot) - ($send ($send self :get-value-only slot-name) :put - self slot-name - ($send self :active-value-set ; handles active value - new-value - ($send self :get-value-only slot-name) - slot-name prop-name) - test)) - (t ($send self :set-value-only slot-name - ($send self :active-value-set ; handles active value - new-value - ($send self :get-value-only slot-name) - slot-name prop-name) - prop-name)))) - (t ($send self :set-value-only slot-name - ($send self :active-value-set new-value ; handles active value - ($send self :get-value-only slot-name prop-name) - slot-name prop-name) - prop-name)))) - - -(def$method (active-value-mixin :put-if-satisfied) - (slot-name new-value &optional (prop-name :value)) - "sets the value of a slot, if the attached constraints are satisfied." - ($send self :put slot-name new-value prop-name :test)) - - - -(def$method (active-value-mixin :put) - (slot-name new-value &optional (prop-name :value) (test nil)) - "sets thevalue of a slot checking - whether the value is a possible value for the slot. - active values are regarded - furthermore it is checked whether all attached constraints are satisfied - if the option test is equal to :test." - (if (is-value prop-name) ;; do constraints check - (let ((check-result - ($send self :check-correct-value slot-name new-value))) - (if (not (eq '$ABORT$ check-result)) - ($send self :set - slot-name (get-check-result check-result) prop-name test))) - ($send self :set slot-name new-value prop-name))) - - -(def$method (active-value-mixin :active-value-set) - (new-value old-value slot-name prop-name) - "evaluates an active-value construct recursively." - - (if (is-active-value old-value) - `(active-value - ,($send self :active-value-set - ($send self ($send self :put-behavior old-value) - new-value old-value prop-name slot-name) - ($send self :local-value old-value) - slot-name prop-name) - ,($send self :get-behavior old-value) - ,($send self :put-behavior old-value)) - new-value)) - - -(def$method (active-value-mixin :put-behavior) - (active-value) - "selects the :put behavior." - - (if (null (fourth active-value)) - :default-put-behavior - (fourth active-value))) - - -(def$method (active-value-mixin :default-put-behavior) - (new-local-value active-value prop-name slot-name) - (declare (ignore active-value prop-name slot-name)) - new-local-value) - -;;------------------------------------------------------------------------------- -;; SOME STANDARD GET BEHAVIORS -;;------------------------------------------------------------------------------- - -(def$method (active-value-mixin :first-fetch) - (old-local-value active-value prop-name slot-name) - (declare (ignore active-value)) - ($send self :replace slot-name (eval old-local-value) prop-name)) - - -(def$method (active-value-mixin :get-indirect) - (old-local-value active-value prop-name slot-name) - (declare (ignore active-value prop-name slot-name)) - (let ((instance-name (first old-local-value)) - (slot-name (second old-local-value)) - (prop-name (or (third old-local-value) :value))) - (send-to-instance-or-self self instance-name :get slot-name prop-name))) - - -;;------------------------------------------------------------------------------- -;; SOME STANDARD PUT BEHAVIORS -;;------------------------------------------------------------------------------- - -(def$method (active-value-mixin :put-indirect) - (new-local-value active-value prop-name slot-name) - (declare (ignore prop-name slot-name)) - (let ((old-local-value ($send self :local-value active-value))) - (let ((instance-name (first old-local-value)) - (slot-name (second old-local-value)) - (prop-name (or (third old-local-value) :value))) - (send-to-instance-or-self self instance-name - :set slot-name new-local-value prop-name) - old-local-value))) - - -; does not work with the actual version of active values -; -;(def$method (active-value-mixin :replace-me) -; (new-local-value active-value prop-name slot-name) -; (declare (ignore active-value)) -; ($send self :replace slot-name new-local-value prop-name)) - - -(def$method (active-value-mixin :no-update-permitted) - (new-local-value active-value prop-name slot-name) - (declare (ignore active-value)) - (baberror (getentry no-update-permit-error-fstr frame-io-table) - slot-name - prop-name - object-name - new-local-value)) - -;;------------------------------------------------------------------------------- -;; CHECK STUFF -;;------------------------------------------------------------------------------- - - -(def$method (active-value-mixin :check-init-value) (slot value) - "internal method. checks whether value is a possible value for slot. -produces an error if the check fails." - (let ((possible-values ($send self :get slot :possible-values))) - (cond ((null possible-values)) - ((not (is-method-of self (get-poss-val-type possible-values))) - (baberror (getentry unknown-poss-val-method-fstr frame-io-table) - possible-values - slot - object-name - (flavor-type-of self))) - ((is-active-value value)) - (($send self :check-value slot value possible-values)) - (t (baberror (getentry constraints-violation-fstr frame-io-table) - value - (get-poss-val-type possible-values) - (get-poss-val-args possible-values) - slot - object-name - (flavor-type-of self)))))) - - -(defun normalize-plist-with-act-vals (plist) - (cond ((null plist) plist) - ((atom plist) `(:value ,plist)) - ((is-multiple-value plist) `(:value ,plist)) - ((is-active-value plist) `(:value ,plist)) - ((is-value (first plist)) plist) - (t `(:value . ,plist)))) - - -(def$method (active-value-mixin :init-slot) (slot-name slot-spezification check) - "initializes a slot with values from slot-spezification." - ;;reverse bewirkt, dass :possible-values vor :value initialisiert wird - ;;allerdings sollten :possible-values per frame definition eingefuehrt werden - - (do ((plist (reverse (normalize-plist-with-act-vals slot-spezification)) - (rest (rest plist)))) - ((null plist)) - (cond ((is-active-value (first plist)) - ($send self :replace slot-name (first plist) (second plist))) - (t (if (and check (eq (second plist) :value)) - ($send self :check-init-value slot-name (first plist))) - ($send self :set slot-name (first plist) (second plist)))))) diff --git a/t/baby2015/kernel/frames/normal/nf-mixin.cl b/t/baby2015/kernel/frames/normal/nf-mixin.cl deleted file mode 100644 index c2f1dd2..0000000 --- a/t/baby2015/kernel/frames/normal/nf-mixin.cl +++ /dev/null @@ -1,32 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; BASE: 10. ;Package: BABYLON -*- - -(in-package "BABYLON") - - -;; Copyright 1986, 1985 and 1984 BY -;; G M D -;; Postfach 1240 -;; D-5205 St. Augustin -;; FRG - - -;; AUTHORS: Franco di Primio, Eckehard Gross, Juergen Walther - - - -;;;;;;;;; MIXIN FOR POSSIBLE and active VALUES ;;;;;;;;;;;;;;;;;;;;;;;; - - -(def$flavor normal-frame-mixin - () - (mini-frame-mixin) - (:documentation "specialization of the frame processor mixin for the knowledge base. -generates a different type of frame processor.")) - -(def$method (normal-frame-mixin :generate-frame-processor) () - "generates a frame processor for a knowledge base." - (setf frame-processor (make-$instance 'normal-frame-processor - :meta-processor self))) - -(assign-typefkt 'frame-type 'normal-frame-mixin) - diff --git a/t/baby2015/kernel/frames/normal/nf-proc.cl b/t/baby2015/kernel/frames/normal/nf-proc.cl deleted file mode 100644 index 26b4fba..0000000 --- a/t/baby2015/kernel/frames/normal/nf-proc.cl +++ /dev/null @@ -1,42 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: BABYLON; Base: 10 -*- - -(in-package "BABYLON") - -;; Copyright 1986, 1985 and 1984 BY -;; G M D -;; Postfach 1240 -;; D-5205 St. Augustin -;; FRG - - -;; AUTHOR: H.W. G U E S G E N - - -;;-------------------------------------------------------------------------------- - - - -(def$flavor active-value-frame-core - () - (active-value-mixin frame-core) - (:documentation "flavor to be used as basic flavor of each frame -instead of basic-frame, if possible values are to be supported.")) - - - -(def$flavor normal-frame-processor - () - (mini-frame-processor) - (:documentation "specialization of basic frame processor generating frames -with possible value feature.")) - - -(def$method (normal-frame-processor :after :init) (&rest plist) - (declare (ignore plist)) - (setf frame-type 'active-value-frame-core)) - - -#-:FMCS(compile-$flavor-$methods normal-frame-processor) - -;;; eof - diff --git a/t/baby2015/kernel/freetext/ft-mixin.cl b/t/baby2015/kernel/freetext/ft-mixin.cl deleted file mode 100644 index 6dfb838..0000000 --- a/t/baby2015/kernel/freetext/ft-mixin.cl +++ /dev/null @@ -1,160 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: BABYLON; Base: 10. -*- - -(in-package "BABYLON") - -;; Copyright 1986, 1985 and 1984 BY -;; G M D -;; Postfach 1240 -;; D-5205 St. Augustin -;; FRG - - -;; AUTHORS: Eckehard Gross, Juergen Walther - - - -(def$flavor free-text-mixin - (free-text-processor) - () - :settable-instance-variables - (:required-instance-variables - kb-name procs active-proc system-trace system-trace-window)) - -(def$method (free-text-mixin :after :init) (&rest plist) - (declare (ignore plist)) - ($send self :generate-free-text-processor) - (setf procs (cons free-text-processor procs))) - -(def$method (free-text-mixin :generate-free-text-processor) () - (setf free-text-processor (make-$instance 'basic-free-text-processor - :meta-processor self))) - -(defrequest free-text - :prolog :eval-free-text-for-prolog - :recall :eval-free-text - :recall-immediate :eval-free-text - :remember :eval-free-text - :store :eval-free-text - :ask :ask-user) - -(defmacro free-text-type (request) - (declare (ignore request)) - ''free-text) - -(assign-typefkt 'free-text-type 'free-text-mixin) - - -(def$method (free-text-mixin :ask-user) - (fact mode &optional (negation-flag nil)) - (when system-trace - ($send self :send-system-trace-window :format - (getentry meta-free-text-trace-fstr free-text-io-table) - mode fact)) - (setf active-proc free-text-processor) - (prog (answer) - A (setq answer - ($send free-text-processor :ask-user fact negation-flag)) - (case answer - (help (if (eq ($send self :help) 'why) - (return 'why) - (go A))) - (t (return answer))))) - - -(def$method (free-text-mixin :eval-free-text) (fact mode) - (when system-trace - ($send self :send-system-trace-window :format - (getentry meta-free-text-trace-fstr free-text-io-table) - mode fact)) - (setf active-proc free-text-processor) - (case mode - ((:RECALL :RECALL-IMMEDIATE) - ($send free-text-processor :recall fact)) - (:REMEMBER ($send free-text-processor :remember fact)) - (:STORE ($send free-text-processor :store fact)))) - - - -(def$method (free-text-mixin :ask-user-for-prolog) (fact mode) - (declare (ignore mode)) - (prog (answer) - A (setq answer - ($send free-text-processor :ask-user fact)) - (case answer - (help (if (eq ($send self :help) 'why) - ($send self :prolog-why)) - (go A)) - (TRUE (return t)) - ((UNKNOWN FALSE) (return nil)) - ;; (prompt (return ($send self :read-clauses))) - (t ;; signal error!! (define entry in deutsch and english) - (return answer))))) - -(defun translate-free-texts-into-prolog-facts (facts) - (mapcar #'list facts)) - -(defun is-free-text-meta-predicate (x) - (member x *free-text-meta-predicates*)) - - - -(def$method (free-text-mixin :eval-free-text-for-prolog) - (request mode) - (when system-trace - ($send self :send-system-trace-window :format - (getentry meta-free-text-trace-fstr free-text-io-table) - mode request)) - (setf active-proc free-text-processor) - (cond ((and (consp request) - (is-free-text-meta-predicate (first request))) - ($send self :eval-free-text-meta-predicate request mode)) - ((and (consp request) - (CONTAINS-VARS request)) - ;; if the request contains variables, then return all true requests - ;; which can be unified with request. - (let* ((predicate (first request)) - (true-facts -; ;; this is unfortunately not possible from the prolog perspective! -; (if (IS-VARIABLE predicate) -; ($send free-text-processor :true-facts) -; ($send free-text-processor :get-true-facts-for predicate)) - ($send free-text-processor :get-true-facts-for predicate))) - (cond ((null true-facts) nil) - (t (translate-free-texts-into-prolog-facts true-facts))))) - (t ;; else establish the state of request: - ;; if the state is determined, return it - ;; else ask the user. - (let ((answer ($send free-text-processor :recall request))) - (if (IS-UNDETERMINED answer) - (setq answer ($send self :ask-user-for-prolog request mode))) - answer)))) - -(def$method (free-text-mixin :eval-free-text-meta-predicate) - (request mode) - (declare (ignore mode)) - (case (first request) - (FREE-TEXT (let* ((true-facts ($send free-text-processor :true-facts)) - (false-facts ($send free-text-processor :false-facts)) - (fact (second request)) - (all-facts (append true-facts false-facts)) - (result nil)) - (cond ((CONTAINS-VARS fact) - (cond ((and (consp fact) ;;index on first element - (not (IS-VARIABLE (first fact)))) - (dolist (a-fact all-facts (nreverse result)) - (when (and (consp a-fact) - (equal (first a-fact) (first fact))) - (setf result - (cons `((,(first request) ,a-fact)) result))))) - (t (dolist (a-fact all-facts (nreverse result)) - (when (consp a-fact) - (setf result - (cons `((,(first request) ,a-fact)) result))))))) - ((member fact all-facts :test #'equal) t) - (t nil)))) - (t ;; signal error! - nil))) - - -;;; eof - diff --git a/t/baby2015/kernel/freetext/ft-proc.cl b/t/baby2015/kernel/freetext/ft-proc.cl deleted file mode 100644 index b1ee218..0000000 --- a/t/baby2015/kernel/freetext/ft-proc.cl +++ /dev/null @@ -1,128 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: BABYLON; Base: 10 -*- - -(in-package "BABYLON") - -;; Copyright 1986, 1985 and 1984 BY -;; G M D -;; Postfach 1240 -;; D-5205 St. Augustin -;; FRG - - -;; AUTHORS: Eckehard Gross, Juergen Walther - - - -(def$flavor basic-free-text-processor - (meta-processor - (true-facts nil) - (false-facts nil)) - () - (:initable-instance-variables meta-processor) - :settable-instance-variables) - -(def$method (basic-free-text-processor :reset-proc) () - "Reset free text data base to initial state." - (setf true-facts nil) - (setf false-facts nil)) - - -(def$method (basic-free-text-processor :add) (fact mode) - "Store fact as true or false" - (case mode - (true (setf true-facts (cons fact true-facts))) - (false (setf false-facts (cons fact false-facts))))) - -(def$method (basic-free-text-processor :recall) (fact) - "Recall the status of a (negated) fact." - (let ((success t) (failure nil)) - (cond ((IS-NEGATED-TERM fact) - (setq fact (GET-POSITIVE-TERM fact)) - (setq success nil) - (setq failure t))) - (cond ((member fact true-facts :test 'equal) success) - ((member fact false-facts :test 'equal) failure) - (t (UNDETERMINED))))) - -(def$method (basic-free-text-processor :remember) (fact) - "Remember the status of a fact. -Returns nil if already known, fact otherwise." - (cond ((member fact true-facts :test 'equal) nil) - (t (setf true-facts (cons fact true-facts)) - fact))) - -(def$method (basic-free-text-processor :store) (fact) - "Store the status of a fact. -Returns the fact in any case." - (if (not (member fact true-facts :test 'equal)) - (setf true-facts (cons fact true-facts))) - fact) - - -(defun format-translate-true-or-false (fact) - (format nil - (getentry is-it-true-question-fstr free-text-io-table) - (if (consp fact) fact `(,fact)))) - - - -(def$method (basic-free-text-processor :ask-user) (fact &optional (negation-flag nil)) - (let ((item-list - `(,(if negation-flag - (getentry expected-answer-no-str free-text-io-table) - (getentry expected-answer-yes-str free-text-io-table)) - ("" :no-select t) - ,@(getentry ask-item-list free-text-io-table))) - (label (getentry choose-one-of-str free-text-io-table))) - ($send meta-processor :babylon-format "~%~A" ;;; <- - (format-translate-true-or-false fact)) - (do ((answer (normalize-answer - ($send meta-processor :babylon-read (list *help-key*))) - ($send meta-processor :choose-from-menu item-list label)) - (echo nil t)) - ((member answer '(yes no unknown help *help-key*)) - (if echo - ($send meta-processor :babylon-format - "~(~S~)" (translate-answer answer))) - (cond - ((eq answer 'yes) ($send self :add fact 'true) 'true) - ((eq answer 'no) ($send self :add fact 'false) 'false) - ((eq answer 'unknown) ($send self :add fact 'false) 'unknown) - ((eq answer 'help) 'help) - ((eql answer *help-key*) - ($send meta-processor :babylon-format "?") 'help)))))) - - - -(def$method (basic-free-text-processor :ask-user-without-adding) (fact) - (let ((item-list `(,(getentry prompt-item free-text-io-table) - ,@(getentry ask-item-list free-text-io-table))) - (label (getentry choose-one-of-str free-text-io-table))) - ($send meta-processor :babylon-format "~%~A" - (format-translate-true-or-false fact)) - (do ((answer (normalize-answer - ($send meta-processor :babylon-read (list *help-key*))) - ($send meta-processor :choose-from-menu item-list label)) - (echo nil t)) - ((member answer '(yes no unknown help *help-key*)) - (if echo - ($send meta-processor :babylon-format - "~(~S~)" (translate-answer answer))) - (cond - ((eq answer 'yes) t) - ((eq answer 'no) nil) - ((eq answer 'unknown) nil) - ((eq answer 'prompt) 'prompt) - ((eq answer 'help) 'help) - ((eql answer *help-key*) - ($send meta-processor :babylon-format "?") 'help)))))) - -(def$method (basic-free-text-processor :get-true-facts-for) - (predicate &optional (test #'(lambda (atom list) - (and (consp list) - (eq atom (first list)))))) - "Yields a list of all non atomic true facts whose first element equals predicate." - (let ((facts nil)) - (dolist (a-true-fact true-facts (nreverse facts)) - (if (funcall test predicate a-true-fact) - (setf facts (cons a-true-fact facts)))))) \ No newline at end of file diff --git a/t/baby2015/kernel/freetext/ft-tab-e.cl b/t/baby2015/kernel/freetext/ft-tab-e.cl deleted file mode 100644 index e4bd026..0000000 --- a/t/baby2015/kernel/freetext/ft-tab-e.cl +++ /dev/null @@ -1,60 +0,0 @@ -;;; -*- Mode: Lisp; Base:10; Syntax: Common-Lisp; Package: BABYLON -*- - -(in-package "BABYLON") - -;; Copyright 1986, 1985 and 1984 BY -;; G M D -;; Postfach 1240 -;; D-5205 St. Augustin -;; FRG - - -;; AUTHOR: J. W A L T H E R - - - -;;This is the English version of all the strings and menu-item-lists of -;;the free-text processor. - - - -(defbabylon-table free-text-io-table english) - - -;;; **************** syntax **************** - - -(defbabylon-entry is-it-true-question-fstr free-text-io-table english - "~5TIs this true: ~{~S ~}") - -(defbabylon-entry choose-one-of-str free-text-io-table english - " Choose one of :") - -(defbabylon-entry yes-str free-text-io-table english - "Yes") - -(defbabylon-entry no-str free-text-io-table english - "No ") - -(defbabylon-entry expected-answer-yes-str free-text-io-table english - '("Expected answer: Yes" :no-select t)) - -(defbabylon-entry expected-answer-no-str free-text-io-table english - '("Expected answer: No " :no-select t)) - -(defbabylon-entry prompt-item free-text-io-table english - `(" Prompt " :value prompt)) - -(defbabylon-entry ask-item-list free-text-io-table english - `((" Yes " :value yes) - (" No " :value no) - ("" :no-select t) - (" -- Help -- " :value help))) - -(defbabylon-entry incorrect-answer-str free-text-io-table english -"~&~10TIncorrect answer: ~S~@ - ~10T====>> Look at the mouse, please ! ") - -(defbabylon-entry meta-free-text-trace-fstr free-text-io-table english - " META -> FREE-TEXT ~S ~S") - diff --git a/t/baby2015/kernel/freetext/ft-tab-g.cl b/t/baby2015/kernel/freetext/ft-tab-g.cl deleted file mode 100644 index 2fc6af8..0000000 --- a/t/baby2015/kernel/freetext/ft-tab-g.cl +++ /dev/null @@ -1,61 +0,0 @@ -;;; -*- Mode: Lisp; Base:10; Syntax: Common-Lisp; Package: BABYLON -*- - -(in-package "BABYLON") - -;; Copyright 1986, 1985 and 1984 BY -;; G M D -;; Postfach 1240 -;; D-5205 St. Augustin -;; FRG - - -;; AUTHOR: J. W A L T H E R - - -;; -;; This is the German version of all the strings and menu-item-lists of -;; the free-text processor. - - - -(defbabylon-table free-text-io-table german) - - -;;; **************** syntax **************** - - -(defbabylon-entry is-it-true-question-fstr free-text-io-table german - "~5TTrifft es zu: ~{~S ~}") - -(defbabylon-entry choose-one-of-str free-text-io-table german - " Waehle einen Eintrag :") - -(defbabylon-entry yes-str free-text-io-table german - "Ja ") - -(defbabylon-entry no-str free-text-io-table german - "Nein") - -(defbabylon-entry expected-answer-yes-str free-text-io-table german - '("Erwartet wird : Ja " :no-select t)) - -(defbabylon-entry expected-answer-no-str free-text-io-table german - '("Erwartet wird : Nein " :no-select t)) - - -(defbabylon-entry prompt-str free-text-io-table german - "Anfordern ") - -(defbabylon-entry ask-item-list free-text-io-table german - `((" ja " :value yes) - (" nein " :value no) - ("" :no-select t) - (" -- Help -- " :value help))) - -(defbabylon-entry incorrect-answer-str free-text-io-table german -"~&~10TUnzulaessige Antwort: ~S~@ - ~10T====>> Bitte die Maus beachten !") - - -(defbabylon-entry meta-free-text-trace-fstr free-text-io-table german - " META -> FREE-TEXT ~S ~S") diff --git a/t/baby2015/kernel/meta/kb-core.cl b/t/baby2015/kernel/meta/kb-core.cl deleted file mode 100644 index 84984ae..0000000 --- a/t/baby2015/kernel/meta/kb-core.cl +++ /dev/null @@ -1,412 +0,0 @@ -;;; -*- Mode: LISP; Package: BABYLON; Syntax: Common-lisp; Base: 10 -*- - -(in-package "BABYLON") - -;; Copyright 1988, 1987, 1986, 1985 and 1984 BY -;; G M D -;; Postfach 1240 -;; D-5205 St. Augustin -;; FRG - - -;; AUTHORS: Franco di Primio, Eckehard Gross, Juergen Walther - - -;; CONTENTS: the base flavor for knowledge bases - - -;;----------------------------------------------------------------------- -;; BASE FLAVOR FOR KNOWLEDGE BASES -;;----------------------------------------------------------------------- - -(def$flavor kb-processor-core - ((kb-name nil) - (language *default-language*) - (instructions nil) - (procs nil)) - () - :settable-instance-variables - (:documentation "This is the base flavor for knowledge-bases. -It provides all the facilities to handle knowledge base operations, -which are global and not exclusively handled by one of the special -processors.")) - -;;----------------------------------------------------------------------- -;; KNOWLEDGE BASE CONFIGURATION CONSTRUCTOR -;;----------------------------------------------------------------------- - -(defun filter-options (key options) - (remove key options :test #'(lambda (a-key element) - (and (listp element) - (eq a-key (first element)))))) - -(defmacro def-kb-configuration (flavor-name &rest options) - "knowledge base configuration constructor. -Generates a knowledge base flavor and a method to determine the type of an expression -which has to be passed to the appropriate processor. The most important options -are: (:special . special-mixins) (:procs . processor-mixins) (:interface . interface-mixins) -which determine the special,processor and interface mixins to be included in the flavor. -No defaults are used if these options are not specified. -All other options are passed to the defflavor form." - - (let ((special-mixins (rest (assoc :special options))) - (proc-mixins (rest (assoc :procs options))) - (interface-mixins (rest (assoc :interface options))) - (rest-options (filter-options :special - (filter-options :interface - (filter-options :procs options))))) - (dolist (flavor (append proc-mixins interface-mixins special-mixins)) - (or (flavorp flavor) (bab-require flavor))) - - `(progn - - (dolist (flavor (append ',proc-mixins ',interface-mixins ',special-mixins)) - (or (flavorp flavor) (bab-require flavor))) - - (def$flavor ,flavor-name () - (,@special-mixins - ,@interface-mixins - ,@proc-mixins - meta-processor-core - kb-processor-core) - :settable-instance-variables - ,@rest-options) - - (def$method (,flavor-name :get-type) (request) - (or ,@(mapcan #'(lambda (proc-mixin) - (let ((fkt (get proc-mixin :typefkt))) - (if fkt - `((,fkt request))))) - proc-mixins))) - - ',flavor-name))) - -;;----------------------------------------------------------------------- -;; KNOWLEDGE BASE INSTANCE CONSTRUCTOR -;;----------------------------------------------------------------------- - - -(def$method (kb-processor-core :make-yourself-known) () - "internal method. -adds the the name of the kb to the list of known kbs." - (unless (member kb-name *known-knowledge-bases*) - (push kb-name *known-knowledge-bases*))) - -(def$method (kb-processor-core :make-yourself-unknown) () - "internal method. -removes the name of the kb from the list of known kbs." - (setf *known-knowledge-bases* - (remove kb-name *known-knowledge-bases*))) - -(def$method (kb-processor-core :make-yourself-current) () - "makes the kb to the current one and its language to the current language." - (if (and (is-activated-kb) - (not (eq *current-knowledge-base* self))) - ($send *current-knowledge-base* :deselect-kb)) - (setq *current-knowledge-base* self) - (setq *language* language)) - -(def$method (kb-processor-core :store-deklaration) (spec) - "internal method." - (declare (ignore spec)) - t) - -(defun use-old-kb? (kb-name) - (when (boundp kb-name) - (let ((kb (symbol-value kb-name))) - (cond ((not (flavor-typep kb 'kb-processor-core)) nil) - ((y-or-n-p (format nil (getentry kb-exists-fstr babylon-io-table) - kb-name (flavor-type-of kb))) - ($send kb :make-yourself-current) t) - (t ($send kb :kill-kb) nil))))) - - -(defmacro def-kb-instance (kb-name kb-configuration &rest init-plist) - "knowledge base instance constructor. -generates an instance of the flavor kb-configuration and assigns it to kb-name. -the generated kb is automatically made current." - - `(eval-when (compile load eval) - (or (find-package ',kb-name) (make-package ',kb-name :use '())) -; (in-package 'user :use (list (or (find-package ',kb-name) -; (make-package ',kb-name)))) -; (unuse-package ',kb-name :user) - (or (flavorp ',kb-configuration) (bab-require ',kb-configuration)) - (unless (use-old-kb? ',kb-name) - (setq ,kb-name - (make-window-or-instance ',kb-configuration - :kb-name ',kb-name - ,@init-plist)) - ($send ,kb-name :store-deklaration - '(def-kb-instance ,kb-name ,kb-configuration ,@init-plist)) - ($send ,kb-name :make-yourself-known) - ($send ,kb-name :make-yourself-current) - ',kb-name))) - - -;;----------------------------------------------------------------------- -;; KNOWLEDGE BASE CONSTRUCTOR zur kompatibilitaet -;;----------------------------------------------------------------------- - - -(defun get-special-mixins-to-include (plist) - (second (member :special plist))) - -(defun get-proc-mixins-to-include (plist) - (or (second (member :procs plist)) - *default-procs*)) - -(defun get-interface-mixins-to-include (plist) - (or (second (member :interface plist)) - *default-interface*)) - -(defun get-kb-configuration () - *default-kb-configuration*) - - -(defun filter-plist (key plist) - (let ((tail (member key plist))) - (append (ldiff plist tail) (rest (rest tail))))) - -(defmacro knowledge-base (kb-name &rest init-plist) - "knowledge base constructor. -generates eventually a kb configuration named PROCESSOR-FOR- and -makes an instance of this configuration. init-plist is searched for values -of the keys :special, :procs and :interface. these are used to build the -:special, :procs and :interface options of the def-kb-configuration form. -if one of the values is missing defaults are used instead. if no values -for :special, :procs and :interface are specified, a default kb-configuration -is used instead of creating a new one. defaults are taken from *default-procs*, -*default-interface* and *default-kb-configuration* respectively." - - (cond ((or (member :procs init-plist) - (member :interface init-plist) - (member :special init-plist)) - (let ((kb-configuration (intern (format nil "PROCESSOR-FOR-~S" kb-name))) - (special-mixins (get-special-mixins-to-include init-plist)) - (proc-mixins (get-proc-mixins-to-include init-plist)) - (interface-mixins (get-interface-mixins-to-include init-plist)) - (rest-plist (filter-plist :special - (filter-plist :interface - (filter-plist :procs init-plist))))) - `(progn (def-kb-configuration - ,kb-configuration - (:special ,@special-mixins) - (:procs ,@proc-mixins) - (:interface ,@interface-mixins)) - (def-kb-instance ,kb-name ,kb-configuration ,@rest-plist) - ($send ,kb-name :store-deklaration - '(knowledge-base ,kb-name ,@init-plist))))) - (t (let ((kb-configuration (get-kb-configuration))) - `(progn (def-kb-instance ,kb-name ,kb-configuration ,@init-plist) - ($send ,kb-name :store-deklaration - '(knowledge-base ,kb-name ,@init-plist))))))) - - -;;----------------------------------------------------------------------- -;; INSTRUCTIONS CONSTRUCTOR -;;----------------------------------------------------------------------- - -(defmacro instructions (&rest instructions) - "assigns instructions to the instructions slot of the current kb." - `(cond ((current-kb-typep 'kb-processor-core) - (send-kb :set-instructions ',instructions) - `(instructions defined for ,(send-kb :kb-name))))) - - -;;----------------------------------------------------------------------- -;; UTILITY FUNCTIONS -;;----------------------------------------------------------------------- - - - -(defun search-for-kb (kb-name) - (let ((kb (if (boundp kb-name) (symbol-value kb-name)))) - (if (not (flavor-typep kb 'kb-processor-core)) - (baberror (getentry kb-does-not-exist-fstr babylon-io-table) kb-name)) - (if (not (current-p kb)) - (if (y-or-n-p (format nil (getentry use-kb-fstr babylon-io-table) kb-name)) - ($send kb :make-yourself-current) - (baberror (getentry unwanted-kb-fstr babylon-io-table) kb-name))))) - - -(defmacro use-kb-instance (kb-name) - "makes kb with name kb-name current. if the external representation -of a kb is distributed over several files this form may insure that -the right kb is current when any of the files is evaluated." - `(eval-when (compile load eval) - ;(in-package "BABYLON" :use (list (or (find-package ',kb-name) - ; (make-package ',kb-name)))) - (in-package "BABYLON") - (use-package (list (or (find-package ',kb-name) - (make-package ',kb-name))) - "BABYLON") - (search-for-kb ',kb-name))) - -;;----------------------------------------------------------------------- - - -(defun is-activated-kb () - (and (boundp '*current-knowledge-base*) - (flavor-typep *current-knowledge-base* 'kb-processor-core))) - -;;----------------------------------------------------------------------- - - -(def$method (kb-processor-core :initialize) () - "method to be specialized by the user." - t) - - -;;----------------------------------------------------------------------- -;; KNOWLEDGE BASE OPERATIONS -;;----------------------------------------------------------------------- - -(def$method (kb-processor-core :run) () - "method to be overwritten by one of the diverse interface mixins. -it is called by :select-kb which is used normally to activate a kb." - t) - -(def$method (kb-processor-core :deselect-kb) () - "method to be specialized by interface mixins." - t) - -(def$method (kb-processor-core :select-kb) () - "activates a kb making it current." - ($send self :make-yourself-current) - ($send self :run)) - - -(def$method (kb-processor-core :reset-kb) () - "sends all processors a :reset message." - (let ((*current-knowledge-base* self)) - (mapc #'(lambda (proc) - ($send proc :send-if-handles :reset-proc)) - procs) - t)) - -;;----------------------------------------------------------------------- - -(def$method (kb-processor-core :kill-kb) () - "makes the kb unaccessable. -if the kb was current one of the remaining known kbs is made current." - ($send self :make-yourself-unknown) - (setf (symbol-value kb-name) nil) - (if (current-p self) - (let ((next-kb (first *known-knowledge-bases*))) - (if next-kb - ($send (symbol-value next-kb) :make-yourself-current) - (setf *current-knowledge-base* nil)))) - t) - - -;;----------------------------------------------------------------------- - - -(def$method (kb-processor-core :global-trace-status) () - "provides information on trace in form of a menu item list." - (let ((trace-items - (cons ($send self :trace-status) - (delete nil - (mapcar #'(lambda (proc) - ($send proc :send-if-handles :trace-status)) - procs)))) - (prot-item ($send self :send-if-handles :prot-status))) - (if prot-item - (cons prot-item trace-items) - trace-items))) - -;;----------------------------------------------------------------------- - -(def$method (kb-processor-core :kb-inform) (&optional (stream *default-dialog-stream*)) - "prints statistics about the kb to stream." - (format stream (getentry state-of-kb-fstr babylon-io-table) kb-name) - (mapc #'(lambda (proc) - ($send proc :send-if-handles :kb-inform stream)) - procs) - (format stream "~%") - kb-name) - -(def$method (kb-processor-core :describe-kb) () - "prints statistics about the kb to the dialog-stream of the kb." - ($send self :kb-inform ($send self :dialog-stream))) - -;;----------------------------------------------------------------------- -;; STARTING THE KNOWLEDGE BASE -;;----------------------------------------------------------------------- - - -(def$method (kb-processor-core :start) - (&optional (list-of-instructions nil)) - "initializes the kb and calls :start-execution within an environment -where *current-knowledge-base* is bound to the kb and *language* to its language. -:start-execution is evaluated within a catch-form with tag knowledge-base-stop-tag -which is used by the functiom stop-kb-execution." - (let ((*current-knowledge-base* self) - (*language* ($send self :language))) - ;; Dies ist notwendig weil innerhalb der "procs" - ;; auf die globalen Variablen referiert wird. - ($send self :initialize) - (catch 'knowledge-base-stop-tag - ($send self :start-execution list-of-instructions)))) - -(def$method (kb-processor-core :start-kb) - (&optional (list-of-instructions nil)) - "same as :start." - ($send self :start list-of-instructions)) - -(defun stop-kb-execution (&optional (result 'knowledge-base-stopped)) - (throw 'knowledge-base-stop-tag result)) - -;(declare-lisp-fns stop-kb-execution) ;; for use in rules - -(def$method (kb-processor-core :start-execution) - (&optional (list-of-instructions nil)) - "evaluates the instructions provided by the parameter list-of-instructions -or those from the slot instructions within a progn form with self bound to the kb." - (let (($self self)) - (declare (special $self)) - (eval `(progn . ,(subst '$self 'self - (or list-of-instructions instructions)))))) - - -;;----------------------------------------------------------------------- -;; INTERACTIVE OPERATIONS -;;----------------------------------------------------------------------- - - - -(def$method (kb-processor-core :reset-kb-confirmed) () - "asks whether to reset the kb resetting it eventually." - (if ($send self :confirm - (format nil (getentry reset-kb-fstr babylon-io-table) kb-name)) - ($send self :reset-kb))) - - -(def$method (kb-processor-core :start-kb-confirmed) () - "asks whether to start the kb starting it eventually." - (when (lexpr-$send self :confirm - (format nil (getentry start-fstr babylon-io-table) - ($send self :kb-name)) - ($send self :global-trace-status)) - ($send self :babylon-format - (getentry starting-kb-fstr babylon-io-table) kb-name) - ($send self :start) - ($send self :babylon-format "~%"))) - - - -;;----------------------------------------------------------------------- - - -(defun reset-knowledge-base () - "asks whether to reset the current kb resetting it eventually." - (send-kb :reset-kb-confirmed)) - -(defun start-knowledge-base () - "asks whether to start the current kb starting it eventually." - (send-kb :start-kb-confirmed)) - -(defun call-kb (&optional (kb *current-knowledge-base*)) - "selects kb." - ($send kb :select-kb)) diff --git a/t/baby2015/kernel/meta/kb-stub.cl b/t/baby2015/kernel/meta/kb-stub.cl deleted file mode 100644 index 98b8e0b..0000000 --- a/t/baby2015/kernel/meta/kb-stub.cl +++ /dev/null @@ -1,44 +0,0 @@ -;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: BABYLON; Base: 10. -*- - -(in-package "BABYLON") - -;; Copyright 1986, 1985 and 1984 BY -;; G M D -;; Postfach 1240 -;; D-5205 St. Augustin -;; FRG - - - -;; AUTHORS: Franco di Primio, Eckehard Gross, Juergen Walther - - -(def$flavor kb-stub - ((meta-processor nil)) - () - #-:FMCS(:default-handler kb-stub-handler) - :settable-instance-variables - (:documentation "flavor allowing the free-text-processor to play -the role of meta-processor.")) - - -(def$method (kb-stub :eval) (goal mode source &rest args) - "asks the user via free-text-processor to evaluate a request." - (declare (ignore source)) - (let ((method (get 'free-text mode))) - (cond ((null method) - (baberror (getentry unknown-eval-mode-error-fstr io-table) - mode - 'free-text - goal)) - (t (lexpr-$send *current-knowledge-base* method goal mode args))))) - -#-:FMCS(defun kb-stub-handler (self ignore selector &rest args) - (declare (ignore ignore)) - (lexpr-$send ($send self :meta-processor) selector args)) - -#+:FMCS(def$method (kb-stub :default-handler) (message) - (lexpr-$send meta-processor (first message) (rest message))) - -;;; eof - diff --git a/t/baby2015/kernel/meta/kb-tab-e.cl b/t/baby2015/kernel/meta/kb-tab-e.cl deleted file mode 100644 index 2220959..0000000 --- a/t/baby2015/kernel/meta/kb-tab-e.cl +++ /dev/null @@ -1,191 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: BABYLON; Base: 10 -*- - -(in-package "BABYLON") - -;; Copyright 1986, 1985 and 1984 BY -;; G M D -;; Postfach 1240 -;; D-5205 St. Augustin -;; FRG - - -;; AUTHOR: Eckehard Gross - -;; All the string stuff for files in directory IO and KBSYSTEM. -;; Meaning of suffices: -;; -str Simple String -;; -fstr Format String -;; -item Single Menu Item -;; -item-list Item Lists for Menus - - -(defbabylon-table babylon-io-table english) - - -(defbabylon-entry type-end-to-confirm-str babylon-io-table english - "[Type ~:C to confirm] ") - -(defbabylon-entry type-end-to-continue-str babylon-io-table english - "[Type ~:C to continue] ") - -(defbabylon-entry select-to-confirm-str babylon-io-table english - "[Select to confirm] ") - -(defbabylon-entry select-to-continue-str babylon-io-table english - "[Select to continue] ") - -(defbabylon-entry confirm-str babylon-io-table english - " Confirm: ") - -(defbabylon-entry quit-item babylon-io-table english - '(" Quit: x " :value :ok)) - -(defbabylon-entry do-nothing-str babylon-io-table english - " Do Nothing ") - -(defbabylon-entry none-kb-current-str babylon-io-table english - " None KB current ") - -(defbabylon-entry none-kb-known-str babylon-io-table english - " None KB known ") - -(defbabylon-entry current-kb-fstr babylon-io-table english - "Current KB: ~S") - -(defbabylon-entry choose-kb-str babylon-io-table english - " Choose a KB ") - -(defbabylon-entry kill-kb-fstr babylon-io-table english - " Kill ~S ") - -(defbabylon-entry run-loop-str babylon-io-table english - " Enter Messages via Lisp Listener") - -(defbabylon-entry file-name-with-default-fstr babylon-io-table english - "Enter Filename (Default ~A):") - - -(defbabylon-entry print-info-about-fstr babylon-io-table english - " Print informations about ~S") - - -(defbabylon-entry reset-kb-fstr babylon-io-table english - " Reset ~S") - -(defbabylon-entry start-fstr babylon-io-table english - " Start ~S") - -(defbabylon-entry starting-kb-fstr babylon-io-table english - "~2%~10T****** STARTING ~S ****** ~2%") - - - -(defbabylon-entry state-of-kb-fstr babylon-io-table english - "~2%****** State of Knowledge Base ~S ****** ~%") - -(defbabylon-entry source-file-fstr babylon-io-table english - "~%- Source File(s): ~38T~{~A ~}") - - - -(defbabylon-entry enter-name-of-file-for-kb-fstr babylon-io-table english - "Give the name of the file where to save ~S [DEFAULT = ~A] ") - - -(defbabylon-entry kb-declaration-fstr babylon-io-table english - "~2%;; ************* KNOWLEDGE BASE DECLARATION ***********~2%") - -(defbabylon-entry instructions-fstr babylon-io-table english - "~2%;; ********* I N S T R U C T I O N S ************~2%") - - -(defbabylon-entry save-fstr babylon-io-table english - " Save ~S") - -(defbabylon-entry there-is-no-current-kb-str babylon-io-table english - "There is no current knowledge base.") - - -(defbabylon-entry unknown-eval-type-error-fstr babylon-io-table english - "~%request ~S of unknown type") - -(defbabylon-entry unknown-eval-mode-error-fstr babylon-io-table english - "~%~S wrong mode for ~S: ~S") - -(defbabylon-entry meta-proc-trace-fstr babylon-io-table english - " META <- ~S: ~S ~S") - - -(defbabylon-entry trace-on-fstr babylon-io-table english - " ~A Trace ON ") - -(defbabylon-entry trace-off-fstr babylon-io-table english - " ~A Trace OFF ") - - -(defbabylon-entry meta-help-item-list babylon-io-table english - '((" Why ? " why) - (" Interrupt " interrupt) - (" LISP " lisp))) - -(defbabylon-entry help-str babylon-io-table english - " H E L P ") - -(defbabylon-entry possible-answers babylon-io-table english - '((yes . yes) - (y . yes) - (no . no) - (n . no) - (unknown . unknown) - (u . unknown) - (? . help) - (h . help) - (prompt . prompt) - (p . prompt) - )) - - -(defbabylon-entry star-str babylon-io-table english - (make-string 71 :initial-element #\*)) - -(defbabylon-entry no-select-str babylon-io-table english - "no selection") - -(defbabylon-entry mult-choose-header-str babylon-io-table english - "Select Several Items") - -(defbabylon-entry illegal-choice-fstr babylon-io-table english - "illegal choice") - -(defbabylon-entry unknown-operation-fstr babylon-io-table english - "~S Unknown Operation for ~S") - -(defbabylon-entry restart-kb-fstr babylon-io-table english - "Restart KB ~S") - -(defbabylon-entry notify-on-select-fstr babylon-io-table english - "~&===> Current KB: ~S~%~A") - - -(defbabylon-entry use-kb-fstr babylon-io-table english - "I will use ~S which is not current. OK? ") - -(defbabylon-entry unwanted-kb-fstr babylon-io-table english - "~S unwanted") - - -(defbabylon-entry kb-exists-fstr babylon-io-table english - "A knowledge base ~S of type ~S already exists.~%Do you want to use it? ") - - -(defbabylon-entry kb-does-not-exist-fstr babylon-io-table english - "The knowledge base ~S does not yet exists." ) - - -(defbabylon-entry enter-file-fstr babylon-io-table english - "Enter Filename: ") - - -(defbabylon-entry kb-of-wrong-type-str babylon-io-table english - "Current KB of wrong type") - diff --git a/t/baby2015/kernel/meta/kb-tab-g.cl b/t/baby2015/kernel/meta/kb-tab-g.cl deleted file mode 100644 index 0d1b1e6..0000000 --- a/t/baby2015/kernel/meta/kb-tab-g.cl +++ /dev/null @@ -1,193 +0,0 @@ -;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: BABYLON; Base: 10 -*- - -(in-package "BABYLON") - -;; Copyright 1986, 1985 and 1984 BY -;; G M D -;; Postfach 1240 -;; D-5205 St. Augustin -;; FRG - - -;; AUTHOR: Eckehard Gross - -;; All the string stuff for files in directory IO and KBSYSTEM. -;; Meaning of suffices: -;; -str Simple String -;; -fstr Format String -;; -item Single Menu Item -;; -item-list Item Lists for Menus - - -(defbabylon-table babylon-io-table german) - - -(defbabylon-entry type-end-to-confirm-str babylon-io-table german - "[Druecke ~:C zur Bestaetigung] ") - -(defbabylon-entry type-end-to-continue-str babylon-io-table german - "[Druecke ~:C zur Fortsetzung] ") - - -(defbabylon-entry select-to-confirm-str babylon-io-table german - "[Selektiere zur Bestaetigung] ") - -(defbabylon-entry select-to-continue-str babylon-io-table german - "[Selektiere zur Fortsetzung] ") - - -(defbabylon-entry confirm-str babylon-io-table german - " Bestaetige: ") - -(defbabylon-entry quit-item babylon-io-table german - '(" Quittiere: x " :value :ok)) - -(defbabylon-entry do-nothing-str babylon-io-table german - " Do Nothing ") - -(defbabylon-entry none-kb-current-str babylon-io-table german - " Keine WB aktuell ") - -(defbabylon-entry none-kb-known-str babylon-io-table german - " Keine WB bekannt ") - -(defbabylon-entry current-kb-fstr babylon-io-table german - "Aktuelle WB: ~S") - -(defbabylon-entry choose-kb-str babylon-io-table german - " Waehle eine WB ") - -(defbabylon-entry kill-kb-fstr babylon-io-table german - " Kill ~S ") - -(defbabylon-entry run-loop-str babylon-io-table german - " Gib Nachrichten via Lisp Listener ein") - -(defbabylon-entry file-name-with-default-fstr babylon-io-table german - "Gib Dateinamen an [Standard ~A]: ") - - -(defbabylon-entry print-info-about-fstr babylon-io-table german - " Liste Informationen ueber ~S") - - -(defbabylon-entry reset-kb-fstr babylon-io-table german - " Setze ~S zurueck") - -(defbabylon-entry start-fstr babylon-io-table german - " Starte ~S") - -(defbabylon-entry starting-kb-fstr babylon-io-table german - "~2%~10T****** STARTING ~S ****** ~2%") - - - -(defbabylon-entry state-of-kb-fstr babylon-io-table german - "~2%****** Status der Wissensbasis ~S ****** ~%") - -(defbabylon-entry source-file-fstr babylon-io-table german - "~%- Quelldatei(en): ~38T~{~A ~}") - - - -(defbabylon-entry enter-name-of-file-for-kb-fstr babylon-io-table german - "Geben Sie einen Dateinamen an, um ~S zu retten [STANDARD = ~A] ") - - -(defbabylon-entry kb-declaration-fstr babylon-io-table german - "~2%;; ************* WISSENSBASIS DEKLARATION ***********~2%") - -(defbabylon-entry instructions-fstr babylon-io-table german - "~2%;; ********* I N S T R U K T I O N E N ************~2%") - - -(defbabylon-entry save-fstr babylon-io-table german - " Rette ~S") - -(defbabylon-entry there-is-no-current-kb-str babylon-io-table german - "Es gibt keine aktuelle Wissensbasis.") - - -(defbabylon-entry unknown-eval-type-error-fstr babylon-io-table german - "~%Typ der Anfrage ~S ist unbekannt") - -(defbabylon-entry unknown-eval-mode-error-fstr babylon-io-table german - "~%~S ist unzulaessiger Modus fuer ~S: ~S") - -(defbabylon-entry meta-proc-trace-fstr babylon-io-table german - " META <- ~S: ~S ~S") - - -(defbabylon-entry trace-on-fstr babylon-io-table german - " ~A Trace ON ") - -(defbabylon-entry trace-off-fstr babylon-io-table german - " ~A Trace OFF ") - - -(defbabylon-entry meta-help-item-list babylon-io-table german - '((" Warum ? " why) - (" Unterbrechung " interrupt) - (" LISP " lisp))) - -(defbabylon-entry help-str babylon-io-table german - " H I L F E ") - -(defbabylon-entry possible-answers babylon-io-table german - '((ja . yes) - (j . yes) - (nein . no) - (n . no) - (unbekannt . unknown) - (u . unknown) - (? . help) - (h . help) - (hilfe . help) - (anfordern . prompt) - (p . prompt) - )) - - -(defbabylon-entry star-str babylon-io-table german - (make-string-of-length 71 "*")) - -(defbabylon-entry no-select-str babylon-io-table german - "Keine Auswahl") - -(defbabylon-entry mult-choose-header-str babylon-io-table german - "Waehle mehrere Eintraege aus") - -(defbabylon-entry illegal-choice-fstr babylon-io-table german - "Unzulaessige Auswahl") - -(defbabylon-entry unknown-operation-fstr babylon-io-table german - "~S unbekannte Operation fuer ~S") - -(defbabylon-entry restart-kb-fstr babylon-io-table german - "Restart WB ~S") - -(defbabylon-entry notify-on-select-fstr babylon-io-table german - "~&===> Aktuelle WB: ~S~%~A") - - -(defbabylon-entry use-kb-fstr babylon-io-table german - "Werde die Wissensbasis ~S benutzen, die nicht aktuell ist. In Ordnung? ") - -(defbabylon-entry unwanted-kb-fstr babylon-io-table german - "~S unerwuenscht") - - -(defbabylon-entry kb-does-not-exist-fstr babylon-io-table german - "Die Wissensbasis ~S existiert noch nicht." ) - - -(defbabylon-entry kb-exists-fstr babylon-io-table german - "Eine Wissensbasis ~S vom Typ ~S existiert bereits.~%Soll sie verwendet werden? ") - -(defbabylon-entry enter-file-fstr babylon-io-table german - "Geben Sie einen Dateinamen ein: ") - - -(defbabylon-entry kb-of-wrong-type-str babylon-io-table german - "Aktuelle WB vom falschen Typ") - diff --git a/t/baby2015/kernel/meta/l-mixin.cl b/t/baby2015/kernel/meta/l-mixin.cl deleted file mode 100644 index 89581da..0000000 --- a/t/baby2015/kernel/meta/l-mixin.cl +++ /dev/null @@ -1,65 +0,0 @@ -;;; -*- Mode: LISP; Package: BABYLON; Syntax: Common-Lisp; Base: 10 -*- - -(in-package "BABYLON") - -;; Copyright 1986, 1985 and 1984 BY -;; G M D -;; Postfach 1240 -;; D-5205 St. Augustin -;; FRG - - -;; AUTHORS: Franco di Primio, Eckehard Gross, Juergen Walther - - -(def$flavor lisp-mixin - () - () - (:required-instance-variables active-proc) - (:documentation "This is the lisp-mixin flavor. -It provides all the facilities to use Lisp functions in the context -of a knowledge base.")) - - -(defrequest lisp-form - :remember :eval-lisp - :store :eval-lisp - :recall :eval-lisp - :prolog :eval-lisp-form-for-prolog) - -(defmacro lisp-type (request) - `(cond ((atom ,request) 'lisp-form) - ((and (symbolp (first ,request)) - (or (fboundp (first ,request)) - (macro-function (first ,request))) - 'lisp-form)))) - -(assign-typefkt 'lisp-type 'lisp-mixin) - -(def$method (lisp-mixin :eval-lisp) (form mode) - "Method to evaluate lisp functions in the context of a kb." - (declare (ignore mode)) - (setf active-proc self) - (eval form)) - -(def$method (lisp-mixin :eval-lisp-form-for-prolog) (form mode) - "This implements the gentle method to evaluate lisp forms in Prolog! - method :EVAL-LISP represents the crude mode. - get an error, if (first form) is a MACRO or a special function!!!" - (declare (ignore mode)) - (setf active-proc self) - (let ((fn (first form)) ;; a function, not a macro!!!! - (args (butlast (cdr form))) - (result (first (last form)))) - (if (not (CONTAINS-VARS args)) - (let ((call-result ;; ist eine Liste von einem oder mehreren Werten. - (multiple-value-list ;; Das, um auch multiple values zu behandeln - (apply fn args))) - (clauses nil)) - ;; Die Moeglichkeit, Funktionen zu benutzen, die multiple values zurueckgeben, - ;; macht Lisp aus Prolog-Sicht sehr interessant!!! (Franco) - (if (is-variable result) ;; gives a list of clauses as result - (dolist (a-value call-result (nreverse clauses)) - (setf clauses (cons `((,fn ,@args ,a-value)) clauses))) - ;; else T or NIL - (not (null (member result call-result)))))))) \ No newline at end of file diff --git a/t/baby2015/kernel/meta/m-mixin.cl b/t/baby2015/kernel/meta/m-mixin.cl deleted file mode 100644 index 37938a1..0000000 --- a/t/baby2015/kernel/meta/m-mixin.cl +++ /dev/null @@ -1,86 +0,0 @@ -;;; -*- Mode: LISP; Package: BABYLON; Syntax: Common-Lisp; Base: 10 -*- - -(in-package "BABYLON") - -;; Copyright 1986, 1985 and 1984 BY -;; G M D -;; Postfach 1240 -;; D-5205 St. Augustin -;; FRG - - -;; AUTHORS: Franco di Primio, Eckehard Gross, Juergen Walther - - - -(def$flavor meta-processor-core - ((system-trace nil) - (system-trace-window nil) - (active-proc)) - () - :settable-instance-variables - (:documentation "This is the meta-processor-core flavor. -It provides all the facilities to handle communication of special -processors to be mixed into one knowledge base.")) - -(def$method (meta-processor-core :after :init) (&rest plist) - (declare (ignore plist)) - (setf active-proc self)) - -(def$method (meta-processor-core :send-system-trace-window) - (selector &rest args) - (lexpr-$send system-trace-window selector args)) - -;;-------------------------------------------------------------------------- -;; EVALUATION OF REQUESTS -;;-------------------------------------------------------------------------- - -(def$method (meta-processor-core :eval) (expression mode processor &rest args) - "Evaluate an expression in mode mode for processor processor." - (declare (ignore processor)) - (let* ((type ($send self :get-type expression)) - (method (get type mode))) - (cond ((null type) - (baberror (getentry unknown-eval-type-error-fstr babylon-io-table) - expression)) - ((null method) - (baberror (getentry unknown-eval-mode-error-fstr babylon-io-table) - mode type expression)) - (t (lexpr-$send self method expression mode args))))) - -(def$method (meta-processor-core :before :eval) - (expression mode processor &rest args) - "Trace :eval messages." - (declare (ignore args)) - (when system-trace - ($send self :send-system-trace-window :format - (getentry meta-proc-trace-fstr babylon-io-table) - processor mode expression))) - -;;-------------------------------------------------------------------------- - -(def$method (meta-processor-core :return-nil) (expression mode &rest args) - "Always returns nil." - (declare (ignore expression mode args)) - nil) - -;;-------------------------------------------------------------------------- - -(def$method (meta-processor-core :help) () - 'why) - -;;-------------------------------------------------------------------------- - -(def$method (meta-processor-core :toggle-system-trace) () - "Toggles system trace mode." - (setf system-trace (if system-trace nil t))) - -(defun toggle-system-trace () - "Toggles system trace mode." - (if (is-activated-kb) - (send-kb :toggle-system-trace))) - -(def$method (meta-processor-core :trace-status) () - (if system-trace - (format nil (getentry trace-on-fstr babylon-io-table) "System") - (format nil (getentry trace-off-fstr babylon-io-table) "System"))) \ No newline at end of file diff --git a/t/baby2015/kernel/modules/b-consat.cl b/t/baby2015/kernel/modules/b-consat.cl deleted file mode 100644 index d5f5525..0000000 --- a/t/baby2015/kernel/modules/b-consat.cl +++ /dev/null @@ -1,33 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Base: 10; Package: BABYLON -*- - -(in-package "BABYLON") - -;;; Copyright 1988, 1987, 1986, 1985 and 1984 BY -;;; G M D -;;; Postfach 1240 -;;; D-5205 St. Augustin -;;; FRG - -;;; AUTHOR: J. Walther - -;;; system module: basic-constraint-mixin : b-consat - -(bab-require 'common) - -(cc-load "consat^basic>cp-tab-e") -(cc-load "consat^basic>cp-tab-g") -(cc-load "consat^basic>bc-fns") -(cc-load "consat^basic>primcstr") -(cc-load "consat^basic>cstrnet") -(cc-load "consat^basic>net-prop") -(cc-load "consat^basic>cstrbase") -(cc-load "consat^basic>bc-proc") -(cc-load "consat^basic>bc-mixin") - -(bab-provide 'basic-constraint-mixin) - -#+(and :CCL (not :MCL)) (cc-load "mac^tools>consat-add-on") -#+:MCL (cc-load "mac^tools>consat-add-on-clos") - -;;; eof - diff --git a/t/baby2015/kernel/modules/b-frame.cl b/t/baby2015/kernel/modules/b-frame.cl deleted file mode 100644 index 9786a8d..0000000 --- a/t/baby2015/kernel/modules/b-frame.cl +++ /dev/null @@ -1,34 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Base: 10; Package: BABYLON -*- - -(in-package "BABYLON") - -;;; Copyright 1988, 1987, 1986, 1985 and 1984 BY -;;; G M D -;;; Postfach 1240 -;;; D-5205 St. Augustin -;;; FRG - -;;; AUTHOR: J. Walther - -;;; system module: basic-frame-mixin : b-frame - -(cc-load "frames^basic>fp-tab-e") -(cc-load "frames^basic>fp-tab-g") - -(cc-load "frames^basic>frames") -(cc-load "frames^basic>fr-core") -(cc-load "frames^basic>bf-inter") -(cc-load "frames^basic>bf-proc") -(cc-load "frames^basic>bf-mixin") - -(bab-provide 'basic-frame-mixin) - -#+(and :CCL (not :MCL)) (cc-load "mac^tools>frame-add-on") -#+:MCL (cc-load "mac^tools>frame-add-on-clos") - -#+(or :CCL-1.3 :MCL)(when (y-or-n-p "~&Load graphic frame browser?") - #+:CCL-1.3(cc-load "mac^tools>babgrapher") - #+:MCL(cc-load "mac^tools>babgrapher-clos")) - -;;; eof - diff --git a/t/baby2015/kernel/modules/b-prolog.cl b/t/baby2015/kernel/modules/b-prolog.cl deleted file mode 100644 index fa25fd7..0000000 --- a/t/baby2015/kernel/modules/b-prolog.cl +++ /dev/null @@ -1,31 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Base: 10; Package: BABYLON -*- - -(in-package "BABYLON") - -;;; Copyright 1988, 1987, 1986, 1985 and 1984 BY -;;; G M D -;;; Postfach 1240 -;;; D-5205 St. Augustin -;;; FRG - -;;; AUTHOR: J. Walther - -;;; system module: basic-prolog-mixin : b-prolog - -(cc-load "prolog^basic>pp-tab-e") -(cc-load "prolog^basic>pp-tab-g") - -(cc-load "prolog^basic>axioms") -(cc-load "prolog^basic>ax-sc") -(cc-load "prolog^basic>bp-inter") -(cc-load "prolog^basic>bp-preds") -(cc-load "prolog^basic>bp-proc") -(cc-load "prolog^basic>bp-mixin") - -(bab-provide 'basic-prolog-mixin) - -#+(and :CCL (not :MCL)) (cc-load "mac^tools>basic-prolog-add-on") -#+:MCL (cc-load "mac^tools>basic-prolog-add-on-clos") - -;;; eof - diff --git a/t/baby2015/kernel/modules/b-rule.cl b/t/baby2015/kernel/modules/b-rule.cl deleted file mode 100644 index 8e99baa..0000000 --- a/t/baby2015/kernel/modules/b-rule.cl +++ /dev/null @@ -1,30 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Base: 10; Package: BABYLON -*- - -(in-package "BABYLON") - -;;; Copyright 1988, 1987, 1986, 1985 and 1984 BY -;;; G M D -;;; Postfach 1240 -;;; D-5205 St. Augustin -;;; FRG - -;;; AUTHOR: J. Walther - -;;; system module: basic-rule-mixin : b-rule - -(cc-load "rules^basic>rp-tab-e") -(cc-load "rules^basic>rp-tab-g") - -(cc-load "rules^basic>rules") -(cc-load "rules^basic>data") -(cc-load "rules^basic>br-inter") -(cc-load "rules^basic>br-proc") -(cc-load "rules^basic>br-mixin") - -(bab-provide 'basic-rule-mixin) - -#+(and :CCL (not :MCL)) (cc-load "mac^tools>basic-rule-add-on") -#+:MCL (cc-load "mac^tools>basic-rule-add-on-clos") - -;;; eof - diff --git a/t/baby2015/kernel/modules/cmds.cl b/t/baby2015/kernel/modules/cmds.cl deleted file mode 100644 index 3bb71fc..0000000 --- a/t/baby2015/kernel/modules/cmds.cl +++ /dev/null @@ -1,30 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Base: 10; Package: BABYLON -*- - -(in-package "BABYLON") - -;;; Copyright 1988, 1987, 1986, 1985 and 1984 BY -;;; G M D -;;; Postfach 1240 -;;; D-5205 St. Augustin -;;; FRG - -;;; AUTHOR: J. Walther - -;;; system module: cmds : cmds - -(cc-load "io^cmds>common-e") -(cc-load "io^cmds>frame-e") -(cc-load "io^cmds>consat-e") -(cc-load "io^cmds>rule-e") -(cc-load "io^cmds>prolog-e") - -(cc-load "io^cmds>common-g") -(cc-load "io^cmds>frame-g") -(cc-load "io^cmds>consat-g") -(cc-load "io^cmds>rule-g") -(cc-load "io^cmds>prolog-g") - -(bab-provide 'cmds) - -;;; eof - diff --git a/t/baby2015/kernel/modules/common.cl b/t/baby2015/kernel/modules/common.cl deleted file mode 100644 index 19ab0df..0000000 --- a/t/baby2015/kernel/modules/common.cl +++ /dev/null @@ -1,21 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Base: 10; Package: BABYLON -*- - -(in-package "BABYLON") - -;;; Copyright 1988, 1987, 1986, 1985 and 1984 BY -;;; G M D -;;; Postfach 1240 -;;; D-5205 St. Augustin -;;; FRG - -;;; AUTHOR: J. Walther - -;;; system module: common - -(cc-load "common^vars") ; variables -(cc-load "common^c-fns") ; functions -(cc-load "common^p-core") ; processor-core - -(bab-provide 'common) - -;;; eof diff --git a/t/baby2015/kernel/modules/fmcs.cl b/t/baby2015/kernel/modules/fmcs.cl deleted file mode 100644 index 28ca931..0000000 --- a/t/baby2015/kernel/modules/fmcs.cl +++ /dev/null @@ -1,24 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Base: 10; Package: BABYLON -*- - -(in-package "BABYLON") - -;;; mcs (old flavor oriented version) - -;;; META CLASS SYSTEM -;;; copy this file into one of your modules folders -;;; _______________________________________________________________________ - - -(cc-load "fmcs^mcs-core") -(cc-load "fmcs^mcs-root") -(cc-load "fmcs^mcs-meth") -(cc-load "fmcs^mcs-util") -(cc-load "fmcs^mcs-map") ; mapping babylon flavor primitives to fmcs - -(pushnew :FMCS *features*) - -;;; mcs does not allow slot access by name -;;; you must use slot-value - -;;; eof - diff --git a/t/baby2015/kernel/modules/freetext.cl b/t/baby2015/kernel/modules/freetext.cl deleted file mode 100644 index 4131c60..0000000 --- a/t/baby2015/kernel/modules/freetext.cl +++ /dev/null @@ -1,24 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Base: 10; Package: BABYLON -*- - -(in-package "BABYLON") - -;;; Copyright 1988, 1987, 1986, 1985 and 1984 BY -;;; G M D -;;; Postfach 1240 -;;; D-5205 St. Augustin -;;; FRG - -;;; AUTHOR: J. Walther - -;;; system module: freetext - -(cc-load "freetext^ft-tab-e") -(cc-load "freetext^ft-tab-g") - -(cc-load "freetext^ft-proc") -(cc-load "freetext^ft-mixin") - -(bab-provide 'free-text-mixin) - -;;; eof - diff --git a/t/baby2015/kernel/modules/m-consat.cl b/t/baby2015/kernel/modules/m-consat.cl deleted file mode 100644 index afdc7ec..0000000 --- a/t/baby2015/kernel/modules/m-consat.cl +++ /dev/null @@ -1,24 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Base: 10; Package: BABYLON -*- - -(in-package "BABYLON") - -;;; Copyright 1988, 1987, 1986, 1985 and 1984 BY -;;; G M D -;;; Postfach 1240 -;;; D-5205 St. Augustin -;;; FRG - -;;; AUTHOR: J. Walther - -;;; system module: mini-constraint-mixin : m-consat - -(bab-require 'basic-constraint-mixin) - -(cc-load "consat^mini>mc-trace") -(cc-load "consat^mini>mc-proc") -(cc-load "consat^mini>mc-mixin") - -(bab-provide 'mini-constraint-mixin) - -;;; eof - diff --git a/t/baby2015/kernel/modules/m-frame.cl b/t/baby2015/kernel/modules/m-frame.cl deleted file mode 100644 index 7c5db3e..0000000 --- a/t/baby2015/kernel/modules/m-frame.cl +++ /dev/null @@ -1,25 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Base: 10; Package: BABYLON -*- - -(in-package "BABYLON") - -;;; Copyright 1988, 1987, 1986, 1985 and 1984 BY -;;; G M D -;;; Postfach 1240 -;;; D-5205 St. Augustin -;;; FRG - -;;; AUTHOR: J. Walther - -;;; system module: mini-frame-mixin : m-frame - -(bab-require 'basic-frame-mixin) - -(cc-load "frames^mini>pos-vals") -(cc-load "frames^mini>ask-supp") -(cc-load "frames^mini>mf-proc") -(cc-load "frames^mini>mf-mixin") - -(bab-provide 'mini-frame-mixin) - -;;; eof - diff --git a/t/baby2015/kernel/modules/m-prolog.cl b/t/baby2015/kernel/modules/m-prolog.cl deleted file mode 100644 index 7df7e09..0000000 --- a/t/baby2015/kernel/modules/m-prolog.cl +++ /dev/null @@ -1,25 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Base: 10; Package: BABYLON -*- - -(in-package "BABYLON") - -;;; Copyright 1988, 1987, 1986, 1985 and 1984 BY -;;; G M D -;;; Postfach 1240 -;;; D-5205 St. Augustin -;;; FRG - -;;; AUTHOR: J. Walther - -;;; system module: mini-prolog-mixin : m-prolog - -(bab-require 'basic-prolog-mixin) - -(cc-load "prolog^mini>mp-preds") -(cc-load "prolog^mini>mp-trace") -(cc-load "prolog^mini>mp-proc") -(cc-load "prolog^mini>mp-mixin") - -(bab-provide 'mini-prolog-mixin) - -;;; eof - diff --git a/t/baby2015/kernel/modules/m-rule.cl b/t/baby2015/kernel/modules/m-rule.cl deleted file mode 100644 index a0633a9..0000000 --- a/t/baby2015/kernel/modules/m-rule.cl +++ /dev/null @@ -1,24 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Base: 10; Package: BABYLON -*- - -(in-package "BABYLON") - -;;; Copyright 1988, 1987, 1986, 1985 and 1984 BY -;;; G M D -;;; Postfach 1240 -;;; D-5205 St. Augustin -;;; FRG - -;;; AUTHOR: J. Walther - -;;; system module: mini-rule-mixin : m-rule - -(bab-require 'basic-rule-mixin) - -(cc-load "rules^mini>mr-trace") -(cc-load "rules^mini>mr-proc") -(cc-load "rules^mini>mr-mixin") - -(bab-provide 'mini-rule-mixin) - -;;; eof - diff --git a/t/baby2015/kernel/modules/meta.cl b/t/baby2015/kernel/modules/meta.cl deleted file mode 100644 index cee8d48..0000000 --- a/t/baby2015/kernel/modules/meta.cl +++ /dev/null @@ -1,26 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Base: 10; Package: BABYLON -*- - -(in-package "BABYLON") - -;;; Copyright 1988, 1987, 1986, 1985 and 1984 BY -;;; G M D -;;; Postfach 1240 -;;; D-5205 St. Augustin -;;; FRG - -;;; AUTHOR: J. Walther - -;;; system module: meta - -(cc-load "meta^kb-tab-e") -(cc-load "meta^kb-tab-g") - -(cc-load "meta^kb-core") -(cc-load "meta^m-mixin") -(cc-load "meta^l-mixin") -(cc-load "meta^kb-stub") - -(bab-provide 'meta) - -;;; eof - diff --git a/t/baby2015/kernel/modules/n-consat.cl b/t/baby2015/kernel/modules/n-consat.cl deleted file mode 100644 index ff94c16..0000000 --- a/t/baby2015/kernel/modules/n-consat.cl +++ /dev/null @@ -1,28 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Base: 10; Package: BABYLON -*- - -(in-package "BABYLON") - -;;; Copyright 1988, 1987, 1986, 1985 and 1984 BY -;;; G M D -;;; Postfach 1240 -;;; D-5205 St. Augustin -;;; FRG - -;;; AUTHOR: J. Walther - -;;; system module: normal-constraint-mixin : n-consat - -(bab-require 'common) -(bab-require 'normal-frame-mixin) -(bab-require 'mini-constraint-mixin) - -(cc-load "consat^normal>restrict") -(cc-load "consat^normal>rstreval") -(cc-load "consat^normal>rstrbase") -(cc-load "consat^normal>nc-proc") -(cc-load "consat^normal>nc-mixin") - -(bab-provide 'normal-constraint-mixin) - -;;; eof - diff --git a/t/baby2015/kernel/modules/n-frame.cl b/t/baby2015/kernel/modules/n-frame.cl deleted file mode 100644 index a51f48c..0000000 --- a/t/baby2015/kernel/modules/n-frame.cl +++ /dev/null @@ -1,24 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Base: 10; Package: BABYLON -*- - -(in-package "BABYLON") - -;;; Copyright 1988, 1987, 1986, 1985 and 1984 BY -;;; G M D -;;; Postfach 1240 -;;; D-5205 St. Augustin -;;; FRG - -;;; AUTHOR: J. Walther - -;;; system module: normal-frame-mixin : n-frame - -(bab-require 'mini-frame-mixin) - -(cc-load "frames^normal>act-vals") -(cc-load "frames^normal>nf-proc") -(cc-load "frames^normal>nf-mixin") - -(bab-provide 'normal-frame-mixin) - -;;; eof - diff --git a/t/baby2015/kernel/modules/n-prolog.cl b/t/baby2015/kernel/modules/n-prolog.cl deleted file mode 100644 index 39b2201..0000000 --- a/t/baby2015/kernel/modules/n-prolog.cl +++ /dev/null @@ -1,24 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Base: 10; Package: BABYLON -*- - -(in-package "BABYLON") - -;;; Copyright 1988, 1987, 1986, 1985 and 1984 BY -;;; G M D -;;; Postfach 1240 -;;; D-5205 St. Augustin -;;; FRG - -;;; AUTHOR: J. Walther - -;;; system module: normal-prolog-mixin : n-prolog - -(bab-require 'mini-prolog-mixin) - -(cc-load "prolog^normal>np-devel") -(cc-load "prolog^normal>np-expl") -(cc-load "prolog^normal>np-proc") -(cc-load "prolog^normal>np-mixin") - -(bab-provide 'normal-prolog-mixin) - -;;; eof diff --git a/t/baby2015/kernel/modules/n-rule.cl b/t/baby2015/kernel/modules/n-rule.cl deleted file mode 100644 index 1830799..0000000 --- a/t/baby2015/kernel/modules/n-rule.cl +++ /dev/null @@ -1,28 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Base: 10; Package: BABYLON -*- - -(in-package "BABYLON") - -;;; Copyright 1988, 1987, 1986, 1985 and 1984 BY -;;; G M D -;;; Postfach 1240 -;;; D-5205 St. Augustin -;;; FRG - -;;; AUTHOR: J. Walther - -;;; system module: normal-rule-mixin : n-rule - -(bab-require 'mini-rule-mixin) - -(cc-load "rules^normal>nr-expl") -(cc-load "rules^normal>nr-devel") -(cc-load "rules^normal>nr-proc") -(cc-load "rules^normal>nr-mixin") - -(bab-provide 'normal-rule-mixin) - -#+(and :CCL (not :MCL)) (cc-load "mac^tools>normal-rule-add-on") -#+:MCL (cc-load "mac^tools>normal-rule-add-on-clos") - -;;; eof - diff --git a/t/baby2015/kernel/prolog/basic/ax-sc.cl b/t/baby2015/kernel/prolog/basic/ax-sc.cl deleted file mode 100644 index 41291e1..0000000 --- a/t/baby2015/kernel/prolog/basic/ax-sc.cl +++ /dev/null @@ -1,444 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: BABYLON; Base: 10 -*- - -(in-package "BABYLON") - -;; Copyright 1986, 1985 and 1984 BY -;; G M D -;; Postfach 1240 -;; D-5205 St. Augustin -;; FRG - -;; DATE: uralt -;; AUTHOR: Eckehard Gross - -;; This file depends on: common>* -;; prolog>basic>axioms - -;;--------------------------------------------------------------------------- - -(def$flavor proc-sc-mixin - (topgoal - top-varcells - (format-option 'vars) - maxvar - env - env-depth - reset-ops) - () - (:required-instance-variables meta-processor axioms status) - :settable-instance-variables - (:documentation "Mixin for prolog-interpreter to handle clauses in course of a proof. -according to the structure copying approach clauses are copied before unification, -their prolog variables beeing replaced by newly generated variables internally -represented by arrays called varcells. -varcells getting instantiated by unification are stacked on the instance variable -env to allow backtracking. the depth of that stack is stored in env-depth. -reset-ops is a stack for those goals, that caused backtrackable side effects. -the goals provided by the user are copied and stored in topgoal. -all varcells in topgoal representing nonanonymous variables are collected -in top-varcells. -the instance variable format-option controlls the display format of results.")) - - -;;--------------------------------------------------------------------------- -;; INTERNAL REPRESENTATION OF CLAUSES -;;--------------------------------------------------------------------------- - - -; Defined in file global-variables - -;(defvar *maxvar* 0 "next free number for a varcell") - -(defvar *vars nil) - -(defvar *tenv nil) - -(defvar *tenv-depth 0) - -(declaim (type list *vars *tenv)) -(declaim (type fixnum *tenv-depth *maxvar*)) - -(defmacro is-var (x) - `(and (symbolp ,x) - (char-equal (aref (string ,x) 0) #\_))) - - -(defstruct (varcell (:type vector) - :named - (:conc-name nil)) - ;;internal representation of a prolog variable - varname ;prolog variable varcell is substituted for - varnr ;internal number of varcell - envnr ;position in stack env - varvalue ;value of varcell - ) - -;(defmacro is-varcell (x) -; `(typep ,x 'varcell)) - -;(defmacro is-varcell (x) -; `(varcell-p ,x)) - -(defmacro gen-varcell (var) - "generates a varcell for var using *maxvar* as internal number." - `(prog1 (make-varcell :varname ,var - :varnr *maxvar* - :envnr nil) - (incf *maxvar*))) - -(defun trans-clause (term) - "copies term substituting prolog variables by associated varcells. -nonanymous variables are collected in *vars to avoid generating -a new varcell for each occurrence of the same variable." - (let ((*vars nil)) - (trans-clause1 term))) - -(defun trans-clause1 (term) - (cond ((is-var term) - (cond ((eq term '_)(gen-varcell term)) - ((not (member term *vars :test 'equal)) - (push term *vars) - (set term (gen-varcell term))) - (t (symbol-value term)))) - ((atom term) term) - ((consp term)(cons (trans-clause1 (first term)) - (trans-clause1 (rest term)))))) - -(defmacro is-bound (varcell) - `(envnr ,varcell)) - -(defmacro is-rest-bound (varcell nr) - `(and (envnr ,varcell) - (<= (envnr ,varcell) ,nr))) - -(defun deref (x) - (cond ((and (varcell-p x)(is-bound x)) - (deref (varvalue x))) - (t x))) - -(defun rest-deref (x nr) - (cond ((and (varcell-p x)(is-rest-bound x nr)) - (rest-deref (varvalue x) nr)) - (t x))) - -(defun subst-prolog-vars (term mode) - "substitutes all varcells in term by their values. -not instantiated varcells are replaced by their internal name, their external -name or by itself according to the values normal ext int of mode." - (cond ((varcell-p term) - (cond ((is-bound term) - (subst-prolog-vars (varvalue term) mode)) - (t (case mode - (normal (intern (format nil "_~S" (varnr term)))) - (ext (varname term)) - (int term))))) - ((atom term) term) - ((consp term) - (cons (subst-prolog-vars (first term) mode) - (subst-prolog-vars (rest term) mode))))) - -(defun rest-subst-prolog-vars (term mode nr) - "substitutes all varcells in term by their values neglecting last instantiations. -instantiations are considered if their position in env is <= nr. -varcells not instantiated till then are replaced by their internal name, their -external name or by itself according to the value normal ext int of mode." - (cond ((varcell-p term) - (cond ((is-rest-bound term nr) - (rest-subst-prolog-vars (varvalue term) mode nr)) - (t (case mode - (normal (intern (format nil "_~S" (varnr term)))) - (ext (varname term)) - (int term))))) - ((atom term) term) - ((consp term) - (cons (rest-subst-prolog-vars (first term) mode nr) - (rest-subst-prolog-vars (rest term) mode nr))))) - - -;;--------------------------------------------------------------------------- -;; SET GOALS & PROVIDE RESULTS -;;--------------------------------------------------------------------------- - - -(def$method (proc-sc-mixin :setgoal) (goals) - "initializes processor to prove goals." - (let ((*vars nil)) - (check-type goals cons (getentry a-list-str prolog-io-table)) - (setq *maxvar* 0) - (setf topgoal (trans-clause1 goals)) - (setf top-varcells (mapcar #'symbol-value (nreverse *vars))) - (setf env nil) - (setf env-depth 0) - (setf reset-ops nil))) - - -(def$method (proc-sc-mixin :return-form) () - "internal method. -returns topgoal after substitution of all varcells by their values, -if the last proof succeded, and NIL otherwise." - (case status - (succ (subst-prolog-vars topgoal 'ext)) - ((fail cfail) nil) - (t (baberror "~S ~S" (getentry status-str prolog-io-table) status)))) - - -(defun value-is-var (pair) - (is-var (cdr pair))) - -(defun gen-var-value-list (varcells type) - (let ((list (mapcar #'(lambda (varcell) - (cons (varname varcell) - (subst-prolog-vars varcell 'ext))) - varcells))) - (case type - (all list) - (bound (remove-if #'value-is-var list))))) - -(def$method (proc-sc-mixin :return-vars) (type) - "internal method. -returns an alist consisting of variables of the topgoal paired with their values, -if the last proof succeded, and NIL otherwise. - might be ALL or BOUND. in the former case all nonanonymous variables -are considered, in the latter case variables bound to a variable are ommitted. -if variables are missing, YES is returned instead." - (case status - (succ (or (gen-var-value-list top-varcells type) - 'yes)) - ((fail cfail) nil) - (t (baberror "~S ~S" (getentry status-str prolog-io-table) status)))) - - -(def$method (proc-sc-mixin :return-result) (&optional rform) - "returns the result of a proof according to or the current format-option: -form: the topgoal is returned after substitution of all varcells by their values, -if the last proof succeded, and NIL otherwise. -vars: an alist is returned consisting of all nonanonymous variables of the topgoal -paired with their values, if the last proof succeded, and NIL otherwise. -bound: like vars but variables whose values are variables are omitted. -if variables are missing, YES is returned instead." - (case (or rform format-option) - (form ($send self :return-form)) - (bound ($send self :return-vars 'bound)) - (vars ($send self :return-vars 'all)) - (t (baberror (getentry wrong-format-fstr prolog-io-table) - (or rform format-option))))) - - -;;--------------------------------------------------------------------------- -;; GET RELEVANT CLAUSES -;;--------------------------------------------------------------------------- - - -(defmacro is-t (assertions) ; returned by meta-processor - `(eq ,assertions t)) - -(def$method (proc-sc-mixin :get-clauses) (goal) - "provides the relevant clauses to prove goal. -if there aren't any clauses the meta-processor is asked." - (let ((clauses (get-clauses-direct goal axioms))) - (cond (clauses clauses) - (meta-processor - (let* ((goal-with-substs (subst-prolog-vars goal 'ext)) - (meta-answer ($send meta-processor :eval - goal-with-substs - :prolog - 'prolog-processor))) - (cond ((null meta-answer) - (setq clauses `((,goal-with-substs (cut) (fail))))) - ((is-t meta-answer) - (setq clauses `((,goal-with-substs)))) - (t (setq clauses meta-answer))) - clauses))))) - - -;;--------------------------------------------------------------------------- -;; UNIFICATION & BACKTRACKING -;;--------------------------------------------------------------------------- - - -(defmacro setvar (varcell term) - "instantiates varcell with term pushing varcell on the environment stack." - `(progn (push ,varcell *tenv) - (incf *tenv-depth) - (setf (varvalue ,varcell) ,term) - (setf (envnr ,varcell) *tenv-depth))) - -(defun unify (term1 term2) - "tries to unify term1 term2. -instantiated varcells are stacked in *tenv." - (cond ((eq term1 term2)) - ((varcell-p term1) (setvar term1 term2)) - ((varcell-p term2) (setvar term2 term1)) - ((and (consp term1) (consp term2)) ;; statt lisp !!!! - (and (unify (deref (first term1)) (deref (first term2))) - (unify (deref (rest term1)) (deref (rest term2))))) - ((equal term1 term2)))) - -(def$method (proc-sc-mixin :unify) (goal clause) ;patch 4.6 - "tries to unify clause with goal. -returns t if successfull and nil otherwise. instantiated varcells are -stacked on env." - (let ((*tenv nil) - (*tenv-depth env-depth)) - (cond ((unify goal clause) - (setf env (nconc *tenv env)) - (setf env-depth *tenv-depth)) - (t (mapc #'(lambda (varcell) - (setf (envnr varcell) nil)) - *tenv) - nil)))) - -(def$method (proc-sc-mixin :trans-unify) (goal clause) - "copies clause and tries to unify its head with goal. -returns the transformed clause if successfull and nil otherwise. -instantiated varcells are stacked on env." - (let ((*tenv nil) - (*tenv-depth env-depth) - (nclause (trans-clause clause))) - (cond ((unify goal (head nclause)) - (setf env (nconc *tenv env)) - (setf env-depth *tenv-depth) - nclause) - (t (mapc #'(lambda (varcell) - (setf (envnr varcell) nil)) - *tenv) - nil)))) - -(def$method (proc-sc-mixin :clause-trans-unify) (goal clause) - "copies clause and tries to unify it with goal. -returns the transformed clause if successfull and nil otherwise. -instantiated varcells are stacked on env." - (let ((*tenv nil) - (*tenv-depth env-depth) - (nclause (trans-clause clause))) - (cond ((unify goal nclause) - (setf env (nconc *tenv env)) - (setf env-depth *tenv-depth) - nclause) - (t (mapc #'(lambda (varcell) - (setf (envnr varcell) nil)) - *tenv) - nil)))) - -(def$method (proc-sc-mixin :reset-env) (n) - "resets env stack." - (declare (fixnum n)) - (do ((var)) - ((>= n (the fixnum env-depth))) - (setq var (prog1 (first env) (setf env (rest env)))) - (setf (envnr var) nil) - (setf env-depth (1- (the fixnum env-depth))))) - - -;;--------------------------------------------------------------------------- -;; RESETTING BACKTRACKABLE SIDE EFFECTS -;;--------------------------------------------------------------------------- - - -(def$method (proc-sc-mixin :cut-reset) (nr) - "resets env stack and reset-ops stack." - (declare (fixnum nr)) - (do ((box (first reset-ops) (first reset-ops))) - ((or (null box) - (> nr ($send box :init-env-depth))) - ($send self :reset-env nr)) - ($send box :prove-goal 'retry))) - -(def$method (proc-sc-mixin :push-goalbox) (box) - (setf reset-ops (cons box reset-ops)) - (setf env-depth (1+ (the fixnum env-depth)))) - -(def$method (proc-sc-mixin :side-reset) (nr) - "resets env stack and pops reset-ops stack." - (declare (fixnum nr)) - (do ((var)) - ((>= (1+ nr) env-depth)) - (setq var - (prog1 (first env) (setf env (rest env)))) - (setf (envnr var) nil) - (setf env-depth (1- env-depth))) - (setf reset-ops (rest reset-ops)) - (setf env-depth (1- env-depth))) - - -;;--------------------------------------------------------------------------- -;; MIXIN FOR GOALBOX-BASIC -;;--------------------------------------------------------------------------- - - -(def$flavor goalbox-sc-mixin - (prolog-processor - goal - clauses - init-env-depth) - () - :settable-instance-variables - (:documentation "Mixin for goalbox-basic corresponding to proc-sc-mixin. -goalbox-basic represents a single (sub)goal emerging during the proof of -a user provided goal. clauses contains all relevant clauses not yet tried -to proof goal and the currently used clause. -to be able to reset instantiations on backtracking init-env-depth -remembers the depth of the instantiations stack at the beginning of -a proof of goal.")) - - -;;--------------------------------------------------------------------------- -;; MACROS FOR RESETTING -;;--------------------------------------------------------------------------- - -#+:SABN(defmacro prepare-reset () - "prepares a goal for backtracking." - `(setf init-env-depth ($send prolog-processor :env-depth))) - - -#-:SABN(defmacro prepare-reset () - "prepares a goal for backtracking." - `(setf ($slot 'init-env-depth) ($send ($slot 'prolog-processor) :env-depth))) - - -#+:SABN(defmacro prepare-side-reset () - "prepares a goal causing backtrackable side effects for backtracking." - `(progn (setf init-env-depth ($send prolog-processor :env-depth)) - ($send prolog-processor :push-goalbox self))) - - -#-:SABN(defmacro prepare-side-reset () - "prepares a goal causing backtrackable side effects for backtracking." - `(progn (setf ($slot 'init-env-depth) - ($send ($slot 'prolog-processor) :env-depth)) - ($send ($slot 'prolog-processor) :push-goalbox self))) - - -#+:SABN(defmacro normal-reset () - "resets a goal." - `($send prolog-processor :reset-env init-env-depth)) - - -#-:SABN(defmacro normal-reset () - "resets a goal." - `($send ($slot 'prolog-processor) :reset-env ($slot 'init-env-depth))) - - -#+:SABN(defmacro cut-reset () - "resets a goal in case of cut." - `($send prolog-processor :cut-reset init-env-depth)) - - -#-:SABN(defmacro cut-reset () - "resets a goal in case of cut." - `($send ($slot 'prolog-processor) :cut-reset ($slot 'init-env-depth))) - -#+:SABN(defmacro side-reset () - "resets a goal causing backtrackable side effects." - `($send prolog-processor :side-reset init-env-depth)) - - -#-:SABN(defmacro side-reset () - "resets a goal causing backtrackable side effects." - `($send ($slot 'prolog-processor) :side-reset ($slot 'init-env-depth))) - - - - -;;; eof - diff --git a/t/baby2015/kernel/prolog/basic/axioms.cl b/t/baby2015/kernel/prolog/basic/axioms.cl deleted file mode 100644 index 90e9ffe..0000000 --- a/t/baby2015/kernel/prolog/basic/axioms.cl +++ /dev/null @@ -1,437 +0,0 @@ -;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: BABYLON; Base: 10. -*- - -(in-package "BABYLON") - -;; Copyright 1986, 1985 and 1984 BY -;; G M D -;; Postfach 1240 -;; D-5205 St. Augustin -;; FRG - -;; DATE: uralt -;; AUTHOR: Franco di Primio, Eckehard Gross - -;; This file depends on: common>* - -;; Contents: a handler for axiom sets. -;; an axiom set consists of a list of clauses. -;; all predicates occuring in the head of one of these clauses are held -;; on the property list of the axiom set name using PREDS as indicator. -;; the defining clauses of a predicate are held on the property -;; list the predicate name using the axioms set name as indicator. -;; axiom sets are free or associated with a kb. in the latter case -;; the kb name is stored as KB-NAME property of the axiom set name. -;; - -;;--------------------------------------------------------------------------- -;; FLAVOR FOR CLAUSE MANAGEMENT -;;--------------------------------------------------------------------------- - - -(def$flavor axset-basic - ((axioms nil)) - (processor-core) - :settable-instance-variables - (:documentation "flavor managing axiom sets and clauses for the prolog interpreter. -axiom sets currently available are bound to axioms.")) - - -;;--------------------------------------------------------------------------- -;; GENERATING INTERNAL REPRESENTATIONS OF AXIOM SETS -;;--------------------------------------------------------------------------- - - -; Defined in file global-variables -;(defvar *AXIOM-SETS* nil "list of known axiom sets.") - - -(defun get-known-axiom-sets () - *axiom-sets*) - - -(defmacro get-preds (axiom-set) - "gets the list of predicates of ." - `(get ,axiom-set 'preds)) - -(defun get-predicates (axset-name) - (rest (get-preds axset-name))) - -(defmacro rem-preds (axiom-set) - "removes the list of predicates of ." - `(remprop ,axiom-set 'preds)) - -(defmacro rem-pred (pred axiom-set) - "removes from the list of predicates of ." - `(setf (get-preds ,axiom-set) - (delete ,pred (get-preds ,axiom-set)))) - -(defmacro add-pred (pred axiom-set) - "adds to the list of predicates of ." - `(setf (get ,axiom-set 'preds) - (nconc (get ,axiom-set 'preds) (list ,pred)))) - - - -;;-------------------------------------------------------------------------------- - -(defmacro head (rule) - `(car ,rule)) - -(defmacro body (rule) - `(cdr ,rule)) - -(defmacro pred (head) - `(car ,head)) - - -(defun normalize-clause (clause) - "removes <- from rules and transforms facts into rules without body." - (if (atom clause) - (baberror (getentry clause-syntax-error-fstr prolog-io-table))) - (if (atom (first clause)) - (setq clause (list clause))) - (if (and (consp (cdr clause)) - (eq (second clause) '<-)) - (cons (first clause) (rest (rest clause))) - clause)) - -(defun get-subgoal-predicates (clause) - "yields the predicates used in the subgoals of ." - (let ((subpreds nil)) - (dolist (a-subgoal (body (normalize-clause clause)) (nreverse subpreds)) - (setf subpreds (if (not (is-variable (pred a-subgoal))) - (cons (pred a-subgoal) subpreds) - subpreds))))) - - -(defun get-clauses (predicate axiom-set) - (get predicate axiom-set)) - - -(defun rem-clause (clause axiom-set) - "removes from the defining clauses of . -the predicate of is removed from the list of predicates of , -if no clauses remain." - (let* ((head (head clause)) - (pred (pred head)) - (rest-clauses (delete clause (get pred axiom-set)))) - (if (null rest-clauses) - (rem-pred pred axiom-set)) - (setf (get pred axiom-set) rest-clauses))) - - -(defmacro rem-clauses (pred axiom-set) - "removes from the list of predicates of with all defining clauses." - `(progn (remprop ,pred ,axiom-set) - (rem-pred ,pred ,axiom-set) - ,pred)) - -(defun remove-all-clauses (axiom-set) - "removes all clauses in without deleting ." - (mapc #'(lambda (pred) - (rem-clauses pred axiom-set)) - (cdr (get-preds axiom-set))) - axiom-set) - - -(defun prolog-assert (clause axiom-set xconc) - "adds to the clauses of using for the placement." - - (let* ((nclause (normalize-clause clause)) - (head (head nclause)) - (pred (pred head)) - (clauses-sofar (get pred axiom-set)) - (pred-sofar (get-preds axiom-set))) - (if (not (member nclause clauses-sofar :test 'equal)) - (setf (get pred axiom-set) - (funcall xconc clauses-sofar (list nclause)))) - (if (not (member pred pred-sofar :test 'equal)) - (add-pred pred axiom-set)) - pred)) - -(defun xpush (list x) - (nconc x list)) - -(defmacro asserta (clause axiom-set) - `(prolog-assert ',clause ',axiom-set #'xpush)) - -(defmacro assertz (clause axiom-set) - `(prolog-assert ',clause ',axiom-set #'nconc)) - -(defun add-axioms (axiom-set clauses) - "adds to the clauses of ." - (if clauses - (mapc #'(lambda (clause) - (prolog-assert clause axiom-set #'nconc)) - clauses)) - axiom-set) - -;;------------------------------------------------------------------------------------------- -;; AXIOM SET GENERATION & RESETTING -;;------------------------------------------------------------------------------------------- - -(defun init-axset (axset-name &optional kb-name) - "builds an empty axiom set named . -if is not NIL, is marked to be associated with ." - (cond ((member axset-name *axiom-sets*) - (remove-all-clauses axset-name)) - (t (push axset-name *axiom-sets*) - (setf (get axset-name 'preds) (list '$preds)) - (if kb-name - (setf (get axset-name 'kb-name) kb-name)))) - axset-name) - - -(defun assert-axioms (axset-name clauses &optional kb-name) - "builds an axiom set named consisting of the predicates defined by . -if is not NIL, is marked to be associated with ." - - (init-axset axset-name kb-name) - (add-axioms axset-name clauses) - (setf (get axset-name 'clauses) clauses) - axset-name) - - -(defmacro defaxiom-set (axset-name &rest clauses) - "constructor macro for free axiom sets." - `(assert-axioms ',axset-name ',clauses)) - -(defun reset-axiom-set (axiom-set &optional (axiom-sets (get-known-axiom-sets))) - "resets if it belongs to the list of axiom sets ." - - (cond ((member axiom-set axiom-sets) - (remove-all-clauses axiom-set) - (add-axioms axiom-set (get axiom-set 'clauses)) - axiom-set) - (t (send-kb :babylon-format - (getentry unknown-axset-fstr prolog-io-table) axiom-set)))) - -(def$method (axset-basic :reset-axiom-sets) (&rest axiom-sets) - "resets if specified or all currently available axiom sets. -all modifications made by consult, reconsult, edit clauses or by prolog programs -are reset." - - (let ((axiom-sets-copy (or (copy-list axiom-sets) - axioms))) - (mapc #'(lambda (axiom-set) - (reset-axiom-set axiom-set axioms)) - axiom-sets-copy) - axiom-sets-copy)) - -;;--------------------------------------------------------------------------- -;; PRINTING OF CLAUSES -;;--------------------------------------------------------------------------- - -(defun ext-rep-clause (clause) - "introduces <- in rules." - (if (and (rest clause) - (not (eq (second clause) '<-))) - `(,(first clause) <- ,@(rest clause)) - clause)) - - -(defun print-clause (clause &optional (label "") (stream *default-dialog-stream*)) - "prints to headed by