DataMuseum.dk

Presents historical artifacts from the history of:

DANOSI

This is an automatic "excavation" of a thematic subset of
artifacts from Datamuseum.dk's BitArchive.

See our Wiki for more about DANOSI

Excavated with: AutoArchaeologist - Free & Open Source Software. 

top - download

⟦166c157e6⟧ TextFile

    Length: 36719 (0x8f6f)
    Types: TextFile
    Names: »RTP86P1.PAS«

Derivation

└─⟦02956c927⟧ Bits:30010510 DVBS1.SW2114.src.2.14-1 SW2114 REAL #1/4 TIME PASCAL SOURCE REL 2.14
    └─⟦this⟧ »RTP\RTP86P1.PAS« 
└─⟦b607d6035⟧ Bits:30010532 RTP compiler Source 1 2.14 26/9(?)-92 DVBS1.SW2114.src.2.14-8
    └─⟦this⟧ »RTP86P1.PAS«

TextFile

{$O+,F+}\r
unit rtp86p1;\r
(*program rtp86p1;*)\r
interface\r
uses pscplm, files, mpaunit, sthunit, sthcom, sthp1, rtp86mpa, p1code;\r
procedure rtp86pass1;\r
implementation\r
procedure rtp86pass1;\r
const\r
(*BOBS, constants generated by the generator *)\r
(**)\r
(* new gramma*)\r
{$IFNDEF RTP86}\r
symbmax = 264;\r
prodmax = 339;\r
lrmax = 1338;\r
lxmax = 240;\r
errorval = 17;\r
nameval = 35;\r
constval = 30;\r
stringval = 50;\r
punktval = 82;\r
stringch =\r
'''';\r
combegin = 89;\r
comlength = 2;\r
\r
(* new gramma *)\r
{$ELSE}\r
(* old gramma*)\r
\r
symbmax = 267;\r
prodmax = 336;\r
lrmax = 1286;\r
lxmax = 270;\r
errorval = 20;\r
nameval = 40;\r
constval = 33;\r
stringval = 59;\r
punktval = 93;\r
stringch =\r
'''';\r
combegin = 100;\r
comlength = 2;\r
{$ENDIF}\r
(*old gramma *)\r
 (*BOBS*)\r
