/* BEGIN INCLUDE FILE . . . mrpg_scan */

dcl  not_flag fixed bin init(0);
dcl  min_paren fixed bin init(0);

scanner: proc;

dcl NL char(1)int static init("
");
dcl AN char(63)int static init("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_");
dcl AZ char(26)int static init("ABCDEFGHIJKLMNOPQRSTUVWXYZ");
dcl az char(26)int static init("abcdefghijklmnopqrstuvwxyz");
dcl symt char(32);
dcl  hold_symt char(32);
dcl  hold_ifi fixed bin(24);
dcl  hold_line fixed bin(24);
dcl  (sym_len, hold_sym_len) fixed bin(24);
dcl ctype fixed bin(24);
dcl  jj fixed bin(24);

	if (not_flag > 0)
	then not_flag = not_flag - 1;
get_more:
	if (ifi>ifl)
	then do;
	     if (ifi > ife)
	     then do;
	          lstk (-la_put).symbol = 0;
	          return;
	     end;
	     call get_line;
	     goto get_more;
	end;
	sym_len = verify(substr(ifile,ifi,ifl-ifi+1),AN) -1;
	if (sym_len > 0)
	then do;
	     symt = translate (substr(ifile,ifi,sym_len),AZ,az);
	     ctype = classify(fixed(unspec(substr(symt,1,1))));
	end;
	else do;
	     symt = "";
	     ctype = classify(fixed(unspec(substr(ifile,ifi,1))));
	     sym_len = 1;
	end;
	lstk (-la_put).symptr = addr(ifilea(ifi));
	lstk (-la_put).symlen = sym_len;
	lstk (-la_put).line = linenumber;
	lstk (-la_put).node_ptr = null();
	lstk (-la_put).bchar = ifi;
	lstk (-la_put).datype = 0;
	call typer;
	lstk (-la_put).echar = ifi - 1;
	return;

typer:	proc;

	goto type(ctype);

type(  0):	/* invalid character */
	call mrpg_error_ (1, linenumber, "Invalid character ""^a"" ignored", substr(ifile, ifi, 1));

type(  1):	/* control characters */
	ifi=ifi+1;
	goto get_more;

type(  2):	/* symbol */
symbol:
	if (sym_len > 1)
	then do;
	     Ch2 = substr (ifile, lstk (-la_put).bchar, 2);
	     if (substr (Ch2, 2, 1) = "_")
	     then if (index (AZ, substr (Ch2, 1, 1)) ^= 0)
	     then call mrpg_error_ (3, lstk.line (-la_put), "Symbol may not begin with ""^a""", Ch2);
dcl Ch2 char(2);
	end;
	lstk (-la_put).symlen = sym_len;
	ifi = ifi + sym_len;
	lstk (-la_put).echar = ifi - 1;
	lstk (-la_put).symbol = 103 ;
	call st_search (substr (ifile, lstk (-la_put).bchar, lstk (-la_put).symlen), tptr, "ID", 0, 0);
	lstk (-la_put).node_ptr = tptr;
	tptr = tptr->symref.sym->symtab.use.b;
	if (tptr = null())			/* Neither defined nor referenced. */
	then lstk (-la_put).datype = 0;
	else if (tptr->datum.type = "RP")
	then lstk.datype(-la_put) = REP;
	else if (tptr->datum.type = "DT")
	then lstk.datype(-la_put) = DET;
	else if (index("*PM*IN*DC*",tptr->datum.type) = 0)
	then lstk (-la_put).datype = 0;	/* Referenced, but not defined. */
	else do;
	     jj = tptr->datum.kind;
	     if (jj = DecSpec)
	     then jj = Decimal;
	     if (jj = Bool)
	     then lstk (-la_put).datype=BOOL;
	     else if (jj = Decimal)
	     then lstk (-la_put).datype = DEC;
	     else if (jj = Table)
	     then do;
	          lstk.datype(-la_put) = TABLE;
		jj = Char;
	     end;
	     else if (jj = Tablev)
	     then do;
		lstk.datype(-la_put) = TABLE;
		jj = Chard;
	     end;
	     else if (jj = Tabled)
	     then do;
		lstk.datype(-la_put) = TABLE;
		jj = Decimal;
	     end;
	     else if (jj = Set)
	     then do;
		lstk.datype(-la_put) = SET;
		jj = Bool;
	     end;
	     else do;
		lstk.datype(-la_put) = CHAR;
		if (jj ^= Char)
		then jj = Chard;
	     end;
	     lstk.node_ptr(-la_put)->symref.kind = jj;
	     if db_sw then call ioa_("^a ^a ^a ^a",
		tptr->datum.type,
		kind_char(tptr->datum.kind),
		dt_s(lstk.datype(-la_put)),
		tptr->datum.sym->symref.sym->symtab.data);
	end;
	return;
type(  3):	/* number */
number:
	lstk (-la_put).symlen, jj = verify (substr (ifile, ifi, 32), "0123456789.") - 1;
	if (jj < sym_len)
	then do;
	     call mrpg_error_ (2, lstk.line(-la_put), "Invalid number ""^a"". Initial digits will be assumed as a number.",
		substr(ifile,ifi,sym_len));
	end;
	else if (index (after (substr (ifile, ifi, jj), "."), ".") ^= 0)
	then do;
	     call mrpg_error_ (2,  lstk.line (-la_put), "Invalid number ""^a""", substr (ifile, ifi, jj));
	end;
	ifi = ifi + jj;
	lstk (-la_put).echar = ifi - 1;
	lstk (-la_put).symbol = 104 ;
	lstk (-la_put).datype = DEC;
	call st_search(substr(ifile,lstk (-la_put).bchar,lstk (-la_put).symlen),tptr,"NU",0,0);
	tptr->symref.kind = Decimal;
	lstk (-la_put).node_ptr = tptr;
	lstk.val(-la_put) = fixed(symtab.data,24);
	return;
type(  4):	/* string */
dcl	sbl	fixed bin(24);
	sbl=ifi;
	ifi=ifi+1;
 try_again:
	jj = index(substr(ifile,ifi,ifl-ifi+1),"""");
	if (jj = 0)
	then do;
	     ifi = ifl+1;
	     if (ifi > ife)
	     then do;
		call mrpg_error_(3,lstk.line(-la_put),"Unterminated quoted string.");
	     end;
	     call get_line;
	     goto try_again;
	end;
	ifi=ifi+jj;
	if(substr(ifile,ifi,1)="""")
	then do;
	     ifi=ifi+1;
	     goto try_again;
	end;
	lstk (-la_put).symlen=ifi-sbl;
	lstk (-la_put).echar = ifi - 1;
	lstk (-la_put).symbol = 105 ;
	lstk (-la_put).datype = CHAR;
	call st_search(substr(ifile,lstk (-la_put).bchar,lstk (-la_put).symlen),tptr,"ST",0,0);
	tptr->symref.kind = Char;
	lstk (-la_put).node_ptr = tptr;
	return;

type(  5):	/* % */
/*	if (translate(substr(ifile,ifi,7),AZ,az)="%ABSENT") then do;
	     ifi = ifi + 7;
	     lstk (-la_put).symlen = 7;
	     lstk (-la_put).symbol =   1 ;
	     return;
	end;
	else*/ if (translate(substr(ifile,ifi,4),AZ,az)="%DAY") then do;
	     ifi = ifi + 4;
	     lstk (-la_put).symlen = 4;
	     lstk (-la_put).symbol =   2 ;
	     call st_search("I_DAY",tptr,"ID",Chard,12);
	     tree.day = "1"b;
	     lstk (-la_put).node_ptr = tptr;
	     lstk (-la_put).datype = 2;
	     return;
	end;
/*	else if (translate(substr(ifile,ifi,4),AZ,az)="%FIT") then do;
	     ifi = ifi + 4;
	     lstk (-la_put).symlen = 4;
	     lstk (-la_put).symbol =   3 ;
	     return;
	end;*/
	else if (translate(substr(ifile,ifi,7),AZ,az)="%HHMMSS") then do;
	     ifi = ifi + 7;
	     lstk (-la_put).symlen = 7;
	     lstk (-la_put).symbol =   4 ;
	     call st_search("I_HHMMSS",tptr,"ID",Char,8);
	     tree.hhmmss = "1"b;
	     lstk (-la_put).node_ptr = tptr;
	     lstk (-la_put).datype = 2;
	     return;
	end;
	else if (translate(substr(ifile,ifi,6),AZ,az)="%LEVEL") then do;
	     ifi = ifi + 6;
	     lstk (-la_put).symlen = 6;
	     lstk (-la_put).symbol =   5 ;
	     return;
	end;
	else if (translate(substr(ifile,ifi,7),AZ,az)="%MMDDYY") then do;
	     ifi = ifi + 7;
	     lstk (-la_put).symlen = 7;
	     lstk (-la_put).symbol =   6 ;
	     call st_search("I_MMDDYY",tptr,"ID",Char,8);
	     tree.mmddyy = "1"b;
	     lstk (-la_put).node_ptr = tptr;
	     lstk (-la_put).datype = 2;
	     return;
	end;
	else if (translate(substr(ifile,ifi,6),AZ,az)="%MONTH") then do;
	     ifi = ifi + 6;
	     lstk (-la_put).symlen = 6;
	     lstk (-la_put).symbol =   7 ;
	     call st_search("I_MONTH",tptr,"ID",Chard,12);
	     tree.month = "1"b;
	     lstk (-la_put).node_ptr = tptr;
	     lstk (-la_put).datype = 2;
	     return;
	end;
	else if (translate(substr(ifile,ifi,11),AZ,az)="%PAGENUMBER") then do;
	     ifi = ifi + 11;
	     lstk (-la_put).symlen = 11;
	     lstk (-la_put).symbol =   8 ;
	     return;
	end;
/*	else if (translate(substr(ifile,ifi,8),AZ,az)="%PRESENT") then do;
	     ifi = ifi + 8;
	     lstk (-la_put).symlen = 8;
	     lstk (-la_put).symbol =   9 ;
	     return;
	end;*/
	else if (translate(substr(ifile,ifi,7),AZ,az)="%REPEAT") then do;
	     ifi = ifi + 7;
	     lstk (-la_put).symlen = 7;
	     lstk (-la_put).symbol =  10 ;
	     return;
	end;
	else if (translate(substr(ifile,ifi,6),AZ,az)="%ROMAN") then do;
	     ifi = ifi + 6;
	     lstk (-la_put).symlen = 6;
	     lstk (-la_put).symbol =  11 ;
	     return;
	end;
	else if (translate(substr(ifile,ifi,7),AZ,az)="%SUBSTR") then do;
	     ifi = ifi + 7;
	     lstk (-la_put).symlen = 7;
	     lstk (-la_put).symbol =  12 ;
	     return;
	end;
	else if (translate(substr(ifile,ifi,6),AZ,az)="%YYDDD") then do;
	     ifi = ifi + 6;
	     lstk (-la_put).symlen = 6;
	     lstk (-la_put).symbol =  13 ;
	     call st_search("I_YYDDD",tptr,"ID",Char,5);
	     tree.yyddd = "1"b;
	     lstk (-la_put).node_ptr = tptr;
	     lstk (-la_put).datype = 2;
	     return;
	end;
	goto error;

type(  6):	/* & */
	do;
	     ifi = ifi + 1;
	     lstk (-la_put).symbol =  25 ;
	     return;
	end;
	goto error;

type(  7):	/* ( */
	do;
	     parenct = parenct + 1;
	     ifi = ifi + 1;
	     lstk (-la_put).symbol =  14 ;
	     return;
	end;
	goto error;

type(  8):	/* ) */
	do;
	     parenct = parenct - 1;
	     ifi = ifi + 1;
	     lstk (-la_put).symbol =  15 ;
	     return;
	end;
	goto error;

type(  9):	/* * */
	do;
	     ifi = ifi + 1;
	     lstk (-la_put).symbol =  16 ;
	     return;
	end;
	goto error;

type( 10):	/* + */
	do;
	     ifi = ifi + 1;
	     lstk (-la_put).symbol =  17 ;
	     return;
	end;
	goto error;

type( 11):	/* , */
	hold_ifi = ifi;
	hold_line = linenumber;
	ifi = ifi + 1;
	if (parenct = 0)
	then if skip()
	then do;
	     call digit_test;
	     if (substr(symt,1,1)="2") then do;
		ifi = ifi + 1;
		lstk (-la_put).symbol = 106 ;
		lstk (-la_put).symlen = ifi - hold_ifi;
		return;
	     end;
	     else if (substr(symt,1,1)="3") then do;
		ifi = ifi + 1;
		lstk (-la_put).symbol = 107 ;
		lstk (-la_put).symlen = ifi - hold_ifi;
		return;
	     end;
	     else if (substr(symt,1,1)="4") then do;
		ifi = ifi + 1;
		lstk (-la_put).symbol = 108 ;
		lstk (-la_put).symlen = ifi - hold_ifi;
		return;
	     end;
	end;
	ifi = hold_ifi;
	linenumber = hold_line;
	ifi = ifi + 1;
	lstk (-la_put).symbol =  18 ;
	return;

type( 12):	/* - */
	if (substr(ifile,ifi,2)="->") then do;
	     ifi = ifi + 2;
	     lstk (-la_put).symlen = 2;
	     lstk (-la_put).symbol =  20 ;
	     return;
	end;
	else do;
	     ifi = ifi + 1;
	     lstk (-la_put).symbol =  19 ;
	     return;
	end;
	goto error;

type( 13):	/* / */
	if (substr(ifile,ifi,2) = "/*") then do;
	     call comment;
	     goto get_more;
	end;
	do;
	     ifi = ifi + 1;
	     lstk (-la_put).symbol =  21 ;
	     return;
	end;
	goto error;

type( 14):	/* : */
	if (substr(ifile,ifi,2)=":=") then do;
	     ifi = ifi + 2;
	     lstk (-la_put).symlen = 2;
	     lstk (-la_put).symbol =  22 ;
	     return;
	end;
	goto error;

type( 15):	/* ; */
	     if (parenct > min_paren)
	     then do;
		parenct = parenct - 1;
		lstk(-la_put).symbol = 15;
		call mrpg_error_(2, lstk.line(-la_put), "Missing "")"" supplied before "";"".");
		return;
	     end;
	do;
	     ifi = ifi + 1;
	     lstk (-la_put).symbol =  23 ;
	     return;
	end;
	goto error;

type( 16):	/* < */
	if (substr(ifile,ifi,2)="<=") then do;
	     ifi = ifi + 2;
	     lstk (-la_put).symlen = 2;
	     lstk (-la_put).symbol =  67 ;
	     return;
	end;
	else do;
	     ifi = ifi + 1;
	     lstk (-la_put).symbol =  71 ;
	     return;
	end;
	goto error;

type( 17):	/* = */
	do;
	     ifi = ifi + 1;
	     lstk (-la_put).symbol =  51 ;
	     return;
	end;
	goto error;

type( 18):	/* > */
	if (substr(ifile,ifi,2)=">=") then do;
	     ifi = ifi + 2;
	     lstk (-la_put).symlen = 2;
	     lstk (-la_put).symbol =  59 ;
	     return;
	end;
	else do;
	     ifi = ifi + 1;
	     lstk (-la_put).symbol =  60 ;
	     return;
	end;
	goto error;

type( 19):	/* A */
	if (symt="ASCENDING") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  26 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="ASC") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  26 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="ALIGN") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  24 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="AND") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  25 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="ATTACH") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  27 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	goto symbol;

