212 lines
6.3 KiB
Ada
212 lines
6.3 KiB
Ada
--
|
||
-- MEMORY.ADA
|
||
--
|
||
-- Memory management package for Artek Ada
|
||
--
|
||
-- Copyright (C) 1986 Artek Corporation
|
||
-- Author: V. Thorsteinsson
|
||
--
|
||
-- This generic package enables users of Artek Ada to access all
|
||
-- 640 Kb of available memory under DOS.
|
||
--
|
||
-- It is implemented as a set of five operations:
|
||
-- ALLOCATE, DEALLOCATE, MODIFY_ALLOCATION, READ, and WRITE.
|
||
-- The allocated memory is modeled as an array (indexed from 0)
|
||
-- of the generic type DATA. Elements of the array may be written
|
||
-- or read using the READ and WRITE operations. The size
|
||
-- of the array may be set using ALLOCATE and the memory used
|
||
-- by the array can be freed with DEALLOCATE. If the user
|
||
-- wishes to modify the size of an already allocated array,
|
||
-- he should use the MODIFY_ALLOCATION procedure. This will
|
||
-- preserve the memory contents up to the latest original element
|
||
-- or the latest new element, whichever is lower in memory.
|
||
-- Any error in usage causes a MEMORY_ERROR exception to be
|
||
-- raised.
|
||
--
|
||
-- Example of usage:
|
||
--
|
||
-- with TEXT_IO; use TEXT_IO;
|
||
-- procedure MEMORY_DEMO is
|
||
--
|
||
-- type SYMBOL is record
|
||
-- IDENTIFIER : STRING (1..32);
|
||
-- SYMTYPE : (OBJECT, PROGRAM, LABEL);
|
||
-- CONTENTS : INTEGER;
|
||
-- end record;
|
||
--
|
||
-- package SYMTABLE is new MEMORY (SYMBOL);
|
||
--
|
||
-- S : SYMBOL;
|
||
--
|
||
-- begin
|
||
-- SYMTABLE.ALLOCATE (2000); -- This allocates about 70K of data
|
||
-- S . IDENTIFIER := "IDENTIFIER ";
|
||
-- S . SYMTYPE := PROGRAM;
|
||
-- for I in 0..1999 loop -- NOTE: not 1 to 2000!
|
||
-- S . CONTENTS := I;
|
||
-- SYMTABLE.WRITE (I, S); -- Write S into array element I
|
||
-- end loop;
|
||
-- SYMTABLE.READ (1555, S); -- Read S from array element 1555
|
||
-- SYMTABLE.DEALLOCATE;
|
||
-- PUT_LINE (INTEGER'IMAGE (S . CONTENTS)); -- Should write 1555
|
||
-- exception
|
||
-- when MEMORY_ERROR =>
|
||
-- PUT_LINE ("Error while working with MEMORY package");
|
||
-- end MEMORY_DEMO;
|
||
--
|
||
|
||
with SYSTEM; use SYSTEM;
|
||
|
||
generic
|
||
type DATA is private;
|
||
package MEMORY is
|
||
procedure ALLOCATE (NUMBER_OF_ELEMENTS : in POSITIVE);
|
||
procedure DEALLOCATE;
|
||
procedure MODIFY_ALLOCATION (NUMBER_OF_ELEMENTS : in POSITIVE);
|
||
procedure READ (NUMBER_OF_ELEMENT : in NATURAL; ELEMENT : out DATA);
|
||
procedure WRITE (NUMBER_OF_ELEMENT : in NATURAL; ELEMENT : in DATA);
|
||
MEMORY_ERROR : exception;
|
||
end MEMORY;
|
||
|
||
with DOS_INTERFACE; use DOS_INTERFACE;
|
||
with LONG_OPERATIONS; use LONG_OPERATIONS;
|
||
with SYSTEM;
|
||
|
||
package body MEMORY is
|
||
|
||
use SYSTEM;
|
||
|
||
type LONG_PTR is record
|
||
OFF : WORD;
|
||
SEG : WORD;
|
||
end record;
|
||
|
||
subtype SEGMENT is WORD;
|
||
|
||
NIL : constant SEGMENT := 0;
|
||
ELEMENT_SIZE : constant INTEGER := DATA'SIZE / STORAGE_UNIT;
|
||
|
||
BASE : SEGMENT := NIL;
|
||
POOLSIZE : NATURAL := 0;
|
||
|
||
R : REG_8086;
|
||
|
||
function DOS_ALLOCATE (SIZE : INTEGER) return SEGMENT is
|
||
begin
|
||
R . AX := 16#4800#;
|
||
R . BX := WORD (SIZE);
|
||
CALL_DOS (R);
|
||
if R . FLAGS mod 2 = 1 then -- Carry set
|
||
raise MEMORY_ERROR;
|
||
end if;
|
||
return R . AX;
|
||
end;
|
||
|
||
procedure DOS_DEALLOCATE (S : SEGMENT) is
|
||
begin
|
||
R . AX := 16#4900#;
|
||
R . ES := S;
|
||
CALL_DOS (R);
|
||
if R . FLAGS mod 2 = 1 then
|
||
raise MEMORY_ERROR;
|
||
end if;
|
||
end;
|
||
|
||
procedure DOS_MODIFY_ALLOCATION (S : SEGMENT; SIZE : INTEGER) is
|
||
begin
|
||
R . AX := 16#4A00#;
|
||
R . ES := S;
|
||
R . BX := WORD (SIZE);
|
||
CALL_DOS (R);
|
||
if R . FLAGS mod 2 = 1 then
|
||
raise MEMORY_ERROR;
|
||
end if;
|
||
end;
|
||
|
||
procedure ALLOCATE (NUMBER_OF_ELEMENTS : in POSITIVE) is
|
||
|
||
SIZE : LONG_INTEGER;
|
||
|
||
begin
|
||
if BASE /= NIL then
|
||
raise MEMORY_ERROR;
|
||
end if;
|
||
SIZE := SHR (NUMBER_OF_ELEMENTS * ELEMENT_SIZE, 4);
|
||
BASE := DOS_ALLOCATE (SIZE . LOW + 1);
|
||
POOLSIZE := NUMBER_OF_ELEMENTS;
|
||
end ALLOCATE;
|
||
|
||
procedure DEALLOCATE is
|
||
begin
|
||
if BASE = NIL then
|
||
raise MEMORY_ERROR;
|
||
end if;
|
||
DOS_DEALLOCATE (BASE);
|
||
POOLSIZE := 0;
|
||
end DEALLOCATE;
|
||
|
||
procedure MODIFY_ALLOCATION (NUMBER_OF_ELEMENTS : in POSITIVE) is
|
||
|
||
SIZE : LONG_INTEGER;
|
||
|
||
begin
|
||
if BASE = NIL then
|
||
raise MEMORY_ERROR;
|
||
end if;
|
||
SIZE := SHR (NUMBER_OF_ELEMENTS * ELEMENT_SIZE, 4);
|
||
DOS_MODIFY_ALLOCATION (BASE, SIZE . LOW + 1);
|
||
POOLSIZE := NUMBER_OF_ELEMENTS;
|
||
end MODIFY_ALLOCATION;
|
||
|
||
procedure MOVE_SHORT_LONG (FROM : in INTEGER; TO : in LONG_INTEGER; SIZE : in INTEGER) is
|
||
begin
|
||
pragma NATIVE (
|
||
16#55#, 16#06#, 16#8B#, 16#EE#, 16#8B#, 16#76#, 16#00#, 16#8B#,
|
||
16#56#, 16#02#, 16#8B#, 16#FA#, 16#81#, 16#E7#, 16#0F#, 16#00#,
|
||
16#81#, 16#E2#, 16#F0#, 16#FF#, 16#B1#, 16#04#, 16#D3#, 16#EA#,
|
||
16#8B#, 16#46#, 16#04#, 16#B1#, 16#0C#, 16#D3#, 16#E0#, 16#0B#,
|
||
16#C2#, 16#8B#, 16#4E#, 16#06#, 16#8E#, 16#C0#, 16#FC#, 16#F3#,
|
||
16#A4#, 16#07#, 16#5D#);
|
||
null;
|
||
end MOVE_SHORT_LONG;
|
||
|
||
procedure MOVE_LONG_SHORT (FROM : in LONG_INTEGER; TO : in INTEGER; SIZE : in INTEGER) is
|
||
begin
|
||
pragma NATIVE (
|
||
16#1E#, 16#55#, 16#8B#, 16#EE#, 16#8B#, 16#7E#, 16#04#, 16#8B#,
|
||
16#56#, 16#00#, 16#8B#, 16#F2#, 16#81#, 16#E6#, 16#0F#, 16#00#,
|
||
16#81#, 16#E2#, 16#F0#, 16#FF#, 16#B1#, 16#04#, 16#D3#, 16#EA#,
|
||
16#8B#, 16#46#, 16#02#, 16#B1#, 16#0C#, 16#D3#, 16#E0#, 16#0B#,
|
||
16#C2#, 16#8B#, 16#4E#, 16#06#, 16#8E#, 16#D8#, 16#FC#, 16#F3#,
|
||
16#A4#, 16#5D#, 16#1F#);
|
||
null;
|
||
end MOVE_LONG_SHORT;
|
||
|
||
procedure READ (NUMBER_OF_ELEMENT : in NATURAL; ELEMENT : out DATA) is
|
||
|
||
ADDRESS : LONG_INTEGER;
|
||
|
||
begin
|
||
if BASE = NIL or NUMBER_OF_ELEMENT >= POOLSIZE then
|
||
raise MEMORY_ERROR;
|
||
end if;
|
||
ADDRESS := INTEGER (BASE) * 16;
|
||
ADDRESS := NUMBER_OF_ELEMENT * ELEMENT_SIZE + ADDRESS;
|
||
MOVE_LONG_SHORT (ADDRESS, ELEMENT'ADDRESS, ELEMENT_SIZE);
|
||
end READ;
|
||
|
||
procedure WRITE (NUMBER_OF_ELEMENT : in NATURAL; ELEMENT : in DATA) is
|
||
|
||
ADDRESS : LONG_INTEGER;
|
||
|
||
begin
|
||
if BASE = NIL or NUMBER_OF_ELEMENT >= POOLSIZE then
|
||
raise MEMORY_ERROR;
|
||
end if;
|
||
ADDRESS := INTEGER (BASE) * 16;
|
||
ADDRESS := NUMBER_OF_ELEMENT * ELEMENT_SIZE + ADDRESS;
|
||
MOVE_SHORT_LONG (ELEMENT'ADDRESS, ADDRESS, ELEMENT_SIZE);
|
||
end WRITE;
|
||
|
||
end MEMORY;
|
||
|