Artek Ada v1.25
This commit is contained in:
davidly
parent
de00a2ae4a
commit
c8dcd3cb13
BIN
Artek Ada v125/A86.EXE
Normal file
BIN
Artek Ada v125/A86.EXE
Normal file
Binary file not shown.
135
Artek Ada v125/ACODES.ADA
Normal file
135
Artek Ada v125/ACODES.ADA
Normal file
@ -0,0 +1,135 @@
|
||||
package ACODES is
|
||||
|
||||
-- This package contains constants to make use of
|
||||
-- the pragma ACODE easier.
|
||||
|
||||
ADD : constant := 0;
|
||||
SUB : constant := 1;
|
||||
MUL : constant := 2;
|
||||
DIV : constant := 3;
|
||||
EQU : constant := 4;
|
||||
NEQ : constant := 5;
|
||||
LES : constant := 6;
|
||||
GTR : constant := 7;
|
||||
LEQ : constant := 8;
|
||||
GEQ : constant := 9;
|
||||
C_NOT : constant := 10; -- NOT is a reserved word in Ada
|
||||
NEG : constant := 11;
|
||||
C_IN : constant := 12; -- IN is a reserved word in Ada
|
||||
C_AND : constant := 13;
|
||||
C_OR : constant := 14;
|
||||
C_XOR : constant := 15;
|
||||
POW : constant := 16;
|
||||
C_MOD : constant := 17;
|
||||
C_REM : constant := 18;
|
||||
LOAD2 : constant := 19;
|
||||
LOAD : constant := 20;
|
||||
STORE : constant := 21;
|
||||
BRANCH : constant := 22;
|
||||
JUMP : constant := 23;
|
||||
ENTER : constant := 24;
|
||||
LEAVE : constant := 25;
|
||||
CALL : constant := 26;
|
||||
INC : constant := 27;
|
||||
DEC : constant := 28;
|
||||
GLC : constant := 29;
|
||||
PLC : constant := 30;
|
||||
ILC : constant := 31;
|
||||
DLC : constant := 32;
|
||||
SHL : constant := 33;
|
||||
SHR : constant := 34;
|
||||
STORE2 : constant := 35;
|
||||
ILC0 : constant := 36;
|
||||
ILC1 : constant := 37;
|
||||
DLC0 : constant := 38;
|
||||
DLC1 : constant := 39;
|
||||
PLC0 : constant := 40;
|
||||
PLC1 : constant := 41;
|
||||
GLC0 : constant := 42;
|
||||
GLC1 : constant := 43;
|
||||
SHL1 : constant := 44;
|
||||
SHR1 : constant := 45;
|
||||
DUP1 : constant := 46;
|
||||
LOAD1 : constant := 47;
|
||||
STORE1 : constant := 48;
|
||||
NOP : constant := 49;
|
||||
SFP : constant := 50;
|
||||
C_ABS : constant := 51;
|
||||
NATIVE : constant := 52;
|
||||
LCALL : constant := 53;
|
||||
ADR : constant := 54;
|
||||
HCOPY : constant := 55;
|
||||
CONC : constant := 56;
|
||||
DUP : constant := 57;
|
||||
SEX : constant := 58;
|
||||
REX : constant := 59;
|
||||
PEX : constant := 60;
|
||||
BLOCK : constant := 61;
|
||||
LINE : constant := 62;
|
||||
CEX : constant := 63;
|
||||
STATIC : constant := 64;
|
||||
INDEX : constant := 65;
|
||||
ADDF : constant := 66;
|
||||
SUBF : constant := 67;
|
||||
MULF : constant := 68;
|
||||
DIVF : constant := 69;
|
||||
EQUF : constant := 70;
|
||||
NEQF : constant := 71;
|
||||
LESF : constant := 72;
|
||||
GTRF : constant := 73;
|
||||
LEQF : constant := 74;
|
||||
GEQF : constant := 75;
|
||||
NEGF : constant := 76;
|
||||
POWF : constant := 77;
|
||||
MULFI : constant := 78;
|
||||
MULIF : constant := 79;
|
||||
DIVFI : constant := 80;
|
||||
EQU1 : constant := 81;
|
||||
NEQ1 : constant := 82;
|
||||
LES1 : constant := 83;
|
||||
GTR1 : constant := 84;
|
||||
LEQ1 : constant := 85;
|
||||
GEQ1 : constant := 86;
|
||||
EQUS : constant := 87;
|
||||
NEQS : constant := 88;
|
||||
LESS : constant := 89;
|
||||
GTRS : constant := 90;
|
||||
LEQS : constant := 91;
|
||||
GEQS : constant := 92;
|
||||
CONCCS : constant := 93;
|
||||
CONCSC : constant := 94;
|
||||
CONCCC : constant := 95;
|
||||
PLC2 : constant := 96;
|
||||
GLC2 : constant := 97;
|
||||
ILC2 : constant := 98;
|
||||
DLC2 : constant := 99;
|
||||
ABSF : constant := 100;
|
||||
CVFI : constant := 101;
|
||||
CVIF : constant := 102;
|
||||
POP1 : constant := 103;
|
||||
CVABS : constant := 104;
|
||||
RBRANCH : constant := 105;
|
||||
LLOAD : constant := 106;
|
||||
LSTORE : constant := 107;
|
||||
INP : constant := 108;
|
||||
OUTP : constant := 109;
|
||||
ANDL : constant := 110;
|
||||
ORL : constant := 111;
|
||||
XORL : constant := 112;
|
||||
NOTL : constant := 113;
|
||||
CVIS : constant := 114;
|
||||
CVSI : constant := 115;
|
||||
EQUL : constant := 116;
|
||||
LOCAL : constant := 117;
|
||||
INF : constant := 118;
|
||||
DUP2 : constant := 119;
|
||||
RSIZE : constant := 120;
|
||||
HDISP : constant := 121;
|
||||
UADD : constant := 122;
|
||||
MKPOS : constant := 123;
|
||||
IMAGE : constant := 124;
|
||||
VALUE : constant := 125;
|
||||
|
||||
end ACODES;
|
||||
|
||||
|
||||
BIN
Artek Ada v125/ADA.ALB
Normal file
BIN
Artek Ada v125/ADA.ALB
Normal file
Binary file not shown.
BIN
Artek Ada v125/ADA.EXE
Normal file
BIN
Artek Ada v125/ADA.EXE
Normal file
Binary file not shown.
BIN
Artek Ada v125/ADAERR.MSG
Normal file
BIN
Artek Ada v125/ADAERR.MSG
Normal file
Binary file not shown.
BIN
Artek Ada v125/AE.EXE
Normal file
BIN
Artek Ada v125/AE.EXE
Normal file
Binary file not shown.
BIN
Artek Ada v125/AI.EXE
Normal file
BIN
Artek Ada v125/AI.EXE
Normal file
Binary file not shown.
BIN
Artek Ada v125/APSE.EXE
Normal file
BIN
Artek Ada v125/APSE.EXE
Normal file
Binary file not shown.
BIN
Artek Ada v125/AR-LARGE.SYS
Normal file
BIN
Artek Ada v125/AR-LARGE.SYS
Normal file
Binary file not shown.
BIN
Artek Ada v125/AR-SMALL.SYS
Normal file
BIN
Artek Ada v125/AR-SMALL.SYS
Normal file
Binary file not shown.
BIN
Artek Ada v125/ARF.EXE
Normal file
BIN
Artek Ada v125/ARF.EXE
Normal file
Binary file not shown.
9
Artek Ada v125/CA.BAT
Normal file
9
Artek Ada v125/CA.BAT
Normal file
@ -0,0 +1,9 @@
|
||||
ada %1%2
|
||||
if errorlevel 4 goto error
|
||||
linklib %1
|
||||
rem Compilation successful
|
||||
goto end
|
||||
:error
|
||||
rem Errors were found
|
||||
:end
|
||||
|
||||
233
Artek Ada v125/CALENDAR.ADA
Normal file
233
Artek Ada v125/CALENDAR.ADA
Normal file
@ -0,0 +1,233 @@
|
||||
|
||||
package CALENDAR is
|
||||
|
||||
type TIME is private;
|
||||
|
||||
subtype DURATION is FLOAT; -- Nonstandard
|
||||
|
||||
subtype YEAR_NUMBER is INTEGER range 1901 .. 2099;
|
||||
subtype MONTH_NUMBER is INTEGER range 1 .. 12;
|
||||
subtype DAY_NUMBER is INTEGER range 1 .. 31;
|
||||
|
||||
subtype DAY_DURATION is DURATION range 0.0 .. 86_400.0;
|
||||
|
||||
function CLOCK return TIME;
|
||||
function YEAR (DATE : TIME) return YEAR_NUMBER;
|
||||
function MONTH (DATE : TIME) return MONTH_NUMBER;
|
||||
function DAY (DATE : TIME) return DAY_NUMBER;
|
||||
function SECONDS (DATE : TIME) return DAY_DURATION;
|
||||
|
||||
procedure SPLIT (DATE : in TIME;
|
||||
YEAR : out YEAR_NUMBER;
|
||||
MONTH : out MONTH_NUMBER;
|
||||
DAY : out DAY_NUMBER;
|
||||
SECONDS : out DAY_DURATION);
|
||||
|
||||
function TIME_OF (YEAR : YEAR_NUMBER;
|
||||
MONTH : MONTH_NUMBER;
|
||||
DAY : DAY_NUMBER;
|
||||
SECONDS : DAY_DURATION := 0.0) return TIME;
|
||||
|
||||
function "+" (LEFT : TIME; RIGHT : DURATION) return TIME;
|
||||
function "+" (LEFT : DURATION; RIGHT : TIME) return TIME;
|
||||
function "-" (LEFT : TIME; RIGHT : DURATION) return TIME;
|
||||
function "-" (LEFT : TIME; RIGHT : TIME) return DURATION;
|
||||
|
||||
function "<" (LEFT, RIGHT : TIME) return BOOLEAN;
|
||||
function "<=" (LEFT, RIGHT : TIME) return BOOLEAN;
|
||||
function ">" (LEFT, RIGHT : TIME) return BOOLEAN;
|
||||
function ">=" (LEFT, RIGHT : TIME) return BOOLEAN;
|
||||
|
||||
TIME_ERROR : exception;
|
||||
|
||||
private
|
||||
|
||||
type TIME is
|
||||
record
|
||||
YEAR_FIELD : YEAR_NUMBER;
|
||||
MONTH_FIELD : MONTH_NUMBER;
|
||||
DAY_FIELD : DAY_NUMBER;
|
||||
SEC_FIELD : DAY_DURATION;
|
||||
end record;
|
||||
|
||||
end;
|
||||
|
||||
with DOS_INTERFACE; use DOS_INTERFACE;
|
||||
|
||||
package body CALENDAR is
|
||||
|
||||
type MONTH_ARRAY is array (MONTH_NUMBER) of DAY_NUMBER;
|
||||
DAYS_IN_MONTH : constant MONTH_ARRAY :=
|
||||
(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
|
||||
FEBRUARY : constant MONTH_NUMBER := 2;
|
||||
DAYS_IN_FEB_WHEN_LEAP : constant DAY_NUMBER := 29;
|
||||
|
||||
function IS_LEAP_YEAR (YEAR : YEAR_NUMBER) return BOOLEAN is
|
||||
begin
|
||||
return (YEAR rem 4) = 0; -- 2000 is a leap year
|
||||
end IS_LEAP_YEAR;
|
||||
|
||||
function CLOCK return TIME is
|
||||
HOUR_DURATION : constant DURATION := 3600.0; -- 1 hour in seconds
|
||||
MINUTE_DURATION : constant DURATION := 60.0; -- 1 minute in seconds
|
||||
SECOND_DURATION : constant DURATION := 1.0; -- 1 second
|
||||
HUNDREDTH_DURATION : constant DURATION := 0.01; -- 1/100 second
|
||||
R : REG_8086;
|
||||
T : TIME;
|
||||
begin
|
||||
R . AX := 16#2A00#; -- Get date from DOS
|
||||
CALL_DOS (R);
|
||||
T . YEAR_FIELD := YEAR_NUMBER (R . CX); -- CX contains year
|
||||
T . MONTH_FIELD := MONTH_NUMBER (R . DX / 256); -- DH contains month
|
||||
T . DAY_FIELD := DAY_NUMBER (R . DX rem 256); -- DL contains day
|
||||
R . AX := 16#2C00#; -- Get time from DOS
|
||||
CALL_DOS (R);
|
||||
T . SEC_FIELD :=
|
||||
HOUR_DURATION * FLOAT (R . CX / 256) -- CH contains hour
|
||||
+ MINUTE_DURATION * FLOAT (R . CX rem 256) -- CL contains minute
|
||||
+ SECOND_DURATION * FLOAT (R . DX / 256) -- DH contains second
|
||||
+ HUNDREDTH_DURATION * FLOAT (R . DX rem 256); -- DL contains hundredth
|
||||
return T;
|
||||
end CLOCK;
|
||||
|
||||
function YEAR (DATE : TIME) return YEAR_NUMBER is
|
||||
begin
|
||||
return DATE . YEAR_FIELD;
|
||||
end YEAR;
|
||||
|
||||
function MONTH (DATE : TIME) return MONTH_NUMBER is
|
||||
begin
|
||||
return DATE . MONTH_FIELD;
|
||||
end MONTH;
|
||||
|
||||
function DAY (DATE : TIME) return DAY_NUMBER is
|
||||
begin
|
||||
return DATE . DAY_FIELD;
|
||||
end DAY;
|
||||
|
||||
function SECONDS (DATE : TIME) return DAY_DURATION is
|
||||
begin
|
||||
return DATE . SEC_FIELD;
|
||||
end SECONDS;
|
||||
|
||||
procedure SPLIT (DATE : in TIME;
|
||||
YEAR : out YEAR_NUMBER;
|
||||
MONTH : out MONTH_NUMBER;
|
||||
DAY : out DAY_NUMBER;
|
||||
SECONDS : out DAY_DURATION) is
|
||||
begin
|
||||
YEAR := DATE . YEAR_FIELD;
|
||||
MONTH := DATE . MONTH_FIELD;
|
||||
DAY := DATE . DAY_FIELD;
|
||||
SECONDS := DATE . SEC_FIELD;
|
||||
end SPLIT;
|
||||
|
||||
function TIME_OF (YEAR : YEAR_NUMBER;
|
||||
MONTH : MONTH_NUMBER;
|
||||
DAY : DAY_NUMBER;
|
||||
SECONDS : DAY_DURATION := 0.0) return TIME is
|
||||
|
||||
function DAYS_IN (YEAR : in YEAR_NUMBER; MONTH : in MONTH_NUMBER)
|
||||
return DAY_NUMBER is
|
||||
begin
|
||||
if IS_LEAP_YEAR (YEAR) and MONTH = FEBRUARY then
|
||||
return DAYS_IN_FEB_WHEN_LEAP;
|
||||
else
|
||||
return DAYS_IN_MONTH (MONTH);
|
||||
end if;
|
||||
end DAYS_IN;
|
||||
|
||||
begin
|
||||
if DAY > DAYS_IN (YEAR, MONTH) then
|
||||
raise TIME_ERROR;
|
||||
else
|
||||
return TIME'(YEAR, MONTH, DAY, SECONDS);
|
||||
end if;
|
||||
end TIME_OF;
|
||||
|
||||
function "+" (LEFT : TIME; RIGHT : DURATION) return TIME is
|
||||
begin
|
||||
return LEFT;
|
||||
end "+";
|
||||
|
||||
function "+" (LEFT : DURATION; RIGHT : TIME) return TIME is
|
||||
begin
|
||||
return RIGHT;
|
||||
end "+";
|
||||
|
||||
function "-" (LEFT : TIME; RIGHT : DURATION) return TIME is
|
||||
begin
|
||||
return LEFT;
|
||||
end "-";
|
||||
|
||||
function "-" (LEFT : TIME; RIGHT : TIME) return DURATION is
|
||||
begin
|
||||
return 0.0;
|
||||
end "-";
|
||||
|
||||
function "<" (LEFT, RIGHT : TIME) return BOOLEAN is
|
||||
begin
|
||||
if LEFT . YEAR_FIELD = RIGHT . YEAR_FIELD then
|
||||
if LEFT . MONTH_FIELD = RIGHT . MONTH_FIELD then
|
||||
if LEFT . DAY_FIELD = RIGHT . DAY_FIELD then
|
||||
return LEFT . SEC_FIELD < RIGHT . SEC_FIELD;
|
||||
else
|
||||
return LEFT . DAY_FIELD < RIGHT . DAY_FIELD;
|
||||
end if;
|
||||
else
|
||||
return LEFT . MONTH_FIELD < RIGHT . MONTH_FIELD;
|
||||
end if;
|
||||
end if;
|
||||
return LEFT . YEAR_FIELD < RIGHT . YEAR_FIELD;
|
||||
end "<";
|
||||
|
||||
function "<=" (LEFT, RIGHT : TIME) return BOOLEAN is
|
||||
begin
|
||||
if LEFT . YEAR_FIELD = RIGHT . YEAR_FIELD then
|
||||
if LEFT . MONTH_FIELD = RIGHT . MONTH_FIELD then
|
||||
if LEFT . DAY_FIELD = RIGHT . DAY_FIELD then
|
||||
return LEFT . SEC_FIELD <= RIGHT . SEC_FIELD;
|
||||
else
|
||||
return LEFT . DAY_FIELD < RIGHT . DAY_FIELD;
|
||||
end if;
|
||||
else
|
||||
return LEFT . MONTH_FIELD < RIGHT . MONTH_FIELD;
|
||||
end if;
|
||||
end if;
|
||||
return LEFT . YEAR_FIELD < RIGHT . YEAR_FIELD;
|
||||
end "<=";
|
||||
|
||||
function ">" (LEFT, RIGHT : TIME) return BOOLEAN is
|
||||
begin
|
||||
if LEFT . YEAR_FIELD = RIGHT . YEAR_FIELD then
|
||||
if LEFT . MONTH_FIELD = RIGHT . MONTH_FIELD then
|
||||
if LEFT . DAY_FIELD = RIGHT . DAY_FIELD then
|
||||
return LEFT . SEC_FIELD > RIGHT . SEC_FIELD;
|
||||
else
|
||||
return LEFT . DAY_FIELD > RIGHT . DAY_FIELD;
|
||||
end if;
|
||||
else
|
||||
return LEFT . MONTH_FIELD > RIGHT . MONTH_FIELD;
|
||||
end if;
|
||||
end if;
|
||||
return LEFT . YEAR_FIELD > RIGHT . YEAR_FIELD;
|
||||
end ">";
|
||||
|
||||
function ">=" (LEFT, RIGHT : TIME) return BOOLEAN is
|
||||
begin
|
||||
if LEFT . YEAR_FIELD = RIGHT . YEAR_FIELD then
|
||||
if LEFT . MONTH_FIELD = RIGHT . MONTH_FIELD then
|
||||
if LEFT . DAY_FIELD = RIGHT . DAY_FIELD then
|
||||
return LEFT . SEC_FIELD >= RIGHT . SEC_FIELD;
|
||||
else
|
||||
return LEFT . DAY_FIELD > RIGHT . DAY_FIELD;
|
||||
end if;
|
||||
else
|
||||
return LEFT . MONTH_FIELD > RIGHT . MONTH_FIELD;
|
||||
end if;
|
||||
end if;
|
||||
return LEFT . YEAR_FIELD > RIGHT . YEAR_FIELD;
|
||||
end ">=";
|
||||
|
||||
end CALENDAR;
|
||||
|
||||
54
Artek Ada v125/CALL_DOS.ASM
Normal file
54
Artek Ada v125/CALL_DOS.ASM
Normal file
@ -0,0 +1,54 @@
|
||||
;
|
||||
; CALL_DOS.ASM
|
||||
;
|
||||
; A program to call DOS from Artek Ada
|
||||
; (C) 1985, 86, 87 Artek Corporation
|
||||
;
|
||||
; Author : V. Thorsteinsson
|
||||
;
|
||||
; As per the Artek Calling Convention rev. 2,
|
||||
; SI points to parameters and DI points to local
|
||||
; variables at entry. BP must not be modified.
|
||||
; SS, ES, and DS all point to the data segment
|
||||
; and must be preserved.
|
||||
; The frames of statically enclosing subprograms
|
||||
; cannot be accessed. Static data also cannot
|
||||
; be accessed.
|
||||
;
|
||||
CGROUP GROUP CODE
|
||||
CODE SEGMENT 'CODE'
|
||||
ASSUME CS:CGROUP, DS:NOTHING, ES:NOTHING
|
||||
;
|
||||
DOSCALL PROC FAR
|
||||
MOV BX, [SI] ; Load the address of REGS (parameter)
|
||||
PUSH BP
|
||||
PUSH ES
|
||||
PUSH BX
|
||||
MOV AX, [BX]
|
||||
MOV CX, [BX+4]
|
||||
MOV DX, [BX+6]
|
||||
MOV SI, [BX+8]
|
||||
LES DI, [BX+10]
|
||||
MOV BX, [BX+2]
|
||||
INT 21h
|
||||
MOV BP, BX
|
||||
POP BX
|
||||
MOV [BX], AX
|
||||
MOV [BX+2], BP
|
||||
MOV [BX+4], CX
|
||||
MOV [BX+6], DX
|
||||
MOV [BX+8], SI
|
||||
MOV [BX+10], DI
|
||||
MOV [BX+12], ES
|
||||
PUSHF
|
||||
POP AX
|
||||
MOV [BX+14], AX ; Set flags
|
||||
POP ES
|
||||
POP BP
|
||||
DOSCALL ENDP
|
||||
;
|
||||
CODE ENDS
|
||||
|
||||
END DOSCALL
|
||||
|
||||
|
||||
3
Artek Ada v125/CALL_DOS.BIN
Normal file
3
Artek Ada v125/CALL_DOS.BIN
Normal file
@ -0,0 +1,3 @@
|
||||
‹ US‹‹O‹W‹wÄ
|
||||
‹_Í!‹ë[‰‰o‰O‰W‰w‰
|
||||
ŚG śX‰G]
|
||||
246
Artek Ada v125/CONIO.ADA
Normal file
246
Artek Ada v125/CONIO.ADA
Normal file
@ -0,0 +1,246 @@
|
||||
--
|
||||
-- CONIO.ADA
|
||||
--
|
||||
-- Console input/output package for Artek Ada
|
||||
-- (Revision 1.1)
|
||||
--
|
||||
-- Copyright (C) 1986, 1987 Artek Corporation
|
||||
--
|
||||
-- Conio contains screen manipulation routines
|
||||
-- using ANSI standard cursor sequences.
|
||||
-- The package requires ANSI.SYS or a similar
|
||||
-- device driver to be installed.
|
||||
-- To install ANSI.SYS, insert this line in the
|
||||
-- CONFIG.SYS file on the root directory:
|
||||
--
|
||||
-- DEVICE=ANSI.SYS
|
||||
--
|
||||
|
||||
package CON_IO is
|
||||
|
||||
-- IBM PC specific constants
|
||||
|
||||
X_SIZE : constant := 80;
|
||||
Y_SIZE : constant := 24;
|
||||
NUM_COLORS : constant := 8;
|
||||
|
||||
subtype X_COORDINATE is INTEGER range 0 .. X_SIZE - 1;
|
||||
subtype Y_COORDINATE is INTEGER range 0 .. Y_SIZE - 1;
|
||||
subtype COLOR_NUMBER is INTEGER range 0 .. NUM_COLORS - 1;
|
||||
|
||||
procedure CLS;
|
||||
procedure CURSOR (X : in X_COORDINATE; Y : in Y_COORDINATE);
|
||||
procedure CURSOR_UP (LINES : in POSITIVE := 1);
|
||||
procedure CURSOR_DOWN (LINES : in POSITIVE := 1);
|
||||
procedure CURSOR_LEFT (COLUMNS : in POSITIVE := 1);
|
||||
procedure CURSOR_RIGHT (COLUMNS : in POSITIVE := 1);
|
||||
procedure COLOR (C : in COLOR_NUMBER);
|
||||
procedure BACKGROUND (C : in COLOR_NUMBER);
|
||||
procedure REV_VIDEO;
|
||||
procedure INTENSITY;
|
||||
procedure UNDERLINE;
|
||||
procedure BLINK;
|
||||
procedure ALL_OFF;
|
||||
procedure GET (S : in out STRING);
|
||||
procedure GET (C : in out CHARACTER);
|
||||
procedure PUT (S : in STRING);
|
||||
procedure PUT (C : in CHARACTER);
|
||||
procedure PUT_LINE (S : in STRING);
|
||||
procedure PUT_LINE (C : in CHARACTER);
|
||||
procedure BOX (
|
||||
X_UPPER : in X_COORDINATE; Y_UPPER : in Y_COORDINATE;
|
||||
X_LOWER : in X_COORDINATE; Y_LOWER : in Y_COORDINATE;
|
||||
DOUBLE : in BOOLEAN := FALSE);
|
||||
|
||||
end;
|
||||
|
||||
with QPUT, QGET;
|
||||
|
||||
package body CON_IO is
|
||||
|
||||
use ASCII;
|
||||
|
||||
procedure CLS is
|
||||
begin
|
||||
QPUT (ESC & "[2J");
|
||||
end CLS;
|
||||
|
||||
function BUTFIRST (S : in STRING) return STRING is
|
||||
-- Used to cut the initial space from INTEGER'IMAGE
|
||||
begin
|
||||
return S (2..S'LAST);
|
||||
end BUTFIRST;
|
||||
|
||||
procedure CURSOR (X : in X_COORDINATE; Y : in Y_COORDINATE) is
|
||||
begin
|
||||
QPUT (ESC & '[' & BUTFIRST (INTEGER'IMAGE (Y + 1)) & ';' &
|
||||
BUTFIRST (INTEGER'IMAGE (X + 1)) & 'H');
|
||||
end CURSOR;
|
||||
|
||||
procedure CURSOR_UP (LINES : in POSITIVE := 1) is
|
||||
begin
|
||||
QPUT (ESC & '[' & BUTFIRST (INTEGER'IMAGE (LINES)) & 'A');
|
||||
end CURSOR_UP;
|
||||
|
||||
procedure CURSOR_DOWN (LINES : in POSITIVE := 1) is
|
||||
begin
|
||||
QPUT (ESC & '[' & BUTFIRST (INTEGER'IMAGE (LINES)) & 'B');
|
||||
end CURSOR_DOWN;
|
||||
|
||||
procedure CURSOR_RIGHT (COLUMNS : in POSITIVE := 1) is
|
||||
begin
|
||||
QPUT (ESC & '[' & BUTFIRST (INTEGER'IMAGE (COLUMNS)) & 'C');
|
||||
end CURSOR_RIGHT;
|
||||
|
||||
procedure CURSOR_LEFT (COLUMNS : in POSITIVE := 1) is
|
||||
begin
|
||||
QPUT (ESC & '[' & BUTFIRST (INTEGER'IMAGE (COLUMNS)) & 'D');
|
||||
end CURSOR_LEFT;
|
||||
|
||||
procedure REV_VIDEO is
|
||||
begin
|
||||
QPUT (ESC & "[7m");
|
||||
end REV_VIDEO;
|
||||
|
||||
procedure INTENSITY is
|
||||
begin
|
||||
QPUT (ESC & "[1m");
|
||||
end INTENSITY;
|
||||
|
||||
procedure UNDERLINE is
|
||||
begin
|
||||
QPUT (ESC & "[4m");
|
||||
end UNDERLINE;
|
||||
|
||||
procedure BLINK is
|
||||
begin
|
||||
QPUT (ESC & "[5m");
|
||||
end BLINK;
|
||||
|
||||
procedure ALL_OFF is
|
||||
begin
|
||||
QPUT (ESC & "[0m");
|
||||
end ALL_OFF;
|
||||
|
||||
procedure COLOR (C : in COLOR_NUMBER) is
|
||||
|
||||
begin
|
||||
QPUT (ESC & '[' & BUTFIRST (INTEGER'IMAGE (C + 30)) & 'm');
|
||||
end COLOR;
|
||||
|
||||
procedure BACKGROUND (C : in COLOR_NUMBER) is
|
||||
|
||||
begin
|
||||
QPUT (ESC & '[' & BUTFIRST (INTEGER'IMAGE (C + 40)) & 'm');
|
||||
end BACKGROUND;
|
||||
|
||||
procedure GET (S : in out STRING) is
|
||||
-- This procedure gets a string from the console.
|
||||
-- Backspacing is allowed.
|
||||
-- The value in the parameter S is used to initialize the
|
||||
-- field and is written to the screen before input takes place.
|
||||
|
||||
PLACE : INTEGER := S'FIRST;
|
||||
C : CHARACTER;
|
||||
|
||||
begin
|
||||
QPUT (S);
|
||||
CURSOR_LEFT (S'LENGTH);
|
||||
loop
|
||||
QGET (C);
|
||||
case C is
|
||||
when CR => -- End entry by hitting ENTER key
|
||||
exit;
|
||||
when BS | DEL => -- Erase last character entered
|
||||
if PLACE > S'FIRST then
|
||||
PLACE := PLACE - 1;
|
||||
CURSOR_LEFT;
|
||||
S (PLACE) := ' ';
|
||||
QPUT (" ");
|
||||
CURSOR_LEFT;
|
||||
end if;
|
||||
when NUL => -- "Swallow" IBM extended ASCII code
|
||||
QGET (C);
|
||||
when HT | LF | ESC => -- Ignore control characters
|
||||
null;
|
||||
when others => -- Allow any other character to be entered
|
||||
S (PLACE) := C;
|
||||
QPUT (C & ""); -- This converts C into a STRING
|
||||
if PLACE < S'LAST then
|
||||
PLACE := PLACE + 1;
|
||||
else
|
||||
CURSOR_LEFT;
|
||||
end if;
|
||||
end case;
|
||||
end loop;
|
||||
end GET;
|
||||
|
||||
procedure GET (C : in out CHARACTER) is
|
||||
S : STRING (1..1) := (1 => C);
|
||||
begin
|
||||
GET (S);
|
||||
C := S (1);
|
||||
end GET;
|
||||
|
||||
procedure PUT (S : in STRING) is
|
||||
begin
|
||||
QPUT (S);
|
||||
end PUT;
|
||||
|
||||
procedure PUT (C : in CHARACTER) is
|
||||
S : STRING (1..1) := (1 => C);
|
||||
begin
|
||||
QPUT (S);
|
||||
end PUT;
|
||||
|
||||
procedure PUT_LINE (S : in STRING) is
|
||||
CRLF : STRING (1..2) := (CR, LF);
|
||||
begin
|
||||
QPUT (S & CRLF);
|
||||
end PUT_LINE;
|
||||
|
||||
procedure PUT_LINE (C : in CHARACTER) is
|
||||
S : STRING (1..3) := (C, CR, LF);
|
||||
begin
|
||||
QPUT (S);
|
||||
end PUT_LINE;
|
||||
|
||||
procedure BOX (
|
||||
X_UPPER : in X_COORDINATE; Y_UPPER : in Y_COORDINATE;
|
||||
X_LOWER : in X_COORDINATE; Y_LOWER : in Y_COORDINATE;
|
||||
DOUBLE : in BOOLEAN := FALSE) is
|
||||
|
||||
HORIZONTAL_LINE : CHARACTER := CHARACTER'VAL (196);
|
||||
UPPER_LEFT_CORNER : CHARACTER := CHARACTER'VAL (218);
|
||||
UPPER_RIGHT_CORNER : CHARACTER := CHARACTER'VAL (191);
|
||||
VERTICAL_LINE : CHARACTER := CHARACTER'VAL (179);
|
||||
LOWER_LEFT_CORNER : CHARACTER := CHARACTER'VAL (192);
|
||||
LOWER_RIGHT_CORNER : CHARACTER := CHARACTER'VAL (217);
|
||||
|
||||
begin
|
||||
if X_UPPER >= X_LOWER or Y_UPPER >= Y_LOWER then
|
||||
raise CONSTRAINT_ERROR;
|
||||
end if;
|
||||
if DOUBLE then
|
||||
null;
|
||||
end if;
|
||||
declare
|
||||
NORMAL_HORIZON : STRING (1..X_LOWER - X_UPPER - 1) :=
|
||||
(others => HORIZONTAL_LINE);
|
||||
begin
|
||||
CURSOR (X_UPPER, Y_UPPER);
|
||||
PUT (UPPER_LEFT_CORNER & NORMAL_HORIZON & UPPER_RIGHT_CORNER);
|
||||
for I in Y_UPPER + 1 .. Y_LOWER - 1 loop
|
||||
CURSOR (X_UPPER, I);
|
||||
PUT (VERTICAL_LINE);
|
||||
CURSOR_RIGHT (X_LOWER - X_UPPER - 1);
|
||||
PUT (VERTICAL_LINE);
|
||||
end loop;
|
||||
CURSOR (X_UPPER, Y_LOWER);
|
||||
PUT (LOWER_LEFT_CORNER & NORMAL_HORIZON & LOWER_RIGHT_CORNER);
|
||||
end;
|
||||
end;
|
||||
|
||||
end;
|
||||
|
||||
|
||||
BIN
Artek Ada v125/DAC.EXE
Normal file
BIN
Artek Ada v125/DAC.EXE
Normal file
Binary file not shown.
448
Artek Ada v125/DIRIOB.ADA
Normal file
448
Artek Ada v125/DIRIOB.ADA
Normal file
@ -0,0 +1,448 @@
|
||||
--
|
||||
-- D I R E C T I N P U T / O U T P U T
|
||||
--
|
||||
-- Body of the Package Direct_IO
|
||||
--
|
||||
-- According to ANSI/MIL-STD 1815A (1983)
|
||||
-- Implemented for Artek Ada
|
||||
--
|
||||
-- Copyright (C) 1986 Artek Corporation
|
||||
-- Author : O. Karlsson
|
||||
--
|
||||
--
|
||||
-- Version: 1.01
|
||||
-- Date last modified: 1986-05-01
|
||||
--
|
||||
|
||||
with DOS_INTERFACE, SYSTEM, LONG_OPERATIONS;
|
||||
|
||||
package body DIRECT_IO is
|
||||
|
||||
use DOS_INTERFACE, SYSTEM, ASCII, LONG_OPERATIONS;
|
||||
|
||||
-- Data types and objects
|
||||
|
||||
EOF : constant CHARACTER := CHARACTER (26);
|
||||
|
||||
R : REG_8086;
|
||||
|
||||
--
|
||||
-- Utility procedure to skip last character read from a file
|
||||
-- Same as " lseek (file, -1) " relative from the file position
|
||||
--
|
||||
|
||||
procedure UNGET (FILE : in FILE_TYPE) is
|
||||
|
||||
begin
|
||||
-- This procedure is only used internally and
|
||||
-- the file is always open
|
||||
R . AX := 16#4201#; -- DOS function 42, lseek
|
||||
R . BX := WORD (FILE . HANDLE);
|
||||
R . CX := -1; -- Desired location from current position
|
||||
R . DX := -1;
|
||||
CALL_DOS (R);
|
||||
if abs R . FLAGS mod 2 = 1 then -- Carry was set
|
||||
raise USE_ERROR; -- There should never be error here
|
||||
end if;
|
||||
end UNGET;
|
||||
|
||||
--
|
||||
-- File management
|
||||
--
|
||||
|
||||
procedure CREATE (
|
||||
FILE : in out FILE_TYPE;
|
||||
MODE : in FILE_MODE := INOUT_FILE;
|
||||
NAME : in STRING := "";
|
||||
FORM : in STRING := "") is
|
||||
|
||||
ASCIIZ_NAME : FILE_NAME_STRING;
|
||||
BLANK_NAME : FILE_NAME_STRING := (others => ' ');
|
||||
BLANK_FORM : FORM_NAME_STRING := (others => ' ');
|
||||
|
||||
-- See chapter 14.2.1
|
||||
|
||||
begin -- Concatenate a null character
|
||||
if FILE /= null then
|
||||
raise STATUS_ERROR;
|
||||
end if;
|
||||
ASCIIZ_NAME (1..NAME'LENGTH) := NAME;
|
||||
ASCIIZ_NAME (NAME'LENGTH + 1) := NUL;
|
||||
R . AX := 16#3C00#; -- Function 3C, Create a file
|
||||
R . DX := WORD (ASCIIZ_NAME'ADDRESS); -- Address of the filename
|
||||
R . CX := 16#0000#; -- No attributes
|
||||
CALL_DOS (R);
|
||||
if abs R . FLAGS mod 2 = 1 then -- Carry was set
|
||||
if R . AX > 3 then -- 4 = Too many open files, 5 = access denied
|
||||
raise USE_ERROR;
|
||||
else
|
||||
raise NAME_ERROR; -- 3 = Path not found
|
||||
end if;
|
||||
end if;
|
||||
FILE := new FILE_DESCR'
|
||||
(NAMELEN => NAME'LENGTH, NAME => BLANK_NAME,
|
||||
FORMLEN => FORM'LENGTH, FORM => BLANK_FORM,
|
||||
MODE => MODE, INDEX => 1,
|
||||
HANDLE => INTEGER (R . AX)); -- AX contains the file handle after call 3C
|
||||
FILE . NAME (1..NAME'LENGTH) := NAME;
|
||||
FILE . FORM (1..FORM'LENGTH) := FORM;
|
||||
end CREATE;
|
||||
|
||||
procedure OPEN (
|
||||
FILE : in out FILE_TYPE;
|
||||
MODE : in FILE_MODE;
|
||||
NAME : in STRING;
|
||||
FORM : in STRING := "") is
|
||||
|
||||
ASCIIZ_NAME : FILE_NAME_STRING;
|
||||
BLANK_NAME : FILE_NAME_STRING := (others => ' ');
|
||||
BLANK_FORM : FORM_NAME_STRING := (others => ' ');
|
||||
|
||||
-- See chapter 14.2.1
|
||||
|
||||
begin
|
||||
if FILE /= null then
|
||||
raise STATUS_ERROR;
|
||||
end if;
|
||||
ASCIIZ_NAME (1..NAME'LENGTH) := NAME;
|
||||
ASCIIZ_NAME (NAME'LENGTH + 1) := NUL;
|
||||
case MODE is
|
||||
when IN_FILE => R . AX := 16#3D00#; -- AH = 3D, Open a file
|
||||
when OUT_FILE => R . AX := 16#3D01#; -- AL = 00, Open for input
|
||||
when INOUT_FILE => R . AX := 16#3D02#; -- AL = 01, Open for output
|
||||
end case; -- AL = 02, Open for in- or out
|
||||
R . DX := WORD (ASCIIZ_NAME'ADDRESS);
|
||||
CALL_DOS (R);
|
||||
if abs R . FLAGS mod 2 = 1 then -- Carry was set
|
||||
if R . AX > 3 then
|
||||
raise USE_ERROR; -- Access denied and to many files open
|
||||
else
|
||||
raise NAME_ERROR; -- File not found
|
||||
end if;
|
||||
end if;
|
||||
FILE := new FILE_DESCR'
|
||||
(NAMELEN => NAME'LENGTH, NAME => BLANK_NAME,
|
||||
FORMLEN => FORM'LENGTH, FORM => BLANK_FORM,
|
||||
MODE => MODE, INDEX => 1,
|
||||
HANDLE => INTEGER (R . AX)); -- AX contains the file handle
|
||||
FILE . NAME (1..NAME'LENGTH) := NAME;
|
||||
FILE . FORM (1..FORM'LENGTH) := FORM;
|
||||
end OPEN;
|
||||
|
||||
procedure CLOSE (FILE : in out FILE_TYPE) is
|
||||
|
||||
-- See chapter 14.2.1
|
||||
|
||||
begin
|
||||
if FILE = null then
|
||||
raise STATUS_ERROR;
|
||||
end if;
|
||||
R . AX := 16#3E00#; -- DOS function 3E, Close a file handle
|
||||
R . BX := WORD (FILE . HANDLE);
|
||||
CALL_DOS (R);
|
||||
if abs R . FLAGS mod 2 = 1 then -- Carry was set
|
||||
raise USE_ERROR; -- Invalid handle. This error should never
|
||||
end if; -- occur. Something is wrong in the file system.
|
||||
FILE := null;
|
||||
end CLOSE;
|
||||
|
||||
procedure DELETE (FILE : in out FILE_TYPE) is
|
||||
|
||||
ASCIIZ_NAME : FILE_NAME_STRING;
|
||||
|
||||
-- See chapter 14.2.1
|
||||
|
||||
begin
|
||||
ASCIIZ_NAME (1..FILE . NAMELEN) := FILE . NAME (1..FILE . NAMELEN);
|
||||
ASCIIZ_NAME (FILE . NAMELEN + 1) := NUL;
|
||||
CLOSE (FILE);
|
||||
R . AX := 16#4100#; -- DOS function 41, delete a file
|
||||
R . DX := WORD (ASCIIZ_NAME'ADDRESS);
|
||||
CALL_DOS (R);
|
||||
if abs R . FLAGS mod 2 = 1 then -- Carry was set
|
||||
raise USE_ERROR; -- Access denied
|
||||
end if;
|
||||
end DELETE;
|
||||
|
||||
procedure RESET (FILE : in out FILE_TYPE; MODE : in FILE_MODE) is
|
||||
|
||||
-- See chapter 14.2.1
|
||||
|
||||
NAME : FILE_NAME_STRING;
|
||||
FORM : FORM_NAME_STRING;
|
||||
NAMELEN : NAME_INDEX;
|
||||
FORMLEN : FORM_INDEX;
|
||||
|
||||
begin
|
||||
if FILE = null then
|
||||
raise STATUS_ERROR;
|
||||
end if;
|
||||
if FILE . MODE = MODE then
|
||||
RESET (FILE);
|
||||
else
|
||||
NAME := FILE . NAME;
|
||||
FORM := FILE . FORM;
|
||||
NAMELEN := FILE . NAMELEN;
|
||||
FORMLEN := FILE . FORMLEN;
|
||||
CLOSE (FILE); -- Must close and reopen since MODE changes
|
||||
OPEN (FILE, MODE, NAME (1 .. NAMELEN), FORM (1..FORMLEN));
|
||||
end if;
|
||||
end RESET;
|
||||
|
||||
procedure RESET (FILE : in out FILE_TYPE) is
|
||||
|
||||
-- See chapter 14.2.1
|
||||
|
||||
begin
|
||||
if FILE = null then
|
||||
raise STATUS_ERROR;
|
||||
end if;
|
||||
-- Do an LSEEK (FILE, 0);
|
||||
R . AX := 16#4200#; -- DOS function 42, lseek
|
||||
R . BX := WORD (FILE . HANDLE);
|
||||
R . CX := 0; -- Desired location from BOF
|
||||
R . DX := 0;
|
||||
CALL_DOS (R);
|
||||
if abs R . FLAGS mod 2 = 1 then -- Carry was set
|
||||
raise USE_ERROR;
|
||||
end if;
|
||||
FILE . INDEX := 1;
|
||||
end RESET;
|
||||
|
||||
function MODE (FILE : in FILE_TYPE) return FILE_MODE is
|
||||
|
||||
-- See chapter 14.2.1
|
||||
|
||||
begin
|
||||
if FILE = null then
|
||||
raise STATUS_ERROR;
|
||||
end if;
|
||||
return FILE . MODE;
|
||||
end MODE;
|
||||
|
||||
function NAME (FILE : in FILE_TYPE) return STRING is
|
||||
|
||||
-- See chapter 14.2.1
|
||||
|
||||
|
||||
begin
|
||||
if FILE = null then
|
||||
raise STATUS_ERROR;
|
||||
end if;
|
||||
return FILE . NAME (1..FILE . NAMELEN);
|
||||
end NAME;
|
||||
|
||||
function FORM (FILE : in FILE_TYPE) return STRING is
|
||||
|
||||
-- See chapter 14.2.1
|
||||
|
||||
begin
|
||||
if FILE = null then
|
||||
raise STATUS_ERROR;
|
||||
end if;
|
||||
return FILE . FORM (1 .. FILE . FORMLEN);
|
||||
end FORM;
|
||||
|
||||
function IS_OPEN (FILE : in FILE_TYPE) return BOOLEAN is
|
||||
|
||||
-- See chapter 14.2.1
|
||||
|
||||
begin
|
||||
return FILE /= null;
|
||||
end IS_OPEN;
|
||||
|
||||
--
|
||||
-- Input and output operations
|
||||
--
|
||||
|
||||
procedure SET_INDEX (FILE : in FILE_TYPE; TO : in POSITIVE_COUNT) is
|
||||
|
||||
BYTE_INDEX : LONG_INTEGER;
|
||||
|
||||
-- See chapter 14.2.4
|
||||
|
||||
begin
|
||||
if FILE = null then
|
||||
raise STATUS_ERROR;
|
||||
end if;
|
||||
R . AX := 16#4200#; -- DOS function 42, lseek
|
||||
R . BX := WORD (FILE . HANDLE);
|
||||
BYTE_INDEX := INTEGER (TO - 1) *
|
||||
INTEGER (ELEMENT_TYPE'SIZE / STORAGE_UNIT);
|
||||
R . CX := WORD (BYTE_INDEX . HIGH); -- Desired location from BOF
|
||||
R . DX := WORD (BYTE_INDEX . LOW);
|
||||
CALL_DOS (R);
|
||||
FILE . INDEX := TO;
|
||||
if abs R . FLAGS mod 2 = 1 then -- Carry was set
|
||||
raise USE_ERROR; -- There should never be error here
|
||||
end if;
|
||||
exception
|
||||
when NUMERIC_ERROR =>
|
||||
raise USE_ERROR;
|
||||
end SET_INDEX;
|
||||
|
||||
procedure FREAD (FILE : in FILE_TYPE; ITEM : out ELEMENT_TYPE) is
|
||||
|
||||
MYITEM : ELEMENT_TYPE;
|
||||
|
||||
begin
|
||||
if FILE = null then
|
||||
raise STATUS_ERROR;
|
||||
elsif FILE . MODE = OUT_FILE then
|
||||
raise MODE_ERROR;
|
||||
end if;
|
||||
R . AX := 16#3F00#; -- DOS function 3F, read from a file or device
|
||||
R . BX := WORD (FILE . HANDLE);
|
||||
R . CX := WORD (ELEMENT_TYPE'SIZE / STORAGE_UNIT);
|
||||
R . DX := WORD (MYITEM'ADDRESS); -- Address of ITEM
|
||||
CALL_DOS (R);
|
||||
if R . AX = 0 then -- Read past EOF
|
||||
raise END_ERROR;
|
||||
end if;
|
||||
if abs R . FLAGS mod 2 = 1 then -- Carry set
|
||||
raise USE_ERROR; -- Access denied or invalid file handle
|
||||
end if;
|
||||
FILE . INDEX := FILE . INDEX + 1;
|
||||
ITEM := MYITEM;
|
||||
end FREAD;
|
||||
|
||||
procedure READ (FILE : in FILE_TYPE;
|
||||
ITEM : out ELEMENT_TYPE;
|
||||
FROM : in POSITIVE_COUNT) is
|
||||
|
||||
-- See chapter 14.2.4
|
||||
|
||||
begin
|
||||
SET_INDEX (FILE, FROM);
|
||||
FREAD (FILE, ITEM);
|
||||
end READ;
|
||||
|
||||
procedure READ (FILE : in FILE_TYPE; ITEM : out ELEMENT_TYPE) is
|
||||
|
||||
-- See chapter 14.2.4
|
||||
|
||||
begin
|
||||
FREAD (FILE, ITEM);
|
||||
end READ;
|
||||
|
||||
procedure FWRITE (FILE : in FILE_TYPE; ITEM : in ELEMENT_TYPE) is
|
||||
|
||||
begin
|
||||
if FILE = null then
|
||||
raise STATUS_ERROR;
|
||||
elsif FILE . MODE = IN_FILE then
|
||||
raise MODE_ERROR;
|
||||
end if;
|
||||
R . AX := 16#4000#; -- DOS function 40, write to a file or device
|
||||
R . BX := WORD (FILE . HANDLE);
|
||||
R . CX := WORD (ELEMENT_TYPE'SIZE / STORAGE_UNIT);
|
||||
R . DX := WORD (ITEM'ADDRESS); -- Address of ITEM
|
||||
CALL_DOS (R);
|
||||
if R . AX = 0 then -- No output made, probably disk full error
|
||||
raise USE_ERROR;
|
||||
end if;
|
||||
if abs R . FLAGS mod 2 = 1 then -- Carry set
|
||||
raise USE_ERROR; -- Access denied or invalid file handle
|
||||
end if;
|
||||
FILE . INDEX := FILE . INDEX + 1;
|
||||
end FWRITE;
|
||||
|
||||
procedure WRITE (FILE : in FILE_TYPE;
|
||||
ITEM : in ELEMENT_TYPE;
|
||||
TO : in POSITIVE_COUNT) is
|
||||
|
||||
-- See chapter 14.2.4
|
||||
|
||||
begin
|
||||
SET_INDEX (FILE, TO);
|
||||
FWRITE (FILE, ITEM);
|
||||
end WRITE;
|
||||
|
||||
procedure WRITE (FILE : in FILE_TYPE; ITEM : in ELEMENT_TYPE) is
|
||||
|
||||
-- See chapter 14.2.4
|
||||
|
||||
begin
|
||||
FWRITE (FILE, ITEM);
|
||||
end WRITE;
|
||||
|
||||
function INDEX (FILE : in FILE_TYPE) return POSITIVE_COUNT is
|
||||
|
||||
-- See chapter 14.2.4
|
||||
|
||||
begin
|
||||
if FILE = null then
|
||||
raise STATUS_ERROR;
|
||||
end if;
|
||||
return FILE . INDEX;
|
||||
end INDEX;
|
||||
|
||||
function SIZE (FILE : in FILE_TYPE) return COUNT is
|
||||
|
||||
BYTE_INDEX : LONG_INTEGER;
|
||||
C : COUNT;
|
||||
|
||||
-- See chapter 14.2.4
|
||||
|
||||
begin
|
||||
if FILE = null then
|
||||
raise STATUS_ERROR;
|
||||
end if;
|
||||
R . AX := 16#4202#; -- DOS function 42, lseek
|
||||
R . BX := WORD (FILE . HANDLE);
|
||||
R . CX := 0; -- Desired location from EOF
|
||||
R . DX := 0;
|
||||
CALL_DOS (R);
|
||||
if abs R . FLAGS mod 2 = 1 then -- Carry was set
|
||||
raise USE_ERROR; -- There should never be error here
|
||||
end if;
|
||||
BYTE_INDEX . HIGH := INTEGER (R . DX);
|
||||
BYTE_INDEX . LOW := INTEGER (R . AX);
|
||||
C := COUNT (BYTE_INDEX / (ELEMENT_TYPE'SIZE / STORAGE_UNIT)); -- Keep the size
|
||||
R . AX := 16#4200#; -- Return to the previous location
|
||||
R . BX := WORD (FILE . HANDLE);
|
||||
BYTE_INDEX := INTEGER (FILE . INDEX - 1) *
|
||||
INTEGER (ELEMENT_TYPE'SIZE / STORAGE_UNIT);
|
||||
R . CX := WORD (BYTE_INDEX . HIGH);
|
||||
R . DX := WORD (BYTE_INDEX . LOW);
|
||||
CALL_DOS (R);
|
||||
if abs R . FLAGS mod 2 = 1 then -- Carry was set
|
||||
raise USE_ERROR; -- There should never be error here
|
||||
end if;
|
||||
return C;
|
||||
exception
|
||||
when NUMERIC_ERROR =>
|
||||
raise USE_ERROR;
|
||||
end SIZE;
|
||||
|
||||
function END_OF_FILE (FILE : in FILE_TYPE) return BOOLEAN is
|
||||
|
||||
CH : CHARACTER;
|
||||
|
||||
-- See chapter 14.2.4
|
||||
|
||||
begin
|
||||
if FILE = null then
|
||||
raise STATUS_ERROR;
|
||||
elsif FILE . MODE = OUT_FILE then
|
||||
raise MODE_ERROR;
|
||||
end if;
|
||||
R . AX := 16#3F00#; -- DOS function 3F, read from a file or device
|
||||
R . BX := WORD (FILE . HANDLE);
|
||||
R . CX := 1; -- Read one byte
|
||||
R . DX := WORD (CH'ADDRESS);
|
||||
CALL_DOS (R);
|
||||
if R . AX = 0 then -- Read past EOF
|
||||
UNGET (FILE);
|
||||
return TRUE;
|
||||
end if;
|
||||
if abs R . FLAGS mod 2 = 1 then -- Carry set
|
||||
raise USE_ERROR; -- Access denied or invalid file handle
|
||||
end if;
|
||||
UNGET (FILE);
|
||||
return CH = EOF;
|
||||
end END_OF_FILE;
|
||||
|
||||
end DIRECT_IO;
|
||||
|
||||
|
||||
99
Artek Ada v125/DIRIOS.ADA
Normal file
99
Artek Ada v125/DIRIOS.ADA
Normal file
@ -0,0 +1,99 @@
|
||||
--
|
||||
-- D I R E C T I N P U T / O U T P U T
|
||||
--
|
||||
-- Specification of the Package Direct_IO
|
||||
--
|
||||
-- Copyright (C) 1986 Artek Corporation
|
||||
--
|
||||
|
||||
with IO_EXCEPTIONS;
|
||||
|
||||
generic
|
||||
|
||||
type ELEMENT_TYPE is private;
|
||||
|
||||
package DIRECT_IO is
|
||||
|
||||
type FILE_TYPE is limited private;
|
||||
|
||||
type FILE_MODE is (IN_FILE, INOUT_FILE, OUT_FILE);
|
||||
type COUNT is range 0 .. INTEGER'LAST;
|
||||
subtype POSITIVE_COUNT is COUNT range 1 .. COUNT'LAST;
|
||||
|
||||
-- File Management
|
||||
|
||||
procedure CREATE (FILE : in out FILE_TYPE;
|
||||
MODE : in FILE_MODE := INOUT_FILE;
|
||||
NAME : in STRING := "";
|
||||
FORM : in STRING := "");
|
||||
|
||||
procedure OPEN (FILE : in out FILE_TYPE;
|
||||
MODE : in FILE_MODE;
|
||||
NAME : in STRING;
|
||||
FORM : in STRING := "");
|
||||
|
||||
procedure CLOSE (FILE : in out FILE_TYPE);
|
||||
procedure DELETE (FILE : in out FILE_TYPE);
|
||||
procedure RESET (FILE : in out FILE_TYPE; MODE : in FILE_MODE);
|
||||
procedure RESET (FILE : in out FILE_TYPE);
|
||||
|
||||
function MODE (FILE : in FILE_TYPE) return FILE_MODE;
|
||||
function NAME (FILE : in FILE_TYPE) return STRING;
|
||||
function FORM (FILE : in FILE_TYPE) return STRING;
|
||||
|
||||
function IS_OPEN (FILE : in FILE_TYPE) return BOOLEAN;
|
||||
|
||||
-- Input and output operations
|
||||
|
||||
procedure READ
|
||||
(FILE : in FILE_TYPE; ITEM : out ELEMENT_TYPE; FROM : POSITIVE_COUNT);
|
||||
procedure READ (FILE : in FILE_TYPE; ITEM : out ELEMENT_TYPE);
|
||||
|
||||
procedure WRITE
|
||||
(FILE : in FILE_TYPE; ITEM : in ELEMENT_TYPE; TO : POSITIVE_COUNT);
|
||||
procedure WRITE (FILE : in FILE_TYPE; ITEM : in ELEMENT_TYPE);
|
||||
|
||||
procedure SET_INDEX (FILE : in FILE_TYPE; TO : in POSITIVE_COUNT);
|
||||
|
||||
function INDEX (FILE : in FILE_TYPE) return POSITIVE_COUNT;
|
||||
function SIZE (FILE : in FILE_TYPE) return COUNT;
|
||||
|
||||
function END_OF_FILE (FILE : in FILE_TYPE) return BOOLEAN;
|
||||
|
||||
-- Exceptions
|
||||
|
||||
STATUS_ERROR : exception renames IO_EXCEPTIONS.STATUS_ERROR;
|
||||
MODE_ERROR : exception renames IO_EXCEPTIONS.MODE_ERROR;
|
||||
NAME_ERROR : exception renames IO_EXCEPTIONS.NAME_ERROR;
|
||||
USE_ERROR : exception renames IO_EXCEPTIONS.USE_ERROR;
|
||||
DEVICE_ERROR : exception renames IO_EXCEPTIONS.DEVICE_ERROR;
|
||||
END_ERROR : exception renames IO_EXCEPTIONS.END_ERROR;
|
||||
DATA_ERROR : exception renames IO_EXCEPTIONS.DATA_ERROR;
|
||||
|
||||
private
|
||||
|
||||
MAX_NAME_LEN : constant := 32; -- Complete name with paths
|
||||
MAX_FORM_LEN : constant := 10; -- The form is not used in MS-DOS
|
||||
|
||||
subtype NAME_INDEX is INTEGER range 0..MAX_NAME_LEN;
|
||||
subtype FORM_INDEX is INTEGER range 0..MAX_FORM_LEN;
|
||||
|
||||
subtype FILE_NAME_STRING is STRING (1..MAX_NAME_LEN);
|
||||
subtype FORM_NAME_STRING is STRING (1..MAX_FORM_LEN);
|
||||
|
||||
type FILE_DESCR is
|
||||
record
|
||||
NAMELEN : NAME_INDEX;
|
||||
NAME : FILE_NAME_STRING;
|
||||
MODE : FILE_MODE;
|
||||
FORMLEN : FORM_INDEX;
|
||||
FORM : FORM_NAME_STRING;
|
||||
INDEX : POSITIVE_COUNT;
|
||||
HANDLE : INTEGER; -- DOS handle number, DOS 2 or later
|
||||
end record;
|
||||
|
||||
type FILE_TYPE is access FILE_DESCR;
|
||||
|
||||
end DIRECT_IO;
|
||||
|
||||
|
||||
194
Artek Ada v125/DOSINT.ADA
Normal file
194
Artek Ada v125/DOSINT.ADA
Normal file
@ -0,0 +1,194 @@
|
||||
--
|
||||
-- DOSINT.ADA
|
||||
--
|
||||
-- MS-DOS and PC-DOS interface package for Artek Ada
|
||||
--
|
||||
-- Copyright (C) 1985, 86, 87 Artek Corporation
|
||||
-- Author: V. Thorsteinsson
|
||||
--
|
||||
-- This package provides a mechanism to call the operating system
|
||||
-- directly from Ada programs. A data type is declared which
|
||||
-- allows the passing of all processor data registers and the
|
||||
-- flags.
|
||||
--
|
||||
-- The package uses the binary file CALL_DOS.BIN, which is assembled
|
||||
-- from CALL_DOS.ASM. This file is included on the Artek Ada Utility
|
||||
-- diskette.
|
||||
--
|
||||
-- To aid the user in writing low-level routines, a few utility
|
||||
-- procedures and functions are included here. They allow reading
|
||||
-- and writing directly from/into memory, reading and writing I/O
|
||||
-- port values, splitting 16-bit registers into halves and more.
|
||||
-- All routines are documented below.
|
||||
--
|
||||
|
||||
package DOS_INTERFACE is
|
||||
|
||||
type WORD is new INTEGER;
|
||||
|
||||
subtype BYTE is WORD range 0..255; -- Note: this is stored in 2 bytes
|
||||
|
||||
type REG_8086 is
|
||||
record
|
||||
AX, BX, CX, DX, SI, DI, ES, FLAGS : WORD;
|
||||
end record;
|
||||
|
||||
procedure CALL_DOS (REGS : in out REG_8086);
|
||||
|
||||
-- The function CALL_DOS uses the REGS structure to fill
|
||||
-- the 8086 registers. It then calls interrupt 21h.
|
||||
-- The registers after exit from DOS are put in the
|
||||
-- REGS structure again.
|
||||
|
||||
function CURRENT_DATA_SEGMENT return WORD;
|
||||
-- This function returns the value of the DS segment register.
|
||||
-- It is provided for convenience when assigning to the ES field
|
||||
-- of the REG_8086 structure in certain DOS calls.
|
||||
|
||||
procedure MERGE_REGISTERS (LO, HI : in BYTE; REG : out WORD);
|
||||
-- Assigns a 16-bit register with two 8-bit register halves.
|
||||
-- Example: MERGE_REGISTERS (16#00#, 16#4C#, REG . AX);
|
||||
-- This will set AX to 16#4C00#.
|
||||
|
||||
procedure SPLIT_REGISTER (REG : in WORD; LO, HI : out BYTE);
|
||||
-- Splits a 16-bit register into two 8-bit halves.
|
||||
-- Example: SPLIT_REGISTER (16#4C00#, LOWPART, HIGHPART);
|
||||
-- This will set LOWPART to 16#00# and HIGHPART to 16#4C#.
|
||||
|
||||
procedure POKE (SEGMENT, OFFSET : in WORD; VALUE : in BYTE);
|
||||
-- Writes the VALUE to memory at address SEGMENT:OFFSET.
|
||||
-- POKE (16#B000#, 16#0000#, 65) will put an A at the start of
|
||||
-- IBM PC screen memory.
|
||||
|
||||
procedure POKE_WORD (SEGMENT, OFFSET : in WORD; VALUE : in WORD);
|
||||
-- Similar to POKE, except that a 16-bit value is written instead
|
||||
-- of an 8-bit value. The low 8 bits of the value are written to
|
||||
-- offset OFFSET, and the high 8 bits are written to OFFSET+1.
|
||||
|
||||
function PEEK (SEGMENT, OFFSET : in WORD) return BYTE;
|
||||
-- Reads an 8-bit BYTE value from memory at address SEGMENT:OFFSET.
|
||||
-- FIRSTBYTE := PEEK (16#B000#, 16#0000#); sets FIRSTBYTE to the
|
||||
-- ASCII value of the first character in the IBM PC screen memory.
|
||||
|
||||
function PEEK_WORD (SEGMENT, OFFSET : in WORD) return WORD;
|
||||
-- Similar to PEEK, except that a 16-bit value is read. The
|
||||
-- low 8 bits of the value are read from SEGMENT:OFFSET, while
|
||||
-- the high 8 bits are read from SEGMENT:OFFSET+1.
|
||||
|
||||
procedure PORT_OUT (PORT : in WORD; VALUE : in BYTE);
|
||||
-- Outputs a byte to the I/O port whose number is in PORT.
|
||||
-- Port numbers and values are very hardware-specific.
|
||||
|
||||
procedure PORT_OUT_WORD (PORT : in WORD; VALUE : in WORD);
|
||||
-- Outputs a word to the I/O port whose number is in PORT.
|
||||
-- Port numbers and values are very hardware-specific.
|
||||
|
||||
function PORT_IN (PORT : in WORD) return BYTE;
|
||||
-- Inputs a byte from the I/O port whose number is in PORT.
|
||||
-- Port numbers and values are very hardware-specific.
|
||||
|
||||
function PORT_IN_WORD (PORT : in WORD) return WORD;
|
||||
-- Inputs a word from the I/O port whose number is in PORT.
|
||||
-- Port numbers and values are very hardware-specific.
|
||||
|
||||
end DOS_INTERFACE;
|
||||
|
||||
package body DOS_INTERFACE is
|
||||
|
||||
pragma SUPPRESS (ALL_CHECKS); -- This is low-level, high-speed code
|
||||
|
||||
procedure CALL_DOS (REGS : in out REG_8086) is
|
||||
begin
|
||||
-- For a full assembly listing of the CALL_DOS code,
|
||||
-- refer to CALL_DOS.ASM on the Utility Diskette.
|
||||
pragma INCLUDE_BINARY ("call_dos.bin");
|
||||
null; -- Required for legal Ada syntax
|
||||
end CALL_DOS;
|
||||
|
||||
function CURRENT_DATA_SEGMENT return WORD is
|
||||
RESULT : WORD;
|
||||
begin
|
||||
pragma NATIVE (16#8C#, 16#1D#); -- Just MOV [DI], DS
|
||||
return RESULT;
|
||||
end;
|
||||
|
||||
procedure MERGE_REGISTERS (LO, HI : in BYTE; REG : out WORD) is
|
||||
begin
|
||||
pragma NATIVE (
|
||||
16#8B#, 16#04#, 16#8B#, 16#54#, 16#02#, 16#8B#, 16#5C#, 16#04#,
|
||||
16#8A#, 16#E2#, 16#89#, 16#07#);
|
||||
null;
|
||||
end MERGE_REGISTERS;
|
||||
|
||||
procedure SPLIT_REGISTER (REG : in WORD; LO, HI : out BYTE) is
|
||||
-- Splits a 16-bit register into
|
||||
begin
|
||||
pragma NATIVE (
|
||||
16#8B#, 16#04#, 16#8B#, 16#5C#, 16#02#, 16#32#, 16#E4#, 16#89#,
|
||||
16#07#, 16#8B#, 16#04#, 16#8B#, 16#5C#, 16#04#, 16#86#, 16#C4#,
|
||||
16#32#, 16#E4#, 16#89#, 16#07#);
|
||||
null;
|
||||
end SPLIT_REGISTER;
|
||||
|
||||
procedure POKE (SEGMENT, OFFSET : in WORD; VALUE : in BYTE) is
|
||||
begin
|
||||
pragma NATIVE (
|
||||
16#06#, 16#8E#, 16#04#, 16#8B#, 16#7C#, 16#02#, 16#8A#, 16#44#,
|
||||
16#04#, 16#AA#, 16#07#);
|
||||
null;
|
||||
end POKE;
|
||||
|
||||
procedure POKE_WORD (SEGMENT, OFFSET : in WORD; VALUE : in WORD) is
|
||||
begin
|
||||
pragma NATIVE (
|
||||
16#06#, 16#8E#, 16#04#, 16#8B#, 16#7C#, 16#02#, 16#8B#, 16#44#,
|
||||
16#04#, 16#AB#, 16#07#);
|
||||
null;
|
||||
end POKE_WORD;
|
||||
|
||||
function PEEK (SEGMENT, OFFSET : in WORD) return BYTE is
|
||||
RESULT : BYTE;
|
||||
begin
|
||||
pragma NATIVE (
|
||||
16#06#, 16#8E#, 16#04#, 16#8B#, 16#5C#, 16#02#, 16#26#, 16#8A#,
|
||||
16#07#, 16#88#, 16#05#, 16#07#);
|
||||
return RESULT;
|
||||
end PEEK;
|
||||
|
||||
function PEEK_WORD (SEGMENT, OFFSET : in WORD) return WORD is
|
||||
RESULT : WORD;
|
||||
begin
|
||||
pragma NATIVE (
|
||||
16#06#, 16#8E#, 16#04#, 16#8B#, 16#5C#, 16#02#, 16#26#, 16#8B#,
|
||||
16#07#, 16#89#, 16#05#, 16#07#);
|
||||
return RESULT;
|
||||
end PEEK_WORD;
|
||||
|
||||
procedure PORT_OUT (PORT : in WORD; VALUE : in BYTE) is
|
||||
begin
|
||||
pragma NATIVE (16#8B#, 16#14#, 16#8A#, 16#44#, 16#02#, 16#EE#);
|
||||
null;
|
||||
end PORT_OUT;
|
||||
|
||||
procedure PORT_OUT_WORD (PORT : in WORD; VALUE : in WORD) is
|
||||
begin
|
||||
pragma NATIVE (16#8B#, 16#14#, 16#8B#, 16#44#, 16#02#, 16#EF#);
|
||||
null;
|
||||
end PORT_OUT_WORD;
|
||||
|
||||
function PORT_IN (PORT : in WORD) return BYTE is
|
||||
RESULT : BYTE;
|
||||
begin
|
||||
pragma NATIVE (16#8B#, 16#14#, 16#EC#, 16#88#, 16#05#);
|
||||
return RESULT;
|
||||
end PORT_IN;
|
||||
|
||||
function PORT_IN_WORD (PORT : in WORD) return WORD is
|
||||
RESULT : WORD;
|
||||
begin
|
||||
pragma NATIVE (16#8B#, 16#14#, 16#ED#, 16#89#, 16#05#);
|
||||
return RESULT;
|
||||
end PORT_IN_WORD;
|
||||
|
||||
end DOS_INTERFACE;
|
||||
|
||||
42
Artek Ada v125/E.ADA
Normal file
42
Artek Ada v125/E.ADA
Normal file
@ -0,0 +1,42 @@
|
||||
with TEXT_IO; use TEXT_IO;
|
||||
|
||||
procedure E is
|
||||
|
||||
h, n, x, d, y : integer;
|
||||
a : Array(0..200) of integer;
|
||||
|
||||
begin
|
||||
h := 200;
|
||||
x := 0;
|
||||
n := h - 1;
|
||||
d := 0;
|
||||
y := 0;
|
||||
|
||||
Put( "starting... " ); New_line;
|
||||
while n > 0 loop
|
||||
a( n ) := 1;
|
||||
n := n - 1;
|
||||
end loop;
|
||||
|
||||
a( 1 ) := 2;
|
||||
a( 0 ) := 0;
|
||||
|
||||
while h > 9 loop
|
||||
h := h - 1;
|
||||
n := h;
|
||||
while 0 /= n loop
|
||||
-- math simplified because complex expressions cause bad code to be generated
|
||||
a( n ) := x REM n;
|
||||
y := a( n - 1 );
|
||||
x := ( y * 10 ) + ( x / n );
|
||||
n := n - 1;
|
||||
end loop;
|
||||
|
||||
Put( INTEGER'IMAGE( x ) );
|
||||
end loop;
|
||||
|
||||
New_line;
|
||||
Put( "done" );
|
||||
New_line;
|
||||
end e;
|
||||
|
||||
24
Artek Ada v125/IOEXC.ADA
Normal file
24
Artek Ada v125/IOEXC.ADA
Normal file
@ -0,0 +1,24 @@
|
||||
--
|
||||
-- Package IO_EXCEPTIONS
|
||||
--
|
||||
-- Standard Ada Input/Output exceptions
|
||||
--
|
||||
-- (C) 1985 Artek Corporation
|
||||
--
|
||||
|
||||
package IO_EXCEPTIONS is
|
||||
|
||||
-- See ANSI/MIL-STD-1815A 1983
|
||||
|
||||
STATUS_ERROR : exception;
|
||||
MODE_ERROR : exception;
|
||||
NAME_ERROR : exception;
|
||||
USE_ERROR : exception;
|
||||
DEVICE_ERROR : exception;
|
||||
END_ERROR : exception;
|
||||
DATA_ERROR : exception;
|
||||
LAYOUT_ERROR : exception;
|
||||
|
||||
end IO_EXCEPTIONS;
|
||||
|
||||
|
||||
BIN
Artek Ada v125/KEYBOARD.EXE
Normal file
BIN
Artek Ada v125/KEYBOARD.EXE
Normal file
Binary file not shown.
BIN
Artek Ada v125/LINKLIB.EXE
Normal file
BIN
Artek Ada v125/LINKLIB.EXE
Normal file
Binary file not shown.
86
Artek Ada v125/LONGOP.ADA
Normal file
86
Artek Ada v125/LONGOP.ADA
Normal file
@ -0,0 +1,86 @@
|
||||
--
|
||||
-- LONGOP.ADA
|
||||
--
|
||||
-- Operations on 32-bit values
|
||||
--
|
||||
-- (C) Copyright 1986 Artek Corporation
|
||||
--
|
||||
-- This package implements a few utility routines for
|
||||
-- the manipulation of 32-bit quantities. It is fairly
|
||||
-- incomplete and is mainly intended for use with DIRECT_IO
|
||||
-- and MEMORY.
|
||||
--
|
||||
-- All operations raise NUMERIC_ERROR if errors occur.
|
||||
--
|
||||
-- Note: Since LONG_INTEGER is implemented here as a record,
|
||||
-- you cannot assign to it as if it were a normal integer.
|
||||
-- Thus, you cannot say L := 1000 if L is a LONG_INTEGER.
|
||||
-- However, you could use L := (1000, 0).
|
||||
--
|
||||
|
||||
package LONG_OPERATIONS is
|
||||
|
||||
type LONG_INTEGER is
|
||||
record
|
||||
LOW, HIGH : INTEGER;
|
||||
end record;
|
||||
|
||||
function "*" (LEFT, RIGHT : in INTEGER) return LONG_INTEGER;
|
||||
function "/" (LEFT : in LONG_INTEGER; RIGHT : in INTEGER) return INTEGER;
|
||||
function "+" (LEFT : in LONG_INTEGER; RIGHT : in INTEGER) return LONG_INTEGER;
|
||||
function SHR (LEFT : in LONG_INTEGER; RIGHT : in NATURAL) return LONG_INTEGER;
|
||||
function "+" (LEFT, RIGHT : in LONG_INTEGER) return LONG_INTEGER;
|
||||
|
||||
end LONG_OPERATIONS;
|
||||
|
||||
package body LONG_OPERATIONS is
|
||||
|
||||
function "*" (LEFT, RIGHT : in INTEGER) return LONG_INTEGER is
|
||||
L : LONG_INTEGER;
|
||||
begin
|
||||
pragma NATIVE (
|
||||
16#8B#, 16#04#, 16#F7#, 16#6C#, 16#02#, 16#AB#, 16#8B#, 16#C2#,
|
||||
16#AB#);
|
||||
return L;
|
||||
end "*";
|
||||
|
||||
function "/" (LEFT : in LONG_INTEGER; RIGHT : in INTEGER) return INTEGER is
|
||||
I : INTEGER;
|
||||
begin
|
||||
pragma NATIVE (
|
||||
16#8B#, 16#04#, 16#8B#, 16#54#, 16#02#, 16#F7#, 16#7C#, 16#04#,
|
||||
16#AB#);
|
||||
return I;
|
||||
end "/";
|
||||
|
||||
function "+" (LEFT : in LONG_INTEGER; RIGHT : in INTEGER) return LONG_INTEGER is
|
||||
L : LONG_INTEGER;
|
||||
begin
|
||||
pragma NATIVE (
|
||||
16#8B#, 16#04#, 16#8B#, 16#54#, 16#02#, 16#03#, 16#44#, 16#04#,
|
||||
16#83#, 16#D2#, 16#00#, 16#89#, 16#05#, 16#89#, 16#55#, 16#02#);
|
||||
return L;
|
||||
end "+";
|
||||
|
||||
function SHR (LEFT : in LONG_INTEGER; RIGHT : in NATURAL) return LONG_INTEGER is
|
||||
L : LONG_INTEGER;
|
||||
begin
|
||||
pragma NATIVE (
|
||||
16#8B#, 16#4C#, 16#04#, 16#E3#, 16#0B#, 16#8B#, 16#04#, 16#8B#,
|
||||
16#54#, 16#02#, 16#D1#, 16#EA#, 16#D1#, 16#D8#, 16#E2#, 16#FA#,
|
||||
16#AB#, 16#8B#, 16#C2#, 16#AB#);
|
||||
return L;
|
||||
end SHR;
|
||||
|
||||
function "+" (LEFT, RIGHT : in LONG_INTEGER) return LONG_INTEGER is
|
||||
L : LONG_INTEGER;
|
||||
begin
|
||||
pragma NATIVE (
|
||||
16#8B#, 16#04#, 16#8B#, 16#54#, 16#02#, 16#03#, 16#44#, 16#04#,
|
||||
16#13#, 16#54#, 16#06#, 16#89#, 16#05#, 16#89#, 16#55#, 16#02#);
|
||||
return L;
|
||||
end "+";
|
||||
|
||||
end LONG_OPERATIONS;
|
||||
|
||||
|
||||
294
Artek Ada v125/MAIL.ADA
Normal file
294
Artek Ada v125/MAIL.ADA
Normal file
@ -0,0 +1,294 @@
|
||||
--
|
||||
-- MAIL.ADA
|
||||
--
|
||||
-- An extremely simple mailing list program for Artek Ada
|
||||
--
|
||||
-- Copyright (C) 1986, 1987 Artek Corporation
|
||||
--
|
||||
-- The MAIL program is intended to demonstrate the use of
|
||||
-- the CON_IO and DIRECT_IO packages. It allows the user
|
||||
-- to enter names in a screen "form", modify the information,
|
||||
-- and to view the entered data.
|
||||
--
|
||||
-- The operation of the program should be self-explanatory.
|
||||
--
|
||||
|
||||
with IO_EXCEPTIONS, CON_IO, DIRECT_IO, QGET;
|
||||
|
||||
procedure MAIL is
|
||||
|
||||
-- The following data type is used to describe customer data.
|
||||
|
||||
type CUSTOMER_REC is
|
||||
record
|
||||
NAME : STRING (1..32);
|
||||
ADDR1 : STRING (1..30);
|
||||
ADDR2 : STRING (1..30);
|
||||
ADDR3 : STRING (1..20);
|
||||
end record;
|
||||
|
||||
-- We're going to use random-access I/O for our customer file,
|
||||
-- so DIRECT_IO is instantiated.
|
||||
|
||||
package CUST_IO is new DIRECT_IO (CUSTOMER_REC);
|
||||
|
||||
-- To avoid dot notation (e.g. CON_IO.SOMETHING),
|
||||
-- we USE the most important packages.
|
||||
|
||||
use CUST_IO, CON_IO;
|
||||
|
||||
CUSTFILE : FILE_TYPE;
|
||||
CHOICE : CHARACTER := 'E'; -- Let the default choice be "Exit"
|
||||
ANYKEY : CHARACTER; -- Used when waiting for the user to press a key
|
||||
|
||||
-- The following procedure demonstrates CON_IO. It uses a lot
|
||||
-- of routines from that package to set up a nice "look".
|
||||
|
||||
procedure SET_UP_SCREEN is
|
||||
|
||||
-- Set up a string of 80 spaces
|
||||
SPACES : constant STRING := (1..80 => ' ');
|
||||
|
||||
begin
|
||||
BACKGROUND (4);
|
||||
CLS;
|
||||
CURSOR (0, 0);
|
||||
INTENSITY;
|
||||
COLOR (2);
|
||||
PUT ("Artek Ada Mailing List Application");
|
||||
CURSOR (0, 1);
|
||||
ALL_OFF;
|
||||
BACKGROUND (6);
|
||||
PUT (SPACES);
|
||||
ALL_OFF;
|
||||
CURSOR (0, 23);
|
||||
REV_VIDEO;
|
||||
BACKGROUND (6);
|
||||
PUT (SPACES);
|
||||
CURSOR (14, 23);
|
||||
PUT ("This application was coded entirely in Artek Ada.");
|
||||
ALL_OFF;
|
||||
CURSOR (0, 0);
|
||||
end SET_UP_SCREEN;
|
||||
|
||||
-- The following procedure allows the user to enter data about new
|
||||
-- customers.
|
||||
|
||||
procedure ADD_CUSTOMER is
|
||||
C : CUSTOMER_REC;
|
||||
LAST : INTEGER;
|
||||
|
||||
-- Aggregates are put to good use in order to initialize the
|
||||
-- customer data to all spaces.
|
||||
|
||||
procedure CLEAR_CUSTOMER (C : out CUSTOMER_REC) is
|
||||
begin
|
||||
C := (
|
||||
NAME => (others => ' '),
|
||||
ADDR1 => (others => ' '),
|
||||
ADDR2 => (others => ' '),
|
||||
ADDR3 => (others => ' ')
|
||||
);
|
||||
end CLEAR_CUSTOMER;
|
||||
|
||||
begin
|
||||
SET_UP_SCREEN;
|
||||
CLEAR_CUSTOMER (C);
|
||||
BACKGROUND (4);
|
||||
BOX (0, 3, 79, 21);
|
||||
COLOR (3);
|
||||
CURSOR (60, 0);
|
||||
PUT ("Add customer");
|
||||
CURSOR (20, 8);
|
||||
PUT ("Enter name => ");
|
||||
GET (C . NAME);
|
||||
CURSOR (20, 10);
|
||||
PUT ("Enter address 1 => ");
|
||||
GET (C . ADDR1);
|
||||
CURSOR (20, 12);
|
||||
PUT ("Enter address 2 => ");
|
||||
GET (C . ADDR2);
|
||||
CURSOR (20, 14);
|
||||
PUT ("Enter address 3 => ");
|
||||
GET (C . ADDR3);
|
||||
-- The following statement writes the customer data to the customer
|
||||
-- file. The TO parameter specifies that we want to write the new
|
||||
-- record at the end of the file.
|
||||
WRITE (CUSTFILE, C, TO => SIZE (CUSTFILE) + 1);
|
||||
END;
|
||||
|
||||
-- The following procedure allows modification of customer data.
|
||||
-- Customers are referenced through record numbers.
|
||||
|
||||
procedure MODIFY_CUSTOMER is
|
||||
RECNUM : STRING (1..5) := "0 "; -- Default record number is zero
|
||||
REC : COUNT;
|
||||
C : CUSTOMER_REC;
|
||||
|
||||
begin
|
||||
MAIN_LOOP:
|
||||
loop
|
||||
begin
|
||||
SET_UP_SCREEN;
|
||||
CURSOR (60, 0);
|
||||
BACKGROUND (4);
|
||||
COLOR (3);
|
||||
PUT ("Modify customer");
|
||||
-- What follows is a standard Ada technique for entering
|
||||
-- and validating data. A block is declared within
|
||||
-- an endless loop. The loop is only exited when legal
|
||||
-- data has been entered. Otherwise, an exception is
|
||||
-- raised, and control passes to the end of the block,
|
||||
-- resulting in the entry starting all over again.
|
||||
loop
|
||||
CURSOR (20, 6);
|
||||
PUT ("Enter number (0=exit) => ");
|
||||
GET (RECNUM);
|
||||
begin
|
||||
-- The VALUE attribute will raise an exception if illegal
|
||||
-- data is contained in RECNUM.
|
||||
REC := COUNT'VALUE (RECNUM);
|
||||
exit;
|
||||
exception
|
||||
when others =>
|
||||
null;
|
||||
end;
|
||||
end loop;
|
||||
exit MAIN_LOOP when REC = 0;
|
||||
-- We read the record specified by the user. The exception
|
||||
-- END_ERROR is raised if we read past the end of the file.
|
||||
READ (CUSTFILE, C, FROM => REC);
|
||||
CURSOR (20, 8);
|
||||
PUT ("Enter name => ");
|
||||
GET (C . NAME);
|
||||
CURSOR (20, 10);
|
||||
PUT ("Enter address 1 => ");
|
||||
GET (C . ADDR1);
|
||||
CURSOR (20, 12);
|
||||
PUT ("Enter address 2 => ");
|
||||
GET (C . ADDR2);
|
||||
CURSOR (20, 14);
|
||||
PUT ("Enter address 3 => ");
|
||||
GET (C . ADDR3);
|
||||
-- The record is written in the same slot as it was read from.
|
||||
WRITE (CUSTFILE, C, TO => REC);
|
||||
exception
|
||||
when END_ERROR | USE_ERROR =>
|
||||
CURSOR (20, 20);
|
||||
BLINK;
|
||||
PUT ("Illegal record number. Press any key ...");
|
||||
ALL_OFF;
|
||||
QGET (ANYKEY);
|
||||
end;
|
||||
end loop MAIN_LOOP;
|
||||
end;
|
||||
|
||||
-- The VIEW procedure allows the user to "page" through the customer
|
||||
-- list on the screen.
|
||||
|
||||
procedure VIEW is
|
||||
|
||||
C : CUSTOMER_REC;
|
||||
|
||||
begin
|
||||
SET_UP_SCREEN;
|
||||
BACKGROUND (4);
|
||||
BOX (0, 3, 79, 21);
|
||||
COLOR (3);
|
||||
CURSOR (60, 0);
|
||||
PUT ("View customers");
|
||||
-- The following line closes the customer file and opens it again
|
||||
-- as an input file. The file is ready for input at the first record.
|
||||
RESET (CUSTFILE, MODE => IN_FILE);
|
||||
MAIN_LOOP:
|
||||
while not END_OF_FILE (CUSTFILE) loop
|
||||
CURSOR (20, 8);
|
||||
BACKGROUND (4);
|
||||
COLOR (3);
|
||||
-- The following line displays the current record number.
|
||||
-- The IMAGE attribute is necessary because we don't have
|
||||
-- a PUT for integers.
|
||||
PUT ("Record number" & COUNT'IMAGE (INDEX (CUSTFILE)));
|
||||
READ (CUSTFILE, C);
|
||||
CURSOR (20, 10);
|
||||
PUT (C . NAME);
|
||||
CURSOR (20, 12);
|
||||
PUT (C . ADDR1);
|
||||
CURSOR (20, 14);
|
||||
PUT (C . ADDR2);
|
||||
CURSOR (20, 16);
|
||||
PUT (C . ADDR3);
|
||||
CURSOR (20, 18);
|
||||
INTENSITY;
|
||||
PUT ("Press SPACE to continue or ESC to exit...");
|
||||
ALL_OFF;
|
||||
loop
|
||||
QGET (ANYKEY);
|
||||
if ANYKEY = ' ' then
|
||||
exit; -- Exit just this small entry loop
|
||||
elsif ANYKEY = ASCII . ESC then
|
||||
exit MAIN_LOOP; -- Exit from the main loop
|
||||
end if;
|
||||
end loop;
|
||||
end loop MAIN_LOOP;
|
||||
-- The following line closes the customer file and re-opens it
|
||||
-- for input and output.
|
||||
RESET (CUSTFILE, MODE => INOUT_FILE);
|
||||
end VIEW;
|
||||
|
||||
begin
|
||||
-- What follows is another standard Ada technique:
|
||||
-- A block is declared; a file is opened; if it existed previously,
|
||||
-- everything is OK and the block is exited; else, an exception is
|
||||
-- raised and a new file is created.
|
||||
begin
|
||||
OPEN (CUSTFILE, NAME => "CUSTOMER.DAT", MODE => INOUT_FILE);
|
||||
exception
|
||||
when NAME_ERROR =>
|
||||
CREATE (CUSTFILE, NAME => "CUSTOMER.DAT");
|
||||
end;
|
||||
loop
|
||||
SET_UP_SCREEN;
|
||||
BACKGROUND (4);
|
||||
BOX (0, 3, 79, 21);
|
||||
COLOR (3);
|
||||
CURSOR (60, 0);
|
||||
PUT ("Main menu");
|
||||
CURSOR (20, 8);
|
||||
PUT ("A - Add new customers to mailing list");
|
||||
CURSOR (20, 10);
|
||||
PUT ("M - Modify information on a customer");
|
||||
CURSOR (20, 12);
|
||||
PUT ("V - View mailing list");
|
||||
CURSOR (20, 14);
|
||||
PUT ("E - Exit program");
|
||||
BOX (5, 17, 75, 19);
|
||||
CURSOR (20, 18);
|
||||
INTENSITY;
|
||||
PUT ("Choose Add, Modify, View or Exit (A/M/V/E) => ");
|
||||
GET (CHOICE);
|
||||
ALL_OFF;
|
||||
case CHOICE is
|
||||
when 'a' | 'A' => ADD_CUSTOMER;
|
||||
when 'm' | 'M' => MODIFY_CUSTOMER;
|
||||
when 'v' | 'V' => VIEW;
|
||||
when 'e' | 'E' => exit;
|
||||
-- Insert your additional choices here
|
||||
when others =>
|
||||
CURSOR (20, 20);
|
||||
BLINK;
|
||||
PUT ("Incorrect choice. Press any key ...");
|
||||
ALL_OFF;
|
||||
QGET (ANYKEY);
|
||||
end case;
|
||||
end loop;
|
||||
CLOSE (CUSTFILE);
|
||||
CURSOR (20, 20);
|
||||
PUT ("Thank you and have a nice day.");
|
||||
exception
|
||||
when others =>
|
||||
ALL_OFF; -- Ensure black and white MS-DOS even if an error occurs
|
||||
raise; -- Let the run-time system report the exception to the user
|
||||
end MAIL; -- End of program
|
||||
|
||||
|
||||
383
Artek Ada v125/MATH.ADA
Normal file
383
Artek Ada v125/MATH.ADA
Normal file
@ -0,0 +1,383 @@
|
||||
--
|
||||
-- MATH.ADA
|
||||
--
|
||||
-- Mathematical routines for Artek Ada
|
||||
--
|
||||
-- Package body Copyright (C) 1986 Artek Corporation
|
||||
-- Author: V. Thorsteinsson
|
||||
--
|
||||
-- The MATH package offers common exponential, logarithmic,
|
||||
-- trigonometric and hyperbolic functions used in mathematical
|
||||
-- calculation.
|
||||
--
|
||||
-- Most routines are implemented in assembly language for maximum
|
||||
-- speed and accuracy. An 8087/287/387 coprocessor is used if
|
||||
-- present and emulated in software if not.
|
||||
--
|
||||
-- The routines raise the exception ARGUMENT_ERROR if their
|
||||
-- arguments are out of bounds.
|
||||
--
|
||||
-- The trigonometric functions can accept an optional CYCLE parameter
|
||||
-- that allows you to work in degrees or grads if you prefer them to
|
||||
-- radians. In this case, say for example:
|
||||
--
|
||||
-- A := SIN (90.0, CYCLE => 360.0);
|
||||
--
|
||||
-- to calculate the sine of a 90 degree angle.
|
||||
--
|
||||
|
||||
generic
|
||||
|
||||
type REAL is digits <>;
|
||||
|
||||
package MATH is
|
||||
|
||||
PI : constant := 3.1415_92653_58979_32384_62643_38327_95029;
|
||||
EXP_1 : constant := 2.7182_81828_45904_52353_60287_47135_26625;
|
||||
|
||||
function SQRT (X : REAL) return REAL;
|
||||
function LOG (X : REAL; BASE : REAL := EXP_1) return REAL;
|
||||
function EXP (X : REAL; BASE : REAL := EXP_1) return REAL;
|
||||
function SIN (X : REAL; CYCLE : REAL := 2.0 * PI) return REAL;
|
||||
function COS (X : REAL; CYCLE : REAL := 2.0 * PI) return REAL;
|
||||
function TAN (X : REAL; CYCLE : REAL := 2.0 * PI) return REAL;
|
||||
function COT (X : REAL; CYCLE : REAL := 2.0 * PI) return REAL;
|
||||
function ARCSIN (X : REAL) return REAL;
|
||||
function ARCCOS (X : REAL) return REAL;
|
||||
function ARCTAN (X : REAL; Y : REAL := 1.0) return REAL;
|
||||
function ARCCOT (X : REAL; Y : REAL := 1.0) return REAL;
|
||||
function SINH (X : REAL) return REAL;
|
||||
function COSH (X : REAL) return REAL;
|
||||
function TANH (X : REAL) return REAL;
|
||||
function COTH (X : REAL) return REAL;
|
||||
function ARCSINH (X : REAL) return REAL;
|
||||
function ARCCOSH (X : REAL) return REAL;
|
||||
function ARCTANH (X : REAL) return REAL;
|
||||
function ARCCOTH (X : REAL) return REAL;
|
||||
|
||||
ARGUMENT_ERROR : exception;
|
||||
|
||||
end MATH;
|
||||
|
||||
package body MATH is
|
||||
|
||||
function "rem" (LEFT, RIGHT : REAL) return REAL is
|
||||
RESULT : REAL;
|
||||
STATUS : INTEGER;
|
||||
begin
|
||||
pragma NATIVE (
|
||||
16#CD#, 16#39#, 16#44#, 16#08#, 16#CD#, 16#39#, 16#04#, 16#CD#,
|
||||
16#35#, 16#E4#, 16#33#, 16#C9#, 16#CD#, 16#39#, 16#7D#, 16#08#,
|
||||
16#CD#, 16#3D#, 16#8B#, 16#45#, 16#08#, 16#9E#, 16#73#, 16#05#,
|
||||
16#CD#, 16#35#, 16#E0#, 16#F7#, 16#D1#, 16#CD#, 16#35#, 16#F8#,
|
||||
16#CD#, 16#39#, 16#7D#, 16#08#, 16#CD#, 16#3D#, 16#8B#, 16#45#,
|
||||
16#08#, 16#9E#, 16#7A#, 16#F1#, 16#CD#, 16#39#, 16#D9#, 16#23#,
|
||||
16#C9#, 16#74#, 16#03#, 16#CD#, 16#35#, 16#E0#, 16#CD#, 16#39#,
|
||||
16#1D#, 16#CD#, 16#3D#);
|
||||
return RESULT;
|
||||
end "rem";
|
||||
|
||||
function MYTAN (X : REAL) return REAL is
|
||||
RESULT : REAL;
|
||||
PIOVER4 : REAL := PI / 4.0;
|
||||
PIOVER2 : REAL := PI / 2.0;
|
||||
STATUS_WORD : INTEGER;
|
||||
ENVIRONMENT : array (1..8) of INTEGER;
|
||||
begin
|
||||
pragma NATIVE (
|
||||
16#CD#, 16#35#, 16#EB#, 16#CD#, 16#39#, 16#04#, 16#CD#, 16#35#,
|
||||
16#E4#, 16#33#, 16#DB#, 16#8B#, 16#CB#, 16#CD#, 16#39#, 16#7D#,
|
||||
16#18#, 16#CD#, 16#3D#, 16#8B#, 16#45#, 16#18#, 16#9E#, 16#73#,
|
||||
16#05#, 16#CD#, 16#35#, 16#E0#, 16#F7#, 16#D1#, 16#CD#, 16#35#,
|
||||
16#F8#, 16#CD#, 16#39#, 16#7D#, 16#18#, 16#CD#, 16#3D#, 16#8B#,
|
||||
16#45#, 16#18#, 16#9E#, 16#7A#, 16#F1#, 16#CD#, 16#39#, 16#D9#,
|
||||
16#CD#, 16#39#, 16#45#, 16#10#, 16#CD#, 16#35#, 16#C9#, 16#CD#,
|
||||
16#34#, 16#D1#, 16#CD#, 16#39#, 16#7D#, 16#18#, 16#CD#, 16#3D#,
|
||||
16#8B#, 16#45#, 16#18#, 16#9E#, 16#76#, 16#07#, 16#CD#, 16#34#,
|
||||
16#E1#, 16#F7#, 16#D3#, 16#F7#, 16#D1#, 16#CD#, 16#39#, 16#45#,
|
||||
16#08#, 16#CD#, 16#34#, 16#D9#, 16#CD#, 16#39#, 16#7D#, 16#18#,
|
||||
16#CD#, 16#3D#, 16#8B#, 16#45#, 16#18#, 16#9E#, 16#73#, 16#05#,
|
||||
16#CD#, 16#34#, 16#E9#, 16#F7#, 16#D3#, 16#CD#, 16#39#, 16#D9#,
|
||||
16#CD#, 16#35#, 16#F2#, 16#23#, 16#C9#, 16#74#, 16#03#, 16#CD#,
|
||||
16#35#, 16#E0#, 16#23#, 16#DB#, 16#74#, 16#05#, 16#CD#, 16#3A#,
|
||||
16#F1#, 16#EB#, 16#03#, 16#CD#, 16#3A#, 16#F9#, 16#CD#, 16#39#,
|
||||
16#1D#, 16#CD#, 16#3D#);
|
||||
return RESULT;
|
||||
end MYTAN;
|
||||
|
||||
function MYCOT (X : REAL) return REAL is
|
||||
-- Cotangent with no checking
|
||||
begin
|
||||
return 1.0 / MYTAN (X);
|
||||
end MYCOT;
|
||||
|
||||
function SQRT (X : REAL) return REAL is
|
||||
RESULT : REAL;
|
||||
begin
|
||||
if X < 0.0 then
|
||||
raise ARGUMENT_ERROR;
|
||||
end if;
|
||||
pragma NATIVE (
|
||||
16#CD#, 16#39#, 16#04#, 16#CD#, 16#35#, 16#FA#, 16#CD#, 16#39#,
|
||||
16#1D#, 16#CD#, 16#3D#);
|
||||
return RESULT;
|
||||
end SQRT;
|
||||
|
||||
function LN (X : REAL) return REAL is
|
||||
RESULT : REAL;
|
||||
begin
|
||||
pragma NATIVE (
|
||||
16#CD#, 16#35#, 16#ED#, 16#CD#, 16#39#, 16#04#, 16#CD#, 16#35#,
|
||||
16#F1#, 16#CD#, 16#39#, 16#1D#, 16#CD#, 16#3D#);
|
||||
return RESULT;
|
||||
end LN;
|
||||
|
||||
function LOG (X : REAL; BASE : REAL := EXP_1) return REAL is
|
||||
begin
|
||||
if X <= 0.0 or BASE <= 0.0 or BASE = 1.0 then
|
||||
raise ARGUMENT_ERROR;
|
||||
end if;
|
||||
if BASE = EXP_1 then
|
||||
return LN (X);
|
||||
else
|
||||
return LN (X) / LN (BASE);
|
||||
end if;
|
||||
end LOG;
|
||||
|
||||
function EXPONENTIAL (X : REAL) return REAL is
|
||||
RESULT : REAL;
|
||||
STATUS : INTEGER;
|
||||
begin
|
||||
pragma NATIVE (
|
||||
16#CD#, 16#39#, 16#04#, 16#CD#, 16#35#, 16#EA#, 16#CD#, 16#3A#,
|
||||
16#C9#, 16#CD#, 16#35#, 16#C0#, 16#CD#, 16#35#, 16#FC#, 16#CD#,
|
||||
16#35#, 16#C0#, 16#CD#, 16#34#, 16#EA#, 16#CD#, 16#35#, 16#E4#,
|
||||
16#CD#, 16#39#, 16#7D#, 16#08#, 16#CD#, 16#3D#, 16#8B#, 16#45#,
|
||||
16#08#, 16#9E#, 16#CD#, 16#35#, 16#E1#, 16#CD#, 16#35#, 16#F0#,
|
||||
16#CD#, 16#35#, 16#E8#, 16#CD#, 16#3A#, 16#C1#, 16#73#, 16#06#,
|
||||
16#CD#, 16#35#, 16#E8#, 16#CD#, 16#3A#, 16#F1#, 16#CD#, 16#35#,
|
||||
16#FD#, 16#CD#, 16#39#, 16#1D#, 16#CD#, 16#39#, 16#D8#, 16#CD#,
|
||||
16#39#, 16#D8#);
|
||||
return RESULT;
|
||||
end EXPONENTIAL;
|
||||
|
||||
function EXP (X : REAL; BASE : REAL := EXP_1) return REAL is
|
||||
begin
|
||||
if BASE <= 0.0 then
|
||||
raise ARGUMENT_ERROR;
|
||||
end if;
|
||||
if BASE = EXP_1 then
|
||||
return EXPONENTIAL (X);
|
||||
else
|
||||
return EXPONENTIAL (X * LN (BASE));
|
||||
end if;
|
||||
end EXP;
|
||||
|
||||
function SIN (X : REAL; CYCLE : REAL := 2.0 * PI) return REAL is
|
||||
CT : REAL;
|
||||
TX : REAL;
|
||||
begin
|
||||
if CYCLE = 0.0 then
|
||||
raise ARGUMENT_ERROR;
|
||||
end if;
|
||||
TX := (X / CYCLE) * 2.0 * PI;
|
||||
TX := TX rem (2.0 * PI); -- Floating-point remainder
|
||||
if (TX = 0.0) or (TX = PI) then -- Avoid division by zero
|
||||
return 0.0;
|
||||
else
|
||||
CT := MYCOT (TX / 2.0); -- Argument has already been checked
|
||||
return (2.0 * CT) / (1.0 + CT * CT);
|
||||
end if;
|
||||
end SIN;
|
||||
|
||||
function COS (X : REAL; CYCLE : REAL := 2.0 * PI) return REAL is
|
||||
CT : REAL;
|
||||
TX : REAL;
|
||||
begin
|
||||
if CYCLE = 0.0 then
|
||||
raise ARGUMENT_ERROR;
|
||||
end if;
|
||||
TX := (X / CYCLE) * 2.0 * PI;
|
||||
TX := TX rem (2.0 * PI);
|
||||
if (TX = 0.0) or (TX = PI) then -- Avoid division by zero
|
||||
return 1.0;
|
||||
else
|
||||
CT := MYCOT (TX / 2.0); -- Argument has already been checked
|
||||
return - (1.0 - CT * CT) / (1.0 + CT * CT);
|
||||
end if;
|
||||
end COS;
|
||||
|
||||
function TAN (X : REAL; CYCLE : REAL := 2.0 * PI) return REAL is
|
||||
|
||||
TX : REAL;
|
||||
|
||||
begin
|
||||
if CYCLE = 0.0 then
|
||||
raise ARGUMENT_ERROR;
|
||||
end if;
|
||||
TX := (X / CYCLE) * 2.0 * PI;
|
||||
TX := TX rem (2.0 * PI);
|
||||
return MYTAN (TX);
|
||||
end TAN;
|
||||
|
||||
function COT (X : REAL; CYCLE : REAL := 2.0 * PI) return REAL is
|
||||
begin
|
||||
return 1.0 / TAN (X, CYCLE);
|
||||
end COT;
|
||||
|
||||
function ARCSIN (X : REAL) return REAL is
|
||||
begin
|
||||
if abs X > 1.0 then
|
||||
raise ARGUMENT_ERROR;
|
||||
end if;
|
||||
return ARCTAN (X / SQRT ((1.0 - X) * (1.0 + X)));
|
||||
end ARCSIN;
|
||||
|
||||
function ARCCOS (X : REAL) return REAL is
|
||||
begin
|
||||
if abs X > 1.0 then
|
||||
raise ARGUMENT_ERROR;
|
||||
end if;
|
||||
return 2.0 * ARCTAN (SQRT ((1.0 - X) / (1.0 + X)));
|
||||
end ARCCOS;
|
||||
|
||||
function ARCTAN (X : REAL; Y : REAL := 1.0) return REAL is
|
||||
|
||||
PIOVER2 : constant REAL := PI / 2.0;
|
||||
|
||||
function ATAN (X, Y : in REAL) return REAL is
|
||||
RESULT : REAL;
|
||||
begin
|
||||
pragma NATIVE (
|
||||
16#CD#, 16#39#, 16#04#, 16#CD#, 16#39#, 16#44#, 16#08#, 16#CD#,
|
||||
16#35#, 16#F3#, 16#CD#, 16#39#, 16#1D#, 16#CD#, 16#3D#);
|
||||
return RESULT;
|
||||
end ATAN;
|
||||
|
||||
begin
|
||||
if X = 0.0 and Y = 0.0 then
|
||||
raise ARGUMENT_ERROR;
|
||||
end if;
|
||||
if X / Y < 0.0 then
|
||||
return - ARCTAN (-X, Y);
|
||||
elsif X > Y then
|
||||
return PIOVER2 - ATAN (Y, X);
|
||||
else
|
||||
return ATAN (X, Y);
|
||||
end if;
|
||||
end ARCTAN;
|
||||
|
||||
function ARCCOT (X : REAL; Y : REAL := 1.0) return REAL is
|
||||
begin
|
||||
return ARCTAN (Y, X);
|
||||
end ARCCOT;
|
||||
|
||||
function SINH (X : REAL) return REAL is
|
||||
EABSX : constant REAL := EXP (abs X);
|
||||
RESULT : REAL;
|
||||
begin
|
||||
RESULT := 0.5 * (EABSX - 1.0 + (EABSX - 1.0) / EABSX);
|
||||
if X >= 0.0 then
|
||||
return RESULT;
|
||||
else
|
||||
return - RESULT;
|
||||
end if;
|
||||
end SINH;
|
||||
|
||||
function COSH (X : REAL) return REAL is
|
||||
EABSX : constant REAL := EXP (abs X);
|
||||
begin
|
||||
return 0.5 * (EABSX + 1.0 / EABSX);
|
||||
end COSH;
|
||||
|
||||
function TANH (X : REAL) return REAL is
|
||||
E2ABSX : constant REAL := EXP (2.0 * abs X);
|
||||
RESULT : REAL;
|
||||
begin
|
||||
RESULT := (E2ABSX - 1.0) / (E2ABSX + 1.0);
|
||||
if X >= 0.0 then
|
||||
return RESULT;
|
||||
else
|
||||
return - RESULT;
|
||||
end if;
|
||||
end TANH;
|
||||
|
||||
function COTH (X : REAL) return REAL is
|
||||
begin
|
||||
return 1.0 / TANH (X);
|
||||
end COTH;
|
||||
|
||||
function ARCSINH (X : REAL) return REAL is
|
||||
|
||||
ABSX : constant REAL := abs X;
|
||||
|
||||
function ASINH (X : REAL) return REAL is
|
||||
SIGNX : constant INTEGER := INTEGER (X / ABSX);
|
||||
Z : constant REAL :=
|
||||
ABSX + ABSX / (1.0 / ABSX + SQRT (1.0 + (1.0 / ABSX / ABSX)));
|
||||
RESULT : REAL;
|
||||
begin
|
||||
pragma NATIVE (
|
||||
16#CD#, 16#3B#, 16#05#, 16#CD#, 16#35#, 16#ED#, 16#CD#, 16#3A#,
|
||||
16#C9#, 16#CD#, 16#39#, 16#45#, 16#02#, 16#CD#, 16#35#, 16#E8#,
|
||||
16#CD#, 16#3A#, 16#C1#, 16#CD#, 16#35#, 16#F1#, 16#CD#, 16#39#,
|
||||
16#5D#, 16#0A#, 16#CD#, 16#3D#);
|
||||
return RESULT;
|
||||
end ASINH;
|
||||
|
||||
begin
|
||||
return ASINH (X);
|
||||
end ARCSINH;
|
||||
|
||||
function ARCCOSH (X : REAL) return REAL is
|
||||
|
||||
function ACOSH (X : REAL) return REAL is
|
||||
Z : constant REAL := X + SQRT ((X - 1.0) * (X + 1.0));
|
||||
RESULT : REAL;
|
||||
begin
|
||||
pragma NATIVE (
|
||||
16#CD#, 16#35#, 16#ED#, 16#CD#, 16#39#, 16#05#, 16#CD#, 16#35#,
|
||||
16#F1#, 16#CD#, 16#39#, 16#5D#, 16#08#, 16#CD#, 16#3D#);
|
||||
return RESULT;
|
||||
end ACOSH;
|
||||
|
||||
begin
|
||||
if X < 1.0 then
|
||||
raise ARGUMENT_ERROR;
|
||||
end if;
|
||||
return ACOSH (X);
|
||||
end ARCCOSH;
|
||||
|
||||
function ARCTANH (X : REAL) return REAL is
|
||||
|
||||
ABSX : constant REAL := abs X;
|
||||
|
||||
function ATANH (X : REAL) return REAL is
|
||||
SIGNX : constant INTEGER := INTEGER (X / ABSX);
|
||||
Z : constant REAL := 2.0 * ABSX / (1.0 - ABSX);
|
||||
RESULT : REAL;
|
||||
begin
|
||||
pragma NATIVE (
|
||||
16#CD#, 16#3B#, 16#05#, 16#CD#, 16#35#, 16#ED#, 16#CD#, 16#3A#,
|
||||
16#C9#, 16#CD#, 16#39#, 16#45#, 16#02#, 16#CD#, 16#35#, 16#E8#,
|
||||
16#CD#, 16#3A#, 16#C1#, 16#CD#, 16#35#, 16#F1#, 16#CD#, 16#39#,
|
||||
16#5D#, 16#0A#, 16#CD#, 16#3D#);
|
||||
return RESULT / 2.0;
|
||||
end ATANH;
|
||||
|
||||
begin
|
||||
if abs X >= 1.0 then
|
||||
raise ARGUMENT_ERROR;
|
||||
end if;
|
||||
return ATANH (X);
|
||||
end ARCTANH;
|
||||
|
||||
function ARCCOTH (X : REAL) return REAL is
|
||||
begin
|
||||
return ARCTANH (1.0 / X);
|
||||
end ARCCOTH;
|
||||
|
||||
end MATH;
|
||||
|
||||
|
||||
|
||||
212
Artek Ada v125/MEMORY.ADA
Normal file
212
Artek Ada v125/MEMORY.ADA
Normal file
@ -0,0 +1,212 @@
|
||||
--
|
||||
-- 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;
|
||||
|
||||
15
Artek Ada v125/QGET.ADA
Normal file
15
Artek Ada v125/QGET.ADA
Normal file
@ -0,0 +1,15 @@
|
||||
|
||||
with DOS_INTERFACE;
|
||||
use DOS_INTERFACE;
|
||||
|
||||
procedure QGET (C : in out CHARACTER) is
|
||||
R : REG_8086;
|
||||
LO, HI : BYTE;
|
||||
begin
|
||||
R . AX := 16#0700#; -- DOS direct console input without echo
|
||||
CALL_DOS (R);
|
||||
SPLIT_REGISTER (R . AX, LO, HI);
|
||||
C := CHARACTER (LO);
|
||||
end QGET;
|
||||
|
||||
|
||||
BIN
Artek Ada v125/QGET.AXE
Normal file
BIN
Artek Ada v125/QGET.AXE
Normal file
Binary file not shown.
BIN
Artek Ada v125/QGET.EXE
Normal file
BIN
Artek Ada v125/QGET.EXE
Normal file
Binary file not shown.
53
Artek Ada v125/QPUT.ADA
Normal file
53
Artek Ada v125/QPUT.ADA
Normal file
@ -0,0 +1,53 @@
|
||||
--
|
||||
-- QPUT.ADA
|
||||
--
|
||||
-- Quick console output procedure for Artek Ada
|
||||
--
|
||||
-- Copyright (C) 1986 Artek Corporation
|
||||
--
|
||||
-- This procedure uses the DOS Quick Write Interrupt
|
||||
-- (29h) to achieve fast console output.
|
||||
--
|
||||
-- Example of usage:
|
||||
--
|
||||
-- with QPUT;
|
||||
-- procedure EXAMPLE is
|
||||
-- begin
|
||||
-- QPUT ("Hello, world!");
|
||||
-- end EXAMPLE;
|
||||
--
|
||||
|
||||
procedure QPUT (S : in STRING) is
|
||||
|
||||
begin
|
||||
--
|
||||
-- The pragma below represents the following assembly language code:
|
||||
--
|
||||
-- CGROUP GROUP CODE
|
||||
-- CODE SEGMENT 'CODE'
|
||||
-- ASSUME CS:CGROUP, DS:NOTHING, ES:NOTHING
|
||||
--
|
||||
-- QPUT PROC FAR
|
||||
--
|
||||
-- MOV CX, [SI+4] ; Load S . SUBSIZE
|
||||
-- JCXZ ENDQP ; Size is zero; don't print
|
||||
-- MOV SI, [SI] ; Load S . ADDRESS
|
||||
-- QPLOOP:
|
||||
-- LODSB
|
||||
-- INT 29h ; Quick Write interrupt
|
||||
-- LOOP QPLOOP
|
||||
-- ENDQP:
|
||||
--
|
||||
-- QPUT ENDP
|
||||
--
|
||||
-- CODE ENDS
|
||||
--
|
||||
-- END QPUT
|
||||
--
|
||||
pragma NATIVE (
|
||||
16#8B#, 16#4C#, 16#04#, 16#E3#, 16#07#, 16#8B#, 16#34#, 16#AC#,
|
||||
16#CD#, 16#29#, 16#E2#, 16#FB#);
|
||||
null; -- For correct Ada syntax
|
||||
end QPUT;
|
||||
|
||||
|
||||
1359
Artek Ada v125/README
Normal file
1359
Artek Ada v125/README
Normal file
File diff suppressed because it is too large
Load Diff
36
Artek Ada v125/SAMPLE1.ADA
Normal file
36
Artek Ada v125/SAMPLE1.ADA
Normal file
@ -0,0 +1,36 @@
|
||||
-- SAMPLE1.ADA uses the standard package TEXT_IO
|
||||
|
||||
with TEXT_IO; use TEXT_IO;
|
||||
|
||||
procedure SAMPLE1 is
|
||||
|
||||
package INTIO is new INTEGER_IO (INTEGER);
|
||||
|
||||
F : FILE_TYPE;
|
||||
|
||||
begin
|
||||
NEW_LINE (3);
|
||||
PUT_LINE ("This is a string output to the standard file CON.");
|
||||
NEW_LINE; -- No parameter means default file and default number of lines
|
||||
PUT ("Following this string is an integer => ");
|
||||
INTIO . PUT (100); -- default width and base
|
||||
NEW_LINE;
|
||||
PUT ("... and the same integer in base 2 => ");
|
||||
INTIO . PUT (100, 10, 2); -- width 10 and base 2
|
||||
NEW_LINE (2);
|
||||
PUT_LINE ("Creating the file TEMP.TMP on default drive and directory.");
|
||||
CREATE (F, OUT_FILE, "TEMP.TMP"); -- No FORM
|
||||
for I in 1..15 loop
|
||||
PUT (F, "Line ");
|
||||
INTIO . PUT (F, I, 3);
|
||||
NEW_LINE (F);
|
||||
end loop;
|
||||
NEW_LINE;
|
||||
PUT_LINE ("The creation of TEMP.TMP was successful.");
|
||||
NEW_LINE (2);
|
||||
exception
|
||||
when NAME_ERROR =>
|
||||
PUT_LINE ("This is an exception handler for NAME_ERROR.");
|
||||
end SAMPLE1;
|
||||
|
||||
|
||||
34
Artek Ada v125/SAMPLE10.ADA
Normal file
34
Artek Ada v125/SAMPLE10.ADA
Normal file
@ -0,0 +1,34 @@
|
||||
|
||||
with TEXT_IO; use TEXT_IO;
|
||||
|
||||
procedure SAMPLE10 is
|
||||
|
||||
package INTIO is new INTEGER_IO (INTEGER);
|
||||
|
||||
type BYTE is array (0..7) of BOOLEAN;
|
||||
|
||||
A, B, C : BYTE;
|
||||
|
||||
procedure PUT (B : in BYTE) is
|
||||
|
||||
begin
|
||||
for I in B'RANGE loop
|
||||
INTIO . PUT (INTEGER (B (I)), WIDTH => 1);
|
||||
end loop;
|
||||
NEW_LINE;
|
||||
end PUT;
|
||||
|
||||
begin
|
||||
PUT_LINE ("Boolean array operator test");
|
||||
A := (FALSE, TRUE, FALSE, TRUE, FALSE, TRUE, FALSE, TRUE);
|
||||
B := (TRUE, FALSE, TRUE, FALSE, TRUE, FALSE, TRUE, FALSE);
|
||||
PUT (A);
|
||||
PUT (B);
|
||||
PUT (A and B);
|
||||
PUT (A or B);
|
||||
PUT (A xor B);
|
||||
PUT (not A);
|
||||
PUT (not B);
|
||||
end SAMPLE10;
|
||||
|
||||
|
||||
40
Artek Ada v125/SAMPLE11.ADA
Normal file
40
Artek Ada v125/SAMPLE11.ADA
Normal file
@ -0,0 +1,40 @@
|
||||
with UNCHECKED_CONVERSION, TEXT_IO;
|
||||
use TEXT_IO;
|
||||
procedure SAMPLE11 is -- UNCHECKED_CONVERSION demonstration
|
||||
|
||||
type FLOAT_INTERNAL is array (0..7) of CHARACTER;
|
||||
|
||||
PI : constant FLOAT := 3.1415_92653_58979_32384_62643_38327_95029;
|
||||
|
||||
INTERNAL_PI : FLOAT_INTERNAL;
|
||||
HEXSTRING : STRING (1..7); -- Room for [sign]16#FF#
|
||||
|
||||
package INTIO is new INTEGER_IO (INTEGER); use INTIO;
|
||||
|
||||
function FLOAT_TO_INTERNAL is
|
||||
new UNCHECKED_CONVERSION (SOURCE => FLOAT, TARGET => FLOAT_INTERNAL);
|
||||
|
||||
function HEX (N : in INTEGER) return STRING is
|
||||
HEXDIGIT : constant STRING := "0123456789ABCDEF";
|
||||
begin -- N must be smaller than 16
|
||||
return (1 => HEXDIGIT (N / 16 + 1), 2 => HEXDIGIT (N mod 16 + 1));
|
||||
end HEX;
|
||||
|
||||
begin
|
||||
PUT_LINE ("This program shows how PI is represented internally in the IEEE 64-bit format.");
|
||||
NEW_LINE;
|
||||
INTERNAL_PI := FLOAT_TO_INTERNAL (PI);
|
||||
PUT ("Byte number : ");
|
||||
for I in INTERNAL_PI'RANGE loop
|
||||
PUT (I, WIDTH => 3);
|
||||
end loop;
|
||||
NEW_LINE;
|
||||
PUT ("Contents (hex) : ");
|
||||
for I in INTERNAL_PI'RANGE loop
|
||||
PUT (' ' & HEX (CHARACTER'POS (INTERNAL_PI (I))));
|
||||
end loop;
|
||||
NEW_LINE;
|
||||
PUT_LINE ("End of program.");
|
||||
end SAMPLE11;
|
||||
|
||||
|
||||
68
Artek Ada v125/SAMPLE12.ADA
Normal file
68
Artek Ada v125/SAMPLE12.ADA
Normal file
@ -0,0 +1,68 @@
|
||||
|
||||
--
|
||||
-- ENUMERATION_IO demo
|
||||
--
|
||||
-- This program may require more than 384 Kb of RAM memory to compile,
|
||||
-- depending on your hardware. (The twin instantiations below are
|
||||
-- memory-hungry while they're being processed.) If you have problems,
|
||||
-- de-install all RAM-resident software and try again.
|
||||
--
|
||||
|
||||
with IO_EXCEPTIONS, TEXT_IO;
|
||||
use TEXT_IO;
|
||||
|
||||
procedure SAMPLE12 is
|
||||
|
||||
type COLORS is (BLACK, BLUE, BROWN, GREEN, RED, WHITE, YELLOW);
|
||||
type INVENTORY is array (COLORS) of INTEGER;
|
||||
|
||||
package EIO is new ENUMERATION_IO (COLORS); use EIO;
|
||||
package INTIO is new INTEGER_IO (INTEGER); use INTIO;
|
||||
|
||||
INV : INVENTORY := (others => 20); -- Initial stock is 20 of each
|
||||
WHICH_COLOR : COLORS;
|
||||
HOW_MANY : INTEGER;
|
||||
|
||||
begin
|
||||
PUT_LINE ("Inventory control program");
|
||||
loop
|
||||
PUT_LINE ("The current inventory is as follows:");
|
||||
for I in COLORS loop
|
||||
PUT (I, WIDTH => 8);
|
||||
end loop;
|
||||
NEW_LINE;
|
||||
for I in COLORS loop
|
||||
PUT (INV (I), WIDTH => 8);
|
||||
end loop;
|
||||
NEW_LINE;
|
||||
loop
|
||||
begin
|
||||
PUT ("How many items (0 to exit) => ");
|
||||
GET (HOW_MANY);
|
||||
exit; -- Exit from loop if no exception
|
||||
exception
|
||||
when DATA_ERROR =>
|
||||
NEW_LINE;
|
||||
PUT_LINE ("Illegal integer. Please reenter.");
|
||||
end;
|
||||
end loop;
|
||||
NEW_LINE;
|
||||
exit when HOW_MANY = 0;
|
||||
loop
|
||||
begin
|
||||
PUT ("Which color do you want to sell/buy => ");
|
||||
GET (WHICH_COLOR);
|
||||
exit; -- Exit from loop if no exception
|
||||
exception
|
||||
when DATA_ERROR =>
|
||||
NEW_LINE;
|
||||
PUT_LINE ("Illegal color. Please reenter.");
|
||||
end;
|
||||
end loop;
|
||||
NEW_LINE;
|
||||
INV (WHICH_COLOR) := INV (WHICH_COLOR) - HOW_MANY;
|
||||
end loop;
|
||||
PUT_LINE ("End of program. Have a nice day.");
|
||||
end SAMPLE12;
|
||||
|
||||
|
||||
40
Artek Ada v125/SAMPLE2.ADA
Normal file
40
Artek Ada v125/SAMPLE2.ADA
Normal file
@ -0,0 +1,40 @@
|
||||
-- SAMPLE2.ADA Packages
|
||||
|
||||
package SAMPLE2_PACK is -- Following is the specification of the package
|
||||
|
||||
type T is limited private;
|
||||
|
||||
procedure PROC1 (I : in INTEGER := 1);
|
||||
procedure PROC2 (TEMP : out T);
|
||||
|
||||
private
|
||||
type T is range 1..10;
|
||||
end SAMPLE2_PACK;
|
||||
|
||||
with TEXT_IO; use TEXT_IO;
|
||||
|
||||
package body SAMPLE2_PACK is -- Following is the implementation of the package
|
||||
|
||||
procedure PROC1 (I : in INTEGER := 1) is
|
||||
begin
|
||||
PUT (INTEGER'IMAGE (I));
|
||||
end PROC1;
|
||||
|
||||
procedure PROC2 (TEMP : out T) is
|
||||
begin
|
||||
TEMP := 2;
|
||||
end PROC2;
|
||||
|
||||
end SAMPLE2_PACK;
|
||||
|
||||
with TEXT_IO, SAMPLE2_PACK; use TEXT_IO, SAMPLE2_PACK;
|
||||
|
||||
procedure SAMPLE2 is -- Following is a program that uses the package
|
||||
S : T;
|
||||
begin
|
||||
PROC1; -- Default parameter
|
||||
PROC2 (S);
|
||||
-- PUT (S); -- Error because S is limited private
|
||||
end SAMPLE2;
|
||||
|
||||
|
||||
35
Artek Ada v125/SAMPLE3.ADA
Normal file
35
Artek Ada v125/SAMPLE3.ADA
Normal file
@ -0,0 +1,35 @@
|
||||
-- SAMPLE3.ADA Overloading
|
||||
|
||||
with TEXT_IO; use TEXT_IO;
|
||||
|
||||
procedure SAMPLE3 is
|
||||
|
||||
procedure NAME (I : in INTEGER) is
|
||||
|
||||
begin
|
||||
PUT_LINE ("Following is an integer => " & INTEGER'IMAGE (I));
|
||||
NEW_LINE (2);
|
||||
end NAME;
|
||||
|
||||
procedure NAME (I : in STRING) is
|
||||
|
||||
begin
|
||||
PUT_LINE ("Following is a string => " & I);
|
||||
NEW_LINE (2);
|
||||
end NAME;
|
||||
|
||||
procedure NAME (I : in CHARACTER) is
|
||||
|
||||
begin
|
||||
PUT_LINE ("Following is a character => " & I);
|
||||
NEW_LINE (2);
|
||||
end NAME;
|
||||
|
||||
begin
|
||||
NEW_LINE (2);
|
||||
NAME ('A'); -- NAME with character parameter
|
||||
NAME ("This is a string"); -- NAME with string parameter
|
||||
NAME (100); -- NAME with integer parameter
|
||||
end SAMPLE3;
|
||||
|
||||
|
||||
23
Artek Ada v125/SAMPLE4.ADA
Normal file
23
Artek Ada v125/SAMPLE4.ADA
Normal file
@ -0,0 +1,23 @@
|
||||
-- SAMPLE4.ADA Strings
|
||||
|
||||
with TEXT_IO; use TEXT_IO;
|
||||
|
||||
procedure SAMPLE4 is
|
||||
|
||||
CONST : constant STRING (1..5) := "Artek";
|
||||
|
||||
subtype STR10 is STRING (1..10);
|
||||
|
||||
S4 : STRING (1..4) := " Ada";
|
||||
S10 : STR10 := ('C', 'o', 'm', 'p', 'i', 'l', 'e', 'r', others => ' ');
|
||||
S20 : STRING (1..21) := (others => ' ');
|
||||
|
||||
begin
|
||||
S20 (S20'FIRST .. CONST'LAST) := CONST;
|
||||
S20 (CONST'LAST + 1 .. CONST'LAST + S4'LAST + S10'LAST + 1) :=
|
||||
S4 & " " & S10;
|
||||
NEW_LINE (2);
|
||||
PUT_LINE (S20);
|
||||
end SAMPLE4;
|
||||
|
||||
|
||||
25
Artek Ada v125/SAMPLE5.ADA
Normal file
25
Artek Ada v125/SAMPLE5.ADA
Normal file
@ -0,0 +1,25 @@
|
||||
-- SAMPLE5.ADA Array and record aggregates
|
||||
|
||||
procedure SAMPLE5 is
|
||||
|
||||
CONST : constant STRING (1..10) := "1234567890";
|
||||
|
||||
type TEMP_TYPE is
|
||||
record
|
||||
FIELD1 : INTEGER;
|
||||
FIELD2 : CHARACTER;
|
||||
FIELD3 : STRING (1..10) := ('H', 'e', 'l', 'l', 'o', others => ' ');
|
||||
end record;
|
||||
|
||||
type TABLE is array (1..10) of INTEGER;
|
||||
|
||||
TEMP : TEMP_TYPE;
|
||||
TEMP_STR : TABLE := (2 | 4 | 10 => 1, others => 0);
|
||||
|
||||
-- TEMP_STR now contains 0 1 0 1 0 0 0 0 0 1
|
||||
|
||||
begin
|
||||
TEMP := (FIELD1 => 35, FIELD2 => 'Y', FIELD3 => CONST);
|
||||
end SAMPLE5;
|
||||
|
||||
|
||||
31
Artek Ada v125/SAMPLE6.ADA
Normal file
31
Artek Ada v125/SAMPLE6.ADA
Normal file
@ -0,0 +1,31 @@
|
||||
-- SAMPLE6.ADA Derived types
|
||||
|
||||
with TEXT_IO; use TEXT_IO;
|
||||
|
||||
procedure SAMPLE6 is
|
||||
|
||||
type DOLLAR_TYPE is new INTEGER;
|
||||
type POUND_TYPE is new INTEGER;
|
||||
|
||||
A, B : INTEGER := 2;
|
||||
D1, D2 : DOLLAR_TYPE := 4; -- Unique integer type
|
||||
P1, P2 : POUND_TYPE := 8; -- Unique integer type
|
||||
|
||||
function "*" (X, Y : DOLLAR_TYPE) return DOLLAR_TYPE is
|
||||
|
||||
-- Multiply dollars only
|
||||
|
||||
begin
|
||||
PUT_LINE ("Multiplying two DOLLAR variables");
|
||||
return DOLLAR_TYPE (INTEGER (X) * INTEGER (Y)); -- Prevent recursion
|
||||
end;
|
||||
|
||||
begin
|
||||
NEW_LINE (2);
|
||||
P1 := P1 * P2;
|
||||
D1 := D1 * D2;
|
||||
-- A := B + D1; -- Illegal
|
||||
-- D2 := D1 - P1; -- Illegal
|
||||
-- P2 := A; -- Illegal
|
||||
end SAMPLE6;
|
||||
|
||||
40
Artek Ada v125/SAMPLE7.ADA
Normal file
40
Artek Ada v125/SAMPLE7.ADA
Normal file
@ -0,0 +1,40 @@
|
||||
-- SAMPLE7.ADA Generic subprogram
|
||||
with TEXT_IO; use TEXT_IO;
|
||||
|
||||
procedure SAMPLE7 is
|
||||
|
||||
package INTIO is new INTEGER_IO (INTEGER);
|
||||
|
||||
generic
|
||||
type ITEM is private;
|
||||
procedure SWAP (X, Y : in out ITEM);
|
||||
|
||||
subtype STRING5 is STRING (1..5);
|
||||
I1 : INTEGER := 0;
|
||||
I2 : INTEGER := 4;
|
||||
C1 : CHARACTER := 'A';
|
||||
C2 : CHARACTER := 'B';
|
||||
S1 : STRING5 := "Artek";
|
||||
S2 : STRING5 := "abcde";
|
||||
|
||||
procedure SWAP (X, Y : in out ITEM) is
|
||||
Z : ITEM;
|
||||
begin
|
||||
Z := X;
|
||||
X := Y;
|
||||
Y := Z;
|
||||
end SWAP;
|
||||
procedure SWAP_INT is new SWAP (ITEM => INTEGER);
|
||||
procedure SWAP_CHR is new SWAP (ITEM => CHARACTER);
|
||||
procedure SWAP_STR is new SWAP (ITEM => STRING5);
|
||||
begin
|
||||
NEW_LINE (2);
|
||||
PUT ("Before => "); INTIO . PUT (I1); INTIO . PUT (I2);
|
||||
SWAP_INT (I1, I2); PUT (" After => "); INTIO . PUT (I1); INTIO . PUT (I2); NEW_LINE (2);
|
||||
PUT ("Before => "); PUT (C1); PUT (C2);
|
||||
SWAP_CHR (C1, C2); PUT (" After => "); PUT (C1); PUT (C2); NEW_LINE (2);
|
||||
PUT ("Before => "); PUT (S1); PUT (S2);
|
||||
SWAP_STR (S1, S2); PUT (" After => "); PUT (S1); PUT (S2); NEW_LINE (2);
|
||||
end SAMPLE7;
|
||||
|
||||
|
||||
33
Artek Ada v125/SAMPLE8.ADA
Normal file
33
Artek Ada v125/SAMPLE8.ADA
Normal file
@ -0,0 +1,33 @@
|
||||
-- SAMPLE8.ADA Dynamic arrays
|
||||
|
||||
with TEXT_IO; use TEXT_IO;
|
||||
|
||||
procedure SAMPLE8 is
|
||||
|
||||
subtype INDEX is INTEGER range 1..10;
|
||||
type ARRAY1_TYPE is array (INDEX range <>) of CHARACTER;
|
||||
subtype T is ARRAY1_TYPE (INDEX);
|
||||
type ARRAY2_TYPE is array (INTEGER range <>, INTEGER range <>) of INTEGER;
|
||||
|
||||
ARR1 : ARRAY1_TYPE (5..8);
|
||||
ARR2 : ARRAY2_TYPE (0..1, 0..5);
|
||||
CH : CHARACTER := 'A';
|
||||
|
||||
begin
|
||||
NEW_LINE (2);
|
||||
for I in ARR1'RANGE loop
|
||||
ARR1 (I) := CH;
|
||||
PUT (ARR1 (I));
|
||||
CH := CHARACTER'SUCC (CH);
|
||||
end loop;
|
||||
NEW_LINE (2);
|
||||
for I in 0..1 loop
|
||||
for J in 0..5 loop
|
||||
ARR2 (I, J) := J;
|
||||
PUT (INTEGER'IMAGE (ARR2 (I, J)));
|
||||
end loop;
|
||||
NEW_LINE;
|
||||
end loop;
|
||||
end SAMPLE8;
|
||||
|
||||
|
||||
40
Artek Ada v125/SAMPLE9.ADA
Normal file
40
Artek Ada v125/SAMPLE9.ADA
Normal file
@ -0,0 +1,40 @@
|
||||
-- SAMPLE9.ADA Use of DOS_INTERFACE
|
||||
|
||||
with DOS_INTERFACE; use DOS_INTERFACE;
|
||||
|
||||
procedure SAMPLE9 is
|
||||
|
||||
R : REG_8086; -- 8086 registers to use for DOS calls
|
||||
|
||||
procedure VERIFY_ON is
|
||||
|
||||
begin
|
||||
R . AX := 16#2E01#; -- AH = function call 2E (Set/reset verify switch)
|
||||
-- AL = 01 verify on, AL = 00 verify off
|
||||
R . DX := 16#0000#; -- DL must be 0 for this function call
|
||||
CALL_DOS (R);
|
||||
if abs R . FLAGS mod 2 = 1 then -- Carry was set, there is some error
|
||||
null; -- Error handling
|
||||
end if;
|
||||
end VERIFY_ON;
|
||||
|
||||
procedure DELETE_FILE (F : in STRING) is
|
||||
|
||||
begin
|
||||
R . AX := 16#4100#; -- Function call 41 (Delete file)
|
||||
R . DX := WORD (F'ADDRESS);
|
||||
CALL_DOS (R);
|
||||
if abs R . FLAGS mod 2 = 1 then -- Carry set, error
|
||||
if R . AX = 2 then
|
||||
null; -- Error handling for file not found
|
||||
else
|
||||
null; -- Error handling for access error
|
||||
end if;
|
||||
end if;
|
||||
end DELETE_FILE;
|
||||
|
||||
begin
|
||||
VERIFY_ON;
|
||||
DELETE_FILE ("TEMP.TMP" & ASCII.NUL); -- Must be zero-terminated
|
||||
end SAMPLE9;
|
||||
|
||||
327
Artek Ada v125/SEQIOB.ADA
Normal file
327
Artek Ada v125/SEQIOB.ADA
Normal file
@ -0,0 +1,327 @@
|
||||
--
|
||||
-- S E Q U E N T I A L I N P U T / O U T P U T
|
||||
--
|
||||
-- Body of the Package Sequential_IO
|
||||
--
|
||||
-- According to ANSI/MIL-STD 1815A (1983)
|
||||
-- Implemented for Artek Ada
|
||||
--
|
||||
-- Copyright (C) 1986 Artek Corporation
|
||||
-- Author : O. Karlsson
|
||||
--
|
||||
--
|
||||
-- Version: 1.00
|
||||
--
|
||||
|
||||
with DOS_INTERFACE, SYSTEM;
|
||||
|
||||
package body SEQUENTIAL_IO is
|
||||
|
||||
use DOS_INTERFACE, SYSTEM, ASCII;
|
||||
|
||||
EOF : constant CHARACTER := CHARACTER (26);
|
||||
|
||||
R : REG_8086;
|
||||
|
||||
--
|
||||
-- Utility procedure to skip last character read from a file
|
||||
-- Same as " lseek (file, -1) " relative from the file position
|
||||
--
|
||||
|
||||
procedure UNGET (FILE : in FILE_TYPE) is
|
||||
|
||||
begin
|
||||
-- This procedure is only used internally and
|
||||
-- the file is always open
|
||||
R . AX := 16#4201#; -- DOS function 42, lseek
|
||||
R . BX := WORD (FILE . HANDLE);
|
||||
R . CX := -1; -- Desired location from current position
|
||||
R . DX := -1;
|
||||
CALL_DOS (R);
|
||||
if R . FLAGS mod 2 = 1 then -- Carry was set
|
||||
raise USE_ERROR; -- There should never be error here
|
||||
end if;
|
||||
end UNGET;
|
||||
|
||||
--
|
||||
-- File management
|
||||
--
|
||||
|
||||
procedure CREATE (
|
||||
FILE : in out FILE_TYPE;
|
||||
MODE : in FILE_MODE := OUT_FILE;
|
||||
NAME : in STRING := "";
|
||||
FORM : in STRING := "") is
|
||||
|
||||
ASCIIZ_NAME : FILE_NAME_STRING;
|
||||
BLANK_NAME : FILE_NAME_STRING := (others => ' ');
|
||||
BLANK_FORM : FORM_NAME_STRING := (others => ' ');
|
||||
|
||||
-- See chapter 14.2.1
|
||||
|
||||
begin -- Concatenate a null character
|
||||
if FILE . IS_OPEN then
|
||||
raise STATUS_ERROR;
|
||||
end if;
|
||||
ASCIIZ_NAME (1..NAME'LENGTH) := NAME;
|
||||
ASCIIZ_NAME (NAME'LENGTH + 1) := NUL;
|
||||
R . AX := 16#3C00#; -- Function 3C, Create a file
|
||||
R . DX := WORD (ASCIIZ_NAME'ADDRESS); -- Address of the filename
|
||||
R . CX := 16#0000#; -- No attributes
|
||||
CALL_DOS (R);
|
||||
if abs R . FLAGS mod 2 = 1 then -- Carry was set
|
||||
if R . AX > 3 then -- 4 = Too many open files, 5 = access denied
|
||||
raise USE_ERROR;
|
||||
else
|
||||
raise NAME_ERROR; -- 3 = Path not found
|
||||
end if;
|
||||
end if;
|
||||
FILE :=
|
||||
(NAMELEN => NAME'LENGTH, NAME => BLANK_NAME,
|
||||
FORMLEN => FORM'LENGTH, FORM => BLANK_FORM,
|
||||
MODE => MODE, IS_OPEN => TRUE,
|
||||
HANDLE => INTEGER (R . AX));
|
||||
FILE . NAME (1..NAME'LENGTH) := NAME;
|
||||
FILE . NAME (1..FORM'LENGTH) := FORM;
|
||||
end CREATE;
|
||||
|
||||
procedure OPEN (
|
||||
FILE : in out FILE_TYPE;
|
||||
MODE : in FILE_MODE;
|
||||
NAME : in STRING;
|
||||
FORM : in STRING := "") is
|
||||
|
||||
ASCIIZ_NAME : FILE_NAME_STRING;
|
||||
BLANK_NAME : FILE_NAME_STRING := (others => ' ');
|
||||
BLANK_FORM : FORM_NAME_STRING := (others => ' ');
|
||||
|
||||
-- See chapter 14.2.1
|
||||
|
||||
begin
|
||||
if FILE . IS_OPEN then
|
||||
raise STATUS_ERROR;
|
||||
end if;
|
||||
ASCIIZ_NAME (1..NAME'LENGTH) := NAME;
|
||||
ASCIIZ_NAME (NAME'LENGTH + 1) := NUL;
|
||||
case MODE is
|
||||
when IN_FILE => R . AX := 16#3D00#; -- AH = 3D, Open a file
|
||||
when OUT_FILE => R . AX := 16#3D01#; -- AL = 00, Open for input
|
||||
end case; -- AL = 01, Open for output
|
||||
R . DX := WORD (ASCIIZ_NAME'ADDRESS);
|
||||
CALL_DOS (R);
|
||||
if abs R . FLAGS mod 2 = 1 then -- Carry was set
|
||||
if R . AX > 3 then
|
||||
raise USE_ERROR; -- Access denied or to many files open
|
||||
else
|
||||
raise NAME_ERROR; -- File not found
|
||||
end if;
|
||||
end if;
|
||||
FILE :=
|
||||
(NAMELEN => NAME'LENGTH, NAME => BLANK_NAME,
|
||||
FORMLEN => FORM'LENGTH, FORM => BLANK_FORM,
|
||||
MODE => MODE, IS_OPEN => TRUE,
|
||||
HANDLE => INTEGER (R . AX));
|
||||
FILE . NAME (1..NAME'LENGTH) := NAME;
|
||||
FILE . NAME (1..FORM'LENGTH) := FORM;
|
||||
end OPEN;
|
||||
|
||||
procedure CLOSE (FILE : in out FILE_TYPE) is
|
||||
|
||||
-- See chapter 14.2.1
|
||||
|
||||
CH : CHARACTER := EOF;
|
||||
|
||||
begin
|
||||
if not FILE . IS_OPEN then
|
||||
raise STATUS_ERROR;
|
||||
end if;
|
||||
if FILE . MODE = OUT_FILE then -- Put EOF at end of file
|
||||
R . AX := 16#4000#; -- DOS function 40, write to a file or device
|
||||
R . BX := WORD (FILE . HANDLE); -- The file handle
|
||||
R . CX := 1; -- Write one byte
|
||||
R . DX := WORD (CH'ADDRESS);
|
||||
CALL_DOS (R);
|
||||
if R . AX = 0 then -- No output made, probably disk full error
|
||||
raise USE_ERROR;
|
||||
end if;
|
||||
if abs R . FLAGS mod 2 = 1 then -- Carry set
|
||||
raise USE_ERROR; -- Access denied or invalid file handle
|
||||
end if;
|
||||
end if;
|
||||
R . AX := 16#3E00#; -- DOS function 3E, Close a file handle
|
||||
R . BX := WORD (FILE . HANDLE);
|
||||
CALL_DOS (R);
|
||||
if abs R . FLAGS mod 2 = 1 then -- Carry was set
|
||||
raise USE_ERROR; -- Invalid handle. This error should never
|
||||
end if; -- occur. Something is wrong in the file system.
|
||||
FILE . IS_OPEN := FALSE;
|
||||
end CLOSE;
|
||||
|
||||
procedure DELETE (FILE : in out FILE_TYPE) is
|
||||
|
||||
ASCIIZ_NAME : FILE_NAME_STRING;
|
||||
|
||||
-- See chapter 14.2.1
|
||||
|
||||
begin
|
||||
CLOSE (FILE);
|
||||
ASCIIZ_NAME (1..FILE . NAMELEN) := FILE . NAME (1..FILE . NAMELEN);
|
||||
ASCIIZ_NAME (FILE . NAMELEN + 1) := NUL;
|
||||
R . AX := 16#4100#; -- DOS function 41, delete a file
|
||||
R . DX := WORD (ASCIIZ_NAME'ADDRESS);
|
||||
CALL_DOS (R);
|
||||
if abs R . FLAGS mod 2 = 1 then -- Carry was set
|
||||
raise USE_ERROR; -- Access denied
|
||||
end if;
|
||||
end DELETE;
|
||||
|
||||
procedure RESET (FILE : in out FILE_TYPE; MODE : in FILE_MODE) is
|
||||
|
||||
-- See chapter 14.2.1
|
||||
|
||||
begin
|
||||
CLOSE (FILE); -- Must close and reopen since MODE changes
|
||||
OPEN (FILE, MODE, FILE . NAME, FILE . FORM);
|
||||
end RESET;
|
||||
|
||||
procedure RESET (FILE : in out FILE_TYPE) is
|
||||
|
||||
-- See chapter 14.2.1
|
||||
|
||||
begin
|
||||
if not FILE . IS_OPEN then
|
||||
raise STATUS_ERROR;
|
||||
end if;
|
||||
-- Do an LSEEK (FILE, 0);
|
||||
R . AX := 16#4200#; -- DOS function 42, lseek
|
||||
R . BX := WORD (FILE . HANDLE); -- File handle
|
||||
R . CX := 0; -- Desired location from BOF
|
||||
R . DX := 0;
|
||||
CALL_DOS (R);
|
||||
if abs R . FLAGS mod 2 = 1 then -- Carry was set
|
||||
raise USE_ERROR;
|
||||
end if;
|
||||
end RESET;
|
||||
|
||||
function MODE (FILE : in FILE_TYPE) return FILE_MODE is
|
||||
|
||||
-- See chapter 14.2.1
|
||||
|
||||
begin
|
||||
if not FILE . IS_OPEN then
|
||||
raise STATUS_ERROR;
|
||||
end if;
|
||||
return FILE . MODE;
|
||||
end MODE;
|
||||
|
||||
function NAME (FILE : in FILE_TYPE) return STRING is
|
||||
|
||||
-- See chapter 14.2.1
|
||||
|
||||
begin
|
||||
if not FILE . IS_OPEN then
|
||||
raise STATUS_ERROR;
|
||||
end if;
|
||||
return FILE . NAME;
|
||||
end NAME;
|
||||
|
||||
function FORM (FILE : in FILE_TYPE) return STRING is
|
||||
|
||||
-- See chapter 14.2.1
|
||||
|
||||
begin
|
||||
if not FILE . IS_OPEN then
|
||||
raise STATUS_ERROR;
|
||||
end if;
|
||||
return FILE . FORM;
|
||||
end FORM;
|
||||
|
||||
function IS_OPEN (FILE : in FILE_TYPE) return BOOLEAN is
|
||||
|
||||
-- See chapter 14.2.1
|
||||
|
||||
begin
|
||||
return FILE . IS_OPEN;
|
||||
end IS_OPEN;
|
||||
|
||||
--
|
||||
-- Input and output operations
|
||||
--
|
||||
|
||||
procedure READ (FILE : in FILE_TYPE; ITEM : out ELEMENT_TYPE) is
|
||||
|
||||
-- See chapter 14.2.2
|
||||
|
||||
begin
|
||||
if not FILE . IS_OPEN then
|
||||
raise STATUS_ERROR;
|
||||
elsif FILE . MODE /= IN_FILE then
|
||||
raise MODE_ERROR;
|
||||
end if;
|
||||
R . AX := 16#3F00#; -- DOS function 3F, read from a file or device
|
||||
R . BX := WORD (FILE . HANDLE); -- The file handle
|
||||
R . CX := WORD (ELEMENT_TYPE'SIZE / STORAGE_UNIT);
|
||||
R . DX := WORD (ITEM'ADDRESS); -- Address of ITEM
|
||||
CALL_DOS (R);
|
||||
if R . AX = 0 then -- Read past EOF
|
||||
raise END_ERROR;
|
||||
end if;
|
||||
if abs R . FLAGS mod 2 = 1 then -- Carry set
|
||||
raise USE_ERROR; -- Access denied or invalid file handle
|
||||
end if;
|
||||
end READ;
|
||||
|
||||
procedure WRITE (FILE : in FILE_TYPE; ITEM : in ELEMENT_TYPE) is
|
||||
|
||||
-- See chapter 14.2.2
|
||||
|
||||
begin
|
||||
if not FILE . IS_OPEN then
|
||||
raise STATUS_ERROR;
|
||||
elsif FILE . MODE /= OUT_FILE then
|
||||
raise MODE_ERROR;
|
||||
end if;
|
||||
R . AX := 16#4000#; -- DOS function 40, write to a file or device
|
||||
R . BX := WORD (FILE . HANDLE); -- The file handle
|
||||
R . CX := WORD (ELEMENT_TYPE'SIZE / STORAGE_UNIT);
|
||||
R . DX := WORD (ITEM'ADDRESS); -- Address of ITEM
|
||||
CALL_DOS (R);
|
||||
if R . AX = 0 then -- No output made, probably disk full error
|
||||
raise USE_ERROR;
|
||||
end if;
|
||||
if abs R . FLAGS mod 2 = 1 then -- Carry set
|
||||
raise USE_ERROR; -- Access denied or invalid file handle
|
||||
end if;
|
||||
end WRITE;
|
||||
|
||||
function END_OF_FILE (FILE : in FILE_TYPE) return BOOLEAN is
|
||||
|
||||
CH : CHARACTER;
|
||||
|
||||
-- See chapter 14.2.2
|
||||
|
||||
begin
|
||||
if not FILE . IS_OPEN then
|
||||
raise STATUS_ERROR;
|
||||
elsif FILE . MODE /= IN_FILE then
|
||||
raise MODE_ERROR;
|
||||
end if;
|
||||
R . AX := 16#3F00#; -- DOS function 3F, read from a file or device
|
||||
R . BX := WORD (FILE . HANDLE); -- The file handle
|
||||
R . CX := 1; -- Read one byte
|
||||
R . DX := WORD (CH'ADDRESS);
|
||||
CALL_DOS (R);
|
||||
if R . AX = 0 then -- Read past EOF
|
||||
UNGET (FILE);
|
||||
return TRUE;
|
||||
end if;
|
||||
if abs R . FLAGS mod 2 = 1 then -- Carry set
|
||||
raise USE_ERROR; -- Access denied or invalid file handle
|
||||
end if;
|
||||
UNGET (FILE);
|
||||
return CH = EOF;
|
||||
end END_OF_FILE;
|
||||
|
||||
end SEQUENTIAL_IO;
|
||||
|
||||
|
||||
86
Artek Ada v125/SEQIOS.ADA
Normal file
86
Artek Ada v125/SEQIOS.ADA
Normal file
@ -0,0 +1,86 @@
|
||||
--
|
||||
-- S E Q U E N T I A L I N P U T / O U T P U T
|
||||
--
|
||||
-- Specification of the Package Sequential_IO
|
||||
--
|
||||
-- Copyright (C) 1986 Artek Corporation
|
||||
--
|
||||
|
||||
with IO_EXCEPTIONS;
|
||||
|
||||
generic
|
||||
|
||||
type ELEMENT_TYPE is private;
|
||||
|
||||
package SEQUENTIAL_IO is
|
||||
|
||||
type FILE_TYPE is limited private;
|
||||
|
||||
type FILE_MODE is (IN_FILE, OUT_FILE);
|
||||
|
||||
-- File Management
|
||||
|
||||
procedure CREATE (FILE : in out FILE_TYPE;
|
||||
MODE : in FILE_MODE := OUT_FILE;
|
||||
NAME : in STRING := "";
|
||||
FORM : in STRING := "");
|
||||
|
||||
procedure OPEN (FILE : in out FILE_TYPE;
|
||||
MODE : in FILE_MODE;
|
||||
NAME : in STRING;
|
||||
FORM : in STRING := "");
|
||||
|
||||
procedure CLOSE (FILE : in out FILE_TYPE);
|
||||
procedure DELETE (FILE : in out FILE_TYPE);
|
||||
procedure RESET (FILE : in out FILE_TYPE; MODE : in FILE_MODE);
|
||||
procedure RESET (FILE : in out FILE_TYPE);
|
||||
|
||||
|
||||
function MODE (FILE : in FILE_TYPE) return FILE_MODE;
|
||||
function NAME (FILE : in FILE_TYPE) return STRING;
|
||||
function FORM (FILE : in FILE_TYPE) return STRING;
|
||||
|
||||
function IS_OPEN (FILE : in FILE_TYPE) return BOOLEAN;
|
||||
|
||||
-- Input and output operations
|
||||
|
||||
procedure READ (FILE : in FILE_TYPE; ITEM : out ELEMENT_TYPE);
|
||||
procedure WRITE (FILE : in FILE_TYPE; ITEM : in ELEMENT_TYPE);
|
||||
|
||||
function END_OF_FILE (FILE : in FILE_TYPE) return BOOLEAN;
|
||||
|
||||
-- Exceptions
|
||||
|
||||
STATUS_ERROR : exception renames IO_EXCEPTIONS.STATUS_ERROR;
|
||||
MODE_ERROR : exception renames IO_EXCEPTIONS.MODE_ERROR;
|
||||
NAME_ERROR : exception renames IO_EXCEPTIONS.NAME_ERROR;
|
||||
USE_ERROR : exception renames IO_EXCEPTIONS.USE_ERROR;
|
||||
DEVICE_ERROR : exception renames IO_EXCEPTIONS.DEVICE_ERROR;
|
||||
END_ERROR : exception renames IO_EXCEPTIONS.END_ERROR;
|
||||
DATA_ERROR : exception renames IO_EXCEPTIONS.DATA_ERROR;
|
||||
|
||||
private
|
||||
|
||||
MAX_NAME_LEN : constant := 32; -- Complete name with paths
|
||||
MAX_FORM_LEN : constant := 10; -- The form is not used in MS-DOS
|
||||
|
||||
subtype NAME_INDEX is INTEGER range 0..MAX_NAME_LEN;
|
||||
subtype FORM_INDEX is INTEGER range 0..MAX_FORM_LEN;
|
||||
|
||||
subtype FILE_NAME_STRING is STRING (1..MAX_NAME_LEN);
|
||||
subtype FORM_NAME_STRING is STRING (1..MAX_FORM_LEN);
|
||||
|
||||
type FILE_TYPE is
|
||||
record
|
||||
NAMELEN : NAME_INDEX;
|
||||
NAME : FILE_NAME_STRING;
|
||||
MODE : FILE_MODE;
|
||||
FORMLEN : FORM_INDEX;
|
||||
FORM : FORM_NAME_STRING;
|
||||
IS_OPEN : BOOLEAN := FALSE;
|
||||
HANDLE : INTEGER; -- DOS handle number, DOS 2 or later
|
||||
end record;
|
||||
|
||||
end SEQUENTIAL_IO;
|
||||
|
||||
|
||||
33
Artek Ada v125/SIEVE.ADA
Normal file
33
Artek Ada v125/SIEVE.ADA
Normal file
@ -0,0 +1,33 @@
|
||||
|
||||
with TEXT_IO; use TEXT_IO;
|
||||
|
||||
procedure SIEVE is
|
||||
|
||||
ITERATIONS : constant := 10;
|
||||
SIZE : constant := 8190; -- 1024;
|
||||
|
||||
type FLAG_TYPE is array (INTEGER range 0..SIZE) of BOOLEAN;
|
||||
|
||||
PRIME, K, COUNT : INTEGER;
|
||||
FLAGS : FLAG_TYPE;
|
||||
|
||||
begin
|
||||
PUT (INTEGER'IMAGE (ITERATIONS)); PUT_LINE (" iterations");
|
||||
for ITER in 1..ITERATIONS loop
|
||||
COUNT := 0;
|
||||
-- PUT ('.'); -- Should be commented out for accurate timing
|
||||
FLAGS := (others => TRUE);
|
||||
for I in FLAGS'RANGE loop
|
||||
if FLAGS (I) then
|
||||
PRIME := I + I + 3;
|
||||
K := I + PRIME;
|
||||
while K <= SIZE loop
|
||||
FLAGS (K) := FALSE;
|
||||
K := K + PRIME;
|
||||
end loop;
|
||||
COUNT := COUNT + 1;
|
||||
end if;
|
||||
end loop;
|
||||
end loop;
|
||||
PUT (INTEGER'IMAGE (COUNT)); PUT_LINE (" primes");
|
||||
end SIEVE;
|
||||
BIN
Artek Ada v125/SYSTEM.FIL
Normal file
BIN
Artek Ada v125/SYSTEM.FIL
Normal file
Binary file not shown.
2417
Artek Ada v125/TEXTIOB.ADA
Normal file
2417
Artek Ada v125/TEXTIOB.ADA
Normal file
File diff suppressed because it is too large
Load Diff
315
Artek Ada v125/TEXTIOS.ADA
Normal file
315
Artek Ada v125/TEXTIOS.ADA
Normal file
@ -0,0 +1,315 @@
|
||||
--
|
||||
-- T E X T I N P U T / O U T P U T
|
||||
--
|
||||
-- Specifications of the Package Text_IO
|
||||
--
|
||||
-- Text handling package for Artek Ada
|
||||
-- Copyright (C) 1986 by Artek Corporation
|
||||
--
|
||||
|
||||
with IO_EXCEPTIONS;
|
||||
|
||||
package TEXT_IO is
|
||||
|
||||
type FILE_TYPE is limited private;
|
||||
|
||||
type FILE_MODE is (IN_FILE, OUT_FILE);
|
||||
|
||||
type COUNT is range 0..INTEGER'LAST;
|
||||
subtype POSITIVE_COUNT is COUNT range 1..COUNT'LAST;
|
||||
UNBOUNDED : constant COUNT := 0;
|
||||
|
||||
subtype FIELD is INTEGER range 0..40;
|
||||
subtype NUMBER_BASE is INTEGER range 2..16;
|
||||
|
||||
type TYPE_SET is (LOWER_CASE, UPPER_CASE);
|
||||
|
||||
-- File Management
|
||||
|
||||
procedure CREATE (FILE : in out FILE_TYPE;
|
||||
MODE : in FILE_MODE := OUT_FILE;
|
||||
NAME : in STRING := "";
|
||||
FORM : in STRING := "");
|
||||
|
||||
procedure OPEN (FILE : in out FILE_TYPE;
|
||||
MODE : in FILE_MODE;
|
||||
NAME : in STRING;
|
||||
FORM : in STRING := "");
|
||||
|
||||
procedure CLOSE (FILE : in out FILE_TYPE);
|
||||
procedure DELETE (FILE : in out FILE_TYPE);
|
||||
procedure RESET (FILE : in out FILE_TYPE; MODE : in FILE_MODE);
|
||||
procedure RESET (FILE : in out FILE_TYPE);
|
||||
|
||||
function MODE (FILE : in FILE_TYPE) return FILE_MODE;
|
||||
function NAME (FILE : in FILE_TYPE) return STRING;
|
||||
function FORM (FILE : in FILE_TYPE) return STRING;
|
||||
|
||||
function IS_OPEN (FILE : in FILE_TYPE) return BOOLEAN;
|
||||
|
||||
-- Control of default input and output files
|
||||
|
||||
procedure SET_INPUT (FILE : in FILE_TYPE);
|
||||
procedure SET_OUTPUT (FILE : in FILE_TYPE);
|
||||
|
||||
function STANDARD_INPUT return FILE_TYPE;
|
||||
function STANDARD_OUTPUT return FILE_TYPE;
|
||||
|
||||
function CURRENT_INPUT return FILE_TYPE;
|
||||
function CURRENT_OUTPUT return FILE_TYPE;
|
||||
|
||||
-- Specifications of line and page lengths
|
||||
|
||||
procedure SET_LINE_LENGTH (FILE : in FILE_TYPE; TO : in COUNT);
|
||||
procedure SET_LINE_LENGTH (TO : in COUNT);
|
||||
|
||||
procedure SET_PAGE_LENGTH (FILE : in FILE_TYPE; TO : in COUNT);
|
||||
procedure SET_PAGE_LENGTH (TO : in COUNT);
|
||||
|
||||
function LINE_LENGTH (FILE : in FILE_TYPE) return COUNT;
|
||||
function LINE_LENGTH return COUNT;
|
||||
|
||||
function PAGE_LENGTH (FILE : in FILE_TYPE) return COUNT;
|
||||
function PAGE_LENGTH return COUNT;
|
||||
|
||||
-- Column, Line, and Page Control
|
||||
|
||||
procedure NEW_LINE (FILE : in FILE_TYPE; SPACING : in POSITIVE_COUNT := 1);
|
||||
procedure NEW_LINE (SPACING : in POSITIVE_COUNT := 1);
|
||||
|
||||
procedure SKIP_LINE (FILE : in FILE_TYPE; SPACING : in POSITIVE_COUNT := 1);
|
||||
procedure SKIP_LINE (SPACING : in POSITIVE_COUNT := 1);
|
||||
|
||||
function END_OF_LINE (FILE : in FILE_TYPE) return BOOLEAN;
|
||||
function END_OF_LINE return BOOLEAN;
|
||||
|
||||
procedure NEW_PAGE (FILE : in FILE_TYPE);
|
||||
procedure NEW_PAGE;
|
||||
|
||||
procedure SKIP_PAGE (FILE : in FILE_TYPE);
|
||||
procedure SKIP_PAGE;
|
||||
|
||||
function END_OF_PAGE (FILE : in FILE_TYPE) return BOOLEAN;
|
||||
function END_OF_PAGE return BOOLEAN;
|
||||
|
||||
function END_OF_FILE (FILE : in FILE_TYPE) return BOOLEAN;
|
||||
function END_OF_FILE return BOOLEAN;
|
||||
|
||||
procedure SET_COL (FILE : in FILE_TYPE; TO : in POSITIVE_COUNT);
|
||||
procedure SET_COL (TO : in POSITIVE_COUNT);
|
||||
|
||||
procedure SET_LINE (FILE : in FILE_TYPE; TO : in POSITIVE_COUNT);
|
||||
procedure SET_LINE (TO : in POSITIVE_COUNT);
|
||||
|
||||
function COL (FILE : in FILE_TYPE) return POSITIVE_COUNT;
|
||||
function COL return POSITIVE_COUNT;
|
||||
|
||||
function LINE (FILE : in FILE_TYPE) return POSITIVE_COUNT;
|
||||
function LINE return POSITIVE_COUNT;
|
||||
|
||||
function PAGE (FILE : in FILE_TYPE) return POSITIVE_COUNT;
|
||||
function PAGE return POSITIVE_COUNT;
|
||||
|
||||
-- Character Input-Output
|
||||
|
||||
procedure GET (FILE : in FILE_TYPE; ITEM : out CHARACTER);
|
||||
procedure GET (ITEM : out CHARACTER);
|
||||
|
||||
procedure PUT (FILE : in FILE_TYPE; ITEM : in CHARACTER);
|
||||
procedure PUT (ITEM : in CHARACTER);
|
||||
|
||||
-- String Input-Output
|
||||
|
||||
procedure GET (FILE : in FILE_TYPE; ITEM : out STRING);
|
||||
procedure GET (ITEM : out STRING);
|
||||
|
||||
procedure PUT (FILE : in FILE_TYPE; ITEM : in STRING);
|
||||
procedure PUT (ITEM : in STRING);
|
||||
|
||||
procedure GET_LINE (FILE : in FILE_TYPE; ITEM : out STRING; LAST : out NATURAL);
|
||||
procedure GET_LINE (ITEM : out STRING; LAST : out NATURAL);
|
||||
procedure PUT_LINE (FILE : in FILE_TYPE; ITEM : in STRING);
|
||||
procedure PUT_LINE (ITEM : in STRING);
|
||||
|
||||
-- Integer Input-Output
|
||||
|
||||
generic
|
||||
|
||||
type NUM is range <>;
|
||||
|
||||
package INTEGER_IO is
|
||||
|
||||
DEFAULT_WIDTH : FIELD := NUM'WIDTH;
|
||||
DEFAULT_BASE : NUMBER_BASE := 10;
|
||||
|
||||
procedure GET
|
||||
(FILE : in FILE_TYPE; ITEM : out NUM; WIDTH : in FIELD := 0);
|
||||
procedure GET (ITEM : out NUM; WIDTH : in FIELD := 0);
|
||||
|
||||
procedure PUT (
|
||||
FILE : in FILE_TYPE;
|
||||
ITEM : in NUM;
|
||||
WIDTH : in FIELD := DEFAULT_WIDTH;
|
||||
BASE : in NUMBER_BASE := DEFAULT_BASE);
|
||||
procedure PUT (
|
||||
ITEM : in NUM;
|
||||
WIDTH : in FIELD := DEFAULT_WIDTH;
|
||||
BASE : in NUMBER_BASE := DEFAULT_BASE);
|
||||
|
||||
procedure GET (
|
||||
FROM : in STRING;
|
||||
ITEM : out NUM;
|
||||
LAST : out POSITIVE);
|
||||
procedure PUT (
|
||||
TO : out STRING;
|
||||
ITEM : in NUM;
|
||||
BASE : in NUMBER_BASE := DEFAULT_BASE);
|
||||
|
||||
end INTEGER_IO;
|
||||
|
||||
-- Floating-point Input/Output
|
||||
|
||||
generic
|
||||
|
||||
type NUM is digits <>;
|
||||
|
||||
package FLOAT_IO is
|
||||
|
||||
DEFAULT_FORE : FIELD := 2;
|
||||
DEFAULT_AFT : FIELD := NUM'DIGITS - 1;
|
||||
DEFAULT_EXP : FIELD := 3;
|
||||
|
||||
procedure GET (FILE : in FILE_TYPE; ITEM : out NUM; WIDTH : in FIELD := 0);
|
||||
procedure GET (ITEM : out NUM; WIDTH : in FIELD := 0);
|
||||
|
||||
procedure PUT (
|
||||
FILE : in FILE_TYPE;
|
||||
ITEM : in NUM;
|
||||
FORE : in FIELD := DEFAULT_FORE;
|
||||
AFT : in FIELD := DEFAULT_AFT;
|
||||
EXP : in FIELD := DEFAULT_EXP);
|
||||
procedure PUT (
|
||||
ITEM : in NUM;
|
||||
FORE : in FIELD := DEFAULT_FORE;
|
||||
AFT : in FIELD := DEFAULT_AFT;
|
||||
EXP : in FIELD := DEFAULT_EXP);
|
||||
|
||||
procedure GET (FROM : in STRING; ITEM : out NUM; LAST : out POSITIVE);
|
||||
procedure PUT (
|
||||
TO : out STRING;
|
||||
ITEM : in NUM;
|
||||
AFT : in FIELD := DEFAULT_AFT;
|
||||
EXP : in FIELD := DEFAULT_EXP);
|
||||
|
||||
end FLOAT_IO;
|
||||
|
||||
-- Fixed-point Input/Output - Not implemented in version 1.00
|
||||
--
|
||||
-- generic
|
||||
--
|
||||
-- type NUM is delta <>;
|
||||
--
|
||||
-- package FIXED_IO is
|
||||
--
|
||||
-- DEFAULT_FORE : FIELD := NUM'FORE;
|
||||
-- DEFAULT_AFT : FIELD := NUM'AFT;
|
||||
-- DEFAULT_EXP : FIELD := 0;
|
||||
--
|
||||
-- procedure GET (FILE : in FILE_TYPE; ITEM : out NUM; WIDTH : in FIELD := 0);
|
||||
-- procedure GET (ITEM : out NUM; WIDTH : in FIELD := 0);
|
||||
--
|
||||
-- procedure PUT (
|
||||
-- FILE : in FILE_TYPE;
|
||||
-- ITEM : in NUM;
|
||||
-- FORE : in FIELD := DEFAULT_FORE;
|
||||
-- AFT : in FIELD := DEFAULT_AFT;
|
||||
-- EXP : in FIELD := DEFAULT_EXP);
|
||||
-- procedure PUT (
|
||||
-- ITEM : in NUM;
|
||||
-- FORE : in FIELD := DEFAULT_FORE;
|
||||
-- AFT : in FIELD := DEFAULT_AFT;
|
||||
-- EXP : in FIELD := DEFAULT_EXP);
|
||||
--
|
||||
-- procedure GET (FROM : in STRING; ITEM : out FLOAT; LAST : out POSITIVE);
|
||||
-- procedure PUT (
|
||||
-- TO : out STRING;
|
||||
-- ITEM : in NUM;
|
||||
-- AFT : in FIELD := DEFAULT_AFT;
|
||||
-- EXP : in FIELD := DEFAULT_EXP);
|
||||
--
|
||||
-- end FIXED_IO;
|
||||
|
||||
-- Enumeration Input/Output - Not implemented in version 1.00
|
||||
|
||||
generic
|
||||
|
||||
type ENUM is (<>);
|
||||
|
||||
package ENUMERATION_IO is
|
||||
|
||||
DEFAULT_WIDTH : FIELD := 0;
|
||||
DEFAULT_SETTING : TYPE_SET := UPPER_CASE;
|
||||
|
||||
procedure GET (FILE : in FILE_TYPE; ITEM : out ENUM);
|
||||
procedure GET (ITEM : out ENUM);
|
||||
|
||||
procedure PUT (
|
||||
FILE : in FILE_TYPE;
|
||||
ITEM : in ENUM;
|
||||
WIDTH : in FIELD := DEFAULT_WIDTH;
|
||||
SET : in TYPE_SET := DEFAULT_SETTING);
|
||||
procedure PUT (
|
||||
ITEM : in ENUM;
|
||||
WIDTH : in FIELD := DEFAULT_WIDTH;
|
||||
SET : in TYPE_SET := DEFAULT_SETTING);
|
||||
|
||||
procedure GET (FROM : in STRING; ITEM : out ENUM; LAST : out POSITIVE);
|
||||
procedure PUT (
|
||||
TO : out STRING;
|
||||
ITEM : in ENUM;
|
||||
SET : in TYPE_SET := DEFAULT_SETTING);
|
||||
|
||||
end ENUMERATION_IO;
|
||||
|
||||
-- Exceptions
|
||||
|
||||
STATUS_ERROR : exception renames IO_EXCEPTIONS.STATUS_ERROR;
|
||||
MODE_ERROR : exception renames IO_EXCEPTIONS.MODE_ERROR;
|
||||
NAME_ERROR : exception renames IO_EXCEPTIONS.NAME_ERROR;
|
||||
USE_ERROR : exception renames IO_EXCEPTIONS.USE_ERROR;
|
||||
DEVICE_ERROR : exception renames IO_EXCEPTIONS.DEVICE_ERROR;
|
||||
END_ERROR : exception renames IO_EXCEPTIONS.END_ERROR;
|
||||
DATA_ERROR : exception renames IO_EXCEPTIONS.DATA_ERROR;
|
||||
LAYOUT_ERROR : exception renames IO_EXCEPTIONS.LAYOUT_ERROR;
|
||||
|
||||
private
|
||||
|
||||
MAX_NAME_LEN : constant := 32; -- Complete name with paths
|
||||
MAX_FORM_LEN : constant := 10; -- The form is not used in MS-DOS
|
||||
|
||||
subtype NAME_INDEX is INTEGER range 0..MAX_NAME_LEN;
|
||||
subtype FORM_INDEX is INTEGER range 0..MAX_FORM_LEN;
|
||||
|
||||
subtype FILE_NAME_STRING is STRING (1..MAX_NAME_LEN);
|
||||
subtype FORM_NAME_STRING is STRING (1..MAX_FORM_LEN);
|
||||
|
||||
type FILE_DESCR is
|
||||
record
|
||||
NAMELEN : NAME_INDEX;
|
||||
NAME : FILE_NAME_STRING;
|
||||
MODE : FILE_MODE;
|
||||
FORMLEN : FORM_INDEX;
|
||||
FORM : FORM_NAME_STRING;
|
||||
COL : POSITIVE_COUNT;
|
||||
LINE : POSITIVE_COUNT;
|
||||
PAGE : POSITIVE_COUNT;
|
||||
LINE_LENGTH : COUNT;
|
||||
PAGE_LENGTH : COUNT;
|
||||
HANDLE : INTEGER;
|
||||
end record;
|
||||
|
||||
type FILE_TYPE is access FILE_DESCR;
|
||||
|
||||
end TEXT_IO;
|
||||
|
||||
|
||||
235
Artek Ada v125/TTT.ADA
Normal file
235
Artek Ada v125/TTT.ADA
Normal file
@ -0,0 +1,235 @@
|
||||
-- Note: The AI interpreter produces correct results.
|
||||
-- The a86 compiler produces inconsistent offsets for accessing "board" and ttt fails to run properly.
|
||||
-- I tried a variety of work-arounds, but they all failed to actually work.
|
||||
|
||||
with TEXT_IO; use TEXT_IO;
|
||||
|
||||
procedure TTT is
|
||||
|
||||
ScoreWin : Constant := 6;
|
||||
ScoreTie : Constant := 5;
|
||||
ScoreLose : Constant := 4;
|
||||
ScoreMax : Constant := 9;
|
||||
ScoreMin : Constant := 2;
|
||||
DefaultIterations : Constant := 10;
|
||||
|
||||
PieceX : Constant := 1;
|
||||
PieceO : Constant := 2;
|
||||
PieceBlank : Constant := 0;
|
||||
|
||||
moves : integer;
|
||||
|
||||
type TTTBoardType is array (integer range 0..8) of integer;
|
||||
board : TTTBoardType;
|
||||
|
||||
function LookForWinner return integer is
|
||||
p : integer;
|
||||
begin
|
||||
p := board(0);
|
||||
if ( PieceBlank /= p and p = board(1) and p = board(2) ) then return p; end if;
|
||||
if ( PieceBlank /= p and p = board(3) and p = board(6) ) then return p; end if;
|
||||
|
||||
p := board(3);
|
||||
if ( ( PieceBlank /= p ) and ( p = board(4) ) and ( p = board(5) ) ) then return p; end if;
|
||||
|
||||
p := board(6);
|
||||
if ( ( PieceBlank /= p ) and ( p = board(7) ) and ( p = board(8) ) ) then return p; end if;
|
||||
|
||||
p := board(1);
|
||||
if ( PieceBlank /= p and p = board(4) and p = board(7) ) then return p; end if;
|
||||
|
||||
p := board(2);
|
||||
if ( PieceBlank /= p and p = board(5) and p = board(8) ) then return p; end if;
|
||||
|
||||
p := board(4);
|
||||
if ( PieceBlank /= p and p = board(0) and p = board(8) ) then return p; end if;
|
||||
if ( PieceBlank /= p and p = board(2) and p = board(6) ) then return p; end if;
|
||||
|
||||
return PieceBlank;
|
||||
end LookForWinner;
|
||||
|
||||
function pos0func return integer is
|
||||
x : integer;
|
||||
begin
|
||||
x := board( 0 );
|
||||
if ( ( x = board(1) and x = board(2) ) or
|
||||
( x = board(3) and x = board(6) ) or
|
||||
( x = board(4) and x = board(8) ) ) then return x; end if;
|
||||
return PieceBlank;
|
||||
end pos0func;
|
||||
|
||||
function pos1func return integer is
|
||||
x : integer;
|
||||
begin
|
||||
x := board( 1 );
|
||||
if ( ( x = board(0) and x = board(2) ) or
|
||||
( x = board(4) and x = board(7) ) ) then return x; end if;
|
||||
return PieceBlank;
|
||||
end pos1func;
|
||||
|
||||
function pos2func return integer is
|
||||
x : integer;
|
||||
begin
|
||||
x := board( 2 );
|
||||
if ( ( x = board(0) and x = board(1) ) or
|
||||
( x = board(5) and x = board(8) ) or
|
||||
( x = board(4) and x = board(6) ) ) then return x; end if;
|
||||
return PieceBlank;
|
||||
end pos2func;
|
||||
|
||||
function pos3func return integer is
|
||||
x : integer;
|
||||
begin
|
||||
x := board( 3 );
|
||||
if ( ( x = board(4) and x = board(5) ) or
|
||||
( x = board(0) and x = board(6) ) ) then return x; end if;
|
||||
return PieceBlank;
|
||||
end pos3func;
|
||||
|
||||
function pos4func return integer is
|
||||
x : integer;
|
||||
begin
|
||||
x := board( 4 );
|
||||
if ( ( x = board(0) and x = board(8) ) or
|
||||
( x = board(2) and x = board(6) ) or
|
||||
( x = board(1) and x = board(7) ) or
|
||||
( x = board(3) and x = board(5) ) ) then return x; end if;
|
||||
return PieceBlank;
|
||||
end pos4func;
|
||||
|
||||
function pos5func return integer is
|
||||
x : integer;
|
||||
begin
|
||||
x := board( 5 );
|
||||
if ( ( x = board(3) and x = board(4) ) or
|
||||
( x = board(2) and x = board(8) ) ) then return x; end if;
|
||||
return PieceBlank;
|
||||
end pos5func;
|
||||
|
||||
function pos6func return integer is
|
||||
x : integer;
|
||||
begin
|
||||
x := board( 6 );
|
||||
if ( ( x = board(7) and x = board(8) ) or
|
||||
( x = board(0) and x = board(3) ) or
|
||||
( x = board(4) and x = board(2) ) ) then return x; end if;
|
||||
return PieceBlank;
|
||||
end pos6func;
|
||||
|
||||
function pos7func return integer is
|
||||
x : integer;
|
||||
begin
|
||||
x := board( 7 );
|
||||
if ( ( x = board(6) and x = board(8) ) or
|
||||
( x = board(1) and x = board(4) ) ) then return x; end if;
|
||||
return PieceBlank;
|
||||
end pos7func;
|
||||
|
||||
function pos8func return integer is
|
||||
x : integer;
|
||||
begin
|
||||
x := board( 8 );
|
||||
if ( ( x = board(6) and x = board(7) ) or
|
||||
( x = board(2) and x = board(5) ) or
|
||||
( x = board(0) and x = board(4) ) ) then return x; end if;
|
||||
return PieceBlank;
|
||||
end pos8func;
|
||||
|
||||
function MinMax( alphaarg : in integer; betaarg : in integer; depth : in integer;
|
||||
move : in integer ) return integer is
|
||||
alpha, beta, p, value, score, pieceMove : integer;
|
||||
begin
|
||||
-- Put( "Moves: " ); Put( INTEGER'IMAGE( moves ) ); New_line;
|
||||
-- Put( " Depth: " ); Put( INTEGER'IMAGE( depth ) ); New_line;
|
||||
-- Put( " Move: " ); Put( INTEGER'IMAGE( move ) ); New_line;
|
||||
-- ShowBoard;
|
||||
|
||||
moves := moves + 1;
|
||||
|
||||
if ( depth >= 4 ) then
|
||||
-- p := LookForWinner; -- this is much slower than the posXfunc solution
|
||||
|
||||
case move is
|
||||
when 0 => p := pos0func;
|
||||
when 1 => p := pos1func;
|
||||
when 2 => p := pos2func;
|
||||
when 3 => p := pos3func;
|
||||
when 4 => p := pos4func;
|
||||
when 5 => p := pos5func;
|
||||
when 6 => p := pos6func;
|
||||
when 7 => p := pos7func;
|
||||
when 8 => p := pos8func;
|
||||
when others => Put( "invalid move!" );
|
||||
end case;
|
||||
|
||||
if ( PieceBlank /= p ) then
|
||||
if ( PieceX = p ) then return ScoreWin; end if;
|
||||
return ScoreLose;
|
||||
end if;
|
||||
|
||||
if ( 8 = depth ) then return ScoreTie; end if;
|
||||
end if;
|
||||
|
||||
alpha := alphaarg;
|
||||
beta := betaarg;
|
||||
|
||||
if ( pieceO = board( move ) ) then -- a bitwise operator on depth would be faster
|
||||
value := ScoreMin;
|
||||
pieceMove := PieceX;
|
||||
else
|
||||
value := ScoreMax;
|
||||
pieceMove := PieceO;
|
||||
end if;
|
||||
|
||||
for p in 0..8 loop
|
||||
if ( PieceBlank = board( p ) ) then
|
||||
board( p ) := pieceMove;
|
||||
score := MinMax( alpha, beta, depth + 1, p );
|
||||
board( p ) := pieceBlank;
|
||||
|
||||
if ( PieceX = pieceMove ) then
|
||||
if ( score = ScoreWin ) then return ScoreWin; end if;
|
||||
if ( score > value ) then
|
||||
if ( score >= beta ) then return score; end if;
|
||||
value := score;
|
||||
if ( value > alpha ) then alpha := value; end if;
|
||||
end if;
|
||||
else
|
||||
if ( score = ScoreLose ) then return ScoreLose; end if;
|
||||
if ( score < value ) then
|
||||
if ( score <= alpha ) then return score; end if;
|
||||
value := score;
|
||||
if ( value < beta ) then beta := value; end if;
|
||||
end if;
|
||||
end if;
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
return value;
|
||||
end MinMax;
|
||||
|
||||
procedure FindSolution( move : in integer ) is
|
||||
z, x, score : integer;
|
||||
begin
|
||||
for z in board'range loop
|
||||
board( z ) := PieceBlank;
|
||||
end loop;
|
||||
board( move ) := PieceX;
|
||||
|
||||
score := MinMax( ScoreMin, ScoreMax, 0, move );
|
||||
end FindSolution;
|
||||
|
||||
i, iterations : integer;
|
||||
begin
|
||||
iterations := DefaultIterations;
|
||||
|
||||
for i in 1..iterations loop -- iterations loop
|
||||
moves := 0;
|
||||
FindSolution( 0 );
|
||||
FindSolution( 1 );
|
||||
FindSolution( 4 );
|
||||
end loop;
|
||||
|
||||
Put( "Moves: " ); Put( INTEGER'IMAGE( moves ) ); New_line;
|
||||
Put( "Iterations: " ); Put( INTEGER'IMAGE( iterations ) ); New_line;
|
||||
end TTT;
|
||||
61
Artek Ada v125/UNCHECK.ADA
Normal file
61
Artek Ada v125/UNCHECK.ADA
Normal file
@ -0,0 +1,61 @@
|
||||
--
|
||||
-- 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;
|
||||
|
||||
|
||||
18
Artek Ada v125/m.bat
Normal file
18
Artek Ada v125/m.bat
Normal file
@ -0,0 +1,18 @@
|
||||
@echo off
|
||||
setlocal
|
||||
|
||||
rem /n removes array bounds checks and must be after the source file
|
||||
ntvdm ada %1.ada /n
|
||||
ntvdm linklib %1
|
||||
|
||||
rem interpreter
|
||||
ntvdm -c -p ai %1
|
||||
|
||||
rem native code. I've found a86 to be buggy.
|
||||
rem note: a86 produces bad code for ttt.ada. it uses inconsistent addresses for the "board" array.
|
||||
rem note2: a86 produces bad code for e.ada but the workaround to use more local variables worked.
|
||||
del %1.exe 2>nul
|
||||
ntvdm a86 %1.axe /n
|
||||
ntvdm -c -p %1.exe
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user