⟦d0a9fe97c⟧

TextFile

procedure ressource_check(size,buf,area);
integer                   size,buf,area ;
<****************************************
. size, buf og area: kald og returværdier.
.
. ved kald indeholdende min. ressource-
. krav. jobbet afbrydes hvis disse krav
. ikke er opfyldt.
.
. ved retur indeholdende de tilrådighed-
. stående ressourcer.
****************************************>
begin
integer array
_  ia(1:14);

real array
_  ra(1:2);

if system(5,system(6,0,ra),ia)=1 then
begin
ia(1):=ia(13)-ia(12);                <* size      *>
ia(2):=ia(14) shift(-12) extract 12; <* free buf *>
ia(3):=ia(14)            extract 12; <* free area *>

if  ia(1)>=size
and ia(2)>=buf
and ia(3)>=area then
begin
size:=ia(1);
buf :=ia(2);
area:=ia(3);
end
else
begin
write(out,<<d________>,
<:<10>Job resources insufficient for normal program run:<10>:>,
<:<10>   Min size: :>,size,<:Act. size: :>,ia(1),
<:<10>   Min buf : :>,buf ,<:Free buf : :>,ia(2),
<:<10>   Min area: :>,area,<:Free area: :>,ia(3),
<:<10>:>);
break(<::>,0,true);
end
end
else
break(<:*** resource test impossible:>,0,true);
end proc;
\f


boolean procedure getclaim(descr);
<********************************>
integer array              descr ;

<*********************************************************

proceduren henter oplysninger om ressourcer m.v.
fra egen procesbeskrivelse, og lagrer disse
oplysninger i <descr> hvis der er tilstækkelig plads,
i modsat fald returner proceduren med værdien "false"

index
.    1: længden af beskrivelsen i bytes
.    2: size
.    3: frie buf
.    4: frie area
.    5: frie internals
.    6: antal ressourcebeskrivelser for baggrundslagre
.....................
. 7-10: device name
.   11: slicelength
.   12: temp entries
.   13: temp segments
.   14: login entries
.   15: login segments
.   16: perm entries
.   17: perm segments
......................

... gentages for antal beskrivelser
*********************************************************>


begin

procedure move_core(adr,ia);
<**************************>
integer             adr    ;
integer array           ia ;

if   system(5,adr,ia) = 0
then system(9,0,<:<10>getclaim:>);

real array
_ ra(1:2);

integer array
_ own_descr(0:14),
_ name_table_adress(0:2),
_ chain_table(-18:0),
_ key_ia(0:0);

integer
_ max_permkey,
_ own_adr,
_ drums,
_ discs,
_ length,
_ low,
_ up,
_ i,
_ j,
_ k;

integer array field
_ base;

<* hent min auxcat permkey *>

move_core(118,key_ia);
max_permkey:=key_ia(0) shift (-12);
if max_permkey > 3 then 
max_permkey:=3;

<* nametable adress for drum og disc chains *>

move_core(92,name_table_adress);

if name_table_adress(1) = 0 then name_table_adress(1):=name_table_adress(2);
if name_table_adress(0) = 0 then name_table_adress(0):=name_table_adress(1);

drums:=(name_table_adress(1) - name_table_adress(0)) // 2;
discs:=(name_table_adress(2) - name_table_adress(1)) // 2;


begin

integer array
_ name_table(1:drums + discs),
_ claim_table(0:max_permkey);

<* own processdescription adress *>

own_adr:=system(6,0,ra);

if own_adr = 0 then system(9,0,<:<10>getclaim:>);

<* det testes om <descr> kan rumme hele beskrivelsen *>

low:=system(3,up,descr);

<* key = 1, medtages ikke ! *>

length:=6 + (5 + (max_permkey + 0) * 2) * (drums + discs);

if    up - low + 1 < length
then  getclaim:=false
else
begin getclaim:=true;

base:=(low - 1) * 2;

move_core(own_adr,own_descr);

