⟦301b11927⟧

TextFile

{$O+,F+}\r
unit rtp86mpa;\r
interface\r
uses dos,pscplm, rtp86rmx, files, mpaunit, sthunit, vmmunit, nthunit, sthint, sthcom;\r
{$F+}\r
(**************** ================= *******************)\r
(******  ROUTINES ******)\r
(* !!! TURBO !!! *)\r
\r
const include_max=20;\r
\r
var\r
(* !!! TURBO !!!\r
fatal,error, warn,break_line : boolean;\r
\r
open_errtxts, open_parsetables, open_openroutine,\r
open_comm, open_listfile, open_tbinfile, open_codelist, open_tsymfile,\r
open_errorfile,     (* indicates whether or not ERRORFILE has been opened *)\r
(*firstcall_closep,\r
call_listh,\r
test_on_co,\r
exit_before: boolean;\r
*)\r
overlayname : string;\r
\r
elementnameptr: ptr_string;\r
    include_niv: integer;\r
    include_info: array[0..include_max] of record\r
      addr: longint;\r
      f: string;\r
    end;\r
\r
(***   ***)\r
current_time:\r
record\r
 hour,minute,second,sec100 : word;\r
end;\r
time_used,\r
last_time: integer;\r
exc: word;\r
\r
procedure open_errortextfile;\r
function find_time_used:integer;\r
procedure open_workfiles;\r
procedure delete_workfile(who: ext_type);\r
procedure delete_workfiles;\r
procedure open_files(module_no:modulerange);\r
procedure close_pagingsystem;\r
\r
procedure open_source(var fileno:integer);\r
(*used by the rtp86_compiler pass1 to open source files*)\r
(*as read by the mpa from the call line. Source files means*)\r
(*a number of contexts and the source text*)\r
\r
procedure shift_source;\r
(*used by the rtp86_compiler pass2 to shift from save_codefile*)\r
(*to codefile*)\r
\r
\r
function stdspix_to_address(stdspix:spixrange;var stdsymbol:st_address):\r
boolean;\r
(*finds the st_address of a stdtype denoted by stdspix*)\r
\r
function stdcode_to_spix(stdcode:codes; var stdspix:spixrange):\r
boolean;\r
(*finds the spix of a stdtype denoted by stdcode*)\r
\r
function stdcode_to_address(stdcode:codes; var stdsymbol:st_address):\r
boolean;\r
(*finds the st_address of a stdtype denoted by stdcode*)\r
\r
function code_of_address(stdsymbol:st_address):codes;\r
(*returns the code of an address*)\r
\r
function search_switch(s: string; var switch_value: integer): boolean;\r
(* function searches for the switch and tells in resultboolean *)\r
(* whether it is found or not.                            *)\r
(* If it is found, the value of the switch is returned in *)\r
(* switchvalue.    *)\r
\r
procedure add_switch(s: string; val: integer);\r
(* procedure searches for af switch of name "s"   *)\r
(* in the list of switchnodes.                  *)\r
(* if it is found, its value is changed to "val"*)\r
(* if not found, a node containing the name and *)\r
(* value of the switch is added to the list     *)\r
\r
procedure save_specs( state : boolean);\r
\r
procedure load_specs( state : boolean);\r
\r
procedure file_missing(f: string);\r
\r
\r
(***********************)\r
\r
implementation\r
\r
(*** HELP PROCEDURES ***)\r
\r
procedure file_missing(f: string);\r
begin\r
writeln;\r
writeln('SYSTEM ERROR from MPA: ');\r
writeln('Systemfile ',f,' does not exist!');  (* errno = 100 *)\r
writeln;\r
halt(1); (* !!! TURBO !!! goto 8888; (* exit *)\r
end;\r
\r
function find_time_used:integer;\r
var new_time: integer;\r
begin\r
  with current_time do\r
  begin\r
    gettime(hour,minute,second,sec100);\r
    new_time := hour mod 10;\r
\r
 (*   new_time:=ord(time[2])-ord('0'); *)\r
    if new_time>=5 then new_time:=new_time-5;\r
\r
\r
(*   new_time:=new_time*3600+(ord(time[4])-ord('0'))*600+\r
              (ord(time[5])-ord('0'))*60+\r
              (ord(time[7])-ord('0'))*10+ord(time[8])-ord('0'); *)\r
\r
    new_time:=new_time*3600+\r
              minute*60+\r
              second;\r
  end;\r
  if new_time>=last_time then find_time_used:=new_time-last_time\r
  else find_time_used:=(5 * 3600) +new_time-last_time;\r
  last_time := new_time;\r
end;\r
\r
\r
\r
\r
procedure save_specs( state : boolean);\r
\r
var\r
addr : st_address;\r
ptr  : st_elemptr;\r
symname,\r
helpstr : string;\r
vmm_ext, nth_ext : three_char;\r
cha     : char;\r
status  : word;\r
\r
begin\r
if state then\r
begin\r
status:=vmmretrieve( stdescriptorptr^, currant_level.va_high,\r
currant_level.va_low, false, false, ptr );\r
if status <> 0 then fatal_error(vmm,status);\r
end;\r
\r
\r
status:= vmmretrieve( stdescriptorptr^, saveinf_addr.va_high,\r
saveinf_addr.va_low, false, true, ptr );\r
if status <> 0 then fatal_error(vmm,status);\r
\r
with ptr^ do\r
begin\r
if state then s_pass:= pass0 else s_pass:= active_module;\r
s_version_no:=version_no;\r
s_make_code:=make_code;\r
s_make_set:=make_set;\r
s_cur_addr := currant_addr;\r
s_last_addr:= last_addr;\r
\r
s_obj_addr := obj_addr;\r
if state then begin\r
s_first_level:=currant_level;\r
s_next_level:=last_created_level;\r
end else begin\r
s_first_level:= first_level;\r
s_next_level:= first_next_level;\r
end;\r
s_last_created_level:= last_created_level;\r
s_create_addr:= st_create_addr;\r
s_dataarea_addr:= st_dataarea_type_addr;\r
s_buffer_addr:= st_buffer_type_addr;\r
s_program_addr:= st_program_type_addr;\r
s_string_addr:= st_string_type_addr;\r
\r
s_fileposition:=file_mark;\r
s_last_cross:=last_cross;\r
end;\r
\r
vmm_ext := vmmextension;\r
nth_ext := nthextension;\r
if state then\r
begin\r
status:= 0;\r
symname:= call_options.savestr;\r
cha:= ext3[ active_module ]\r
end else\r
begin\r
symname:= callparams[no_of_files].filename;\r
cha:= chr( ord(active_module) + ord('0'));\r
end;\r
vmm_ext[3]:= cha;\r
nth_ext[3]:= cha;\r
helpstr:= symname;\r
status:= 0;\r
change_ext(helpstr,vmm_ext);\r
if status = 0 then\r
status:= vmmsavetable( stdescriptorptr^, helpstr,\r
saveinf_addr.va_high, saveinf_addr.va_low);\r
\r
(*create nameconvertiontable*)\r
if status = 0 then change_ext(helpstr,nth_ext);\r
if status = 0 then status:= nthsave(helpstr);\r
if status <> 0 then fatal_error(vmm,status);\r
end;\r
\r
\r
procedure load_specs( state : boolean);\r
\r
var\r
addr : st_address;\r
ptr  : st_elemptr;\r
symbtabname,\r
namestr,\r
helpstr : string;\r
vmm_ext, nth_ext : three_char;\r
cha     : char;\r
status  : word;\r
p       : integer;\r
\r
begin\r
   vmm_ext := vmmextension;\r
   nth_ext := nthextension;\r
status:=0;\r
symbtabname:=callparams[no_of_files].filename;\r
change_ext(symbtabname,vmm_ext);\r
namestr:=symbtabname;\r
if status=0 then change_ext(namestr,nth_ext);\r
if state then begin\r
cha:= ext3[ pass2 ];\r
end else\r
cha:= chr( ord(active_module) + ord('0') - 1);\r
vmm_ext[3]:= cha;\r
nth_ext[3]:= cha;\r
\r
(*open symboltable*)\r
if state then helpstr:=call_options.loadstr\r
else helpstr:=callparams[no_of_files].filename;\r
if status=0 then change_ext(helpstr, vmm_ext);\r
if status=0 then\r
begin\r
if not file_exist(helpstr) then fatal_error(mpa,12);\r
status:= vmmgettable( stdescriptorptr,symbtabname, vmaxresidents,\r
helpstr, saveinf_addr);\r
end;\r
if status <> 0 then fatal_error(vmm,status);\r
\r
(*create nameconvertiontable*)\r
if status=0 then change_ext(helpstr, nth_ext);\r
if not file_exist(helpstr) then fatal_error(mpa,12);\r
if status=0 then status:= nthget(namestr,nmaxresidents,helpstr);\r
if status=0 then\r
status:= vmmretrieve(stdescriptorptr^, saveinf_addr.va_high,\r
saveinf_addr.va_low,false,false, ptr );\r
if status <> 0 then fatal_error(vmm,status);\r
with ptr^ do\r
begin\r
if s_version_no<>version_no then fatal_error(mpa,113);\r
make_code:= s_make_code or make_code;\r
make_set:= s_make_set;\r
last_addr:= s_last_addr; (* ????? *)\r
obj_addr := s_obj_addr;\r
currant_addr := s_cur_addr;\r
last_created_level:= s_last_created_level;\r
next_level:=s_next_level;\r
first_next_level:=s_next_level;\r
first_level:= s_first_level;\r
st_nilladdr:= s_nilladdr;\r
last_cross:= st_nilladdr;\r
st_stopaddr:= s_stopaddr;\r
st_btype_addr:= s_btype;\r
st_wtype_addr:= s_wtype;\r
st_rtype_addr:= s_rtype;\r
st_ptype_addr:= s_ptype;\r
st_emptyset_addr:= s_emptyset_addr;\r
st_create_addr:= s_create_addr;\r
st_dataarea_type_addr:= s_dataarea_addr;\r
st_buffer_type_addr:= s_buffer_addr;\r
st_program_type_addr:= s_program_addr;\r
st_string_type_addr:= s_string_addr;\r
st_undeclared_addr:= s_undeclared_addr;\r
last_cross:=s_last_cross;\r
\r
for p:= first_ix to maxstddefinitions do\r
stdspix_to_symbol_table[ p ]:= s_stdsymbol_table[ p ];\r
\r
st_mailboxtype_addr  := stdspix_to_symbol_table[ 7 ].symbol;\r
st_referencetype_addr:= stdspix_to_symbol_table[ 8 ].symbol;\r
st_pooltype_addr     := stdspix_to_symbol_table[ 9 ].symbol;\r
st_processtype_addr  := stdspix_to_symbol_table[ 10 ].symbol;\r
st_porttype_addr     := stdspix_to_symbol_table[ 11 ].symbol;\r
st_chaintype_addr    := stdspix_to_symbol_table[ 12 ].symbol;\r
file_mark:=s_fileposition;\r
first_charspix:=s_charspix;\r
anonymousspix:=s_anonymousspix;\r
first_addr:=s_first_addr;\r
st_spix_of_exception:=s_spix_of_exception;\r
end;\r
currant_level:=first_level;\r
status:=vmmretrieve(stdescriptorptr^,currant_level.va_high,currant_level.va_low,\r
               true,true,currant_level_ptr);\r
if status=0 then\r
status:=vmmretrieve(stdescriptorptr^,last_created_level.va_high,\r
last_created_level.va_low,true,true,last_created_level_ptr);\r
if status<>0 then fatal_error(vmm,status);\r
status:=vmmretrieve(stdescriptorptr^,currant_addr.va_high,currant_addr.va_low,true,\r
               false,last_elem);\r
last_addr:=currant_addr;\r
currant_ptr:=last_elem;\r
if status<>0 then fatal_error(vmm,status);\r
end;\r
\r
\r
\r
function search_switch( s:string; var switch_value: integer): boolean;\r
var\r
a: string[12];\r
found: boolean;\r
begin\r
a := 'search-switc';\r
(******************)\r
\r
(*#BEGINTEST\r
if mpatest then\r
writeln(testoutput, a : 12);\r
(*ENDTEST#*)\r
\r
switchpoint := switchstart;\r
found := false;\r
while (switchpoint <> nil) and not found do\r
begin\r
found := equalname(s,switchpoint^.name);\r
if not found then\r
switchpoint := switchpoint^.next;\r
if mpatest then\r
with switchpoint^ do\r
if length(name) > 0 then\r
writeln(testoutput,name, '  value: ',value);\r
end;\r
\r
search_switch := found;\r
\r
if found then\r
(** return switch-value **)\r
switch_value := switchpoint^.value;\r
\r
end (*search-switch*);\r
\r
procedure add_switch( s: string; val: integer);\r
var\r
a: string[12];\r
dummy: integer;\r
begin\r
a := 'add-switch  ';\r
(******************)\r
\r
(*#BEGINTEST\r
if mpatest then\r
writeln(testoutput, a : 12);\r
(*ENDTEST#*)\r
\r
if not search_switch(s,dummy) then\r
begin\r
new(switchpoint);\r
with switchpoint^ do\r
begin\r
name := s;\r
value := val;\r
next := switchstart;\r
end;\r
switchstart:= switchpoint;\r
end else\r
switchpoint^.value := val;\r
if mpatest then\r
with switchpoint^ do\r
writeln(testoutput, name,'  value: ', value);\r
end (*add-switch*);\r
\r
procedure check_time_option;\r
var temp:word;\r
    ok:boolean;\r
begin\r
  ok:=ord(coption)=get_byte;\r
  ok:=ok and (ord(mpa)=get_2_byte);\r
  ok:=ok and (checktimelow=get_2_byte);\r
  ok:=ok and (checktimehigh=get_2_byte);\r
  if not ok then fatal_error(mpa,113);\r
end;\r
\r
procedure skip_time_option;\r
var ok:boolean;\r
    temp:word;\r
begin\r
  ok:=get_byte=ord(coption);\r
  ok:=ok and (ord(mpa)=get_2_byte);\r
  if ok then begin\r
    temp:=get_2_byte; temp:=get_2_byte;\r
  end else fatal_error(mpa,113);\r
end;\r
\r
\r
procedure put_time_option;\r
begin\r
  put_byte(ord(coption));\r
  put_2_byte(ord(mpa));\r
  put_2_byte(starttimelow);\r
  put_2_byte(starttimehigh);\r
end;\r
\r
(**** OPENING EXTERNAL FILES ***)\r
\r
function get_filename(ext: ext_type;\r
var fname: string; var helpname: string):boolean;\r
(** Returns true if file already exists - false otherwise **)\r
(** The file path is returned in helpname  **)\r
(** The filename is made from the last source-filename followed **)\r
(** by the extension chosen.      **)\r
var\r
a: string[12];\r
i: integer;\r
status: word;\r
begin\r
a := 'get-filename';\r
(******************)\r
\r
(*#BEGINTEST\r
if mpatest then\r
writeln(testoutput, a : 12);\r
(*ENDTEST#*)\r
\r
(*** UPS !!! ***)\r
a := '            ';   (*** SKAL NOK ANDRES - SKYLDES TYPE AF EXTENSION *)\r
for i:= 1 to 3 do\r
a[i] := extension[ext,i];\r
(*****  *****)\r
\r
status:= 0;\r
fname:=callparams[no_of_files].filename;\r
change_ext(fname,extension[ext]);\r
helpname:= fname;\r
\r
if status<>0 then get_filename := false else\r
if file_exist(fname) then\r
get_filename := true\r
else\r
get_filename := false;\r
end; (** get_filename **)\r
\r
procedure open_errortextfile;\r
var\r
a: string[12];\r
helpname: string;\r
sourcename: string;\r
begin\r
a := 'open-ertxtfi';\r
(******************)\r
\r
(*#BEGINTEST\r
if mpatest then\r
writeln(testoutput, a : 12);\r
(*ENDTEST#*)\r
\r
        helpname:= errortexts;\r
        if file_exist(helpname) then begin\r
          assign(errtxts, errortexts);\r
          reset(errtxts);\r
          open_errtxts:= true;\r
        end else file_missing(errortexts);\r
end; (*open-errortextfile *)\r
\r
procedure open_testoutput(module_no:modulerange);\r
var\r
a: string[12];\r
testname: string;\r
helpname: string;\r
ext     : three_char;\r
testvar :integer;\r
step    : integer;\r
vmmstatus: word;\r
begin (*resets testoutput for writing testmessages from the*)\r
      (*active module. filename is 'source.ts<module_no>'  *)\r
      (*two external routines is used:                     *)\r
      (*procedure change_ext(d,s:string,ext:alfa12) which  *)\r
      (*returns s as d with new extension ext.             *)\r
      (*procedure path_to_alfa(s:string,t:path_alfa) which *)\r
      (*which returns s as t ready for resetting           *)\r
      (*This is NOT for PASS0! In case of PAAS0 - testoutput *)\r
      (*is opened in RTP86PASS0, when reading the option.   *)\r
\r
a := 'open-tstoutp';\r
(******************)\r
\r
(*#BEGINTEST\r
if mpatest then\r
writeln(testoutput, a : 12);\r
(*ENDTEST#*)\r
\r
(*preparing extension ts<module_no> *)\r
ext := 'ts ';\r
ext[3] := chr(ord('1') +ord(module_no)-ord(pass1));\r
\r
case module_no of\r
pass1: testvar := testpass1;\r
pass2: testvar := testpass2;\r
pass3: testvar := testpass3;\r
pass4: testvar := testpass4;\r
listh: testvar := testlist\r
else (*otherwise*);\r
end;\r
\r
\r
if testvar > -1 then\r
begin\r
if testvar >= 10000 then\r
begin\r
if not test_on_co then begin\r
assign(testoutput, 'con');\r
rewrite(testoutput);\r
test_on_co:= true;\r
end;\r
case module_no of\r
pass1: testpass1 := testpass1 mod 10000;\r
pass2: testpass2 := testpass2 mod 10000;\r
pass3: testpass3 := testpass3 mod 10000;\r
pass4: testpass4 := testpass4 mod 10000;\r
listh: testlist := testlist mod 10000\r
else (*otherwise*);\r
end;\r
\r
end (** if >= 10000 *)\r
else\r
begin\r
(*fetch sourcefilename - last file name in callparams*)\r
vmmstatus:= 0;\r
helpname:= callparams[no_of_files].filename;\r
change_ext(helpname,ext);\r
if vmmstatus=0 then\r
begin\r
testname:= helpname;\r
assign(testoutput,testname);\r
rewrite(testoutput);\r
test_on_co:=false;\r
end else begin\r
if not test_on_co then begin\r
assign(testoutput,'con');\r
rewrite(testoutput);\r
end;\r
test_on_co:=true;\r
end;\r
\r
end\r
end;\r
end; (*open_testoutput*)\r
\r
procedure open_source(var fileno:integer);\r
var\r
a: string[12];\r
begin (*used by the  rtp86-compiler pass1 to open source files *)\r
      (*as read by mpa from the call line. Source files means  *)\r
      (* a number of contexts and the sourcetext.              *)\r
a := 'open-source ';\r
(******************)\r
\r
(*#BEGINTEST\r
if mpatest then\r
writeln(testoutput, a : 12);\r
(*ENDTEST#*)\r
\r
linenumber := 0;\r
elementnumber := noelement;\r
elementspix := anonymousspix;\r
\r
if (* ?INCLUDE? *) TRUE OR (fileno<>sourcenumber) then\r
begin\r
with callparams[fileno] do\r
begin\r
reset_file(filename, extension[dummy]);\r
IF Fileno = no_of_files THEN SetSourceDate;\r
\r
include_niv:=0;\r
include_info[ 0 ].f:= filename;\r
end;\r
sourcenumber := fileno;\r
end else\r
\r
\r
if (include_niv=0) then\r
begin\r
if fileno<no_of_files then\r
begin\r
fileno:= fileno+1;\r
with callparams[fileno] do\r
begin\r
reset_file(filename, extension[dummy]);\r
include_niv:=0;\r
include_info[ 0 ].f:= filename;\r
end;\r
sourcenumber := fileno;\r
end;\r
end else\r
begin\r
  include_niv:=include_niv-1;\r
  with include_info[include_niv] do\r
  begin\r
    reset_file(f, extension[dummy]);\r
    files_skip_to(addr);\r
  end;\r
end;  \r
(**  fatal_error(mpa, 103); (*sourcefile does no more exist*)\r
end; (*open source*)\r
\r
procedure open_include(var f:string);\r
var\r
a: string[12];\r
begin (*used by the  rtp86-compiler pass1 to open include files *)\r
a := 'open-include';\r
(******************)\r
\r
(*#BEGINTEST\r
if mpatest then\r
writeln(testoutput, a : 12);\r
(*ENDTEST#*)\r
\r
elementnumber := noelement;\r
elementspix := anonymousspix;\r
\r
\r
if (* ?INCLUDE? *) FALSE AND (include_niv<include_max) then begin\r
include_niv:=include_niv+1;\r
include_info[ include_niv ].f:= f;\r
(* include_info[ include_niv ].addr:= files_read_pos; *)\r
reset_file(f, extension[dummy]);\r
end else errormsg(pass1, 128);\r
\r
\r
end; (*open include*)\r
\r
procedure shift_source;\r
var fname:string;\r
begin\r
  fname:=callparams[no_of_files].filename;\r
  reset_file(fname, extension[co2]);\r
  skip_time_option;\r
end;\r
\r
procedure open_workfiles;\r
var\r
a: string[12];\r
   b: boolean;\r
   helpname  : string;\r
   sourcename: string;\r
begin\r
a := 'open-workfil';\r
(******************)\r
\r
(*#BEGINTEST\r
if mpatest then\r
writeln(testoutput, a : 12);\r
(*ENDTEST#*)\r
\r
(** LST **)\r
(*\r
b := get_filename(lst,helpname,sourcename);\r
assign(listfile,sourcename);\r
rewrite(listfile);\r
open_listfile:= true;\r
*)\r
(** ERR **)\r
b := get_filename(err,helpname,sourcename);\r
assign(errorfile,sourcename);\r
rewrite(errorfile);\r
open_errorfile := true;\r
\r
(** CMD **)\r
b := get_filename(cmd,helpname,sourcename);\r
assign(comm,sourcename);\r
rewrite(comm,1);\r
open_comm := true;\r
\r
end; (*open workfiles*)\r
\r
procedure delete_workfile(who: ext_type);\r
var\r
a: string[12];\r
e: word;\r
fname: string;\r
fpath: string;\r
help: file;\r
begin\r
a := 'delete-workf';\r
(******************)\r
\r
(*#BEGINTEST\r
if mpatest then\r
writeln(testoutput, a : 12);\r
(*ENDTEST#*)\r
if not survival[who] then\r
begin\r
e:=0;\r
fname:= callparams[no_of_files].filename;\r
change_ext(fname,extension[who]);\r
if e=0 then begin\r
fpath:= fname;\r
assign(help, fname);\r
if file_exist(fname) then\r
erase(help);\r
end;\r
if who = err then\r
open_errorfile := false;\r
end;\r
survival[who]:=true; (* do not exist *)\r
end; (* delete-workfile *)\r
\r
procedure delete_workfiles;\r
var step: ext_type;\r
begin\r
for step := co1 to cmd do\r
if not survival[step] then delete_workfile(step);\r
end;\r
\r
\r
procedure open_files(module_no:modulerange);\r
(*opens the files for the module in question*)\r
var\r
a: string[12];\r
b: boolean;\r
temp,temp1,temp2:word;\r
fname,\r
tname,\r
path,\r
open_name : string;\r
open_file_name: string;\r
begin\r
a := 'open-files  ';\r
(******************)\r
\r
(*#BEGINTEST\r
if mpatest then\r
writeln(testoutput, a : 12);\r
(*ENDTEST#*)\r
\r
fname := callparams[no_of_files].filename;  (* name of last sourcefile *)\r
\r
case module_no of\r
pass1 : begin\r
        if file_exist(parsetablename) then begin\r
          assign(parsetables,parsetablename);\r
          reset(parsetables);\r
          open_parsetables := true;\r
        end else file_missing(parsetablename);\r
\r
        (** CO1 **)\r
        rewrite_file(fname, extension[co1]);\r
        put_time_option;\r
        load_tab:=false;\r
        end;\r
pass2: begin\r
        (** CO2 **)\r
        if call_options.savecode then\r
        begin\r
        tname:=call_options.savestr;\r
        rewrite_file(tname,cobextension);\r
        put_time_option;\r
        if call_options.loadcode<=1 then\r
        begin\r
          tname:=call_options.loadstr;\r
          reset_file(tname,cobextension);\r
          check_time_option;\r
          temp:=get_byte;\r
        repeat\r
          while temp<>ord(ceos) do\r
          begin\r
            put_byte(temp);\r
            temp:=get_byte;\r
          end;\r
          temp1:=get_byte;\r
          temp2:=get_byte;\r
          temp:=get_byte;\r
          if not end_of_file then \r
          begin\r
            put_byte(ord(ceos));\r
            put_byte(temp1);\r
            put_byte(temp2);\r
          end;\r
        until end_of_file;\r
        end;\r
        end else begin\r
          rewrite_file(fname, extension[co2]);\r
          put_time_option;\r
        end;\r
       \r
       (** CO1 **)\r
       reset_file(fname, extension[co1]);\r
       if load_tab then begin\r
         check_time_option;\r
         load_tab:=false;\r
       end else skip_time_option;\r
\r
(**       fatal_error(mpa,104);  (** RTP1CODE missing **)\r
       end;\r
pass3: begin\r
        (** CO3 **)\r
        rewrite_file(fname, extension[co3]);\r
        put_time_option;\r
\r
       (** CO2 **)\r
       if call_options.loadcode<=1 then\r
       begin\r
         fname:=call_options.loadstr;\r
         reset_file(fname,cobextension);\r
         check_time_option;\r
         load_tab:=false\r
       end else begin\r
         reset_file(fname, extension[co2]);\r
         if load_tab then begin\r
           check_time_option;\r
           load_tab:=false;\r
         end else skip_time_option;\r
       end;\r
\r
(**       fatal_error(mpa,105);   (** RTP2CODE missing **)\r
       end;\r
pass4: begin\r
       new(filebufferptr);\r
       filebufferalloc := true;\r
       b := get_filename(tbf,path,open_name);\r
       assign(tbinfile,open_name);\r
       rewrite(tbinfile,1);\r
       open_tbinfile:= true;\r
if make_code then\r
begin\r
       b := get_filename(cls,path,open_name);\r
       assign(codelist,open_name);\r
       rewrite(codelist);\r
       open_codelist:= true;\r
\r
       b := get_filename(tsf,path,open_name);\r
       assign(tsymfile,open_name);\r
       rewrite(tsymfile);\r
       open_tsymfile:= true;\r
end;\r
\r
        (** CO4 **)\r
        rewrite_file(fname, extension[co4]);\r
\r
       (** CO3 **)\r
       reset_file(fname, extension[co3]);\r
         if load_tab then begin\r
           check_time_option;\r
           load_tab:=false;\r
         end else skip_time_option;\r
\r
(**       fatal_error(mpa,106);  (** RTP3CODE missing **)\r
\r
       Case computer of\r
       RC5000 :\r
         open_file_name:= RC5000openroutinename;\r
       RC3502 :\r
         open_file_name:= RC3502openroutinename;\r
       oldpi3 :\r
         open_file_name:= oldpi3openroutinename;\r
       else\r
         open_file_name:= openroutinename;\r
       end;\r
(* !!!TOG  Same open routines\r
       if computer=0 then (* PI3 *) (*else\r
       if computer=1 then (* PARTNER *) (*open_file_name[10]:='2'; *)\r
       path:= open_file_name;\r
       if file_exist(path) then begin\r
         assign(openroutine,open_file_name);\r
         reset(openroutine);\r
         open_openroutine := true;\r
       end else file_missing(open_file_name);\r
       end;\r
listh: begin\r
\r
(** LST **)\r
if not filebufferalloc then new(filebufferptr);\r
b := get_filename(lst,path,open_name);\r
assign(listfile,open_name);\r
settextbuf(listfile,filebufferptr^);\r
rewrite(listfile);\r
open_listfile:= true;\r
\r
       if open_comm then begin\r
         close(comm);\r
         open_comm:=false;\r
       end;\r
       if get_filename(cmd,path,open_name) then\r
       begin\r
         assign(comm,open_name);\r
         reset(comm);\r
         open_comm:= true;\r
       end else fatal_error(mpa,108);\r
       (** commandfile does not exist - listhandler cannot be started**)\r
\r
(*       if get_filename(err,path,open_name) then *)\r
       if open_errorfile then\r
       reset(errorfile)\r
       else fatal_error(mpa,109);\r
       (** file containing errorrecords does not exist.**)\r
\r
       end (*listh*)\r
else (*otherwise*);\r
end;(*case*)\r
open_testoutput(module_no);\r
end;(*open_files*)\r
\r
procedure close_pagingsystem;\r
var\r
a: string[12];\r
status:word;\r
begin\r
a := 'close-paging';\r
(******************)\r
\r
(*#BEGINTEST\r
if mpatest then\r
writeln(testoutput, a : 12);\r
(*ENDTEST#*)\r
\r
status := vmmdeletetable(stdescriptorptr);\r
if status <> 0 then fatal_error(vmm,status);\r
status := nthdelete;\r
if status <> 0 then fatal_error(vmm,status);\r
end;\r
\r
(*TESTING PROCEDURES*)\r
\r
(***********************************************)\r
(*#BEGINTEST\r
(***\r
procedure test_callparams(param:callparameters);\r
var\r
a: string[12];\r
i : integer;\r
count : 1 .. maxcallparams;\r
begin (*print out the callparameters to the compilercall*)\r
(**\r
a := 'test-callpar';\r
(******************)\r
\r
(**\r
writeln(testoutput,'START TEST-READCALLPARAMS');\r
\r
count := 1;\r
while (count <= no_of_files) do\r
begin\r
write(testoutput,'file no.:', count,'  ');\r
writeln(param[count].filename);\r
count := count + 1;\r
end;\r
\r
writeln(testoutput,'slut TESTCALLPARAMS');\r
\r
end;\r
(*ENDTEST#*)\r
\r
(*#BEGINTEST\r
procedure test_switches;\r
var\r
a: string[12];\r
i: integer;\r
helpptr: ptr_switchnode;\r
begin\r
a := 'test-switche';\r
writeln('START procedure test_switches');\r
helpptr := switchstart;\r
while helpptr <> nil do\r
begin\r
with helpptr^ do\r
begin\r
write(name);\r
write(':  ');\r
writeln(value);\r
end;\r
helpptr := helpptr^.next;\r
end;\r
\r
writeln('slut testswitches');\r
end; \r
(*ENDTEST#*)\r
(**************************************************)\r
\r
(* PROCEDURES TO SEARCH THE STDSPIX TO SYMBOL TABLE*)\r
\r
function stdspix_to_address(stdspix:spixrange;var stdsymbol:st_address):\r
boolean;\r
var\r
a: string[12];\r
count, pos : integer;\r
begin\r
a := 'stdspix-to-a';\r
(******************)\r
\r
(*#BEGINTEST\r
if mpatest then\r
writeln(testoutput, a : 12);\r
(*ENDTEST#*)\r
\r
pos := first_ix-1;\r
for count := first_ix to maxstddefinitions do\r
with stdspix_to_symbol_table[count] do\r
if stdspix = spix then pos := count;\r
if pos <> first_ix-1 then\r
with stdspix_to_symbol_table[pos] do\r
stdsymbol := symbol;\r
stdspix_to_address := pos <> first_ix-1;\r
end;\r
\r
function stdcode_to_spix(stdcode:codes;var stdspix:spixrange):\r
boolean;\r
var\r
a: string[12];\r
count,pos : integer;\r
begin\r
a := 'stdcode-to-s';\r
(******************)\r
\r
(*#BEGINTEST\r
if mpatest then\r
writeln(testoutput, a : 12);\r
(*ENDTEST#*)\r
\r
pos := first_ix-1;\r
for count := first_ix to maxstddefinitions do\r
with stdspix_to_symbol_table[count] do\r
if stdcode = symbolkind then pos := count;\r
if pos <> first_ix-1 then\r
with stdspix_to_symbol_table[pos] do stdspix := spix;\r
stdcode_to_spix := pos <> first_ix-1;\r
end;\r
\r
function stdcode_to_address(stdcode:codes;var stdsymbol:st_address):\r
boolean;\r
var\r
a: string[12];\r
count,pos:integer;\r
begin\r
a := 'stdcode-t-ad';\r
(******************)\r
\r
(*#BEGINTEST\r
if mpatest then\r
writeln(testoutput, a : 12);\r
(*ENDTEST#*)\r
\r
pos :=first_ix-1;\r
for count := first_ix to maxstddefinitions do\r
with stdspix_to_symbol_table[count] do\r
if stdcode =symbolkind then pos := count;\r
if pos <> first_ix-1 then\r
with stdspix_to_symbol_table[pos] do stdsymbol := symbol;\r
stdcode_to_address := pos <> first_ix-1;\r
end;\r
\r
function code_of_address(stdsymbol: st_address): codes;\r
(* returns the code of an address *)\r
var\r
a: string[12];\r
count,pos: integer;\r
begin\r
a := 'code-of-addr';\r
(******************)\r
\r
(*#BEGINTEST\r
if mpatest then\r
writeln(testoutput, a : 12);\r
(*ENDTEST#*)\r
\r
pos:= first_ix - 1;\r
for count:= first_ix to maxstddefinitions do\r
with stdspix_to_symbol_table[count] do\r
if (stdsymbol.va_low=symbol.va_low) and\r
   (stdsymbol.va_high=symbol.va_high) then pos:= count;\r
if (pos=first_ix - 1) and (count <> first_ix) then code_of_address:= cerror\r
else\r
with stdspix_to_symbol_table[pos] do\r
code_of_address:= symbolkind;\r
end;\r
begin\r
setcbreak(true);\r
end.\r
«eof»
DataMuseum.dk

DANOSI

⟦301b11927⟧ TextFile

Derivation

TextFile
