$include "defs.icn"
$include "global_vars.icn"

####################################################################
#####################################################################
#*
# *  Russell scanner
# */


#DJDSTOP
# #
# # ##include    "../parser/y.tab.h"
# #
# # #define STKSIZE     5       /* depth of scanner error recovery stack        */
# #
# #
# # /*
# #  * code for nil pointer
# #  */
# # #define     NIL     0
# #
# #
# # extern boolean pflag;      /* input is preprocessor output */
# # #define     ESCCHAR '#'    /* signals position in preprocessor output */
# #
# #
# # /* entry in reserved identifier table */
# # struct restab {
# #     char    * rt_txt;
# #     int     rt_val; };
# #
# # /*
# #  * reserved word tables
# #  */
# #
# # struct restab residtab[];
# # int nresids;
# #
# # struct restab resoptab[];
# # int nresops;
# #
# # /*
# #  * table of character classes
# #  * and macro to find character class
# #  */
# #
# # int cctab[];
# #
# # # define CCLASS(c) ((c) == EOF ? EOFCC : cctab[c])
# #
# #
# # /*
# #  * global variables for communicating with yacc;
# #  */
# #
# # int yyline = 0;
# # int yycolno = 0;
# # char * yyinfnm;
# #
# # int yydebug;
# #
# # int yylval;
# #
# # /* declarations for table of virtual line numbers versus real line
# #  * numbers and filenames. The table is created by the scanner and
# #  * then used by later passes to convert a virtual line number
# #  * stored in the syntax tree to the real line number printed in
# #  * an error message.
# #  */
# # typedef struct VrLine{
# #     int vr_vline,            /* virtual line number at which file */
# #                              /* change or line number jump occurred */
# #         vr_rline,            /* corresponding real line number */
# #         vr_fname;            /* string table index of filename */
# #     struct VrLine * vr_next; /* pointer to next record */  } vrline;
# #
# # vrline * vrtable = NIL,  /* pointers to first and last table entries */
# #        * vrtend  = NIL;
# #
# # int yyvline = 0;  /* curent virtual line number */
# #
# # static int scansavc = '\n';    /* n.b. preprocessor line number scan       */
# #                                /* routine only checks for '@' after '\n'   */
# #
# # static int scanstk[STKSIZE];
# # static int stktop = -1;
# #
# # char tokenbuf[1000];  /* also used by some other routines as string buffer */
# # /* static */ int tokenlgth;
# #
# #
# # /*
# #  *      get next token --
# #  *      put it in tokenbuf.
# #  *              return token code.
# #  */
# #DJDSTART

