home *** CD-ROM | disk | FTP | other *** search
/ Amiga MA Magazine 1998 #6 / amigamamagazinepolishissue1998.iso / coders / jËzyki_programowania / oberon / system / rxa.mod (.txt) < prev    next >
Oberon Text  |  2012-04-20  |  21KB  |  638 lines
  1. Syntax10.Scn.Fnt
  2. Syntax10i.Scn.Fnt
  3. MODULE RXA;    (* Andreas Margelisch, 1990 *)
  4. IMPORT  Texts, SYSTEM;
  5. CONST
  6.     tab = 9; cr = 13; blank = 32; dq = 34;
  7.     (* values for tokenval *)
  8.     shorthand = -1;
  9.     metasymbol = -2;
  10.     literal = -3;
  11.     msalternation = -4;
  12.     msopenpar = -5;
  13.     msclosepar = -6;
  14.     msopenquo = -7;
  15.     msclosequo = -8;
  16.     mssubexpr = -9;
  17.     mult = 4;
  18.     nofSET = MAX(SET) + 1;
  19.     nofpos = mult * nofSET;
  20.     nofstates = 128;
  21.     nofchar = 134;
  22.     nofsubexpr = 10;
  23.     undefined= - 1;
  24.     inoffset = 10;
  25.     endoffset = 20;
  26.     spezchar = 134;
  27.     (* Error Codes  : errorcode >= 0 means CHR(errorval) expected *)
  28.     noerror* = 0; (* Kein Fehler *)
  29.     noposfree* = -1; (* position array  ist voll *)
  30.     nostatesfree* = -2; (* states array  ist voll *)
  31.     nometaexp* = -3; (* Unerwartetes Metasymbol gefunden *)
  32.     chrleft* = -4; (* Mindestens eine schliessende Klammer ")", "]", "}" zuviel *)
  33.     wsubexpr* = -5; (* Falscher Teilausdruck-Identifier *)
  34.     subexprrest* = -6; (* Teilausdruck von { }-Klammernpaar umgeben *)
  35.     wshorthand* = -7; (* Falscher Abk
  36. rzungs-Identifier *)
  37.     notnotexp* = -8; (* Notoperator kann nicht angewendet werden *)
  38.     nodfa* = -9; (* Replace unm
  39. glich, da kein DFA vorhanden *)
  40.     repllinefull* = -10; (* Parameter line bei Replace ist voll *)
  41.     linecopofl* = -11; (* Interne Variable linecop in Prozedur Replace ist zu klein *)
  42. TYPE PosSet = ARRAY (mult) OF SET;
  43.         NodePtr = POINTER TO Node;
  44.         Node = RECORD
  45.             pos : INTEGER;
  46.             ch : CHAR;
  47.             nullable : BOOLEAN;
  48.             first, last : PosSet;
  49.             nextl, nextr : NodePtr
  50.         END;
  51.         PosDesc = RECORD
  52.             ch : CHAR;
  53.             shorthand, notoperator : BOOLEAN;
  54.             follow : PosSet
  55.         END;
  56.         PosArray = ARRAY(nofpos) OF PosDesc;
  57.         SubExprDesc = RECORD
  58.             nodeptr : NodePtr;
  59.             spos, epos : INTEGER;
  60.             follow : PosSet
  61.         END;
  62.         DFASubExprDesc = RECORD
  63.             set : BOOLEAN;
  64.             beg, end : INTEGER
  65.         END;
  66.         TransDesc = RECORD
  67.             state : INTEGER;
  68.             subset : SET
  69.         END;
  70.         DFA* = POINTER TO DFADesc;
  71.         DFADesc = RECORD
  72.             nofst : INTEGER;
  73.             subdetect : BOOLEAN;
  74.             trans : ARRAY (nofstates),(nofchar+1) OF TransDesc;
  75.             accepted : ARRAY (nofstates) OF BOOLEAN;
  76.             sub : ARRAY (nofsubexpr) OF DFASubExprDesc
  77.        END;
  78.         Line = ARRAY MAX( INTEGER ) OF CHAR;
  79.         LinePtr = POINTER TO Line;
  80.     rxl : LinePtr;
  81.     rxpos, tokenval, treepos, errorvar, countflag : INTEGER;
  82.     lookahead : CHAR;
  83.     pd : POINTER TO PosArray;
  84.     subexpr : ARRAY (nofsubexpr) OF SubExprDesc;
  85.     subdetect, notflag, inkleene, inquotes, first : BOOLEAN;
  86. (* set operations for TYPE PosSet *)
  87.  PROCEDURE PSEmpty( VAR set : PosSet );
  88.      VAR i : INTEGER;
  89.  BEGIN
  90.      i := 0; WHILE i < mult DO set[i] := {}; INC(i) END
  91.  END PSEmpty;
  92.  PROCEDURE PSIsEmpty( set : PosSet ) : BOOLEAN;
  93.  VAR i : INTEGER;
  94.  BEGIN
  95.      i := 0; WHILE i < mult DO IF set[i] # {} THEN RETURN FALSE END; INC(i) END;
  96.      RETURN TRUE
  97.  END PSIsEmpty;
  98.  PROCEDURE PSIsEqual( set1, set2 : PosSet ) : BOOLEAN;
  99.      VAR i : INTEGER;
  100.  BEGIN
  101.      i := 0; WHILE i < mult DO IF set1[i] # set2[i] THEN RETURN FALSE END; INC(i) END;
  102.      RETURN TRUE
  103.  END PSIsEqual;
  104.  PROCEDURE PSIn( set : PosSet; v : INTEGER ) : BOOLEAN;
  105.  BEGIN
  106.      RETURN ( v MOD nofSET ) IN set[v DIV nofSET]
  107.  END PSIn;
  108.  PROCEDURE PSIncl( VAR set : PosSet; v : INTEGER );
  109.  BEGIN
  110.      INCL( set[v DIV nofSET], v MOD nofSET )
  111.  END PSIncl;
  112.  PROCEDURE PSUnion( set1, set2 : PosSet; VAR resset : PosSet );
  113.      VAR i : INTEGER;
  114.  BEGIN
  115.      i := 0; WHILE i < mult DO resset[i] := set1[i] + set2[i]; INC(i) END
  116.  END PSUnion;
  117.  PROCEDURE GetChar(): CHAR;
  118.      VAR ch: CHAR;
  119.  BEGIN
  120.      ch := rxl[rxpos];
  121.      CASE countflag OF
  122.          0 : IF (ch = 0X) OR (rxpos >= LEN(rxl^) ) THEN INC( countflag ); RETURN ")"
  123.               ELSE INC(rxpos); RETURN ch
  124.               END |
  125.          1 : INC( countflag ); RETURN ("#") |
  126.      ELSE
  127.          IF errorvar = chrleft THEN errorvar := noerror END; RETURN("#")
  128.      END
  129.  END GetChar;
  130.  PROCEDURE SetPosition ( ptr : NodePtr; chr : CHAR );
  131.  BEGIN
  132.      IF treepos < nofpos THEN
  133.          ptr.pos := treepos;
  134.          PSIncl( ptr.first, treepos );
  135.          PSIncl( ptr.last, treepos );
  136.          ptr.nullable := FALSE;
  137.          pd[treepos].ch := chr;
  138.          pd[treepos].shorthand := tokenval = shorthand;
  139.          pd[treepos].notoperator := notflag;
  140.          PSEmpty(pd[treepos].follow);
  141.          INC(treepos)
  142.      ELSE
  143.          errorvar := noposfree
  144.      END
  145. END SetPosition;
  146. PROCEDURE NewNode( VAR ptr : NodePtr );
  147. BEGIN
  148.     NEW(ptr);
  149.     PSEmpty(ptr.first);
  150.     PSEmpty(ptr.last);
  151.     ptr.nextr := NIL;
  152.     ptr.nextl := NIL;
  153.     ptr.ch := lookahead;
  154.     CASE tokenval OF
  155.         literal : SetPosition( ptr, ptr.ch ) |
  156.         shorthand : SetPosition( ptr, ptr.ch )
  157.     ELSE (* metasymbol *)
  158.         ptr.pos := metasymbol
  159.     END;
  160.     notflag := FALSE
  161. END NewNode;
  162. PROCEDURE LexAn():CHAR;
  163.     VAR ch : CHAR;
  164. BEGIN
  165.     ch := GetChar();
  166.     IF ~inquotes THEN WHILE (ORD(ch) = blank) OR (ORD( ch ) = cr ) OR ( ORD( ch ) = tab ) DO ch := GetChar() END END;
  167.     IF ~first & ( ORD(ch) =  dq ) THEN inquotes := ~inquotes;
  168.         IF inquotes THEN first := TRUE; tokenval := msopenquo ELSE tokenval := msclosequo END
  169.     ELSE
  170.         IF inquotes THEN
  171.             tokenval := literal; first := FALSE
  172.         ELSE
  173.             CASE ch OF
  174.                 "A", "a", "b", "c", "d", "h", "i", "l", "o", "t", "w" : tokenval := shorthand |
  175.                 "X" : ch := GetChar(); tokenval := mssubexpr;
  176.                          IF ( ch < "0" ) OR ( ch > "9" ) THEN errorvar := wsubexpr END |
  177.                 "{", "(", "[" : tokenval := msopenpar |
  178.                 "}", ")", "]" : tokenval := msclosepar |
  179.                 "|" : tokenval := msalternation |
  180.                 "~" : notflag := ~notflag; ch := LexAn();
  181.                         IF ( tokenval # msopenquo ) & ( tokenval # shorthand ) THEN errorvar := notnotexp END
  182.             ELSE
  183.                 tokenval := literal;
  184.                 IF (ch # "#") OR ( countflag = 0 ) THEN errorvar := wshorthand END
  185.             END
  186.         END;
  187.     END;
  188.     RETURN ch
  189. END LexAn;
  190. PROCEDURE Match( ch : CHAR );
  191. BEGIN
  192.     IF ( errorvar = chrleft ) OR ( errorvar = noerror ) THEN
  193.         IF lookahead = ch THEN
  194.             lookahead := LexAn()
  195.         ELSE
  196.             errorvar := ORD(ch)
  197.         END
  198.     END;
  199. END Match;
  200. PROCEDURE InitSubExpr( ptr : NodePtr; spos : INTEGER; kleenef : BOOLEAN );
  201.     VAR ind : INTEGER;
  202. BEGIN
  203.     IF kleenef THEN
  204.         errorvar := subexprrest
  205.     ELSE
  206.         subdetect := TRUE;
  207.         ind := ORD(lookahead) - ORD("0");
  208.         Match( lookahead );
  209.         subexpr[ind].nodeptr := ptr;
  210.         subexpr[ind].spos := spos;
  211.         subexpr[ind].epos := treepos;
  212.         PSEmpty( subexpr[ind].follow )
  213. END InitSubExpr;
  214. PROCEDURE^ Term( VAR ptr : NodePtr );
  215. PROCEDURE^ Factor( VAR ptr : NodePtr );
  216. PROCEDURE RegExpr( VAR ptr : NodePtr );
  217.     VAR np : NodePtr;
  218. BEGIN
  219.     Term( ptr );
  220.     WHILE ( tokenval = msalternation ) & (errorvar = chrleft) DO
  221.         NewNode( np );
  222.         Match( "|" );
  223.         np.nextl := ptr;
  224.         ptr := np;
  225.         Term( ptr.nextr )
  226. END RegExpr;
  227. PROCEDURE Term( VAR ptr : NodePtr );
  228.     VAR np : NodePtr; tv : INTEGER; lh : CHAR;
  229. BEGIN
  230.     Factor( ptr );
  231.     WHILE ( tokenval # msclosepar ) & ( tokenval # msclosequo ) & ( tokenval # msalternation ) & (errorvar = chrleft ) DO
  232.         tv := tokenval; lh := lookahead;
  233.         tokenval := metasymbol;
  234.         lookahead := "u";
  235.         NewNode( np );
  236.         tokenval := tv; lookahead := lh;
  237.         np.nextl := ptr;
  238.         ptr := np;
  239.         Factor( ptr.nextr )
  240. END Term;
  241. PROCEDURE Factor( VAR ptr : NodePtr );
  242.     VAR tpos : INTEGER;
  243.         kleenef, not : BOOLEAN;
  244. BEGIN
  245.     kleenef := inkleene;
  246.     tpos := treepos;
  247.     CASE tokenval OF
  248.         msopenpar :
  249.             CASE lookahead OF
  250.                 "{" : inkleene := TRUE; NewNode( ptr ); Match( "{" ); ptr.ch := "{"; RegExpr( ptr.nextl ); Match( "}" );
  251.                         inkleene := FALSE |
  252.                 "[" : NewNode( ptr ); Match( "[" ); ptr.ch := "["; RegExpr( ptr.nextl ); Match( "]" ) |
  253.                 "(" : Match( "(" ); RegExpr( ptr ); Match( ")" )
  254.             ELSE
  255.             END |
  256.         msopenquo : not := notflag; Match(CHR(dq)); RegExpr( ptr ); Match(CHR(dq));
  257.                              IF not & ( treepos - tpos > 1 ) THEN errorvar := notnotexp END |
  258.         shorthand, literal : NewNode( ptr ); Match( lookahead )
  259.     ELSE errorvar := nometaexp
  260.     END;
  261.     IF ( errorvar = chrleft ) & ( tokenval = mssubexpr ) THEN InitSubExpr( ptr, tpos, kleenef ) END
  262. END Factor;
  263. PROCEDURE CalcFiLa( ptr : NodePtr );
  264. BEGIN
  265.     IF ( ptr.nextl # NIL ) & (ptr.nextl.pos = metasymbol) THEN CalcFiLa( ptr.nextl ) END;
  266.     IF ( ptr.nextr # NIL ) & (ptr.nextr.pos = metasymbol) THEN CalcFiLa( ptr.nextr ) END;
  267.     CASE ptr.ch OF
  268.         "|" : ptr.nullable := ptr.nextl.nullable OR ptr.nextr.nullable;
  269.             PSUnion(ptr.nextl.first, ptr.nextr.first, ptr.first);
  270.             PSUnion(ptr.nextl.last, ptr.nextr.last, ptr.last) |
  271.         "{", "[" : ptr.nullable := TRUE;
  272.             ptr.first := ptr.nextl.first;
  273.             ptr.last := ptr.nextl.last |
  274.         "u" : ptr.nullable := ptr.nextl.nullable & ptr.nextr.nullable;
  275.             ptr.first := ptr.nextl.first;
  276.             IF ptr.nextl.nullable THEN PSUnion(ptr.first,ptr.nextr.first, ptr.first) END;
  277.             ptr.last := ptr.nextr.last;
  278.             IF ptr.nextr.nullable THEN PSUnion(ptr.last,ptr.nextl.last, ptr.last )END
  279. END CalcFiLa;
  280. PROCEDURE CalcFollow( ptr : NodePtr );
  281.     VAR j : INTEGER;
  282. BEGIN
  283.     IF ( ptr.nextl # NIL ) & (ptr.nextl.pos = metasymbol) THEN CalcFollow( ptr.nextl ) END;
  284.     IF ( ptr.nextr # NIL ) & (ptr.nextr.pos = metasymbol) THEN CalcFollow( ptr.nextr ) END;
  285.     CASE ptr.ch OF
  286.         "{" :
  287.             j := 0;
  288.             WHILE j < treepos DO
  289.                 IF PSIn( ptr.last, j )THEN PSUnion(pd[j].follow, ptr.first, pd[j].follow )END;
  290.                 INC(j)
  291.             END | (* WHILE*)
  292.         "u" :
  293.             j := 0;
  294.             WHILE j < treepos DO
  295.                 IF PSIn( ptr.nextl.last, j ) THEN PSUnion( pd[j].follow, ptr.nextr.first, pd[j].follow ) END;
  296.                 INC(j)
  297.             END (* WHILE*)
  298.     ELSE (* alternation *)
  299. END CalcFollow;
  300. PROCEDURE CalcFollowSubExpr;
  301.     VAR i, j : INTEGER;
  302. BEGIN
  303.     i := 0;
  304.     WHILE i < nofsubexpr DO
  305.         IF subexpr[i].nodeptr # NIL THEN
  306.             j := 0;
  307.             WHILE j < treepos DO
  308.                 IF PSIn( subexpr[i].nodeptr.last, j ) THEN PSUnion( subexpr[i].follow, pd[j].follow, subexpr[i].follow ) END;
  309.                 INC(j)
  310.             END
  311.         END;
  312.         INC(i)
  313.     END; (* WHILE*)
  314. END CalcFollowSubExpr;
  315. PROCEDURE SetState( dfa : DFA; set : PosSet; VAR ind : INTEGER; VAR ps : ARRAY OF PosSet );
  316.     VAR i, k : INTEGER;
  317. BEGIN
  318.     ind := 0;
  319.     WHILE ind < dfa.nofst DO
  320.         IF PSIsEqual( ps[ind],  set ) THEN RETURN ELSE INC(ind) END
  321.     END;
  322.     IF dfa.nofst  < nofstates THEN
  323.         ps[dfa.nofst] := set;
  324.         dfa.accepted[dfa.nofst] := PSIn( set, treepos -1 );
  325.         IF ( dfa.accepted[dfa.nofst] ) & subdetect THEN
  326.             k := 0;
  327.             WHILE k < nofsubexpr DO
  328.                 IF subexpr[k].nodeptr # NIL THEN
  329.                     IF PSIsEqual( subexpr[k].follow, ps[dfa.nofst] ) THEN INCL( dfa.trans[ dfa.nofst, spezchar].subset,  k + endoffset ) END
  330.                 END;
  331.                 INC(k)
  332.             END
  333.         END;
  334.         i := 0; WHILE i < nofchar DO dfa.trans[dfa.nofst, i].state := undefined; dfa.trans[dfa.nofst, i].subset := {}; INC(i) END;
  335.         INC( dfa.nofst )
  336.     ELSE
  337.         errorvar := nostatesfree
  338. END SetState;
  339. PROCEDURE ChrIn( sid : CHAR; ch : INTEGER; short : BOOLEAN ) : BOOLEAN;
  340. BEGIN
  341.     IF short THEN
  342.         CASE sid OF
  343.             "A" : RETURN ( ORD("A") <= ch ) & ( ch <= ORD("Z")) |
  344.             "a" : RETURN ( ORD("a") <= ch ) & ( ch <= ORD("z")) |
  345.             "b" : RETURN ( ORD("0") <= ch ) & ( ch <= ORD("1")) |
  346.             "c" : RETURN ( ch = cr ) |
  347.             "d" : RETURN ( ORD("0") <= ch ) & ( ch <= ORD("9")) |
  348.             "h" : RETURN ( ChrIn( "d", ch, TRUE )) OR (( ORD("A") <= ch ) & ( ch <= ORD("F"))) |
  349.             "i" : RETURN ChrIn( "l", ch, TRUE ) OR ChrIn( "d", ch, TRUE ) |
  350.             "l" :  RETURN ( ChrIn( "A", ch, TRUE ) ) OR ( ChrIn( "a", ch, TRUE ) ) |
  351.             "o" : RETURN ( ORD("0") <= ch ) & ( ch <= ORD("7")) |
  352.             "t" : RETURN ( ch = tab ) |
  353.             "w" : RETURN ( ch = tab ) OR ( ch = cr ) OR ( ch = blank )
  354.         ELSE RETURN FALSE
  355.         END
  356.     ELSE RETURN sid = CHR( ch )
  357. END ChrIn;
  358. PROCEDURE CalcStates(  dfa : DFA; anchor : NodePtr );
  359.     VAR j, k, ind, unmark, index : INTEGER;
  360.         ps : ARRAY (nofstates) OF PosSet;
  361.         compstates : ARRAY (nofchar) OF PosSet;
  362.         ch : CHAR;
  363.         not, short : BOOLEAN;
  364.         hset, set : SET;
  365.     PROCEDURE HandleSubExpr( pos : INTEGER ) : SET;
  366.         VAR set : SET;
  367.             insub : BOOLEAN;
  368.             k : INTEGER;
  369.     BEGIN
  370.         set := {}; k := 0;
  371.         WHILE k < nofsubexpr DO
  372.             IF subexpr[k].nodeptr # NIL THEN
  373.                 insub := (  subexpr[k].spos <= pos ) & ( pos < subexpr[k].epos );
  374.                 IF PSIn( subexpr[k].nodeptr.first, pos ) THEN INCL( set, k ) END;
  375.                 IF insub THEN INCL( set, k + inoffset ) END;
  376.                 IF ~insub & PSIn( subexpr[k].follow, pos ) THEN  INCL( set, k + endoffset ) END
  377.             END;
  378.             INC(k)
  379.         END;
  380.         RETURN set
  381.     END HandleSubExpr;
  382. BEGIN
  383.     dfa.nofst := 0; unmark := 0; j := 0;
  384.     WHILE j < nofchar DO PSEmpty( compstates[j] ); INC(j) END;
  385.     SetState( dfa, anchor.first, ind, ps );
  386.     WHILE unmark < dfa.nofst DO
  387.         j := 0;
  388.         WHILE j <  treepos DO
  389.             IF PSIn( ps[unmark], j ) THEN
  390.                 not := pd[j].notoperator; short := pd[j].shorthand;
  391.                 IF short OR not THEN
  392.                     k := 0; ch := pd[j].ch; first := TRUE;
  393.                     WHILE k < nofchar DO
  394.                         IF ( ~ChrIn( ch, k, short ) & not ) OR ( ChrIn( ch, k, short ) & ~not ) THEN
  395.                             IF subdetect THEN
  396.                                 IF first THEN set := HandleSubExpr( j ); first := FALSE END;
  397.                                 hset := dfa.trans[unmark, k].subset; hset := set + hset; dfa.trans[unmark, k].subset := hset
  398.                             END;
  399.                             PSUnion( compstates[k], pd[j].follow, compstates[k] )
  400.                         END;
  401.                         INC(k)
  402.                     END
  403.                 ELSE
  404.                     index := ORD(pd[j].ch);
  405.                     IF subdetect THEN
  406.                         hset := dfa.trans[unmark, index].subset; hset := HandleSubExpr( j ) + hset; dfa.trans[unmark, index].subset := hset
  407.                     END;
  408.                     PSUnion( compstates[index], pd[j].follow, compstates[index] )
  409.                 END
  410.             END;
  411.             INC(j)
  412.         END;
  413.         j := 1; (* CHR(0) is reserved for EOS *)
  414.         WHILE j < nofchar DO
  415.             IF ~PSIsEmpty(compstates[j]) THEN
  416.                 SetState( dfa, compstates[j], ind, ps );
  417.                 dfa.trans[unmark, j].state := ind;
  418.                 PSEmpty( compstates[j] )
  419.             END;
  420.             INC(j)
  421.         END;
  422.         INC(unmark)
  423. END CalcStates;
  424. PROCEDURE Dump*( dfa : DFA; VAR w : Texts.Writer );
  425. (* Druckt den zu dfa geh
  426. rigen Automaten im System.Log Viewer aus. *)
  427.     VAR i, j : INTEGER;
  428. BEGIN
  429.     Texts.WriteLn( w ); Texts.WriteString(w, " D F A "); Texts.WriteLn( w ); Texts.WriteLn( w );
  430.     i := 0;
  431.     WHILE i < dfa.nofst DO
  432.         IF dfa.accepted[i] THEN Texts.WriteString( w, "accepted ") ELSE Texts.WriteString(w, "not accepted ") END;
  433.         Texts.WriteString(w, "State "); Texts.WriteInt(w, i, 3); Texts.WriteString(w, " : "); Texts.WriteLn( w );
  434.         j := 0;
  435.         WHILE j < nofchar DO
  436.             IF dfa.trans[i,j].state # undefined THEN
  437.                 Texts.WriteString(w, "( chr = "); Texts.Write(w, CHR(j)); Texts.WriteString(w, ", ORD = "); Texts.WriteInt(w,  j, 4 );
  438.                 Texts.WriteString(w, ", newstate = "); Texts.WriteInt(w, dfa.trans[i,j].state,2); Texts.WriteString(w, " )");
  439.                 Texts.WriteLn( w )
  440.             END;
  441.             INC(j)
  442.         END;
  443.         Texts.WriteLn( w );
  444.         INC(i)
  445.     END;
  446.     Texts.WriteString( w, "end of dump" ); Texts.WriteLn( w )
  447. END Dump;
  448. PROCEDURE New*( rx : ARRAY OF CHAR; VAR dfa : DFA; VAR error, pos : INTEGER);
  449.         Konstruiert den passenden deterministischen endlichen Automaten dfa zum regul
  450. ren Ausdruck rx.
  451.         error > 0    :    character ( CHR( error ) ) wird an der Position pos in rx verlangt.
  452.         error = 0    :    Automat konstruiert.
  453.         error < 0    :    error enth
  454. lt den Wert der entsprechenden Fehlerkonstante des in rx an der
  455.                                 Position pos aufgetretenen Fehlers.
  456.         i : INTEGER;
  457.         anchor : NodePtr;
  458. BEGIN
  459.     NEW( dfa );
  460.     NEW( pd );
  461.     i := 0; WHILE i < nofsubexpr DO subexpr[i].nodeptr := NIL; INC(i) END;
  462.     rxpos := 0;
  463.     treepos := 0;
  464.     countflag := 0;
  465.     errorvar := chrleft;
  466.     subdetect := FALSE; notflag := FALSE; inkleene := FALSE; inquotes := FALSE; first := FALSE;
  467.     rxl := SYSTEM.VAL( LinePtr, SYSTEM.ADR(rx) );
  468.     lookahead := "(";
  469.     tokenval := msopenpar;
  470.     anchor := NIL;
  471.     RegExpr( anchor );
  472.     IF inquotes THEN errorvar := dq END;
  473.     IF errorvar = noerror THEN
  474.         CalcFiLa( anchor );
  475.         CalcFollow( anchor );
  476.         IF subdetect THEN CalcFollowSubExpr END;
  477.         CalcStates( dfa, anchor );
  478.         dfa.subdetect := subdetect;
  479.         i := 0;
  480.         WHILE i < nofsubexpr DO dfa.sub[i].set := subexpr[i].nodeptr # NIL; INC(i) END
  481.     END;
  482.     rxl := NIL;
  483.     anchor := NIL;
  484.     error := errorvar;
  485.     IF error # noerror THEN pos := rxpos; dfa := NIL; RETURN END
  486. END New;
  487. PROCEDURE Search*( dfa : DFA; line : ARRAY OF CHAR; VAR beg, end : INTEGER );
  488.         Sucht in line ab der Position beg den durch dfa bestimmten regul
  489. ren Ausdruck.
  490.         end >= 0    :    [beg, end[ ist der erste ( ab Suchposition beg ) und l
  491. ngste Bereich, der dem
  492.                               gesuchten regl
  493. ren Ausdruck entspricht.
  494.         end < 0      :    Regul
  495. rer Ausdruck in line nicht gefunden.
  496.     VAR state, i, pos, ch : INTEGER;
  497.         len : LONGINT;
  498.         block : ARRAY( nofsubexpr ) OF BOOLEAN;
  499.     PROCEDURE SavePos( subset : SET; state : INTEGER );
  500.         VAR i : INTEGER;
  501.     BEGIN
  502.         i := 0;
  503.         WHILE i < nofsubexpr DO
  504.             IF ( ~ block[i] ) & ( state # undefined ) THEN
  505.                 IF ( i IN subset ) & ( dfa.sub[i].beg = undefined ) THEN dfa.sub[i].beg := pos END;
  506.                 IF ~block[i] & ( dfa.sub[i].beg # undefined ) THEN
  507.                     IF ( i + endoffset IN subset ) THEN
  508.                         dfa.sub[i].end := pos
  509.                     ELSIF dfa.accepted[state] & (i + endoffset IN dfa.trans[state, spezchar].subset ) THEN
  510.                         dfa.sub[i].end := pos + 1
  511.                     END
  512.                 END;
  513.                 IF ( dfa.sub[i].beg # undefined ) & (~( i + inoffset IN subset ) ) THEN
  514.                     IF dfa.sub[i].end = undefined THEN dfa.sub[i].beg := undefined ELSE block[i] := TRUE END
  515.                 END
  516.             END;
  517.             INC(i)
  518.         END
  519.     END SavePos;
  520.     PROCEDURE SearchRX( subexp : BOOLEAN );
  521.     BEGIN
  522.         len := LEN(line);
  523.         end := undefined;
  524.         WHILE ( end = undefined ) & ( beg < len ) & ( line[beg] # 0X) DO
  525.             pos := beg;
  526.             state := 0;
  527.             LOOP
  528.                 ch := ORD(line[pos]);
  529.                 IF dfa.accepted[state] THEN end := pos END;
  530.                 IF ( pos >= len) OR (ch = 0) THEN EXIT END;
  531.                 IF subexp THEN SavePos( dfa.trans[state, ch].subset, dfa.trans[state, ch].state ) END;
  532.                 state := dfa.trans[state, ch].state;
  533.                 IF state = undefined THEN EXIT END;
  534.                 INC(pos)
  535.             END; (* LOOP *)
  536.             INC(beg)
  537.         END;
  538.         DEC(beg)
  539.     END SearchRX;
  540. BEGIN
  541.     IF dfa # NIL THEN
  542.         SearchRX( FALSE );
  543.         IF dfa.subdetect & ( end  # undefined ) THEN
  544.             i := 0;
  545.             WHILE i < nofsubexpr DO dfa.sub[i].beg := undefined; dfa.sub[i].end := undefined; block[i] := ~dfa.sub[i].set; INC(i) END;
  546.             SearchRX( TRUE )
  547.         END
  548.     END;
  549. END Search;
  550. PROCEDURE Replace*( dfa : DFA; VAR line : ARRAY OF CHAR; replpat : ARRAY OF CHAR;
  551.                                         beg, end : INTEGER; VAR error, pos : INTEGER );
  552.         Ersetzt das St
  553. ck [beg, end[ in line durch replpat. linecop muss eine Kopie von line sein.
  554.         error > 0    :    character ( CHR( error ) ) wird an der Position pos in replpat verlangt. line bleibt unver
  555. ndert.
  556.         error = 0    :    replace erfolgreich, das St
  557. ck [beg, end[ in line wurde durch ein St
  558. ck [beg, pos[
  559.                                ersetzt.
  560.         error < 0    :    error enth
  561. lt den Wert der entsprechenden Fehlerkonstante des in replpat an der
  562.                                Position pos aufgetretenen Fehlers. line bleibt unver
  563. ndert.
  564.     CONST noofchar = 1024;
  565.     VAR lineind, replind, ind, spos : INTEGER;
  566.         ch : CHAR;
  567.         EORPL, linefull, first, inquotes : BOOLEAN;
  568.         linecop : ARRAY (noofchar) OF CHAR;
  569.     PROCEDURE GetCh() : CHAR;
  570.         VAR ch : CHAR;
  571.     BEGIN
  572.         ch := replpat[replind];
  573.         IF (replind < LEN( replpat ) ) & (ch # 0X) THEN EORPL := FALSE; INC(replind) ELSE EORPL := TRUE END; RETURN ch
  574.     END GetCh;
  575.     PROCEDURE LexAn():CHAR;
  576.         VAR ch : CHAR;
  577.     BEGIN
  578.         ch := GetCh();
  579.         IF ~inquotes THEN WHILE (ORD(ch) = blank) OR (ORD(ch) = cr ) OR (ORD(ch) = tab) DO ch := GetCh() END END;
  580.         IF ~first & ( ORD( ch ) = dq) THEN inquotes := ~inquotes;
  581.             IF inquotes THEN first := TRUE; tokenval := msopenquo ELSE tokenval := msclosequo END
  582.         ELSE
  583.             IF inquotes THEN
  584.                 tokenval := literal; first := FALSE; RETURN ch
  585.             ELSE
  586.                 CASE ch OF
  587.                    "X" : ch := GetCh();
  588.                             IF ( "0" <= ch ) & ( ch <= "9" ) THEN tokenval := mssubexpr; RETURN ch END|
  589.                     "t" : tokenval := shorthand; RETURN CHR( tab ) |
  590.                     "c" : tokenval := shorthand; RETURN CHR( cr ) |
  591.                 ELSE
  592.                 END
  593.             END;
  594.             IF ~EORPL THEN error := wsubexpr END
  595.         END;
  596.         RETURN ch
  597.     END LexAn;
  598.     PROCEDURE Append( chr : CHAR );
  599.     BEGIN
  600.         IF lineind < LEN( line ) THEN line[lineind] := chr; INC(lineind); linefull := FALSE ELSE linefull := TRUE END
  601.     END Append;
  602. BEGIN
  603.     IF dfa # NIL THEN
  604.         (*IF LEN( line ) > noofchar THEN error := linecopofl; RETURN ELSE*) COPY( line, linecop ) (*END*);
  605.         replind := 0; lineind := beg; linefull := FALSE; inquotes := FALSE; first := FALSE; error := noerror;
  606.         ch := LexAn();
  607.         WHILE (~linefull) & ( ~ EORPL ) & ( error = noerror ) DO
  608.             CASE tokenval OF
  609.                 msopenquo : ch := LexAn();
  610.                                      WHILE ( tokenval # msclosequo ) & ( ~EORPL ) DO
  611.                                          Append( ch ); ch := LexAn()
  612.                                      END;
  613.                                      IF tokenval # msclosequo THEN error := dq END |
  614.                 mssubexpr :  ind := ORD(ch) - ORD("0");
  615.                                      IF dfa.sub[ind].end # undefined THEN
  616.                                          spos := dfa.sub[ind].beg;
  617.                                          WHILE (spos < dfa.sub[ind].end) DO Append( linecop[spos] ); INC(spos ) END
  618.                                      END |
  619.                 shorthand   : Append( ch )
  620.                 ELSE
  621.             END;
  622.             ch := LexAn()
  623.         END;
  624.         IF error = noerror THEN
  625.             pos := lineind;
  626.             spos := end;
  627.             WHILE ( spos < LEN( linecop ) ) & ( linecop[spos] # 0X ) DO Append( linecop[spos] ); INC( spos ) END;
  628.             IF lineind < LEN( line ) THEN Append( CHR(0) ) END;
  629.             IF linefull THEN error := repllinefull ELSE RETURN END
  630.         END;
  631.     ELSE
  632.         error := nodfa
  633.     END;
  634.     pos := replind;
  635.     COPY( linecop, line )
  636. END Replace;
  637. END RXA.
  638.