descr.base(1):=length * 2;
descr.base(2):=own_descr(12) - own_descr(11);
descr.base(3):=own_descr(13) shift (-12);
descr.base(4):=own_descr(13) extract 12 ;
descr.base(5):=own_descr(14) shift (-12);
descr.base(6):=drums + discs;

<*
de enkelte ressourcebeskrivelser findes,
og indsættes i <descr> succesivt
*>

move_core(name_table_adress(0),name_table);

base:=base + 12;

for i:=1 step 1 until drums + discs do
begin

<* hent chaintable for dette device *>

move_core(name_table(i) - 36,chain_table);

<* hent ressourcebeskrivelsen for device i own processdescription *>

move_core(own_adr + chain_table(-18),claim_table);

<* indsæt devicenavn *>

for j:=1 step 1 until 4 do
descr.base(j):=chain_table(-10 + j);

<* slicelength *>

descr.base(5):=chain_table(-4);

<* indsættelse af entries/slices *>

k:=0; <* key = 1, medtages ikke! *>
for j:=0, 2 step 1 until max_permkey do
begin
descr.base(6 + 2*k):=claim_table(j) shift (-12);
descr.base(7 + 2*k):=claim_table(j) extract 12 * chain_table(-4);
k:=k + 1;
end;

<* base flyttes frem til næste ressource beskrivelse *>

base:=base + 10 + 4 * (max_permkey + 0);

end alle entries;

end claims;

end indre blok;

end getclaim;
\f


integer procedure fpscan(val,kind);
<*********************************>
long array               val;
integer array                kind;

<*
proceduren læser programkaldet
og lagrer de enkelte elementer i val.

kind(i) indeholder typen på elementet i val(i).

kind = 1:  skilletegn                 val(i) indeholder iso-værdien.
kind = 2:  talparameter               val(i) indeholder tallet.
kind = 3:  tekstparameter             val(i) og val(i+1) indeholder tekststrengen.

tekstparametre fylder altid 2 elementer i val.

returværdien fra fpscan angiver antallet af elementer 
i val og kind, der har fået tildelt en værdi.
returværdien er negativ såfremt enten val eller kind er fyldt op,
og ikke alle parametre kunne lagres.
*>

 <* programmeret af ejlert andersen, dato: 250579 *>

 <* ændret af       ejlert andersen, dato: 090979 *>
\f


begin
boolean
_ full;

integer
_ min,
_ max,
_ low1,
_ low2,
_ up1,
_ up2,
_ seperator,
_ option,
_ item,
_ return,
_ index;

real array
_ param(1:2);

long field
_ lf1,
_ lf2;

<* initialisering *>
lf1  :=4;
lf2  :=8;
item :=0;
full :=false;
low1 :=system(3,up1,val );
low2 :=system(3,up2,kind);
min  :=if low1 < low2 then low2 else low1;
max  :=if up1 < up2 then up1 else up2;
index:=min;
\f


<* indlæsning *>

if max < min then full:=true
else
for return:=system(4,item,param)
while return <> 0 and -,full do
begin
seperator:=return shift(-12);
option   :=return extract 12;

