home *** CD-ROM | disk | FTP | other *** search
/ Amiga MA Magazine 1998 #6 / amigamamagazinepolishissue1998.iso / coders / jËzyki_programowania / oberon / demos / compress.mod (.txt) next >
Oberon Text  |  1977-12-31  |  30KB  |  1,234 lines
  1. Syntax10.Scn.Fnt
  2. MODULE Compress; (* (c) ejz, first version: 14.1.92, this version: 30.11.94 *)
  3.     IMPORT Files, Texts, Oberon, MenuViewers, TextFrames, Viewers;
  4.         CONST
  5.             BufferSize = 8192;
  6.             IndexBitCount = 12;
  7.             LengthBitCount = 4;
  8.             WindowSize = 4096;
  9.             RawLookAheadSize = 16;
  10.             BreakEven = 1;
  11.             LookAheadSize = RawLookAheadSize + BreakEven;
  12.             TreeRoot = WindowSize;
  13.             EndOfStream = 0;
  14.             Unused = 0;
  15.             Temp = "temp.temp";
  16.             err1 = "Error in archive";
  17.             err2 = " not found";
  18.             err3 = " Archive to big";
  19.             err4 = "Filename to long, can not append .bak";
  20.             DirMenu = "System.Close System.Grow Compress.Open Compress.Extract Compress.Delete Compress.Add";
  21.             EditMenu = "System.Close System.Copy System.Grow Edit.Search Edit.Store";
  22.             maxFileSize = 3000000;
  23.             xx = 32768;
  24.             Menu = 0;
  25.             Cmd = 1;
  26.             EOFName = "~ ";
  27.         TYPE
  28.             Node = RECORD
  29.                 parent , smallerChild, largerChild: INTEGER
  30.             END;
  31.             fName = ARRAY 32 OF CHAR;
  32.             Header = RECORD
  33.                 Name: fName;
  34.                 length, Check: LONGINT;
  35.                 date, time: LONGINT;
  36.                 ratio: REAL
  37.             END;
  38.             List = POINTER TO ListDesc;
  39.             ListDesc = RECORD
  40.                 Name: fName;
  41.                 next: List
  42.             END;
  43.             AddList = POINTER TO AddListDesc;
  44.             AddListDesc = RECORD
  45.                 Name: fName;
  46.                 next: AddList;
  47.                 pos: LONGINT
  48.             END;
  49.         VAR
  50.             W: Texts.Writer;
  51.             Buffer: ARRAY BufferSize OF CHAR;
  52.             BufferPtr, CurBitNr, Len, maxLen: LONGINT;
  53.             CurByte: LONGINT;
  54.             Window: ARRAY WindowSize+RawLookAheadSize+1 OF CHAR;
  55.             Tree: POINTER TO ARRAY WindowSize+1 OF Node;
  56.             Err, opt, sym: BOOLEAN;
  57.             T: Texts.Text;
  58.             cmdSource: INTEGER;
  59.             help : INTEGER;
  60.         PROCEDURE WriteString(str: ARRAY OF CHAR);
  61.         BEGIN
  62.             Texts.WriteString(W, str);
  63.             Texts.Append(T, W.buf)
  64.         END WriteString;
  65.         PROCEDURE WriteLn;
  66.         BEGIN
  67.             Texts.WriteLn(W);
  68.             Texts.Append(T, W.buf)
  69.         END WriteLn;
  70.         PROCEDURE WriteInt(i: LONGINT);
  71.         BEGIN
  72.             Texts.WriteInt(W, i, 0);
  73.             Texts.Append(T, W.buf)
  74.         END WriteInt;
  75.         PROCEDURE WriteReal(r: REAL);
  76.         BEGIN
  77.             Texts.WriteReal(W, r, 10);
  78.             Texts.Append(T, W.buf)
  79.         END WriteReal;
  80.         PROCEDURE WriteDate(t, d: LONGINT);
  81.         BEGIN
  82.             Texts.WriteDate(W, t, d);
  83.             Texts.Append(T, W.buf)
  84.         END WriteDate;
  85.         PROCEDURE ReadHeader(VAR R: Files.Rider; VAR h: Header; VAR err: BOOLEAN);
  86.             VAR
  87.                 i: INTEGER;
  88.                 chk: LONGINT;
  89.         BEGIN
  90.             Files.ReadBytes(R, h.Name, 32);
  91.             IF R.eof & (R.res = 32) THEN
  92.                 h.Name := EOFName;
  93.                 err := FALSE;
  94.                 RETURN
  95.             END;
  96.             Files.ReadLInt(R, h.length);
  97.             Files.ReadLInt(R, h.Check);
  98.             Files.ReadLInt(R, h.date);
  99.             Files.ReadLInt(R, h.time);
  100.             Files.ReadReal(R, h.ratio);
  101.             IF (h.ratio > 0.0) & (h.ratio < 1000000.0) THEN
  102.                 i := 0;
  103.                 chk := 0;
  104.                 WHILE i < 32 DO
  105.                     chk := chk+ORD(h.Name[i]);
  106.                     INC(i)
  107.                 END;
  108.                 chk := chk+h.length+ENTIER(h.ratio)+(h.time MOD xx)+(h.date MOD xx);
  109.                 err := chk # h.Check
  110.             ELSE
  111.                 err := TRUE
  112.             END
  113.         END ReadHeader;
  114.         PROCEDURE WriteHeader(VAR R: Files.Rider; VAR h: Header; newDate: BOOLEAN);
  115.             VAR i: INTEGER;
  116.         BEGIN
  117.             h.Check := 0;
  118.             i := 0;
  119.             WHILE i < 32 DO
  120.                 h.Check := h.Check + ORD(h.Name[i]);
  121.                 INC(i)
  122.             END;
  123.             IF newDate THEN
  124.                 Oberon.GetClock(h.time, h.date)
  125.             END;
  126.             h.Check := h.Check+h.length+(h.time MOD xx)+(h.date MOD xx)+ENTIER(h.ratio);
  127.             Files.WriteBytes(R, h.Name, 32);
  128.             Files.WriteLInt(R, h.length);
  129.             Files.WriteLInt(R, h.Check);
  130.             Files.WriteLInt(R, h.date);
  131.             Files.WriteLInt(R, h.time);
  132.             Files.WriteReal(R, h.ratio)
  133.         END WriteHeader;
  134.         PROCEDURE CopyFrom(VAR Ri, Ro: Files.Rider; len: LONGINT);
  135.             VAR i: LONGINT;
  136.         BEGIN
  137.             Files.ReadBytes(Ri, Buffer, BufferSize);
  138.             i := BufferSize;
  139.             WHILE i <= len DO
  140.                 Files.WriteBytes(Ro, Buffer, BufferSize);
  141.                 Files.ReadBytes(Ri, Buffer, BufferSize);
  142.                 INC(i, BufferSize)
  143.             END;
  144.             Files.WriteBytes(Ro, Buffer, len MOD BufferSize)
  145.         END CopyFrom;
  146.         PROCEDURE CopyTo(VAR Ri, Ro: Files.Rider);
  147.         BEGIN
  148.             Files.ReadBytes(Ri, Buffer, BufferSize);
  149.             WHILE ~Ri.eof DO
  150.                 Files.WriteBytes(Ro, Buffer, BufferSize);
  151.                 Files.ReadBytes(Ri, Buffer, BufferSize)
  152.             END;
  153.             Files.WriteBytes(Ro, Buffer, BufferSize-Ri.res)
  154.         END CopyTo;
  155.         PROCEDURE FlushBits(VAR R: Files.Rider);
  156.         BEGIN
  157.             IF CurBitNr # 7 THEN
  158.                 Buffer[BufferPtr] := CHR(CurByte);
  159.                 INC(BufferPtr)
  160.             END;
  161.             IF BufferPtr > 0 THEN
  162.                 Files.WriteBytes(R, Buffer, BufferPtr);
  163.                 INC(Len, BufferPtr)
  164.             END
  165.         END FlushBits;
  166.         PROCEDURE InputBit(VAR R: Files.Rider): LONGINT;
  167.             VAR h: LONGINT;
  168.         BEGIN
  169.             IF CurBitNr = 7 THEN
  170.                 IF BufferPtr = BufferSize THEN
  171.                     Files.ReadBytes(R, Buffer, BufferSize);
  172.                     INC(Len, BufferSize);
  173.                     IF Len >= maxLen+ BufferSize THEN Err := TRUE END;
  174.                     BufferPtr := 0
  175.                 END;
  176.                 CurByte := ORD(Buffer[BufferPtr]);
  177.                 INC(BufferPtr)
  178.             END;
  179.             h := ASH(CurByte, -CurBitNr) MOD 2;
  180.             DEC(CurBitNr);
  181.             IF CurBitNr < 0 THEN CurBitNr := 7 END;
  182.             RETURN h
  183.         END InputBit;
  184.         PROCEDURE InputBits(VAR R: Files.Rider; count: LONGINT): LONGINT;
  185.             VAR i, h: LONGINT;
  186.         BEGIN
  187.             h := 0;
  188.             i := count-1;
  189.             WHILE i >= 0 DO
  190.                 IF CurBitNr = 7 THEN
  191.                     IF BufferPtr = BufferSize THEN
  192.                         Files.ReadBytes(R, Buffer, BufferSize);
  193.                         INC(Len, BufferSize);
  194.                         IF Len > maxLen+ BufferSize THEN Err := TRUE END;
  195.                         BufferPtr := 0
  196.                     END;
  197.                     CurByte := ORD(Buffer[BufferPtr]);
  198.                     INC(BufferPtr)
  199.                 END;
  200.                 IF ASH(CurByte, -CurBitNr) MOD 2 = 1 THEN
  201.                     h := h+ASH(1, i)
  202.                 END;
  203.                 DEC(CurBitNr);
  204.                 IF CurBitNr < 0 THEN CurBitNr := 7 END;
  205.                 DEC(i)
  206.             END;
  207.             RETURN h
  208.         END InputBits;
  209.         PROCEDURE OutputBit(VAR R: Files.Rider; bit: LONGINT);
  210.         BEGIN
  211.             IF bit = 1 THEN
  212.                 CurByte := CurByte+ASH(1, CurBitNr)
  213.             END;
  214.             DEC(CurBitNr);
  215.             IF CurBitNr < 0 THEN
  216.                 Buffer[BufferPtr] := CHR(CurByte);
  217.                 INC(BufferPtr);
  218.                 IF BufferPtr = BufferSize THEN
  219.                     Files.WriteBytes(R,  Buffer, BufferSize);
  220.                     INC(Len, BufferSize);
  221.                     BufferPtr := 0
  222.                 END;
  223.                 CurBitNr := 7;
  224.                 CurByte := 0
  225.             END
  226.         END OutputBit;
  227.         PROCEDURE OutputBits(VAR R: Files.Rider; bits, count: LONGINT);
  228.             VAR i, h: LONGINT;
  229.         BEGIN
  230.             h := bits;
  231.             i := count-1;
  232.             WHILE i >= 0 DO
  233.                 IF ASH(h, -i) MOD 2 = 1 THEN
  234.                     CurByte := CurByte+ASH(1, CurBitNr)
  235.                 END;
  236.                 DEC(CurBitNr);
  237.                 IF CurBitNr < 0 THEN
  238.                     Buffer[BufferPtr] := CHR(CurByte);
  239.                     INC(BufferPtr);
  240.                     IF BufferPtr = BufferSize THEN
  241.                         Files.WriteBytes(R, Buffer, BufferSize);
  242.                         INC(Len, BufferSize);
  243.                         BufferPtr := 0
  244.                     END;
  245.                     CurBitNr := 7;
  246.                     CurByte := 0
  247.                 END;
  248.                 DEC(i)
  249.             END
  250.         END OutputBits;
  251.         PROCEDURE Init;
  252.             VAR i: INTEGER;
  253.         BEGIN
  254.             i := 0;
  255.             WHILE i < WindowSize DO
  256.                 Tree[i].parent := Unused;
  257.                 Tree[i].smallerChild := Unused;
  258.                 Tree[i].largerChild := Unused;
  259.                 Window[i] := CHR(0);
  260.                 INC(i)
  261.             END;
  262.             Tree[i].parent := Unused;
  263.             Tree[i].smallerChild := Unused;
  264.             Tree[i].largerChild := Unused;
  265.             WHILE i < WindowSize+RawLookAheadSize+1 DO
  266.                 Window[i] := CHR(0);
  267.                 INC(i)
  268.             END
  269.         END Init;
  270.         PROCEDURE InitTree(r: INTEGER);
  271.         BEGIN
  272.             Tree[TreeRoot].largerChild := r;
  273.             Tree[r].parent := TreeRoot;
  274.             Tree[r].largerChild := Unused;
  275.             Tree[r].smallerChild := Unused
  276.         END InitTree;
  277.         PROCEDURE ContractNode(oldNode, newNode: INTEGER);
  278.         BEGIN
  279.             help := Tree[oldNode].parent;
  280.             Tree[newNode].parent := help;
  281.             help := Tree[oldNode].parent;
  282.             IF Tree[help].largerChild = oldNode THEN
  283.                 Tree[help].largerChild := newNode
  284.             ELSE
  285.                 Tree[help].smallerChild := newNode
  286.             END;
  287.             Tree[oldNode].parent := Unused
  288.         END ContractNode;
  289.         PROCEDURE ReplaceNode(oldNode, newNode: INTEGER);
  290.             VAR parent: INTEGER;
  291.         BEGIN
  292.             parent := Tree[oldNode].parent;
  293.             IF Tree[parent].smallerChild = oldNode THEN
  294.                 Tree[parent].smallerChild := newNode
  295.             ELSE
  296.                 Tree[parent].largerChild := newNode
  297.             END;
  298.             Tree[newNode] := Tree[oldNode];
  299.             help := Tree[newNode].smallerChild;
  300.             Tree[help].parent := newNode;
  301.             help := Tree[newNode].largerChild;
  302.             Tree[help].parent := newNode;
  303.             Tree[oldNode].parent := Unused
  304.         END ReplaceNode;
  305.         PROCEDURE FindNextNode(node: INTEGER): INTEGER;
  306.             VAR next: INTEGER;
  307.         BEGIN
  308.             next := Tree[node].smallerChild;
  309.             WHILE Tree[next].largerChild # Unused DO
  310.                 next := Tree[next].largerChild
  311.             END;
  312.             RETURN next
  313.         END FindNextNode;
  314.         PROCEDURE DeleteString(p: INTEGER);
  315.             VAR replacement: INTEGER;
  316.         BEGIN
  317.             IF Tree[p].parent = Unused THEN
  318.                 RETURN
  319.             END;
  320.             IF Tree[p].largerChild = Unused THEN
  321.                 ContractNode(p, Tree[p].smallerChild)
  322.             ELSIF Tree[p].smallerChild = Unused THEN
  323.                 ContractNode(p, Tree[p].largerChild)
  324.             ELSE
  325.                 replacement := FindNextNode(p);
  326.                 DeleteString(replacement);
  327.                 ReplaceNode(p, replacement)
  328.             END
  329.         END DeleteString;
  330.         PROCEDURE AddString(newNode: INTEGER; VAR matchPosition: INTEGER): INTEGER;
  331.             VAR i, testNode, delta, matchLength, child: INTEGER;
  332.         BEGIN
  333.             IF newNode = EndOfStream THEN
  334.                 RETURN 0
  335.             END;
  336.             testNode := Tree[TreeRoot].largerChild;
  337.             matchLength := 0;
  338.             LOOP
  339.                 i := 0;
  340.                 delta := 0;
  341.                 WHILE (i < LookAheadSize) & (delta = 0) DO
  342.                     delta := ORD(Window[newNode+i]) - ORD(Window[testNode+i]);
  343.                     INC(i)
  344.                 END;
  345.                 IF delta # 0 THEN DEC(i) END;
  346.                 IF i >= matchLength THEN
  347.                     matchLength := i;
  348.                     matchPosition := testNode;
  349.                     IF matchLength >= LookAheadSize THEN
  350.                         ReplaceNode(testNode, newNode);
  351.                         RETURN matchLength
  352.                     END;
  353.                 END;
  354.                 IF delta >= 0 THEN
  355.                     child := Tree[testNode].largerChild
  356.                 ELSE
  357.                     child := Tree[testNode].smallerChild
  358.                 END;
  359.                 IF child = Unused THEN
  360.                     IF delta >= 0 THEN
  361.                         Tree[testNode].largerChild := newNode
  362.                     ELSE
  363.                         Tree[testNode].smallerChild := newNode
  364.                     END;
  365.                     Tree[newNode].parent := testNode;
  366.                     Tree[newNode].largerChild := Unused;
  367.                     Tree[newNode].smallerChild := Unused;
  368.                     RETURN matchLength
  369.                 END;
  370.                 testNode := child
  371.             END
  372.         END AddString;
  373.         PROCEDURE Compress(VAR Input, Output: Files.Rider);
  374.             VAR
  375.                 i, lookAheadBytes, currentPosition, replaceCount, matchLength, matchPosition: INTEGER;
  376.                 ch: CHAR;
  377.         BEGIN
  378.             Init;
  379.             currentPosition := 1;
  380.             i := 0;
  381.             WHILE (i < LookAheadSize) & ~Input.eof DO
  382.                 Files.Read(Input, ch);
  383.                 Window[currentPosition+i] := ch;
  384.                 IF currentPosition+i < RawLookAheadSize+1 THEN
  385.                     Window[currentPosition+i+WindowSize-1] := ch
  386.                 END;
  387.                 INC(i)
  388.             END;
  389.             IF Input.eof THEN DEC(i) END;
  390.             lookAheadBytes := i;
  391.             InitTree(currentPosition);
  392.             matchLength := 0;
  393.             matchPosition := 0;
  394.             WHILE lookAheadBytes > 0 DO
  395.                 IF matchLength > lookAheadBytes THEN
  396.                     matchLength := lookAheadBytes
  397.                 END;
  398.                 IF matchLength <= BreakEven THEN
  399.                     replaceCount := 1;
  400.                     OutputBit(Output, 1);
  401.                     OutputBits(Output, ORD(Window[currentPosition]), 8)
  402.                 ELSE
  403.                     OutputBit(Output, 0);
  404.                     OutputBits(Output, matchPosition, IndexBitCount);
  405.                     OutputBits(Output, matchLength-(BreakEven+1), LengthBitCount);
  406.                     replaceCount := matchLength
  407.                 END;
  408.                 i := 0;
  409.                 WHILE i < replaceCount DO
  410.                     DeleteString((currentPosition+LookAheadSize) MOD (WindowSize-1));
  411.                     Files.Read(Input, ch);
  412.                     IF Input.eof THEN
  413.                         DEC(lookAheadBytes)
  414.                     ELSE
  415.                         Window[currentPosition+LookAheadSize] := ch;
  416.                         Window[(currentPosition+LookAheadSize) MOD (WindowSize-1)] := ch
  417.                     END;
  418.                     currentPosition := (currentPosition+1) MOD (WindowSize-1);
  419.                     IF lookAheadBytes # 0 THEN
  420.                         matchLength := AddString(currentPosition, matchPosition)
  421.                     END;
  422.                     INC(i)
  423.                 END
  424.             END;
  425.             OutputBit(Output, 0);
  426.             OutputBits(Output, EndOfStream, IndexBitCount)
  427.         END Compress;
  428.         PROCEDURE Expand(VAR Input, Output: Files.Rider);
  429.             VAR
  430.                 i, currentPosition, matchLength, matchPosition: INTEGER;
  431.                 ch: CHAR;
  432.         BEGIN
  433.             Err := FALSE;
  434.             Init;
  435.             currentPosition := 1;
  436.             LOOP
  437.                 IF InputBit(Input) # 0 THEN
  438.                     ch := CHR(InputBits(Input, 8));
  439.                     Files.Write(Output, ch);
  440.                     Window[currentPosition] := ch;
  441.                     IF currentPosition < RawLookAheadSize+1 THEN
  442.                         Window[currentPosition+WindowSize-1] := ch
  443.                     END;
  444.                     currentPosition := (currentPosition+1) MOD (WindowSize-1)
  445.                 ELSE
  446.                     matchPosition := SHORT(InputBits(Input, IndexBitCount));
  447.                     IF matchPosition = EndOfStream THEN EXIT END;
  448.                     matchLength := SHORT(InputBits(Input, LengthBitCount));
  449.                     INC(matchLength, BreakEven);
  450.                     i := 0;
  451.                     WHILE i <= matchLength DO
  452.                         ch := Window[matchPosition+i];
  453.                         Files.Write(Output, ch);
  454.                         Window[currentPosition] := ch;
  455.                         IF currentPosition < RawLookAheadSize+1 THEN
  456.                             Window[currentPosition+WindowSize-1] := ch;
  457.                         END;
  458.                         currentPosition := (currentPosition+1) MOD (WindowSize-1);
  459.                         INC(i)
  460.                     END
  461.                 END;
  462.                 IF Err THEN RETURN END
  463.             END
  464.         END Expand;
  465.         PROCEDURE CopyToArc(VAR f: Files.File; VAR Ro: Files.Rider; VAR ratio: REAL): LONGINT;
  466.             VAR Ri: Files.Rider;
  467.         BEGIN
  468.             Files.Set(Ri, f, 0);
  469.             Len := 0;
  470.             BufferPtr := 0;
  471.             CurBitNr := 7;
  472.             CurByte := 0;
  473.             Compress(Ri, Ro);
  474.             FlushBits(Ro);
  475.             ratio := 100*Len/Files.Length(f);
  476.             RETURN Len
  477.         END CopyToArc;
  478.         PROCEDURE CopyFromArc(VAR Ri: Files.Rider; VAR f: Files.File; len: LONGINT);
  479.             VAR Ro: Files.Rider;
  480.         BEGIN
  481.             maxLen := len;
  482.             Files.Set(Ro, f, 0);
  483.             Len := 0;
  484.             BufferPtr := BufferSize;
  485.             CurBitNr := 7;
  486.             CurByte := 0;
  487.             Expand(Ri, Ro);
  488.             IF Err THEN
  489.                 WriteString("Error expanding");
  490.                 WriteLn
  491.             END
  492.         END CopyFromArc;
  493.         PROCEDURE StringLen(str: ARRAY OF CHAR): INTEGER;
  494.             VAR i: INTEGER;
  495.         BEGIN
  496.             i := 0;
  497.             WHILE (i < LEN(str)) & (str[i] # CHR(0)) DO
  498.                 INC(i)
  499.             END;
  500.             RETURN i
  501.         END StringLen;
  502.         PROCEDURE UpString(VAR str: ARRAY OF CHAR);
  503.             VAR i: INTEGER;
  504.         BEGIN
  505.             i := 0;
  506.             WHILE i < StringLen(str) DO
  507.                 IF (str[i] >= "a") & (str[i] <= "z") THEN
  508.                     str[i] := CHR(ORD(str[i])+ORD("A")-ORD("a"))
  509.                 END;
  510.                 INC(i)
  511.             END
  512.         END UpString;
  513.         PROCEDURE StringConcat(VAR dest: ARRAY OF CHAR; a: ARRAY OF CHAR);
  514.             VAR i, j: INTEGER;
  515.         BEGIN
  516.             i := StringLen(dest);
  517.             j :=  0;
  518.             WHILE (i < LEN(dest)) & (j < StringLen(a)) DO
  519.                 dest[i] := a[j];
  520.                 INC(i);
  521.                 INC(j)
  522.             END;
  523.             IF i < LEN(dest) THEN dest[i] := CHR(0) END
  524.         END StringConcat;
  525.         PROCEDURE Search(NameList: List; VAR Name: fName): List;
  526.         BEGIN
  527.             WHILE NameList # NIL DO
  528.                 IF NameList.Name = Name THEN RETURN NameList END;
  529.                 NameList := NameList.next
  530.             END;
  531.             RETURN NIL
  532.         END Search;
  533.         PROCEDURE SearchA(NameList: AddList; VAR Name: fName): AddList;
  534.         BEGIN
  535.             WHILE NameList # NIL DO
  536.                 IF NameList.Name = Name THEN RETURN NameList END;
  537.                 NameList := NameList.next
  538.             END;
  539.             RETURN NIL
  540.         END SearchA;
  541.         PROCEDURE Remove(VAR NameList: List; VAR Name: fName);
  542.             VAR cur, prev: List;
  543.         BEGIN
  544.             cur := NameList.next;
  545.             prev := NameList;
  546.             WHILE cur # NIL DO
  547.                 IF cur.Name = Name THEN
  548.                     prev.next := cur.next;
  549.                     RETURN
  550.                 ELSE
  551.                     prev := cur
  552.                 END;
  553.                 cur := cur.next
  554.             END
  555.         END Remove;
  556.         PROCEDURE GetArcName(VAR name: fName);
  557.             VAR
  558.                 V: Viewers.Viewer;
  559.                 S: Texts.Scanner;
  560.         BEGIN
  561.             V := Oberon.Par.vwr;
  562.             IF (V.dsc IS TextFrames.Frame) & (V.dsc = Oberon.Par.frame) THEN
  563.                 Texts.OpenScanner(S, V.dsc(TextFrames.Frame).text, 0);
  564.                 Texts.Scan(S);
  565.                 IF S.class = Texts.Name THEN
  566.                     cmdSource := Menu;
  567.                     COPY(S.s, name);
  568.                     RETURN
  569.                 END
  570.             END;
  571.             cmdSource := Cmd;
  572.             name := EOFName
  573.         END GetArcName;
  574.         PROCEDURE GetText(): Texts.Text;
  575.             VAR
  576.                 V: Viewers.Viewer;
  577.         BEGIN
  578.             V := Oberon.Par.vwr;
  579.             IF (V = NIL) OR (V.dsc = NIL) OR (V.dsc.next = NIL) THEN
  580.                 RETURN NIL
  581.             ELSIF V.dsc.next IS TextFrames.Frame THEN
  582.                 RETURN V.dsc.next(TextFrames.Frame).text
  583.             ELSE
  584.                 RETURN NIL
  585.             END
  586.         END GetText;
  587.         PROCEDURE GetArgs(VAR NameList: List);
  588.             VAR
  589.                 h, last: List;
  590.                 S: Texts.Scanner;
  591.                 mn: fName;
  592.                 arrow: BOOLEAN;
  593.                 T: Texts.Text;
  594.                 beg, end, time, pos: LONGINT;
  595.         BEGIN
  596.             pos := 0;
  597.             end := 0;
  598.             arrow := FALSE;
  599.             NameList := NIL;
  600.             last := NIL;
  601.             GetArcName(mn);
  602.             IF mn # EOFName THEN
  603.                 arrow := TRUE;
  604.                 NEW(h);
  605.                 h.next := NIL;
  606.                 COPY(mn, h.Name);
  607.                 NameList := h;
  608.                 last := NameList;
  609.                 Oberon.GetSelection(T, beg, end, time);
  610.                 IF time > 0 THEN
  611.                     Texts.OpenScanner(S, T, beg); pos := beg; Texts.Scan(S)
  612.                 ELSE
  613.                     RETURN
  614.                 END
  615.             ELSE
  616.                 Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos);
  617.                 Texts.Scan(S);
  618.                 IF (S.class = Texts.Char) & (S.c = "^") THEN
  619.                     arrow := TRUE;
  620.                     Oberon.GetSelection(T, beg, end, time);
  621.                     IF time > 0 THEN
  622.                         Texts.OpenScanner(S, T, beg); pos := beg; Texts.Scan(S)
  623.                     ELSE
  624.                         RETURN
  625.                     END
  626.                 END
  627.             END;
  628.             WHILE ((cmdSource = Menu) &  (pos <= end+StringLen(S.s))) OR
  629.                                 ((cmdSource = Cmd) & (S.class = Texts.Name) & (~arrow OR (arrow & (pos <= end+StringLen(S.s))))) DO
  630.                 NEW(h);
  631.                 h.next := NIL;
  632.                 COPY(S.s, h.Name);
  633.                 IF Search(NameList, h.Name) = NIL THEN
  634.                     IF last = NIL THEN
  635.                         NameList := h
  636.                     ELSE
  637.                         last.next := h
  638.                     END;
  639.                     last := h
  640.                 END;
  641.                 Texts.Scan(S);
  642.                 IF ~arrow & (S.class = Texts.Char) & (S.c = "^") THEN
  643.                     arrow := TRUE;
  644.                     Oberon.GetSelection(T, beg, end, time);
  645.                     IF time > 0 THEN
  646.                         Texts.OpenScanner(S, T, beg); Texts.Scan(S)
  647.                     END
  648.                 END;
  649.                 pos := Texts.Pos(S)
  650.             END;
  651.             IF cmdSource = Menu THEN
  652.                 opt := TRUE
  653.             ELSE
  654.                 opt := FALSE;
  655.                     IF (S.class = Texts.Char) & ((S.c = "/") OR (S.c = "\")) THEN
  656.                         Texts.Scan(S);
  657.                         IF (S.class = Texts.Name) & (S.s[0] = "d") THEN opt := TRUE END;
  658.                     END
  659.             END
  660.         END GetArgs;
  661.         PROCEDURE OpenArchive(VAR NameList: List; warn: BOOLEAN): Files.File;
  662.             VAR ArcF: Files.File;
  663.         BEGIN
  664.             ArcF := Files.Old(NameList.Name);
  665.             IF (ArcF = NIL) & warn THEN
  666.                 WriteString("archive: ");
  667.                 WriteString(NameList.Name);
  668.                 WriteString(err2);
  669.                 WriteLn
  670.             END;
  671.             RETURN ArcF
  672.         END OpenArchive;
  673.         PROCEDURE Trimm(VAR name: ARRAY OF CHAR);
  674.             VAR
  675.                 l, i, j: LONGINT;
  676.                 back: fName;
  677.                 ch: CHAR;
  678.         BEGIN
  679.             l := LEN(name);
  680.             j := -1;
  681.             i := 0;
  682.             WHILE (i < l) & (name[i] # 0X) DO
  683.                 ch := name[i];
  684.                 IF (ch = "/") OR (ch = "\") THEN
  685.                     j := i
  686.                 END;
  687.                 INC(i)
  688.             END;
  689.             IF j >= 0 THEN
  690.                 COPY(name, back);
  691.                 j := j+1;
  692.                 i := 0;
  693.                 WHILE (j < l) & (back[j] # 0X) DO
  694.                     name[i] := back[j];
  695.                     INC(i);
  696.                     INC(j)
  697.                 END;
  698.                 name[i] := 0X
  699.             END
  700.         END Trimm;
  701.     PROCEDURE NextName(VAR name: ARRAY OF CHAR);
  702.         VAR
  703.             i, l: LONGINT;
  704.             ch: CHAR;
  705.     BEGIN
  706.         l := LEN(name);
  707.         i := 0;
  708.         WHILE (i < l) & (name[i] # 0X) DO
  709.             INC(i)
  710.         END;
  711.         IF i >= l THEN
  712.             name[l-1] := CHR(ORD(name[l-1])+1)
  713.         ELSE
  714.             ch := name[i-1];
  715.             IF (ch >= "0") & (ch <= "8") THEN
  716.                 name[i-1] := CHR(ORD(name[i-1])+1)
  717.             ELSE
  718.                 name[i] := "0";
  719.                 IF (i+1) < l THEN
  720.                     name[i+1] := 0X
  721.                 END
  722.             END
  723.         END
  724.     END NextName;
  725.         PROCEDURE Directory*;
  726.             VAR
  727.                 NameList: List;
  728.                 ArcF: Files.File;
  729.                 R: Files.Rider;
  730.                 h: Header;
  731.                 err, newViewer: BOOLEAN;
  732.                 x, y, n: INTEGER;
  733.                 V: MenuViewers.Viewer;
  734.                 t: Texts.Text;
  735.                 totRatio: REAL;
  736.         BEGIN
  737.             GetArgs(NameList);
  738.             IF NameList = NIL THEN
  739.                 RETURN
  740.             END;
  741.             ArcF := OpenArchive(NameList, TRUE);
  742.             err := FALSE;
  743.             IF ArcF = NIL THEN
  744.                 RETURN
  745.             ELSE
  746.                 IF cmdSource = Menu THEN
  747.                     t := GetText()
  748.                 ELSE
  749.                     t := NIL
  750.                 END;
  751.                 IF t = NIL THEN
  752.                     NEW(t);
  753.                     t := TextFrames.Text("");
  754.                     newViewer := TRUE
  755.                 ELSE
  756.                     newViewer := FALSE;
  757.                     Texts.Delete(t, 0, t.len)
  758.                 END;
  759.                 T := t;
  760.                 n := 0;
  761.                 totRatio := 0.0;
  762.                 Files.Set(R, ArcF, 0);
  763.                 ReadHeader(R, h, err);
  764.                 WHILE (h.Name # EOFName) & ~err DO
  765.                     WriteString(h.Name);
  766.                     IF opt THEN
  767.                         WriteString("  ");
  768.                         WriteDate(h.time, h.date);
  769.                         WriteString("   ");
  770.                         WriteInt(h.length);
  771.                         WriteString("  ");
  772.                         WriteReal(h.ratio);
  773.                         WriteString("% ")
  774.                     END;
  775.                     WriteLn;
  776.                     INC(n);
  777.                     totRatio := totRatio+h.ratio;
  778.                     Files.Set(R, ArcF, Files.Pos(R)+h.length);
  779.                     ReadHeader(R, h, err)
  780.                 END
  781.             END;
  782.             IF ArcF = NIL THEN
  783.                 WriteString(NameList.Name);
  784.                 WriteString(err2);
  785.                 WriteLn;
  786.                 RETURN
  787.             END;
  788.             IF Files.Pos(R) = 0 THEN
  789.                 WriteString("Archive is empty");
  790.                 WriteLn
  791.             ELSE
  792.                 WriteLn;
  793.                 IF opt & ~err THEN
  794.                     WriteString("Average: ");
  795.                     WriteReal(totRatio/n);
  796.                     WriteString("% ");
  797.                     WriteString(", Size: ");
  798.                     WriteInt(Files.Length(ArcF));
  799.                     WriteString(" Bytes");
  800.                     WriteLn
  801.                 END
  802.             END;
  803.             IF err THEN
  804.                 WriteString(err1);
  805.                 WriteLn
  806.             END;
  807.             IF newViewer THEN
  808.                 Oberon.AllocateUserViewer(Oberon.Mouse.X, x, y);
  809.                 V := MenuViewers.New(TextFrames.NewMenu(NameList.Name, DirMenu),
  810.                         TextFrames.NewText(t, 0), TextFrames.menuH, x, y);
  811.                 V.dsc.next.handle := TextFrames.Handle
  812.             END;
  813.             T := Oberon.Log;
  814.             IF ArcF # NIL THEN Files.Close(ArcF) END
  815.         END Directory;
  816.         PROCEDURE Add*;
  817.             VAR
  818.                 nl, NameList: List;
  819.                 addL, ha: AddList;
  820.                 new, err, changed: BOOLEAN;
  821.                 ArcF, AddF: Files.File;
  822.                 R: Files.Rider;
  823.                 h: Header;
  824.                 ver: INTEGER;
  825.                 pos, len: LONGINT;
  826.         BEGIN
  827.             GetArgs(NameList);
  828.             IF (NameList = NIL) OR (NameList.next = NIL) THEN
  829.                 RETURN
  830.             END;
  831.             new := FALSE;
  832.             ArcF := OpenArchive(NameList, FALSE);
  833.             IF ArcF = NIL THEN
  834.                 WriteString("New archive");
  835.                 WriteLn;
  836.                 new := TRUE;
  837.                 ArcF := Files.New(NameList.Name)
  838.             END;
  839.             WriteString("Compress.Add ");
  840.             WriteString(NameList.Name);
  841.             WriteLn;
  842.             changed := FALSE;
  843.             Files.Set(R, ArcF, 0);
  844.             addL := NIL;
  845.             pos := Files.Pos(R);
  846.             ReadHeader(R, h, err);
  847.             WHILE (h.Name # EOFName) & ~err DO
  848.                 IF addL = NIL THEN
  849.                     NEW(addL);
  850.                     addL.Name := h.Name;
  851.                     addL.pos := pos;
  852.                     addL.next := NIL
  853.                 ELSE
  854.                     NEW(ha);
  855.                     ha.Name := h.Name;
  856.                     ha.pos := pos;
  857.                     ha.next := addL;
  858.                     addL := ha
  859.                 END;
  860.                 Files.Set(R, ArcF, Files.Pos(R)+h.length);
  861.                 pos := Files.Pos(R);
  862.                 ReadHeader(R, h, err)
  863.             END;
  864.             IF err THEN
  865.                 WriteString(err1);
  866.                 WriteLn;
  867.                 Files.Close(ArcF);
  868.                 RETURN
  869.             END;
  870.             IF NameList.next # NIL THEN
  871.                 h.length := 0;
  872.                 nl := NameList.next;
  873.                 WHILE nl # NIL DO
  874.                     AddF := Files.Old(nl.Name);
  875.                     IF AddF = NIL THEN
  876.                         WriteString("    ");
  877.                         WriteString(nl.Name);
  878.                         WriteString(err2);
  879.                         WriteLn
  880.                     ELSE
  881.                         Trimm(nl.Name);
  882.                         IF (Files.Length(ArcF) + Files.Length(AddF)) >= maxFileSize THEN
  883.                             Files.Close(AddF);
  884.                             nl.next := NIL;
  885.                             WriteString(err3);
  886.                             WriteLn
  887.                         ELSE
  888.                             IF SearchA(addL, nl.Name) # NIL THEN
  889.                                 WHILE SearchA(addL, nl.Name) # NIL DO
  890.                                     NextName(nl.Name)
  891.                                 END
  892.                             END;
  893.                             Files.Set(R, ArcF, Files.Length(ArcF));
  894.                             pos := Files.Pos(R);
  895.                             COPY(nl.Name, h.Name);
  896.                             WriteString("    ");
  897.                             WriteString(nl.Name);
  898.                             WriteLn;
  899.                             changed := TRUE;
  900.                             h.ratio := 0.0;
  901.                             WriteHeader(R, h, TRUE);
  902.                             len := CopyToArc(AddF, R, h.ratio);
  903.                             h.length := len;
  904.                             Files.Close(AddF);
  905.                             Files.Set(R, ArcF, pos);
  906.                             WriteHeader(R, h, TRUE);
  907.                             NEW(ha);
  908.                             ha.Name := nl.Name;
  909.                             ha.pos := pos;
  910.                             ha.next := addL;
  911.                             addL := ha
  912.                         END
  913.                     END;
  914.                     nl := nl.next
  915.                 END
  916.             END;
  917.             IF new THEN
  918.                 Files.Register(ArcF)
  919.             ELSE
  920.                 Files.Close(ArcF)
  921.             END;
  922.             IF changed & (cmdSource=Menu) THEN Directory END
  923.         END Add;
  924.         PROCEDURE Delete*;
  925.             TYPE
  926.                 DelList = POINTER TO DelListDesc;
  927.                 DelListDesc = RECORD
  928.                     start, end: LONGINT;
  929.                     next, prev: DelList
  930.                 END;
  931.             VAR
  932.                 NameList, nl: List;
  933.                 DeleteList, last, dl: DelList;
  934.                 ArcF, TmpF: Files.File;
  935.                 R, Rt: Files.Rider;
  936.                 h: Header;
  937.                 pos, beg: LONGINT;
  938.                 res: INTEGER;
  939.                 err, changed: BOOLEAN;
  940.         BEGIN
  941.             GetArgs(NameList);
  942.             IF (NameList = NIL) OR (NameList.next = NIL) THEN
  943.                 RETURN
  944.             END;
  945.             ArcF := OpenArchive(NameList, TRUE);
  946.             IF ArcF = NIL THEN
  947.                 RETURN
  948.             END;
  949.             DeleteList := NIL;
  950.             last := NIL;
  951.             changed := FALSE;
  952.             WriteString("Compress.Delete ");
  953.             WriteString(NameList.Name);
  954.             WriteLn;
  955.             Files.Set(R, ArcF, 0);
  956.             beg := 0;
  957.             ReadHeader(R, h, err);
  958.             WHILE (h.Name # EOFName) & (NameList.next # NIL) & ~err DO
  959.                 pos := Files.Pos(R);
  960.                 IF Search(NameList, h.Name) # NIL THEN
  961.                     NEW(dl);
  962.                     dl.start := beg;
  963.                     dl.end := pos+h.length;
  964.                     dl.next := NIL;
  965.                     IF last = NIL THEN
  966.                         DeleteList := dl;
  967.                     ELSE
  968.                         last.next := dl
  969.                     END;
  970.                     last := dl;
  971.                     WriteString("    ");
  972.                     WriteString(h.Name);
  973.                     WriteLn;
  974.                     Remove(NameList, h.Name)
  975.                 END;
  976.                 Files.Set(R, ArcF, pos+h.length);
  977.                 beg := pos+h.length;
  978.                 ReadHeader(R, h, err)
  979.             END;
  980.             Files.Close(ArcF);
  981.             nl := NameList.next;
  982.             WHILE nl # NIL DO
  983.                 WriteString("    ");
  984.                 WriteString(nl.Name);
  985.                 WriteString(err2);
  986.                 WriteLn;
  987.                 nl := nl.next
  988.             END;
  989.             IF err THEN
  990.                 WriteString(err1);
  991.                 WriteLn
  992.             END;
  993.             IF DeleteList # NIL THEN
  994.                 changed := TRUE;
  995.                 Files.Rename(NameList.Name, Temp, res);
  996.                 ArcF := Files.New(NameList.Name);
  997.                 Files.Set(R, ArcF, 0);
  998.                 TmpF := Files.Old(Temp);
  999.                 Files.Set(Rt, TmpF, 0);
  1000.                 WHILE DeleteList # NIL DO
  1001.                     CopyFrom(Rt, R, DeleteList.start-Files.Pos(Rt));
  1002.                     Files.Set(Rt, TmpF, DeleteList.end);
  1003.                     DeleteList := DeleteList.next
  1004.                 END;
  1005.                 CopyTo(Rt, R);
  1006.                 Files.Close(TmpF);
  1007.                 Files.Delete(Temp, res);
  1008.                 Files.Register(ArcF)
  1009.             END;
  1010.             IF changed & (cmdSource=Menu) THEN Directory END
  1011.         END Delete;
  1012.         PROCEDURE Extract*;
  1013.             VAR
  1014.                 NameList: List;
  1015.                 ArcF, AddF: Files.File;
  1016.                 R: Files.Rider;
  1017.                 h: Header;
  1018.                 pos: LONGINT;
  1019.                 res: INTEGER;
  1020.                 err: BOOLEAN;
  1021.         BEGIN
  1022.             GetArgs(NameList);
  1023.             IF (NameList = NIL) OR (NameList.next = NIL) THEN
  1024.                 RETURN
  1025.             END;
  1026.             ArcF := OpenArchive(NameList, TRUE);
  1027.             IF ArcF = NIL THEN
  1028.                 RETURN
  1029.             END;
  1030.             WriteString("Compress.Extract ");
  1031.             WriteString(NameList.Name);
  1032.             WriteLn;
  1033.             Files.Set(R, ArcF, 0);
  1034.             ReadHeader(R, h, err);
  1035.             WHILE (h.Name # EOFName) & (NameList.next # NIL) & ~err DO
  1036.                 pos := Files.Pos(R);
  1037.                 IF Search(NameList, h.Name) # NIL THEN
  1038.                     WriteString("    ");
  1039.                     WriteString(h.Name);
  1040.                     AddF := Files.Old(h.Name);
  1041.                     IF AddF # NIL THEN
  1042.                         WriteString(" overwriting");
  1043.                         Files.Close(AddF);
  1044.                         Files.Delete(h.Name, res)
  1045.                     END;
  1046.                     WriteLn;
  1047.                     AddF := Files.New(h.Name);
  1048.                     CopyFromArc(R, AddF, h.length);
  1049.                     Files.Register(AddF);
  1050.                     Remove(NameList, h.Name)
  1051.                 END;
  1052.                 Files.Set(R, ArcF, pos+h.length);
  1053.                 ReadHeader(R, h, err)
  1054.             END;
  1055.             IF err THEN
  1056.                 WriteString(err1);
  1057.                 WriteLn
  1058.             END;
  1059.             IF NameList.next # NIL THEN
  1060.                 NameList := NameList.next;
  1061.                 WHILE NameList # NIL DO
  1062.                     WriteString(NameList.Name);
  1063.                     WriteString(err2);
  1064.                     WriteLn;
  1065.                     NameList := NameList.next
  1066.                 END
  1067.             END;
  1068.             Files.Close(ArcF)
  1069.         END Extract;
  1070.         PROCEDURE ExtractAll*;
  1071.             VAR
  1072.                 NameList: List;
  1073.                 ArcF, AddF: Files.File;
  1074.                 R: Files.Rider;
  1075.                 h: Header;
  1076.                 pos: LONGINT;
  1077.                 res: INTEGER;
  1078.                 err: BOOLEAN;
  1079.         BEGIN
  1080.             GetArgs(NameList);
  1081.             IF NameList = NIL THEN
  1082.                 RETURN
  1083.             END;
  1084.             ArcF := OpenArchive(NameList, TRUE);
  1085.             IF ArcF = NIL THEN
  1086.                 RETURN
  1087.             END;
  1088.             WriteString("Compress.ExtractAll ");
  1089.             WriteString(NameList.Name);
  1090.             WriteLn;
  1091.             Files.Set(R, ArcF, 0);
  1092.             ReadHeader(R, h, err);
  1093.             WHILE (h.Name # EOFName) &  ~err DO
  1094.                 WriteString("    ");
  1095.                 WriteString(h.Name);
  1096.                 pos := Files.Pos(R);
  1097.                 AddF := Files.Old(h.Name);
  1098.                 IF AddF # NIL THEN
  1099.                     WriteString(" overwriting");
  1100.                     Files.Close(AddF);
  1101.                     Files.Delete(h.Name, res)
  1102.                 END;
  1103.                 WriteLn;
  1104.                 AddF := Files.New(h.Name);
  1105.                 CopyFromArc(R, AddF, h.length);
  1106.                 Files.Register(AddF);
  1107.                 Files.Set(R, ArcF, pos+h.length);
  1108.                 ReadHeader(R, h, err)
  1109.             END;
  1110.             IF err THEN
  1111.                 WriteString(err1);
  1112.                 WriteLn
  1113.             END;
  1114.             Files.Close(ArcF)
  1115.         END ExtractAll;
  1116.         PROCEDURE Open*;
  1117.             VAR
  1118.                 NameList: List;
  1119.                 ArcF, AddF: Files.File;
  1120.                 R: Files.Rider;
  1121.                 h: Header;
  1122.                 pos: LONGINT;
  1123.                 res, x, y: INTEGER;
  1124.                 err: BOOLEAN;
  1125.                 t: Texts.Text;
  1126.                 V: MenuViewers.Viewer;
  1127.         BEGIN
  1128.             GetArgs(NameList);
  1129.             IF NameList = NIL THEN
  1130.                 RETURN
  1131.             ELSIF NameList.next = NIL THEN
  1132.                 RETURN
  1133.             END;
  1134.             ArcF := OpenArchive(NameList, TRUE);
  1135.             IF ArcF = NIL THEN
  1136.                 RETURN
  1137.             END;
  1138.             AddF := NIL;
  1139.             Files.Set(R, ArcF, 0);
  1140.             ReadHeader(R, h, err);
  1141.             WHILE (h.Name # EOFName) &  ~err & (AddF = NIL) DO
  1142.                 pos := Files.Pos(R);
  1143.                 IF h.Name = NameList.next.Name THEN
  1144.                     AddF := Files.New(Temp);
  1145.                     CopyFromArc(R, AddF, h.length);
  1146.                     Files.Register(AddF)
  1147.                 ELSE
  1148.                     Files.Set(R, ArcF, pos+h.length);
  1149.                     ReadHeader(R, h, err)
  1150.                 END
  1151.             END;
  1152.             IF err THEN
  1153.                 WriteString(err1);
  1154.                 WriteLn
  1155.             END;
  1156.             Files.Close(ArcF);
  1157.             IF AddF # NIL THEN
  1158.                 NEW(t);
  1159.                 t := TextFrames.Text(Temp);
  1160.                 Oberon.AllocateUserViewer(Oberon.Mouse.X, x, y);
  1161.                 V := MenuViewers.New(TextFrames.NewMenu(h.Name, EditMenu),
  1162.                         TextFrames.NewText(t, 0), TextFrames.menuH, x, y);
  1163.                 V.dsc.next.handle := TextFrames.Handle;
  1164.                 Files.Delete(Temp, res)
  1165.             ELSE
  1166.                 WriteString(NameList.next.Name);
  1167.                 WriteString(err2);
  1168.                 WriteLn
  1169.             END
  1170.         END Open;
  1171.         PROCEDURE Compile*;
  1172.             VAR
  1173.                 NameList: List;
  1174.                 ArcF, AddF: Files.File;
  1175.                 R: Files.Rider;
  1176.                 h: Header;
  1177.                 pos: LONGINT;
  1178.                 res, x, y: INTEGER;
  1179.                 err: BOOLEAN;
  1180.                 t: Texts.Text;
  1181.                 V: MenuViewers.Viewer;
  1182.                 T: Texts.Text; par: Oberon.ParList; cmd: ARRAY 32 OF CHAR;
  1183.         BEGIN
  1184.             COPY("Compiler.Compile", cmd);
  1185.             NEW(par); par.pos := 0; par.text := TextFrames.Text(""); par.frame := Oberon.Par.frame; par.vwr:= Oberon.Par.vwr;
  1186.             GetArgs(NameList);
  1187.             IF sym THEN WriteString("Compiler.Compile/s"); WriteLn; END;
  1188.             IF NameList = NIL THEN
  1189.                 RETURN
  1190.             ELSIF NameList.next = NIL THEN
  1191.                 RETURN
  1192.             END;
  1193.             ArcF := OpenArchive(NameList, TRUE);
  1194.             IF ArcF = NIL THEN
  1195.                 RETURN
  1196.             END;
  1197.             AddF := NIL;
  1198.             Files.Set(R, ArcF, 0);
  1199.             ReadHeader(R, h, err);
  1200.             WHILE (h.Name # EOFName) & (NameList.next # NIL) & ~err DO
  1201.                 pos := Files.Pos(R);
  1202.                 IF Search(NameList, h.Name) # NIL THEN
  1203.                     AddF := Files.New(Temp);
  1204.                     CopyFromArc(R, AddF, h.length);
  1205.                     Files.Register(AddF);
  1206.                     Texts.WriteString(W, Temp); 
  1207.                     IF sym THEN Texts.WriteString(W, "/s") END;
  1208.                     Texts.WriteString(W, " ~");
  1209.                     Texts.Delete(par.text, 0, par.text.len); Texts.Append(par.text, W.buf);
  1210.                     COPY("Compiler.Compile", cmd); Oberon.Call(cmd, par, FALSE, res);
  1211.                     Remove(NameList, h.Name)
  1212.                 END;
  1213.                 Files.Set(R, ArcF, pos+h.length);
  1214.                 ReadHeader(R, h, err)
  1215.             END;
  1216.             IF err THEN
  1217.                 WriteString(err1);
  1218.                 WriteLn
  1219.             END;
  1220.             Files.Close(ArcF);
  1221.         END Compile;
  1222.     PROCEDURE CompileS*;
  1223.     BEGIN
  1224.         sym := TRUE; Compile; sym := FALSE;
  1225.     END CompileS;
  1226. BEGIN
  1227.     Texts.OpenWriter(W);
  1228.     T := Oberon.Log;
  1229.     Texts.WriteString(W, "Compress, EJZ 30.11.94");
  1230.     Texts.WriteLn(W);
  1231.     Texts.Append(Oberon.Log, W.buf);
  1232.     NEW(Tree)
  1233. END Compress.
  1234.