⟦22f317609⟧

TextFile

\r
program printpass1(output, testin);\r
uses dos, rtpunit;\r
\r
label 5;\r
type \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..210;\r
txtcodetype = array [codeindex] of alfa;\r
var\r
convcodes : array [codeindex] of codes;\r
testin : file of integer;\r
actcode : codes;\r
output_open, first : boolean;\r
from_line, to_line, line,\r
decl, spix, intcode, sort : integer;\r
printmode,\r
prelude, names_out, ok: boolean;\r
const\r
textcodes : txtcodetype = (\r
'nocode',\r
'error', 'errortext', 'errorno',\r
'option',\r
'newline',\r
'eom',\r
\r
'endstandards',\r
'standardname',\r
\r
'anonymous', \r
'boolean',\r
'char',\r
'shadow',\r
'reference',\r
'semaphore',\r
'son',\r
'processrec',\r
'exception',\r
'abs',\r
'succ',\r
'pred',\r
'new',\r
'nil',\r
'nilref',\r
'chr',\r
'ord',       \r
\r
'include', 'endinclude',\r
'context', 'errcontext', 'endcontext',\r
\r
'endprefix',\r
\r
'beginlevel', 'endlevel',\r
'declaration', 'declare', 'declarelist',\r
\r
'external', 'forward',\r
\r
'endformallist', 'endformal',\r
'endprocdecl', 'endfuncdecl', 'endtypedecl',\r
'endconstantdecl',\r
\r
'noinit', 'init', 'endvardecl',\r
\r
'export',\r
'exportvalue', 'exportsize', 'exportdisp', 'exportoffset', 'exportaddr',\r
\r
'enddeclarations',\r
\r
'startlabelscope', 'endlabelscope',\r
\r
'begincode', 'codeline', 'endcode',\r
\r
'endblock',\r
\r
'typeid',\r
'endtype',\r
'without_data',\r
\r
'newtype',\r
'endscalar', 'endsubrange', 'endarray', 'endfield', 'endrecord', 'endset',\r
'endpool', 'endpointer', 'endreadonly',\r
'endextprocess',\r
'packed',\r
\r
'begin', 'end',\r
\r
'labeldef',\r
\r
'casestat', 'caseexpr', 'caselabel', 'caselabelrange', 'caselist',\r
'caseelement', 'otherwise', 'endcase',\r
\r
'forstat', 'forvar', 'up', 'down', 'endfor',\r
\r
'ifstat', 'ifexpr', 'else', 'endif',\r
\r
'repeatstat', 'until', 'endrepeat',\r
'loopstat', 'contloopstat', 'exitloopstat', 'endloopstat', 'exitlock',\r
\r
'whilestat', 'whileexpr', 'endwhile',\r
\r
'lockstat', 'withstat', 'withvar',\r
'lockmesstat',\r
'nolocaldecl', 'endlocaldeclare',\r
'nolocaltype',\r
'withcomma', 'do', 'endwith', 'endlock',\r
\r
'gotostat', 'endgoto',\r
'exitstat',\r
\r
'channelstat', 'chanvar', 'endchannel',\r
\r
'endassign', 'endexchange',\r
\r
'callprocedure',\r
\r
\r
'endexpression',\r
'eq', 'ne', 'lt', 'le', 'gt', 'ge', 'in',\r
'uplus', 'uminus', 'plus', 'minus', 'or', 'xor',\r
'star', 'slash', 'div', 'mod', 'and',\r
'shift', 'not',\r
'endvariable',\r
'typesizecall', 'varsizecall',\r
'index', \r
\r
\r
'setlist', 's_element', 'm_element', 'endsetlist',\r
'literal',\r
'id',\r
'skipparam',\r
'field',\r
'uparrow',\r
'rangefirst', \r
'range',      \r
\r
'beginactual', 'actualparam', 'doubleparam', 'endactual',\r
'beginstruc', 'endstruc',\r
\r
\r
'functrailer', 'functemp', 'errorarg', 'argument',\r
'fcall', 'endproc',\r
'callprocess', 'processargument',\r
'endprocessparam',\r
'strucrecord', 'strucarray',\r
\r
\r
'process', 'procedure', 'function', 'type',\r
'scalarelem', 'recfield', 'constant', 'var',\r
'varp', 'valuep', 'funcval' ,\r
'label',\r
'prefix',\r
'undeclared' ,\r
\r
\r
\r
'alias' ,\r
\r
'errorkind' ,\r
'scalar', 'subrange', 'array', 'record', 'set', 'pool',\r
'pointer', 'forwardpointer', 'readonly',\r
'extprocess',\r
\r
'integer', 'real', 'niltype',\r
'text', \r
\r
'lastcode' \r
\r
);\r
 \r
