|
DataMuseum.dkPresents historical artifacts from the history of: RC4000/8000/9000 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about RC4000/8000/9000 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 73728 (0x12000)
Types: TextFile
Names: »tptoa«
└─⟦00964e8f7⟧ Bits:30007478 RC8000 Dump tape fra HCØ.
└─⟦b2ec5d50f⟧
└─⟦this⟧ »tptoa«
begin
procedure writetest(text);
integer array text;
begin
integer i,j,k;
j:=system(3,k,text);
for i:=j,i+1 while i<=k and text(i-1) <> 0 do
begin
outchar(out,if text(i) = 0 then 38 else text(i));
end;
if text(i-1) <> 0 then outchar(out,37);
end writetest;
procedure writetesti(text,j);
value j; integer j; integer array text;
begin
integer i,k;
system(3,k,text);
for i:=j,i+1 while i<=k and text(i-1) <> 0 do
begin
outchar(out,if text(i) <> 0 then text(i) else 38);
end;
if text(i-1) <> 0 then outchar(out,37);
end writetesti;
procedure writetestnl(textstring);
string textstring;
begin
write(out,<:<10>:>,textstring,<:<58>:>);
end writetestnl;
procedure writetestno(number);
value number; integer number;
begin
write(out,number);
end writetestno;
procedure writetestchar(char);
value char; integer char;
begin
if char > 32 and char < 127 then
outchar(out,char)
else
write(out,false add 34,1,<<zdd>,char,false add 34,1);
end writetestchar;
integer searchtablelength,
ntablength,
stdlinelength,
maxniveau;
comment all texts is assumed to be of stdlinelength,
unless otherwise conditions assure another length
;
stdlinelength := 132;
comment table length initialisation;
searchtablelength := 253;
ntablength := 6000;
comment in sequential pascal their is only 2 niveaus
program and procedure, note no
local procedures;
maxniveau := 1;
begin
integer array
ntab(0:ntablength),
searchtable(0:searchtablelength);
integer entrynext,
entrytype,
entrylength,
entrynamelength,
entrytypeid,
basicentrylength,
entrytypedeckind,
entryparameterlistlength,
entrytypedecref;
comment entry types;
integer constantentry,
typedecentry,
recorddecentry,
recordentry,
reservedword,
variabledecentry,
structuredecentry,
routineheading,
enumerationconstantentry,
recordfixedpartelemententry,
recordelementfixedinwithblockentry,
recordelementvariantentry
recordelementvariantinwithblockentry;
comment name types;
integer notype,
integertype,
realtype,
chartype,
booleantype,
stringtype,
nextdeclaredtype;
comment type declaration kinds;
integer enumerationtype,
previusdefinedtype,
simpletype,
subrangetype;
procedure initofntabrecord;
begin
comment this procdure inits constants which
conserning records and entrylength
in the ntab;
comment identifier symbol record describtion;
entrynext := 0;
entrylength := 1;
basicentrylength := 6;
entrynamelength := 3;
entrytype := 4;
constantentry := 1;
typedecentry := 2;
recorddecentry := 3;
recordentry := 4;
reservedword := 5;
variabledecentry := 7;
structuredecentry := 8;
routineheading := 9;
entrytypeid :=5;
comment refference to a structured type,
if type dec kind is previus definied type;
entrytypedecref := 5;
notype := 0;
integertype:= 1;
realtype := 2;
chartype:= 3;
booleantype := 4;
stringtype := 5;
nextdeclaredtype := 6;
entryparameterlistlength := 6;
entrytypedeckind := 6;
enumerationtype := 1;
previusdefinedtype := 2;
subrangetype := 3;
end initofntabrecord;
comment table entry types;
comment ***************************************************
version 1.1 jan.1981.
lilli andersen
carsten gyrn.
***************************************************
in this version all texts and charakters
if considered as charakters is contained in a integer
and texts is integer array with one charakter stored
in every integer item.
***************************************************;
comment ***************************************************
implementation dependent
input/output procedures
*************************************************;
comment
procedure sourcechar schould read a charakter from
the file where the pascal
source program is stored.▶16◀▶16◀▶16◀
procedure objectchar schould write a charakter on the file
where the algol object program
is wanted.
procedure listchar schould write a char on the file where
the program listning, and error messages
is wanted.
all these procedure schold accept or return charater
values, as integers in the iso alphabet
( close to asscii), the alphabet and conversion
is given below.
( iso alphabet table );
procedure sourcechar(char);
integer char;
begin
readchar(in,char);
end sourcechar;
procedure objectchar(char);
value char; integer char;
begin
comment implementation dependent code,
algol 8 version;
outchar(objectfile,char);
end objectchar;
procedure listchar(char);
value char; integer char;
begin
comment implementaion dependant code,
algol 8 version;
outchar(out,char);
end listchar;
comment decleration of file in the algol 8 version;
zone objectfile(128,1,stderror);
procedure openfiles;
begin
comment make all files ready to charakter input output.
in the algol8 version the files for input source char
and output of list char allready is openened and
ready, becayse the standard input and output files
is used.
the file to the object file is declared just prior
to this procedure.
open(objectfile) as bs storage:(4) name:(<:objectfile:>) error mask :(0);
end openfiles;
procedure closefiles;
begin
comment terminates all ues of files.
see comment to procedure obenfiles;
close(objectfile,true);
end closefiles;
comment ******************************************************
implemantion dependant
conversion procedures
******************************************************;
boolean procedure convertstring(textarray,textstring);
integer array textarray; string textstring;
begin
comment this procedure schould convert a string given as parameter
to an integer array, where the charakters is
packed left justified in a prober way ( see comment version ).
the items in the textarray not used for the conversion is
zero filled (null charakter).
the procedure returns true if the conversion is ok,
false otherwise;
comment code for convertstring in algol 8,
where move string converts a string to
a real array where the charakters is packed
as 6 charakters in every word, and
a charakter occupie 8 bits;
real array workarray(1:stdlinelength);
integer i;
movestring(workarray,1,textstring);
for i:=1,i+1 while textarray(i-1) <> 0 do
textarray(i) := workarray((i-1)//6+1) shift (-(48 -((i-1) mod 6+1)*8))
extract 8;
end convertstring;
comment *******************************************************
input output procedures
*******************************************************;
boolean procedure readsourceline;
begin
comment the procedure reads a string of a charakters
using the procedure sourcechar, until either
a new line, a form feed, a carrige return or a
end medium charakter is met or the array line
if filled up. the array line is assumed to be of standard
line length;
integer i;
if -, endoffile then
begin
for i:=1,i+1 while class(sourceline(i-1)) < endoflineclass and
i < stdlinelength do
sourcechar(sourceline(i));
endofline := false;
sourceline(i) := nullchar;
sourcelinecounter := sourcelinecounter +1;
gpointer := 1;
if listsource then
listsourceline;
readsourceline := if class(sourceline(i-1)) < endoflineclass then
true else false;
if sourceline(i-1) = emchar then endoffile := true;
end;
end readsourceline;
procedure writeobjectline(text);
integer array text;
begin
comment write a std. text un the ogject file
using the output procedure object char;
integer index;
for index := 1,index+1 while index <= stdlinelength
and text(index-1) <> nullchar do
begin
objectchar(text(index));
end;
end writeobjectline;
procedure listline(line);
integer array line;
begin
comment output a line given in the integer parameter line
on the list file.
the procedure stop output symbol from the line
when a nlchareter , a formfeed, a carrige return or
a end medium charakter is met or when the
last charakter in the array line is met;
integer i;
for i:=1,i+1 while class(line(i-1)) < endoflineclass and
line(i) <> nullchar and
i <= stdlinelength do
listchar(line(i));
end listline;
procedure listsourceline;
begin
comment prints the source code with line numbers;
integer index;
integer array numbertext,
formatnumber(1:12);
converttextinteger(numbertext,sourcelinecounter);
formatrigthtext(formatnumber,7,numbertext,1);
concattext(printline,formatnumber,sourceline);
insertnlchar(printline);
listline(printline);
end listsourceline;
comment error and recovery procedures;
procedure error(errorstring);
string errorstring;
begin
comment errortext will be printed out on the list fie
if list a pointer
if source text is to be listed then a pointer
is printed out before the error text line
at positioning at current g pointer.
line number is printed out before
the error line text;
integer array numbertext,
formatnumber(1:12),
errortext(1:stdlinelength);
integer index;
if listsource then
begin
for index := 1 step 1 until gpointer+7-1 do
printline(index) := blankchar;
printline(gpointer) := snabelachar;
printline(gpointer+1) := nullchar;
insertnlchar(printline);
listline(printline);
resettext(printline);
end
else
begin
converttextinteger(numbertext,sourcelinecounter);
formatrigthtext(formatnumber,7,numbertext,1);
movetext(printline,formatnumber);
converttextinteger(numbertext,gpointer);
formatrigthtext(formatnumber,7,numbertext,1);
appendtext(printline,formatnumber);
end;
convertstring(errortext,errorstring);
appendtext(printline,errortext);
insertnlchar(printline);
listline(printline);
end error;
comment recovery conditions;
integer skipsemicolon,
skipbegin,
skipbeginsemicolon,
skipreservedwordsemicolon,
skipreservedword;
procedure initofrecoverconditions;
begin
skipsemicolon := 1;
comment skip until reserved word symbol begin or
past semicolon;
skipbeginsemicolon := 2;
comment skip until begin;
skipbegin := 3;
comment skip until reserved word symbol or
past semicolon;
skipreservedwordsemicolon := 4;
comment skip until next reserved word;
skipreservedword := 5;
end initofreceverconditions;
procedure recover(condition);
value condition; integer condition;
begin
comment this procedure tryes to firn
the start of the next sentence, and set gpointer to
start there;
end recover;
comment variables used in connection with input and output
procedures;
boolean endofline,
endoffile,
listsource;
comment input and output buffers;
integer array sourceline,
objectline,
printline(1:stdlinelength);
integer sourcelinecounter,
objectlinecounter;
procedure initinputoutputvariables;
begin
endofline := true;
endoffile := false;
comment allways listning;
listsource := true;
sourcelinecounter := 0;
objectlinecounter := 0;
end initinputoutputvariables;
comment objectcode printing procedures;
procedure outcodenl;
begin
comment creates a newline char on the object line
and write it out on the objectfile;
objectlinecounter := objectlinecounter +1;
insertnlchar(objectline);
writeobjectline(objectline);
end outcodenl;
procedure outcodechar(char);
value char; integer char;
begin
comment append the char to last of the objectline;
if appendchar(objectline,char) then
begin
outcodenl;
resettext(objectline);
objectline(1) := char;
end;
end objectchar;
procedure outcodetext(text);
integer array text;
begin
comment add the text to
the object line. if the result of
the adding is greateher than std line then
the object line i writen out and
text is firt of new object line;
if -, appendtext(objectline,text) then
begin
outcodenl;
movetext(objectline,text);
end;
end outcodetext;
procedure outcodestring(textstring);
string textstring;
begin
comment adds the textstring to the objectline.
if the result of the adding is greather
than stdlinelength then objectline
is written out on objectfile and
textstring is made first of a new
objectline;
integer array text(1:stdlinelength);
convertstring(text,textstring);
if -, appendtext(objectline,text) then
begin
outcodenl;
movetext(objectline,text);
end;
end outcodestring;
comment variable used in connection with the procedure
next,next0,next1,next2 which get next symbol from
the source file;
comment text,text0,text1,text2 contains the text of the identifier;
integer array text,text0,text1,text2(1:stdlinelength);
comment entry,entry0,entry1,entry2 contain
an index of the identifier;
integer entry,entry0,entry1,entry2;
comment symbol,symbol0,symbol1,symbol2 contaion the symbol class of the
the next symbol;
integer symbol,symbol0,symbol1,symbol2;
comment aux,aux0,aux1,aux2 contaions varius values;
integer aux,aux0,aux1,aux2;
comment the procedures next,next0,next1,next2 call
getnextsymbol with different parameters;
integer procedure next;
begin
next := symbol := getnextsymbol(text,entry,aux);
end next;
integer procedure next0;
begin
next0 := symbol0 := getnextsymbol(text0,entry0,aux0);
end next0;
integer procedure next1;
begin
next1 := symbol1 := getnextsymbol(text1,entry1,aux1);
end next1;
integer procedure next2;
begin
next2 := symbol2 := getnextsymbol(text2,entry2,aux2);
end next2;
comment table for class values associated to each
char;
integer array charclass(0:127);
integer procedure class(char);
value char; integer char;
comment returns a class value associated to a given char.
in this version the class values is taken from the
table charclass;
begin
class := charclass(char);
end class;
integer procedure thisclass;
begin
comment delivers the class of the current spointer from
the char in source line, only made to
speed things up a bit;
thisclass := charclass(sourceline(spointer));
end thisclass;
comment variables used as symbol classes;
integer illegalclass,
letterclass,
digetclass,
exponentchar,
rigthbraketchar,
leftbraketchar,
investchar,
nextchar;
comment charakter constants;
integer nullchar,
nlchar,
emchar,
ffchar,
crchar,
blankchar,
minuschar,
starchar,
zerodigetchar,
equalchar,
greatherchar,
lesschar,
periodchar,
colonchar,
doublequotechar,
snabelachar,
firstsingleclass,
lastsingleclass,
firstdoubleclass,
lastdoubleclass,
firstseperatorclass,
endoffileclass,
endoflineclass;
comment variables used as constant delivered as results
from getnextsymbol, directive symbol and doublequotesymbol
is not defined in the sequential pascal rapport
page 5.;
integer unknownsymbol,
namesymbol,
numbersymbol,
greathersymbol,
greatherequalsymbol,
lesssymbol,
lessequalsymbol,
notequalsymbol,
periodsymbol,
rangeseperatorsymbol,
rigtharraybraketsymbol,
leftarraybraketsymbol,
leftbraketsymbol,
rigthbraketsymbol,
assignmentsymbol,
plussymbol,
minussymbol,
timessymbol,
slashsymbol,
pointersymbol,
ambersandsymbol,
equalsymbol,
snabelasymbol,
commasymbol,
semicolonsymbol,
colonsymbol,
singlequotesymbol,
doublequotesymbol,
directivelsymbol;
comment variables used inconnection with get next symbol.
gpointer points to next char in sourceline,
rpointer points to start of previus symbol
used for error recovery,
spointer used for scanning in sourceline
is undefined after call of next;
integer gpointer,
spointer,
rpointer,
symbclass;
integer procedure getnextsymbol(text,index,aux);
integer array text; integer index,aux;
begin
if skipseperatorsymbol then
begin
comment init recovery pointer
and scan pointer;
rpointer := gpointer;
spointer := gpointer;
if symbclass = letterclass then
getnextsymbol := getnextname(text,index,aux)
else
if symbclass = digetclass then
getnextsymbol := getnextnumber(text,index,aux)
else
if symbclass >= firstsingleclass and
symbclass <= lastsingleclass then
getnextsymbol := getnextsinglecharsymbol(text,index,aux)
else
getnextsymbol := getnextdoublecharsymbol(text,index,aux);
end
else
begin
getnextsymbol := endoffileclass;
end;
end getnextsymbol;
integer procedure getnextname(text,index,aux);
integer array text; integer index,aux;
begin
comment letter found.
collect text, and look up;
integer spointer;
for spointer := gpointer, spointer + 1
while symbclass = letterclass or
symbclass = digetclass do
begin
text(spointer+1-gpointer) := sourceline(spointer);
symbclass := class(sourceline(spointer+1));
end;
comment set end text charakter in text;
text(spointer+1-gpointer) := nullchar;
gpointer := spointer;
comment look up text in texttable;
if lookuptext(text,index) then
begin
comment find name type in ntab
and return result;
if ntab(index+entrytype) = reservedword then
begin
comment because the reserved word is one of
the most common symbols it is given a
spcial symbol. also instead of returning
the type in the var aux the nameid is returned,
( i.e. is it a begin or a while ect.).
;
getnextname := reservedword;
aux := ntab(index+entrytypeid);
end
else
begin
getnextname := namesymbol;
aux := ntab(index+entrytype);
end;
end
else
getnextname := unknownnamesymbol;
end getnextname;
integer procedure getnextnumber(text,index,aux);
integer array text; integer index,aux;
begin
comment number found.
read number and store as text.
aux gives as result integer or real;
aux := integertype;
for spointer:=gpointer,
spointer+1 while thisclass = digetclass do
begin
text(spointer+1-gpointer) := sourceline(spointer);
end;
if class(spointer) = periodsymbol then
begin
aux := realtype;
comment decimalpart found;
text(spointer+1-gpointer) := sourceline(spointer);
for spointer:=spointer+1 while
thisclass=digetclass do
begin
text(spointer+1-gpointer) := sourceline(spointer);
end;
if sourceline(spointer) = exponentchar then
begin
comment exponent part found;
text(spointer+1-gpointer) := sourceline(spointer);
for spointer := spointer+1 while
thisclass = digetclass do
begin
text(spointer+1-gpointer) := sourceline(spointer);
end;
end exponent part;
end decimalpart;
comment set end text charakter;
text(spointer+1-gpointer) := 0;
gpointer := spointer;
getnextnumber := numbersymbol;
end getnextnumber;
integer procedure getnextsinglecharsymbol(text,index,aux);
integer array text; integer index,aux;
begin
comment single charakter symbol is met,
the class of the symbol is used as result,
aux is set to the charakter value,
text and index is unassigned;
aux := sourceline(gpointer);
getnextsinglecharsymbol := symbclass;
gpointer := gpointer+1;
end getnextsinglesymbol;
integer procedure getnextdoublecharsymbol(text,index,aux);
integer array text; integer index,aux;
begin
investchar := sourceline(gpointer);
nextchar := sourceline(gpointer+1);
if investchar = colonchar and nextchar = equalchar then
begin
getnextdoublecharsymbol:= assignmentsymbol;
gpointer := gpointer + 2;
end
else
if investchar = leftbraketchar and nextchar = periodchar then
begin
getnextdoublecharsymbol:= leftarraybraketsymbol;
gpointer := gpointer + 2;
end
else
if investchar = periodchar then
begin
if nextchar = rigthbraketchar then
begin
getnextdoublecharsymbol:= rigtharraybraketsymbol;
gpointer := gpointer + 2;
end
else
if nextchar = periodchar then
begin
getnextdoublecharsymbol:= rangeseperatorsymbol;
gpointer := gpointer + 2;
end
else
begin
getnextdoublecharsymbol:= periodsymbol;
gpointer := gpointer +1;
end;
end
else
if investchar = lesschar then
begin
if nextchar = greatherchar then
begin
getnextdoublecharsymbol:= notequalsymbol;
gpointer := gpointer +2;
end
else
if nextchar = equalchar then
begin
getnextdoublecharsymbol:= lessequalsymbol;
gpointer := gpointer+2;
end
else
begin
getnextdoublecharsymbol:= lesssymbol;
gpointer := gpointer +1;
end;
end
else
if investchar = greatherchar then
begin
if nextchar = equalchar then
begin
getnextdoublecharsymbol:= greatherequalsymbol;
gpointer := gpointer +2;
end
else
begin
getnextdoublecharsymbol:= greathersymbol;
gpointer := gpointer +1;
end;
end
else
begin
getnextdoublecharsymbol := unknownsymbol;
gpointer := gpointer +1;
end;
aux := investchar;
index := nextchar;
end getnextdoublesymbol;
boolean procedure skipseperatorsymbol;
begin
comment this procedure skips all seperator symbols
i.e blank, newline, carriege return and form feed
charakters and comments.
the skipping starts with the charakter pointerd out
by gpointer, at return gpointer points to
the first charakter not part of a seperator and
symbclass contains the class of the first char
not part of a seperator.
the result of skipseperator is false if
endoffile is met otherwise true;
if -, endoffile then
begin
if endofline then readsourceline;
for symbclass := class(sourceline(gpointer))
while symbclass >= firstseperatorclass and
-, endoffile do
begin
if symbclass = endoflineclass then
readsourceline
else
if symbclass = doublequotesymbol then
skipcomment
else
gpointer := gpointer +1;
end;
end;
skipseperatorsymbol := if endoffile then false else true;
end skipblank;
procedure skipcomment;
begin
comment skips from a begining of a comment
until and past its end.
gpointer points on the first duoblequote
at entry. ;
for gpointer := gpointer +1
while sourceline(gpointer) <> doublequotechar and
-, endoffile do
begin
if class(sourceline(gpointer)) = endoflineclass then
begin
readsourceline;
gpointer := 0;
end;
end;
end skipcomment;
procedure initofsearchtable;
begin
comment initialize every entry in the searchtable
with the initial value nil;
integer index;
for index := 0 step 1 until searchtablelength do
searchtable(index) := nil;
end initofsearchtable;
boolean procedure insertname(tabindex,name,recordtype,recordidno);
value recordtype,recordidno;
integer tabindex,recordtype,recordidno;
integer array name;
begin
integer nameindex,recordindex;
comment insert name in identifier table.
if the name is allready in the idnametable then
it is not inserted but the same name in the
idnametable is used. if the same name exists in the
idname table then it must be on same or a lower
niveau;
lookupname(name,nameindex);
nameindex := allocate(length0(name));
movename4(ntab,nameindex,name);
comment record information insert in ntable;
recordindex := allocate(basicentrylength);
ntab(recordindex+entrylength) := basicentrylength;
ntab(recordindex+entrynext) := searchtable(tabindex);
searchtable(tabindex) := recordindex;
ntab(recordindex+entryrecordtype) := recordtype;
ntab(recordindex+entryrecordtypeid) := recordidno;
ntab(recordindex+entrynamelength) := length0(name);
tabindex := recordindex;
end insertname;
boolean procedure lookuptext(text,textindex);
integer array text; integer textindex;
begin
comment lookup a text in the ntab indexed through the
search table.
the result is true if the text is found othervise false.
if the text is found then the textindex points to the symbol
in the ntab.
if the text is not found then textindex is the
index in the search table;
integer hashkey,searchkey,textlength;
boolean textfound;
textfound := false;
textlength := length0(text);
hashkey := calculatehashkey(text);
searchkey := searchtable(hashkey);
textindex := hashkey;
for dummy := dummy while
-, textfound and searchkey <> nil do
begin
if textlength = ntab(searchkey+entrynamelength) then
begin
if comparetext(text,1,ntab,
ntab(searchkey-ntab(searchkey+entrynamelength))) then
begin
textindex := searchkey;
textfound := true;
end
end;
searchkey := ntab(searchkey+entrynext);
end;
lookuptext := textfound;
end lookuptext;
integer procedure calculatehashkey(text);
integer array text;
begin
comment calculates a search key to be used
for searching in the symbolable.
the key is calculated using all charakters
in the text.
if no text is aplied to the procedure
the hash key as result i zero.;
integer hashkey,index;
hashkey := 0;
index := 0;
for index := index+1 while text(index) <> 0 do
hashkey := hashkey + index*text(index);
calculatehashkey := hashkey mod searchtablelength
+ ( if hashkey <> 0 then 1 else 0);
end calculatehashkey;
procedure resettext(text);
integer array text;
begin
comment insert a null char in the frirst position
in the text, and by doing so making it a standard
left justified empty text;
text(1) := nullchar;
end resettext;
boolean procedure comparetext(text1,pointer1,text2,pointer2);
integer array text1,text2;
integer pointer1,pointer2;
begin
comment compares a text in array text1 with a text in array text2.
the texts starts in the arrays at pointer1 or pointer2
respectively.
result true if the texts are equal othervise false.
it is asumed the the texts ends correct whit a zero
charakter;
integer index;
boolean finiscompare;
finiscompare := false;
comparetext := true;
for index := 0, index+1 while -,finiscompare do
begin
if text1(pointer1+index) <> text2(pointer2+index) then
begin
comparetext := false;
finiscompare := true;
end;
if text1(pointer1+index) = 0 then finiscompare := true;
end;
end comparetext;
boolean procedure concattext(resulttext,text1,text2);
integer array resulttext,text1,text2;
begin
comment concatenate 2 left justified texts text1 and text2
to result text.
;
integer indexfrom,indexto;
indexto := 1;
indexfrom:= 0;
for indexfrom := indexfrom+1 while text1(indexfrom) <> 0
and indexto < stdlinelength do
begin
resulttext(indexto) := text1(indexfrom);
indexto := indexto + 1;
end;
indexfrom := 0;
for indexfrom := indexfrom + 1 while text2(indexfrom) <> 0
and indexto < stdlinelength do
begin
resulttext(indexto) := text2(indexfrom);
indexto := indexto + 1;
end;
concattext := if indexto > 131 then false else true;
resulttext(indexto) := 0;
end concattext;
boolean procedure appendtext(text1,text2);
integer array text1,text2;
begin
comment adds text2 into text1 after the zero ending char
in text1.
if the result of the appending is longer than
stdlinelength then text1 is left unchanged.
the result of append is true if the appending
is performed othervise false;
integer text1length,index2;
for text1length := 0,
text1length+1 while text1(text1length) <> nullchar
and text1length <= stdlinelength do;
for index2:=0,index2+1 while text1length+index2 < stdlinelength
and text2(index2) <> nullchar do
text1(text1length+index2) := text2(index2+1);
if index2+text1length <= stdlinelength then
appendtext := true
else
begin
appendtext := false;
text1(text1length) := nullchar;
end;
end appendtext;
boolean procedure appendchar(text,char);
value char; integer char;
integer array text;
begin
comment appends the char to the last of the text;
integer index;
for index:=1,index+1 while index<=stdlinelength
and text(index-1) <> nullchar do;
if index+1 < stdlinelength then
begin
appendchar := true;
text(index-1) := char;
text(index) := nullchar;
end
else
appendchar := true;
end appendchar;
boolean procedure movetext(resulttext,sourcetext);
integer array resulttext,sourcetext;
begin
comment moves the contents of sourcetext to result text.
both text is left justified.
the result schold obius allways be true, but
if source text not end with a zero charakter then
the result is false;
integer index;
for index := 1,index+1 while index < stdlinelength do
resulttext(index) := sourcetext(index);
movetext := if index < stdlinelength then true else false;
end movetext;
boolean procedure movetext1(resulttext,text1,indexlow,indexhigh);
value indexlow,indexhigh; integer indexlow,indexhigh;
integer array resulttext,text1;
begin
comment moves a text from array text1 indexed
from indexlow to index high to the array
resulttext left justified.
if a zero charakter in text1 is met before
index high then the procedure is terminated.
the result of the procedure is false if more
than stdlinelength charakters is tryed to be moved
othervise true;
integer indexto;
indexto := 0;
for indexto:=indexto+1 while indexto < stdlinelength
and indexlow <= indexhigh do
begin
resulttext(indexto) := text1(indexlow);
if resulttext(indexto) = 0 then
indexlow := indexhigh + 1
else
indexlow := indexlow + 1;
end;
movetext1 := if indexto < stdlinelength then true else false;
end movetext1;
boolean procedure movetext2(resulttext,indexhigh,indexlow,sourcetext);
integer array resulttext,sourcetext; integer indexhigh,indexlow;
begin
comment
moves the left justifieded sourcetext ending on a zero
charakter to resulttext starting at index indexlow.
indexhigh is the last position in resulttext where
sourcetext is mowed to.
the zero ending charakter ending sourcetext is not
mowed.
the result of the procedure is true if the move was
succesfull otherwise false (i.e. result text was
mot long enogh to take the whole of sourcetext);
integer index;
index:=0;
for index:=index+1 while sourcetext(index) <> 0 and
indexlow+index < stdlinelength do
begin
resulttext(indexlow+index-1) := sourcetext(index);
end;
movetext2 := if indexlow+index < stdlinelength then true else false;
end movetext2;
boolean procedure movetext3(resulttext,indexrlow,indexrhigh,
sourcetext,indexslow,indexshigh);
value indexrlow,indexslow,indexshigh;
integer array resulttext,sourcetext;
integer indexrlow,indexrhigh,indexslow,indexshigh;
begin
comment move sourcetext from lindexslow to indexshigh
to resulttext from indexrlow to indexrhigh.
indexrhigh is a result parameter.
the result of the procedure is true
if the move was successfully otherwise false;
integer index;
index :=-1;
for index := index+1 while indexslow+index <= indexrhigh and
indexslow+index < stdlinelength and
indexrlow+index < stdlinelength do
begin
resulttext(indexrlow+index) := sourcetext(indexslow+index);
end;
movetext3 := if indexrlow+index >= stdlinelength then false
else
if indexslow+index >= stdlinelength then false
else true;
end movetext3;
boolean procedure movetext4(resulttext,indexlow,sourcetext);
value indexlow; integer indexlow;
integer array resulttext,sourcetext;
begin
comment moves a left justified text from source text to
result text starting at positon indexlow in resulttext;
integer index;
for index:=1,index+1 while sourcetext(index-1) <> 0 do
begin
resulttext(indexlow-1+index) := sourcetext(index);
end;
movetext4 := if sourcetext(index) <> 0 then false else true;
end movetext4;
boolean procedure movetext5(tabtext,tabindex,text);
value tabindex;
integer array tabtext,text;
integer tabindex;
begin
comment moves a left justified text from
text to a 2 dimentional array tabtext
where the first index is tabindex and the
the second index is the text;
integer charindex;
charindex := 0;
for charindex:=charindex+1 while text(charindex) <> 0 and
charindex < stdlinelength do
begin
tabtext(tabindex,charindex) := text(charindex);
end;
tabtext(tabindex,charindex) := 0;
movetext5 := if text(charindex) <> 0 then false else true;
end movetext5;
boolean procedure movetext6(text,tabtext,tabindex);
value tabindex;
integer array text,tabtext;
integer tabindex;
begin
comment movex a left justified text in the table
texttable indexed with the tabindex to the
text;
integer charindex;
charindex := 0;
for charindex := charindex +1 while charindex < stdlinelength and
tabtext(tabindex,charindex) <> 0 do
begin
text(charindex) := tabtext(tabindex,charindex);
end;
text(charindex) := 0;
movetext6 := if tabtext(tabindex,charindex) = 0 then true else false;
end movetext6;
procedure converttextinteger(text,number);
value number; integer number; integer array text;
begin
comment converts an integer number to a text with
std format left justified;
integer index,turnindex,help;
if number < 0 then
begin
text(index):=minuschar;
turnindex := 2;
index:=2;
number := -1* number;
end
else
begin
index := 1;
turnindex := 1;
end;
for index := index ,index+1 while number > 0 do
begin
text(index) := ( number mod 10) + zerodigetchar;
number := number // 10;
end;
text(index) := 0;
comment turn number;
for index := index -1 while index <> turnindex do
begin
help := text(index);
text(index) := text(turnindex);
turnindex := turnindex+1;
end;
end converttextinteger;
boolean procedure convertintegertext(result,text);
integer result; integer array text;
begin
comment converts a left justified text which contains
diget charakters into a integer.
result is zero if no diget charakters is met,
the conversion stops when the first non diget charakter
is met,
convertintegertext is false if no diget is met
otherwise false;
integer index,number;
number := 0;
index := 0;
for index := index+1 while class(text(index)) = digetclass do
begin
number := number*10 + text(index)-zerodigetchar;
end;
convertintegertext := if index > 1 then true else false;
result := number;
end convertintegertext;
procedure formattext(resulttext,resultlength,position,sourcetext);
value position,resultlength; integer resultlength,position;
integer array resulttext,sourcetext;
begin
comment formats sourcetext into resulttext so
it will be resultlength charakters long and
start in position. not used position veill
be filled with blanks;
integer index;
for index := 1 step 1 until position-1 do
resulttext(index) := blankchar;
for index := index+1 while sourcetext(index) <> 0
and index <= resultlength do
resulttext(index) := sourcetext(index+1-position);
for index := index step 1 until resultlength do
resulttext(index) := blankchar;
end formattext;
procedure formatrigthtext(resulttext,resultlength,sourcetext,endspace);
value resultlength,endspace; integer resultlength,endspace;
integer array resulttext,sourcetext;
begin
comment positions sourcetext rigth in
resulttext which is resulttext ling so
after sourcetext their is endpace blankchars.
if source text can not be in resulttext plus endspace
then sourcetext is filed up with starchar;
integer index,leadingblanks;
if length(sourcetext) + endspace > resultlength then
begin
for index := 1 step 1 until resultlength do
resulttext(index) := starchar;
resulttext(index+1) := nullchar;
end
else
begin
leadingblanks := resultlength -(endspace+length(sourcetext));
for index := 1 step 1 until leadingblanks do
resulttext(index) := blankchar;
index := 0;
for index := index +1 while sourcetext(index) <> 0 and
index < stdlinelength do
resulttext(index+leadingblanks) := sourcetext(index);
for index := 1 step 1 until endspace do
resulttext(resultlength+1-1) := blankchar;
resulttext(resultlength+1) := nullchar;
end;
end formatrigthtext;
integer procedure length0(text);
integer array text;
begin
comment calcualtes the length of text
which is left justified and ending on
zero charakter.
if the last char is not a zero char then
zero char is inserted.
if length is negative then text was
not ending on a zero charakter.
the zero char is included in the length
calculation;
integer index;
for index :=0, index+1 while index < stdlinelength and
text(index) <> 0 do;
length0 := if text(index) = 0 then index else -index;
if index= stdlinelength then text(index) := 0;
end length0;
integer procedure length(text);
integer array text;
begin
comment catculates the length of a left justified std format
text. if the last char is not a null char then
a nnull char is inserted an the length is given
as negative. the zero char is not included in the
length calculation, see proccedure length0;
integer index;
for index := 0 , index +1 while index<= stdlinelength and
text(index) <> 0 do;
length := if text(index) = 0 then index-1 else -index-1;
if index=stdlinelength then text(index) := 0;
end length;
boolean procedure insertnlchar(line);
integer array line;
begin
comment inserts a nl char if
before the zero char ending the text line
if no nl char is present before.
if the line fills the whole array the
nl char is inserted instead of
the zero char.
if the zero char is substitueted then
insertnlchar is false else true;
integer index;
for index :=1,index+1 while index <= stdlinelength and
line(index-1) <> nlchar do
begin
if line(index) = 0 then
begin
line(index) := nlchar;
if index+1 <= stdlinelength then line(index+1) := nullchar;
end;
end;
insertnlchar := if index > stdlinelength then false else true;
end procedure insertnlchar;
comment reservedword symbols;
comment reservedword symbols constant;
integer resarray,
resbegin,
resconst,
rescase,
resdiv,
resdo,
resdownto,
reselse,
resend,
resfor,
resforward,
resfunction,
resif,
resin,
resmod,
resnot,
resof,
resor,
resprocedure,
resprogram,
resrecord,
resrepeat,
resset,
resthen,
resto,
restype,
resuniv,
resvar,
reswhile,
reswith;
procedure initofreservedwordsymbol;
begin
comment initialization of reservedword constants;
resarray := 1; resbegin := 2; resconst := 3;
rescase := 4; resdiv := 5; resdo := 6;
resdownto := 7; reselse := 8; resend := 9;
resfor := 10; resforward := 11; resfunction := 12;
resif := 13; resin := 14; resmod := 15;
resnot := 16; resof := 17; resor := 18;
resprocedure := 19; resprogram := 20; resrecord := 21;
resrepeat := 22; resset := 23; resthen := 24;
resto := 25; restype := 26; resuniv := 27;
resvar := 28; reswhile := 29; reswith := 30;
end initofreservedwordsymbol;
comment symbolconstants;
integer lastreservedword,
unknownnamesymbol
firstidentifier,
idboolean,
idchar,
idinteger,
idreal,
idfalse,
idtrue,
predefinedidentifier;
procedure initofsymbolconstants;
begin
lastreservedword:=30;
firstidentifier := 32;
comment predeclared identifiers;
comment 4 types is predeclared;
idboolean := 32;
idchar := 33;
idinteger := 34;
idreal := 35;
comment the two resrved enumeration values
true and false;
idfalse := 36;
idtrue := 37;
end initofsymbolconstants;
procedure initofnametable;
begin
comment this procedure initialize the name table
with the reservedword symbol and predefined
identifiers (ex. false and true);
integer array texttable(1:30,1:12);
integer array text(1:12);
integer index,searchindex;
comment initialize the tet table with the reservedword;
convertstring(text,<:array:>);
movetext5(texttable,1,text);
convertstring(text,<:begin:>);
movetext5(texttable,2,text);
convertstring(text,<:case:>);
movetext5(texttable,3,text);
convertstring(text,<:const:>);
movetext5(texttable,4,text);
convertstring(text,<:div:>);
movetext5(texttable,5,text);
convertstring(text,<:do:>);
movetext5(texttable,6,text);
convertstring(text,<:downto:>);
movetext5(texttable,7,text);
convertstring(text,<:else:>);
movetext5(texttable,8,text);
convertstring(text,<:end:>);
movetext5(texttable,9,text);
convertstring(text,<:for:>);
movetext5(texttable,10,text);
convertstring(text,<:forward:>);
movetext5(texttable,11,text);
convertstring(text,<:function:>);
movetext5(texttable,12,text);
convertstring(text,<:if:>);
movetext5(texttable,13,text);
convertstring(text,<:in:>);
movetext5(texttable,14,text);
convertstring(text,<:mod:>);
movetext5(texttable,15,text);
convertstring(text,<:not:>);
movetext5(texttable,16,text);
convertstring(text,<:of:>);
movetext5(texttable,17,text);
convertstring(text,<:or:>);
movetext5(texttable,18,text);
convertstring(text,<:procedure:>);
movetext5(texttable,19,text);
convertstring(text,<:program:>);
movetext5(texttable,20,text);
convertstring(text,<:record:>);
movetext5(texttable,21,text);
convertstring(text,<:repeat:>);
movetext5(texttable,22,text);
convertstring(text,<:set:>);
movetext5(texttable,23,text);
convertstring(text,<:then:>);
movetext5(texttable,24,text);
convertstring(text,<:to:>);
movetext5(texttable,25,text);
convertstring(text,<:type:>);
movetext5(texttable,26,text);
convertstring(text,<:univ:>);
movetext5(texttable,27,text);
convertstring(text,<:var:>);
movetext5(texttable,28,text);
convertstring(text,<:while:>);
movetext5(texttable,29,text);
convertstring(text,<:with:>);
movetext5(texttable,30,text);
comment insert reservedwords symbols
in name table;
for index := 1 step 1 until 30 do
begin
movetext6(text,texttable,index);
lookuptext(text,searchindex);
insertname(searchindex,text,reservedword,index);
end;
comment insert predefined identifiers in
name table;
convertstring(text,<:boolean:>);
movetext5(texttable,1,text);
convertstring(text,<:char:>);
movetext5(texttable,2,text);
convertstring(text,<:integer:>);
movetext5(texttable,3,text);
convertstring(text,<:real:>);
movetext5(texttable,4,text);
convertstring(text,<:false:>);
movetext5(texttable,5,text);
convertstring(text,<:true:>);
movetext5(texttable,6,text);
for index := 1 step 1 until 6 do
begin
movetext6(text,texttable,index);
lookuptext(text,searchindex);
insertname(searchindex,text,predefinedidentifier,index+31);
end;
end initofnametable;
procedure initclasscharsymbol;
begin
integer i;
comment init all illegal charakters;
unknownsymbol := 1;
illegalclass := 1;
for i:= 0 step 1 until 127 do
charclass(i) := 1;
comment charakters which is skipped in input;
charclass(0) := 0;
comment charakter null is internaly
used for ending texts;
nullchar := 0;
comment diget is class 10;
numbersymbol := 10;
digetclass := 10;
zerodigetchar := 48;
for i:=48 step 1 until 58 do
charclass(i) := 10;
comment letters is class 12;
comment unknown name is when the identifier is
not found in the name table;
unknownnamesymbol := 11;
comment name symbol is when the identifier is
found in the name table;
namesymbol := 12;
comment reservedword is when the entrytype found
in the name table is of reservedword type.
this value is initialised and defined
in section name table record;
comment initialised to 5, therefor symbol class 5
is reserved;
reservedword := reservedword;
letterclass := 12;
for i:= 65 step 1 until 90 do
charclass(i) := 12;
for i:= 97 step 1 until 122 do
charclass(i) := letterclass;
comment single class;
firstsingleclass := 14;
comment plus char;
plussymbol := 14;
charclass(43) := 14;
comment minus char;
minussymbol := 15;
minuschar := 45;
charclass(45) := 15;
comment times char or star char;
starchar := 42;
timessymbol := 16;
charclass(42) := 16;
comment slash char;
slashsymbol := 17;
charclass(47) := 17;
comment and char;
ambersandsymbol := 18;
charclass(38) := 18;
comment equal char ;
equalsymbol := 19;
charclass(61) := 19;
comment snabela char;
pointersymbol := 20;
snabelasymbol := 20;
snabelachar := 64;
charclass(64) := 20;
comment rigth braket;
rigthbraketsymbol := 21;
charclass(41) := 21;
comment comma char;
commasymbol := 22;
charclass(44) := 22;
comment semicolon char;
semicolonsymbol := 23;
charclass(59) := 23;
comment quote char;
singlequotesymbol := 24;
charclass(60) := 24;
lastsingleclass := 24;
comment class 25 not used;
comment symbols which is migth single if not double;
comment colon class;
charclass(58) := 26;
colonsymbol := 26;
comment period char;
charclass(46) := 27;
periodsymbol := 27;
comment comment less char;
charclass(60) := 28;
lesssymbol := 28;
comment greather char;
charclass(62) := 29;
greathersymbol := 29;
comment init of double charakters symbol;
comment colon char and equal char is assignment;
colonchar := 58; equalchar := 61;
assignmentsymbol := 30;
firstdoubleclass := 30;
comment left braket and period is left array braket;
leftbraketchar := 40; periodchar := 46;
leftarraybraketsymbol := 34;
comment period char and rigth braket is rigth array braket;
rigthbraketchar := 41;
rigtharraybraketsymbol := 36;
comment period char and period char is range symbol;
rangeseperatorsymbol := 38;
comment lesschar end greather char is notequal symbol;
lesschar := 60; greatherchar := 62;
notequalsymbol := 38;
comment lesschar and equal char is lessequalsymbol;
lessequalsymbol := 40;
comment greather char and equal char is greatherequalsymbol;
greatherequalsymbol := 42;
lastdoubleclass := 42;
comment double quote char class;
charclass(34) := 59;
doublequotechar := 34;
doublequotesymbol := 59;
firstseperatorclass := 59;
comment space char class;
charclass(32) := 60;
blankchar := 32;
comment new line , form feed and carrige return is class 20;
endoflineclass := 62;
nlchar := 10;
charclass(10) := 62;
ffchar := 12;
charclass(12) := 62;
crchar := 13;
charclass(13) := 62;
comment end medium class, the higest class number;
endoffileclass := 64;
emchar := 25;
charclass(25) := 64;
end initclasscharsymbol;
comment the table contaion information about the name table
when a niveau change occur;
integer array niveautable(1:maxniveau,1:2);
boolean procedure newniveau;
begin
comment the value of the first free in the niveau table
entry in the name table
is saved in the niveau table;
if thisniveauno > maxniveau then
newniveau := false
else
begin
niveautable(thisniveauno,1) := ntabfree;
thisniveau := ntabfree;
thisniveauno := thisniveauno+1;
end;
end newniveau;
boolean procedure removeniveau;
begin
comment removes all entry in the ntab and
identifier texts connected to them
until next niveau.
;
integer searchindex,chain,index;
comment find previus niveau;
if thisniveauno -1 < 1 then
removeniveau := false
else
begin
thisniveauno := thisniveauno - 1;
comment free all entreis ntab
connected to thisniveauno;
ntabfree := niveautable(thisniveauno,1);
thisniveau := niveautable(thisniveau-1,1);
for index :=1 step 1 until searchtablelength do
begin
chain := searchtable(index);
for chain := chain while chain > ntabfree do
chain := ntab(chain+entrynext);
searchtable(index) := chain;
end;
end;
end removeniveau;
integer procedure allocate(elements);
value elements; integer elements;
begin
comment allocate elementss in the ntab.
result is index of first symbol
ellocated;
allocate := ntabfree;
ntabfree := ntabfree + elements;
if ntabfree > ntablength then
fatalerror(<:ntab limit:>);
end allocate;
procedure disallocate(elements);
value elements; integer elements;
begin
comment frees elementss in ntab;
ntabfree := ntabfree - elements;
if ntabfree < 1 then
fatalerror(<:ntab limit zero:>);
end disallocate;
procedure includestackinentry(entry);
value entry; integer entry;
begin
comment the entry is considered to be the latest
inserted in ntab, a possible use of the
the rest of ntab as stack is included in the
ntab record, i.e the ntab records length
is changed so the record length is j
from entry to justbefore ntabfree;
ntab(entry) := ntabfree - entry;
end includestackinentry;
procedure disallocatetoentry(entry);
value entry; integer entry;
begin
comment this entry is considdered the last inserted,
a possible stack use after this record
is removed;
ntabfree := entry + ntab(entry+entrylength);
end disallocatetoentry;
procedure changeentrylength(entry,change);
value entry,change; integer entry,change;
begin
comment the latest created entry in name table
is changed to the new length;
if change > 0 then
allocate(change);
ntab(entry+entrylength) := ntab(entry+entrylength) + change;
end changeentrylength;
boolean procedure controldeclaration(symbol,entry);
value symbol,entry;
integer symbol,entry;
comment control of a new identifier can be declared
as a variable or a type, in the present
niveau and care taken for parameters
and record contents.
;
begin
if symbol = unknownname or
( symbol = namesymbol and entry < thisniveau ) or
( symbol = namesymbol and
( ntab(entry+entrytype) = recorcelementfixedentry or
ntab(entry+entrytype) = reccordelementvariantentry))
then
controldecleration := true
else
controldecleration := false;
end controldeclaration;
comment test procedures and texst facilityis;
boolean array testb(1:20);
integer testall,
testgetsymb,
testnametab;
procedure initoftest;
begin
integer index;
for index := 1 step 1 until 20 do
testb(index) := false;
testall := 1;
testgetsymb := 2;
testnametab := 3;
end initoftest;
boolean procedure test(index);
value index; integer index;
begin
test := testb(testall) or testb(index);
end test;
comment error handling procedures;
procedure fatalerror(errorstring);
string errorstring;
begin
comment called after unrecorverable error,
normaly table length violation.
the only goto statement in the program;
integer array errorline(1:stdlinelength);
convertstring(errorline,errorstring);
insertnlchar(errorline);
listline(errorline);
goto endprogram;
end fatalerror;
comment varius constants;
integer nil;
procedure initvariusconstants;
begin
comment varius generel constants is initialised in this procedure;
comment nil is the terminal symbol.
also used to assign variables indicate
undifined condition,
it schould be initialized to the max negative
integer or another appropriate number.
in a 24 bit 1 complement machine it is
-8388607, in 2 complement -8288608;
nil := -8388708;
comment dummy is used for varius purposes and
can not be expected thave any predefined
value, specialy used in for sentences;
dummy := 1234567;
end initvariusconstants;
comment varius variables;
integer ntabfree,
thisniveau,
thisniveauno,
dummy;
procedure initvariusvariables;
begin
comment initialise varius variable;
comment free pointer in name table and
identifier table.
the first symbol indexed by zero is not used;
ntabfree := 1;
comment the outmost niveau in a pascal program
contain all predeclared identifiers,
and is niveau 0, prefix niveau 1,
program niveau 2, and procedures niveau 3.;
thisniveauno := 0;
comment points to thefirst entry in the name table
containg entryes under thisniveauno;
thisniveau := ntabfree;
end initvariusvariables;
comment global variables used in connection with
code generation;
integer whilelabno,
replabno;
procedure initofcodevariables;
begin
comment initializing of variables used in connection with
code generation;
comment label numbers used to destinguish labes
generated from while and repeat statement;
whilelabno := 0;
replabno := 0;
end initofcodevariables;
procedure initofcodeconstants;
begin
comment initialising of constants used in conection with
with code generation;
end initofcodegeneration;
procedure initgenerel;
begin
comment call of all init procedures.
the order is critical
betwen every group;
comment first group;
initvariusconstants;
initclasscharsymbol;
initvariusvariables;
initofntabrecord;
comment second group;
initofsearchtable;
initofsymbolconstants;
comment third group;
initofnametable;
initofreservedwordsymbol;
initofcodeconstants;
comment fourth group;
initofcodevariables;
initoftest;
initinputoutputvariables;
end initgenerel;
procedure scantest;
begin
integer i;
next1;
write(out,<:<10>NEXT:>,<<-dddd>,symbol1,
<: INDEX::>,entry1,<: AUX::>,aux1,
<: TEXT1: :>);
i:=0;
for i:= i+1 while i<= stdlinelength and
text1(i) <> 0 do
outchar(out,text1(i));
if text1(i) = 0 then outchar(out,38);
end scantest;
comment transformation procedures;
comment
the syntax graphs in the comment is in the
following form.
symbols is represented with their names or
special charakters, fx :
while + ; := <= const
constructs definied by other graphs is
represented as the name of teh construct
enclosed in lessbraket and equalbraket, fx:
<identifier> <prefix> <statement>
arraows is represented with minuschars
directly folowed by less braket or
equal braket, fx:
---> ---->----- <---- ----<-----
for shifting from one arrow line to another
the charakter exclaration mark (!) is used.
no direction is suplied.
for syntaxgraps spreading over more lines
a number enclosed in greather and lessbraket is used.
fx :
-----> <3>
<3> ---->---
;
procedure program;
begin
comment
sequential program is
-> <prefix> -> <block> -> . ->
;
prefix;
block;
end program;
procedure prefix;
begin
comment
prefix is
--- <const definition> <--
! !
-------------------------------> <1>
! !
--- <type definition> <--
<1> --> <prefix routines> --> <programheading> -->
;
for dummy := next while symbol = namesymbol and
( aux = resconst or aux = restype ) do
begin
if aux = resconst then
constdefinition
else
typedefinition;
end;
prefixroutines;
programheading;
end prefix;
procedure constdefinition;
begin
comment
constant definition is:
--> const --> <identifier> --> = --> <constant> --> ; -->
! !
---------------------------------------
where the namesymbol const
allready is detected.
;
integer thisentry;
for dummy := next while symbol <> reservedword do
begin
if controldeclaration(symbol,entry) then
begin
insertname(entry,text,constantentry,nil);
if next0 = equalsymbol then
begin
constant;
end
else
begin
error(<:equalsign expected:>,skipreservedword);
end;
end
else
begin
if symbol = namesymbol and ntab(entry+entrytype) <> reservedword then
begin
error(<: allready decleared identifier:>,skipreservedword);
end
else
begin
error(<:identifier expected:>,skipreservedword);
end;
end;
end;
end constdefinition;
procedure constant;
begin
comment <constant> is :
<constant> is:
----> <identifier> ---------------->
! !
!--> <enumeration constant> -->!
! !
!--> <real constant> --------->!
! !
---> <string constant> ------->!
;
integer index;
next0;
if symbol0= numbersymbol then
begin
indec := changeentrylength(entry,length0(text0));
movetext4(ntab,index,text0);
comment type of the number is given in aux
either real or integer type;
ntab(entry+entrytypeid) := aux;
end
else
if symbol0 = stringsymbol then
begin
ntab(entry+entrytypeid) := stringtype;
index := changeentrylength(entry,length0(text0));
movetext4(ntab,index,text0);
end
else
if symbol0 = charsymbol then
begin
ntab(entry+entrytypeid) := chartype;
index := changeentrylength(entry,1);
ntab(entry+index) := aux0;
end
else
if symbol0 = namesymbol and aux0 = constantentry then
begin
ntab(entry+entrytypeid) := ntab(entry0+entrytypeid);
end
else
begin
error(<:illegal constant:>,skipreservedword);
end;
end constant;
procedure typedefinition;
begin
comment
type definitions is:
-->type--><identifier>-->=--><type>--> ; -->
! !
------------------------------------
where the reserved word type allready is met.
;
integer thisentry;
for dummy := next while symbol <> reservedword do
begin
if controldeclaration(symbol,entry) then
begin
insertname(entry,text,typedecentry,nil);
if next0 = equalsymbol then
begin
comment typedeclaration;
typedec(entry+typeidentry);
end
else
begin
error(<:equalsign exepcted:>,skipreservedword);
end;
end
else
if symbol = namesymbol then
begin
error(<:allready declared identifier:>,reservedword);
end
else
begin
error(<:identifier expected:>,reservedword);
end;
end;
end typedefinition;
procedure typedec;
begin
comment typedec is named type in the syntax graphs.
typedec is :
----><identifier>--------------->--
!--><enumeration type>-->--!
!--><real type>--------->--!
!--><array type>-------->--!
!--><record type>------->--!
!--><set type>---------->--!
!--><pointer type>------>--!
;
next0;
if symbol0 = reservedwordsymbol then
begin
if aux0 = resarray then
begin
arraytype;
end
else
if aux0 = resrecord then
begin
recordtype;
ntab(entry+entrytypeid) := recorddecentry;
end
else
if aux0 = resset then
begin
settype;
ntab(entry+entrytypeid) := setdecentry;
end
else
begin
error(<:illegal reserved word:>,skipsemicolon);
end;
end
else
if symbol0 = pointersymbol then
begin
pointertype;
end
else
if symbol0 = namesymbol then
begin
if entry = typedecentry then
begin
comment previus defined entry;
index := allocate(2);
ntab(index) := previusdefinedtype;
ntab(index+1) := entry;
end
else
begin
error(<:XXXXXX:>,skipsemicolon);
end;
end
else
if symbol0= namesymbol and aux0 = enumerationconstantentry then
begin
comment a subrangerefference type;
index := allocate(3);
ntab(index) := reffferencesubrance;
comment insert low range refferange;
ntab(index+1) := entry0;
if next <> subrangesymbol then
begin
error(<:subrangesymbol expected:>,semicolonsymbol);
end
else
begin
next0;
if sumbol0 <> namesymbol and aux0 = enumerationconstant then
begin
ntab(index+2) := entry0;
comment control types;
if ntab(ntab(index+1)+6) <> ntab(ntab(index+2)+6) then
begin
error(<:incompatibel subrange types:>,skipsemicolon);
end
else
begin
comment controlmin max value;
movetext5(text,ntab,ntab(index+1)+7);
convertintegertext(lowrange,text);
movetext5(text,ntab,ntab(index+2)+7);
convertintegertext(highrange,text);
if lowrange > highrange then
begin
error(<:subrange value error:>,skipsemicolon);
end;
end;
end;
end
else
if symbol0 = numbersymbol then
begin
comment a subrange integer type;
index :=allocate(3);
ntab(index) := subrangenumbertype;
convertintegertext(lowrange,text0);
ntab(index+1) := lowrange;
if next0 <> subrangesymbol then
begin
error(<:subrange expected:>,semicolonsymbol);
end
else
begin
next0;
if symbol0 <> numbersymbol then
begin
error(<:subrange type error:>,semicolonsymbol);
end
else
begin
convertintegertext(highrange,text0);
ntab(index+1) := highrange;
comment control min max value;
if lowrange > highrange then
begin
error(<:subrange value error:>,skipsemicolon);
end;
end;
end;
end
else
if symbol0=leftbraketsymbol then
begin
comment non standard enumeration type.
var or type dec. set to next dec type.
;
comment call scan identifier list,
including rigth braket;
identifierlist;
end
else
begin
error(<: type declaration expected:>,skipsemicolon);
end;
end typedec;
procedure arraytype;
begin
integer index;
index := allocate(1);
ntab(index) := arraytypedecblock;
next0;
if symbol0 <> leftarraybrakket then
begin
error(<:left array braket expected:>,semicolonsymbol);
end
else
begin
arraydimensions;
typedec;
end;
end arraytype;
procedure identifierlist;
begin
comment
identifierlist is:
-->(--><identifier>-->)-->
! !
---<--,<-----
and is transformed to:
enumeration type and a subrange record
is placed into the stack.
all identifiers is inserted inthe name table
as constants and typeid as next declared type.
their value is value of nextvalue, which is inserted
as normal for constants.
;
integer nextconstvalue;
integer index;
nextconstvalue := 0;
index := allocate(3);
ntab(index) := enumerationdeclaration;
previus := index+1;
for dummy := next1 while symbol = unknownnamesymbol do
begin
comment as type is inserted refference to next,
which is either the variable or typedecleration;
if controldecleration(symbol,entry) then
insert(text1,entry1,enumerationstantentry,nil);
ntab(previuslink) := entry1;
previuslink := entry1 +5;
comment insert entry to enumeration declaration;
ntab(allocate(1)) := index;
nextconstvalue := nextconstvalue+1;
converttextinteger(constanttext,nextconstantvalue);
index := allocate(length0(constanttext));
movetext4(ntab,index,constanttext);
includestackinentry(entry1);
end;
ntab(index+2) := nextconstvalue;
if symbol1 <> rigthparsymbol then
begin
if symbbol1 = namesymbol then
error(<:identifier allready declared:>);
else
error(<:identifier expected:>,skipsemicolon);
end;
end identifierlist;
procedure vardecleration;
begin
comment the reserved word 'var' is met;
integer previusdeclaredtype;
comment contain information abaut the previus delclered
type;
previusdeclaredtype := nil;
next;
if controldecleration(sy,bol,entry) then
begin
insert(entry,text,variabledec,nil);
if next0 <> colonsymbol then
begin
error(<:colon expected:>,semicolonsymbol);
end
else
begin
typedec;
includestackinentry(entry);
if ntab(entry+5) = previusdefinedentry then
definitionentry := ntab(entry+6)
else
definitionindex := entry+5;
definitiontype := ntab(definitionindex);
if definitiontype = pointertype then
begin
declareinteger(<:po:>,entry);
end
if definitiontype = subrangerefferencetype then
begin
declareinteger(<:uf:>,entry);
end
else
if difinitiontype = subrangenumbertype then
begin
declareinteger(<:un:>,entry);
end
else
if definitiontype = enumerationtype then
begin
delareinteger(<:en:>,entry);
end
end;
end;
if previusdeclaredtype <> nil then
begin
outcodechar(semicolon);
outcodenl;
end;
end vardecleration;
procedure declare(type,prefix,entry);
value dectype,entry;
string prefix;
begin
if type = previusdecleredtype then
begin
outcodechar(commachar);
outcodenl;
movetext6(text,ntab,entry-namelength);
converttexttostring(text1,prefix);
concat(text1,text);
end declare;
procedure prefixroutines;
begin
comment
prefix routines is:
<--<procedure heading><--
! !
-->------------------------------->
! !
<--<function heading><--
;
if symbol = reservedword
for dummy := dummy while (symbol = reservedword and
(aux = resfunction or aux = resprocedure) do
begin
if aux = resfunction then
functionheading
else
if aux = resprocedure then
procedureheading;
end;
end prefixroutines;
procedure compoundstatement;
begin
comment
compound statement is:
where the reserved word begin allready is met.
;
end compoundstatement;
procedure statement;
begin
comment statement is:
;
next;
is symbol = reservedverd then
begin
if aux = resbegin then
begin
comment compoundstatement;
compoundstatement;
end
else
if aux = resif then
begin
istatement;
end
else
if aux = resfor then
begin
forstatement;
end
else
if aux = reswhile then
begin
whilestatement;
end
else
if aux = resrepeat then
begin
repeatstatement;
end
else
if aux = reswith then
begin
withstatement;
end
else
begin
error(<:illegal reserved word, statement expected:>,skipsemicolon);
end
else
if symbol = namesymbol or symbol=unknownname then
begin
if symbol = unknownname then
begin
error(<:undeclared:>);
insert(entry,text,notype,nil);
end;
comment after meeting a name it can be either a assignment
statement or a routinecall.
A routine call can be a call of a function as
the call of a type procedure in algol.
if the next symbol is an assignment symbol then
it is assumed to be a assignment statement else
a routinecall.
next and next0 have the 2 first symbols
in the statement.
;
if next0 = assignmentsymbol then
assignmentstatement
else
routinecallstatement;
end
else
begin
error(<:statement expected:>,skipsemicolon);
end;
end statement;
procedure assignmentstatement;
begin
comment
assignmentstatement used for assignment.
assignment is:
--><variable>-->:=--><expr>-->
An assignment defines the assignment of an expression
value to a variable. The varable and the expression
must be compatible. The variable must not be a constant
parameter.
transformed to algol as:
--><varaible>-->:=--><expr>-->
the variable name is in next, the assignmentsymbol
is in next0.
;
integer assignmenttype;
end assignmentstatement;
procedure ifstatement;
begin
comment if statement is:
-----
where If allready is met.
;
outcodestring(<:if :>);
if expr <> booleantype then
begin
error(<:boolean expresion expected:>,skipsemicolon);
end;
comment after expr the reserved word then
schould be in next;
if symbol <> resthen then
begin
error(<:then expected:>,skipreservedwordsemicolon);
end
else
begin
outcodestring(<: then:>);
outcodenl;
end;
statement;
if symbol = reselse then
begin
outcode(<: else :>);
outcodenl;
statement;
end;
end ifstatement;
procedure forstatement;
begin
comment the for statement is:
where the reserved word for allready is met;
integer controlvariabletype;
outcodestring(<:for :>);
next;
if symbol = nametype then
begin
outcodestring(<:si:>);
movetext5(text,ntab,ntab(entry+entryrefname));
outcodetext(text);
if next <> assignmentsymbol then
begin
error(<:assignment expected:>,skipsemicolon);
end
else
begin
outcodestring(<::=:>);
if expr <> controlvariabletype then
begin
error(<:expresion type error:>,skipsemicolon);
end
else
begin
comment after expresion the reserved word
to or downto is met from call of next;
if symbol <> resto and symbol <> resdownto then
begin
error(<:to or downto expected:>,skipsemicolon);
end
else
begin
if symbol = resto then
outcodestring(<: step 1 until :>
else
outcodestring(<: step -1 until :>);
if expr <> controlvariabletype then
begin
error(<:expresion type error:>,skipsemicolon);
end
else
begin
comment the reserved word do is met in expresion
comment after expresion the reserved word
do is met from call of next;
if symbol <> resdo then
begin
error(<:do expected:>,noskip);
end;
outcodestring(<: do:>);
outcodenl;
statement;
end;
end;
end;
end;
end
else
begin
error(<:enumeration type variable expected:>,skipsemicolon);
end;
end forstatement;
procedure whilestatement;
begin
comment
while statement is:
-->'while'-->expr-->'do'-->statement-->
where the namesymbol 'while' allready is met.
transformed to algol as:
-->'whilelab<no>:'-->
-->'if -,('<expr>') then goto whilelab<no+1>'-->
--> <statement><semicolon> -->
! !
----------------------------
--'goto whilelab<no>'<semicolon> -->
-->whilelab<no+1><semicolon>-->
;
integer thiswhilelabelno;
integer array whilenotext,whileno1text(1:12);
thiswhilalabelno := whilelabno;
whilelabno := whilelabno +1;
thiswhilelabelno1 := whilelabno;
whilelabno := whilelabno +1;
outcodestring(<:whilelabel:>);
converttextinteger(whilenotext,thiswhilelabno);
outcodetext(whilenotext);
outcodechar(colonchar);
outcodechar(semicolonchar);
outcodenl;
outcodestring(<:if -,(:>);
expr;
if symbol <> name and aux <> resdo then
begin
error(<: do expected:>,skipsemicolon);
end;
outcodestring(<:) then goto whilelab:>);
outcodetext(whileno1text);
outcodechar(semicolonchar);
statement;
outcodestring(<:goto whilelab:>);
outcodetext(whilenotext);
outcodechar(semicolonchar);
outcodenl;
outcodestring(<:whilelab:>);
outcodetext(whileno1text);
outcodechar(colonchar);
end whilestatement;
procedure repeatstatement;
begin
comment
repeat statement is:
-->'repeat'-->statement-->'until'-->expr-->
! !
------<semicolon><------
where the name 'repest' is met.
translated to algol as:
-->'replab<no>:'-->statement<semicolon>-->
! !
-------------
-->'if -,('expr') then goto replab<no>'-->
;
integer thisreplabno;
integer array repnotext(1:12);
thisreplabno := replabno;
replabno := replabno+1;
converttextinteger(repnotext,thisreplabno);
outcodetext(repnotext);
outcodenl;
outcodestringstring(<:::>);
statement;
if symbol = name and aux = resuntil then
begin
outcodenl;
outcodestring(<:if -,(:>);
expr;
outcodestring(<:) then goto replab:>);
outcodetext(repnotext);
outcodechar(semicolonchar);
end
else
begin
error(<:until expected:>,skipsemicolon);
end
end repeatstatement;
comment start program;
initgenerel;
program;
end table dec. block;
comment label called from procedure fatalerror;
endprogram:
end outhermost block;
▶EOF◀