Module Macros =
Begin

Require 'bliss.req';

! given a raw delimiter, tests whether it is a left brace and
! if so, returns its correspnding right brace.  otherwise 0

Routine LBRACEL(X : Integer) =
Begin
    Return Selectone .X Of Set
	['(']:
	    ')';
	['[']:
	    ']';
	['<']:
	    '>';
	[Otherwise]:
	    0
    Tes
End;

! given a raw delimiter, test whether it is a right brace

Routine RBRACEL(X : Integer) =
Begin
    If .X Eql ')' Or .X Eql '>' Or .X Eql ']' Then
	Return TRUE
    Else
	Return FALSE
End;

! UTILITY ROUTINE TO DETERMINE BRACKETS IN ITERATED MACROS

Routine DETBRACKET(WANTSYM : Boolean) =
Begin
    Local
	X		: Integer;
    Literal
	MACRPLIT	= %o'126',
	MACRSETI	= %o'06',	! SEE 'ONCE.BLI' FOR VALUES
	MACRTESI	= %o'23',
	MACROF		= %o'17';
    Literal
	MACRPLISTO	= '('^16  +')'^8  +',',
	MACRCOMPO	= '('^16  +')'^8  +';',
	MACRSETO	= MACRSETI^16 +MACRTESI^8 +';';

! if a delimiter is wanted (e.g. a symbol has already been gotten)
! and a symbol was gotten...

    If Not .WANTSYM And .SYM Neq NIL Then 

! after a structure name the separator is a ':' in case this is
! a declaration otherwise assume this is a function call and
! use ',' as the separator and '()' and the prefix/postfix.
!
! note: change this when new syntax is introduced.

	If .SYM[gt_type] Eql T_VARIABLE And .SYM[st_code] Eql S_STRUCTURE Then
	    Return ':'
	Else
	    Return MACRPLISTO;

! some special cases:
!
!			sep	prefix	suffix

!	after PLIT:	','	'('	')'
!	after OF	';'	SET	TES
!	after SET	';'
!	after ','	','
!	after ';'	';'

    Selectone .OLDDELI Of Set
	[0,MACRPLIT]:
	    Return MACRPLISTO;
	[MACROF]:
	    Return MACRSETO;
	[MACRSETI]:
	    Return ';';		! PROVIDE YOUR OWN COLONS!
	[',',';']:
	    Return .OLDDELI
    Tes;
    X=.DT[.OLDDELI];
    Case .X<lex_class> From LO_CLASS_TYPE To HI_CLASS_TYPE Of Set
	[CL_DECL]:
	    Return ',';
	[CL_OPER]:
	    Return .OLDDELI;
	[CL_CLOSE]:
	    Return MACRPLISTO;
	[CL_OPEN]:
	    If LBRACEL(.OLDDELI) Neq 0 Then
		Return ','
	    Else
		Return ';'
    Tes
End;

! TAKES AS MANY ACTUALS AS CAN BE BOUND AT
! ONCE IN THE CURRENT MACRO EXPANSION, AND
! BINDS THEM TO FORMALS. ACTBEG IS THE LIST
! OF BOUND PARAMETERS.
!
Routine MACRPICKOFF(ACTBEG : Ref Vector,NUMBER) : Novalue =
Begin
    Incr I From 0 To .NUMBER-1 Do
	Begin
	If params_test_eof() Then
	    Exitloop;
	ACTBEG[.I] = .(params_next())
	End
End;

! collect lexemes for a macro argument up until the given delimiter
!
! returns:
!		0 - error found
!		1 - argument is empty
!		2 - non-empty argument found
!
! notes:
!	this routine is called only when in raw mode.

Global Routine SCANTO(RBRACK : Integer,ERP : Integer,COMMAP : Boolean) =
Begin
    Local
	I		: Integer,
	MATCHRB		: Integer;

! assume argument is empty

    I = 1;

! loop until we reach the delimiter

    While TRUE Do
	Begin

! get a raw symbol and delimiter

	RUND(QL_NAME);

! if the top-level call to SCANTO and DEL was not quoted and is
! the delimiter desired...

	If .COMMAP And Not .flg_quote_del Then 
	    If .DEL Eql ',' Or .DEL Eql .RBRACK Then
		Begin