\r
procedure get_parameters;\r
const\r
equal = 6; space = 4; dot = 8;\r
name  = 10; int = 4;\r
power12 = 256;\r
\r
var\r
i, sep, paramno: integer;\r
id: alfa;\r
(* output_open: boolean; *)\r
\r
procedure paramerror;\r
begin\r
if output_open then\r
begin\r
close(output);\r
output_open:= false;\r
end;\r
write(output, '*** printpass1, param error ');\r
repeat\r
if sep div power12 = space then\r
write (output, ' ')\r
else\r
write (output, '.');\r
if sep mod power12 = name then\r
write (output, id)\r
else\r
write (output, i:1);\r
paramno := paramno + 1;\r
sep := paramread\r
(paramno, i, id);\r
if sep = 0 then sep := space * power12;\r
until sep div power12 = space;\r
writeln (output);\r
ok:= false;\r
paramno := paramno - 1;\r
end;\r
\r
function getint : integer;\r
var\r
p: integer;\r
begin\r
p := paramread (paramno + 1, i, id);\r
if p = dot * power12 + int then\r
begin\r
getint := i;\r
paramno := paramno + 1;\r
end\r
else\r
begin\r
paramerror;\r
getint := 0;\r
end;\r
end;\r
\r
begin (* body of getparams *)\r
ok := true;\r
sep := paramread (1, i, id);\r
if sep div power12 = equal then\r
begin\r
sep := paramread (0, i, id);\r
assign (output, id);\r
rewrite (output);\r
output_open:= true;\r
paramno := 2;\r
end\r
else\r
begin\r
output_open:= false;\r
paramno := 1;\r
end;\r
sep := paramread (paramno, i, id);\r
\r
while sep > 0 do\r
begin\r
if sep <> space * power12 + name then\r
paramerror\r
else\r
begin\r
if id = 'prelude     ' then prelude := true\r
else\r
if id = 'names       ' then names_out := true\r
else\r
if id = 'from        ' then from_line := getint\r
else\r
if id = 'to          ' then to_line := getint\r
else\r
paramerror;\r
end;\r
paramno := paramno + 1;\r
sep := paramread (paramno, i, id);\r
end;\r
if not ok then\r
begin\r
writeln(output, ' call syntax is:');\r
writeln(output, '(outfile =)printpass1 (prelude) (from.from-line) (to.to-line) (names) ');\r
writeln(output, 'prelude means: print code of contexts');\r
writeln(output, 'names   means: list correspondence between code numbers and names ');\r
writeln(output, 'from-line and to-line denote an interval of lines');\r
end; (* not ok *)\r
end;\r
\r
begin (* main program *)\r
from_line := 0; to_line := 32000; line := 1;\r
prelude := false; names_out := false;\r
\r
get_parameters;\r
if ok then\r
\r
begin\r
\r
for actcode := cnocode to clastcode do\r
begin\r
convcodes[ord(actcode)] := actcode;\r
if names_out then\r
writeln (output, ord(actcode):3, ' = ', textcodes [ ord (actcode) ]);\r
end;\r
(*if names_out then\r
page (output);*)\r
\r
\r
first := true;\r
\r
5: if first then\r
assign(testin,'rtppass1.cod')\r
else assign(testin,'rtppass1.sym');\r
reset(testin);\r
\r
while not eof(testin) do\r
begin\r
printmode:= prelude and (line>=from_line) and (line<=to_line);\r
read(testin, intcode);\r
case convcodes\r
\r
[intcode] of\r
\r
cliteral: begin\r
read(testin, intcode, sort); \r
if printmode then\r
write(line, ': ','literal( ', textcodes[intcode]:8, ', ', sort:2,', <:');\r
for spix := 1 to sort do \r
begin read(testin,decl); \r
if printmode then\r
if (decl<ord(' ')) or (decl>126) then\r
write('<',decl: 1,'>') else\r
write(chr(decl)); end; \r
if printmode then write(':>)');\r
end;\r
\r
ccodeline: begin\r
read(testin, sort);\r
if printmode then\r
write(line, ': ','codeline ( ', sort : 1, ' ): ');\r
for sort := sort downto 1 do\r
begin\r
read(testin, decl); \r
if printmode then\r
write(chr( decl ) );\r
end;\r
end;\r
\r
ctypesizecall, cvarsizecall,\r
ccontext,cfield, cid, ctypeid: begin read(testin,spix); \r
if printmode then\r
write(line, ': ',textcodes[intcode]:7,'( ',spix:2,' )');\r
end;\r
\r
cdeclaration: begin read(testin, intcode);\r
if printmode then\r
write(line, ': ','declaration( ', textcodes[intcode]:10,') ');\r
end; \r
cdeclarelist, cdeclare: begin\r
read(testin,spix); \r
if printmode then\r
write(line, ': ',textcodes[intcode],'( ',spix:3,' )'); end;\r
\r
clabeldef: begin\r
read(testin, sort, spix);\r
if printmode then\r
write(line, ': ', 'labeldef( ',sort:2,spix:4,' )');\r
end; \r
\r
cstartlabelscope,cendlabelscope: begin\r
read(testin,decl); \r
if printmode then\r
write(line, ': ',textcodes[intcode],'( ',decl:3,' )');\r
end;\r
\r
cnewline: begin\r
read(testin, line); \r
printmode:= false;\r
end; \r
\r
coption: begin\r
read(testin, spix, sort, intcode);\r
write(line, ': ','option (', spix:3, ', ', sort:3, ', ', intcode:3, ')');\r
printmode:= true;\r
end;\r
\r
cendinclude:\r
begin\r
if printmode then\r
write(line, ': ','endinclude');\r
prelude:= true;\r
end;\r
\r
cstandardname: begin \r
read(testin, spix, intcode); \r
if printmode then\r
write(line, ': ','standardname( ',spix:3,', ',textcodes[intcode],')');\r
end; \r
\r
cnewtype: begin read(testin, intcode); \r
if printmode then\r
write(line, ': ','newtype( ', textcodes[intcode], ')' ); end;\r
\r
cexitlock, cexitloopstat, ccontloopstat: begin\r
if printmode then\r
write(line, ': ', textcodes[ intcode ]);\r
read(testin, intcode);\r
if printmode then\r
write('( ', textcodes[ intcode ], ')');\r
end;\r
\r
else\r
if printmode then\r
write(line, ': ',textcodes[intcode]);\r
end; (* case *)\r
\r
if printmode then\r
writeln;\r
\r
end; (* while *)\r
\r
if first then begin first := false; \r
(*page(output)*); goto 5; end;\r
end; (* if get params *)\r
\r
if output_open then\r
close(output);\r
end.\r
«eof»
DataMuseum.dk

DANOSI

⟦22f317609⟧ TextFile

Derivation

TextFile
