⟦5a4301938⟧

TextFile

job hj 6 200 time 11 0 area 10 size 100000
message op lib job
( source = copy 25.1
  opliblst = set 1 disc1
  opliblst = indent source mark lc
  listc = cross opliblst
  o errors
  message op lib
  pascal80 spacing.1000 codesize.1000 openv source
  o c
  lookup pass6code
  if ok.yes
  ( oldoplib = move oplib
    oplib = move pass6code
  )
  opliblst = copy listc errors
  scope user opliblst
finis )
\f


(*-------------------------- op lib -----------------------------------*)
prefix openzone;
procedure openzone (          (*  opens a zone for driver comm. *)
var z: zone;                  (*  the zone to be opened       *)
driv: ^semaphore;         (*  driver process sem          *)
answ: ^semaphore;         (*  answers arrives here        *)
bufs : integer;               (*  no of buffers               *)
var home: pool 1;             (*  ownerpool for buffers       *)
v1, v2, v3, v4: byte );       (*  u values in message headers *)

const
output = 2;
firstbuf = 6;                (*  general driver buffer    *)
lastbuf = firstbuf+80-1;

type
buffer = record              (*  for driver comm.       *)
first,                   (*  pointer to 1st char  *)
last,                    (*  pointer to last output char  *)
next: integer;           (*  pointer to last+1 input char *)
chars: array (firstbuf..lastbuf) of char
end;

begin
with z do
begin
driver:= driv;
answer:= answ;
u2val := v2;
state := 0;
readstate:= -1;
nextp:= firstbuf;
lastpos:= lastbuf;

for bufs:= bufs downto 1 do
begin
alloc ( cur, home, answer^);
cur^.u1:= v1;
cur^.u2:= 0;
cur^.u3:= v3;
cur^.u4:= v4;
lock cur as buf: buffer do  with buf do
begin
first:= firstbuf;
last:= lastbuf;
next:= first
end;
signal ( cur, free )
end
end
end ; (*  of openzone  *)

\f


prefix openopzone;
procedure openopzone (          (*  opens a zone for operator comm. *)
var z: zone;                  (*  the zone to be opened       *)
driv: ^semaphore;         (*  driver process sem          *)
answ: ^semaphore;         (*  answers arrives here        *)
bufs : integer;               (*  no of buffers               *)
var home: pool 1;             (*  ownerpool for buffers       *)
v1, v2, v3, v4: byte );       (*  u values in message headers *)

const
output = 2;
firstbuf = 6+alfalength;                (*  operator buffer    *)
lastbuf = firstbuf+80-1;

type
opbuffer = record              (*  for operator comm.       *)
first,                   (*  pointer to 1st char  *)
last,                    (*  pointer to last output char  *)
next: integer;           (*  pointer to last+1 input char *)
name: alfa;              (*  process inc name             *)
chars: array (firstbuf..lastbuf) of char
end;

begin
with z do
begin
driver:= driv;
answer:= answ;
u2val := v2;
state := 0;
readstate:= -1;
nextp:= firstbuf;
lastpos:= lastbuf;

for bufs:= bufs downto 1 do
begin
alloc ( cur, home, answer^);
cur^.u1:= v1;
cur^.u2:= 0;
cur^.u3:= v3;
cur^.u4:= v4;
lock cur as buf: opbuffer do  with buf do
begin
name:= own.incname;
first:= firstbuf;
last:= lastbuf;
next:= first
end;
signal ( cur, free )
end
end
end ; (*  of openopzone  *)

\f


prefix outend;
procedure outend (              (*  sends outputbuffer to driver  *)
var z: zone        );           (*  specifies the document     *)

type
zonebuffer = record
first, last, next: integer;
(*  the rest is silence here    *)
end;

begin
with z do
if not nil ( cur) then
begin
lock cur as buf: zonebuffer do  buf.last:= nextp-1;
cur^.u2:= u2val;
signal ( cur, driver^)
end
end ; (*  of outend  *)

\f


prefix outchar;
procedure outchar (                (*  writes 1 char in zone z  *)
var z: zone;                     (*  specifies the document  *)
t: char           );             (*  character to be written *)

const
opsize = 3+ (alfalength+80) div 2;

type
zonebuffer = record
first, last, next: integer;
chars: array (6..6+80-1) of char
end;
opbuffer = record
first, last, next: integer;
name: alfa;
chars: array (6+alfalength..6+alfalength+80-1) of char
end;