! save SYM if there is one and return the status

		If .SYM Eql 0 Then
		    Return .I;
		StoreLexeme(prm_buff,SZ_PRM_BUFF,.SYM,0);
		Return 2
		End;

! we have a symbol and delimiter and so save them.  in lower level
! calles to SCANTO the delimiter is save regardless of whether it
! is a closing brace

	I = 2;
	StoreLexeme(prm_buff,SZ_PRM_BUFF,.SYM,.DEL);

! Q: what if DEL was quoted?  we should not be performing any of the
!    tests below.

	If .DEL Eql .RBRACK Then
	    Return 2;

! if DEL is an opening brace then recursively call SCANTO to
! get what is inside the braces.  this allows commas to not
! be interpreted wrongly.

	MATCHRB = LBRACEL(.DEL);
	If .MATCHRB Neq 0 Then
	    Begin
	    If SCANTO(.MATCHRB,.pos_del,FALSE) Eql 0 Then
		Return 0
	    End

! don't allow the foolishness of unbalanced braces.  see question above.

	Else If RBRACEL(.DEL) Neq 0 Then
	    Begin
	    ERRPRNT(.ERP,.pos_del,B11$_UNBALANCED);
	    Return 0
	    End
	End
End;

!+
! routines to save and restore lexical context
!-

Routine SaveLexContext(v : Ref Vector) : Novalue =
Begin
    v[0] = .flg_macro_body;
    v[1] = .mac_v_trace;
    v[2] = .SYM;
    v[3] = .OLDDEL;
    v[4] = .OLDDELI;
    flg_macro_body = TRUE;
    If .mac_v_trace Then
	trace_append(.mac_mode);
    mac_v_trace = FALSE;
    OLDDELI  = 0
End;

Routine RestoreLexContext(v : Ref Vector) : Novalue =
Begin
    While .mac_v_eos And .mac_index Neq 0 Do
	macro_finis();
    flg_macro_body = .v[0];
    mac_v_trace    = .v[1];
    SYM            = .v[2];
    OLDDEL         = .v[3];
    OLDDELI        = .v[4]
End;

!+
! routines to save the restore the argument context
!-

Routine SaveArgContext(v : Ref Vector) : Novalue =
Begin
    v[0] = SZ_STREAM(.arg_buff[strm_size]);
    v[1] = SZ_STREAM(.prm_buff[strm_size]);
    If .v[0] Gtr 0 Then
	v[2] = DUPSPACE(arg_buff,.v[0])
    Else
	v[2] = 0;
    If .v[1] Gtr 0 Then
	v[3] = DUPSPACE(prm_buff,.v[1])
    Else
	v[3] = 0;
    arg_buff[strm_size] = 0;
    arg_buff[strm_next] = 0;
    prm_buff[strm_size] = 0;
    prm_buff[strm_next] = 0
End;

Routine RestoreArgContext(v : Ref Vector) : Novalue =
Begin
    If .v[0] Gtr 0 Then
	Begin
	MOVECORE(.v[2],arg_buff,.v[0]);
	RELEASESPACE(.v[2],.v[0])
	End
    Else
	Begin
	arg_buff[strm_size] = 0;
	arg_buff[strm_next] = 0
	End;
    If .v[1] Gtr 0 Then
	Begin
	MOVECORE(.v[3],prm_buff,.v[1]);
	RELEASESPACE(.v[3],.v[1])
	End
    Else
	Begin
	prm_buff[strm_size] = 0;
	prm_buff[strm_next] = 0
	End
End;

Macro
	NEXTAP		= stream_append(arg_buff,SZ_ARG_BUFF) %,
	NEWNULL		= GETSPACE(1) %;

! D.2: EXPANSION PER SE

