home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 9 / 09.iso / l / l216 / 1.ddi / PARSMAIN.PRO < prev    next >
Encoding:
Text File  |  1987-03-23  |  12.6 KB  |  475 lines
  1. /**********************************************************************
  2.  
  3.      Turbo Prolog Toolbox
  4.      (C) Copyright 1987 Borland International.
  5.  
  6.             Parser generator
  7.  
  8.             Invariants
  9.             ==========
  10.  
  11. About names
  12.   Production names are always in upper case.
  13.   Functors are in lowercase
  14.  
  15. **********************************************************************/
  16.  
  17. nobreak
  18. code=3500
  19. project "parser"
  20. include "parser.def"
  21.  
  22. include "tpreds.pro"
  23. include "lineinp.pro"
  24. include "filename.pro"
  25. include "status.pro"
  26. include "pulldown.pro"
  27.  
  28. /************************************************************************
  29.             Check parser
  30. ************************************************************************/
  31.  
  32. PREDICATES
  33.   new_error(STRING,CURSOR)
  34.   check_parser
  35.   check_domains
  36.   check_graml(GRAMTOKL)
  37.   check_gramtok(GRAMTOK)
  38.   check_term(TERM)
  39.   check_prod(CURSOR,PRODNAME)
  40.   check_doml(CURSOR,PRODNAMES)
  41.   check_groups(PRODNAME,PRODGROUPS)
  42.   none_selfref(PRODNAME,PRIORGROUP)
  43.   check_priorgroup(PRODNAME,PRIORGROUP)
  44.   check_assoc(PRODNAME,ASSOC,GRAMTOKL)
  45.   check_terms
  46.   check_compatterml(PRODNAME,TERML)
  47.   check_compatrestlist(TERM,TERML)
  48.   check_compatterm(TERM,TERM)
  49.   check_equalsize(CURSOR,GRAMTOKL,TERM)
  50.   gettermdoml(TERM,PRODNAMES)
  51.   check_equallength(CURSOR,PRODNAMES,PRODNAMES)
  52.   check_reserved(STRING,CURSOR)
  53.   reserved_word(STRING)
  54.   check_tok(TOKK)
  55.   check_sepp(SEPARATOR,CURSOR)
  56.  
  57. CLAUSES
  58.   check_parser:-retract(error(_,_)),fail.
  59.   check_parser:-
  60.     check_domains,
  61.     check_terms.
  62.  
  63.   check_domains:-
  64.     p(_,list(PROD1,CURSOR,_,SEPARATOR)),
  65.     check_sepp(SEPARATOR,CURSOR),
  66.     not(check_prod(CURSOR,PROD1)),
  67.     !,fail.
  68.   check_domains:-
  69.     p(PRODNAME,groups(GROUPS)),
  70.     not(check_groups(PRODNAME,GROUPS)),
  71.     !,fail.
  72.   check_domains.
  73.  
  74.   check_groups(_,[]).
  75.   check_groups(PRODNAME,[PRODUCTIONS]):-!,
  76.     check_priorgroup(PRODNAME,PRODUCTIONS),
  77.     none_selfref(PRODNAME,PRODUCTIONS).
  78.   check_groups(PRODNAME,[H|T]):-
  79.     check_priorgroup(PRODNAME,H),
  80.     check_groups(PRODNAME,T).
  81.  
  82.   none_selfref(_,[]).
  83.   none_selfref(PRODNAME,[prod(_,[prodname(PRODNAME,CURSOR)|_],_,_)|_]):-!,
  84.     new_error("Split up in priority groups !",CURSOR),fail.
  85.   none_selfref(PRODNAME,[_|T]):-
  86.     none_selfref(PRODNAME,T).
  87.  
  88.   check_priorgroup(_,[]).
  89.   check_priorgroup(PRODNAME,[prod(ASSOC,GRAML,CURSOR,TERM)|T]):-
  90.     check_assoc(PRODNAME,ASSOC,GRAML),
  91.     check_graml(GRAML),
  92.     check_term(TERM),
  93.     check_equalsize(CURSOR,GRAML,TERM),
  94.     check_priorgroup(PRODNAME,T).
  95.  
  96.   check_assoc(_,left,_):-!.
  97.   check_assoc(_,_,[prodname(_,_)|_]):-!.
  98.   check_assoc(_,right(CURSOR),_):-
  99.     new_error("rightassoc not alloved here",CURSOR),fail.
  100.  
  101.   check_graml([]).
  102.   check_graml([GRAMTOK|T]):-
  103.     check_gramtok(GRAMTOK),
  104.     check_graml(T).
  105.  
  106.   check_gramtok(prodname(PROD1,CURSOR)):-check_prod(CURSOR,PROD1).
  107.   check_gramtok(tok(name(NAME,CURSOR),_)):-
  108.     check_tok(name(NAME,CURSOR)).
  109.   check_gramtok(tok(cmp(NAME,CURSOR,DOML),_)):-
  110.     check_tok(cmp(NAME,CURSOR,DOML)),
  111.     check_doml(CURSOR,DOML).
  112.  
  113.   check_tok(name(NAME,CURSOR)):-
  114.     check_reserved(NAME,CURSOR),
  115.     decltok(NAME,name(NAME,_)),!.
  116.   check_tok(name(NAME,CURSOR)):-
  117.     not(decltok(NAME,_)),!,
  118.     assert(decltok(NAME,name(NAME,CURSOR))).
  119.   check_tok(cmp(NAME,CURSOR,DOML)):-
  120.     check_reserved(NAME,CURSOR),
  121.     decltok(NAME,cmp(NAME,_,DOML)),!.
  122.   check_tok(cmp(NAME,CURSOR,DOML)):-
  123.     not(decltok(NAME,_)),!,
  124.     assert(decltok(NAME,cmp(NAME,CURSOR,DOML))).
  125.   check_tok(cmp(_,CURSOR,_)):-
  126.     new_error("Token not compatible with old use of same name",CURSOR),fail.
  127.   check_tok(name(_,CURSOR)):-
  128.     new_error("Token not compatible with old use of same name",CURSOR),fail.
  129.  
  130.   check_sepp(sep(NAME),CURSOR):-!,check_tok(name(NAME,CURSOR)).
  131.   check_sepp(_,_).
  132.  
  133.   check_doml(_,[]).
  134.   check_doml(CURSOR,[H|T]):-
  135.     check_prod(CURSOR,H),
  136.     check_doml(CURSOR,T).
  137.  
  138.   check_term(dom(PROD1,CURSOR)):-!,check_prod(CURSOR,PROD1).
  139.   check_term(term(_,CURSOR,DOML)):-!,check_doml(CURSOR,DOML).
  140.   check_term(_).
  141.  
  142.   check_equalsize(CURSOR,GRAML,TERM):-
  143.     getdoml(GRAML,9999,DOML1),
  144.     gettermdoml(TERM,DOML2),
  145.     check_equallength(CURSOR,DOML1,DOML2).
  146.  
  147.   gettermdoml(term(_,_,DOML),DOML):-!.
  148.   gettermdoml(dom(DOM,_),[DOM]):-!.
  149.   gettermdoml(_,[]).
  150.  
  151.   check_equallength(_,[],[]):-!.
  152.   check_equallength(CURSOR,[_|T1],[_|T2]):-!,
  153.     check_equallength(CURSOR,T1,T2).
  154.   check_equallength(CURSOR,_,_):-
  155.     new_error("There are not the same number of domain names on both sides",CURSOR),fail.
  156.  
  157.   check_prod(_,PROD):-prodname(PROD),!.
  158.   check_prod(_,"CURSOR"):-!.
  159.   check_prod(_,"STRING"):-!.
  160.   check_prod(_,"REAL"):-!.
  161.   check_prod(_,"INTEGER"):-!.
  162.   check_prod(_,"CHAR"):-!.
  163.   check_prod(_,"SYMBOL"):-!.
  164.   check_prod(_,PROD):-userprod(PROD),!.
  165.   check_prod(_,PROD):-userdom(PROD),!.
  166.   check_prod(CURSOR,PROD):-
  167.     concat("Unknown production name: ",PROD,MSG),
  168.     new_error(MSG,CURSOR),fail.
  169.  
  170.   check_terms:-
  171.     p(PRODNAME,_),
  172.     findall(TERMS,terms(PRODNAME,TERMS),TERML),
  173.     not(check_compatterml(PRODNAME,TERML)),
  174.     !,fail.
  175.   check_terms.
  176.  
  177.   check_compatterml(_,[]).
  178.   check_compatterml(PRODNAME,[dom(PROD1,CURSOR)|_]):-
  179.     not(PROD1=PRODNAME),!,
  180.     new_error("A reference to a new domain is not allowed",CURSOR),
  181.     fail.
  182.   check_compatterml(PRODNAME,[H|T]):-
  183.     check_compatrestlist(H,T),
  184.     check_compatterml(PRODNAME,T).
  185.  
  186.   check_compatrestlist(_,[]).
  187.   check_compatrestlist(TERM,[H|T]):-
  188.     check_compatterm(TERM,H),
  189.     check_compatrestlist(TERM,T).
  190.  
  191.   check_compatterm(name(ID,_),term(ID,CURSOR,_)):-!,
  192.     new_error("Same functor twice with different parameters",CURSOR),fail.
  193.   check_compatterm(term(ID,_,_),name(ID,CURSOR)):-!,
  194.     new_error("Same functor twice with different parameters",CURSOR),fail.
  195.   check_compatterm(term(ID,_,DOML1),term(ID,CURSOR,DOML2)):-not(DOML1=DOML2),!,
  196.     new_error("Same functor twice with different parameters",CURSOR),fail.
  197.   check_compatterm(_,_).
  198.  
  199.   check_reserved(NAME,CURSOR):-
  200.     reserved_word(NAME),!,
  201.     new_error("Reserved words in the prolog system can not be used",CURSOR),fail.
  202.   check_reserved(_,_).
  203.  
  204.   reserved_word("assert").
  205.   reserved_word("asserta").
  206.   reserved_word("assertz").
  207.   reserved_word("database").
  208.   reserved_word("domains").
  209.   reserved_word("or").
  210.   reserved_word("bound").
  211.   reserved_word("free").
  212.   reserved_word("findall").
  213.   reserved_word("fail").
  214.   reserved_word("global").
  215.   reserved_word("if").
  216.   reserved_word("not").
  217.   reserved_word("include").
  218.   reserved_word("clauses").
  219.   reserved_word("readterm").
  220.   reserved_word("goal").
  221.   reserved_word("and").
  222.   reserved_word("predicates").
  223.   reserved_word("retract").
  224.   reserved_word("write").
  225.   reserved_word("writef").
  226.   reserved_word("constants").
  227.  
  228. /************************************************************************
  229.         TRANSFORMING THE TREE TO CLAUSES
  230. ************************************************************************/
  231.  
  232. PREDICATES
  233.   assertproductions(PRODUCTIONS)
  234.   assertsection(SECTION)
  235.   assertparser(PARSER)
  236.   nondeterm member(PRODNAME,PRODNAMES)
  237.  
  238. CLAUSES
  239.   assertparser([]).
  240.   assertparser([H|T]):-assertsection(H),assertparser(T).
  241.   
  242.   assertsection(productions_(PRODUCTIONS)):-!,assertproductions(PRODUCTIONS).
  243.   assertsection(userprods_(PRODUCTIONS)):-
  244.     member(PROD,PRODUCTIONS),
  245.     assert(userprod(PROD)),
  246.     fail.
  247.   assertsection(userdoms_(PRODUCTIONS)):-
  248.     member(PROD,PRODUCTIONS),
  249.     assert(userdom(PROD)),
  250.     fail.
  251.   assertsection(_).
  252.  
  253.   assertproductions([]).
  254.   assertproductions([p(PRODNAME,_,PRODBODY)|T]):-
  255.     not(prodname(PRODNAME)),!,
  256.     assert(prodname(PRODNAME)),
  257.     assert(p(PRODNAME,PRODBODY)),
  258.     assertproductions(T).
  259.   assertproductions([p(_,CURSOR,_)|_]):-
  260.     new_error("Production already defined",CURSOR),fail.
  261.  
  262.   member(X,[X|_]).
  263.   member(X,[_|L]):-member(X,L).
  264.  
  265.  
  266. /************************************************************************
  267.         USER INTERFACE
  268. ************************************************************************/
  269.  
  270. PREDICATES
  271.   scan_error(STRING,CURSOR)
  272.  
  273. include "parser.sca"
  274.  
  275. PREDICATES
  276.   ed(STRING,CURSOR)
  277.   chksure(INTEGER,STRING)
  278.   change(DBASEDOM)
  279.   nondeterm repparse
  280.   better_error(CURSOR)
  281.   refreshsource
  282.   parse
  283.   clear
  284.  
  285. PREDICATES
  286.   expect(CURSORTOK,TOKL,TOKL)
  287.   syntax_error(STRING,TOKL)
  288.   checkempty(TOKL)
  289.  
  290. include "parser.par"
  291.  
  292. CLAUSES
  293.   better_error(CURSOR):-
  294.     error(_,OLDCURSOR),OLDCURSOR>=CURSOR,!,fail.
  295.   better_error(_).
  296.  
  297.   new_error(_,_):-retract(error(_,_)),fail.
  298.   new_error(MSG,CURSOR):-assert(error(MSG,CURSOR)).
  299.  
  300.   expect(TOK,[TOK|L],L):-!.
  301.   expect(t(TOK,_),[t(_,CURSOR)|_],_):-
  302.     better_error(CURSOR),
  303.     str_tok(STR,TOK),
  304.     concat(STR," expected",MSG),
  305.     new_error(MSG,CURSOR),fail.
  306.  
  307.   syntax_error(PROD,[t(_,CURSOR)|_]):-
  308.     better_error(CURSOR),
  309.     concat("Syntax error in ",PROD,MSG),
  310.     new_error(MSG,CURSOR),fail.
  311.  
  312.   scan_error(MSG,CURSOR):-ed(MSG,CURSOR),fail.
  313.  
  314.   checkempty([]):-!.
  315.   checkempty([t(_,CURSOR)|_]):-
  316.     better_error(CURSOR),
  317.     new_error("Syntax error",CURSOR).
  318.  
  319.   chksure(_,STR):-source(STR),!,fail.
  320.   chksure(0,_):-!.
  321.   chksure(1,_):-
  322.     lineinput(5,70,40,66,66,"Skip the changes (y/n) ? ","",ANS),
  323.     upper_lower(ANS,ANS1),
  324.     ANS1="y",!,
  325.     refreshsource,
  326.     fail.
  327.   chksure(_,_).
  328.  
  329.   ed(MSG,CURSOR):-
  330.     source(TXT),
  331.     shiftwindow(OLD),
  332.     shiftwindow(1),
  333.     editmsg(TXT,TXT1,"","",MSG,CURSOR,"",RET),
  334.     shiftwindow(OLD),
  335.     chksure(RET,TXT1),!,
  336.     change(source(TXT1)).
  337.  
  338.   change(source(_)):-retract(source(_)),fail.
  339.   change(filename(_)):-retract(filename(_)),fail.
  340.   change(X):-assert(X).
  341.  
  342.   repparse.
  343.   repparse:-error(MSG,CURSOR),ed(MSG,CURSOR),!,repparse.
  344.  
  345.   refreshsource:-
  346.     source(SOURCE),!,
  347.     shiftwindow(OLDW),
  348.     shiftwindow(1),
  349.     window_str(SOURCE),
  350.     shiftwindow(OLDW).
  351.  
  352.   clear:-retract(p(_,_)),fail.
  353.   clear:-retract(prodname(_)),fail.
  354.   clear:-retract(error(_,_)),fail.
  355.   clear:-retract(userdom(_)),fail.
  356.   clear:-retract(userprod(_)),fail.
  357.   clear:-retract(pred_second(_,_,_,_,_,_)),fail.
  358.   clear:-retract(pred_first(_,_,_,_)),fail.
  359.   clear:-retract(suffix(_)),fail.
  360.   clear:-retract(difflist(_)),fail.
  361.   clear:-retract(clausevar(_,_)),fail.
  362.   clear:-retract(outptermvar(_,_)),fail.
  363.   clear:-retract(decl(_,_)),fail.
  364.   clear:-retract(decltok(_,_)),fail.
  365.   clear:-retract(exist_prior(_,_)),fail.
  366.   clear:-retract(catchallflag),fail.
  367.   clear.
  368.  
  369.   parse:-
  370.     filename(FILENAME),
  371.     repparse,
  372.     clear,
  373.     source(STR1),
  374.     write("\nScan"),
  375.     tokl(0,STR1,L),
  376.     write("\nParse"),
  377.     s_parser(L,L1,X),
  378.     checkempty(L1),
  379.     write("\nAssert"),
  380.     assertparser(X),
  381.     write("\nCheck"),
  382.     check_parser,!,
  383.     write("\nGenerate domain definitions"),
  384.     newext(FILENAME,dom,DOMFILENAME),
  385.     openwrite(outfile,DOMFILENAME),
  386.     writedevice(outfile),
  387.     gendomaindef,
  388.     closefile(outfile),
  389.     write("\nGenerate parse predicates"),
  390.     newext(FILENAME,par,PREDFILENAME),
  391.     openwrite(outfile,PREDFILENAME),
  392.     writedevice(outfile),
  393.     genparser,
  394.     closefile(outfile),
  395.     write("\nParser generated."),
  396.     clear.
  397.   parse:-
  398.     beep,
  399.     write("\n>> Parsing aborted"),
  400.     clear.
  401.  
  402.   pdwaction(1,0):-
  403.     shiftwindow(OLD),shiftwindow(3),
  404.     parse,
  405.     shiftwindow(OLD),
  406.     refreshstatus.
  407.   pdwaction(2,0):-
  408.     filename(FILE),
  409.     newext(FILE,par,NEWNAME),
  410.     file_str(NEWNAME,TXT),!,
  411.     makewindow(1,7,0,"",0,0,25,80),
  412.     editmsg(TXT,_,"Generated parser",NEWNAME,"",0,"",_),
  413.     removewindow,
  414.     refreshstatus.
  415.   pdwaction(2,0):-refreshstatus.
  416.   pdwaction(3,0):-
  417.     shiftwindow(OLD),shiftwindow(1),
  418.     source(TXT),
  419.     editmsg(TXT,TXT1,"","","",0,"",RET),
  420.     shiftwindow(OLD),
  421.     refreshstatus,
  422.     chksure(RET,TXT1),!,
  423.     change(source(TXT1)),
  424.     refreshsource.
  425.   pdwaction(3,0):-refreshstatus.
  426.   pdwaction(4,1):-
  427.     readfilename(5,40,66,66,grm,"",NEW),
  428.     change(filename(NEW)),
  429.     file_str(NEW,NEWSOURCE),!,
  430.     change(source(NEWSOURCE)),
  431.     refreshsource,
  432.     refreshstatus.
  433.   pdwaction(4,1).
  434.   pdwaction(4,2):-
  435.     source(SOURCE),
  436.     filename(OLD),
  437.     readfilename(5,40,66,66,grm,OLD,NEW),
  438.     change(filename(NEW)),
  439.     file_str(NEW,SOURCE),
  440.     refreshstatus,!.
  441.   pdwaction(4,2).
  442.   pdwaction(4,3):-setdir(5,40,66,66).
  443.   pdwaction(4,4):-system("").
  444.   pdwaction(5,0):-
  445.     lineinput(5,70,40,66,66,"Are you sure (y/n) ? ","",ANS),!,
  446.     upper_lower(ANS,ANS1),
  447.     ANS1><"y".
  448.   pdwaction(5,0).
  449.  
  450.  
  451. GOAL
  452. /*
  453.           1         2         3         4         5         6         7
  454. 01234567890123456789012345678901234567890123456789012345678901234567890123456789
  455.   Generate parser      Display parser      Edit grammar     Files     Quit
  456. */
  457.   makewindow(3,116,116,"Messages",14,0,10,40),
  458.   makewindow(1,23,23,"Edit",3,0,21,80),
  459.   makestatus(112," Select with arrows or use first upper case letter"),
  460.   pulldown(66,
  461.       [ curtain(2,"Generate parser",[]),
  462.         curtain(23,"Display parser",[]),
  463.         curtain(43,"Edit grammar",[]),
  464.         curtain(61,"Files",["Load","Save","Dir"]),
  465.             curtain(71,"Quit",[])
  466.           ],_,_),
  467.   removestatus,removewindow,removewindow.
  468.  
  469. /* Initial values in the database */
  470.  
  471. CLAUSES
  472.   filename("work.grm").
  473.   source("").
  474.   insmode.
  475.