procedure yylex()
    local c, cc, p, outtok, retry_loop, saw_quote, startline, startfnm , cmtnest , yycat, yydescr, do_retry

    if (stktop >= 0) then {
	outtok := scanstk[stktop]
	stktop -:= 1
	token_cnt +:= 1
	rpt_progress(p,yycat,outtok,yydescr)
	return ( outtok )
    }

    retry_loop := TRUE
    while retry_loop = TRUE do {
# retry:
    c := scansavc
    cc := cclass(c)
    yylval := 0
    p := "" # Will concat to

	while( cc = WHTCC ) do {

	    if( c == "\n" ) then {
		yyline +:= 1
		yyvline +:= 1
		c := getchr()
		if( c == ESCCHAR & pflag)  then {
		    rdposition()
		    c = "\n" # Repeat check for ESCCHAR next time around
		    yyline -:= 1
		    yyvline -:= 1
		    # Line number is correct for next line
		}
	    } else {
		c := getchr()
	    }
	    cc := cclass(c)
	}
    case (cc) of {

	LETCC:
	    {
		p ||:=  c
		c := getchr()
		cc := cclass(c)
		while ( (cc == LETCC) | (cc == DIGCC) )
		do {
		    p ||:=  c
		    c := getchr()
		    cc := cclass(c)
		}
		tokenlgth := *p
		outtok := reschk_id(p,WORDID)
		scansavc := c
		token_cnt +:= 1
		yycat := "ID"
		if outtok ~= WORDID then yydescr := "RESERVED ID"
		else  yydescr := "DEFINED ID"
		rpt_progress(p,yycat,outtok,yydescr)
		return outtok
	    }
 	SQUCC: # single quote
 	{
	    p ||:=  c
	    c := getchr()
	    cc := cclass(c)
 	    saw_quote := FALSE
 	    repeat {
 		if ( cc == EOFCC | c == "\n" ) then {
 		    yyperror("Unterminated quoted identifier")
 		    break
 		}
 		if (c == "\\") then {
 		    c := getchr()
 		    case (c) of {
 			"t": p ||:= "\t"
 			"n": p ||:= "\n"
 			"r": p ||:= "\r"
 			default:  p ||:=  c

 		    }
 		} else {
 		    p ||:=  c
 		}
 		c := getchr()
 		cc := cclass(c)
 		if (saw_quote == TRUE) then {
 		    if (cc == SQUCC) then {
 			# ignore this character and keep scanning
			c := getchr()
			cc := cclass(c)
 		    } else {
 			# end of identifier
			break
 		    }
 		}
		if (cc == SQUCC) then
		    saw_quote := TRUE
		else
		    saw_quote := FALSE

 	    }



 	    outtok := WORDID
 	    yylval := stt_enter(p,*p)
#################################
	    scansavc := c
	    token_cnt +:= 1
	    yycat := "Sing Quote"
	    yydescr := "Sing Quote"
	    sing_quoted_cnt +:= 1
	    rpt_progress(p,yycat,outtok,yydescr)
	    return outtok
###################################
 	}

 	DQUCC: # double quote
 	{
#	    p ||:=  c
#	    c := getchr()
#	    cc := cclass(c)
 	    saw_quote := FALSE
 	    repeat {
 		if (cc == EOFCC | c == "\n") then {
 		    yyperror("Unterminated string")
 		    break
 		}
 		if (c == "\\") then {
 		    c := getchr()
 		    case (c) of {
 			"t": p ||:= "\t"
 			"n": p ||:= "\n"
 			"r": p ||:= "\r"
 			default:  p ||:=  c
 		    }
 		} else {
 		    p ||:=  c
 		}
 		c := getchr()
 		cc := cclass(c)
 		if (saw_quote == TRUE) then {
 		    if (cc == DQUCC) then {
 			# ignore this character and keep scanning
 			# Note that the previous double quote was saved
			c := getchr()
			cc = cclass(c)
 		    } else {
 			# end of string
			break
 		    }
 		}
		if (cc == DQUCC) then
		    saw_quote := TRUE
		else
		    saw_quote := FALSE
 	    }
 	    # Delete trailing quote.
 	    outtok := QSTRING
 	    # allocate a buffer for the string and return it
 	    yylval := p[2:-1]
#################################
	    scansavc := c
	    token_cnt +:= 1
	    yycat := "Dbl Quote"
	    yydescr := "Dbl Quote"
	    dbl_quoted_cnt +:= 1
	    rpt_progress(p,yycat,outtok,yydescr)
	    return outtok
###################################
 	}
	SEPCC:
	    {
		do_retry := FALSE
		p := scansavc := c
		c := getchr()
		if( (scansavc == "(") & (c == "*") )
		then {
		    comments_cnt +:= 1
		    # process a comment
		    startline := yyline
		    # temporary line counter used in comments
		    # so error message has a useful line number
		    # if EOF occurs inside a comment
		    startfnm := yyinfnm
		    cmtnest := 0
		    $include "pass1/scanner/scan_sep_inc.icn"
		    while( cmtnest > 0 )  do
			$include "pass1/scanner/scan_sep_inc.icn"
		    if do_retry = TRUE then {
			next
		    }
		    # put2w( S_YYLINE, yyline )
		    scansavc := c
		    next
#	    outtok := p ||:=  c
		} # if comment
		outtok := ord(p)  # not sure -- was outtok = p++
		    yyinfo("SEP p = " || p || " c = " || c || " outtok = " || outtok )
		yycat := "SEP"
		yydescr := p
		scansavc := c
		token_cnt +:= 1
		seperator_cnt +:= 1
		rpt_progress(p,yycat,outtok,yydescr)
		return ( outtok )

	    }
	DIGCC: {
	    p ||:=  c
	    c := getchr()
	    cc := cclass(c)
	    while( cc == DIGCC | cc == LETCC )
	    do
		{
		    p ||:=  c
		    c := getchr()
		    cc := cclass(c)
		}
	    outtok := UQSTRING # unquoted string
	    #allocate buffer and return it, as for quoted strings

	    yylval := p
	    yycat := "NUM"
	    yydescr := p
	    scansavc := c
	    token_cnt +:= 1
	    numeral_cnt +:= 1
	    rpt_progress(p,yycat,outtok,yydescr)
	    return ( outtok )
	}
	OPRCC:
	    {
		p ||:=  c
		c := getchr()
		cc := cclass(c)
		while ( cc == OPRCC )
		do {
		    p ||:=  c
		    c := getchr()
		    cc := cclass(c)
		}
		tokenlgth := *p
		outtok := reschk_op(p,OPID)
		scansavc := c
		token_cnt +:= 1
		yycat := "OPR"
		if outtok ~= OPID then yydescr := "RESERVED OPR"
		else yydescr := "DEFINED OPR"
		rpt_progress(p,yycat,outtok,yydescr)
		return outtok
	    }
	EOFCC:
	    {
		scansavc := "\n"  # Set things up for core image to be subsequently
		# restarted

		rpt_progress(p,"EOF",EOF,"EOF")
		return(EOF)
	    }
	BADCC:
	    {
		c := getchr()
		scansavc := c
		next
	    }

    }

    scansavc := c
}
    token_cnt +:= 1
    rpt_progress(p,yycat,outtok,yydescr)
    return ( outtok )

