! File:   LEXAN.BLI
!
!    This work was supported by the Advanced Research
!    Projects Agency of the Office of the Secretary of
!    Defense (F44620-73-C-0074) and is monitored by the
!    Air Force Office of Scientific Research.
!
Module LEXAN=
Begin
!				LEXAN MODULE
!				------------
!
!                                                       D. WILE
!                                                       C. WEINSTOCK
!
!	THIS MODULE IS THE LEXICAL ANALYZER.  A PRIMARY FUNCTION IS
!	THE HANDLING OF MACRO AND STRUCTURE CREATION AND EXPANSION.
!
!
Require 'Bliss';

Own
	VAL		: Integer,
	MACRNUMBL	: Integer,
	STRING		: Integer,
	ACCUM		: Vector[32,Byte],
	NSSYM		: Ref ST,
	NSPTR		: Ref ST,
	NSDIGITS	: Vector[10,Byte],
	SCHAR		: Integer,
	STYPE		: Integer;

Forward Routine   !IN ORDER OF APPEARANCE
	BLOCKPURGE	: Novalue,
	FSYMPROTECT	: Novalue,
	SKAN1		: Novalue,
	SKAN,
	DETBRACKET,
	STRMCONC,
	STRMPUSH,
	STRMPOP		: Novalue,
	STRMZTOP	: Novalue,
	STRMQUIT,
	STRMAPPEND,
	STRMNEXT,
	STRMTEOF,
	REMNEXT,
	REMTEOF,
	STRMRELEASE	: Novalue,
	RUND		: Novalue,
	SCANFOR		: Novalue,
	FILETAKE	: Novalue,
	STRMTAKE	: Novalue,
	HRUND		: Novalue,
	STRUFTOLEX	: Novalue,
	UNDCLTOLEX	: Novalue,
	QNATOLEX	: Novalue,
	SFCONVERT	: Novalue,
	SFEXPAND	: Novalue,
	LSERROR		: Novalue,
	MACRPICKOFF	: Novalue,
	SCANTO,
	MACRSWAP	: Novalue,
	EMACR		: Novalue,
	EMACRF		: Novalue,
	ESTRU		: Novalue,
	POPORIT,
	STRUCOPY	: Novalue,
	APPEND,
	STRUSC,
	OUTSTR		: Novalue,
	MACRTAPNDP	: Novalue,
	MACRTE		: Novalue,
	MACRTFPO	: Novalue,
	MACRTIV		: Novalue,
	MACRTLPO	: Novalue,
	MACRTPB		: Novalue,
	MACRTPBE	: Novalue,
	MACRTS		: Novalue,
	MACRTV		: Novalue,
	MACRTNULLV	: Novalue,
	OUTMHD		: Novalue;


!I. GENERAL:
!
!	1. THIS ROUTINE DOES A CLEANUP AT THE END OF
!	   A BLOCK.
!
!II. SPECIFIC:
!
!	1. *
!
!		A. DO ALL THE FOLLOWING FOR EACH OF THE HASH 
!		   TABLE ENTRIES.
!
!			1. GET THE THREAD FROM THE HASH TABLE
!			   ENTRY.
!
!			2. FOR EACH SYMBOL WHOSE LEVEL IS THE
!			   SAME AS THE CURRENT BLOCK LEVEL:
!
!				A. CHANGE THE LINK OF THE NAME
!				   TABLE ENTRY TO POINT AT WHAT
!				   THE SYMBOL TABLE ENTRY POINTS
!				   AT.
!
!				B. CHANGE THE HASH TABLE THREAD
!				   TO THE VALUE OF THE THREAD
!				   OF THE SYMBOL TABLE ENTRY.
!
!				C. NOW ADD THE SYMBOL TABLE
!				   ENTRY TO A PURGED LIST. THE
!				   EXTERNAL VARIABLE 'PURGED'
!				   CONTAINS THE LINK OF THE LAST
!				   ENTRY PURGED. SO WE MAKE THIS
!				   ENTRY POINT THE LAST ENTRY
!				   PURGED, AND MAKE 'PURGED'
!				   POINT TO THIS NEWLY PURGED
!				   ENTRY. THUS, PURGED ENTRIES
!				   ARE LINKED THROUGH THEIR
!				   THREAD FIELDS.
!
!		B. FINALLY, DECREMENT THE BLOCKLEVEL.

Global Routine BLOCKPURGE : Novalue =
Begin
    Local
	NEXTSTE		: Ref ST,
	S		: Ref ST;

    If .num_error Gtr 0 Then
	FSYMPROTECT();

! loop for each hash chain

    Incr I From 0 To HTSIZE-1 Do
	Begin

! loop for each entry on the hash chain which is at this
! block level

	S = .HT_THREAD[.I];
	While .S Neqa 0 And .S[st_scope] Eql .BLOCKLEVEL Do
	    Begin

! unbind the symbol and place it on the purge list

	    NT[.S[st_name],nt_symb] = .S[st_prev];
	    HT_THREAD[.I] = NEXTSTE = .S[st_next];
	    S[st_next] = .PURGED;
	    PURGED = .S;

! remove any use and change lists for variables

	    If ISSTVAR(S) And .S[st_var_chg_list] Neqa 0 Then
		Begin
		RELLST(.S[st_var_chg_list]);
		RELLST(.S[st_var_use_list]);
		S[st_var_chg_list] = 0;
		S[st_var_use_list] = 0
		End;
	    S = .NEXTSTE
	    End
	End;
    BLOCKLEVEL = .BLOCKLEVEL-1
End;

!
! PROTECT SYMBOL IN FUTWINDOW FROM THE EFFECTS OF BLOCKPURGE;
! NEEDED BECAUSE OF THE RATHER PECULIAR LOOK-AHEAD NATURE OF
! THE LEXICAL ANALYZER.
!
Global Routine FSYMPROTECT : Novalue =
Begin
    Local
	FUTSYM		: Ref ST;

    FUTSYM = .FUTWINDOW<lex_part>;
    If .FUTSYM<lex_type> Eql T_NAME Then
	Begin
	FUTSYM = .FUTSYM[nt_symb];
	If .FUTSYM[st_scope] Eql .BLOCKLEVEL Then
	    FUTSYM[st_scope] = .BLOCKLEVEL-1
	End
End;

Macro
	range(X,Y)=(.SCHAR Geq X And .SCHAR Leq Y) %,
	FERROR(O,P,N)=(ERRPRNT(O,P,N)) %;

! CHARACTER SCAN ROUTINES
! -----------------------

!
! character class codes:
!	0	digit
!	1	letter
!	2	quote
!	3	punctuation
!	4	white space
!	5	end-of-line
!	6	invalid
!
! note:	digit and letter must be 0,1 respectively.
!

Bind
    TYPETAB = Uplit Byte (
		5,6,6,6,6,6,6,6,6,4,4,6,4,4,6,6,
		6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,
		4,5,6,6,1,7,6,2,3,3,3,3,3,3,3,3,
		0,0,0,0,0,0,0,0,0,0,3,3,3,3,3,6,
		3,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
		1,1,1,1,1,1,1,1,1,1,1,3,3,3,3,1,
		6,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
		1,1,1,1,1,1,1,1,1,1,1,6,6,6,6,6
	) : Vector[,Byte];

!
! CALLED TO GET THINGS GOING AT THE BEGINNING OF A FILE.
!
Global Routine SKAN1 : Novalue =
Begin
    SCHAR = 0;
    STYPE = 5
End;

Routine SKAN =
!
!	THIS ROUTINE DOES THE PRIMARY CHARACTER SCANNING FOR
!	THE COMPILER. THE VALUE RETURNED BY THE ROUTINE IS:
!
!	    0: NO SCANNING PERFORMED
!	    1: <IDENTIFIER> FOUND
!		(THE 10 CHARACTERS ARE IN ACCUM[0:1])
!	    2: <LITERAL> FOUND (VALUE IN VAL)
!	    3: (LONG) STRING FOUND
!		(LENGTH IN ACCUMLENGTH, STRING IN STRING)
!	    4: SPECIAL CHARACTER FOUND
!	    5: (SHORT) STRING FOUND (VALUE IN VAL)
!

Begin

! SCANNER

!
! VERY LOW LEVEL INPUT. GETS A CHARACTER FROM INPUT
! BUFFER ('BUFF', POINTER 'PBUFF'), PUTTING THE CHARACTER
! IN 'CHAR' AND ITS TYPE IN 'TYPE'.
!
    Routine SCANNER : Novalue =
    Begin
	If .SCHAR Eql 0 Then
	    READALINE();
	SCHAR = ch$rchar_a(PBUFF);
	If .SCHAR Eql 9 Then
	    pos_char = .pos_char Or 7;
	pos_char = .pos_char + 1;
	STYPE  =  .TYPETAB[.SCHAR]
    End;

