/* --- Copyright University of Sussex 1990. All rights reserved. ----------
 > File:            C.all/lisp/src/macros.p
 > Purpose:         Macro compilation
 > Author:          John Williams, Nov  7 1985
 > Documentation:   CLtL, p143-152
 > Related Files:   C.all/lisp/src/lamlists.p
 */

lisp_compile_mode;

section $-lisp;

constant procedure (compile_mac_lamlist, dest_def_code);

lconstant macro CURRENT_MACRO_NAME = [f_name(caller(1))];


define lconstant Checkr_macro_arglist(arglist);
	lvars arglist;
	if listp(arglist) then
		fast_back(arglist)
	else
		lisp_error(CURRENT_MACRO_NAME, arglist, 2,
					'Non-list given to macro expander function ~S')
	endif
enddefine;


define lconstant Check_macro_arglist_end(arglist);
	lvars arglist;
	unless arglist == [] do
		lisp_error(CURRENT_MACRO_NAME, arglist, 2,
					'Too many arguments supplied to macro ~S')

	endunless
enddefine;


define lconstant Compile_macro_rarg(var, arglist);
	lvars arglist var;
	checkr_var(var) ->;
	lispPUSH(arglist);
	sysPUSHQ(if listp(var) then var else symbol_string(var) endif);
	sysCALLQ(procedure(arglist, var);
				lvars arglist var;
				if ispair(arglist) then
					fast_destpair(arglist)
				else
					lisp_error(var, CURRENT_MACRO_NAME, 2,
								'Missing ~A argument in ~S form')
				endif
			 endprocedure);
	lispPOP(arglist);
enddefine;


define lconstant Compile_macro_oarg(oarg, arglist) -> var;
	lvars arglist init lab1 lab2 oarg svar var;
	dest_oarg(oarg) -> var -> init -> svar;
	sysNEW_LABEL() -> lab1;
	sysNEW_LABEL() -> lab2;
	lispPUSH(arglist);
	sysCALLQ(ispair);                   ;;; if ispair(arglist) ->> svar then
	if svar then                        ;;;     destpair(arglist) -> arglist
		sysPUSHS(0);                    ;;; else
		sysCALLQ(lisp_true);            ;;;     <init>
		lispLOCAL(svar);                ;;; endif -> var;
		lispPOP(svar)
	endif;
	sysIFNOT(lab1);
	lispPUSH(arglist);
	sysCALLQ(fast_destpair);
	lispPOP(arglist);
	sysGOTO(lab2);
	sysLABEL(lab1);
	compile_form(init, 1);
	sysLABEL(lab2);
enddefine;


define lconstant MacPOP(var);
	lvars var;
	if listp(var) then
		compile_mac_lamlist(var, false)
	else
		lispLOCAL(var);
		lispPOP(var)
	endif
enddefine;


define compile_mac_lamlist(lamlist, env);
	lvars allow_other_keys arglist env lamlist checkend dot kargs
			lamkeysym len var;

	;;; if "env" is true, assume entire macro call-form on stack
	;;; otherwise, argument to match with nested lambda-list on stack
	false ->> checkend ->> dot -> lamkeysym;
	lispNEW_VTOK() -> arglist;
	lispPOP(arglist);
WHOLE:
	if lamlist starts_with @&WHOLE then
		destlamlist(lamlist) -> lamlist -> var -> lamkeysym;
		lispPUSH(arglist);
		lispLOCAL(var);
		lispPOP(var)
	endif;
	if env then
		lispSAVE_STKLEN(true);
		lispPUSH(arglist);
		sysCALLQ(Checkr_macro_arglist);
		lispPOP(arglist);
	endif;
RARGS:
	until atom(lamlist) or islamkeysym(fast_front(lamlist)) do
		fast_destpair(lamlist) -> lamlist -> var;
		Compile_macro_rarg(var, arglist);
		MacPOP(var);
	enduntil;
