SableCC2Hs-0.0.0.1: prolog/parser.pl

:- consult('parser_tables.pl').
:- consult('trim_ast.pl').

test1:- lift(Input),runParser(Input,_).
test2:-runParser("#EXPRESSION\n 1+1",_).
test3:-runParser("#PREDICATE\n e:M",_).


lift("\
MACHINE Lift\n\
\n\
ABSTRACT_VARIABLES  floor\n\
\n\
INVARIANT /*test comment*/ floor : 0..99\n\
\n\
ASSERTIONS floor>=0\n\
INITIALISATION floor := 4\n\
\n\
OPERATIONS\n\
\n\
	inc = PRE floor<99 THEN floor := floor + 1 END ;\n\
	\n\
	dec = BEGIN floor := floor - 1 END;\n\
	\n\
	result  <-- ground = \n\
	            IF floor=0 THEN\n\
	             result := TRUE\n\
	            ELSE\n\
	             result := FALSE\n\
	            END\n\
	\n\
END").


runParser(Input,AST2):-
  lexerLoop(Input,mode_0/0,[],LexerTokens),!,
  mapTokenIDs(LexerTokens,ParserTokens),!,
%  printTokens(ParserTokens),
  parserLoop([pstate_0/dummyStack],ParserTokens,[(_/AST1)|_]),!,
%  write(AST1),nl,nl,
  trim(AST1,AST2),!,
  write(AST2).

parserLoop(Stack,Input,Res) :-
  findAction(Stack,Input,Action),!,
  parserLoop2(Action,Stack,Input,Res).
parserLoop2(accept,Stack,_,Stack).
parserLoop2(error(ErrorID),_Stack,_,_Res) :- !,errorMessage(ErrorID,Msg),name(N,Msg),throw(parseError(N)).
parserLoop2(shift(_),_Stack,[],_Res) :- !,throw(parserBug('shift action with empty input')).
parserLoop2(shift(NewState),Stack,[H|Rest],Res) :- !,
  parserLoop([(NewState/H)|Stack],Rest,Res).
parserLoop2(reduce(ID,PopCount,GotoIndex),Stack,Input,Res) :- !,
  takeNodes(PopCount,Stack,Nodes),
  constructAST(ID,Nodes,AST),
  dropStack(PopCount,Stack,RestStack),
  findGoto(GotoIndex,RestStack,NewState),
  parserLoop([(NewState/AST)|RestStack],Input,Res).

findAction([], _,_) :- !, throw(parserBug('findAction : empty Stack')).
findAction(_ ,[],_) :- !, throw(parserBug('findAction : empty Input')).
findAction([(StateID/_)|_],[(TokenID/_)|_],Res) :- action(StateID, TokenID, Res),!.
findAction([(StateID/_)|_],_,Res) :- !,defaultAction(StateID,Res).
findAction(_,_,_) :- trow(parserBug('findAction : lookup failed')).

findGoto(_GI,[],_Res) :- !, throw(parserBug('findGoto : empty stack')).
findGoto(GI,[(StateID/_)|_],Res) :- goto(GI,StateID,Res),!.
findGoto(GI,_,Res) :- !,defaultGoto(GI,Res).
findGoto(_,_,_) :- trow(parserBug('findGoto : look failed')).

takeNodes(0,_,[]).
takeNodes(I,[(_/Node)|Rest],[Node|RR]):- !,
  I2 is I-1,
  takeNodes(I2,Rest,RR).

dropStack(0,R,R).
dropStack(I,[_|T],Res) :- !,
  I2 is I-1,
  dropStack(I2,T,Res).

constructAST(ID,Nodes,AST) :-
  reductionRule(ID,Nodes,Term),
  evalReduction(Term,AST).

evalReduction(var(X),X):- !.
evalReduction(emptyList,[]):- !.
evalReduction(singletonList(L),[Res]):-!,evalReduction(L,Res).
evalReduction(appendList(L1,L2),Res):- !,
  evalReduction(L1,R1),
  evalReduction(L2,R2),
  append(R1,R2,Res).
evalReduction(appendNode(L,N),Res):-!,
  evalReduction(L,R1),
  evalReduction(N,R2),
  append(R1,[R2],Res).
evalReduction(newNode(Constructor1,Constructor2,L),Res):-!,
  reduceList(L,Nodes),
  % for almost all cases Construct1 has all information we need and we could almost write
  % Res=..[Constructor1|[pos(0,0,0,0,0,0)|Nodes]].
  % but there are two exceptions ! ('true' and 'false')
  % therefore we keep both and use an extra trim pass.
  Res = node(Constructor1,Constructor2,pos(0,0,0,0),Nodes).
evalReduction(head(E),Res):-!,
  evalReduction(E,[Res]).
