|
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: 100608 (0x18900)
Types: TextFile
Names: »tjsclib «
└─⟦9ccaf6601⟧ Bits:30008165 Bånd med SW8000 kildetekst/release værktøjer
└─⟦f546e193b⟧
└─⟦this⟧ »tjsclib «
job j 2 time 12 00 size 55000 perm disc1 1000 25 temp disc 1000 25 buf 10 area 10
oclaim
mode listing.yes; yes => listning v. oversættelse
clear user ,
jsclib ,
xnulstil ,
xnulfratil ,
xkl ,
xhex ,
xbin ,
xstatustxt ,
xwritealarm ,
xstderror ,
xtrapbreak ,
xnametable ,
xmaxbuflgd ,
xdumpzone ,
xinitinput ,
xinput ,
xwaitinput ,
xinitoutput ,
xsetoutput ,
xoutput ,
xwaitoutput ,
xcopyzone ,
xconnectout ,
xsortsq ,
xclaimproc ,
xbsclaim ,
xopencreate ,
xopencrsq ,
xprimostate ,
xprimosend ,
xhost ,
xsearchproc ,
xebcdtable ,
xwriteall ,
xy ,
xpos ,
xhome ,
xclreol ,
xclreos ,
xclrhom ,
xtrace ,
xtextlgd ,
xnameok ,
xdiscok ,
xclaim ,
oclaim , program
; slang procedurer
xnulstil = set 1 disc1 ; jsc 01.01.1983
xnulfratil = entry bs xnulstil ; jsc 01.01.1983
; algol procedurer
jsclib = set 1 disc1 ; jsc 24.07.1987
xkl = set 1 disc1 ; jsc 01.12.1987
xhex = set 1 disc1 ; jsc 14.12.1988
xbin = set 1 disc1 ; jsc 14.12.1988
xstatustxt = set 1 disc1 ; jsc 15.11.1988
xwritealarm = set 1 disc1 ; jsc 15.10.1988
xstderror = set 1 disc1 ; jsc 10.11.1988
xtrapbreak = set 1 disc1 ; jsc 27.07.1988
xnametable = set 1 disc1 ; jsc 27.07.1988
xmaxbuflgd = set 1 disc1 ; jsc 27.09.1988
xdumpzone = set 1 disc1 ; jsc 15.08.1988
xinitinput = set 1 disc1 ; jsc 15.08.1988
xinput = set 1 disc1 ; jsc 15.08.1988
xwaitinput = set 1 disc1 ; jsc 15.08.1988
xinitoutput = set 1 disc1 ; jsc 15.08.1988
xsetoutput = set 1 disc1 ; jsc 15.08.1988
xoutput = set 1 disc1 ; jsc 15.08.1988
xwaitoutput = set 1 disc1 ; jsc 15.08.1988
xcopyzone = set 1 disc1 ; jsc 25.09.1988
xconnectout = set 1 disc1 ; jsc 27.07.1988
xsortsq = set 1 disc1 ; jsc 30.12.1987
xclaimproc = set 1 disc1 ; jsc 01.01.1982
xbsclaim = set 1 disc1 ; jsc 01.01.1982
xopencreate = set 1 disc1 ; jsc 01.08.1987
xopencrsq = set 1 disc1 ; jsc 01.08.1987
xprimostate = set 1 disc1 ; jsc 01.08.1987
xprimosend = set 1 disc1 ; jsc 01.08.1987
xhost = set 1 disc1 ; jsc 01.08.1987
xsearchproc = set 1 disc1 ; jsc 01.01.1982
xebcdtable = set 1 disc1 ; jsc 30.09.1981
xwriteall = set 1 disc1 ; jsc 05.02.1982
xy = set 1 disc1 ; jsc 21.01.1983
xpos = set 1 disc1 ; jsc 01.12.1987
xhome = set 1 disc1 ; jsc 01.12.1987
xclreol = set 1 disc1 ; jsc 01.12.1987
xclreos = set 1 disc1 ; jsc 01.12.1987
xclrhom = set 1 disc1 ; jsc 01.12.1987
xtrace = set 1 disc1 ; jsc 01.12.1987
xtextlgd = set 1 disc1 ; jsc 01.12.1987
xnameok = set 1 disc1 ; jsc 01.12.1987
xdiscok = set 1 disc1 ; jsc 01.12.1987
xclaim = set 1 disc1 ; jsc 12.10.1988
; object programmer
oclaim = set 1 disc1 ; jsc 01.07.1987
if listing.yes
( ljsclib = set 1000 disc1
scope user ljsclib
if ok.no
finis
o ljsclib
)
head iso
jsclib = algol blocks.yes bossline.no ix.no xref.yes
jsclib (dummy)
external
procedure jsclib;
begin
<* tom *>
end procedure jsclib;
end;
if ok.yes
if warning.yes
(o c
message algol procedure fejl jsclib
finis)
\f
if listing.yes
head iso
(xnulstil = slang entry.no names.no xref.yes
xnulstil xnulfratil)
;
; jsc den 1/1-1983
;
; procedure til nulstilling af en vilkårlig type array
; kald af procedurer:
; xnulstil (array)
; xnulfratil (array, fra, til)
; array ::= vilkårlig type array eller zone
; fra ::= integer, der opfattes som intege field
; til ::= integer, der opfattes som intege field
; fra/til = -8388608 => fra/til := start adr på array
; fra/til = 8388607 => fra/til := slut adr på array
;
; nulstillingen -binært nul- sker fra første til sidste element i arrayet
; eller fra adresse <fra> til adresse <til>.
; adresserne <fra> og <til> opfattes som integer fields.
; --------------
;
; cpu-forbruget på rc8000 model 55 er:
; xnulstil: 88 mikrosek til start og 3.7 mikrosek pr dobbeltord
; xnulfratil: 160 mikrosek til start og 3.7 mikrosek pr dobbeltord
; det ses heraf, at xnulstil er hurtigere end brugen af for i:=1 step 1 ...
; ved nulstilling af 6 dobbeltord og derover, og at xnulfratil er det
; ved nulstilling af 11 dobbeltord og derover.
;
; exempel 1: xnulstil (z) => hele z nulstilles
; exempel 2: xnulfratil (z, 10, 32) => z nulstilles fra adr 10 til 32
;
;
b. ; begin
m.slangprocedure xnulstil og xnulfratil
g1, i7 ; g0, g1 are used by insertproc as adresses
; of first and last tail. i-names area used
; to define entries and externals for tail-
; parts, may be changed to anything else but
; g0, g1, and h-names.
l.d. ; list.off
p.<:fpnames:> ; indkopier fpnames
l. ; list.on
s. d2, j60, a3, c7, f6 ; segm start
; d1 is used to define no. of abs words
; d2 is used to define no. of abs words + points
; j-names are used to define rs entries, for
; mnemotecnic resons they correspond to rs numbers.
w. k=10000, h. ;
i5=0 ; no of externals
i4:
d0: d2 , d1 ; rel last point, rel last abs word
j4: i5+4 , 0 ; rs entry take expression
j8: i5+8 , 0 ; - end adress expresion
j13: i5+13, 0 ; - last used
j21: i5+21, 0 ; - general alarm
j29: i5+29, 0 ; - param alarm
j30: i5+30, 0 ; - saved last used
d1=k-2-d0 ; abs words
d2=k-2-d0 ; abs words and points
w.
i3: i5 ; no of externals
0 ; no of owns
830101,0000 ; date, time
; arbejdsvariable
f0: 0 ; array lgd
f1: 0 ; adr på 1. element i array
f2: 0 ; wrk adr
f3: 0 ; - portion til behandling
f4: 0 ; element lgd i array (hw)
f5: 0 ; første adr i array
f6: 0 ; sidste adr i array
i0:
i7: rl. w2 (j13.) ; w2:=last used
ds. w3 (j30.) ; saved last used:=last used
jl. w3 c0. ; kald check og udpak array
; hent 1. integer param, indexcheck og param i f1
dl w1 x2+12 ; get formals
jl. w3 c4. ; index mv. check
al w1 x1-1 ; w1 skal pege på første hw
rs. w1 f5. ; f5:= lower adr
wa w1 (x2+8) ; w1:=w1+base for array
rs. w1 f1. ; f1:=lower adr
; hent 2. integer param, indexcheck og lgd i f0
dl w1 x2+16 ; get formals
jl. w3 c4. ; index mv. check
rs. w1 f6. ; f6:= upper adr
ws. w1 f5. ; w1:=upper adr-lower adr
al w1 x1+1 ; medtag endepunkterne
rs. w1 f0. ; f0:=array lgd i hw
jl. w3 a3. ; goto behandling
i6: rl. w2 (j13.) ; w2:=last used
ds. w3 (j30.) ; saved last used:=last used
jl. w3 c0. ; kald check og udpak array
a3:
; begin test
; dl. w3 (j30.)
; rl. w1 f5.
; rs w1 (x2+20)
; rl. w1 f6.
; rs w1 (x2+24)
; rl. w1 f0.
; rs w1 (x2+28)
;; jl. w3 (j8.)
; end test
; klargør til selve nulstillingen
rl. w0 f0. ; w0:=array lgd
rl. w1 f1. ; w1:=start adresse
al w2 0 ; w2:=0
al w3 0 ; w3:=0
; behandl første hw hvis array starter på ulige adr
so w1 1 ; if w1 mod 2 = 0 then
jl. a0. ; goto test slut adr
hs w3 x1 ; hw.1:=0
al w1 x1+1 ; adr:=adr+1
al w0 -1 ;
wa. w0 f0. ; lgd:=lgd-1
rs. w0 f0. ; f0:=lgd
; behandl sidste hw. hvis ulige arraylgd.
a0: so w0 1 ; if lgd mod 2 <> 1 then
jl. a1. ; goto test helord
am. (f0.) ; else nulstil sidste element i array
hs w3 x1-1 ;
al w0 -1 ;
wa. w0 f0. ;
rs. w0 f0. ; lgd:=lgd-1;
; behandl første helord, hvis ikke lgd er et helt antal dobbeltord
a1: so w0 2.01 ; if lgd mod 4 = 0
sz w0 2.10 ;
jl. 4 ;
jl. a2. ; then goto nulstil
rs w3 x1 ; else første helord := 0
al w1 x1+2 ; adr:=adr+2
al w0 -2 ;
wa. w0 f0. ; lgd:=lgd-2
rs. w0 f0. ; f0:=lgd
; nulstil portion
a2: rl. w0 f0. ; w0:=lgd
sl w0 4 ; if lgd >= 4 then
jl. c1. ; goto udfør nulstilling
jl. w3 (j8.) ; end adress expression
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; procedure check og udpak array (arr)
; call: w2: stack ref
; w3: return adress
; return: w0: length of array in hw (osse i f0)
; w1: adress of first word in array (osse i f1)
; w2: unchanged
c0: al w1 2.11111 ; entry check and unpack:
la w1 x2+6 ; kind:=bits(19:23).formal1
sn w1 23 ; if kind=zone then kind:=19
al w1 19 ;
sh w1 21 ; if kind > 21
sh w1 16 ; or kind < 17
jl. w3 (j29.) ; then alarm(<:param:>)
sn w1 17 ; if kind = boolean array
al w1 1 ; then w1:=1
sn w1 18 ; if kind = integer array
al w1 2 ; then w1:=2
sl w1 19 ; if kind >= real
al w1 4 ; then w1:=4
rs. w1 f4. ; f4:=if boolean then 1 else i if integer then 2 else 4
rl w1 x2+8 ;
ba w1 x2+6 ;
rl w0 x1-2 ;
rs. w0 f6. ; f6:=upper index
ws w0 x1 ; w0:=upper index -(lower index - k) (= array lgd)
rs. w0 f0. ; f0:=array lgd i hw
rl w1 x1 ;
al w1 x1+1 ; w1:=(lower index - k?) + 1
; det tyder på at der er en fejl i manualen
; da der vist er tale om "lowerindex - 1"
; og ikke som angivet "lowerindex - k"
rs. w1 f5. ; f5:=lower index
wa w1 (x2+8) ; w1:=w1+base for array
rs. w1 f1. ; f1:=abs lower adress
jl x3 ; return
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; udpak param og indexcheck samt oprunding til helord
; call: w0: 1. formal
; w1: 2. formal
; w2: stackref
; w3: retur adr
; retur w1: parameter
; w2: uændret
; w3: brugt til arb
c4:
rs. w3 c5. ; gem returadresse
;
; expressions are computed at callside (value def)
so w0 16 ; if expression
jl. w3 (j4.) ; then goto (rs take expression)
ds. w3 (j30.) ; saved stack ref, saved w3:=w2,w3
dl w1 x1 ; w1:=res
rl w3 x2+10 ;
sz w3 1 ; if type = real
cf w1 0 ; then convert to integer
rl. w3 c7. ; w3:= -8388605
sh w1 x3 ; if param < -8388605
rl. w1 f5. ; then param:=start adr
ac w3 x3 ; w3:=8388605
sl w1 x3 ; if param > 8388605
rl. w1 f6. ; then param:=slut adr
sz w1 1 ; if w1 er ulige
al w1 x1+1 ; then w1:=w1+1
al. w0 c6. ; w0:=alarmtext adresse
sh. w1 (f6.) ; if w1 > upper index
sh. w1 (f5.) ; or w1 < (<= ?) lower index
jl. w3 (j21.) ; then (rs general alarm)
jl. (c5.) ; returner
c5: 0 ; returadr
c6: <:<10>nulfield:> ; alarmtext
c7: -8388605 ; næsten minus moppe
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; procedure udfør nulstil
; call: w0: lgd på resterende array
; w1: adr på første helord til nulstilling
; w3: nul
c1: ac w0 (0) ; w0:=-lgd
sh w0 -256 ; if lgd >= maxlgd
al w0 -256 ; then w0:=-maxlgd
rs. w0 f3. ; f3:=-portion i hw.
rl. w0 f0. ; w0:=lgd
wa. w0 f3. ; w0:=w0+portion
rs. w0 f0. ; lgd:=lgd-portion
ws. w1 f3. ; w1:=w1+portion
rs. w1 f2. ; wrkadr:=wrkadr+portion
rl. w0 f3. ;
as w0 -1 ; w0:=protion // 2
am (0) ;
jl. c3. ; goto c3-portion//2
c2:
ds w3 x1-254 ; nulstil array (wrkadr-254)
ds w3 x1-250 ; nulstil array (wrkadr-250)
ds w3 x1-246 ; nulstil array (wrkadr-246)
ds w3 x1-242 ; nulstil array (wrkadr-242)
ds w3 x1-238 ; nulstil array (wrkadr-238)
ds w3 x1-234 ; nulstil array (wrkadr-234)
ds w3 x1-230 ; nulstil array (wrkadr-230)
ds w3 x1-226 ; nulstil array (wrkadr-226)
ds w3 x1-222 ; nulstil array (wrkadr-222)
ds w3 x1-218 ; nulstil array (wrkadr-218)
ds w3 x1-214 ; nulstil array (wrkadr-214)
ds w3 x1-210 ; nulstil array (wrkadr-210)
ds w3 x1-206 ; nulstil array (wrkadr-206)
ds w3 x1-202 ; nulstil array (wrkadr-202)
ds w3 x1-198 ; nulstil array (wrkadr-198)
ds w3 x1-194 ; nulstil array (wrkadr-194)
ds w3 x1-190 ; nulstil array (wrkadr-190)
ds w3 x1-186 ; nulstil array (wrkadr-186)
ds w3 x1-182 ; nulstil array (wrkadr-182)
ds w3 x1-178 ; nulstil array (wrkadr-178)
ds w3 x1-174 ; nulstil array (wrkadr-174)
ds w3 x1-170 ; nulstil array (wrkadr-170)
ds w3 x1-166 ; nulstil array (wrkadr-166)
ds w3 x1-162 ; nulstil array (wrkadr-162)
ds w3 x1-158 ; nulstil array (wrkadr-158)
ds w3 x1-154 ; nulstil array (wrkadr-154)
ds w3 x1-150 ; nulstil array (wrkadr-150)
ds w3 x1-146 ; nulstil array (wrkadr-146)
ds w3 x1-142 ; nulstil array (wrkadr-142)
ds w3 x1-138 ; nulstil array (wrkadr-138)
ds w3 x1-134 ; nulstil array (wrkadr-134)
ds w3 x1-130 ; nulstil array (wrkadr-130)
ds w3 x1-126 ; nulstil array (wrkadr-126)
ds w3 x1-122 ; nulstil array (wrkadr-122)
ds w3 x1-118 ; nulstil array (wrkadr-118)
ds w3 x1-114 ; nulstil array (wrkadr-114)
ds w3 x1-110 ; nulstil array (wrkadr-110)
ds w3 x1-106 ; nulstil array (wrkadr-106)
ds w3 x1-102 ; nulstil array (wrkadr-102)
ds w3 x1-98 ; nulstil array (wrkadr-98)
ds w3 x1-94 ; nulstil array (wrkadr-94)
ds w3 x1-90 ; nulstil array (wrkadr-90)
ds w3 x1-86 ; nulstil array (wrkadr-86)
ds w3 x1-82 ; nulstil array (wrkadr-82)
ds w3 x1-78 ; nulstil array (wrkadr-78)
ds w3 x1-74 ; nulstil array (wrkadr-74)
ds w3 x1-70 ; nulstil array (wrkadr-70)
ds w3 x1-66 ; nulstil array (wrkadr-66)
ds w3 x1-62 ; nulstil array (wrkadr-62)
ds w3 x1-58 ; nulstil array (wrkadr-58)
ds w3 x1-54 ; nulstil array (wrkadr-54)
ds w3 x1-50 ; nulstil array (wrkadr-50)
ds w3 x1-46 ; nulstil array (wrkadr-46)
ds w3 x1-42 ; nulstil array (wrkadr-42)
ds w3 x1-38 ; nulstil array (wrkadr-38)
ds w3 x1-34 ; nulstil array (wrkadr-34)
ds w3 x1-30 ; nulstil array (wrkadr-30)
ds w3 x1-26 ; nulstil array (wrkadr-26)
ds w3 x1-22 ; nulstil array (wrkadr-22)
ds w3 x1-18 ; nulstil array (wrkadr-18)
ds w3 x1-14 ; nulstil array (wrkadr-14)
ds w3 x1-10 ; nulstil array (wrkadr-10)
ds w3 x1-6 ; nulstil array (wrkadr-6)
ds w3 x1-2 ; nulstil array (wrkadr-2)
c3: jl. a2. ; return til nulstil portion
h. 0, r.d0.+512-8 ; fyld op med nuller
w. <:nulstil<0><0><0><0><0>:> ; fejltext
i.e. ; end segment
w. ; tail for insertproc
g0: ; first entry
1 ; segm
0, 0, 0, 0 ; plads til navn
1<23+i6-i4 ; entrypoint
1<18+41<12 ; notype proc (undefined)
0 ;
; 1<18+3<12+3<6+3<0 ; test
; 13<18+13<12+41<6 ; test
4<12+i3-i4 ; kind, ext list
1<12+0 ; segm, own core
g1: ; last entry
1<23+4 ; backingstorage
0,0,0,0 ; plads til navn
1<23+i7-i4 ; entrypoint
1<18+13<12+13<6+41<0 ; notype proc(undefined, val.integer, val.integer)
0 ;
; 1<18+3<12+3<6+3<0 ; test
; 13<18+13<12+41<6 ; test
4<12+i3-i4 ; kind, ext list
1<12+0 ; segm, own core
l.d. ; list.off
p.<:insertproc:> ; indkopier insertproc
if ok.yes
if warning.yes
(o c
message slang procedure fejl xnulstil xnulfratil
finis)
\f
if listing.yes
head iso
xkl = algol blocks.yes bossline.no ix.no xref.yes
xkl
external
integer procedure xkl;
begin
real r;
systime (5, 0, r);
xkl := r;
end procedure xkl;
end;
if ok.yes
if warning.yes
(o c
message algol procedure fejl xkl
finis)
\f
if listing.yes
head iso
xhex = algol blocks.yes bossline.no ix.no xref.yes
xhex
external
real procedure xhex (tal, cif);
value tal;
long tal;
integer cif;
begin <* returner tal som "cif" hexcifre *>
own integer state;
integer i, j;
real r;
r := real <::>;
if state < cif then
begin <* op til 6 cifre *>
repeat
state := state + 1;
j := tal shift (- (cif - state) * 4) extract 4;
j := if j < 10 then j + '0' else j - 10 + 'A';
r := real (logor (r, extend j shift (40 - (state - 1) mod 6 * 8)));
until state mod 6 = 0 or state = cif;
if state mod 6 <> 0 then state := 0; <* der kan være et "nul" *>
end
else state := 0; <* slut med "nul" *>
xhex := r;
end procedure xhex;
end;
if ok.yes
if warning.yes
(o c
message algol procedure fejl xhex
finis)
\f
if listing.yes
head iso
xbin = algol blocks.yes bossline.no ix.no xref.yes
xbin
external
real procedure xbin (tal, cif);
value tal;
long tal;
integer cif;
begin <* returner tal som "cif" bincifre *>
own integer state;
integer i, j;
real r;
r := real <::>;
if state < cif then
begin <* op til 6 cifre *>
repeat
state := state + 1;
j := tal shift (- (cif - state) * 1) extract 1;
j := if j = 1 then '1' else '.';
r := real (logor (r, extend j shift (40 - (state - 1) mod 6 * 8)));
until state mod 6 = 0 or state = cif;
if state mod 6 <> 0 then state := 0; <* der kan være et "nul" *>
end
else state := 0; <* slut med "nul" *>
xbin := r;
end procedure xbin;
end;
if ok.yes
if warning.yes
(o c
message algol procedure fejl xbin
finis)
\f
if listing.yes
head iso
xstatustxt = algol blocks.yes bossline.no ix.no xref.yes
xstatustext
external
real procedure xstatustxt (bit);
integer bit;
begin
<* proceduren omsætter bit, der angiver bitnr talt fra venstre
i statusordet (0..23) til text
*>
xstatustxt := real (case bit + 1 of (
<:intervention:>,
<:parity error:>,
<:timer:>,
<:data overrun:>,
<:block length:>,
<:end document:>,
<:load point:>,
<:att or tape mark:>,
<:write enable:>,
<:mode error:>,
<:read error:>,
<:card reject:>,
<:checksum:>,
<:bit 13:>,
<:bit 14:>,
<:stopped:>,
<:word defect:>,
<:position error:>,
<:non exist:>,
<:disconnected:>,
<:unintelligible:>,
<:rejected:>,
<:normal:>,
<:hard error:>));
end procedure xstatustxt;
end;
if ok.yes
if warning.yes
(o c
message algol procedure fejl xstatustxt
finis)
\f
if listing.yes
head iso
xwritealarm = algol blocks.yes bossline.no ix.no xref.yes
xwritealarm
external
boolean procedure xwritealarm;
begin
<* hvis alarmtypen er "giveup" udskrives alarmtexten
og der returneres true
ellers returneres false
*>
long array text (1 : 4);
long array field docname;
integer status, cause, param, bit, col;
real comma;
integer array ia (1 : 20);
docname := 8;
status := getalarm (text);
if text (1) shift (- 40) extract 8 <= 'sp' then
begin <* slet foranstillet nl ell lign *>
text (1) := text (1) shift 8 + text (2) shift (- 40);
if text (2) shift (- 40) extract 8 <> 'nul'
then text (2) := text (2) shift 8;
end;
cause := alarm_cause extract 24;
param := alarm_cause shift (-24);
if cause = - 11 then
begin <* giveup alarm *>
xwritealarm := true;
col := write (out, text, param, "sp", 1, text.docname);
comma := real <:: :>;
for bit := 0 step 1 until 23 do
if status shift bit < 0 then
begin
if col > 60 then
begin
outchar (out, 'nl');
comma := real <: :>;
col := 0;
end;
col := col + write (out, string comma, string xstatustxt (bit));
comma := real <:, :>;
end;
end
else xwritealarm := false;
getzone6 (out, ia);
if ia (1) <> 4 then setposition (out, 0, 0);
end procedure xwritealarm;
end;
if ok.yes
if warning.yes
(o c
message algol procedure fejl xwritealarm
finis)
\f
if listing.yes
head iso
xstderror = algol blocks.yes bossline.no ix.no xref.yes
xstderror
external
procedure xstderror (z, s, b);
zone z;
integer s, b;
begin
<* udskriver dokumentnavnet mv og kalder stderror v harderror *>
integer array zd (1 : 20), tail (1 : 10);
long array field laf2;
laf2 := 2;
getzone6 (z, zd);
if monitor (42, z, 0, tail) <> 0 then tail.laf2 (1) := long <::>;
write (out, "nl", 1,
<<zd.dd>, xkl / 100 00, ":", 1, <<d>,
zd.laf2,
<: hw=:>, b,
<: st=:>, string xbin (s, 24),
if tail.laf2 (1) <> long <::> then <: disk.:> else <::>, tail.laf2,
<: mk=:>, zd (1) shift (- 12), ".", 1, zd (1) extract 12,
<: fi=:>, zd (7), <: bl=:>, zd (8), <: seg=:>, zd (9),
<: zst=:>, zd (13), <: ush=:>, zd (17));
getzone6 (out, zd);
if zd (1) <> 4 then setposition (out, 0, 0);
if logor (s, zd (10)) extract 24 <> zd (10) or s extract 1 = 1
then stderror (z, s, b);
end procedure xstderror;
end;
if ok.yes
if warning.yes
(o c
message algol procedure fejl xstderror
finis)
\f
if listing.yes
head iso
xtrapbreak = algol blocks.yes bossline.no ix.no xref.yes
xtrapbreak
external
procedure xtrapbreak;
begin
<* proceduren breaker til næste trapniveau hvis alarmcause=break *>
if alarmcause extract 24 = - 9 then
begin <* break *>
trap (0); <* clear evt. traplabel *>
system (9, 8, <:<10>break:>);
end break;
end procedure xtrapbreak;
end;
if ok.yes
if warning.yes
(o c
message algol procedure fejl xtrapbreak
finis)
\f
if listing.yes
head iso
xnametable = algol blocks.yes bossline.no ix.no xref.yes
xnametable
external
integer procedure xnametable (addr);
value addr;
integer addr;
begin
<* proceduren returnerer name table address for den givne processadresse
ved ukendt process returneres nul
*>
integer array mon (1 : 5);
integer max;
system (5, 72, mon); <* get monitor (72 .. 80) *>
max := (mon (5) - mon (1)) // 2 + 1;
begin <* extra *>
integer array core (1 : max);
integer i, j;
system (5, mon (1), core); <* get nametable *>
i := 0;
for i := i + 1 while core (i) <> addr and i < max do ;
if core (i) = addr
then xnametable := mon (1) + (i - 1) * 2
else xnametable := 0;
end extra;
end procedure xnametable;
end;
if ok.yes
if warning.yes
(o c
message algol procedure fejl xnametable
finis)
\f
if listing.yes
head iso
xmaxbuflgd = algol blocks.yes bossline.no ix.no xref.yes
xmaxbuflgd
external
integer procedure xmaxbuflgd (antbuf, frit, high);
value antbuf;
integer antbuf, frit;
boolean high;
begin
<* proceduren returnerer den maximalt mulige bufferlængde i hw
pr buffer når der skal laves antbuf buffere fordelet over lavt
og højt lager, hvis ikke high benyttes kun lavt lager
der friholdes frit hw til programsegmenter mv
*>
integer i, l, h, b, a_l, a_h;
integer array ia (1 : 4);
long array la (1 : 2);
system (13, i, ia); <* get algol release *>
h := 0;
l := if i <= 2 and ia (1) shift (- 12) <= 3 or not high
then system (2, 0, la) <* før algol2 v.4.0 ell kun lavt lager *>
else system (15, h, la); <* fra algol2 v.4.0 *>
l := l - frit;
if l < 0 then
begin
h := h + l;
l := 0;
end;
if h < 0 then h := 0;
al := (extend antbuf * l) // (l + h);
ah := (extend antbuf * h) // (l + h);
if al + ah < antbuf then antbuf := antbuf + 1;
al := (extend antbuf * l) // (l + h);
ah := (extend antbuf * h) // (l + h);
b :=
if al = 0 then h // ah else
if ah = 0 then l // al else
if h // ah <= l // al then h // ah else l // al;
xmaxbuflgd := b // 4 * 4; <* hele dw adresser *>
comment test write (out, <<d>,
<: l.:>, l, <: h.:>, h, <: al.:>, al, <: ah.:>, ah, <: b.:>, b);
end procedure xmaxbuflgd;
end;
if ok.yes
if warning.yes
(o c
message algol procedure fejl xmaxbuflgd
finis)
\f
if listing.yes
head iso
xinitinput = algol blocks.yes bossline.no ix.no xref.yes
xinitinput
external
procedure xinitinput (z, zd);
zone z;
integer array zd;
begin
<* jsc d. 15/8-1988
procedurekomplex til lowlevel dobbeltbufret io
init-in/out-put benyttes før nogen anden procedure, zonedescriptor
sættes op bl.a med zonestate 15/16 der betegner procedurekomplexet
zonen skal på forhånd være åbnet på normal vis.
setoutput forbereder zonen på output i angivne share, data fyldes
ind med håndkraft.
in/out-put sender message vha. monitor 16. v disk optælles segmcount.
wait-in/out-put afventer svar vha. monitor 18 og kalder evt stderror.
io-funktionerne styres udelukkende af zonen, zonedescriptoren og shareno
der er altid sat op til en maximal stor record
proceduren xcopyzone benytter procedurekomplexet til multibufret
datakopiering, fx. fra lan til disk, disk til disk osv.
*>
<* proceduren initierer zonen z til input *>
integer res, shno;
integer array sh (1 : 12);
shno := 1; <* start med første share *>
getzone6 (z, zd);
if zd (20) < zd (18) then system (9, zd (20), <:<10>zlgth:>);
monitor (92, z, 0, sh); <* create entry lock process *>
if zd (1) extract 12 = 4 then
begin <* disc *>
zd (7) := 0; <* filecount *>
zd (8) := 0; <* blockcount *>
zd (9) := 0; <* segmcount *>
end disc;
zd (13) := 15; <* zonestate after input *>
zd (14) := zd (19) + (zd (20) // zd (18) * 4) * (shno - 1); <* record base *>
zd (15) := zd (14) + zd (20) // zd (18) * 4; <* last hw *>
zd (16) := zd (20) // zd (18) * 4; <* record length *>
zd (17) := shno; <* used share *>
if zd (16) < 1 then system (9, zd (20), <:<10>zlgth:>);
setzone6 (z, zd);
for shno := 1 step 1 until zd (18) do
begin <* pr share *>
comment getshare6 (z, sh, shno);
sh (1) := 0; <* free share *>
sh (2) := (zd (20) // zd (18) * 4) * (shno - 1) + 1; <* first shared *>
sh (3) := sh (2) + (zd (20) // zd (18) * 4) - 1; <* last shared *>
sh (4) := 3 shift 12 + 0; <* input *>
sh (5) := zd (19) + sh (2); <* first abs adr *>
sh (6) := zd (19) + sh (3) - 1; <* last abs adr *>
sh (7) := zd (9); <* segm count *>
sh (8) := sh (9) := sh (10) := sh (11) := 0; <* ubenyttet *>
sh (12) := sh (5) + 0; <* top transferred *>
setshare6 (z, sh, shno);
end pr share;
end procedure xinitinput;
end;
if ok.yes
if warning.yes
(o c
message algol procedure fejl xinitinput
finis)
\f
if listing.yes
head iso
xinput = algol blocks.yes bossline.no ix.no xref.yes
xinput
external
integer procedure xinput (z, zd, shno, hw);
value hw;
zone z;
integer array zd;
integer shno, hw;
begin
<* proceduren starter input af hw halvord på zonen z's share shno
hvis hw = 0 laves input med maxlgd
hvis hv < 512 og kind = 4 laves alarm (length)
hvis hw > zonebuffer laves alarm (length)
hvis zonestate <> 15 laves alarm (zonest)
hvis kind=4 tælles segmentcount op til næste segm
retur antal hw i inputmessage
*>
integer array sh (1 : 12);
comment getzone6 (z, zd);
comment getshare6 (z, sh, shno);
if hw = 0 then hw := zd (20) // zd (18) * 4; <* max antal hw *>
if zd (13) <> 15 then system (9, zd (13), <:<10>zonest:>);
if zd (1) extract 12 = 4 and hw < 512 then system (9, hw, <:<10>length:>);
if hw > zd (20) // zd (18) * 4 then system (9, hw, <:<10>length:>);
zd (14) := zd (19) + (zd (20) // zd (18) * 4) * (shno - 1); <* record base *>
zd (15) := zd (14) + zd (20) // zd (18) * 4; <* last hw *>
zd (16) := zd (20) // zd (18) * 4; <* record length *>
zd (17) := shno; <* used share *>
sh (1) := 0; <* free share *>
sh (2) := (zd (20) // zd (18) * 4) * (shno - 1) + 1; <* first shared *>
sh (3) := sh (2) + (zd (20) // zd (18) * 4) - 1; <* last shared *>
sh (4) := 3 shift 12 + 0; <* input *>
sh (5) := zd (19) + sh (2); <* first abs adr *>
sh (6) := sh (5) + hw - 2; <* last abs adr *>
sh (7) := zd (9); <* segm count *>
sh (8) := sh (9) := sh (10) := sh (11) := 0; <* ubenyttet *>
sh (12) := sh (5) + 0; <* top transferred *>
setzone6 (z, zd);
setshare6 (z, sh, shno);
if monitor (16, z, shno, zd) = 0 then system (9, 6, <:<10>break:>);
if zd (1) extract 12 = 4 then zd (9) := zd (9) + hw // 512; <* segmcount *>
setzone6 (z, zd);
xinput := hw;
end procedure xinput;
end;
if ok.yes
if warning.yes
(o c
message algol procedure fejl xinput
finis)
\f
if listing.yes
head iso
xwaitinput = algol blocks.yes bossline.no ix.no xref.yes
xwaitinput
external
integer procedure xwaitinput (z, zd, shno);
zone z;
integer array zd;
integer shno;
begin
<* proceduren afventer input på zonen z's share shno
retur antal hw læst
*>
integer hw, res;
integer array sh (1 : 12), answer (1 : 8);
zd (14) := zd (19) + (zd (20) // zd (18) * 4) * (shno - 1); <* record base *>
zd (15) := zd (14) + zd (20) // zd (18) * 4; <* last hw *>
zd (17) := shno; <* used share, skal sættes før wait answer *>
zd (16) := zd (20) // zd (18) * 4; <* record length *>
setzone6 (z, zd);
res := monitor (18, z, shno, answer);
if res = 1 and answer (1) = 0 then <* ok *> else
if res <> 1 then xstderror (z, 1 shift res, 0) else
if answer (1) = 1 shift 18 then hw := 0 <* em *> else
if answer (1) <> 0 then xstderror (z, answer (1), answer (2));
hw := answer (2);
xwaitinput := hw;
end procedure xwaitinput;
end;
if ok.yes
if warning.yes
(o c
message algol procedure fejl xwaitinput
finis)
\f
if listing.yes
head iso
xinitoutput = algol blocks.yes bossline.no ix.no xref.yes
xinitoutput
external
procedure xinitoutput (z, zd);
zone z;
integer array zd;
begin
<* proceduren initierer zonen z til output *>
integer res, shno;
integer array sh (1 : 12);
shno := 1; <* start med første share *>
getzone6 (z, zd);
if zd (20) < zd (18) then system (9, zd (20), <:<10>zlgth:>);
monitor (92, z, 0, sh); <* create entry lock process *>
monitor (8, z, 0, sh); <* reserve process *>
if zd (1) extract 12 = 4 then
begin <* disc *>
zd (7) := 0; <* filecount *>
zd (8) := 0; <* blockcount *>
zd (9) := 0; <* segmcount *>
end disc;
zd (13) := 16; <* zonestate after output *>
zd (14) := zd (19) + (zd (20) // zd (18) * 4) * (shno - 1); <* record base *>
zd (15) := zd (19) + zd (20) // zd (18) * 4; <* last hw *>
zd (16) := zd (20) // zd (18) * 4; <* record length *>
zd (17) := shno; <* used share *>
if zd (16) < 1 then system (9, zd (20), <:<10>zlgth:>);
setzone6 (z, zd);
for shno := 1 step 1 until zd (18) do
begin <* pr share *>
comment getshare6 (z, sh, shno);
sh (1) := 0; <* free share *>
sh (2) := (zd (20) // zd (18) * 4) * (shno - 1) + 1; <* first shared *>
sh (3) := sh (2) + (zd (20) // zd (18) * 4) - 1; <* last shared *>
sh (4) := 5 shift 12 + 0; <* output *>
sh (5) := zd (19) + sh (2); <* first abs adr *>
sh (6) := zd (19) + sh (3) - 1; <* last abs adr *>
sh (7) := zd (9); <* segm count *>
sh (8) := sh (9) := sh (10) := sh (11) := 0; <* ubenyttet *>
sh (12) := sh (5) + 0; <* top transferred *>
setshare6 (z, sh, shno);
end pr share;
end procedure xinitoutput;
end;
if ok.yes
if warning.yes
(o c
message algol procedure fejl xinitoutput
finis)
\f
if listing.yes
head iso
xsetoutput = algol blocks.yes bossline.no ix.no xref.yes
xsetoutput
external
procedure xsetoutput (z, zd, shno, hw);
zone z;
integer array zd;
integer shno, hw;
begin
<* proceduren setter up til output af hw halvord på zonen z's share shno
hvis hw < 512 og kind = 4 laves alarm (length)
hvis hw = 0 laves alarm (length)
hvis hw > zonebuffer laves alarm (length)
hvis zonestate <> 16 laves alarm (zonest)
*>
integer array sh (1 : 12);
comment getzone6 (z, zd);
comment getshare6 (z, sh, shno);
if zd (13) <> 16 then system (9, zd (13), <:<10>zonest:>);
if hw < 512 and zd (1) extract 12 = 4
or hw = 0 then system (9, hw, <:<10>length:>);
if hw > zd (20) // zd (18) * 4 then system (9, hw, <:<10>length:>);
zd (14) := zd (19) + (zd (20) // zd (18) * 4) * (shno - 1); <* record base *>
zd (15) := zd (14) + zd (20) // zd (18) * 4; <* last hw *>
zd (16) := hw; <* record length *>
zd (17) := shno; <* used share *>
setzone6 (z, zd);
end procedure xsetoutput;
end;
if ok.yes
if warning.yes
(o c
message algol procedure fejl xsetoutput
finis)
\f
if listing.yes
head iso
xoutput = algol blocks.yes bossline.no ix.no xref.yes
xoutput
external
integer procedure xoutput (z, zd, shno, hw);
zone z;
integer array zd;
integer shno, hw;
begin
<* proceduren starter output af hw halvord på zonen z's share shno
hvis hw < 512 og kind = 4 laves alarm (length)
hvis hw = 0 laves alarm (length)
hvis hw > zonebuffer laves alarm (length)
hvis zonestate <> 16 laves alarm (zonest)
hvis kind=4 tælles segmentcount op til næste segm
retur antal hw i inputmessage
*>
integer array sh (1 : 12);
comment getzone6 (z, zd);
comment getshare6 (z, sh, shno);
if zd (13) <> 16 then system (9, zd (13), <:<10>zonest:>);
if hw < 512 and zd (1) extract 12 = 4
or hw = 0 then system (9, hw, <:<10>length:>);
if hw > zd (20) // zd (18) * 4 then system (9, hw, <:<10>length:>);
zd (14) := zd (19) + (zd (20) // zd (18) * 4) * (shno - 1); <* record base *>
zd (15) := zd (19) + zd (20) // zd (18) * 4; <* last hw *>
zd (16) := zd (20) // zd (18) * 4; <* record length *>
zd (17) := shno; <* used share *>
sh (1) := 1; <* ready share *>
sh (2) := (zd (20) // zd (18) * 4) * (shno - 1) + 1; <* first shared *>
sh (3) := sh (2) + (zd (20) // zd (18) * 4) - 1; <* last shared *>
sh (4) := 5 shift 12 + 0; <* output *>
sh (5) := zd (19) + sh (2); <* first abs adr *>
sh (6) := sh (5) + hw - 2; <* last abs adr *>
sh (7) := zd (9); <* segm count *>
sh (8) := sh (9) := sh (10) := sh (11) := 0; <* ubenyttet *>
sh (12) := sh (5) + 0; <* top transferred *>
setzone6 (z, zd);
setshare6 (z, sh, shno);
if monitor (16, z, shno, zd) = 0 then system (9, 6, <:<10>break:>);
if zd (1) extract 12 = 4 then zd (9) := zd (9) + hw // 512; <* segmcount *>
setzone6 (z, zd);
xoutput := hw;
end procedure xoutput;
end;
if ok.yes
if warning.yes
(o c
message algol procedure fejl xoutput
finis)
\f
if listing.yes
head iso
xwaitoutput = algol blocks.yes bossline.no ix.no xref.yes
xwaitoutput
external
integer procedure xwaitoutput (z, zd, shno);
zone z;
integer array zd;
integer shno;
begin
<* proceduren afventer output på zonen z's share shno
retur antal hw skrevet
*>
integer hw, res;
integer array sh (1 : 12), answer (1 : 8);
zd (14) := zd (19) + (zd (20) // zd (18) * 4) * (shno - 1); <* record base *>
zd (15) := zd (14) + zd (20) // zd (18) * 4; <* last hw *>
zd (16) := zd (20) // zd (18) * 4; <* record length *>
zd (17) := shno; <* used share, skal sættes før wait answer *>
setzone6 (z, zd);
res := monitor (18, z, shno, answer);
if res = 1 and answer (1) = 0 then <* ok *> else
if res <> 1 then xstderror (z, 1 shift res, 0) else
if answer (1) <> 0 then xstderror (z, answer (1), answer (2));
hw := answer (2);
xwaitoutput := hw;
end procedure xwaitoutput;
end;
if ok.yes
if warning.yes
(o c
message algol procedure fejl xwaitoutput
finis)
\f
if listing.yes
head iso
xcopyzone = algol blocks.yes bossline.no ix.no xref.yes
xcopyzone
external
long procedure xcopyzone (z_ind, z_ud, lgd, buflgd, shares);
value lgd;
zone z_ind, z_ud;
long lgd;
integer buflgd, shares;
begin
<* jsc d. 22/9-1988
proceduren kopierer indholdet fra z_ind til z_ud
hvis lgd >= 0 kopieres lgd hw ellers til em på input
z_ind og z_ud er zoner indeholdende kind og navn
filer udvides ikke, stderror kaldes strax ved fejl
antal hw kopieret returneres i procedurenavnet
buflgd angiver hver enkelt buffer i hw
shares angiver ønsket antal buffere pr input og output
fx. giver buflgd=512 og shares=2 ialt 4 shares og 2048 hw
*>
<* testudskrifter slås til ved at ændre "comment test" til "comment test" *>
zone z (buflgd // 4 * 2 * shares, 2 * shares, xstderror);
integer shno, antsh, aktive, i;
long hw;
boolean em;
long array field laf2;
integer array ia, zd_ind, zd_ud (1 : 20), data (1 : shares * 2);
laf2 := 2;
antsh := shares * 2;
em := false;
hw := 0;
if lgd < 0 then lgd := (extend (- 1)) shift (- 1); <* max tal *>
comment test write (out, "nl", 1, <<d>, <:xcopyzone,:>,
<: lgd.:>, lgd,
<: buflgd.:>, buflgd,
<: shares.:>, shares,
<: forbrug, bufs.:>, antsh, <: hw:>, antsh * buflgd);
<* open *>
getzone6 (z_ind, ia);
comment test write (out, "nl", 1, <:kopier fra.:>, ia.laf2,
<<d>, <: kind.:>, ia (1) shift (- 12), ".", 1, ia (1) extract 12);
getzone6 (z, zd_ind);
tofrom (zd_ind, ia, 26); <* genbrug zd (1)..zd (13) *>
setzone6 (z, zd_ind);
xinitinput (z, zd_ind);
getzone6 (z_ud, ia);
comment test write (out, "nl", 1, <:kopier til.:>, ia.laf2,
<<d>, <: kind.:>, ia (1) shift (- 12), ".", 1, ia (1) extract 12);
getzone6 (z, zd_ud);
tofrom (zd_ud, ia, 26); <* genbrug zd (1)..zd (13) *>
setzone6 (z, zd_ud);
xinitoutput (z, zd_ud);
for shno := 1 step 1 until antsh do data (shno) := 0; <* fri *>
aktive := 0;
for shno := 1 step 2 until antsh do
if lgd > 0 then
begin <* initier input i hveranden *>
comment test write (out, "nl", 1, <<d>, <:init input sh.:>, shno);
data (shno) := - xinput (z, zd_ind, shno, 0); <* input max *>
lgd := lgd + data (shno);
data (shno) := - 1; <* input sendt *>
aktive := aktive + 1;
end init input;
shno := 1;
while aktive > 0 do
begin <* while shares ude *>
if data (shno) > 0 then
begin <* output sendt *>
comment test write (out, "nl", 1, <<d>, <:wait output:>);
i := xwaitoutput (z, zd_ud, shno);
if i < data (shno) then xstderror (z, 1 shift 19, i); <* blocklength *>
hw := hw + i;
data (shno) := 0; <* fri *>
aktive := aktive - 1;
end output sendt;
if data (shno) < 0 then
begin <* input sendt *>
comment test write (out, "nl", 1, <<d>, <:wait input:>);
i := xwaitinput (z, zd_ind, shno);
if i < - data (shno) then xstderror (z, 1 shift 19, i); <* blocklength *>
data (shno) := i; <* marker output sendt *>
comment test write (out, <<d>, <: received.:>, data (shno));
if data (shno) >= 512 then
begin <* ej em *>
comment test write (out, "nl", 1, <<d>, <:output.:>, data (shno));
xoutput (z, zd_ud, shno, data (shno));
end ej em
else
begin <* em *>
comment test write (out, "nl", 1, <<d>, <:em:>);
em := true;
data (shno) := 0; <* fri *>
aktive := aktive - 1;
end em;
end input sendt;
if data (shno) = 0 and not em and lgd > 0 then
begin <* fri og ej em *>
comment test write (out, "nl", 1, <<d>, <:input:>);
data (shno) := - xinput (z, zd_ind, shno, 0); <* input max *>
lgd := lgd + data (shno);
aktive := aktive + 1;
end fri og ej em;
shno := if shno <> antsh then shno + 1 else 1;
comment test write (out, "nl", 1, <<d>, <:status,:>,
<: shno.:>, shno,
<: aktive.:>, aktive,
<: em.:>, if em then <:ja:> else <:nej:>,
<: data (:>, shno, <:) = :>, data (shno),
<: lgd.:>, lgd);
end while aktive;
xcopyzone := hw;
end procedure xcopyzone;
end;
if ok.yes
if warning.yes
(o c
message algol procedure fejl xcopyzone
finis)
\f
if listing.yes
head iso
xdumpzone = algol blocks.yes bossline.no ix.no xref.yes
xdumpzone
external
procedure xdumpzone (zout, z, shno, txt);
zone zout, z;
integer shno;
string txt;
begin
<* proceduren udskriver indholdet af zonedescriptor
hvis shno > 0 udskrives sharedescriptor nr shno
hvis shno = 0 udskrives samtlige sharedescriptore
hvis shno < 0 udskrives ingen sharedescriptor
der udskrives på zonen zout
*>
integer i, j;
integer array sh (1 : 12), zd (1 : 20);
long array field laf2;
laf2 := 2;
getzone6 (z, zd);
write (zout, "nl", 1, <:zone.:>, zd.laf2, "sp", 1, txt);
for i := 1 step 1 until 20 do write (zout, <<-dddddddd>,
if i mod 6 = 1 then "nl" else "sp", 1, zd (i));
if shno >= 0 then
for j := (if shno = 0 then 1 else shno) step 1
until (if shno = 0 then zd (18) else shno) do
begin
getshare6 (z, sh, j);
write (zout, "nl", 1, <:share no:>, j);
for i := 1 step 1 until 12 do write (zout, <<-dddddddd>,
if i mod 6 = 1 then "nl" else "sp", 1, sh (i));
end;
outchar (zout, 'nl');
getzone6 (zout, zd);
if zd (1) <> 4 then setposition (zout, 0, 0);
end procedure xdumpzone;
end;
if ok.yes
if warning.yes
(o c
message algol procedure fejl xdumpzone
finis)
\f
if listing.yes
head iso
xconnectout = algol blocks.yes bossline.no ix.no xref.yes
xconnectout
external
boolean procedure xconnectout;
begin
<* jsc d. 27/7-1988
connecter en evt. venstreside i programkaldet til out
efterfølgende kald disconecter
retur: true hvis venstreside i programkaldet eller false
*>
own integer nr;
own long l1, l2;
long array la, stack (1 : 2);
integer array ia (1 : 20);
if system (4, 1, la) = 6 shift 12 + 10 then
begin <* venstre side *>
if nr = 1 then
begin <* disconnect *>
stack (1) := l1;
stack (2) := l2;
getzone6 (out, ia);
fpproc (34, 0, out, if ia (1) = 0 or ia (1) = 8 then 'nl' else 'em'); <* close up *>
fpproc (30, 0, out, stack); <* unstack zone *>
end disconnect
else
if nr = 0 then
begin <* connect *>
stack (1) := stack (2) := long <::>;
system (4, 0, la);
fpproc (33, 0, out, 'nul'); <* out end *>
fpproc (29, 0, out, stack); <* stack zone *>
fpproc (28, 1 shift 1 + 1, out, la); <* connect zone *>
if monitor (42, out, 0, ia) = 0 and ia (1) >= 0 then
begin <* lookup file ok *>
ia (1) := 1;
ia (6) := systime (7, 0, 0.0);
ia (7) := ia (8) := ia (9) := ia (10) := 0;
monitor (44, out, 0, ia);
end lookup;
l1 := stack (1);
l2 := stack (2);
end connect;
nr := nr + 1;
xconnectout := true;
end venstre side
else xconnectout := false;
end procedure xconnectout;
end;
if ok.yes
if warning.yes
(o c
message algol procedure fejl xconnectout
finis)
\f
if listing.yes
head iso
xsortsq = algol blocks.yes bossline.no ix.no xref.yes
xsortsq
external
procedure xsortsq (fromname, toname, todisc, nkey, recdescr, maxreclength, clear);
long array fromname, toname, todisc;
integer nkey, maxreclength;
integer array recdescr;
boolean clear;
begin
<* proceduren sorterer sqfilen i fromname over i toname
call parametre:
fromname ::= fra navn
toname ::= tilnavn, 'nul' medfører wrknavn
todisc ::= tildisc, 'nul' medfører frit valg
nkey ::= antal nøgler
recdescr ::= integer array (1 : nkey + 1, 1 : 2) der
beskriver af nøglerne på formen:
key1: type, field, key2: type, field ....
type dækker over følgende:
1=12 bit signed integer
2=24 bit signed integer
3=long
4=real
5=12 bit unsigned integer
positiv medfører stigende sortering
negativ medfører faldende sortering
hvis recdescr (nkey + 1, 1) <> 0 indholder
den længdefeltet for recorden, ellers er der
tale om fastlængde records
maxreclength ::= fastlængde: recordlængden
variablellængde: maximal recordlængde
clear ::= true medfører clearing af inputfil
*>
integer noofrecs, result, explanation, i, j;
real eof;
integer array param (1 : 7);
real array names (1 : 6);
long array field laf0, laf8, laf16;
laf0 := 0;
laf8 := 8;
laf16 := 16;
param (1) := 0; <* segsprblock fra sq-filen *>
param (2) := clear extract 1; <* 0=bevar inputfilen, 1=slet inputfilen *>
param (3) := 0; <* segsprblock fra sq-filen *>
param (4) := if recdescr (nkey + 1, 1) = 0 then 1 else 0; <* 1=fix, 0=var *>
param (5) := maxreclength; <* reclgd/max reclgd *>
param (6) := nkey; <* noofkeys *>
param (7) := 1; <* runtimealarm v. resourceproblemer *>
tofrom (names.laf0, fromname, 8);
tofrom (names.laf8, toname, 8);
tofrom (names.laf16, todisc, 8);
eof := real <::>;
noofrecs := - 1; <* tag fra sqfilen *>
mdsortproc (param, recdescr, names, eof, noofrecs, result, explanation);
if result <> 1 then system (9, 8,<:<10>xsortsq:>);
tofrom (toname, names.laf8, 8); <* toname retur *>
end procedure xsortsq;
end;
if ok.yes
if warning.yes
(o c
message algol procedure fejl xsortsq
finis)
\f
if listing.yes
head iso
xclaimproc = algol blocks.yes bossline.no ix.no xref.yes
xclaimproc
external
boolean procedure xclaimproc (keyno, bsno, bsname, entries, segm, slicelgd);
value keyno;
integer keyno, bsno, entries, segm, slicelgd;
long array bsname;
<*******************************************************************************
parametre keyno (kald) : 0 : temp
2 : login
3 : user / project
bsno (kald) : -2 : returværdi = bsno for device with bsname
-1 : returværdi = bsno for main bsdevice
0-n : uændret returværdi (n = max bsdevice)
bsname (retur) : discnavn
entries( - ) : antal entries (keyno)
segm ( - ) : antal segmenter (keyno)
slicelgd( - ) : slicelængde
*******************************************************************************>
begin
boolean før_mon9;
integer bsdevices, firstbs, ownadr, mainbs, i;
long array field name;
integer array core (1 : 18);
name := 0;
ownadr := system (6, i, core.name);
system (5, 92, core);
bsdevices := (core (3) - core (1)) // 2;
firstbs := core (1);
mainbs := core (4);
if bsno >= 0 and bsno < bsdevices and keyno >= 0 and keyno <= 3
or bsno >= - 2 and bsno < 0
then
begin
integer array nametable (1 : bsdevices);
name := 18;
xclaimproc := true;
system (5, firstbs, nametable);
if keyno < 0 or keyno > 3 then keyno := 0;
if bsno = - 1 then
begin <* find main device number *>
for bsno := bsno + 1 while nametable (bsno + 1) <> mainbs do;
end bsno = - 1
else
if bsno = - 2 then
begin <* find device number for bsname *>
bsno := - 1;
repeat
bsno := bsno + 1;
system (5, nametable (bsno + 1) - 36, core); <* get chaintable *>
until bsno >= bsdevices
or (core.name (1) = bsname (1)
and (core.name (1) extract 8 = 0 or core.name (2) = bsname (2)));
if bsno >= bsdevices then goto fejl;
end bsno = - 2;
system (5, nametable (bsno + 1) - 36, core); <* get chaintable *>
if core.name (1) shift (- 40) = 'nul' then goto ud;
bsname (1) := core.name (1);
if core.name (1) extract 8 <> 'nul'
then bsname (2) := core.name (2)
else bsname (2) := long <::>;
slicelgd := core (15);
før_mon9 := core (2) extract 12 shift (- 3) <> 3;
system (5, ownadr + core (1), core); <* get process description *>
if før_mon9 then
begin <* monitor rel før 9.0 *>
entries := core (keyno + 1) shift (- 12);
segm := core (keyno + 1) extract 12 * slicelgd;
end
else
begin <* monitor rel 9.0 og derefter *>
entries := core (keyno * 2 + 1);
segm := core (keyno * 2 + 2) * slicelgd;
end;
end else
begin
fejl:
xclaimproc := false;
ud: entries := segm := slicelgd := 0;
bsname (1) := bsname (2) := 0;
end;
end xclaimproc;
end;
if ok.yes
if warning.yes
(o c
message algol procedure fejl xclaimproc
finis)
\f
if listing.yes
head iso
xbsclaim = algol blocks.yes bossline.no ix.no xref.yes
xbsclaim
external
boolean procedure xbsclaim (funk, segm, entry, slicelgd, perm, kit);
value funk, perm;
integer funk, perm, segm, entry, slicelgd;
long array kit;
begin
<*******************************************************************************
kald:
funk = 0 => max segmenter, entry opfyldt
1 => max entries , segm opfyldt
2 => max segmenter, max entries
3 => mest hensigtsmæssige disc, segm opfyldt, entr opfyldt
4 => min segmenter, segmenter og entries opfyldt
5 => min entries, segmenter og entries opfyldt
6 => min segmenter og min entries, s og e opfyldt
segm = minimum antal segmenter der kræves
entry = minimum antal entries der kræves
perm = den aktuelle permkey (0=temp, 2=login, 3=user/project)
kit = hvis kit = <::> ønskes et vilkårligt kit ellers kit
hvis kravene ikke er opfyldt er bs_claim falsk og parametrene uforandrede
hvis kravene er opfyldt er bs_claim sand og følgende gælder:
retur:
kit = navnet på kittet
segm = antal segmenter på kit
entry = antal entries på kit
slicelgd = segm pr slice på kit
perm = permkey for valgte løsning
*******************************************************************************>
real procedure ulempe;
begin
<* proceduren beregner ulempeværdien for en given sammensætning af
slicelængde, rest-slices, rest-segmenter,
vægtene for forbrug af slices og entries kan varieres i koden *>
integer spild, fillgd_slices, afv_fra_gnsn, led_slices,
slice_fak, entry_fak; <* sette er de to omtalte vægte *>
real pct_fri_slices, pct_fri_entries;
if seg >= slgd and entr > 0 then
begin
slice_fak := 20;
entry_fak := 10;
spild := (segm + slgd - 1) // slgd * slgd - segm;
fillgd_slices := (segm - 1) // slgd + 1;
led_slices := seg // slgd;
pct_fri_entries := 100 / entr;
pct_fri_slices := fillgd_slices * 100 / led_slices;
afv_fra_gnsn := abs (fillgd_slices - led_slices / entr) * 100 / (led_slices / entr);
ulempe := spild + slice_fak * pct_fri_slices + entry_fak * pct_fri_entries + afv_fra_gnsn;
end seg > 0 and entr > 0
else ulempe := 2 ** 2044;
end procedure ulempe;
real gl_ulempe;
integer max_entr, max, max_sl, kit_no, entr, seg, slgd, p, max_p;
long array max_kit, bs (1 : 2);
max_entr := max := max_sl := 0;
max_p := perm;
tofrom (max_kit, kit, 8);
gl_ulempe := 2 ** 2045;
for p := perm step 1 until 3 do
begin <* alle permkeys støøre end ell lig med *>
kit_no := - 1;
for kit_no := kit_no + 1 while
xclaimproc (p, kit_no, bs, entr, seg, slgd) do
if bs (1) shift (- 40) = 'nul'
or (kit (1) shift (- 40) <> 'nul'
and (kit (1) <> bs (1)
or kit (1) extract 8 <> 'nul' and kit (2) <> bs (2)))
then <* forkert kit *> else
if (case funk + 1 of (
seg > max and entr >= entry,
entr > max_entr and seg >= segm,
seg > max and entr >= max_entr or seg >= max and entr > max_entr,
gl_ulempe > ulempe,
seg >= segm and entr >= entry and (seg < max or max = 0),
seg >= segm and entr >= entry and (entr < max_entr or max_entr = 0),
seg >= segm and entr >= entry and ((seg < max or max = 0) or (entr < max_entr or max_entr = 0)),
false))
then
begin
gl_ulempe := ulempe;
max_entr := entr; max := seg; max_sl := slgd; max_p := p;
tofrom (max_kit, bs, 8);
end;
end pr perm;
if max >= segm and max_entr >= entry and max_kit (1) <> 0 then
begin
xbsclaim := true;
tofrom (kit, max_kit, 8); segm := max; entry := max_entr; slicelgd := max_sl; perm := max_p;
end ok else xbsclaim := false;
end procedure xbsclaim;
end;
if ok.yes
if warning.yes
(o c
message algol procedure fejl xbsclaim
finis)
\f
if listing.yes
head iso
xopencreate = algol blocks.yes bossline.no ix.no xref.yes
xopencreate
external
integer procedure xopencreate (z, modekind, name, giveup, perm);
value modekind;
zone z;
integer modekind;
long array name;
integer giveup;
integer perm;
begin
<* retur:
0 = ok
1 = reserved by another
2 = calling process is not a user
3 = process does not exist
4 = area process is writeprotected
processen åbnes og der returneres efter ovenstående mønster,
hvis filen ikke existerer oprettes denne,
hvis der er peget på en entry åbnes til det denne peger på,
oprettelse finder sted på disken med flest <perm> segmenter.
filen reserveres ikke.
*>
integer i;
integer array ia (1 : 20), bases (1 : 8);
long array field doc;
doc := 2;
system (11, 0, bases);
open (z, modekind, name, giveup);
if monitor (42, z, 0, ia) = 0 <* existerer *>
and ia (1) < 0 <* entry *>
then
begin <* gå videre i kæden *>
close (z, true);
open (z, ia (1) extract 23, ia.doc, giveup);
modekind := ia (1) extract 23;
end entry;
if modekind extract 12 = 4 then
begin <* diskfil *>
if monitor (76, z, 0, ia) <> 0 <* lookup entry *>
or ia (2) < bases (7) or ia (3) > bases (8) then
begin <* create entry *>
ia.doc (1) := ia.doc (2) := long <::>;
xbsclaim (0, 1, 1, 0, perm, ia.doc); <* find disk med flest <perm> segm *>
ia (7) := ia (8) := ia (9) := ia (10) := 0;
ia (1) := 1;
ia (6) := systime (7, 0, 0.0);
monitor (40, z, 0, ia); <* create entry *>
end create entry;
end diskfil;
monitor (52, z, 0, ia); <* create area process *>
xopencreate := monitor (8, z, 0, ia); <* reserve process *>
monitor (10, z, 0, ia); <* release process *>
end procedure xopencreate;
end;
if ok.yes
if warning.yes
(o c
message algol procedure fejl xopencreate
finis)
\f
if listing.yes
head iso
xopencrsq = algol blocks.yes bossline.no ix.no xref.yes
xopencrsq
external
integer procedure xopencrsq (z, name, giveup, function, perm);
zone z;
long array name;
integer giveup, function, perm;
begin
<*
processen åbnes og der returneres med opensq's værdi
hvis filen ikke existerer oprettes denne,
oprettelse finder sted på disken med flest <perm> segmenter.
filen reserveres ikke.
*>
integer array ia (1 : 20), bases (1 : 8);
integer buflgd;
long array field doc;
integer i;
doc := 2;
system (11, 0, bases);
getzone6 (z, ia);
buflgd := ia (20) // 128;
open (z, 4, name, 0);
close (z, false);
if function extract 12 <> 2 then <* ej opret *> else
if monitor (76, z, 0, ia) <> 0 <* lookup entry *>
or ia (2) < bases (7) or ia (3) > bases (8) then
begin <* create entry *>
ia.doc (1) := ia.doc (2) := long <::>;
xbsclaim (0, 1, 1, 0, perm, ia.doc); <* find disk med flest <perm> segm *>
ia (7) := ia (8) := ia (9) := ia (10) := 0;
ia (1) := 0;
ia (6) := systime (7, 0, 0.0);
monitor (40, z, 0, ia); <* create entry *>
end create entry;
i := 1;
xopencrsq := opensq (z, string name (increase (i)), giveup, function);
end procedure xopencrsq;
end;
if ok.yes
if warning.yes
(o c
message algol procedure fejl xopencrsq
finis)
\f
if listing.yes
head iso
xprimostate = algol blocks.yes bossline.no ix.no xref.yes index.yes
xprimostate (index.yes)
external
real procedure xprimostate (nr);
integer nr;
begin
<* max 17 tegn retur *>
if nr < 0 then xprimostate := real (case - nr of (
<:?:>,
<:Afvist af Primo:>,
<:Primofejl:>,
<:Primofejl:>,
<:Primo mangler:>,
<:Buffermangel:>,
<:Parameterfejl:>,
<:Parameterfejl:>,
<:Parameterfejl:>,
<:?:>,
<:?:>,
<:Transport ukendt:>,
<:Resourcemangel:>,
<:?:>,
<:Filproblemer:>,
<:Printerproblemer:>))
else xprimostate := real <:Ok:>;
end procedure xprimostate;
end;
if ok.yes
if warning.yes
(o c
message algol procedure fejl xprimostate
finis)
\f
if listing.yes
head iso
xprimosend = algol blocks.yes bossline.no ix.no xref.yes index.yes
xprimosend (index.yes)
external
integer procedure xprimosend (printer, fil);
long array printer, fil;
begin
<* sender filen "fil" til printeren beskrevet ved entryen "printer",
primosend returnerer transportnumret hvis alt er ok
ellers - fejlkode, hvor
fejlkode: 1 = ?
2 = Afvist af Primo
3 = Primofejl
4 = Primofejl
5 = Primo mangler
6 = Messagebuffermangel
7 = Parameterfejl
8 = Parameterfejl
9 = Parameterfejl
10 = ?
11 = ?
12 = Transport ukendt
13 = Resourcemangel
14 = ?
15 = Problemer med filen
16 = Problemer med printeren
*>
integer i, cleng, rleng;
integer array carr (1 : 39), rarr (1 : 11);
long array field transname, username, sendername, receivername,
groupname, queuename;
integer field reply, number, criterion, sendererror, receivererror,
state, chposition, errorcause, errorstatus;
long array processname (1 : 2);
transname := 4;
username := 16;
sendername := 40;
receivername := 50;
groupname := 60;
queuename := 68;
reply := 2;
number := 4;
criterion := 60;
sendererror := 16;
receivererror := 20;
state := 42;
chposition := 44;
errorcause := 50;
errorstatus := 52;
cleng := 39;
for i := 1 step 1 until cleng do carr (i) := - 1;
rleng := 11;
for i := 1 step 1 until rleng do rarr (i) := 0;
system (6, 0, processname); <* processname som user *>
tofrom (carr.username, processname, 8);
if fil (1) extract 8 = 'nul' then fil (2) := long <::>;
tofrom (carr.sendername, fil, 8);
if printer (1) extract 8 = 'nul' then printer (2) := long <::>;
tofrom (carr.receivername, printer, 8);
i := transfer (2, carr, cleng, rarr, rleng);
if i = 0 and rarr.reply <> 0 then i := rarr.reply + 10;
xprimosend := if i = 0 then rarr.number else - i;
end procedure xprimosend;
end;
if ok.yes
if warning.yes
(o c
message algol procedure fejl xprimosend
finis)
\f
if listing.yes
head iso
xhost = algol blocks.yes bossline.no ix.no xref.yes
xhost
external
integer procedure xhost (name);
long array name; <* min 2 dw *>
begin
<* hent hostid og hostname
hvis hostname starter med rc8000 og der er mere end 11 tegn
slettes rc8000 samt evt efterfølgende - ol.
*>
integer array ia (1 : 1);
long array xname (1 : 3);
system (5, 1186, ia);
xhost := ia (1);
system (5, 1192, xname);
if xname (1) extract 8 = 'nul' or xname (2) extract 8 = 'nul' then <* ok *>
else
if xname (1) = long <:rc800:> add '0' then
begin <* slet første del af navnet *>
xname (1) := xname (2);
xname (2) := xname (3);
xname (3) := long <::>;
while xname (1) shift (- 40) extract 8 <= '@' do
begin <* skub til venstre *>
xname (1) := xname (1) shift 8 + xname (2) shift (- 40) extract 8;
xname (2) := xname (2) shift 8 + xname (3) shift (- 40) extract 8;
xname (3) := xname (3) shift 8;
end skub;
end slet første del;
xname (2) := xname (2) shift (- 8) shift 8; <* slut med <nul> *>
tofrom (name, xname, 8);
end procedure xhost;
end;
if ok.yes
if warning.yes
(o c
message algol procedure fejl xhost
finis)
\f
if listing.yes
head iso
xsearchproc = algol blocks.yes bossline.no ix.no xref.yes index.yes
xsearchproc
external
boolean procedure xsearchproc (z, typ, base, perm, navn, ia);
value perm;
integer perm, typ;
zone z;
integer array base, ia;
long array navn;
begin
<**************************************************************************
proceduren søger efter filer i cataloget, til hvilket z er åbnet,
search returnerer true hvis den har fundet en entry, der opfylder
base og perm-kravet, ellers returneres false.
procedurekald :
typ ::= 0 shift 0 => forfra
1 shift 0 => fortsæt
0 shift 1 => perm skal matche
1 shift 1 => perm altid ok
0 shift 2 => filens base skal være nøjagtig som base
1 shift 2 => filen skal ligge indenfor base
2 shift 2 => filen skal kunne ses fra base
base ::= nedre/øvre base
perm ::= 0 => temp
1 => special
2 => login
3 => permanent
retur:
typ ::= 1 shift 0 vil være sat hvis der er fundet en entry
0 shift 0 vil være sat hvis ingen entry fundet
base ::= uændret
perm ::= uændret
navn ::= navn på fundet entry
ia ::= head and tail (monitor-76) for fundet entry
searchproc er true hvis entry fundet, ellers false
*************************************************************************>
own integer blok, entry_ref, res, gl_perm;
own long gl_navn1, gl_navn2, gl_base;
boolean fundet;
integer array field entry;
long field lf1, lf2;
long array field laf;
lf1 := 4; lf2 := 6; laf := 6;
if typ extract 1 = 0 then
begin <* forfra *>
gl_perm := perm;
gl_navn1 := gl_navn2 := gl_base := 0;
blok := 0;
entry_ref :=- 34;
end forfra;
fundet := false;
setposition (z, 0, blok);
res := inrec6 (z, 0);
inrec6 (z, res);
entry := entry_ref;
if typ extract 1 = 1 then
begin
if z.entry (1) = - 1
or z.entry.lf2 <> gl_base
or z.entry (1) extract 3 <> gl_perm
or z.entry.laf (1) <> gl_navn1
or z.entry.laf (2) <> gl_navn2 then
begin <* gal indgang *>
while (if entry > 476 then false else
z.entry (1) = - 1
or z.entry.lf2 <> gl_base
or z.entry (1) extract 3 <> gl_perm
or z.entry.laf (1) <> gl_navn1
or z.entry.laf (2) <> gl_navn2)
do entry := entry + 34;
if entry > 476 then entry := - 34;
end;
end typ <> 0;
repeat
entry := entry + 34;
if entry > 476 then
begin
blok := blok + 1;
entry := 0;
res := inrec6 (z, 0);
inrec6 (z, res);
end ny blok;
if res < 34 then <* slut *> else
if z.entry (1) = - 1 then <* tom *> else
if z.entry (1) extract 3 <> perm and typ shift (- 1) extract 1 = 0
then <* perm skal matche og det gør den ikke *>
else
if (case typ shift (- 2) extract 2 + 1 of (
<* 0<2 = filbaser matcher med base *>
(extend z.entry (2) = extend base (1)
and extend z.entry (3) = extend base (2)),
<* 1<2 = filbaser indenfor base *>
(extend z.entry (2) >= extend base (1)
and extend z.entry (3) <= extend base (2)),
<* 2<2 = filbaser ses fra base *>
(extend z.entry (3) >= extend base (1)
and extend z.entry (2) <= extend base (2))
))
then fundet := true;
until fundet or res < 34;
entry_ref := entry;
if fundet then
begin
typ := typ shift (- 1) shift 1 + 1;
xsearchproc := true;
tofrom (ia, z.entry, 34);
tofrom (navn, z.entry.laf, 8);
gl_perm := ia (1) extract 3;
gl_navn1 := navn (1);
gl_navn2 := navn (2);
gl_base := z.entry.lf2;
end
else
begin
typ := typ shift (- 1) shift 1;
xsearchproc := false;
gl_perm := 0;
gl_navn1 := gl_navn2 := gl_base := 0;
end;
end procedure xsearchproc;
end;
if ok.yes
if warning.yes
(o c
message algol procedure fejl xsearchproc
finis)
\f
if listing.yes
head iso
xebcdtable = algol blocks.yes bossline.no ix.no xref.yes
xebcdtable
external
procedure xebcdtable (type, alfa);
value type;
integer type;
integer array alfa;
begin
<*******************************************************************************
beskrivelse af proceduren xebcdtable (type, alfa);
<type> ::= 1, 2, 3 eller 4
1 => iso til ebcdic
2 => iso til ebcdic incl. æ, ø og å
konvertering af små bogstaver til store
konvertering af div. tegn så udseendet passer
til rc8000 printere
3 => ebcdic til iso
4 => ebcdic til iso incl. æ, ø og å
konvertering af store bogstaver til små
konvertering af div. tegn så udseendet passer
fra rc8000 til ibm printere
<alfa> ::= integer array startende i index 0
type = 1 => længden >= 128
type = 2 => længden >= 128
type = 3 => længden >= 256
type = 4 => længden >= 256
retur:
alfa assignes med de interne tegn-værdier,
svarende til de, ved type, specificerde tegnsæt.
efter at alfa er assignet som iso til ebcdic, vil
det, i forbindelse med "outtable" direkte være
muligt at skrive ebcdic.
efter at alfa er assignet som ebcdic til iso, vil
det, i forbindelse med "intable" direkte være
muligt at læse ebcdic.
alle ukendte tegn assignes med værdien for "*",
ved ebcdic til iso alfabetet får ukendte tegn
endvidere tilknyttet tegnklasse 6, som omfatter
alle almindelige bogstaver.
alfa assignes fra index 0 til det maximale index.
exempel på skrivning i ebcdic:
------------------------------
integer array alfa (0 : 127);
-
xebcdtable (2, alfa);
outtable (alfa);
comment der er nu indsat et ebcdic-alfabet til skrivning;
-
-
-
outtable (0);
comment der er nu indsat et almindeligt iso-alfabet til skrivning;
-
exempel på læsning af ebcdic:
-----------------------------
integer array alfa (0 : 255);
-
-
xebcdtable (4, alfa);
intable (alfa);
comment der er nu indsat et ebcdic-alfabet til læsning;
-
-
-
intable (0);
comment der er nu indsat et alm. iso-alfabet til læsning;
-
*******************************************************************************>
integer alfa_max, alfa_lgd, i;
if type = 1 or type = 2 then
begin <* iso til ebcdic *>
for i := 0 step 1 until 127 do
alfa (i) := case i + 1 of (
<* 0 - 7 *> 0, 1, 2, 3, 55, 45, 46, 47,
<* 8 - 15 *> 22, 5, 21, 11, 12, 13, 14, 15,
<* 16 - 23 *> 16, 17, 18, 'Ø', 60, 61, 50, 38,
<* 24 - 31 *> 24, 25, 63, 39, 34, 'Ø', 53, 'Ø',
<* 32 - 39 *> 64, 90, 127, 123, 91, 108, 80, 125,
<* ! " # $ % & ' *>
<* 40 - 47 *> 77, 93, 92, 78, 107, 96, 75, 97,
<* ( ) * + , - . / *>
<* 48 - 55 *> 240, 241, 242, 243, 244, 245, 246, 247,
<* 0 1 2 3 4 5 6 7 *>
<* 56 - 63 *> 248, 249, 122, 94, 76, 126, 110, 111,
<* 8 9 : ; < = > ? *>
<* 64 - 71 *> 124, 193, 194, 195, 196, 197, 198, 199,
<* @ A B C D E F G *>
<* 72 - 79 *> 200, 201, 209, 210, 211, 212, 213, 214,
<* H I J K L M N O *>
<* 80 - 87 *> 215, 216, 217, 226, 227, 228, 229, 230,
<* P Q R S T U V W *>
<* 88 - 95 *> 231, 232, 233, 'Ø', 224, 'Ø', 95, 109,
<* X Y Z * * * ^ _ *>
<* 96 - 103 *> 121, 129, 130, 131, 132, 133, 134, 135,
<* ` a b c d e f g *>
<* 104 - 111 *> 136, 137, 145, 146, 147, 148, 149, 150,
<* h i j k l m n o *>
<* 112 - 119 *> 151, 152, 153, 162, 163, 164, 165, 166,
<* p q r s t u v w *>
<* 120 - 127 *> 167, 168, 169, 192, 106, 208, 161, 7,
<* x y z * * * ü *>
0 );
end iso / ebcdic
else
if type = 3 or type = 4 then
begin <* ebcdic til iso *>
for i := 0 step 1 until 255 do
alfa (i) := ( case i + 1 of (
<* 0 - 7 *> 0, 7, 7, 7, 6, 7, 6, 0,
<* 8 - 15 *> 6, 6, 6, 7, 8, 0, 7, 7,
<* 16 - 23 *> 7, 7, 7, 6, 6, 8, 7, 6,
<* 24 - 31 *> 7, 8, 6, 6, 6, 6, 6, 6,
<* 32 - 39 *> 6, 6, 7, 6, 6, 6, 7, 7,
<* 40 - 47 *> 6, 6, 6, 6, 6, 7, 7, 7,
<* 48 - 55 *> 6, 6, 7, 6, 6, 7, 6, 7,
<* 56 - 63 *> 6, 6, 6, 6, 7, 7, 6, 7,
<* 64 - 71 *> 7, 6, 6, 6, 6, 6, 6, 6,
<* 72 - 79 *> 6, 6, 6, 4, 7, 7, 3, 6,
<* 80 - 87 *> 7, 6, 6, 6, 7, 6, 6, 6,
<* 88 - 95 *> 6, 6, 7, 7, 7, 7, 7, 7,
<* 96 - 103 *> 3, 7, 6, 6, 6, 6, 6, 6,
<* 104 - 111 *> 6, 6, 7, 7, 7, 7, 7, 7,
<* 112 - 119 *> 6, 6, 6, 6, 6, 6, 6, 6,
<* 120 - 127 *> 6, 7, 7, 7, 6, 5, 7, 7,
<* 128 - 135 *> 6, 6, 6, 6, 6, 6, 6, 6,
<* 136 - 143 *> 6, 6, 6, 6, 6, 6, 6, 6,
<* 144 - 151 *> 6, 6, 6, 6, 6, 6, 6, 6,
<* 152 - 159 *> 6, 6, 6, 6, 6, 6, 6, 6,
<* 160 - 167 *> 6, 7, 6, 6, 6, 6, 6, 6,
<* 168 - 175 *> 6, 6, 6, 6, 6, 6, 6, 6,
<* 176 - 183 *> 6, 6, 6, 6, 6, 6, 6, 6,
<* 184 - 191 *> 6, 6, 6, 6, 6, 6, 6, 6,
<* 192 - 199 *> 7, 6, 6, 6, 6, 6, 6, 6,
<* 200 - 207 *> 6, 6, 6, 6, 6, 6, 6, 6,
<* 208 - 215 *> 7, 6, 6, 6, 6, 6, 6, 6,
<* 216 - 223 *> 6, 6, 6, 6, 6, 6, 6, 6,
<* 224 - 231 *> 7, 6, 6, 6, 6, 6, 6, 6,
<* 232 - 239 *> 6, 6, 6, 6, 6, 6, 6, 6,
<* 240 - 247 *> 2, 2, 2, 2, 2, 2, 2, 2,
<* 248 - 255 *> 2, 2, 6, 6, 6, 6, 6, 6,
0 ) ) shift 12 + ( case i + 1 of (
<* 0 - 7 *> 0, 1, 2, 3, '*', 9, '*', 127,
<* 8 - 15 *> '*', '*', '*', 11, 12, 13, 14, 15,
<* 16 - 23 *> 16, 17, 18, '*', '*', 10, 8, '*',
<* 24 - 31 *> 24, 25, '*', '*', '*', '*', '*', '*',
<* 32 - 39 *> '*', '*', 28, '*', '*', '*', 23, 27,
<* 40 - 47 *> '*', '*', '*', '*', '*', 5, 6, 7,
<* 48 - 55 *> '*', '*', 22, '*', '*', 30, '*', 4,
<* 56 - 63 *> '*', '*', '*', '*', 20, 21, '*', 26,
<* 64 - 71 *> 32, '*', '*', '*', '*', '*', '*', '*',
<* * * * * * * * *>
<* 72 - 79 *> '*', '*', '*', 46, 60, 40, 43, '*',
<* * * * . < ( + * *>
<* 80 - 87 *> 38, '*', '*', '*', '*', '*', '*', '*',
<* & * * * * * * * *>
<* 88 - 95 *> '*', '*', 33, 36, 42, 41, 59, 94,
<* * * ! * * ) ; * *>
<* 96 - 103 *> 45, 47, '*', '*', '*', '*', '*', '*',
<* - / * * * * * * *>
<* 104 - 111 *> '*', '*', 124, 44, 37, 95, 62, 63,
<* * * * , % _ > ? *>
<* 112 - 119 *> '*', '*', '*', '*', '*', '*', '*', '*',
<* * * * * * * * * *>
<* 120 - 127 *> '*', 96, 58, 35, 64, 39, 61, 34,
<* * ` : # @ ' = " *>
<* 128 - 135 *> '*', 97, 98, 99, 100, 101, 102, 103,
<* * a b c d e f g *>
<* 136 - 143 *> 104, 105, '*', '*', '*', '*', '*', '*',
<* h i * * * * * * *>
<* 144 - 151 *> '*', 106, 107, 108, 109, 110, 111, 112,
<* * j k l m n o p *>
<* 152 - 159 *> 113, 114, '*', '*', '*', '*', '*', '*',
<* q r * * * * * * *>
<* 160 - 167 *> '*', 126, 115, 116, 117, 118, 119, 120,
<* * ü s t u v w x *>
<* 168 - 175 *> 121, 122, '*', '*', '*', '*', '*', '*',
<* y z * * * * * * *>
<* 176 - 183 *> '*', '*', '*', '*', '*', '*', '*', '*',
<* * * * * * * * * *>
<* 184 - 191 *> '*', '*', '*', '*', '*', '*', '*', '*',
<* * * * * * * * * *>
<* 192 - 199 *> 123, 65, 66, 67, 68, 69, 70, 71,
<* * A B C D E F G *>
<* 200 - 207 *> 72, 73, '*', '*', '*', '*', '*', '*',
<* H I * * * * * * *>
<* 208 - 215 *> 125, 74, 75, 76, 77, 78, 79, 80,
<* * J K L M N O P *>
<* 216 - 223 *> 81, 82, '*', '*', '*', '*', '*', '*',
<* Q R * * * * * * *>
<* 224 - 231 *> 92, '*', 83, 84, 85, 86, 87, 88,
<* * * S T U V W X *>
<* 232 - 239 *> 89, 90, '*', '*', '*', '*', '*', '*',
<* Y Z * * * * * * *>
<* 240 - 247 *> 48, 49, 50, 51, 52, 53, 54, 55,
<* 0 1 2 3 4 5 6 7 *>
<* 248 - 255 *> 56, 57, '*', '*', '*', '*', '*', '*',
<* 8 9 * * * * * * *>
0 ) );
end ebcdic / iso
else system (9, type, <:<10>***type:>);
case type of
begin
; <* iso til ebcdic *>
begin <* iso til ebcdic modificeret *>
alfa (91) := alfa (123) := 123;
alfa (92) := alfa (124) := 124;
alfa (93) := alfa (125) := 91;
for i := 97 step 1 until 122 do alfa (i) := alfa (i - 32);
end;
; <* ebcdic til iso *>
begin <* ebcdic til iso modificeret *>
alfa (123) := 6 shift 12 + 123;
alfa (124) := 6 shift 12 + 124;
alfa (91) := 6 shift 12 + 125;
alfa (106) := alfa (192) := alfa (208) := alfa (224) := 6 shift 12 + '*';
for i := 193 step 1 until 201,
209 step 1 until 217,
226 step 1 until 233 do alfa (i) := alfa (i - 64);
end;
end case;
alfa_lgd := case type of (128, 128, 256, 256);
system (3, alfa_max, alfa);
for i := alfa_lgd step 1 until alfa_max do alfa (i) := alfa (i - alfa_lgd);
end procedure xebcdtable;
end;
if ok.yes
if warning.yes
(o c
message algol procedure fejl xebcdtable
finis)
\f
if listing.yes
head iso
xwriteall = algol blocks.yes bossline.no ix.no xref.yes
xwriteall
external
procedure xwriteall (z, ra, lgd, type);
value lgd, type;
integer lgd;
long type;
zone z;
real array ra;
begin
<*
proceduren skriver indholdet af ra på zonen z på følgende former:
type = 1 => real
type = 10 => long
type = 100 => integer
type = 1000 => half
type = 10000 => char
type = 100000 => bits
type = 1000000 => iso
type = 10000000 => ebcdic
type = 0 => alle
samt diverse kombinationer af ovenstående.
hvis lgd > 0 udskrives ra fra field 2 til field lgd ellers udskrives hele ra
*>
integer field ref;
integer array field iaf0;
integer fra, til, ord_pr_lin, lin_lgd, rest_plads, i;
boolean typ;
integer array ebcd (0 : 255);
rest_plads := lin_lgd := ord_pr_lin := 0;
iaf0 := 0;
ref := 0;
typ := type = 0;
for i := 0 step 1 until 7 do
typ := if round (type / 10 ** i) mod 10 <> 1 then typ
else typ or false add (1 shift i);
for i := 0 step 1 until 7 do
lin_lgd := if -, typ shift (- i) then lin_lgd else
lin_lgd + (case i + 1 of (20, 20, 10, 10, 12, 25, 4, 4));
ord_pr_lin := (114 - 8) // lin_lgd;
if ord_pr_lin > 1 then ord_pr_lin := ord_pr_lin // 2 * 2;
if typ shift (- 7) then
begin
xebcdtable (3, ebcd);
for i := 0 step 1 until 255 do ebcd (i) := ebcd (i) extract 12;
end;
til := (lgd + 1) // 2;
fra := if til > 0 then 1 else system (3, til, ra.iaf0);
fra := fra * 2;
til := til * 2;
for ref := fra step 2 until til do
begin
integer array tegn (1 : 3);
if rest_plads <= 0 then
begin <* linieskift *>
integer t;
t := write (z, "nl", 1, <<ddd>, ref - 1, ":", 1, <<d>,
if ref - 2 + ord_pr_lin * 2 <= til
then ref - 2 + ord_pr_lin * 2 else til);
write (z, "sp", 8 - t, ":", 1);
rest_plads := ord_pr_lin;
end linieskift;
if typ shift (- 4) extract 8 > 0 then
begin
tegn (1) := ra.ref shift (- 16) extract 8;
tegn (2) := ra.ref shift (- 8) extract 8;
tegn (3) := ra.ref extract 8;
end;
if typ shift (- 0) then
<* real *> begin
integer t;
real field rf;
rf := ref;
if rf - 2 >= fra then t := write (z, ra.rf) else t := 0;
write (z, "sp", 10 - t);
end real;
if typ shift (- 1) then
<* long *> begin
integer t;
long field lf;
lf := ref;
if lf - 2 >= fra then t := write (z, ra.lf) else t := 0;
write (z, "sp", 20 - t);
end long;
if typ shift (- 2) then
<* integer *> write (z, <<-ddddddddd>, ra.ref);
if typ shift (- 3) then
<* half *> write (z, <<-dddd>, ra.ref shift (- 12), ra.ref extract 12);
if typ shift (- 4) then
<* char *> write (z, <<-ddd>, tegn (1), tegn (2), tegn (3));
if typ shift (- 5) then
<* bits *> begin
integer bit;
outchar (z, 'sp');
for bit := - 23 step 1 until 0 do
if ra.ref shift bit extract 1 = 1 then outchar (z, '1') else outchar (z, '.');
end bits;
if typ shift (- 6) then
<* iso *> write (z, "sp", 1,
false add (if tegn (1) > 32 and tegn (1) < 127 then tegn (1) else 32), 1,
false add (if tegn (2) > 32 and tegn (2) < 127 then tegn (2) else 32), 1,
false add (if tegn (3) > 32 and tegn (3) < 127 then tegn (3) else 32), 1);
if typ shift (- 7) then
<* ebcdic *> begin
tegn (1) := ebcd (tegn (1));
tegn (2) := ebcd (tegn (2));
tegn (3) := ebcd (tegn (3));
write (z, "sp", 1,
false add (if tegn (1) > 32 and tegn (1) < 127 then tegn (1) else 32), 1,
false add (if tegn (2) > 32 and tegn (2) < 127 then tegn (2) else 32), 1,
false add (if tegn (3) > 32 and tegn (3) < 127 then tegn (3) else 32), 1);
end ebcdic;
rest_plads := rest_plads - 1;
end for ref;
end procedure xwriteall;
end;
if ok.yes
if warning.yes
(o c
message algol procedure fejl xwriteall
finis)
\f
if listing.yes
head iso
xy = algol blocks.yes bossline.no ix.no xref.yes index.yes
xy (index.yes)
external
real procedure xy (x, y);
value x, y;
integer x, y;
begin comment
jsc den 21/1-1983.
beskrivelse af proceduren ---------- xy ----------
proceduren benyttes til positionering på rc822 skærme
proceduren kaldes med x-y koordinaterne, hvor øverste venstre
har koordinaterne 1,1
ex. writeint (z, string xy (40, 10), <<dddd.dd->, beløb);
xy := if y < 1 then real ((extend 29 + 128) shift 32 + extend 13 shift 40) else
real ((extend (6 + 128) shift 16 + 95 shift 8 + 95 +
(x - (x - 1) shift (- 5) shift 6) shift 8 add y) shift 16 +
extend 13 shift 40);
end procedure xy;
end;
if ok.yes
if warning.yes
(o c
message algol procedure fejl xy
finis)
\f
if listing.yes
head iso
xpos = algol blocks.yes bossline.no ix.no xref.yes index.yes
xpos (index.yes)
external
real procedure xpos (term, col, lin);
value col, lin;
integer term, col, lin;
begin comment
jsc den 21/12-1988.
beskrivelse af proceduren ---------- xpos ----------
proceduren benyttes til positionering på diverse terminaler
term betegner terminaltypen
udskriftszonen skal lade alt gå transparent igennem (fx mode 1024)
fx. 851=rc851, 822=rc822, 3=adm3, 52=vt52, 100=vt100, 220=vt220
proceduren kaldes med col-lin koordinaterne, hvor øverste venstre
har koordinaterne 1,1
ex. writeint (z, string xpos (z, 100, 40, 10), <<dddd.dd->, beløb);
own integer status, glterm;
if term <> glterm and status <> 0 then term := status := 0;
if col < 1 or col > 80 then col := 1;
if lin < 1 or lin > 25 then lin := 1;
if term = 100
or term = 200
or term = 220 then
begin <* vt100 / vt200 / vt220 *>
case status + 1 of
begin
begin
xpos := real (extend 'esc' shift 40
+ extend 'Æ' shift 32
+ extend (lin // 10 mod 10 + '0') shift 24
+ (lin mod 10 + '0') shift 16
+ ';' shift 8
+ (col // 10 mod 10 + '0'));
status := 1;
end;
begin
xpos := real (extend (col mod 10 + '0') shift 40
+ extend 'H' shift 32);
status := 0;
end;
end case;
end vt100/200/220
else
if term = 822
or term = 851 then
begin <* rc822 / rc851 *>
xpos := real (extend (6 shift 16 + 95 shift 8 + 95
+ (col - (col - 1) shift (- 5) shift 6) shift 8 add lin) shift 16
+ extend 'cr' shift 40);
end rc822/851
else
if term = 52 then
begin <* vt52 *>
xpos := real (extend 'esc' shift 40
+ extend 'Y' shift 32
+ extend (lin + 32) shift 24
+ (col + 31) shift 16);
end vt52
else
if term = 3 then
begin <* adm3 *>
xpos := real (extend 'esc' shift 40
+ extend '=' shift 32
+ extend (lin + 32) shift 24
+ (col + 31) shift 16);
end adm3
else xpos := real <::>;
glterm := term;
end procedure xpos;
end;
if ok.yes
if warning.yes
(o c
message algol procedure fejl xpos
finis)
\f
if listing.yes
head iso
xhome = algol blocks.yes bossline.no ix.no xref.yes index.yes
xhome (index.yes)
external
real procedure xhome (term);
integer term;
begin comment
positionerer i øverste venstre hjørne;
xhome := real (
if term = 822 or term = 851 then <:<29>:>
else
if term = 100
or term = 200
or term = 220 then <:<27>Æ;H:>
else
if term = 52 then <:<27>H:>
else
if term = 3 then <:<31>:>
else <::>);
end procedure xhome;
end;
if ok.yes
if warning.yes
(o c
message algol procedure fejl xhome
finis)
\f
if listing.yes
head iso
xclreol = algol blocks.yes bossline.no ix.no xref.yes index.yes
xclreol (index.yes)
external
real procedure xclreol (term);
integer term;
begin comment
clear to end of line;
xclreol := real (
if term = 822 or term = 851 then <:<30>:>
else
if term = 100
or term = 200
or term = 220 then <:<27>Æ0K:>
else
if term = 52 then <:<27>K:>
else
if term = 3 then <:?:>
else <::>);
end procedure xclreol;
end;
if ok.yes
if warning.yes
(o c
message algol procedure fejl xclreol
finis)
\f
if listing.yes
head iso
xclreos = algol blocks.yes bossline.no ix.no xref.yes index.yes
xclreos (index.yes)
external
real procedure xclreos (term);
integer term;
begin comment
clear to end of screen;
xclreos := real (
if term = 822 or term = 851 then <:<31>:>
else
if term = 100
or term = 200
or term = 220 then <:<27>ÆJ:>
else
if term = 52 then <:<27>J:>
else
if term = 3 then <:?:>
else <::>);
end procedure xclreos;
end;
if ok.yes
if warning.yes
(o c
message algol procedure fejl xclreos
finis)
\f
if listing.yes
head iso
xclrhom = algol blocks.yes bossline.no ix.no xref.yes index.yes
xclrhom (index.yes)
external
real procedure xclrhom (term);
integer term;
begin comment
home og clear to end of screen;
own integer status, glterm;
if term <> glterm and status <> 0 then term := status := 0;
if term = 822 or term = 851 then xclrhom := real <:<29><31>:>
else
if term = 100
or term = 200
or term = 220 then
begin <* vt100 / vt200 / vt220 *>
case status + 1 of
begin
begin
xclrhom := real <:<27>Æ;H<27>:> add 'Æ';
status := 1;
end;
begin
xclrhom := real <:0J:>;
status := 0;
end;
end case;
end vt100/200/220
else
if term = 52 then xclrhom := real <:<27>H<27>J:>
else
if term = 3 then xclrhom := real <:?:>
else xclrhom := real <::>;
glterm := term;
end procedure xclrhom;
end;
if ok.yes
if warning.yes
(o c
message algol procedure fejl xclrhom
finis)
\f
if listing.yes
head iso
xtrace = algol blocks.yes bossline.no ix.no xref.yes
xtrace
external
procedure trace (la);
long array la;
begin
integer i;
trap (ud);
i := 1;
if la (1) = long <::>
then system (9, xkl, <:<10>trace:>)
else system (9, xkl, string la (increase (i)));
ud:
end procedure trace;
end;
if ok.yes
if warning.yes
(o c
message algol procedure fejl xtrace
finis)
\f
if listing.yes
head iso
xtextlgd = algol blocks.yes bossline.no ix.no xref.yes
xtextlgd
external
integer procedure textlgd (la);
long array la;
begin
<* returnerer antal tegn i texten *>
integer i, c, max;
system (3, max, la);
max := max * 6;
i := 0;
repeat
c := la (i // 6 + 1) shift (i mod 6 * 8 - 40) extract 8;
if c <> 'nul' then i := i + 1;
until c = 'nul' or i = max;
textlgd := i;
end procedure textlgd;
end;
if ok.yes
if warning.yes
(o c
message algol procedure fejl xtextlgd
finis)
\f
if listing.yes
head iso
xnameok = algol blocks.yes bossline.no ix.no xref.yes index.yes
xnameok (index.yes)
external
boolean procedure xnameok (name, maske);
long array name, maske;
begin
<* true hvis name=maske, "*" og "?" kan benyttes på cpm vis
tom maske medfører altid ok,
max 12 tegn
*>
integer i, j, k, c1, c2;
boolean ok;
ok := true;
i := 0;
if maske (1) <> long <::> and maske (1) <> long <:*:> then
repeat
if i = 0 or c1 <> 'nul' then
c1 := name (i // 6 + 1) shift (i mod 6 * 8 - 40) extract 8;
c2 := maske (i // 6 + 1) shift (i mod 6 * 8 - 40) extract 8;
ok := c1 = c2 or c2 = '?' or c2 = '*';
i := i + 1;
until i = 12 or not ok or c2 = '*';
xnameok := ok;
end procedure xnameok;
end;
if ok.yes
if warning.yes
(o c
message algol procedure fejl xnameok
finis)
\f
if listing.yes
head iso
xdiscok = algol blocks.yes bossline.no ix.no xref.yes index.yes
xdiscok (index.yes)
external
boolean procedure xdiscok (disc, maske);
long array disc, maske;
begin
<* true hvis disc=maske, tom maske medfører altid ok *>
boolean ok;
if maske (1) shift (- 40) = 'nul' then ok := true
else
if disc (1) = maske (1)
and (disc (2) = maske (2) or maske (1) extract 8 = 'nul')
then ok := true
else ok := false;
xdiscok := ok;
end procedure xdiscok;
end;
if ok.yes
if warning.yes
(o c
message algol procedure fejl xdiscok
finis)
\f
if listing.yes
head iso
xclaim = algol blocks.yes bossline.no ix.no xref.yes index.yes
xclaim (index.yes)
external
procedure xclaim (hw);
integer hw;
begin
<* jsc den 22/2-1989
reserverer "hw" halvord i stakken
*>
integer array i (1 : (hw + 1) // 2);
end;
end;
\f
oclaim = algol blocks.yes bossline.no ix.no xref.yes connect.no
oclaim
begin <* kildetexten til oclaim *>
<**************************************************************************
jsc den 1/6-1987
Beskrivelse af programmet -----oclaim-----
Claim program for Rc8000.
Programkald:
oclaim (<process>)
process ::= navnet på processen hvis ressourcer skal udskrives,
hvis udeladt tages os selv.
**************************************************************************>
long array procname (1 : 2);
zone z (1, 1, stderror);
integer bsdevices, firstbs, procadr, bsno, i, j;
boolean ownprocess;
integer array core, internal (1 : 18), ia (1 : 20);
long array field laf0, laf2, name;
real array field raf0;
procedure fejl (text);
string text;
begin
write (out, "*", 3, "sp", 1, text, "nl", 1);
errorbits := 1 shift 0 + 1 shift 1;
goto kikset;
end procedure fejl;
laf0 := raf0 := 0;
laf2 := 2;
name := 18;
ownprocess := false;
i := system (4, 1, procname);
if i = 0 then
begin <* own process *>
ownprocess := true;
procadr := system (6, 0, procname);
end
else
if i = 4 shift 12 + 10 then
begin <* specificeret process *>
open (z, 0, procname, 0);
close (z, true);
procadr := monitor (4, z, 0, ia);
getzone6 (z, ia);
tofrom (procname, ia.laf2, 8);
end
else fejl (<:Parameter error:>);
if procadr = 0 then fejl (<:Process does not exist:>);
system (5, 92, core); <* get first bs mv. *>
bsdevices := (core (3) - core (1)) // 2; <* top chain - first chain *>
firstbs := core (1);
begin <* extra niveau *>
integer array nametable (1 : bsdevices);
system (5, firstbs, nametable); <* get chaintable for bsdevices *>
system (5, procadr, internal); <* get part of processdescr *>
write (out, <<-d>,
<:Claims for :>, internal.laf2,
<: Size:>, internal (13) - internal (12),
<: Bufs:>, internal (14) shift (- 12) + (if ownprocess then 1 else 0),
<: Areas:>, internal (14) extract 12 + (if ownprocess then 1 else 0),
<: Internals:>, internal (15) shift (- 12),
<: Prio:>, internal (16),
"nl", 1, "-", 72, "nl", 1,
<:Discname Slice ---Temp--- ---Login--- ---Perm---:>);
for bsno := 1 step 1 until bsdevices do
begin <* gennemløb alle discs *>
system (5, nametable (bsno) - 36, core); <* get part of chaintable *>
system (5, procadr + core (1), internal); <* get part of internal *>
if core.name (1) shift (- 40) <> 'nul' then
begin <* ikke tom *>
write (out, "nl", 1,
true, 12, core.name,
<<-ddddddd>, core (15));
for i := 0, 2, 3 do <* permkey *>
write (out,
<<-dddddd>, internal (i * 2 + 2) * core (15), <* segments *>
<<-dddd>, internal (i * 2 + 1)); <* entries *>
end ej tom;
end for bsno;
write (out, "nl", 1, "-", 72, "nl", 1);
end extra;
kikset:
trapmode := 1 shift 10; <* drop end <segm> *>
end;
if ok.yes
if warning.yes
(o c
message algol program fejl oclaim
finis)
\f
if listing.yes
head iso
jsclib = compresslib ,
xnulstil , (xnulfratil er allerede libbet til xnulstil)
xkl ,
xhex ,
xbin ,
xstatustxt ,
xwritealarm ,
xstderror ,
xtrapbreak ,
xnametable ,
xmaxbuflgd ,
xdumpzone ,
xinitinput ,
xinput ,
xwaitinput ,
xinitoutput ,
xsetoutput ,
xoutput ,
xwaitoutput ,
xcopyzone ,
xconnectout ,
xsortsq ,
xclaimproc ,
xbsclaim ,
xopencreate ,
xopencrsq ,
xprimostate ,
xprimosend ,
xhost ,
xsearchproc ,
xebcdtable ,
xwriteall ,
xy ,
xpos ,
xhome ,
xclreol ,
xclreos ,
xclrhom ,
xtrace ,
xtextlgd ,
xnameok ,
xdiscok ,
xclaim ,
if ok.no
c=message kikset ved compresslib
scope user.disc1 ,
jsclib ,
xnulstil ,
xnulfratil ,
xkl ,
xhex ,
xbin ,
xstatustxt ,
xwritealarm ,
xstderror ,
xtrapbreak ,
xnametable ,
xmaxbuflgd ,
xdumpzone ,
xinitinput ,
xinput ,
xwaitinput ,
xinitoutput ,
xsetoutput ,
xoutput ,
xwaitoutput ,
xcopyzone ,
xconnectout ,
xsortsq ,
xclaimproc ,
xbsclaim ,
xopencreate ,
xopencrsq ,
xprimostate ,
xprimosend ,
xhost ,
xsearchproc ,
xebcdtable ,
xwriteall ,
xy ,
xpos ,
xhome ,
xclreol ,
xclreos ,
xclrhom ,
xtrace ,
xtextlgd ,
xnameok ,
xdiscok ,
xclaim ,
oclaim ;
if ok.no
c=message kikset ved scope user
lookup ,
jsclib ,
xnulstil ,
xnulfratil ,
xkl ,
xhex ,
xbin ,
xstatustxt ,
xwritealarm ,
xstderror ,
xtrapbreak ,
xnametable ,
xmaxbuflgd ,
xdumpzone ,
xinitinput ,
xinput ,
xwaitinput ,
xinitoutput ,
xsetoutput ,
xoutput ,
xwaitoutput ,
xcopyzone ,
xconnectout ,
xsortsq ,
xclaimproc ,
xbsclaim ,
xopencreate ,
xopencrsq ,
xprimostate ,
xprimosend ,
xhost ,
xsearchproc ,
xebcdtable ,
xwriteall ,
xy ,
xpos ,
xhome ,
xclreol ,
xclreos ,
xclrhom ,
xtrace ,
xtextlgd ,
xnameok ,
xdiscok ,
xclaim ,
oclaim ;
if ok.no
c=message der mangler filer
o c
c=message translation ended
end
finis
▶EOF◀