! PRWORD

!
! SCAN FOR A PAIR OF CHARACTERS FOR A STRING,
! AND RETURN 0 IF THE STRING IS TERMINATED.
!

    Routine PRWORD=
    Begin
!
! HANDLE QUOTATION MARKS DURING STRING SCANNING.
!
	Routine GETCH=
	Begin
	    Macro
		DUMMYBIT=1^63 %;

	    If .SCHAR Eql 0 Then
		Begin
		ERRPRNT(0,.pos_atom,ERSYMRQ);
		Return FALSE
		End;
	    If .SCHAR Neq '''' Then
		Return TRUE;
	    SCANNER();
	    If .SCHAR Neq '''' Then
		Return FALSE;
	    SCHAR = .SCHAR Or DUMMYBIT;	! SO TWO CONSECUTIVE CALLS
					! WILL RETURN THE SAME VALUE
	    Return TRUE
	End;

	STRING = 0;
	If Not GETCH() Then
	    Return FALSE;
	STRING = .SCHAR;
	SCANNER();
	If Not GETCH() Then
	    Return FALSE;
	STRING = .STRING Or .SCHAR^8;
	SCANNER();
	Return GETCH()
    End;	! OF PRWORD

! MAIN BODY OF SKAN

    Local
	I,
	INDEX;

!!    CHAR = .SCHAR;
!!    TYPE = .STYPE;
    While TRUE Do
	Begin
	While .STYPE Eql 4 Do
	    SCANNER();
	pos_atom = .pos_char;
	Case .STYPE From 0 To 7 Of Set

	    [0]: ! 0 - DIGITS 0-9
		Begin
		VAL = 0;
		While .STYPE Eql 0 Do
		    Begin
		    VAL = .VAL*10 + .SCHAR-'0';
		    SCANNER()
		    End;
		INDEX = 2;
		Exitloop
		End;

	    [1]: ! 2 - LETTERS
		Begin
		If .SCHAR Eql '$' And .TYPETAB[.PBUFF[0]] Neq 1 Then
		    Begin
		    SCANNER();
		    VAL = '$';
		    INDEX = 4;
		    Exitloop
		    End;
		I = 0;
		Do
		    Begin
		    If .SCHAR Geq 'a' And .SCHAR Leq 'z' Then
			SCHAR = .SCHAR - 32;
		    ACCUM[.I] = .SCHAR;
		    I = .I + 1;
		    SCANNER()
		    End
		While .STYPE Leq 1;
		ACCUM[.I] = 0;
		INDEX = 1;
		Exitloop
		End;

	    [2]: ! 3 - SINGLE OR DOUBLE QUOTE
		Begin
		Local
			SPEC,
			N,
			FSTRHED	: Ref ST,
			PCELL	: Ref ST;

		FSTRHED = 0;
		SCANNER();
		SPEC = PRWORD();
		If .SPEC Then
		    Begin
		    N = 0;
		    FSTRHED = GETCELL(PL_STRING,SZ_PLIT);
		    While TRUE Do
			Begin
			PCELL = NEWBOT(.FSTRHED,PL_LEXEME,SZ_PLIT);
			PCELL[plit_lexeme] = LITLEXEME(.STRING);
			If Not .SPEC Then
			    Exitloop;
			SPEC = PRWORD();
			N = .N + 1
			End;
		    FSTRHED[plit_length] = .N;
		    STRING = 0
		    End;
		If .FSTRHED Neq 0 Then
		    (STRING = .FSTRHED; INDEX = 3)
		Else
		    (VAL = .STRING; INDEX = 5);
		Exitloop
		End;

	    [5]: ! 5 - ! (COMMENT TERMINATED BY EOL)
		Begin
		SCHAR = 0;
		SCANNER()
		End;

	    [7]: ! 6 - % (COMMENT TERMINATED BY ANOTHER %)
		Begin
		Local SAVSCT,SAVSCC;
		SAVSCT = .SCANTYPE;
		SCANTYPE = 'C';
		SAVSCC = .pos_scan;
		pos_scan = .pos_char;
		Do
		    SCANNER()
		Until .SCHAR Eql '%';
		SCANTYPE = .SAVSCT;
		pos_scan = .SAVSCC;
		SCANNER()
		End;

	    [3]: ! 7 - DELIMITER CHARACTER
		Begin
		VAL = .SCHAR;
		SCANNER();
		INDEX = 4;
		Exitloop
		End;

	    [Inrange]:
		0;

	    [6]: ! 15 - IGNORE CHARACTER
		SCANNER()
	Tes
	End;
    Return .INDEX
End;

! NOTE: MACRCOMSEL ALSO APPEARS IN SYNTAX.BLI.

Literal
	MACRCOMSEL=%x'7fffffff';

Bind
	LBRACE = Uplit Byte('{', '[', '<', '(') : Vector[,Byte],
	RBRACE = Uplit Byte(0, '}', ']', '>', ')') : Vector[,Byte];

!
! VALUE RETURNED:
!   IF X IS A LEFT BRACE (IS IN 'LBRACE'), THE
!   CORRESPONDING RIGHT BRACE; OTHERWISE 0.
!
Routine LBRACEL(X : Integer)=
Begin
    Return .RBRACE[1+(Decr I From 3 To 0 Do 
	    If .X Eql .LBRACE[.I] Then Exitloop .I)]
End;

!
! VALUE RETURNED:
!   TRUE IF X IS A RIGHT BRACE (IS IN 'RBRACE');
!   OTHERWISE FALSE.
!
Routine RBRACEL(X : Integer)=
Begin
    Return (1+(Decr I From 4 To 1 Do
	    If .X Eql .RBRACE[.I] Then Exitloop 0))
End;


! UTILITY ROUTINE TO DETERMINE BRACKETS IN ITERATED MACROS

Routine DETBRACKET(WANTSYM : Boolean)=
Begin
    Local
	X		: Integer;
    Literal
	MACRPLIT	=%o'126',
	MACRSETI	=%o'6',	! SEE 'ONCE.BLI' FOR VALUES
	MACRTESI	=%o'23',
	MACRNSETI	=%o'27',
	MACRTESNI	=%o'30',
	MACROF		=%o'17';
    Literal
	MACRCOMMAO=',',
	MACRSEMO  =';',
	MACRCOLONO=':',
	MACRPLISTO='('^16  +')'^8  +',',
	MACRCOMPO ='('^16  +')'^8  +';',
	MACRSETO  =MACRSETI^16 +MACRTESI^8 +';',
	MACRNSETO =MACRNSETI^16+MACRTESNI^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 TK_EMPTY 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.

	If .SYM<lex_type> Eql T_SYMBOL And .SYM[gt_type] Eql S_STRUCTURE Then
	    Return MACRCOLONO
	Else
	    Return MACRPLISTO;

! some special cases:
!
!			sep	prefix	suffix

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

    Selectone .OLDDELI Of Set
	[0,MACRPLIT]:
	    Return MACRPLISTO;
	[MACROF]:
	    Return MACRSETO;
	[MACRSETI,MACRNSETI]:
	    Return MACRSEMO;	! PROVIDE YOUR OWN COLONS!
	[MACRCOMSEL]:
	    Return MACRNSETO;
	[',',';']:
	    Return .OLDDELI
    Tes;
    X=.DT[.OLDDELI];
    Case .X<lex_class> From LO_CLASS_TYPE To HI_CLASS_TYPE Of Set
	[DCLRTR]:
	    Return MACRCOMMAO;
	[OP]:
	    Return .OLDDELI;
	[CLOBRAC]:
	    Return MACRPLISTO;
	[OPENBRAC]:
	    If LBRACEL(.OLDDELI) Neq 0 Then
		Return MACRCOMMAO
	    Else
		Return MACRSEMO
    Tes
End;

! STREAM MANAGEMENT ROUTINES

Routine STRMCONC(FIRST : Ref Vector,SECOND : Ref Vector) =
Begin
    Local
	POINT		: Ref Vector;

    If .FIRST Eql 0 Then
	Return .SECOND;
    POINT = .FIRST;
    Until .POINT[strm_next] Eqla 0 Do
	POINT = .POINT[strm_next];
    POINT[strm_next] = .SECOND;
    Return .FIRST
End;