type( 20):	/* B */
	if (symt="BEGINS") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  29 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="BEGIN") then do;
	if (not_flag = 0)
	then do;
	     if (parenct > 0)
	     then do;
		parenct = parenct - 1;
		lstk(-la_put).symbol = 15;
		call mrpg_error_(2, lstk.line(-la_put), "Missing "")"" supplied before ""BEGIN"".");
		return;
	     end;
	     if (if_nest > 0)
	     then do;
		lstk.symbol(-la_put) = 117; /* FI; */
		call mrpg_error_(2, lstk.line(-la_put), "Missing ""FI;"" supplied before ""BEGIN"".");
		return;
	     end;
	end;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  28 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="BOOLEAN") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  56 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="BOOL") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  56 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="BREAK") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  31 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="BSP") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol = 109;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	goto symbol;

type( 21):	/* C */
	if (symt="CENTER") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  32 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="CHARACTER") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  33 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="CHAR") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  33 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="COLUMN") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  34 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="COL") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  34 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="CONCATENATE") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  35 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="CONTAINS") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  37 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="CONTAIN") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  36 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	goto symbol;

type( 22):	/* D */
	if (symt="DCL")
	| (symt="DECLARE") then do;
	     hold_ifi = ifi;
	     hold_line = linenumber;
	     hold_symt = symt;
	     hold_sym_len = sym_len;
	     ifi = ifi + sym_len;
	     if skip()
	     then do;
		call digit_test;
		if (substr(symt,1,1) = "1")
		then do;
		     ifi = ifi + 1;
		     lstk (-la_put).symbol =  39 ;
		     lstk (-la_put).symlen = ifi-hold_ifi;
		     return;
		end;
	     end;
	     ifi = hold_ifi;
	     linenumber = hold_line;
	     symt = hold_symt;
	     sym_len = hold_sym_len;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  38 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="DECIMAL")
	| (symt = "DEC") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol = 30 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="DEFAULT") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  40 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="DEFINE") then do;
	     hold_ifi = ifi;
	     hold_line = linenumber;
	     hold_symt = symt;
	     hold_sym_len = sym_len;
	     ifi = ifi + sym_len;
	     if skip()
	     then do;
		call digit_test;
		if (substr(symt,1,1) = "1")
		then do;
		     ifi = ifi + 1;
		     lstk (-la_put).symbol =  41 ;
		     lstk (-la_put).symlen = ifi-hold_ifi;
		     return;
		end;
	     end;
	     ifi = hold_ifi;
	     linenumber = hold_line;
	     symt = hold_symt;
	     sym_len = hold_sym_len;
	     goto symbol;
	end;
	else if (symt="DELIMITED") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  42 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="DESCENDING") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  43 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="DESC") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  43 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="DETAILFOOT") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  45 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="DETAILHEAD") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  46 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="DETAIL") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  44 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="DUPLICATE") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  47 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="DUPL") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  47 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	goto symbol;

