/* --- Copyright University of Sussex 1993. All rights reserved. ----------
 > File:            C.all/lisp/src/deftype.p
 > Purpose:         Type specifier expansion
 > Author:          John Williams, Jan 28 1987 (see revisions)
 > Documentation:   CLtL, p50-51
 > Related Files:   C.all/lisp/src/types.p
 */

lisp_compile_mode;

section $-lisp;

define deftype(form) -> name;
	lvars form;
	dlvars body, lamlist, name;

	dest_def_code(form, @TYPE) -> body -> lamlist -> name;
	declare_new_type(name);

	if lamlist == []
	and islistlength(body, 1)
	and (is_constant_value(fast_front(body)) ->> form) then
		form
	else
		/* Make '*' the default default for &OPTIONAL parameters */
		list_*
			(#| while ispair(lamlist) do
					fast_destpair(lamlist) -> lamlist;
					if dup() == @&OPTIONAL then
						while ispair(lamlist) do
							fast_destpair(lamlist) -> lamlist -> form;
							quitif(islamkeysym(form));
							if issymbol(form) then
								[^form [^@QUOTE ^@*]]
							else
								form
							endif
						endwhile
					endif
				endwhile;
				lamlist
			|#) -> lamlist;

		lispFCOMPILE(
			name,
			@TYPE,
			procedure();
				lvars docstring, lab, p;
				fill_function_info(Current_function_info, 1, 1, 1);
				parse_body(body, true, true) -> docstring -> -> body;
				writeable conspair(0, []) -> p;
				sysPUSHS(1);
				sysCALLQ(ispair);
				sysIFSO(sysNEW_LABEL() ->> lab);
				sysPUSHQ(p);
				sysUCALLQ(fast_front);
				sysPUSHQ(p);
				sysLABEL(lab);
				compile_mac_lamlist(lamlist, true);
				compile_body(name, body, 1);
				if docstring then
					docstring -> documentation(name, @TYPE)
				endif
			endprocedure)

	endif -> tpi_xpdr(type_info(name))
enddefine;


endsection;


/* --- Revision History ---------------------------------------------------
--- John Williams, Aug 27 1993
		Now creates unique work pairs for type expansion function.
		Tidied up.
 */