Routine STRMPUSH(STKADD : Ref Vector) =
Begin
    Local
	SPACE		: Ref Vector,
	LEN		: Integer;

    LEN = .STKADD[strm_size]+SZ_STREAM;
    SPACE = GETSPACE(.LEN);
    MOVECORE(.STKADD,.SPACE,.LEN);
    STKADD[strm_next] = .SPACE	! NOTE: LENGTH NOT CHANGED
End;

Global Routine STRMPOP(STKADD : Ref Vector) : Novalue =
Begin
    Local
	SPACE		: Ref Vector,
	LEN		: Integer;

    SPACE = .STKADD[strm_next];
    LEN = .SPACE[strm_size]+SZ_STREAM;
    MOVECORE(.SPACE,.STKADD,.LEN);
    RELEASESPACE(.SPACE,.LEN)
End;

Routine STRMZTOP(STKADD : Ref Vector) : Novalue =
Begin
    CLEARCORE(STKADD[strm_data(0)],.STKADD[strm_size])
End;

!
! DETACH A STREAM FROM ITS BASE
!	AND RESET THE BASE TO EMPTINESS;
! REVERSE POINTERS IN THE STREAM
!	AND RETURN THE NEW BASE AS VALUE.
!
Global Routine STRMQUIT(STKADD : Ref Vector) =
Begin
    Local
	CURRENT		: Ref Vector,
	NEXT		: Ref Vector,
	TEMP		: Ref Vector;

    CURRENT = 0;
    NEXT = STRMPUSH(.STKADD);
    Do
	Begin
	TEMP = .NEXT[strm_next];
	NEXT[strm_next] = .CURRENT;
	CURRENT = .NEXT;
	NEXT = .TEMP
	End
    While .NEXT Neqa 0;
    STKADD[strm_next] = 0;
    STKADD[strm_size] = 0;
    Return .CURRENT
End;

Global Routine STRMAPPEND(STKADD : Ref Vector,Max) =
Begin
    If .STKADD[strm_size] Eql .Max Then
	Begin
	STRMPUSH(.STKADD);
	STKADD[strm_size] = 1
	End
    Else
	STKADD[strm_size] = .STKADD[strm_size] + 1;
    Return STKADD[strm_data(.STKADD[strm_size]-1)]
End;

Routine STRMNEXT =
Begin
    STRMPOS = .STRMPOS+1;
    If .STRMPOS Gtr WSTMAX-1 Then
	Begin
	STRMPOS = 1;
	STRMTOP = .STRMTOP[strm_next]
	End;
    Return STRMTOP[strm_data(.STRMPOS-1)]
End;

Routine STRMTEOF =
Begin
    If .STRMPOS Eql .STRMTOP[strm_size] Then
	Return (.STRMTOP[strm_next] Eqla 0)
    Else
	Return FALSE
End;

Routine REMNEXT =
Begin
    REMPOS = .REMPOS+1;
    If .REMPOS Gtr APLMAX-1 Then
	Begin
	REMPOS = 1;
	REMTOP = .REMTOP[strm_next]
	End;
    Return REMTOP[strm_data(.REMPOS-1)]
End;

Routine REMTEOF =
Begin
    If .REMPOS Eql .REMTOP[strm_size] Then
	Return (.REMTOP[strm_next] Eqla 0)
    Else
	Return FALSE
End;

Global Routine STRMRELEASE(CURRENT : Ref Vector) : Novalue =
Begin
    Local
	NEXT		: Ref Vector;

    If .CURRENT Eqla 0 Then
	Return;
    Do
	Begin
	NEXT = .CURRENT[strm_next];
	RELEASESPACE(.CURRENT,.CURRENT[strm_size]+SZ_STREAM);
	CURRENT = .NEXT
	End
    While .CURRENT Neqa 0
End;


! MAIN LEXICAL ANALYZER
! ---------------------

!
! CALLED WHEN THE TRACE BIT IS ABOUT TO BE SAVED AND RESET
! (CALLED FROM MACRSWAP,DETREMAIN,SFSTRING,SFNAME)
!
! MAKES SURE THE TRACE OUTPUT STREAM IS IN GOOD SHAPE FOR
! THIS CHANGE.
!
Macro NOTETRACE=
		If .TRACEBIT Then
		    If .SUBTYPE<MAC_V_ITERATIVE>
			Then MACRTAPNDP(ITMS,FALSE)
			Else MACRTAPNDP(TMS,FALSE)   %;

Macro TRYSTREAMPOP(DUMMY)=
		While .STRMEOF Do
		    If POPORIT() Then
			Exitloop  %;

Macro MACRTRUND(S,D)=
		STRMAPPEND(MTBUF,MTMAX-1) = FORMWINDOW(S,D) %;


Global Routine RUND(QUOTELEVEL) : Novalue =
Begin
    Literal
	SYMBOL=TRUE,
	DELIMITER=FALSE;

    If .PEEKBIT Then
	Begin
	PEEKBIT = FALSE;
	Return
	End;
    QUOTE_SYM = FALSE;
    QUOTE_DEL = FALSE;
    OLDDEL = .DEL;
    SCANFOR(SYMBOL,.QUOTELEVEL);
    If .TRACEBIT Then
	MACRTRUND(.SYM,.SYM<lex_type>,0);
    If .EXPANDERR Then
	Begin
	EXPANDERR = 0;
	OLDDELI = .DEL;
	DEL = .DT[.DEL];
	HRUND();
	Return
	End;
     SCANFOR(DELIMITER,.QUOTELEVEL);
     If .TRACEBIT Then
	If .MTBUF[strm_size] Eql 0 Then
	    MACRTRUND(TK_EMPTY,0,.DEL)
	Else
	    Begin
	    Bind X = MTBUF[strm_data(.MTBUF[strm_size]-1)];
	    X<lex_delim> = .DEL
	    End;
    If .MACRCP Then
	Return;
    If .STRUCP Then
	STRUCOPY();
    RESWD = .DEL<lex_reswd>;
    DEL<lex_reswd> = 0;
    OLDDELI = .DEL;
    DEL = .DT[.DEL];
    HRUND()
End;

Global Routine SCANFOR(SYMORDEL, QUOTELEVEL) : Novalue =
Begin
    Local
	S		: Ref ST,
	N		: Integer,
	TSYM		: Ref ST;
    Macro
	FILLSYM=
		Begin
		If .QUOTED Then
		    (QUOTED = FALSE; QUOTE_SYM = TRUE);
		SYM = .FUTWINDOW<lex_part>;
		TAKE
		End %,
	FILLDEL=
		Begin
		If .QUOTED Then
		    (QUOTED = FALSE; QUOTE_DEL = TRUE);
		DEL = .FUTWINDOW<lex_delim>;
		TAKE
		End %,
	TAKE=
		If .STREAMIN Then STRMTAKE() Else FILETAKE() %;

    While TRUE Do
	Begin
	TRYSTREAMPOP(0);

! if no symbol, just return the delimiter

	If Not .ATOMISSYM Then
	    Begin
	    If .SYMORDEL Then
		SYM = TK_EMPTY
	    Else
		FILLDEL;
	    Return
	    End;

! determine what we might be binding to

	Select .FUTWINDOW<lex_type> Of Set
	    [T_NAME]:
		Begin
		TSYM = .NT[.FUTWINDOW<lex_part>,nt_symb];
		N = 1
		End;
	    [T_SYMBOL]:
		Begin
		TSYM = .FUTWINDOW<lex_part>;
		N = 1
		End;
	    [Otherwise]:
		N = 0
	Tes;

! if binding enabled and there is something to bind to

	If Not .QUOTED And .N Then
	    Begin

! determine the quote level at which binding may occur

	    N = 0;
	    Selectone .TSYM[gt_type] Of Set
		[S_MACRO]:
		    If .QUOTELEVEL Lss T_MACRO Then
			N = T_MACRO;
		[S_LEX_CONV]:
		    If .QUOTELEVEL Lss T_LEX_CONV Then
			N = T_LEX_CONV;
		[S_LEX_EXPAND]:
		    If .QUOTELEVEL Lss T_LEX_EXPAND Then
			N = T_LEX_EXPAND
	    Tes;
	    If .N Gtr 0 Then
		Begin
		FUTWINDOW<lex_addr> = .TSYM;
		FUTWINDOW<lex_type> = .N
		End
	    End;

