home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Turbo Toolbox
/
Turbo_Toolbox.iso
/
sonderh1
/
execpgm.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1987-12-22
|
12KB
|
299 lines
(*--------------------------------------------------------------------------*)
(*
Modul: ExecPgm - Aufruf von Nicht-Turbo-Pascal-Programmen
und DOS-Speicherverwaltung
Compiler: Turbo Pascal 3.0 (MS-DOS)
Autor: Ulrich Telle
Version: 1.0
*)
(*--------------------------------------------------------------------------*)
type
r8086 = record
case integer of
1: (AX, BX, CX, DX, BP, DI, SI, DS, ES, Flags : integer);
2: (AL, AH, BL, BH, CL, CH, DL, DH : byte);
end;
asciiz = string [65];
anystr = string [255];
var
Regs : r8086;
(*--------------------------------------------------------------------------*)
(*
Funktion: Zuordnung eines neuen Speicherblocks
Parameter (E - Eingabe, A - Ausgabe)
(E) Para_erforderlich Anzahl der benoetigten Paragraphen
(A) Block_Segment Segment-Adresse des neuen Speicherblocks,
falls genuegend Speicherplatz vorhanden
sonst Anzahl der verfuegbaren Paragraphen
Funktionswert = 0, falls genuegend Speicherplatz vorhanden
> 0, sonst
*)
function Malloc (Para_erforderlich : integer;
var Block_Segment : integer) : integer;
begin
Regs.BX := Para_erforderlich; (* Anzahl erforderlicher Paragraphen *)
Regs.AX := $4800; (* Funktion 48h *)
MsDos (Regs); (* MS-DOS-Aufruf *)
if Odd (Regs.Flags) (* Uebertragskennung gesetzt ? *)
then begin
Block_Segment := Regs.BX; (* Ja, Anzahl verfuegbarer Para- *)
Malloc := Lo (Regs.AX); (* graphen und Fehlernummer zurueck- *)
end (* geben *)
else begin
Block_Segment := Regs.AX; (* Nein, Segment Adresse und Fehler- *)
Malloc := 0; (* nummer 0 zurueckgeben *)
end;
end;
(*--------------------------------------------------------------------------*)
(*
Funktion Freigabe eines Speicherbereichs
Parameter (E - Eingabe, A - Ausgabe)
(E) Block_Segment Segment-Adresse des freizugebenden
Speicherblocks,
Funktionswert = 0, falls Freigabe erfolgreich
> 0, sonst
*)
function Mfree (Block_Segment : integer) : integer;
begin
Regs.ES := Block_Segment; (* Adresse des freizugebenden *)
(* Speicher-Segments *)
Regs.AX := $4900; (* Funktion 49h *)
MsDos (Regs); (* MS-DOS-Aufruf *)
if Odd (Regs.Flags) (* Uebertragskennung gesetzt ? *)
then Mfree := Regs.AL (* Ja, Fehlernummer zurueckgeben *)
else Mfree := 0; (* Nein, Fehlernummer 0 zurueckgeben *)
end;
(*--------------------------------------------------------------------------*)
(*
Funktion Verkleinerung eines Speicherbereichs
Verschieben des Turbo Pascal Stack-Segments
Parameter (E - Eingabe, A - Ausgabe)
(E) Para_freigeben Anzahl freizugebender Paragraphen
Funktionswert = 0, falls Verkleinerung erfolgreich
> 0, sonst
*)
function SetBlock (Para_freigeben : integer) : integer;
begin
Inline($1E (* Push DS ; DS-Register sichern *)
/$8C/$C8 (* Mov AX,CS ; Groesse in Paragraphen *)
/$8C/$D3 (* Mov BX,SS ; des aktuellen Blocks = *)
/$81/$C3/$00/$10 (* Add BX,=$1000 ; SS + $1000 - CS *)
/$2B/$D8 (* Sub BX,AX ; - Para_freigeben = *)
/$2B/$9E (* Sub BX,[BP]Para_freigeben *)
/Para_freigeben (* ; Neue Block-Groesse *)
/$8E/$C0 (* Mov ES,AX ; Segment aktueller Block *)
/$B4/$4A (* Mov AH,4Ah ; DOS-Funktion $4A *)
/$CD/$21 (* Int 21h ; Block-Veraenderung *)
/$B4/$00 (* Mov AH,0 *)
/$72/$1B (* JB Ende ; Freigabe moeglich ? *)
/$8C/$D0 (* Mov AX,SS ; - Ja, Stack verschieben *)
/$8E/$D8 (* Mov DS,AX ; DS:SI = Zeiger auf *)
/$2B/$86 (* Sub AX,[BP]Para_freigeben ; alten Stack *)
/Para_freigeben
/$8E/$C0 (* Mov ES,AX ; ES:DI = Zeiger auf *)
/$8B/$DC (* Mov BX,SP neuen Stack *)
/$8B/$FB (* Mov DI,BX *)
/$8B/$F3 (* Mov SI,BX *)
/$8B/$CC (* Mov CX,SP ; Zweierkomplement von SP *)
/$F7/$D9 (* Neg CX ; ist die Stack-Groesse *)
/$FC (* ClD ; CX Bytes verschieben *)
/$F3/$A4 (* Rep MovS (B) ; von DS:SI nach ES:DI *)
/$8E/$D0 (* Mov SS,AX ; Stack-Register umsetzen *)
/$33/$C0 (* XOr AX,AX ; Fehlercode = 0 *)
/$1F (* Ende: Pop DS *)
/$8B/$E5 (* Mov SP,BP ; Ruecksprung *)
/$5D (* Pop BP *)
/$C2/$04/$00 ); (* Ret 4 *)
end;
(*--------------------------------------------------------------------------*)
(*
Funktion Aufruf eines Programms (.EXE oder .COM)
Parameter (E - Eingabe, A - Ausgabe)
(E) Program_Name Name des aufzurufenden Programms
gegebenenfalls mit Pfadangabe
(E) Parameter_String Kommandozeile fuer das Programm
Funktionswert = 0, falls Aufruf erfolgreich
> 0, sonst
*)
function Exec (var Program_Name : asciiz;
var Parameter_String : anystr) : integer;
var
LCB : array [1..7] of integer; (* Load Control Block *)
FCB_1, FCB_2 : array [1..12] of byte; (* File Control Blocks *)
begin
(* File Control Blocks erzeugen *)
Move (Mem [CSeg:$5C], FCB_1, 12);
Move (Mem [CSeg:$6C], FCB_2, 12);
(* Load Control Block erzeugen *)
LCB [1] := 0; (* Umgebung des aufrufenden Programms *)
LCB [2] := Ofs (Parameter_String);
LCB [3] := Seg (Parameter_String);
LCB [4] := Ofs (FCB_1);
LCB [5] := Seg (FCB_1);
LCB [6] := Ofs (FCB_2);
LCB [7] := Seg (FCB_2);
(* Aufruf der MS-DOS-Funktion *)
Regs.AX := $4B00; (* Funktion 4Bh *)
Regs.ES := Seg (LCB); (* Adresse des Load Control Blocks *)
Regs.BX := Ofs (LCB);
Regs.DS := Seg (Program_Name); (* Adresse des Programmnamens *)
Regs.DX := Succ (Ofs (Program_Name));
MsDos (Regs); (* MS-DOS-Aufruf *)
if Odd (Regs.Flags) (* Uebertragskennung gesetzt ? *)
then Exec := Regs.AL (* Ja, Fehlernummer zurueckgeben *)
else Exec := 0; (* Nein, Fehlernummer 0 zurueckgeben *)
end;
(*--------------------------------------------------------------------------*)
(*
Funktion Rueckkehr-Code feststellen
Parameter (E - Eingabe, A - Ausgabe)
keine
Funktionswert Rueckkehr-Code des vorher aufgerufenen Programms
*)
function GetReturnCode : integer;
begin
Regs.AX := $4D00; (* Funktion 4Dh *)
MsDos (Regs); (* MS-DOS-Aufruf *)
GetReturnCode := Regs.AL; (* Rueckkehr Code zurueckgeben *)
end;
(*--------------------------------------------------------------------------*)
(*
Funktion Auffinden des Kommandoprozessor-Namens
Parameter (E - Eingabe, A - Ausgabe)
(A) ComSpec Name des Kommandoprozessors
gegebenenfalls mit Pfadangabe
Funktionswert TRUE, falls ComSpec gefunden
FALSE, sonst
*)
function ComSpec (var ComName : asciiz) : boolean;
type
Dos_Env_Type = array [1..254] of byte; (* DOS Umgebung *)
Dos_Env_String = ^Dos_Env_Type;
var
Dos_Env : Dos_Env_String;
Dos_EnvS : string [255];
Idx : integer;
begin
Dos_Env := Ptr (MemW[CSeg:$2C], $00); (* 254 Byte der *)
Move (Dos_Env^, Dos_EnvS [1], 254); (* DOS-Umgebung kopieren *)
Dos_EnvS [255] := #0;
Dos_EnvS [0] := #255;
Idx := Pos ('COMSPEC=', Dos_EnvS); (* COMSPEC= Teil finden *)
if Idx = 0
then ComSpec := false
else begin
ComSpec := true;
Delete (Dos_EnvS, 1, Idx+7); (* ASCIIZ Zeichenkette *)
Idx := Pos (#0, Dos_EnvS); (* Laufwerk:[Pfad]Dateiname *)
Dos_EnvS := Copy (Dos_EnvS,1,Idx); (* des Kommandoprozessors *)
(* extrahieren *)
while Dos_Envs [1] = ' ' do
Delete (Dos_EnvS, 1,1);
ComName := Dos_EnvS;
end;
end;
(*--------------------------------------------------------------------------*)
(*
Funktion MS-DOS Fehlerbedingungen
Parameter (E - Eingabe, A - Ausgabe)
(E) Fehler_Code DOS Fehlercode
Funktionswert TRUE, falls Fehler_Code <> 0
FALSE, sonst
*)
function Dos_Fehler (Fehler_Code : integer) : boolean;
const
Fehler_Anzahl = 18;
type
Fehler_Tabelle_Type = array [1..Fehler_Anzahl] of string [41];
const
Fehler_Tabelle : Fehler_Tabelle_Type =
('Ungueltige Funktionsnummer',
'Datei nicht gefunden',
'Pfad nicht gefunden',
'Zu viele offene Dateien',
'Zugriff abgewiesen',
'Ungueltige Dateinummer (Handle)',
'Speicher-Kontroll-Bloecke zerstoert',
'Zuwenig Speicherplatz',
'Ungueltige Speicherbereichsadresse',
'Ungueltige Umgebung',
'Ungueltiges Format',
'Ungueltiger Zugriffscode',
'Ungueltige Daten',
'Unbekannter Fehler', (* von DOS nicht verwendet *)
'Ungueltiges Laufwerk angegeben',
'Versuch, das aktuelle Unterverzeichnis zu loeschen',
'Nicht die gleiche Einheit (Device)',
'Keine weiteren Dateien');
begin
Dos_Fehler := true;
if Fehler_Code = 0
then Dos_Fehler := false
else if Fehler_Code in [1..Fehler_Anzahl]
then writeln ('*** DOS Fehler ', Fehler_Code, ': ',
Fehler_Tabelle [Fehler_Code])
else writeln ('*** Unbekannter Fehler: ', Fehler_Code);
end;
(*--------------------------------------------------------------------------*)