home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / sonderh1 / execpgm.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1987-12-22  |  11.7 KB  |  299 lines
  1. (*--------------------------------------------------------------------------*)
  2. (*
  3.      Modul:        ExecPgm - Aufruf von Nicht-Turbo-Pascal-Programmen
  4.                              und DOS-Speicherverwaltung
  5.  
  6.      Compiler:     Turbo Pascal 3.0   (MS-DOS)
  7.  
  8.      Autor:        Ulrich Telle
  9.  
  10.      Version:      1.0
  11.                                                                             *)
  12. (*--------------------------------------------------------------------------*)
  13.  
  14. type
  15.   r8086  = record
  16.              case integer of
  17.                1: (AX, BX, CX, DX, BP, DI, SI, DS, ES, Flags : integer);
  18.                2: (AL, AH, BL, BH, CL, CH, DL, DH : byte);
  19.            end;
  20.   asciiz = string [65];
  21.   anystr = string [255];
  22.  
  23. var
  24.   Regs : r8086;
  25.  
  26.  
  27. (*--------------------------------------------------------------------------*)
  28. (*
  29.        Funktion:        Zuordnung eines neuen Speicherblocks
  30.  
  31.        Parameter (E - Eingabe, A - Ausgabe)
  32.  
  33.          (E) Para_erforderlich    Anzahl der benoetigten Paragraphen
  34.  
  35.          (A) Block_Segment        Segment-Adresse des neuen Speicherblocks,
  36.                                   falls genuegend Speicherplatz vorhanden
  37.                                   sonst Anzahl der verfuegbaren Paragraphen
  38.  
  39.        Funktionswert    = 0, falls genuegend Speicherplatz vorhanden
  40.                         > 0, sonst
  41.                                                                              *)
  42. function Malloc (Para_erforderlich : integer;
  43.                  var Block_Segment : integer) : integer;
  44.  
  45. begin
  46.   Regs.BX := Para_erforderlich;  (* Anzahl erforderlicher Paragraphen *)
  47.   Regs.AX := $4800;              (* Funktion 48h                      *)
  48.   MsDos (Regs);                  (* MS-DOS-Aufruf                     *)
  49.   if Odd (Regs.Flags)            (* Uebertragskennung gesetzt ?       *)
  50.     then begin
  51.       Block_Segment := Regs.BX;  (* Ja, Anzahl verfuegbarer Para-     *)
  52.       Malloc := Lo (Regs.AX);    (* graphen und Fehlernummer zurueck- *)
  53.       end                        (* geben                             *)
  54.     else begin
  55.       Block_Segment := Regs.AX;  (* Nein, Segment Adresse und Fehler- *)
  56.       Malloc := 0;               (* nummer 0 zurueckgeben             *)
  57.       end;
  58. end;
  59.  
  60. (*--------------------------------------------------------------------------*)
  61. (*
  62.        Funktion         Freigabe eines Speicherbereichs
  63.  
  64.        Parameter (E - Eingabe, A - Ausgabe)
  65.  
  66.          (E) Block_Segment        Segment-Adresse des freizugebenden
  67.                                   Speicherblocks,
  68.  
  69.        Funktionswert    = 0, falls Freigabe erfolgreich
  70.                         > 0, sonst
  71.                                                                             *)
  72.  
  73. function Mfree (Block_Segment : integer) : integer;
  74.  
  75. begin
  76.   Regs.ES := Block_Segment;      (* Adresse des freizugebenden        *)
  77.                                  (* Speicher-Segments                 *)
  78.   Regs.AX := $4900;              (* Funktion 49h                      *)
  79.   MsDos (Regs);                  (* MS-DOS-Aufruf                     *)
  80.   if  Odd (Regs.Flags)           (* Uebertragskennung gesetzt ?       *)
  81.     then Mfree := Regs.AL        (* Ja, Fehlernummer zurueckgeben     *)
  82.     else Mfree := 0;             (* Nein, Fehlernummer 0 zurueckgeben *)
  83. end;
  84.  
  85. (*--------------------------------------------------------------------------*)
  86. (*
  87.        Funktion         Verkleinerung eines Speicherbereichs
  88.                         Verschieben des Turbo Pascal Stack-Segments
  89.  
  90.        Parameter (E - Eingabe, A - Ausgabe)
  91.  
  92.          (E) Para_freigeben       Anzahl freizugebender Paragraphen
  93.  
  94.        Funktionswert    = 0, falls Verkleinerung erfolgreich
  95.                         > 0, sonst
  96.                                                                             *)
  97.  
  98. function SetBlock (Para_freigeben : integer) : integer;
  99.  
  100. begin
  101.   Inline($1E             (*       Push  DS        ; DS-Register sichern     *)
  102.         /$8C/$C8         (*       Mov   AX,CS     ; Groesse in Paragraphen  *)
  103.         /$8C/$D3         (*       Mov   BX,SS     ; des aktuellen Blocks =  *)
  104.         /$81/$C3/$00/$10 (*       Add   BX,=$1000 ; SS + $1000 - CS         *)
  105.         /$2B/$D8         (*       Sub   BX,AX     ; - Para_freigeben =      *)
  106.         /$2B/$9E         (*       Sub   BX,[BP]Para_freigeben               *)
  107.             /Para_freigeben                    (* ; Neue Block-Groesse      *)
  108.         /$8E/$C0         (*       Mov   ES,AX     ; Segment aktueller Block *)
  109.         /$B4/$4A         (*       Mov   AH,4Ah    ; DOS-Funktion $4A        *)
  110.         /$CD/$21         (*       Int   21h       ; Block-Veraenderung      *)
  111.         /$B4/$00         (*       Mov   AH,0                                *)
  112.         /$72/$1B         (*       JB    Ende      ; Freigabe moeglich ?     *)
  113.         /$8C/$D0         (*       Mov   AX,SS     ; - Ja, Stack verschieben *)
  114.         /$8E/$D8         (*       Mov   DS,AX     ; DS:SI = Zeiger auf      *)
  115.         /$2B/$86         (*       Sub   AX,[BP]Para_freigeben ; alten Stack *)
  116.             /Para_freigeben
  117.         /$8E/$C0         (*       Mov   ES,AX     ; ES:DI = Zeiger auf      *)
  118.         /$8B/$DC         (*       Mov   BX,SP                   neuen Stack *)
  119.         /$8B/$FB         (*       Mov   DI,BX                               *)
  120.         /$8B/$F3         (*       Mov   SI,BX                               *)
  121.         /$8B/$CC         (*       Mov   CX,SP     ; Zweierkomplement von SP *)
  122.         /$F7/$D9         (*       Neg   CX        ; ist die Stack-Groesse   *)
  123.         /$FC             (*       ClD             ; CX Bytes verschieben    *)
  124.         /$F3/$A4         (*       Rep   MovS (B)  ; von DS:SI nach ES:DI    *)
  125.         /$8E/$D0         (*       Mov   SS,AX     ; Stack-Register umsetzen *)
  126.         /$33/$C0         (*       XOr   AX,AX     ; Fehlercode = 0          *)
  127.         /$1F             (* Ende: Pop   DS                                  *)
  128.         /$8B/$E5         (*       Mov   SP,BP     ; Ruecksprung             *)
  129.         /$5D             (*       Pop   BP                                  *)
  130.         /$C2/$04/$00  ); (*       Ret   4                                   *)
  131. end;
  132.  
  133. (*--------------------------------------------------------------------------*)
  134. (*
  135.        Funktion         Aufruf eines Programms (.EXE oder .COM)
  136.  
  137.        Parameter (E - Eingabe, A - Ausgabe)
  138.  
  139.          (E) Program_Name         Name des aufzurufenden Programms
  140.                                   gegebenenfalls mit Pfadangabe
  141.  
  142.          (E) Parameter_String     Kommandozeile fuer das Programm
  143.  
  144.        Funktionswert    = 0, falls Aufruf erfolgreich
  145.                         > 0, sonst
  146.                                                                             *)
  147.  
  148. function Exec (var Program_Name     : asciiz;
  149.                var Parameter_String : anystr) : integer;
  150.  
  151. var
  152.   LCB          : array [1..7] of integer;       (* Load Control Block *)
  153.   FCB_1, FCB_2 : array [1..12] of byte;         (* File Control Blocks *)
  154.  
  155. begin
  156.  
  157. (* File Control Blocks erzeugen *)
  158.  
  159.   Move (Mem [CSeg:$5C], FCB_1, 12);
  160.   Move (Mem [CSeg:$6C], FCB_2, 12);
  161.  
  162. (* Load Control Block erzeugen *)
  163.  
  164.   LCB [1] := 0;                 (* Umgebung des aufrufenden Programms *)
  165.   LCB [2] := Ofs (Parameter_String);
  166.   LCB [3] := Seg (Parameter_String);
  167.   LCB [4] := Ofs (FCB_1);
  168.   LCB [5] := Seg (FCB_1);
  169.   LCB [6] := Ofs (FCB_2);
  170.   LCB [7] := Seg (FCB_2);
  171.  
  172. (* Aufruf der MS-DOS-Funktion *)
  173.  
  174.   Regs.AX := $4B00;              (* Funktion 4Bh                      *)
  175.   Regs.ES := Seg (LCB);          (* Adresse des Load Control Blocks   *)
  176.   Regs.BX := Ofs (LCB);
  177.   Regs.DS := Seg (Program_Name); (* Adresse des Programmnamens        *)
  178.   Regs.DX := Succ (Ofs (Program_Name));
  179.   MsDos (Regs);                  (* MS-DOS-Aufruf                     *)
  180.   if Odd (Regs.Flags)            (* Uebertragskennung gesetzt ?       *)
  181.     then Exec := Regs.AL         (* Ja, Fehlernummer zurueckgeben     *)
  182.     else Exec := 0;              (* Nein, Fehlernummer 0 zurueckgeben *)
  183. end;
  184.  
  185. (*--------------------------------------------------------------------------*)
  186. (*
  187.        Funktion         Rueckkehr-Code feststellen
  188.  
  189.        Parameter (E - Eingabe, A - Ausgabe)
  190.  
  191.          keine
  192.  
  193.        Funktionswert    Rueckkehr-Code des vorher aufgerufenen Programms
  194.                                                                             *)
  195.  
  196. function GetReturnCode : integer;
  197.  
  198. begin
  199.   Regs.AX := $4D00;              (* Funktion 4Dh                      *)
  200.   MsDos (Regs);                  (* MS-DOS-Aufruf                     *)
  201.   GetReturnCode := Regs.AL;      (* Rueckkehr Code zurueckgeben       *)
  202. end;
  203.  
  204. (*--------------------------------------------------------------------------*)
  205. (*
  206.        Funktion         Auffinden des Kommandoprozessor-Namens
  207.  
  208.        Parameter (E - Eingabe, A - Ausgabe)
  209.  
  210.          (A) ComSpec              Name des Kommandoprozessors
  211.                                   gegebenenfalls mit Pfadangabe
  212.  
  213.        Funktionswert    TRUE, falls ComSpec gefunden
  214.                         FALSE, sonst
  215.                                                                             *)
  216.  
  217. function ComSpec (var ComName : asciiz) : boolean;
  218.  
  219. type
  220.   Dos_Env_Type   = array [1..254] of byte;  (* DOS Umgebung *)
  221.   Dos_Env_String = ^Dos_Env_Type;
  222.  
  223. var
  224.   Dos_Env  : Dos_Env_String;
  225.   Dos_EnvS : string [255];
  226.   Idx      : integer;
  227.  
  228. begin
  229.   Dos_Env := Ptr (MemW[CSeg:$2C], $00); (* 254 Byte der             *)
  230.   Move (Dos_Env^, Dos_EnvS [1], 254);    (* DOS-Umgebung kopieren    *)
  231.   Dos_EnvS [255] := #0;
  232.   Dos_EnvS [0] := #255;
  233.   Idx := Pos ('COMSPEC=', Dos_EnvS);     (* COMSPEC= Teil finden     *)
  234.   if Idx = 0
  235.     then ComSpec := false
  236.     else begin
  237.       ComSpec := true;
  238.       Delete (Dos_EnvS, 1, Idx+7);       (* ASCIIZ Zeichenkette      *)
  239.       Idx := Pos (#0, Dos_EnvS);         (* Laufwerk:[Pfad]Dateiname *)
  240.       Dos_EnvS := Copy (Dos_EnvS,1,Idx); (* des Kommandoprozessors   *)
  241.                                          (* extrahieren              *)
  242.       while Dos_Envs [1] = ' ' do
  243.         Delete (Dos_EnvS, 1,1);
  244.       ComName := Dos_EnvS;
  245.       end;
  246. end;
  247.  
  248. (*--------------------------------------------------------------------------*)
  249. (*
  250.        Funktion         MS-DOS Fehlerbedingungen
  251.  
  252.        Parameter (E - Eingabe, A - Ausgabe)
  253.  
  254.          (E) Fehler_Code          DOS Fehlercode
  255.  
  256.        Funktionswert    TRUE, falls Fehler_Code <> 0
  257.                         FALSE, sonst
  258.  
  259.                                                                             *)
  260.  
  261. function Dos_Fehler (Fehler_Code : integer) : boolean;
  262.  
  263. const
  264.   Fehler_Anzahl = 18;
  265. type
  266.   Fehler_Tabelle_Type = array [1..Fehler_Anzahl] of string [41];
  267.  
  268. const
  269.   Fehler_Tabelle : Fehler_Tabelle_Type =
  270.     ('Ungueltige Funktionsnummer',
  271.      'Datei nicht gefunden',
  272.      'Pfad nicht gefunden',
  273.      'Zu viele offene Dateien',
  274.      'Zugriff abgewiesen',
  275.      'Ungueltige Dateinummer (Handle)',
  276.      'Speicher-Kontroll-Bloecke zerstoert',
  277.      'Zuwenig Speicherplatz',
  278.      'Ungueltige Speicherbereichsadresse',
  279.      'Ungueltige Umgebung',
  280.      'Ungueltiges Format',
  281.      'Ungueltiger Zugriffscode',
  282.      'Ungueltige Daten',
  283.      'Unbekannter Fehler', (* von DOS nicht verwendet *)
  284.      'Ungueltiges Laufwerk angegeben',
  285.      'Versuch, das aktuelle Unterverzeichnis zu loeschen',
  286.      'Nicht die gleiche Einheit (Device)',
  287.      'Keine weiteren Dateien');
  288.  
  289. begin
  290.   Dos_Fehler := true;
  291.   if Fehler_Code = 0
  292.     then Dos_Fehler := false
  293.     else if Fehler_Code in [1..Fehler_Anzahl]
  294.            then writeln ('*** DOS Fehler ', Fehler_Code, ': ',
  295.                          Fehler_Tabelle [Fehler_Code])
  296.            else writeln ('*** Unbekannter Fehler: ', Fehler_Code);
  297. end;
  298.  
  299. (*--------------------------------------------------------------------------*)