! if the symbol is to be quoted

	If .QUOTELEVEL Geq .FUTWINDOW<lex_type> Then
	    Begin
	    If .SYMORDEL Then
		FILLSYM
	    Else
		DEL = 0;
	    Return
	    End;
	If .FUTWINDOW<lex_type> Eql T_LEX_EXPAND Then
	    If .ST[.FUTWINDOW<lex_part>,st_which] Eql 3 Then
		Begin
		If .SYMORDEL Then
		    Begin
		    FILLSYM;
		    SFCONVERT(.SYM,.QUOTELEVEL)
		    End
		Else
		    DEL = 0;
		Return
		End;

! SPECIAL FUNCTION UNQUOTE GLITCH

	N = .FUTWINDOW<lex_type>;
	If .N Leq QL_LEX_CONVERT Then
	    Begin
	    If .SYMORDEL Then
		Begin
		FILLSYM;
		Selectone .N Of Set
		    [T_STRUCT_ARG]:
			STRUFTOLEX();
		    [T_STRING_L]:
			LSERROR();
		    [T_STRING_S]:
			SYM<lex_type> = T_LITERAL;
		    [T_LEX_CONV]:
			SFCONVERT(.SYM,.QUOTELEVEL);
		    [Otherwise]:
			QNATOLEX()
		Tes
		End
	    Else
		DEL = 0;
	    Return
	    End;
	If .QUOTED Then
	    (QUOTED = FALSE; QUOTE_SYM = TRUE);
	S = .FUTWINDOW<lex_part>;
	TAKE;
	Select .S<lex_type> Of Set
	    [T_MACRO]:
		EMACR(.S,.SYMORDEL);
	    [T_MACRO_ARG]:
		EMACRF(.S);
	    [T_LEX_EXPAND]:
		SFEXPAND(.S)
	Tes
	End
End;

! B. TAKES

Routine FILETAKE : Novalue =
Begin
    If .ATOMISSYM Then
	pos_sym = .pos_atom
    Else
	pos_del = .pos_atom;
    Case SKAN() From 0 To 5 Of Set
	[0]:
	    0;

	[1]: ! IDENTIFIER OR RESERVED WORD
	    Begin
	    Local
		LEX	: Ref ST,
		NAME	: Ref NT;

	    NAME = SEARCH(ACCUM,S_UNDECLARE);
	    LEX = .NAME[nt_symb];
	    If .LEX[gt_type] Eql S_DELIMITER Then
		Begin
		ATOMISSYM = FALSE;
		FUTWINDOW<lex_delim> = .LEX[st_which];
		FUTWINDOW<lex_reswd> = TRUE
		End
	    Else
		Begin
		ATOMISSYM = TRUE;
		FUTWINDOW = FASTLEXOUT(T_NAME,.NAME)
		End
	    End;

	[2]: ! LITERALS
	    Begin
	    FUTWINDOW = LITLEXEME(.VAL);
	    ATOMISSYM = TRUE
	    End;

	[3]: ! LONG STRING
	    Begin
	    FUTWINDOW = LEXOUT(T_STRING_L,.STRING);
	    ATOMISSYM = TRUE
	    End;
         
	[4]: ! OPERATOR OR BRACKET CHARACTER
	    Begin
	    ATOMISSYM = FALSE;
	    FUTWINDOW<lex_delim> = .VAL
	    End;

	[5]: ! SHORT STRING
	    Begin
	    FUTWINDOW = LEXOUT(T_STRING_S,.VAL);
	    ATOMISSYM = TRUE
	    End
    Tes
End;

Routine STRMTAKE : Novalue =
Begin
    If .ATOMISSYM And .FUTWINDOW<lex_delim> Neq 0 Then
	Begin
	ATOMISSYM = FALSE;
	Return
	End;
    If STRMEOF = STRMTEOF() Then
	Return;
    FUTWINDOW = .(STRMNEXT());
    If .FUTWINDOW<lex_type> Eql T_WANT_SYM Then
	Begin
	FUTWINDOW<lex_addr> = .NT[.FUTWINDOW<lex_part>,nt_symb];
	FUTWINDOW<lex_type> = T_SYMBOL
	End;
    ATOMISSYM = .FUTWINDOW<lex_type> Neq 0
End;

! C. CONVERSIONS

Routine HRUND : Novalue =
Begin
    If .SYM Neq TK_EMPTY Then
	Begin
	If .SYM<lex_type> Eql T_SYMBOL Then
	    If .SYM[st_scope] Lss .RBLOCKLEVEL Then
		If ISEXP(SYM) Then
		    If .SYM[st_v_nouplevel] Then
			Begin
			WARNEM(.pos_sym,ERUPLVL);
			SYM = ZERO
			End
	End

! TRUE IF .OLDDEL IS ')',']','>',OR 'END'

    Else If .OLDDEL Lss TK_END Or .OLDDEL Gtr TK_RBRACKET Then
	Begin
	Selectone .DEL Of Set
	    [TK_CALL]:
		Begin
		DEL = TK_LPAREN;
		OLDDELI = (If .flg_plit Then ',' Else ';')
		End;
	    [TK_MINUS]:
		DEL = TK_NEG;
	    [TK_ADD]:
		DEL = TK_PLUS
	Tes;
	Return
	End;
    Selectone .DEL Of Set
	[TK_WHILE]: DEL = TK_WHILE2;
	[TK_UNTIL]: DEL = TK_UNTIL2;
	[TK_DO]:    DEL = TK_DO2
    Tes
End;

!
! CHANGE THE STRUCTURE FORMAL IN SYM
! TO A 'REAL' LEXEME.
!
Routine STRUFTOLEX : Novalue =
Begin
    Local
	PAR		: Ref GT;

    SYM = .STRUACT[.SYM<lex_addr>+1];
    If .SYM<lex_type> Eql T_NODE Then
	SYM = FAKECSE(.SYM);
    UNDCLTOLEX()
End;

!
! CHANGE THE UNDECLARED SYMBOL IN SYM
! TO A 'DECLARED' EXTERNAL SYMBOL,
! AND COMPLAIN TO THE PROGRAMMER.
!
Routine UNDCLTOLEX : Novalue =
Begin
    If .SYM<lex_type> Eql T_SYMBOL Then
	If .SYM[gt_type] Eql S_UNDECLARE Then
	    Begin
	    SYM = STINSERT(.SYM[st_name],S_EXTERNAL,0);
	    SYM<lex_type> = T_SYMBOL;
	    DEFASYM(.SYM,2,0,16);
	    DEFMAP(.SYM);
	    SYM[st_var_linkage] = .sym_bliss;
	    PEXTERNAL(0,2,.SYM);
	    SYM[st_v_unlim_acts] = TRUE;
	    If Not .ERRLEVEL Then
		WARNEM(.pos_sym,IDERR)
	End
End;

!
! CHANGE THE QUOTED NAME IN SYM TO A 'REAL' LEXEME.
!
Global Routine QNATOLEX : Novalue =
Begin
    If .SYM<lex_type> Eql T_NAME Then
	Begin
	SYM<lex_addr> = .SYM[nt_symb];
	SYM<lex_type> = T_SYMBOL
	End;
     UNDCLTOLEX()
End;

