Category : Miscellaneous Language Source Code
Archive   : ADAMENU2.ZIP
Filename : MSDOS.PKG
package body msdos is
use Strings;
type months is ( nul, january, february, march, april,
may, june, july, august, september,
october, november, december );
function date return lstring is
-- Returns the system date in character form
-- The form is: January 1, 1987
temp : lstring (80);
tnum : lstring;
separator1 : lstring (1) := (1," ", 1);
separator2 : lstring (2) := (2,", ",2);
currmonth : months;
i : integer;
begin
temp.data := (others => character'val (0));
year := 0;
month := 0;
day := 0;
asm
16#B4#, 16#2A#, -- mov ah, 16#2a
16#CD#, 16#21#, -- int 16#21
16#89#, 16#0E#, YEAR'address, -- mov [year],cx
16#88#, 16#36#, MONTH'address, -- mov [month],dh
16#88#, 16#16#, DAY'address, -- mov [day],dl
16#A2#, DAYOFWEEK'address; -- mov [dayofweek],al
currmonth := months'val(month);
case month is
when 1 => Temp.Len := 7;
when 2 => Temp.Len := 8;
when 3 => Temp.Len := 5;
when 4 => Temp.Len := 5;
when 5 => Temp.Len := 3;
when 6 => Temp.Len := 4;
when 7 => Temp.Len := 4;
when 8 => Temp.Len := 6;
when 9 => Temp.Len := 9;
when 10 => Temp.Len := 7;
when 11 => Temp.Len := 8;
when 12 => Temp.Len := 8;
when others => raise CONSTRAINT_ERROR;
end case;
Temp.Data (1..Temp.Len) :=
Months'image (Currmonth)(1..Temp.Len);
Temp := concat (Temp, separator1);
Temp := concat (Temp, str (day));
Temp := concat (Temp, separator2);
Temp := concat (Temp, str (year));
for i in 2..length (temp)
loop
if temp.data(i) in 'A'..'Z' then
temp.data(i) :=
character'val (character'pos (temp.data(i))+32);
end if;
end loop;
return temp;
exception
when STORAGE_ERROR => Raise;
end date;
function time (form : in timeform) return lstring is
-- Reurns the system time in character form
-- The form is: hh:mm:ss
temp,
h, m, s : Lstring (20);
begin
-- make sure all high bytes are cleared
hours := 0;
minutes := 0;
seconds := 0;
hundreths := 0;
asm
16#B4#, 16#2C#, -- mov ah,16#2c
16#CD#, 16#21#, -- int 16#21
16#88#, 16#2E#, HOURS'address, -- mov [hour],ch
16#88#, 16#0E#, MINUTES'address, -- mov [miutes],cl
16#88#, 16#36#, SECONDS'address, -- mov [seconds],dh
16#88#, 16#16#, HUNDRETHS'address; -- mov [hundreths],dl
h := str(hours,20);
m := str(minutes,20);
s := str(seconds,20);
if (hours < 10) then h := "0" + h; end if;
if (seconds < 10) then s := "0" + s; end if;
if (minutes < 10) then m := "0" + m; end if;
if (form = military) then
temp := h +":"+ m +":"+ s;
else -- form = default
if (hours > 12) then
hours := hours-12;
h := Str (hours,20);
temp := h +":"+ m +" pm";
else
temp := h +":"+ m +" am";
end if;
end if; -- (form = military)
return temp;
exception
when STORAGE_ERROR => Raise;
end time;
function tics return integer is
-- Return the seconds portion of the system time
begin
asm
16#B4#, 16#2C#, -- mov ah,16#2c
16#CD#, 16#21#, -- int 16#21
16#88#, 16#36#, SECONDS'address; -- mov [seconds],dh
return seconds;
end tics;
function kybdchar return character is
-- Wait for the next character from the keyboard.
-- Ignores control c, no echo to output
begin
asm
16#B4#, 16#07#, -- MOV AH,07
16#CD#, 16#21#, -- INT #21
16#A2#, inkey'address; -- MOV [inkey],AL
return inkey;
end kybdchar;
procedure bell is
-- Sound the bell
begin
asm
16#B2#,16#07#, -- mov dl,07
16#B4#,16#02#, -- mov ah,02
16#CD#,16#21#; -- int 21h
end bell;
procedure termcode (code : in integer) is
-- Terminate current process and set MSDOS errorlevel
begin
retcode := character'val (code);
asm
16#B4#,16#4C#, -- mov ah, 4Ch ; function 4ch, Terminate a process
16#A0#,
retcode'address, -- mov al, [retcode] ; set the return code
16#CD#,16#21#; -- int 16#21 ; call DOS
end termcode;
function free_disk_space (drive : in character) return float is
-- return the free space on the drive in kilobytes
bytes_per_cluster : integer;
free_space : float := 0.0;
begin
dos_error := false;
-- Convert the drive designator from char to integer
retcode := character'val (character'pos (drive)-64);
-- A = 1, B = 2, . . .
asm
16#b4#,16#36#, -- mov ah,16#36 ; request default
16#8a#,16#16#,
retcode'address, -- mov dl,[drive] ; drive
16#cd#,16#21#, -- int 16#21 ; call dos
16#3d#,16#ff#,16#ff#, -- cmp ax,16#ffff ; was it a valid drive?
16#74#,16#12#, -- je error ;
16#a3#,
sectors_per_cluster'address,-- mov word [sectors_per_cluster],ax
16#89#,16#1e#,
available_clusters'address, -- mov word [available_clusters],bx
16#89#,16#0e#,
bytes_per_sector'address, -- mov word [bytes_per_sector],cx
16#89#,16#16#,
total_clusters'address, -- mov word [total_clusters],dx
16#e9#,16#05#,16#00#, -- jmp exit
-- error:
16#c6#,16#06#,
dos_error'address,16#ff#; -- mov byte [dos_error], 16#ff
-- ; set the error flag
-- exit:
if dos_error then return -1.0; end if;
bytes_per_cluster := bytes_per_sector *
sectors_per_cluster;
free_space := float (available_clusters) *
float (bytes_per_cluster);
return free_space/1000.00; -- Return the space in kilobytes
exception
when STORAGE_ERROR => Raise;
end free_disk_space;
procedure Flush_Keyboard_Buffer is
begin
asm
16#B4#,16#0C#, -- mov ah,#0C ; Flush keyboard buffer
16#A0#,16#FF#,
16#CD#,16#21#; -- int #21 ; call DOS
KeyPress := False;
end Flush_Keyboard_Buffer;
function Keypressed return BOOLEAN is
-- Return true if a character is waiting in the
-- keyboard buffer, else return false
begin
KeyPress := False;
asm
16#B4#,16#0B#, -- mov ah,#0b ; Check keyboard status
16#CD#,16#21#, -- int #21 ; call DOS
16#3C#,16#00#, -- cmp al,0 ; 0 if no key pressed
16#74#,16#08#, -- je nopress
16#C6#,16#06#,
KEYPRESS'address,16#01#, -- mov [>keypress],byte 1
16#E9#,16#05#,16#00#, -- jmp exit
--nopress:
16#C6#,16#06#,
KEYPRESS'address,16#00#; -- mov [>keypress],byte 0
--exit:
return keypress;
exception
when STORAGE_ERROR => Raise;
end keypressed;
end msdos;
Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!
This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.
But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/