(*-end-of-generated-constants-*)\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
lr_type=array[lrinx] of lrelm; (* lr-parse tables *)\r
\r
var\r
 lr_ptr:^lr_type;\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:array [char] of boolean; (*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
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
i: integer;\r
\r
\r
\r
(* bobs-procedures*)\r
\r
procedure put_comm(i:integer);\r
begin\r
  blockwrite(comm, i, 1);\r
end;\r
\r
\r
procedure getsource;\r
(* "sourcenumber" is the number of the latest read source text or\r
context - - It is '0', if we are about to access the first one *)\r
var\r
opt : array[1..5] of integer;\r
i, pno : integer;\r
newsource : integer;\r
begin\r
\r
(*#BEGINTEST\r
if xtestpass1 then\r
writeln(output,' GETSOURCE - oldno: ',sourcenumber);\r
(*ENDTEST#*)\r
\r
(*\r
newsource:= sourcenumber;\r
open_source(newsource);\r
*)\r
old_source:= sourcenumber;\r
\r
(* if sourcenumber <>newsource then *)\r
if sourcenumber< no_of_files then\r
(* open the file *)\r
begin\r
sourcenumber := sourcenumber + 1; (*newsource;*)\r
\r
open_source(sourcenumber);\r
\r
linenumber:= 1;\r
last_line:= linenumber;\r
\r
(* !!! TURBO !!!\r
comm^:= 12;                    put(comm);\r
comm^:= sourcenumber mod 256;  put(comm);\r
comm^:= linenumber mod 256;    put(comm);\r
comm^:= linenumber div 256;    put(comm);\r
comm^:= 0;                     put(comm);\r
*)\r
put_comm( 12);\r
put_comm( lo(sourcenumber));\r
put_comm( lo(linenumber));\r
put_comm( hi(linenumber));\r
put_comm( 0 );\r
\r
source_start:= false;\r
if sourcenumber > 1 then\r
emit( cnewline, nill, true, 0, false , 0, cnocode );\r
emit( coption, ord(allpass), true, ord(sourceno_), true, sourcenumber,\r
cnocode );\r
with call_options do\r
begin\r
if listing = 2 then\r
begin\r
liston:= true; p1list:= true;\r
end else\r
begin\r
liston:= false; p1list:= false;\r
end;\r
if indexcheck then opt[1]:= ord(ixcheck_) else opt[1]:= ord(noixcheck_);\r
if rangecheck then opt[2]:= ord(rangecheck_) else\r
                   opt[2]:= ord(norangecheck_);\r
if accesscheck then opt[3]:= ord(accesscheck_) else\r
                    opt[3]:= ord(noaccesscheck_);\r
if code then opt[4]:= ord(code_) else opt[4]:= ord(nocode_);\r
last_code:= ord(opt[4]);\r
if overflowcheck then opt[5] := ord(oflowcheck_) else\r
                   opt[5] := ord(nooflowcheck_);\r
emit(coption, ord(pass3),true,ord(createsize_),true,createsize,cnocode);\r
end;\r
for i:= 1 to 5 do\r
begin\r
if i=4 then pno:= ord(pass4) else pno:= ord(pass3);\r
emit(coption, pno, true, opt[i], true, 0, cnocode );\r
end;\r
emit( cnewline, nill, true, linenumber, false , 0, cnocode );\r
\r
if end_of_file then moreinput := false;\r
end\r
else\r
moreinput := false;\r
(** ? error - sourcetxt savnes - hidtil kun laest\r
contexter idet 'more_sources_allowed' var sat   **)\r
\r
(*#BEGINTEST\r
if xtestpass1 then\r
writeln(output,'end GETSOURCE - newno: ',sourcenumber);\r
(*ENDTEST#*)\r
end; (** getsource **)\r
\r
procedure initialize;\r
var\r
ch:char;\r
local_test : integer;\r
begin\r
\r
(* initialize global variables and open files *)\r
\r
accept_segment:=1; (* accept: 0 *)\r
\r
elementnumber:= 0;\r
linenumber := 0;\r
last_line:= 0;\r
save_mode:= no_specs;\r
 \r
lastlabelscope := 0;\r
lastbuffered := 0;\r
niv_count:= -1;\r
last_code:= ord(nocode_);\r
currentlabelscope := lastlabelscope;\r
typespecs:= [];\r
\r
p1st_curraddr  := last_addr;\r
st_recordaddr  := st_nilladdr;\r
\r
more_sources_allowed := true;\r
include_txt:= true;\r
incl_condition:= true;\r
source_start:= false;\r
liston     := false;\r
p1list     := false;\r
in_comment := false;\r
type_colon := false;\r
type_decl  := false;\r
first_colon:= true;\r
program_type:= false;\r
link_param     := false;\r
in_family      := false;\r
scalar_decl    := false;\r
region_stat    := false;\r
xtestpass1     := false;\r
make_packed    := false;\r
typebufferflag := false;\r
pack_info       := notpacked;\r
\r
str_and:= 'AND';\r
str_or:= 'OR';\r
str_xor:='XOR';\r
str_not:='NOT';\r
(*\r
with str_and do\r
begin\r
length:= 3;\r
alfa[1]:= 'A';\r
alfa[2]:= 'N';\r
alfa[3]:= 'D';\r
end;\r
\r
with str_or do\r
begin\r
length:= 2;\r
alfa[1]:= 'O';\r
alfa[2]:= 'R';\r
end;\r
\r
with str_xor do\r
begin\r
length:= 3;\r
alfa[1]:= 'X';\r
alfa[2]:= 'O';\r
alfa[3]:= 'R';\r
end;\r
\r
with str_not do\r
begin\r
length:= 3;\r
alfa[1]:= 'N';\r
alfa[2]:= 'O';\r
alfa[3]:= 'T';\r
end;\r
*)\r
if testpass1 >= 0 then\r
begin\r
xtestpass1:= testpass1 mod 2 = 1;\r
make_packed:= (testpass1 div 2) mod 2 = 1;\r
local_test:= testpass1 div 256;\r
if local_test > 0 then\r
begin\r
if odd( local_test ) then teststh:= true;\r
local_test:= local_test div 2;\r
if odd( local_test ) then teststh:= false;\r
local_test:= local_test div 2;\r
if odd( local_test ) and (original_testvmm >= 0) then testvmmupdate:= true;\r
local_test:= local_test div 2;\r
if odd( local_test ) then testvmmupdate:= false;\r
end; (* local_test > 0 *)\r
end; (* testpass1 >= 0 *)\r
\r
former_ptr:= nil;\r
\r
new( txton_ptr );\r
with txton_ptr^ do\r
begin\r
former:= former_ptr;\r
txton:= true;\r
inc_state:= true;\r
end;\r
\r
\r
(*** initialize "NUMBERCONV"  used in procedure "CODE" ***)\r
for ch := minch to maxch do\r
numberconv [ ch ] := 16;\r
for ch := '0' to '9' do numberconv [ ch ] := ord(ch) - ord('0');\r
numberconv ['A'] := 10;\r
numberconv ['B'] := 11;\r
numberconv ['C'] := 12;\r
numberconv ['D'] := 13;\r
numberconv ['E'] := 14;\r
numberconv ['F'] := 15;\r
numberconv ['a'] := 10;\r
numberconv ['b'] := 11;\r
numberconv ['c'] := 12;\r
numberconv ['d'] := 13;\r
numberconv ['e'] := 14;\r
numberconv ['f'] := 15;\r
\r
new(lr_ptr);\r
(*******)\r
\r
\r
(* force generation of code for the predefined names and types *)\r
\r
(* ourput version number as option( 0, 1, pass1_version )  *)\r
iwparam.i := pass1_version;\r
emit(coption, ord(allpass), true, ord(versionpass1), true, iwparam.w, cnocode);\r
\r
\r
end;\r
\r
\r
(***** HERE WAS PROCEDURE "CODE" originally placed *****)\r
\r
(* bobs procedures continuated*)\r
(*#t- *)\r
\r
procedure parser(var lr:lr_type);\r
const\r
skipch=' ';\r
\r
procedure dumplr;\r
var i:integer;\r
begin writeln(testoutput,'  i ',' chain next kind symb prod');\r
for i:=1 to lrmax do\r
with lr[i] do\r
begin write(testoutput,' ',i:3,chain:6,next:5,kind:5);\r
case kind of\r
1,2,4,6: writeln(testoutput,symb:5,err:5);\r
0,3    : writeln(testoutput,rs:5,prod:5);\r
5:     writeln(testoutput,lb:5)\r
end\r
end\r
end;\r
\r
\r
\r
procedure getoption( var ch : char );\r
\r
const\r
pname       = 1;\r
pval        = 2;\r
name_or_val = 3;\r
\r
var\r
ch1      : char;\r
i, val, res, pno : integer;\r
comno    : byte;\r
ifcon, list_opt,\r
ok, send : boolean;\r
opt, step: option_tokens;\r
optionname: string;\r
varname     : string;\r
\r
procedure skiptonext;\r
begin\r
while (lineinx<linelength) and\r
(ch <> ',') do begin\r
lineinx:=lineinx+1;\r
ch:=line[lineinx];\r
end;\r
ch:= ' ';\r
end;\r
\r
(*\r
function start_param : boolean;\r
begin\r
ch:= ' ';\r
while (ch<= ' ') or (ch = '(') do\r
if lineinx>=linelength\r
then ch:= ')' else\r
begin lineinx:=lineinx+1; ch:=line[lineinx]; end;\r
start_param:= ch <> ')';\r
end;\r
*)\r
\r
function readtitle : integer;\r
begin\r
while (ch<>'"') and (lineinx<linelength) do\r
begin lineinx:=lineinx+1; ch:=line[lineinx]; end;\r
if lineinx < linelength then\r
begin lineinx:=lineinx+1; ch:=line[lineinx]; end;\r
\r
if lineinx < linelength then\r
(*with varname255 do*)\r
begin\r
varname:='';    readtitle:= 7;\r
repeat\r
varname:= concat(varname, ch);\r
if lineinx>=linelength then ch:='"' else\r
begin lineinx:=lineinx+1; ch:=line[lineinx]; end;\r
until ch= '"';\r
end (** with **) else readtitle:= -1;\r
end;\r
\r
function startread : boolean;\r
begin\r
while ((ch<=' ') or (ch='(')) and (lineinx<linelength) do\r
begin lineinx:=lineinx+1; ch:=line[lineinx]; end;\r
startread:= lineinx<linelength;\r
end;\r
\r
\r
function readop: integer;\r
var op : integer;\r
begin\r
\r
if not startread then op:= 7 else\r
begin\r
(** ch <> sp **)\r
case ch of\r
'=' : op:= 1;\r
'<' : op:= 2;\r
'>' : op:= 3\r
else (*otherwise*) op:= 7;  (* legal after name: ',' or ')' or eol *)\r
end; (* case *)\r
\r
if op < 7 then\r
begin\r
if lineinx < linelength then\r
begin lineinx:=lineinx+1; ch:=line[lineinx]; end;\r
if lineinx>=linelength then op:=-1 else\r
case ch of\r
'-',\r
' ' : ;\r
'=' : if op > 1 then op:= op+3 else op:= -1;\r
'<' : op:= -1;\r
'>' : if op = 2 then op:= 4 else op:= -1\r
else (*otherwise*) if not namech[ch] then op:= -1;\r
end; (* case *)\r
if not namech[ch] and (ch<>'-') then ch:= ' ';\r
\r
end; (* op < 7 *)\r
end; (* op=7 *)\r
readop:= op;\r
(* if ok then 1 <= op <= 7 *)\r
end; (* readop *)\r
\r
\r
\r
function readparam( par : integer ): integer;\r
(*** result : operatorvalue or if < 0 then error ***)\r
var\r
i, op :integer;\r
\r
function readname : integer;\r
begin\r
if namech[ch] and ( not digitch[ch] ) then\r
\r
(*with varname do*)\r
begin\r
varname:='';\r
(*length:= 0;*)    readname:= 7;\r
repeat\r
(*length:= length + 1;\r
alfa[length]:= convch[ch];*)\r
varname:= concat(varname, convch[ch]);\r
if lineinx>=linelength then ch:=' ' else\r
begin lineinx:=lineinx+1; ch:=line[lineinx]; end;\r
until not namech[ch];\r
end (** with **) else readname:= -1;\r
\r
(** ch is a delimitor, may be sp,=,<,>, ',' or )  **)\r
end; (* readname *)\r
\r
\r
function readval : integer;\r
var\r
s : integer;\r
begin\r
s:= 1;\r
while (lineinx<linelength) and not digitch[ch] do\r
begin\r
if ch = '-' then s:= -1;\r
lineinx:=lineinx+1; ch:=line[lineinx];\r
end;\r
if digitch[ch] then\r
begin\r
val:= 0;  readval:= 8;\r
repeat\r
val:= val*10 + ord(ch) - ord('0');\r
if lineinx>=linelength then ch:=' ' else\r
begin lineinx:=lineinx+1; ch:=line[lineinx]; end;\r
until not digitch[ch];\r
val:= val*s;\r
end else readval:= -1;\r
end; (* readval *)\r
\r
\r
begin\r
if  startread then\r
begin\r
case par of\r
pname       : i:= readname;\r
pval        : i:= readval;\r
name_or_val : if digitch[ch] or (ch='-') then i:= readval else i:= readname\r
else (*otherwise*) i:= -1;\r
end; (* case *)\r
end else i:= -1;\r
readparam:= i;\r
end;  (* readparam *)\r
\r
\r
\r
function bool_expr : boolean;\r
var\r
op, res, v1, v2, state : integer;\r
b, b0, neg : boolean;\r
begin\r
state:= 0;\r
\r
while state < 4 do\r
begin\r
neg:= false;\r
op:= readparam(name_or_val);\r
if (op=7) and equalname(varname, str_not) then\r
begin\r
neg:= true;\r
op:= readparam(name_or_val);\r
end;\r
if op=8 then v1:= val else if op=7 then ok:= search_switch( varname, v1 )\r
else ok:= false;\r
if ok then\r
begin\r
op:= readop;\r
if (op>0) and (op<7) then\r
begin\r
res:= readparam(name_or_val);\r
if res=8 then v2:= val else\r
if res=7 then ok:= search_switch( varname, v2 ) else ok:= false;\r
end;\r
end;\r
\r
if ok then\r
begin\r
case op of\r
1 : b:= v1 = v2;\r
2 : b:= v1 < v2;\r
3 : b:= v1 > v2;\r
4 : b:= v1 <> v2;\r
5 : b:= v1 <= v2;\r
6 : b:= v1 >= v2\r
else (*otherwise*);\r
end; (* case *)\r
\r
if neg then b:= not b;\r
\r
if state > 0 then (* second expression *)\r
case state of\r
1: b:= b and b0;\r
2: b:= b or b0;\r
3: b:= ( b and not b0) or (b0 and not b)\r
else (*otherwise*) ;\r
end; (* case *)\r
\r
ch:= ' ';\r
op:= readparam( pname );\r
if op=7 then\r
begin\r
(** operator read **)\r
b0:= b;\r
if equalname(varname, str_and) then state:= 1 else\r
if equalname(varname, str_or)  then state:= 2 else\r
if equalname(varname, str_xor) then state:= 3 else ok:= false;\r
end else state:= 4;\r
(** end op = 7 **)\r
end;(* ok *)\r
if not ok then state:= 5;\r
end; (* while *)\r
if ok then bool_expr:= b else bool_expr:= false;\r
end; (* function *)\r
\r
\r
begin  (***  get option ***)\r
\r
(***  read option name ***)\r
optionname :='';\r
ok:= false;  ch:= ' ';\r
if startread then\r
begin\r
for i:= 1 to alfalength do if namech[ch] then\r
begin\r
optionname:= optionname + convch[ch] ;\r
if lineinx>=linelength then ch:=' ' else\r
begin lineinx:=lineinx+1; ch:=line[lineinx]; end;\r
end else\r
optionname:= optionname + ' ';\r
(*** search option in optiontext ***)\r
for step:= test_ to last_p_option_ do\r
if not ok then\r
begin\r
opt:= step;  i:= 0;\r
repeat\r
i:= i + 1;\r
ok:= optionname[i] = option_text[step,i];\r
until not ok or (i>=length(option_text[step]));\r
end;\r
end;\r
val:= 0;\r
if include_txt then send:= true else send:= false;\r
list_opt:= false;\r
if ok then\r
begin\r
ch:= ' ';\r
case opt of\r
test_:\r
if include_txt then\r
begin\r
if startread then\r
begin\r
if not digitch[ch] then\r
begin\r
ch1:= convch[ch];\r
case ch1 of\r
'P' : while not digitch[ch] and (lineinx<linelength) do\r
begin lineinx:=lineinx+1; ch:=line[lineinx]; end;\r
'S' : pno:= ord( sth );\r
'L' : pno:= ord( listh );\r
'V' : pno:= ord( vmm )\r
else (*otherwise*) ok:= false;\r
end; (* case *)\r
end;\r
if digitch[ch] then\r
begin\r
case (ord(ch) - ord('0')) of\r
1: pno:= ord(pass1);\r
2: pno:= ord(pass2);\r
3: pno:= ord(pass3);\r
4: pno:= ord(pass4)\r
else (*otherwise*)  ok:= false;\r
end; (* case *)\r
end;\r
ch:= ' ';\r
if ok and (readparam( pval ) > 0) then\r
begin\r
if ( pno= ord(pass1)) then\r
begin\r
if testpass1 >= 0 then\r
begin\r
xtestpass1:= val mod 2 = 1;\r
make_packed:= (val div 2) mod 2 = 1;\r
res:= val div 256;\r
if res > 0 then\r
begin\r
if odd( res ) then teststh:= true;\r
res:= res div 2;\r
if odd( res ) then teststh:= false;\r
end; (* res > 0 *)\r
send:= false;\r
end; (* testpass1 > 0 *)\r
res:= val div 1024;\r
if odd( res ) and ( original_testvmm >= 0 ) then testvmmupdate:= true;\r
res:= res div 2;\r
if odd( res ) then testvmmupdate:= false;\r
end (* pass1 *)\r
else if (pno=ord(vmm)) and testvmmupdate then testvmm:= val;\r
end;\r
end else ok:= false;\r
end;\r
\r
\r
code_,\r
nocode_:\r
if include_txt then\r
begin\r
pno:= ord( pass4 );\r
last_code:= ord(opt);\r
make_code:=make_code or (opt=code_);\r
end;\r
\r
segment_:\r
if include_txt then\r
begin\r
send:=false;\r
if make_segmentation then\r
warning(pass1, 137)\r
(* last segment empty, $SEGMENT ignored *)\r
else\r
if last_segment<max_segment then\r
begin\r
if readparam(pname)=7 then begin\r
make_segmentation:=true;\r
segment_info[last_segment+1].spix:= st_spixofname(varname);\r
segment_info[last_segment+1].list:= nil;\r
segment_info[last_segment+1].no_of_symbol:= 0;\r
segment_info[last_segment+1].code_size:=0;\r
end else warning(pass1, 135);\r
        (* illegal segment name, $SEGMENT ignored *)\r
end else warning(pass1, 136);\r
        (* too many segments, $SEGMENT ignored *)\r
end;\r
\r
version_:\r
  BEGIN\r
    IF SourceNumber = No_Of_Files THEN\r
      BEGIN\r
        if  readparam(pval) <> -1\r
         then call_options.version := val mod 256;\r
        if readparam(pval) <> -1\r
         then call_options.Subversion := val mod 256;\r
      END;\r
  END;\r
\r
createsize_:\r
if include_txt then\r
begin\r
if  readparam(pval) < 0 then ok:= false;\r
if ok then pno:= ord(pass3);\r
end;\r
\r
ixcheck_, noixcheck_, rangecheck_, norangecheck_, oflowcheck_,\r
nooflowcheck_, accesscheck_, noaccesscheck_:\r
if include_txt then pno:= ord(pass3);\r
\r
else (*otherwise*)\r
begin\r
val:= 1;\r
list_opt:= true;\r
end;\r
\r
end; (* case *)\r
\r
if ok and send and not list_opt then\r
emit( coption, pno, true, ord(opt), true, val, cnocode);\r
\r
if list_opt then\r
begin\r
\r
comno:= 0;\r
case opt of\r
\r
title_, subtitle_:\r
if include_txt then\r
begin\r
if readtitle < 0 then ok:= false;\r
if opt = title_ then comno:= 1 else comno:= 9;\r
end;\r
\r
pagewidth_, pagelength_:\r
if include_txt then\r
begin\r
if opt = pagewidth_ then comno:= 2 else comno:= 3;\r
if readparam(pval) < 0 then ok:= false;\r
end;\r
\r
listoff_:\r
if include_txt then\r
begin\r
comno := 10;\r
val   := 3;\r
liston:= false;\r
p1list:= false;\r
end;\r
\r
liston_ :\r
if include_txt then\r
begin\r
comno := 10;\r
val   := 4;\r
liston:= true;\r
p1list:= true;\r
end;\r
\r
eject_ :if include_txt  then comno:= 14;\r
\r
set_,default_:\r
if include_txt then\r
begin\r
repeat\r
if readparam( pname ) <> 7 then i:= -1 else\r
begin\r
i:= readop;\r
if (i=1) then i:= readparam( pval ) else i:= -1;\r
if i = 8 then\r
begin\r
add_switch( varname, val ,opt=default_);\r
skiptonext;\r
end else i:= -1;\r
end;\r
if i= -1 then ok:= false;\r
until (lineinx >= linelength) or not ok;\r
send:= false;\r
end;\r
\r
if_:\r
begin\r
former_ptr:= txton_ptr;\r
new( txton_ptr );\r
txton_ptr^.former:= former_ptr;\r
include_txt:= former_ptr^.inc_state;\r
if include_txt then\r
begin\r
ifcon:= bool_expr;\r
if ok then include_txt:= ifcon;\r
end;\r
txton_ptr^.txton:= include_txt;\r
txton_ptr^.inc_state:= include_txt;\r
comno:= 11;\r
end; (* if *)\r
\r
endif_:\r
if former_ptr <> nil then\r
begin\r
dispose( txton_ptr );\r
txton_ptr:= former_ptr;\r
former_ptr:= txton_ptr^.former;\r
include_txt:= txton_ptr^.inc_state;\r
comno:= 11;\r
end; (* endif *)\r
\r
elseif_:\r
if former_ptr <> nil then\r
begin\r
if former_ptr^.inc_state then\r
begin\r
if txton_ptr^.txton then include_txt:= false else\r
begin\r
ifcon:= bool_expr;\r
if ok then include_txt:= ifcon;\r
txton_ptr^.txton:= include_txt;\r
end;\r
txton_ptr^.inc_state:= include_txt;\r
end;\r
comno:= 11;\r
end;  (* elseif *)\r
\r
else_:\r
if former_ptr <> nil then\r
begin\r
if former_ptr^.inc_state then\r
with txton_ptr^ do\r
begin\r
if txton then include_txt:= false else\r
begin\r
include_txt:= true;\r
txton:= include_txt;\r
end;\r
inc_state:= include_txt;\r
end;\r
comno:= 11;\r
end (* else *)\r
\r
else (*otherwise*)  ok:= false;\r
end; (* case *)\r
\r
if comno = 11 then\r
begin\r
if incl_condition=include_txt then send:= false else\r
begin\r
val:= 1;\r
send:= true;\r
incl_condition:= include_txt;\r
if include_txt then\r
begin\r
val:= 2;\r
if liston and not p1list and call_options.iflist then\r
begin\r
val:= 4;\r
p1list:= true;\r
end;\r
end else\r
if p1list and call_options.iflist then\r
begin\r
p1list:= false;\r
val:= 3;\r
end;\r
if val > 2 then\r
begin\r
(* !!! TURBO !!!\r
comm^:= 10;                    put(comm);\r
comm^:= sourcenumber mod 256;  put(comm);\r
comm^:= linenumber mod 256;    put(comm);\r
comm^:= linenumber div 256;    put(comm);\r
comm^:= val mod 256;           put(comm);\r
*)\r
put_comm( 10);\r
put_comm( lo(sourcenumber));\r
put_comm( lo(linenumber));\r
put_comm( hi(linenumber));\r
put_comm( lo(val) );\r
val:= val -2;\r
end;\r
end;\r
end;  (** comno = 11 **)\r
\r
if send and ok then\r
begin\r
(* !!! TURBO !!!\r
comm^:= comno;                 put(comm);\r
comm^:= sourcenumber mod 256;  put(comm);\r
comm^:= linenumber mod 256;    put(comm);\r
comm^:= linenumber div 256;    put(comm);\r
*)\r
put_comm( comno);\r
put_comm( lo(sourcenumber));\r
put_comm( lo(linenumber));\r
put_comm( hi(linenumber));\r
\r
if (comno=1) or (comno=9) then\r
begin\r
(*with  varname255 do *)\r
begin\r
(*comm^:=  length;    put(comm);*)\r
put_comm( length(varname));\r
for i:= 1 to length(varname) do\r
begin\r
(*comm^:= ord(name[i]);  put(comm);*)\r
put_comm( ord(varname[i]));\r
end;\r
end; (* with *)\r
end else\r
begin\r
(*comm^:= val mod 256;   put(comm);*)\r
put_comm( lo(val));\r
end;\r
end; (* send *)\r
end; (* opt > createsize *)\r
end;\r
\r
while lineinx<linelength do\r
begin lineinx:=lineinx+1; ch:=line[lineinx]; end;\r
if not ok then warning( pass1, 130 );\r
end;\r
\r
\r
procedure readline;\r
label 102; (* skip lines longer than 'rtpstringmax'-1 charactes *)\r
var lgt:integer;\r
    i:word;\r
    ch:char;\r
begin\r
elementnumber:=0;\r
102: lineinx:=0; lgt:=-1;\r
linenumber:=linenumber+1;\r
if end_of_file then\r
begin\r
while former_ptr<>nil do\r
begin\r
line[1]:='$';\r
line[2]:='e';\r
line[3]:='n';\r
line[4]:='d';\r
line[5]:='i';\r
line[6]:='f';\r
linelength:=6;\r
lineinx:=1;\r
ch:='$';\r
getoption(ch);\r
end;\r
\r
if newsymb <> punktval then errormsg(pass1,123);\r
if more_sources_allowed then\r
getsource else\r
begin\r
moreinput:=false;\r
if sourcenumber < no_of_files then warning( pass1, 133 );\r
end;\r
end;\r
if not moreinput then\r
begin\r
ch:='.';\r
line[1]:=ch;\r
lgt:=1;\r
newsymb:=0;\r
include_txt:= true;\r
end else\r
begin\r
lgt:=get_line(line);\r
if lgt=0 then goto 102;\r
if lgt>=rtpstringmax then\r
errormsg(pass1,102); (* line too long *)\r
ch:=line[1];\r
\r
if (ch='$') and not in_comment then (* option *)\r
begin\r
linelength:=lgt;\r
lineinx:=1;\r
getoption(ch);\r
lineinx:=lgt;\r
goto 102;\r
end; (* option *)\r
end;\r
if not include_txt then goto 102;\r
linelength:=lgt;\r
end;\r
\r
procedure inchar;\r
begin\r
if lineinx=linelength then readline;\r
lineinx:=lineinx+1;\r
ch:=line[lineinx];\r
end; (*inchar*)\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
ok := true;\r
moreinput:=true; lineinx:=1; chbufi:=0;\r
linelength:=1;\r
parsestack[0].table:=0; attstack[0].chbufp:=chbufi;\r
ch:=' '; parsestack[0].link:=0;\r
for ch1:= chr(0) to ' ' do if (ch1<>chr(10)) and (ch1<>chr(13)) then\r
convch[ ch1 ]:= ' ';\r
for ch1 := ' ' to '~' do\r
if (ch1 >= 'a') and (ch1 <= 'z') then\r
convch [ ch1 ] := chr( ord(ch1) - ( ord('a') - ord('A') ) )\r
else\r
convch [ ch1 ] := ch1;\r
\r
(** initialize "digitch" and "namech" **)\r
for ch1 := chr(0) to maxch do\r
begin\r
digitch [ch1] := false;\r
namech [ch1] := false;\r
end;\r
\r
for ch1 := '0' to '9' do\r
begin\r
digitch [ ch1] := true;\r
namech [ch1] := true;\r
end;\r
\r
for ch1 := 'a' to 'z' do\r
namech[ ch1 ] := true;\r
\r
for ch1 := 'A' to 'Z' do\r
namech [ch1] := true;\r
namech ['_'] := true;\r
\r
(** end of initialize digitch and namech **)\r
\r
\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
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 chain=0 then\r
begin\r
lr[firstlb].chain:=i;\r
newlb:=true;\r
end;\r
end\r
else (*otherwise*);\r
end (* case *)\r
end\r
;\r
prodtab[0] := 0;\r
(* read the production labels *)\r
for i := 1 to prodmax do\r
begin\r
read(tables, a, prodtab[ a ]);\r
(* !!! TURBO !!!\r
while not eoln(tables) do get(tables);\r
get(tables);\r
*) readln(tables);\r
end;\r
\r
end;(*initialize*)\r
\r
procedure lexical;\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 : word;\r
passnr, optnr, optvalue : integer;\r
commentend : char;\r
\r
begin (* skip comment *)\r
\r
start_line := linenumber; (* remember current line number in case of unterminated comment *)\r
\r
if chbuf[ chbufi ] = '-' then\r
(* comment syntax: --................eoln *)\r
begin\r
(* Now skip the rest of the line, which is read by "readline" --\r
  this is here done by increasing "lineinx" followed by a call \r
  of "inchar"   **)\r
\r
lineinx := linelength;\r
end\r
else\r
begin\r
if chbuf[ chbufi ] = '(' then commentend := ')'\r
else commentend := '>';\r
\r
in_comment:= true;\r
repeat\r
while (ch <> '*') and moreinput do inchar;\r
inchar;\r
until (ch = commentend) or not moreinput;\r
in_comment:= false;\r
if not moreinput then\r
begin\r
errormsg( pass1, 103 ); (* comment did not terminate *)\r
write(testoutput,'(* comment started in line ', start_line:1, ' *)');\r
end;\r
\r
end;\r
\r
inchar;\r
end; (* skip comment *)\r
\r
\r
procedure pushch;\r
begin\r
chbuf[chbufi]:=ch;\r
if chbufi<chbufmax then chbufi:=chbufi+1\r
else fatal_error( pass1,206);\r
if xtestpass1 then write(testoutput,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
\r
case strch of\r
'"': begin  (*text or string delimiter *)\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 errormsg( pass1,101);\r
(* string did not terminate within line *)\r
\r
char_or_text := ctext;\r
  (**for use in procedure "literal" in procedure "code" **)\r
end; (*text*)\r
\r
'''': begin  (*char delimiter **)\r
      if strch = line[lineinx + 1] (*lookahead*) then\r
        (** correct character constant **)\r
       begin\r
        pushch;\r
        if strch=line[lineinx] then\r
          if strch=line[lineinx+2] then lineinx := lineinx+1;        \r
            (* accept '''' instead of ''' *)\r
        lineinx := lineinx + 2;   (*i.e.: skip char-delimiter **)\r
        ch := line[lineinx];\r
       end\r
else\r
begin\r
while( ch <> strch ) and ( lineinx < linelength ) do\r
begin\r
lineinx:= lineinx+1;\r
ch:= line[lineinx];\r
end;\r
if ch=strch then\r
begin\r
lineinx:= lineinx + 1;\r
ch:= line[lineinx];\r
end;\r
errormsg( pass1,0);\r
end;\r
(* "  ' expected"  or "illegal character delimiter" or .. *)\r
\r
char_or_text := cchar;\r
end (* char *);\r
\r
end; (** case strch...**)\r
\r
newsymb:=stringval\r
end; (*readstring*)\r
\r
\r
\r
begin (*lexical*)\r
999:\r
\r
if xtestpass1 then\r
begin\r
writeln(testoutput); write(testoutput,' lexical: '); (***snapshot***)\r
end;\r
\r
while ch <= skipch do inchar;\r
if not source_start then\r
begin\r
source_start:= true;\r
(* !!! TURBO !!!\r
comm^:= 8;                     put(comm);\r
comm^:= sourcenumber mod 256;  put(comm);\r
comm^:= linenumber mod 256;    put(comm);\r
comm^:= linenumber div 256;    put(comm);\r
comm^:= 0;                     put(comm);\r
*)\r
put_comm( 8);\r
put_comm( lo(sourcenumber));\r
put_comm( lo(linenumber));\r
put_comm( hi(linenumber));\r
put_comm( 0 );\r
\r
end;\r
\r
oldbufi:=chbufi;\r
if not moreinput then\r
begin\r
if newsymb=0 then (*third*)\r
begin\r
errormsg( pass1,122);\r
ok:= false;\r
end else\r
if newsymb=1 then (*second*) newsymb:=0\r
else (*first*) newsymb:=1\r
end\r
else\r
if digitch [ ch ] then\r
begin (*konst*)\r
elementnumber:= elementnumber + 1;\r
\r
\r
repeat\r
chbuf [ chbufi ] := ch;\r
if chbufi < chbufmax then \r
chbufi := chbufi + 1\r
else fatal_error( pass1, 206 );\r
\r
if xtestpass1 then write(testoutput, ch); (***SNAPSHOT***)\r
\r
if lineinx = linelength then\r
readline;\r
\r
lineinx := lineinx + 1;\r
ch := line [ lineinx ] ;\r
\r
until not (digitch [ ch ]);\r
newsymb:=constval;\r
int_or_real := cinteger;\r
if (ch='.') and (line[lineinx+1]<>'.') \r
and (line [ lineinx + 1 ] <> ')' ) then\r
begin (*decimal fraction*)\r
int_or_real := creal;\r
chbuf [ chbufi ] := ch;\r
if chbufi < chbufmax then \r
chbufi := chbufi + 1\r
else fatal_error( pass1, 206 );\r
\r
if xtestpass1 then write(testoutput, ch); (***SNAPSHOT***)\r
\r
if lineinx = linelength then\r
readline;\r
\r
lineinx := lineinx + 1;\r
ch := line [ lineinx ] ;\r
\r
if digitch [ ch ] then\r
repeat\r
chbuf [ chbufi ] := ch;\r
if chbufi < chbufmax then \r
chbufi := chbufi + 1\r
else fatal_error( pass1, 206 );\r
\r
if xtestpass1 then write(testoutput, ch); (***SNAPSHOT***)\r
\r
if lineinx = linelength then\r
readline;\r
\r
lineinx := lineinx + 1;\r
ch := line [ lineinx ] ;\r
\r
until not (digitch [ ch ])\r
else errormsg( pass1,100); (* error in realconstant: digit expected *)\r
end;\r
\r
if (ch = 'E') or (ch = 'e') then\r
begin (*exponent*)\r
int_or_real := creal;\r
chbuf [ chbufi ] := 'E';\r
if chbufi < chbufmax then \r
chbufi := chbufi + 1\r
else fatal_error( pass1, 206 );\r
\r
if xtestpass1 then write(testoutput, ch); (***SNAPSHOT***)\r
\r
if lineinx = linelength then\r
readline;\r
\r
lineinx := lineinx + 1;\r
ch := line [ lineinx ] ;\r
\r
if (ch = '+') or (ch = '-') then\r
begin\r
chbuf [ chbufi ] := ch;\r
if chbufi < chbufmax then \r
chbufi := chbufi + 1\r
else fatal_error( pass1, 206 );\r
\r
if xtestpass1 then write(testoutput, ch); (***SNAPSHOT***)\r
\r
if lineinx = linelength then\r
readline;\r
\r
lineinx := lineinx + 1;\r
ch := line [ lineinx ] ;\r
\r
end;\r
\r
if digitch [ ch ] then\r
repeat\r
chbuf [ chbufi ] := ch;\r
if chbufi < chbufmax then \r
chbufi := chbufi + 1\r
else fatal_error( pass1, 206 );\r
\r
if xtestpass1 then write(testoutput, ch); (***SNAPSHOT***)\r
\r
if lineinx = linelength then\r
readline;\r
\r
lineinx := lineinx + 1;\r
ch := line [ lineinx ] ;\r
\r
until not (digitch [ ch ])\r
else errormsg( pass1,100);\r
end;\r
end\r
else (* not konst *)\r
begin (* search in termtree *)\r
\r
\r
lxnode:=entry[convch [ ch ]]; newi:=lxnode.hp;\r
chbuf [ chbufi ] := ch;\r
if chbufi < chbufmax then \r
chbufi := chbufi + 1\r
else fatal_error( pass1, 206 );\r
\r
if xtestpass1 then write(testoutput, ch); (***SNAPSHOT***)\r
\r
if lineinx = linelength then\r
readline;\r
\r
lineinx := lineinx + 1;\r
ch := line [ lineinx  ] ;\r
\r
if newi <> 0 then\r
repeat\r
if lx[newi].ch= convch [ ch ] then\r
begin\r
lxnode:=lx[newi];\r
newi:=lxnode.hp;\r
chbuf [ chbufi ] := ch;\r
if chbufi < chbufmax then \r
chbufi := chbufi + 1\r
else fatal_error( pass1, 206 );\r
\r
if xtestpass1 then write(testoutput, ch); (***SNAPSHOT***)\r
\r
if lineinx = linelength then\r
readline;\r
\r
lineinx := lineinx + 1;\r
ch := line [ lineinx ] ;\r
\r
end\r
else newi:=lx[newi].np;\r
until newi=0;\r
oldch:=chbuf[chbufi-1];\r
if namech [ oldch ] and namech [ ch ] then\r
begin\r
elementnumber:= elementnumber + 1;\r
repeat\r
chbuf [ chbufi ] := ch;\r
if chbufi < chbufmax then \r
chbufi := chbufi + 1\r
else fatal_error( pass1, 206 );\r
\r
if xtestpass1 then write(testoutput, ch); (***SNAPSHOT***)\r
\r
if lineinx = linelength then\r
readline;\r
\r
lineinx := lineinx + 1;\r
ch := line [ lineinx ] ;\r
\r
until not(namech [ ch ]);\r
newsymb:=nameval\r
end\r
else\r
if lxnode.tv > 0 then (*valid terminal*)\r
begin\r
chbufi:=oldbufi;\r
if lxnode.tv=stringescape then readstring\r
else\r
if lxnode.tv=combegin then\r
begin\r
skipcomment ;\r
goto 999; (* enter lexical once more  *)\r
end else newsymb:=lxnode.tv;\r
end\r
else\r
if namech [ oldch ] then\r
begin\r
newsymb:= nameval;\r
elementnumber:= elementnumber + 1;\r
end\r
else errormsg( pass1,0)\r
end\r
end; (*lexical*)\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
\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
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 fatal_error( pass1,201);\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 fatal_error( pass1,201);\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 fatal_error( pass1,204);\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
\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
procedure syntaxerror;\r
var success: boolean;\r
s,s1: stackinx;\r
begin\r
if xtestpass1 then\r
begin\r
writeln(testoutput,' <---syntaxerror'); (***snapshot***)\r
writeln(testoutput, 'pass1 error no :', lr[startinx].err,\r
'   lineno: ',linenumber,'   elementno: ',elementnumber);\r
end;\r
errormsg( pass1,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 xtestpass1 then write(testoutput,' <---skipped'); (***snapshot***)\r
lexical\r
end;\r
until success or (not ok); \r
if not ok then fatal_error( pass1,203)\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
begin (* parser *)\r
initialize(parsetables);\r
(** dumplr; **)\r
parse;\r
end; (*parser*)\r
\r
\r
(* !!! TURBO !!! procedure rtp86pass1; *)\r
begin\r
\r
initialize;\r
getsource;\r
linenumber:=0; (* linenumber is updated first in readline *)\r
parser(lr_ptr^);\r
\r
if make_segmentation then\r
warning(pass1, 138);\r
(* illegal segment, $SEGMENT ignored *)\r
make_segmentation:=last_segment>1;\r
\r
while txton_ptr <> nil do\r
begin\r
former_ptr:= txton_ptr;\r
txton_ptr:=former_ptr^.former;\r
dispose( former_ptr);\r
end;\r
dispose(lr_ptr);\r
\r
\r
(* !!! TURBO !!!\r
comm^:= 13;                       put(comm);\r
comm^:= (sourcenumber+1) mod 256; put(comm);\r
comm^:= 0;    put(comm);\r
comm^:= 0;    put(comm);\r
comm^:= 0;    put(comm);\r
*)\r
put_comm( 13);\r
put_comm( lo(sourcenumber + 1));\r
put_comm( 0);\r
put_comm( 0);\r
put_comm( 0 );\r
\r
\r
(*#BEGINTEST\r
if xtestpass1 then writeln(testoutput,'END PASS1 ---');\r
(*ENDTEST#*)\r
\r
end;\r
end.\r
\r
\r
«eof»