Routine SFCONVERT(S : Ref ST,QUOTELEVEL) : Novalue =
Begin
    Macro
	ODDCHAR(X)=((X)^(-8)) %, EVENCHAR(X)=((X) And 255) %;
    Literal
	SYMBOL=1,
	DELIMITER=0;
    Own
	QL;

    Routine SFASCII(LEX)=
    Begin
	Return .LEX
    End;

    Routine SFASCIZ(LEX : Ref GT)=
    Begin
	Local
	    SHEAD	: Ref ST,
	    PCELL	: Ref ST;

	If .LEX<lex_type> Eql T_LITERAL Then
	    If ODDCHAR(.LEX<lex_value>) Eql 0 Then
		Return .LEX
	    Else
		Begin
		SHEAD = GETCELL(PL_STRING,SZ_PLIT);
		SHEAD[plit_length] = 1;
		PCELL = NEWBOT(.SHEAD,PL_LEXEME,SZ_PLIT);
		PCELL[plit_lexeme] = .LEX
		End
	Else
	    Begin
	    SHEAD = .LEX<lex_addr>;
	    If .ST[.SHEAD[cel_bot],plit_lbyte] Eql 0 Then
		Return .LEX
	    End;
	PCELL = NEWBOT(.SHEAD,PL_LEXEME,SZ_PLIT);
	PCELL[plit_lexeme] = LITLEXEME(0);
	SHEAD[plit_length] = .SHEAD[plit_length]+1;
	Return LEXOUT(T_STRING_L,.SHEAD)
    End;

    Routine SFRADIX50(LEX : Ref GT)=
    Begin
	Local
	    NHEAD	: Ref ST,
	    PCELL	: Ref ST,
	    T;
	Own
	    SHEAD	: Ref ST,
	    ATLEFT,
	    CURRENT	: Ref ST;
	Macro
	    NOTEOF=(.CURRENT Neq .SHEAD) %,
	    NEXTIN=
		Begin
		If NOTEOF Then
		    If .ATLEFT Then
			Begin
			V = .CURRENT[plit_lbyte];
			ATLEFT = FALSE;
			CURRENT = .CURRENT[cel_next];
			.V
			End
		    Else
			Begin
			ATLEFT = TRUE;
			V = .CURRENT[plit_rbyte];
			If .CURRENT[plit_lbyte] Eql 0 Then
			    If .CURRENT[cel_next] Eql .SHEAD Then
				CURRENT = .SHEAD;
			.V
			End
		Else
		    0
		End %,
	    R50IN=R50CHAR(NEXTIN) %;

	Routine R50CHAR(CHAR)=
	Begin
	    If range('0','9') Then
		Return 30+.CHAR-'0'
	    Else If range('A','Z') Then
		Return 1+.CHAR-'A'
	    Else If .CHAR Eql '$' Then
		Return 27
	    Else If .CHAR Eql '.' Then
		Return 28
	    Else If .CHAR Eql ' ' Then
		Return 0
	    Else If .CHAR Eql 0 Then
		Return 0
	    Else
		Begin
		WARNEM(.pos_sym,WABADRAD50);
		Return 0
		End
	End;

	Routine R50WORD=
	Begin 
	    Local N, V;

	    N = 0;
	    Incr I From 0 To 2 Do
		N = 40*.N+R50IN;
	    Return LITLEXEME(.N)
	End;

	If .LEX<lex_type> Eql T_LITERAL Then
	    Begin
	    T = .LEX<lex_value>;
	    Return LITLEXEME(
			(R50CHAR(EVENCHAR(.T))*40+R50CHAR(ODDCHAR(.T)))*40)
	    End;
	SHEAD = .LEX<lex_addr>;
	CURRENT = .SHEAD[cel_top];
	ATLEFT = FALSE;
	If .SHEAD[plit_length] Eql 2 Then
	    If .ST[.SHEAD[cel_bot],plit_lbyte] Eql 0 Then
		Return R50WORD();
	NHEAD = GETCELL(PL_STRING,SZ_PLIT);
	NHEAD[plit_length] = 0;
	Do
	    Begin
	    PCELL = NEWBOT(.NHEAD,PL_LEXEME,SZ_PLIT);
	    PCELL[plit_lexeme] = R50WORD();
	    NHEAD[plit_length] = .NHEAD[plit_length]+1
	    End
	While NOTEOF;
	Return LEXOUT(T_STRING_L,.NHEAD)
    End;


    Routine SFUNQUOTE : Novalue =
    Begin
	SCANFOR(SYMBOL,.QL);
	If .SYM<lex_type> Eql T_NAME Then
	    Begin
	    SYM<lex_addr> = .SYM[nt_symb];
	    SYM<lex_type> = T_SYMBOL
	    End;
	Return .SYM
    End;

    Forward Routine
	GETNSCHARS, GETNSARG;
    Macro
	INITNS=
		Local SAVT,SAVOD,SAVSTCP,SAVMACP;
		Bind SUBTYPE=MACRSUBTYPE;
		SAVT = .TRACEBIT;
		SAVOD = .OLDDEL;
		SAVSTCP = .STRUCP;
		SAVMACP = .MACRCP;
		NOTETRACE;
		TRACEBIT = FALSE;
		STRUCP = FALSE;
		MACRCP = FALSE;
		SCANFOR(DELIMITER,QL_LEXEME);
		If .DEL Neq '(' Then ;		! ERROR
		OLDDELI = ','  %;
    Macro
	WINDUPNS=
		TRACEBIT = .SAVT;
		OLDDEL = .SAVOD;
		STRUCP = .SAVSTCP;
		MACRCP = .SAVMACP %;

    Routine SFNAME : Novalue =
    Begin
	Local
	    NAMEND	: Ref NT,
	    NAME	: Vector[32,Byte],
	    PNAME	: Ref Vector[,Byte],
	    I,
	    CHAR;

	INITNS;

	I = 0;
	NSPTR = 0;
	Do
	    Begin
	    NAMEND = GETNSCHARS(CHAR,1);
	    If .NAMEND Eql 2 Then
		Exitloop;	! ERROR HAS OCCURRED
	    If .I Lss 32 Then
		Begin
		NAME[.I] = .CHAR;
		I = .I + 1
		End
	    Else
		Begin
		Until .DEL Eql TK_RPAREN Do
		    RUND(QL_STRING_S);
		Exitloop
		End
	    End
	Until .NAMEND;
	NAME[.I] = 0;
	If .NAMEND Neq 2 Then
	    Begin
	    SYM = SEARCH(NAME,S_UNDECLARE);
	    SYM = FASTLEXOUT(T_NAME,.SYM);
	    If .QL Lss QL_NAME Then QNATOLEX();
	    End;
	WINDUPNS;
	Return .SYM
    End;

    Routine SFSTRING : Novalue =
    Begin
	Local
	    TWOCHARS	: Integer,
	    LENGTH	: Integer,
	    FSTRHED	: Ref ST,
	    PCELL	: Ref ST,
	    STRNGEND;

	INITNS;
	FSTRHED = 0;
	LENGTH = 0;
	NSPTR = 0;
	Do
	    Begin
	    STRNGEND = GETNSCHARS(TWOCHARS,2);
	    If .STRNGEND Eql 2 Then
		Exitloop;	! ERROR HAS OCCURRED
	    If .FSTRHED Eql 0 Then
		If .STRNGEND Then
		    Begin
		    SYM = LEXOUT(If .QL Lss QL_STRING_S Then T_LITERAL Else T_STRING_S,
					.TWOCHARS);
		    WINDUPNS;
		    Return .SYM
		    End
		Else
		    FSTRHED = GETCELL(PL_STRING,SZ_PLIT);
	    LENGTH = .LENGTH + 1;
	    PCELL = NEWBOT(.FSTRHED,PL_LEXEME,SZ_PLIT);
	    PCELL[plit_lexeme] = LITLEXEME(.TWOCHARS)
	    End
	Until .STRNGEND;
	If .STRNGEND Neq 2 Then
	    Begin
	    FSTRHED[plit_length] = .LENGTH;
	    SYM = FASTLEXOUT(T_STRING_L,.FSTRHED)
	    End;
	WINDUPNS;
	Return .SYM
    End;

    Own
	NSCOUNT,
	NSLEFT;

    Routine GETNSCHARS(DEST,COUNT)=
    Begin
	.DEST = 0;
	Incr I To (.COUNT-1) Do
	    Begin
	    If .NSPTR Eql 0 Then
		If .DEL Eql TK_RPAREN Then
		    Return TRUE
		Else If GETNSARG() Then
		    Return 2;
	    Case .NSSYM<lex_type> From 0 To T_STRING_S Of Set
		[ 0 ]:
		    0;

		[ T_LITERAL ]:
		    Begin
		    If (NSCOUNT = .NSCOUNT+1) Eql 6 Then
			NSCOUNT = 0
		    End;

		[ T_SYMBOL, T_NODE, T_ERROR ]:
		    0;

		[ T_STRING_L ]:
		    Begin
		    If Not .NSLEFT Then
			Begin
			If .NSPTR[plit_lbyte] Eql 0 Then
			    NSPTR = 0
			End
		    Else
			Begin
			If (NSPTR = .NSPTR[cel_next]) Eql .NSSYM<lex_addr> Then
			    NSPTR = 0
			End;
		    NSLEFT = Not .NSLEFT
		    End;

		[ T_STRING_S ]:
		    Begin
		    If Not .NSLEFT Then
			Begin
			NSPTR = ODDCHAR(.NSPTR)
			End
		    Else
			Begin
			NSPTR = 0
			End;
		    NSLEFT = Not .NSLEFT
		    End

	    Tes
	    End;	! OF LOOP
	Return (.NSPTR Eql 0) And (.DEL Eql TK_RPAREN)
    End;	! OF GETNSCHARS

