⟦631824905⟧

TextFile

job oer 2 200 time 11 0 area 10 size 100000
( source = copy 25.1
tstaplst = set 1 disc1
tstaplst = indent source mark lc
listc = cross tstaplst
o errors
message  tap program
pascal80 spacing.3000 codesize.3000 alarmenv source
o c
lookup pass6code
if ok.yes
( tstapbin = set 1 disc1
  tstapbin = move pass6code
  scope user tstapbin
)
tstaplst = copy listc errors
scope user tstaplst
convert errors
finis
)
\f


<*
process tsconnector (
   opsem : sempointer;                  (*  operator sem      *)
var s1, s2, s3, s4, s5: !sempointer;
var sem, p2, p3, p4, p5, p6: !ts_pointer  );

*>
process tap (
  opsem : sempointer;                   (*  operator sem   *)
  var sem : !ts_pointer );                (*  main sem      *)

   (*---------------------------------------------------------------
    *
    * function:   the tap module is used to supervise
    *             the traffic between 2 modules.
    *
    * externals:   testopen, testout
    *
    * var params:  sem
    *
    * semaphores:  the module sends to the system semaphore
    *              "operatorsem".
    *
    *
    * programmed oct 1980 by hej
    *
   --------------------------------------------------------------*)

const

version = "vers  0.08 /" ;


\f


const
opbufsize = 80; (* no. of bytes in buffers to the operator module *)
 
firstindex= 6 + alfalength;
lastindex= firstindex + (opbufsize - 1);
ok= 0; (* result from operator *)
 
 
type
opbuftype=
record
first,
last,
next: integer;
name: alfa;
data: array (firstindex..lastindex) of char
end;

alarmbuftype = array (1..size_listen) of integer;
 
alfa10= array (1..10) of char;
 
var
(*********  pools  *********)
opbufpool: pool 3 of opbuftype;

(**********  semaphores  **********)
wsem         (* buffers written by the operatormodule is
                returned here *)
: semaphore;

(**********  references  **********)
opoutref,   (* ref. to buffer to operator *)
cur           (* ref. to current buffer *)
: reference;

(**********  zones  **********)
z: zone;



(**********  integers  **********)
base,            (* number base for input and output *)
mc,
i,
lastword        (* used by "o"-command *)
: integer;


(**********  externals **********)

procedure setoflowmask ( obit: boolean);
external;
 
\f


procedure outchar(ch:char);
(* writes ch into the output buffer *)
begin
lock opoutref as opbuf: opbuftype do
with opbuf do
begin
last:= last + 1;
data (last):= ch;
end;
end (* outchar *);
\f


procedure outinteger ( int, positions : integer);
(*  writes the integer int using outchar      *)

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

const
lastpos = 16;        (*  lastpos+1 positions in layout   *)
dig = digittable ('0','1','2','3','4','5','6','7',
                  '8','9','a','b','c','d','e','f' );

type
range = 0..lastpos ;

var
digits : array (range) of char;
p : range;
res : integer;
negative : boolean;

procedure setzero ( stop : range );
(*       global     p         *)
begin
while p > stop do
begin
res:= 0;
digits(p):= '0';
p:= p-1
end;
 if base = 16 then digits(p+1):= dig(8+res)
else digits(p+1):= '1'
end;

begin
for p:= 0 to lastpos do digits(p):= sp;
p:= lastpos;
negative:= int<0;
if negative and (base <> 10 ) then int:= int - (-32768);

repeat          (*  unpack the digits backwards    *)
res:= abs ( int mod base);
digits(p):= dig(res);
p:= p-1;
int:= int div base
until (p=0) or (int=0);

if negative then
case base of
2:  setzero ( lastpos-16);

8:  setzero ( lastpos-6);

10:
begin
digits(p):= '-';     (*  sign  *)
p:= p-1
end;

16: setzero ( lastpos-4)
otherwise
end; (*  case  *)

res:= lastpos+1 - positions;        (*  where to start  *)
while res < 0 do                 (*  make extra sp   *)
begin
outchar ( sp);
res:= res+1
end;

if res < p then p:= res;

for p:= p to lastpos do outchar ( digits(p));

end;   (* outinteger  *)

\f


procedure outstring10(text: alfa10);
(* writes the text into opbuf starting at outputpointer
which is updated accordingly *)
var
i: integer;
begin
for i:=1 to 10 do
outchar( text(i) );
end (* out string 10 *);
\f

 
procedure outnl;
(* prepares opbuf for output to the operator and signals
it to operator module *)
begin
if not nil(opoutref) then
begin
outchar(nl);
signal(opoutref, opsem^)
end;
wait(opoutref, wsem);
lock opoutref as opbuf: opbuftype do
opbuf.last:= firstindex;
end (* writenl *);

\f


procedure display;

begin
outchar ("u");   outchar(":");
outinteger ( cur^.u1, 4);
outinteger ( cur^.u2, 4);
outinteger ( cur^.u3, 4);
outinteger ( cur^.u4, 4);
outinteger ( cur^.size, 8);
outnl;
if cur^.size >= size_listen then   (*  alarmbuffer  *)
lock cur as buf: alarmbuftype do
if buf(1) in (. 0..64 .) then
begin
outstring10 ("label     ");
for i:= 1 to 8 do outinteger ( buf(i), 6);
outnl;
lastword:= (buf(1)+3) div 2;
if lastword > size_listen then lastword:= size_listen;
if lastword > 8  then
begin
outstring10 ("datapart  ");
for i:= 9 to lastword do outinteger ( buf(i), 6);
outnl;
end
end
end;      (*  display  *)
 
\f


function equal ( a, b : sempointer ): boolean;

type
os = record  sp: sempointer  end;

var
one, two: os;

begin
one.sp:= a;
two.sp:= b;
equal:= one = two
end;

\f



      (****************************************
      *                                       *
      *       m a i n   p r o g r a m         *
      *                                       *
      ****************************************)

begin
testopen (z, own.incname, opsem);
testout ( z, version, al_env_version);

(* initialise op buffers *)
for i:= 1 to 3 do
begin
alloc (opoutref, opbufpool, wsem);
opoutref^.u1:=2; (* write *)
lock opoutref as opbuf: opbuftype do
with opbuf do
begin
first:= firstindex;
name:= own.incname;
data(firstindex):= "!";
end;
return (opoutref);
end;
 
outnl;
setoflowmask ( true);      (*  no except for arith. overflow   *)
base:= 16;
 
repeat
wait ( cur, sem.w^);
display;
if equal ( sem.w, sem.s ) then return ( cur)
else
signal ( cur, sem.s^)
until false

end .

▶EOF◀
DataMuseum.dk

RC4000/8000/9000

⟦631824905⟧ TextFile

Derivation

TextFile
