|
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: 39936 (0x9c00)
Types: TextFile
Names: »tinp«
└─⟦00964e8f7⟧ Bits:30007478 RC8000 Dump tape fra HCØ.
└─⟦b2ec5d50f⟧
└─⟦1a9e12e70⟧ »ccompose«
└─⟦this⟧
\f
\f
(
inp=algol connect.no fp.yes list.no
if ok.yes
scope user inp
lookup inp
)
begin integer buflim ;
buflim := 126 ;
begin
zone input(256,2,endcheck),output,text(128,1,stderror) ;
boolean vterm,efrec,lastcom,PGrec,group1,nlrec,wrong,console,
bsilgl,incom,incommand,print,name,
reread,properline ,lbufstop,cbufstop ;
integer minfont,maxfont,minlead,maxlead,minlw,maxlw,minval,maxval,
minTS,maxTS,mode,i,j,k,a,separator,htno,
ht,posn,p,order,order1,int,a1,length,
l,term,routine,linecount,A,pointer1,pointer2,
ftposn,cmdposn,preseparator,
prechar ,lines ,emchar ,char,class ,sourceparamno;
integer array table(0:511) ,actionb(1:28),
commandname(1:28),linebuf(1:buflim),compbuf(1:buflim+1,1:2);
real t1,t2 ;
real array ra(1:2),ERROR(1:20),nl(1:2) ,tform(1:1) ;
boolean array line(1:128) ;
comment procedures ;
integer procedure getchar(char) ;
comment getchar hands over the next character of input - skipping
illegal non-graphics and composed graphics.The routine initiates
input and output as required.Getchar gives the class of the character ;
integer char ;
begin integer i,separator1,k,b,j,type ,c ;
boolean bsgroup ,toolong ;
if reread then
begin
char := prechar extract 12 ;
getchar := prechar shift (-12) ;
reread := false ;
goto OUT2
end ;
bsgroup := toolong := false ;
\f
AGAIN:
if p>126 then goto NLINE ;
if p=126 then
begin
NLINE1:
outline ;
nl(1) :=nl(2) := 0.0 shift (-12) ;
NLINE:
length :=inline(input,line) ;
if abs(length) >1000 then
begin
length := sgn(length)*(abs(length)-1000) ; error(13,0) ;
end ;
if length < 0 then
begin length := -length ;error(12,0)end ;
p := 0 ;
end of reading line ;
p := p+1 ;comment address next character ;
char := line(p) extract 12 ;
getchar := prechar := type :=
if char = 127 then 1
else
if char > 127 then 4
else
if char > 57 then 11
else
case char + 1 of (1,11,11,11,11,11,11,11,
11,6,5,11,5,11,11,11,
11,11,11,11,11,11,11,11,
11,3,11,11,11,11,11,11,
7,11,11,11,11,11,11,11,
11,11,11,9,8,9,11,11,
10,10,10,10,10,10,10,10,
10,10) ;
if type > 6 then type := 6 ;
case type of
begin
comment 1 nul and del are skipped ;
goto AGAIN ;
comment 2 no class; ;
comment 3 em char,exit ;
begin
if efrec then goto EXIT1 ;
close(input,true) ;
if -,nextsource then goto EXIT1;
goto NLINE1 ;
end ;
comment 4 char with backspace indic,skipped ;
begin bsgroup := true ; goto AGAIN end ;
comment 5 nl and ff,line is output-next line input and
scanned for RO command ;
begin
outline ;
length := inline(input,line) ;
if abs(length) >1000 then
begin toolong := true ;length := sgn(length)*(abs(length)-1000) end ;
\f
p := 0 ;
separator1 := separator ;
for i := 1 step 1 until abs(length) do
begin
if line(i) extract 12 = separator1 then
begin comment look for RO OR SE command ;
k := i ;b := 0 ;
for j := 1 step 1 until 2 do
begin for k := k+1 while ( line (k) extract 12)=32 and k < 127 do ;
c := line(k) extract 12 ;
c := if c<96 then c add 32 else c ;
b := b shift 8 add c
end ;
if b = 115 shift 8 add 101 then
begin comment SE command ;
for k := k+1 while ( line (k) extract 12) = 32 and k < 127 do ;
if ( line (k) extract 12)>32 then separator1 := ( line (k) extract 12) ;
end
else if b = 114 shift 8 add 111 then
begin comment RO command ;
for k := k+1 while ( line (k) extract 12) = 32 and k < 127 do ;
if ( line (k) extract 12) = separator1 then
begin comment move remainder of the line up in the array,arrange that
the nl char is skipped ;
for i := 1 step 1 until abs(length) - k do line(i):=line(i+k) ;
nl(1) := nl(2) := 0.0 shift (-12) ;
if length<0 then
begin length := -length ;error(12,0) end ;
if toolong then error(17,0) ; toolong := false ;
goto AGAIN
end RO command found ;
end
end check command ;
end scan of next line ;
comment RO command not found,and end of scanned line reached ;
LINEEND:
if A <> 0 then erroroutput ;
if length <0 then
begin length := -length ;error(12,0) end ;
if toolong then error(13,0) ; toolong := false ;
if properline then linecount := linecount + 1 ;
properline := false ;
end of nl and ff handling ;
comment 6 other character ;
begin
if bsgroup then
begin comment ignore character and set error if in command ;
if bsilgl then error(1,order add 32) ;
bsgroup := false ;
goto AGAIN
end
end
end of case statement ;
prechar := prechar shift 12 add char ;
OUT2:
end of procedure getchar ;
\f
boolean procedure nextsource;
begin
integer no,sep;
array param,ra(1:2);
no:=sourceparamno+1;
nextsource:=false;
for sep:=system(4,no,param) while sep shift (-12)>3 do
begin
if sep=4 shift 12+10 then
begin
if system(4,no+1,ra) shift (-12)<6 then
begin
opendoc(input,param,1 shift 18 + 1 shift 16,0);
nextsource:=true;
goto F
end
end;
no:=no+1
end;
F: sourceparamno:=no;
end nextsource;
procedure opendoc(z,name,giveup,mode); value giveup,mode;
zone z; array name; integer giveup,mode;
begin integer i,q;
integer array zdes(1:20), tail(1:10);
getzone6(z,zdes); zdes(13):=4; setzone6(z,zdes);
q:=0; open(z, 4, string name(increase(q)),0);
getzone6(z,zdes); zdes(13):=4; setzone6(z,zdes);
if mode=0 then
begin q:=3;
if monitor(42,z,0,tail)<>0 then goto L
end;
q:=1 shift 1+1;
fpproc(27+mode,q,z,name);
if q<>0 then
begin
L: i:=0; write(out,<:***inp end. connect :>,
string name(increase(i)),<:, :>,<<d>,q,false add 10,1);
terminate(3);
end;
getzone6(z,zdes); zdes(10):=giveup; zdes(13):=0;
if mode=0 then
begin
zdes(14):=zdes(15):=zdes(19);
zdes(16):=0
end;
setzone6(z,zdes)
end;
procedure alarm(s); string s;
begin
write(out,<:***inp end. :>,s,<:<10>:>);
terminate(3);
end;
\f
procedure terminate(result); value result; integer result;
begin integer array zdes(1:20);
getzone6(input,zdes);
if zdes(13)<>4 then close(input,true);
getzone6(output,zdes);
if zdes(13)<>4 then close(output,true);
getzone6(text,zdes);
if zdes(13)<>4 then close(text,true);
fpproc(7,0,0,result)
end terminate;
integer procedure increase(i) ;
integer i ; increase := i := i+1 ;
procedure footfall;
comment footfall is called when an error is detected in
a command, it may be in the mnemonic code or in the
parameters, and the main program has skipped to the
next separator.
By examining the following characters it is checked
wheather the separator really is a end separator and
not a start separator and though indicating a missing
end separator;
begin integer i,j,a,a1;
READ2CHAR:
order:=order1:=0; name:=true;
incommand:=bsilgl:=nlrec:=false;
for i:=1,2 do
begin
for j:=getchar(a) while a=32 or j=5 do if j=5 then nlrec:=true;
if a=separator then goto COMMAND;
a1:=if a<96 then a+32 else a;
order1:=order1 shift 8 add a1;
order:=order shift 8 add a;
if j<>10 then name:=false
end;
if nlrec and mode=4 then
begin if htno>ht then
begin error(8,0); erroroutput
end;
htno:=0
end;
if group1 then
begin group1:=false; if -,PGrec then error(9,0)
end;
reread:=true;
\f
order1:=order1 shift 8;
order:=order shift 8;
for cmdposn:=1 step 1 until 26 do
if order1=commandname(cmdposn) then goto ACTION
else if name then
begin comment the 2 first characters after the separator are digits,
that is possible start of a name,
check if the next 3 characters are 2 digits and 1 separator;
name:=true;
for i:=1,2 do
begin j:=getchar(a);
if j<>10 then name:=false
end;
getchar(a); if a<>separator then name:=false;
if name then
begin comment skip to next separator;
for j:=getchar(a) while a<>separator do;
goto READ2CHAR
end;
end name;
goto DATAREAD; comment no missing end separator;
end footfall;
procedure error(x,a) ;
integer x,a ;
comment A and ERROR are global,x gives failure
number, a value referring to the failure
e.g. commandname ;
begin
wrong:=true;
if A< 20 then begin
A := A + 1 ;
ERROR(A) := 0.0 shift (-12) ;
ERROR(A) :=ERROR(A) add a shift 24 add x ;
end ;
end of procedure ;
real procedure pack(count) ;
comment packs the line number enclosed by
-separators- into a real. uses global - preseparator,which
gives the separator at the end of the previous line ;
value count ;
integer count ;
begin integer array table(1:6) ;integer i ;real rcount ;
table(1) := table(6) := preseparator ;
for i := 2 step 1 until 5 do
table (i) := 48 ; comment zeroes ;
i := 6 ;
for i := i-1 while count <> 0 do
begin
table(i) := count mod 10 + 48 ;
count := count // 10
end ;
for i := 1 step 1 until 6 do
rcount := rcount shift 8 add table(i) ;
pack := rcount ;
end of pack procedure ;
\f
procedure outline ;
comment outputs line to data file , and text file,if present ;
begin integer c,i,j,k,x,a,action,outlength ;
real array B,C(1:44) ;
x := i := k := 0 ;
for i := i+k while i<126 do
begin
k := 0 ; x := x + 1 ; B(x):=C(x) := 0.0 shift (-12) ;
for j := 1 step 1 until 6 do
begin
COMP1:
k := k+1 ;a := line(i +k) extract 12 ;
action := if a = 127 then 1
else
if a > 127 then 2 else
if a > 31 then 3 else
case a+1 of
(1,3,3,3,3,3,3,3,3,5,4,3,4,3,3,3,
3,3,3,3,3,3,3,3,3,4,3,3,3,3,3,3 ) ;
case action of
begin
comment 1 and 127 ignored ;
if i+k > 126 then goto COMP2 else goto COMP1 ;
comment 2 bs indication ;
begin
C(x):=C(x) shift 8 add (a extract 7);
B(x):= B(x) shift 8 add (a extract 7 ) ;
line(i+k) := false add 8 ;
k := k-1
end ;
comment 3 other char ;
begin
if a > 32 then properline := true ;
comment graphic in line ;
C(x):=C(x) shift 8 add a;
B(x) :=B(x) shift 8 add a ;
end ;
comment 4 nl and em and ff char ;
COMP2:
begin
if j= 1 then x := x-1 else
begin
k := 8 *(7-j) ;
C(x):=C(x) shift k;
B(x) :=B(x) shift k ;
end ;
goto FINISH ;
end ;
comment 5 HT character;
begin
B(x):=B(x) shift 8 add a;
C(x):=C(x) shift 8 add 38;
comment set and in text output;
end;
end of case statement ;
end of inner loop ;
end of outer loop ;
\f
FINISH: outlength := x ;
c:= 1 ;
if linecount mod 10 = 0 and -, incom and (nl(1) = real <:<10>:>
or nl(1)=real <:<12>:>) then
begin
if linecount >= 10000 then linecount := 0 ;
nl(2) := pack(linecount ) ;
c := 2
end ;
preseparator := separator ; comment set
current separator ;
incom := incommand ;
outdata(output,pointer1,nl,c,1) ;
outdata(output,pointer1,B,outlength,1) ;
if print then
begin
if nl(1)=real <:<10>:> then
begin comment form feed every 45 lines ;
lines := (lines + 1) mod 45 ;
if lines = 0 then outdata(text,pointer2,tform,1,1) ;
end
else if nl(1) = real <:<12>:> then
begin
lines := 0 ; nl(1) := real <:<10>:> ;
outdata(text,pointer2,tform,1,1) ;
end ;
outdata(text,pointer2,nl,2,1) ;
outdata(text,pointer2,C,outlength,1) ;
end ;
nl(1) := if a = 12 then real <:<12>:> else real <:<10>:> ;
comment set ff or nl character ;
nl(2) := real <: :> add 32 ;
end of outline procedure ;
\f
procedure erroroutput ;
comment this procedure is used after a line is output to give
msgs re the errors in the line,the failures have been saved
in the array ERROR.Pointer A gives the number of failures ;
begin integer i,j,k ; real array msg(0:4) ;
for i := 1 step 1 until A do
begin
j := (ERROR(i) extract 24 )*4 - 4 ;
for k := 1 step 1 until 4 do
msg (k) := real(case(k+j) of (
<:BS in:> add 32,<:typol:> add 32,<:comma:> add 110,<:d:>,
<:inval:> add 105,<:d dat:> add 97,<: :>,<: :>,
<:typol:> add 32,<:in te:> add 120,<:t :>,<:DUMMY:>,
<:too m:> add 97,<:ny li:> add 110,<:es in:> add 32,<:text:>,
<:inval:> add 105,<:d com:> add 109,<:and :>,<: :>,
<:comma:> add 110,<:d not:> add 32,<:first:> add 32,<:input:>,
<:unkno:> add 119,<:n com:> add 109,<:and :>,<: :>,
<:too m:> add 97,<:ny HT:> add 115,<: in p:> add 114,<:eline:>,
<:PS co:> add 109,<:mand :> add 110,<:ot in:> add 32,<:group:>,
<:no EF:> add 32,<:comma:> add 110,<:d:>,<: :>,
<:inval:> add 105,<:d in :> add 112,<:resen:> add 116,<: mode:>,
<:illeg:> add 97,<:l cha:> add 114,<:acter:>,<: :>,
<:line :> add 116,<:oo lo:> add 110,<:g:>,<: :> )) ;
if -, print then
begin comment current output ;
k := 0 ;
write(out,<:<10>* :>,<<dddd>,linecount,<: :>,
string(ERROR(i) shift (-24) shift 24) ,
string msg(increase(k))) ;
end
else
begin comment text file output ;
lines := (lines + 1) mod 45 ;
if lines = 0 then outdata(text,pointer2,tform,1,1) ;
msg(0) := real <:<10>* :> add ( ERROR(i) shift (-24) extract 24 ) ;
outdata(text,pointer2,msg,5,0) ;
end ;
end of inner block ;
A := 0 ; comment clear ERROR array ;
end of erroroutput procedure ;
\f
boolean procedure number(sum,vterm,term) ;
integer sum,term ;
boolean vterm ;
comment
input classes other space sign digit
0.init 4-0 1-0 2-1 3-2
1-after sign - 1-1 4-0 -
2.after digit - 1-2 - - ;
begin integer char,j,state,class,action ,i ;
integer array no(1:10) ;
boolean sign ;
state := 0 ; i := 0 ; number := false; sign := true ;
REPEAT:
class := (case getchar(char) of (1,1,1,1,1,1,2,1,3,4,1)) + state * 4 ;
state := case class of (0,0,1,2,0,1,0,2,0,2,0,2) ;
action := case class of (4,1,2,3,4,1,4,3,4,1,4,3) ;
case action of
begin
comment 1 space no action ; ;
comment 2 set sign ; if char = 45 then sign := false ;
comment 3 set digit ;
begin number := true ; i := i+1 ; no(i) := char end ;
comment 4 terminate ; goto OUT
end ;
goto REPEAT ;
OUT:
sum := 0 ;
if i>0 then
begin
for j := 1 step 1 until i do
sum := sum+(no(j)-48)*10**(i-j) ;
if -, sign then sum := -sum
end ;
term := char ;
vterm:=term=44;
end of procedure ;
procedure outdata(a,b,c,d,e) ;
comment this procedure builds up a record to be output
by standard proc. outrec .
a zone name
b pointer in buffer
c real array with data
d no of elements in array
e starting point in array ;
zone a ;
integer b,d,e ;
array c ;
begin integer i ;
for i := e step 1 until (e + d-1 ) do
begin
if b> 128 then begin outrec(a,128) ; b := 1 end ;
a(b) := c(i) ;
b := b + 1 ;
end ;
end of outdata procedure ;
\f
procedure endcheck(z,s,b) ;
zone z ; integer s,b ;
comment global emchar is used - this is set up when data
for intable is given ;
begin
if s extract 1 > 0 then stderror(z,s,b) else
if s shift (-18) extract 1 = 1 and b = 0
or s shift (-16) extract 1 = 1 then
begin
b := 2 ;
z(1) := 0.0 shift 8 add emchar shift 8 add emchar
shift 8 add emchar shift 24 ;
end
end of blockproc ;
integer procedure inline(z,a);
zone z; boolean array a;
begin comment
the procedure reads a line from the zone z and puts the line in the array a
with one character pr. element.
in case the line contains composed characters, the elements are placed in
sequence and characters which should b followed by a bs-character have bit 1
set to 1.
parameters:
z a zone which should be opened and closed and initialized by setposition
outside the procedure.
a a boolean array declared with the limits 1:buflim.
(concerning buflim see later)
after a call of the procedure the array will contain a line where a line
is a string of characters terminated by a class 3 character (nl,ff).
if an input line has more than buflim characters succeding calls of the procedure
will put blocks of buflim characters in the array until a class 3 character
is met.
for lines longer than buflim positions will backspacing across the buflimth
character give an erroneous result.
value:
after a call inline will assume one of the following values:
a +no. of characters in the array under normal conditions.
b -no. of characters in the array in the case that one or more characters of class 5
is met.
c 1000+no. of characters in the array a in case of the last call of the
procedure in connection with a line where the buffer for composed
characters is exceeded.
both buffers contain max. buflim elements.
the characters read until the buffer for composed elements is filled up
are placed in a and the rest of the line is skipped.
\f
method:
the buffer for composed characters mentioned above is contained in an array
with the limits 1:buflim+1,1:2.
the first column contains the character values and the second column the
corresponding graphical position in the line.
after a line is read the elements in the buffer for composed characters
are sorted into sequence corresponding totheir graphical positions.
afterwards the buffer is merged with the ordinary line buffer into the array
a.
global variables:
char an integer containing the last read character.
char should be initialized to 0 in the start of the program.
class an integer containing the class of the last read character.
class should be initialized to 0 in the start of the program.
lbufstop a boolean which is true when the array a is filled during merging
from the linebuffer and else false.
cbufstop a booleanwhich is true when the array a is filled up during merging
from the buffer for composed characters, and else false.
buflim an integer containing the size of the buffers.
buflim should be set the max. number of characters in a normal
input line in the start of the program.
linebuf a one-dimensional array containing a character pr element corresponding
to the position in the line.
in the case of composed characters is only the first element i linebuf.
compbuf a two dimensional array containing the second and the following elements of
composed characters.
the first column contains the character values and the second the
position in the line.
linebuf and compbuf should be declared as integer arrays with the
limits 1:buflim and 1:buflim+1,1:2 respectively.
own varibles:
curl an own integer indicating the current index of the linebuffer.
curc an own integer indicating the current index of the buffer for
composed characters.
curcmax an own boolean set true if the buffer for composed characters is
exceeded.
class5 an own boolean set true if a character of class 5 is met in the line.
li, ci own integers containing the index of linebuf and compbuf respectively
during merging to the output array a.
local variables:
lb a boolean set true if the next character read is to be stored in
linebuf and set false if it is to be stored in compbuf.
point an integer pointing at the actual position of the line.
point is counted 1 up for each chracter read with the exception of
bs and cr. in the case of bs point is counted 1 down and in the case
of cr point is set to 0.
ai an integer containing the current index of the output array a.
;
integer point,ai; own integer li,ci,curl,curc;
boolean lb; own boolean curcmax,class5;
comment globals boolean lbufstop ,cbufstop
integer class,char,buflim
integer array linebuf(1:buflim),compbuf(1:buflim+1,1:2);
\f
procedure shellsort(a,n);
value n; integer array a; integer n;
begin integer i,j,k,m,w1,w2;
for i:=1 step i until n do m:=2*i-1;
for m:=m//2 while m<>0 do
begin
k:=n-m;
for j:=1 step 1 until k do
begin
for i:=j step -m until 1 do
begin
if a(i+m,2)>=a(i,2) then goto l1;
w1:=a(i,1); w2:=a(i,2);
a(i,1):=a(i+m,1); a(i,2):=a(i+m,2);
a(i+m,1):=w1; a(i+m,2):=w2;
end i;
l1: end j;
end m;
end shellsort;
if lbufstop or cbufstop then goto merge;
curl:=curc:=point:=0;
curcmax:=class5:=false; lb:=true;
if class<>3 then
begin
for class:=class,readchar(z,char) while class<>3 do
if class=2 then
class2:
begin
if lb then
begin
if curl=buflim then goto outp;
curl:=curl+1; point:=point+1;
linebuf(curl):=char;
end
else
begin
if curc=buflim then
begin
curcmax:=true;
for class:=readchar(z,char) while class<>3 do;
comment rest of line skipped;
if curl<buflim then curl:=curl+1;
linebuf(curl):=char; class:=0;
goto outp;
end;
point:=point+1;
lb:=point=curl;
if char<>32 then
begin
curc:=curc+1;
compbuf(curc,1):=char;
compbuf(curc,2):=point
end;
end lb false;
end class =2
else
\f
if class=0 then begin comment skipped;end
else
if class=4 then
begin
lb:=false;
point:=if char=8 then point-1 else 0;
if point<0 then point:=0;
end
else
begin comment class=5;
class5:=true;
goto class2
end read loop;
end class<>3;
comment class=3;
if curl<buflim then
begin
curl:=curl+1;
linebuf(curl):=char;
class:=0;
end;
outp:
if curc>0 then
begin comment sort of compbuf and merging with linebuf;
shellsort(compbuf,curc);
li:=1; ci:=1;
merge:
ai:=0;
for li:=li step 1 until curl do
begin
if ai=buflim then
begin
lbufstop:=true;
goto procvalue
end;
if -,cbufstop then
begin
ai:=ai+1;
a(ai):=false add linebuf(li)
end;
for ci:=ci while ci<=curc and compbuf(ci,2)=li do
begin
if ai>0 then a(ai):=a(ai)add 1024;
if ai=buflim then
begin
cbufstop:=true;
goto procvalue
end;
if a(ai) extract 12<>1056 then ai:= ai+1 ;
comment <sp><bs> skipped ;
a(ai):=false add compbuf(ci,1);
ci:=ci+1
end ci loop
end li merge loop;
\f
lbufstop:=cbufstop:=false;
end if curc>0
else
begin
for ai:=1 step 1 until curl do a(ai):=false add linebuf(ai);
ai:=curl;
end;
procvalue:
if curcmax and -,(lbufstop or cbufstop) then ai:=ai+1000;
inline:=if class5 then -ai else ai;
end inline;
\f
begin comment scan call parameters;
integer sep,no,next,q,machine;
boolean readtable;
real array param,sourcefile,tablefile(1:2);
machine:=4; print:=false;
readtable:=false; sourceparamno:=0;
sep:=system(4,1,param);
if sep=6 shift 12+10 then
begin
system(4,0,param); opendoc(output,param,0,1);
end else
alarm(<:no object:>);
no:=2;
for sep:=system(4,no,param) while sep shift (-12)>3 do
begin
if sep extract 12 <> 10 then goto paramerror;
if param(1)=real<:machi:> add 110 then
begin
sep:=system(4,no+1,param);
if sep=8 shift 12+4 then
begin
machine:=param(1)+3;
if machine>5 or machine<4 then goto paramerror;
next:=no+2
end else
if sep shift (-12)<6 then goto sourcename
else goto paramerror
end else
if param(1)=real<:text:> then
begin
sep:=system(4,no+1,param);
if sep=8 shift 12+10 then
begin
opendoc(text,param,0,1);
print:=true;
next:=no+2
end else
if sep shift (-12)<6 then goto sourcename
else goto paramerror
end else
if param(1)=real<:table:> then
begin
sep:=system(4,no+1,param);
if sep=8 shift 12+10 then
begin
tablefile(1):=param(1); tablefile(2):=param(2);
next:=no+2; readtable:=true
end else
if sep shift (-12)<6 then goto sourcename
else goto paramerror;
end else
begin
sourcename:
if sourceparamno=0 then
begin
sourceparamno:=no+1;
system(4,no,sourcefile);
end;
next:=no+1
end;
\f
if system(4,next,param) shift (-12) >=6 then
goto paramerror
else no:=next
end while;
if false then
paramerror:
begin
write(out,<:***inp param :>);
for sep:=system(4,no,param) ,
system(4,no,param) while sep shift (-12)>5 do
begin
write(out,if sep shift (-12)=8 then <:.:> else <: :>);
i:=0;
if sep extract 12=10 then
write(out,string param(increase(i))) else
write(out,<<d>,entier(param(1)+.5));
no:=no+1
end;
outchar(out,10);
terminate(3);
end;
if sourceparamno=0 then alarm(<:no source:>);
opendoc(input,sourcefile,1 shift 18+1 shift 16,0);
begin
zone intab(256,2,stderror) ;
integer i,class,x,y,z ;
if readtable then
begin comment set up table as user requires ;
opendoc(intab,tablefile,0,0);
emchar := 511 ;
for i := 0 step 1 until 511 do
table(i) := 5 shift 12 add 33 ;
for i := read(intab,x,y,z) while i = 3 do
begin
if x<0 or x>511
or (y<0 or y>127 and z<>1)
or z<0 or z> 5 then alarm(<:input table data error:>);
class := if (y=10 or y=12 or y=25) then 3
else if (y=8 or y=13) then 4
else if (y=0 or y=127) and z<>1 then 0
else z ;
table(x) := class shift 12 add y ;
if y= 25 and x<emchar then emchar := x ;
comment save users lower case value for EM character ;
end ;
close(intab,true) ;
end
else
\f
begin comment set up table for iso-code input
and output where non-graphics are illegal chars ;
for i := 1 step 1 until 7,
11,
14 step 1 until 24,
26 step 1 until 31,
128 step 1 until 255 do
table(i) := 5 shift 12 add 33 ;
table(0) := table(127) := 0 ;
comment blind characters ;
table(10) := table(12) := table(25) := 3 ;
comment nl,ff,em line terminators ;
table(8) := table(13) := 4 ;
comment bs,cr special characters ;
for i := 9,32 step 1 until 126 do table(i) := 2 ;
for i := 0,8,9,10,12,13,25,32 step 1 until 127 do
table(i) := table(i) shift 12 add i ;
emchar := 25 ;
end ;
end setting up intable ;
minfont := case machine of (1,1,1,1,1) ;
maxfont := case machine of (2,7,1,1,1) ;
minlead := case machine of (0,12,12,12,3) ;
maxlead := case machine of (31,24,24,24,30) ;
minlw := case machine of (0,0,0,0,0) ;
maxlw := case machine of (140,325,325,325,325) ;
minTS := case machine of (5,1,1,1,1) ;
maxTS := case machine of (12,1,1,1,1) ;
comment 1 for JUSTOTEXT, 2 for DURA 941, 3 flexo, 4 RC 610 lp
5 diablo ;
intable(table) ;
tableindex := 0 ;
write(out,<:input syntax check begin.:>);
systime(1,0,t1);
write(out,<< zd dd dd>,systime(2,t1,t2),t2);
setposition(out,0,0);
end scan and init;
incommand :=incom := efrec := reread :=
lbufstop := cbufstop := properline := bsilgl := line(127) := line(128) :=false ;
mode := linecount := 1 ; comment justifying mode and 1st line set ;
A := char := class := lines := 0 ; tform(1) := real <:<12><10><10>:> ;
p := 127 ; pointer1 := pointer2 := 129 ; comment to
initialise input and output ;
if print then outdata(text,pointer2,tform,1,1) ;
comment form feed for printout ;
separator := preseparator := 42 ; comment * ;
nl(1) := 0.0 shift (-12) ; nl(2) := real <: :> add 32 ;
comment set up tables for actions ;
for i := 1 step 1 until 28 do
actionb(i) := case i of
(1,1,1,1,1,3,3,16,4,4,4,4,5,2,6,7,8,9,10,10,11,12,17,13,14,15,6,4) ;
comment set up command name table ;
for i := 1 step 1 until 28 do
commandname(i) := real (case i of (
<:rj:>,<:sj:>,<:ct:>,<:ta:>,<:qr:>,<:nl:>,<:np:>,<:ns:>,<:ft:>,
<:ts:>,<:lw:>,<:ld:>,<:ps:>,<:sc:>,<:se:>,<:pl:>,
<:pn:>,<:rh:>,<:fn:>,<:mt:>,<:cm:>,<:ro:>,<:sb:>,
<:ef:>,<:lm:>,<:fg:>,<:ds:>,<:sl:>)) shift (-24) extract 24 ;
\f
ftposn := 8 ;
comment N.B. in the command table the mode commands
must be the first to occur :
commands which depend on mode must be at the start of
the table,actiona array gives action related to mode :
ft,ts,lw,ld must lie together in that order(these commands
are dependent on the typesetting equipment):-ftposn-
gives the posn-1 of ft relative to the start of the
table ;
INITIAL:
for i := getchar(a) while a <= 32 do;
name := true ; group1 := true ;PGrec := false ;
if a = separator then goto COMMAND else error(6,0) ;
comment must start with command group ;
DATAREAD:
for i := getchar(a) while a<>separator do
if mode=4 then
begin comment tab mode checks ;
if i=6 then htno := htno+1 else if i=5 then
begin
if htno>ht then
begin
error(8,0) ;
erroroutput ;
end ;
htno := 0 ;
end
end ;
COMMAND:
incommand := bsilgl := name := true ;
order := order1 := 0 ;
for i := 1 step 1 until 2 do
begin
for j := getchar(a) while a = 32 do ;
a1 := if a<96 then a add 32 else a ;
order1 := order1 shift 8 add a1 ;
order := order shift 8 add a ;
if a=separator then
begin comment end separator met before valid
command read;
error(7,order shift 8 add 32);
goto COMMEND
end;
if j <> 10 then name := false ;comment char not digit ;
end ;
order1 := order1 shift 8 ;
order := order shift 8 ; comment as for string with chars
left justified,and padded out with zeroes ;
for cmdposn := 1 step 1 until 28 do
if order1 = commandname(cmdposn) then goto ACTION ;
if -, name then error(7,order add 32) ;
\f
comment either illegal command or -name- to come here ;
for i := getchar(a) while a<> separator do
if a <> 32 and i <> 10 then name := false ; comment only digits and spaces valid ;
if name then
begin
for i := p,i-1 while line(i) extract 12 <> separator,i do
line(i) :=false ;
end
else footfall;
goto COMMEND ;
ACTION:
routine:=actionb(cmdposn);
case routine of
begin
begin comment 1 RJ,SJ,CT,TA commeands ;
if mode=4 then
begin
if htno>ht then error(8,order add 32) ;
htno := 0 ;
end check for no of HTs in line ;
mode := cmdposn ; comment set new mode ;
if mode=4 then
begin comment TA command ;
htno := 0 ;
ht := -1 ; comment no of tabs per line ;
vterm := true ;
for ht := ht+1 while vterm do
if -, number(int,vterm,term) then goto DATAERR ;
if term<>separator or ht>24 then goto DATAERR ;
end
else goto ENDSEPARATOR
end ;
ENDSEPARATOR:
begin comment SC commands ;
for i := getchar(a) while a<>separator do
if a<>32 then goto CHARERR ;
comment only spaces valid ;
end ;
begin comment 3 NL,NP command ;
if number(int,vterm,term) and
int<0 or term<>separator
then goto DATAERR
end ;
begin comment 4 FT,TS,LW,LD,SL commands ;
if cmdposn=28 then cmdposn:=12;
minval := case cmdposn-ftposn of (minfont,minTS,minlw,minlead) ;
maxval := case cmdposn-ftposn of (maxfont,maxTS,maxlw,maxlead) ;
comment values set up at initialisation depending
on typesetting machine ;
if -, number(int,vterm,term) or
int<minval or int>maxval
or term<>separator then goto DATAERR ;
end ;
\f
begin comment 5 PS command ;
PGrec := true ;
if mode=4 then
begin
if htno>ht then error(8,order add 32) ;
htno := 0
end ;
if number(int,vterm,term) then
begin
if int<0 then goto DATAERR
end;
if vterm then
begin
if number(int,vterm,term)
and int<0 then goto DATAERR
end;
if term<>separator then goto DATAERR;
end ;
begin comment 6 SE command ;
for i := getchar(a) while a= 32 do ;
if cmdposn=27 and a=separator then goto N;
if a<32 or
a=45 or
a=95 or
a=126 then goto CHARERR ;
comment non-graphic, hyphen,
underline and overline are illegal ;
j := a ;
for i := getchar(a) while a=32 do ;
if a<>separator then goto CHARERR ;
if cmdposn=15 then
separator := j ;
N: end ;
begin comment 7 PL command ;
integer array arg(1:5) ;
for j := 1 step 1 until 5 do
arg(j) := case j of (297,30,235,18,10) ;
comment set standard arguments ;
for j := 1 step 1 until 4 do
begin
if number(int,vterm,term) then
begin
arg(j) := int ;
if int<0 then goto DATAERR ;
end ;
if -, vterm then goto DATAERR ;
end ;
if number(int,vterm,term) then
arg(5) := int ;
if arg(5)<0 then goto DATAERR ;
if term<>separator or
arg(5)>arg(4) or
arg(2)<arg(4)
then goto DATAERR ;
end ;
\f
begin comment 8 PN command ;
if -,number(int,vterm,term) or
int<0 or
int>5 then goto DATAERR ;
comment check position ;
if -, number(int,vterm,term) or
term<>separator or int<0
then goto DATAERR ;
comment page number must be positive;
end ;
begin comment 9 RH command ;
for j := getchar(a) while a=32 do ;
if a<>separator then
begin
reread := true ;
goto FN
end
end ;
FN:
begin comment 10 FN,MT commands ;
if -, number(int,vterm,term) or
int<minfont or int> maxfont
or -, vterm then error(2,order add 32) ;
comment test for font ;
goto CM
end ;
CM:
begin comment 11 CM command ;
bsilgl := wrong := false ; j := 0 ;
for k := getchar(a) while a<>separator do
if k=5 then j := j+1;
if (order1=real <:rh:> shift (-24) extract 24 and j>3) or
(order1=real <:mt:> shift (-24) extract 24 and j>0)
or (order1=real<:ns:> shift (-24) extract 24 and j>0)
then error(4,order add 32) ;
comment 3 nl valid in RH text,0 valid
in MT+NS text ;
if wrong then footfall;
end ;
begin comment 12 RO command ;
error(5,order add 32) ;
goto ENDSEPARATOR
end invalid RO command ;
begin comment 13 EF command ;
efrec := true ;
if mode=4 then
begin
if htno>ht then error(8,order add 32) ;
htno := 0 ;
end ;
for i := getchar(a) while a=32 do ;
if a<>separator then error(2,order add 32) ;
for i := getchar(a) while i=i do ;
comment check EF command and read to em
which causes jump to EXIT1 ;
end ;
\f
LM:
begin comment 14 LM commands ;
if -, number(int,vterm,term) or
int<0 or term<>separator then goto DATAERR
end ;
begin comment 15 FG command ;
if mode=4 then
begin
if htno>ht then error(8,order add 32) ;
htno := 0 ;
end ;
goto LM
end ;
begin comment 16 NS command;
if -,number(int,vterm,term) or -,vterm
or int<minfont or int>maxfont
then goto DATAERR;
comment check font;
if -,number(int,vterm,term) or -,vterm or int<1 then goto
DATAERR;
comment check linefeed parameter;
goto CM; comment check textstring;
end;
begin comment 17 SB command;
if -,number(int,vterm,term) then
begin comment char,parameter expected;
if term<32 then goto DATAERR;
comment nonprintable;
number(int,vterm,term); comment to read terminator;
if -,vterm or -,number(int,vterm,term) then goto DATAERR;
end
else if vterm then
begin
if -,number(int,vterm,term) then goto DATAERR
end numeric char;
comment now checkvalue of parameter;
if int<1 or int>17 or term<>separator then goto DATAERR
end;
DATAERR:
begin
error(2,order add 32) ;
if term <> separator then
for i := getchar(a) while a <> separator do ;
footfall;
end ;
CHARERR:
begin
error(2,order add 32) ;
for i := getchar(a) while a <> separator do ;
footfall; end ;
end of case statement : actions for commands and error11 and error2 ;
\f
COMMEND:
incommand := bsilgl := nlrec:=false ; comment outside command;
for i := getchar(a) while a = 32 or i = 5 do if i=5 then nlrec:=true ;comment spaces
and nl chars ignored between commands ;
if a = separator then goto COMMAND ;
if nlrec & mode=4 then
begin
if htno>ht then
begin error(8,0); erroroutput
end;
htno:=0
end;
if group1 then
begin group1 := false ; if -, PGrec then error(9,0) end ;
reread := true ;
goto DATAREAD ; comment return to scanning text ;
EXIT1:
if -, efrec then error(10,0) ;
EXIT2:
outline ;
if A <> 0 then erroroutput ;
nl(1) := real <:<25>:> ; comment em ;
outdata(output,pointer1,nl,1,1) ;
for i := pointer1 step 1 until 128 do
output(i) := 0.0 shift (-12) ;
comment fill block with nulls ;
nl(1) := real <:<10><25>:> ; comment nl and em ;
if print then
begin
outdata(text,pointer2,nl,1,1 ) ;
for i := pointer2 step 1 until 128 do
text(i) := 0.0 shift (-12) ;
comment fill block with nulls ;
end ;
EXIT3:
write(out,<:<10>input syntax check end. :>) ;
systime(1,0,t1) ;
write(out,<< zd dd dd>,systime(2,t1,t2),t2,<:<10>:>) ;
terminate(0);
end ;
end
▶EOF◀