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