1 MODULE Texts
; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91**) (* << RC, MB, JT *)
5 (*--- insert field e: Elem into Texts.Scanner and change Texts.Scan to set it in case of class=6 *)
11 TAB
= 9X
; CR
= 0DX
; maxD
= 9;
13 load
* = 0; store
* = 1;
15 replace
* = 0; insert
* = 1; delete
* = 2; unmark
* = 3;
17 Inval
* = 0; Name
* = 1; String
* = 2; Int
* = 3; Real
* = 4; LongReal
* = 5; Char
* = 6;
19 textTag
= 0F0X
; DocBlockId
= 0F7X
; version
= 01X
;
22 FontsFont
= POINTER TO FontDesc
;
24 name
: ARRAY 32 OF CHAR;
27 Run
= POINTER TO RunDesc
;
32 col
, voff
: SYSTEM
.INT8
;
33 ascii
: BOOLEAN (* << *)
36 Piece
= POINTER TO PieceDesc
;
37 PieceDesc
= RECORD (RunDesc
)
42 Elem
* = POINTER TO ElemDesc
;
43 Buffer
* = POINTER TO BufDesc
;
44 Text
* = POINTER TO TextDesc
;
46 ElemMsg
* = RECORD END;
47 Handler
* = PROCEDURE (e
: Elem
; VAR msg
: ElemMsg
);
49 ElemDesc
* = RECORD (RunDesc
)
55 FileMsg
* = RECORD (ElemMsg
)
61 CopyMsg
* = RECORD (ElemMsg
)
65 IdentifyMsg
* = RECORD (ElemMsg
)
66 mod
*, proc
*: ARRAY 32 OF CHAR
75 Notifier
* = PROCEDURE (T
: Text
; op
: INTEGER; beg
, end
: LONGINT);
86 col
*, voff
*: SYSTEM
.INT8
;
93 Scanner
* = RECORD (Reader
)
95 line
*, class
*: INTEGER;
101 s
*: ARRAY 64 OF CHAR (* << *)
107 col
*, voff
*: SYSTEM
.INT8
;
112 Alien
= POINTER TO RECORD (ElemDesc
)
115 mod
, proc
: ARRAY 32 OF CHAR
121 FontsDefault
: FontsFont
;
123 PROCEDURE FontsThis(VAR name
: ARRAY OF CHAR): FontsFont
;
126 NEW(F
); COPY(name
, F
.name
); RETURN F
131 PROCEDURE Find (T
: Text
; VAR pos
: LONGINT; VAR u
: Run
; VAR org
, off
: LONGINT);
132 VAR v
: Run
; m
: LONGINT;
134 IF pos
>= T
.len
THEN pos
:= T
.len
; u
:= T
.head
; org
:= T
.len
; off
:= 0; T
.cache
:= T
.head
; T
.corg
:= 0
135 ELSE v
:= T
.cache
.next
; m
:= pos
- T
.corg
;
136 IF pos
>= T
.corg
THEN
137 WHILE m
>= v
.len
DO DEC(m
, v
.len
); v
:= v
.next
END
139 WHILE m
< 0 DO v
:= v
.prev
; INC(m
, v
.len
) END;
141 u
:= v
; org
:= pos
- m
; off
:= m
; T
.cache
:= v
.prev
; T
.corg
:= org
145 PROCEDURE Split (off
: LONGINT; VAR u
, un
: Run
);
148 IF off
= 0 THEN un
:= u
; u
:= un
.prev
149 ELSIF off
>= u
.len
THEN un
:= u
.next
150 ELSE NEW(p
); un
:= p
; U
:= u(Piece
);
151 p^
:= U^
; INC(p
.org
, off
); DEC(p
.len
, off
); DEC(U
.len
, p
.len
);
152 p
.ascii
:= u
.ascii
; p
.prev
:= U
; p
.next
:= U
.next
; p
.next
.prev
:= p
; U
.next
:= p (* << *)
156 PROCEDURE Merge (T
: Text
; u
: Run
; VAR v
: Run
);
159 IF (u
IS Piece
) & (v
IS Piece
) & (u
.fnt
.name
= v
.fnt
.name
) & (u
.col
= v
.col
) & (u
.voff
= v
.voff
)
160 & (u(Piece
).ascii
= v(Piece
).ascii
) THEN (* << *)
161 p
:= u(Piece
); q
:= v(Piece
);
162 IF (p
.file
= q
.file
) & (p
.org
+ p
.len
= q
.org
) THEN
163 IF T
.cache
= u
THEN INC(T
.corg
, q
.len
)
164 ELSIF T
.cache
= v
THEN T
.cache
:= T
.head
; T
.corg
:= 0
166 INC(p
.len
, q
.len
); v
:= v
.next
171 PROCEDURE Splice (un
, v
, w
: Run
; base
: Text
); (* (u, un) -> (u, v, w, un) *)
174 IF v
# w
.next
THEN u
:= un
.prev
;
175 u
.next
:= v
; v
.prev
:= u
; un
.prev
:= w
; w
.next
:= un
;
177 IF v
IS Elem
THEN v(Elem
).base
:= base
END;
183 PROCEDURE ClonePiece (p
: Piece
): Piece
;
185 BEGIN NEW(q
); q^
:= p^
; RETURN q
188 PROCEDURE CloneElem (e
: Elem
): Elem
;
190 BEGIN msg
.e
:= NIL; e
.handle(e
, msg
); RETURN msg
.e
196 PROCEDURE CopyElem
* (SE
, DE
: Elem
);
197 BEGIN DE
.len
:= SE
.len
; DE
.fnt
:= SE
.fnt
; DE
.col
:= SE
.col
; DE
.voff
:= SE
.voff
;
198 DE
.W
:= SE
.W
; DE
.H
:= SE
.H
; DE
.handle
:= SE
.handle
201 PROCEDURE ElemBase
* (E
: Elem
): Text
;
205 PROCEDURE ElemPos
* (E
: Elem
): LONGINT;
206 VAR u
: Run
; pos
: LONGINT;
207 BEGIN u
:= E
.base
.head
.next
; pos
:= 0;
208 WHILE u
# E
DO pos
:= pos
+ u
.len
; u
:= u
.next
END;
213 PROCEDURE HandleAlien (E
: Elem
; VAR msg
: ElemMsg
);
214 VAR e
: Alien
; r
: Files
.Rider
; i
: LONGINT; ch
: CHAR;
217 IF msg
IS CopyMsg
THEN
218 WITH msg
: CopyMsg
DO NEW(e
); CopyElem(E
, e
);
219 e
.file
:= E
.file
; e
.org
:= E
.org
; e
.span
:= E
.span
; e
.mod
:= E
.mod
; e
.proc
:= E
.proc
;
222 ELSIF msg
IS IdentifyMsg
THEN
223 WITH msg
: IdentifyMsg
DO
224 COPY(E
.mod
, msg
.mod
); COPY(E
.proc
, msg
.proc
); msg
.mod
[31] := 1X (*alien*)
226 ELSIF msg
IS FileMsg
THEN
228 IF msg
.id
= store
THEN Files
.Set(r
, E
.file
, E
.org
); i
:= E
.span
;
229 WHILE i
> 0 DO Files
.Read(r
, ch
); Files
.Write(msg
.r
, ch
); DEC(i
) END
239 PROCEDURE OpenBuf
* (B
: Buffer
);
241 BEGIN NEW(u
); u
.next
:= u
; u
.prev
:= u
; B
.head
:= u
; B
.len
:= 0
244 PROCEDURE Copy
* (SB
, DB
: Buffer
);
246 BEGIN u
:= SB
.head
.next
; v
:= DB
.head
.prev
;
248 IF u
IS Piece
THEN vn
:= ClonePiece(u(Piece
)) ELSE vn
:= CloneElem(u(Elem
)) END;
249 v
.next
:= vn
; vn
.prev
:= v
; v
:= vn
; u
:= u
.next
251 v
.next
:= DB
.head
; DB
.head
.prev
:= v
;
255 PROCEDURE Recall
* (VAR B
: Buffer
);
256 BEGIN B
:= del
; del
:= NIL
262 PROCEDURE Save
* (T
: Text
; beg
, end
: LONGINT; B
: Buffer
);
263 VAR u
, v
, w
, wn
: Run
; uo
, ud
, vo
, vd
: LONGINT;
264 BEGIN Find(T
, beg
, u
, uo
, ud
); Find(T
, end
, v
, vo
, vd
);
267 IF u
IS Piece
THEN wn
:= ClonePiece(u(Piece
)); DEC(wn
.len
, ud
); INC(wn(Piece
).org
, ud
)
268 ELSE wn
:= CloneElem(u(Elem
))
270 w
.next
:= wn
; wn
.prev
:= w
; w
:= wn
; u
:= u
.next
; ud
:= 0
272 IF vd
> 0 THEN (*v IS Piece*) wn
:= ClonePiece(v(Piece
)); wn
.len
:= vd
- ud
; INC(wn(Piece
).org
, ud
);
273 w
.next
:= wn
; wn
.prev
:= w
; w
:= wn
275 w
.next
:= B
.head
; B
.head
.prev
:= w
;
276 INC(B
.len
, end
- beg
)
279 PROCEDURE Insert
* (T
: Text
; pos
: LONGINT; B
: Buffer
);
280 VAR u
, un
, v
: Run
; p
, q
: Piece
; uo
, ud
, len
: LONGINT;
281 BEGIN Find(T
, pos
, u
, uo
, ud
); Split(ud
, u
, un
);
282 len
:= B
.len
; v
:= B
.head
.next
;
283 Merge(T
, u
, v
); Splice(un
, v
, B
.head
.prev
, T
);
284 INC(T
.len
, len
); B
.head
.next
:= B
.head
; B
.head
.prev
:= B
.head
; B
.len
:= 0;
285 IF T
.notify
# NIL THEN T
.notify(T
, insert
, pos
, pos
+len
) END
288 PROCEDURE Append
* (T
: Text
; B
: Buffer
);
289 VAR v
: Run
; pos
, len
: LONGINT;
290 BEGIN pos
:= T
.len
; len
:= B
.len
; v
:= B
.head
.next
;
291 Merge(T
, T
.head
.prev
, v
); Splice(T
.head
, v
, B
.head
.prev
, T
);
292 INC(T
.len
, len
); B
.head
.next
:= B
.head
; B
.head
.prev
:= B
.head
; B
.len
:= 0;
293 IF T
.notify
# NIL THEN T
.notify(T
, insert
, pos
, pos
+len
) END
296 PROCEDURE Delete
* (T
: Text
; beg
, end
: LONGINT);
297 VAR c
, u
, un
, v
, vn
: Run
; co
, uo
, ud
, vo
, vd
: LONGINT;
299 Find(T
, beg
, u
, uo
, ud
); Split(ud
, u
, un
); c
:= T
.cache
; co
:= T
.corg
;
300 Find(T
, end
, v
, vo
, vd
); Split(vd
, v
, vn
); T
.cache
:= c
; T
.corg
:= co
;
301 NEW(del
); OpenBuf(del
); del
.len
:= end
- beg
;
302 Splice(del
.head
, un
, v
, NIL);
303 Merge(T
, u
, vn
); u
.next
:= vn
; vn
.prev
:= u
;
304 DEC(T
.len
, end
- beg
);
305 IF T
.notify
# NIL THEN T
.notify(T
, delete
, beg
, end
) END
308 PROCEDURE ChangeLooks
* (T
: Text
; beg
, end
: LONGINT; sel
: SET; fnt
: FontsFont
; col
, voff
: SYSTEM
.INT8
);
309 VAR c
, u
, un
, v
, vn
: Run
; co
, uo
, ud
, vo
, vd
: LONGINT;
310 BEGIN Find(T
, beg
, u
, uo
, ud
); Split(ud
, u
, un
); c
:= T
.cache
; co
:= T
.corg
;
311 Find(T
, end
, v
, vo
, vd
); Split(vd
, v
, vn
); T
.cache
:= c
; T
.corg
:= co
;
313 IF (0 IN sel
) & (fnt
# NIL) THEN un
.fnt
:= fnt
END;
314 IF 1 IN sel
THEN un
.col
:= col
END;
315 IF 2 IN sel
THEN un
.voff
:= voff
END;
317 IF u
.next
= un
THEN u
:= un
; un
:= un
.next
ELSE u
.next
:= un
; un
.prev
:= u
END
319 Merge(T
, u
, un
); u
.next
:= un
; un
.prev
:= u
;
320 IF T
.notify
# NIL THEN T
.notify(T
, replace
, beg
, end
) END
326 PROCEDURE OpenReader
* (VAR R
: Reader
; T
: Text
; pos
: LONGINT);
329 IF pos
>= T
.len
THEN pos
:= T
.len
END;
330 Find(T
, pos
, u
, R
.org
, R
.off
); R
.run
:= u
; R
.eot
:= FALSE
;
332 Files
.Set(R
.rider
, u(Piece
).file
, u(Piece
).org
+ R
.off
)
336 PROCEDURE Read
* (VAR R
: Reader
; VAR ch
: CHAR);
337 VAR u
: Run
; pos
: LONGINT; nextch
: CHAR;
338 BEGIN u
:= R
.run
; R
.fnt
:= u
.fnt
; R
.col
:= u
.col
; R
.voff
:= u
.voff
; INC(R
.off
);
339 IF u
IS Piece
THEN Files
.Read(R
.rider
, ch
); R
.elem
:= NIL;
340 IF (ch
= 0AX
) & u(Piece
).ascii
THEN ch
:= CR (* << LF to CR *)
341 ELSIF (ch
= CR
) & u(Piece
).ascii
THEN (* << CR LF to CR *)
342 pos
:= Files
.Pos(R
.rider
); Files
.Read(R
.rider
, nextch
);
343 IF nextch
= 0AX
THEN INC(R
.off
) ELSE Files
.Set(R
.rider
, u(Piece
).file
, pos
) END
345 ELSIF u
IS Elem
THEN ch
:= ElemChar
; R
.elem
:= u(Elem
)
346 ELSE ch
:= 0X
; R
.elem
:= NIL; R
.eot
:= TRUE
348 IF R
.off
= u
.len
THEN INC(R
.org
, u
.len
); u
:= u
.next
;
350 WITH u
: Piece
DO Files
.Set(R
.rider
, u
.file
, u
.org
) END
352 R
.run
:= u
; R
.off
:= 0
356 PROCEDURE ReadElem
* (VAR R
: Reader
);
359 WHILE u
IS Piece
DO INC(R
.org
, u
.len
); u
:= u
.next
END;
360 IF u
IS Elem
THEN un
:= u
.next
; R
.run
:= un
; INC(R
.org
); R
.off
:= 0;
361 R
.fnt
:= u
.fnt
; R
.col
:= u
.col
; R
.voff
:= u
.voff
; R
.elem
:= u(Elem
);
363 WITH un
: Piece
DO Files
.Set(R
.rider
, un
.file
, un
.org
) END
365 ELSE R
.eot
:= TRUE
; R
.elem
:= NIL
369 PROCEDURE ReadPrevElem
* (VAR R
: Reader
);
371 BEGIN u
:= R
.run
.prev
;
372 WHILE u
IS Piece
DO DEC(R
.org
, u
.len
); u
:= u
.prev
END;
373 IF u
IS Elem
THEN R
.run
:= u
; DEC(R
.org
); R
.off
:= 0;
374 R
.fnt
:= u
.fnt
; R
.col
:= u
.col
; R
.voff
:= u
.voff
; R
.elem
:= u(Elem
)
375 ELSE R
.eot
:= TRUE
; R
.elem
:= NIL
379 PROCEDURE Pos
* (VAR R
: Reader
): LONGINT;
380 BEGIN RETURN R
.org
+ R
.off
384 (** Scanners --------------- NW --------------- **)
386 PROCEDURE OpenScanner
* (VAR S
: Scanner
; T
: Text
; pos
: LONGINT);
387 BEGIN OpenReader(S
, T
, pos
); S
.line
:= 0; S
.nextCh
:= " "
390 (*IEEE floating point formats:
391 x = 2^(e-127) * 1.m bit 0: sign, bits 1- 8: e, bits 9-31: m
392 x = 2^(e-1023) * 1.m bit 0: sign, bits 1-11: e, bits 12-63: m *)
394 PROCEDURE Scan
* (VAR S
: Scanner
);
397 neg
, negE
, hex
: BOOLEAN;
399 e
: INTEGER; k
: LONGINT;
400 x
, f
: REAL; y
, g
: LONGREAL;
401 d
: ARRAY maxD
OF CHAR;
403 PROCEDURE ReadScaleFactor
;
405 IF ch
= "-" THEN negE
:= TRUE
; Read(S
, ch
)
407 IF ch
= "+" THEN Read(S
, ch
) END
409 WHILE ("0" <= ch
) & (ch
<= "9") DO
410 e
:= e
*10 + ORD(ch
) - 30H
; Read(S
, ch
)
414 BEGIN ch
:= S
.nextCh
; i
:= 0;
416 IF ch
= CR
THEN INC(S
.line
)
417 ELSIF (ch
# " ") & (ch
# TAB
) THEN EXIT
421 IF ("A" <= CAP(ch
)) & (CAP(ch
) <= "Z") OR (ch
= "/") OR (ch
= ".") THEN (*name*) (* << *)
422 REPEAT S
.s
[i
] := ch
; INC(i
); Read(S
, ch
)
423 UNTIL (CAP(ch
) > "Z") & (ch
# "_") (* << *)
424 OR ("A" > CAP(ch
)) & (ch
> "9")
425 OR ("0" > ch
) & (ch
# ".") & (ch
# "/") (* << *)
426 OR (i
= 63); (* << *)
427 S
.s
[i
] := 0X
; S
.len
:= i
; S
.class
:= 1
428 ELSIF ch
= 22X
THEN (*literal string*)
430 WHILE (ch
# 22X
) & (ch
>= " ") & (i
# 63) DO (* << *)
431 S
.s
[i
] := ch
; INC(i
); Read(S
, ch
)
433 S
.s
[i
] := 0X
; S
.len
:= i
+1; Read(S
, ch
); S
.class
:= 2
435 IF ch
= "-" THEN neg
:= TRUE
; Read(S
, ch
) ELSE neg
:= FALSE
END ;
436 IF ("0" <= ch
) & (ch
<= "9") THEN (*number*)
437 hex
:= FALSE
; j
:= 0;
438 LOOP d
[i
] := ch
; INC(i
); Read(S
, ch
);
439 IF ch
< "0" THEN EXIT END;
441 IF ("A" <= ch
) & (ch
<= "F") THEN hex
:= TRUE
; ch
:= CHR(ORD(ch
)-7)
442 ELSIF ("a" <= ch
) & (ch
<= "f") THEN hex
:= TRUE
; ch
:= CHR(ORD(ch
)-27H
)
447 IF ch
= "H" THEN (*hex number*)
448 Read(S
, ch
); S
.class
:= 3;
449 IF i
-j
> 8 THEN j
:= i
-8 END ;
450 k
:= ORD(d
[j
]) - 30H
; INC(j
);
451 IF (i
-j
= 7) & (k
>= 8) THEN DEC(k
, 16) END ;
452 WHILE j
< i
DO k
:= k
*10H
+ (ORD(d
[j
]) - 30H
); INC(j
) END ;
453 IF neg
THEN S
.i
:= -k
ELSE S
.i
:= k
END
454 ELSIF ch
= "." THEN (*read real*)
456 WHILE ("0" <= ch
) & (ch
<= "9") DO d
[i
] := ch
; INC(i
); Read(S
, ch
) END ;
458 e
:= 0; y
:= 0; g
:= 1;
459 REPEAT y
:= y
*10 + (ORD(d
[j
]) - 30H
); INC(j
) UNTIL j
= h
;
460 WHILE j
< i
DO g
:= g
/10; y
:= (ORD(d
[j
]) - 30H
)*g
+ y
; INC(j
) END ;
463 IF e
<= 308 THEN y
:= y
/ Reals
.TenL(e
) ELSE y
:= 0 END
465 IF e
<= 308 THEN y
:= Reals
.TenL(e
) * y
ELSE HALT(40) END
467 IF neg
THEN y
:= -y
END ;
468 S
.class
:= 5; S
.y
:= y
469 ELSE e
:= 0; x
:= 0; f
:= 1;
470 REPEAT x
:= x
*10 + (ORD(d
[j
]) - 30H
); INC(j
) UNTIL j
= h
;
471 WHILE j
< i
DO f
:= f
/10; x
:= (ORD(d
[j
])-30H
)*f
+ x
; INC(j
) END;
472 IF ch
= "E" THEN ReadScaleFactor
END ;
474 IF e
<= 38 THEN x
:= x
/ Reals
.Ten(e
) ELSE x
:= 0 END
476 IF e
<= 38 THEN x
:= Reals
.Ten(e
) * x
ELSE HALT(40) END
478 IF neg
THEN x
:= -x
END ;
479 S
.class
:= 4; S
.x
:= x
481 IF hex
THEN S
.class
:= 0 END
482 ELSE (*decimal integer*)
483 S
.class
:= 3; k
:= 0;
484 REPEAT k
:= k
*10 + (ORD(d
[j
]) - 30H
); INC(j
) UNTIL j
= i
;
485 IF neg
THEN S
.i
:= -k
ELSE S
.i
:= k
END;
486 IF hex
THEN S
.class
:= 0 ELSE S
.class
:= 3 END
489 IF neg
THEN S
.c
:= "-" ELSE S
.c
:= ch
; Read(S
, ch
) END
498 PROCEDURE OpenWriter
* (VAR W
: Writer
);
499 BEGIN NEW(W
.buf
); OpenBuf(W
.buf
);
500 W
.fnt
:= FontsDefault
; W
.col
:= Displaywhite
; W
.voff
:= 0;
501 W
.file
:= Files
.New(""); Files
.Set(W
.rider
, W
.file
, 0)
504 PROCEDURE SetFont
* (VAR W
: Writer
; fnt
: FontsFont
);
508 PROCEDURE SetColor
* (VAR W
: Writer
; col
: SYSTEM
.INT8
);
512 PROCEDURE SetOffset
* (VAR W
: Writer
; voff
: SYSTEM
.INT8
);
517 PROCEDURE Write
* (VAR W
: Writer
; ch
: CHAR);
518 VAR u
, un
: Run
; p
: Piece
;
519 BEGIN Files
.Write(W
.rider
, ch
); INC(W
.buf
.len
); un
:= W
.buf
.head
; u
:= un
.prev
;
520 IF (u
IS Piece
) & (u(Piece
).file
= W
.file
) & (u
.fnt
.name
= W
.fnt
.name
) & (u
.col
= W
.col
) & (u
.voff
= W
.voff
)
521 & ~
u(Piece
).ascii
THEN (* << *)
523 ELSE NEW(p
); u
.next
:= p
; p
.prev
:= u
; p
.next
:= un
; un
.prev
:= p
;
524 p
.len
:= 1; p
.fnt
:= W
.fnt
; p
.col
:= W
.col
; p
.voff
:= W
.voff
;
525 p
.file
:= W
.file
; p
.org
:= Files
.Length(W
.file
) - 1; p
.ascii
:= FALSE (* << *)
529 PROCEDURE WriteElem
* (VAR W
: Writer
; e
: Elem
);
532 IF e
.base
# NIL THEN HALT(99) END;
533 INC(W
.buf
.len
); e
.len
:= 1; e
.fnt
:= W
.fnt
; e
.col
:= W
.col
; e
.voff
:= W
.voff
;
534 un
:= W
.buf
.head
; u
:= un
.prev
; u
.next
:= e
; e
.prev
:= u
; e
.next
:= un
; un
.prev
:= e
537 PROCEDURE WriteLn
* (VAR W
: Writer
);
541 PROCEDURE WriteString
* (VAR W
: Writer
; s
: ARRAY OF CHAR);
544 WHILE s
[i
] >= " " DO Write(W
, s
[i
]); INC(i
) END
547 PROCEDURE WriteInt
* (VAR W
: Writer
; x
, n
: SYSTEM
.INT64
);
549 i
: INTEGER; x0
: SYSTEM
.INT64
;
553 IF x
= MIN(SYSTEM
.INT64
) THEN WriteString(W
, " -9223372036854775808"); RETURN
554 ELSE DEC(n
); x0
:= -x
559 a
[i
] := CHR(x0
MOD 10 + 30H
); x0
:= x0
DIV 10; INC(i
)
561 WHILE n
> i
DO Write(W
, " "); DEC(n
) END;
562 IF x
< 0 THEN Write(W
, "-") END;
563 REPEAT DEC(i
); Write(W
, a
[i
]) UNTIL i
= 0
566 PROCEDURE WriteHex
* (VAR W
: Writer
; x
: LONGINT);
567 VAR i
: INTEGER; y
: LONGINT;
569 BEGIN i
:= 0; Write(W
, " ");
570 REPEAT y
:= x
MOD 10H
;
571 IF y
< 10 THEN a
[i
] := CHR(y
+ 30H
) ELSE a
[i
] := CHR(y
+ 37H
) END;
572 x
:= x
DIV 10H
; INC(i
)
574 REPEAT DEC(i
); Write(W
, a
[i
]) UNTIL i
= 0
577 PROCEDURE WriteReal
* (VAR W
: Writer
; x
: REAL; n
: INTEGER);
578 VAR e
: INTEGER; x0
: REAL;
579 d
: ARRAY maxD
OF CHAR;
580 BEGIN e
:= Reals
.Expo(x
);
582 WriteString(W
, " 0");
583 REPEAT Write(W
, " "); DEC(n
) UNTIL n
<= 3
585 WriteString(W
, " NaN");
586 WHILE n
> 4 DO Write(W
, " "); DEC(n
) END
588 IF n
<= 9 THEN n
:= 3 ELSE DEC(n
, 6) END;
589 REPEAT Write(W
, " "); DEC(n
) UNTIL n
<= 8;
590 (*there are 2 < n <= 8 digits to be written*)
591 IF x
< 0.0 THEN Write(W
, "-"); x
:= -x
ELSE Write(W
, " ") END;
592 e
:= (e
- 127) * 77 DIV 256;
593 IF e
>= 0 THEN x
:= x
/ Reals
.Ten(e
) ELSE x
:= Reals
.Ten(-e
) * x
END;
594 IF x
>= 10.0 THEN x
:= 0.1*x
; INC(e
) END;
595 x0
:= Reals
.Ten(n
-1); x
:= x0
*x
+ 0.5;
596 IF x
>= 10.0*x0
THEN x
:= x
*0.1; INC(e
) END;
597 Reals
.Convert(x
, n
, d
);
598 DEC(n
); Write(W
, d
[n
]); Write(W
, ".");
599 REPEAT DEC(n
); Write(W
, d
[n
]) UNTIL n
= 0;
601 IF e
< 0 THEN Write(W
, "-"); e
:= -e
ELSE Write(W
, "+") END;
602 Write(W
, CHR(e
DIV 10 + 30H
)); Write(W
, CHR(e
MOD 10 + 30H
))
606 PROCEDURE WriteRealFix
* (VAR W
: Writer
; x
: REAL; n
, k
: INTEGER);
607 VAR e
, i
: INTEGER; sign
: CHAR; x0
: REAL;
608 d
: ARRAY maxD
OF CHAR;
610 PROCEDURE seq(ch
: CHAR; n
: INTEGER);
611 BEGIN WHILE n
> 0 DO Write(W
, ch
); DEC(n
) END
614 PROCEDURE dig(n
: INTEGER);
617 DEC(i
); Write(W
, d
[i
]); DEC(n
)
621 BEGIN e
:= Reals
.Expo(x
);
622 IF k
< 0 THEN k
:= 0 END;
623 IF e
= 0 THEN seq(" ", n
-k
-2); Write(W
, "0"); seq(" ", k
+1)
624 ELSIF e
= 255 THEN WriteString(W
, " NaN"); seq(" ", n
-4)
625 ELSE e
:= (e
- 127) * 77 DIV 256;
626 IF x
< 0 THEN sign
:= "-"; x
:= -x
ELSE sign
:= " " END;
627 IF e
>= 0 THEN (*x >= 1.0, 77/256 = log 2*) x
:= x
/Reals
.Ten(e
)
628 ELSE (*x < 1.0*) x
:= Reals
.Ten(-e
) * x
630 IF x
>= 10.0 THEN x
:= 0.1*x
; INC(e
) END;
632 IF k
+e
>= maxD
-1 THEN k
:= maxD
-1-e
633 ELSIF k
+e
< 0 THEN k
:= -e
; x
:= 0.0
635 x0
:= Reals
.Ten(k
+e
); x
:= x0
*x
+ 0.5;
636 IF x
>= 10.0*x0
THEN INC(e
) END;
637 (*e = no. of digits before decimal point*)
638 INC(e
); i
:= k
+e
; Reals
.Convert(x
, i
, d
);
640 seq(" ", n
-e
-k
-2); Write(W
, sign
); dig(e
);
641 Write(W
, "."); dig(k
)
642 ELSE seq(" ", n
-k
-3);
643 Write(W
, sign
); Write(W
, "0"); Write(W
, ".");
644 seq("0", -e
); dig(k
+e
)
649 PROCEDURE WriteRealHex
* (VAR W
: Writer
; x
: REAL);
652 BEGIN Reals
.ConvertH(x
, d
); i
:= 0;
653 REPEAT Write(W
, d
[i
]); INC(i
) UNTIL i
= 8
656 PROCEDURE WriteLongReal
* (VAR W
: Writer
; x
: LONGREAL; n
: INTEGER);
658 VAR e
: INTEGER; x0
: LONGREAL;
659 d
: ARRAY maxD
OF CHAR;
660 BEGIN e
:= Reals
.ExpoL(x
);
662 WriteString(W
, " 0");
663 REPEAT Write(W
, " "); DEC(n
) UNTIL n
<= 3
665 WriteString(W
, " NaN");
666 WHILE n
> 4 DO Write(W
, " "); DEC(n
) END
668 IF n
<= 10 THEN n
:= 3 ELSE DEC(n
, 7) END;
669 REPEAT Write(W
, " "); DEC(n
) UNTIL n
<= maxD
;
670 (*there are 2 <= n <= maxD digits to be written*)
671 IF x
< 0 THEN Write(W
, "-"); x
:= -x
ELSE Write(W
, " ") END;
673 (* Scale e to be an exponent of 10 rather than 2 *)
674 e
:= SHORT(LONG(e
- 1023) * 77 DIV 256);
675 IF e
>= 0 THEN x
:= x
/ Reals
.TenL(e
) ELSE x
:= Reals
.TenL(-e
) * x
END ;
676 IF x
>= 10.0D0
THEN x
:= 0.1D0
* x
; INC(e
) END;
678 (* Scale x to the number of digits requested *)
679 x0
:= Reals
.TenL(n
-1); x
:= x0
*x
+ 0.5D0
;
680 IF x
>= 10.0D0
*x0
THEN x
:= 0.1D0
* x
; INC(e
) END ;
682 (* Generate the mantissa digits of x *)
683 Reals
.ConvertL(x
, n
, d
);
685 DEC(n
); Write(W
, d
[n
]); Write(W
, ".");
686 REPEAT DEC(n
); Write(W
, d
[n
]) UNTIL n
= 0;
689 IF e
< 0 THEN Write(W
, "-"); e
:= -e
ELSE Write(W
, "+") END;
690 Write(W
, CHR(e
DIV 100 + 30H
)); e
:= e
MOD 100;
691 Write(W
, CHR(e
DIV 10 + 30H
));
692 Write(W
, CHR(e
MOD 10 + 30H
))
696 PROCEDURE WriteLongRealHex
* (VAR W
: Writer
; x
: LONGREAL);
699 BEGIN Reals
.ConvertHL(x
, d
); i
:= 0;
700 REPEAT Write(W
, d
[i
]); INC(i
) UNTIL i
= 16
701 END WriteLongRealHex
;
703 PROCEDURE WriteDate
* (VAR W
: Writer
; t
, d
: LONGINT);
705 PROCEDURE WritePair(ch
: CHAR; x
: LONGINT);
707 Write(W
, CHR(x
DIV 10 + 30H
)); Write(W
, CHR(x
MOD 10 + 30H
))
711 WritePair(" ", d
MOD 32); WritePair(".", d
DIV 32 MOD 16); WritePair(".", d
DIV 512 MOD 128);
712 WritePair(" ", t
DIV 4096 MOD 32); WritePair(":", t
DIV 64 MOD 64); WritePair(":", t
MOD 64)
718 PROCEDURE Load0 (VAR r
: Files
.Rider
; T
: Text
);
719 VAR u
, un
: Run
; p
: Piece
; e
: Elem
;
720 org
, pos
, hlen
, plen
: LONGINT; ecnt
, fcnt
: SHORTINT;
721 fno
, col
, voff
: SYSTEM
.INT8
;
724 mods
, procs
: ARRAY 64, 32 OF CHAR;
725 name
: ARRAY 32 OF CHAR;
726 fnts
: ARRAY 32 OF FontsFont
;
728 PROCEDURE LoadElem (VAR r
: Files
.Rider
; pos
, span
: LONGINT; VAR e
: Elem
);
729 VAR a
: Alien
; org
, ew
, eh
: LONGINT; eno
: SYSTEM
.INT8
;
731 Files
.ReadLInt(r
, ew
); Files
.ReadLInt(r
, eh
); Files
.Read(r
, eno
);
732 IF eno
> ecnt
THEN ecnt
:= eno
; Files
.ReadString(r
, mods
[eno
]); Files
.ReadString(r
, procs
[eno
]) END;
735 IF e
# NIL THEN e
.W
:= ew
; e
.H
:= eh
; e
.base
:= T
;
736 msg
.pos
:= pos
; e
.handle(e
, msg
);
737 IF Files
.Pos(r
) # org
+ span
THEN e
:= NIL END
739 IF e
= NIL THEN Files
.Set(r
, f
, org
+ span
);
740 NEW(a
); a
.W
:= ew
; a
.H
:= eh
; a
.handle
:= HandleAlien
; a
.base
:= T
;
741 a
.file
:= f
; a
.org
:= org
; a
.span
:= span
;
742 COPY(mods
[eno
], a
.mod
); COPY(procs
[eno
], a
.proc
);
747 BEGIN pos
:= Files
.Pos(r
); f
:= Files
.Base(r
);
748 NEW(u
); u
.len
:= MAX(LONGINT); (*u.fnt := FontsDefault;*)u
.fnt
:= NIL; u
.col
:= Displaywhite
;
749 T
.head
:= u
; ecnt
:= 0; fcnt
:= 0;
750 msg
.id
:= load
; msg
.r
:= r
;
751 Files
.ReadLInt(msg
.r
, hlen
); (*!!!org := pos + hlen;*) org
:= pos
-2 + hlen
; pos
:= org
; Files
.Read(msg
.r
, fno
);
753 IF fno
> fcnt
THEN fcnt
:= fno
; Files
.ReadString(msg
.r
, name
); fnts
[fno
] := FontsThis(name
) END;
754 Files
.Read(msg
.r
, col
); Files
.Read(msg
.r
, voff
); Files
.ReadLInt(msg
.r
, plen
);
755 IF plen
> 0 THEN NEW(p
); p
.file
:= f
; p
.org
:= pos
; p
.ascii
:= FALSE
; un
:= p
; un
.len
:= plen
756 ELSE LoadElem(msg
.r
, pos
- org
, -plen
, e
); un
:= e
; un
.len
:= 1
758 (*un.fnt := fnts[fno];*) un
.col
:= col
; un
.voff
:= voff
;
759 INC(pos
, un
.len
); u
.next
:= un
; un
.prev
:= u
; u
:= un
; Files
.Read(msg
.r
, fno
)
761 u
.next
:= T
.head
; T
.head
.prev
:= u
; T
.cache
:= T
.head
; T
.corg
:= 0;
762 Files
.ReadLInt(msg
.r
, T
.len
); Files
.Set(r
, f
, Files
.Pos(msg
.r
) + T
.len
)
765 PROCEDURE Load
* (VAR r
: Files
.Rider
; T
: Text
);
766 CONST oldTag
= -4095;
769 (* for compatibility inner text tags are checked and skipped; remove this in a later version *)
770 Files
.ReadInt(r
, tag
); IF tag
# oldTag
THEN Files
.Set(r
, Files
.Base(r
), Files
.Pos(r
)-2) END;
774 PROCEDURE Open
* (T
: Text
; name
: ARRAY OF CHAR);
775 VAR f
: Files
.File
; r
: Files
.Rider
; u
: Run
; p
: Piece
; tag
, version
: CHAR; hlen
: LONGINT;
776 BEGIN f
:= Files
.Old(name
);
777 IF f
= NIL THEN f
:= Files
.New("") END;
778 Files
.Set(r
, f
, 0); Files
.Read(r
, tag
); Files
.Read(r
, version
);
779 IF (tag
= textTag
) OR (tag
= 01X
) & (version
= textTag
) THEN Load0(r
, T
)
781 NEW(u
); u
.len
:= MAX(LONGINT); u
.fnt
:= NIL; u
.col
:= Displaywhite
;
783 IF (tag
= DocBlockId
) & (version
= 07X
) THEN (* extract ascii text from System 3 text document *)
784 Files
.Set(r
, f
, 28); Files
.ReadLInt(r
, hlen
);
785 Files
.Set(r
, f
, 22 + hlen
); Files
.ReadLInt(r
, T
.len
); p
.org
:= 26 + hlen
787 T
.len
:= Files
.Length(f
); p
.org
:= 0
789 IF T
.len
> 0 THEN p
.len
:= T
.len
; p
.fnt
:= FontsDefault
;
790 p
.col
:= Displaywhite
; p
.voff
:= 0; p
.file
:= f
; p
.ascii
:= TRUE
;
791 u
.next
:= p
; u
.prev
:= p
; p
.next
:= u
; p
.prev
:= u
792 ELSE u
.next
:= u
; u
.prev
:= u
794 T
.head
:= u
; T
.cache
:= T
.head
; T
.corg
:= 0
798 PROCEDURE Store
* (VAR r
: Files
.Rider
; T
: Text
);
799 VAR r1
: Files
.Rider
; u
, un
: Run
; e
: Elem
; org
, pos
, delta
, hlen
, rlen
: LONGINT; ecnt
, fcnt
: SHORTINT; ch
: CHAR; (* << *)
801 msg
: FileMsg
; iden
: IdentifyMsg
;
802 mods
, procs
: ARRAY 64, 32 OF CHAR;
803 fnts
: ARRAY 32 OF FontsFont
;
804 block
: ARRAY 1024 OF CHAR;
806 PROCEDURE StoreElem (VAR r
: Files
.Rider
; pos
: LONGINT; e
: Elem
);
807 VAR r1
: Files
.Rider
; org
, span
: LONGINT; eno
: SYSTEM
.INT8
;
808 BEGIN COPY(iden
.mod
, mods
[ecnt
]); COPY(iden
.proc
, procs
[ecnt
]); eno
:= 1;
809 WHILE (mods
[eno
] # iden
.mod
) OR (procs
[eno
] # iden
.proc
) DO INC(eno
) END;
810 Files
.Set(r1
, Files
.Base(r
), Files
.Pos(r
));
811 Files
.WriteLInt(r
, 0); Files
.WriteLInt(r
, 0); Files
.WriteLInt(r
, 0); (*fixup slot*)
813 IF eno
= ecnt
THEN INC(ecnt
); Files
.WriteString(r
, iden
.mod
); Files
.WriteString(r
, iden
.proc
) END;
814 msg
.pos
:= pos
; org
:= Files
.Pos(r
); e
.handle(e
, msg
); span
:= Files
.Pos(r
) - org
;
815 Files
.WriteLInt(r1
, -span
); Files
.WriteLInt(r1
, e
.W
); Files
.WriteLInt(r1
, e
.H
) (*fixup*)
819 org
:= Files
.Pos(r
); msg
.id
:= store
; msg
.r
:= r
; Files
.WriteLInt(msg
.r
, 0); (*fixup slot*)
820 u
:= T
.head
.next
; pos
:= 0; delta
:= 0; fcnt
:= 1; ecnt
:= 1;
822 IF u
IS Elem
THEN iden
.mod
[0] := 0X
; u(Elem
).handle(u(Elem
), iden
) ELSE iden
.mod
[0] := 1X
END;
823 IF iden
.mod
[0] # 0X
THEN
824 fnts
[fcnt
] := u
.fnt
; fno
:= 1;
825 WHILE fnts
[fno
].name
# u
.fnt
.name
DO INC(fno
) END;
826 Files
.Write(msg
.r
, fno
);
827 IF fno
= fcnt
THEN INC(fcnt
); Files
.WriteString(msg
.r
, u
.fnt
.name
) END;
828 Files
.Write(msg
.r
, u
.col
); Files
.Write(msg
.r
, u
.voff
)
830 IF u
IS Piece
THEN rlen
:= u
.len
; un
:= u
.next
;
831 WHILE (un
IS Piece
) & (un
.fnt
= u
.fnt
) & (un
.col
= u
.col
) & (un
.voff
= u
.voff
) DO
832 INC(rlen
, un
.len
); un
:= un
.next
834 Files
.WriteLInt(msg
.r
, rlen
); INC(pos
, rlen
); u
:= un
835 ELSIF iden
.mod
[0] # 0X
THEN StoreElem(msg
.r
, pos
, u(Elem
)); INC(pos
); u
:= u
.next
836 ELSE INC(delta
); u
:= u
.next
839 Files
.Write(msg
.r
, 0); Files
.WriteLInt(msg
.r
, T
.len
- delta
);
840 (*!!!hlen := Files.Pos(msg.r) - org;*) hlen
:= Files
.Pos(msg
.r
) - org
+ 2;
841 Files
.Set(r1
, Files
.Base(msg
.r
), org
); Files
.WriteLInt(r1
, hlen
); (*fixup*)
846 IF u
.ascii
THEN Files
.Set(r1
, u
.file
, u
.org
); delta
:= u
.len
; (* << LF to CR *)
847 WHILE delta
> 0 DO Files
.Read(r1
, ch
); DEC(delta
);
848 IF ch
= 0AX
THEN Files
.Write(msg
.r
, CR
) ELSE Files
.Write(msg
.r
, ch
) END
850 ELSE Files
.Set(r1
, u
.file
, u
.org
); delta
:= u
.len
;
851 WHILE delta
> LEN(block
) DO Files
.ReadBytes(r1
, block
, LEN(block
));
852 Files
.WriteBytes(msg
.r
, block
, LEN(block
)); DEC(delta
, LEN(block
))
854 Files
.ReadBytes(r1
, block
, delta
); Files
.WriteBytes(msg
.r
, block
, delta
)
857 ELSE iden
.mod
[0] := 0X
; u(Elem
).handle(u(Elem
), iden
);
858 IF iden
.mod
[0] # 0X
THEN Files
.Write(msg
.r
, ElemChar
) END
863 IF T
.notify
# NIL THEN T
.notify(T
, unmark
, 0, 0) END
866 PROCEDURE Close
* (T
: Text
; name
: ARRAY OF CHAR);
867 VAR f
: Files
.File
; r
: Files
.Rider
; i
, res
: INTEGER; bak
: ARRAY 64 OF CHAR;
869 f
:= Files
.New(name
); Files
.Set(r
, f
, 0); Files
.Write(r
, textTag
); Files
.Write(r
, version
); Store(r
, T
);
870 i
:= 0; WHILE name
[i
] # 0X
DO INC(i
) END;
871 COPY(name
, bak
); bak
[i
] := "."; bak
[i
+1] := "B"; bak
[i
+2] := "a"; bak
[i
+3] := "k"; bak
[i
+4] := 0X
;
872 Files
.Rename(name
, bak
, res
); Files
.Register(f
)
875 BEGIN del
:= NIL; NEW(FontsDefault
); FontsDefault
.name
:= "Syntax10.Scn.Fnt"