begin
with z do
begin
if nil ( cur) then        (*  get a buffer  *)
begin
wait ( cur, free);
state:= cur^.u2;
lock cur as buf: zonebuffer do  nextp:= buf.first;
end;
if cur^.size >= opsize then
lock cur as buf: opbuffer do buf.chars(nextp):= t
else
lock cur as buf: zonebuffer do buf.chars(nextp):= t;
nextp:= nextp+1;
if nextp > lastpos then outend ( z)
end
end ; (*  of outchar  *)

\f


prefix outtext;
procedure outtext (                 (*  writes text on z  *)
var z: zone;                        (*  specifies the document  *)
text: alfa         );               (*  text to be written
                                       # works as textstop         *)

var
i: byte:= 1;

begin
while text(i) <> "#" do
begin
outchar ( z, text(i));
if i = alfalength then text(i):= "#"  else i:= i+1
end
end ; (*  of outtext  *)

\f


prefix outfill;
procedure outfill (                (*  repeated outchar    *)
var z: zone;                       (*  specifies the document  *)
filler: char;                      (*  character to be written *)
rep: integer     );                (*  repeat counter          *)

begin

for rep:= rep downto 1 do outchar ( z, filler)

end ; (*  of outfill  *)

\f


prefix outnumber;
procedure outnumber (              (*  write an integer as decimal  *)
var z: zone;                       (*  specifies the document       *)
num: integer;                      (*  the integer                  *)
pos: integer      );               (*  no of writepositions         *)

(*
pos may give some spaces before the number, but all
digits are written.
*)

var
neg: boolean;
i: byte:= 1;
digits: array (1..5) of char;

begin
if num = -32768 then
begin
outfill ( z, sp, pos-6);
outtext ( z, "-32768#     ")
end
else
begin
neg:= num < 0;
if neg then
begin
pos:= pos-1;
num:= -num
end;

repeat
digits(i):= chr ( num mod 10 + ord("0"));
num:= num div 10;
i:= i+1
until num = 0;

outfill ( z, sp, pos-i+1);
if neg then outchar ( z, "-");
for i:= i-1 downto 1 do outchar ( z, digits(i))
end
end ; (*  of outnumber  *)

\f


prefix outhex;
procedure outhex (          (*  writes an integer as hexadecimal  *)
var z: zone;                (*  specifies the document    *)
num: integer;               (*  number to be written      *)
pos: integer    );          (*  write positions           *)

type
table = array (0..15) of char;

const
hextab = table ("0","1","2","3","4","5","6","7",
                "8","9","a","b","c","d","e","f"  );

var
bit0: byte:= 0;

begin
if num < 0 then
begin
bit0:= 8;
num:= num - (-32768);
end;
outfill ( z, sp, pos-4);
outchar ( z, hextab(bit0+num div (16*16*16)));
outchar ( z, hextab(num div (16*16) mod 16));
outchar ( z, hextab(num div 16      mod 16));
outchar ( z, hextab(num             mod 16));
end ; (*  of outhex  *)

\f


prefix opin;
procedure opin ( var z: zone);         (*  request input  *)

var
msg: reference;

begin
with z do
if open ( free) then
begin
wait ( msg, free);
msg^.u2:= u2val;
signal ( msg, driver^)
end
end ; (*  of opin  *)

\f


prefix opanswer;
procedure opanswer (         (*  transfers a message to zone z  *)
var msg: reference;          (*  a message with operator input  *)
var z: zone          );      (*  an input zone                  *)

begin

signal ( msg, z.dataready)

end ; (*  of opanswer  *)

\f


prefix optest;
function optest ( var z: zone ): boolean;
(*
optest is true if the zone has some data ready.
i. e. opwait will not wait.
*)

begin

optest := open ( z.dataready)

end ; (*  of optest  *)

\f


prefix opwait;
procedure opwait (            (*  waits for input to z  *)
var z: zone;                  (*  specifies the document  *)
var inputpool: pool 1 );      (*  input buffer pool       *)

const
read = 1;

type
zonebuffer = record
first, last, next: integer
end;

var
n: integer:= 0;     (*  msg counter  *)
operatorinput: boolean;

begin
with z do
if nil ( cur) then
begin
if not open ( dataready) then      (*  wait for input answer  *)
begin
repeat
wait ( cur, answer^);
operatorinput:= ownertest ( inputpool, cur) and ( cur^.u1 mod 8 = read);
signal ( cur, dataready);
n:= n+1
until operatorinput;

for n:= n downto 2 do       (*  send other messages back into queue  *)
begin
wait ( cur, dataready);
signal ( cur, answer^);
end;
end;
wait ( cur, dataready);
state:= cur^.u2;
lock cur as buf: zonebuffer do nextp:= buf.first
end
end ; (*  of opwait  *)

\f


prefix readchar;
procedure readchar (             (*  reads next character  *)
var z: zone;                     (*  specifies the document    *)
var t: char         );           (*  delivered character or nl  *)

const
opsize = 3 + (alfalength+80) div 2;

type
zonebuffer = record
first, last, next: integer;
chars: array (6..6+80-1) of char
end;
opbuffer = record
first, last, next: integer;
name: alfa;
chars: array (6+alfalength..6+alfalength+80-1) of char
end;

begin
t:= nl;
with z do
if nil ( cur) then  readstate:= -1
else
begin
readstate:= 0;
if cur^.size >= opsize then         (*  operator buffer  *)
lock cur as buf: opbuffer do
begin
if nextp < buf.next then
t:= buf.chars(nextp)
else  readstate:= -1
end
else
lock cur as buf: zonebuffer do
if nextp < buf.next then
t:= buf.chars(nextp)
else  readstate:= -1;

if readstate = -1 then signal ( cur, free)
else  nextp:= nextp+1
end
end ; (*  of readchar  *)

\f


prefix readinteger;
procedure readinteger (           (*  reads a decimal number   *)
var z: zone;                      (*  specifies the document    *)
var num: integer       );         (*  value read or 0           *)
(*
syntax:  (0..n)*(not digit), (0..1)*sign, (1..5)*digit
z.readstate = 0 if value assigned.
*)
const
max = 3276;                (*  max integer div 10  *)
digits = (. "0".."9" .);
wanted = (. "0".."9", nl .);

var
prev, t: char:= sp;
d: byte:= 0;
sign: integer;

begin
num:= 0;

repeat
prev:= t;
readchar ( z, t)
until t in wanted;

if t <> nl then        (*  a number is met   *)
begin
if prev = "-" then sign:= -1 else sign:= +1;

while ( num < max ) and ( t in digits ) do
begin
num:= num*10 - ord("0") + ord( t);
readchar ( z, t)
end;

if ( num <= max ) and ( t in digits ) then          (*  include last digit  *)
begin
d:= ord ( t) - ord("0");
if 2*d < 16-sign then     (*  accept  *)
begin
num:= num*10;
z.nextp:= z.nextp+1
end
else  d:= 0
end;

num:= sign*num + sign*d;
z.readstate:= 0;
z.nextp:= z.nextp-1
end
end ; (*  of readinteger  *)

\f


prefix readhex;
procedure readhex (             (*  reads a hexadecimal number  *)
var z: zone;                    (*  specifies the document      *)
var num: integer    );          (*  value read or 0             *)

(*
syntax:  (0..n)*(not hexdigit), (1..4)*hexdigit
z.readstate = 0 if value assigned.
*)

const
hexdigits =  (. "0".."9", "a".."f" .);
wanted = (. nl, "0".."9", "a".."f" .);

var
t: char;
a, b, c, d: byte:= 0;      (*  4 digits  *)

begin
num:= 0;

repeat readchar ( z, t) until t in wanted;

if t <> nl then               (*  a number is met   *)
begin

while ( a = 0 )  and ( t in hexdigits ) do
begin
a:= b;   b:= c;   c:= d;
if ord ( t) <= ord ("9") then
d:= ord ( t) - ord ("0")  else
d:= ord ( t) - ord ("a") + 10;
readchar ( z, t)
end;

num:= ((((a+8) mod 16 -8)*16+b)*16+c)*16+d;
z.readstate:= 0;
z.nextp:= z.nextp-1
end
end ; (*  of readhex  *)

\f


prefix readname;
procedure readname (          (*  reads a name from z   *)
var z: zone;                  (*  specifies the document   *)
var name: alfa       );       (*  read name                *)

(*
syntax:  (0..n)*sp, 1*letter, (0..11)*alfanum
readstate = 0 if name assigned.
you may initialize name before readname.
*)

const
letters = (. "A".."Å", "a".."å" .);
alfanum = (. "A".."Å", "a".."å", "0".."9" .);

var
t: char;
i: byte:= 0;

begin

repeat  readchar ( z, t) until t <> sp;

if t in letters then        (*  read the name  *)
begin

repeat
i:= i+1;
name(i):= t;
readchar ( z, t);
until ( i >= alfalength ) or not ( t in alfanum );

z.readstate:= 0;
z.nextp:= z.nextp-1;
end
else
if z.readstate = 0 then  z.readstate:= 1

end . (*  of readname  *)

 (*------------------------- end of oplib -----------------------------*)
▶EOF◀
DataMuseum.dk

RC4000/8000/9000

⟦5a4301938⟧ TextFile

Derivation

TextFile