type( 23):	/* E */
	if (symt="EDIT") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  48 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="ENDS") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  50 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="END") then do;
	if (not_flag = 0)
	then do;
	     if (parenct > 0)
	     then do;
		parenct = parenct - 1;
		lstk(-la_put).symbol = 15;
		call mrpg_error_(2, lstk.line(-la_put), "Missing "")"" supplied before ""END"".");
		return;
	     end;
	     if (if_nest > 0)
	     then do;
		lstk.symbol(-la_put) = 117; /* FI; */
		call mrpg_error_(2, lstk.line(-la_put), "Missing ""FI;"" supplied before ""END"".");
		return;
	     end;
	end;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  49 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="ELSE") then do;
	     if (parenct > 0)
	     then do;
		parenct = parenct - 1;
		lstk(-la_put).symbol = 15;
		call mrpg_error_(2, lstk.line(-la_put), "Missing "")"" supplied before ""ELSE"".");
		return;
	     end;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol = 115 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="EQ") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  51 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	goto symbol;

type( 24):	/* F */
	if (symt="FALSE") then do;
	     ifi = ifi + sym_len;
	     call st_search("""0""b",tptr,"ST",0,0);
	     lstk (-la_put).node_ptr = tptr;
	     lstk (-la_put).symbol =  52 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="FILE") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  53 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
/**/	else if (symt="FILL") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  54 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;/**/
/*	else if (symt="FIT") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  55 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;*/
	else if (symt="FI") then do;
	     if (parenct > 0)
	     then do;
		parenct = parenct - 1;
		lstk(-la_put).symbol = 15;
		call mrpg_error_(2, lstk.line(-la_put), "Missing "")"" supplied before ""FI"".");
		return;
	     end;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol = 116 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
/*	else if (symt="FOLD") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  58 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;*/
	goto symbol;

type( 25):	/* G */
	if (symt="GE") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  59 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="GT") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  60 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	goto symbol;

type( 26):	/* H */
	if (symt="HOLD") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  61 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	goto symbol;

type( 27):	/* I */
	if (symt="IF") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  62 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="INPUT") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  64 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="IN") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  63 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	goto symbol;

type( 28):	/* J */

type( 29):	/* K */
	if (symt="KEY") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  66 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	goto symbol;

type( 30):	/* L */
	if (symt="LEFT") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  68 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="LET") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  69 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="LE") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  67 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="LINE") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  70 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="LT") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  71 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	goto symbol;

type( 31):	/* M */
	if (symt="MAXLINE") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  72 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="MAXL") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  72 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="MINLINE") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  73 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="MINL") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  73 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	goto symbol;

type( 32):	/* N */
	if (symt="NE") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  74 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="NOT") then do;
	     not_flag = 2;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  76 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="NO") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  75 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="NUMBER") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  77 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	goto symbol;

type( 33):	/* O */
	if (symt="ON") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  78 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="OPTIONAL") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  79 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="OR") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  80 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	goto symbol;

type( 34):	/* P */
	if (symt="PAGEFOOT") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  81 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="PAGEHEAD") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  82 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="PAGELENGTH") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  83 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="PAGEWIDTH") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  84 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="PARAMETER") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  85 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="PARM") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  85 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="PAUSE") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  65 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="PGL") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  83 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="PGW") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  84 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="PICTURE") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  86 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="PIC") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  86 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="POSITION") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  87 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="PRINT") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  88 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	goto symbol;

type( 35):	/* R */
	if (symt="RECORD") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  89 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="REPORTFOOT") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  91 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="REPORTHEAD") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  92 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="REPORT") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  90 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="RETURNS") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  93 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="RIGHT") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  94 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	goto symbol;

type( 36):	/* S */
	if (symt="SORT") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  95 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
/*	else if (symt="SKIP") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol = 112;
	     lstk (-la_put).symlen =sym_len;
	     return;
	end;*/
/*	else if (symt="STOP") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol = 111;
	     lstk (-la_put).symlen =sym_len;
	     return;
	end;*/
	else if (symt="SET") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol = 113;
	     lstk (-la_put).symlen =sym_len;
	     return;
	end;
	else if (symt="SPECIAL")
	| (symt="SPEC") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  110 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="STREAM") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  96 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="SWITCH") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  97 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	goto symbol;

type( 37):	/* T */
	if (symt="TABLE") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  98 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="TRANSFORM") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  99 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="TRAN") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol =  99 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="TRUE") then do;
	     ifi = ifi + sym_len;
	     call st_search("""1""b",tptr,"ST",0,0);
	     lstk (-la_put).node_ptr = tptr;
	     lstk (-la_put).symbol = 100 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="THEN") then do;
	     if (parenct > 0)
	     then do;
		parenct = parenct - 1;
		lstk(-la_put).symbol = 15;
		call mrpg_error_(2, lstk.line(-la_put), "Missing "")"" supplied before ""THEN"".");
		return;
	     end;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol = 114 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	goto symbol;