!
! SCAN FOR ANOTHER ARGUMENT FOR  %NAME OR  %STRING;
! PUT INFORMATION ABOUT IT IN NSSYM, NSPTR(NSCOUNT),
! AND NSLEFT(NSDIGITS).  RETURN TRUE IF
! SCAN WAS UNSUCCESSFUL (DUE TO ERRORS).
!
    Routine GETNSARG=
    Begin
	Label
	    aaa;

	While 1 Do
	    aaa: Begin
	    RUND(QL_STRING_S);
	    If .DEL Neq TK_COMMA And .DEL Neq TK_RPAREN Then
		Begin
		ERRORR(PARAERR,PSPAR,.pos_del,.pos_del);
		Return TRUE
		End;
	    SYM = BINDBIND(.SYM);
	    If Not ONEOF(.SYM<lex_type>,T_LITERAL,T_STRING_L,T_STRING_S) Then
		Begin
		WARNEM(.pos_sym,WILLNSARG);
		If .DEL Eql TK_RPAREN Then
		    Return TRUE;
		Leave aaa
		End;
	    NSSYM = .SYM;
	    Case .SYM<lex_type> From 0 To T_STRING_S Of Set
		[ 0 ]:
		    0;

		[ T_LITERAL ]:
		    Begin
		    If (SYM = .SYM<lex_value>) Eql 0 Then
			Begin
			NSDIGITS[4] = '0';
			NSCOUNT = 5;
			Return FALSE
			End;
		    NSCOUNT = (Decr I From 5 To 1 Do
				Begin
				NSDIGITS[.I-1] = (.SYM Mod 10)+'0';
				If (SYM = .SYM/10) Eql 0 Then
				    Exitloop .I
				End)
		    End;

		[ T_SYMBOL, T_NODE, T_ERROR ]:
		    0;

		[ T_STRING_L ]:
		    Begin
		    NSPTR = .NSSYM[cel_top];
		    NSLEFT = FALSE
		    End;

		[ T_STRING_S ]:
		    Begin
		    NSPTR = .NSSYM<lex_value>;
		    NSLEFT = FALSE
		    End
	    Tes;
	    Return FALSE
	    End
    End;

    Routine SFCOUNT : Novalue =
    Begin
	Local
	    N		: Integer;
	Bind
	    SUBTYPE	= MACRSUBTYPE;

	N = (If .SUBTYPE Eql MAC_RECURSIVE Then .MACRNAME[st_mac_depth] Else .MACRITCOUNT);
	Return LITLEXEME(.N-1)
    End;

    Routine SFLENGTH : Novalue =
    Begin
	Return LITLEXEME(.MACRLENGTH)
    End;

! ACTUAL BODY OF SFCONVERT

    Local
	SFIND;
    Own
	SPECF	: Vector[8]
		  Initial(SFASCII,SFASCIZ,SFRADIX50,SFUNQUOTE,
			SFNAME,SFSTRING,SFCOUNT,SFLENGTH);

    QL = .QUOTELEVEL;
    SFIND = .S[st_which];
    If .SFIND Leq 2 Then		! LONG STRING CONVERSIONS
	Begin
	SCANFOR(SYMBOL,QL_STRING_L);
	If Not ONEOF(.SYM<lex_type>,T_LITERAL,T_STRING_L) Then
	    Begin
	    WARNEM(.pos_sym,ERNEEDLS);
	    Return
	    End
	End;
    SYM = Bliss(.SPECF[.SFIND],.SYM);
    If .QL Lss .SYM<lex_type> Then
	LSERROR()
End;

Routine SFEXPAND(S : Ref ST) : Novalue =
Begin

    Routine SFQUOTE : Novalue =
    Begin
	QUOTED = TRUE
    End;

    Routine SFREMAINING : Novalue =
    Begin
	0			! FERROR(.pos_sym,.pos_sym,NOTIMPL)
    End;

    Own
	SFJUMP	: Vector[2] Initial(SFQUOTE,SFREMAINING);

    Bliss(.SFJUMP[.S[st_which]])
End;

Routine LSERROR : Novalue =
Begin
    WARNEM(.pos_atom,ERILSUSE);
    SYM = ZERO
End;

! D. EXPANDERS

! D.1: ACTUAL PARAMETER ROUTINES

!
! 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 REMTEOF() Then
	    Exitloop;
	ACTBEG[.I] = .(REMNEXT())
	End
End;

Macro
	APPENDSYM=
		(If .SYM Neq 0 Then STRMAPPEND(WSTBUF,WSTMAX-1) = .SYM) %,
	APPENDWIND=
		STRMAPPEND(WSTBUF,WSTMAX-1) = FORMWINDOW(.SYM,.DEL) %;

Routine SCANTO(RBRACK,ERP,COMMAP)=
Begin
    Local
	MATCHRB;

    Incr I Do
	Begin
	RUND(QL_NAME);
	If .COMMAP And Not .QUOTE_DEL Then 
	    If .DEL Eql ',' Or .DEL Eql .RBRACK Then
		If .SYM Eql 0 Then
		    Return .I
		Else
		    Begin
		    APPENDSYM;
		    Return 1
		    End;
	APPENDWIND;
	If .DEL Eql .RBRACK Then
	    Return 1;
	If (MATCHRB = LBRACEL(.DEL)) Neq 0 Then
	    Begin
	    If SCANTO(.MATCHRB,.pos_del,0) Lss 0 Then
		Return -1
	    End
	Else If RBRACEL(.DEL) Neq 0 Then
	    Begin
	    FERROR(.ERP,.pos_del,ERMFPL);
	    Return -1
	    End
	End
End;

Macro
	NEXTAP=STRMAPPEND(APLBUF,APLMAX-1) %,
	NEWNULL=GETSPACE(1) %;

Macro
	DETRFI=
		(aaa: Begin
		Local NUMNULL, MATCHRB;
		PLISTLEN = NUMNULL = 0;
		RUND(QL_NAME);
		If (MATCHRB = LBRACEL(.DEL)) Eql 0 Then
		    Begin
		    ERRINFO[0] = .MACSTE;
		    FERROR(.pos_del,.pos_del,ERMPL);
		    Leave aaa With 1
		    End;
		OLDDELI = ',';	! SIGNAL TO DETBRACKET
		Do
		    Begin
		    Case SIGN(SCANTO(.MATCHRB,.pos_del,TRUE)) From -1 To 1 Of Set
			[-1]:
			    Leave aaa With 1; ! ERROR IN SCANTO
			[0]:
			    NUMNULL = .NUMNULL+1; ! NULL STREAM
			[1]:
			    Begin
			    Incr I From 1 To .NUMNULL Do
				NEXTAP = NEWNULL;
			    NEXTAP = STRMQUIT(WSTBUF);
			    PARMSEEN = TRUE;
			    PLISTLEN = .PLISTLEN+.NUMNULL+1;
			    NUMNULL = 0
			    End
		    Tes
		    End
		Until .DEL Eql .MATCHRB;
		PLISTTOP = PLISTBEG = STRMQUIT(APLBUF);
		0
		End) %;

    Macro
	DETREMAIN=
		(bbb: Begin
		Local SSYM, SCOPY, SOLDDEL, SOLDDELI, RETVAL, STRACE;

		If .MACSTE Eql .sym_remainder Then
		    Begin
		    If .MACRNACTS Lss .REMLEN Then
			Begin
			PLISTTOP = .REMTOP;
			PLISTBEG = .REMBEG;
			SAVPOS = .REMPOS;
			PLISTLEN = .REMLEN-.MACRNACTS
			End
		    Else
			Begin
			SUBTYPE = MAC_PASSED;
			PARMSEEN = FALSE
			End;
		    Leave bbb With 0
		    End;
		TRACEE(MACRTPB);
		APMBUF[strm_size] = (If .WSTBUF[strm_size] Eql 0
				Then .APLBUF[strm_size]+SZ_STREAM
				Else SZ_STREAM + APLMAX+.WSTBUF[strm_size]);
		STRMPUSH(APMBUF);
		APLBUF[strm_size] = 0;
		APLBUF[strm_next] = 0;
		WSTBUF[strm_size] = 0;
		WSTBUF[strm_next] = 0;
		SCOPY = .MACRCP;
		MACRCP = TRUE;
		PARMSEEN = FALSE;
		NOTETRACE;
		STRACE = .TRACEBIT;
		TRACEBIT = FALSE;
		SSYM = .SYM;
		SOLDDEL = .OLDDEL;
		SOLDDELI = .OLDDELI;
		OLDDELI = 0;
		RETVAL = DETRFI;
		TRYSTREAMPOP(0);
		MACRCP = .SCOPY;
		SYM = .SSYM;
		OLDDEL = .SOLDDEL;
		OLDDELI = .SOLDDELI;
		TRACEBIT = .STRACE;
		STRMPOP(APMBUF);
		.RETVAL
		End) %;

