61 lines
1.7 KiB
Plaintext
61 lines
1.7 KiB
Plaintext
|
--
|
|||
|
|
-- UNCHECK.ADA
|
|||
|
|
--
|
|||
|
|
-- Unchecked programming procedures for Artek Ada
|
|||
|
|
--
|
|||
|
|
-- Copyright (C) 1986 Artek Corporation
|
|||
|
|
--
|
|||
|
|
-- These utility procedures are implemented in accordance
|
|||
|
|
-- with the Ada standard.
|
|||
|
|
--
|
|||
|
|
|
|||
|
|
generic
|
|||
|
|
type OBJECT is limited private;
|
|||
|
|
type NAME is access OBJECT;
|
|||
|
|
procedure UNCHECKED_DEALLOCATION (X : in out NAME);
|
|||
|
|
|
|||
|
|
with ACODES; use ACODES;
|
|||
|
|
procedure UNCHECKED_DEALLOCATION (X : in out NAME) is
|
|||
|
|
|
|||
|
|
begin
|
|||
|
|
pragma ACODE (NOP, 00, 00, 00);
|
|||
|
|
pragma ACODE (LOAD2); -- Load pointer to X
|
|||
|
|
pragma ACODE (CVABS);
|
|||
|
|
pragma ACODE (LOAD2); -- Load contents of X
|
|||
|
|
pragma ACODE (HDISP, 00, 00, 00); -- Dispose the element pointed to by X
|
|||
|
|
pragma ACODE (LOAD2); -- Load pointer to X
|
|||
|
|
pragma ACODE (CVABS, 00, 00);
|
|||
|
|
pragma ACODE (STORE2); -- Store NULL in it
|
|||
|
|
null; -- To make this legal Ada syntax
|
|||
|
|
end UNCHECKED_DEALLOCATION;
|
|||
|
|
|
|||
|
|
generic
|
|||
|
|
type SOURCE is limited private;
|
|||
|
|
type TARGET is limited private;
|
|||
|
|
function UNCHECKED_CONVERSION (S : SOURCE) return TARGET;
|
|||
|
|
|
|||
|
|
with ACODES; use ACODES;
|
|||
|
|
function UNCHECKED_CONVERSION (S : SOURCE) return TARGET is
|
|||
|
|
|
|||
|
|
type TARGET_ACCESS is access TARGET;
|
|||
|
|
TARGET_POINTER : TARGET_ACCESS;
|
|||
|
|
|
|||
|
|
function SOURCE_ADDRESS return TARGET_ACCESS is
|
|||
|
|
A : TARGET_ACCESS;
|
|||
|
|
begin
|
|||
|
|
pragma ACODE (NOP, 00, 00, 00, 01, 00, 00); -- A'ADDRESS, S'ADDRESS
|
|||
|
|
pragma ACODE (ADR); -- Convert S to 16-bit offset
|
|||
|
|
pragma ACODE (STORE2); -- and store in A
|
|||
|
|
return A;
|
|||
|
|
end SOURCE_ADDRESS;
|
|||
|
|
|
|||
|
|
begin
|
|||
|
|
if SOURCE'SIZE /= TARGET'SIZE then
|
|||
|
|
raise CONSTRAINT_ERROR;
|
|||
|
|
else
|
|||
|
|
TARGET_POINTER := SOURCE_ADDRESS;
|
|||
|
|
return TARGET_POINTER . all; -- Return the target (read from the source!)
|
|||
|
|
end if;
|
|||
|
|
end UNCHECKED_CONVERSION;
|
|||
|
|
|
|||
|
|
|