end

#*
# * read current position ( line no, file name )
# *   up to and including newline character
# * This routine clobbers tokenbuf & tokenlgth this shouldn't matter.
# */

    procedure rdposition()
#DJDSTOP
# #     local c, n = 0, p
# #     initial n := 0
# #     while ( (c := getchr()) == " " )
# #     yyline :=
# # 	    if /(c ? any(&digits)) then break
# # 	    n := n * 10 + (c - "0")
# # 	    c := getchr()
# # 	}
# # 	yyline = n
# #
# # 	repeat {
# # 	    if( c == EOF ) goto bad
# # 	    if( c != " " ) break;
# # 	    c := getchr();
# # 	}
# # 	if( c != """ ) goto bad;
# #     c:= getchr();
# #
# #     p := ""
# #     for(;;) {
# #         if( c == EOF ) goto bad;
# # 	if( c == """) break;
# # 	p ||:=  c
# #         c := getchr();
# #     }
# #     tokenlgth = p - tokenbuf;
# #     yyinfnm = (char *)stt_enter( tokenbuf, tokenlgth );
# #     addposition(yyinfnm, yyline);
# #
# #     goto out;
# #
# #     bad:
# # 	# There was a syntax error in the line number specification.
# #     # This is either a preprocessor error or a bizarre input pgm
# #     yyperror("Error in line number");
# #     out:
# # 	# Scan to the end of the line discarding any junk.
# #     while ( (c != "\n") & (c != EOF) ) {
# #         c:= getchr();
# #     }
# #DJDSTART
end
#DJDSTOP
# # # add new record to vrtable, associating fn and ln with the current
# # # value of yyvline
# #     procedure addposition(fn,ln)
# #     unsigned fn;  # stt pointer
# #     int ln;
# #     {   register vrline * p;
# #
# #     p = (vrline *) gc_malloc(sizeof(vrline));
# #     if (vrtable == NIL)
# #     vrtable = p;
# #     else
# #         (vrtend -> vr_next) = p;
# #     vrtend = p;
# #     (p -> vr_vline) = yyvline;
# #     (p -> vr_rline) = ln;
# #     (p -> vr_fname) = fn;
# #     (p -> vr_next ) = NIL;
# # }
# #
# #     /*
# # 	* look up contents of token buf in a reserved-word table
# #     *   of nentries entries.
# #     *
# # 	* return value if it is reserved,
# #     *   otherwise return default value,
# #     *     add token buf to string table,
# #     *       and set yylval to the string table pointer.
# #     */
# #     reschk( tbl, nentries, dflt )
# #     register struct restab *tbl;
# #     {
# #     register int m;
# #     register int l, r;
# #     register char * this_entry;
# #
# #     l = 0; r = nentries-1;
# #     while ( l < r ) {
# # 	m = (l + r) / 2;
# # 	this_entry = tbl[m].rt_txt;
# # 	if( *this_entry < *tokenbuf |
# # 	   (*this_entry == *tokenbuf & strcmp(this_entry, tokenbuf) < 0) )
# #         l = m + 1;
# # 	else
# # 	    r = m;
# #     }
# #
# #     if( strcmp(tbl[l].rt_txt,tokenbuf) == 0 )
# #     return( tbl[l].rt_val );
# #     else {
# # 	yylval = stt_enter( tokenbuf, tokenlgth );
# # 	return( dflt );
# #     }
# #
# # end
# #     /*
# # 	* push a token back onto the input
# #     */
# #DJDSTART

