1MODULE Texts; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91**) (* << RC, MB, JT *) 2 IMPORT 3 Files, Modules, Reals, SYSTEM, Out; 4 5 (*--- insert field e: Elem into Texts.Scanner and change Texts.Scan to set it in case of class=6 *) 6 7 8 CONST 9 Displaywhite = 15; 10 ElemChar* = 1CX; 11 TAB = 9X; CR = 0DX; maxD = 9; 12 (**FileMsg.id**) 13 load* = 0; store* = 1; 14 (**Notifier op**) 15 replace* = 0; insert* = 1; delete* = 2; unmark* = 3; 16 (**Scanner.class**) 17 Inval* = 0; Name* = 1; String* = 2; Int* = 3; Real* = 4; LongReal* = 5; Char* = 6; 18 19 textTag = 0F0X; DocBlockId = 0F7X; version = 01X; 20 21 TYPE 22 FontsFont = POINTER TO FontDesc; 23 FontDesc = RECORD 24 name: ARRAY 32 OF CHAR; 25 END ; 26 27 Run = POINTER TO RunDesc; 28 RunDesc = RECORD 29 prev, next: Run; 30 len: LONGINT; 31 fnt: FontsFont; 32 col, voff: SYSTEM.INT8; 33 ascii: BOOLEAN (* << *) 34 END; 35 36 Piece = POINTER TO PieceDesc; 37 PieceDesc = RECORD (RunDesc) 38 file: Files.File; 39 org: LONGINT 40 END; 41 42 Elem* = POINTER TO ElemDesc; 43 Buffer* = POINTER TO BufDesc; 44 Text* = POINTER TO TextDesc; 45 46 ElemMsg* = RECORD END; 47 Handler* = PROCEDURE (e: Elem; VAR msg: ElemMsg); 48 49 ElemDesc* = RECORD (RunDesc) 50 W*, H*: LONGINT; 51 handle*: Handler; 52 base: Text 53 END; 54 55 FileMsg* = RECORD (ElemMsg) 56 id*: INTEGER; 57 pos*: LONGINT; 58 r*: Files.Rider 59 END; 60 61 CopyMsg* = RECORD (ElemMsg) 62 e*: Elem 63 END; 64 65 IdentifyMsg* = RECORD (ElemMsg) 66 mod*, proc*: ARRAY 32 OF CHAR 67 END; 68 69 70 BufDesc* = RECORD 71 len*: LONGINT; 72 head: Run 73 END; 74 75 Notifier* = PROCEDURE (T: Text; op: INTEGER; beg, end: LONGINT); 76 TextDesc* = RECORD 77 len*: LONGINT; 78 notify*: Notifier; 79 head, cache: Run; 80 corg: LONGINT 81 END; 82 83 Reader* = RECORD 84 eot*: BOOLEAN; 85 fnt*: FontsFont; 86 col*, voff*: SYSTEM.INT8; 87 elem*: Elem; 88 rider: Files.Rider; 89 run: Run; 90 org, off: LONGINT 91 END; 92 93 Scanner* = RECORD (Reader) 94 nextCh*: CHAR; 95 line*, class*: INTEGER; 96 i*: LONGINT; 97 x*: REAL; 98 y*: LONGREAL; 99 c*: CHAR; 100 len*: SHORTINT; 101 s*: ARRAY 64 OF CHAR (* << *) 102 END; 103 104 Writer* = RECORD 105 buf*: Buffer; 106 fnt*: FontsFont; 107 col*, voff*: SYSTEM.INT8; 108 rider: Files.Rider; 109 file: Files.File 110 END; 111 112 Alien = POINTER TO RECORD (ElemDesc) 113 file: Files.File; 114 org, span: LONGINT; 115 mod, proc: ARRAY 32 OF CHAR 116 END; 117 118 VAR 119 new*: Elem; 120 del: Buffer; 121 FontsDefault: FontsFont; 122 123 PROCEDURE FontsThis(VAR name: ARRAY OF CHAR): FontsFont; 124 VAR F: FontsFont; 125 BEGIN 126 NEW(F); COPY(name, F.name); RETURN F 127 END FontsThis; 128 129 (* run primitives *) 130 131 PROCEDURE Find (T: Text; VAR pos: LONGINT; VAR u: Run; VAR org, off: LONGINT); 132 VAR v: Run; m: LONGINT; 133 BEGIN 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 138 ELSE 139 WHILE m < 0 DO v := v.prev; INC(m, v.len) END; 140 END; 141 u := v; org := pos - m; off := m; T.cache := v.prev; T.corg := org 142 END 143 END Find; 144 145 PROCEDURE Split (off: LONGINT; VAR u, un: Run); 146 VAR p, U: Piece; 147 BEGIN 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 (* << *) 153 END 154 END Split; 155 156 PROCEDURE Merge (T: Text; u: Run; VAR v: Run); 157 VAR p, q: Piece; 158 BEGIN 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 165 END; 166 INC(p.len, q.len); v := v.next 167 END 168 END 169 END Merge; 170 171 PROCEDURE Splice (un, v, w: Run; base: Text); (* (u, un) -> (u, v, w, un) *) 172 VAR u: Run; 173 BEGIN 174 IF v # w.next THEN u := un.prev; 175 u.next := v; v.prev := u; un.prev := w; w.next := un; 176 REPEAT 177 IF v IS Elem THEN v(Elem).base := base END; 178 v := v.next 179 UNTIL v = un 180 END 181 END Splice; 182 183 PROCEDURE ClonePiece (p: Piece): Piece; 184 VAR q: Piece; 185 BEGIN NEW(q); q^ := p^; RETURN q 186 END ClonePiece; 187 188 PROCEDURE CloneElem (e: Elem): Elem; 189 VAR msg: CopyMsg; 190 BEGIN msg.e := NIL; e.handle(e, msg); RETURN msg.e 191 END CloneElem; 192 193 194 (** Elements **) 195 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 199 END CopyElem; 200 201 PROCEDURE ElemBase* (E: Elem): Text; 202 BEGIN RETURN E.base 203 END ElemBase; 204 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; 209 RETURN pos 210 END ElemPos; 211 212 213 PROCEDURE HandleAlien (E: Elem; VAR msg: ElemMsg); 214 VAR e: Alien; r: Files.Rider; i: LONGINT; ch: CHAR; 215 BEGIN 216 WITH E: Alien DO 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; 220 msg.e := e 221 END 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*) 225 END 226 ELSIF msg IS FileMsg THEN 227 WITH msg: FileMsg DO 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 230 END 231 END 232 END 233 END 234 END HandleAlien; 235 236 237 (** Buffers **) 238 239 PROCEDURE OpenBuf* (B: Buffer); 240 VAR u: Run; 241 BEGIN NEW(u); u.next := u; u.prev := u; B.head := u; B.len := 0 242 END OpenBuf; 243 244 PROCEDURE Copy* (SB, DB: Buffer); 245 VAR u, v, vn: Run; 246 BEGIN u := SB.head.next; v := DB.head.prev; 247 WHILE u # SB.head DO 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 250 END; 251 v.next := DB.head; DB.head.prev := v; 252 INC(DB.len, SB.len) 253 END Copy; 254 255 PROCEDURE Recall* (VAR B: Buffer); 256 BEGIN B := del; del := NIL 257 END Recall; 258 259 260 (** Texts **) 261 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); 265 w := B.head.prev; 266 WHILE u # v DO 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)) 269 END; 270 w.next := wn; wn.prev := w; w := wn; u := u.next; ud := 0 271 END; 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 274 END; 275 w.next := B.head; B.head.prev := w; 276 INC(B.len, end - beg) 277 END Save; 278 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 286 END Insert; 287 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 294 END Append; 295 296 PROCEDURE Delete* (T: Text; beg, end: LONGINT); 297 VAR c, u, un, v, vn: Run; co, uo, ud, vo, vd: LONGINT; 298 BEGIN 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 306 END Delete; 307 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; 312 WHILE un # vn DO 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; 316 Merge(T, u, un); 317 IF u.next = un THEN u := un; un := un.next ELSE u.next := un; un.prev := u END 318 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 321 END ChangeLooks; 322 323 324 (** Readers **) 325 326 PROCEDURE OpenReader* (VAR R: Reader; T: Text; pos: LONGINT); 327 VAR u: Run; 328 BEGIN 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; 331 IF u IS Piece THEN 332 Files.Set(R.rider, u(Piece).file, u(Piece).org + R.off) 333 END 334 END OpenReader; 335 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 344 END 345 ELSIF u IS Elem THEN ch := ElemChar; R.elem := u(Elem) 346 ELSE ch := 0X; R.elem := NIL; R.eot := TRUE 347 END; 348 IF R.off = u.len THEN INC(R.org, u.len); u := u.next; 349 IF u IS Piece THEN 350 WITH u: Piece DO Files.Set(R.rider, u.file, u.org) END 351 END; 352 R.run := u; R.off := 0 353 END 354 END Read; 355 356 PROCEDURE ReadElem* (VAR R: Reader); 357 VAR u, un: Run; 358 BEGIN u := R.run; 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); 362 IF un IS Piece THEN 363 WITH un: Piece DO Files.Set(R.rider, un.file, un.org) END 364 END 365 ELSE R.eot := TRUE; R.elem := NIL 366 END 367 END ReadElem; 368 369 PROCEDURE ReadPrevElem* (VAR R: Reader); 370 VAR u: Run; 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 376 END 377 END ReadPrevElem; 378 379 PROCEDURE Pos* (VAR R: Reader): LONGINT; 380 BEGIN RETURN R.org + R.off 381 END Pos; 382 383 384 (** Scanners --------------- NW --------------- **) 385 386 PROCEDURE OpenScanner* (VAR S: Scanner; T: Text; pos: LONGINT); 387 BEGIN OpenReader(S, T, pos); S.line := 0; S.nextCh := " " 388 END OpenScanner; 389 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 *) 393 394 PROCEDURE Scan* (VAR S: Scanner); 395 CONST maxD = 32; 396 VAR ch, term: CHAR; 397 neg, negE, hex: BOOLEAN; 398 i, j, h: SHORTINT; 399 e: INTEGER; k: LONGINT; 400 x, f: REAL; y, g: LONGREAL; 401 d: ARRAY maxD OF CHAR; 402 403 PROCEDURE ReadScaleFactor; 404 BEGIN Read(S, ch); 405 IF ch = "-" THEN negE := TRUE; Read(S, ch) 406 ELSE negE := FALSE; 407 IF ch = "+" THEN Read(S, ch) END 408 END; 409 WHILE ("0" <= ch) & (ch <= "9") DO 410 e := e*10 + ORD(ch) - 30H; Read(S, ch) 411 END 412 END ReadScaleFactor; 413 414 BEGIN ch := S.nextCh; i := 0; 415 LOOP 416 IF ch = CR THEN INC(S.line) 417 ELSIF (ch # " ") & (ch # TAB) THEN EXIT 418 END ; 419 Read(S, ch) 420 END; 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*) 429 Read(S, ch); 430 WHILE (ch # 22X) & (ch >= " ") & (i # 63) DO (* << *) 431 S.s[i] := ch; INC(i); Read(S, ch) 432 END; 433 S.s[i] := 0X; S.len := i+1; Read(S, ch); S.class := 2 434 ELSE 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; 440 IF "9" < ch THEN 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) 443 ELSE EXIT 444 END 445 END 446 END; 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*) 455 Read(S, ch); h := i; 456 WHILE ("0" <= ch) & (ch <= "9") DO d[i] := ch; INC(i); Read(S, ch) END ; 457 IF ch = "D" THEN 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 ; 461 ReadScaleFactor; 462 IF negE THEN 463 IF e <= 308 THEN y := y / Reals.TenL(e) ELSE y := 0 END 464 ELSIF e > 0 THEN 465 IF e <= 308 THEN y := Reals.TenL(e) * y ELSE HALT(40) END 466 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 ; 473 IF negE THEN 474 IF e <= 38 THEN x := x / Reals.Ten(e) ELSE x := 0 END 475 ELSIF e > 0 THEN 476 IF e <= 38 THEN x := Reals.Ten(e) * x ELSE HALT(40) END 477 END ; 478 IF neg THEN x := -x END ; 479 S.class := 4; S.x := x 480 END ; 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 487 END 488 ELSE S.class := 6; 489 IF neg THEN S.c := "-" ELSE S.c := ch; Read(S, ch) END 490 END 491 END; 492 S.nextCh := ch 493 END Scan; 494 495 496 (** Writers **) 497 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) 502 END OpenWriter; 503 504 PROCEDURE SetFont* (VAR W: Writer; fnt: FontsFont); 505 BEGIN W.fnt := fnt 506 END SetFont; 507 508 PROCEDURE SetColor* (VAR W: Writer; col: SYSTEM.INT8); 509 BEGIN W.col := col 510 END SetColor; 511 512 PROCEDURE SetOffset* (VAR W: Writer; voff: SYSTEM.INT8); 513 BEGIN W.voff := voff 514 END SetOffset; 515 516 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 (* << *) 522 INC(u.len) 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 (* << *) 526 END 527 END Write; 528 529 PROCEDURE WriteElem* (VAR W: Writer; e: Elem); 530 VAR u, un: Run; 531 BEGIN 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 535 END WriteElem; 536 537 PROCEDURE WriteLn* (VAR W: Writer); 538 BEGIN Write(W, CR) 539 END WriteLn; 540 541 PROCEDURE WriteString* (VAR W: Writer; s: ARRAY OF CHAR); 542 VAR i: INTEGER; 543 BEGIN i := 0; 544 WHILE s[i] >= " " DO Write(W, s[i]); INC(i) END 545 END WriteString; 546 547 PROCEDURE WriteInt* (VAR W: Writer; x, n: SYSTEM.INT64); 548 VAR 549 i: INTEGER; x0: SYSTEM.INT64; 550 a: ARRAY 24 OF CHAR; 551 BEGIN i := 0; 552 IF x < 0 THEN 553 IF x = MIN(SYSTEM.INT64) THEN WriteString(W, " -9223372036854775808"); RETURN 554 ELSE DEC(n); x0 := -x 555 END 556 ELSE x0 := x 557 END; 558 REPEAT 559 a[i] := CHR(x0 MOD 10 + 30H); x0 := x0 DIV 10; INC(i) 560 UNTIL x0 = 0; 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 564 END WriteInt; 565 566 PROCEDURE WriteHex* (VAR W: Writer; x: LONGINT); 567 VAR i: INTEGER; y: LONGINT; 568 a: ARRAY 20 OF CHAR; 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) 573 UNTIL i = 8; 574 REPEAT DEC(i); Write(W, a[i]) UNTIL i = 0 575 END WriteHex; 576 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); 581 IF e = 0 THEN 582 WriteString(W, " 0"); 583 REPEAT Write(W, " "); DEC(n) UNTIL n <= 3 584 ELSIF e = 255 THEN 585 WriteString(W, " NaN"); 586 WHILE n > 4 DO Write(W, " "); DEC(n) END 587 ELSE 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; 600 Write(W, "E"); 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)) 603 END 604 END WriteReal; 605 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; 609 610 PROCEDURE seq(ch: CHAR; n: INTEGER); 611 BEGIN WHILE n > 0 DO Write(W, ch); DEC(n) END 612 END seq; 613 614 PROCEDURE dig(n: INTEGER); 615 BEGIN 616 WHILE n > 0 DO 617 DEC(i); Write(W, d[i]); DEC(n) 618 END 619 END dig; 620 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 629 END; 630 IF x >= 10.0 THEN x := 0.1*x; INC(e) END; 631 (* 1 <= x < 10 *) 632 IF k+e >= maxD-1 THEN k := maxD-1-e 633 ELSIF k+e < 0 THEN k := -e; x := 0.0 634 END; 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); 639 IF e > 0 THEN 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) 645 END 646 END 647 END WriteRealFix; 648 649 PROCEDURE WriteRealHex* (VAR W: Writer; x: REAL); 650 VAR i: INTEGER; 651 d: ARRAY 8 OF CHAR; 652 BEGIN Reals.ConvertH(x, d); i := 0; 653 REPEAT Write(W, d[i]); INC(i) UNTIL i = 8 654 END WriteRealHex; 655 656 PROCEDURE WriteLongReal* (VAR W: Writer; x: LONGREAL; n: INTEGER); 657 CONST maxD = 16; 658 VAR e: INTEGER; x0: LONGREAL; 659 d: ARRAY maxD OF CHAR; 660 BEGIN e := Reals.ExpoL(x); 661 IF e = 0 THEN 662 WriteString(W, " 0"); 663 REPEAT Write(W, " "); DEC(n) UNTIL n <= 3 664 ELSIF e = 2047 THEN 665 WriteString(W, " NaN"); 666 WHILE n > 4 DO Write(W, " "); DEC(n) END 667 ELSE 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; 672 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; 677 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 ; 681 682 (* Generate the mantissa digits of x *) 683 Reals.ConvertL(x, n, d); 684 685 DEC(n); Write(W, d[n]); Write(W, "."); 686 REPEAT DEC(n); Write(W, d[n]) UNTIL n = 0; 687 688 Write(W, "D"); 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)) 693 END 694 END WriteLongReal; 695 696 PROCEDURE WriteLongRealHex* (VAR W: Writer; x: LONGREAL); 697 VAR i: INTEGER; 698 d: ARRAY 16 OF CHAR; 699 BEGIN Reals.ConvertHL(x, d); i := 0; 700 REPEAT Write(W, d[i]); INC(i) UNTIL i = 16 701 END WriteLongRealHex; 702 703 PROCEDURE WriteDate* (VAR W: Writer; t, d: LONGINT); 704 705 PROCEDURE WritePair(ch: CHAR; x: LONGINT); 706 BEGIN Write(W, ch); 707 Write(W, CHR(x DIV 10 + 30H)); Write(W, CHR(x MOD 10 + 30H)) 708 END WritePair; 709 710 BEGIN 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) 713 END WriteDate; 714 715 716 (** Text Filing **) 717 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; 722 f: Files.File; 723 msg: FileMsg; 724 mods, procs: ARRAY 64, 32 OF CHAR; 725 name: ARRAY 32 OF CHAR; 726 fnts: ARRAY 32 OF FontsFont; 727 728 PROCEDURE LoadElem (VAR r: Files.Rider; pos, span: LONGINT; VAR e: Elem); 729 VAR M: Modules.Module; Cmd: Modules.Command; a: Alien; 730 org, ew, eh: LONGINT; eno: SYSTEM.INT8; 731 BEGIN new := NIL; 732 Files.ReadLInt(r, ew); Files.ReadLInt(r, eh); Files.Read(r, eno); 733 IF eno > ecnt THEN ecnt := eno; Files.ReadString(r, mods[eno]); Files.ReadString(r, procs[eno]) END; 734 org := Files.Pos(r); M := Modules.ThisMod(mods[eno]); 735 IF M # NIL THEN Cmd := Modules.ThisCommand(M, procs[eno]); 736 IF Cmd # NIL THEN Cmd END 737 END; 738 e := new; 739 IF e # NIL THEN e.W := ew; e.H := eh; e.base := T; 740 msg.pos := pos; e.handle(e, msg); 741 IF Files.Pos(r) # org + span THEN e := NIL END 742 END; 743 IF e = NIL THEN Files.Set(r, f, org + span); 744 NEW(a); a.W := ew; a.H := eh; a.handle := HandleAlien; a.base := T; 745 a.file := f; a.org := org; a.span := span; 746 COPY(mods[eno], a.mod); COPY(procs[eno], a.proc); 747 e := a 748 END 749 END LoadElem; 750 751 BEGIN pos := Files.Pos(r); f := Files.Base(r); 752 NEW(u); u.len := MAX(LONGINT); (*u.fnt := FontsDefault;*)u.fnt := NIL; u.col := Displaywhite; 753 T.head := u; ecnt := 0; fcnt := 0; 754 msg.id := load; msg.r := r; 755 Files.ReadLInt(msg.r, hlen); (*!!!org := pos + hlen;*) org := pos -2 + hlen; pos := org; Files.Read(msg.r, fno); 756 WHILE fno # 0 DO 757 IF fno > fcnt THEN fcnt := fno; Files.ReadString(msg.r, name); fnts[fno] := FontsThis(name) END; 758 Files.Read(msg.r, col); Files.Read(msg.r, voff); Files.ReadLInt(msg.r, plen); 759 IF plen > 0 THEN NEW(p); p.file := f; p.org := pos; p.ascii := FALSE; un := p; un.len := plen 760 ELSE LoadElem(msg.r, pos - org, -plen, e); un := e; un.len := 1 761 END; 762 (*un.fnt := fnts[fno];*) un.col := col; un.voff := voff; 763 INC(pos, un.len); u.next := un; un.prev := u; u := un; Files.Read(msg.r, fno) 764 END; 765 u.next := T.head; T.head.prev := u; T.cache := T.head; T.corg := 0; 766 Files.ReadLInt(msg.r, T.len); Files.Set(r, f, Files.Pos(msg.r) + T.len) 767 END Load0; 768 769 PROCEDURE Load* (VAR r: Files.Rider; T: Text); 770 CONST oldTag = -4095; 771 VAR tag: INTEGER; 772 BEGIN 773 (* for compatibility inner text tags are checked and skipped; remove this in a later version *) 774 Files.ReadInt(r, tag); IF tag # oldTag THEN Files.Set(r, Files.Base(r), Files.Pos(r)-2) END; 775 Load0(r, T) 776 END Load; 777 778 PROCEDURE Open* (T: Text; name: ARRAY OF CHAR); 779 VAR f: Files.File; r: Files.Rider; u: Run; p: Piece; tag, version: CHAR; hlen: LONGINT; 780 BEGIN f := Files.Old(name); 781 IF f = NIL THEN f := Files.New("") END; 782 Files.Set(r, f, 0); Files.Read(r, tag); Files.Read(r, version); 783 IF (tag = textTag) OR (tag = 01X) & (version = textTag) THEN Load0(r, T) 784 ELSE (*ascii*) 785 NEW(u); u.len := MAX(LONGINT); u.fnt := NIL; u.col := Displaywhite; 786 NEW(p); 787 IF (tag = DocBlockId) & (version = 07X) THEN (* extract ascii text from System 3 text document *) 788 Files.Set(r, f, 28); Files.ReadLInt(r, hlen); 789 Files.Set(r, f, 22 + hlen); Files.ReadLInt(r, T.len); p.org := 26 + hlen 790 ELSE 791 T.len := Files.Length(f); p.org := 0 792 END ; 793 IF T.len > 0 THEN p.len := T.len; p.fnt := FontsDefault; 794 p.col := Displaywhite; p.voff := 0; p.file := f; p.ascii := TRUE; 795 u.next := p; u.prev := p; p.next := u; p.prev := u 796 ELSE u.next := u; u.prev := u 797 END; 798 T.head := u; T.cache := T.head; T.corg := 0 799 END 800 END Open; 801 802 PROCEDURE Store* (VAR r: Files.Rider; T: Text); 803 VAR r1: Files.Rider; u, un: Run; e: Elem; org, pos, delta, hlen, rlen: LONGINT; ecnt, fcnt: SHORTINT; ch: CHAR; (* << *) 804 fno: SYSTEM.INT8; 805 msg: FileMsg; iden: IdentifyMsg; 806 mods, procs: ARRAY 64, 32 OF CHAR; 807 fnts: ARRAY 32 OF FontsFont; 808 block: ARRAY 1024 OF CHAR; 809 810 PROCEDURE StoreElem (VAR r: Files.Rider; pos: LONGINT; e: Elem); 811 VAR r1: Files.Rider; org, span: LONGINT; eno: SYSTEM.INT8; 812 BEGIN COPY(iden.mod, mods[ecnt]); COPY(iden.proc, procs[ecnt]); eno := 1; 813 WHILE (mods[eno] # iden.mod) OR (procs[eno] # iden.proc) DO INC(eno) END; 814 Files.Set(r1, Files.Base(r), Files.Pos(r)); 815 Files.WriteLInt(r, 0); Files.WriteLInt(r, 0); Files.WriteLInt(r, 0); (*fixup slot*) 816 Files.Write(r, eno); 817 IF eno = ecnt THEN INC(ecnt); Files.WriteString(r, iden.mod); Files.WriteString(r, iden.proc) END; 818 msg.pos := pos; org := Files.Pos(r); e.handle(e, msg); span := Files.Pos(r) - org; 819 Files.WriteLInt(r1, -span); Files.WriteLInt(r1, e.W); Files.WriteLInt(r1, e.H) (*fixup*) 820 END StoreElem; 821 822 BEGIN 823 org := Files.Pos(r); msg.id := store; msg.r := r; Files.WriteLInt(msg.r, 0); (*fixup slot*) 824 u := T.head.next; pos := 0; delta := 0; fcnt := 1; ecnt := 1; 825 WHILE u # T.head DO 826 IF u IS Elem THEN iden.mod[0] := 0X; u(Elem).handle(u(Elem), iden) ELSE iden.mod[0] := 1X END; 827 IF iden.mod[0] # 0X THEN 828 fnts[fcnt] := u.fnt; fno := 1; 829 WHILE fnts[fno].name # u.fnt.name DO INC(fno) END; 830 Files.Write(msg.r, fno); 831 IF fno = fcnt THEN INC(fcnt); Files.WriteString(msg.r, u.fnt.name) END; 832 Files.Write(msg.r, u.col); Files.Write(msg.r, u.voff) 833 END; 834 IF u IS Piece THEN rlen := u.len; un := u.next; 835 WHILE (un IS Piece) & (un.fnt = u.fnt) & (un.col = u.col) & (un.voff = u.voff) DO 836 INC(rlen, un.len); un := un.next 837 END; 838 Files.WriteLInt(msg.r, rlen); INC(pos, rlen); u := un 839 ELSIF iden.mod[0] # 0X THEN StoreElem(msg.r, pos, u(Elem)); INC(pos); u := u.next 840 ELSE INC(delta); u := u.next 841 END 842 END; 843 Files.Write(msg.r, 0); Files.WriteLInt(msg.r, T.len - delta); 844 (*!!!hlen := Files.Pos(msg.r) - org;*) hlen := Files.Pos(msg.r) - org + 2; 845 Files.Set(r1, Files.Base(msg.r), org); Files.WriteLInt(r1, hlen); (*fixup*) 846 u := T.head.next; 847 WHILE u # T.head DO 848 IF u IS Piece THEN 849 WITH u: Piece DO 850 IF u.ascii THEN Files.Set(r1, u.file, u.org); delta := u.len; (* << LF to CR *) 851 WHILE delta > 0 DO Files.Read(r1, ch); DEC(delta); 852 IF ch = 0AX THEN Files.Write(msg.r, CR) ELSE Files.Write(msg.r, ch) END 853 END 854 ELSE Files.Set(r1, u.file, u.org); delta := u.len; 855 WHILE delta > LEN(block) DO Files.ReadBytes(r1, block, LEN(block)); 856 Files.WriteBytes(msg.r, block, LEN(block)); DEC(delta, LEN(block)) 857 END; 858 Files.ReadBytes(r1, block, delta); Files.WriteBytes(msg.r, block, delta) 859 END 860 END 861 ELSE iden.mod[0] := 0X; u(Elem).handle(u(Elem), iden); 862 IF iden.mod[0] # 0X THEN Files.Write(msg.r, ElemChar) END 863 END; 864 u := u.next 865 END; 866 r := msg.r; 867 IF T.notify # NIL THEN T.notify(T, unmark, 0, 0) END 868 END Store; 869 870 PROCEDURE Close* (T: Text; name: ARRAY OF CHAR); 871 VAR f: Files.File; r: Files.Rider; i, res: INTEGER; bak: ARRAY 64 OF CHAR; 872 BEGIN 873 f := Files.New(name); Files.Set(r, f, 0); Files.Write(r, textTag); Files.Write(r, version); Store(r, T); 874 i := 0; WHILE name[i] # 0X DO INC(i) END; 875 COPY(name, bak); bak[i] := "."; bak[i+1] := "B"; bak[i+2] := "a"; bak[i+3] := "k"; bak[i+4] := 0X; 876 Files.Rename(name, bak, res); Files.Register(f) 877 END Close; 878 879BEGIN del := NIL; NEW(FontsDefault); FontsDefault.name := "Syntax10.Scn.Fnt" 880END Texts. 881