OARGS:
	if lamlist starts_with @&OPTIONAL then
		@&OPTIONAL -> lamkeysym;
		fast_back(lamlist) -> lamlist;
		until atom(lamlist) or islamkeysym(fast_front(lamlist)) do
			fast_destpair(lamlist) -> lamlist -> var;
			Compile_macro_oarg(var, arglist) -> var;
			MacPOP(var);
		enduntil
	endif;
REST:
	if atom(lamlist) and lamlist /== nil then
		;;; implicit &REST parameter
		true -> dot;
		lispPUSH(arglist);
		lispLOCAL(checkr_var(lamlist));
		lispPOP(lamlist);
	elseif lamlist starts_with @&REST or lamlist starts_with @&BODY then
		destlamlist(lamlist) -> lamlist -> var -> lamkeysym;
		lispPUSH(arglist);
		if lamkeysym == @&BODY and ispair(var) then
			;;; request for declarations and doc-string
			destlist(var) -> len;
			unless len fi_<= 3 do
				lisp_error(var, 1,
							'Malformed macro &BODY parameter specifier')
			endunless;
			sysPUSHQ(len == 3);
			sysPUSHQ(false);
			sysCALLQ(parse_body);
			sysCALLQ(lisp_true);
			fast_repeat 3 - len times
				sysERASE(0)
			endfast_repeat;
			fast_repeat len times
				checkr_var() -> var;
				lispLOCAL(var);
				lispPOP(var)
			endfast_repeat
		else
			MacPOP(var)
		endif
	else
		not(lamkeysym == @&WHOLE) -> checkend
	endif;
KEYS:
	if lamlist starts_with @&KEY then
		false -> allow_other_keys;
		fast_destpair(lamlist) -> lamlist -> lamkeysym;
		[% until atom(lamlist) or islamkeysym(fast_front(lamlist)) do
			fast_destpair(lamlist) -> lamlist
		enduntil %] -> kargs;
		if lamlist starts_with @&ALLOW-OTHER-KEYS then
			fast_destpair(lamlist) -> lamlist -> lamkeysym;
			true -> allow_other_keys
		endif;
		unless kargs == [] do
			lispLOCAL(keyword_count_var);
			lispPUSH(arglist);
			sysCALLQ(destlist);
			sysCALLQ(conskeylist);
			lispPOP(keyword_count_var);
			lispPOP(arglist);
			compile_kargs(kargs, arglist, allow_other_keys)
		endunless;
	elseif checkend then
		lispPUSH(arglist);
		sysCALLQ(Check_macro_arglist_end)
	endif;
	arglist -> lispNEW_VTOK();
ENV:
	if (lamlist starts_with @&ENVIRONMENT) and env /== true then
		destlamlist(lamlist) -> lamlist -> var -> lamkeysym;
		lispPUSH(env);
		lispLOCAL(checkr_var(var));
		lispPOP(var);
		env -> lispNEW_VTOK();
	endif;
AUX:
	if (lamlist starts_with @&AUX) and env then
		fast_destpair(lamlist) -> lamlist -> lamkeysym;
		compile_aux(
			[% until atom(lamlist) or islamkeysym(fast_front(lamlist)) do
				fast_destpair(lamlist) -> lamlist
			enduntil %])
	endif;
END:
	check_lamlist_end(lamlist, lamkeysym, dot)
enddefine;


define compile_macro() with_nargs 1;
	dlvars body lamlist name;
	dest_def_code(@MACRO) -> body -> lamlist -> name;
	lispFCOMPILE(
		name,
		@MACRO,
		procedure();
			lvars docstring env;
			fill_function_info(Current_function_info, 2, 2, 1);
			parse_body(body, true, true) -> docstring -> -> body;
			lispCHECK_NARGS(2, false);
			lispNEW_VTOK() -> env;
			lispPOP(env);
			compile_mac_lamlist(lamlist, env);
			compile_body(name, body, 1);
			if docstring then
				docstring -> documentation(name, @FUNCTION)
			endif
		endprocedure)
enddefine;


endsection;