procedure yyunlex( tok )
    stktop +:= 1
    scanstk[stktop] = tok
end
#***************************************************************************
#*# define cclass(c) ((c) == EOF ? EOFCC : cctab[c])
procedure cclass(c)
    local it
    yyinfo("cclass1 c = " ||  c)
    if (c =="\n" | c == "\t") then
	{
	    yyinfo("cclass WHTCC")
	    write(ccode_file, "c = " || c || " class = " || WHTCC)
	    return WHTCC
	}
    if (c == EOF) then
	{
	    yyinfo("cclass EOFCC")
	    write(ccode_file, "c = " || c || " class = " || EOFCC)
	    return EOFCC
	}
    it := cctab[c]
    write(ccode_file, "c = " || c || " class = " || it)
    yyinfo("cclass c = " || c || "cctab[c] = " || it)

    return it
end
#*****************************************************************************
# Fast version of c = getchr() */

#  charfix()
# #define getchr(c)  (yycolno++, ((c = getchar()) < 32? charfix(c) : c))
# c = getchr()
procedure getchr()
    local ch, gotit
    gotit := TRUE
    yyinfo("getchr linebuf = " || linebuf)
    while  (*linebuf = 0) do {
	if \linebuf :=  read(infile) then {
	    linebuf := " " || linebuf # sub for missing end of line
	    line_cnt +:=  1
	    gotit := TRUE
	}
	else {
	    gotit := FALSE
	    return EOF
	}
    }
    if (gotit = TRUE) then {
	yyinfo("in while *linebuf = " || *linebuf)
	yyinfo(" after read linebuf = " || linebuf)
	ch := linebuf[1:2]
	yyinfo("ch = " || ch)
	char_cnt +:=  1
	linebuf := linebuf[2:0]
	yyinfo("scan getchr read linebuf = " || linebuf || "ch = " || ch)
	return ch
    }
    ch := linebuf[1:2]
    char_cnt +:=  1
    linebuf := linebuf[2:0]
    yyinfo("scan getchr from linebuf = " || linebuf || "ch = " || ch)
    return ch
end
#*****************************************************************************
#* reschk_id(p,  dflt )
procedure reschk_id(p,dflt)
    local it
    yyinfo("reschk_id p = " || p)
    if ((it := restab[p]) > 0) then
	{
	    reserved_id_cnt +:= 1
	    return it
	}
    else
	{
	    defined_id_cnt +:= 1
	    yylval := stt_enter(p,*p)
	    yydescr := yylval
	    return dflt
	}
end
procedure reschk_op(p,dflt)
    local it
    yyinfo("reschk_op p = " || p)
    if ((it := restab[p]) > 0) then
	{
	    reserved_op_cnt +:= 1
	    return it
	}
    else
	{
	    defined_op_cnt +:= 1
	    yylval := stt_enter(p,*p)
	    yydescr := yylval
	    return dflt
	}
end

