From 04e68443040c7abad84d66477e98f93bed701760 Mon Sep 17 00:00:00 2001 From: Lars-Dominik Braun Date: Mon, 4 Feb 2019 13:09:03 +0100 Subject: Initial import --- system/multiuser/1.7.5/src/basic archive | 401 +++++++++++++++++++++++++++++++ 1 file changed, 401 insertions(+) create mode 100644 system/multiuser/1.7.5/src/basic archive (limited to 'system/multiuser/1.7.5/src/basic archive') diff --git a/system/multiuser/1.7.5/src/basic archive b/system/multiuser/1.7.5/src/basic archive new file mode 100644 index 0000000..8235607 --- /dev/null +++ b/system/multiuser/1.7.5/src/basic archive @@ -0,0 +1,401 @@ +(* ------------------- VERSION 11 06.03.86 ------------------- *) +PACKET basic archive DEFINES + + archive blocks , + block number , + check read , + format archive , + read block , + read , + rewind , + search dataspace , + seek , + size , + skip dataspace , + write block , + write : + +INT VAR blocknr := 0 , + rerun := 0 , + page := -1 , + bit word := 1 , + unreadable sequence length := 0 ; +INT CONST all ones :=-1 ; + + +DATASPACE VAR label ds ; + +LET write normal = 0 , + archive version = 1 , + first page stored = 2 , + dr size = 3 , + first bit word = 4 , +(* write deleted data mark = 64 , *) + inconsistent = 90 , + read error = 92 , + label size = 131 ; + +BOUND STRUCT (ALIGN dummy for page1, + (* Page 2 begins: *) + ROW label size INT lab) VAR label; + + +INT PROC block number : + block nr +ENDPROC block number ; + +PROC seek (INT CONST block) : + block nr := block +ENDPROC seek ; + +PROC rewind : + forget (label ds); + label ds := nilspace; + label := label ds; + block nr := 0; + rerun := session +END PROC rewind; + +PROC skip dataspace: + check rerun; + get label; + IF is error + THEN + ELIF olivetti + THEN block nr INCR label.lab (dr size+1) + ELSE block nr INCR label.lab (dr size) + FI +END PROC skip dataspace; + +PROC read (DATASPACE VAR ds): + read (ds, 30000, FALSE) +ENDPROC read ; + +PROC read (DATASPACE VAR ds, INT CONST max pages, BOOL CONST error accept) : + enable stop ; + check rerun; + get label; + init next page; + INT VAR i ; + FOR i FROM 1 UPTO max pages REP + next page; + IF no further page THEN LEAVE read FI; + check storage ; + check rerun ; + read block ; + block nr INCR 1; + PER . + +read block : + disable stop ; + get external block (ds, page, block nr) ; + ignore read error if no errors accepted ; + enable stop . + +ignore read error if no errors accepted : + IF is error CAND error code = read error CAND NOT error accept + THEN clear error + FI . + +check storage : + INT VAR size, used ; + storage (size, used) ; + IF used > size + THEN forget (ds) ; + ds := nilspace ; + errorstop ("Speicherengpass") ; + LEAVE read + FI . + +check rerun : + IF rerun <> session + THEN errorstop ("RERUN beim Archiv-Zugriff") ; + LEAVE read + FI . + +END PROC read; + +PROC check read : + + enable stop ; + get label ; + INT VAR pages, i; + IF olivetti + THEN pages := label.lab (dr size+1) + ELSE pages := label.lab (dr size) + FI ; + FOR i FROM 1 UPTO pages REP + get external block (label ds, 2, block nr) ; + block nr INCR 1 + PER . + +ENDPROC check read ; + +PROC write (DATASPACE CONST ds): + enable stop ; + check rerun; + INT VAR label block nr := block nr; + block nr INCR 1;init label; + INT VAR page := -1,i; + FOR i FROM 1 UPTO ds pages (ds) REP + check rerun ; + page := next ds page(ds,page); + put external block (ds, page, block nr) ; + reset archive bit; + label.lab(dr size) INCR 1; + block nr INCR 1 + PER; + put label. + + + init label: + label.lab(archive version) := 0 ; + label.lab(first page stored) := 0 ; + label.lab(dr size) := 0; + INT VAR j; + FOR j FROM first bit word UPTO label size REP + label.lab (j) := all ones + PER. + + put label: + put external block (label ds, 2, label block nr). + + reset archive bit: + reset bit (label.lab (page DIV 16+first bit word), page MOD 16). + +END PROC write; + +PROC get label: + + enable stop ; + get external block (label ds, 2, block nr) ; + block nr INCR 1; + check label. + +check label: + IF may be z80 format label OR may be old olivetti format label + THEN + ELSE errorstop (inconsistent, "Archiv inkonsistent") + FI. + +may be z80 format label : + z80 archive AND label.lab(dr size) > 0 . + +may be old olivetti format label : + olivetti AND label.lab(first page stored)=0 AND label.lab(dr size+1) > 0 . + +END PROC get label; + +PROC next page: + IF z80 archive + THEN + WHILE labelbits = all ones REP + bitword INCR 1; + IF bitword >= label size THEN + no further page := true; LEAVE next page FI + PER; + INT VAR p := lowest reset (labelbits); + set bit (labelbits, p); + page := 16*(bitword-first bit word)+p + ELSE + WHILE oli bits = 0 REP + bitword INCR 1; + IF bitword >= labelsize-64 THEN + no further page := true; LEAVE next page FI + PER; + p := lowest set (oli bits); + reset bit (olibits, p); + page := 16*(bitword-firstbitword)+p; + FI. + + label bits : label.lab (bitword). + oli bits : label.lab (bitword+1). + +END PROC next page; +. +olivetti : label.lab (archive version) = -1. + +z80 archive : label.lab (archive version) = 0. + +init next page: + BOOL VAR no further page := false; + bitword := first bit word. + +check rerun : + IF rerun <> session + THEN errorstop ("RERUN beim Archiv-Zugriff") + FI . + +PROC get external block (DATASPACE VAR ds, INT CONST page, + INT CONST block nr): + + INT VAR error ; + read block (ds, page, block nr, error) ; + SELECT error OF + CASE 0: read succeeded + CASE 1: error stop ("Lesen unmoeglich (Archiv)") + CASE 2: read failed + CASE 3: error stop ("Archiv-Ueberlauf") + OTHERWISE error stop ("??? (Archiv)") + END SELECT . + +read succeeded : + unreadable sequence length := 0 . + +read failed : + unreadable sequence length INCR 1 ; + IF unreadable sequence length >= 30 + THEN errorstop ("30 unlesbare Bloecke hintereinander") + ELSE error stop (read error, "Lesefehler (Archiv)") + FI . + +END PROC get external block; + +PROC put external block (DATASPACE CONST ds, INT CONST page, + INT CONST block nr): + INT VAR error; + write block (ds, page, write normal, block nr, error) ; + SELECT error OF + CASE 0: + CASE 1: error stop ("Schreiben unmoeglich (Archiv)") + CASE 2: error stop ("Schreibfehler (Archiv)") + CASE 3: error stop ("Archiv-Ueberlauf") + OTHERWISE error stop ("??? (Archiv)") + END SELECT . + +END PROC put external block; + +PROC read block (DATASPACE VAR ds, + INT CONST ds page no, + INT CONST block no, + INT VAR return code) : + read block; + retry if read error. + +read block: + block in (ds, ds page no, 0, block no, return code). + +retry if read error: + INT VAR retry; + FOR retry FROM 1 UPTO 10 WHILE return code = 2 REP + reset to block 0 if fifth try; + read block + PER. + +reset to block 0 if fifth try: + IF retry = 5 + THEN block in (ds, ds page no, 0, 0, return code) + FI. + +END PROC read block; + +PROC write block (DATASPACE CONST ds, + INT CONST ds page no, + INT CONST mode, + INT CONST block no, + INT VAR return code): + write block; + retry if write error. + +write block: + block out (ds, ds page no, mode * 256, block no, return code) . + +retry if write error: + INT VAR retry; + FOR retry FROM 1 UPTO 10 WHILE return code = 2 REP + reset to block 0 if fifth try; + write block + PER. + +reset to block 0 if fifth try: + IF retry = 5 + THEN disable stop; + DATASPACE VAR dummy ds := nilspace; + block in (dummy ds, 2, 0, 0, return code); + forget (dummy ds); + enable stop + FI. + +END PROC write block; + +INT PROC size (INT CONST key) : + + INT VAR return code ; + control (5, key, 0, return code) ; + return code . + +ENDPROC size ; + +INT PROC archive blocks : + size (0) +ENDPROC archive blocks ; + +PROC search dataspace (INT VAR ds pages) : + + disable stop ; + ds pages := -1 ; + INT CONST last block := archive blocks ; + + WHILE block nr < last block REP + IF block is dataspace label + THEN ds pages := pages counted ; + LEAVE search dataspace + FI ; + block nr INCR 1 + UNTIL is error PER . + +block is dataspace label : + look at label block ; + IF is error + THEN IF error code = read error OR error code = inconsistent + THEN clear error + FI ; + FALSE + ELSE count pages ; + pages counted = number of pages as label says + FI . + +look at label block : + INT CONST + old block nr := block nr ; + get label ; + block nr := old block nr. + +count pages : + INT VAR + pages counted := 0 ; + init next page ; + next page ; + WHILE NOT no further page REP + pages counted INCR 1 ; + next page + PER . + +number of pages as label says : label.lab (dr size) . + +ENDPROC search dataspace ; + +PROC format archive (INT CONST format code) : + + IF format is possible + THEN format + ELSE errorstop ("'format' ist hier nicht implementiert") + FI . + +format is possible : + INT VAR return code ; + control (1,0,0, return code) ; + bit (return code, 4) . + +format : + control (7, format code, 0, return code) ; + IF return code = 1 + THEN errorstop ("Formatieren unmoeglich") + ELIF return code > 1 + THEN errorstop ("Schreibfehler (Archiv)") + FI . + +ENDPROC format archive ; + +END PACKET basic archive; + -- cgit v1.2.3