|
DataMuseum.dkPresents historical artifacts from the history of: DANOSI |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about DANOSI Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 31947 (0x7ccb)
Types: TextFile
Names: »P1PARS.PAS«
└─⟦b6837b237⟧ Bits:30010500 SW2103 REL 1.11 Sourcer DVBS1.SW2103.rel.1.11-1 MASTER 31-1-192
└─⟦this⟧ »P1PARS.PAS«
procedure parser;\r
const\r
(*BOBS, constants generated by the generator *)\r
symbmax=250;\r
prodmax=316;\r
lrmax=1263;\r
lxmax=223;\r
errorval=18;\r
nameval=35;\r
constval=29;\r
stringval=50;\r
stringch =\r
'''';\r
combegin=87;\r
comlength=2;\r
(*BOBS) \r
(*-end-of-generated-constants-*)\r
realkonst=45;\r
skipch=' ';\r
\r
(*-end-of-parser-constants-*)\r
\r
type\r
symbol=0..symbmax;\r
errno=0..prodmax;\r
prodno=0..prodmax;\r
rslength=-1..symbmax;\r
mode=0..6;\r
lrinx=0..lrmax;\r
lrelm=packed record\r
chain: lrinx; (*next item in this state*)\r
next: lrinx; (*next state*)\r
case kind: mode of\r
1,2,4,6: (symb: symbol; err: errno);\r
0,3 : (rs: rslength; prod: prodno);\r
5: (lb: lrinx)\r
end;\r
lxinx=0..lxmax;\r
lxelm=packed record\r
np,hp: lxinx;\r
tv: symbol; ch:char\r
end;\r
stackelm=packed record\r
link: stackinx;\r
table: lrinx\r
end;\r
(*-end-of-parser-types-*)\r
\r
var\r
\r
lr: array[lrinx] of lrelm; (* lr-parse tables *)\r
\r
parsestack: array[stackinx] of stackelm; (*parse stack*)\r
\r
entry: array[char] of lxelm;\r
lx: array[lxinx] of lxelm; (*lexical tables*)\r
namech, (*chars used in names*)\r
digitch:set of char; (*chars used for digits*)\r
newsymb: symbol; (*current terminal symbol*)\r
ch: char; (*current char*)\r
stringescape: integer; (*internal value of the stringescape terminal*)\r
oldbufi: chbufinx; (*first char in chbuf of current lexical token *)\r
moreinput:boolean; (*becomes false when input is exhausted*)\r
comend : array[1..comlength] of char ; (*string which ends a comment *)\r
prodtab : array [prodno] of integer;\r
\r
(*-end-of-parser-variables-*)\r
\r
\r
procedure dumplr;\r
var i:integer;\r
begin writeln(output, ' i ',' chain next kind symb prod');\r
for i:= 1 to lrmax do\r
with lr[i] do\r
begin write(output, ' ',i:3,chain:6,next:5,kind:5);\r
case kind of\r
1,2,4,6: writeln(output, symb:5,err:5);\r
0,3 : writeln(output, rs:5,prod:5);\r
5: writeln(output, lb:5)\r
end\r
end\r
end;\r
\r
(* procedures for input/output of characters*)\r
(*$r+*)\r
procedure readline;\r
(*$r-*)\r
type\r
t_operator= (no_op, lt_op, le_op, gt_op, ge_op, eq_op, dif_op, or_op, xor_op);\r
\r
var lgt, terminator : integer;\r
stop_read : boolean;\r
ch : char;\r
\r
procedure directive_warning(warning_text: t_directive_warnings);\r
(* mark point of error in directive line and treat the line as a comment *)\r
var step: integer;\r
prgrlst : boolean;\r
begin\r
if not printed then\r
begin\r
prgrlst:= programlist;\r
programlist:= true; (* force printing of erroneous line *)\r
printline;\r
programlist:= prgrlst;\r
end;\r
for step:= 1 to lineinx-1+6 do\r
write(output, ' ');\r
writeln(output, '^');\r
case warning_text of\r
expression_expected: writeln(output, '*** expression expected');\r
or_operator_expected: writeln(output, '*** (X)OR expected');\r
and_expected: writeln(output, '*** AND expected');\r
right_par_expected: writeln(output, '*** ")" expected ');\r
eq_expected: writeln(output, '*** "=" expected');\r
undefined_switch: writeln(output, '*** switch not defined, value 0 assumed');\r
unknown_directive: writeln(output, '*** unknown directive');\r
file_does_not_exist: writeln(output, '*** INCLUDE file does not exist ');\r
range_error: writeln(output, '*** value outside range');\r
endif_without_matching_if: writeln(output, '*** ENDIF without matching IF');\r
elseif_without_matching_if: writeln(output, '*** ELSEIF without matching IF');\r
else_not_after_if_or_elseif: writeln(output, '*** ELSE without matching IF or ELSEIF');\r
else\r
writeln(output, '*** other error: ', ord(warning_text));\r
end;\r
\r
if warning_text<>undefined_switch then\r
begin\r
writeln(output, '*** directive line skipped');\r
stop_read := false; (* exit get and handle directive *)\r
end;\r
end; (* directive_warning *)\r
\r
\r
procedure nextchar;\r
(* let ch be next significant character of directive line, i.e. skip\r
double blanks, letters are converted to upper case, lineinx denotes the\r
position of ch in the directive line, if lineinx reaches the end of the\r
line ch is assigned a blank character *)\r
begin\r
if lineinx<linelength then\r
lineinx:= lineinx+1;\r
ch:= upcase(line[ lineinx ]);\r
if ch=' ' then\r
while (lineinx<linelength) and (line[ lineinx+1 ]=' ') do\r
lineinx:= lineinx+1;\r
if dir_testoutput then writeln(output, 'nextchar: "', ch, '"');\r
end; (* nextchar *)\r
\r
\r
function get_int: integer;\r
(* ch is first digit of the integer value to pickup from the line buffer *)\r
var\r
result: integer;\r
begin\r
result:= 0;\r
while ch in digitch do\r
begin\r
result:= result*10+ord(ch)-ord('0');\r
nextchar;\r
end;\r
get_int:= result;\r
if ch=' ' then\r
nextchar;\r
if dir_testoutput then writeln(output, 'get_int= ', result);\r
end; (* get int *)\r
\r
\r
function get_switch(warn_if_undef: boolean): p_switch;\r
(* pickup a switch name, search through the list of known switches, if not\r
found then insert the name, the result is a pointer to the switch *)\r
var\r
inx: integer; (* index into sw_name *)\r
sw_name: alfa;\r
sw_chain: p_switch;\r
begin\r
inx:= 0;\r
assign_alfa(sw_name, ' ');\r
while ch in namech do\r
begin\r
inx:= inx+1;\r
if inx<=alfalength then\r
sw_name[ inx ]:= ch;\r
nextchar;\r
end;\r
sw_chain:= first_switch;\r
while (sw_chain<>nil) and (sw_chain^.name<>sw_name) do\r
sw_chain:= sw_chain^.next_switch;\r
if sw_chain=nil then (* not found, add to list *)\r
begin\r
if warn_if_undef then\r
directive_warning(undefined_switch);\r
new(sw_chain);\r
with sw_chain^ do\r
begin\r
next_switch:= first_switch; (* insert in front of list *)\r
name:= sw_name;\r
val:= 0;\r
switch_assigned:= sw_not_defined;\r
end; (* with new element *)\r
first_switch:= sw_chain;\r
end; (* add to list *)\r
get_switch:= sw_chain;\r
if ch=' ' then\r
nextchar;\r
if dir_testoutput then\r
writeln(output, 'get switch: ', ofs(sw_chain), ' name= ', sw_name);\r
end; (* get switch *)\r
\r
\r
function expression: boolean; forward;\r
\r
\r
function factor: integer;\r
(* factor::= unsigned constant\r
. ! switch\r
. ! ( expression )\r
. ! NOT factor\r
*)\r
var\r
result: integer;\r
switch: p_switch;\r
begin\r
if ch='(' then\r
begin\r
nextchar; (* bypass the ( *)\r
if ch=' ' then\r
nextchar;\r
result:= ord(expression);\r
if ch<>')' then\r
directive_warning(right_par_expected)\r
else\r
nextchar;\r
if ch=' ' then\r
nextchar;\r
end (* ( expression ) *)\r
else\r
if ch in digitch then\r
result:= get_int\r
else\r
if ch in namech then\r
begin\r
switch:= get_switch(true); (* directive_warning if not defined *)\r
if switch^.name='NOT ' then\r
result:= ord(factor=0)\r
else\r
result:= switch^.val;\r
end (* switch/ NOT factor *)\r
else\r
begin\r
directive_warning(expression_expected);\r
result:= 0;\r
end;\r
factor:= result;\r
if dir_testoutput then writeln(output, 'factor= ', result);\r
end; (* factor *)\r
\r
\r
function term: integer;\r
(* term ::= factor (AND factor)* *)\r
var\r
result, operand: integer;\r
switch: p_switch;\r
begin\r
result:= factor;\r
while ch='A' do\r
begin\r
switch:= get_switch(false (* do not warn if not found, it must be there *));\r
if switch^.name<>'AND ' then\r
directive_warning(and_expected);\r
operand:= factor;\r
result:= ord((result<>0) and (operand<>0));\r
end; (* while *)\r
term:= result;\r
end; (* term *)\r
\r
\r
function simple_expression: integer;\r
(* simple expression ::= sign term (or_operator term)*\r
\r
. sign ::= empty\r
. ! +\r
. ! -\r
\r
. or_operator ::= OR\r
. ! XOR\r
*)\r
var\r
result, operand: integer;\r
operator: t_operator;\r
switch: p_switch;\r
begin\r
if ch='+' then\r
begin\r
nextchar;\r
if ch=' ' then\r
nextchar;\r
result:= term;\r
end\r
else\r
if ch='-' then\r
begin\r
nextchar;\r
if ch=' ' then\r
nextchar;\r
result:= -term;\r
end\r
else\r
result:= term;\r
\r
while (ch='X') or (ch='O') do\r
begin\r
switch:= get_switch(false(* do not warn if not found, it must be there *));\r
if switch^.name='XOR ' then\r
operator:= xor_op\r
else\r
if switch^.name='OR ' then\r
operator:= or_op\r
else\r
directive_warning(or_operator_expected);\r
operand:= term;\r
if operator=xor_op then\r
result:= ord((result=0) and (operand<>0) or (result<>0) and (operand=0))\r
else\r
result:= ord((result<>0) or (operand<>0));\r
end; (* while *)\r
simple_expression:= result;\r
end; (* simple expression *)\r
\r
\r
function expression: boolean;\r
(* expression ::= simple expression (rel_operator simple expression)*\r
.\r
. rel_operator ::= <\r
. ! >=\r
. ! <\r
. ! <=\r
. ! =\r
. ! <>\r
*)\r
var\r
result, operand: integer;\r
operator: t_operator;\r
switch: t_switch;\r
\r
\r
begin\r
result:= simple_expression;\r
operator:= no_op;\r
if ch='<' then\r
begin\r
operator:= lt_op;\r
nextchar;\r
if ch='=' then\r
begin\r
operator:= le_op;\r
nextchar;\r
end\r
else\r
if ch='>' then\r
begin\r
operator:= dif_op;\r
nextchar;\r
end;\r
end\r
else\r
if ch='>' then\r
begin\r
operator:= gt_op;\r
nextchar;\r
if ch='=' then\r
begin\r
operator:= ge_op;\r
nextchar;\r
end;\r
end (*>*)\r
else\r
if ch='=' then\r
begin\r
operator:= eq_op;\r
nextchar;\r
end; (*=*)\r
\r
if ch=' ' then\r
nextchar;\r
\r
if operator<>no_op then\r
begin\r
operand:= simple_expression;\r
case operator of\r
lt_op: result:= ord(result<operand);\r
le_op: result:= ord(result<=operand);\r
gt_op: result:= ord(result>operand);\r
ge_op: result:= ord(result>=operand);\r
eq_op: result:= ord(result=operand);\r
dif_op: result:= ord(result<>operand);\r
end; (* case *)\r
end; (* operator<>no_op *)\r
\r
expression:= result<>0;\r
end; (* expression *)\r
\r
\r
procedure get_compiler_directive;\r
(* dollar sign met as first character of a line, now handle the directive,\r
in case of errors the line will be treated as a comment, and a warning is given *)\r
const\r
(* possible directives are: *)\r
dlr_include = 'INCLUDE ';\r
dlr_if = 'IF ';\r
dlr_endif = 'ENDIF ';\r
dlr_else = 'ELSE ';\r
dlr_elseif = 'ELSEIF ';\r
dlr_exception = 'EXCEPTION ';\r
dlr_createsize = 'CREATESIZE ';\r
dlr_code = 'CODE ';\r
dlr_nocode = 'NOCODE ';\r
dlr_list = 'LIST ';\r
dlr_nolist = 'NOLIST ';\r
dlr_set = 'SET ';\r
dlr_default = 'DEFAULT ';\r
dlr_version = 'VERSION ';\r
dlr_linenumber= 'LINENUMBER ';\r
dlr_roundupline= 'ROUNDUPLINE ';\r
\r
var\r
ch1: char; (* help character, current character is the global varible ch *)\r
inx: integer; (* help index into directive *)\r
help_val, version_val1, version_val2, version_val3: integer;\r
switch: p_switch;\r
file_name, (* for the name of a file to be INCLUDEd *)\r
directive: alfa;\r
\r
begin\r
nextchar;\r
nextchar; (* skip the dollar sign *)\r
inx:= 0;\r
assign_alfa(directive, ' ');\r
while ch in namech do\r
begin\r
inx:= inx+1;\r
directive[ inx ]:= ch;\r
nextchar;\r
end;\r
if ch=' ' then\r
nextchar; (* ch:= next significant character *)\r
\r
case directive[ 1 ] of\r
'I': (* INCLUDE or IF *)\r
begin\r
if directive=dlr_if then\r
begin\r
if directive_top^.next_dir=nil then\r
begin\r
new(directive_top^.next_dir);\r
with directive_top^.next_dir^ do\r
begin\r
former_dir:= directive_top;\r
next_dir:= nil;\r
end;\r
end; (* add new directive stack node *)\r
directive_top:= directive_top^.next_dir;\r
with directive_top^do\r
begin\r
dir_kind:= d_if;\r
surr_skip_state:= cond_skip_text;\r
after_else:= false;\r
if not cond_skip_text then\r
cond_skip_text:= not expression;\r
after_noskip:= not cond_skip_text;\r
end; (* with *)\r
end (* IF *)\r
else\r
if directive=dlr_include then\r
begin\r
inx:= 0;\r
assign_alfa(file_name, ' ');\r
while ch in namech do\r
begin\r
inx:= inx+1;\r
if inx<=alfalength then\r
file_name[ inx ]:= ch;\r
nextchar;\r
end;\r
assign(input, concat(source_path, file_name));\r
settextbuf(input, in_buf_ptr^);\r
(*$I-*)\r
reset(input);\r
if ioresult <> 0 then\r
begin\r
nofile(concat(source_path, file_name));\r
end;\r
(*$I+*)\r
include_count:= include_count+1;\r
if not printed then printline;\r
push_source(linenumber, file_name);\r
end (* INCLUDE *)\r
else\r
directive_warning(unknown_directive);\r
end; (* IF and INCLUDE *)\r
\r
'N', 'L', 'C', 'R': (* NOCODE, CODE, LINENUMBER, ROUNDUPLINE, *)\r
(* LIST, NOLIST, CREATESIZE *)\r
begin\r
if (directive=dlr_code) or (directive=dlr_nocode) then\r
begin\r
if not cond_skip_text then\r
begin\r
emit(coption, 5, code5, cnocode);\r
emit(cnocode, 1-ord(directive=dlr_code), nill, cnocode);\r
emit(coption, 6, code6, cnocode);\r
emit(cnocode, ord(directive=dlr_code), nill, cnocode);\r
end;\r
end\r
else\r
if (directive=dlr_list) or (directive=dlr_nolist) then\r
begin\r
if not cond_skip_text then\r
begin\r
programlist:= directive=dlr_list;\r
remember_list:= programlist;\r
end;\r
end\r
else\r
if directive=dlr_createsize then\r
begin\r
if not cond_skip_text then\r
begin\r
emit(coption, 5, 10, cnocode); (* OPTION to PASS5(10, size) *)\r
emit(cnocode, get_int, nill, cnocode);\r
end;\r
end (* createsize *)\r
else\r
if directive = dlr_linenumber then\r
begin\r
help_val := get_int;\r
if help_val > linenumber then linenumber := help_val;\r
end else\r
if directive = dlr_roundupline then\r
begin\r
linenumber := ((linenumber + 999) div 1000) * 1000;\r
end else\r
directive_warning(unknown_directive);\r
end; (* CODE, NOCODE, CREATSIZE *)\r
\r
'D', 'S': (* DEFAULT, SET, i.e. define switch(es), if DEFAULT only if undefined *)\r
(* syntax: $SET switch=value (switch=value)* *)\r
(* syntax: $DEFAULT switch=value (switch=value)* *)\r
if (directive=dlr_set) or (directive=dlr_default) then\r
begin\r
if not cond_skip_text then\r
repeat\r
switch:= get_switch(false); (* possibly a definition *)\r
if ch<>'=' then\r
directive_warning(eq_expected);\r
repeat\r
nextchar;\r
until (ch<>' ') or (lineinx=linelength);\r
help_val:= simple_expression;\r
with switch^ do\r
if ((directive=dlr_set) or (switch_assigned=sw_not_defined))\r
and (switch_assigned<>sw_not_assignable) then\r
begin\r
val:= help_val;\r
switch_assigned:= sw_assigned;\r
end;\r
until lineinx=linelength;\r
end (* SET *)\r
else\r
directive_warning(unknown_directive);\r
\r
'V': (* VERSION *)\r
if directive=dlr_version then\r
begin\r
if not cond_skip_text\r
and (version_switch^.switch_assigned<>sw_not_assignable) then\r
begin\r
while (not (ch in digitch)) and (lineinx<linelength) do\r
nextchar;\r
version_val1:= factor;\r
while (not(ch in digitch)) and (lineinx<linelength) do\r
nextchar;\r
if lineinx<linelength then\r
begin\r
version_val2:= factor;\r
while (not (ch in digitch)) and (lineinx<linelength) do\r
nextchar;\r
if lineinx<linelength then\r
begin\r
version_val3:= factor;\r
if (version_val2>9) or (version_val3>9) then\r
directive_warning(range_error)\r
else\r
version_val1:= (version_val1*10+version_val2)*10+version_val3;\r
end\r
else\r
begin\r
if (version_val1<256) and (version_val2<256) then\r
version_val1:= version_val1*256+version_val2\r
else\r
directive_warning(range_error);\r
end;\r
end;\r
if version_val1>65535 then\r
directive_warning(range_error)\r
else\r
begin\r
emit(coption, 6, 15, cnocode); (* !!!! must be as defined by pass6 !!! *)\r
emit(cnocode, version_val1, nill, cnocode);\r
version_switch^.val:= version_val1;\r
end;\r
end;\r
end\r
else\r
directive_warning(unknown_directive);\r
\r
'E': (* ENDIF, ELSE, ELSEIF, EXCEPTION *)\r
begin\r
if directive=dlr_endif then\r
begin\r
if directive_top^.dir_kind<>d_if then\r
directive_warning(endif_without_matching_if)\r
else\r
begin\r
cond_skip_text:= directive_top^.surr_skip_state;\r
directive_top:= directive_top^.former_dir;\r
end;\r
end (* ENDIF *)\r
else\r
if directive=dlr_else then\r
begin\r
with directive_top^ do\r
if (dir_kind=d_if) and not after_else then\r
begin\r
after_else:= true;\r
if not surr_skip_state then (* noskip at $IF *)\r
cond_skip_text:= after_noskip;\r
end\r
else\r
directive_warning(else_not_after_if_or_elseif);\r
end (* ELSE *)\r
else\r
if directive=dlr_elseif then\r
begin\r
with directive_top^ do\r
if (dir_kind=d_if) and not after_else then\r
begin\r
if not surr_skip_state then (* noskip at $IF *)\r
if after_noskip then (* IF or ELSEIF already chosen, skip unconditional *)\r
cond_skip_text:= true\r
else\r
begin\r
cond_skip_text:= not expression;\r
after_noskip:= not cond_skip_text;\r
end;\r
end (* after IF or ELSEIF *)\r
else\r
directive_warning(elseif_without_matching_if);\r
end (* ELSEIF *)\r
else\r
if directive=dlr_exception then\r
begin\r
if not cond_skip_text then\r
begin\r
emit(coption, 5, 7, cnocode); (* OPTION to PASS5( 7, size) *)\r
emit(cnocode, get_int, nill, cnocode);\r
end;\r
end (* exception *)\r
else\r
directive_warning(unknown_directive);\r
end; (* ENDIF, ELSE, ELSEIF *)\r
else\r
directive_warning(unknown_directive);\r
end (* case *)\r
end; (* get compiler directive *)\r
\r
\r
begin (* readline *)\r
\r
repeat\r
printed:= false;\r
if locallinenumber>=0 then\r
locallinenumber:= locallinenumber+1;\r
linenumber:= linenumber+1;\r
\r
(* avoid destroying the buffer mark in case of type buffering *)\r
if not typebufferflag then\r
emit(cnewline, linenumber, nill, cnocode);\r
if inputfile then\r
if eoln(input) then readln(input);\r
lgt:= 0; (* number of valid characters in 'line' *)\r
repeat (* read until end of line, end of file, or line full *)\r
\r
terminator := -1;\r
repeat\r
if not inputfile then terminator := 0 else\r
if eof(input) then terminator := 0 else\r
if eoln(input) then terminator := 1 else\r
if lgt < linemax then\r
begin\r
read(input, ch);\r
if ord(ch) < 32 then\r
begin\r
if ord(ch) = 10 then terminator := 1;\r
end else\r
if ord(ch) = 127 then else\r
begin\r
lgt := lgt + 1;\r
line[ lgt ]:= ch;\r
end;\r
end else terminator := 2;\r
until terminator >= 0;\r
\r
case terminator of\r
1: begin\r
lgt:= lgt+1;\r
line[ lgt ]:= ' ';\r
stop_read:= true;\r
end;\r
0: begin\r
if lgt=0 then\r
begin\r
if include_count=0 then\r
begin\r
linenumber:= 1;\r
if more_sources_allowed then\r
readcall; (* more sources ??? *)\r
if inputfile then inputfile := not eof(input);\r
if not inputfile then\r
begin\r
moreinput:= false;\r
line[ 1 ]:= '.'; (* termination character *)\r
lgt:= 1;\r
stop_read:= true;\r
end\r
else\r
stop_read:= false;\r
end (* include count = 0 *)\r
else\r
begin\r
close(input); (* unstack zone *)\r
pop_source(true (* emit name of surrounding source file *));\r
if eoln(input) then readln(input);\r
include_count:= include_count-1;\r
stop_read:= false;\r
end;\r
end (* empty line *)\r
else\r
begin (* process line *)\r
(* simulate end of line action *)\r
lgt:= lgt+1;\r
line[ lgt ]:= ' ';\r
stop_read:= true;\r
end;\r
end;\r
else\r
stop_read:= true; (* line full *)\r
end\r
until stop_read;\r
linelength:= lgt;\r
lgt:= 1;\r
while (lgt<linelength) and (line[ lgt ]=' ') do\r
lgt:= lgt+1;\r
lineinx:= lgt-1;\r
if line[ lgt ]='$' then\r
begin\r
get_compiler_directive;\r
lineinx:= linelength; (* skip remaining part of line *)\r
end;\r
if cond_skip_text then\r
begin\r
lineinx:= linelength; (* skip the line, but make sure it will be printed *)\r
(* in case of option programlist turned on *)\r
if not moreinput then stop(7); (* premature end of file, missing $ENDIF *)\r
end;\r
until stop_read;\r
\r
end; (* readline *)\r
\r
procedure inchar;\r
begin\r
while lineinx=linelength do\r
begin\r
if programlist and not printed and moreinput then printline;\r
if errorinx>0 then\r
begin\r
writeln(output);\r
errorinx:= 0;\r
end;\r
readline;\r
end;\r
lineinx:= lineinx+1;\r
ch:= upcase(line[lineinx]);\r
end; (*inchar*)\r
(*$r-*)\r
\r
\r
(*end of input/output procedures*)\r
\r
procedure initialize(var tables : text);\r
var cc,ch1:char;\r
a,b,c,d,e,i:integer;\r
firstlb : integer;\r
newlb : boolean;\r
begin\r
list_file_name := blank;\r
ok:= true;\r
moreinput:= true; lineinx:= 1; chbufi:= 0;\r
indention:= 0;\r
linelength:= 1; printed:= true; errorinx:= 0;\r
parsestack[0].table:= 0; attstack[0].chbufp:= chbufi;\r
for i:= 0 to stackmax do\r
attstack[ i ].bufferstart:= 1;\r
ch:= ' '; parsestack[0].link:= 0;\r
digitch:= ['0'..'9']; namech:= ['A'..'Z','0'..'9','_'];\r
readln(tables,i); (* i:= number of constants to skip *)\r
for i:= i downto 1 do readln(tables);\r
for i:= 1 to comlength do read(tables,comend[i]) ;\r
readln(tables) ;\r
for ch1:= minch to maxch do\r
begin readln(tables,cc,cc,a,b,c);\r
with entry[cc] do\r
begin\r
ch:= cc; np:= a; hp:= b; tv:= c\r
end\r
end;\r
entry['"']:= entry[''''];\r
for i:= 0 to lxmax do\r
with lx[i] do\r
begin readln(tables,cc,cc,a,b,c);\r
ch:= cc; np:= a; hp:= b; tv:= c\r
end;\r
if stringch=' ' then (*string facility is not used *) stringescape:= -2\r
else stringescape:= entry[stringch].tv;\r
newlb:= true;\r
for i:= 0 to lrmax do\r
with lr[i] do\r
begin read(tables,a,b,c,d);\r
if c<>5 then readln(tables,e) else readln(tables) ;\r
chain:= a; next:= b; kind:= c;\r
case c of\r
1,2,4,6: begin symb:= d; err:= e end;\r
0,3 : begin rs:= d; prod:= e end;\r
5 :begin lb:= d;\r
if newlb then\r
begin firstlb:= i; newlb:= false; end;\r
if a=0 then\r
begin\r
lr[firstlb].chain:= i;\r
newlb:= true;\r
end;\r
end\r
end\r
end\r
;\r
prodtab[0]:= 0;\r
(* read the production labels *)\r
for i:= 1 to prodmax do\r
readln(tables, a, prodtab[a]);\r
end;(*initialize*)\r
\r
(*$r+*)\r
procedure lexical;\r
(*$r-*)\r
(* returns next terminal in newsymb*)\r
label 999; (* after skipcomment newsymb is empty and an extra turn is\r
needed, this is done by means of a 'goto start' *)\r
\r
var\r
newi: integer;\r
oldch: char;\r
lxnode: lxelm;\r
\r
procedure skipcomment;\r
(* read next char on input until comend is recognized *)\r
var\r
start_line, passnr, optnr, optvalue : integer;\r
commentend : char;\r
begin (* skip comment *)\r
start_line:= linenumber; (* remember current line number in case of unterminated comment *)\r
if chbuf[ chbufi ]='-' then (* -- comment *)\r
lineinx:= linelength (* skip the line *)\r
else\r
begin\r
if chbuf[ chbufi ]='(' then commentend:= ')'\r
else commentend:= '>';\r
if ch='$' then (* option *)\r
begin\r
(* the syntax of option is: $ passnr optnr optvalue *)\r
while not (( ch>='0') and (ch<='9')) do inchar; (* skip *)\r
passnr:= ord(ch)-ord('0');\r
\r
repeat\r
inchar; (* skip delimiter *)\r
until (ch>='0') and (ch<='9');\r
\r
optnr:= 0;\r
while (ch>='0') and (ch<='9') do\r
begin\r
if optnr<100 then\r
optnr:= optnr * 10+ord(ch)-ord('0');\r
inchar;\r
end; (*option number *)\r
\r
while not ((ch>='0') and (ch<='9')) do\r
inchar; (* skip delimiter *)\r
\r
optvalue:= 0;\r
while (ch>='0') and (ch<='9') and (optvalue<10000 ) do\r
begin\r
optvalue:= optvalue * 10+ord(ch)-ord('0');\r
inchar;\r
end;\r
if passnr=1 then\r
begin\r
case optnr of\r
1: begin\r
programlist:= optvalue=1;\r
remember_list:= programlist;\r
end;\r
2: call_pass_3:= optvalue=1;\r
3: nametable_dump:= optvalue=1; (* dump the hash table on file: spixtoname *)\r
else ;\r
end (* case *) ;\r
end\r
else\r
begin\r
\r
(* emit the option *)\r
emit(coption, passnr, optnr, cnocode);\r
emit(cnocode, optvalue, nill, cnocode);\r
end;\r
\r
end; (* option *)\r
\r
repeat\r
while (ch<>'*') and moreinput do inchar;\r
inchar;\r
until (ch=commentend) or not moreinput;\r
if not moreinput then\r
begin\r
markerror( 103 ); (* comment did not terminate *)\r
write(output,'(* comment started in line ', start_line:1, ' *)');\r
end;\r
end; (* not -- comment *)\r
inchar;\r
end; (* skip comment *)\r
\r
\r
(*$r+*)\r
procedure pushch;\r
(*$r-*)\r
begin\r
chbuf[chbufi]:= ch;\r
if chbufi<chbufmax then chbufi:= chbufi+1\r
else stop(6);\r
if testoutput then write(output,ch); (***snapshot***)\r
end; (*pushch*)\r
\r
procedure readstring;\r
var strch:char;\r
instring : boolean;\r
begin\r
strch:= oldch;\r
ch:= line[lineinx]; (* maybe ch was converted to upper case *)\r
instring:= true;\r
while\r
( instring (* preceding character was not a string delimiter *)\r
or ( ch=strch ) (* this character is a delim *)\r
) and ( lineinx<>linelength ) (* stop at eoln *)\r
do\r
begin\r
instring:= (ch<>strch) or not instring;\r
(* false at first delim after character, else true *)\r
if instring then pushch;\r
lineinx:= lineinx+1;\r
ch:= line[lineinx]; (* inchar without converting to upper case *)\r
end;\r
if instring or (ch=strch) then markerror(101);\r
(* string did not terminate within line *)\r
newsymb:= stringval\r
end; (*readstring*)\r
\r
begin (*lexical*)\r
999:\r
\r
if testoutput then\r
begin\r
writeln(output); write(output,' lexical: '); (***snapshot***)\r
end;\r
\r
while ch=skipch do inchar;\r
oldbufi:= chbufi;\r
if not moreinput then\r
begin\r
if newsymb=0 then (*third*) stop(2)\r
else\r
if newsymb=1 then (*second*) newsymb:= 0\r
else (*first*) newsymb:= 1\r
end\r
else\r
if ch in digitch then\r
begin (*konst*)\r
repeat\r
pushch; inchar;\r
until not (ch in digitch);\r
newsymb:= constval;\r
if (ch='.') and (line[lineinx+1]<>'.')\r
and (line [ lineinx+1 ]<>')' ) then\r
begin (*decimal fraction*)\r
pushch; inchar;\r
if ch in digitch then\r
repeat\r
pushch; inchar;\r
until not (ch in digitch)\r
else markerror(100); (* error in realconstant: digit expected *)\r
newsymb:= realkonst;\r
end;\r
\r
if ch='E' then\r
begin (*exponent*)\r
pushch; inchar;\r
if ch in ['+','-'] then\r
begin\r
pushch; inchar;\r
end;\r
\r
if ch in digitch then\r
repeat\r
pushch; inchar;\r
until not (ch in digitch)\r
else markerror(100);\r
newsymb:= realkonst;\r
end;\r
end\r
else (* not konst *)\r
begin (* search in termtree *)\r
pushch;\r
lxnode:= entry[ch]; newi:= lxnode.hp;\r
inchar;\r
if newi<>0 then\r
repeat\r
if lx[newi].ch=ch then\r
begin pushch;\r
lxnode:= lx[newi];\r
newi:= lxnode.hp;\r
inchar;\r
end\r
else newi:= lx[newi].np;\r
until newi=0;\r
oldch:= chbuf[chbufi-1];\r
if (oldch in namech) and (ch in namech) then\r
begin\r
repeat pushch;\r
inchar;\r
until not(ch in namech);\r
newsymb:= nameval\r
end\r
else\r
if lxnode.tv>0 then (*valid terminal*)\r
begin\r
if lxnode.tv=realkonst then newsymb:= nameval (* the name 'realkonst' is not a reserved word *)\r
else\r
begin newsymb:= lxnode.tv;\r
chbufi:= oldbufi;\r
if newsymb=stringescape then readstring\r
else\r
if newsymb=combegin then begin skipcomment ;\r
goto 999; (* enter lexical once more *)\r
end\r
end\r
end\r
else\r
if oldch in namech then newsymb:= nameval\r
else markerror(0)\r
end\r
end; (*lexical*)\r
\r
\r
procedure special_code(oldtop, newtop : stackinx; prod : integer);\r
\r
(* this procedure is only used for handling of open routines *)\r
\r
(* handling of open routines by hand ( do not use parse ) *)\r
\r
(* syntax:\r
beginbody appetite :\r
pass5code\r
endbody\r
\r
code:\r
. literal begincode\r
. codeline( length ) .....\r
. .\r
. .\r
. .\r
. endcode\r
. endlevel\r
\r
*)\r
\r
var\r
stepvar : integer;\r
\r
function not_endbody : boolean;\r
(* see if the next word is 'endbody', lineix is only changed\r
if succes i.e. parsing may continue as if the routine body\r
only consisted of : 'beginbody appetite : '\r
*)\r
\r
var\r
step, oldindex : integer;\r
endbody : alfa;\r
found : boolean; (* local result *)\r
\r
begin\r
found:= false;\r
while ch=skipch do inchar;\r
oldindex:= lineinx; (* remember index of first character *)\r
\r
if ch='E' then (* possibly endbody *)\r
begin\r
endbody:= 'endbody ';\r
step:= 1;\r
while (endbody [ step ]=line [ lineinx ] ) and\r
(endbody [ step ]<>' ') do\r
begin\r
step:= step+1; lineinx:= lineinx+1;\r
end;\r
found:= (endbody [ step ]=' ') and not (line [ lineinx ] in namech);\r
\r
if not found then\r
lineinx:= oldindex (* reset lineinx *)\r
else\r
ch:= line [ lineinx ]; (* prepare return to parse *)\r
\r
end; (* maybe endbody *)\r
\r
not_endbody:= not found;\r
\r
\r
end; (* not_endbody *)\r
\r
begin (* special code *)\r
(* just read 'beginbody appetite' *)\r
while ch=skipch do inchar;\r
if ch=':' then inchar;\r
\r
emitcode(cbegincode);\r
\r
while not_endbody and moreinput do\r
begin\r
emit(ccodeline, linelength-lineinx, nill, cnocode);\r
for stepvar:= lineinx to linelength-1 do\r
emit(cnocode, ord( line [ stepvar ] ), nill, cnocode);\r
lineinx:= linelength; (* now current line is processed *)\r
inchar;\r
end; (* while *)\r
emit(cendcode, nill, nill, cendlevel);\r
\r
end; (* special code *)\r
\r
\r
(*$r+*)\r
procedure parse;\r
const\r
redumax= 25; (* reduction buffer size *)\r
\r
type\r
reduinx= 0..redumax;\r
reduelem= record\r
oldtop,newtop: stackinx;\r
prod: prodno\r
end;\r
var\r
redubuf: array[reduinx] of reduelem; (* reduction buffer *)\r
redutop: reduinx;\r
stacktop,pseudotop,validtop,top : stackinx;\r
startinx,lri,start: lrinx;\r
\r
procedure advance;\r
var i: integer;\r
begin\r
(*perform reductions*)\r
for i:= 1 to redutop do\r
with redubuf[i] do\r
begin\r
if prodtab[prod]>0 then code(oldtop,newtop,prodtab[prod])\r
else\r
if prodtab [ prod ]<>0 then\r
special_code(oldtop, newtop, prodtab [ prod ] );\r
attstack[newtop].chbufp:= attstack[newtop-1].chbufp\r
end;\r
(*update stack*)\r
for i:= 1 to stacktop-validtop do\r
parsestack[validtop+i]:= parsestack[top+i];\r
if redutop>0 then (* possible pop of chbuf *)\r
if oldbufi=chbufi then (* newsymb notin [name,konst,string]*)\r
chbufi:= attstack[stacktop-1].chbufp\r
else (*newsymb in [name,konst,string]*)\r
attstack[stacktop].chbufp:= oldbufi;\r
(*shift*)\r
if stacktop=stackmax then stop(1);\r
stacktop:= stacktop+1;\r
parsestack[stacktop].table:= startinx;\r
attstack[stacktop].chbufp:= chbufi;\r
(* freeze new stack situation, ready for new lookahead *)\r
top:= stacktop; pseudotop:= stacktop; validtop:= stacktop;\r
start:= lri; redutop:= 0\r
end; (*advance*)\r
\r
procedure backtrack( btop: stackinx; bstart: lrinx);\r
begin\r
stacktop:= btop; validtop:= btop; pseudotop:= btop;\r
startinx:= bstart; lri:= bstart;\r
redutop:= 0\r
end; (* backtrack *)\r
\r
procedure pseudoshift;\r
begin\r
if pseudotop=stackmax then stop(1);\r
stacktop:= stacktop+1;\r
pseudotop:= top+(stacktop-validtop);\r
parsestack[pseudotop].table:= startinx;\r
attstack[pseudotop].chbufp:= chbufi;\r
end; (* pseudoshift *)\r
\r
function lookahead( lsymbol: symbol): boolean;\r
label 11,12;\r
var decided: boolean;\r
li,si,locallri,low,high,k,locallb: lrinx;\r
\r
procedure queue( rs: rslength; p: prodno);\r
begin\r
if redutop=redumax then stop(4);\r
redutop:= redutop+1;\r
with redubuf[redutop] do\r
begin\r
oldtop:= stacktop; stacktop:= stacktop-rs; newtop:= stacktop;\r
if stacktop<=validtop then\r
begin\r
pseudotop:= stacktop; validtop:= stacktop\r
end else pseudotop:= pseudotop-rs;\r
prod:= p\r
end\r
end; (* queue *)\r
\r
begin\r
decided:= false;\r
locallri:= lri;\r
repeat\r
startinx:= locallri;\r
case lr[locallri].kind of\r
0: begin\r
decided:= true; lookahead:= true; ok:= false\r
end;\r
1: begin\r
while lr[locallri].symb<>lsymbol do\r
begin li:= lr[locallri].chain;\r
if li=0 then goto 11; (* exit loop *)\r
locallri:= li\r
end;\r
11: decided:= true; lookahead:= lr[locallri].symb=lsymbol\r
end;\r
2,4,6:\r
begin\r
while lr[locallri].symb<>lsymbol do\r
begin li:= lr[locallri].chain;\r
if li=0 then goto 12; (* exit loop *)\r
locallri:= li\r
end;\r
12: if lr[locallri].kind= 2 then\r
begin\r
decided:= true; lookahead:= true\r
end\r
else if lr[locallri].kind= 6 then\r
begin\r
pseudoshift;\r
stacktop:= stacktop-1; pseudotop:= pseudotop-1;\r
queue(-1,lr[locallri].err)\r
end\r
end;\r
3: begin\r
queue(lr[locallri].rs,lr[locallri].prod)\r
end;\r
5: begin\r
si:= parsestack[pseudotop].table;\r
low:= locallri;\r
locallri:= lr[locallri].chain;\r
high:= locallri-1;\r
while low<high do\r
begin\r
k:= (low+high) div 2;\r
locallb:= lr[k].lb;\r
if locallb>si then high:= k-1\r
else\r
if locallb<si then low:= k+1\r
else\r
begin\r
high:= k;\r
low:= high;\r
end;\r
end;\r
k:= (low+high+1) div 2;\r
if lr[k].lb=si then locallri:= k;\r
end\r
end; (* case *)\r
locallri:= lr[locallri].next;\r
until decided;\r
lri:= locallri;\r
end; (* lookahead *)\r
(*$r-*)\r
\r
procedure syntaxerror;\r
var success: boolean;\r
s,s1: stackinx;\r
begin\r
if testoutput then write(output,' <---syntaxerror'); (***snapshot***)\r
markerror(lr[startinx].err);\r
backtrack(top,start);\r
pseudoshift;\r
s:= 0;\r
for s1:= 0 to top do\r
begin\r
backtrack( top, start ) ; (* 80.03.21 *)\r
pseudoshift;\r
\r
backtrack(s1,parsestack[s1+1].table);\r
if lookahead(errorval) then\r
begin\r
parsestack[s1].link:= s; s:= s1\r
end\r
end;\r
success:= false;\r
repeat\r
s1:= s;\r
repeat\r
backtrack( top, start ); (* 80.03.21 *)\r
pseudoshift;\r
\r
backtrack(s1,parsestack[s1+1].table);\r
if lookahead(errorval) then\r
begin\r
pseudoshift;\r
success:= lookahead(newsymb)\r
end;\r
s1:= parsestack[s1].link;\r
until (s1=0) or success;\r
if not success then\r
begin\r
(* mark previous symbol skipped *)\r
if testoutput then write(output,' <---skipped'); (***snapshot***)\r
lexical\r
end;\r
until success or (not ok); \r
if not ok then stop(3)\r
end; (* syntaxerror *)\r
\r
\r
begin (* parse *)\r
top:= 0; start:= 1;\r
backtrack(top,start);\r
while ok do\r
begin\r
lexical;\r
if not lookahead(newsymb) then syntaxerror;\r
advance;\r
end;\r
end; (*parse*)\r
(*$r-*)\r
\r
begin (* parser *)\r
assign(input,concat(rtp35_pathname, i_pass1_tabname));\r
settextbuf(input, in_buf_ptr^);\r
(*$I-*)\r
reset(input);\r
if ioresult <> 0 then\r
begin\r
nofile(concat(rtp35_pathname, i_pass1_tabname));\r
end;\r
(*$I+*)\r
initialize(input);\r
close(input);\r
parse;\r
end; (*parser*)\r
\r
«eof»