type( 38):	/* V */
	if (symt="VARYING") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol = 101 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	else if (symt="VAR") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol = 101 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	goto symbol;

type( 39):	/* W */
	if (symt="WORD") then do;
	     ifi = ifi + sym_len;
	     lstk (-la_put).symbol = 102 ;
	     lstk (-la_put).symlen = sym_len;
	     return;
	end;
	goto symbol;

type( 40):	/* ^ */
	if (substr(ifile,ifi,2)="^=") then do;
	     ifi = ifi + 2;
	     lstk (-la_put).symlen = 2;
	     lstk (-la_put).symbol =  74 ;
	     return;
	end;
	else do;
	     ifi = ifi + 1;
	     lstk (-la_put).symbol =  76 ;
	     return;
	end;
	goto error;

type( 41):	/* | */
	if (substr(ifile,ifi,2)="||") then do;
	     ifi = ifi + 2;
	     lstk (-la_put).symlen = 2;
	     lstk (-la_put).symbol =  35 ;
	     return;
	end;
	else do;
	     ifi = ifi + 1;
	     lstk (-la_put).symbol =  80 ;
	     return;
	end;

error:
	call mrpg_error_(2,linenumber,"Unrecognized token ""^a"".",substr(ifile,ifi,max(1,sym_len)));
	ifi = ifi + max(1,sym_len);
	goto get_more;
