1 unit fparser;
2
3 {
4
5 }
6
7 interface
8 uses erweiter;
9
10 type
11 pfparserknoten=^tfparserknoten;
12 tfparserknoten=record
13 ele:string;
14 l,r:pfparserknoten;
15 end;
16
17 procedure parser(var s:string;var x:pfparserknoten);
18 const
19 Symbole:array[5..22] of string=('SUBJ','FROM','TO','BODY','ORIG','DEST','LEN','OZONE','ONET','ONODE','OPOINT','DZONE','DNET','DNODE','DPOINT','FLAG','KLUDGE','ANY');
20
21
22 implementation
23
24 const
25 a_klammerauf=1; { ( }
26 a_klammerzu=2; { ) }
27 a_not=3; { not }
28 a_and=4; { and }
29 a_or=5; { or, xor }
30 a_vergleich=6; { =,<,>,%}
31 a_symbol=7;
32 a_vergleichmit=8; { "..." }
33
unescapenull34 function unescape(s:string):string;
35 type
36 replacearray=array[1..2] of record
37 orig,repl:string
38 end;
39 const
40 rep:replacearray=((orig:'\\';repl:'\'),(orig:'\1';repl:#1));
41 var
42 i:integer;
43 wert:word;
44 position:word;
45 begin
46 for i:=1 to high(rep) do begin
47 while pos(rep[i].orig,s)>0 do begin
48 position:=pos(rep[i].orig,s);
49 delete(s,position,length(rep[i].orig));
50 insert(rep[i].repl,s,position);
51 end;
52 end;
53 for i:=1 to length(s)-3 do
54 begin
55 if (s[i]='\') and (s[i+1] in ['0'..'9']) and (s[i+2] in ['0'..'9']) and (s[i+3] in ['0'..'9']) then begin
56 wert:=s2z(s[i+1]+s[i+2]+s[i+3]);
57 delete(s,i,4);
58 insert(char(wert),s,i);
59 end;
60 end;
61 unescape:=s;
62 end;
63
whatisnull64 function whatis(s:String):integer;
65 var
66 i:word;
67 begin
68 if s='(' then begin whatis:=a_klammerauf; exit; end;
69 if s=')' then begin whatis:=a_klammerzu; exit; end;
70 if s='-' then begin whatis:=a_not; exit; end;
71 if s='&' then begin whatis:=a_and; exit; end;
72 if s='|' then begin whatis:=a_or; exit; end;
73 if (s='=') or (s='<') or (s='>') or (s='%') then begin whatis:=a_vergleich; exit; end;
74 if (s[1]='"') and (s[length(s)]='"') then begin whatis:=a_vergleichmit; exit; end;
75 for i:=low(symbole) to high(symbole) do if symbole[i]=Up(s) then begin whatis:=a_symbol; exit; end;
76 writeln('ParserError (WHATIS): ',s); whatis:=0;
77 end;
78
nextklammernull79 function nextklammer(var s:String):String;
80 var
81 level,i:word;
82 begin
83 level:=1;
84 for i:=1 to length(s) do begin
85 if s[i]='(' then inc(level);
86 if s[i]=')' then dec(level);
87 if level=0 then begin
88 nextklammer:=copy(s,1,i-1);
89 delete(s,1,i);
90 exit;
91 end;
92 end;
93 writeln('PaserError Klammerebenen falsch'); nextklammer:='';
94 end;
95
getobjnull96 function getobj(var s:String):string;
97 var
98 t:String;
99 i:word;
100 begin
101 s:=killspaceae(s);
102 if length(s)=0 then begin getobj:=''; exit; end;
103 if s[1] in ['(',')','&','|','=','<','>','%'] then begin
104 getobj:=s[1];
105 delete(s,1,1);
106 s:=killspaceae(s);
107 exit;
108 end;
109 if s[1]='"' then begin
110 t:='"';
111 delete(s,1,1);
112 if pos('"',s)=0 then begin writeln('ParserError (" missing) ',s); getobj:=''; exit; end;
113 t:=t+copy(s,1,pos('"',s));
114 delete(s,1,pos('"',s));
115 getobj:=t;
116 s:=killspaceae(s);
117 exit;
118 end;
119 for i:=low(symbole) to high(symbole) do begin
120 if symbole[i]=Up(copy(s,1,length(symbole[i]))) then begin
121 getobj:=symbole[i];
122 delete(s,1,length(symbole[i]));
123 s:=killspaceae(s);
124 exit;
125 end;
126 end;
127 writeln('ParserError (getobj)',s); getobj:='';
128 end;
129
130 procedure parser(var s:string;var x:pfparserknoten);
131 var
132 t:string;
133 y:pfparserknoten;
134 begin
135 s:=killspaceae(s);
136 new(x);
137 fillchar(x^,sizeof(x^),0);
138 while s<>'' do begin
139 t:=getobj(s);
140 if t='' then begin x:=nil; halt; end; {evtl. exit}
141 case whatis(t) of
142 0:begin x:=nil; exit; end;
143 a_klammerauf:begin
144 t:=nextklammer(s);
145 if t='' then begin x:=nil; exit; end;
146 if (x^.ele='') and (x^.r=nil) and (x^.l=nil) then begin
147 dispose(x); x:=nil;
148 parser(t,x); if x=nil then begin x:=nil; exit; end;
149 end else begin
150 parser(t,x^.l); if x=nil then begin x:=nil; exit; end;
151 end;
152 end;
153 a_not,a_and,
154 a_or,a_vergleich:begin
155 if not (
156 (x^.l<>nil) and (x^.r=nil) and (x^.ele='') or
157 (x^.l<>nil) and (x^.r<>nil) and (x^.ele<>'')
158 ) then begin
159 writeln('ParserError (CASE 1)'); x:=nil; exit;
160 end;
161 if x^.r<>nil then begin
162 new(y); fillchar(y^,sizeof(y^),0);
163 y^.l:=x;
164 x:=y;
165 x^.ele:=up(t);
166 parser(s,x^.r); if x=nil then begin x:=nil; exit; end;
167 end;
168 x^.ele:=up(t);
169 end;
170 a_symbol,
171 a_vergleichmit:begin
172 t:=unescape(t);
173 if not (
174 ((x^.ele='') and (x^.l=nil) and (x^.r=nil)) or
175 ((x^.ele<>'') and (x^.l<>nil) and (x^.r=nil)) or
176 ((x^.ele<>'') and (x^.l<>nil) and (x^.r<>nil))
177 ) then begin
178 writeln('ParserError (CASE 2)'); x:=nil; exit;
179 end;
180 if (x^.ele='') and (x^.l=nil) and (x^.r=nil) then begin
181 new(x^.l);
182 fillchar(x^.l^,sizeof(x^.l^),0);
183 x^.l^.ele:=t;
184 continue;
185 end;
186 if (x^.ele<>'') and (x^.l<>nil) and (x^.r=nil) then begin
187 new(x^.r);
188 fillchar(x^.r^,sizeof(x^.r^),0);
189 x^.r^.ele:=t;
190 continue;
191 end;
192 if (x^.ele<>'') and (x^.l<>nil) and (x^.r=nil) then begin
193 new(y); fillchar(y^,sizeof(y^),0);
194 y^.l:=x;
195 x:=y;
196 continue;
197 end;
198 writeln('ParserError (CASE 3)'); x:=nil; exit;
199 end;
200 else begin
201 writeln('ParserError in Case'); x:=nil; exit;
202 end;
203 end;
204 end;
205 end;
206
207 procedure show(x:pfparserknoten);
208 begin
209 { if x=nil then exit;
210 gotoxy(wherex,wherey+1);
211 show(x^.l);
212 write(x^.ele);
213 show(x^.r);
214 gotoxy(wherex,wherey-1);}
215 end;
216
217 end.