home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1987 / 08 / menu.ucs < prev    next >
Encoding:
Text File  |  1987-07-10  |  12.9 KB  |  373 lines
  1. (*$U-*) { Compiler-Option, die bewirkt, dass das nach- }
  2.         { folgende Programm als Systemprogramm ueber-  }
  3.         { setzt wird. Gleichzeitig werden auch die     }
  4.         { folgenden Optionen gesetzt:                  }
  5.         {(*$R-*) Bereichsueberschreitungen erlaubt    }
  6.         {(*$V-*) keine Pruefung der Stringlaengen     }
  7.         {(*$I-*) I/O-Fehler werden nicht geprueft     }
  8.         {(*$G+*) GOTO-Anweisung erlaubt               }
  9.  
  10. SEGMENT Pascalsystem;(* Segment 0 *)
  11.  
  12. (******************************************)
  13. (*                                        *)
  14. (*    M E N U          Revision [0.5b]    *)
  15. (*                                        *)
  16. (*    Auswahl und Start von Programmen    *)
  17. (*                                        *)
  18. (*$C  von Klaus Seiler, Februar 1986      *)
  19. (*                                        *)
  20. (******************************************)
  21.  
  22. CONST MaxUnit  = 20; (* Max. physikalische Unit-#  *)
  23.       VidLeng  =  7; (* Laenge des Volumenamens    *)
  24.       FNamLeng = 23; (* Laenge des Filenamens      *)
  25.  
  26. TYPE UnitNum  = 0..MaxUnit;
  27.      Vid      = STRING[VidLeng ];
  28.      FilNam   = STRING[FNamLeng];
  29.  
  30. VAR SysVars1    : ARRAY[1..125 ] OF INTEGER;
  31.     UnitTable   : (* Geraetetabelle des Betriebssystems *)
  32.                   ARRAY[UnitNum] OF RECORD
  33.                                       UVid : Vid
  34.                                       CASE UisBlkd : BOOLEAN OF
  35.                                         TRUE : (UEovBlk : INTEGER)
  36.                                       END;
  37.     SysVars2    : ARRAY[252..281] OF INTEGER;
  38.     OldNextCode : FilNam; (* UCSD-Pascal Version II.1 *)
  39.                           (* Apple-Pascal Version 1.1 *)
  40.     SysVars3    : ARRAY[294..327] OF INTEGER;
  41.     NewNextCode : FilNam; (* Apple-Pascal Version 1.2 *)
  42.  
  43.  (*========================================================*)
  44.  (* Eigentliches Benutzerprogramm                          *)
  45.  (* Normalerweise: PROGRAM Menu(INPUT,OUTPUT);             *)
  46.  
  47. SEGMENT PROCEDURE Menu (Xinput, Xoutput : INTEGER);
  48.                        (* Segment 1 *)
  49.  
  50. CONST SystemID  = -16607; (* Version des Systems     *)
  51.       FBlkSize  =    512; (* Disketten-Block Laenge  *)
  52.       MaxDir    =     77; (* Max. Katalogeintraege   *)
  53.       DirBlk    =      2; (* erster phys. Dir.-Block *)
  54.       TidLeng   =     15; (* Laenge der Titel-ID     *)
  55.       Width     =     79; (* Bildschirm-Weite        *)
  56.       Height    =     23; (* Bildschirm-Hoehe        *)
  57.       BEL       =      7; (* Glocke                  *)
  58.       VT        =     11; (* bis Seitenende loeschen *)
  59.       EM        =     25; (* Home-Kontrollzeichen    *)
  60.       ESC       =     27; (* Escape-Zeichen          *)
  61.       GS        =     29; (* bis Zeilenende loeschen *)
  62.       NoError   =      0; (* I/O-Result              *)
  63.  
  64. TYPE (* Format des UCSD-Inhaltsverzeichnisses *)
  65.      DirRange  = 0..MaxDir;
  66.      Tid       = STRING [TidLeng];
  67.      ByteArray = PACKED ARRAY[0..0] OF 0..255;
  68.      BytePtr   = ^ByteArray;
  69.      FileKind  = (UntypedFile, XdskFile, CodeFile,
  70.                   TextFile, InfoFile, DataFile,
  71.                   GrafFile, FotoFile, SecureDir);
  72.      DateRec   = PACKED RECORD
  73.                    Dummy : 0..256;
  74.                    Year  : 0..100
  75.                  END;
  76.      DirEntry  = PACKED RECORD
  77.                    DLastBlk,
  78.                    DFirstBlk : INTEGER
  79.                    CASE DFKind : FileKind OF
  80.                      SecureDir,
  81.                      UntypedFile :
  82.                       (Filler1   : 0..4095;
  83.                        DVid      : Vid;
  84.                        DEovBlk   : INTEGER;
  85.                        DNumFiles : DirRange;
  86.                        Dummy     : REAL);
  87.                      XdskFile,
  88.                      CodeFile,
  89.                      TextFile,
  90.                      InfoFile,
  91.                      DataFile,
  92.                      GrafFile,
  93.                      FotoFile :
  94.                       (Filler2   : 0..2047;
  95.                        Status    : BOOLEAN;
  96.                        DTid      : Tid;
  97.                        DLastByte : 1..FBlkSize;
  98.                        DAccess   : DateRec)
  99.                  END;(* DirEntry *)
  100.      Directory = ARRAY [DirRange] OF DirEntry;
  101.      DirP      = ^Directory;
  102.  
  103. VAR EdiEsc, EraseEol,
  104.     EraseEos, Home     : CHAR;   (* Kontrollzeichen     *)
  105.     LastUnit : UnitNum;          (* Versionsbedingung   *)
  106.     Switch   : BytePtr;          (* Zeiger auf SystemID *)
  107.     GDirP    : DirP;             (* Zeiger auf Katalog  *)
  108.  
  109. (*--------------------------------------------------------*)
  110. (* Inhaltsverzeichnis des Geraets FUnit lesen und ab der  *)
  111. (* Adresse GDirP abspeichern.                             *)
  112.  
  113. FUNCTION FetchDir (FUnit : UnitNum) : BOOLEAN;
  114.  
  115. VAR Indx : DirRange;
  116.     Ok   : BOOLEAN;
  117.  
  118. BEGIN
  119.   Mark (GDirP);
  120.   (* keinen Speicherplatz reservieren *)
  121.   (* new (GDirP) geht auch            *)
  122.  
  123.   unitread (FUnit, GDirP^, SizeOf (Directory), DirBlk);
  124.   Ok := IOResult = NoError;
  125.   WITH GDirP^[0], UnitTable [FUnit] DO BEGIN
  126.     IF Ok THEN BEGIN (* Lesen war erfolgreich, Directory untersuchen *)
  127.       Ok := (DFirstBlk = 0) AND
  128.             (DFKind IN [UntypedFile, SecureDir]) AND
  129.             (Length (DVid) IN [1..VidLeng]) AND
  130.             (DNumFiles >= 0) AND (DNumFiles <= MaxDir);
  131.       IF DVid <> UVid THEN BEGIN (* neues Volume in Unit *)
  132.         Indx := 1;
  133.         WHILE (Indx <= DNumFiles) OR NOT Ok DO
  134.           WITH GDirP^[Indx] DO (* Eintraege testen *)
  135.             IF NOT (Length (DTid) IN [1..TidLeng]) OR
  136.                (DLastBlk < DFirstBlk) OR
  137.                (DLastByte > FBlkSize) OR
  138.                (DLastByte <= 0) OR
  139.                (DAccess.Year >= 100) THEN
  140.                Ok := FALSE
  141.              ELSE
  142.                Indx := Indx + 1;
  143.         IF Ok THEN BEGIN (* in Geraetetabelle aufnehmen *)
  144.           UVid := DVid;
  145.           UEovBlk := DEovBlk
  146.         END
  147.       END
  148.     END;
  149.     FetchDir := Ok;
  150.     IF NOT Ok THEN BEGIN (* aus Geraetetabelle loeschen *)
  151.       UVid := '';
  152.       UEovBlk := MaxInt;
  153.       GDirP := NIL
  154.     END
  155.   END (* with *)
  156. END;(* FetchDir *)
  157.  
  158. (*--------------------------------------------------------*)
  159. (* Ein zulaessiges Zeichen einlesen                       *)
  160.  
  161. FUNCTION GetChar (LastCh : CHAR) : CHAR;
  162.  
  163. VAR Ch : CHAR;
  164.     Ok : BOOLEAN;
  165.  
  166. BEGIN
  167.   REPEAT
  168.     Read(keyboard, Ch);
  169.     (* keyboard entspricht der Datei KBD in Turbo-Pascal *)
  170.  
  171.     IF (LastCh >= 'A') AND (LastCh <= 'Z') AND
  172.        (Ch >= 'a') AND (Ch <= 'z') THEN
  173.       Ch := Chr (Ord (Ch) - Ord ('a') + Ord ('A'));
  174.     Ok := (Ch = EdiEsc) OR
  175.          ((Ch >= 'A') AND (Ch <= 'Z')) OR
  176.          ((Ch >= 'a') AND (Ch <= 'z')) OR
  177.          ((Ch >= '0') AND (Ch <= '9') AND (LastCh <= '9'));
  178.     IF NOT Ok THEN Write (Chr (BEL))
  179.   UNTIL Ok;
  180.   GetChar := Ch
  181. END;(* GetChar *)
  182.  
  183. (*--------------------------------------------------------*)
  184. (* Naechstes Code-File aussuchen                          *)
  185.  
  186. PROCEDURE Get (VAR NextCodeFile : FilNam);
  187.  
  188. VAR FCount    : INTEGER;
  189.     LNumFiles : DirRange;
  190.     SelCh     : CHAR;
  191.     Ch        : CHAR;
  192.     Select    : ARRAY['0'..'z'] OF DirRange;
  193.     LDir      : Directory;
  194.  
  195.  
  196.  
  197.   (*- - - - - - - - - - - - - - - - - - - - - - - - - -*)
  198.   (* Geraet auswaehlen                                 *)
  199.  
  200.   FUNCTION WhichUnit : UnitNum;
  201.  
  202.   VAR LUnit : INTEGER;
  203.       Ok    : BOOLEAN;
  204.  
  205.   BEGIN
  206.     GotoXY  (0,4);
  207.     WriteLn (EraseEos, 'Unit-Tabelle:');
  208.     WriteLn;
  209.     FOR LUnit := 4 TO LastUnit DO
  210.       WITH UnitTable [LUnit] DO
  211.         IF UisBlkd AND (Length (UVid) > 0) THEN
  212.           WriteLn ('#',LUnit:2,': ',UVid,':');
  213.     Ok := FALSE;
  214.     REPEAT
  215.       Write (Home,
  216.              'Welche Unit ? #    [<esc> verlassen]',
  217.              EraseEol);
  218.       GotoXY (15,0);
  219.       Read (LUnit);
  220.       IF IOResult <> NoError THEN (* Fehler im Eingabeformat *)
  221.         Exit(Get);                (* z. B <esc>              *)
  222.       ReadLn;   (* "integer" besser mit "readln" lesen *)
  223.       IF (LUnit < 4) OR (LUnit > LastUnit) THEN
  224.         Write ('4..', LastUnit, ' erwartet')
  225.       ELSE
  226.         IF NOT UnitTable [LUnit].UisBlkd THEN
  227.           Write ('Unit #', LUnit,' nicht block-strukturiert')
  228.         ELSE
  229.           Ok := TRUE;
  230.       Write (EraseEol)
  231.     UNTIL Ok;
  232.     WhichUnit := LUnit;
  233.   END;(* WhichUnit *)
  234.  
  235.  
  236.  
  237.   (*- - - - - - - - - - - - - - - - - - - - - - - - - -*)
  238.   (* Inhaltsverzeichnis durchstoebern und alle Pro-    *)
  239.   (* gramme sortiert auf dem Bildschirm anzeigen.      *)
  240.  
  241.   FUNCTION GetFiles (LUnit : UnitNum;
  242.                      VAR Dir : Directory) : BOOLEAN;
  243.  
  244.    (*- - - - - - - - - - - - - - - - - - - - - - - - -*)
  245.    (* Inhaltsverzeichnis sortieren                    *)
  246.    (* Anm.: Der Compiler muss rekursiven Code         *)
  247.    (*       erzeugen koennen.                         *)
  248.  
  249.     PROCEDURE QuickSort (VAR d : Directory; l, r : INTEGER);
  250.  
  251.     VAR i, j  : INTEGER;
  252.         Pivot : Tid;
  253.         Entry : DirEntry;
  254.  
  255.     BEGIN
  256.       IF r > l THEN BEGIN
  257.         i := l;
  258.         j := Pred (r);
  259.         Pivot := d[r].DTid; (* Pivot-Element *)
  260.         REPEAT (* Zwei Bereiche so bilden, dass der eine Teil, *)
  261.                (* gemessen am Pivot-Element, nur kleine, der   *)
  262.                (* andere Teil nur grosse Elemente enthaelt.    *)
  263.           WHILE d[i].DTid < Pivot DO i := Succ (i);
  264.           WHILE (d[j].DTid > Pivot)
  265.                 AND (j >= l) DO (* fuer den Fall, dass das Pivot-Element  *)
  266.                                 (* von alphabetisch kleinster Ordnung ist *)
  267.             j := Pred (j);
  268.             IF i < j THEN BEGIN (* Elemente vertauschen  *)
  269.               Entry := d[i];
  270.               d[i] := d[j];
  271.               d[j] := Entry;
  272.               i := Succ (i);
  273.               j := Pred (j)
  274.             END
  275.         UNTIL i >= j;       (* i ist Pivot-Position; *)
  276.         Entry := d[i];      (* an diese Stelle das   *)
  277.         d[i] := d[r];       (* Pivot-Element ablegen *)
  278.         d[r] := Entry;
  279.         QuickSort (d, l, Pred (i));(* Nun beide Stapel *)
  280.         QuickSort (d, Succ (i), r) (* getr. sortieren. *)
  281.       END
  282.     END;(* QuickSort *)
  283.  
  284.  
  285.   BEGIN (* GetFiles *)
  286.     GetFiles := FALSE;
  287.     IF NOT FetchDir (LUnit) THEN BEGIN
  288.       Write ('Kann Katalog von Unit #',LUnit, ' nicht lesen');
  289.       Exit (GetFiles) (* auf ein Neues *)
  290.     END;
  291.     Dir := GDirP^; (* auf zu neuen Taten *)
  292.     WITH Dir[0] DO BEGIN
  293.       WriteLn;
  294.       WriteLn (EraseEos, DVid,': in #',LUnit,' mit ',DNumFiles,' File(s)');
  295.       IF DNumFiles = 0 THEN BEGIN
  296.         Write ('Diskette leer');
  297.         Exit (GetFiles) (* wieder nicht's *)
  298.       END;
  299.       QuickSort (Dir, 1, DNumFiles)
  300.     END;
  301.     GetFiles := TRUE (* jetzt aber ! *)
  302.   END; (* GetFiles *)
  303.  
  304. BEGIN (* Get *)
  305.   NextCodeFile := '';
  306.   REPEAT
  307.     REPEAT UNTIL GetFiles (WhichUnit, LDir);
  308.     SelCh := Pred ('A');
  309.     LNumFiles  := 0;
  310.     FCount    := -1;
  311.     REPEAT (* alle Code-Files anzeigen *)
  312.       LNumFiles := LNumFiles + 1;
  313.       IF LDir[LNumFiles].DFKind = CodeFile THEN BEGIN
  314.         FCount := FCount + 1;
  315.         IF SelCh = 'Z' THEN (* Nachfolger finden *)
  316.           SelCh := 'a'
  317.         ELSE
  318.           IF SelCh = 'z' THEN
  319.             SelCh := '0'
  320.           ELSE
  321.             SelCh := Succ(SelCh);
  322.         GotoXY (FCount DIV (Height-4) * 20,
  323.                 FCount MOD (Height-4) + 4);
  324.         Write ('(',SelCh,') ', LDir[LNumFiles].DTid);
  325.         Select[SelCh] := LNumFiles
  326.       END
  327.     UNTIL (SelCh = '9') OR (LNumFiles = LDir[0].DNumFiles);
  328.     Ch := EdiEsc;
  329.     IF FCount < 0 THEN
  330.       Write ('kein Code-File gefunden')
  331.     ELSE BEGIN (* Es wird doch noch was *)
  332.       Write (Home, 'Welches Programm starten ? (A..',
  333.              SelCh, ') <esc> verlassen', EraseEol);
  334.       Ch := GetChar (SelCh)
  335.     END;
  336.     Page (Output)
  337.   UNTIL Ch <> EdiEsc; (* Dann nochmal von vorne *)
  338.   NextCodeFile := Concat (LDir[0].DVid, ':',
  339.                           LDir[Select[Ch]].DTid);
  340.   IF Length (NextCodeFile) < FNamLeng THEN (* keinen Suffix anhaengen *)
  341.     Insert('.', NextCodeFile, Length (NextCodeFile) + 1);
  342.   WriteLn (NextCodeFile, ' ausfuehren...')
  343. END;
  344.  
  345. (*--------------------------------------------------------*)
  346.  
  347. BEGIN (* Menu *)
  348.   Switch := NIL;                {(*$R-*) notwendig  }
  349.   IF Switch^[SystemID] = 3 THEN { Pascal 1.2 !      }
  350.     LastUnit := 20              { Anzahl der max.   }
  351.   ELSE                          { moeglichen Units, }
  352.     LastUnit := 12;
  353.   EdiEsc   := Chr (ESC);   { Bildschirm- und   }
  354.   Home     := Chr (EM);    { Eingabesteuer-    }
  355.   EraseEol := Chr (GS);    { zeichen setzen    }
  356.   EraseEos := Chr (VT);
  357.   Page(Output);
  358.   IF LastUnit = MaxUnit THEN { Pascal 1.2 ?      }
  359.     Get (NewNextCode)
  360.   ELSE
  361.     Get (OldNextCode)
  362. END; (* Menu *)
  363.  
  364. (*========================================================*)
  365.  
  366. BEGIN (* PascalSystem *)
  367.  (* Dummyblock des Pascalsystems kann mit dem *)
  368.  (* dem Dienstprogramm LIBRARY.CODE geloescht *)
  369.  (* werden, indem nur das Segment MENU (S# 1) *)
  370.  (* auf ein neues File kopiert wird.          *)
  371. END. (* PascalSystem *)
  372.  
  373.