scanner.p

<B>Digital的Unix操作系统VAX 4.2源码</B>

procedure GetComment(comment : char);
var
    stop : boolean;
begin {GetComment}
    inComment := true;
    stop := false;
    repeat
	if ch = '*' then begin
	    NextChar;
	    if (ch = ')') then begin
		NextChar;
		stop := true;
	    end;
	end else if ch = '(' then begin
	    NextChar;
	    if (ch = '*') then begin
		NextChar;
		{ nested comment, recur }
		GetComment('(');
	    end;
	end else begin
	    NextChar;
	end;
    until stop;
    inComment := false;
end; {GetComment}

begin {NextTok}
    continue := true;
    while continue do begin
	if endOfFile then begin
	    token.kind := TKENDOFFILE;
	    continue := false;
	    readingFile := false;
	end else if ch in [' ',chr(TABCHAR),chr(FORMFEEDCHAR),chr(LINEFEEDCHAR),
			    chr(RETURNCHAR)]
	then begin
	    NextChar;
	end else if ch in ['a'..'z','A'..'Z','@'] then begin
	    repeat
		if upperCaseFlag then begin
		    if ch in ['a'..'z'] then begin
			ch := chr(ord(ch)-ord('a')+ord('A'));
		    end;
		end;
		AddChar(ch);
		NextChar;
	    until not (ch in ['a'..'z', 'A'..'Z', '0'..'9']);
	    token.str := NewString;
	    token.kind := KeyLookUp(token.str);  {see if keyword or ident}
	    continue := false;		{exit procedure}
	end else if ch in ['0'..'9'] then begin
	    {handle numbers}
	    HandleNumbers(token);		{handles ints and reals}
	    continue := false;		{exit procedure}
	end else if (ch in [' '..'~']) then begin
	    case (ch) of
		'$','%','?','\','_','`','!','~' : begin
		    token.kind := TKBAD;
		    NextChar;
		    continue := false;
		end;
		'<' : begin
		    NextChar;
		    if (ch = '>') then begin
			token.kind := TKNOTEQUAL;
			NextChar;
		    end else if (ch = '=') then begin
			token.kind := TKLSEQUAL;
			NextChar;
		    end else begin
			token.kind := TKLESS;
		    end;
		    continue := false;		{exit procedure}
		end;
		'=' : begin
		    token.kind := TKEQUALS;
		    NextChar;
		    continue := false;		{exit procedure}
		end;
		'>' : begin
		    NextChar;
		    if (ch = '=') then begin
			token.kind := TKGREQUAL;
			NextChar;
		    end else begin
			token.kind := TKGREATER;
		    end;
		    continue := false;		{exit procedure}
		end;
		':' : begin
		    NextChar;
		    if (ch = '=') then begin
			token.kind := TKASSIGN;
			NextChar;
		    end else begin
			token.kind := TKCOLON;
		    end;
		    continue := false;		{exit procedure}
		end;
		'+' : begin
		    token.kind := TKPLUS;
		    NextChar;
		    continue := false;		{exit procedure}
		end;
		'-' : begin
		    token.kind := TKMINUS;
		    NextChar;
		    continue := false;		{exit procedure}
		end;
		'*' : begin
		    token.kind := TKASTERISK;
		    NextChar;
		    continue := false;		{exit procedure}
		end;
		';' : begin
		    if previousToken <> TKSEMICOLON then begin
			token.kind := TKSEMICOLON;
			NextChar;
			continue := false;	{exit procedure}
		    end else begin
			NextChar;		{ skip extra ;s }
		    end;
		end;
		')' : begin
		    token.kind := TKRPAREN;
		    NextChar;
		    continue := false;		{exit procedure}
		end;
		'(' : begin
		    NextChar;
		    if (ch = '*') then begin		{start comment}
			GetComment('(');
		    end else begin
			token.kind := TKLPAREN;
			continue := false;		{exit procedure}
		    end;
		end;
		'/' : begin
		    token.kind := TKSLASH;
		    NextChar;
		    continue := false;		{exit procedure}
		end;
		'{' : begin
		    token.kind := TKLBRACE;
		    NextChar;
		    continue := false;		{exit procedure}
		end;
		'}' : begin
		    token.kind := TKRBRACE;
		    NextChar;
		    continue := false;		{exit procedure}
		end;
		'|' : begin
		    token.kind := TKBAR;
		    NextChar;
		    continue := false;		{exit procedure}
		end;
		'^' : begin
		    token.kind := TKUPARROW;
		    NextChar;
		    continue := false;		{exit procedure}
		end;
		'.' : begin
		    NextChar;
		    if (ch = '.') then begin
			token.kind := TKDOTDOT;
			NextChar;
		    end else begin
			token.kind := TKDOT;
		    end;
		    continue := false;		{exit procedure}
		end;
		'[' : begin
		    token.kind := TKLBRACKET;
		    NextChar;
		    continue := false;		{exit procedure}
		end;
		']' : begin
		    token.kind := TKRBRACKET;
		    NextChar;
		    continue := false;		{exit procedure}
		end;
		'&' : begin
		    token.kind := TKAMPERSAND;
		    NextChar;
		    continue := false;		{exit procedure}
		end;
		',' : begin
		    token.kind := TKCOMMA;
		    NextChar;
		    continue := false;		{exit procedure}
		end;
		'#' : begin
		    token.kind := TKSHARP;
		    NextChar;
		    continue := false;		{exit procedure}
		end;
		'''', '"' : begin		{string}
		    strDelim := ch;		{save apostr. or quotes}
		    NextChar;
		    instring := true;
		    stringStartLine := currLine;
		    repeat
			if ch = strDelim then begin
			    NextChar;
			    if not standardStringFlag and (ch = strDelim)
			    then begin
				{ doubled delimiter = delimiter character }
				AddChar(ch);
				NextChar;
			    end else begin
				{ must have been end of string }
				instring := false;
			    end;
			end else if not standardStringFlag and (ch = '\')
			then begin
			    NextChar;
			    if ch = 'n' then begin
				AddCharX(LINEFEEDCHAR);	{ newline }
			    end else if ch = 't' then begin
				AddCharX(TABCHAR);	{ tab }
			    end else if ch = 'r' then begin
				AddCharX(RETURNCHAR);	{ return }
			    end else if ch = 'f' then begin
				AddCharX(FORMFEEDCHAR);	{ form feed }
			    end else if ch = 'b' then begin
				AddCharX(BACKSPACECHAR);{ backspace }
			    end else if ch in ['0'..'9'] then begin
				i := 1;
				value := 0;
				while (i <= 3) and (ch in ['0'..'9']) do begin
				    value := value*8 + ord(ch)-ord('0');
				    NextChar;
				    i := i + 1;
				end;
				AddCharX(value);
				PrevChar;	{ don't consume extra char }
			    end else begin
				AddChar(ch);		{ etc. ', ", \ }
			    end;
			    NextChar;
			end else begin
			    if currLine <> stringStartLine then begin
				Error('String crosses line boundary');
				instring := false;
			    end;
			    { normal character }
			    AddChar(ch);
			    NextChar;
			end;
		    until not instring;
		    str := NewString;
		    if str^.length = 1 then begin
			token.kind := TKCHARCONST;
			new(token.con);
			token.con^.kind := DTCHAR;
			token.con^.charVal := GetCharX(str,0);
		    end else begin
			token.kind := TKSTRCONST;
			new(token.con);
			token.con^.kind := DTSTRING;
			token.con^.strVal := str;
		    end; {if}
		    continue := false;		{exit procedure}
		end;
	    end; {case}
	end else begin
	    AddChar(ch);
	    ErrorName(NewString,'Invalid character');
	    NextChar;
	    token.kind := TKBAD;
	    continue := false;
	end; {if}
    end; {while}
    previousToken := token.kind;
end; {NextTok}

function yylex : Token;
var
	i : integer;
begin
    NextTok(currToken);
    if currToken.kind = TKIDENT then begin
	yylval.str := currToken.str;
    end else if currToken.kind in [TKCARDCONST, TKREALCONST, TKBOOLCONST,
		TKCHARCONST, TKSTRCONST]
    then begin
	yylval.con := currToken.con;
    end;
    if 't' in debugSet then begin
	write(currToken.kind,' ');
	if (currToken.kind in [TKIDENT, TKCARDCONST, TKREALCONST, TKBOOLCONST,
			    TKCHARCONST, TKSTRCONST]) then begin
	    case (currToken.kind) of
		TKIDENT : begin
		    write('ident: ');
		    WriteString(output,currToken.str);
		    writeln;
		end;
		TKCARDCONST : begin
		    writeln('int: ',currToken.con^.cardVal:1:0);
		end;
		TKREALCONST : begin
		    writeln('real: ', currToken.con^.realVal);
		end;
		TKBOOLCONST : begin
		    writeln('bool: ', currToken.con^.boolVal);
		end;
		TKCHARCONST : begin
		    write('char: ',currToken.con^.charVal);
		    writeln;
		end;
		TKSTRCONST : begin
		    write('string: ');
		    WriteString(output,currToken.con^.strVal);
		    writeln;
		end;
	    end; {case}
	end else begin		{ must be token or keyword }
	    writeln('currToken: ',currToken.kind);
	end;
    end; {if}
    yylex := currToken.kind;
end; {yylex}

procedure LineWrite;
var
	i : integer;
begin
    for i := 1 to inFile^.size do begin
	if inFile^.line[i] in [MINCHAR..MAXCHAR] then begin
	    write(output,chr(inFile^.line[i]));
	end else begin
	    write(output,'?');
	end;
    end;
end;

procedure yyerror(var msgx : ErrorString);
var
    i : integer;
    msg : ErrorString;
begin
    msg := '  ';
    i := 1;
    while msgx[i] <> chr(0) do begin
	msg[i] := msgx[i];
	i := i + 1;
    end;
    Error(msg);
end;