home *** CD-ROM | disk | FTP | other *** search
/ Oakland CPM Archive / oakcpm.iso / sigm / vol229 / bytype86.lbr / TYPES15.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1986-02-10  |  6.3 KB  |  257 lines
  1. PROGRAM ByTypes;
  2. CONST
  3.     HiValue = 127;
  4.     NumAcross = 6;
  5.  
  6. TYPE
  7.     FieldType = (Names,Types);
  8.     NameType = PACKED ARRAY[1..8] OF CHAR;
  9.     TypeType = PACKED ARRAY[1..3] OF CHAR;
  10.     EntryType = PACKED RECORD CASE BOOLEAN OF
  11.                     TRUE  : (FName : NameType;
  12.                              FType : TypeType);
  13.             FALSE : (FullEntry : PACKED ARRAY[1..11] OF CHAR);
  14.                 END;
  15.     NodePtr  = ^NodeType;
  16.     NodeType = PACKED RECORD
  17.                   Info : EntryType;
  18.           Junk : PACKED ARRAY[0..0] OF BYTE; { get a word boundary }
  19.                   Next : NodePtr;
  20.                END;
  21.     PTR      = ^BYTE;
  22.     STR16    = STRING[16];
  23.  
  24. VAR
  25.     Count     : INTEGER;
  26.     Drive     : BYTE;
  27.     FileSpec  : STR16;
  28.     ListHead  : NodePtr;
  29.     HiName    : NameType;
  30.     HiExt     : TypeType;
  31.     OutFile   : TEXT;
  32.     Result    : INTEGER;
  33.  
  34. EXTERNAL PROCEDURE CmdTail;
  35. EXTERNAL FUNCTION Argc : INTEGER;
  36. EXTERNAL PROCEDURE CmdTokn(Num : INTEGER; VAR S : STR16);
  37.  
  38. EXTERNAL FUNCTION @BDOS86(Func : INTEGER; address : PTR) : INTEGER;
  39.  
  40. PROCEDURE GetParms;
  41. VAR
  42.     Temp : STR16;
  43.  
  44. BEGIN { GetParms }
  45.  
  46.     CmdTail;
  47.     Drive := 0;
  48.     FileSpec := 'CON:';
  49.     CmdTokn(1,Temp);
  50.     CASE Argc OF
  51.         1 : BEGIN
  52.               IF Temp[1] = '>' THEN FileSpec := COPY(Temp,2,LENGTH(Temp)-1)
  53.               ELSE Drive := ORD(Temp[1]) - $40;
  54.             END;
  55.         2 : BEGIN
  56.               Drive := ORD(Temp[1]) - $40;
  57.               CmdTokn(2,Temp);
  58.               IF Temp[1] = '>' THEN DELETE(Temp,1,1);
  59.               FileSpec := Temp;
  60.             END;
  61.     END; { Case }
  62.  
  63. END; { GetParms }
  64.  
  65. FUNCTION ReadDir : NodePtr;
  66. CONST
  67.     FcbSize  = 35;
  68.     GetFirst = 17;
  69.     GetNext  = 18;
  70.     SetDMA   = 26;
  71.  
  72. TYPE
  73.     DirEntry = RECORD
  74.           User : BYTE;
  75.                   Item : EntryType;
  76.                   Filler : PACKED ARRAY[1..20] OF BYTE;
  77.                END;
  78.     FcbType  = PACKED ARRAY [0..FcbSize] OF BYTE;
  79.  
  80. VAR
  81.     Buffer  : PACKED ARRAY[0..3] OF DirEntry;
  82.     Fcb     : FcbType;
  83.     I,X     : INTEGER;
  84.     T       : NodePtr;
  85.  
  86. PROCEDURE InitFcb;
  87. BEGIN
  88.  
  89.     FILLCHAR(Fcb,SIZEOF(Fcb),CHR(0));
  90.     FILLCHAR(Fcb[1],11,'?');
  91.  
  92. END;
  93.  
  94. BEGIN { ReadDir }
  95.  
  96.     InitFcb;
  97.     Fcb[0] := Drive;
  98.     T := ListHead;
  99.     I := @BDOS86(SetDMA,ADDR(Buffer));
  100.     I := @BDOS86(GetFirst,ADDR(Fcb));
  101.     WHILE I <> 255 DO BEGIN
  102.         Count := Count + 1;
  103.         NEW(T^.Next);
  104.         T := T^.Next;
  105.     FOR X := 1 TO SIZEOF(EntryType) DO
  106.       T^.Info.FullEntry[X] := CHR(ORD(Buffer[I].Item.FullEntry[X]) & $7F);
  107.         I := @BDOS86(GetNext,ADDR(Fcb));
  108.     END;
  109.     T^.Next := ListHead;
  110.     ReadDir := ListHead^.Next;
  111.     ListHead^.Next := ListHead;
  112.  
  113. END; { ReadDir }
  114.  
  115. FUNCTION Merge(a,b : NodePtr; Field : FieldType) : NodePtr;
  116. VAR
  117.     C : NodePtr;
  118.  
  119. BEGIN { Merge }
  120.  
  121.     C := ListHead;
  122.     IF Field = Names THEN
  123.     REPEAT
  124.         IF A^.Info.FName <= b^.Info.FName THEN BEGIN
  125.             C^.Next := a;
  126.             c       := a;
  127.             a       := a^.Next;
  128.         END
  129.         ELSE BEGIN
  130.             C^.Next := b;
  131.             C       := b;
  132.             B       := B^.Next;
  133.         END;
  134.     UNTIL C^.Info.FName = HiName
  135.     ELSE
  136.     REPEAT
  137.         IF A^.Info.FType <= b^.Info.FType THEN BEGIN
  138.             C^.Next := a;
  139.             c       := a;
  140.             a       := a^.Next;
  141.         END
  142.         ELSE BEGIN
  143.             C^.Next := b;
  144.             C       := b;
  145.             B       := B^.Next;
  146.         END;
  147.     UNTIL C^.Info.FType = HiExt;
  148.     Merge := ListHead^.Next;
  149.     ListHead^.Next := ListHead;
  150.  
  151. END; { Merge }
  152.  
  153. FUNCTION MergeSort( C : NodePtr; Field : FieldType) : NodePtr;
  154. VAR
  155.     A,B,Head,Todo,T : NodePtr;
  156.     I,N             : INTEGER;
  157.  
  158. BEGIN { MergeSort }
  159.  
  160.     N := 1;
  161.     NEW(Head);
  162.     Head^.Next := C;
  163.     REPEAT
  164.         Todo := Head^.Next;
  165.         C    := Head;
  166.         REPEAT
  167.             T := Todo;
  168.             A := T;
  169.             FOR I := 1 TO N-1 DO T := T^.Next;
  170.             B       := T^.Next;
  171.             T^.Next := ListHead;
  172.             T       := B;
  173.             FOR I := 1 TO N-1 DO T := T^.Next;
  174.             Todo    := T^.Next;
  175.             T^.Next := ListHead;
  176.             C^.Next := Merge(a,b,Field);
  177.             FOR I := 1 TO N+N DO C := C^.Next;
  178.         UNTIL Todo = ListHead;
  179.         N := N + N;
  180.     UNTIL A = Head^.Next;
  181.     MergeSort := Head^.Next;
  182. END; { MergeSort }
  183.  
  184. PROCEDURE PrintEm(P : NodePtr);
  185. CONST
  186.     Space = ' ';
  187.  
  188. VAR
  189.     Bord1     : PACKED ARRAY[1..39] OF CHAR;
  190.     Bord2     : PACKED ARRAY[1..35] OF CHAR;
  191.     Bottom    : PACKED ARRAY[1..79] OF CHAR;
  192.     LastOne : TypeType;
  193.     NumPrinted : INTEGER;
  194.  
  195. PROCEDURE DoBorder(VAR Exts : TypeType);
  196. BEGIN
  197.  
  198.     IF NumPrinted <> 0 THEN WRITELN(OutFile);
  199.     WRITE(OutFile,Bord1);
  200.     WRITE(OutFile,'[',Exts,']');
  201.     WRITELN(OutFile,Bord2);
  202.  
  203. END;
  204.  
  205. BEGIN
  206.  
  207.     NumPrinted := 0;
  208.     FILLCHAR(LastOne,SIZEOF(LastOne),CHR(HiValue));
  209.     FILLCHAR(Bord1,SIZEOF(Bord1),'-');
  210.     FILLCHAR(Bord2,SIZEOF(Bord2),'-');
  211.     FILLCHAR(Bottom,SIZEOF(Bottom),'=');
  212.     WHILE P <> ListHead DO BEGIN
  213.         WITH P^.Info DO BEGIN
  214.             IF FType <> LastOne THEN BEGIN
  215.                 DoBorder(FType);
  216.                 LastOne := FType;
  217.                 NumPrinted := 0;
  218.             END;
  219.             WRITE(OutFile,Space:5,FName);
  220.             NumPrinted := NumPrinted + 1;
  221.             IF NumPrinted = NumAcross THEN BEGIN
  222.                 WRITELN(OutFile);
  223.                 NumPrinted := 0;
  224.             END;
  225.         END;
  226.         P := P^.Next;
  227.     END;
  228.     WRITELN(OutFile);
  229.     WRITELN(OutFile,Bottom);
  230.  
  231. END; { PrintEm }
  232.  
  233. BEGIN { Main }
  234.  
  235.     GetParms;
  236.     ASSIGN(OutFile,FileSpec);
  237.     REWRITE(OutFile);
  238.     IF IORESULT = 255 THEN BEGIN
  239.         WRITELN('Can''t open ',FileSpec);
  240.         EXIT;
  241.     END;
  242.     FILLCHAR(HiName,SIZEOF(NameType),CHR(HiValue));
  243.     FILLCHAR(HiExt,SIZEOF(TypeType),CHR(HiValue));
  244.     Count    := 0;
  245.     NEW(ListHead);
  246.     WITH ListHead^.Info DO BEGIN
  247.         FName := HiName;
  248.         FType := HiExt;
  249.     END;
  250.     ListHead^.Next := NIL;
  251.     PrintEm(MergeSort(MergeSort(ReadDir,Names),Types));
  252.     WRITE(OutFile,Count:5,' File(s) listed');
  253.     WRITELN(OutFile,'  [by_Types v1.5]');
  254.     CLOSE(OutFile,Result);
  255.  
  256. END.
  257.