<<>> <> <> <> DIRECTORY Ascii, IO, M3Scan, RefText, Rope; M3ScanImpl: CEDAR PROGRAM IMPORTS Ascii, IO, RefText, Rope EXPORTS M3Scan = BEGIN OPEN M3Scan; GetM3Token: PUBLIC PROC [stream: IO.STREAM, buffer: REF TEXT, flushComments: BOOL Ź FALSE] RETURNS [tokenKind: TokenKind, token: REF TEXT, charsSkipped: INT, error: TokenError] = { char: CHAR; NextChar: PROC RETURNS [CHAR] = INLINE { char Ź stream.GetChar[]; token Ź RefText.InlineAppendChar[token, char]; RETURN [Ascii.Lower[char]] }; NextCharSkip: PROC RETURNS [CHAR] = INLINE { <> char Ź stream.GetChar[]; charsSkipped Ź charsSkipped + 1; RETURN [char]; }; PutbackChar: PROC = { stream.Backup[token[token.length Ź token.length - 1]]; }; <> AcceptExtendedChar: PROC RETURNS [success: BOOL] = { <> ENABLE IO.EndOfStream => GO TO Failure; SELECT NextChar[] FROM 'n, 'r, 't, 'f, '\', '\", '\\ => RETURN[TRUE]; IN ['0..'7] => { THROUGH [1..2] DO IF NextChar[] NOT IN ['0..'7] THEN GO TO Failure ENDLOOP; RETURN[TRUE]; }; ENDCASE => GO TO Failure; EXITS Failure => { error Ź $extendedChar; RETURN[FALSE] } }; AcceptRealTail: PROC [] = { <> DO SELECT NextChar[ ! IO.EndOfStream => GO TO Accept] FROM IN ['0..'9] => NULL; 'e, 'd, 'x => { [] Ź AcceptExponent[]; RETURN }; ENDCASE => { PutbackChar[]; RETURN }; ENDLOOP; EXITS Accept => RETURN }; AcceptExponent: PROC RETURNS [success: BOOL] = { <> SELECT NextChar[ ! IO.EndOfStream => GO TO Failure] FROM '-, '+ => [] Ź NextChar[ ! IO.EndOfStream => GO TO Failure]; ENDCASE => NULL; IF char NOT IN ['0..'9] THEN GO TO Failure; DO IF NextChar[ ! IO.EndOfStream => GO TO Success] NOT IN ['0..'9] THEN { PutbackChar[]; GO TO Success } ENDLOOP; EXITS Success => RETURN [TRUE]; Failure => { error Ź $numericLiteral; RETURN [FALSE] }; }; error Ź $none; token Ź buffer; token.length Ź 0; charsSkipped Ź 0; { DO token.length Ź 0; SELECT NextChar[ ! IO.EndOfStream => GO TO EOFReturn] FROM IN [IO.NUL .. IO.SP] => { <> charsSkipped Ź charsSkipped + 1; }; '( => { <> prev: CHAR Ź IO.CR; depth: INT Ź 1; tokenKind Ź $tokenSINGLE; IF NextChar[! IO.EndOfStream => GO TO Return] # '* THEN GO TO PutbackReturn; tokenKind Ź $tokenCOMMENT; IF flushComments THEN { charsSkipped Ź charsSkipped + 2; -- for the leading two dashes DO SELECT NextCharSkip[ ! IO.EndOfStream => GO TO eof] FROM ') => IF prev = '* THEN {IF (depth Ź depth-1) = 0 THEN EXIT}; '* => IF prev = '( THEN {depth Ź depth+1; char Ź 'x}; <<"Sys. Prog. with M3" gives no consideration to string literals within comments.>> ENDCASE; prev Ź char; ENDLOOP; EXITS eof => {}; } ELSE DO SELECT NextChar[ ! IO.EndOfStream => GO TO Return] FROM ') => IF prev = '* THEN {IF (depth Ź depth-1) = 0 THEN GO TO Return}; <> '* => IF prev = '( THEN {depth Ź depth+1; char Ź 'x}; ENDCASE; prev Ź char; ENDLOOP; }; '< => { <> prev: CHAR Ź IO.CR; depth: INT Ź 0; tokenKind Ź $tokenSINGLE; SELECT NextChar[! IO.EndOfStream => GO TO Return] FROM '* => depth Ź 1; ': => GO TO DoubleReturn; '= => GO TO DoubleReturn; ENDCASE => GO TO PutbackReturn; tokenKind Ź $tokenPRAGMA; DO SELECT NextChar[ ! IO.EndOfStream => GO TO Return] FROM '> => IF prev = '* THEN {IF (depth Ź depth-1) = 0 THEN GO TO Return}; < in the pragma>> '* => IF prev = '< THEN {depth Ź depth+1; char Ź 'x}; ENDCASE; prev Ź char; ENDLOOP; }; IN ['a .. 'z] => { <> tokenKind Ź $tokenID; DO SELECT NextChar[ ! IO.EndOfStream => GO TO Return] FROM IN ['a..'z], IN ['0..'9], '_ => NULL; ENDCASE => GO TO PutbackReturn; ENDLOOP; }; IN ['0 .. '9] => { <> tokenKind Ź $tokenDECIMAL; WHILE NextChar[ ! IO.EndOfStream => GO TO Return] IN ['0..'9] DO ENDLOOP; SELECT Ascii.Lower[char] FROM '. => { IF NextChar[ ! IO.EndOfStream => GO TO Invalid] IN ['0 .. '9] THEN { -- REAL tokenKind Ź $tokenREAL; AcceptRealTail[]; GO TO Return } ELSE { -- DECIMAL followed by dotdot PutbackChar[]; GO TO PutbackReturn } }; '_ => { tokenKind Ź $tokenBASED; DO SELECT NextChar[ ! IO.EndOfStream => GO TO Return] FROM IN ['0 .. '9] => NULL; IN ['a .. 'f] => NULL; ENDCASE => GO TO PutbackReturn ENDLOOP; }; ENDCASE => GO TO PutbackReturn; EXITS Invalid => { error Ź $numericLiteral; GO TO ErrorReturn } }; '. => { <> tokenKind Ź $tokenSINGLE; SELECT NextChar[ ! IO.EndOfStream => GO TO Return] FROM '. => GO TO DoubleReturn; -- dotdot ENDCASE => GO TO PutbackReturn; -- dot }; ',, ';, '#, '+, '-, '*, '/, '^, '&, '), '[, '], '{, '}, '| => GO TO SingleReturn; '\' => { <> tokenKind Ź $tokenCHAR; SELECT NextChar[ ! IO.EndOfStream => GO TO Illegal] FROM '\\ => IF NOT AcceptExtendedChar[] THEN GO TO ErrorReturn; '\' => GO TO Illegal; ENDCASE => NULL; IF NextChar[ ! IO.EndOfStream => GO TO Illegal] # '\' THEN GO TO Illegal; EXITS Illegal => { error Ź $charLiteral; GO TO ErrorReturn }; }; '\" => { <> tokenKind Ź $tokenTEXT; DO c: CHAR Ź NextChar[ ! IO.EndOfStream => GO TO Illegal]; SELECT c FROM '\" => GO TO Return; '\\ => IF NOT AcceptExtendedChar[] THEN GO TO ErrorReturn; ENDCASE => NULL; ENDLOOP; EXITS Illegal => { error Ź $stringLiteral; GO TO ErrorReturn }; }; '= => { <'>> tokenKind Ź $tokenSINGLE; SELECT NextChar[ ! IO.EndOfStream => GO TO Return] FROM '> => GO TO DoubleReturn; ENDCASE => GO TO PutbackReturn; }; '>, ': => { <' or '>='>> tokenKind Ź $tokenSINGLE; SELECT NextChar[ ! IO.EndOfStream => GO TO Return] FROM '= => GO TO DoubleReturn; ENDCASE => GO TO PutbackReturn; }; ENDCASE => { error Ź $singleChar; GO TO ErrorReturn }; ENDLOOP; EXITS Return => { RETURN }; PutbackReturn => { PutbackChar[]; RETURN }; SingleReturn => { tokenKind Ź $tokenSINGLE; RETURN }; DoubleReturn => { tokenKind Ź $tokenDOUBLE; RETURN }; EOFReturn => { tokenKind Ź $tokenEOF; RETURN }; ErrorReturn => { tokenKind Ź $tokenERROR; RETURN }; } }; GetM3TokenRope: PUBLIC PROC [stream: IO.STREAM, flushComments: BOOL] RETURNS [tokenKind: TokenKind, token: Rope.ROPE, charsSkipped: INT] = { buffer: REF TEXT = RefText.ObtainScratch[100]; { ENABLE UNWIND => RefText.ReleaseScratch[buffer]; tokenText: REF TEXT; [tokenKind: tokenKind, token: tokenText, charsSkipped: charsSkipped] Ź GetM3Token[stream, buffer, flushComments]; SELECT tokenKind FROM tokenEOF => ERROR IO.EndOfStream[stream]; tokenERROR => ERROR IO.Error[$SyntaxError, stream]; ENDCASE; token Ź Rope.FromRefText[tokenText]; }; RefText.ReleaseScratch[buffer]; RETURN [tokenKind, token, charsSkipped]; }; ScanBack: PUBLIC PROC [base: Rope.ROPE, from: INT] RETURNS [start: INT] = { len: INT ~ base.Length[]; lm1: INT ~ len-1; char: CHAR Ź ' ; NextChar: PROC RETURNS [CHAR] = INLINE { IF (from Ź from-1) < 0 THEN ERROR IO.EndOfStream[NIL]; char Ź base.Fetch[from]; RETURN [Ascii.Lower[char]]}; PeekNext: PROC RETURNS [CHAR] = INLINE { IF from>0 THEN RETURN base.Fetch[from-1] ELSE RETURN [' ]}; PeekPrev: PROC RETURNS [CHAR] = INLINE { IF from0 DO SELECT NextChar[] FROM '* => IF NextChar[]=open THEN depth Ź depth-1; close => IF NextChar[]='* THEN depth Ź depth+1; ENDCASE => NULL; ENDLOOP; RETURN [from]}; { ENABLE IO.EndOfStream => GOTO PutbackReturn; maybeInside: BOOL Ź TRUE; WHILE NextChar[] IN [IO.NUL .. IO.SP] DO SELECT char FROM '\n, '\r, '\l => maybeInside Ź FALSE; ENDCASE => NULL; ENDLOOP; SELECT char FROM '\', '\" => { sc: CHAR ~ char; p1: INT ~ from; DO pos, n: INT Ź 0; WHILE NextChar[] # sc DO IF maybeInside THEN SELECT char FROM '\n, '\r, '\l => RETURN [p1]; ENDCASE => NULL; ENDLOOP; pos Ź from; WHILE NextChar[] = '\\ DO n Ź n+1 ENDLOOP; IF (n MOD 2) = 0 THEN RETURN [pos] ELSE IF n>0 THEN maybeInside Ź FALSE; from Ź from+1; ENDLOOP}; IN ['A..'Z], IN ['a..'z], IN ['0..'9], '_, '+, '-, '. => { last: CHAR Ź char; DO SELECT NextChar[] FROM IN ['a..'z], IN ['0..'9], '_, '+, '- => NULL; '. => IF last='. THEN RETURN [from]; ENDCASE => EXIT; last Ź char ENDLOOP; RETURN [from+1]}; ') => IF NextChar[] = '* THEN RETURN SkipNester['(, ')] ELSE RETURN [from+1]; '> => SELECT NextChar[] FROM '* => RETURN SkipNester['<, '>]; '= => RETURN [from]; ENDCASE => RETURN [from+1]; '* => SELECT PeekNext[] FROM '(, '< => RETURN [from-1]; ENDCASE => SELECT PeekPrev[] FROM ') => RETURN SkipNester['(, ')]; '> => RETURN SkipNester['<, '>]; ENDCASE => RETURN [from]; '= => SELECT NextChar[] FROM ':, '<, '> => RETURN [from]; ENDCASE => RETURN [from+1]; ': => SELECT NextChar[] FROM '< => RETURN [from]; ENDCASE => RETURN [from+1]; ENDCASE => RETURN [from]; EXITS PutbackReturn => {from Ź from+1; RETURN [from]} }}; END.