! D.2: EXPANSION PER SE

!
! SAVE THE OLD LEXICAL ANALYSIS CONTEXT, AND PUSH
! IN A NEW ONE, WITH APPROPRIATE INITIALIZATION. JUST
! HOW MUCH CONTEXT IS SAVED IS DETERMINED BY STACKLENGTH.
!
Routine MACRSWAP(STACKLENGTH,TYPE,STREAMPOS) : Novalue =
Begin
    Bind
	SUBTYPE=MACRSUBTYPE; ! FOR 'ITERATED' MACRO

    INPBUF[strm_size] = .STACKLENGTH;
    If .SUBTYPE Neq MAC_STRUCTURE Then
	NOTETRACE;
    STRMPUSH(INPBUF);
    STRMZTOP(INPBUF);
    STREAMIN = TRUE;
    MACRSUBTYPE = .TYPE;
    STRMTOP = STRMBEG = .STREAMPOS;
    TRACEBIT = .swit_expand
End;

Macro
	TRACEIT(ROUT,PAR)=If .swit_expand Then ROUT(PAR) %;

Routine EMACR(MACSTE : Ref ST,SYMORDEL) : Novalue =
Begin
    Macro
	TRACEE(X)=TRACEIT(X,.MACSTE) %;
    Local
	SUBTYPE		: Ref ST,
	PLISTLEN,
	PLISTTOP,
	PLISTBEG,
	SAVPOS,
	BRIND,
	PARMSEEN;
    Label
	aaa,bbb;

    SUBTYPE = .MACSTE[st_mac_type];

    If .swit_expand Then
	Begin
	FORCELINE();
	MACRNUMBL = .MACRNUMBL+4
	End;
    If .SUBTYPE<MAC_V_ITERATIVE> Then
	BRIND = DETBRACKET(.SYMORDEL);
    If .SUBTYPE<MAC_V_ARGUMENTS> Neq 0 Then
	If DETREMAIN Then
	    Begin
	    EXPANDERR = TRUE;
	    Return
	    End; ! TRACE EMPTY STREAM HERE SOMETIME
    If .SUBTYPE<MAC_V_RECURSIVE> And Not .PARMSEEN Then
	Begin
	TRACEE(MACRTE);
	TRACEE(MACRTNULLV);
	Return
	End;
    MACRSWAP(INPMAX-1,.SUBTYPE,.MACSTE[st_mac_body]);
    MACRNAME = .MACSTE;
    If .SUBTYPE Eql MAC_SIMPLE Then
	Begin
	TRACEE(MACRTE);
	STRMTAKE();
	Return
	End;
    REMTOP = .PLISTTOP;
    REMBEG = .PLISTBEG;
    MACRLENGTH = REMLEN = .PLISTLEN;
    If .MACRNAME Eql .sym_remainder Then
	REMPOS = .SAVPOS;
    MACRNACTS = .MACSTE[st_mac_num_fixed]+.MACSTE[st_mac_num_ited];
    If .SUBTYPE Eql MAC_PASSED Then
	Begin
	TRACEE(MACRTE);
	STRMTAKE();
	Return
	End;
    If .SUBTYPE Neq MAC_FIXED And .REMLEN Lss .MACRNACTS Then
	Begin
	STRMEOF = TRUE;
	MACRSUBTYPE = MAC_PASSED;
	TRACEE(MACRTE);
	Return
	End;
    MACRACT = GETSPACE(.MACRNACTS+2);
    MACRACT[strm_size] = .MACRNACTS;
    MACRPICKOFF(MACRACT[2],.MACRNACTS);
    TRACEE(MACRTFPO);
    TRACEE(MACRTE);
    If .SUBTYPE Eql MAC_FIXED Then
	Begin
	MACRNACTS = .REMLEN;
	STRMTAKE();
	Return
	End;
    If .SUBTYPE Eql MAC_RECURSIVE Then
	Begin
	MACSTE[st_mac_depth] = .MACSTE[st_mac_depth]+1;
	STRMTAKE();
	Return
	End;
    MACRITCOUNT = 1;
    If .MACRNAME Neq .sym_remainder Then
	Begin
	TRACEE(MACRTPBE);
	TRACEE(MACRTLPO)
	End;
    MACRSEP = .BRIND;
    MACRNF = .MACSTE[st_mac_num_fixed];
    MACRNI = .MACSTE[st_mac_num_ited];
    If .MACRSEP[2] Eql 0 Then
	STRMTAKE()
    Else
	Begin
	FUTWINDOW<lex_delim> = .MACRSEP[2];
	TRACEE(MACRTS)
	End
End;

Routine EMACRF(OFFST : Ref ST) : Novalue =
Begin
    Bind
	SUBTYPE=MACRSUBTYPE;
    Local
	OLDTRACE;

    OLDTRACE = .TRACEBIT;
    If .SUBTYPE Eql MAC_FIXED And .OFFST<lex_addr> Gtr .MACRNACTS Then
	Return;
    MACRSWAP(INPMAX-1,MAC_SIMPLE,.MACRACT[.OFFST<lex_addr>+1]);
    TRACEBIT = .OLDTRACE;
    ACTUALEXP = TRUE;
    STRMTAKE()
End;

Global Routine ESTRU(STREAM : Ref Vector,ACTUALS : Ref Vector,
			STRUCT : Ref ST,FAKE : Boolean) : Novalue =
Begin
    Local
	VALUE,SAVEL;

! WINDOW SHOULD CONTAIN RIGHT BRACKET

    If .STRUCP Or .NOTREE Then
	Begin
	If Not .FAKE Then
	    RUNDE();
	SYM = ZERO;
	Return
	End;
    DEL = TK_SEMICOLON;
    NEWLASTEND(PSPOI);
    MACRSWAP(INPMAX-1,MAC_STRUCTURE,.STREAM);
    TRACEBIT = FALSE;
    STRUEXPAND = TRUE;
    STRUACT = .ACTUALS;
    STRUNAME = .STRUCT;
    STRMTAKE();
    RUND(QL_LEXEME);
    EXPRESSION(); ! SIZE MUST WORRY ABOUT LITERAL
    RESLASTEND;
      
! WINDOW SHOULD CONTAIN RIGHT POINTER CLOSE

    VALUE = .SYM;
    If Not .FAKE Then
	RUNDE();
    SYM = .VALUE
End;

! E. POP CONTEXTS

!
! 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.
!
Routine POPORIT=
Begin
    Macro
	%Quote TRACEE(ROUT)=TRACEIT(ROUT,.MACRNAME) %;
    Bind
	SUBTYPE=MACRSUBTYPE;
    Local
	OLDTMS;

    If .SUBTYPE<MAC_V_ITERATIVE> Then 
	Begin
	If (REMLEN = .REMLEN-.MACRNACTS) Lss .MACRNI Then
	    Begin ! CLOSING DELIMITER
	    TRACEE(MACRTIV);
	    If .MACRSEP[1] Neq 0 Then
		Begin
		SUBTYPE = MAC_RECURSIVE;		!SO AS NOT TO GO THROUGH AGAIN
		FUTWINDOW<lex_delim> = .MACRSEP[1];
		MACRITCOUNT = 0;
		TRACEE(MACRTS);
		STRMEOF = FALSE;
		ATOMISSYM = FALSE;
		Return TRUE ! CAUSE SCANFOR LOOP EXIT
		End
	    End
	Else
	    Begin
	    TRACEE(MACRTIV);
	    MACRITCOUNT = .MACRITCOUNT+1;
	    MACRNACTS = .MACRNI;
	    MACRPICKOFF(MACRACT[.MACRNF+2],.MACRNI);
	    STRMTOP = .STRMBEG;
	    STRMPOS = 0;
	    ATOMISSYM = FALSE;
	    STRMEOF = FALSE;
	    If .MACRSEP[0] Neq 0 Then
		Begin
		FUTWINDOW<lex_delim> = .MACRSEP[0];
		TRACEE(MACRTS);
		If .MACRNAME Neq .sym_remainder Then
		    Begin
		    TRACEE(MACRTPBE);
		    TRACEE(MACRTLPO)
		    End;
		Return TRUE
		End
	    Else
		Begin
		STRMTAKE();
		If .MACRNAME Neq .sym_remainder Then
		    Begin
		    TRACEE(MACRTPBE);
		    TRACEE(MACRTLPO)
		    End;
		Return FALSE
		End
	    End
	End;

    If .SUBTYPE Eql MAC_RECURSIVE Then
	MACRNAME[st_mac_depth] = .MACRNAME[st_mac_depth]-1;
    If .SUBTYPE Neq MAC_STRUCTURE And Not .ACTUALEXP Then
	TRACEE(MACRTV);
    If .SUBTYPE<MAC_V_ARGUMENTS> Neq 0 And .MACRNAME Neq .sym_remainder Then
	Begin
	REMTOP = .REMBEG;
	REMPOS = 0;
	While Not REMTEOF() Do
	    Begin
	    REMNEXT();
	    STRMRELEASE(.REMTOP[.REMPOS])
	    End;
	STRMRELEASE(.REMBEG);
	If .SUBTYPE Eql MAC_PASSED Then
	    RELEASESPACE(.MACRACT,.MACRACT[strm_size]+SZ_STREAM)
	End;
    If .TRACEBIT Then
	Begin
	OLDTMS = .TMS;
	STRMPOP(INPBUF);
	If .TRACEBIT Then
	    If .SUBTYPE<MAC_V_ITERATIVE> Then
		ITMS = STRMCONC(.ITMS,.OLDTMS)
	    Else
		TMS = STRMCONC(.TMS,.OLDTMS)
	Else
	    STRMRELEASE(.OLDTMS)
	End
    Else
	STRMPOP(INPBUF);
    Return FALSE
