|
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: 97536 (0x17d00)
Types: TextFile
Names: »tpascallib«
└─⟦00964e8f7⟧ Bits:30007478 RC8000 Dump tape fra HCØ.
└─⟦b2ec5d50f⟧
└─⟦this⟧ »tpascallib«
; pascal library
;
; version 8
; date 79 07 03
;
; the contents is for the time being :
; segmno entries
; 0-1 runtime error
;
; 2 ln
; exp
; sinh
; system
; clock
;
; 3 arcsin
; sqrt
; date
; time
;
; 4 arctan
; arg
; cos
; sin
; monitor
;
; 5-6 file initialization
; reset
; rewrite
; close
; remove
; replace
;
; 7-8 write (text)
; real
; integer
; boolean
; character
; string
; put
;
; 9-10 read (text)
; iso
; get
; char
; integer
; real
;
; 11 read/write (binary)
; pack
; unpack
s. s10 w.
p.<:fpnames:>
; definition of zone states
; (values almost as in algol)
s1 = 1 ; after read char
s3 = 3 ; after write char
s4 = 4 ; after declaration
s5 = 5 ; after read binary
s6 = 6 ; after write binary
s8 = 8 ; after open
\f
; segment 0-1
; the virtual part of runtime error
; call :
; w0 = abs addr of first of procedure table
; w1 = abs addr of interrupt routine
; w2 = abs addr of first of library table
; w3 = abs addr of param-area
;
; the procedure writes out a text indicating a runtime
; error and a line number, then fp-end is called to terminate normally.
;
b. c50, g2 w.
g0: ; start of buffer
jl. g1. ; goto init;
; initcode for pascal-program:
; insert the programname 'pascrun' just before the old program name
b. a10, b10 w.
a0: ; start of initcode
b10 ; size of initcode (number of words)
rl w0 x1+h51 ; move fp-modebits to program stack
rs. w0 b3. ;
la. w0 b0. ; remove fp-modebits: pause and list;
rs w0 x1+h51 ;
al w0 x2+b5 ; current command := current command - simulated;
rs w0 x1+h8 ;
rl. w0 b1. ; insert dummy 'end' in front;
a1: rs w0 x2+b5 ;
rl w0 x2 ; move a possible lefthand side and
al w2 x2+2 ; the delimiter preceding the program name;
sh w2 x3+2 ;
jl. a1. ;
; now there is room for inserting a new program name etc.
al. w3 b2. ; w3 := start of new program name etc.;
a5: rl w0 x3 ;
rs w0 x2+b5 ; move new program name to fp-program stack;
al w2 x2+2 ;
al w3 x3+2 ;
se. w3 b4. ;
jl. a5. ;
al w2 0 ; w2 := normal return to fp;
jl x1+h7 ; goto fp-end-program;
b0: -1 - 1<3 - 1<0 ; mask out: pause + list from modebits
b1: 2<12 + 2 ; dummy 'end'-element;
b2: ; start of new program name etc:
<:pascrun:>, 0 ;
4<12 + 10 ;
0 ;
b3: 0-0-0 ; (old fp-mode bits)
0 ;
0 ;
4<12 + 10 ;
b4: ; top of new program name etc:
b5 = b2 - b4 - 2 ; size of inserted elements (negative)
b10 = (:k - a0:) > 1 ; number of words in init-code
e. ;
\f
g2: ; start of text-table:
h.
c0., c1., c2., c3., c4., c5., c6., c7., c8., c9.,
c10.,c11.,c12.,c13.,c14.,c15.,c16.,c17.,c18.,c19.,
c20.,c21.,c22.,c23.,c24.,c25.
w.
c0:<:end<0>:>
c1:<:process too small<0>:>
c2:<:index or subrange out of bounds, value is: <0>:>
c3:<:wrong answer on input request<0>:>
c4:<:wrong no of halfwords transferred<0>:>
c5:<:break<0>:>
c6:<:giveup, blocklength = <0>:>
c7:<:negative field width<0>:>
c8:<:replace file not ok<0>:>
c9:<::>
c10:<:negative argument to ln or sqrt<0>:>
c11:<:illegal argument to exp or sinh<0>:>
c12:<:illegal argument to arcsin<0>:>
c13: <:illegal zonestate<0>:>
c14:<:eof trouble<0>:>
c15:<:file cannot be connected for i/o<0>:>
c16:<:file cannot be removed<0>:>
c17:<:file desc. cannot be changed<0>:>
c18:<:file does not exist<0>:>
c19:<:file cannot be looked up<0>:>
c20:<:b,o or h expected<0>:>
c21:<:digit expected<0>:>
c22:<:try to read past eof<0>:>
c23:<:integer overflow<0>:>
c24:<:illegal pointer value<0>:>
c25:<:dispose outside used area<0>:>
0, r. (:(:k+511:)>9<9-k:)>1 + 1 ; fill up to whole segment
b. a20, b30, d50, f10, m99, p10 w.
; d-names and f-names are relative to call in resident code
d38 = 0 ; error number
d39 = 2 ; stackref when error occured
d40 = 4 ; abs returnaddr where error occured
d41 = 6 ; return point: abs proc table entry
d42 = 8 ; rel return addr
d43 = 10 ; current pascal procedure
f9 = 12 ; enter fp-break
f0 = 14 ; transfer from program file
d44 = 16 ; blocksread
d45 = 18 ; abs return address of last library call
; description of procedure table entry
p0 = 0 ; segment number in program file
p2 = 2 ; top of proc
p4 = 4 ; size of stack-space
p6 = 6 ; first of proc
p8 = 8 ; virtual addr of first error line
b0: 0 ; abs start of procedure table
b1: 0 ; abs addr of interrupt routine
b2: 0 ; abs start of library table
b3: 0 ; rs-param address
b5: ; abs addresses in fp
m30: h30 ; unstack zone
m31: h31-2 ; outtext
m32: h32-2 ; outinteger
m26: h26-2 ; outchar
m7: h7 -2 ; end-program
m66: h66+2 ; bytes transferred in fp-answer
m68: h68 ; fp-stderror
b6: ; (end of table)
b9: <:<10>blocksread = <0>:>
b10: <:<10>occured in <0>:>
b11: <:<10>called from <0>:>
b12: 0-0-0 ; abs line number
b13: <: = line <0>:>
b14: 0-0-0 ; rel line number
b15: <: of <0>:>
b16: 0, r.4, 0 ; procedure name (terminated with zero)
b17: <: :> ; (three spaces, to convert capital to small letters)
b18: <: rel of segm <0>:>
b20: -1 -1<23 ; max level (initially: max)
b21: 0 ; current level (initially: zero)
b22: 0-0-0 ; procedure table entry
b23: 0-0-0 ; rel proc addr
b24: 0-0-0 ; cur virt error table addr
b25: 0 ; index-value (initially zero)
b26: 0-0-0 ; stackref
b27: <: of library<0>:>
b28: <: of program<0>:>
; procedure get stack item
;
; call: w0 = wanted item no
; w3 = return
;
; exit: w0 = actual item no
; w1 = point: proc table entry
; w2 = rel proc return
; w3 = stackref
b. i10, j10 w.
j0: 0 ; saved return
j1: 0 ; wanted item no
m0: ;
ds. w0 j1. ; save (return, wanted item no);
al w0 0 ; actual item no := 0;
rl. w3 b3. ;
dl w2 x3+d42 ; w1w2 := return point where error occured;
rl w3 x3+d39 ; w3 := stackref when error occured;
i1: ; rep:
se. w0 (j1.) ; if act item no = wanted item no
sh w2 -1 ; or rel return addr < 0 then
jl. (j0.) ; return;
sl. w1 (b2.) ; if proc table entry >= first library entry then
jl. i3. ; goto after library call;
dl w2 x3-2041 ; w1w2 := returnpoint (stackref);
rx w1 4 ;
rl w3 x3-2037 ; w3 := dynamic link (stackref);
i2: ; next:
ba. w0 1 ; increase (act item no);
jl. i1. ; goto rep;
i3: ; after library call:
rl. w1 b3. ;
rl w2 x1+d45 ; w2 := rel return from last library call;
rl w1 x1+d43 ; w1 := current pascal procedure;
ws w2 x1+p6 ;
jl. i2. ; goto next;
e. ;
; procedure get next virt
;
; call: w3 = return
;
; exit: w0 = word
; w2 = unchanged
b. i10, j10 w.
j0: -1 ; current segment (initially: undef)
j1: 0 ; saved w2
j2: 0 ; return
j3: 0 ; rel linebuffer
m1: ;
ds. w3 j2. ; save (w2, return);
rl. w1 b24. ;
al w1 x1+2 ; increase (cur virt addr);
rs. w1 b24. ;
al w0 x1-2 ; segment := previous virt
ld w1 -9 ; divided by 512;
ls w1 -24+9 ; rel linebuffer := previous virt
rs. w1 j3. ; mod 512;
sn. w0 (j0.) ; if segment <> current segment then
jl. i1. ; begin
rs. w0 j0. ; current segment := segment;
rl. w2 b3. ;
jl w2 x2+f0 ; transfer from program file;
jl. a8. ;+2: ioerror: goto write absolute;
i1: ; end;
rl. w1 j3. ;
rl. w0 x1+g0. ; w0 := linebuffer (rel linebuffer);
dl. w3 j2. ; restore (w2, return);
jl x3 ; return;
e. ;
g1: ; init:
ds. w1 b1. ; save (abs proc table start, interrupt address);
ds. w3 b3. ; save (abs lib table start, rs-param addr);
rl w2 66 ;
rl w2 x2+22 ; w2 := first of process;
al. w1 b5. ; w1 := first of fp-entry table
a0: ; rep:
rl w0 x1 ;
wa w0 4 ; convert whole table to abs addresses;
rs w0 x1 ;
al w1 x1+2 ;
se. w1 b6. ; if not whole table converted then
jl. a0. ; goto rep;
; unstack the whole chain for output-zone
al w1 x2+h21 ; w1 := addr of 'output';
al w2 x2+h55+30 ; w2 := addr of 'output' chain;
al. w3 2 ; w3 := return to here...
rl w0 x2 ; rep:
se w0 0 ; while stackchain <> 0 do
jl. (m30.) ; unstack (output, output chain);
rl. w0 m68. ; primary output.error action := fp-stderror;
rs w0 x1+h2+2 ;
al w2 10 ;
jl. w3 (m26.) ; outchar (newline);
rl. w2 b3. ;
rl w1 x2+d38 ; w1 := error number;
se w1 5 ; if error number = break then
jl. a2. ; begin
rl. w3 b1. ; w3 := interrupt address;
rl w1 x3+10 ; w1 := break-address;
rl w0 x1-2 ; w0 := erroneous instruction;
se w0 0 ; if all zero then
jl. a11. ; begin <* io-errors are trapped as such *>
rl. w0 (m66.) ; value := bytes transferred in fp-answer;
al w1 6 ; error number := io-error;
jl. a12. ; goto set value and error;
a11: ; end;
ls w0 -18 ; w0 := instruction code (break-instruction);
se w0 30 ; if instruction = 'instr 30' then
jl. a2. ; begin
bz w0 x1-2 ;
ls w0 12+6 ;
ls w0 -12-6-4 ; w0 := w-field of instruction;
ls w0 1 ;
wa w3 0 ;
rl w0 x3 ; value := regdump (w-field);
al w1 2 ; w1 := error number := index-error;
a12: ; set value and error:
rs. w0 b25. ;
rs w1 x2+d38 ;
a2: ; end;
; end;
al. w0 g2. ;
wa w0 x2+d38 ; w0 := error table address (error number);
ba w0 (0) ; w0 := abs addresses of error text;
jl. w3 (m31.) ; outtext (error text);
rl w0 x2+d38 ;
sn w0 0 ; if error number = 0 <* i.e. normal end *> then
jl. a10. ; goto terminate;
sn w0 6 ; if error number = io-error then
al w0 2 ; error number := 2; <* force printing *>
se w0 2 ; if error number = 2 <* index error *> then
jl. a3. ;
rl. w0 b25. ;
jl. w3 (m32.) ; outinteger (value);
1<23 + 32<12 + 1;
a3: ;
rl. w0 b20. ;
jl. w3 m0. ; max level := get stack item (maximum);
rs. w0 b20. ;
a1: ; unwind:
rl. w0 b21. ;
sn. w0 (b20.) ; if cur level = max level then
jl. a10. ; goto terminate;
jl. w3 m0. ; get stack item (cur level);
ba. w0 1 ;
rs. w0 b21. ; increase (cur level);
sh. w1 0 ; if proc table entry is rel then
wa. w1 b0. ; make proc table entry abs;
ds. w2 b23. ; save (point);
rl w2 x1+p8 ; current virt error addr :=
rs. w2 b24. ; virt error addr (proc table entry);
rs. w3 b26. ; save (stackref);
sn w0 1 ; text := if firstline then
am b10-b11; <:occured in :> else
al. w0 b11. ; <:called from :>;
jl. w3 (m31.) ; outtext (text);
rl. w0 b22. ; if called from library then
sl. w0 (b2.) ;
jl. a8. ; goto write absolute;
jl. w3 m1. ; firstline := get virt;
rs. w0 b12. ;
al. w2 b16. ;
a5: jl. w3 m1. ; procname := 4 * get virt;
lo. w0 b17. ; (converted to small letters)
rs w0 x2 ;
al w2 x2+2 ;
se. w2 b16.+8 ;
jl. a5. ;
rl. w2 b12. ; line := firstline;
a6: ; rep:
al w2 x2+1 ; increase (line);
jl. w3 m1. ; if get virt <= rel return then
c.-1
m.*** midlertidig omregning til halvord
ls w0 1
z.
sh. w0 (b23.) ;
jl. a6. ; goto rep;
al w0 x2-2 ;
jl. w3 (m32.) ; outinteger (line - 2);
32<12 + 6 ;
al. w0 b13. ;
jl. w3 (m31.) ; outtext (<: = line :>);
al w0 x2-2 ;
ws. w0 b12. ;
jl. w3 (m32.) ; outinteger ( line-2 - firstline );
32<12 + 2 ;
al. w0 b15. ;
jl. w3 (m31.) ; outtext (<: of :>);
al. w0 b16. ;
jl. w3 (m31.) ; outtext (procedure name);
m.*** jl. a1. ; goto unwind;
a8: ; write absolute:
m.*** midlertidig udskrift af sref
rl. w0 b26. ;
jl. w3 (m32.) ; outinteger (stackref);
32<12 + 6 ;
rl. w0 b23. ;
jl. w3 (m32.) ; outinteger ( rel proc return );
1<23 + 32<12 + 4;
al. w0 b18. ;
jl. w3 (m31.) ; outtext (<: rel of segm :>);
rl. w2 b22. ;
rl w0 x2+p0 ;
jl. w3 (m32.) ; outinteger (segment number of procedure);
32<12 + 2 ;
sl. w2 (b2.) ; text := if entry < first of library table
am b27-b28; then <: of library:>
al. w0 b28. ; else <: of program:>;
jl. w3 (m31.) ; outtext (text);
jl. a1. ; goto unwind;
a10: ; terminate:
al. w0 b9. ;
jl. w3 (m31.) ; outtext (<:blocksread =:>);
rl. w3 b3. ;
rl w0 x3+d44 ;
jl. w3 (m32.) ; outinteger (blocksread);
32<12 + 1 ;
al w2 10 ;
jl. w3 (m26.) ; outchar (newline);
rl. w3 b3. ;
rl w0 x3+d38 ; w0 := error number;
se w0 0 ; w2 := result :=
am 1 ; if normal end then 0 <* ok *>
al w2 0 ; else 1 <* not ok *>;
sn w0 6 ; if io-error then
jl. a13. ; goto stderror;
se w0 5 ; if not break then
jl. (m7.) ; goto fp end-program;
jl x3+f9 ; goto break;
a13: rl. w3 b1. ; stderror:
dl w1 x3+2 ; restore (w0,w1,w2,w3) from regdump;
dl w3 x3+6 ;
jl. (m68.) ; goto fp-stderror;
e. ; end program block;
e. ; end segment block;
\f
; segment 2
; library procedures : ln, exp, sinh, system, clock
; ln, exp sinh has been made by ns and nsa
0,r.(:1026-k:)>1
s. a1,b16,c17,d6,g5,w.
jl. d1. ; entry ln
jl. d2. ; entry exp
jl. d3. ; entry sinh
jl. d5. ; entry system
jl. d6. ; entry clock
0 ; saved stack top
d0: 0 ; save return adress
; working locations
g0: 0 ; single cell
0
g2: 0 ; double cell
0
g3: 0 ; double cell
0
g4: 0 ; double cell
; floating point constants
0
c0: 2048 ; 0
h. 1024 , 0 ;
c1: 0 , 1 ; 1
-2048 , 0
c2: 0 , 0 ;-1
1024 , 0
c3: 0 , 2 ; 2
8.2613 , 8.4413
c4: 8.7676 , 0 ; ln2
8.2650 , 8.1171
c5: 8.4640 , 0 ; sqrt2/2
1024 , 0
c6: 0 , 0 ; 0.5
; constants for ln
8.5154 , 8.3642
c7: 8.7704 , 1 ; d
8.5603 , 8.5212
c8: 8.0121 , 1 ; c
8.2411 , 8.1173
c9: 8.4457 , -2 ; b
8.2705 , 8.2435
c10: 8.4504 , 2 ; a
; constants for exp
8.2500 , 8.3355
c11: 8.6211 , 6 ; d
8.2347 , 8.1522
c12: 8.3445 , 3 ; c
8.3145 , 8.1273
c13: 8.6157 , -4 ; b
w.
c14=c3 ; a
; integer constants
w.
c15: 2048
c16: -2049
c17: 2049
; real procedure ln(u)
d1: ds.w3 d0. ; store return address (entry from complex)
sh w0 0 ; if u <= 0
jl. a0. ; then goto alarm message
hs.w1 g0. ; n := exponent(u)
hl.w1 -5 ; x := fraction(u)
dl w3 2
fs.w1 c5. ; x1:= x-1/sqrt2
fa.w3 c5. ; x2:= x+1/sqrt2
fd w1 6 ; t := x1/x2
ds.w1 g2.
fm w1 2 ; t2:= t**2
ds.w1 g3.
fa.w1 c7.
dl.w3 c8.
fd w3 2
fa.w3 c9.
fm.w3 g3.
fa.w3 c10.
fm.w3 g2. ; s := t*(a+t2*(b+c/(d+t2)))
bl.w1 g0.
ci w1 0
fs.w1 c6.
fa w1 6 ; r := s+n-0.5
fm.w1 c4. ; w0w1 := ln := r*ln2
jl. d4. ; end ln
\f
; real procedure exp(u)
d2: ds.w3 d0. ; store return address ( entry from complex )
al w2 2
al w3 b16
jl. b0.
; real procedure sinh(u)
d3: ds.w3 d0. ; store return address ( entry from complex )
al w2 b15
al w3 b12
b0: hs.w2 b13.
hs.w3 b14.
ds.w1 g2. ;
fd.w1 c4. ; comment underflow may occur
fa.w1 c6. ; x := u/ln2+0.5
bl w2 3 ; v := exponent(x)
sl w2 14 ; if v >= 14
jl. b2. ; then goto b2
as w0 x2-23 ; n := entier(fraction(x)*2**(v-23))
rs.w0 g0.
ci w0 0
fm.w0 c4. ; s := n*ln2
dl.w2 g2.
fs w2 0 ; x := u-s
ds.w2 g2.
fm w2 4 ; x2:= x**2
ds.w2 g3.
fa.w2 c11.
dl.w0 c12.
fd w0 4
fa.w0 c13.
fm.w0 g3.
fa.w0 c14.
ds.w0 g4. ; s := a+x2*(b+c/(x2+d))
fs.w0 g2. ; s1 := s-x
ds.w0 g3.
dl.w1 g2.
fm.w1 c3.
fd.w1 g3.
fa.w1 c1. ; r := 1+2*x/s1
rl.w2 g0.
b11: jl. 0 ; branching for exp or sinh
b13 = b11+1
ba w2 3 ; v := n+exponent(r)
hl w1 5 ; r := r*2**n
sl.w2 (c15.) ; if v >= 2048
jl. b3. ; then goto b3
sh.w2 (c16.) ; if v <= -2049
b1: dl.w1 c0. ; then exp := 0
jl. d4.
b2: rl.w3 g2.-2 ; b2:
sh w3 -1 ; if u <= 0
b4: jl. 0 ; or called from exp then goto alarm
b3: jl. a1. ; else goto b1
b14 = b4 + 1
b16 = b1-b4
; sinh
b5: se w2 0
jl. b6. ; if n <> 0 then goto b6
dl.w1 c1.
dl.w3 g4.
fa.w3 g2.
fd w1 6
dl.w3 c1.
fd.w3 g3. ; s1 := s-x
fa w1 6 ; rh := (1/(s+x)+1/(s-x))*x
fm.w1 g2.
jl. b9. ; goto b9
b6: sl w2 0 ; if n > 0
jl. b7. ; then goto b7
dl.w3 c2.
fd w3 2 ; r := -1/r
dl w1 6
ac.w2 (g0.) ; n := -n
b7: ba w2 3 ; b7: v := n + exponent(r)
sl.w2 (c17.) ; if v > 2048
jl. a1. ; then goto alarm
sl w2 19 ; if v >= 19
jl. b10. ; then goto b10
hs w2 3 ; r := r*2**n
dl.w3 c1.
fd w3 2
fs w1 6
fm.w1 c6. ; w0w1 := (r-1/r)/2
b9: jl. d4.
b10: al w2 x2-1 ; b10:
hl w1 5 ; w0w1 := r*2**(n-1)
jl. d4. ; end sinh
b15 = b5-b11
b12 = b3-b4
; error return
a0: am 10-11 ; alarm 10 negative argument
a1: al w1 11 ; - 11
rl. w2 d0.-2 ;
rl w3 x2+4 ; add of runtime procedure
rs. w3 d0.-2 ;
rl w2 x2+8 ; w2 := stacktop
rl. w3 d0. ; w3 := add where error occurred
al w0 -1 ; indicate error ocuured in library
jl. (d0.-2) ; jump to rt error
d4: dl. w3 d0. ;
rl w2 x2+8 ; w2 := stacktop
jl x3+2 ;
\f
; system
; call :
; w0 - add of integer
; w1 - add of alfa
; w2 - abs proc table entry (unimportant)
; w3 - return - 4
; +0 segm<12 + rel
; +2 param no
m.******** hovsa: pas paa paging-fejl
; return
; w1 - seperator (sep<12 + length) if error 0 is returned
; and value set in integer var or alfa
;
; the procedure searches the fp-stack to find the parameter denoted by w0.
; if the parameter is found it is copied into either an integer or an alfa.
; if not found 0 is returned in the seperator.
b. b5, a7 w.
b0: 0,r.4 ; saved registers
b1: <: :> ; (three spaces)
a0: 0 ;
d5: ds. w0 b0.+2 ;
ds. w2 b0.+6 ;
rl w3 x3+2 ;
rs. w3 a0. ;
rl w2 66 ;
rl w2 x2+22 ; w2 := process start
rl w2 x2+h8 ; ptr := start of fp-stack
al w1 0 ;
a2: sl. w1 (a0.) ; while par < wanted par then
jl. a1. ; begin
ba w2 x2+1 ; increase (pointer);
bl w3 x2 ; w3 := seperator;
sh w3 3 ; if end of command then
jl. a4. ; goto not found;
al w1 x1+1 ; param := param + 1
jl. a2. ; end
a1: bz w3 x2+1 ; w3 := length
;ks-1100
se w3 4 ; if integer then
jl. a5. ;
rl w3 x2+2 ;
;ks-1101
rs. w3 (b0.+2) ; int := value from fp-stack
jl. a6. ;
a5: se w3 10 ; if alfa then
jl. a4. ;
rl. w1 b0.+4 ; w1 := add of alfa
dl w0 x2+4 ;
lo. w3 b1. ;
lo. w0 b1. ;
ds w0 x1+2 ;
dl w0 x2+8 ; copy name from stack
lo. w3 b1. ;
lo. w0 b1. ; (filled up with spaces)
ds w0 x1+6 ; to alfa
a6: rl w1 x2 ; w1 := seperator < 12 + length
a7: rl. w2 b0.+6 ; return
rl w2 x2+8 ; reestablish stack top
rl. w3 b0. ;
jl x3+4 ;
a4: al w1 0 ; error return
jl. a7. ;
e.
; clock (real function)
; the procedure delivers the time elapsed since the process was started.
; the result may be delivered with an error the size of a time slice
; usually (25.6 msec).
; call :
; w2 = proc table entry
; w3 = return-2
; +0: segm<12 + rel
; return :
; w0,w1 result as a real
b. a1 w.
10000<9
a0: 4096 + 14 - 47
d6: ; clock:
ds. w3 d0. ;
rl w1 66 ;
dl w1 x1+56 ; time slices used by own process
nd w1 3 ;
fd. w1 a0. ;
jl. d4. ; return;
e.
e.
\f
; segment 3
;slang subroutines: arcsin, sqrt, date and time
;rc 30.11.70
;by ns adapted from nsa
; changed 78 03 30 by bbj to fit pascal
0,r.(:1538-k:)>1
b. a1,b25,c6,d14,g10,w.
jl. d1. ; entry arcsin
jl. d2. ; entry sqrt
jl. d12. ; entry date
jl. d13. ; entry time
0 ; saved w2
d0: 0 ; save return adress
; working locations
w.
0
g3: 0 ; double cell
0
g4: 0 ; double cell
g8: 0
; floating point constants
h.
1024 , 0
c1: 0 , 1 ; 1
-2048 , 0
c2: 0 , 0 ;-1
1024 , 0
c3: 0 , 2 ; 2
8.3110 , 8.3755
c4: 8.2421 , 1 ; pi/2
; chebyshev constants for arcsin
8.5737 , 8.2725
c5: 8.5063 , 5 ; p0,q0
8.2607 , 8.1707
8.7441 , 5 ; p1
8.4222 , 8.3364
8.1301 , 3 ; p2
8.3174 , 8.7301
8.3566 , -1 ; p3
8.3067 , 8.2571
8.5276 , 5 ; q1
8.5325 , 8.2076
c6: 8.3306 , 4 ; q2
\f
w.
; real procedure arcsin(u)
d1: ds.w3 d0. ; store return address ( complex entry point )
al w3 d8
hs.w3 d6.
bl w3 3 ; if exponent(u) <= -16
sh w3 -16 ; then arcsin := u
jl. d11. ; else
ds.w1 g3. ; begin
sl w0 0
jl. b0.
fm.w1 c2. ;
bl w3 3
b0: sh w3 -1 ; if abs(u) <= 0.5 then
jl. b1. ; begin
al w3 b8
hs.w3 b9. ; b := true
jl. b6. ; goto b6
b1: al w3 2 ; end
hs.w3 b9. ; b := false
fm w1 2 ; u2 := u**2
dl w3 2 ; w2w3:=u2
b3: ds.w1 g4. ;
fa.w3 c6. ;
fm.w3 g4. ;
fa.w3 c6.-4 ;
fm.w3 g4. ;
fa.w3 c5. ;
fm.w1 c6.-8 ;
fa.w1 c6.-12 ;
fm.w1 g4. ;
fa.w1 c6.-16 ;
fm.w1 g4. ;
fa.w1 c5. ;
fd w1 6 ;
b5: jl. 0 ; if b then goto b7
fm.w1 g3. ; arcsin := u*y
jl. d11. ; return
b6: dl.w3 c1. ; b6:
fs w3 2
sh w2 -1 ; if abs(u) > 1
jl. a0. ; then goto alarm
fd.w3 c3.
dl w1 6 ; u2 := (1-abs(u))/2
jl. b3. ; goto b3
b7: rx.w0 g4.-2 ; b7:
rx.w1 g4. ; w0w1 := u2
jl. d4. ; u1 := sqrt(u2)
d10: fm.w1 g4.
fm.w1 c3.
fs.w1 c4. ; arcsin := y := 2*u1*y - pi/2
rl.w2 g3.-2
sl w2 0 ; if u >= 0
fm.w1 c2. ; then arcsin := -y
jl. d11. ; end arcsin
b8 = b7-b5
b9 = b5+1
\f
; real procedure sqrt(u)
d2: ds.w3 d0. ; store return address ( complex entry point )
al w3 d7
hs.w3 d6.
d4: sh w0 -1 ; if u<0
jl. a1. ; then goto alarm
sn w0 0 ; if u=0
jl. d5. ; then sqrt:=0 and jump out
rl w3 0 ; else begin w3:=w0:=u0
as w3 -2 ; start 1. iteration, w3:=u0/4
rs.w3 g8. ; store u0/4
wa.w3 b21. ; w3:=u0/4+c/4
rl.w2 b22. ; w2:=b/16
wd w3 6 ; w3:=b/2/(u0+c)
la.w3 b25. ; remove sign bit of w3
wa.w3 b23. ; u1/2:=w3:=(a+b/(u0+c)
rl.w2 g8. ; start 2. iteration, w2:=u0/4
rs.w3 g8. ; store u1/2
wd w3 6 ; w3:=u0/u1
as w3 -1 ; w3:=u0/u1/2
wa.w3 g8. ; u2:=w3:=(u1+u0/u1)/2
al w2 x3 ; start 3. iteration, w2:=u2
bl w3 3 ; w3:=two_exp of u
as w3 -1 ; w3:=two_exp//2
sz w1 1 ; if two_exp is odd
fm.w3 b24. ; then w2w3:=w2w3*sqrt(2)
fd w1 6 ; w0w1:=u/u2
fa w1 6 ; w0w1:=u/u2+u2
bl w2 3 ; w2:=two_exp of w0w1
al w2 x2 -1 ; w2:=two_exp-1
hl w1 5 ; w0w1:=w0w1/2:=sqrt(u)
d5: jl. 0 ; end
b21: 8.2143 1676 ; c/4 c=2.1938165
b22: 8.6573 4114 ; b/16 b=-5.0350099
b23: 8.1116 2452 ; a/2-1 a=2.5764869. sqrt(u)=a+b/(u+c)
8.2650 1171 ;
b24: 8.4640 0001 ; sqrt(2)
b25: 8.3777 7777 ; 2**23-1
d6=d5+1
m.****** sqrt: ikke pæn addressering
d7=b6-2-d5
d8=d10-d5
; return
d11: dl. w3 d0. ;
rl w2 x2+8 ;
jl x3+2 ; return
; error return
a0: am 12-10 ; alarm 12 illegal arg to arcsin
a1: al w1 10 ; alarm 10 negative arg to sqrt
rl. w2 d0.-2 ;
rl w3 x2+4 ;
rs. w3 d0.-2 ; store add of rt error
rl w2 x2+8 ; w2 := stacktop
rl. w3 d0. ; w3 := error address
al w0 -1 ;
jl. (d0.-2); jump to rt error
\f
; date and time
; call :
; w1 - add of alfa variable
; w2 - abs add of proc table entry
; w3 - return - 2
;
; the procedure returns the date and time in the alfa variable
; addressed by w1.
; the result is delivered as :
; date : yy.mm.dd.
; time : hh.mm.
;
b. a20, b10 w.
b0: 0,r.2 ;
b1: 10 ;
b2: 48<16+48<8+46 ;
b3: <: :> ;
b5: 0,r.4 ;
; variables and constants for short clock
a0: 1172 ; units per minute
a1: 70313 ; - - hour
a2: 1687500 ; - - day
a3: 153 ; days in five months (march-july)
a4: 1461 ; days in four years
a5: 99111 ; offset for computing year
a6: 5 ;
0 ; saved minute
a9: 0 ; saved hour
a11=461 ; three months offset
a12=5 ; one days offset
a13=586 ; half a minute
d12: am 1 ; date
d13: al w0 0 ; time
ds. w1 b0.+2 ;
ds. w3 d0. ;
jd 1<11+36; get clock
ld w1 5 ;
;ks-1200
; short clock
ld w2 -100 ; clear w1,w2
al w3 0 ; clear w3
ld w0 10 ; w3,w0:= truncated clock>9
wd. w0 a2. ; w0 := dayno
al w3 x3+a13 ; add minute rounding
wd. w3 a1. ; w3 := hour
wd. w2 a0. ; w2 := minute
ds. w3 a9. ; save minute , hour
al w3 0 ;
ld w2 -100 ;
ls w0 2 ; w0 := dayno*4
wa. w0 a5. ; add offset
wd. w0 a4. ; w0 := year
ls w3 -2 ; w3 is converted
wm. w3 a6. ; to fitfh-days
al w3 x3+a11 ; w3 := w3+three months offset
wd. w3 a3. ; w3:=month
sh w3 12 ; if month > 12 then
jl. a15. ; begin
ba. w0 1 ; increase year
al w3 x3-12 ; decrease month
a15: al w2 x2+a12 ; end
wd. w2 a6. ; w2:=date
; end short clock
rl. w1 b0. ;
sn w1 0 ; if 0 then
jl. b4. ; goto time
;ks-1201
; date
; w0 - year
; w1 - month
; w2 - day
ds. w3 b5.+6 ;
rl w1 0 ;
jl. w2 b10. ; pack into chars
rl. w3 b0.+2 ;
rs w0 x3 ; alfa(1) := year
rl. w1 b5.+6 ;
jl. w2 b10. ;
rs w0 x3+2 ; alfa(2) := month
rl. w1 b5.+4 ;
jl. w2 b10. ;
rs w0 x3+4 ; alfa(3) := day
jl. b6. ; return
; time
; a9 - hour
; a9-2 - minute
b4: rl. w1 a9. ;
jl. w2 b10. ;
rl. w3 b0.+2 ;
rs w0 x3 ; alfa(1) := hour
rl. w1 a9.-2 ;
jl. w2 b10. ;
rs w0 x3+2 ; alfa(2) := minute
rs w1 x3+4 ; alfa(3) := <: :>
b6: rs w1 x3+6 ; alfa(4) := <: :>
jl. d11. ; return
; pack an integer to a string
; w1 - number to split into characters
; w2 - return
b10: al w0 0 ;
wd. w1 b1. ;
ls w1 16 ; first digit < 16
ls w0 8 ; +second digit < 8
lo w0 2 ;
wa. w0 b2. ; +space
rl. w1 b3. ;
jl x2 ;
e.
e.
\f
; segment 4
;slang subroutines: arctan, arg, cos, sin, monitor
;by ns adapted from nsa
; changed 78 03 30 by bbj to fit pascal
0, r.(:2050-k:)>1
b. b12,c27,d14,g6,w.
jl. d1. ; entry arctan
jl. d2. ; entry arg
jl. d3. ; entry cos
jl. d4. ; entry sin
0 ; saved w2
d0: 0 ; save return adress
w.
; working locations
0
g0: 0 ; double cell
0
g1: 0 ; double cell
0
g2: 0 ; double cell
g3: 0
g4: 0
g5: 0
g6: 0
; floating point constants
h. 0 , 0
c0: 0 ,-2048 ; 0
1024 , 0
c1: 0 , 1 ; 1
-2048 , 0
c2: 0 , 0 ;-1
1024 , 0
c3: 0 , 2 ; 2
8.3110 , 8.3755
c4: 8.2421 , 0 ; pi/4
8.3110 , 8.3755
c5: 8.2421 , 1 ; pi/2
8.3110 , 8.3755
c6: 8.2421 , 2 ; pi
8.3110 , 8.3755
c7: 8.2421 , 3 ; pi*2
8.3240 , 8.4746
c8: 8.3177 ,-1 ; sqrt2 - 1
; constants for arctan
w. c20=c1 ; d0
h. 8.4005 , 8.1433
c21: 8.5135 ,-6 ; d1
8.2063 , 8.3675
c22: 8.1510 , 2 ; d2
8.3173 , 8.7332
c23: 8.5776 , 1 ; d3
8.5521 , 8.2144
c24: 8.6150 , 0 ; e1
8.4513 , 8.6070
c25: 8.1005 ,-1 ; e2
; constants for sin
8.4317 , 8.1351
c26: 8.3444 ,-18 ; a5
8.2500 , 8.1775
8.7702 ,-12 ; a4
8.5464 , 8.5673
8.3771 ,-7 ; a3
8.2431 , 8.5357
8.7411 ,-3 ; a2
8.5325 , 8.0414
8.3304 , 0 ; a1
8.3110 , 8.3755
8.2420 , 1 ; a0
\f
w.
; real procedure arctan(u)
d1: ds.w3 d0. ; store return address (entry from complex)
al w2 d10
hs.w2 d7.
d5: ds.w1 g0.
sh w0 -1 ; absu := abs(u)
jl. b0.
dl.w3 c4.
jl. b1.
b0: dl.w1 c0. ; phi := if u >= 0 then pi/4
ds w1 6 ; else -pi/4
fs.w1 g0.
fs.w3 c4.
b1: ds.w1 g1.
fs.w1 c8.
sl w0 0 ; if absu < sqrt2-1 then
jl. b2. ; begin
dl.w1 g0. ; t := u; phi := 0
dl.w3 c0. ; end
jl. b4. ;
b2: fs.w1 c3. ; else
sl w0 0 ; if absu < sqrt2 + 1 then
jl. b3. ; begin
dl.w1 g1.
fs.w1 c2.
ds.w1 g2.
dl.w1 g1.
fa.w1 c2.
fd.w1 g2. ; t := (absu - 1)/(absu + 1)
rx.w3 g0.-2
sh w3 -1 ; if u <= 0 then
fm.w1 c2. ; t := -t
rx.w3 g0.-2 ; end
jl. b4. ; else
b3: dl.w1 c2. ; begin
fd.w1 g0. ; t := -1/u
al w3 x3+1 ; phi := 2*phi
b4: ds.w3 g1. ; end;
ds.w1 g0. ; comment (g0) := t , (g1) := phi
bl w3 3 ; if exponent(t) <= -18 then
sh w3 -18 ; arc := t
jl. b5. ; else
fm w1 2 ; begin
ds.w1 g2. ; t2 := t**2
fa.w1 c23.
dl.w3 c25.
fd w3 2
fa.w3 g2.
fa.w3 c22.
dl.w1 c24.
fd w1 6
fa.w1 c21.
fm.w1 g2.
fa.w1 c20.
fm.w1 g0. ; arc := t*(d0+t2*(d1+e1/(d2+t2+e2/(t2+d3))))
; end
b5: fa.w1 g1. ; arctan := phi + arc
d7 = b5+3
d9: jl. 0 ; if called from arg then return to arg
; end arctan
\f
d2: ds.w3 d0. ; return address; comment entry from complex
m.***** 'arg' can't be called like this...
dl w3 x2
ds.w3 g4. ; commment (g4) := x
ds.w1 g6. ; comment (g6) := y
bl w1 3
bs w1 7 ; n := exponent(y) - exponent(x)
sh w1 36 ; if n > 36 then
jl. b7. ; b6:
b6: dl.w1 c5. ; begin
rl.w2 g5. ; arg := pi/2
sh w2 -1 ; if y < 0
fm.w1 c2. ; then arg := -pi/2
jl. d11. ; end
d10=k-2-d9 ; else
b7: sl w1 -2047 ; if n < -2047 then
jl. b9. ; b8: begin
b8: dl.w1 c0. ; arg := 0
rl.w2 g3.
sh w2 -1 ; if x < 0
dl.w1 c6. ; then arg := sign(y)*pi
jl. b6.+2 ; end
b9: dl.w1 g6. ; else
; begin
sn w0 0 ; if y = 0
jl. b8. ; then goto b8
sn w2 0 ; if x = 0
jl. b6. ; then goto b6
fd w1 6
al w2 d8
hs.w2 d7.
jl. d5. ; arg := phi := arctan(y/x)
d6: rl.w2 g3.
d8 = d6-d9
sl w2 0 ; if x < 0
jl. d11.
rl.w2 g5. ;
sh w2 -1 ; if y < 0
fs.w1 c6. ;
sl w2 0 ;
fa.w1 c6. ; arg := phi + sign(y)*pi
jl. d11. ; end arg
\f
; real procedure cos(u)
d3: ds.w3 d0. ; store return address ( entry from complex )
dl.w3 c5.
fs w3 2
dl w1 6 ; u := pi/2 - u
jl. b10. ; cos := sin(u)
; real procedure sin(u)
d4: ds.w3 d0. ; store return address ( entry from complex )
b10: bl w3 3
sh w3 -18 ; if exponent(u) <= 18 then
jl. d11. ; sin := u
fd.w1 c5. ; else
bl w2 3 ; if exponent(u/pi/2) > 35 then
sh w2 35 ; sin := 0
jl. b11.
dl.w1 c0. ; else
jl. d11. ; begin
b11: sh w2 22 ; z := u/pi/2
jl. b12. ; if exponent(z) > 22 then
rs w0 6 ; begin
as w3 x2-43
ci w3 20 ; z1 := entier(z*2**(-20))*2**20
fs w1 6 ; z := z - z1
; end
b12: rs w0 6
bl w2 3
as w3 x2-23
al w3 x3+1
as w3 -1
rs.w3 g5. ; n := (entier(z)+1)2
ci w3 1
fs w1 6 ; x := z-float(2*n)
rl.w2 g5.
sz w2 1 ; if n is odd
fm.w1 c2. ; then x := -x
ds.w1 g2.
fm w1 2 ; x2 := x*x
ds.w1 g4. ; p := x2
fm.w1 c26. ; p := p*a5
fa.w1 c26.+4 ; p := p + a4
fm.w1 g4. ; p := p * x2
fa.w1 c26.+8 ; p := p + a3
fm.w1 g4. ; p := p * x2
fa.w1 c26.+12 ; p := p + a2
fm.w1 g4. ; p := p * x2
fa.w1 c26.+16 ; p := p + a1
fm.w1 g4. ; p := p * x2
fa.w1 c26.+20 ; p := p + a0
fm.w1 g2. ; sin := x*p
jl. d11. ; end sin
d11: dl. w3 d0. ;
rl w2 x2+8 ;
jl x3+2 ; return
0,r.(:2562-k:)>1
e.
\f
; segment 5-6
; file handling procedures
; call parameters :
; w0 - see each procedure
; w1 - add of zone descriptor + -h0 (+36)
; w2 - abs add of proc table entry
; w3 - return - 2
;
; the stack picture looks like (if not input or output) :
; name of file (8 halfwords)
; zone descriptor (h5 halfwords)
; share - (h6 - )
; data buffer (512 - )
; file buffer (if binary file)
;
; the following free parameters in a zone descriptor
; are used by the pascal i/o system :
;
; z+h2+6 (halfword) : zone state (almost as in algol)
; (see definition of s-names)
; z+h2+7 (halfword) : file type
; 0 = binary
; 1 = text
; 2 = iso
; z+h3+6 (word) : (not used, but could be used for recsize)
; z+h4+0 (halfword) : eof
; 0 = false
; 1 = true
; z+h4+1 (halfword) : eoln
; 0 = false
; 1 = true
; z+h4+2 (word) : length of binary file (irrell if text file)
; read: remaining halfwords
; write: number of halfwords written
; z+h4+4 (word) : file buffer
; binary file: address of filebuf
; text file : next character
;
; the following field is used in the share descriptor:
;
; first share+(14:20) : file name
;
; the organization of the code :
;
; init and select
; file initialization (i1) 4<12 + 0
; reset (i2) 4<12 + 2
; rewrite (i3) 4<12 + 4
; close (i4) 4<12 + 6
; remove (i5) 4<12 + 8
; replace (i9) 4<12 + 10
; monitor (i10) 4<12 + 12
; error return
;
; b-variables are global variables for all procedures
; c-variables are error returns
;
\f
b. b20, c10, i10 w.
jl. i0. ;+0
jl. i0. ;+2
jl. i0. ;+4
jl. i0. ;+6
jl. i0. ;+8
jl. i0. ;+10
jl. i0. ;+12
b0: 0 ; saved w0: (sometimes addr of name)
b1: 0 ; saved w1: zone address
b2: 0 ; saved w2: proc table entry
b3: 0 ; saved w3: (increased) return
b4: 0 ; first of process
b5: 0, r.10 ; tail for lookup entry
i0: ; common entry:
al w3 x3+2 ; (increase entry);
ds. w1 b1. ;
ds. w3 b3. ; save (registers);
bl w2 x3-1 ; w2 := rel entry;
am (66) ;
rl w3 +22 ; w3 := first of process;
rs. w3 b4. ; save (first of process);
bl w0 x1+h2+6 ; w0 := zone state;
; w0 = zone state
; w1 = zone
; w2 = rel entry
; w3 = first of process
jl. x2+2 ; switch to:
jl. i1. ; file init
jl. i2. ; reset
jl. i3. ; rewrite
jl. i4. ; close
jl. i5. ; remove
jl. i9. ; replace
jl. i10. ; monitor
\f
; file initialization
; this procedure has two parameters in the original call :
; +0 4<12 + 0
; +2 text (1) / binary (0) / iso (2)
;
; the procedure initializes a zone and share descriptor :
; base buffer area
; set share to base buffer area + 1
; last add of buffer
; used share
; first share
; last share
; give up mask
; give up action
;
; also the private variables are set:
; zone state
; file type
; eof
; length of binary file
; file buffer
; file name
;
; if zone is 'current in' or 'current out' then the zone
; is stacked prior to initializing private variables
;
; call parameters :
; w0 - add of external file name
; w1 - zone add
;
b. a10 w.
i1: ; file init:
se w1 x3+h20 ; if zone = current input then
jl. a1. ;
jl w3 x3+h29-4 ; stack current input
jl. a5. ; else
a1: ;
se w1 x3+h21 ; if zone = current output then
jl. a2. ; begin
al w2 x3+h55+30 ; chain := std chain for output;
jl w3 x3+h29 ; stack zone;
jl. a5. ; end
a2: ; else
m.*** 'fileinit': midlertidigt ingen test af zonestate
c.-1
se w0 s4 ; if zonestate <> after decl then
jl. c6. ; error(illegal zone state);
z.
; the following initialization ougth to be done in a separate call
al w2 x1+h0+h5 ; w2 := address of share 0 := first free after zone;
al w3 x2+h6-1 ; w3 := base buffer := last of share descr;
al w0 x3+512 ; w0 := last of buffer; (* bufsize = 512 *)
ds w0 x1+h0+2 ;
ba. w0 1 ; first of file buffer :=
rs w0 x1+h4+4 ; top of buffer;
al w3 x3+1 ; first shared (share 0) :=
rs w3 x2+2 ; first of buffer;
rs w2 x1+h0+4 ; used share := share;
rs w2 x1+h0+6 ; first share:= share;
rs w2 x1+h0+8 ; last share := share;
al w0 0 ;
rs w0 x2+14 ; filename(0) (in share 0) := 0; <* prepare rewrite *>
rs w0 x1+h2+0 ; giveup mask := 0;
rl. w3 b4. ;
rl w0 x3+h20+h2+2; (use same giveup action as in primary input);
rs w0 x1+h2+2 ; giveup action := pascal runtime system;
rl. w3 b3. ;
bl w0 x3+1 ; filetype := param from call;
hs w0 x1+h2+7 ;
a5: ; common init:
al w0 s8 ; zone state := after open;
hs w0 x1+h2+6 ;
rl. w3 b0. ; w3 := file name param;
rl w2 x1+h0+6 ; w2 := file name addr;
al w2 x2+14 ;
dl w1 x3+2 ; move filename from param
ds w1 x2+2 ; to share 0 (* for later use by 'reset' etc *)
dl w1 x3+6 ;
ds w1 x2+6 ;
jl. w3 i8. ; replace trailing spaces by nulls;
rl. w3 b3. ;
al w3 x3+2 ; increase (return); i.e. skip filename param;
rs. w3 b3. ;
jl. i7. ; return;
e.
\f
; reset
; the procedure has the following function :
; terminate transfers
; if file does not exist then error
; connect input
; copy file length to zone description
b. a10 w.
i2: ; reset:
sn w0 s4 ; if zone state = after decl then
jl. c6. ; error (illegal zone state);
jl. w3 i6. ; terminate transfer;
rl w3 x1+h0+6 ; w3 := file name addr;
al w3 x3+14 ;
al. w1 b5. ;
jd 1<11+42; lookup entry;
se w0 0 ; if not ok then
jl. c2. ; error (file does not exist);
al w2 x3 ;
rl. w1 b1. ; w1 := zone;
am. (b4.) ;
jl w3 +h27 ; connect input (zone, filename);
se w0 0 ; if not ok then
jl. c5. ; error (file not connected);
rs w0 x1+h4+0+1 ; eof := eoln := false;
rl. w0 b5.+18 ; zone.filelength :=
rs w0 x1+h4+2 ; tail.length; <* irrell for text files *>
bl w0 x1+h2+7 ; zonestate :=
sn w0 0 ; if filetype = binary then
am s5-s1 ; after read binary
al w0 s1 ; else
hs w0 x1+h2+6 ; after read char;
m.*** 'reset': midlertidig opdigtet 'newline'
c.+1
al w2 10 ;
sn w0 s1 ; if read char then
rs w2 x1+h4+4 ; filebuf := newline;
al w2 1 ;
sn w0 s1 ; if readchar then
hs w2 x1+h4+1 ; eoln := true;
z.
jl. i7. ; return;
e.
\f
; rewrite
; the function of the procedure :
; terminate transfer
; connect output
; reset filelength
b. a10 w.
i3: ; rewrite:
; notice: the check on zonestate is not needed, because the
; filename is initialized to zero by 'file init'
sn w0 s4 ; if zonestate = after decl then
jl. c6. ; error (illegal zonestate);
jl. w3 i6. ; terminate transfer;
rl w2 x1+h0+6 ; w2 := filename addr;
al w2 x2+14 ;
al w0 1<1+1 ; w0 := 1 slice, pref. on disc;
am. (b4.) ;
jl w3 +h28 ; connect output (zone, filename, w0);
se w0 0 ; if not ok then
jl. c5. ; error (file cannot be connected);
; notice: fp will initialize filename, if it was empty
m.***** rewrite: ad hoc metode: nulstil segm count
rs w0 x1+h1+16 ; segment count := 0;
rs w0 x1+h4+2 ; filelength := 0;
rl w2 x1+h0+6 ; w2 := file name addr;
al w2 x2+14 ;
se w0 (x2+0) ; if filename was empty then
jl. a1. ; begin
dl w0 x1+h1+4 ;
ds w0 x2+2 ; move zonename to filename;
dl w0 x1+h1+8 ;
ds w0 x2+6 ;
a1: ; end;
al w2 1 ; eof := true;
hs w2 x1+h4+0 ;
bl w0 x1+h2+7 ; zonestate :=
sn w0 0 ; if filetype = binary then
am s6-s3 ; after write binary
al w0 s3 ; else
hs w0 x1+h2+6 ; after write char;
jl. i7. ; return;
e.
\f
; close
; the function of the procedure:
; if file not used then the procedure is blind
; terminate transfers
; if 'current in' and not 'i-bit' then unstack
; if 'current out' then unstack
b. a10 w.
i4: ; close:
sn w0 s4 ; if zonestate = after decl then
jl. i7. ; return;
jl. w3 i6. ; terminate transfer;
al w0 s4 ; zonestate :=
hs w0 x1+h2+6 ; after decl;
rl. w3 b4. ; w3 := first of process;
se w1 x3+h20 ; if zone = 'current in' then
jl. a1. ; begin
rl w0 x1+h2+0 ; if 'i-bit' not set in giveup mask then
so w0 2.1 ;
jl w3 x3+h30-4 ; unstack current input;
jl. i7. ; end
a1: ; else
al w2 x3+h55+30 ;
sn w1 x3+h21 ; if zone = 'current out' then
jl w3 x3+h30 ; unstack (current output chain);
jl. i7. ; return;
e.
; remove entry
; the procedure cancels files
; no matter the result of the remove it is assumed to be ok. (30/11/78)
;
b. w.
i5: ; remove:
rl w3 x1+h0+6 ; w3 := file name addr;
al w3 x3+14 ;
jd 1<11+48 ; remove entry
;ks-820
; sn w0 0 ; if entry removed then
jl. i7. ; return
; jl. c4. ; else error(entry not removed)
e.
\f
; terminate (help procedure)
; the procedure has the following function :
; if after write char then closeup text
; if after write binary then outblock, in case of data in share
; if after read or write then terminate zone
; if output to bs area then
; begin
; set shortclock in catalog entry
; cut area to used size
; set filelength in tail, in case of binary file
; end
;
; call: w1 = zone
; w3 = return
; exit: w1 = zone, other regs undef
b. a10, f10 w.
f0: 0 ; saved return
i6: ; terminate transfer:
rs. w3 f0. ; save (return);
bl w0 x1+h2+6 ; w0 := zone.state;
rl. w2 b4. ; w2 := first of process;
se w0 s3 ; if zonestate = after write char then
jl. a1. ; begin
jl w3 x2+h95 ; close up text (zone);
rl. w2 b4. ; w2 := first of process;
jl. a5. ; goto terminate;
a1: ; end;
se w0 s6 ; if zonestate = after write binary then
jl. a2. ; begin
rl w0 x1+h3+0 ; w0 := record base;
rl w3 x1+h0+4 ; w3 := used share;
sl w0 (x3+2) ; if recbase >= first shared(used share) then
jl w3 x2+h23 ; outblock;
jl. a5. ; goto terminate;
a2: ; end;
se w0 s1 ; if zonestate = after read char or
sn w0 s5 ; zonestate = after read binary then
a5: ; terminate:
jl w3 x2+h79 ; terminate zone (zone);
bl w2 x1+h1+1 ; w2 := kind (zone);
bl w0 x1+h2+6 ; w0 := zonestate;
se w0 s3 ; if (zonestate = after write char or
sn w0 s6 ; zonestate = after write binary)
se w2 4 ; and zonekind = 'bs' then
jl. a10. ; begin
rl w3 x1+h0+6 ; w3 := filename addr;
al w3 x3+14 ;
al. w1 b5. ; w1 := tail addr;
jd 1<11+42; lookup entry (name, tail);
se w0 0 ; if not ok then
jl. c2. ; error (file does not exist);
rl. w0 b5.+0 ; w0 := size.tail;
sh w0 -1 ; if size < 0 then
jl. a9. ; return;
jd 1<11+36; tail.shortclock :=
ld w1 5 ; getclock shift (-19) extract 24;
rs. w0 b5.+10 ;
rl. w1 b1. ; w1 := zone addr;
rl w0 x1+h1+16 ; size.tail := segment count (zone);
rs. w0 b5.+0 ;
bl w0 x1+h2+7 ; if filetype = binary then
rl w2 x1+h4+2 ;
sn w0 0 ;
rs. w2 b5.+18 ; filelength.tail := filelength (zone);
al. w1 b5. ;
jd 1<11+44; change entry (name, tail);
a9: ; end;
; return:
rl. w1 b1. ; w1 := zone;
a10: jl. (f0.) ; return;
e.
\f
; replace of spaces with binary zero in file name
; call: w2 = filename addr
; w3 = return
; exit: all regs undef
b. a10, f10 w.
f0: 0 ; start of filename
f1: 0 ; saved return
i8: ; replaces spaces:
ds. w3 f1. ; save (filename addr, return);
al w2 x2+8 ; wordaddr := top of filename;
a0: ; next word:
al w2 x2-2 ; decrease (wordaddr);
rl w0 x2 ; word := filename (wordaddr);
al w3 0 ; shift := 0;
a1: ; next char:
al w3 x3-8 ; shift := shift - 8;
ld w1 x3 ; w0 := first char(s);
ls w1 -16 ; w1 := char (shift);
se w1 32 ; if char <> space then
jl. (f1.) ; return;
ac w1 x3 ;
ls w0 x1 ; w0 := first char(s) leftjustified;
rs w0 x2 ; filename (wordaddr) := word;
se w3 -24 ; if not all chars in word tested then
jl. a1. ; goto next char;
se. w2 (f0.) ; if not all filename converted then
jl. a0. ; goto next word;
jl. (f1.) ; return;
e.
\f
; replace ( <programname> )
;
; call: w1 = addr of name of new program
b. a10 w.
a0: ; start of program-stack
2<12 + 2 ;
2<12 + 10 ;
<:pascrun:>, 0 ;
4<12 + 10 ;
0
a1: 0-0-0 ; (old fp-mode bits)
0 ;
0 ;
4<12 + 10 ;
a2: 0, r.4 ; name of new program
a3: ; top of program-stack
i9: ; replace:
dl w3 x1+2 ; move name to program-stack;
ds. w3 a2.+2 ;
dl w3 x1+6 ;
ds. w3 a2.+6 ;
al. w2 a2. ; insert zeroes for spaces;
jl. w3 i8. ;
rl w3 66 ;
rl w3 x3+22 ; w3 := start of process;
rl w2 x3+h51 ;
rs. w2 a1. ; move fp-modebits to program stack;
sz w2 2.1 ; remove list-bit;
al w2 x2-2.1 ;
rs w2 x3+h51 ;
rl w2 x3+h8 ; w2 := current command;
a5: ba w2 x2+1 ; next:
bl w0 x2+0 ; if seperator (increase (pointer)) <> 'end' then
sl w0 4 ;
jl. a5. ; goto next;
al. w1 a3. ; w1 := top of program-stack;
a7: al w2 x2-2 ; rep:
al w1 x1-2 ; decrease pointers;
rl w0 x1 ;
rs w0 x2 ; move one word;
se. w1 a0. ; if w1 <> start of program-stack then
jl. a7. ; goto rep;
rs w2 x3+h8 ; current command := command pointer;
m.****** replace: husk at afstakke current output
al w2 0 ; w2 := normal return to fp;
jl x3+h7 ; goto fp-end-program;
e. ;
; monitor procedure
;
; the procedure sets up a monitor call
;
; the functions implemented are:
; 40: create entry
; 42: lookup entry
; 44: change entry
; 48: remove entry
;
; call: w0: name address (may be padded with blank)
; w1: tail address
; w2: proc table entry
; w3: return-4
; +0 : segm<12 + rel
; +2 : function number
b. a10 w.
a0: 0, r.4 ; name (without trailing spaces)
i10: ;
rl. w2 b3. ;
al w0 x2+2 ;
rs. w0 b3. ; return := after parameters;
al w1 -1 ; w1 := illegal result;
rl w2 x2+0 ; w2 := function number;
sl w2 40 ; if function out of range then
sl w2 48+1 ;
jl. i7. ; return;
al w2 x2-2048 ;
hs. w2 a1. ; save function in monitor call;
rl. w3 b0. ; w3 := name addr;
al. w2 a0. ; w1 := local name;
dl w1 x3+2 ;
ds w1 x2+2 ; move name;
dl w1 x3+6 ;
ds w1 x2+6 ;
jl. w3 i8. ; remove spaces;
rl. w1 b1. ; w1 := tail address;
al. w3 a0. ; w3 := name address;
jd 1<11+0+0+0;
a1 = k-1 ;
rl w1 0 ; w1 := result;
jl. i7. ; return;
e. ;
\f
; error return
c6: am 13-19 ;13: illegal zonestate:
c1: am 1 ;19 - file cannot be looked up
c2: am 1 ;18 - file does not exist
c3: am 1 ;17 - file cannot be removed
c4: am 1 ;16 - file cannot be changed
c5: al w1 15 ;15 - - - - connected for i/o
rl. w2 b0.+4 ;
rl w3 x2+4 ; w3 := add of rt error
;ks-819
rs. w3 b0.+4 ;
rl w2 x2+8 ; w2 := stacktop
rl. w3 b0.+6 ; w3 := add where error occurred
al w0 -1 ;
;ks-820
jl. (b0.+4); jump to rt error
; normal return
i7: rl. w2 b0.+4 ;
rl w2 x2+8 ; w2 := stacktop
jl. (b0.+6); return
e.
\f
; segment 7-8
; pascal i/o
; write routines for text files
b. a45,b15,c22, i5, d15 w.
0,r.(:3586-k:)>1
jl. i0. ;+0 write real
jl. i0. ;+2 write integer, boolean, char, string
; this is the common part for all write routines (text).
; registers at call :
; w0 - argument or add of argument
; w1 - zone desc add
; w2 - procedure table add
; w3 - return - 4
; +0 5<12 + relative
; +2 m<12 + n/relative1
;
; if the relative add is odd, the call is writeln = write, outchar(nl)
; instead of write
d0: 0,r.4 ; saved registers
d1: 0 ; process start
d2: 0 ; write (0)/writeln(1)
i0: ds. w3 d0.+6 ;
rl w2 66 ;
rl w2 x2+22 ; w2 := process start
rs. w2 d1. ; process start
ds. w1 d0.+2 ;
bl w2 x1+h2+6 ; w2 := zonestate;
se w2 s3 ; if zonestate <> after write text then
jl. d12. ; error (illegal zonestate);
bl w1 x3+1 ;
al w2 1 ;
la w2 2 ; if writeln then
rs. w2 d2. ; d2 := 1 else d2 := 0
bl w1 x3+1 ; w1 := rel entry add
jl. x1+2 ;
jl. i1. ; write real
jl. i2. ; write integer etc.
; at exit registers contain :
; w0 - argument or add of argument
; w3 - return-4
\f
; write real.
;
; call parameters :
; w0 - add of argument (first word)
; w3 - return-4, pointing to
; +0 5<12 + 0 or 1
; +2 m<12 + n
;
; if m,n is not specified , the default value 14<12 + 0
; must be present.
;
;
; the format is as follows :
; bit meaning
; 0
; 1-5 no of significant digits (b)
; 6-9 - - digits before point (h)
; 10-13 - - - after - (d)
; 14-15 not used (pn)
; 16-17 sign of number (01) (fn)
; 18-19 no of digits in exponent (s)
; 20-21 first letter of exponent part (pe)
; 22-23 sign of exponent (fe)
;
; the format is packed as follows :
; m:=m-2 (one space for . , and one for sign)
; if n<>0 then
; m<18 + (m-n)<14 + n<10 + 1<6
; if n = 0 then
; (m-4)<18 + 1<14 + (m-5)<10 + 1<6 + 3<4 + 3<2 + 2
;
b. c10 w.
1<23
c0: 0 ; layout words
c2: 1<6 + 3<4 +2<2 +2 ; part of layout
c3: 1<6 ; - - -
c7: 2 ; constant
c8: 4 ;
i1: bl w0 x3+2 ; w0 := m
sh w0 -1 ; if m < 0 then
jl. d13. ; error(negative field width)
sh w0 14 ; if m > 15 then
jl. c1. ; begin
rl w2 0 ; w2 := m
rl. w1 d0.+2 ; w1 := zone desc
al w2 x2-14 ;
jl. w3 d10. ; outspace
al w0 14 ;
rl. w3 d0.+6 ;
c1: ; end
ws. w0 c7. ; m:=m-2
bl w1 x3+3 ; w1 := n
al w2 1 ;
sn w1 0 ; if n<> 0 then
jl. c4. ;
rl w2 0 ;
ws w2 2 ; w2 := m-n
jl. c5. ; else w2 := 2
c4: rl w1 0 ; if n<>0 then w1 := n
al w1 x1-5 ; else w1 := n-5
ws. w0 c8. ; m := m - 4
c5:
ls w0 18 ;
ls w2 14 ;
ls w1 10 ;
lo w0 2 ;
lo w0 4 ; w0 := w0<18 + w2<14 + w1<10
rl. w3 d0.+6 ;
bl w3 x3+3 ;
sn w3 0 ; if n=0 then
lo. w0 c2. ; add exponent part
se w3 0 ; else no exponent
lo. w0 c3. ;
rs. w0 c0. ;
rl. w1 d0. ;
dl w1 x1+2 ; load argument
al. w2 c0. ; load abs add of format
jl. w3 a44. ; goto write real
jl. d11. ; return
e.
; output character
b. e0 w.
e0: 0
a14: rl. w1 d0.+2 ; w1 := zone desc add
rs. w3 e0. ; store return
am. (d1.) ;
jl w3 h26 ; outchar
jl. (e0.) ; return
e.
h.
2048, 0
a26: 0, 0 ; -1 floating
1024, 0
a34: 0, 1 ; 1.0
1280, 0
0, 4 ; 10**1
1600, 0
0, 7 ; 10**2
1250, 0
0, 14 ; 10**4
1525,3600
0, 27 ; 10**8
1136,3556
3576, 54 ; 10**16
1262, 726
3393, 107 ; 10**32
1555,3087
2640, 213 ; 10*64
1181,3363
3660, 426 ; 10**128
1363,3957
4061, 851 ; 10**256
1816,3280
1397,1701 ; 10**512
a0:h.
32; sp
48; 0
43; +
45; -
46; .
39; '
w.
0 ; w2 for write real - w3 for write signed word
a1:
0; return for write real (w3)
0; +2 point buf
0; +4 unpack buf
0; +6 start buf
0,0; +8 layout
0; +12 first digit buffer
a8: 10;constant
5; +2 constant
a2:0, r. 15;buffer
a5: rs. w3 a1. -2 ; write signed integer word
ds. w1 a2. +2
al w3 0
hs. w3 a23.
a24: dl w2 x2 ; w1,w2:= layout
ls w1 -1
ds. w2 a1. +10
dl. w1 a2. +2
se w3 0
jl. a22.
sz w2 3<6
bz. w3 a0.
lo w1 0
sn w1 0
jl. a12.
sz w2 2<6
bz. w3 a0. +2
a22: am 301
a12: al w1 -300
so w2 1<8
al w1 300
so w2 2<8
al w1 1
rs. w1 a1. +12
sl w0 0
jl. a20.
ld w1 48
ss. w1 a2. +2
ds. w1 a2. +2
bz. w3 a0. +3
a20: hs. w3 a19.
ld w3 -18
ac w2 x2
hs. w2 a18.
al w2 0
ld w3 4
ls w3 -20
al. w3 x3 a2. -1
rs. w3 a1. +2
wa w2 6
rs. w2 a1. +6
wa. w3 a1. +12
rs. w3 a1. +12
a13: rl. w1 a1. +8
ls w1 1
rs. w1 a1. +8
al. w3 a13.
bz. w2 a0.
sh w1 -1
jl. a14. ; output character
al. w1 a2. +29
dl. w0 a2. +2
a7: sh. w1 (a1. +12)
bz. w2 a0. +1
hs w2 x1
al w1 x1 -1
sl. w1 a2.
jl. a7.
a23=k+1
al w1 x1
jl. a9.
a10: al w2 0
wd. w3 a8. +2
rx w2 6
wd. w0 a8.
al w1 x1 1
ba. w3 a0. +1
hs w3 x1
rs w2 6
ls w0 1
ld w0 -1
a9: sn w0 0
se w3 0
jl. a10.
sh. w1 a2. -1
rl. w1 a1. +2
rs. w1 a1. +4
a18=k+1
al w1 x1
bz. w2 a0. +1
a16: sh. w1 a2. -1
jl. a21.
sh. w1 (a1. +2)
bz. w2 a0.
hs w2 x1
al w1 x1 -1
jl. a16.
a21: dl. w3 a1. +8
ws. w2 a1. +4
ls w3 x2
rl. w2 a1. +4
sl. w2 (a1. +6)
ds. w3 a1. +8
rl. w2 a1. +10
so w2 3<8
am 3<8
sz w2 0
jl. w3 a4.
rl.w0 a1. +6
a11:se. w0 (a1. +12)
sn. w0 (a1. +4)
jl. w3 a4.
rl. w2 a1. +8
a15: ld w2 1
rs. w2 a1. +8
bz. w2 a0.
sz w1 1
jl. w3 a14. ; output character
sh. w0 a2. -1
jl. (a1. -2)
bz w3 (0)
bz. w2 a0.
bz. w2 a0. +4
sn. w0 (a1. +2)
jl. w3 a14. ; output character
bz w2 (0)
jl. w3 a14. ; output character
bs. w0 a15. +1
jl. a11.
a4: al w2
a19 = a4 +1
sn w2 0
jl x3
al w1 0
hs. w1 a4. +1
jl. a14. ; output character
h.
-1000, -100
a33: -10, -1 ; exp limits
-1, -1
a30: -1, -1 ; rounding constant, no-sign exp limit
w.
a44: ds. w3 a1. ; write real
sl w0 0
jl. a25.
fm. w1 a26.
am. (a0. +2)
a25: al w3 0
hs. w3 a27.
so. w0 (a34. -2)
jl. a35.
ds. w1 a2. +2
bz w2 x2
a28: sl w2 13<6 -1
la. w2 a28.
hs. w2 (a1. -2)
ld w3 -6
ls w3 -20
ws w3 4
rl. w1 (a1. -2)
ls w1 10
ls w1 -20
wa w3 2
sl w3 0
am x3
al w3 1
rs. w3 a2. +16
dl. w0 a2. +2
a39: hs w0 2
sh w1 -1
jl. a38.
al w1 x1 128
fd. w0 a34. +32
jl. a39.
a38: hs. w1 a29.
ds. w0 a2. +10
rl. w3 (a1. -2)
dl. w1 a30.
sz w3 3
dl. w1 a33.
sz w3 2<4
ld w1 -24
sz w3 1<4
ld w1 -12
hs. w1 a31.
al. w3 a34.
dl w1 x3
a36: al w3 x3 4
sz w2 1
fm w1 x3
ls w2 -1
sl w2 1
jl. a36.
jl. w3 a37.
ds. w1 a2. +6
al w3 9
a40: dl. w1 a2. +10
ls w3 2
fm. w1 x3 a34. +4
ds. w1 a2. +14
ls w3 -2
sl w3 10
al. w3 a6.
a37: bl w2 3
sh w2 40
ld w1 x2 -46
ss. w1 a30.
ld w1 -1
sl w3 10
jl x3
ss. w1 a2. +6
al w2 -1
ls w2 x3
a29=k+1
al w2 x2
sh w0 -1
a31=k+1
sh w2
jl. a32.
dl. w1 a2. +14
ds. w1 a2. +10
hs. w2 a29.
a32: al w3 x3 -1
jl. a40.
a6: ds. w1 a2. +2
lo w0 2
sn w0 0
jl. a35.
rl. w3 a2. +16
ls w3 10
ba. w3 a29.
al w2 0
wd. w3 a2. +16
bl. w1 a29.
ws w1 4
bl. w3 a31.
sl w1 x3 +1
jl. a42.
al w1 x3 1
ac w2 x3 1
ba. w2 a29.
jl. a42.
a35: ld w2 48
ds. w2 a2. +2
a42: hs. w1 a29.
hs. w2 a23.
dl. w3 a1.
rl w0 x2
sn w1 0
sz w0 3<4+1
al. w3 a43.
rs. w3 a1. -2
a27=k+1
al w3
jl. a24.
a43: rl. w0 a1. +10
bl. w3 a29.
bz. w2 a0.
sn w3 0
so w0 3<2
bz. w2 a0. +5
jl. w3 a14. ; output character
al. w2 a1. +10
rl w0 x2
ls w0 18
al w3 15<2
ld w0 2
ls w3 4
ld w0 10
rs w3 x2
bl. w1 a29.
rl. w3 a1.
sl w1 0 ; write signed word
am 1 ;
al w0 -1 ;
jl. a5. ;
\f
; this is the write routines for
; integer, boolean, string, character, the proc put and writeln.
; the call is as follows :
; +0 segm<12 + 2 or 3
; +2 m <12 + relative
;
; where relative is :
; +2 integer, +4 boolean, +6 char,
; +8 string , +10 put , +12 writeln (without parameters)
;
; if m is not used the default value must be used
; common code for all procedures
i2: bl w2 x3+2 ; w2 := m
sh w2 -1 ; if m < 0 then
jl. d13. ; error(negative field width)
bl w3 x3+3 ; w3 := relative
rl. w1 d0.+2 ; w1 := zone desc
jl. x3 ;
jl. d5. ; write integer
jl. d6. ; - boolean
jl. d7. ; - character
jl. d8. ; - string
jl. d9. ; put(filebuffer)
jl. d11. ; writeln (without parameters)
; at exit to each procedure
; w0 - argument
; w1 - zone desc
; w2 - m
; write integer
b. a2 w.
1<23 + 32<12 + 0-0-0 ; layout for negative numbers
a2: 0<23 + 32<12 + 0-0-0 ; layout for positive numbers
d5: sh w2 12 ; if m > 12 then
jl. a0. ; begin
al w2 x2-12 ; m:=m-12
jl. w3 d10. ; outspace
al w2 12 ; m:=12
rl. w0 d0. ; w0 := argument
a0: ; end
sh w0 -1 ; if number < 0 then
am -2 ; layout := <<-d>
wa. w2 a2. ; else
rs. w2 a1. ; layout := <<d>;
am. (d1.) ;
jl w3 h32 ; outinteger
a1: 1<23 + 32<12 + 0 ;
jl. d11. ; return
e.
; write boolean
b. a2 w.
a1: <:false<0>:>
a2: <:true<0>:>
d6: al w2 x2-4 ; if true then m := m-4
sn w0 0 ; else m := m-5
al w2 x2-1 ;
jl. w3 d10. ; outspace(m-4/m-5)
rl. w2 d0. ; w2 := false(0) / true(1)
al. w0 a2. ;
sn w2 0 ;
al. w0 a1. ;
am. (d1.) ;
jl w3 h31 ; outtext(true/false)
jl. d11. ; return
e.
; write character
b. w.
d7: al w2 x2-1 ;
jl. w3 d10. ; outspace
rl. w2 d0. ;
am. (d1.) ;
jl w3 h26 ; outchar
jl. d11. ; return
e.
; write string
; call :
; w0 - start add of string
; w1 - zone desc
; w2 - m (total length)
; return + 4 - length of string in characters
;
; algorithm :
; if m > length then outspace(m-length)
; i := length mod 3
; j := length div 3
; x := word(w0+2*j)
; if i=0 then x := <0><0><0>
; if i=1 then x := x la 11111111 <0> <0>
; if i=2 then x := x la 1111111111111111 <0>
; word(w0+2*j) := x
; outtext
; restore word(w0+2*j)
;
b. a5 w.
a0: 0,0 ; stored registers
a2: 3 ; const
a3: 0 ; temp word
a4: 2.111111110000000000000000 ; mask 1
a5: 2.111111111111111100000000 ; mask 2
d8: ds. w1 a0.+2 ; save registers
rl. w3 d0.+6 ; w3 := return add
sh w2 (x3+4) ; if m > length then
jl. a1. ; begin
ws w2 x3+4 ; m := m-length
jl. w3 d10. ; outspace(m)
rl. w2 d0.+6 ;
rl w2 x2+4 ; w2 := length
a1: ; end
al w1 0 ;
wd. w2 a2. ; w1 := length mod 3
ls w2 1 ; w2 := length in halfwords
wa. w2 a0. ; w2 := add of word where <0> is to be inserted
rl w3 x2 ;
rs. w3 a3. ; save word
sn w1 0 ; if rest = 0 then w0 := 0
al w0 0 ;
sn w1 1 ; if rest=1 then w0:= mask1
rl. w0 a4. ;
sn w1 2 ; if rest = 2 then w0 := mask2
rl. w0 a5. ;
la w0 x2 ; insert <0> in the right place
rs w0 x2 ;
dl. w1 a0.+2 ; w0 := start add of string
am. (d1.) ; w1 := zone desc add
jl w3 h31 ; outtext
rl. w0 a3. ;
rs w0 x2 ;
rl. w3 d0.+6 ;
al w3 x3+2 ;
rs. w3 d0.+6 ;
jl. d11. ; return
e.
; put(filebuffer)
b. w.
d9: rl w2 x1+h4+4 ; w2 := filebuffer
am. (d1.) ;
jl w3 h26 ; outchar
jl. d11. ; return
e.
; outspace (help procedure)
; call :
; w1 - zone desc
; w2 - m
; w3 - return
; function of procedure :
; while m > 0 do
; begin outchar(sp); m:=m-1
; end
b. a2 w.
a1: 0,r.2
d10: ds. w3 a1.+2 ;
a2: al w2 32 ; char := sp
rl. w0 a1. ; w0 := m
sh w0 0 ; while m > 0 do
jl. (a1.+2) ; begin
am. (d1.) ;
jl w3 h26 ; outchar(sp)
rl. w2 a1. ;
al w2 x2-1 ; m:=m-1
rs. w2 a1. ;
jl. a2. ; end
e.
; return
b. a0 w.
d11: rl. w0 d2. ;
sn w0 0 ; if writeln then
jl. a0. ; begin
al w2 10 ;
rl. w1 d0.+2 ; zone desc
am. (d1.) ;
jl w3 h33 ; outend(nl)
a0: ; end
dl. w3 d0.+6 ;
rl w2 x2+8 ; reestablish stacktop
jl x3+4 ; return
e.
; error return
d13: am 7-13 ; alarm 7 - negative field width
d12: al w1 13 ; alarm 13 - illegal zonestate
rl. w2 d0.+4 ;
rl w3 x2+4 ; w3 := add of rt error
rs. w3 d0.+4 ;
rl w2 x2+8 ; w2 := stacktop
rl. w3 d0.+6 ; w3 := add where error occurred
al w0 -1 ;
jl. (d0.+4) ; jump to error return
e.
\f
; segment 9-10
; read and get (textfiles)
; the read procedure always takes the first character from the filebuffer.
;
; call of read and get :
; w0 - add of var to return read 'item' in (if real then first word)
; w1 - zone desc
; w3 - return -2
;
; call code :
; jl (x2-2035)
; 6<12 + relative
; relative :
; +0 read iso +1 readline iso
; +2 get
; +4 read char +5 readline char
; +6 read integer +7 readline integer
; +8 read real +9 readline real
; +11 readline (without parameters)
;
; return : the item read in word(w0) (if real then word(w0) and word(w0+2))
;
; used globals
; z+h4+0 - eof (true=1/false=0)
; z+h4+1 - eoln
; z+h4+4 - filebuf
b. b3, g10, i15 w.
0,r.(:512*9+2-k:)>1
jl. i10. ;
jl. i10. ;
jl. i10. ;
jl. i10. ;
jl. i10. ;
jl. i10. ;
b0: 0,r.4 ; saved registers
b1: 0 ; process start
b2: 0 ; readline (1)/ read (0)
i10: ds. w3 b0.+6 ; save w2,w3
rl w2 66 ;
rl w2 x2+22 ;
rs. w2 b1. ; save process start
ds. w1 b0.+2 ; save w0,w1
bl w2 x1+h2+6 ; w2 := zonestate;
se w2 s1 ; if zonestate <> after read char then
jl. g5. ; error (illegal zonestate);
bz w2 x1+h4+0 ;
sn w2 1 ; if eof then
jl. g1. ; runtime error(try to read past eof)
bl w3 x3+1 ;
al w2 1 ;
la w2 6 ; if read line then
rs. w2 b2. ; b2 :=1 else b2:= 0
rl w2 x1+h4+4 ; w2 := filebuf;
jl. x3+2 ;
jl. i1. ; read-iso
jl. i2. ; get
jl. i3. ; read-char
jl. i4. ; read-integer
jl. i5. ; read-real
jl. i6. ; readln (without parameters)
; registers at exit to the procedures
; w0 - add of var to read to
; w1 - zone desc add
; w2 = filebuf
; read character
i3: ;
se w2 10 ;
sn w2 12 ; if char = newline or char = formfeed then
al w2 32 ; char := space;
sl w2 32 ; if char outside legal range then
sl w2 128 ;
jl. g4. ; goto index-alarm;
; read iso
i1: ;
rs. w2 (b0.) ; var := filebuffer;
jl. i2. ; goto get next char;
\f
; read integer/ read real (text)
;
; variables
; f - global for both integer and real
; c - actions
; v - states
b. f5, c40, r40 w.
f1: 0 ; current state
; character set table
f0: h.
16,10,10,10,10,10,10,10,10,10,10,10,10,16,10 ; 0-14
10,10,10,10,10,10,10,10,10,10,14,10,10,10,10 ; 15-29
10,10,12,10,10,4 ,10,10,10,8,10,10,10, 2,10 ; 30-44
0, 4,10,6,6,6,6,6,6,6,6,6,6,10,10 ; 45-59
10,10,10,10,10,8,8,8,8,8,8,10,10,10,10 ; 60-74
10,10,10,10,10,10,10,10,10,10,10,10,10,10,10 ; 75-89
10,10,10,10,10,10,10,8,8,8,8,8,8,10,10 ; 90-104
10,10,10,10,10,10,10,10,10,10,10,10,10,10,10 ; 105-119
10,10,10,10,10,10,10,16 ; 120-127
w.
; note that # and . are classified equal, this means
; that # and . may replace each other.
; read character and choose action
c0: ;
am. (b1.) ;
jl w3 +h25 ; read char;
rs w2 x1+h4+4 ; filebuf := char;
sl w2 128 ; if illegal char then
al w2 0 ; char := null;
f3: bl. w3 x2+f0. ; w3 := char type
am. (f1.) ;
f4: rl. w3 x3 ;
hs. w3 f1.+1 ; store new state
bl w3 6 ;
f2: jl. x3 ; goto action
; error return
g5: am 13-23 ; 13 - illegal zonestate:
g0: am 23-22 ; 23 - integer overflow
g1: am 22-21 ; 22 - try to read past eof
g2: am 21-20 ; 21 - digit expected
g3: am 20-2 ; 20 - b,o or h expected
g4: al w1 2 ; 2 - index alarm
rl. w2 b0.+4 ;
rl w3 x2+4 ;
rs. w3 b0.+4 ;
rl w2 x2+8 ; w2 := stacktop
rl. w3 b0.+6 ; w3 := error add
al w0 -1 ;
jl. (b0.+4) ; jump to rt error
\f
; read integer
; the integer obeys the following syntax :
; (+/-) (spaces) (#b/#o/#h) ((digit))
; the reading is performed as a state/action table
; variables
; r - states
; d - global var
; a - local var
b. d10 w.
d2: 0 ; sign
d3: 0 ; base
; actions :
; c0 - chose action on basis of char and state
; c1 - sign
; c2 - chose base <> 10
; c3 - int := int * base + ch - cst
; c4 - terminate
; g2,g3 - error
; init code
i4: al w0 1 ;
rs. w0 d2. ; sign := plus
al w0 10 ;
rs. w0 d3. ; base := 10
hs. w0 d4. ;
al w0 r0 ;
rs. w0 f1. ; state := r0
al w0 0 ; integer := 0;
jl. f3. ; goto start
; sign
c1: al w3 -1 ;
rs. w3 d2. ; sign := -1
jl. c0. ; goto next action
; recalculate base and digit
b. a2 w.
c2: sl w2 97 ; if small letter then convert to capital;
al w2 x2-32 ;
se w2 98-32 ; if b then
jl. a0. ; begin (* binary *)
al w2 2 ; base := 2
jl. a2. ; end
a0: se w2 111-32; if o then
jl. a1. ; begin (* octal *)
al w2 8 ; base:=8
jl. a2. ; end
a1: se w2 104-32; if h then
jl. g3. ; begin (* hexadecimal *)
al w2 16 ; base := 16
a2: rs. w2 d3. ; end else error(b,o or h expected)
hs. w2 d4. ;
jl. c0. ; goto next action
e.
; calculate next digit of integer
; algorithm :
; if ch > digit (2,7,9,f) then error
; cst := 48
; if ch > 'a' then cst := 87
; int := int*base + ch -cst
; if int > maxint then overflow
c5: ; hexadecimal digit (or exponent mark)
sh w2 64 ; if not letter then
jl. c4. ; goto end of integer;
sh w2 96 ; if capital letter then
am -55+87 ; w2 := capital letter - 55
am -87+48 ; else w2 := small letter - 87
; otherwise
c3: ; digit:
al w2 x2-48 ; w2 := digit - 48;
sl w2 0-0-0 ; if w2 >= base then
d4 = k-1 ; base
jl. g2. ; error (read integer);
wm. w0 d3. ; integer * base
wa w0 4 ; + ch
se w3 0 ; if w3 <> 0 then
jl. g0. ; error(overflow)
jl. c0. ; goto next action
; end of integer
c4: ;
wm. w0 d2. ;
rs. w0 (b0.) ; var := read integer
jl. i6. ; return
; state action table
h.
; 0 2 4 6 8 10 12 14 16
; - + # 0..9 a..f others sp em blinds
r0=k-f4
c1-f2,r1, c0-f2,r1, c0-f2,r2, c3-f2,r3, c0-f2,r0, c0-f2,r0, c0-f2,r0, g1-f2,r4, c0-f2,r0 ;
r1=k-f4
g2-f2,r0, g2-f2,r0, c0-f2,r2, c3-f2,r3, g2-f2,r0, g2-f2,r0, c0-f2,r1, g1-f2,r4, c0-f2,r1 ;
r2=k-f4
g3-f2,r0, g3-f2,r0, g3-f2,r0, g3-f2,r0, c2-f2,r3, c2-f2,r3, g3-f2,r0, g1-f2,r4, c0-f2,r2 ; b,o or h expected
r3=k-f4
c4-f2,r4, c4-f2,r4, c4-f2,r4, c3-f2,r3, c5-f2,r3, c4-f2,r4, c4-f2,r4, c4-f2,r4, c0-f2,r3 ; int:=int*base+ch-cst
r4=k-f4
w.
e.
\f
; read real
; a real obeys the following scheme :
; (+/-) unsigned int (.) ((digit)) (e) (+/-) unsigned int
;
; this is implemented by a state action table
; where
; r's are states
; c's are actions
;
; the actions are
; c0 - next char and action
; c21 - sign of number part
; c22 - number := number*10+ch-48
; c23 - fraction := fraction * 10 + ch - 48
; s:=s/10
; c24 - scale factor:= scale factor*10 + ch - 48
; c25 - sign of scale factor
; c26 - finish action
b. e10 w.
e0: 0 ; sign of number
e1: 0,0 ; number (floating)
e2: 0,0 ; fraction part (floating)
e3: 0 ; scale factor
e4: 0 ; sign of scale
e6: 8388607 ; max integer
h.
e5: 1280, 0 ;
0 , 4 ; floating 10
e7: 1638,1638 ;
1638, -3 ; floating 0.1
w.
e8: 0,0 ; used in fraction part (1.0)
; init
i5: al w0 1 ;
rs. w0 e0. ; sign := 'plus'
rs. w0 e4. ; sign of scale := 'plus'
al w0 0 ;
rs. w0 e2. ; fraction part := 0
rs. w0 e1. ; number := 0
rs. w0 e3. ; scale factor := 0
al w0 1 ;
ci w0 0 ;
ds. w0 e8.+2 ; fraction const := 1.
al w0 r20 ;
rs. w0 f1. ; set state to start
jl. f3. ; goto start
; sign
c21: al w0 -1 ;
rs. w0 e0. ; sign of number := -
jl. c0. ; goto next action
; number part
; nb ! no check on integer overflow
b. a0 w.
a0: 10 ;
c22: rl. w0 e1. ;
wm. w0 a0. ; number * 10
al w2 x2-48 ; ch-48
wa w0 4 ;
rs. w0 e1. ; number :=
jl. c0. ; goto next action
; fraction
; algorithm :
; if fraction > maxint then skip
; fraction := fraction * 10 + ch -48
; s:= s * 0.1
c23: rl. w0 e2. ;
sl. w0 (e6.) ; if fraction > maxint then
jl. c0. ; goto next action
wm. w0 a0. ; fraction * 10
al w2 x2-48 ;
wa w0 4 ; + (ch-48)
rs. w0 e2. ; fraction :=
dl. w0 e8.+2 ; w0,w1 := 0.1
fm. w0 e7.+2 ;
ds. w0 e8.+2 ; s := s*0.1
jl. c0. ; goto next action
; scale factor
c24: rl. w0 e3. ;
wm. w0 a0. ; scale factor * 10
al w2 x2-48 ;
wa w0 4 ; +ch - 48
rs. w0 e3. ; scale factor :=
jl. c0. ; goto next action
e.
; sign of scale factor
c25: al w0 -1 ;
rs. w0 e4. ; sign of scale factor := -1
jl. c0. ; goto next action
; finish action
; algorithm :
; filebuffer := ch
; number := (number + fraction part) ** 10 sign*scalefactor
b. a3 w.
a0: 0,0 ;
c26: ;
rl. w2 e4. ; w2 := sign of scale
dl. w0 e5.+2 ; w0,w3 := 10.
sn w2 -1 ;
dl. w0 e7.+2 ; scaling := 10. or .1
ds. w0 a0.+2 ;
rl. w0 e2. ; w0 := fraction
ci w0 0 ; convert fraction to real
fm. w0 e8.+2 ;
ds. w0 e2.+2 ; fraction := fraction * s
rl. w0 e1. ; w0 := number
ci w0 0 ; convert number part to real
fa. w0 e2.+2 ; number + fraction part
rl. w2 e3. ; w2 := scale factor
a1: sh w2 0 ; while scale > 0 do
jl. a2. ; begin
fm. w0 a0.+2 ; number := number **10*sign
al w2 x2-1 ;
jl. a1. ; end
a2: ds. w0 e1.+2 ;
rl. w0 e0. ; w0 := sign of number
ci w0 0 ;
fm. w0 e1.+2 ;
rl. w2 b0. ;
ds w0 x2+2 ; store result in variable
jl. i6. ; goto return
e.
; return
b. a3 w.
i6: ; terminate after read integer - read real:
rl w2 x1+h4+4 ; w2 := last char;
jl. a0. ; goto examine;
i2: ; get next char:
am. (b1.) ;
jl w3 +h25 ; read char;
a0: ; examine:
rl. w0 b2. ; w0 := readline-flag;
sn w0 0 ; if readline then
jl. a2. ; begin
al w0 0 ; (prepare reset of readline-flag)
sn w2 25 ; if char = em then
rs. w0 b2. ; readline-flag := 0;
se w2 10 ; if char = newline
sn w2 12 ; or char = form feed then
rs. w0 b2. ; readline flag := 0;
jl. i2. ; goto get next char;
a2: ; end;
; w0 = 0
; w1 = zone
; w2 = last char
hs w0 x1+h4+1 ; eoln := false;
rs w2 x1+h4+4 ; filebuf := last char;
sl w2 32 ; if last char is graphic then
sl w2 128 ;
jl. a3. ;
jl. a1. ; goto return;
a3: ; non-graphic:
al w0 1 ;
se w2 10 ; if last char = newline
sn w2 12 ; or last char = form feed then
hs w0 x1+h4+1 ; eoln := true;
sn w2 25 ; if last char = em then
hs w0 x1+h4+1 ; eoln := true;
sn w2 25 ; if last char = em then
hs w0 x1+h4+0 ; eof := true;
bl w0 x1+h2+7 ; w0 := filetype;
se w0 1 ; if filetype <> text then
jl. a1. ; goto return;
se w2 10 ; if last char = newline or
sn w2 25 ; last char = em then
jl. a1. ; goto return;
se w2 12 ; if last char = ff then goto return;
jl. i2. ; goto get next char;
a1: dl. w3 b0.+6 ;
rl w2 x2+8 ; reestablish stack
jl x3+2 ; return
e.
; state action table
; 0 2 4 6 8 10 12 14 16
; - + . 0..9 ' others sp em blinds
h.
r20=k-f4
c21-f2,r21, c0-f2 ,r21, c0-f2 ,r20, c22-f2,r22, c0-f2 ,r20, c0-f2 ,r20, c0-f2 ,r20, g1-f2,r20, c0-f2,r20; skip until +,-,0..9
r21=k-f4
g2-f2 ,r20, g2-f2 ,r20, g2-f2 ,r20, c22-f2,r22, g2-f2 ,r20, g2-f2 ,r20, c0-f2 ,r21, g1-f2,r20, c0-f2,r21; sign of number part
r22=k-f4
c26-f2,r27, c26-f2,r27, c0-f2 ,r23, c22-f2,r22, c0-f2 ,r24, c26-f2,r27, c26-f2,r27, c26-f2,r27, c0-f2,r22; number part
r23=k-f4
c26-f2,r27, c26-f2,r27, c26-f2,r27, c23-f2,r23, c0-f2 ,r24, c26-f2,r27, c26-f2,r27, g1-f2,r20, c0-f2,r23; fraction part
r24=k-f4
c25-f2,r25, c0-f2 ,r25, g2-f2 ,r20, c24-f2,r26, g2-f2 ,r20, g2-f2 ,r20, c0-f2 ,r24, g1-f2,r20, c0-f2,r24; sign of scale factor
r25=k-f4
g2-f2 ,r20, g2-f2 ,r20, g2-f2 ,r20, c24-f2,r26, g2-f2 ,r20, g2-f2 ,r20, c0-f2 ,r25, g1-f2,r20, c0-f2,r25; scale factor
r26=k-f4
c26-f2,r27, c26-f2,r27, c26-f2,r27, c24-f2,r26, c26-f2,r27, c26-f2,r27, c26-f2,r27, g1-f2,r20, c0-f2,r26; scale factor and finish
r27=k-f4
w.
e. ; end read real
e. ; end segment;
e.
\f
; segment 11
b. f5,c1 w.
0,r.(:5634-k:)>1
jl. f4. ;
jl. f4. ;
jl. f4. ;
c0: 0,r.4
f4: al w3 x3+2 ;
ds. w3 c0.+6 ; save registers
ds. w1 c0.+2 ;
bl w2 x3-1 ;
jl. x2+2 ;
jl. f1. ;+0 read/write binary
jl. f2. ;+2 pack
jl. f3. ;+4 unpack
; at exit to each procedure the registers are untouched
; except for w2
\f
; read / write binary file
; the procedure transfers a number of halfwords (to) from
; a zone buffer to (from) a variable.
;
; the procedures include both read/write and get/put because get and put
; are special cases of read/write where w0 points to the filebuffer
; situated immediately after the data buffer.
;
; call :
; w0 - start add of var to read to/write from
; w1 - zone description
; w3 - return-4 :
; +0 7<12 + 0 (read)/ 1 (write)
; +2 no of halfwords to read/write (length)
;
; the following globals are used :
; z+h2+6 (halfword): zonestate
; z+h3+0 (word) : record base
; z+h3+2 (word) : last byte
; (z+h3+4 (word) : record length) (not used yet)
; z+h4+0 (halfword): eof
; z+h4+2 (word) : length of file (in halfwords)
; (z+h4+4 (word) : file buffer addr)
;
; algorithm:
; length of file := if input then length - recsize
; else length + recsize
; if length = 0 then eof := true;
; rep:
; for zonesize := lastbyte - recbase while zonesize = 0 do
; inblock (or outblock);
; if recsize = 0 then return;
; size := minimum (zonesize, recsize);
; move 'size' halfwords between zone and record;
; recsize := recsize - size;
; recbase := recbase + size;
; goto rep;
;
; notice: the algorithm will always ensure room in the buffer for
; at least one word
b. a20, i10 w.
i1: 0 ; remaining halfwords to move
i2: 0 ; top fromptr
f1: ; binary read-write:
; w0 = record addr
; w1 = zone
; w2 = rel entry (0==read, 1==write)
; w3 = return-2
rl w3 x3 ; remaining := recsize param;
rs. w3 i1. ;
bl w0 x1+h2+6 ; w0 := zonestate;
se w2 0 ; if
am s6-s5 ; (write and zonestate <> after write binary)
se w0 s5 ; or (read and zonestate <> after read binary) then
jl. a11. ; error (illegal zonestate);
sn w0 s5 ; if after read binary then
ac w3 x3 ; remaining filelength := filelength - recsize
wa w3 x1+h4+2 ; else
rs w3 x1+h4+2 ; remaining filelength := filelength + recsize;
se w0 s5 ; if after write binary then
jl. a1. ; goto test zone size;
rl. w0 i1. ; w0 := recsize; (* prepare moving of filebuffer *)
sl w3 0 ; if remaining file length < 0 then
jl. a0. ; begin
bl w3 x1+h4+0 ; w3 := eofflag;
se w3 0 ; if eof then
jl. a12. ; error (try to read past eof);
rs. w3 i1. ; recsize := 0; (* don't read to filebuffer *)
al w3 1 ; eof := true;
hs w3 x1+h4+0 ;
a0: ; end;
; move filebuffer to read-record
; w0 = original recsize
rl w3 x1+h4+4 ; w3 := from-address := addr of file buffer;
rl. w2 c0. ; w2 := to-address := addr of record;
rs. w3 c0. ; (addr of record := filebuffer)
se w2 x3 ; if not 'get' then
jl. a4. ; goto move;
a1: ; test zone size:
rl w0 x1+h3+2 ; zonesize := lastbyte
ws w0 x1+h3+0 ; - recbase;
se w0 0 ; if zonesize = 0 then
jl. a2. ; begin
rl w2 66 ;
rl w2 x2+22 ;
bl w0 x1+h2+6 ; if zonestate = after write binary then
sn w0 s6 ;
am h23-h22; outblock (zone)
jl w3 x2+h22 ; else inblock (zone);
jl. a1. ; goto test zone size;
a2: ; end;
rl. w3 i1. ; w3 := remaining recsize;
sh w3 0 ; if remaining <= 0 then
jl. a10. ; goto return;
; w0 = zonesize
; w1 = zone addr
; w3 = remaining recsize
sl w0 x3 ; size := minimum (zonesize, recsize);
al w0 x3 ;
ws w3 0 ; remaining recsize := remaining recsize
rs. w3 i1. ; - size;
rl w2 x1+h3+0 ; recbase :=
wa w2 0 ; recbase + size;
rx w2 x1+h3+0 ; zonefirst := old recbase + 1;
al w2 x2+1 ;
rl. w3 c0. ; recordptr :=
wa w3 0 ; recordptr + size;
rx. w3 c0. ; recfirst := old recordptr;
; w0 = number of halfwords to move
; w1 = zone addr
; w2 = zonefirst
; w3 = recfirst
bl w1 x1+h2+6 ;
sn w1 s5 ; if zonestate = after read binary then
rx w3 4 ; exchange (zonefirst, recfirst);
a4: ; move:
; w0 = number of halfwords to move
; w2 = to-address
; w3 = from-address
so w0 2.10 ; if odd number of words to move then
jl. a5. ; begin
rl w1 x3 ;
rs w1 x2 ; move one word;
al w2 x2+2 ; increase (to-address);
al w3 x3+2 ; increase (from-address);
bs. w0 -1;note ; decrease (number of halfwords);
a5: ; end;
wa w0 6 ;
rs. w0 i2. ; top fromptr := from-address + no of halfwords;
jl. a7. ; goto test;
a6: ; move double:
dl w1 x3+2 ;
ds w1 x2+2 ; move two words;
al w2 x2+4 ; increase (to-address);
al w3 x3+4 ; increase (from-address);
a7: ; test:
se. w3 (i2.) ; if from-address <> top fromptr then
jl. a6. ; goto move double;
rl. w1 c0.+2 ; w1 := zone address;
jl. a1. ; goto test zonesize;
a10: ; return:
dl. w3 c0.+6 ; w3 := return-2;
rl w2 x2+8 ; w2 := stackref;
jl x3+2 ; return;
a11: am 13-22 ; illegal zonestate:
a12: al w1 22 ; try to read past eof:
dl. w3 c0.+6 ; w3 := return address;
rl w0 x2+4 ; w0 := address of runtime error;
rl w2 x2+8 ; w2 := stackref;
jl (0) ; goto runtime error;
e.
\f
; pack (limited to string/alfa)
; call parameters :
; w0 - start add of array to pack from
; w1 - - - - string/alfa to pack to
; w3 - return-4
; +2 number of elements to pack
b. a4 w.
a1: 0 ; add of last word to pack
f2: rl w2 x3 ;
ls w2 1 ; length*2
wa w0 4 ; last add to pack from
;ks-950
rs. w0 a1. ;
al w3 0 ;
rl. w2 c0. ; w2 := start addr to pack from;
a2: ; next to-word:
al w0 1 ; partial word := 1;
a3: ; next char:
sl. w2 (a1.) ; if from-addr >= top addr to pack from then
jl. a4. ; goto terminate packing;
ld w0 8 ; partial word := partial word shift 8
lo w0 x2 ; + char(from addr);
al w2 x2+2 ; increase (from addr);
se w3 1 ; if partial word not full then
jl. a3. ; goto next char;
rs w0 x1 ; word (to pointer) := partial word;
al w1 x1+2 ; increase (to pointer);
jl. a2. ; goto next to-word;
a4: ; terminate packing:
; w0 contains: 0, 1 or 2 characters, rigthjustified
sn w0 1 ; if partial word is empty (i.e. = flag) then
jl. f5. ; goto return;
ld w0 8 ; fill partial word up with spaces;
al w2 32 ; w2 := space;
lo w0 4 ;
se w3 1 ;
ld w0 8 ;
lo w0 4 ;
rs w0 x1 ; word (to pointer) := partial word;
jl. f5. ; goto return;
e.
; unpack (limited as pack)
; call parameters :
; w0 - start add of array to contain unpacked characters
; w1 - start add of string/alfa to unpack
; w3 - return-4
; +2 length of string/alfa to unpack
;
b. a5 w.
a1: 0 ; last add to contain unpacked
f3: rl w2 x3 ;
ls w2 1 ; length * 2
wa w0 4 ;
;ks-955
rs. w0 a1. ; add of last word to unpack into
rl. w2 c0. ; w2 := to pointer;
a2: ; next word:
rl w0 x1 ;
al w3 0 ; char := first char of word (from pointer);
ld w0 8 ; partial word := char 2,3 + one;
ba. w0 1 ;
a3: ; next char:
sl. w2 (a1.) ; if to pointer >= top to pointer then
jl. f5. ; goto return;
rs w3 x2 ; word (to pointer) := char;
al w2 x2+2 ; increase (to pointer);
al w3 0 ; char := leftmost char of partial word;
ld w0 8 ; partial word := partial word shift 8;
se w0 0 ; if partial word <> 0 then
jl. a3. ; goto next char;
al w1 x1+2 ; increase (from pointer);
jl. a2. ; goto next word;
e.
f5: dl. w3 c0.+6 ;
rl w2 x2+8 ;
jl x3+2 ; return
e.
e.
0,r.(:6146-k:)>1
e. ; end fpnames
; end segment
e.
▶EOF◀