end;


digit_test:	proc;

	if (index("1234",substr(symt,1,1))^=0)
	then do;
	     if (substr(symt,2) ^= "")
	     then call mrpg_error_(2,linenumber,"Invalid number ""^a"". Initial digit will be assumed as a number.",
		symt);
	end;
end;

get_line: proc;

	     linenumber=linenumber+1;
	     if (lino(1) ^= 0)
	     then do;
		if (linenumber > lino(2))
		then db_sw = "0"b;
		else if (linenumber >= lino(1))
		then db_sw = "1"b;
	     end;
	     i = index(substr(ifile,ifi,ife-ifi+1),NL);
	     if (i=0)
	     then i=ife-ifi+1;
	     else i=i-1;
	     ifl=ifi+i;
	     if pr_sw then call ioa_("^4i^-^a",linenumber,substr(ifile,ifi,i));

	end;

comment:	proc;

dcl sbl fixed bin(24);
dcl  bln fixed bin;

	     bln = linenumber;
	     sbl, ifi = ifi + 2;
loop:
	     jj = index(substr(ifile,ifi,ifl-ifi+1),"*/");
	     if (jj = 0)
	     then do;
		ifi = ifl + 1;
		if (ifi > ife)
		then call mrpg_error_(3,lstk.line(-la_put),"Unterminated comment.");
		call get_line;
		goto loop;
	     end;
	     ifi = ifi + jj+1;
	     if (index(substr(ifile,sbl,ifi-sbl+1),"/*") ^= 0)
	     then call mrpg_error_(1,bln,"-^5i.  This comment contains an imbedded ""/*"".",linenumber);