End;

! F. STRUCTURE COPY

Routine STRUCOPY : Novalue =
Begin
    Local
	NAME		: Ref ST,
	P		: Ref Block,
	x;
    Label
	aaa;

    X = 0;
    aaa: Begin
    If .SYM<lex_type> Neq T_SYMBOL Then
	Leave aaa;
    NAME = .SYM<lex_addr>;
    If .NAME[gt_type] Neq S_STRUCT_ARG Then
	If .NAME[gt_type] Eql S_STRUCTURE And .NAME Eql .sym_define Then
	    Begin
	    If .DEL Eql '[' Then
		Begin
		WARNEM(.pos_sym,WASTRUCTREC);
		SYM = .sym_vector;
		Leave aaa
		End;
	    If .OLDDEL Neq TK_DOT Then
		Begin
		WARNEM(.pos_sym,ERSNMBDOT);
		SYM = FASTLEXOUT(T_STRUCT_ARG,1);
		Leave aaa
		End;
	    SYM<lex_addr> = 1-.num_actuals
	    End
	Else
	    Leave aaa
    Else
	SYM<lex_addr> = .NAME[st_which];
    SYM<lex_type> = T_STRUCT_ARG;
    If .OLDDEL Neq TK_DOT Then
	Begin
	X = ZERO;
	Leave aaa
	End;
    If .SIZEEXP Then
	Begin
	WARNEM(.pos_sym,ERNODOTS);
	SYM<lex_addr> = .SYM<lex_addr>-.num_actuals;
	Return
	End;
    SYM<lex_addr> = .SYM<lex_addr>+.num_actuals;
    P = WSTBUF[strm_data(.WSTBUF[strm_size] - 1)];
    If .P[0,lex_type] Eql S_DELIMITER Then
	Begin
	P[0,lex_part]  = .SYM;
	P[0,lex_delim] = .DEL;
	SYM = ZERO;
	Return
	End
    Else
	P[0,lex_delim] = 0
    End; ! aaa
    APPEND();
    If .X Neq 0 Then
	SYM = .X
End;

Routine APPEND=
Begin
    Local
	LSYM		: Ref ST;

    If (If .SYM<lex_type> Eql T_SYMBOL Then .SYM[st_scope] Gtr .STRUCLEVEL Else 0) Then
	LSYM = LEXOUT(T_WANT_SYM,.SYM[st_name])
    Else
	LSYM = .SYM;
    STRMAPPEND(WSTBUF,WSTMAX-1) = FORMWINDOW(.LSYM,.DEL)
End;

Global Routine STRUSC(SIZEPRED : Boolean) =
Begin 
    Local
	SAVEDEL		: Integer,
	P		: Ref Block[,Quad];

    NOCODE;
    STRUCP = TRUE;
    SIZEEXP = .SIZEPRED;
    SAVEDEL = .DEL;
    DEL = (If .DEL Eql TK_LPAREN Then '(' Else .OLDDELI);
    STRUCOPY();
    DEL = .SAVEDEL;
    EXPRESSION();
    P = WSTBUF[strm_data(.WSTBUF[strm_size] - 1)];
    P[0,lex_delim] = '>'; ! OVERWRITE CLOSING DELIMITER
    STRUCP = FALSE;
    RESNOTREE;
    Return STRMQUIT(WSTBUF)
End;


! G. MACRO TRACE ROUTINES

Literal
	NONE=0;

Global Routine OUTSTR(S : Ref Vector) : Novalue =
Begin
    Local
	ATOMDEL,
	X;

    If .S Eql 0 Then
	Begin
	Print(AZ('NULL\n'));
	Return
	End;
    Do
	Begin
	Incr I From 1 To .S[strm_size] Do
	    Begin
	    X = .S[strm_data(.I-1)];
	    ATOMDEL = (.DTPF[.X<lex_delim>] Neq 0);
	    Print(AZ('%p'),.X);
	    If .ATOMDEL Then
		OUTPUT(' ');
	    Print(AZ('%l'),.X<lex_delim>);
	    If .ATOMDEL Or (.X<lex_delim> Eql 0) Then
		OUTPUT(' ')
	    End
	End
    While (S = .S[strm_next]) Neqa 0;
    Print(AZ('\n'))
End;

Routine MACRTAPNDP(ADTMS,PRINTBOOL) : Novalue =
Begin
    .ADTMS = STRMCONC(..ADTMS, STRMQUIT(MTBUF));
    If .PRINTBOOL Then
	OUTSTR(..ADTMS)
End;

Routine MACRTE(S : Ref ST) : Novalue =
Begin
    OUTMHD(.S,NONE,NONE,':');
    Print(AZ('EXPANSION\n'))
End;

Routine MACRTFPO(S : Ref ST) : Novalue =
Begin
    Incr I From 1 To .S[st_mac_num_fixed] Do
	Begin
	OUTMHD(.S,NONE, .I, '=');
	OUTSTR(.MACRACT[.I+1])
	End
End;

Routine MACRTIV(S : Ref ST) : Novalue =
Begin
    OUTMHD(.S,.MACRITCOUNT,NONE,'=');
    MACRTAPNDP(ITMS, TRUE);
    TMS = STRMCONC(.TMS,.ITMS);
    ITMS = 0
End;

Routine MACRTLPO(S : Ref ST) : Novalue =
Begin
    Incr I From 1 To .S[st_mac_num_ited] Do
	Begin
	OUTMHD(.S,.MACRITCOUNT,.I+.S[st_mac_num_fixed],'=');
	OUTSTR(.MACRACT[.I+.S[st_mac_num_fixed]+1])
	End
End;

Routine MACRTPB(S : Ref ST) : Novalue =
Begin
    OUTMHD(.S,NONE,NONE,':');
    Print(AZ('PARAMETER BINDING\n'))
End;

Routine MACRTPBE(S : Ref ST) : Novalue =
Begin
    OUTMHD(.S,.MACRITCOUNT,NONE,':');
    Print(AZ('PARAMETER BINDING / EXPANSION\n'))
End;

Routine MACRTS(S : Ref ST) : Novalue =
Begin
    OUTMHD(.S,NONE,NONE,':');
    Print(AZ('SEPARATOR = %l\n'),.FUTWINDOW<lex_delim>)
End;

Routine MACRTV(S : Ref ST) : Novalue =
Begin
    OUTMHD(.S,NONE,NONE,'=');
    MACRTAPNDP(TMS,TRUE);
    Print(AZ('\n'));
    MACRNUMBL = .MACRNUMBL-4
End;

Routine MACRTNULLV(S : Ref ST) : Novalue =
Begin
    OUTMHD(.S,NONE,NONE,'=');
    OUTSTR(0);
    Print(AZ('\n'));
    MACRNUMBL = .MACRNUMBL-4
End;

Routine OUTMHD(S : Ref ST,ITLEVEL,PARAMNO,EQORCOLON) : Novalue =
Begin
    Print(AZ(';;%t[%p]'),.MACRNUMBL,.S);
    If .ITLEVEL Gtr NONE Then
	Print(AZ('[%d]'),.ITLEVEL-1);
    If .PARAMNO Gtr NONE Then
	Print(AZ('(%d)'),.PARAMNO);
    Print(AZ('%c '),.EQORCOLON)
End;

! END OF LEXAN MODULE

End
Eludom