!
! SAVE THE OLD LEXICAL ANALYSIS CONTEXT, AND PUSH
! A NEW ONE, WITH APPROPRIATE INITIALIZATION.
!
Global Routine MACRSWAP(MODE,TYPE : Integer,STREAMPOS) : Novalue =
Begin
    Local
	p;

    If .MODE Neq SRC_STRUCTURE And .mac_v_trace Then
	trace_append(.mac_mode);
    p = DUPSPACE(mac_info,SZ_MAC_INFO);
    CLEARCORE(mac_info,SZ_MAC_INFO);
    mac_next    = .p;
    mac_type    = .MODE;
    mac_mode    = .TYPE;
    mac_body    = .STREAMPOS;
    mac_body0   = .STREAMPOS;
    mac_v_trace = .swit_expand
End;

! expand a macro

Global Routine macro_expand_macro(MACSTE : Ref ST,SYMORDEL) : Novalue =
Begin
    Local
	SUBTYPE		: Ref ST,
	PLISTLEN	: Integer,
	PLISTTOP	: Integer,
	PLISTBEG	: Integer,
	SAVPOS		: Integer,
	BRIND		: Integer,
	PARMSEEN	: Integer,
	ctx		: Vector[5],
	arg		: Vector[4],
	RETVAL		: Integer,
	NUMNULL		: Integer,
	MATCHRB		: Integer;
    Label
	aaa;

    SUBTYPE = .MACSTE[st_mac_type];

! if tracing this macro, flush the listing line and bump the tab stop

    If .swit_expand Then
	Begin
	FORCELINE();
	trace_begin()
	End;

! if iterated, determine the delimiters to use

    If .SUBTYPE<MAC_V_ITERATIVE> Then
	BRIND = DETBRACKET(.SYMORDEL)
    Else
	BRIND = 0;

! if the macro has arguments then collect them

    If .SUBTYPE Neq 0 Then
	Begin

! the macro $REMAINDER takes it arguments from its caller

	If .MACSTE Eql .sym_remainder Then
	    Begin
	    If .mac_num_actual Lss .mac_argc Then
		Begin
		PLISTTOP = .mac_argv;
		PLISTBEG = .mac_argv0;
		SAVPOS   = .mac_iarg;
		PLISTLEN = .mac_argc-.mac_num_actual
		End
	    Else
		Begin
		SUBTYPE  = MAC_PASSED;
		PARMSEEN = FALSE
		End
	    End
	Else
	    Begin
	    If .swit_expand Then
		trace_bindings(.MACSTE);
	    SaveArgContext(arg);
	    SaveLexContext(ctx);
	    PARMSEEN = FALSE;
	    PLISTLEN = 0;
	    NUMNULL  = 0;
	    RUND(QL_NAME);

! get the argument delimiter and display an error if the
! delimiter is missing

	    MATCHRB = LBRACEL(.DEL);
	    If .MATCHRB Eql 0 Then
		Begin
		ERRPRNT(.pos_del,.pos_del,B11$_MISSING_ACTUALS,.MACSTE);
		RETVAL = TRUE
		End
	    Else
		aaa: Begin
		OLDDELI = ',';
		RETVAL  = FALSE;
		Do
		    Begin
		    Case SCANTO(.MATCHRB,.pos_del,TRUE) From 0 To 2 Of Set
			[0]:
			    Begin
			    RETVAL = TRUE;
			    Leave aaa
			    End;
			[1]:
			    NUMNULL = .NUMNULL+1; ! NULL STREAM
			[2]:
			    Begin
			    Incr I From 1 To .NUMNULL Do
				NEXTAP = NEWNULL;
			    NEXTAP   = stream_quit(prm_buff);
			    PARMSEEN = TRUE;
			    PLISTLEN = .PLISTLEN+.NUMNULL+1;
			    NUMNULL  = 0
			    End
		    Tes
		    End
		Until .DEL Eql .MATCHRB;
		PLISTTOP = PLISTBEG = stream_quit(arg_buff);
		End;
	    RestoreLexContext(ctx);
	    RestoreArgContext(arg);
	    If .RETVAL Then
		Return
	    End
	End;

! if there were no macros and this is a recursive macro then
! don't expand it

    If .SUBTYPE<MAC_V_RECURSIVE> And Not .PARMSEEN Then
	Begin
	If .swit_expand Then
	    Begin
	    trace_expansion(.MACSTE);
	    trace_null_body(.MACSTE)
	    End;
	Return
	End;