evalReduction(_,_):-throw(parserBug('cannot eval reduction')).

reduceList([],[]).
reduceList([H|T],[H2|T2]) :-
  evalReduction(H,H2),
  reduceList(T,T2).

mapTokenIDs([],[(EOF_ID/'dummy eof token')]):-eof_token_id(EOF_ID).
mapTokenIDs([(TokenID/TokenString)|Rest],[(NewID/TokenString)|R]) :-
  token(TokenID,_,just(NewID)),!,
  mapTokenIDs(Rest,R).
mapTokenIDs([(TokenID/_)|Rest],R) :-
  token(TokenID,_,nothing),!,
  mapTokenIDs(Rest,R).

printTokens([]).
printTokens([(TokenID/TokenString)|Rest]) :-
  format("tokenID :"),
  write(TokenID),
  format(" TokenString "),
  format('~s',[TokenString]),nl,
  printTokens(Rest).

lexerLoop([],_,Acc,Res):- reverse(Acc,Res).
lexerLoop(Input,Mode/Nest,Acc,Res) :-
  checkState(left('error:no token recognized'),state_0/Mode,Input,[],NextToken),!,
  lexerLoop2(Mode/Nest,Acc,NextToken,Res).

lexerLoop2(ModeNest,Acc,right(NewInput,TokenString,TokenID),Res) :-
  updateMode(ModeNest,TokenID,NewModeNest),
  lexerLoop(NewInput,NewModeNest,[TokenID/TokenString|Acc],Res).
lexerLoop2(_ModeNest,_Acc,left(Err),_Res) :- throw(Err).

scanChar(_,_,[],_,_Res) :- throw('internalLexerError').
scanChar(LastAcceptedToken,State/Mode,[H|Rest],Acc,Res) :-
  transition(State,Mode,ITable),
  lookupInterval(H,ITable,NextState),
  scanChar2(NextState,LastAcceptedToken,State/Mode,[H|Rest],Acc,Res).

scanChar2(nothing,LastAcceptedToken,_,_,_,LastAcceptedToken).
scanChar2(just(epsilon(NewState)),LastAcceptedToken,_/Mode,[H|Rest],Acc,Res):-
  scanChar(LastAcceptedToken,NewState/Mode,[H|Rest],Acc,Res).

scanChar2(just(notEpsilon(NewState)),LastAcceptedToken,_/Mode,[H|Rest],Acc,Res):-
  checkState(LastAcceptedToken,NewState/Mode,Rest,[H|Acc],Res).


checkState(LastAcceptedToken,State/Mode,Input,Acc,Res) :-
  accepts(State,Mode,Accept),!,
  checkState2(Accept,LastAcceptedToken,State/Mode,Input,Acc,Res).

checkState2(just(TokenID),_LastAcceptedToken,_,[],Acc,right([],Seen,TokenID)) :- !,
  reverse(Acc,Seen).

checkState2(nothing,LastAcceptedToken,_,[],_Seen,LastAcceptedToken).

checkState2(just(TokenID),_LastAcceptedToken,State/Mode,Input,Acc,Res) :- !,
  reverse(Acc,Seen),
  scanChar(right(Input,Seen,TokenID),State/Mode,Input,Acc,Res).

checkState2(nothing,LastAcceptedToken,State/Mode,Input,Acc,Res) :- !,
  scanChar(LastAcceptedToken,State/Mode,Input,Acc,Res).

lookupInterval(_,leaf,nothing).
lookupInterval(Char,node(LowTree,LowChar,_,_,_),Res) :-
  Char < LowChar, ! , lookupInterval(Char,LowTree,Res).
lookupInterval(Char,node(_,_,_,HighChar,HighTree),Res) :-
  Char > HighChar, ! , lookupInterval(Char,HighTree,Res).
lookupInterval(Char,node(_,LowChar,State,HighChar,_),just(State)) :-
  Char =< HighChar, Char >= LowChar.

%
% hardcoded token IDs :
% token(token_0, 'TComment', nothing).
% token(token_1, 'TCommentEnd', nothing).
%


updateMode(Mode/Nest,TokenID,Res) :-
  modeTransition(TokenID, Mode,TMode),
  updateMode2(TMode/Nest, TokenID, Res).

updateMode2(Mode/Nest, token_0,Res) :- !,
  NewNest is Nest + 1,
  updateMode3(Mode/NewNest, token_0,Res).

updateMode2(Mode/Nest, token_1,Res) :- !,
  NewNest is Nest - 1,
  updateMode3(Mode/NewNest, token_1,Res).

updateMode2(ModeNest,Token,Res) :- updateMode3(ModeNest,Token,Res).

updateMode3(_/0,token_1,mode_0/0):- !.
updateMode3(ModeNest,_,ModeNest).