if index > min then
begin
val (index):=case (seperator//2+2) 
_            of   (41,40,10,32,61,46);
kind(index):=1;

index:=index+1;
full :=index > max;
end;

if -,full then
begin
case (option//2+1) of
begin
;

;

<* tal *>
begin
val (index):=round param(1);
kind(index):=2;
end;

;

;

<*tekst *>
begin
val (index):=param.lf1;
kind(index):=3;

index:=index+1;
full :=index > max;

if -,full then
begin
val (index):=param.lf2;
kind(index):=3;
end;
end;

end case;

if -,full then
begin
index:=index+1;
full :=index > max;
item :=item+1;
end;
end -,full;

end input;

if -,full then
begin
val (index):=0;
kind(index):=0;
end;

fpscan:=if full then -(index-min) else index-min;

end procedure fpscan;
\f


integer procedure connect(z,name,segm);
<*************************************>
zone                      z           ;
long array                  name      ;
integer                          segm ;

<**************************************
programmør : ejlert andersen
dato       : 23 07 80

funktion   :
proceduren åbner <z> til <name>.
hvis katalogindgangen ikke findes oprettes
et bs-area med det angivne navn 
og størrelsen <segm> på det specificerede
device. hvis <name> indeholder mere end
2 elementer anvendes name(3-4) som
device navn.

parametre  :
z          : zonen som skal connectes
name       : navn på katalogindgang m.v.
name(1-2)  : navn på katalogindgang 
name(3-4)  : navn på evt. device
segm       : områdets størrelse i segm
.            hvis segm < 0 testes ikke på content-key
.            hvis segm = 0 skal katalogingangen findes

returværdi :
connect    : dokumentets kind
segm       : størrelsen af bs-area hvis dette findes
***************************************>


begin


procedure error(no);
<******************>
integer         no ;

begin
write(out,"nl",2,doc,"sp",2);

case no of
begin
write(out,<:work-area-name kan ikke genereres, monitor(68)=:>,return);
write(out,<:området findes ikke, monitor(76)=:>,return);
write(out,device,"sp",2,<:området kan ikke oprettes på:>,abs segm,<: segm, monitor(40)=:>,return);
write(out,<:entry peger ikke på ny entry eller et område:>);
write(out,<:området er beskyttet ved content-key :>,<<d>,entry(9) shift(-12),<:.:>,entry(9) extract 12);
write(out,<:areal-proces kan ikke oprettes, monitor(52)=:>,return);
write(out,<:peripheral proces kan ikke initialiseres, monitor(6)=:>,return)
end case;

system(9,modekind extract 12,<:<10>*connect:>);
end error;



long array
_ doc,
_ device(1:2);

integer array
_ entry(-6:10),
_ descr( 1:20);

integer
_ file,
_ block,
_ modekind,
_ return,
_ low,
_ up;

boolean
_ newentry;

long array field
_ docf,
_ devicef;


<* initialisering *>

docf     :=  2;
devicef  :=-12;

file     :=
block    :=  0;

modekind :=  4;

low:=system(3,up,name);

if name(1) = long <::> then
begin
return:=monitor(68)generate_name:(z,0,entry);

getzone6(z,descr);
name(1):=descr.docf(1);
name(2):=descr.docf(2);

if return <> 0 then error(1);
end;

doc(1):=name(1);
doc(2):=name(2);

if up - low >= 3 then
begin
device(1):=name(3);
device(2):=name(4);
end
else
device(1):=
device(2):=long <::>;



newentry:=true;

repeat
close(z,true);
open(z,modekind,doc,0);

return:=monitor(76)lookup_head_and_tail:(z,0,entry);

if return <> 0 and modekind extract 12 = 4 then
begin  <* katalogindgangen findes ikke *>
if segm = 0 then error(2)
else
begin  <* der oprettes et bs-area *>
for return:=-6 step 1 until 10 do entry(return):=0;

entry.devicef(1):=device(1);
entry.devicef(2):=device(2);
entry(-6)       :=abs segm;

return:=monitor(40)create_entry:(z,0,entry);
if return <> 0 then error(3);
end;

newentry:=false;
end
else
if entry(1) <= 0 then
begin  <* katalogindgangen ikke et bs-area *>
if entry.docf(1) = long <::> then error(4);

modekind:=entry(1) extract 23;
doc(1)  :=entry.docf(1);
doc(2)  :=entry.docf(2);
file    :=entry(7);
block   := entry(8);
newentry:=modekind extract 12 = 4;

if -,newentry then
begin
close(z,true);
open(z,modekind,doc,0);
end;
end
else
begin  <* katalogindgangen er et bs-area *>
if segm shift(-23) = 0 and entry(9) <> 0 then error(5);
segm:=if segm shift(-23) = 1 then -entry(1) else entry(1);

newentry:=false;
end;


until -,newentry;

<* area-process oprettes *>

return:=
if modekind extract 12 =  4 then
monitor(52)create_area_process:(z,0,entry) else
if modekind extract 12 = 10
or modekind extract 12 = 12
or modekind extract 12 = 14 then
monitor(6)initialize_process:(z,0,entry) else 0;

if return <> 0 then error(6);

<* dokumentet positioneres *>

if modekind extract 12 = 18 then setposition(z,file,block) else
if modekind extract 12 =  4 then setposition(z,   0,block) else
if modekind extract 12 = 12 then write(z,false,200)           ;

connect:=modekind extract 12;

end connect;
\f


procedure printarea(z,papirtype);
<*******************************>
zone                z;
integer               papirtype;

<*
proceduren converter det til
zonen z knyttede bs-area
*>

begin
integer array 
_ descr(1:20);

integer 
_ i;

long array field
_ laf;

laf:=10;

getzone6(z,descr);
for i:=8,7,6,5 do descr(i):=descr(i-3);
descr(1):=30 shift 12 + 1 shift 9 + 1; <* convert *>
descr(2):=long<:con:> shift (-24);
descr(3):=long<:v:> shift (-24);
descr(4):=papirtype;

descr(2):=system(10,0,descr);

if descr(2) <> 1 then 
begin
write(out,<:<10><10>*** printarea, :>,descr.laf,<: - mangler message buffere:>);
system(9,descr(2),<:<10>*convert:>);
end;

if descr(1) <> 0 then
begin

write(out,<:<10><10>*** printarea, :>,descr.laf,
<: - :>,case descr(1) of (
<:cbufs exceeded:>,
<:file does not exist:>,
<:file has wrong scope:>,
<:temporary ressources insufficient:>,
<:file in use:>,
<:file is not area:>,
<:file is no text file:>,
<:8:>,<:9:>,<:10:>,<:11:>,<:12:>,<:13:>,
<:14:>,<:15:>,<:16:>,<:17:>,<:18:>,
<:attention status at remote batch terminal:>,
<:device unknown:>,
<:device not printer:>,
<:parent device disconnected:>,
<:23:>));

system(9,descr(1),<:<10>*convert:>);
end;

end printarea;
\f


procedure monitorerror(fnc,z,retur,stop);
<***************************************>
value                  fnc,  retur,stop ;
zone                       z            ;
integer                  fnc,retur      ;
boolean                            stop ;


begin
integer
_  casenr;

integer array
_  ia(1:20);

long array field
_  laf;

laf:=2;

getzone6(z,ia);


if fnc < 40 then
casenr:=case (7*(fnc-8)//2+retur) of (

<**********************************************************>
<* fnc     1   2   3   4   5   6   7                      *>
<**********************************************************>
<*  8  *>  1, 13, 14,  0,  0,  0,  0,  <* reserve process *>
<* 10  *>  0,  0,  0,  0,  0,  0,  0,  <* release process *>
<**********************************************************>
0) else

if fnc < 72 then
casenr:=case (7*(fnc-40)//2+retur) of (

<**********************************************************>
<* fnc *   1   2   3   4   5   6   7                      *>
<**********************************************************>
<* 40  *>  0,  2,  3,  4,  5, 22,  7,  <* create entry    *>
<* 42  *>  0,  2,  8,  0,  0,  6,  7,  <* lookup entry    *>
<* 44  *>  0,  2,  8,  9, 10, 11,  7,  <* change entry    *>
<* 46  *>  0,  2, 23,  9, 10, 12,  7,  <* rename entry    *>
<* 48  *>  0,  2,  8,  9, 10,  6,  7,  <* remove entry    *>
<* 50  *>  0,  2, 24,  9, 10, 25,  7,  <* permanent entry *>
<* 52  *> 15,  2,  8, 16,  0,  6,  0,  <* create area prc *>
<**********************************************************>
0) else

casenr:=case (7*(fnc-72)//2+retur) of (

<**********************************************************>
<* fnc     1   2   3   4   5   6   7                      *>
<**********************************************************>
<* 72  *>  0, 17, 18, 19,  0,  6,  0,  <* set catalog base*>
<* 74  *>  0,  2, 20, 21, 10,  6,  7,  <* set entry base  *>
<* 76  *>  0,  2,  8,  0,  0,  6,  7,  <* lookup head,tail*>
<**********************************************************>
0);


write(out,"sp",15-write(out,"nl",2,ia.laf),<:, :>,

if fnc < 40 then (case ((fnc-6)//2) of (
<:reserve process:>,
<:release process:>))
else
if fnc < 72 then (case ((fnc-38)//2) of (
<:create entry:>,
<:lookup entry:>,
<:change entry:>,
<:rename entry:>,
<:remove entry:>,
<:permanent entry:>,
<:create area process:>))
else
(case ((fnc-70)//2) of (
<:set catalog base:>,
<:set entry base:>,
<:lookup head and tail:>)),

"nl",1,<:monitor(:>,<<dd>,fnc,<:)=:>,<<d>,retur,<:, :>);

if casenr > 0 then write(out,
case casenr of (
<*  1 *> <:reserved by another process:>,
<*  2 *> <:catalog i/o error:>,
<*  3 *> <:name conflict:>,
<*  4 *> <:claims exceeded:>,
<*  5 *> <:catalog base of calling process does not allow creation of entry:>,
<*  6 *> <:name format illegal:>,
<*  7 *> <:maincat not present:>,
<*  8 *> <:entry not found:>,
<*  9 *> <:entry protected, i.e. base of entry name not contained in max base of calling process:>,
<* 10 *> <:area process (or entry lock process) reserved/used by another process:>,
<* 11 *> <:name format or new size illegal; claims exceeded:>,
<* 12 *> <:name format (old or new name) illegal:>,
<* 13 *> <:calling process is not a user; process cannot be reserved:>,
<* 14 *> <:process does not exist; calling process is not a user of area process:>,
<* 15 *> <:area claims exceeded:>,
<* 16 *> <:entry does not describe an area:>,
<* 17 *> <:state of internal process does not permit modifikation:>,
<* 18 *> <:process does not exist; process is not an internal process; process is not a child of calling process:>,
<* 19 *> <:new base illegal:>,
<* 20 *> <:entry not found; name conflict (at the new base):>,
<* 21 *> <:entry protected, i.e. old base of entry name not contained in max base of calling process:>,
<* 22 *> <:name format of entry or document illegal:>,
<* 23 *> <:entry not found or new name overlap:>,
<* 24 *> <:entry not found; name overlap (in auxiliary catalog):>,
<* 25 *> <:name format illegal; claims exceeded:>,
<*    *> <::>));



if stop then break(<:*** monitor error:>,0,true);

end monitorerror;



\f


procedure break(tekst,fejlværdi,stop);
<************************************>
string          tekst                ;
integer               fejlværdi      ;
boolean                         stop ;

<*
proceduren udskriver en fejludskrift
med en evt. tilhørende fejlværdi
på current output file.
er stop 'true' afbrydes programmet
*>

begin
long array
_ programname(1:2);

write(out,"nl",2,tekst);

if fejlværdi <> 0 then
write(out,"sp",1,<<-d>,fejlværdi);

if stop then
begin
if   system(4,1,programname) shift(-12) <> 6 
then system(4,0,programname);

write(out,"nl",2,<:*** program, :>,programname,
_         <: - is terminated !:>,"nl",1);

<* break of program - no error message *>

trapmode:= -1;

system(9,0,<::>);
end if stop;

end break;
\f


▶EOF◀
DataMuseum.dk

RC4000/8000/9000

⟦d0a9fe97c⟧ TextFile

Derivation

TextFile