! establish a new stream context

    MACRSWAP(SRC_MACRO,.SUBTYPE,.MACSTE[st_mac_body]);
    mac_name = .MACSTE;

! if a simple macro then we are all done

    If .SUBTYPE Eql MAC_SIMPLE Then
	Begin
	If .swit_expand Then
	    trace_expansion(.MACSTE);
	Return
	End;

! setup for binding parameters

    mac_argv   = .PLISTTOP;
    mac_argv0  = .PLISTBEG;
    mac_length = .PLISTLEN;
    mac_argc   = .PLISTLEN;

! $REMAINDER does not take its own parameter but instead steals
! the parameters of the macro invoking it.  here we note the index
! of the next invoking macros arguments.

    If .mac_name Eql .sym_remainder Then
	mac_iarg = .SAVPOS;

! compute the number of arguments that will be eaten

    mac_num_actual = .MACSTE[st_mac_num_fixed] + .MACSTE[st_mac_num_ited];

! pass macros are all setup now

    If .SUBTYPE Eql MAC_PASSED Then
	Begin
	If .swit_expand Then
	    trace_expansion(.MACSTE);
	Return
	End;

! if too few arguments for an iterated macro then terminate
! the macro now.

    If .SUBTYPE Neq MAC_FIXED And .mac_argc Lss .mac_num_actual Then
	Begin
	mac_v_eos = TRUE;
	mac_mode = MAC_PASSED;
	If .swit_expand Then
	    trace_expansion(.MACSTE);
	Return
	End;

! allocate a stream for the bound actuals

    mac_actuals = GETSPACE(SZ_STREAM(.mac_num_actual));
    mac_actuals[strm_size] = .mac_num_actual;

! now bind the parameters and trace the binding

    MACRPICKOFF(mac_actuals[strm_data(0)],.mac_num_actual);
    If .swit_expand Then
	Begin
	trace_fixed_formals(.MACSTE);
	trace_expansion(.MACSTE)
	End;

! if a fixed macro then we are done

    If .SUBTYPE Eql MAC_FIXED Then
	Begin
	mac_num_actual = .mac_argc;
	Return
	End;

! if a recursive macro then update the recursion depth and then
! we are done.

    If .SUBTYPE Eql MAC_RECURSIVE Then
	Begin
	MACSTE[st_mac_depth] = .MACSTE[st_mac_depth] + 1;
	Return
	End;

! this is the first iteration of an iterative macro

    mac_iteration = 1;

! perform tracing

    If .mac_name Neq .sym_remainder And .swit_expand Then
	Begin
	trace_binding_expansion(.MACSTE);
	trace_iterated_formals(.MACSTE)
	End;

! note the number of fixed and iterative arguments and save the
! iteration delimiters

    mac_num_fixed = .MACSTE[st_mac_num_fixed];
    mac_num_iter = .MACSTE[st_mac_num_ited];
    mac_delim = .BRIND;

! output any opening delimiter

    If .mac_delim[2] Neq 0 Then
	Begin
	PushLexeme(T_DELIMITER,0,.mac_delim[2]);
	If .swit_expand Then
	    trace_separator(.MACSTE,.mac_delim[2])
	End
End;

! expand a macro argument

Global Routine macro_expand_formal(OFFST : Ref ST) : Novalue =
Begin
    Local
	OLDTRACE	: Boolean;

! save the trace bit so we may pass it down

    OLDTRACE = .mac_v_trace;

! ignore the request if not enough arguments were given.  this
! effectively treats the argument as null.

    If .mac_mode Eql MAC_FIXED And .OFFST Gtr .mac_num_actual Then
	Return;

! save the old stream and establish a new stream

    MACRSWAP(SRC_MACRO_ARG,MAC_SIMPLE,.mac_actuals[strm_data(.OFFST-1)]);

! pass down the trace bit

    mac_v_trace  = .OLDTRACE
End;

! POP OR ITERATE
!   CALLED WHEN THE 'STREAM END-OF-FILE' CONDITION
!	IS DISCOVERED BY SCANFOR. FOR ITERATED MACROS,
!	STARTS ANOTHER ITERATION (IF WARRANTED); FOR
!	OTHER MACROS (& STRUCTURES), POPS THE CONTEXT
!	THAT WAS PUSHED BY MACRSWAP.
!
! notes:
!	the future lexeme stack is part of the stream structure.
!	if a separator lexeme is pushed due to an iterated macro
!	then the structure may not be released.