end;

skip:	proc () returns (bit (1));

dcl (i, j) fixed bin (24);
dcl  found bit (1);

	     found = "0"b;
try_again:
	     do ifi = ifi to ifl;
		j = classify (fixed (unspec (ifilea (ifi))));
		if (j ^= 1)
		then do;
		     if (substr(ifile,ifi,2) = "/*")
		     then do;
			call comment;
			goto try_again;
		     end;
		     found = "1"b;
		     goto finished;
		end;
	     end;
	     if (ifi <= ife)
	     then do;
		call get_line;
		goto try_again;
	     end;
finished:
	     if found
	     then do;
		sym_len = verify (substr (ifile, ifi, 32), AN) - 1;
		if (sym_len > 0)
		then symt = translate (substr (ifile, ifi, sym_len), AZ, az);
		else symt = "";
	     end;
	     return (found);

	end;
dcl	classify(0:127) fixed bin(8)unal int static init(

/*  000 001 002 003 004 005 006 007  */
      1,  1,  1,  1,  1,  1,  1,  1,

/*  010 011 012 013 014 015 016 017  */
      1,  1,  1,  1,  1,  1,  1,  1,

/*  020 021 022 023 024 025 026 027  */
      1,  1,  1,  1,  1,  1,  1,  1,

/*  030 031 032 033 034 035 036 037  */
      1,  1,  1,  1,  1,  1,  1,  1,

/*  040 "!" """ "#" "$" "%" "&" "'"  */
      1,  0,  4,  0,  0,  5,  6,  0,

/*  "(" ")" "*" "+" "," "-" "." "/"  */
      7,  8,  9, 10, 11, 12,  3, 13,

/*  "0" "1" "2" "3" "4" "5" "6" "7"  */
      3,  3,  3,  3,  3,  3,  3,  3,

/*  "8" "9" ":" ";" "<" "=" ">" "?"  */
      3,  3, 14, 15, 16, 17, 18,  0,

/*  "@" "A" "B" "C" "D" "E" "F" "G"  */
      0, 19, 20, 21, 22, 23, 24, 25,

/*  "H" "I" "J" "K" "L" "M" "N" "O"  */
     26, 27,  2, 29, 30, 31, 32, 33,

/*  "P" "Q" "R" "S" "T" "U" "V" "W"  */
     34,  2, 35, 36, 37,  2, 38, 39,

/*  "X" "Y" "Z" "[" "\" "]" "^" "_"  */
      2,  2,  2,  0,  0,  0, 40,  0,

/*  "`" "a" "b" "c" "d" "e" "f" "g"  */
      0,  2,  2,  2,  2,  2,  2,  2,

/*  "h" "i" "j" "k" "l" "m" "n" "o"  */
      2,  2,  2,  2,  2,  2,  2,  2,

/*  "p" "q" "r" "s" "t" "u" "v" "w"  */
      2,  2,  2,  2,  2,  2,  2,  2,

/*  "x" "y" "z" "{" "|" "}" "~" ""  */
      2,  2,  2,  0, 41,  0,  0,  1);
