|
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: 49159 (0xc007)
Types: TextFile
Names: »P1INIT.PAS«
└─⟦b6837b237⟧ Bits:30010500 SW2103 REL 1.11 Sourcer DVBS1.SW2103.rel.1.11-1 MASTER 31-1-192
└─⟦this⟧ »P1INIT.PAS«
\r
const\r
filrec_max = 256;\r
\r
(* 01.10.91 ebk 1.8 Include files not implemented *)\r
(* 15.10.91 ebk 1.9 RTP3524: More than 6000 names allowed *)\r
(* 18.12.91 ebk 1.10 Update according to corrections made by jaba at RC8000*)\r
(* 28.01.92 ebk 1.11 System switches defined and compilerversion pass6 done*)\r
\r
version=' version 1992.01.23 rel 1.11'; (* OBS OBS OBS OBS OBS OBS OBS *)\r
(* if rel is changed *)\r
(* change compiler_version also *)\r
(* in p6init *)\r
\r
(*global constants used in code*)\r
targetz80='z80 ';\r
target_z80=0; (* option value *)\r
target3502='RC3502/1';\r
target_3502=1; (* option value , default *)\r
target3502c='RC3502/2';\r
target_3502c= 2; (* option value *)\r
pass1_version=701;\r
higherror=110; (* highest error number from code *)\r
\r
reduced_intermediate_language= true; (* if reduced_intermediate_language then\r
suppress output of the following codes:\r
endformal,\r
endcontext,\r
endtype,\r
end,\r
endexpression *)\r
\r
\r
(* bobs-constants*)\r
stackmax=150; (*size of attstack and parsestack *)\r
stringmax=12; (* size of attribute string *)\r
chbufmax=300; (* size of array chbuf *)\r
minch=' '; maxch='~'; (*first/last character in type char*)\r
sp= ' ';\r
testoutput=false; (* do not output the steps in the parse *)\r
dir_testoutput=false;\r
\r
nill= -1;\r
blank=' '; (*to clear a variable of type alfa*)\r
doubleblank = ' ';\r
maxnamelength=255; (* maximum length of a name *)\r
maxspix=65000; (* maximum number of different spix'es *)\r
typebuffersize= 800; (* maximum number of buffered codes *)\r
hashtablesize=41;\r
stop3=3; (* option value to pass3 for stop.3 *)\r
stop4=5; (* option value to pass4 for stop.4 *)\r
stop5=5; (* option value to pass5 for stop.5 *)\r
pres3=6; (* option value to pass3 for preserve.yes *)\r
pres4=7; (* option value to pass4 for preserve.yes *)\r
pres5=12; (* option value to pass5 for preserve.yes *)\r
pres6=6; (* option value to pass6 for preserve.yes *)\r
code5= 4; (* option value to pass5 for suppressing comments, for option code *)\r
code6= 1; (* option value to pass6 for codelist *)\r
surv3= 5; (* option value to pass3 for survey.yes or no *)\r
surv4= 10; (* option value to pass4 for survey.yes or no *)\r
surv5= 6; (* option value to pass5 for survey.yes or no *)\r
surv6= 10; (* option value to pass6 for survey.yes or no *)\r
\r
opt_target_machine=4; (* option value to pass3 for target machine identification *)\r
\r
\r
\r
type\r
filrec = array[1..filrec_max] of integer;\r
\r
(* bobs-types*)\r
chbufinx=0..chbufmax;\r
stackinx=0..stackmax;\r
stringtype=packed array[1..stringmax] of char;\r
\r
(*types used in code*)\r
attributes=record\r
chbufp:chbufinx;\r
bufferstart : 1..typebuffersize; (* start index in type buffer\r
for this element *)\r
oldlabelscope : integer;\r
end;\r
\r
hashindex=0..hashtablesize;\r
namelength=0.. maxnamelength;\r
spixrange=0.. maxspix;\r
\r
nameptr=^ namenode;\r
nameheadptr=^ namehead;\r
\r
namehead=packed record\r
length : namelength;\r
spix : spixrange;\r
start : nameptr; (* first chunk *)\r
next : nameheadptr;\r
end;\r
\r
namenode=packed record\r
next : nameptr;\r
case boolean of\r
true: ( namepart : alfa );\r
false: ( integerpart : integer );\r
(* integerpart is only used by the hash function *)\r
end;\r
\r
(* types concerning compiler directives *)\r
t_cond_directives= (d_if, d_dummy); (* directives saved in directive stack *)\r
\r
t_directive_warnings=\r
(or_operator_expected, end_expected, undefined_switch, unknown_directive,\r
file_does_not_exist,\r
and_expected, right_par_expected, expression_expected, eq_expected, range_error,\r
endif_without_matching_if, elseif_without_matching_if, else_not_after_if_or_elseif);\r
\r
t_sw_assign= (sw_not_defined, sw_assigned, sw_not_assignable);\r
\r
p_switch= ^ t_switch;\r
t_switch= record\r
next_switch: p_switch;\r
name: alfa;\r
val: integer;\r
switch_assigned: t_sw_assign;\r
end;\r
\r
p_dir_record= ^ t_dir_record;\r
t_dir_record= record\r
former_dir, (* double chained list of directives, directive_top denote top element *)\r
next_dir: p_dir_record;\r
dir_kind: t_cond_directives;\r
after_else, (* indicates if ELSE was met, for check against double ELSE and ELSEIF after ELSE *)\r
after_noskip, (* indicates if the IF- or an earlier ELSEIF-expression was true *)\r
surr_skip_state: boolean; (* true means skip text *)\r
end;\r
\r
\r
\r
declarekind=(decl, decllist); (* used by emitdeclare *)\r
codes =\r
(\r
cnocode,\r
cerror, cerrortext, cerrorno,\r
coption,\r
cnewline,\r
ceom,\r
\r
cendstandards,\r
cstandardname,\r
(* parameters to 'standardname' *)\r
canonymous, (* first std name *)\r
cboolean,\r
cchar,\r
cshadow,\r
creference,\r
csemaphore,\r
cson,\r
cprocessrec,\r
cexception,\r
cabs,\r
csucc,\r
cpred,\r
cnew,\r
cnil,\r
cnilref,\r
cchr,\r
cord, (* last std name *)\r
\r
cinclude, cendinclude,\r
ccontext, cerrcontext, cendcontext,\r
\r
cendprefix,\r
\r
cbeginlevel, cendlevel,\r
cdeclaration, cdeclare, cdeclarelist,\r
\r
cexternal, cforward,\r
\r
cendformallist, cendformal,\r
cendprocdecl, cendfuncdecl, cendtypedecl,\r
cendconstantdecl,\r
\r
cnoinit, cinit, cendvardecl,\r
\r
cexport,\r
cexportvalue, cexportsize, cexportdisp, cexportoffset, cexportaddr,\r
\r
cenddeclarations,\r
\r
cstartlabelscope, cendlabelscope,\r
\r
cbegincode, ccodeline, cendcode,\r
\r
cendblock,\r
\r
ctypeid,\r
cendtype,\r
cwithout_data,\r
\r
cnewtype,\r
cendscalar, cendsubrange, cendarray, cendfield, cendrecord, cendset,\r
cendpool, cendpointer, cendreadonly,\r
cendextprocess,\r
cpacked,\r
\r
cbegin, cend,\r
\r
clabeldef,\r
\r
ccasestat, ccaseexpr, ccaselabel, ccaselabelrange, ccaselist,\r
ccaseelement, cotherwise, cendcase,\r
\r
cforstat, cforvar, cup, cdown, cendfor,\r
\r
cifstat, cifexpr, celse, cendif,\r
\r
crepeatstat, cuntil, cendrepeat,\r
cloopstat, ccontloopstat, cexitloopstat, cendloopstat, cexitlock,\r
\r
cwhilestat, cwhileexpr, cendwhile,\r
\r
clockstat, cwithstat, cwithvar,\r
clockmesstat,\r
cnolocaldecl, cendlocaldeclare,\r
cnolocaltype,\r
cwithcomma, cdo, cendwith, cendlock,\r
\r
cgotostat, cendgoto,\r
cexitstat,\r
\r
cchannelstat, cchanvar, cendchannel,\r
\r
cendassign, cendexchange,\r
\r
ccallprocedure,\r
\r
(* expression codes *)\r
cendexpression,\r
ceq, cne, clt, cle, cgt, cge, cin,\r
cuplus, cuminus, cplus, cminus, cor, cxor,\r
cstar, cslash, cdiv, cmod, cand,\r
cshift, cnot,\r
cendvariable,\r
ctypesizecall, cvarsizecall,\r
cindex, (* <<< used internally by pass3 *)\r
\r
(* operand codes *)\r
csetlist, cs_element, cm_element, cendsetlist,\r
cliteral,\r
cid,\r
cskipparam,\r
cfield,\r
cuparrow,\r
crangefirst, (* <<< used internally by pass3 *)\r
crange, (* <<< used internally by pass3 *)\r
\r
cbeginactual, cactualparam, cdoubleparam, cendactual,\r
cbeginstruc, cendstruc,\r
\r
(* the following few lines are all for internal pass3-use *)\r
cfunctrailer, cfunctemp, cerrorarg, cargument,\r
cfcall, cendproc,\r
ccallprocess, cprocessargument,\r
cendprocessparam,\r
cstrucrecord, cstrucarray,\r
\r
(* namekinds i.e. parameters for 'declaration' *)\r
cprocess, cprocedure, cfunction, ctype,\r
cscalarelem, crecfield, cconstant, cvar,\r
cvarp, cvaluep, cfuncval (* <<< used internally by pass3 *),\r
clabel,\r
cprefix,\r
cundeclared (* <<< used internally by pass3 *),\r
\r
\r
(* typekinds *)\r
calias (* <<< used internally by pass3 *),\r
(* typekinds i.e. parameters for 'newtype' *)\r
cerrorkind (* <<< used internally by pass3 *),\r
cscalar, csubrange, carray, crecord, cset, cpool,\r
cpointer, cforwardpointer, creadonly,\r
cextprocess,\r
(* standard types *)\r
cinteger, creal, cniltype,\r
ctext, (* used for string-literals *)\r
\r
clastcode (* used internally by pass1/pass3 *)\r
\r
);\r
\r
codeindex = 0 .. 220; (* greater than number of codes *)\r
(* end pass 1 codes *) \r
\f
\r
\r
\r
\r
t_stat_stack= ^ stat_stack_elem;\r
\r
stat_stack_elem= record\r
next_stat, (* double chained list of nested statements of kind LOCK, LOCKMES, *)\r
former_stat: t_stat_stack; (* CHANNEL and the repetitive statements, used for *)\r
stat_kind: codes; (* proper handling of EXITLOOP, CONTINUELOOP, and EXIT *)\r
end;\r
\r
t_source_stack= ^ source_stack_elem;\r
\r
source_stack_elem= record (* remember source file names and line numbers across the INCLUDE directive *)\r
first_line: integer; (* last read line of surrounding source file before INCLUDE *)\r
errors_marked: boolean; (* for better error informations *)\r
file_name: alfa;\r
former_source, next_source: t_source_stack; (* double chained list of nested sources *)\r
end;\r
\r
text_buf_type = array[1..1024] of char;\r
var\r
in_buf_ptr, spix_buf_ptr: ^text_buf_type;\r
code_filptr :^ filrec;\r
code_fileix : integer;\r
symb_filptr :^ filrec;\r
symb_fileix : integer;\r
exitsave : pointer;\r
i : integer;\r
inputfile : boolean;\r
list_file_name,\r
program_name : alfa; (* name of called program, rtp35021, rtp35022 or pascalz80 *)\r
systemparamno : integer; (* reference to next fp-parameter\r
in the command stack *)\r
top_of_source_stack: t_source_stack;\r
\r
(* variables concerning the compiler directives *)\r
survey_pass1, (* if true a list of switch values is printed *)\r
cond_skip_text: boolean; (* actual mode of text skipping *)\r
directive_top: p_dir_record; (* top element of nested skip conditions *)\r
last_system_switch, (* system switches are not listed in *)\r
(* the survey list *)\r
version_switch, (* pointer to the version switch, *)\r
(* which may be defined in the call *)\r
first_switch: p_switch; (* start of defined switches *)\r
\r
(* bobs-variables*)\r
attstack: array[stackinx] of attributes;\r
chbuf: array[chbufinx] of char;\r
chbufi: chbufinx;\r
convch: array[char] of char;\r
ok: boolean;\r
(*chbuf, chbufi, field chbufp of attributes, tables and ok\r
(*should not be changed by the user *)\r
errormarks : packed array [0..higherror] of boolean;\r
warningcount,\r
errorcount : integer ;\r
line: line_type; (* contains current line *)\r
include_count, (* holds number of nested include directives *)\r
linenumber, (* current global line number *)\r
locallinenumber, (* used to distinguish between declaration and definition of a label *)\r
linelength, (*length of current line*)\r
errorinx, (*position in line of last error mark*)\r
indention, (*number of leading spaces on a line *)\r
lineinx: integer; (*position in line of current ch*)\r
more_sources_allowed, (* true until prefix or process met *)\r
call_pass_3, (* option '$ 1 2 1 ' *)\r
remember_list, (* remember 'programlist' across std environment *)\r
programlist, (* option list.yes or '$ 1 1 1' *)\r
printed: boolean; (*true if current line has been printed*)\r
anonymousspix, (* spix of '?' *)\r
first_spix, (* spix of '_first____rc' *)\r
last_spix, (* spix of '_last_____rc' *)\r
bufsize_spix, (* spix of '_bufsize__rc' *)\r
lastspix, (* highest spix in use *)\r
currentlabelscope, (* the actual label level *)\r
lastlabelscope : integer; (* highest used scope nr *)\r
\r
\r
before_standard_defs ,\r
contextparsing,\r
survey_wanted,\r
nametable_dump : boolean; (* option survey.yes or no *)\r
\r
current_export_kind : codes; (* the kind of an export object *)\r
\r
dimension_count, (* count nested arrays, i.e. the number of dimensions *)\r
\r
\r
saved_lastbuffered, (* used in connection with lock without retyping *)\r
lastbuffered : integer; (* last used element in typebuffer *)\r
typebuffer : array [0..typebuffersize] of integer;\r
typebufferflag : boolean; (* indicates whether the codes are to be buffered or not *)\r
\r
nil_namehead,\r
lastnamehead, (* last used name head *)\r
alias_name, (* remember name node for alias name *)\r
nameheadfreelist : nameheadptr;\r
nil_name,\r
namenodefreelist : nameptr;\r
\r
\r
namehashtable : array [ hashindex ] of nameheadptr;\r
\r
statement_stack_top: t_stat_stack;\r
\r
str_const_top: integer; (* top element of constant string *)\r
string_const: packed array [ 1..maxnamelength ] of 0..255; (* constant string *)\r
\r
(* the global variables used in emit-procedures *)\r
symbfile, codefile : file of filrec;\r
spixtable : text;\r
\r
\f
\r
procedure myexit; forward;\r
procedure stop(n: integer); forward;\r
\r
procedure printline;\r
var i :integer;\r
begin\r
if programlist then\r
begin\r
write(output, linenumber:5,' ');\r
if cond_skip_text then\r
write(output, '--'); (* mark line as skipped *)\r
for i:= 1 to indention do\r
write(output, ' ');\r
for i:= 1 to linelength do write(output, line[i]);\r
writeln(output);\r
end;\r
printed:= true\r
end; (*printline*)\r
\r
procedure warning(n: integer);\r
var i : integer;\r
prgrlst : boolean;\r
begin\r
warningcount:= warningcount+1;\r
errormarks[n]:= true;\r
if not printed then\r
begin\r
prgrlst:= programlist;\r
programlist:= true; (* force printing of erroneous line *)\r
with top_of_source_stack ^ do\r
begin\r
if not errors_marked then\r
begin\r
write(output, 'Source file name: ', file_name);\r
if include_count>0 then\r
write(output, ' Included at line: ', first_line);\r
writeln(output);\r
end;\r
errors_marked:= true;\r
end; (* with top of source stack *)\r
printline;\r
programlist:= prgrlst;\r
end;\r
if errorinx=0 then\r
begin\r
write(output, ' *****');\r
for i:= 1 to indention do\r
write(output, ' ');\r
end;\r
for i:= errorinx to lineinx-2 do write(output, ' ');\r
write(output, '^', n:1);\r
errorinx:= lineinx+3\r
end; (* warning *)\r
\r
procedure markerror(n : integer);\r
var oldwarning : integer;\r
begin\r
errorcount:= errorcount+1;\r
oldwarning:= warningcount;\r
warning(n);\r
warningcount:= oldwarning;\r
end; (* markerror *)\r
\r
procedure printerrors;\r
var\r
i, currenttextno : integer;\r
ch : char;\r
begin\r
(*page(output);*)\r
writeln(output,'number of errors :', errorcount : 4);\r
writeln(output,'number of warnings:', warningcount : 4);\r
writeln(output);\r
writeln(output,'error description');\r
if program_name='rtp35022' then\r
begin (*model 2*)\r
assign(input,concat(rtp35_pathname, i_passx_err2name));\r
end else\r
begin (*model1 or z80*)\r
assign(input,concat(rtp35_pathname, i_passx_err1name));\r
end;\r
\r
settextbuf(input, in_buf_ptr^);\r
(*$I-*)\r
reset(input);\r
if ioresult <> 0 then\r
begin\r
if program_name='rtp35022' then\r
begin\r
nofile(concat(rtp35_pathname, i_passx_err2name));\r
end else\r
nofile(concat(rtp35_pathname, i_passx_err1name));\r
end;\r
(*$I+*)\r
\r
currenttextno:= -1;\r
\r
for i:= currenttextno+1 to higherror do\r
if errormarks[i] then\r
begin\r
\r
(* find the text *)\r
while i>currenttextno do\r
begin\r
if not eoln(input) then readln(input);\r
if not eof(input) then read(input, currenttextno)\r
else currenttextno:= higherror+1;\r
end;\r
\r
write(output,i : 4, ': ');\r
if i<>currenttextno then\r
write(output, ' (no text) ')\r
else\r
while not eoln(input) do\r
begin\r
read(input, ch);\r
write(output,ch);\r
end;\r
writeln(output);\r
end; (* for i:= .... *)\r
\r
end; (* printerrors *)\r
\r
\r
procedure terminate(stop_execution: boolean);\r
var i: integer;\r
heapfree : longint;\r
begin\r
if inputfile then close(input);\r
write(codefile, code_filptr^);\r
close(codefile);\r
write(symbfile, symb_filptr^);\r
close(symbfile);\r
if nametable_dump then\r
for i:= 0 to hashtablesize do\r
begin\r
linenumber:= 0;\r
lastnamehead:= namehashtable [ i ];\r
writeln(spixtable, ' entry number ', i : 1 );\r
while lastnamehead<>nil_namehead do\r
with lastnamehead ^ do\r
begin\r
linenumber:= linenumber+1;\r
writeln(spixtable,linenumber, spix, start ^ . namepart : 14 );\r
lastnamehead:= next;\r
end; (* with *)\r
end; (* for ... *)\r
\r
flush(spixtable);\r
close(spixtable);\r
if survey_pass1 then\r
begin\r
writeln(output, 'Information survey from REAL-TIME PASCAL, pass1 ',\r
version);\r
writeln(output, 'Defined switches:');\r
while first_switch<>last_system_switch do\r
with first_switch^ do\r
begin\r
writeln(output, name: 12, '=', val:9);\r
first_switch := next_switch;\r
end;\r
(* special print of version switch *)\r
with version_switch^ do\r
writeln(output, name:12,'=', val:9,'=', val div 256:3, '.', val mod 256:1);\r
end; (* survey pass1 *)\r
if errorcount>0 then printerrors;\r
if list_file_name <> blank then\r
begin\r
close(output);\r
assign(output,'');\r
append(output);\r
if errorcount > 0 then printerrors;\r
end;\r
if survey_wanted then\r
begin\r
heapfree := memavail;\r
release(heaporg);\r
writeln;\r
writeln(output, 'Heep space used in bytes: ',\r
memavail - heapfree);\r
writeln;\r
end;\r
call_pass_3 := not stop_execution;\r
end; (* terminate program *)\r
\f
\r
procedure outcode(p: integer);\r
begin\r
code_fileix := code_fileix + 1;\r
if code_fileix > filrec_max then\r
begin\r
write(codefile, code_filptr^);\r
code_fileix := 1;\r
end;\r
code_filptr^[code_fileix] := p;\r
end;\r
\r
procedure outsymb(p: integer);\r
begin\r
symb_fileix := symb_fileix + 1;\r
if symb_fileix > filrec_max then\r
begin\r
write(symbfile, symb_filptr^);\r
symb_fileix := 1;\r
end;\r
symb_filptr^[symb_fileix] := p;\r
end;\r
\r
procedure emit( code : codes;\r
param1, param2 : integer;\r
descriptor : codes );\r
\r
var i_code, i_desc: integer;\r
\r
begin\r
\r
i_code := ord(code);\r
i_desc := ord(descriptor);\r
\r
if not typebufferflag then\r
begin\r
if code<>cnocode then outcode(i_code);\r
if param1<>nill then outcode(param1);\r
if param2<>nill then outcode(param2);\r
if descriptor<>cnocode then outcode(i_desc);\r
end;\r
\r
if typebufferflag then\r
begin\r
if typebuffersize-lastbuffered<4 then stop(12); (*fatal error*)\r
if code<>cnocode then\r
begin\r
lastbuffered:= lastbuffered+1;\r
typebuffer[lastbuffered]:= ord(code);\r
end;\r
if param1<>nill then\r
begin\r
lastbuffered:= lastbuffered+1;\r
typebuffer[lastbuffered]:= param1;\r
end;\r
if param2<>nill then\r
begin\r
lastbuffered:= lastbuffered+1;\r
typebuffer[lastbuffered]:= param2;\r
end;\r
if descriptor<>cnocode then\r
begin\r
lastbuffered:= lastbuffered+1;\r
typebuffer[lastbuffered]:= ord(descriptor);\r
end;\r
\r
end; (* buffered mode *)\r
\r
\r
end; (* emit *)\r
\r
\r
procedure emit_typebuffer;\r
var\r
step: integer;\r
begin\r
typebufferflag:= false;\r
for step:= 1 to lastbuffered do\r
emit( cnocode, typebuffer[step], nill, cnocode);\r
lastbuffered:= 0;\r
end; (* emit typebuffer *)\r
\r
\r
procedure emitcode(code : codes );\r
begin\r
emit(code, nill, nill, cnocode);\r
end;\r
\r
\r
procedure emitboth( code : codes ; param1, param2 : integer );\r
var i_code: integer;\r
begin\r
emit(code, param1, param2, cnocode);\r
(* output the code on file for labels *)\r
i_code := ord(code);\r
outsymb(i_code);\r
if param1<>nill then outsymb(param1);\r
if param2<>nill then outsymb(param2);\r
end;\r
\r
\r
\r
procedure emitdeclare(kind : declarekind; spix : integer);\r
var\r
code : codes;\r
\r
begin\r
case kind of\r
decl: code:= cdeclare;\r
decllist: code:= cdeclarelist;\r
end; (* case *)\r
\r
emit(code, spix, nill, cnocode);\r
\r
end; (* emitdeclare *)\r
\r
\r
\r
procedure emitname(name : nameheadptr);\r
(* output the name and the corresponding spix on file spixtable *)\r
\r
var\r
namep : nameptr;\r
\r
begin\r
with name ^ do\r
begin\r
write(spixtable, spix : 4, ' ');\r
namep:= start;\r
end; (* with name *)\r
while namep<>nil_name do\r
with namep ^ do\r
begin\r
write(spixtable, namepart);\r
namep:= next;\r
end; (* while *)\r
writeln(spixtable);\r
\r
end; (* emit name *)\r
\r
procedure emit_source_name;\r
var\r
step: integer;\r
begin\r
if top_of_source_stack<>nil then\r
with top_of_source_stack ^ do\r
for step:= 1 to alfalength div 2 do\r
begin\r
emit(coption, 0, 70+step, cnocode);\r
emit(cnocode, ord(file_name[ step*2-1 ])*256 +\r
ord(file_name[ step*2 ]), nill, cnocode);\r
end;\r
end; (* emit source name *)\r
\r
\r
procedure push_source(line: integer; new_file_name: alfa);\r
begin\r
with top_of_source_stack^ do\r
begin\r
if next_source=nil then\r
begin (* allocate a new element, otherwise reuse an earlier allocated element *)\r
new(next_source);\r
with next_source^ do\r
begin\r
next_source:= nil;\r
former_source:= top_of_source_stack;\r
end;\r
end; (* next source=nil *)\r
top_of_source_stack:= next_source;\r
end; (* with top of source stack *)\r
with top_of_source_stack^ do\r
begin\r
file_name:= new_file_name;\r
errors_marked:= false;\r
first_line:= line;\r
end; (* with *)\r
emit_source_name;\r
end; (* push source *)\r
\r
\r
procedure pop_source(dump_source_name: boolean);\r
begin\r
with top_of_source_stack^ do\r
begin\r
if errors_marked and (former_source<>nil) then\r
former_source^.errors_marked:= false; (* force printing of file name in case of errors *)\r
top_of_source_stack:= former_source;\r
end; (* with *)\r
if dump_source_name then\r
emit_source_name;\r
end; (* pop source *)\r
\r
\r
procedure returnname(name : nameheadptr); forward;\r
\r
\r
\r
function searchname( name : nameheadptr ) : spixrange;\r
\r
(* search the name in the name structure, if not found then\r
insert the name; the function result is the spix which is associated\r
with the name *)\r
\r
var\r
current, former, result : nameheadptr;\r
found : boolean;\r
hashvalue : hashindex;\r
name1, name2 : nameptr;\r
\r
begin\r
hashvalue:= name ^.start ^.integerpart mod hashtablesize;\r
\r
current:= namehashtable[hashvalue];\r
former:= nil_namehead;\r
found:= false;\r
\r
while current<>nil_namehead do\r
with current ^ do\r
begin\r
if length< name ^.length then\r
begin\r
former:= current;\r
current:= next;\r
end\r
else\r
if length= name ^.length then\r
begin (* compare names *)\r
name1:= start;\r
name2:= name ^.start;\r
while name1<>nil_name do\r
with name1 ^ do\r
if namepart<> name2 ^.namepart then\r
name1:= nil_name (* exit, different *)\r
else\r
begin\r
name1:= next;\r
name2:= name2 ^.next;\r
end;\r
\r
if name2=nil_name then (*current=name *)\r
begin\r
found:= true;\r
result:= current;\r
current:= nil_namehead; (* exit *)\r
end\r
else\r
(* different *)\r
begin\r
former:= current; current:= next;\r
end;\r
\r
end (* current length=name length *)\r
\r
else\r
(* current length>name length, i.e. insert *)\r
current:= nil_namehead; (* exit while *)\r
end; (* while current<>nil *)\r
\r
\r
if not found then (* insert *)\r
with name ^ do\r
begin\r
result:= name;\r
lastspix:= lastspix+1;\r
spix:= lastspix;\r
emitname(name);\r
if former=nil_namehead then (* insert name as the first name in the list *)\r
begin\r
next:= namehashtable[hashvalue];\r
namehashtable[hashvalue]:= name;\r
end\r
else (* insert name after 'former' *)\r
begin\r
next:= former ^.next;\r
former ^.next:= name;\r
end;\r
end (* not found *)\r
else\r
returnname(name);\r
\r
(* now result points at the searched name *)\r
searchname:= result ^.spix;\r
\r
end; (* search name *)\r
\r
\r
\r
\r
\r
function getnamehead : nameheadptr;\r
var\r
nameheadp : nameheadptr;\r
\r
begin\r
if nameheadfreelist=nil_namehead then\r
begin\r
new(nameheadp);\r
end\r
else\r
begin\r
nameheadp:= nameheadfreelist;\r
nameheadfreelist:= nameheadp ^.next; (* next keeps the chain of free elements *)\r
end;\r
\r
with nameheadp ^ do\r
begin (* initialize the fields *)\r
length:= 0;\r
start:= nil_name;\r
next:= nil_namehead;\r
spix:= 0;\r
end;\r
\r
getnamehead:= nameheadp;\r
\r
end; (* get name head *)\r
\r
\r
\r
\r
function getnamenode : nameptr;\r
\r
var\r
name : nameptr;\r
\r
begin\r
if namenodefreelist=nil_name then\r
begin\r
new(name);\r
end\r
else\r
begin\r
name:= namenodefreelist;\r
namenodefreelist:= name ^.next;\r
end;\r
\r
with name ^ do\r
begin\r
next:= nil_name;\r
namepart:= blank;\r
end;\r
\r
getnamenode:= name;\r
\r
end; (* get name node *)\r
\r
\r
\r
procedure returnname(name : nameheadptr);\r
\r
(* insert the name head and the name parts into the freelists *)\r
\r
var\r
localnext, namelist : nameptr;\r
\r
begin\r
(* return the head *)\r
name ^.next:= nameheadfreelist;\r
nameheadfreelist:= name;\r
\r
(* return the name part *)\r
\r
namelist:= nameheadfreelist ^.start;\r
while namelist<>nil_name do\r
with namelist ^ do\r
begin\r
localnext:= next;\r
next:= namenodefreelist;\r
namenodefreelist:= namelist;\r
namelist:= localnext;\r
end;\r
\r
end; (* return name *)\r
\r
\r
\r
procedure predef_environment;\r
(* generate code for standard names and standard types *)\r
\r
type\r
double_alfa=packed array [ 1 .. 24 (* 2 * alfalength *) ] of char;\r
\r
\r
var\r
codeword, kind : codes;\r
step, spix, length : integer;\r
\r
\r
function spix_of_name(name : double_alfa) : integer;\r
(* convert the name into internal representation and search\r
the name table for the spix *)\r
var\r
nameheadp : nameheadptr;\r
locallength : integer;\r
\r
begin\r
nameheadp:= getnamehead;\r
\r
with nameheadp ^ do\r
begin\r
start:= getnamenode;\r
with start ^ do\r
begin\r
for locallength:= 1 to alfalength do\r
namepart [ locallength ]:= name [ locallength ] ;\r
\r
if name [ alfalength+1 ]<>' ' then\r
begin\r
next:= getnamenode;\r
with next ^ do\r
for locallength:= 1 to alfalength do\r
namepart [ locallength ]:= name [ alfalength+locallength ] ;\r
end; (* if name [ alfalength+1 ]<>space *)\r
\r
end; (* with start ^ *)\r
\r
locallength:= alfalength * 2;\r
if name<>doubleblank then\r
begin\r
while name[ locallength ]=' ' do\r
locallength:= locallength-1;\r
length:= locallength;\r
spix_of_name:= searchname(nameheadp);\r
end\r
else\r
begin\r
returnname(nameheadp);\r
spix_of_name:= nill;\r
end;\r
\r
end; (* with nameheadp ^ ... *)\r
\r
end; (* spix of name *)\r
\r
\r
procedure standardnames(name : double_alfa; namecode : codes);\r
(*insert the name into the name table and emit:\r
standardname(spix stdname *)\r
var\r
spix : integer;\r
\r
begin\r
spix:= spix_of_name(name);\r
if name='? ' then anonymousspix:= spix;\r
emit( cstandardname, spix, nill, namecode);\r
end;\r
\r
\r
\r
procedure standardtypes(name : double_alfa; typeflag : codes);\r
(* insert the name into the nametable and emit:\r
declaration( type ) declare( spix declnr )\r
newtype( typeflag ) endtypedecl *)\r
\r
var\r
spix : integer;\r
\r
begin\r
spix:= spix_of_name(name);\r
emit( cdeclaration, nill, nill, ctype);\r
emitdeclare(decl, spix);\r
if not reduced_intermediate_language then\r
emitcode(cendformal);\r
emit( cnewtype, nill, nill, typeflag);\r
emitcode(cendtypedecl);\r
end;\r
\r
\r
begin (* predef environment *)\r
(* generate code for the standard names and types (build in types) *)\r
(* note: the name-strings must be in upper case (internal representation) *)\r
standardnames('? ', canonymous);\r
standardnames('SUCC ', csucc);\r
standardnames('PRED ', cpred);\r
standardnames('NEW ', cnew);\r
standardnames('NIL ', cnil);\r
standardnames('NILREF ', cnilref);\r
standardnames('ORD ', cord);\r
standardnames('CHR ', cchr);\r
standardnames('PROCESS_DESCRIPTOR ', cson );\r
standardnames('PROCESSREC ', cprocessrec);\r
standardnames('ABS ', cabs);\r
standardnames('SHADOW ', cshadow);\r
standardnames('REFERENCE ', creference);\r
standardnames('CHAR ', cchar);\r
standardnames('BOOLEAN ', cboolean);\r
standardnames('SEMAPHORE ', csemaphore);\r
standardnames('EXCEPTION ', cexception);\r
\r
emitcode(cendstandards);\r
\r
\r
\r
standardtypes('INTEGER ', cinteger);\r
standardtypes('REAL ', creal);\r
standardtypes('NILTYPE ', cniltype);\r
\r
before_standard_defs:= false;\r
\r
(* find some interesting spixes *)\r
first_spix:= spix_of_name ('_FIRST____RC ');\r
(* used during implicit retyping in lock *)\r
last_spix:= spix_of_name ('_LAST_____RC ');\r
(* used during implicit retyping in lock *)\r
bufsize_spix:= spix_of_name('_BUFSIZE__RC ');\r
(* used during implicit retyping in lock *)\r
\r
end; (* predefine environment *)\r
\f
\r
procedure readcall;\r
(* read the call of the compiler from current input *)\r
const\r
power12=256;\r
equality=6;\r
point=8;\r
yes_or_no= 'yes or no '; (* error text *)\r
number= 'number '; (* error text *)\r
yes_no_file = 'yes/no/file '; (* error text *)\r
list= 'list';\r
yes= 'yes';\r
no= 'no';\r
survey= 'survey';\r
codelist= 'codelist';\r
codesize= 'codesize'; (* option for pass6, the size of a program page *)\r
stop= 'stop'; (* option stop.<pass nr> *)\r
spacing= 'spacing';\r
stack_size= 'stack';\r
pascalz80= 'pascalz80';\r
rtp_model_2= 'rtp35022';\r
z80_lib= 'lib';\r
z80_abs= 'abs';\r
z80_index= 'index';\r
z80_short= 'short';\r
exception= 'exception';\r
measure= 'measure';\r
preserve= 'preserve'; (* preserve.no (default) means remove intermediate files *)\r
call_version= 'version'; (* for setting of version, option to pass 6 *)\r
set_switch= 'set'; (* for setting of switches in the call *)\r
\r
var\r
i,j, int, stop_code, separator, length, version_val1, version_val2: integer;\r
a, codefilename, envfilename, sourcefilename : alfa;\r
date_and_time: datetime; (* converted short clock of source files *)\r
first : boolean;\r
read_env_flag : boolean;\r
param : (list_program, filename, code_size, surveyinfo, stop_param,\r
spacing_param, measureparam, except_param, preserve_param, set_param,\r
version_param, codelist_param, stack_param, index_param,\r
abs_param, lib_param, short_param);\r
switch: p_switch;\r
\r
procedure write_compiler_version;\r
var\r
dat, tim : alfa;\r
var i : integer;\r
begin\r
date(dat); time(tim);\r
write(output, dat);\r
for i := 1 to 10 do write(output,tim[i]);\r
write(output, 'REAL-TIME PASCAL for ');\r
if program_name=rtp_model_2 then\r
write(output, target3502c)\r
else if program_name=pascalz80 then\r
write(output, targetz80)\r
else\r
write(output, target3502);\r
writeln(output, version : 27);\r
end;\r
\r
procedure checkleftside;\r
(* read standard environment, after the call systemparamno is\r
the number of the first input information parameter *)\r
begin\r
systemparamno:= 1;\r
if paramread(systemparamno, int, a) div power12=equality then\r
begin\r
(* left hand side present *)\r
\r
i:= paramread(0, int, codefilename);\r
i:= 1;\r
while i <= alfalength div 2 do\r
begin\r
emit(coption, 6, 80+i, cnocode);\r
emit(cnocode, ord( codefilename [ i * 2-1 ] ) * 256 +\r
ord( codefilename [ i * 2 ] ), nill, cnocode );\r
i := i + 1;\r
end; (* output codefilename *)\r
\r
systemparamno:= systemparamno+1; (* skip name of compiler *)\r
end;\r
i:= paramread( systemparamno-1, int, program_name); (* read compiler name *)\r
if program_name=rtp_model_2 then\r
begin\r
assign_alfa(envfilename, i_pass1_env2name);\r
emit(coption, (* to pass *) 3, opt_target_machine, cnocode);\r
emit(cnocode, target_3502c, nill, cnocode);\r
end\r
else\r
if program_name=pascalz80 then\r
assign_alfa(envfilename, i_pass1_envzname)\r
else\r
assign_alfa(envfilename, i_pass1_env1name);\r
write_compiler_version;\r
end; (* check left side *)\r
\r
\r
\r
procedure error(near_param, expected_param: alfa);\r
\r
procedure out_error;\r
begin\r
writeln(output, '??? error in call of Real-Time Pascal compiler');\r
if near_param<>blank then\r
begin\r
write(output, 'error detected near: ', near_param);\r
if expected_param<>blank then\r
write(output, ', expected: ', expected_param);\r
writeln(output);\r
end;\r
end;\r
\r
procedure out_call_syntax;\r
begin\r
writeln(output, 'Call syntax is:');\r
writeln(output, ' 1 1 1 * ');\r
writeln(output, 'rtp35021 (((=object_file_name)(<s><option>) (<s> file_name) ) ');\r
writeln(output, ' 0 0 0 0');\r
writeln(output, 'object_file_name is a file descriptor describing the backing storage');\r
writeln(output, ' area where the object code is stored, if omitted ');\r
writeln(output, ' "rtppass6.cod" is assumed.');\r
writeln(output, 'file_name is a file descriptor describing the backing storage');\r
writeln(output, ' area where the contexts and source program are stored');\r
writeln(output, ' if omitted current input is assumed.');\r
writeln(output, '<option>::= codesize-<size> ! list-<yes/no/file> ! stop-<pass number>');\r
writeln(output, ' ! spacing-<interval> ! measure-<yes or no> ! exception-<appetite>');\r
writeln(output, ' ! short-<yes or no> ! stack-<appetite> ! codelist-<yes or no>');\r
writeln(output, ' ! survey-<yes or no> ! version-<version no> ! version-<v1-v2>');\r
writeln(output, ' ! version-<v1-v2-v3> ! set-<sw_name-sw_value>! preserve-<yes or no>');\r
writeln(output, ' ! paramin-<paramfile>');\r
end;\r
\r
begin\r
out_error;\r
out_call_syntax;\r
if list_file_name <> blank then\r
begin\r
close(output);\r
assign(output,'');\r
append(output);\r
out_error;\r
out_call_syntax;\r
end;\r
\r
rtphalt( false (* terminate with ok.no *) );\r
end;\r
\r
begin\r
read_env_flag:= systemparamno=nill;\r
if read_env_flag then checkleftside;\r
if inputfile then\r
begin\r
close(input);\r
inputfile:= false;\r
programlist:= remember_list;\r
pop_source(false (* do not emit a source file name *));\r
end;\r
\r
j:= paramread(systemparamno,int,a);\r
first:= true;\r
param:= pred(filename); (* param<>filename *)\r
\r
while ((j mod power12)<>0) and ((j div power12)<>2)\r
and (param<>filename) do\r
begin\r
separator:= j div power12;\r
length:= j mod power12;\r
\r
if first then\r
begin\r
first:= false;\r
if separator=point then error(a, blank)\r
else\r
if a=list then param:= list_program\r
else if a=codesize then param:= code_size\r
else if a=spacing then param:= spacing_param\r
else if a=stop then param:= stop_param\r
else if a=survey then param:= surveyinfo\r
else if a=stack_size then param:= stack_param\r
else if a=codelist then param:= codelist_param\r
else if a=z80_lib then param:= lib_param\r
else if a=z80_abs then param:= abs_param\r
else if a=z80_index then param:= index_param\r
else if a=z80_short then param:= short_param\r
else if a=measure then param:= measureparam\r
else if a=exception then param:= except_param\r
else if a=preserve then param:= preserve_param\r
else if a=call_version then param:= version_param\r
else if a=set_switch then\r
begin\r
param:= set_param;\r
switch:= nil; (* prepared for a name, when not nil a value is expected *)\r
end\r
else\r
begin\r
param:= filename;\r
sourcefilename:= a;\r
end;\r
end\r
else\r
begin\r
first:= true;\r
if (separator<>point) and (param<>filename) then error(a, '. ')\r
else\r
case param of\r
list_program:if length<>10 then error(list, yes_no_file)\r
else\r
begin\r
programlist:= a<>no;\r
remember_list:= programlist;\r
if (a<>no) and (a<>yes) then\r
begin\r
list_file_name := a;\r
assign(output, list_file_name);\r
rewrite(output);\r
write_compiler_version;\r
end;\r
end;\r
\r
stop_param:\r
if length<>4 then error(stop, number)\r
else (* generate an option for the pass to stop after *)\r
if (int=3) or (int=4) or (int=5) then\r
begin\r
case int of\r
3: stop_code:= stop3;\r
4: stop_code:= stop4;\r
5: stop_code:= stop5;\r
end; (* case *)\r
emit(coption, int, nill, cnocode);\r
emit(cnocode, stop_code, 0, cnocode);\r
end (* 3, 4, 5 *)\r
else\r
if (int=1) or (int=2) then\r
call_pass_3:= false;\r
\r
set_param: (* syntax is set.switch_name.switch_value *)\r
begin\r
if length=10 then (* name *)\r
if switch<>nil then (* name after name *)\r
error(set_switch, number(* expected *))\r
else\r
begin\r
first:= false; (* do not change param, but read one parameter more *)\r
new(switch);\r
for int := 1 to alfalength do a[int] := upcase(a[int]);\r
switch^.name:= copy(concat(a,' '),1,alfalength);\r
end (* legal name *)\r
else (* length=4, i.e. number *)\r
if switch=nil then\r
error(set_switch, 'switch_name ')\r
else\r
with switch^ do\r
begin\r
val:= int;\r
next_switch:= first_switch; (* start of defined switches chain *)\r
first_switch:= switch;\r
end; (* legal number *)\r
end; (* set switch *)\r
\r
preserve_param:\r
if length<>10 then error(preserve, yes_or_no)\r
else\r
if (a<>yes) and (a<>no) then error(preserve, yes_or_no)\r
else\r
if a=yes then\r
begin (* signal preserve.yes to the following passes *)\r
emit(coption, 3, nill, cnocode);\r
emit(cnocode, pres3, 1, cnocode); (* option preserve.yes *)\r
emit(coption, 4, nill, cnocode);\r
emit(cnocode, pres4, 1, cnocode); (* option preserve.yes *)\r
emit(coption, 5, nill, cnocode);\r
emit(cnocode, pres5, 1, cnocode); (* option preserve.yes *)\r
emit(coption, 6, nill, cnocode);\r
emit(cnocode, pres6, 1, cnocode); (* option preserve.yes *)\r
end; (* emit options preserve.yes *)\r
\r
surveyinfo: begin\r
if (length=10) and ((a=yes) or (a=no)) then\r
int:= ord( a=yes )\r
else error(survey, yes_or_no);\r
survey_wanted := int >= 1;\r
emit( coption, 6, surv6, cnocode ); (* generate statistics in pass 6 *)\r
emit( cnocode, int, nill, cnocode );\r
emit( coption, 3, surv3, cnocode); (* produce statistical information about *)\r
emit( cnocode, ord(int>=1), nill, cnocode); (* maximum size of dynamic structures *)\r
emit( coption, 4, surv4, cnocode); (* produce statistical information about *)\r
emit( cnocode, ord(int>=1), nill, cnocode); (* maximum size of dynamic structures *)\r
emit( coption, 5, surv5, cnocode); (* produce survey information about *)\r
emit( cnocode, ord(int>=1), nill, cnocode); (* routines and processes, default is survey.no *)\r
survey_pass1 := int=1;\r
end;\r
\r
version_param: if length<>4 then error(call_version, number)\r
else\r
begin\r
version_val1:= int;\r
j:= paramread(systemparamno+1, int, a);\r
if j=4 (* number *)+ power12*point then (* version.v1.v2 *)\r
begin\r
version_val2:= int;\r
systemparamno:= systemparamno+1;\r
j:= paramread(systemparamno+1, int, a);\r
if j=4 (* number *)+ power12*point then (* version.v1.v2.v3 *)\r
if (version_val2<10) and (int<10) then\r
begin\r
systemparamno:= systemparamno+1;\r
version_val1:= (version_val1*10+version_val2)*10+int;\r
end\r
else\r
begin\r
systemparamno:= systemparamno+ord(version_val2<10); (* point at wrong parameter *)\r
error(call_version, '0..9 ');\r
end\r
else\r
begin\r
if (version_val1<256) and (version_val2<256) then\r
version_val1:= version_val1*256+version_val2\r
else\r
begin\r
systemparamno:= systemparamno-ord(version_val2<256);\r
error(call_version, '0..255 ');\r
end;\r
end;\r
end;\r
if version_val1<65536 then\r
with version_switch^ do\r
begin\r
emit(coption, 6, 15, cnocode); (* !!!! must be as defined by pass6 !!! *)\r
emit(cnocode, version_val1, nill, cnocode);\r
if switch_assigned = sw_not_assignable then\r
error(call_version, 'not multiple');\r
val:= version_val1;\r
switch_assigned := sw_not_assignable;\r
end\r
else\r
error(call_version, '0..65535 ');\r
end; (* version *)\r
\r
\r
code_size:\r
if length<>4 then error(codesize, number)\r
else\r
begin\r
emit(coption, 6, 3, cnocode); (* !!!! must be as defined by pass6 !!! *)\r
emit(cnocode, int, nill, cnocode);\r
end;\r
\r
except_param:\r
if length<>4 then error(exception, number)\r
else\r
begin\r
emit (coption, 5, 7, cnocode);\r
emit (cnocode, int, nill, cnocode);\r
end;\r
\r
lib_param: (* z80 library information *)\r
if length<>10 then error(z80_lib, '<filename> ')\r
else\r
for i:= 1 to alfalength div 2 do\r
begin\r
emit(coption, 5, 80+i, cnocode );\r
emit(cnocode, ord( a [ i * 2-1 ] ) * 256 +\r
ord( a [ i * 2 ] ), nill, cnocode);\r
end; (* output lib file name *)\r
\r
stack_param: (* rc3502 default create size *)\r
if length<>4 then error(stack_size, number)\r
else (* generate option 5, 10, int *)\r
begin\r
emit( coption, 5, 10, cnocode );\r
emit( cnocode, int, nill, cnocode );\r
end;\r
\r
abs_param: if length<>10 then error(z80_abs, yes_or_no)\r
else\r
if (a=yes) or (a=no) then\r
begin\r
if a=yes then\r
begin\r
emit(coption, 6, 8, cnocode); (* for z80 pass6 *)\r
emit(cnocode, 1, nill, cnocode);\r
end;\r
end\r
else error(z80_abs, yes_or_no);\r
\r
index_param: if length<>10 then error(z80_index, yes_or_no)\r
else\r
if (a=yes) or (a=no) then\r
begin\r
emit(coption, 4, 9, cnocode); (* for z80 pass4 *)\r
emit(cnocode, ord( a=yes ), nill, cnocode);\r
end\r
else error(z80_index, yes_or_no);\r
\r
short_param: if length<>10 then error(z80_short, yes_or_no)\r
else\r
if (a=yes) or (a=no) then\r
begin\r
if program_name=pascalz80 then\r
emit(coption, 5, 11, cnocode) (* for z80 pass5 *)\r
else\r
emit(coption, 6, 13, cnocode); (* for lambda pass6 *)\r
emit(cnocode, ord( a=yes ), nill, cnocode);\r
end\r
else error(z80_short, yes_or_no);\r
\r
codelist_param:\r
if length<>10 then error(codelist, yes_or_no)\r
else\r
if (a=yes) or (a=no) then\r
begin\r
emit( coption, 5, code5, cnocode ); (* generate pass5-comments *)\r
emit( cnocode, 1-ord( a=yes ), nill, cnocode );\r
emit( coption, 6, code6, cnocode ); (* generate code listing in pass6 if yes *)\r
emit( cnocode, ord( a=yes ), nill, cnocode );\r
end\r
else error(codelist, yes_or_no);\r
\r
measureparam:\r
if length<>10 then error(measure, yes_or_no)\r
else\r
if (a=yes) or (a=no) then\r
begin\r
emit( coption, 5, 11, cnocode ); (* generate trap instructions *)\r
emit( cnocode, ord(a=yes), nill, cnocode );\r
end\r
else error(measure, yes_or_no);\r
\r
spacing_param:\r
if length<>4 then error(spacing, number)\r
else\r
begin\r
emit(coption, 6, 9, cnocode); (* must be as defined by pass6 !!! *)\r
emit(cnocode, int, nill, cnocode);\r
end;\r
\r
filename:\r
systemparamno:= systemparamno-1; (* make the next increment dummy *)\r
\r
end; (* case *)\r
end; (* second *)\r
systemparamno:= systemparamno+1;\r
if param <> filename then j:= paramread(systemparamno,int,a);\r
end;\r
if read_env_flag then\r
begin\r
sourcefilename:= envfilename;\r
if param=filename then\r
systemparamno:= systemparamno-1 (* do not skip file name *)\r
else\r
param:= filename; (* force open call *)\r
end;\r
\r
if param=filename then\r
begin\r
if read_env_flag then\r
begin\r
programlist:= false; (* do not list standard environment *)\r
assign(input, concat(rtp35_pathname, sourcefilename));\r
end else\r
begin\r
assign(input, concat(source_path, sourcefilename));\r
if survey_wanted then\r
begin\r
writeln(' file: ', concat(source_path, sourcefilename));\r
end;\r
end;\r
settextbuf(input, in_buf_ptr^);\r
\r
(*$I-*)\r
reset(input);\r
if ioresult <> 0 then\r
begin\r
if read_env_flag then\r
begin\r
nofile(concat(rtp35_pathname, sourcefilename));\r
end else\r
nofile(concat(source_path, sourcefilename));\r
end;\r
(*$I+*)\r
inputfile:= true;\r
(* tell sourcefile name as options *)\r
push_source(linenumber, sourcefilename);\r
filetime(input, date_and_time);\r
with date_and_time do\r
begin\r
emit(coption, 0, 81, cnocode);\r
emit(cnocode, year, nill, cnocode);\r
emit(coption, 0, 82, cnocode);\r
emit(cnocode, month, nill, cnocode);\r
emit(coption, 0, 83, cnocode);\r
emit(cnocode, day, nill, cnocode);\r
emit(coption, 0, 84, cnocode);\r
emit(cnocode, hour, nill, cnocode);\r
emit(coption, 0, 85, cnocode);\r
emit(cnocode, min, nill, cnocode);\r
end;\r
end;\r
\r
end; (* read call *)\r
\r
\r
procedure initialize;\r
const\r
sw_i86_val= 110;\r
sw_rc3502_val= 120;\r
sw_ta_val= 130;\r
sw_rtp3502_val= 210;\r
sw_rtp86_val= 220;\r
sw_rtp_val= 230;\r
sw_rtp8000_val= 240;\r
var\r
ch:char;\r
step : integer;\r
switch: p_switch;\r
cur_clock: datetime;\r
\r
begin\r
\r
getclock(cur_clock);\r
\r
(* initialize global variables and open files *)\r
\r
for ch := ' ' to 'Ђ' do\r
if (ch >= 'a') and (ch >= 'є') then\r
convch[ch] := chr(ord(ch) - (ord('a') - ord('A')))\r
else\r
convch[ch] := ch;\r
\r
systemparamno:= nill;\r
include_count:= 0;\r
new(top_of_source_stack);\r
with top_of_source_stack^ do\r
begin\r
former_source:= nil;\r
next_source:= nil;\r
errors_marked:= false;\r
first_line:= 1;\r
file_name:= ' '; (* current input *)\r
end; (* with top of source stack *)\r
\r
more_sources_allowed:= true;\r
inputfile:= false; (* inputfile met in the call *)\r
programlist:= false; (* list.no is default *)\r
remember_list:= programlist;\r
\r
cond_skip_text:= false; (* $IF false assumed *)\r
new(directive_top);\r
with directive_top^ do (* initialize bottom element of stack for nested directives,\r
only $IFs are pushed *)\r
begin\r
former_dir:= nil;\r
next_dir:= nil;\r
dir_kind:= d_dummy; (* stop mark different from d_if *)\r
surr_skip_state:= false;\r
after_else:= false;\r
after_noskip:= true;\r
end;\r
\r
survey_pass1:= false;\r
first_switch:= nil; (* empty chain of defined switches *)\r
(* define the predefined switches *)\r
new(switch);\r
with switch^ do\r
begin\r
name:= 'VERSION '; (* value of $VERSION switch *)\r
val:= 0;\r
switch_assigned:= sw_not_defined;\r
next_switch:= first_switch; (* include in chain *)\r
first_switch:= switch;\r
version_switch:= first_switch;\r
end;\r
(* switch names and switch values which must be *)\r
(* known by all RTP compilers *)\r
new(switch);\r
with switch^ do\r
begin\r
name:= 'FALSE ';\r
val:= 0;\r
switch_assigned:= sw_not_assignable;\r
next_switch:= first_switch; (* include in chain *)\r
first_switch:= switch;\r
end;\r
new(switch);\r
with switch^ do\r
begin\r
name:= 'TRUE ';\r
val:= 1;\r
switch_assigned:= sw_not_assignable;\r
next_switch:= first_switch; (* include in chain *)\r
first_switch:= switch;\r
end;\r
new(switch);\r
with switch^ do\r
begin\r
name:= 'i86 ';\r
val:= sw_i86_val;\r
switch_assigned:= sw_not_assignable;\r
next_switch:= first_switch; (* include in chain *)\r
first_switch:= switch;\r
end;\r
new(switch);\r
with switch^ do\r
begin\r
name:= 'RC3502 ';\r
val:= sw_rc3502_val;\r
switch_assigned:= sw_not_assignable;\r
next_switch:= first_switch; (* include in chain *)\r
first_switch:= switch;\r
end;\r
new(switch);\r
with switch^ do\r
begin\r
name:= 'TA ';\r
val:= sw_ta_val;\r
switch_assigned:= sw_not_assignable;\r
next_switch:= first_switch; (* include in chain *)\r
first_switch:= switch;\r
end;\r
new(switch);\r
with switch^ do\r
begin\r
name:= 'RTP3502 ';\r
val:= sw_rtp3502_val;\r
switch_assigned:= sw_not_assignable;\r
next_switch:= first_switch; (* include in chain *)\r
first_switch:= switch;\r
end;\r
new(switch);\r
with switch^ do\r
begin\r
name:= 'RTP86 ';\r
val:= sw_rtp86_val;\r
switch_assigned:= sw_not_assignable;\r
next_switch:= first_switch; (* include in chain *)\r
first_switch:= switch;\r
end;\r
new(switch);\r
with switch^ do\r
begin\r
name:= 'RTP ';\r
val:= sw_rtp_val;\r
switch_assigned:= sw_not_assignable;\r
next_switch:= first_switch; (* include in chain *)\r
first_switch:= switch;\r
end;\r
new(switch);\r
with switch^ do\r
begin\r
name:= 'RTP2111 ';\r
val:= sw_rtp8000_val;\r
switch_assigned:= sw_not_assignable;\r
next_switch:= first_switch; (* include in chain *)\r
first_switch:= switch;\r
end;\r
new(switch);\r
with switch^ do\r
begin\r
name:= 'TARGET '; (* target computer , set to rc3502 *)\r
val:= sw_rc3502_val;\r
switch_assigned:= sw_not_assignable;\r
next_switch:= first_switch; (* include in chain *)\r
first_switch:= switch;\r
end;\r
new(switch);\r
with switch^ do\r
begin\r
name:= 'LANGUAGE '; (* language dialect *)\r
val:= sw_rtp3502_val;\r
switch_assigned:= sw_not_assignable;\r
next_switch:= first_switch; (* include in chain *)\r
first_switch:= switch;\r
end;\r
new(switch);\r
with switch^ do\r
begin\r
name:= 'NOT '; (* operator picked up as a switch name *)\r
val:= 0;\r
switch_assigned:= sw_not_assignable;\r
next_switch:= first_switch; (* include in chain *)\r
first_switch:= switch;\r
end; (* insert operator as switch *)\r
new(switch);\r
with switch^ do\r
begin\r
name:= 'AND '; (* operator picked up as a switch name *)\r
val:= 0;\r
switch_assigned:= sw_not_assignable;\r
next_switch:= first_switch; (* include in chain *)\r
first_switch:= switch;\r
end; (* insert operator as switch *)\r
new(switch);\r
with switch^ do\r
begin\r
name:= 'XOR '; (* operator picked up as a switch name *)\r
val:= 0;\r
switch_assigned:= sw_not_assignable;\r
next_switch:= first_switch; (* include in chain *)\r
first_switch:= switch;\r
end; (* insert operator as switch *)\r
new(switch);\r
with switch^ do\r
begin\r
name:= 'OR '; (* operator picked up as a switch name *)\r
val:= 0;\r
switch_assigned:= sw_not_assignable;\r
next_switch:= first_switch; (* include in chain *)\r
first_switch:= switch;\r
end; (* insert operator as switch *)\r
(* end of system switches *)\r
last_system_switch := first_switch;\r
\r
call_pass_3:= true; (* automatical call of pass3 if no errors detected *)\r
locallinenumber:= -1;\r
linenumber:= 0;\r
for step:= 0 to higherror do\r
errormarks[step]:= false;\r
errorcount:= 0;\r
warningcount:= 0;\r
\r
lastspix:= 0;\r
lastlabelscope:= 0;\r
currentlabelscope:= lastlabelscope;\r
\r
survey_wanted := false;\r
nametable_dump:= false; (* survey.no *)\r
\r
lastbuffered:= 0;\r
saved_lastbuffered:= 0;\r
typebufferflag:= false;\r
\r
new(nil_namehead);\r
nil_namehead^.next:= nil;\r
nameheadfreelist:= nil_namehead;\r
new(nil_name);\r
nil_name^.next:= nil;\r
namenodefreelist:= nil_name;\r
\r
for step:= 0 to hashtablesize do\r
namehashtable[step]:= nil_namehead;\r
\r
new(statement_stack_top);\r
with statement_stack_top^ do\r
begin\r
former_stat:= nil;\r
next_stat:= nil;\r
stat_kind:= cnocode; (* dummy bottom element different from lock and channel *)\r
end;\r
\r
new(code_filptr);\r
code_fileix := 0;\r
new(symb_filptr);\r
symb_fileix := 0;\r
assign(symbfile,concat(path1_name, o_pass1_symbname)); rewrite(symbfile);\r
assign(codefile,concat(path1_name, o_pass1_codename)); rewrite(codefile);\r
assign(spixtable,concat(path1_name,o_pass1_spixname));\r
settextbuf(spixtable,spix_buf_ptr^);\r
rewrite(spixtable);\r
\r
(* force generation of code for the predefined names and types *)\r
before_standard_defs:= true;\r
\r
(* ourput version number as option( 0, 1, pass1_version ) *)\r
emit(coption, 0, 1, cnocode);\r
emit(cnocode, pass1_version, nill, cnocode);\r
(* output time of start as options 141 through 146 to pass6 *)\r
with cur_clock do\r
begin\r
emit(coption, 6, 141, cnocode);\r
emit(cnocode, year, nill, cnocode);\r
emit(coption, 6, 142, cnocode);\r
emit(cnocode, month, nill, cnocode);\r
emit(coption, 6, 143, cnocode);\r
emit(cnocode, day, nill, cnocode);\r
emit(coption, 6, 144, cnocode);\r
emit(cnocode, hour, nill, cnocode);\r
emit(coption, 6, 145, cnocode);\r
emit(cnocode, min, nill, cnocode);\r
emit(coption, 6, 146, cnocode);\r
emit(cnocode, sec, nill, cnocode);\r
end; (* cur clock *)\r
\r
end;\r
\r
«eof»