Global Routine macro_finis : Novalue =
Begin
    Local
	OLDTMS,
	pp,
	flg;

! if an iterative macro...

    If .mac_mode<MAC_V_ITERATIVE> Then 
	Begin

! reduce the number of arguments left by the number of arguments
! consumed the last time around.

	mac_argc = .mac_argc - .mac_num_actual;
	If .swit_expand Then
	    trace_end_iteration(.mac_name);

! if not enough arguments for another iteration...

	If .mac_argc Lss .mac_num_iter Then
	    Begin

! at the end of an iterated macro.  if there is a closing delimiter then
! generate it and also make sure we don't come through here again

	    If .mac_delim[1] Neq 0 Then
		Begin
		mac_mode = MAC_RECURSIVE;
		mac_iteration = 0;
		If .swit_expand Then
		    trace_separator(.mac_name,.mac_delim[1]);
		mac_v_eos = FALSE;
		PushLexeme(T_DELIMITER,0,.mac_delim[1]);
		Return
		End
	    End
	Else

! we have enough arguments for another iteration...

	    Begin

! bump iteration count and setup the number of arguments to be
! comsumed by this iteration

	    mac_iteration  = .mac_iteration+1;
	    mac_num_actual = .mac_num_iter;

! bind the next set of arguments

	    MACRPICKOFF(mac_actuals[strm_data(.mac_num_fixed)],.mac_num_iter);

! rewind to the start of the macro body

	    mac_body  = .mac_body0;
	    mac_ibody = 0;
	    mac_v_eos = FALSE;

! if there is a macro separator then generate it

	    If .mac_delim[0] Neq 0 Then
		Begin
		PushLexeme(T_DELIMITER,0,.mac_delim[0]);
		If .swit_expand Then
		    trace_separator(.mac_name,.mac_delim[0])
		End;

! perform tracing

	    If .mac_name Neq .sym_remainder And .swit_expand Then
		Begin
		trace_binding_expansion(.mac_name);
		trace_iterated_formals(.mac_name)
		End;
	    Return
	    End
	End;

! we come here if this is either not an iterated macro or an
! iterated macro which has completed all iterations and has no
! closing delimiter.

! if a recursive macro, reduce the recursion depth

    If .mac_mode Eql MAC_RECURSIVE Then
	mac_name[st_mac_depth] = .mac_name[st_mac_depth]-1;
    If .mac_type Eql SRC_MACRO And .swit_expand Then
	trace_end(.mac_name);

! if this macro had arguments then release them.  note that the
! $REMAINDER macro has arguments but those arguments are actually
! its caller's.

    If .mac_mode Neq 0 And .mac_name Neq .sym_remainder Then
	Begin
	mac_argv = .mac_argv0;
	mac_iarg = 0;
	While Not params_test_eof() Do
	    Begin
	    params_next();
	    stream_release(.mac_argv[.mac_iarg])
	    End;
	stream_release(.mac_argv0);
	If .mac_mode Eql MAC_PASSED Then
	    RELEASESPACE(.mac_actuals,SZ_STREAM(.mac_actuals[strm_size]))
	End;

! if tracing then save the old traced token stream and then release
! the current macro stream.  if the previous macro was traced then
! give this traced tokens to it otherwise chuck it.

    flg = .mac_v_trace;
    OLDTMS = .mac_trace1;
    pp = .mac_next;
    MOVECORE(.pp,mac_info,SZ_MAC_INFO);
    RELEASESPACE(.pp,SZ_MAC_INFO);
    If .flg Then
	Begin
	If .mac_v_trace Then
	    If .mac_mode<MAC_V_ITERATIVE> Then
		mac_trace2 = stream_concat(.mac_trace2,.OLDTMS)
	    Else
		mac_trace1 = stream_concat(.mac_trace1,.OLDTMS)
	Else
	    stream_release(.OLDTMS)
	End
End;

End
Eludom