end;
st_search:	proc(c, p, id, t, l);

dcl	c	char(*),			/* string to enter into symbol table */
	p	ptr,			/* pointer to symref (OUT) */
	id	char(2),			/* type of symbol table entry */
	t	fixed bin,		/* type of datum */
	l	fixed bin;		/* length of datum */

dcl	tptr	ptr;

	symbol_leng = length(c);
	do symtabptr = table.b
		repeat (symtab.next)
		while(symtabptr  ^= null());
	     if (symtab.data = c)
	     then goto found;
	end;
	allocate symtab in (space);
	symtab.type = id;
	symtab.use.b, symtab.use.e = null();
	symtab.data = c;
	call link(tree.table,symtabptr);
found:
	allocate symref in (space);
	symref.type = "SY";
	symref.line = lstk (-la_put).line;
	symref.bchar = lstk (-la_put).bchar;
	symref.echar = lstk (-la_put).echar;
	symref.next = null();
	symref.usage = null();
	symref.sym = symtabptr;
	p = srefptr;
	if (t = 0)
	then return;
	tptr = p->symref.sym->symtab.use.b;
	if (tptr = null())
	then goto doit;
	if (tptr->symref.type ^= "DC")
	then do;
doit:
	     allocate datum in (space) set (tptr);
	     tptr->datum.type = "DC";
	     tptr->datum.sym = p;
	     tptr->datum.kind = t;
	     tptr->datum.leng = l;
	     tptr->datum.datal.b, tptr->datum.datal.e = null();
	     tptr->datum.check.b, tptr->datum.check.e = null();
	     call use_def(tptr);
	     call link(tree.local,tptr);
	end;
	p->symref.kind = tptr->datum.kind;

end;
/* END INCLUDE FILE . . . mrpg_scan */


*/
                                          -----------------------------------------------------------


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull
and Bull HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato. Users consider that Multics provided the best software architecture for 
managing computer hardware properly and for executing programs. Many subsequent operating systems 
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

                                          -----------------------------------------------------------

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by Bull HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved

*/