#DJDSTOP
# # ***************************************************************************
# #     *# define cclass(c) ((c) == EOF ? EOFCC : cctab[c])
# # cclass    	  debug = "cclass1 c = " c
# # DIFFER(c,"\n")     :s(cclass_skip1a)
# # cclass = WHTCC     :(RETURN)
# # cclass_skip1a	  DIFFER(c,"\t")     :s(cclass_skip1b)
# # cclass = WHTCC     :(RETURN)
# # cclass_skip1b      DIFFER(c,EOF)    :s(cclass_skip2)
# # cclass = EOFCC     :(RETURN)
# # cclass_skip2	  debug = "cclass2 c = " c
# # cclass = cctab[c]         :(RETURN)
# # *****************************************************************************
# #     * Fast version of c = getchr() */
# #
# #     *  charfix()
# # * #define getchr(c)  (yycolno++, ((c = getchar()) < 32? charfix(c) : c))
# # * c = getchr()
# # getchr   debug = "getchr2 linebuf = " linebuf
# # EQ(SIZE(linebuf),0) :f(getchr_sk2)
# # * indicate new line (really 2 chars - snobol doesn't return new line
# # 	 linebuf =  infile :f(getchr_sk)
# # 	 line_cnt = line_cnt + 1
# #  debug = linebuf
# # 	 getchr = "\n"     :(RETURN)
# # getchr_sk2	 linebuf LEN(1) . getchr =
# # 		 char_cnt = char_cnt + 1
# # 		 DIFFER(getchr,tab_chr)  :s(getchr_sk3)
# # * handle tab character
# # 		 getchr = "\t"
# # getchr_sk3	 	  		 :(RETURN)
# # getchr_sk getchr = EOF  		  :(RETURN)
# # *****************************************************************************
# # * reschk_id(p,  dflt )
# # reschk_id  debug = "reschk_id p = " p
# # 	   debug = "restab[p] = " restab[p]
# # 	   DIFFER(restab[p])  :f(reschk_id_empty)
# # 	   reserved_id_cnt = reserved_id_cnt + 1
# # 	reschk_id = restab[p] :(RETURN)
# # reschk_id_empty yylval = stt_enter(p,SIZE(p))
# # 		yydescr = yylval
# # 		reschk_id = dflt :(RETURN)
# # **************************************************************************
# # * reschk_op(p,  dflt )
# # reschk_op  debug = "reschk_op p = " p
# # 	   debug = "restab[p] = " restab[p]
# # 	   DIFFER(restab[p])  :f(reschk_op_empty)
# # 	   reserved_op_cnt = reserved_op_cnt + 1
# #
# # 	reschk_op = restab[p] :(RETURN)
# # reschk_op_empty yylval = stt_enter(p,SIZE(p))
# # 		yydescr = yylval
# # 		reschk_op = dflt  :(RETURN)
# #
# # ****************************************************************************
# #DJDSTART
procedure rpt_progress(p,yycat,outtok,yydescr)
    local sz,it,sz1,sz2,sz3,it5,prog_part1
    initial {
	sz := 26 - *"token"
	if (sz < 2) then sz := 2
	sz1 := 18 - *"yydescr"
	if (sz1 < 2) then sz1 := 2
	sz2 := 18 - *"yycat"
	if (sz2 < 2) then sz2 := 2
	sz3 := 8 - *"outtok"
	if (sz3 < 2) then sz3 := 2
	prog_part1 := "token" || repl(" ",sz) || "yydescr" || repl(" ",sz1) || "yycat" || repl(" ",sz2) || "outtok"  || repl(" ",sz3) ||  "yylval"
	write(progress,prog_part1)
    }
    sz := 26 - *p
    if (sz < 2) then sz := 2
    it := string(yydescr)
    sz1 := 18 - *it
    if (sz1 < 2) then sz1 := 2
    sz2 := 18 - *yycat
    if (sz2 < 2) then sz2 := 2
    sz3 := 8 - *outtok
    if (sz3 < 2) then sz3 := 2
    it5 := string(yylval)

    prog_part1 := p || repl(" ",sz) || yydescr || repl(" ",sz1) || yycat || repl(" ",sz2) || outtok  || repl(" ",sz3) ||  it5
    write(progress,prog_part1)
end