diff --git a/Artek Ada v125/A86.EXE b/Artek Ada v125/A86.EXE new file mode 100644 index 0000000..67f514b Binary files /dev/null and b/Artek Ada v125/A86.EXE differ diff --git a/Artek Ada v125/ACODES.ADA b/Artek Ada v125/ACODES.ADA new file mode 100644 index 0000000..dcc5801 --- /dev/null +++ b/Artek Ada v125/ACODES.ADA @@ -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; + + \ No newline at end of file diff --git a/Artek Ada v125/ADA.ALB b/Artek Ada v125/ADA.ALB new file mode 100644 index 0000000..6040a94 Binary files /dev/null and b/Artek Ada v125/ADA.ALB differ diff --git a/Artek Ada v125/ADA.EXE b/Artek Ada v125/ADA.EXE new file mode 100644 index 0000000..2b1edcb Binary files /dev/null and b/Artek Ada v125/ADA.EXE differ diff --git a/Artek Ada v125/ADAERR.MSG b/Artek Ada v125/ADAERR.MSG new file mode 100644 index 0000000..ed0a446 Binary files /dev/null and b/Artek Ada v125/ADAERR.MSG differ diff --git a/Artek Ada v125/AE.EXE b/Artek Ada v125/AE.EXE new file mode 100644 index 0000000..9c587f8 Binary files /dev/null and b/Artek Ada v125/AE.EXE differ diff --git a/Artek Ada v125/AI.EXE b/Artek Ada v125/AI.EXE new file mode 100644 index 0000000..a95e7a5 Binary files /dev/null and b/Artek Ada v125/AI.EXE differ diff --git a/Artek Ada v125/APSE.EXE b/Artek Ada v125/APSE.EXE new file mode 100644 index 0000000..b526b7d Binary files /dev/null and b/Artek Ada v125/APSE.EXE differ diff --git a/Artek Ada v125/AR-LARGE.SYS b/Artek Ada v125/AR-LARGE.SYS new file mode 100644 index 0000000..ba36b8f Binary files /dev/null and b/Artek Ada v125/AR-LARGE.SYS differ diff --git a/Artek Ada v125/AR-SMALL.SYS b/Artek Ada v125/AR-SMALL.SYS new file mode 100644 index 0000000..7d32575 Binary files /dev/null and b/Artek Ada v125/AR-SMALL.SYS differ diff --git a/Artek Ada v125/ARF.EXE b/Artek Ada v125/ARF.EXE new file mode 100644 index 0000000..e580bdb Binary files /dev/null and b/Artek Ada v125/ARF.EXE differ diff --git a/Artek Ada v125/CA.BAT b/Artek Ada v125/CA.BAT new file mode 100644 index 0000000..c32c143 --- /dev/null +++ b/Artek Ada v125/CA.BAT @@ -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 + \ No newline at end of file diff --git a/Artek Ada v125/CALENDAR.ADA b/Artek Ada v125/CALENDAR.ADA new file mode 100644 index 0000000..c18f087 --- /dev/null +++ b/Artek Ada v125/CALENDAR.ADA @@ -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; + diff --git a/Artek Ada v125/CALL_DOS.ASM b/Artek Ada v125/CALL_DOS.ASM new file mode 100644 index 0000000..f0d5afb --- /dev/null +++ b/Artek Ada v125/CALL_DOS.ASM @@ -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 + + \ No newline at end of file diff --git a/Artek Ada v125/CALL_DOS.BIN b/Artek Ada v125/CALL_DOS.BIN new file mode 100644 index 0000000..02f1162 --- /dev/null +++ b/Artek Ada v125/CALL_DOS.BIN @@ -0,0 +1,3 @@ +‹US‹‹O‹W‹wÄ +‹_Í!‹ë[‰‰o‰O‰W‰w‰ +ŒG œX‰G] \ No newline at end of file diff --git a/Artek Ada v125/CONIO.ADA b/Artek Ada v125/CONIO.ADA new file mode 100644 index 0000000..5337bb5 --- /dev/null +++ b/Artek Ada v125/CONIO.ADA @@ -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; + + \ No newline at end of file diff --git a/Artek Ada v125/DAC.EXE b/Artek Ada v125/DAC.EXE new file mode 100644 index 0000000..7566860 Binary files /dev/null and b/Artek Ada v125/DAC.EXE differ diff --git a/Artek Ada v125/DIRIOB.ADA b/Artek Ada v125/DIRIOB.ADA new file mode 100644 index 0000000..9d4c832 --- /dev/null +++ b/Artek Ada v125/DIRIOB.ADA @@ -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; + + \ No newline at end of file diff --git a/Artek Ada v125/DIRIOS.ADA b/Artek Ada v125/DIRIOS.ADA new file mode 100644 index 0000000..1961d98 --- /dev/null +++ b/Artek Ada v125/DIRIOS.ADA @@ -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; + + \ No newline at end of file diff --git a/Artek Ada v125/DOSINT.ADA b/Artek Ada v125/DOSINT.ADA new file mode 100644 index 0000000..14c5d6a --- /dev/null +++ b/Artek Ada v125/DOSINT.ADA @@ -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; + \ No newline at end of file diff --git a/Artek Ada v125/E.ADA b/Artek Ada v125/E.ADA new file mode 100644 index 0000000..4bf1a87 --- /dev/null +++ b/Artek Ada v125/E.ADA @@ -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; + diff --git a/Artek Ada v125/IOEXC.ADA b/Artek Ada v125/IOEXC.ADA new file mode 100644 index 0000000..71d781c --- /dev/null +++ b/Artek Ada v125/IOEXC.ADA @@ -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; + + \ No newline at end of file diff --git a/Artek Ada v125/KEYBOARD.EXE b/Artek Ada v125/KEYBOARD.EXE new file mode 100644 index 0000000..ca378bb Binary files /dev/null and b/Artek Ada v125/KEYBOARD.EXE differ diff --git a/Artek Ada v125/LINKLIB.EXE b/Artek Ada v125/LINKLIB.EXE new file mode 100644 index 0000000..f2410bd Binary files /dev/null and b/Artek Ada v125/LINKLIB.EXE differ diff --git a/Artek Ada v125/LONGOP.ADA b/Artek Ada v125/LONGOP.ADA new file mode 100644 index 0000000..4ed574c --- /dev/null +++ b/Artek Ada v125/LONGOP.ADA @@ -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; + + \ No newline at end of file diff --git a/Artek Ada v125/MAIL.ADA b/Artek Ada v125/MAIL.ADA new file mode 100644 index 0000000..e5016ca --- /dev/null +++ b/Artek Ada v125/MAIL.ADA @@ -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 + + \ No newline at end of file diff --git a/Artek Ada v125/MATH.ADA b/Artek Ada v125/MATH.ADA new file mode 100644 index 0000000..4312426 --- /dev/null +++ b/Artek Ada v125/MATH.ADA @@ -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; + + + \ No newline at end of file diff --git a/Artek Ada v125/MEMORY.ADA b/Artek Ada v125/MEMORY.ADA new file mode 100644 index 0000000..59b7ffb --- /dev/null +++ b/Artek Ada v125/MEMORY.ADA @@ -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; + \ No newline at end of file diff --git a/Artek Ada v125/QGET.ADA b/Artek Ada v125/QGET.ADA new file mode 100644 index 0000000..7e6e658 --- /dev/null +++ b/Artek Ada v125/QGET.ADA @@ -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; + + \ No newline at end of file diff --git a/Artek Ada v125/QGET.AXE b/Artek Ada v125/QGET.AXE new file mode 100644 index 0000000..b894247 Binary files /dev/null and b/Artek Ada v125/QGET.AXE differ diff --git a/Artek Ada v125/QGET.EXE b/Artek Ada v125/QGET.EXE new file mode 100644 index 0000000..7e15354 Binary files /dev/null and b/Artek Ada v125/QGET.EXE differ diff --git a/Artek Ada v125/QPUT.ADA b/Artek Ada v125/QPUT.ADA new file mode 100644 index 0000000..4e19fd0 --- /dev/null +++ b/Artek Ada v125/QPUT.ADA @@ -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; + + \ No newline at end of file diff --git a/Artek Ada v125/README b/Artek Ada v125/README new file mode 100644 index 0000000..a27d047 --- /dev/null +++ b/Artek Ada v125/README @@ -0,0 +1,1359 @@ + README for Artek Ada version 1.25 (revised Jan. 22, 1987) + + + + Thank you very much for choosing Artek Ada. + + This file contains information about additions and improve- + ments to Artek Ada. Please read it carefully. + + NOTICE TO USERS OF EARLIER RELEASES + ----------------------------------- + + You cannot use libraries (ADA.ALB files) from previous + releases of the compiler with the new 1.25 compiler. You + will have to recompile your library units with the new + compiler. Any "old" units in the library will cause an error + message to appear. Also, old AXE files cannot be executed + using the new interpreter. This is because the A-code has + been modified slightly for better memory efficiency. + + The file LINKINFO.TMP is no longer generated or supported by + the compiler. After library subprograms were introduced, + this file lost its purpose, and because it has been confusing + users, we decided to remove it entirely. + + USING THE COMPILER WITH TWO DISKETTE DRIVES + ------------------------------------------- + + Artek Ada release 1.25 comes on three diskettes instead of + two as described in the User's Guide. + + The first diskette, labeled "Compiler", and the diskette + marked "Utility 1" contain the Artek Ada compiler and associ- + ated files. You need only these two diskettes to use the + Artek Ada system. The third diskette, labeled "Utility 2", + contains Ada demonstration and sample source files. You do + not need to install this diskette in your two-diskette + system. + + To use Artek Ada with two diskette drives, just follow the + instructions in the User's Guide, pretending that the + "Utility 2" diskette does not exist. Then, before using the + system for the first time, enter the command + + path B:\ + + This will tell the operating system to look for Artek Ada + system files on the B: drive as well as the A: drive. + + Now, at the A> prompt, you can type apse just as nor- + mal, and you are in business. The operating system and the + APSE will automatically switch between drives when necessary. + + For your convenience, you may want to put the above path com- + mand in a batch file, preferably AUTOEXEC.BAT, so that you do + not need to enter it each time you want to use Artek Ada. + + Your Ada files will be stored on drive A, where approximately + 80 Kbytes of diskette space are free. If you want to have a + look at some of the Ada source files on the Utility 2 + diskette, just copy them over to drive A and compile the pro- + grams as usual. Note, however, that they will not fit all at + once. + + DEVIATIONS FROM THE STANDARD NOT LISTED IN APPENDIX F + ----------------------------------------------------- + + Most of the following deficiencies will be remedied in future + updates. These updates will be made available to registered + users. + + Main program parameters are ignored and should not be used. + + Only the first 16 characters of an identifier are considered + significant when distinguishing between identifier names. + + The compiler maximum line length is 255 characters. (This is + not a deviation from Standard Ada, since any reasonable line + length is allowed by the Standard.) + + Renaming is not allowed for packages. + + Type conversions are not allowed as OUT and IN OUT parame- + ters. + + Ambiguous subprograms may be declared without error, but when + an attempt is made to call one of them, an error message is + generated. + + Identical identifiers introduced by USE clauses do not hide + each other. + + Use clauses applied to library units are not inherited in + secondary units (except subunits). This means that if you + WITH and USE TEXT_IO is a library package specification, you + will have to re-USE TEXT_IO in the body (although you do not + have to re-WITH). + + The attributes IMAGE, VALUE, PRED, SUCC etc. cannot be re- + named as functions or be given as a default generic subpro- + gram parameter. + + Files accessed by DIRECT_IO cannot have more than 65535 + records. Each record can be up to 64K in size. + + Artek Ada requires the body of a generic subprogram or pack- + age to be compiled before the subprogram or package is in- + stantiated. + + Library generic packages cannot be instantiated at the out- + ermost level to give library packages. + + Generic object parameters are not supported. + + NEW PROGRAMS + ------------ + + NATIVE CODE TRANSLATOR + + The Artek Native Code Translator is now included with the + compiler. The Translator is contained in a file called + A86.EXE, with run-time libraries being located in the files + AR-SMALL.SYS and AR-LARGE.SYS. To access the translator from + the APSE, use the T (translate) command, as explained in the + User's Guide (page 49). + + The translator takes a linked-and-ready AXE file as input and + produces MS-DOS/PC-DOS standard EXE files as output. In the + current release, it is not possible to generate OBJ files. + This will be included in a future release. + + Programs should behave in exactly the same manner when + executed as translated EXE files as they did when + interpreted, only much faster. The only "incompatibility" + problem may occur because the translated code uses a wee bit + more heap space than the interpreted one; this is especially + apparent when you use constants of unconstrained types. + + A tip to save disk and memory space: The translator examines + your program to see whether you use floating-point + calculations. If you do not, the small run-time library (AR- + SMALL.SYS) is linked with your program instead of the normal + one (AR-LARGE.SYS), for a savings of about 11 K bytes. This + is because the floating-point software emulator is not + needed. If your program contains just a few floating-point + operations, you may want to consider alternate programming + methods to eliminate those operations. The payoff is a + whopping 11 K bytes! + + For speed-intensive programs, you may want to consider using + the /n (no checks) compiler option when you compile final + releases. This will increase execution speed by 5-25 % + depending on the nature of your program. However, out-of- + bounds array indices etc. will not be detected if you use + this option. + + The A86 translator program can be invoked with command-line + options that are not documented in the User's Guide. Most of + these options, alas, have no effect in the current release. + + The command-line options are as follows: + + /i - Inline 8087/80287 code generation + + If this switch is used, the compiler generates 8087 opcodes + directly instead of software emulator interrupts. This will + improve the speed of your floating-point routines slightly. + + On the other hand, translating with the /i switch will + prevent your program from running on a computer that doesn't + have an math co-processor. + + The advantages and disadvantages of the /i switch are summed + up in the following table: + + FP programs | Without 8087/287 | With 8087/287 + ------------------------------------------------------------- + no /i option | Slow math, | Fast math, + | 11 Kb emulator | 11 Kb emulator + | overhead | overhead + ------------------------------------------------------------- + /i option used | Program bombs | Fastest math + ------------------------------------------------------------- + + /o - Object file generation + + This switch will be used in a future version of the + translator to instruct it to generate an OBJ file instead of + an EXE file. The OBJ file can then be linked with standard + MS-DOS linkers, to libraries which conform with the Microsoft + C or Pascal calling conventions. Currently, this option has + no effect. + + /d - Debug information + + When used in conjunction with the /o switch, this indicates + that debugging information such as line numbers, etc. should + be included in the generated OBJ file. This information is + required by debuggers such as SYMDEB and CodeView (trademarks + of Microsoft Corp.) Currently, this option has no effect. + + /n - No stack checking + + This option is used to prevent the translator from generating + a run-time-system call at the start of every subprogram in + order to check for stack or heap overflow. Currently, this + option is always assumed to be present, and no special code + is generated to check for overflow. The run-time system, + however, senses when the heap and the stack collide, and in + this case raises STORAGE_ERROR. + + /l - Large data model + + The translator by default uses a "P" memory model. This + means that programs can be up to 1 megabyte, while data space + is limited to 64 Kbytes. The limitation on data space is + because the a-code intermediate language used by Artek Ada + uses 16-bit pointers only. This will be expanded to 32 bits + in a future release. The /l option will then specify that + 32-bit pointers should be used in the final EXE file also. + Currently, the option has no effect. + + /1 - 80186 code generation + + When this option is used, the compiler will optimize + generated code for the Intel 80186 microprocessor. This will + result in a space and time savings of 1-8 % depending on the + nature of your program. The drawback is that a program + compiled with this switch will not run on a 8088 or 8086 + microprocessor. + + /2 - 80286 code generation + + This option is used to optimize code generation for the 80286 + microprocessor. This is mainly advantageous for programs + which contain tasking. However, the /2 switch is at the + moment equal to the /1 switch, except that some optimization + is done for the 80827 math co-processor if the /i switch is + also present. + + /3 - 80386 code generation + + This option is currently equal to the /1 option. + + For pragma NATIVE writers + ------------------------- + + If you write pragma NATIVEs, you need to know that the + calling environment described in the User's Guide has been + extended somewhat. + + Any pragma NATIVEs you've already written will continue to + work on the interpreter as before. However, they will not + work in translated programs. To create pragma NATIVEs that + are portable between the interpreter and the translator, + please observe the calling conventions described below. + + At the time when the pragma NATIVE code gets control, the SI + register is loaded with the address of the current + procedure's first parameter. The DI register contains the + address of the current procedure's first local variable. + Additionally, the DS, ES and SS segment registers all point + to the current data segment, so you do not have to use ES: + segment overrides all the time. You may destroy all data + registers in your routine except BP, which must be restored + to its original value if you overwrite it. Segment registers + should also be restored to their original contents. + + An example is in order here. Take a look at the following + function: + + function ADD (A, B : in INTEGER) return INTEGER is + RESULT : INTEGER; + begin + pragma NATIVE (...); + return RESULT; + end ADD; + + Previously, your assembly language code might have looked + like this: + + MOV AX, ES:[BP] ; Load A (at offset 0 in the current frame) + ADD AX, ES:[BP+2] ; Add B (at offset 2) + MOV ES:[BP+4], AX ; Store in RESULT (at offset 4) + + The new, translator-portable code is as follows: + + MOV AX, [SI] ; Load A (parameter at offset 0) + ADD AX, [SI+2] ; Add B (parameter at offset 2) + MOV [DI], AX ; Store in RESULT (variable at offset 0) + + Or, even better, replace the last line with the STOSW + instruction. + + AUTOMATIC RECOMPILATION FACILITY (ARF) + + A new utility program is included in release 1.25. This is + the Automatic Recompilation Facility, or ARF. + + The ARF finds out which Ada programs and modules are obsolete + and must be recompiled and/or relinked. It will either pre- + sent you with a list of the necessary operations, write a + batch file for you, or automatically compile and link the + relevant files without further intervention. + + The ARF uses time and date information in the ADA.ALB library + file, as well as MS-DOS file dates, to calculate its results. + You must always set your system clock at boot-up for the ARF + to work correctly. (Of course, the best solution is to have + an automatic clock/calendar card in your computer.) + + The ARF is invoked from the DOS command line by typing + + ARF [/option] + + where /option is one of the following: + + /l : list the necessary operations to be performed + /b : create the batch file DOARF.BAT + /a : automatically compile and link all obsolete files. + + If the option is omitted, the ARF is run in list (/l) mode. + + Note that 1) running ARF in list mode and then typing in the + listed commands, 2) running ARF in batch mode and then typing + DOARF, and 3) running ARF in automatic mode are all + equivalent. + + To accommodate the ARF, we added a new option ("Auto") to the + APSE. Pressing the A key when the main APSE menu is shown on + the screen invokes the ARF in automatic mode. + + The ARF is a time and headache saver when writing complex + software with many inter-module dependencies. + + The ARF is similar in concept to the UNIX and MS-DOS MAKE + utilities, except that module dependencies are calculated au- + tomatically. This means that you do not need to write a spe- + cial script file for the ARF to work. + + A subtle point regarding source file names: When you compile + a program with Artek Ada, the source file name and path are + stored in the program library. This information is then used + by ARF to determine what the name of your original source + file was. If you rename source files or copy them from one + DOS subdirectory to another, ARF may have obsolete informa- + tion about your source file. In this case, you should recom- + pile your module manually, and ARF will remember the new + source file name and/or path. + + COMPILER ENHANCEMENTS + --------------------- + + TASKING PROGRAMS CAN BE SYNTAX-CHECKED + + The 1.25 compiler will compile programs containing most task + declarations and tasking statements. It will, however, not + generate any code for tasking constructs. + + Syntax errors will be spotted and limited semantic checking + is performed. + + The syntax checking is not yet perfect, especially if complex + tasking programs are being compiled. + + BETTER MEMORY MANAGEMENT + + Users of previous releases discovered that complex programs + would sometimes run out of memory after having been running + for some time. This was because the heap became too + fractured, preventing reuse of individual blocks, and slowly + filled all available memory space. + + The 1.25 compiler has a greatly enhanced memory management + mechanism that is designed to put an end to problems of this + kind. + + DYNAMIC ARRAYS + + Dynamic arrays and dynamic aggregates are fully supported in + release 1.25. (For an example of dynamic aggregates, see the + program SAMPLE11.ADA on the Utility 2 diskette.) + + IMAGE AND VALUE FOR ENUMERATION TYPES + + The IMAGE and VALUE attributes are now fully implemented. + The ENUMERATION_IO package is included in TEXT_IO. + + LIBRARY GENERIC SUBPROGRAMS + + Release 1.25 fully supports library generic subprograms. Now + you can write for the last time those sort and search proce- + dures you've been writing over and over again in the past. + Make'em generic! + + UNCHECKED PROGRAMMING + + As a consequence of the addition of library generic subpro- + grams, we've been able to add UNCHECKED_DEALLOCATION and + UNCHECKED_CONVERSION. These two library generic subprograms + deallocate (dispose) an access object, and convert an object + from one type to another, respectively. UNCHECKED_CONVERSION + will only work if the two types are of the same size. Other- + wise, it raises CONSTRAINT_ERROR. + + In true Artek fashion, the source code to these two subpro- + grams is provided on the Utility 2 diskette under the name of + UNCHECK.ADA. + + PRAGMA ACODE + + If you examine the source code for UNCHECK.ADA, you will see + that the bulk of the two procedures is written with a new + pragma, pragma ACODE. This pragma is similar to pragma + NATIVE, except that it allows you to directly insert A-code + into your program. + + The ACODE pragma takes a list of integer constants as a pa- + rameter. The first of these is interpreted as an A-code, and + the following integers are interpreted as data bytes. + + To aid you in writing ACODE pragmas, we included the source + file ACODES.ADA. ACODES is a package which contains constant + declarations for all the currently supported A-codes. You + will see how it is used in UNCHECK.ADA. + + As an example, consider the following: + + pragma ACODE (NOP, 00, 00, 00); + pragma ACODE (LOAD2); + + This code fragment loads the 2-byte object at address 0, + level 0, onto the A-stack. + + PRAGMA INCLUDE_BINARY + + If you want to include long assembly-language routines in + your Ada programs, you will quickly become tired of entering + long and unreadable pragma NATIVEs. And there is indeed a + better way, called pragma INCLUDE_BINARY. + + INCLUDE_BINARY allows you to tell the compiler to read a + binary file (most often a COM or BIN file) from the disk and + include it as if it were a gigantic pragma NATIVE. + + The syntax is: + + pragma INCLUDE_BINARY ("[filename.ext]"); + + The file name can include a drive letter and/or a + subdirectory specification. This pragma is allowed anywhere + a statement is allowed. The file name string must be a + constant and be enclosed within quotes or percent signs. + + The file you specify will be included in the generated code, + verbatim, byte by byte. + + To prepare a file for use with INCLUDE_BINARY, use an + assembler and the EXE2BIN utility to convert your EXE files + into MS-DOS COM or BIN format before you compile the Ada + program. Don't use an ORG statement in your assembler source + file. + + A typical command sequence to prepare a binary file for + inclusion in an Ada program is as follows: + + MASM binfile; -- Assuming the Microsoft(R) Macro Assembler + LINK binfile; -- Ignore stack warning message from linker! + EXE2BIN binfile -- Convert binfile.exe to binfile.bin + ADA adaprog + + - assuming that adaprog.ada contains the line + + pragma INCLUDE_BINARY ("binfile.bin"); + + If the file you specify doesn't exist, the compiler gives an + error message and skips the pragma. + + The same considerations apply for INCLUDE_BINARY code as for + NATIVE code, with regards to register usage, parameter + addresses, etc. + + PRAGMA SUPPRESS + + The compiler now has a pragma which suppresses all run-time + CONSTRAINT_ERROR checks. This pragma is as follows: + + pragma SUPPRESS (ALL_CHECKS); + + The effect is equivalent to specifying the /n option when the + compiler is started (see User's Guide, page 29). + + The pragma SUPPRESS (NO_CHECKS) will reinstate constraint + checking. + + CONDITIONAL COMPILATION + + The compiler now optimizes if-statements with static condi- + tions so that no code is generated for then/else-branches + that would always be skipped anyway. This allows conditional + compilation of program parts, since you can trust that the + code you don't need won't be included in the final file. As + an example of this consider + + DEBUG : constant BOOLEAN := TRUE; + + if DEBUG then + PUT_LINE ("VAR is" & INTEGER'IMAGE (VAR)); + end if; + + If DEBUG is not TRUE, no code at all is generated for the if- + statement. + + ERRORLEVEL RETURN FOR BATCH PROCESSING + + The compiler now returns a status code when compilation is + finished. This status code can be interrogated with the IF + ERRORLEVEL n batch command. + + The codes are as follows: + + 0 - Compilation was successful with no errors and no warn- + ings. + + 2 - Warnings were given, but no errors were found. + + 4 - Errors were found. Fix and recompile. + + These return codes are compatible with MS-Pascal (R) and + other common compilers. + + BLINKING ASTERISK DURING COMPILATION + + If you do not specify the /listsource option when you com- + pile, the compiler can appear dead for a long period of time. + This is because Artek Ada utilizes the available memory in + your computer to the fullest extent to save disk I/O. To + assure you that all is well during compilation, an asterisk + blinks on your screen while the compiler is working. + + Even if the asterisk stops blinking momentarily, give the + compiler a chance. Resolving the overloading in a very com- + plex expression can take up to 20 seconds on a PC. + + VERSION 1.00 AC FILES NO LONGER REQUIRED + + After library subprograms were introduced, the compiler was + changed so that all compiled subprograms are entered directly + into the program library instead of being written to an AC + file. + + Therefore, AC files are no longer required or supported. + + Any library subprogram can be linked to create an executable + file (AXE file) by typing LINKLIB [name of program]. You + should, however, beware of making subprograms which have + parameters into AXE files. + + AUTOMATIC DISPOSE + + Dynamic data are now automatically deallocated from the heap + when the access type in question goes out of scope. Note + that this means that if you have a library package which + declares an access type, objects of that type are never deal- + located, because the type never goes out of scope (except + when the program finishes, of course.) If you want to deal- + locate an object of such a type, use UNCHECKED DEALLOCATION. + + SMALL BITS + + The following "small bits" have been implemented: Block + names, quotes within string constants, return statement + within procedures (previously only for functions), exit from + blocks inside loops, very nice checking of CASE choices (Try + it sometime! Write a program with missing CASE choices and + watch how the compiler handles them), no more "intermodule + fixup" errors in generics, increased accuracy in internal + math operations, negative index values in constrained type + declarations, and more!. + + LINKER ENHANCEMENTS + ------------------- + + Export and import of sublibraries has been added, a full + library directory facility, deletion of modules by wild + cards, and more. The additions are explained below. + + MORE USER-FRIENDLINESS (we hope) + + All linker/librarian options may now be specified in full or + partially at your discretion. This means that you can type + linklib /delete or linklib /del or linklib /d; it all means + the same. + + If you don't remember a linklib command, just type linklib + /help (/h will do) to obtain a full listing of the available + options. + + LIBRARY MODULE DELETION + + The Artek Linker/Librarian has an undocumented option, /d, + which allows you to delete modules from the Ada library. + + To delete a module called MODULENAME, enter + + linklib MODULENAME /delete + + Wild cards can be used to specify multiple modules. This is + explained below. See "EXPORT AND IMPORT OF SUBLIBRARIES." + + LIBRARY REORGANIZATION + + Due to the file structure used for the library, the ADA.ALB + file does not shrink in size even if you delete modules from + the library. If you want to pack the library file down to + its REAL size, use the new switch on the linker: + + linklib /reorg -- This can be shortened to /r + + This will write a new ADA.ALB library file which contains no + empty space. If the linker runs out of disk space during the + reorganization, it will give an error message and leave the + original file intact. + + EXPORT AND IMPORT OF SUBLIBRARIES + + In release 1.25 of Artek Ada, you can transfer a-code object + modules between libraries. This is done by using two new + options in the linker, /export and /import. + + This feature can be used to transfer object module libraries + between programmers, or to distribute modules for Artek Ada + in object form, or to save space in the main ADA.ALB. Note + that the 1.25 compiler can only read and write the main + library, ADA.ALB. + + To export a module from the main ADA.ALB library, type + + linklib [modulename1+modulename2+...+modulenameN] /export + (not including the square brackets; no spaces between + the module names and plus-signs) + + A new library file will be created with the name + [modulename1].ALB, containing the module(s) you specified. + Any previous ALB file with the same name is overwritten. + + If you specify modules that are not found in the library, + they are simply ignored and not exported to the final + library. This can be used to name sublibraries, as shown in + the examples below. + + The asterisk ("*") is allowed as a "wild card" in module + names. Thus, if you ask linklib to export gks*, it will put + all modules whose name begin with "gks" in the new subli- + brary. + + To import a sublibrary into ADA.ALB, type + + linklib [libraryname] /import (no square brackets) + + This will import the library whose file name is + [libraryname].ALB into the main ADA.ALB library. Any modules + which previously existed in ADA.ALB with the same name as an + imported module are deleted. Only one library name is + allowed at a time; you cannot string them together with plus + signs. + + A few examples are in order: + + linklib text_io /export + + This command will export the text_io module (specification + and body) into a new sublibrary called TEXT_IO.ALB. + + linklib text_io+direct_io+sequential_io /e + + This will export all the mentioned i/o modules into a new + sublibrary called TEXT_IO.ALB. + + linklib iolib+text_io+direct_io+sequential_io /e + + Assuming that the module iolib is not found in the library, + this will copy text_io, direct_io and sequential_io into a + sublibrary called IOLIB.ALB. + + linklib gks*+graphics* /e + + This command exports all modules whose names begin with "gks" + or "graphics" into the sublibrary GKS.ALB. + + linklib gks /import + + This will import the sublibrary GKS.ALB back again into + ADA.ALB. + + LDIR REPLACED BY LINKLIB /LIST + + The old LDIR command to list library contents has been dis- + continued. Now, its function is performed by the /list + option on the linker/librarian. This change is transparent + to users of the APSE. The M (modules) command works as + before. The difference is that it now invokes linklib + instead of ldir. + + You can now list the contents of sublibraries as well as the + main ADA.ALB library. To list the contents of a sublibrary + called GKS.ALB, type + + linklib gks /l + + If you don't specify a library name, ADA.ALB is assumed. + + DEBUGGER ENHANCEMENTS + --------------------- + + The Artek Interpreter/debugger has been enhanced greatly. + The main added features are the following:- + + - Source-level debugging + - Post-mortem debugging + - Exception trapping + - Call stack display + - Heap block display + + They are documented below. + + SOURCE DEBUGGING + + To enable source debugging for a particular compilation unit, + compile it with the /d (debugging) switch. The compiler will + generate an ADB file (Ada DeBug), which contains source line + numbering information. + + To debug a program, just invoke the interpreter/debugger + AI.EXE with the /d (debugging) switch, or use the D command + from the APSE. The debugger will automatically locate and + load the available debugging information. You can see which + modules of a program have source debugging available by + entering the M (modules) command within the debugger. The + text "(source debug)" will appear after the names of all mod- + ules for which an ADB file is available. + + If the debugger finds an ADB file which is older than the + corresponding source file, it will issue a warning. If you + have indeed edited the source file and subsequently compiled + it without the /d switch, the debugger may not be able to lo- + cate the source information correctly. In this case, either + recompile the offending unit with a /d switch, or delete the + ADB file. The latter removes source debugging for the unit + in question. + + Once the debugger has been started, it shows you the current + source line in high intensity, as well as the A-code to be + executed next. You can single-step and trace, and the debug- + ger will show you the relevant source lines as the code for + them is executed. + + Every time the program flow leaves one module and enters + another, the debugger displays the name of the module en- + tered. + + To view the source code for a particular module, use the new + V (view) command. You will be asked for a module name and a + line number. You only have to enter enough characters to + make the module name unique. When the correct module name is + shown on the screen, press ENTER or a colon (":"). Then, + enter the line number you want to view from. + + The debugger will show a default module name and line number. + If you want to use either or both of those, press the ENTER + key immediately instead of entering data. The default will + then be entered automatically. + + The current release of the debugger does not support the + Backspace key while entering a module name. If you press an + incorrect key, you'll have to start all over again. + + To set a breakpoint at a particular source line, use the B + (breakpoint) command. Then follow a similar procedure to the + one described for the view command. + + Note that in the current release, the debugger will sometimes + stop on a breakpoint one instruction earlier than expected. + This is a minor annoyance and will be corrected in a future + release. + + The debugger will display a highlighted "BP=>" symbol in + front of a line on which a breakpoint is set. + + Note that you must have the ANSI.SYS driver installed in your + CONFIG.SYS file for highlighting and colors to work correctly + in the debugger. + + POST-MORTEM DEBUGGING + + Post-mortem debugging has also been added. Now, after a pro- + gram has finished execution, either normally or because of an + exception, you are presented with the post-mortem debugger + prompt "Post-mortem>". You are then allowed to use all the + normal debugger commands except Trace, Single-step and Go. + These commands have no effect in post-mortem mode. + + To exit to the operating system, use the Quit command. + + EXCEPTION TRAPPING + + The E command, for Exception trap toggle, has been added. To + enable exception trapping, give the E command while at the + debugger prompt. To disable it, press the E key again. + + Exception trapping, when enabled, causes the debugger to stop + execution whenever an exception is raised and wait for your + command. It is similar to setting a breakpoint at every + RAISE statement (but additionally, implicit exceptions such + as division by zero are trapped). + + When you are at an exception trap point, you can Single-step, + Trace or Go, as usual. + + Exception trapping is very useful when you have a spurious + exception appearing somewhere in your program and you want to + know exactly where it was originally raised. + + CALL STACK DUMP + + The C ("Call stack dump") command has also been added to the + debugger. This command dumps the current procedure call + stack on the screen. + + A typical dump looks as follows: + + Lv Address ExcH DynL SL + 02 00 0134 0000 0049 01 + 01 01 872A 88C0 004B 00 + 00 00 0B4F 0000 0000 + + The first column, Lv, indicates the current (dynamic) call + level. The "02" in this case means that procedure nesting is + two levels deep at the moment. + + The second column, Address, gives the number of the calling + module and the return address in that module. For a list of + currently active modules and their numbers, press M for the + Modules command. + + The third column gives the address of the exception handler + which was in effect at the point of the call. + + The fourth column, DynL, is the beginning of the frame of the + calling procedure. This will probably only be of interest to + seasoned A-code hackers. + + The last column, SL, gives the static link to the next stati- + cally enclosing frame. For a technical discussion about the + function of the static link, we refer you to Niklaus Wirth's + book Algorithms+Data Structures=Programs (Prentice Hall, + 1976). + + HEAP BLOCKS DISPLAY + + The H (heap dump) command now displays heap data in an easy- + to-understand block format, complete with block size and + linkage information. Each block is marked "Free" or + "Temporary" if it is on the system free-list or temporary- + list, respectively. Blocks on the free-list have been + disposed and may be reused by the heap allocator. Blocks on + the temporary-list are for intermediate results from + expression evaluation and subprogram calls and will be freed + when no longer in use. + + REGISTER DUMP + + The r (register dump) command now shows the current heap + pointer (the address of the beginning of the heap) and the + amount of free memory remaining between the stack and the + heap. Also, the number of free bytes within the heap itself + is displayed. + + EDITOR ENHANCEMENTS + ------------------- + + WINDOWING + + The Artek Editor now has multi-window, multi-file editing + capabilities. To open a new window, use the ESC W O (window + open) command. You will be asked whether the new window + should be horizontal or vertical. Finally, you are asked + where you want the new window border to be placed on the + screen. + + To close a window, type ESC W C. + + A window can be moved by using the ESC W M command. This + allows you to use the cursor to point to the window edge to + move. When you have selected the edge, move the cursor to + the place where it should be placed and type ENTER. The edi- + tor will move the window edge to the desired place. + + To move between windows, press function key F1 and use the + cursor keys to point to the window which you want to move to. + + You can select a new buffer for editing by typing ALT-N or + ESC N. The next buffer in line will be displayed in the cur- + rent window. There are 10 buffers available. + + ESC P or ALT-P can be used to select the previous buffer for + editing. + + To load a file into a new buffer, use the ESC F A (File Add) + command. This will load a file from disk into a previously + empty buffer. + + The editor always displays the name of the current workfile + in the lower right corner of the screen. It is preceded by a + digit and a colon (for example 0:example.ada). The digit + indicates which buffer you are working on at the moment, from + zero to nine. + + NEW EDITING FUNCTIONS + + New editing functions include Cut to end of line, Move line + to center of screen and Delete line. They are described + below. + + To delete ("cut") the text to the right of the cursor in + the current line, press Alt and c simultaneously. + + To move the current line to the center of the screen, + scrolling the screen if necessary, press Alt-b. This will + bring the surrounding program text into view. + + To delete the current line and close up the vacated space, + press the Ctrl and BACKSPACE keys at the same time. + + The Ada Editor now contains several Ada-specific features. + You can comment and decomment a block, indent and outdent + blocks, and search for matching parenthesis. + + To comment an Ada block, select the block in the normal way + using function key F6 and the cursor keys. Then, type + (the + plus key). There are two plus keys on the standard IBM key- + board; either one will do the trick. + + You will see that the marked block is commented out by in- + serting two hyphens at the start of every line. + + To remove the comment hyphens from a program block, select + the block and type - (the minus key). + + To indent a program block, select the block and press the TAB + key. The TAB key is located above the CTRL key on the stan- + dard IBM keyboard. + + To "outdent" a program block, select the block and press + SHIFT and TAB at the same time. + + To find corresponding left and right parenthesis in a + program, just place the cursor on a parenthesis and press + F10. The editor will automatically highlight the text + between matching parenthesis. + + As a matter of fact, you can position the cursor anywhere + between a pair of parenthesis and press F10. The editor + will still highlight the correct block of text. + + If there is a parenthesis mismatch and the editor cannot + find a corresponding parenthesis, a beep will be heard and + the editor does not highlight a program block. + + SCREEN SYNCHRONIZATION OPTIONAL + + If you have a color graphics card, it may produce flicker + and "snow" on the screen when text is scrolled. To prevent + this, use the Screen Sync field in the editor Options as + detailed below. + + After invoking the editor, enter ESC O (letter O) for + Options, use the CURSOR DOWN key to move to the Screen Sync + field, and set it to Y (for Yes). Note that after this, + the editor will slow down considerably, since it waits for + the screen's vertical retrace to occur everytime data is + written. + + APSE ENHANCEMENTS + ----------------- + + Five commands have been added to the APSE, and one command + has been renamed. The five new commands are: Auto, for + invoking the ARF; Fork, for executing DOS commands without + leaving the APSE; Help, for displaying a help screen; + Redirect, to output compiler listings etc. to a printer or to + a file; and finally setUp (invoked by typing U) to select + screen colors and other system defaults. The renamed command + is Run, which is now called eXecute (invoked by typing X). + + These additions and changes are documented below. + + FORK COMMAND ADDED + + You can now execute DOS commands without leaving the APSE. + The F (fork) command has been added for this purpose. + + After you press F, the APSE will ask you for the DOS command + which you want to execute. If you press ENTER without enter- + ing a command, you will be taken into COMMAND.COM with the + drive> prompt. (To exit to the APSE again, enter EXIT and + press the ENTER key.) If you type a command, however, the + APSE will execute the command as if you had typed it at the + drive> prompt. + + HELP SCREEN AVAILABLE + + By typing H for Help while inside the APSE, you can now + obtain a screenful of information about the various APSE com- + mands, compiler options, and more. + + SETUP ADDED IN APSE AND EDITOR + + You can now decide once and for all which colors you want the + APSE and the Editor to use for text on the screen. Also, + screen synchronization may be permanently set. + + If you don't want to use Artek's AE editor, you can set that + up in the APSE, too. Also, source and object file paths may + be defined to be something else than the default directory. + + All this is done through the new setUp commands (invoked by + pressing U) in the APSE and the Editor. + + REDIRECTION ADDED TO THE APSE + + We have added the Redirect command to the APSE. This command + allows you to specify a file into which compiler output is to + be redirected. Also, the output of the Show and Modules com- + mands is redirected to this file. + + This allows you to list the compiler output to a printer, or + to a text file. + + The Run command had to be changed because of the naming con- + flict and is now called eXecute. It is invoked by typing X. + + DEFAULT ENTRY TO EDITOR AFTER UNSUCCESSFUL COMPILATION + + If you are using the APSE and the compiler finds an error in + your program, you will be asked immediately after the compi- + lation terminates whether you want to invoke the editor or go + back to the APSE. By pressing E, you will load the editor + without having to go to the APSE first. Press any other key + to return to the APSE as normal. + + DISASSEMBLER ENHANCEMENTS + ------------------------- + + LIBRARY NAME NOT REQUIRED + + The A-Code disassembler now always disassembles from the main + Ada library. Therefore, the optional library parameter has + been removed and the library ADA.ALB is automatically + searched for the module you specify. + + NEW INCLUDED SOFTWARE + --------------------- + + MEMORY PACKAGE ALLOWS 640 K FOR DATA + + We now include a new package, MEMORY.ADA, with the compiler. + This is a generic package which allows you to use all the + available RAM in your computer (excluding MS-DOS and the run- + ning program itself) for data within Ada programs. + + The package functions similarly to DIRECT_IO. You begin by + instantiating it for the data type you wish to use. Then, + you call an ALLOCATE procedure to tell MEMORY how many pieces + of your data record you want to be able to store. After + these formalities have been fulfilled, you can READ and WRITE + data to "records" in memory, just as if the memory were con- + figured as an array. The only difference is that you have to + use READ and WRITE instead of normal assignment and indexing. + + After use, you can DEALLOCATE the memory, and you can even + MODIFY_ALLOCATION if you find that you need more or less mem- + ory than originally anticipated. + + The MEMORY package is documented with comments and an exam- + ple. See the source file MEMORY.ADA. + + In the future, it is possible to add the Lotus-Intel-Mi- + crosoft (trademarks) Expanded Memory Standard and IBM AT + Extended memory access in the MEMORY package, while keeping + the same specification. + + MATH PACKAGE + + Release 1.25 includes a comprehensive package of basic mathe- + matical functions. Included are square roots, exponentials, + logarithms, and trigonometric functions complete with hyper- + bolic and inverse functions. + + The specification of the MATH package is derived from Ada + Letters (the publication of ACM SigAda). It is a generic + package, ready to instantiate for your favorite FLOAT type. + + Source code is included in the file MATH.ADA. You will + notice that many of the functions are written with high-speed + pragma NATIVEs. The MATH library uses an 8087/80287 + coprocessor if available or the emulation library if not. + + ENHANCED DOS_INTERFACE + + The DOS_INTERFACE package has been enhanced with several low- + level utility subprograms. They are as follows: + + 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. + + function PORT_IN (PORT : in WORD) return BYTE; + + Inputs a byte from the I/O port whose number is in PORT. + + function PORT_IN_WORD (PORT : in WORD) return WORD; + + Inputs a word from the I/O port whose number is in PORT. + + Also, a new field has been added to the REGS_8086 record. + This field, ES, contains the value of the ES segment reg- + ister. + + The source code for DOS_INTERFACE can be found in the file + DOSINT.ADA on the Utility 2 diskette. + + SCREEN INPUT/OUTPUT PACKAGES AND SUBPROGRAMS + + On the Utility 2 diskette, we have included the library sub- + programs QPUT and QGET. These subprograms have the following + specifications: + + procedure QPUT (S : in STRING); + + procedure QGET (C : in out CHARACTER); + + QPUT uses a special DOS interrupt to achieve fast console + output. QGET returns a character typed at the console, in- + cluding extended ASCII codes, control characters, etc. No + filtering is done. + + The package CON_IO contains several utility subprograms for + manipulating the display. Among others, cursor addressing, + video attributes and colors are supported through calls to + this package. Boxes can easily be drawn on the screen using + the BOX procedure. The file CONIO.ADA on Utility Diskette 2 + contains commented source code for this package. Also, an + example of its use can be found in the MAIL.ADA program + described below. + + SAMPLE ADA PROGRAMS + + On the Utility 2 diskette, you will find 12 sample Ada pro- + grams ready to compile. This will get you started with Artek + Ada. The samples are named SAMPLE1.ADA through SAMPLE12.ADA. + + Also included is a demonstration program, MAIL, which demon- + strates the use of the CON_IO console I/O package. This + program allows you to enter, modify and view names in a + mailing list. + + TECHNICAL NOTES + --------------- + + "GOTCHA!" WITH LIBRARY SUBPROGRAM SPECIFICATIONS AND BODIES + + Library subprograms are stored in the program library in two + parts: the specification and the body. The specification + may be separately compiled. When you submit a subprogram + body for compilation, the compiler checks the library for a + corresponding specification. If a specification is found, + there must be an exact match between its parameter names, + types and modes, and those of the body. If this is not the + case, an error message is generated. To get rid of the error + message, you must either delete the offending subprogram from + the program library before you recompile, or insert a + separate subprogram specification before the body in your + source file. + + The same gotcha can also apply if you have an old specifi- + cation in your library which has WITHed some program units + you no longer use. These units will be included in the final + AXE and/or EXE file, much to your annoyance. + + The easiest way to find out whether any unwanted modules have + crept into an AXE file is to invoke the debugger (with the + name of the file as a parameter) and use the Modules command. + + The same solution applies as above: delete the old subpro- + gram from the library before you recompile or write out the + subprogram specification explicitly yourself and include it + in the source file just before the body. + + AUTO-SENSING OF 8087/80287 COPROCESSOR + + The Artek Interpreter now automatically detects the presence + of an 8087/80287 math coprocessor and uses it if present. If + not, a software emulator executes math instructions. + + ERRATA + ------ + + The following errors have been found in the Artek Ada User's + Guide: + + Page 24: + + The editor keys and are juxtaposed. + Actually, stands for "Cursor to previous error in + file" and stands for "Cursor to next error in + file". + + Pages 34 and 185: + + The constant SYSTEM . STORAGE_UNIT is incorrectly given as + 16. Since the 8086/88/186/286 family of microprocessors is + byte-addressable, we decided that it would be more convenient + if SYSTEM . STORAGE_UNIT were given the value 8 instead of + 16. This affects for example the use of the SIZE attribute, + which returns the size of its prefix in bits. To obtain the + size in bytes, divide the result by SYSTEM . STORAGE_UNIT. + + Page 65: + + The IN A-code has its parameters listed in the wrong order. + The correct order is: + + WORD Operand + WORD Lower bound of range + WORD Upper bound of range + + Pages 79 and 106: + + In the text about parameter passing with the CALL and LCALL + A-codes, "Mode in or out" should be "Mode in out or out". + + Page 99: + + The result for the DUP1 A-code lists only one "BYTE Operand". + The result is in fact twice "BYTE Operand". + + Page 108: + + The operation of the HCOPY A-code has been changed. Its + description is now as follows: + + Parameters: + + List of BYTES Data to be copied to the heap + WORD Number of bytes to copy + WORD Link to next element in heap chain + + Result: + + WORD Heap address where the data was stored + + Description: + + Pops the data bytes off the stack and stores them on the + heap. Stores the forward link in the link field of the in- + ternal heap control block. Returns the address in the heap + of the stored data. These data must subsequently be accessed + with absolute memory addressing (level 255, see LOAD). + + Page 116: + + "This exception is emitted by..." should be "This instruction + is emitted by...". + + Page 157: + + The CVABS A-code is incorrectly documented. The correct text + follows: + + Parameters: + + WORD Absolute address of data on stack + + Result: + + BYTE -1 (absolute level indicator) + WORD Absolute address of data + + Description: + + CVABS reads a 16-bit absolute address off the stack, pushes + an absolute level indicator byte (-1) on the stack, and then + re-pushes the address. In effect, the instruction inserts a + -1 byte in the stack just before the top word. This is used + to quickly prepare a pointer value for use in a LOAD or STORE + instruction. + + Page 186: + + In the example about the use of address representation + clauses, a typo in the PC's screen memory address causes it + to be incorrectly listed as 16#8000#:0000. As seasoned hack- + ers know, the address is actually 16#B000#:0000. That's a + letter B instead of a digit 8. + + Unfortunately, this is really a moot point, since address + representation clauses as detailed here are not implemented + in release 1.25. diff --git a/Artek Ada v125/SAMPLE1.ADA b/Artek Ada v125/SAMPLE1.ADA new file mode 100644 index 0000000..2b444e4 --- /dev/null +++ b/Artek Ada v125/SAMPLE1.ADA @@ -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; + + \ No newline at end of file diff --git a/Artek Ada v125/SAMPLE10.ADA b/Artek Ada v125/SAMPLE10.ADA new file mode 100644 index 0000000..e1f0e12 --- /dev/null +++ b/Artek Ada v125/SAMPLE10.ADA @@ -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; + + \ No newline at end of file diff --git a/Artek Ada v125/SAMPLE11.ADA b/Artek Ada v125/SAMPLE11.ADA new file mode 100644 index 0000000..6e26da1 --- /dev/null +++ b/Artek Ada v125/SAMPLE11.ADA @@ -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; + + \ No newline at end of file diff --git a/Artek Ada v125/SAMPLE12.ADA b/Artek Ada v125/SAMPLE12.ADA new file mode 100644 index 0000000..ce77474 --- /dev/null +++ b/Artek Ada v125/SAMPLE12.ADA @@ -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; + + \ No newline at end of file diff --git a/Artek Ada v125/SAMPLE2.ADA b/Artek Ada v125/SAMPLE2.ADA new file mode 100644 index 0000000..b095a20 --- /dev/null +++ b/Artek Ada v125/SAMPLE2.ADA @@ -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; + + \ No newline at end of file diff --git a/Artek Ada v125/SAMPLE3.ADA b/Artek Ada v125/SAMPLE3.ADA new file mode 100644 index 0000000..a1dbe75 --- /dev/null +++ b/Artek Ada v125/SAMPLE3.ADA @@ -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; + + \ No newline at end of file diff --git a/Artek Ada v125/SAMPLE4.ADA b/Artek Ada v125/SAMPLE4.ADA new file mode 100644 index 0000000..45a47ec --- /dev/null +++ b/Artek Ada v125/SAMPLE4.ADA @@ -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; + + \ No newline at end of file diff --git a/Artek Ada v125/SAMPLE5.ADA b/Artek Ada v125/SAMPLE5.ADA new file mode 100644 index 0000000..798778a --- /dev/null +++ b/Artek Ada v125/SAMPLE5.ADA @@ -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; + + \ No newline at end of file diff --git a/Artek Ada v125/SAMPLE6.ADA b/Artek Ada v125/SAMPLE6.ADA new file mode 100644 index 0000000..fab1d54 --- /dev/null +++ b/Artek Ada v125/SAMPLE6.ADA @@ -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; + diff --git a/Artek Ada v125/SAMPLE7.ADA b/Artek Ada v125/SAMPLE7.ADA new file mode 100644 index 0000000..5fe6d2d --- /dev/null +++ b/Artek Ada v125/SAMPLE7.ADA @@ -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; + + \ No newline at end of file diff --git a/Artek Ada v125/SAMPLE8.ADA b/Artek Ada v125/SAMPLE8.ADA new file mode 100644 index 0000000..7f5fbc4 --- /dev/null +++ b/Artek Ada v125/SAMPLE8.ADA @@ -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; + + \ No newline at end of file diff --git a/Artek Ada v125/SAMPLE9.ADA b/Artek Ada v125/SAMPLE9.ADA new file mode 100644 index 0000000..04419e2 --- /dev/null +++ b/Artek Ada v125/SAMPLE9.ADA @@ -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; + \ No newline at end of file diff --git a/Artek Ada v125/SEQIOB.ADA b/Artek Ada v125/SEQIOB.ADA new file mode 100644 index 0000000..b8ebf38 --- /dev/null +++ b/Artek Ada v125/SEQIOB.ADA @@ -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; + + \ No newline at end of file diff --git a/Artek Ada v125/SEQIOS.ADA b/Artek Ada v125/SEQIOS.ADA new file mode 100644 index 0000000..0f548ce --- /dev/null +++ b/Artek Ada v125/SEQIOS.ADA @@ -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; + + \ No newline at end of file diff --git a/Artek Ada v125/SIEVE.ADA b/Artek Ada v125/SIEVE.ADA new file mode 100644 index 0000000..37bdbd2 --- /dev/null +++ b/Artek Ada v125/SIEVE.ADA @@ -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; diff --git a/Artek Ada v125/SYSTEM.FIL b/Artek Ada v125/SYSTEM.FIL new file mode 100644 index 0000000..b63dc35 Binary files /dev/null and b/Artek Ada v125/SYSTEM.FIL differ diff --git a/Artek Ada v125/TEXTIOB.ADA b/Artek Ada v125/TEXTIOB.ADA new file mode 100644 index 0000000..a6645cb --- /dev/null +++ b/Artek Ada v125/TEXTIOB.ADA @@ -0,0 +1,2417 @@ +-- +-- T E X T I N P U T / O U T P U T +-- +-- Body of the Package Text_IO +-- +-- According to ANSI/MIL-STD 1815A (1983) +-- Implemented for Artek Ada +-- +-- Copyright (C) 1986, 1987 Artek Corporation +-- Authors : O. Karlsson & V. Thorsteinsson +-- +-- +-- Version: 1.00 February 1986 +-- Deviations from the standard: +-- +-- ENUMERATION_IO not implemented +-- FIXED_IO not implemented +-- CHARACTER PUT and GET accept 8 bit characters +-- GET and PUT floating point to/from string not implemented +-- +-- Version: 1.01 June 1986 +-- PUT and GET floating point to/from string implemented +-- GET_LINE for console input corrected +-- +-- Version: 1.02 November 1986 +-- ENUMERATION_IO implemented +-- + +with DOS_INTERFACE, SYSTEM; +use DOS_INTERFACE, SYSTEM, ASCII; + +package body TEXT_IO is + + -- Data types and objects + + R : REG_8086; + + EOF : constant CHARACTER := CHARACTER (26); + + IN_CONSOLE_HANDLE : constant INTEGER := 0; -- DOS Handle for STDIN + OUT_CONSOLE_HANDLE : constant INTEGER := 1; -- DOS Handle for STDOUT + + DOS_INPUT, DOS_OUTPUT : FILE_TYPE; + + CURR_INPUT, CURR_OUTPUT : FILE_TYPE; + + DOS_IO_NAME : FILE_NAME_STRING := + (1 => 'C', 2 => 'O', 3 => 'N', others => ' '); -- CON file + + PREV_CHAR : CHARACTER; + UNGET_RAISED : BOOLEAN := FALSE; + +-- +-- 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 + if FILE . HANDLE = 0 then -- Can't do UNGET on console input + UNGET_RAISED := TRUE; + else + 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 if; + end UNGET; + +-- +-- procedures READ and WRITE are used internally +-- + + procedure READ (FILE : in FILE_TYPE; ITEM : out CHARACTER) is + + begin +-- See comment at start of WRITE regarding checks on FILE + if FILE . HANDLE = 0 and UNGET_RAISED then -- Called UNGET on console + ITEM := PREV_CHAR; + UNGET_RAISED := FALSE; + elsif FILE . HANDLE = 0 then -- Input from console + R . AX := 16#0100#; -- DOS function 01, keyboard input + CALL_DOS (R); + PREV_CHAR := CHARACTER (R . AX mod 256); + ITEM := PREV_CHAR; + else + 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 (ITEM'ADDRESS); -- Address of ITEM + CALL_DOS (R); + if R . AX = 0 then -- Read past EOF + raise END_ERROR; + end if; + if R . FLAGS mod 2 = 1 then -- Carry set + raise USE_ERROR; -- Access denied or invalid file handle + end if; + end if; + end READ; + + procedure WRITE (FILE : in FILE_TYPE; ITEM : in CHARACTER) is + + begin +-- The following checks are not needed since WRITE is never called +-- if one of the conditions is true +-- if FILE = null 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); + R . CX := 1; -- Write one byte + 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 R . FLAGS mod 2 = 1 then -- Carry set + raise USE_ERROR; -- Access denied or invalid file handle + end if; + end WRITE; + + procedure WRITE_STRING (FILE : in FILE_TYPE; ITEM : in STRING) is + + begin + R . AX := 16#4000#; -- DOS function 40, write to a file or device + R . BX := WORD (FILE . HANDLE); + R . CX := WORD (ITEM'LENGTH); -- Write LENGTH bytes + R . DX := WORD (ITEM'ADDRESS); -- Address of ITEM + CALL_DOS (R); + if R . AX /= WORD (ITEM'LENGTH) then -- Probably disk full error + raise USE_ERROR; + end if; + if R . FLAGS mod 2 = 1 then -- Carry set + raise USE_ERROR; -- Access denied or invalid file handle + end if; + end WRITE_STRING; + +-- +-- 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.3.1 + + begin -- Concatenate a null character + if FILE /= null then -- Already open + 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 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, + COL => 1, LINE => 1, PAGE => 1, + LINE_LENGTH => UNBOUNDED, PAGE_LENGTH => UNBOUNDED, + HANDLE => INTEGER (R . AX)); + 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.3.1 + + begin + if FILE /= null then -- File already open + 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 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, + COL => 1, LINE => 1, PAGE => 1, + LINE_LENGTH => UNBOUNDED, PAGE_LENGTH => UNBOUNDED, + MODE => MODE, + HANDLE => INTEGER (R . AX)); + 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.3.1 + + begin + if FILE = null then + raise STATUS_ERROR; + end if; + if FILE . MODE = OUT_FILE then + NEW_PAGE (FILE); + WRITE (FILE, EOF); + end if; + R . AX := 16#3E00#; -- DOS function 3E, Close a file handle + R . BX := WORD (FILE . HANDLE); + CALL_DOS (R); + if 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.3.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 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 + + TL, TP : COUNT; + +-- See chapter 14.3.1 + + begin + if FILE = null then + raise STATUS_ERROR; + elsif (FILE = CURR_INPUT and MODE /= IN_FILE) or + (FILE = CURR_OUTPUT and MODE /= OUT_FILE) then + raise MODE_ERROR; + end if; + TL := FILE . LINE_LENGTH; + TP := FILE . PAGE_LENGTH; + CLOSE (FILE); -- Must close and reopen since MODE changes + OPEN (FILE, MODE, FILE . NAME, FILE . FORM); + if FILE . MODE = IN_FILE then -- Restore line and page lengths + FILE . LINE_LENGTH := TL; + FILE . PAGE_LENGTH := TP; + end if; + end RESET; + + procedure RESET (FILE : in out FILE_TYPE) is + +-- See chapter 14.3.1 + + begin + if FILE = null then + raise STATUS_ERROR; + end if; + if FILE . MODE = OUT_FILE then + NEW_PAGE (FILE); + WRITE (FILE, EOF); + 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 R . FLAGS mod 2 = 1 then -- Carry was set + raise USE_ERROR; + end if; + FILE . COL := 1; + FILE . LINE := 1; + FILE . PAGE := 1; + end RESET; + + function MODE (FILE : in FILE_TYPE) return FILE_MODE is + +-- See chapter 14.3.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.3.1 + + begin + if FILE = null then + raise STATUS_ERROR; + end if; + return FILE . NAME; + end NAME; + + function FORM (FILE : in FILE_TYPE) return STRING is + +-- See chapter 14.3.1 + + begin + if FILE = null then + raise STATUS_ERROR; + end if; + return FILE . FORM; + end FORM; + + function IS_OPEN (FILE : in FILE_TYPE) return BOOLEAN is + +-- See chapter 14.3.1 + + begin + return FILE /= null; + end IS_OPEN; + +-- +-- Control of default input and output files +-- + + procedure SET_INPUT (FILE : in FILE_TYPE) is + +-- See chapter 14.3.2 + + begin + if FILE = null then + raise STATUS_ERROR; + elsif FILE . MODE /= IN_FILE then + raise MODE_ERROR; + end if; + CURR_INPUT := FILE; + end SET_INPUT; + + procedure SET_OUTPUT (FILE : in FILE_TYPE) is + +-- See chapter 14.3.2 + + begin + if FILE = null then + raise STATUS_ERROR; + elsif FILE . MODE /= OUT_FILE then + raise MODE_ERROR; + end if; + CURR_OUTPUT := FILE; + end SET_OUTPUT; + + function STANDARD_INPUT return FILE_TYPE is + +-- See chapter 14.3.2 + + begin + return DOS_INPUT; + end STANDARD_INPUT; + + function STANDARD_OUTPUT return FILE_TYPE is + +-- See chapter 14.3.2 + + begin + return DOS_OUTPUT; + end STANDARD_OUTPUT; + + function CURRENT_INPUT return FILE_TYPE is + +-- See chapter 14.3.2 + + begin + return CURR_INPUT; + end CURRENT_INPUT; + + function CURRENT_OUTPUT return FILE_TYPE is + +-- See chapter 14.3.2 + + begin + return CURR_OUTPUT; + end CURRENT_OUTPUT; + +-- +-- Specification of line and page lengths +-- + + procedure SET_LINE_LENGTH (FILE : in FILE_TYPE; TO : in COUNT) is + +-- See chapter 14.3.3 + + begin + if FILE = null then + raise STATUS_ERROR; + elsif FILE . MODE /= OUT_FILE then + raise MODE_ERROR; + end if; + FILE . LINE_LENGTH := TO; + end SET_LINE_LENGTH; + + procedure SET_LINE_LENGTH (TO : in COUNT) is + +-- See chapter 14.3.3 + + begin + SET_LINE_LENGTH (CURR_OUTPUT, TO); + end SET_LINE_LENGTH; + + procedure SET_PAGE_LENGTH (FILE : in FILE_TYPE; TO : in COUNT) is + +-- See chapter 14.3.3 + + begin + if FILE = null then + raise STATUS_ERROR; + elsif FILE . MODE /= OUT_FILE then + raise MODE_ERROR; + end if; + FILE . PAGE_LENGTH := TO; + end SET_PAGE_LENGTH; + + procedure SET_PAGE_LENGTH (TO : in COUNT) is + +-- See chapter 14.3.3 + + begin + SET_PAGE_LENGTH (CURR_OUTPUT, TO); + end SET_PAGE_LENGTH; + + function LINE_LENGTH (FILE : in FILE_TYPE) return COUNT is + +-- See chapter 14.3.3 + + begin + if FILE = null then + raise STATUS_ERROR; + elsif FILE . MODE /= OUT_FILE then + raise MODE_ERROR; + end if; + return FILE . LINE_LENGTH; + end LINE_LENGTH; + + function LINE_LENGTH return COUNT is + +-- See chapter 14.3.3 + + begin + return LINE_LENGTH (CURR_OUTPUT); + end LINE_LENGTH; + + function PAGE_LENGTH (FILE : in FILE_TYPE) return COUNT is + +-- See chapter 14.3.3 + + begin + if FILE = null then + raise STATUS_ERROR; + elsif FILE . MODE /= OUT_FILE then + raise MODE_ERROR; + end if; + return FILE . PAGE_LENGTH; + end PAGE_LENGTH; + + function PAGE_LENGTH return COUNT is + +-- See chapter 14.3.3 + + begin + return PAGE_LENGTH (CURR_OUTPUT); + end PAGE_LENGTH; + +-- +-- Column, Line, and Page Contril +-- + + procedure NEW_LINE (FILE : in FILE_TYPE; + SPACING : in POSITIVE_COUNT := 1) is + +-- See chapter 14.3.4 + + begin + if FILE = null then + raise STATUS_ERROR; + elsif FILE . MODE /= OUT_FILE then + raise MODE_ERROR; + else + for I in 1 .. SPACING loop + WRITE (FILE, CR); + WRITE (FILE, LF); + FILE . LINE := FILE . LINE + 1; + if (FILE . PAGE_LENGTH /= UNBOUNDED) and + (FILE . LINE >= FILE . PAGE_LENGTH) then + WRITE (FILE, FF); + FILE . PAGE := FILE . PAGE + 1; + end if; + end loop; + FILE . COL := 1; + end if; + end NEW_LINE; + + procedure NEW_LINE (SPACING : in POSITIVE_COUNT := 1) is + +-- See chapter 14.3.4 + + begin + NEW_LINE (CURR_OUTPUT, SPACING); + end NEW_LINE; + + procedure SKIP_LINE (FILE : in FILE_TYPE; + SPACING : in POSITIVE_COUNT := 1) is + + PREVCH, CH : CHARACTER; + +-- See chapter 14.3.4 + + begin + if FILE = null then + raise STATUS_ERROR; + elsif FILE . MODE /= IN_FILE then + raise MODE_ERROR; + end if; + for I in 1..SPACING loop + PREVCH := ' '; + loop + READ (FILE, CH); + case CH is + when CR => + FILE . COL := 1; + if FILE . HANDLE = 0 then -- Input from console + FILE . LINE := FILE . LINE + 1; + if (FILE . PAGE_LENGTH /= UNBOUNDED) and + (FILE . LINE >= FILE . PAGE_LENGTH) then + FILE . PAGE := FILE . PAGE + 1; + FILE . LINE := 1; + end if; + exit; + end if; + when LF => + FILE . LINE := FILE . LINE + 1; + if (FILE . PAGE_LENGTH /= UNBOUNDED) and + (FILE . LINE >= FILE . PAGE_LENGTH) then + FILE . PAGE := FILE . PAGE + 1; + FILE . LINE := 1; + end if; + when FF => + FILE . PAGE := FILE . PAGE + 1; + FILE . COL := 1; + FILE . LINE := 1; + when EOF => + if (PREVCH = CR) or (PREVCH = LF) or (PREVCH = FF) then + UNGET (FILE); + exit; + else + raise END_ERROR; + end if; + when others => + if (PREVCH = CR) or (PREVCH = LF) or (PREVCH = FF) then + UNGET (FILE); + exit; + end if; + end case; + PREVCH := CH; + end loop; + end loop; + end SKIP_LINE; + + procedure SKIP_LINE (SPACING : in POSITIVE_COUNT := 1) is + +-- See chapter 14.3.4 + + begin + SKIP_LINE (CURR_INPUT, SPACING); + end SKIP_LINE; + + function END_OF_LINE (FILE : in FILE_TYPE) return BOOLEAN is + + CH : CHARACTER; + +-- See chapter 14.3.4 + + begin + if FILE = null then + raise STATUS_ERROR; + elsif FILE . MODE /= IN_FILE then + raise MODE_ERROR; + end if; + READ (FILE, CH); + UNGET (FILE); + return (CH = CR) or (CH = LF) or (CH = EOF); + exception + when END_ERROR => -- If already EOF return TRUE + UNGET (FILE); + return TRUE; + end END_OF_LINE; + + function END_OF_LINE return BOOLEAN is + +-- See chapter 14.3.4 + + begin + return END_OF_LINE (CURR_INPUT); + end END_OF_LINE; + + procedure NEW_PAGE (FILE : in FILE_TYPE) is + +-- See chapter 14.3.4 + + begin + if FILE = null then + raise STATUS_ERROR; + elsif FILE . MODE /= OUT_FILE then + raise MODE_ERROR; + end if; + if (FILE . COL > 1) or (FILE . COL = 1 and FILE . LINE = 1) then + NEW_LINE (FILE); -- Sets FILE . COL := 1 + end if; + WRITE (FILE, FF); -- Form Feed + FILE . LINE := 1; + FILE . PAGE := FILE . PAGE + 1; + end NEW_PAGE; + + procedure NEW_PAGE is + +-- See chapter 14.3.4 + + begin + NEW_PAGE (CURR_OUTPUT); + end NEW_PAGE; + + procedure SKIP_PAGE (FILE : in FILE_TYPE) is + + CH : CHARACTER; + +-- See chapter 14.3.4 + + begin + if FILE = null then + raise STATUS_ERROR; + elsif FILE . MODE /= IN_FILE then + raise MODE_ERROR; + end if; + loop + READ (FILE, CH); + if CH = EOF then + raise END_ERROR; + end if; + exit when CH = FF; + end loop; + FILE . LINE := 1; + FILE . COL := 1; + FILE . PAGE := FILE . PAGE + 1; + end SKIP_PAGE; + + procedure SKIP_PAGE is + +-- See chapter 14.3.4 + + begin + SKIP_PAGE (CURR_INPUT); + end SKIP_PAGE; + + function END_OF_PAGE (FILE : in FILE_TYPE) return BOOLEAN is + + CH : CHARACTER; + +-- See chapter 14.3.4 + + begin + if FILE = null then + raise STATUS_ERROR; + elsif FILE . MODE /= IN_FILE then + raise MODE_ERROR; + end if; + READ (FILE, CH); -- returns TRUE if (CR LF FF), (FF) or (EOF) + if CH = CR or CH = LF then + READ (FILE, CH); + if CH = CR or CH = LF then + READ (FILE, CH); + UNGET (FILE); + end if; + UNGET (FILE); + end if; + UNGET (FILE); + return CH = FF or CH = EOF; + exception + when END_ERROR => + UNGET (FILE); + return TRUE; + end END_OF_PAGE; + + function END_OF_PAGE return BOOLEAN is + +-- See chapter 14.3.4 + + begin + return END_OF_PAGE (CURR_INPUT); + end END_OF_PAGE; + + function END_OF_FILE (FILE : in FILE_TYPE) return BOOLEAN is + + CH : CHARACTER; + +-- See chapter 14.3.4 + + begin + if FILE = null then + raise STATUS_ERROR; + elsif FILE . MODE /= IN_FILE then + raise MODE_ERROR; + end if; + READ (FILE, CH); -- returns TRUE if (CR LF FF EOF), (FF EOF) + -- or (CR LF EOF) or (EOF) + if CH = CR or CH = LF or CH = FF then + READ (FILE, CH); + if CH = CR or CH = LF or CH = FF then + READ (FILE, CH); + if CH = CR or CH = LF or CH = FF then + READ (FILE, CH); + UNGET (FILE); + end if; + UNGET (FILE); + end if; + UNGET (FILE); + end if; + UNGET (FILE); + return CH = EOF; + exception + when END_ERROR => + UNGET (FILE); + return TRUE; + end END_OF_FILE; + + function END_OF_FILE return BOOLEAN is + +-- See chapter 14.3.4 + + begin + return END_OF_FILE (CURR_INPUT); + end; + + procedure SET_COL (FILE : in FILE_TYPE; TO : in POSITIVE_COUNT) is + + CH : CHARACTER; + +-- See chapter 14.3.4 + + begin + if FILE = null then + raise STATUS_ERROR; + elsif FILE . MODE = OUT_FILE and FILE . LINE_LENGTH /= UNBOUNDED + and TO > FILE . LINE_LENGTH then + raise LAYOUT_ERROR; + end if; + if FILE . MODE = IN_FILE then + if FILE . COL /= TO then + loop + READ (FILE, CH); -- Read until (FILE . COL = TO) or EOF + case CH is + when CR => + FILE . COL := 1; + when LF => + FILE . LINE := FILE . LINE + 1; + if (FILE . PAGE_LENGTH /= UNBOUNDED) and + (FILE . LINE >= FILE . PAGE_LENGTH) then + FILE . PAGE := FILE . PAGE + 1; + FILE . LINE := 1; + end if; + when FF => + FILE . PAGE := FILE . PAGE + 1; + FILE . COL := 1; + FILE . LINE := 1; + when EOF => + raise END_ERROR; + when others => + FILE . COL := FILE . COL + 1; + end case; + exit when FILE . COL = TO; + end loop; + end if; + else -- For file in OUT_MODE + if FILE . COL > TO then + NEW_LINE (FILE); + end if; + if FILE . COL < TO then + for I in FILE . COL .. TO - 1 loop + WRITE (FILE, ' '); + FILE . COL := FILE . COL + 1; + end loop; + end if; + end if; + end SET_COL; + + procedure SET_COL (TO : in POSITIVE_COUNT) is + +-- See chapter 14.3.4 + + begin + SET_COL (CURR_OUTPUT, TO); -- Default output file, see page 14-15 + end SET_COL; + + procedure SET_LINE (FILE : in FILE_TYPE; TO : in POSITIVE_COUNT) is + +-- See chapter 14.3.4 + + begin + if FILE = null then + raise STATUS_ERROR; + elsif FILE . MODE = OUT_FILE and FILE . PAGE_LENGTH /= UNBOUNDED + and TO > FILE . PAGE_LENGTH then + raise LAYOUT_ERROR; + end if; + if FILE . MODE = IN_FILE then + if FILE . LINE /= TO then + loop + SKIP_LINE (FILE); -- This raises END_ERROR if EOF + exit when FILE . LINE = TO; + end loop; + end if; + else -- FILE . MODE = OUT_FILE + if FILE . LINE < TO then + loop + NEW_LINE (FILE); -- Spacing 1, see page 14-16 + exit when FILE . LINE = TO; + end loop; + elsif FILE . LINE > TO then + NEW_PAGE (FILE); + NEW_LINE (FILE, TO - 1); + end if; + end if; + end SET_LINE; + + procedure SET_LINE (TO : in POSITIVE_COUNT) is + +-- See chapter 14.3.4 + + begin + SET_LINE (CURR_OUTPUT, TO); + end SET_LINE; + + function COL (FILE : in FILE_TYPE) return POSITIVE_COUNT is + +-- See chapter 14.3.4 + + begin + if FILE = null then + raise STATUS_ERROR; + end if; + return FILE . COL; + end COL; + + function COL return POSITIVE_COUNT is + +-- See chapter 14.3.4 + + begin + return COL (CURR_OUTPUT); -- Def. current output file, see page 14-15 + end COL; + + function LINE (FILE : in FILE_TYPE) return POSITIVE_COUNT is + +-- See chapter 14.3.4 + + begin + if FILE = null then + raise STATUS_ERROR; + end if; + return FILE . LINE; + end LINE; + + function LINE return POSITIVE_COUNT is + +-- See chapter 14.3.4 + + + begin + return LINE (CURR_OUTPUT); -- Def. current output file, see page 14-15 + end LINE; + + function PAGE (FILE : in FILE_TYPE) return POSITIVE_COUNT is + +-- See chapter 14.3.4 + + begin + if FILE = null then + raise STATUS_ERROR; + end if; + return FILE . PAGE; + end PAGE; + + function PAGE return POSITIVE_COUNT is + +-- See chapter 14.3.4 + + begin + return PAGE (CURR_OUTPUT); -- Def. curr. output file, see page 14-15 + end PAGE; + +-- +-- Character input/output +-- + + procedure GET (FILE : in FILE_TYPE; ITEM : out CHARACTER) is + + INCHAR : CHARACTER; + +-- See chapter 14.3.6 + + begin + if FILE = null then + raise STATUS_ERROR; + elsif FILE . MODE /= IN_FILE then + raise MODE_ERROR; + end if; + loop + READ (FILE, INCHAR); -- There is no DATA_ERROR eight bit characters + case INCHAR is + when CR => + FILE . COL := 1; + when LF => + FILE . LINE := FILE . LINE + 1; + if (FILE . PAGE_LENGTH /= UNBOUNDED) and + (FILE . LINE >= FILE . PAGE_LENGTH) then + FILE . PAGE := FILE . PAGE + 1; + FILE . LINE := 1; + end if; + when FF => + FILE . PAGE := FILE . PAGE + 1; + FILE . COL := 1; + FILE . LINE := 1; + when EOF => + raise END_ERROR; + when others => + FILE . COL := FILE . COL + 1; + exit; -- This is a legal character + end case; + end loop; + ITEM := INCHAR; + end GET; + + procedure GET (ITEM : out CHARACTER) is + +-- See chapter 14.3.6 + + begin + GET (CURR_INPUT, ITEM); + end GET; + + procedure PUT (FILE : in FILE_TYPE; ITEM : in CHARACTER) is + +-- See chapter 14.3.6 + + begin + if FILE = null then + raise STATUS_ERROR; + elsif FILE . MODE = IN_FILE then + raise MODE_ERROR; + end if; + if FILE . LINE_LENGTH /= UNBOUNDED and + FILE . COL >= FILE . LINE_LENGTH then + if FILE . PAGE_LENGTH /= UNBOUNDED and + FILE . PAGE_LENGTH >= FILE . PAGE then + NEW_PAGE (FILE); + else + NEW_LINE (FILE); + end if; + end if; + WRITE (FILE, ITEM); + FILE . COL := FILE . COL + 1; + end PUT; + + procedure PUT (ITEM : in CHARACTER) is + +-- See chapter 14.3.6 + + begin + PUT (CURR_OUTPUT, ITEM); + end PUT; + +-- +-- String input/output +-- + + procedure GET (FILE : in FILE_TYPE; ITEM : out STRING) is + +-- See chapter 14.3.6 + + begin + if FILE = null then + raise STATUS_ERROR; + elsif FILE . MODE /= IN_FILE then + raise MODE_ERROR; + end if; + for I in ITEM'RANGE loop + GET (FILE, ITEM (I)); + end loop; + end GET; + + procedure GET (ITEM : out STRING) is + +-- See chapter 14.3.6 + + begin + GET (CURR_INPUT, ITEM); + end GET; + + procedure PUT (FILE : in FILE_TYPE; ITEM : in STRING) is + +-- See chapter 14.3.6 + + begin + if FILE = null then + raise STATUS_ERROR; + elsif FILE . MODE /= OUT_FILE then + raise MODE_ERROR; + end if; + if FILE . LINE_LENGTH /= UNBOUNDED and + FILE . COL >= FILE . LINE_LENGTH then + if FILE . PAGE_LENGTH /= UNBOUNDED and + FILE . PAGE_LENGTH >= FILE . PAGE then + NEW_PAGE (FILE); + else + NEW_LINE (FILE); + end if; + end if; + WRITE_STRING (FILE, ITEM); + FILE . COL := FILE . COL + COUNT (ITEM'LENGTH); + end PUT; + + procedure PUT (ITEM : in STRING) is + +-- See chapter 14.3.6 + + begin + PUT (CURR_OUTPUT, ITEM); + end; + + procedure GET_LINE (FILE : in FILE_TYPE; + ITEM : out STRING; LAST : out NATURAL) is + + INCHAR : CHARACTER; + POINTER : NATURAL := ITEM'FIRST - 1; + +-- See chapter 14.3.6 + + begin + if FILE = null then + raise STATUS_ERROR; + elsif FILE . MODE /= IN_FILE then + raise MODE_ERROR; + end if; + loop + READ (FILE, INCHAR); + case INCHAR is + when CR | LF => + UNGET (FILE); + SKIP_LINE (FILE); + if FILE . HANDLE = 0 then -- Input from console + if INCHAR = CR then + PUT (DOS_OUTPUT, LF); + else + PUT (DOS_OUTPUT, CR); + end if; + end if; + exit; + when FF => + UNGET (FILE); + SKIP_PAGE (FILE); + exit; + when EOF => + exit; + when others => + FILE . COL := FILE . COL + 1; + POINTER := POINTER + 1; + ITEM (POINTER) := INCHAR; + exit when POINTER = ITEM'LAST; + end case; + end loop; + LAST := POINTER; + end GET_LINE; + + procedure GET_LINE (ITEM : out STRING; LAST : out NATURAL) is + +-- See chapter 14.3.6 + + begin + GET_LINE (CURR_INPUT, ITEM, LAST); + end GET_LINE; + + procedure PUT_LINE (FILE : in FILE_TYPE; ITEM : in STRING) is + +-- See chapter 14.3.6 + + begin + if FILE = null then + raise STATUS_ERROR; + elsif FILE . MODE /= OUT_FILE then + raise MODE_ERROR; + end if; + PUT (FILE, ITEM); + NEW_LINE (FILE); + end PUT_LINE; + + procedure PUT_LINE (ITEM : in STRING) is + +-- See chapter 14.3.6 + + begin + PUT_LINE (CURR_OUTPUT, ITEM); + end PUT_LINE; + +-- +-- Integer I/O +-- +-- The following utility procedures are not included in +-- the INTEGER_IO package in order to decrease instantiation overhead. +-- + + function VALID_INT (BASE : in NUMBER_BASE; + CH : in CHARACTER) return INTEGER is + + N : INTEGER; + + begin + if CH >= 'a' then + N := INTEGER (CH) - INTEGER ('a') + 10; + elsif CH >= 'A' then + N := INTEGER (CH) - INTEGER ('A') + 10; + else + N := INTEGER (CH) - INTEGER ('0'); + end if; + if N > BASE - 1 then -- illegal digit for base + return -1; + else + return N; + end if; + end VALID_INT; + + procedure READ_INT (FILE : in FILE_TYPE; + MAX_WIDTH : in FIELD; + INT : out INTEGER; + BASE : in out NUMBER_BASE; + HAS_EXP : in BOOLEAN := FALSE) is + + COUNTER : INTEGER := 0; + BASE_CHANGED : BOOLEAN := FALSE; + INCHAR : CHARACTER; + TEMP : INTEGER; + MINUS : BOOLEAN := FALSE; + ONUM : INTEGER; + + begin + ONUM := 0; + loop + READ (FILE, INCHAR); + COUNTER := COUNTER + 1; + case INCHAR is + when '0'..'9' | 'a'..'f' | 'A'..'F' => + if not BASE_CHANGED and (INCHAR = 'e' or INCHAR = 'E') then + UNGET (FILE); + exit; + else + TEMP := VALID_INT (BASE, INCHAR); + if TEMP > -1 then + ONUM := BASE * ONUM + TEMP; + FILE . COL := FILE . COL + 1; + else -- Illegal character + raise DATA_ERROR; + end if; + end if; + when '#' | ':' => + FILE . COL := FILE . COL + 1; + if not BASE_CHANGED and not HAS_EXP and + (ONUM > 1 and ONUM < 17) then -- We have read the base + BASE := ONUM; + ONUM := 0; + BASE_CHANGED := TRUE; + elsif BASE_CHANGED and not HAS_EXP then + exit; + elsif MAX_WIDTH = 0 or + (MAX_WIDTH > 0 and COUNTER = MAX_WIDTH) then + exit; + else + raise DATA_ERROR; + end if; + when '-' => + FILE . COL := FILE . COL + 1; + if HAS_EXP then + MINUS := TRUE; + else + exit; + end if; + when '+' => + FILE . COL := FILE . COL + 1; + if not HAS_EXP then + exit; + end if; + when CR | LF | FF | EOF => + UNGET (FILE); + exit; + when others => + if MAX_WIDTH = 0 then + UNGET (FILE); + exit; + else + raise DATA_ERROR; + end if; + end case; + exit when COUNTER = MAX_WIDTH and MAX_WIDTH > 0; + end loop; + if MINUS then + ONUM := - ONUM; + end if; + INT := ONUM; + end READ_INT; + + procedure GET (FILE : in FILE_TYPE; + ITEM : out INTEGER; + WIDTH : in FIELD; + INBASE : NUMBER_BASE) is + + COUNTER : INTEGER := 0; + INCHAR : CHARACTER; + BASE : NUMBER_BASE := INBASE; + INT : INTEGER; + ONUM : INTEGER; + ALREADY_SOMETHING : BOOLEAN := FALSE; + +-- See chapter 14.3.7 + + begin + if FILE = null then + raise STATUS_ERROR; + elsif FILE . MODE /= IN_FILE then + raise MODE_ERROR; + end if; + ONUM:= 0; + loop + READ (FILE, INCHAR); + case INCHAR is + when FF | CR | LF => + if WIDTH /= 0 or ALREADY_SOMETHING then + UNGET (FILE); + exit; + end if; + when EOF => + UNGET (FILE); + exit; + when ' ' => + FILE . COL := FILE . COL + 1; + if WIDTH > 0 then + COUNTER := COUNTER + 1; + end if; + when '-' => + if ALREADY_SOMETHING then + raise DATA_ERROR; + end if; + FILE . COL := FILE . COL + 1; + if WIDTH > 0 then + COUNTER := COUNTER + 1; + end if; + READ_INT (FILE, WIDTH - COUNTER, ONUM, BASE); + ONUM := - ONUM; + ALREADY_SOMETHING := TRUE; + when '+' => + if ALREADY_SOMETHING then + raise DATA_ERROR; + end if; + FILE . COL := FILE . COL + 1; + if WIDTH > 0 then + COUNTER := COUNTER + 1; + end if; + READ_INT (FILE, WIDTH - COUNTER, ONUM, BASE); + ALREADY_SOMETHING := TRUE; + when '0' .. '9' => + UNGET (FILE); + READ_INT (FILE, WIDTH - COUNTER, ONUM, BASE); + ALREADY_SOMETHING := TRUE; + when 'e' | 'E' => + if not ALREADY_SOMETHING then + raise DATA_ERROR; + end if; + FILE . COL := FILE . COL + 1; + if WIDTH > 0 then + COUNTER := COUNTER + 1; + end if; + READ_INT (FILE, WIDTH - COUNTER, INT, BASE, TRUE); + ONUM := ONUM * BASE ** INT; + exit; + when others => + raise DATA_ERROR; + end case; + exit when COUNTER = WIDTH and WIDTH > 0; + end loop; + ITEM := ONUM; + exception + when NUMERIC_ERROR => + raise DATA_ERROR; + end GET; + + procedure PUT ( + FILE : in FILE_TYPE; + ITEM : in INTEGER; + WIDTH : in FIELD; + BASE : in NUMBER_BASE) is + + IMAGE : STRING (1..19); -- Max possible is "-2#[15 bits]#" + DIGIT : constant STRING (1..16) := "0123456789ABCDEF"; + POINTER : POSITIVE := IMAGE'LAST; + REST : INTEGER := abs ITEM; + +-- See chapter 14.3.7 + + begin + if BASE /= 10 then -- Make Ada standard based literal syntax + IMAGE (POINTER) := '#'; + POINTER := POINTER - 1; + end if; + if REST = 0 then + IMAGE (POINTER) := '0'; + POINTER := POINTER - 1; + end if; + while REST /= 0 loop -- Code the digits + IMAGE (POINTER) := DIGIT ((REST mod BASE) + 1); + POINTER := POINTER - 1; + REST := REST / BASE; + end loop; + if BASE /= 10 then + IMAGE (POINTER) := '#'; + POINTER := POINTER - 1; + REST := BASE; -- Code the base itself + while REST /= 0 loop + IMAGE (POINTER) := DIGIT ((REST mod 10) + 1); + POINTER := POINTER - 1; + REST := REST / 10; + end loop; + end if; + if ITEM < 0 then -- Put minus sign + IMAGE (POINTER) := '-'; + POINTER := POINTER - 1; + end if; + for I in IMAGE'LAST - POINTER + 1 .. WIDTH loop -- Put preceding spaces + PUT (FILE, ' '); + end loop; + PUT (FILE, IMAGE (POINTER + 1 .. IMAGE'LAST)); -- Put the slice + end PUT; + + procedure GET_INT (FROM : in STRING; + INDEX : in out POSITIVE; + INT : out INTEGER; + BASE : in out NUMBER_BASE; + HAS_EXP : in BOOLEAN := FALSE) is + + BASE_CHANGED : BOOLEAN := FALSE; + INCHAR : CHARACTER; + TEMP : INTEGER; + MINUS : BOOLEAN := FALSE; + ONUM : INTEGER; + + begin + ONUM := 0; + loop + INCHAR := FROM (INDEX); + case INCHAR is + when '0'..'9' | 'a'..'f' | 'A'..'F' => + if not BASE_CHANGED and (INCHAR = 'e' or INCHAR = 'E') then + exit; + else + TEMP := VALID_INT (BASE, INCHAR); + if TEMP > -1 then + ONUM := BASE * ONUM + TEMP; + else + raise DATA_ERROR; + end if; + end if; + when '#' | ':' => + if not BASE_CHANGED and not HAS_EXP and + (ONUM > 1 and ONUM < 17) then -- We have read the base + BASE := ONUM; + ONUM := 0; + BASE_CHANGED := TRUE; + else + INDEX := INDEX + 1; + exit; + end if; + when '-' => + if HAS_EXP then + MINUS := TRUE; + else + exit; + end if; + when '+' => + if not HAS_EXP then + exit; + end if; + when others => + exit; + end case; + exit when INDEX = FROM'LAST; + INDEX := INDEX + 1; + end loop; + if MINUS then + ONUM := - ONUM; + end if; + INT := ONUM; + end GET_INT; + + procedure GET ( + FROM : in STRING; + ITEM : out INTEGER; + LAST : out POSITIVE; + INBASE : in NUMBER_BASE) is + + INT : INTEGER; + BASE : NUMBER_BASE := INBASE; + L : POSITIVE; + ONUM : INTEGER; + ALREADY_SOMETHING : BOOLEAN := FALSE; + +-- See chapter 14.3.7 + + begin + L := FROM'FIRST; + loop + case FROM (L) is + when ' ' => + L := L + 1; + if ALREADY_SOMETHING then + exit; + end if; + when '-' => + if ALREADY_SOMETHING then + raise DATA_ERROR; + end if; + L := L + 1; + GET_INT (FROM, L, ONUM, BASE); + ONUM := - ONUM; + ALREADY_SOMETHING := TRUE; + when '+' => + if ALREADY_SOMETHING then + raise DATA_ERROR; + end if; + L := L + 1; + GET_INT (FROM, L, ONUM, BASE); + ALREADY_SOMETHING := TRUE; + when '0' .. '9' => + GET_INT (FROM, L, ONUM, BASE); + ALREADY_SOMETHING := TRUE; + when 'e' | 'E' => + if not ALREADY_SOMETHING then + raise DATA_ERROR; + end if; + L := L + 1; + GET_INT (FROM, L, INT, BASE, TRUE); + ONUM := ONUM * BASE ** INT; + exit; + when others => + raise DATA_ERROR; + end case; + exit when L = FROM'LAST; + end loop; + LAST := L; + ITEM := ONUM; + exception + when NUMERIC_ERROR => + raise DATA_ERROR; + end GET; + + procedure PUT ( + TO : out STRING; + ITEM : in INTEGER; + BASE : in NUMBER_BASE) is + + DIGIT : constant STRING (1..16) := "0123456789ABCDEF"; + POINTER : POSITIVE := TO'LAST; + REST : INTEGER := abs ITEM; + +-- See chapter 14.3.7 + + begin + if BASE /= 10 then -- Make Ada standard based literal syntax + TO (POINTER) := '#'; + POINTER := POINTER - 1; + end if; + if REST = 0 then + TO (POINTER) := '0'; + POINTER := POINTER - 1; + end if; + while REST /= 0 loop -- Code the digits + TO (POINTER) := DIGIT ((REST mod BASE) + 1); + POINTER := POINTER - 1; + REST := REST / BASE; + end loop; + if BASE /= 10 then + TO (POINTER) := '#'; + POINTER := POINTER - 1; + REST := BASE; -- Code the base itself + while REST /= 0 loop + TO (POINTER) := DIGIT ((REST mod 10) + 1); + POINTER := POINTER - 1; + REST := REST / 10; + end loop; + end if; + if ITEM < 0 then -- Put minus sign + TO (POINTER) := '-'; + POINTER := POINTER - 1; + end if; + TO (TO'FIRST .. POINTER) := (others => ' '); + end PUT; + + package body INTEGER_IO is + + procedure GET (FILE : in FILE_TYPE; + ITEM : out NUM; + WIDTH : in FIELD := DEFAULT_WIDTH) is + + ONUM : INTEGER; + + begin + GET (FILE, ONUM, WIDTH, DEFAULT_BASE); + ITEM := NUM (ONUM); + end GET; + + procedure GET (ITEM : out NUM; WIDTH : in FIELD := 0) is + + ONUM : INTEGER; + + begin + GET (CURR_INPUT, ONUM, WIDTH, DEFAULT_BASE); + ITEM := NUM (ONUM); + end GET; + + procedure PUT ( + FILE : in FILE_TYPE; + ITEM : in NUM; + WIDTH : in FIELD := DEFAULT_WIDTH; + BASE : in NUMBER_BASE := DEFAULT_BASE) is + begin + PUT (FILE, INTEGER (ITEM), WIDTH, BASE); + end PUT; + + procedure PUT ( + ITEM : in NUM; + WIDTH : in FIELD := DEFAULT_WIDTH; + BASE : in NUMBER_BASE := DEFAULT_BASE) is + + begin + PUT (CURR_OUTPUT, INTEGER (ITEM), WIDTH, BASE); + end PUT; + + procedure GET ( + FROM : in STRING; + ITEM : out NUM; + LAST : out POSITIVE) is + + ONUM : INTEGER; + + begin + GET (FROM, ONUM, LAST, DEFAULT_BASE); + ITEM := NUM (ONUM); + end GET; + + procedure PUT ( + TO : out STRING; + ITEM : in NUM; + BASE : in NUMBER_BASE := DEFAULT_BASE) is + + begin + PUT (TO, INTEGER (ITEM), BASE); + end PUT; + + end INTEGER_IO; + +-- +-- Floating point I/O +-- +-- The following utility procedures are not included in the body +-- of FLOAT_IO to decrease instantiation overhead. + + type SUCCESS_TYPE is + (NOTHING, BEFORE_PERIOD, AFTER_PERIOD, EXPONENT); + + procedure READ_INT (FILE : in FILE_TYPE; + MAX_WIDTH : in FIELD; + BASE : in out NUMBER_BASE; + NUMBER : in out FLOAT; + WHERE : in SUCCESS_TYPE; + COUNTER : out INTEGER; + STR : in STRING; + STR_INDEX : in out INTEGER; + USE_STRING: in BOOLEAN) is + + BASE_CHANGED : BOOLEAN := FALSE; + INCHAR : CHARACTER; + INT : INTEGER := 0; + TEMP : INTEGER; + MINUS : BOOLEAN := FALSE; + CTR : INTEGER; + + begin + CTR := 0; + STR_INDEX := STR_INDEX - 1; + loop + STR_INDEX := STR_INDEX + 1; + if USE_STRING then + INCHAR := STR (STR_INDEX); + else + READ (FILE, INCHAR); + end if; + CTR := CTR + 1; + case INCHAR is + when '0'..'9' | 'a'..'f' | 'A'..'F' => + if not BASE_CHANGED and (INCHAR = 'e' or INCHAR = 'E') then + if USE_STRING then + STR_INDEX := STR_INDEX - 1; + else + UNGET (FILE); + end if; + exit; + else + TEMP := VALID_INT (BASE, INCHAR); + if TEMP > -1 then + case WHERE is + when BEFORE_PERIOD => + NUMBER := BASE * NUMBER + FLOAT (TEMP); + when AFTER_PERIOD => + NUMBER := NUMBER + TEMP * FLOAT (BASE) + **(- CTR); + when EXPONENT => + INT := INT * 10 + TEMP; -- Get the exponent + when NOTHING => -- This should not happen + raise DATA_ERROR; + end case; + if not USE_STRING then + FILE . COL := FILE . COL + 1; + end if; + else -- Illegal character + raise DATA_ERROR; + end if; + end if; + when '#' | ':' => + if not USE_STRING then + FILE . COL := FILE . COL + 1; + end if; + if not BASE_CHANGED and WHERE = BEFORE_PERIOD and + (INT > 1 and INT < 17) then -- We have read the base + BASE := INT; + INT := 0; + BASE_CHANGED := TRUE; + elsif WHERE = AFTER_PERIOD then + exit; + else + raise DATA_ERROR; + end if; + when '-' => + if WHERE = EXPONENT then + MINUS := TRUE; + if not USE_STRING then + FILE . COL := FILE . COL + 1; + end if; + else + raise DATA_ERROR; + end if; + when '+' => + if WHERE /= EXPONENT then + raise DATA_ERROR; + end if; + if not USE_STRING then + FILE . COL := FILE . COL + 1; + end if; + when '.' => + if WHERE = BEFORE_PERIOD or MAX_WIDTH = 0 then + if USE_STRING then + STR_INDEX := STR_INDEX - 1; + else + UNGET (FILE); + end if; + exit; + else + raise DATA_ERROR; + end if; + when CR | LF | FF | EOF => -- Termination of input + if WHERE = BEFORE_PERIOD then + raise DATA_ERROR; + else + if USE_STRING then + STR_INDEX := STR_INDEX - 1; + else + UNGET (FILE); + end if; + exit; + end if; + when others => + if MAX_WIDTH = 0 then -- Termination of input + if USE_STRING then + STR_INDEX := STR_INDEX - 1; + else + UNGET (FILE); + end if; + exit; + else + raise DATA_ERROR; + end if; + end case; + exit when (CTR = MAX_WIDTH and MAX_WIDTH > 0) or + (USE_STRING and STR_INDEX = STR'LAST); + end loop; + if WHERE = EXPONENT then + if MINUS then + INT := - INT; + end if; + NUMBER := NUMBER * FLOAT (BASE) ** INT; + end if; + COUNTER := CTR; + end READ_INT; + + function EXPO (F : in FLOAT) return INTEGER is + + -- Returns the binary exponent of an IEEE floating-point + -- number. The bias (1023) is subtracted. + + E : INTEGER; + + begin + pragma NATIVE ( + 16#8B#, 16#44#, 16#06#, 16#25#, 16#F0#, 16#7F#, 16#D1#, 16#E8#, + 16#D1#, 16#E8#, 16#D1#, 16#E8#, 16#D1#, 16#E8#, 16#2D#, 16#FF#, + 16#03#, 16#89#, 16#05#); + return E; + end EXPO; + + procedure GET_STR_FILE (FILE : in FILE_TYPE; + ITEM : out FLOAT; + WIDTH : in FIELD := 0; + STR : in STRING; + STR_INDEX : in out INTEGER; + USE_STRING : in BOOLEAN) is + + SUCCESS : SUCCESS_TYPE := NOTHING; + INDEX : INTEGER; + COUNTER : INTEGER := 0; + INCHAR : CHARACTER; + BASE : NUMBER_BASE := 10; + ONUM : FLOAT; + MINUS : BOOLEAN := FALSE; + +-- See chapter 14.3.8 + + begin + if FILE = null then + raise STATUS_ERROR; + elsif FILE . MODE /= IN_FILE then + raise MODE_ERROR; + end if; + STR_INDEX := STR'FIRST - 1; + ONUM := 0.0; + loop + STR_INDEX := STR_INDEX + 1; + if USE_STRING then + INCHAR := STR (STR_INDEX); + else + READ (FILE, INCHAR); + end if; + case INCHAR is + when FF | CR | LF => + if WIDTH /= 0 or SUCCESS = AFTER_PERIOD or + SUCCESS = EXPONENT then + if USE_STRING then + STR_INDEX := STR_INDEX - 1; + else + UNGET (FILE); + end if; + exit; + end if; + when EOF => + if USE_STRING then + STR_INDEX := STR_INDEX - 1; + else + UNGET (FILE); + end if; + exit; + when ' ' => + if SUCCESS = NOTHING then + if not USE_STRING then + FILE . COL := FILE . COL + 1; + end if; + if WIDTH > 0 then + COUNTER := COUNTER + 1; + end if; + elsif SUCCESS = AFTER_PERIOD then + if USE_STRING then + STR_INDEX := STR_INDEX - 1; + else + UNGET (FILE); + end if; + exit; + else + raise DATA_ERROR; + end if; + when '-' => + if SUCCESS = NOTHING then + SUCCESS := BEFORE_PERIOD; + else + raise DATA_ERROR; + end if; + if USE_STRING then + STR_INDEX := STR_INDEX + 1; + else + FILE . COL := FILE . COL + 1; + end if; + if WIDTH > 0 then + COUNTER := COUNTER + 1; + end if; + READ_INT (FILE, WIDTH - COUNTER, BASE, ONUM, + SUCCESS, INDEX, STR, STR_INDEX, USE_STRING); + if WIDTH > 0 then + COUNTER := COUNTER + INDEX; + end if; + MINUS := TRUE; + when '+' => + if SUCCESS = NOTHING then + SUCCESS := BEFORE_PERIOD; + else + raise DATA_ERROR; + end if; + if USE_STRING then + STR_INDEX := STR_INDEX + 1; + else + FILE . COL := FILE . COL + 1; + end if; + if WIDTH > 0 then + COUNTER := COUNTER + 1; + end if; + READ_INT (FILE, WIDTH - COUNTER, BASE, ONUM, + SUCCESS, INDEX, STR, STR_INDEX, USE_STRING); + if WIDTH > 0 then + COUNTER := COUNTER + INDEX; + end if; + when '0' .. '9' => + if SUCCESS = NOTHING then + SUCCESS := BEFORE_PERIOD; + end if; + if not USE_STRING then + UNGET (FILE); + end if; + READ_INT (FILE, WIDTH - COUNTER, BASE, ONUM, + SUCCESS, INDEX, STR, STR_INDEX, USE_STRING); + if WIDTH > 0 then + COUNTER := COUNTER + INDEX; + end if; + when '.' => + if USE_STRING then + STR_INDEX := STR_INDEX + 1; + else + FILE . COL := FILE . COL + 1; + end if; + if WIDTH > 0 then + COUNTER := COUNTER + 1; + end if; + if SUCCESS = BEFORE_PERIOD then + SUCCESS := AFTER_PERIOD; + READ_INT (FILE, WIDTH - COUNTER, BASE, ONUM, + SUCCESS, INDEX, STR, STR_INDEX, USE_STRING); + if WIDTH > 0 then + COUNTER := COUNTER + INDEX; + end if; + else + raise DATA_ERROR; + end if; + when 'e' | 'E' => + if USE_STRING then + STR_INDEX := STR_INDEX + 1; + else + FILE . COL := FILE . COL + 1; + end if; + if WIDTH > 0 then + COUNTER := COUNTER + 1; + end if; + if SUCCESS = AFTER_PERIOD then + SUCCESS := EXPONENT; + READ_INT (FILE, WIDTH - COUNTER, BASE, ONUM, + SUCCESS, INDEX, STR, STR_INDEX, USE_STRING); + if WIDTH > 0 then + COUNTER := COUNTER + INDEX; + end if; + else + raise DATA_ERROR; + end if; + when others => + raise DATA_ERROR; + end case; + exit when (COUNTER >= WIDTH and WIDTH > 0) or (SUCCESS = EXPONENT) or + (USE_STRING and STR_INDEX = STR'LAST); + end loop; + if MINUS then + ONUM := - ONUM; + end if; + ITEM := ONUM; + exception + when NUMERIC_ERROR => + raise DATA_ERROR; + end GET_STR_FILE; + + INDEX : INTEGER; -- Index for FLOAT_STR + FLOAT_STR : STRING (1..30); -- Temporary string for PUT FLOAT to + -- a file or a string + + procedure PUT_STR + (ITEM : in FLOAT; + FORE, AFT, EXP : in FIELD) is + + X : FLOAT := ITEM; + T : FLOAT; + E, TEMP_INDEX : INTEGER; + D : INTEGER range 0..9; + MINUS_NUM : BOOLEAN; + AFTER : FIELD := AFT; + +-- See chapter 14.3.8 + + function TEN (EX : in INTEGER) return FLOAT is + + begin + return 10.0 ** EX; + end TEN; + + function CUT_SPACE (S : in STRING) return STRING is + + begin + return S (2..S'LAST); + end CUT_SPACE; + + function LENGTH (S : in STRING) return INTEGER is + + begin + return S'LENGTH; + end; + + begin -- PUT for FLOAT + FLOAT_STR (FLOAT_STR'FIRST .. FLOAT_STR'LAST) := (others => ' '); + INDEX := 1; + if AFTER = 0 then + AFTER := 1; + end if; + MINUS_NUM := X < 0.0; + X := abs X; + if X = 0.0 then -- Avoid peculiar exponent if zero + E := 0; + else + E := EXPO (FLOAT (X)); -- Process exponent + end if; + if X /= 0.0 then + E := ((E + 1) * 77) / 256; -- Convert to base 10 exponent + end if; + if TEN (E) > X then + E := E - 1; -- Correct integer arithmetic error + end if; + if EXP > 0 then + X := X / TEN (E); + end if; + if X /= 0.0 then + X := X + 0.5 * TEN (- AFTER); -- Rounding + end if; + if EXP > 0 and X >= 10.0 then + X := X / 10.0; + E := E + 1; + elsif EXP = 0 and X >= TEN (E + 1) then + E := E + 1; + end if; + -- Handle FORE + if X = 0.0 then -- X = 0: Special case + for I in 2 .. FORE loop + FLOAT_STR (INDEX) := ' '; + INDEX := INDEX + 1; + end loop; + FLOAT_STR (INDEX) := '0'; + INDEX := INDEX + 1; + elsif EXP > 0 then -- EXP > 0: Only one digit in FORE + if MINUS_NUM then + for I in 3 .. FORE loop + FLOAT_STR (INDEX) := ' '; + INDEX := INDEX + 1; + end loop; + FLOAT_STR (INDEX) := '-'; + INDEX := INDEX + 1; + else + for I in 2 .. FORE loop + FLOAT_STR (INDEX) := ' '; + INDEX := INDEX + 1; + end loop; + end if; + D := INTEGER (X - 0.5); -- Convert to TRUNC + if X - FLOAT (D) >= 1.0 then -- Rounded too much + D := D + 1; -- Add one to digit + end if; + FLOAT_STR (INDEX) := CHARACTER (D + 48); + INDEX := INDEX + 1; + X := (X - FLOAT (D)) * 10.0; + else -- EXP = 0: Put all digits in FORE + if E < 0 then + if MINUS_NUM then + for I in 3 .. FORE loop + FLOAT_STR (INDEX) := ' '; + INDEX := INDEX + 1; + end loop; + FLOAT_STR (INDEX) := '-'; + INDEX := INDEX + 1; + FLOAT_STR (INDEX) := '0'; + INDEX := INDEX + 1; + else + for I in 2 .. FORE loop + FLOAT_STR (INDEX) := ' '; + INDEX := INDEX + 1; + end loop; + FLOAT_STR (INDEX) := '0'; + INDEX := INDEX + 1; + end if; + elsif MINUS_NUM then -- E > 0 + for I in E + 3 .. FORE loop + FLOAT_STR (INDEX) := ' '; + INDEX := INDEX + 1; + end loop; + FLOAT_STR (INDEX) := '-'; + INDEX := INDEX + 1; + else -- E > 0 + for I in E + 2 .. FORE loop + FLOAT_STR (INDEX) := ' '; + INDEX := INDEX + 1; + end loop; + end if; + for I in reverse 0 .. E loop -- Take all the digits + T := TEN (I); + D := INTEGER (X / T - 0.5); -- Convert to TRUNC + X := X - D * T; + if X >= T then -- Rounded too much + D := D + 1; + X := X - T; + end if; + FLOAT_STR (INDEX) := CHARACTER (D + 48); + INDEX := INDEX + 1; + end loop; + X := X * 10.0; -- Prepare for AFT + end if; + -- Handle AFT + FLOAT_STR (INDEX) := '.'; + INDEX := INDEX + 1; + for I in 1..AFTER loop -- Put the mantissa + D := INTEGER (X - 0.5); -- Convert to TRUNC + if X - FLOAT (D) >= 1.0 then -- Rounded too much + D := D + 1; -- Add one to digit + end if; + FLOAT_STR (INDEX) := CHARACTER (D + 48); + INDEX := INDEX + 1; + X := (X - FLOAT (D)) * 10.0; + end loop; + -- Handle EXP + if EXP > 0 then + FLOAT_STR (INDEX) := 'E'; + INDEX := INDEX + 1; + if E >= 0 then + FLOAT_STR (INDEX) := '+'; + INDEX := INDEX + 1; + else + FLOAT_STR (INDEX) := '-'; + INDEX := INDEX + 1; + end if; + if E > 99 then + for I in 5 .. EXP loop + FLOAT_STR (INDEX) := '0'; + INDEX := INDEX + 1; + end loop; + elsif E > 9 then + for I in 4 .. EXP loop + FLOAT_STR (INDEX) := '0'; + INDEX := INDEX + 1; + end loop; + else + for I in 3 .. EXP loop + FLOAT_STR (INDEX) := '0'; + INDEX := INDEX + 1; + end loop; + end if; + TEMP_INDEX := INDEX + LENGTH (INTEGER'IMAGE (abs E)) - 2; + FLOAT_STR (INDEX..TEMP_INDEX) := CUT_SPACE (INTEGER'IMAGE (abs E)); + INDEX := TEMP_INDEX + 1; + end if; + INDEX := INDEX - 1; + end PUT_STR; + + package body FLOAT_IO is + + procedure GET (FILE : in FILE_TYPE; + ITEM : out NUM; + WIDTH : in FIELD := 0) is + + ONUM : FLOAT; + DUMMY: INTEGER; + + begin + GET_STR_FILE (FILE, ONUM, WIDTH, "", DUMMY, FALSE); + ITEM := NUM (ONUM); + end GET; + + procedure GET (ITEM : out NUM; WIDTH : in FIELD := 0) is + +-- See chapter 14.3.8 + + ONUM : FLOAT; + DUMMY : INTEGER; + + begin + GET_STR_FILE (CURR_INPUT, ONUM, WIDTH, "", DUMMY, FALSE); + ITEM := NUM (ONUM); + end GET; + + procedure PUT + (FILE : in FILE_TYPE; + ITEM : in NUM; + FORE : in FIELD := DEFAULT_FORE; + AFT : in FIELD := DEFAULT_AFT; + EXP : in FIELD := DEFAULT_EXP) is + + begin + PUT_STR (FLOAT (ITEM), FORE, AFT, EXP); + PUT (FILE, FLOAT_STR (FLOAT_STR'FIRST..INDEX)); + end PUT; + + procedure PUT (ITEM : in NUM; + FORE : in FIELD := DEFAULT_FORE; + AFT : in FIELD := DEFAULT_AFT; + EXP : in FIELD := DEFAULT_EXP) is + +-- See chapter 14.3.8 + + begin + PUT_STR (FLOAT (ITEM), FORE, AFT, EXP); + PUT (CURR_OUTPUT, FLOAT_STR (FLOAT_STR'FIRST..INDEX)); + end PUT; + + procedure GET (FROM : in STRING; + ITEM : out NUM; + LAST : out POSITIVE) is + +-- See chapter 14.3.8 + + ONUM : FLOAT; + LEN : INTEGER; + + begin + GET_STR_FILE (CURR_INPUT, ONUM, 0, FROM, LEN, TRUE); + ITEM := NUM (ONUM); + LAST := POSITIVE (LEN); + end GET; + + procedure PUT (TO : out STRING; + ITEM : in NUM; + AFT : in FIELD := DEFAULT_AFT; + EXP : in FIELD := DEFAULT_EXP) is + +-- See chapter 14.3.8 + + LEN : INTEGER; + + begin + LEN := FLOAT_STR'LENGTH - AFT - EXP - 3; -- 3 is for . E sign of E + if EXP = 0 then + LEN := LEN + 2; + end if; + PUT_STR (FLOAT (ITEM), LEN, AFT, EXP); + if TO'LENGTH = FLOAT_STR'LENGTH then + TO := FLOAT_STR; + elsif TO'LENGTH < FLOAT_STR'LENGTH then + TO := FLOAT_STR (FLOAT_STR'LAST - TO'LENGTH + 1..FLOAT_STR'LAST); + else + TO (TO'FIRST .. TO'LAST - FLOAT_STR'LENGTH) := (others => ' '); + TO (TO'LAST - FLOAT_STR'LENGTH + 1 .. TO'LAST) := FLOAT_STR; + end if; + end PUT; + + end FLOAT_IO; + +-- +-- Input / Output for Enumeration Types +-- + +-- The following utility subprograms are not included +-- in the body of ENUMERATION_IO to decrease instantiation overhead + + function LEGAL_ID_CHAR + (CH : in CHARACTER; FIRST : in BOOLEAN) return BOOLEAN is + + begin + if FIRST and CH in '0'..'9' then -- Id cannot begin with digit + return FALSE; + end if; + case CH is + when 'a'..'z' | 'A'..'Z' | '0'..'9' | '_' => + return TRUE; + when others => + return FALSE; + end case; + end LEGAL_ID_CHAR; + + procedure ASSIGN_STR + (S1 : out STRING; S2 : in STRING; L : out INTEGER) is + + begin + L := S2'LENGTH; + S1 (S2'RANGE) := S2; + end ASSIGN_STR; + + package body ENUMERATION_IO is + + MAX_IDENT_LENGTH : constant := 132; + + procedure GET (FILE : in FILE_TYPE; ITEM : out ENUM) is + +-- See chapter 14.3.9 + + CH : CHARACTER; + STR : STRING (1..MAX_IDENT_LENGTH); + I : INTEGER := 0; + + begin + GET (FILE, CH); -- Skipped leading garbage + if CH = ''' then -- Special case: Character literal, f.ex 'A' + STR (1) := CH; -- if TEXT_IO . ENUMERATION (CHARACTER) + READ (FILE, STR (2)); -- has been instantiated + READ (FILE, STR (3)); + FILE . COL := FILE . COL + 2; + I := 3; + else -- Input an identifier + while LEGAL_ID_CHAR (CH, I = 0) loop + I := I + 1; + STR (I) := CH; + READ (FILE, CH); + FILE . COL := FILE . COL + 2; + end loop; -- The identifier is now in STR (1..I) + UNGET (FILE); + end if; + ITEM := ENUM'VALUE (STR (1..I)); + exception + when CONSTRAINT_ERROR => -- Raised by ENUM'VALUE + raise DATA_ERROR; -- This was an illegal enum identifier + end; + + procedure GET (ITEM : out ENUM) is + +-- See chapter 14.3.9 + + begin + GET (CURR_INPUT, ITEM); + end GET; + + procedure PUT (FILE : in FILE_TYPE; + ITEM : in ENUM; + WIDTH : in FIELD := DEFAULT_WIDTH; + SET : in TYPE_SET := DEFAULT_SETTING) is + +-- See chapter 14.3.9 + + STR : STRING (1..MAX_IDENT_LENGTH); + LENGTH : INTEGER; + + begin + ASSIGN_STR (STR, ENUM'IMAGE (ITEM), LENGTH); + if (SET = LOWER_CASE) AND (STR (1) /= ''') then + for J in 1..LENGTH loop + if STR (J) in 'A'..'Z' then -- Convert to lower case + STR (J) := CHARACTER (INTEGER (STR (J)) + 32); + end if; + end loop; + end if; + PUT (FILE, STR (1..LENGTH)); + for I in LENGTH + 1..WIDTH loop + PUT (FILE, ' '); + end loop; + end PUT; + + procedure PUT (ITEM : in ENUM; + WIDTH : in FIELD := DEFAULT_WIDTH; + SET : in TYPE_SET := DEFAULT_SETTING) is + +-- See chapter 14.3.9 + + begin + PUT (CURR_OUTPUT, ITEM, WIDTH, SET); + end PUT; + + procedure GET (FROM : in STRING; + ITEM : out ENUM; + LAST : out POSITIVE) is + +-- See chapter 14.3.9 + + CH : CHARACTER; + I : INTEGER := FROM'FIRST; + FI : INTEGER; + L : POSITIVE; + + begin + loop + CH := FROM (I); + exit when (CH /= LF) or (CH /= CR) or (CH /= FF) or + (CH /= ' ') or (I = FROM'LAST); + I := I + 1; + end loop; -- Skipped leading blanks and line and page terminators + FI := I; + if CH = ''' then -- Special case: Character literal, for example 'A' + L := FI + 3; + ITEM := ENUM'VALUE (FROM (FI..L)); + else -- Input an identifier + while LEGAL_ID_CHAR (FROM (I), I = FI) AND (I < FROM'LAST) loop + I := I + 1; + end loop; + if I = FROM'LAST then + L := I; + else + L := I - 1; + end if; + ITEM := ENUM'VALUE (FROM (FI..L)); + end if; + LAST := L; + exception + when CONSTRAINT_ERROR => -- Raised by ENUM'VALUE + raise DATA_ERROR; -- This was an illegal enum identifier + end GET; + + procedure PUT ( + TO : out STRING; + ITEM : in ENUM; + SET : in TYPE_SET := DEFAULT_SETTING) is + +-- See chapter 14.3.9 + + LENGTH : INTEGER; + STR : STRING (1..MAX_IDENT_LENGTH); + + begin + ASSIGN_STR (STR, ENUM'IMAGE (ITEM), LENGTH); + if LENGTH > TO'LENGTH then + raise LAYOUT_ERROR; + end if; + if (SET = LOWER_CASE) AND (STR (1) /= ''') then + for J in 1..LENGTH loop + if STR (J) in 'A'..'Z' then -- Convert to lower case + STR (J) := CHARACTER (INTEGER (STR (J)) + 32); + end if; + end loop; + end if; + TO (TO'FIRST..TO'FIRST + LENGTH - 1) := STR (1..LENGTH); + for I in TO'FIRST + LENGTH..TO'LAST loop + TO (I) := ' '; + end loop; + end PUT; + + end ENUMERATION_IO; + +begin + -- Pre-opened files + DOS_INPUT := new FILE_DESCR'( + NAMELEN => 3, NAME => DOS_IO_NAME, + FORMLEN => 0, FORM => (others => ' '), + MODE => IN_FILE, + COL => 1, + LINE => 1, LINE_LENGTH => UNBOUNDED, + PAGE => 1, PAGE_LENGTH => UNBOUNDED, + HANDLE => IN_CONSOLE_HANDLE); + DOS_OUTPUT := new FILE_DESCR'( + NAMELEN => 3, NAME => DOS_IO_NAME, + FORMLEN => 0, FORM => (others => ' '), + MODE => OUT_FILE, + COL => 1, + LINE => 1, LINE_LENGTH => UNBOUNDED, + PAGE => 1, PAGE_LENGTH => UNBOUNDED, + HANDLE => OUT_CONSOLE_HANDLE); + CURR_INPUT := DOS_INPUT; + CURR_OUTPUT := DOS_OUTPUT; +end TEXT_IO; + \ No newline at end of file diff --git a/Artek Ada v125/TEXTIOS.ADA b/Artek Ada v125/TEXTIOS.ADA new file mode 100644 index 0000000..f1ffa49 --- /dev/null +++ b/Artek Ada v125/TEXTIOS.ADA @@ -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; + + \ No newline at end of file diff --git a/Artek Ada v125/TTT.ADA b/Artek Ada v125/TTT.ADA new file mode 100644 index 0000000..1c1e722 --- /dev/null +++ b/Artek Ada v125/TTT.ADA @@ -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; diff --git a/Artek Ada v125/UNCHECK.ADA b/Artek Ada v125/UNCHECK.ADA new file mode 100644 index 0000000..ec9dd5e --- /dev/null +++ b/Artek Ada v125/UNCHECK.ADA @@ -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; + + \ No newline at end of file diff --git a/Artek Ada v125/m.bat b/Artek Ada v125/m.bat new file mode 100644 index 0000000..7bf2616 --- /dev/null +++ b/Artek Ada v125/m.bat @@ -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 + +