$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
