|
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: 61424 (0xeff0)
Types: TextFile
Names: »LIST.PAS«
└─⟦02956c927⟧ Bits:30010510 DVBS1.SW2114.src.2.14-1 SW2114 REAL #1/4 TIME PASCAL SOURCE REL 2.14
└─⟦this⟧ »RTP\LIST.PAS«
└─⟦4f587ad96⟧ Bits:30010518 DVBS1.SW2114.src.2.7-1 SW2114 1/4 Real Time Pascal 2.7 92.06.16
└─⟦this⟧ »RTP\LIST.PAS«
└─⟦a2a9e188c⟧ Bits:30010526 DVBS1.SW2114.src.2.6-4 RTP Compiler Source SW2104+SW2114 Disk 1 92.02.03 HEJ HHA
└─⟦this⟧ »RTP\LIST.PAS«
└─⟦b607d6035⟧ Bits:30010532 RTP compiler Source 1 2.14 26/9(?)-92 DVBS1.SW2114.src.2.14-8
└─⟦this⟧ »LIST.PAS«
└─⟦fd2665794⟧ Bits:30010523 DVBS1.SW2114.src.2.6-1 RTP compiler source SW2104+SW2114 Disk#1 30/1-92 HHA
└─⟦this⟧ »RTP\LIST.PAS«
{$F+,O+}\r
unit list;\r
interface\r
procedure listhandler;\r
\r
IMPLEMENTATION\r
uses dos,pscplm,files,mpaunit,rtp86mpa,sthunit,sthcom;\r
\r
procedure listhandler;\r
LABEL 10;\r
CONST\r
maxword= $FFFF;\r
blank=' ';\r
lsize=240; (* LONGEST LINE*)\r
ssize= 90; (* DEEPEST STACK LOAD*)\r
ksize= 55; (* ENTIRE NO OF KEYWORDS*)\r
keynumsize = 13;\r
toplength = 12; (* longest identifier *)\r
if_priority=6; (* special if priority makes it possible for ELSE to pop one IF *)\r
defaultpagelength=45;\r
defaultpagewidth=115;\r
maxprel=10;(* max number of list/nolist options before first programline *)\r
\r
alfalength = 12;\r
maxlines=255;\r
recs=5; (* no of records in eatch buffer *)\r
errhead='Errors and Warnings'; errheadl=19;\r
codehead='Code listing'; codeheadl=12;\r
crosshead='Cross reference'; crossheadl=15;\r
infohead='Compiler information'; infoheadl=20;\r
\r
res_begin=1;\r
res_case=2;\r
res_do=3;\r
res_else=4;\r
res_end=5;\r
res_endloop=6;\r
res_function=7;\r
res_loop=8;\r
res_otherwise=9;\r
res_procedure=10;\r
res_program=11;\r
res_record=12;\r
res_repeat=13;\r
res_shared=14;\r
res_type=15;\r
res_until=16;\r
res_var=17;\r
res_with=18;\r
res_const=19;\r
res_lock=20;\r
res_lockdata=21;\r
res_lockbuf=22;\r
\r
\r
(**** commands *********************)\r
titlecomm = 1; (* length:byte; text:string *)\r
pagewidthcomm = 2; (* pagewidth: byte *)\r
pagelengthcomm= 3; (* pagelength: byte *)\r
indentcomm = 4; (* indent: off=1,on=2 *)\r
markcomm = 5; (* mark: off=1,on=2 *)\r
keycomm = 6; (* key: own=1,low=2,upp=3 *)\r
ownkeyw_=1; lckeyw_=2;\r
idcomm = 7; (* id: own=1,low=2,upp=3 *)\r
ownid_=1; lcid_=2;\r
programcomm = 8; (* *)\r
subtitlecomm = 9; (* length:byte; text:string *)\r
listcomm =10; (* listing: nolist=1,list=2,listoff=3,liston=4 *)\r
conditioncomm =11; (* condition: off=1,on=2 *)\r
sourcecomm =12; (* *)\r
endcomm =13; (* *)\r
eject =14;\r
\r
\r
TYPE\r
stackelement= RECORD\r
prior,indent:integer\r
END;\r
tablelement = RECORD\r
p1,p2,spacing:integer\r
END;\r
\r
passnotype=pass1..pass4;\r
(* alfa9=packed array[1..9] of char;\r
alfa10=packed array[1..10] of char;\r
alfa13=packed array[1..13] of char;\r
alfa14=packed array[1..14] of char;\r
*)\r
VAR\r
eol: boolean; (** false until END-OF-LINE is met **)\r
\r
alfanum:array[char] of 0..4; (* IDENTIFY THE ALPHANUMERIC SYMBOLS *)\r
tsize:integer; (* NO OF INTERESTING KEYWORDS *)\r
line:ARRAY[0..lsize] OF char; (* LINE LEFT JUSTIFIED*)\r
pos:integer; (* POINTER TO CURRENT CHARACTER*)\r
lastpos:integer; (* LAST POSITION ON CURRENT LINE*)\r
linepos:integer; (* POINTER TO LAST USED PRINTPOS*)\r
lineno :integer; (* LINE NUMBER OF CURRENT LINE *)\r
sourceno :integer; (* NUMBER OF CORRENT SOURCE *)\r
current,ch:char; (* CH IS FIRST CHAR ON NEXT LINE*)\r
fresh:boolean; (* LINE READ,NOT YET PRINTED*)\r
margin,print_margin,cond_margin:integer; (* HANDLES INDENTION*)\r
oldpos:integer; (* USED TO HOLD POSITIONS IN RECORDS*)\r
state: (declare,statement,formal_parameters);\r
bracket_niv, on_bracket_niv: integer;\r
formfeed, myind,\r
noind_ : boolean;\r
listmode,printmode,next_printmode,markmode:boolean;\r
read_commands:boolean;\r
idmode,\r
reskeymode: byte;\r
conditionstate,next_conditionstate: char;\r
prelude,prelude2: boolean;\r
listx: byte;\r
preludeline: array[1..maxprel] of integer;\r
preludeop: array[1..maxprel] of byte;\r
plength,pwidth,paging: byte;\r
pageno,pline: integer;\r
headtxt: string;\r
headnamelength: byte;\r
headname: string[string_length];\r
time: datetime;\r
packedtime: longint;\r
timestring : string[string_length];\r
subheadl: byte;\r
subheadtxt: string;\r
printtop: integer;\r
commkey,commsource,commop: byte;\r
commline: integer;\r
\r
endcomment: char; (* '>' or ')' depending on the start of the comment *)\r
norecord:integer;\r
inwith:boolean;\r
\r
cmarkstack,markstack:ARRAY[-10..lsize] OF integer;\r
markpointer,nextmark:integer;\r
\r
\r
\r
stack:ARRAY[0..ssize] OF stackelement;\r
top: integer; (* STACK POINTER *)\r
top_bound: integer;\r
table:ARRAY[1..30] OF tablelement;\r
(* ACTUALLY THIS BOUND OF 30 IS "TSIZE" *)\r
keyword: ARRAY[1..ksize] OF string[12];\r
table_index:array[1..ksize] of integer;\r
keynum:ARRAY[1..keynumsize] OF integer;\r
lf,ff,cr,tab: char;\r
\r
internalerror : boolean;\r
\r
(* variables for errorlisting *)\r
err: array[passnotype,1..recs] of errorrecs;\r
seqno,full,empty,filled: array[passnotype] of word;\r
curseqno: word;\r
stop: errorrecs;\r
acterrorrec : errorrecs;\r
\r
(* TURBO *)\r
function get_comm : byte;\r
var\r
b : byte;\r
begin\r
blockread(comm,b,1);\r
get_comm := b;\r
end;\r
\r
procedure makeprintabletime(VAR packedtime : longint;VAR name : string);\r
BEGIN\r
unpacktime(packedtime,time);\r
\r
name := ' '; (* 18 *)\r
name[1]:=' ';\r
name[2]:= chr((time.year - 1900) div 10 + ord('0'));\r
name[3]:= chr(time.year mod 10 + ord('0'));\r
\r
name[4]:='.';\r
name[5]:=chr(time.month div 10 + ord('0'));\r
name[6]:=chr(time.month mod 10 + ord('0'));\r
name[7]:='.';\r
name[8]:=chr(time.day div 10 + ord('0'));\r
name[9]:=chr(time.day mod 10 + ord('0'));\r
name[10]:=' ';\r
name[11]:=chr(time.hour div 10 + ord('0'));\r
name[12]:=chr(time.hour mod 10 + ord('0'));\r
name[13]:='.';\r
name[14]:=chr(time.min div 10 + ord('0'));\r
name[15]:=chr(time.min mod 10 + ord('0'));\r
name[16]:='.';\r
name[17]:=chr(time.sec div 10 + ord('0'));\r
name[18]:=chr(time.sec mod 10 + ord('0'));\r
END;\r
\r
procedure error(e_txt1: string);\r
begin\r
writeln(listfile);\r
writeln(listfile,'*** LISTHANDLER ERROR ***',e_txt1);\r
\r
end (*error*);\r
\r
\r
(*** NEW READ PROCEDURES FOR READING BYTE-FILES ***)\r
procedure read_(var c: char);\r
var\r
dummy:char;\r
begin\r
c:=chr(get_byte);\r
if c < blank then\r
begin\r
eol := false;\r
\r
if (c = cr) and (chr(next_byte) = lf) then\r
begin\r
eol := true;\r
c:=chr(get_byte);\r
end else eol:=(c = lf);\r
if (c = chr(25)) or (c = chr(26)) then\r
begin\r
end_of_file:=true;\r
eol:=true;\r
end;\r
c := blank;\r
end;\r
if chr(next_byte) = ff then\r
begin\r
if printmode then formfeed:=true;\r
repeat\r
dummy:=chr(get_byte);\r
until chr(next_byte)<>ff;\r
end else\r
if end_of_file then eol:=true;\r
end; (** read_ **)\r
\r
procedure readln_;\r
var\r
dummy: char;\r
begin\r
while not eol do read_(dummy);\r
eol := false;\r
end;\r
\r
(*** END READ-PROCEDURES ***)\r
procedure shift_the_source;\r
var conn : file;\r
e: word;\r
pos,i,j:integer;\r
begin\r
\r
(*#BEGINTEST\r
if testlist>1 then\r
begin\r
writeln(testoutput,'shift_the_so');\r
end;\r
(*ENDTEST#*)\r
if (sourceno>0) and (sourceno<=no_of_files) then\r
with callparams[sourceno] do with call_options do begin\r
if pagewidth<>0 then begin\r
pwidth:=pagewidth; if pwidth<75 then pwidth:=75; end;\r
if pagelength<>0 then begin\r
plength:=pagelength; if plength<30 then plength:=30; end;\r
if plength=1 then begin plength:=maxlines; paging:=0; end else paging:=1;\r
if indent<>0 then myind:=indent=2;\r
noind_:=myind;\r
if mark<>0 then markmode:=mark=1;\r
if keyword<>0 then reskeymode:=keyword;\r
if ident<>0 then idmode:=ident;\r
if listing<>0 then begin\r
listmode:=listing=2; printmode:=listmode; next_printmode:=printmode;\r
end;\r
assign(conn,filename);\r
reset(conn);\r
getftime(conn,packedtime);\r
close(conn);\r
makeprintabletime(packedtime,timestring);\r
\r
i:=length(filename);\r
while (i>0) and (filename[i]<>'/') and (filename[i]<>':') and\r
(filename[i]<>'\') do i:=i-1;\r
j:=length(filename) - i;\r
headname := '';\r
for pos:= 1 to j do headname :=headname + filename[i+pos];\r
headname := headname + timestring;\r
\r
headnamelength:=j+18;\r
end;\r
end; (* shift_the_source *)\r
\r
procedure command;\r
var i: integer;\r
\r
procedure getcomm;\r
begin\r
(*#BEGINTEST\r
if testlist>1 then\r
begin\r
writeln(testoutput,'getcomm');\r
end;\r
(*ENDTEST#*)\r
if eof(comm) or (commkey=endcomm) then begin\r
commkey:=endcomm;\r
commsource:=255;\r
commline:=32767;\r
read_commands:=false;\r
prelude:=false;\r
end else\r
begin\r
commkey := get_comm;\r
commsource := get_comm;\r
commline := get_comm;\r
commline := get_comm * 256 + commline;\r
commop := get_comm;\r
\r
if read_commands then read_commands:= ((commkey<>listcomm) or (commop<>4))\r
and (commkey<>sourcecomm);\r
end;\r
end; (* getcomm *)\r
\r
begin\r
(*#BEGINTEST\r
if testlist>1 then\r
begin\r
writeln(testoutput,'command');\r
end;\r
(*ENDTEST#*)\r
\r
if commsource<>1 then\r
case commkey of\r
titlecomm: begin\r
headtxt := '';\r
for i:=1 to commop do\r
begin\r
headtxt := headtxt + chr(get_comm);\r
end;\r
end;\r
\r
pagewidthcomm: begin pwidth:=commop; if pwidth<75 then pwidth:=75; end;\r
\r
pagelengthcomm: begin plength:=commop; if plength<30 then plength:=30; end;\r
\r
indentcomm: myind:=commop=2;\r
\r
markcomm: markmode:=commop=1;\r
\r
conditioncomm:\r
if commop<>1 then\r
begin\r
conditionstate:=blank;\r
if next_conditionstate = '-' then bracket_niv := on_bracket_niv;\r
next_conditionstate:=blank;\r
if top_bound>0 then\r
begin\r
top:=top_bound-1;\r
top_bound:=0;\r
margin:=cond_margin;\r
end;\r
end else begin\r
on_bracket_niv := bracket_niv;\r
next_conditionstate:='-';\r
if top>=ssize then top:=ssize-1;\r
top_bound:=top+1;\r
for i:=0 to top do\r
begin\r
if top<ssize then\r
begin\r
top:=top+1;\r
stack[top]:=stack[i];\r
end;\r
end;\r
cond_margin:=margin;\r
end;\r
\r
keycomm: reskeymode:=commop;\r
\r
idcomm: idmode:=commop;\r
\r
eject: if printmode then formfeed:=true;\r
\r
endcomm: begin\r
sourceno:=255; (* only skip of commands, no source opened *)\r
read_commands:=false; end_of_file:=true; end;\r
\r
subtitlecomm: begin\r
subheadl:=commop;\r
subheadtxt :='';\r
for i:=1 to subheadl do begin\r
subheadtxt := subheadtxt + chr(get_comm);\r
end;\r
if not prelude then pline:=maxlines;\r
end;\r
\r
sourcecomm: begin\r
pline:=maxlines; pageno:=0; prelude:=true; listx:=1;\r
end_of_file:=true;\r
conditionstate:=blank;\r
next_conditionstate:=blank;\r
if top_bound>0 then begin\r
top:=top_bound-1;\r
top_bound:=0;\r
margin:=cond_margin;\r
end;\r
headtxt := '';\r
subheadl:=0;\r
if sourceno<commsource then sourceno:=commsource;\r
end;\r
\r
programcomm: begin\r
prelude:=false;\r
if sourceno<= no_of_files then\r
begin\r
(* sourceno := sourceno+1;*)\r
lineno:=1;\r
open_source(sourceno);\r
while chr(next_byte)=ff do i:=get_byte;\r
eol:=false;\r
if listx<>1 then begin\r
preludeline[listx]:=commline; preludeop[listx]:=0; listx:=1;\r
prelude2:=true;\r
end;\r
end;\r
end;\r
\r
listcomm:\r
if prelude then begin\r
preludeline[listx]:=commline; preludeop[listx]:=commop; listx:=listx+1;\r
end else if listmode then \r
begin\r
next_printmode:=commop=4;\r
if next_printmode then printmode:=true else read_commands:=true;\r
end;\r
end;\r
\r
if prelude2 then begin\r
if preludeop[listx]<>0 then begin\r
commkey:=listcomm; commop:=preludeop[listx];\r
commline:=preludeline[listx];\r
listx:=listx+1;\r
end else begin\r
prelude2:=false;\r
getcomm;\r
end;\r
end (* prelude2 *)\r
else getcomm;\r
end; (*** command ***)\r
\r
procedure primcomm;\r
var pos,i,j: integer;\r
e: word;\r
(*#BEGINTEST\r
a:string[12];\r
(*ENDTEST#*)\r
begin\r
\r
(*#BEGINTEST\r
if testlist>1 then\r
begin\r
a:='primcomm ';\r
writeln(testoutput,a);\r
end;\r
(*ENDTEST#*)\r
shift_the_source;\r
while prelude do command;\r
end; (* primcomm *)\r
\r
\r
\r
FUNCTION resword(length:integer;name:string):integer;\r
VAR\r
i:integer;\r
res:integer;\r
BEGIN\r
res:=0;\r
IF length <= toplength THEN\r
BEGIN\r
i:=keynum[length];\r
length:=keynum[length+1];\r
REPEAT\r
IF keyword[i]=name THEN res:=i;\r
i:=i+1;\r
UNTIL(i>=length) OR (res<>0);\r
END;\r
resword:=res;\r
END;\r
\r
\r
PROCEDURE initialize;\r
CONST\r
length2 = 55;\r
VAR\r
i:integer;\r
\r
k_ix,\r
index:integer;\r
(*#BEGINTEST\r
a:string[12];\r
(*ENDTEST#*)\r
\r
\r
\r
procedure init_p_table(a:string;length,a1,a2,a3,no:integer);\r
begin\r
with table[index] do\r
begin\r
p1:=a1;\r
p2:=a2;\r
spacing:=a3;\r
end;\r
length:=resword(length,a);\r
if (length=0) or (index<>no) then\r
begin\r
error('err table ');\r
internalerror := true;;\r
end\r
else\r
BEGIN\r
table_index[length]:=index;\r
index:=index+1;\r
END;\r
end;\r
\r
procedure init_p_key( a:string);\r
var\r
curr_keylgth: integer;\r
ch: char;\r
begin\r
keyword[index]:=a;\r
index:=index+1;\r
\r
(** Now "pascalkeys(index)" is initiated ! **)\r
(* In the following it is found out whther "keynum"\r
is to be updated or not. *)\r
\r
(** Find length of "a" **)\r
curr_keylgth := 1; ch :=a[1];\r
while (ord(ch) <> space) and (curr_keylgth < alfalength) do\r
begin\r
curr_keylgth := curr_keylgth + 1;\r
ch := a [ curr_keylgth ];\r
end;\r
if ord(ch) = space then\r
curr_keylgth := curr_keylgth - 1;\r
\r
(** Adjust evt. array "keynum" - holding pointers to "pascalkeys"\r
telling where in table keys of a certain length is starting *)\r
\r
if curr_keylgth <= keynumsize then\r
begin\r
if curr_keylgth > k_ix then\r
begin\r
while k_ix < curr_keylgth do\r
begin\r
k_ix := k_ix + 1;\r
keynum [ k_ix ] := index-1;\r
end;\r
\r
end else if curr_keylgth=0 then keynum[k_ix+1]:=index-1;\r
end\r
else\r
BEGIN\r
error('err keysize ');\r
internalerror := true;\r
end;\r
end;\r
\r
procedure add_pos(add_p:integer);\r
begin\r
if pos+add_p>=pwidth then begin\r
pline:=pline+1;\r
writeln(listfile);\r
write(listfile,' ':11);\r
pos:=11+add_p;\r
end\r
else pos:=pos+add_p;\r
end;\r
\r
procedure write_option(a: string);\r
begin\r
add_pos(11);\r
write(listfile,a:10,' ');\r
end;\r
\r
BEGIN\r
\r
if testlist>=256 then\r
begin\r
if odd(testlist div 1024) then testvmm:=original_testvmm;\r
if odd(testlist div 256) then teststh:=true;\r
testlist:=testlist mod 256;\r
end;\r
(*#BEGINTEST\r
if testlist>0 then\r
begin\r
a:='initialize ';\r
writeln(testoutput,a);\r
end;\r
(*ENDTEST#*)\r
lf := chr(10);\r
ff := chr(12);\r
cr := chr(13);\r
tab:= chr(9);\r
eol := false;\r
\r
(** default options **)\r
myind := false;\r
listmode := false;\r
printmode := false;\r
next_printmode := false;\r
read_commands := false;\r
markmode := true;\r
conditionstate := blank;\r
next_conditionstate := blank;\r
plength := defaultpagelength;\r
pwidth := defaultpagewidth;\r
paging := 1;\r
prelude2 := false;\r
formfeed := false;\r
subheadl := 0;\r
sourceno := 1; (* skip rtp86std.env *)\r
reskeymode := 3;\r
idmode := 2;\r
commkey := sourcecomm;\r
commsource := 0;\r
\r
with call_options do\r
begin\r
if pagewidth<>0 then begin\r
pwidth:=pagewidth; if pwidth<75 then pwidth:=75; end;\r
if pagelength<>0 then begin\r
plength:=pagelength; if plength<30 then plength:=30; end;\r
end;\r
\r
pline:=plength div 2 - 6;\r
for i:=1 to pline do begin writeln(listfile); end;\r
\r
write(listfile,' Real Time Pascal-86, ',versionsid,' ');\r
pos:=65;\r
\r
getftime(comm,packedtime); (* FUSK *)\r
makeprintabletime(packedtime,timestring);\r
write(listfile,timestring);\r
\r
add_pos(pwidth); (* newline *)\r
for i:=sourceno+1 to no_of_files do\r
with callparams[i] do\r
begin\r
add_pos(length(filename)+2);\r
write(listfile,filename);\r
if i<>no_of_files then write(listfile,', ');\r
end;\r
with call_options do\r
begin\r
if (loadcode=1) or savecode then add_pos(pwidth); (* newline *)\r
if (loadcode=1) then\r
begin\r
add_pos(7+length(loadstr));\r
write(listfile,'LOAD(');\r
if length(loadstr)>0 then write(listfile,loadstr);\r
write(listfile,') ');\r
end;\r
if savecode then\r
begin\r
add_pos(6+length(savestr));\r
write(listfile,'SAVE(');\r
if length(savestr)>0 then write(listfile,savestr);\r
write(listfile,')');\r
end;\r
add_pos(pwidth); (* newline *)\r
\r
case computer of\r
partner: begin\r
add_pos(16);\r
write(listfile,'TARGET(PARTNER) ');\r
end;\r
RC5000: begin\r
add_pos(15);\r
write(listfile,'TARGET(RC5000) ');\r
end;\r
RC3502: begin\r
add_pos(15);\r
write(listfile,'TARGET(RC3502) ');\r
end;\r
(* otherwise; TURBO *)\r
else\r
begin\r
add_pos(14);\r
write(listfile,'COMPUTER(PI3) ');\r
end;\r
end;\r
if optimize>0 then\r
begin\r
add_pos(16);\r
write(listfile,'OPTIMIZE(',optimize,') ');\r
end;\r
if code then write_option('CODE ') else write_option('NOCODE ');\r
if indexcheck then write_option('INDEX ')\r
else write_option('NOINDEX ');\r
if rangecheck then write_option('RANGE ')\r
else write_option('NORANGE ');\r
if accesscheck then write_option('ACCESS ')\r
else write_option('NOACCESS ');\r
if overflowcheck then write_option('OVERFLOW ')\r
else write_option('NOOVERFLOW');\r
if optionbreakpoint then write_option('BREAK ');\r
if iflist then write_option('IFLIST ')\r
else if listing=2 then write_option('LIST ')\r
else write_option('NOLIST ');\r
if listing=2 then begin\r
case indent of\r
1: write_option('IND ');\r
2: write_option('NOIND ');\r
(* otherwise; TURBO *)\r
end;\r
case mark of\r
1: write_option('MARK ');\r
2: write_option('NOMARK ');\r
(* otherwise; TURBO *)\r
end;\r
case keyword of\r
1: write_option('OWNKEY ');\r
2: write_option('LCKEY ');\r
3: write_option('UCKEY ');\r
(* otherwise; TURBO *)\r
end;\r
case ident of\r
1: write_option('OWNID ');\r
2: write_option('LCID ');\r
3: write_option('UCID ');\r
(* otherwise; TURBO *)\r
end;\r
if xref=1 then write_option('NOXREF ') else\r
write_option('XREF ');\r
end;\r
if pagewidth<>0 then\r
begin\r
add_pos(17);\r
write(listfile,'PAGEWIDTH(',pagewidth,') ');\r
end;\r
if pagelength<>0 then\r
begin\r
add_pos(18);\r
write(listfile,'PAGELENGTH(',pagelength,') ');\r
end;\r
if createsize<>0 then\r
begin\r
add_pos(18);\r
write(listfile,'CREATESIZE(',createsize,') ');\r
end;\r
if (pagesize3502<>0) AND (Computer = RC3502) then\r
begin\r
add_pos(16);\r
write(listfile,'CODESIZE(',pagesize3502,') ');\r
end;\r
add_pos(pwidth); (* newline *)\r
switchpoint:=switchcall;\r
while switchpoint<>nil do\r
with switchpoint^ do\r
begin\r
if name <> 'TARGET' THEN\r
BEGIN\r
add_pos(12+length(name));\r
write(listfile,'SET(');\r
if length(name)>0 then write(listfile,name);\r
write(listfile,'=',switchpoint^.call_value,') ');\r
END;\r
switchpoint:=switchpoint^.next;\r
end;\r
\r
add_pos(15);\r
write(listfile,'SPAGERES(',vmaxresidents,') ');\r
add_pos(15);\r
write(listfile,'NPAGERES(',nmaxresidents,') ');\r
\r
add_pos(pwidth); (* newline *)\r
writeln(listfile); pline:=pline+1;\r
end;\r
\r
\r
\r
\r
\r
if call_options.listing=2 then\r
begin\r
command; (* skip dummy command; not read from file *)\r
command; (* sourcecomm *)\r
primcomm;\r
\r
\r
for i:=0 to 127 do alfanum[chr(i)]:=0;\r
alfanum['_']:=1;\r
for i:=ord('0') to ord('9') do alfanum[chr(i)]:=2;\r
for i:=ord('A') to ord('Z') do alfanum[chr(i)]:=3;\r
for i:=ord('a') to ord('z') do alfanum[chr(i)]:=3;\r
alfanum['B']:=4;\r
alfanum['C']:=4;\r
alfanum['D']:=4;\r
alfanum['E']:=4;\r
alfanum['F']:=4;\r
alfanum['I']:=4;\r
alfanum['L']:=4;\r
alfanum['O']:=4;\r
alfanum['P']:=4;\r
alfanum['R']:=4;\r
alfanum['S']:=4;\r
alfanum['T']:=4;\r
alfanum['U']:=4;\r
alfanum['V']:=4;\r
alfanum['W']:=4;\r
(** The above set has to be updated in correspondence with\r
contents of "PASCALTABLE". The set contains all destinct\r
first-letters of keywords in "TABLE". **)\r
\r
\r
\r
linepos := 0;\r
markpointer := 0;\r
\r
top := 1;\r
top_bound:=0;\r
\r
\r
(** Searching in the following table is done by 'binary search'\r
on the length of the keywords. Because of that the table\r
"keynum" is present and the keywords has to be put into the table\r
in increasing length **)\r
\r
for k_ix := 1 to keynumsize do\r
keynum [ k_ix ] := length2;\r
k_ix := 1;\r
index := 1;\r
keynum [ k_ix ] := index;\r
(**)\r
init_p_key('IF ');\r
init_p_key('DO ');\r
init_p_key('OF ');\r
init_p_key('TO ');\r
init_p_key('IN ');\r
init_p_key('AS ');\r
init_p_key('OR ');\r
init_p_key('END ');\r
init_p_key('FOR ');\r
init_p_key('VAR ');\r
init_p_key('DIV ');\r
init_p_key('MOD ');\r
init_p_key('SET ');\r
init_p_key('AND ');\r
init_p_key('NOT ');\r
init_p_key('XOR ');\r
init_p_key('THEN ');\r
init_p_key('ELSE ');\r
init_p_key('WITH ');\r
init_p_key('GOTO ');\r
init_p_key('CASE ');\r
init_p_key('LOCK ');\r
init_p_key('TYPE ');\r
init_p_key('LOOP ');\r
init_p_key('EXIT ');\r
init_p_key('BEGIN ');\r
init_p_key('UNTIL ');\r
init_p_key('WHILE ');\r
init_p_key('ARRAY ');\r
init_p_key('CONST ');\r
init_p_key('SHIFT ');\r
init_p_key('REPEAT ');\r
init_p_key('RECORD ');\r
init_p_key('DOWNTO ');\r
init_p_key('PACKED ');\r
init_p_key('REGION ');\r
init_p_key('SHARED ');\r
init_p_key('ENDLOOP ');\r
init_p_key('INSPECT ');\r
init_p_key('FORWARD ');\r
init_p_key('LOCKBUF ');\r
init_p_key('PROGRAM ');\r
init_p_key('FUNCTION ');\r
init_p_key('EXITLOOP ');\r
init_p_key('LOCKDATA ');\r
init_p_key('EXTERNAL ');\r
init_p_key('PROCEDURE ');\r
init_p_key('OTHERWISE ');\r
init_p_key('PACKED3502 ');\r
init_p_key('OPENROUTINE ');\r
init_p_key('CONTINUELOOP');\r
init_p_key(' ');\r
IF not internalerror then\r
BEGIN\r
for i:=1 to index-1 do table_index[i]:=0;\r
\r
index := 1;\r
init_p_table('BEGIN ',5,4,4,2,res_begin);\r
init_p_table('CASE ',4,0,4,2,res_case);\r
init_p_table('DO ',2,0,0,0,res_do);\r
init_p_table('ELSE ',4,7,5,2,res_else);\r
init_p_table('END ',3,5,0,0,res_end);\r
init_p_table('ENDLOOP ',7,5,0,0,res_endloop);\r
init_p_table('FUNCTION ',8,0,2,2,res_function);\r
init_p_table('LOOP ',4,0,4,2,res_loop);\r
init_p_table('OTHERWISE ',9,0,5,2,res_otherwise);\r
init_p_table('PROCEDURE ',9,0,2,2,res_procedure);\r
init_p_table('PROGRAM ',7,3,2,2,res_program);\r
init_p_table('RECORD ',6,0,2,2,res_record);\r
init_p_table('REPEAT ',6,0,4,2,res_repeat);\r
init_p_table('SHARED ',6,3,2,2,res_shared);\r
init_p_table('TYPE ',4,3,2,2,res_type);\r
init_p_table('UNTIL ',5,5,0,0,res_until);\r
init_p_table('VAR ',3,3,2,2,res_var);\r
init_p_table('WITH ',4,0,5,2,res_with);\r
init_p_table('CONST ',5,3,2,2,res_const);\r
init_p_table('LOCK ',4,0,5,2,res_lock);\r
init_p_table('LOCKDATA ',8,0,5,2,res_lockdata);\r
init_p_table('LOCKBUF ',7,0,5,2,res_lockbuf);\r
init_p_table('EXTERNAL ',8,4,0,0,index);\r
init_p_table('FOR ',3,0,5,2,index);\r
init_p_table('FORWARD ',7,4,0,0,index);\r
init_p_table('IF ',2,0,if_priority,2,index);\r
init_p_table('OPENROUTINE ',11,4,0,0,index);\r
init_p_table('REGION ',6,0,5,2,index);\r
init_p_table('THEN ',4,7,if_priority,2,index);\r
init_p_table('WHILE ',5,0,5,2,index);\r
END; (* not internalerror *)\r
\r
if not internalerror then\r
BEGIN\r
tsize:=index-1;\r
\r
(*** TESTOUTPUT ***)\r
(**for i:=1 to keynumsize do\r
begin\r
write(listfile,'k_ix',i:3);\r
write(listfile,'contents:',keynum[i]:3);\r
writeln(listfile);\r
end;**)\r
\r
\r
margin:=3;\r
FOR i:=1 TO lsize DO line[i]:=blank;\r
stack[0].prior:=10; (* bottom never unstack *)\r
stack[0].indent:=0;\r
stack[1].indent:=2;\r
stack[1].prior:=2;\r
line[ 0 ] := ' '; (* anything <> from *, used in skip *)\r
state := declare;\r
bracket_niv:= 0;\r
norecord:=0;\r
inwith:=false;\r
END; (* not internalerror *)\r
end;\r
END; (** initialize **)\r
\r
procedure writepage;\r
var i:integer;\r
begin\r
write(listfile,#12);\r
(*page(listfile); TURBO *)\r
pageno:=pageno+1;\r
writeln(listfile,headtxt:pwidth-headnamelength-9,blank,\r
headname:headnamelength,' Page ',pageno);\r
if subheadl<>0 then begin\r
writeln(listfile,subheadtxt:subheadl);\r
end else writeln(listfile);\r
pline:=3;\r
writeln(listfile);\r
end;\r
\r
PROCEDURE writeeol;\r
BEGIN\r
IF formfeed THEN\r
BEGIN\r
pline:=maxlines; formfeed := false;\r
END;\r
writeln(listfile);\r
linepos:=0\r
END;\r
\r
\r
\r
PROCEDURE pushmark(pos:integer);\r
BEGIN\r
if conditionstate<>'-' then\r
begin\r
IF markpointer<lsize THEN\r
markpointer:=markpointer+1;\r
markstack[markpointer]:=pos;\r
end;\r
END;\r
\r
\r
\r
PROCEDURE popmark;\r
BEGIN\r
if conditionstate<>'-' then\r
begin\r
markstack[markpointer]:=0;\r
IF markpointer>0 THEN\r
markpointer:=markpointer-1;\r
end;\r
END;\r
\r
\r
procedure prepare_printline;\r
var i:integer;\r
a:string[12];\r
begin\r
(*#BEGINTEST\r
if testlist>2 then\r
begin\r
a:='prepare_prin';\r
writeln(testoutput,a);\r
end;\r
(*ENDTEST#*)\r
\r
fresh:=false;\r
print_margin:=margin;\r
if print_margin > (pwidth - 20) then Print_margin := pwidth - 20;\r
for i:=1 to markpointer do\r
cmarkstack[i]:=markstack[i];\r
cmarkstack[markpointer+1]:=0;\r
end;\r
\r
PROCEDURE printline; FORWARD;\r
PROCEDURE semicolon; FORWARD;\r
\r
PROCEDURE skip(skipend:char); FORWARD;\r
\r
\r
\r
PROCEDURE changeletters(lowercase:boolean;pos:integer);\r
VAR\r
i,add:integer;\r
ch,a,z:char;\r
BEGIN\r
IF lowercase THEN\r
BEGIN\r
add:=32;\r
a:='A';\r
z:='Z';\r
END\r
ELSE\r
BEGIN\r
add:=-32;\r
a:='a';\r
z:='z';\r
END;\r
i:=pos;\r
REPEAT\r
ch:=line[i];\r
IF (ch>=a) AND (ch<=z) THEN line[i]:=chr(ord(ch)+add);\r
i:=i-1;\r
UNTIL (alfanum[ch] = 0) OR (i=0);\r
END;\r
\r
\r
\r
\r
PROCEDURE pushindent(prioritet,indention:integer);\r
(*STACK ONE LEVEL OF INDENTION *)\r
BEGIN\r
if top<ssize then top:=top+1;\r
WITH stack[top] DO\r
BEGIN\r
prior:=prioritet;\r
indent:=indention-oldpos;\r
oldpos:=pos;\r
margin:=margin+indent;\r
END;\r
END;\r
\r
\r
PROCEDURE popindent;\r
(*REMOVE ONE LEVEL OF INDENTION FROM STACK*)\r
BEGIN\r
with stack[top] do begin\r
margin:=margin-indent;\r
IF oldpos>0 THEN oldpos:=oldpos-indent;\r
end;\r
IF top>top_bound THEN top:=top-1;\r
END;\r
\r
\r
PROCEDURE pasidentifier;\r
(* CHECKS IF IDENTIFIER IS A KEYWORD WITH EFFECT\r
ON INDENTION. IF SO, INDENTION IS ADJUSTED*)\r
(* AS ONLY ONE KEYWORD MAY AFFECT INDENTION -\r
CURRENT MARGIN CAN BE PRINTED OUT AS SOON AS THE\r
FIRST KEYWORD WITH EFFECT ON INDENTION IS FOUND. *)\r
VAR key:string[12];\r
k,try:integer;\r
a:string[12];\r
\r
BEGIN\r
(*#BEGINTEST\r
if testlist>2 then\r
begin\r
a:='pasidentifie';\r
writeln(testoutput,a);\r
end;\r
(*ENDTEST#*)\r
key := '';\r
IF alfanum[current] >= 3\r
THEN k:=1 ELSE k:=toplength + 1;\r
REPEAT\r
IF k <= toplength THEN\r
key := key + current;\r
k := k + 1;\r
pos:=pos+1; current:=line[pos];\r
IF (current>='a') AND (current<='z') THEN current:=chr(ord(current)-32);\r
UNTIL (alfanum[current] = 0) ;\r
k:=k-1;\r
IF (k <= toplength) AND (k > 1) THEN\r
BEGIN (* MIGHT BE INTERESTING KEYWORD*)\r
FOR try := k+1 TO 12 DO key:= key + blank;\r
try:=resword( k, key );\r
end else try:=0;\r
IF try<>0 THEN\r
BEGIN\r
if reskeymode<>ord(ownkeyw_) then\r
changeletters(reskeymode=ord(lckeyw_),pos-1);\r
try:=table_index[try];\r
if (try<>0) and (state <> formal_parameters) THEN\r
with table[try] do\r
BEGIN (* KEYWORD AFFECTING MARGIN IS FOUND *)\r
case try of\r
res_until, res_otherwise, res_endloop: semicolon;\r
res_end: if state<>formal_parameters then semicolon;\r
res_do: inwith:=false;\r
res_type, res_const:\r
begin\r
state:=declare;\r
bracket_niv:=0;\r
end;\r
res_var, res_shared:\r
begin\r
if state<>formal_parameters then\r
begin\r
state:=declare;\r
bracket_niv:=0;\r
end;\r
end;\r
res_program, res_procedure, res_function:\r
begin\r
state:=formal_parameters;\r
bracket_niv:=0;\r
end;\r
res_begin: begin\r
state:=statement;\r
bracket_niv:=0;\r
end;\r
(* otherwise; TURBO *)\r
end;\r
\r
\r
(* SEE IF UNSTACKING*)\r
with stack[top] do\r
IF prior<p1 THEN\r
BEGIN\r
if try=res_else then\r
(* unstack until IF is on the top, the IF element is poped by the\r
normal pop action *)\r
begin\r
while stack[top].prior = 5 do popindent;\r
(* remove indention from while, for, with, .. *)\r
if stack[top].prior <> if_priority then (* error in IF - ELSE structure *)\r
begin\r
pushindent( if_priority, pos-4 (* length of ELSE *) ); (* dummy IF *)\r
end;\r
end (* else handling *)\r
else\r
IF (try=res_end) AND (norecord>0) THEN\r
BEGIN (*SPECIAL HANDLING OF RECORD *)\r
margin:=margin-2;\r
IF fresh THEN prepare_printline;\r
margin:=margin+2;\r
IF oldpos>0 THEN oldpos:=oldpos-indent;\r
norecord:=norecord-1;\r
END;\r
margin:=margin-indent;\r
if top>top_bound then top:=top-1;\r
END;\r
\r
IF fresh THEN prepare_printline;\r
(** SEE COMMENT IN BEGINNING OF PROCEDURE!! **)\r
\r
(* SEE IF STACKING*)\r
(** IF p2=0 THEN ACTUAL KEYWORD DOES NOT CAUSE\r
FURTHER INDENTION IN THE FOLLOWING LINES **)\r
IF p2>0 THEN\r
begin\r
if top<ssize then top:=top+1;\r
with stack[top] do begin\r
prior:=p2;\r
if (try=res_record) and (state<>formal_parameters) then begin\r
indent:=spacing+pos-7-oldpos;\r
oldpos:=spacing+pos-7;\r
norecord:=norecord+1;\r
end else indent:=spacing;\r
margin:=margin+indent;\r
end;\r
end;\r
\r
case try of\r
res_with, res_lock, res_lockdata, res_lockbuf:\r
begin\r
inwith:=true;\r
oldpos:=spacing;\r
end;\r
res_end: if current='.' then\r
begin\r
printline;\r
WHILE NOT end_of_file DO\r
(** Copy from input to output-file **)\r
IF eol THEN\r
BEGIN\r
writeln(listfile);\r
readln_;\r
END\r
ELSE\r
BEGIN\r
read_(ch);\r
write(listfile,ch);\r
END;\r
printmode:= false;\r
\r
end;\r
(* otherwise TURBO *)\r
end;\r
\r
IF markmode THEN\r
begin\r
case try of\r
res_begin, res_repeat, res_loop, res_case, res_record:\r
begin\r
pushmark(margin+1-spacing);\r
end;\r
res_end, res_until, res_endloop: popmark;\r
(*otherwise TURBO *)\r
end;\r
end;\r
END; (* taking care of interesting keywords *)\r
END (* if resword ... *)\r
else if idmode<>ord(ownid_) then\r
changeletters(idmode=ord(lcid_),pos-1);\r
\r
END (* IDENTIFIER*);\r
\r
\r
PROCEDURE semicolon;\r
(* UNSTACK UNTIL STACKTOP DOES NOT CONTAIN IF OR ELSE*)\r
BEGIN\r
WHILE (stack[top].prior=5) or (stack[top].prior=if_priority) DO\r
BEGIN\r
margin:=margin-stack[top].indent;\r
if top>top_bound then top:=top-1;\r
END\r
END (* SEMICOLON*);\r
\r
\r
PROCEDURE printline;\r
VAR pos,mpos:integer;\r
a:string[12];\r
BEGIN\r
(*#BEGINTEST\r
if testlist>2 then\r
begin\r
a:='printline ';\r
writeln(testoutput,a);\r
end;\r
(*ENDTEST#*)\r
if fresh then prepare_printline;\r
pos:=0;\r
if printmode then begin\r
write(listfile,lineno:5,':',conditionstate,conditionstate);\r
repeat\r
printtop:=pwidth+pos-9;\r
IF (noind_=false) THEN write(listfile,blank);\r
if (noind_ <> true) then\r
if not (lastpos = 0) or markmode then\r
(*IF NOT ((lastpos=0) OR noind_) OR markmode THEN*)\r
(*AN EMPTY LINE IS NOT SPACED*)\r
BEGIN nextmark:=1;\r
FOR mpos:=1 TO print_margin DO\r
(** "print_margin" number of blanks are printed out. -\r
Perhabs including a "mark". **)\r
BEGIN\r
IF markmode THEN\r
BEGIN IF mpos=cmarkstack[nextmark] THEN\r
BEGIN write(listfile,'!');\r
nextmark:=nextmark+1;\r
END\r
ELSE\r
write(listfile,blank);\r
END (* markmode *)\r
ELSE write(listfile,blank);\r
END; (* for *)\r
printtop:=pwidth-print_margin+pos-7;\r
END;\r
pline:=pline+paging;\r
if pos=0 then print_margin:=print_margin+2;\r
if lastpos<>0 then begin\r
if lastpos<=printtop then printtop:=lastpos;\r
repeat pos:=pos+1; write(listfile,line[pos]);\r
until pos=printtop;\r
if pos<lastpos then begin\r
writeln(listfile);\r
if pline>=plength then writepage;\r
write(listfile,' ':8);\r
end;\r
end;\r
until pos=lastpos;\r
print_margin:=print_margin-2;\r
writeeol;\r
end;\r
lineno:=lineno+1;\r
printmode:=next_printmode;\r
conditionstate:=next_conditionstate;\r
end; (*PRINTLINE*)\r
\r
\r
PROCEDURE readline;\r
VAR pos,i,j:integer; conn,e: word;\r
dummy:char;\r
a:string[12];\r
BEGIN\r
(*#BEGINTEST\r
if testlist>2 then\r
begin\r
a:='readline ';\r
writeln(testoutput,a);\r
end;\r
(*ENDTEST#*)\r
\r
while (lineno>=commline) and (sourceno=commsource) do command;\r
\r
if pline>=plength then begin\r
if printmode then writepage;\r
end; (* pline>=plength *)\r
\r
pos:=0; lastpos:=0; oldpos:=0; fresh:=true; (* LINE IS READ, NOT PRINTED*)\r
ch := blank;\r
IF myind=false THEN\r
(* Preceeding blanks and tabs in line are skipped - if wanted. *)\r
while ((ch=blank) or (ch=tab)) and (not eol) DO read_(ch);\r
WHILE NOT eol DO\r
BEGIN\r
IF pos<lsize-2 THEN pos:=pos+1;\r
line[pos]:=ch;\r
IF ch<>blank THEN lastpos:=pos;\r
read_(ch)\r
END;\r
(* Now "lastpos" points at last character <> blank in the line *)\r
\r
\r
\r
IF ch<>blank THEN\r
BEGIN lastpos:=pos+1;\r
line[lastpos]:=ch;\r
END;\r
\r
line[lastpos+1]:=blank;\r
IF NOT end_of_file THEN eol:= false;\r
END (* READLINE*);\r
\r
PROCEDURE skip;\r
LABEL 11; (* exit in case of eof *)\r
BEGIN\r
IF fresh THEN prepare_printline;\r
\r
REPEAT\r
IF pos>=lastpos THEN\r
IF end_of_file THEN\r
BEGIN\r
GOTO 11;\r
END\r
ELSE\r
BEGIN \r
printline;\r
readline;\r
prepare_printline;\r
pos:=0;\r
END;\r
pos:=pos+1; current:=line[pos];\r
UNTIL current=skipend;\r
IF skipend = ':' THEN\r
BEGIN\r
pos := pos + 1; current := line[pos];\r
END;\r
11:\r
END;\r
\r
\r
\r
procedure geterr;\r
(*#BEGINTEST\r
var a:string[12];\r
(*ENDTEST#*)\r
begin\r
(*#BEGINTEST\r
if testlist>1 then\r
begin\r
a:='geterr ';\r
writeln(testoutput,a);\r
end;\r
(*ENDTEST#*)\r
if eof(errorfile) then acterrorrec :=stop else begin\r
read(errorfile,acterrorrec); curseqno:=curseqno+1;\r
end;\r
(*if eof(errorfile) then acterrorrec :=stop;*)\r
end;\r
\r
procedure fill(p: passnotype);\r
var i: passnotype;\r
(*#BEGINTEST\r
a:string[12];\r
(*ENDTEST#*)\r
begin\r
(*#BEGINTEST\r
if testlist>1 then\r
begin\r
a:='fill ';\r
writeln(testoutput,a);\r
end;\r
(*ENDTEST#*)\r
if curseqno>seqno[p] then begin\r
reset(errorfile); geterr; curseqno:=1; i:=pass1;\r
(*if eof(errorfile) then acterrorrec :=stop; !!!! hha*)\r
end else\r
begin\r
i:=acterrorrec.pass;\r
if i>p then i:=p;\r
end;\r
for i:=i to p do begin\r
while curseqno<seqno[i] do geterr;\r
while acterrorrec.pass<i do geterr;\r
while filled[i]<recs do begin\r
if acterrorrec.pass>i then begin\r
err[i,empty[i]]:=stop; filled[i]:=recs;\r
end else begin\r
err[i,empty[i]]:=acterrorrec;\r
filled[i]:=filled[i]+1;\r
geterr;\r
end;\r
if empty[i]=recs then empty[i]:=1\r
else empty[i]:=empty[i]+1;\r
end; (* while filled *)\r
seqno[i]:=curseqno;\r
end; (* for i *)\r
end; (* fill *)\r
\r
procedure write_hex(v,p:word);\r
var i:integer;\r
help,temp: word;\r
begin\r
if v=maxword then write(listfile,' ':p) else\r
begin\r
if p>5 then write(listfile,' ':p-5);\r
help:=4096;\r
for i:=1 to 4 do\r
begin\r
temp:=v div help;\r
v:=v mod help;\r
help:=help div 16;\r
if temp<10 then write(listfile,temp) else\r
write(listfile,chr(ord('A')+temp-10));\r
end;\r
write(listfile,'h');\r
end;\r
end;\r
\r
\r
procedure infolisting; FORWARD;\r
procedure errorlisting;\r
var p,i: passnotype; d,e: integer;\r
no_space:integer;\r
stop_error:boolean;\r
(*#BEGINTEST\r
a:string[12];\r
(*ENDTEST#*)\r
spixnameptr:ptr_string;\r
no_warnings, no_errors, no_fatals: integer;\r
old_pline, old_pageno:integer;\r
begin\r
(*#BEGINTEST\r
if testlist>0 then \r
begin\r
a:='errorlisting';\r
writeln(testoutput,a);\r
end;\r
(*ENDTEST#*)\r
\r
subheadl:=0;\r
headtxt := errhead;\r
\r
(** default options **)\r
no_warnings:=0;\r
no_errors:=0;\r
no_fatals:=0;\r
sourceno := 0;\r
\r
old_pline:=pline; (* save pline if no error *)\r
old_pageno:=pageno;\r
pline:=maxlines;\r
pageno:=0;\r
\r
headname :=' ';\r
headnamelength:=1;\r
\r
stop.pass:=pass4;\r
stop.source:=maxcallparams;\r
stop.line:=32767;\r
stop.element:=32767;\r
\r
curseqno:=maxword;\r
for p:=pass1 to pass4 do begin\r
seqno[p]:=1; empty[p]:=1; full[p]:=1; filled[p]:=0;\r
end;\r
\r
p:=pass4;\r
stop_error:=false;\r
repeat\r
if filled[p]=0 then fill(p);\r
\r
(* find next error to be listed *)\r
p:=pass1;\r
for i:=pass2 to pass4 do begin\r
d:=ord(err[i,full[i]].source) - ord(err[p,full[p]].source);\r
if d=0 then begin\r
d:=ord(err[i,full[i]].line) - ord(err[p,full[p]].line);\r
if d=0 then\r
d:=ord(err[i,full[i]].element) - ord(err[p,full[p]].element);\r
end;\r
if d<0 then p:=i;\r
end; (* for i *)\r
if err[p,full[p]].element < 32767 then with err[p,full[p]] do begin\r
(* more errors to be listed *)\r
if source > sourceno then \r
begin\r
if source>no_of_files then source:=no_of_files;\r
if source > sourceno then sourceno:=source;\r
pline:= plength; (* new page *)\r
shift_the_source;\r
end;\r
if pline+1>=plength then writepage;\r
case kind of\r
1: begin write(listfile,'***WARNING from: '); no_space:=3;\r
no_warnings:=no_warnings+1; end;\r
2: begin write(listfile,'***ERROR from: '); no_space:=5;\r
no_errors:=no_errors+1; end;\r
(*otherwise*) else begin write(listfile,'***FATAL ERROR from:'); no_space:=0;\r
no_fatals:=no_fatals+1;\r
end;\r
end;\r
case module_ of\r
mpa: write(listfile,'MPA',' ':13+no_space);\r
pass0: write(listfile,'PARSE',' ':11+no_space);\r
pass1: write(listfile,'PARSE',' ':11+no_space);\r
pass2: write(listfile,'ANALYSE',' ':9+no_space);\r
pass3: write(listfile,'ALLOCATE',' ':8+no_space);\r
pass4: write(listfile,'OBJECT',' ':10+no_space);\r
sth: write(listfile,'SYMBOL TABLE',' ':4+no_space);\r
listh: write(listfile,'LIST',' ':12+no_space);\r
vmm: write(listfile,'VIRTUAL MEMORY ':16+no_space);\r
systemq: write(listfile,' COMPILER',' ':7+no_space);\r
exceptq: write(listfile,'EXCEPTION',' ':7+no_space);\r
(*otherwise*) else write(listfile,' ':16+no_space);\r
end;\r
(*\r
if (sourceno>0) and (sourceno<=maxcallparams) then\r
with callparams[sourceno].filename do\r
begin\r
write(listfile,'in: ',alfa:length,': ');\r
if length<20 then write(listfile,' ':20-length);\r
end else\r
write(listfile,'During initialization. ');\r
*)\r
if line<>0 then write(listfile,'LINE:',line:4,' ') else\r
write(listfile,' ':12);\r
if element<>noelement then write(listfile,'ELEMENT:',element:3,' ')\r
else write(listfile,' ':12);\r
if spixno<>anonymousspix then\r
begin\r
st_nameofspix(spixno,spixnameptr);\r
writeln(listfile,spixnameptr^);\r
end else writeln(listfile);\r
write(listfile,' ':3);\r
if find_errormessage(module_,errorno) then begin\r
pos:=3;\r
while not eoln(errtxts) do begin\r
read(errtxts,ch); \r
if pos<pwidth then begin write(listfile,ch); pos:=pos+1 end;\r
write(listfile);\r
end end else \r
begin \r
write(listfile,'error number: ');\r
write_hex(errorno,5);\r
end;\r
writeln(listfile);\r
pline:=pline+2;\r
if full[p]=recs then full[p]:=1 else full[p]:=full[p]+1;\r
filled[p]:=filled[p]-1;\r
end else stop_error:=true;\r
until stop_error;\r
if no_warnings+no_errors+no_fatals=0 then\r
(* reset pline, no errors detected *)\r
begin\r
pline:=old_pline; pageno:=old_pageno;\r
if stop_module=listh then infolisting;\r
end;\r
\r
if pline+5>=plength then writepage else writeln(listfile);\r
(* write mem info *)\r
writeln(listfile,'HEAP available : ',startmemavail,' bytes');\r
writeln(listfile,'HEAP used for symbol and name table :',\r
startmemavail - (memavail + lengthoffilebuffer),\r
' bytes');\r
writeln(listfile);\r
\r
if no_fatals>0 then writeln(listfile,'COMPILATION ABORTED') else\r
if no_warnings+no_errors>0 then\r
begin\r
if no_errors>0 then begin\r
if no_warnings>0 then writeln(listfile,no_warnings,' WARNINGS.');\r
writeln(listfile,no_errors,' ERRORS DETECTED. COMPILATION STOPPED.');\r
end else writeln(listfile,no_warnings,' WARNINGS. COMPILATION COMPLETED.');\r
end else writeln(listfile,'NO ERRORS DETECTED. COMPILATION COMPLETED');\r
\r
\r
end; (* errorlisting *)\r
\r
(***** ---------- *****)\r
\r
procedure codelisting;\r
var c:char;\r
new_sourceno:byte;\r
new_lineno:integer;\r
i,j:integer;\r
s:string[14];\r
(*#BEGINTEST\r
a:String[12];\r
(*ENDTEST#*)\r
begin\r
(*#BEGINTEST\r
if testlist>0 then\r
begin\r
a:='codelisting ';\r
writeln(testoutput,a);\r
end;\r
(*ENDTEST#*)\r
reset(codelist);\r
pline:=maxlines;\r
pageno:=0;\r
lineno:=-1;\r
new_lineno:=-1;\r
sourceno:=0;\r
new_sourceno:=0;\r
\r
headtxt :=codehead;\r
\r
subheadl:=0;\r
\r
\r
while not eof(codelist) do\r
begin\r
if eoln(codelist) then c:=' ' ELSE\r
read(codelist,c);\r
if c='$' then begin (* option *)\r
read(codelist,c);\r
if c='S' then\r
begin (* maybe new source *)\r
readln(codelist,new_sourceno);\r
if new_sourceno>sourceno then\r
begin\r
sourceno:=new_sourceno;\r
pline:=maxlines;\r
shift_the_source;\r
end;\r
end else\r
begin (* lineno *)\r
readln(codelist,new_lineno);\r
end;\r
end else begin (* copy line *)\r
if pline>=plength then writepage;\r
if new_lineno<>lineno then begin\r
if pline+5>=plength then writepage else\r
begin writeln(listfile); pline:=pline+1; end;\r
write(listfile,' ':14,'; LINE ',new_lineno);\r
if sourceno<>new_sourceno then with callparams[new_sourceno] do\r
begin\r
s :='';\r
i:=length(filename);\r
while (i>0) and (filename[i]<>'/') and\r
(filename[i]<>':') do i:=i-1;\r
for j:=1 to length(filename)-i do s := s + filename[i+j];\r
i:=length(filename)-i;\r
if i>0 then write(listfile,' in ',s:i);\r
end;\r
writeln(listfile);\r
writeln(listfile); pline:=pline+2;\r
lineno:=new_lineno;\r
end;\r
write(listfile,c);\r
pos:=1;\r
while not eoln(codelist) do\r
begin\r
read(codelist,c);\r
if pos<pwidth then begin write(listfile,c); pos:=pos+1; end;\r
end;\r
writeln(listfile); readln(codelist); pline:=pline+1;\r
end;\r
end;\r
end; (* codelisting *)\r
\r
function write_source(sourceno:integer):integer;\r
var i,j:integer;\r
s:string[14];\r
begin\r
with callparams[sourceno] do\r
begin\r
s :='';\r
i:=length(filename);\r
while (i>0) and (filename[i]<>'/') and\r
(filename[i]<>':') do i:=i-1;\r
for j:=1 to length(filename) -i do s := s + filename[i+j];\r
i:=length(filename)-i;\r
if i>0 then write(listfile,s:i);\r
end;\r
write_source:=i;\r
end;\r
\r
procedure crosslisting;\r
var next_symbol, next_line, the_symbol: st_address;\r
cur_ptr: st_elemptr;\r
last_source, adjust, i: integer;\r
name_ptr: ptr_string;\r
ch: char;\r
line_mode: codes;\r
line_no:0..6;\r
(*#BEGINTEST\r
a:string[12];\r
(*ENDTEST#*)\r
\r
begin\r
(*#BEGINTEST\r
if testlist>0 then \r
begin\r
a:='crosslisting';\r
writeln(testoutput,a);\r
end;\r
(*ENDTEST#*)\r
if not equal_addr(last_cross,st_nilladdr) then begin\r
pline:=maxlines;\r
pageno:=0;\r
headtxt :=crosshead;\r
subheadl:=0;\r
headname :=' ';\r
headnamelength:=1;\r
\r
st_cross_init;\r
next_symbol:=last_cross;\r
while not equal_addr(next_symbol,st_nilladdr) do\r
begin\r
if pline+2>=plength then writepage;\r
st_retrieve(next_symbol,cur_ptr);\r
with cur_ptr^ do\r
begin\r
next_line:=st_first_line;\r
next_symbol:=st_next_decl;\r
the_symbol:=st_cross_symbol;\r
st_nameofspix(st_cross_spix,name_ptr);\r
(*with name_ptr^ do *)\r
begin\r
for i:=1 to length(name_ptr^) do\r
begin\r
ch:=name_ptr^[i];\r
if ('A'<=ch) AND (ch<='Z') then ch:=chr(ord(ch)+32);\r
write(listfile,ch);\r
end;\r
pos:=15;\r
if length(name_ptr^)<15 then write(listfile,' ':15-length(name_ptr^))\r
else begin\r
writeln(listfile); pline:=pline+1;\r
write(listfile,' ':15);\r
end;\r
end;\r
end;\r
st_retrieve(next_line,cur_ptr);\r
with cur_ptr^ do\r
begin\r
next_line:=st_next_line;\r
case st_line_mode[1] of\r
ccontext: write(listfile,'CONTEXT ');\r
cprogdecl: write(listfile,'PROGRAM ');\r
cprogram: write(listfile,'PROGRAM ');\r
cfuncdecl: write(listfile,'FUNCTION ');\r
cfunction: write(listfile,'FUNCTION ');\r
cprocdecl: write(listfile,'PROCEDURE ');\r
cprocedure: write(listfile,'PROCEDURE ');\r
cconstdecl: write(listfile,'CONSTANT ');\r
cconstant: write(listfile,'CONSTANT ');\r
cfamilytype: write(listfile,'FAMILY ');\r
ctypedecl: write(listfile,'TYPE ');\r
ctype: write(listfile,'TYPE ');\r
cscalartype: write(listfile,'SCALAR ');\r
cscalarelem: write(listfile,'SCALAR ');\r
crecfield: write(listfile,'FIELD ');\r
cvardecl: write(listfile,'VARIABLE ');\r
cshareddecl: write(listfile,'SHARED ');\r
cforstat: write(listfile,'FOR VARIABLE');\r
clabeldef: write(listfile,'LABEL ');\r
clockvar: write(listfile,'LOCK NAME ');\r
cwithstat,\r
cwithvar: write(listfile,'WITH NAME ');\r
cformalparamlist:write(listfile,'FORMAL PARAM');\r
(*otherwise*) else write(listfile,' ');\r
end;\r
if st_line[1]>0 then\r
write(listfile,' in ')\r
else write(listfile,' ');\r
i:=write_source(st_source[1]);\r
pos:=pos+16+i;\r
last_source:=st_source[1];\r
adjust:=7-pos mod 7; \r
write(listfile,' ':adjust);\r
pos:=pos+adjust;\r
if st_line[1]>0 then\r
begin\r
write(listfile,st_line[1]:6,'*');\r
pos:=pos+7;\r
end;\r
\r
end;\r
line_no:=2;\r
while line_no<=cur_ptr^.st_line_no do\r
begin\r
with cur_ptr^ do\r
begin\r
if last_source<>st_source[line_no] then (* maybe newline *)\r
begin\r
if pos+28>=pwidth then pos:=pwidth (* newline *) else\r
begin\r
write(listfile,' ':2);\r
i:=write_source(st_source[line_no]);\r
pos:=pos+2+i;\r
last_source:=st_source[line_no];\r
adjust:=7-pos mod 7;\r
write(listfile,' ':adjust); pos:=pos+adjust;\r
end;\r
end;\r
if pos+7>=pwidth then\r
begin\r
writeln(listfile); pline:=pline+1;\r
if pline>=plength then writepage;\r
if last_source<>st_source[line_no] then\r
begin\r
write(listfile,' ':31); pos:=31;\r
i:=write_source(st_source[line_no]);\r
pos:=pos+i;\r
\r
last_source:=st_source[line_no];\r
adjust:=7-pos mod 7;\r
write(listfile,' ':adjust); pos:=pos+adjust;\r
end else\r
begin\r
write(listfile,' ':42); pos:=42;\r
end;\r
end;\r
case st_line_mode[line_no] of\r
cforward: ch:='*';\r
cassignstat: ch:='=';\r
caddr: ch:='@';\r
cwithvar: ch:='<';\r
clockstat: ch:='>';\r
clabel: ch:=':';\r
(*otherwise*) else ch:=' ';\r
end;\r
write(listfile,st_line[line_no]:6,ch); pos:=pos+7;\r
end;\r
line_no:=line_no+1;\r
if line_no>5 then\r
if not equal_addr(next_line,st_nilladdr) then\r
begin\r
st_retrieve(next_line,cur_ptr);\r
next_line:=cur_ptr^.st_next_line;\r
line_no:=1;\r
end;\r
end;\r
writeln(listfile); pline:=pline+1;\r
end;\r
pline:=plength;\r
end;\r
end;\r
\r
procedure infolisting;\r
var i:integer;\r
ch:char;\r
next_seg_line,\r
next_seg,\r
name,line,data_size,appetite,c_size,codesize:word;\r
entry, code_size:longint;\r
space,name_length:integer;\r
new_source, dynamic:byte;\r
addr: st_address;\r
ptr: st_elemptr;\r
seg: word;\r
finis,stop:boolean;\r
name_ptr: ptr_string;\r
kind_str: string[10];\r
(*#BEGINTEST\r
a:string[12];\r
(*ENDTEST#*)\r
\r
\r
procedure write_int(v,p:word);\r
begin\r
if v=maxword then write(listfile,' ':p) else\r
begin\r
write(listfile,v:p);\r
end;\r
end;\r
\r
\r
procedure write_info_head;\r
begin\r
if pline+16>=plength then writepage;\r
pline:=pline+2;\r
write(listfile,'Kind Name ');\r
name_length:=pwidth-62;\r
if name_length>30 then name_length:=30;\r
write(listfile,' ':name_length-11);\r
write(listfile,'Line Entry Code Data Appetite Createsize');\r
IF Computer = RC3502 THEN write(listFile,' CodeSize');\r
writeln(listfile);\r
writeln(listfile);\r
end;\r
\r
begin\r
(*#BEGINTEST\r
if testlist>0 then\r
begin\r
a:='infolisting ';\r
writeln(testoutput,a);\r
end;\r
(*ENDTEST#*)\r
IF (Computer = RC5000) OR (Computer = RC3502) THEN Last_Segment := 1;\r
pline:=maxlines;\r
pageno:=0;\r
\r
headtxt := infohead;\r
subheadl:=0;\r
\r
next_seg:=2;\r
if last_segment<=1 then next_seg_line:=maxword else\r
next_seg_line:=segment_info[2].line;\r
finis:=false;\r
repeat\r
stop:=false;\r
repeat\r
(* read command *)\r
if eof(comm) then begin finis:=true; stop:=true; end\r
else\r
begin new_source:=get_comm;\r
line:=get_comm;\r
line:=line+get_comm * 256;\r
addr.va_low:=get_comm;\r
addr.va_low:=addr.va_low+get_comm*256;\r
addr.va_high:=get_comm;\r
addr.va_high:=addr.va_high+get_comm*256;\r
\r
entry:=maxword;\r
code_size:=0;\r
data_size:=maxword;\r
appetite:=maxword;\r
codesize := maxword;\r
c_size:=maxword;\r
dynamic:=0;\r
st_retrieve(addr,ptr);\r
with ptr^ do\r
begin\r
name:=st_spix;\r
case st_kind of\r
cprocedure: begin\r
kind_str:='PROCEDURE ';\r
data_size:=st_varsize;\r
appetite:=max_offset - data_size;\r
end;\r
cfunction: begin\r
kind_str:='FUNCTION ';\r
data_size:=st_varsize;\r
appetite:=max_offset - data_size;\r
end;\r
cprogram: begin\r
kind_str:='PROGRAM ';\r
c_size:=prog_createsize;\r
IF Computer = RC5000 THEN c_size := c_size - 100;\r
data_size:=st_varsize+st_paramsize;\r
appetite:=max_offset-data_size;\r
data_size := data_size - 100\r
end;\r
ctype: begin\r
kind_str:='FAMILY ';\r
appetite:=st_type_maxoffset;\r
end;\r
(*otherwise*) else kind_str:=' ';\r
end;\r
if st_kind<>ctype then\r
begin\r
if line>=next_seg_line then\r
begin\r
writeln(listfile);\r
pline:=pline+1;\r
next_seg:=next_seg+1;\r
if last_segment<next_seg then next_seg_line:=maxword else\r
next_seg_line:=segment_info[next_seg].line;\r
end;\r
IF (Computer = RC5000) OR (Computer = RC3502) THEN\r
entry := MegaFirst_Offset\r
ELSE\r
entry:=first_offset;\r
if st_specs=st_global then\r
begin\r
segment_info[1].spix:=st_spix;\r
code_size:=0;\r
if last_segment=1 then\r
BEGIN\r
IF (Computer = RC5000) THEN\r
BEGIN\r
Code_Size := Last_Offset;\r
Code_Size := Code_Size SHL 16;\r
END;\r
IF Computer = RC3502 THEN\r
BEGIN\r
Code_Size := MegaLast_Offset;\r
CodeSize := st_Size;\r
END\r
ELSE\r
code_size:=st_size + Code_size;\r
END\r
else\r
begin\r
for seg:=1 to last_segment do\r
code_size:=code_size+segment_info[seg].code_size;\r
end;\r
end;\r
end;\r
\r
\r
if pline+5>=plength then write_info_head;\r
write(listfile,kind_str);\r
st_nameofspix(name,name_ptr);\r
(*with name_ptr^ do*)\r
if length(name_ptr^)>0 then\r
begin\r
for i:=1 to length(name_ptr^) do\r
begin\r
ch:=name_ptr^[i];\r
if ('A'<=ch) AND (ch<='Z') then ch:=chr(ord(ch)+32);\r
write(listfile,ch)\r
end;\r
i:=name_length-length(name_ptr^);\r
if i<=0 then\r
begin\r
writeln(listfile);\r
pline:=pline+1;\r
i:=name_length+10;\r
end;\r
end else i:=name_length;\r
write(listfile,' ':i);\r
write_int(line,5);\r
write_hex(entry,8);\r
if code_size=0 then write(listfile,' ':7)\r
else write(listfile,code_size:7);\r
write_int(data_size,7);\r
write_int(appetite,11);\r
if dynamic<>0 then write(listfile,'+')\r
else write(listfile,' ');\r
write_int(c_size,12);\r
write_int(codesize,11);\r
writeln(listfile);\r
pline:=pline+1;\r
end;\r
end;\r
until stop;\r
writeln(listfile); pline:=pline+1;\r
until finis;\r
IF Computer = RC5000 THEN\r
BEGIN\r
if pline+3>plength then\r
writepage;\r
\r
writeln(listfile); pline:=pline+1;\r
writeln(listfile,'CONSTANT AREA SIZE : ',SizeOfConst); pline:=pline+1;\r
writeln(listfile,'LINE AND NAME TABLE SIZE : ',SizeOfLineTable); pline:=pline+1;\r
writeln(listfile); pline:=pline+1;\r
END;\r
if last_segment>1 then begin\r
segment_info[1].line:=1;\r
writeln(listfile); pline:=pline+1;\r
if pline+last_segment+5<=plength then begin\r
writeln(listfile,'Segment name line code');\r
writeln(listfile);\r
pline:=pline+2;\r
end else pline:=maxlines;\r
for seg:=1 to last_segment do\r
with segment_info[seg] do\r
begin\r
if pline+2>plength then begin\r
writepage;\r
writeln(listfile,'Segment name line code');\r
writeln(listfile);\r
pline:=pline+2;\r
end;\r
st_nameofspix(spix,name_ptr);\r
(*with name_ptr^ do*)\r
if length(name_ptr^)>0 then\r
begin\r
for i:=1 to length(name_ptr^) do\r
begin\r
ch:=name_ptr^[i];\r
if ('A'<=ch) AND (ch<='Z') then ch:=chr(ord(ch)+32);\r
write(listfile,ch)\r
end;\r
i:=length(name_ptr^);\r
end\r
else begin write(listfile,'?'); i:=1; end;\r
if i<30 then write(listfile,' ':30-i) else\r
begin writeln(listfile); pline:=pline+1; write(listfile,' ':30); end;\r
\r
writeln(listfile,line:5,code_size:9);\r
end;\r
end;\r
end; \r
\r
\r
\r
\r
\r
\r
\r
\r
(* MAIN PROGRAM*)\r
BEGIN\r
(*#BEGINTEST\r
if testlist>0 then\r
begin\r
writeln(testoutput,'listhandler');\r
end;\r
(*ENDTEST#*)\r
internalerror := false;\r
reset(comm,1);\r
initialize;\r
if internalerror or fatal THEN goto 10;\r
\r
IF markmode THEN\r
BEGIN FOR pos:=-1 TO lsize DO\r
begin\r
markstack[pos]:=0;\r
cmarkstack[pos]:=0;\r
end;\r
END;\r
IF myind THEN noind_:=true;\r
\r
if call_options.listing=2 then\r
begin\r
\r
REPEAT\r
WHILE NOT end_of_file DO\r
BEGIN\r
readline;\r
pos:=1; current:=line[pos];\r
while pos<=lastpos do\r
begin\r
IF (current>='a') AND (current<='z') THEN current:=chr(ord(current)-32);\r
CASE current OF\r
'A','B','C','D','E','F','G','H','I','J',\r
'K','L','M','N','O','P','Q','R','S','T',\r
'U','V','W','X','Y','Z':\r
begin\r
pasidentifier;\r
pos:=pos-1;\r
end;\r
\r
'0','1','2','3','4',\r
'5','6','7','8','9':\r
BEGIN\r
REPEAT pos:=pos+1 UNTIL alfanum[line[pos]]<>2;\r
pos:=pos-1;\r
END;\r
\r
'(','<':\r
IF line[pos+1]='*' THEN\r
BEGIN\r
if pos = 1 (* i.e. in front of the line *) then\r
pushindent(4, 2) (* indent 2 more positions *)\r
else pushindent(4, pos-1); (* no further indention caused by comment *)\r
if current='(' then endcomment:=')' else endcomment:='>';\r
repeat skip('*') until line[pos+1]=endcomment;\r
pos:=pos+1;\r
popindent;\r
END else\r
if (current='(') then\r
begin\r
if state=declare THEN\r
pushindent(4,pos)\r
(* INDENTION OF SCALAR TYPES AND VARIANT FIELDS IN RECORDS *)\r
else if (state=formal_parameters)\r
then bracket_niv:=bracket_niv+1;\r
end;\r
\r
')':\r
IF state=declare THEN\r
BEGIN(*UNSTACK INDENTION OF SCALAR TYPES AND VARIANT PARTS IN RECORDS*)\r
popindent;\r
END else\r
BEGIN\r
if (state=formal_parameters) then\r
BEGIN\r
if bracket_niv>0 then bracket_niv:=bracket_niv-1;\r
END;\r
END;\r
\r
'"' : skip('"'); (* text string *)\r
\r
'''':\r
BEGIN\r
if line[ pos + 1 ] = '''' then pos:=pos+1;\r
skip(''''); (* char *)\r
END;\r
\r
'-':\r
if line[ pos + 1 ] = '-' then (* RTP86-comment *)\r
begin\r
pushindent(4, 2); (* indent 2 more positions *)\r
if fresh then prepare_printline;\r
popindent;\r
pos := lastpos; (*i.e.: skip rest of line *)\r
end;\r
\r
'$': begin\r
oldpos := margin;\r
margin := 1;\r
if fresh then prepare_printline;\r
margin := oldpos;\r
pos := lastpos;\r
end;\r
\r
':': if (line[pos+1]<>'=') and\r
not inwith and (state=statement) THEN\r
BEGIN (*INDENTION OF CASELABELS *)\r
semicolon;(*POP PREVIOUS STACKED CASELABELS AND IFSTATEMENTS *)\r
pushindent(5,oldpos + 2);\r
END;\r
\r
';': if state=formal_parameters then\r
begin\r
if bracket_niv=0 then state:=declare;\r
end else semicolon;\r
\r
(*OTHERWISE;*)\r
END;\r
pos:=pos+1;\r
current:=line[pos];\r
IF fresh THEN prepare_printline;\r
END (* SCAN OF LINE*);\r
printline;\r
while read_commands do command;\r
END (* SCAN OF INPUT FILE *);\r
IF commkey=sourcecomm THEN BEGIN command; primcomm; END;\r
UNTIL end_of_file;\r
end;\r
sourceno:=255; (* only skip of commands, no source opened *)\r
while commkey<>endcomm do command;\r
close_files;\r
if call_options.xref<>1 then crosslisting;\r
10:;\r
errorlisting;\r
if make_code and (not fatal) then codelisting;\r
END;\r
END\r
.\r
«eof»