diff -uNr a/ffa/MANIFEST.TXT b/ffa/MANIFEST.TXT --- a/ffa/MANIFEST.TXT fc1bdea6ee6bf8bb8c53a2012690cf585f482216a44fc7e0aaad542064a9f1b0c9f6f060cb539dda8b54759544a7f12aa87ac46121628a02eb3a43711741cb17 +++ b/ffa/MANIFEST.TXT 4b07f2d20d2c455fb34cd6ed8883f39164c4e048fc53a3e8cfadc1f6f1dd1f627c7b2dcf9cda5140e069d4602c07b6c17bc4b4922a90ebe328bcd171dbc7cf67 @@ -24,3 +24,4 @@ 612828 ffa_ch20d_litmus_nested_fix "Fix for bug where nested 'clearsigned' sigs were rejected." 629424 ffa_ch21a_bis_fix_ch15_gcd "Fix for lethal flaw in Ch.15's Greatest Common Divisor." 659788 ffa_ch21a_ter_ch14_ch20_errata "Fix for false alarm in Ch.14; Removal of two mutually-canceling bugs in Litmus." + 828719 ffa_dpmi_poc "Peh running under DPMI using ward (POC)." diff -uNr a/ffa/ffacalc/cmdline.adb b/ffa/ffacalc/cmdline.adb --- a/ffa/ffacalc/cmdline.adb 6f32ba846b2ddc89efecb4647890d79dc4cdf333185aa1821a8631583657aacde6d8528b95a7e2d98f71b9b0a174a8df0475f5f5f9f6b759a0baf1f3e256f86f +++ b/ffa/ffacalc/cmdline.adb 505e02836c0f81b57fcd4967a7ab5487b821247dbdd68c5b8e1121db861d71e7dfa3ffd074611e5781386a5d3582a4c4a25d6bdab840267772945be7312ec8f2 @@ -17,44 +17,53 @@ ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ -with System; use System; - package body CmdLine is - -- Test if GNAT's cmdline mechanism is available - function Initialized return Boolean is - gnat_argv : System.Address; - pragma Import (C, gnat_argv, "gnat_argv"); - + function Arg_Count return Natural is begin - return gnat_argv /= System.Null_Address; - end Initialized; - + return Count + 1; + end Arg_Count; -- Fill the provided string with the text of Number-th cmdline arg procedure Get_Argument(Number : in Natural; Result : out CmdLineArg) is begin - if Number >= Arg_Count or (not Initialized) then + if Number >= Arg_Count then raise Constraint_Error; end if; - declare - L : constant Integer := Len_Arg(Number); - Arg : aliased String(1 .. L); - begin - -- Will it fit into the available space? - if L > Result'Length then - raise Constraint_Error; - end if; - - -- Get this arg string from where GNAT stowed it - Fill_Arg(Arg'Address, Number); - - -- Copy it to Result: - Result := (others => ' '); - Result(Arg'Range) := Arg; - end; + Result := (others => ' '); + Result(Result'First .. Result'First + Length(Number) - 1) + := psp.Command_Tail(Start(Number) .. Finish(Number)); + end Get_Argument; + function Len_Arg (Arg_Num : Integer) return Integer is + begin + return Length(Arg_Num); + end Len_Arg; + +begin + + for i in 1 .. psp.Command_Tail_Length loop + if In_Argument_P then + if psp.Command_Tail(i) = Character'Val(16#20#) then + Finish(Count) := i - 1; + Length(Count) := i - Start(Count); + In_Argument_P := false; + end if; + else + if psp.Command_Tail(i) /= Character'Val(16#20#) then + Count := Count + 1; + Start(Count) := i; + In_Argument_P := true; + end if; + end if; + end loop; + + if in_argument_p then + Finish(Count) := psp.Command_Tail_Length; + Length(Count) := psp.Command_Tail_Length - Start(Count) + 1; + end if; + end CmdLine; diff -uNr a/ffa/ffacalc/cmdline.ads b/ffa/ffacalc/cmdline.ads --- a/ffa/ffacalc/cmdline.ads 38c999f7611a8733b8b8298ffd4f06c0f829dace631235465eced1e5973f945ee0e421bb0ffab7dc7cf2b6bdc7c3940dd1fc55ecf4bed6b7f202df68b9f23846 +++ b/ffa/ffacalc/cmdline.ads 7d556f0b059603411ff922328bcd591383f55a9530bc933f62c033451bd479261a7de763ffb2407acdbba7918fa573dc413d827d95f12eb4b41acb9b97cd27cf @@ -18,28 +18,38 @@ ------------------------------------------------------------------------------ with System; +with Weightless.DPMI; use Weightless.DPMI; package CmdLine is - - -- IMHO this is reasonable. - CmdLineArg_Length : constant Positive := 256; + pragma Elaborate_Body; + + CmdLineArg_Length : constant Positive := 127; subtype CmdLineArg is String(1 .. CmdLineArg_Length); - - function Initialized return Boolean; - + function Arg_Count return Natural; - pragma Import(C, Arg_Count, "__gnat_arg_count"); - + procedure Get_Argument(Number : in Natural; Result : out CmdLineArg); function Len_Arg (Arg_Num : Integer) return Integer; - pragma Import(C, Len_Arg, "__gnat_len_arg"); - + private - - procedure Fill_Arg (A : System.Address; Arg_Num : Integer); - pragma Import(C, Fill_Arg, "__gnat_fill_arg"); - + + PSP_Address : System.Address; + pragma Import(C, PSP_Address, "__psp_address"); + + PSP : Program_Segment_Prefix + with Address => PSP_Address, Alignment => 1; + pragma Import(Ada, PSP); + + In_Argument_P : Boolean := false; + + subtype Command_Line_Range is Natural range 1 .. 127; + + Start : array (1 .. 64) of Command_Line_Range; + Finish : array (1 .. 64) of Command_Line_Range; + Length : array (1 .. 64) of Command_Line_Range; + Count : Natural := 0; + end CmdLine; diff -uNr a/ffa/ffacalc/ffa_rng.adb b/ffa/ffacalc/ffa_rng.adb --- a/ffa/ffacalc/ffa_rng.adb 2f7f257e0ae6f10a8b865c9bc6fc904ee0a2ee24ebaf3a68f49959d9cccdba4c6f7b612c5e189ad7bc6d9b560b799c611d28c20755f68cf9592f2f5b2bf81fe1 +++ b/ffa/ffacalc/ffa_rng.adb 531c860f3a17940f4d62df1dc32decb67389ea0d3d7a2fa799813806111fd505c31308147b55d6d1fb5fd870e8d4929b217194af1fb6f44b06bd1e68c2da85aa @@ -36,6 +36,7 @@ when others => Eggog("Could not open RNG at : " & RNG_Unix_Path & "!"); end; + null; end Init_RNG; @@ -52,6 +53,7 @@ when others => Eggog("Could not read from RNG!"); end; + null; end FZ_Random; end FFA_RNG; diff -uNr a/ffa/ffacalc/ffa_rng.ads b/ffa/ffacalc/ffa_rng.ads --- a/ffa/ffacalc/ffa_rng.ads 26fdb67915e7b62c803d76892f63ec6df69c656d209ce5d1359ea310b67d019451e3caae52dba2c7afca472ba83880720776e9f3e589f1c905f5e5c68fa33960 +++ b/ffa/ffacalc/ffa_rng.ads 148d3d10695dbe718ad325946def66ab28eb254a82f606a45184a972f063001359d5fdcae9b92337d6aca6e3804ccfd60968bef17efcb2ea90817efc9afbefd3 @@ -25,7 +25,7 @@ package FFA_RNG is - Default_RNG_Path : constant String := "/dev/random"; + Default_RNG_Path : constant String := "AUX"; -- For reading from RNGs: package Word_IO is new Ada.Sequential_IO(Element_Type => Word); diff -uNr a/ffa/ffacalc/os.adb b/ffa/ffacalc/os.adb --- a/ffa/ffacalc/os.adb 05940de6b9b69ff1479bee3ef9bf100edb3cff903a3ec4a014d6b238643c576f1136fd5c0a48ed43c3c5234e576f317ccb2db45f21d0e2465320fb5cd1f2bd47 +++ b/ffa/ffacalc/os.adb a63f1b99a02a1aa5f1b0eb62b91c80d2c24f67f91b4491ad6ea6a0927d17b902a3ad36df490f13a14f190c36b5ab28af530c93c7653e1bbaa73e95d6ef759200 @@ -17,17 +17,26 @@ ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ +with Weightless.DPMI; use Weightless.DPMI; +with Weightless.DPMI.Character_IO; use Weightless.DPMI.Character_IO; +with Weightless.DPMI.File_IO; use Weightless.DPMI.File_IO; + package body OS is -- Receive a character from the TTY, and True if success (False if EOF) function Read_Char(C : out Character) return Boolean is - i : int; - Result : Boolean := False; - begin - i := GetChar; - if i /= EOF then - C := Character'Val(i); - Result := True; + Error : DOS_Error; + Result : Boolean := True; + A : aliased Character; + N : Natural; + begin + Error := Read_File(STANDARD_INPUT, A'Address, 1, N); + if Error /= NO_ERROR_OCCURED then + raise Program_Error; + end if; + C := A; + if N = 0 then + Result := False; end if; return Result; end Read_Char; @@ -35,38 +44,49 @@ -- Send a character to the TTY. procedure Write_Char(C : in Character) is - R : int; - pragma Unreferenced(R); begin - R := PutChar(int(Character'Pos(C))); + Write_Standard_Output(C); end Write_Char; -- Send a Newline to the TTY. procedure Write_Newline is begin + Write_Char(Character'Val(16#D#)); Write_Char(Character'Val(16#A#)); end Write_Newline; -- Send a String to the TTY. procedure Write_String(S : in String) is + Error : DOS_Error; + N : Natural; begin - for i in S'Range loop - Write_Char(S(i)); - end loop; + Error := Write_File(STANDARD_OUTPUT, S'Address, S'Length, N); + if Error /= NO_ERROR_OCCURED or else N /= S'Length then + raise Program_Error; + end if; end Write_String; -- Exit with an error condition report. procedure Eggog(M : String) is - begin - for i in 1 .. M'Length loop - To_Stderr(M(I)); - end loop; + Error : DOS_Error; + N : Natural; + CRLF : aliased String := Character'Val(16#D#) & + Character'Val(16#A#); + pragma Volatile(CRLF); + begin + Error := Write_File(STANDARD_ERROR, M'Address, M'Length, N); + if Error /= NO_ERROR_OCCURED or else N /= M'Length then + raise Program_Error; + end if; - -- Emit LF - To_Stderr(Character'Val(16#A#)); + -- Emit CRLF + Error := Write_File(STANDARD_ERROR, CRLF'Address, CRLF'Length, N); + if Error /= NO_ERROR_OCCURED or else N /= CRLF'Length then + raise Program_Error; + end if; -- Exit Quit(Sad_Code); @@ -74,13 +94,22 @@ -- Warn operator re: potentially-dangerous condition. procedure Achtung(M : String) is - begin - for i in 1 .. M'Length loop - To_Stderr(M(I)); - end loop; + Error : DOS_Error; + N : Natural; + CRLF : aliased String := Character'Val(16#D#) & + Character'Val(16#A#); + pragma Volatile(CRLF); + begin + Error := Write_File(STANDARD_ERROR, M'Address, M'Length, N); + if Error /= NO_ERROR_OCCURED or else N /= M'Length then + raise Program_Error; + end if; -- Emit LF - To_Stderr(Character'Val(16#A#)); + Error := Write_File(STANDARD_ERROR, CRLF'Address, CRLF'Length, N); + if Error /= NO_ERROR_OCCURED or else N /= CRLF'Length then + raise Program_Error; + end if; end Achtung; end OS; diff -uNr a/ffa/ffacalc/os.ads b/ffa/ffacalc/os.ads --- a/ffa/ffacalc/os.ads 43131dac54edfdfa3f300e333375a6080b331ccf51104f5ffd1648e1d17ef7b8a3925a101238cdc183557061e0e9b8340e91da20583c029ca9d1304ca0f40702 +++ b/ffa/ffacalc/os.ads 359e16c0e9296257eee75a787ec63158d04deb861bf1bd548148a942cc255d36bed00b32139a0223beb8beeb0395c37fbc5df0bbe2bdbeeab23305ee65873bca @@ -18,8 +18,9 @@ ------------------------------------------------------------------------------ with Interfaces; use Interfaces; -with Interfaces.C; use Interfaces.C; +--with Interfaces.C; use Interfaces.C; +with Weightless.DPMI.Process_Control; use Weightless.DPMI.Process_Control; package OS is @@ -41,31 +42,12 @@ -- Warn operator re: potentially-dangerous condition. procedure Achtung(M : String); - procedure Quit(Return_Code : Integer); - pragma Import - (Convention => C, - Entity => Quit, - External_Name => "exit"); + procedure Quit(Return_Code : Return_Code_Type) renames Terminate_Program; -- Result Codes for Termination - Yes_Code : constant Integer := 1; - No_Code : constant Integer := 0; - Mu_Code : constant Integer := -1; - Sad_Code : constant Integer := -2; - -private - - -- POSIX stdio: - EOF : constant int := -1; + Yes_Code : constant Return_Code_Type := 1; + No_Code : constant Return_Code_Type := 0; + Mu_Code : constant Return_Code_Type := -1; + Sad_Code : constant Return_Code_Type := -2; - function GetChar return int; - pragma Import(C, getchar); - - function PutChar(item: int) return int; - pragma Import(C, putchar); - - -- GNATistic - procedure To_Stderr(C : Character); - pragma Import(Ada, To_Stderr, "__gnat_to_stderr_char"); - end OS; diff -uNr a/ffa/ffacalc/peh.adb b/ffa/ffacalc/peh.adb --- a/ffa/ffacalc/peh.adb dfe0396cae073dabbbfb280a5075344b9cd5149f062004db94d849558575af12c61a992bb68133968e76a864065186714e97c146373ffcc769e20b4ef50a4859 +++ b/ffa/ffacalc/peh.adb bad108f906f880b85db139537ead67d7b93e52155e5ada8c18c7ecaa882edde757471203b5fd12701240fd2a5c818cc83950ed83a7b686f50e32dc2527dcb971 @@ -34,7 +34,7 @@ -- If a valid number of command line params was NOT given, print a likbez : if Arg_Count < 5 or Arg_Count > 6 then - Eggog("Usage: ./peh WIDTH HEIGHT TAPESPACE LIFE [/dev/rng]"); + Eggog("Usage: PEH width height tapespace life [RNG]"); end if; declare diff -uNr a/ffa/ffacalc/peh.gpr b/ffa/ffacalc/peh.gpr --- a/ffa/ffacalc/peh.gpr 49b8c0ba83c82375365bc0edcf9d69113d1a3abbcdb577c118171bbdb6245c68fd29e182a0a6b11d7d76b4742a28fa81909c99996ed9f6e4e1fbae195c3f6952 +++ b/ffa/ffacalc/peh.gpr 1a1e528004a1f1f7ff890e44d79e5a5ca80750ff5e10d24586899c144147473657119f8ad814869c632248adec21939b7949e979e046e63c428ab2df16fa85f8 @@ -38,9 +38,10 @@ use ("-g"); when "release" => for Switches ("Ada") - use ("-O2", "-fdump-scos", "-gnata", "-fstack-check", + use ("-O2", "-gnata", "-fstack-check", "-gnatyd", "-gnatym", - "-fdata-sections", "-ffunction-sections"); + "-fdata-sections", "-ffunction-sections", + "-gnatec=" & Peh'Project_Dir & "restrict.adc"); end case; end Compiler; diff -uNr a/ffa/ffacalc/restrict.adc b/ffa/ffacalc/restrict.adc --- a/ffa/ffacalc/restrict.adc false +++ b/ffa/ffacalc/restrict.adc b373d0596514a20658f6328559a3f54e3de989770ff309432520d76b74b49f9a6806d8e17138a313370f9e073104dd81c67abd16d1ebe05262a640bf87b68bae @@ -0,0 +1 @@ +pragma Restrictions(No_Exception_Propagation); diff -uNr a/ffa/libffa/ffa.gpr b/ffa/libffa/ffa.gpr --- a/ffa/libffa/ffa.gpr 21fd2701a60f083712880e75c2d1b0f24d71c958e14f24a1666b039ea0ff2efba3eed79a9f8a608a2161edddb37b648b4871e0a40ab6d70b44ffb53fd8fe47b4 +++ b/ffa/libffa/ffa.gpr 8db3501ec3ab001c0db8cd6bb13001d711708b22a0357870c7fc6a9dc5951ceafd3152493d1beec00f3feb5669c70650748b87fc370c49eff3f3be99b60fb628 @@ -53,7 +53,7 @@ use ("-g"); when "release" => for Switches ("Ada") - use ("-O2", "-fdump-scos", "-gnata", "-fstack-check", + use ("-O2", "-gnata", "-fstack-check", "-gnatyd", "-gnatym", "-fdata-sections", "-ffunction-sections", "-gnatwr", "-gnatw.d", "-gnatec=" & FFA'Project_Dir & "restrict.adc"); diff -uNr a/ffa/libffa/fz_mul.ads b/ffa/libffa/fz_mul.ads --- a/ffa/libffa/fz_mul.ads 3c5d5273ab2eef6466bd84dde5d07580d94f37265f94dfa2d838299f713c029111daef9fcabe90da83a9b2aec5ada218000fbf9f14e918c16b455221e57e845b +++ b/ffa/libffa/fz_mul.ads f30f504bb7c3ffe3d3d8a13ebca8758c0673d3b53bbeab02ee4bdde5aaa8b6819d388848c454339304e7f3257175a22cd9afbfa99ee0d0402559689b32ce6d98 @@ -37,7 +37,7 @@ procedure FZ_Mul_Comba(X : in FZ; Y : in FZ; XY : out FZ); - pragma Inline_Always(FZ_Mul_Comba); + --pragma Inline_Always(FZ_Mul_Comba); -- Karatsuba's Multiplier. (CAUTION: UNBUFFERED) procedure Mul_Karatsuba(X : in FZ; diff -uNr a/ffa/libffa/fz_sqr.ads b/ffa/libffa/fz_sqr.ads --- a/ffa/libffa/fz_sqr.ads 623437f526af813a67934ad1775dcf808bea6d81ddd86871c1508e822b107d4a033db361b10bae54126b2de095432ba4cecd733a4833d00e19a551a8051a8ee2 +++ b/ffa/libffa/fz_sqr.ads e3ef8a896dd2eaefd5cb0d9aad5e57878913a5e9804a741517ff5450294f6401d1526494f68791e7787efa8a14dda3b8fa7455debc53acc0d1ea98e2d4e3a6af @@ -35,7 +35,7 @@ -- Comba's squaring. (CAUTION: UNBUFFERED) procedure FZ_Sqr_Comba(X : in FZ; XX : out FZ); - pragma Inline_Always(FZ_Sqr_Comba); + --pragma Inline_Always(FZ_Sqr_Comba); -- Karatsuba's Squaring. (CAUTION: UNBUFFERED) procedure Sqr_Karatsuba(X : in FZ; diff -uNr a/ffa/libffa/iron.ads b/ffa/libffa/iron.ads --- a/ffa/libffa/iron.ads 528072d08137c29163c651c1fcd9a56787f4e6cbcc72bd7a090d24588f79889a81fad33b1bfcf6ce611c5b3ecd07642bfec7cb3db63699832059d97d0bff0717 +++ b/ffa/libffa/iron.ads 6beaf9cca5f7f2b5f9b9fac8a98cba94c306cc146687a14934d9a667e83ddbb0fb71fb126cd5589f85eefb88e3158f686e188a1525532f6773941ccd0fbd48e3 @@ -24,15 +24,15 @@ -------------------------------------- -------- For a 64-bit system: -------- -------------------------------------- - MachineBitness : constant Positive := 64; - MachineBitnessLog2 : constant Positive := 6; -- log2(64) + -- MachineBitness : constant Positive := 64; + -- MachineBitnessLog2 : constant Positive := 6; -- log2(64) -------------------------------------- -------------------------------------- -------- For a 32-bit system: -------- -------------------------------------- - -- MachineBitness : constant Positive := 32; - -- MachineBitnessLog2 : constant Positive := 5; -- log2(32) + MachineBitness : constant Positive := 32; + MachineBitnessLog2 : constant Positive := 5; -- log2(32) -------------------------------------- -- Bits per Byte diff -uNr a/ffa/libffa/restrict.adc b/ffa/libffa/restrict.adc --- a/ffa/libffa/restrict.adc 9e6fc99f6ea080396c3c1a6358b7dde04b241f3ffeac951bb389efecadccc3b5578b500bcb1bb9a8ccccb8026af38f7fa2e9d2a07ddbd054961b3f452cdc4ae2 +++ b/ffa/libffa/restrict.adc 3ca5ec8d87880984894d45a4cacd6ea3f60c183ad9dc343c642d8f72af3bbdf298fc47d7df8965e1e010e4c3e69a89fe748a7119012ea9b81b1ac22a2562ad6f @@ -41,7 +41,7 @@ pragma Restrictions(No_Exception_Propagation); pragma Restrictions(No_Exception_Registration); pragma Restrictions(No_Finalization); -pragma Restrictions(No_Fixed_Io); +--pragma Restrictions(No_Fixed_Io); pragma Restrictions(No_Floating_Point); pragma Restrictions(No_Implementation_Aspect_Specifications); pragma Restrictions(No_Implementation_Units); @@ -49,12 +49,12 @@ pragma Restrictions(No_Implicit_Conditionals); pragma Restrictions(No_Implicit_Dynamic_Code); pragma Restrictions(No_Implicit_Heap_Allocations); -pragma Restrictions(No_Implicit_Protected_Object_Allocations); -pragma Restrictions(No_Implicit_Task_Allocations); +--pragma Restrictions(No_Implicit_Protected_Object_Allocations); +--pragma Restrictions(No_Implicit_Task_Allocations); pragma Restrictions(No_Initialize_Scalars); pragma Restrictions(No_Local_Protected_Objects); pragma Restrictions(No_Local_Timing_Events); -pragma Restrictions(No_Multiple_Elaboration); +--pragma Restrictions(No_Multiple_Elaboration); pragma Restrictions(No_Nested_Finalization); pragma Restrictions(No_Protected_Type_Allocators); pragma Restrictions(No_Protected_Types); @@ -67,7 +67,7 @@ pragma Restrictions(No_Stream_Optimizations); pragma Restrictions(No_Streams); pragma Restrictions(No_Task_Allocators); -pragma Restrictions(No_Task_At_Interrupt_Priority); +--pragma Restrictions(No_Task_At_Interrupt_Priority); pragma Restrictions(No_Task_Attributes_Package); pragma Restrictions(No_Task_Hierarchy); pragma Restrictions(No_Tasking); @@ -77,7 +77,7 @@ pragma Restrictions(No_Unchecked_Conversion); pragma Restrictions(No_Unchecked_Deallocation); pragma Restrictions(No_Wide_Characters); -pragma Restrictions(Pure_Barriers); +--pragma Restrictions(Pure_Barriers); pragma Restrictions(Simple_Barriers); pragma Restrictions(Static_Priorities); pragma Restrictions(Static_Storage_Size); diff -uNr a/ffa/libffa/w_mul.ads b/ffa/libffa/w_mul.ads --- a/ffa/libffa/w_mul.ads d4f70ca1801350af790c22469a84d8eadeba8e5dc89143e610bc5f0aeebc37a42f980cc58d74d28e1a9f127be18f565978233f7ee1e92d5d57dfffca9114c8c1 +++ b/ffa/libffa/w_mul.ads 0be49239e6782e9d5a31edee2f3b298a95f713d0323c01818f5bd5846f227cb75e6f5c7931529643200fe5312aa0632211a87cfa1c7f7d2935d73dc4e58767e7 @@ -37,7 +37,7 @@ -- Multiply half-words X and Y, producing a Word-sized product (Egyptian) function Mul_HalfWord_Soft(X : in HalfWord; Y : in HalfWord) return Word; - pragma Inline_Always(Mul_HalfWord_Soft); + --pragma Inline_Always(Mul_HalfWord_Soft); -- Get the bottom half of a Word function BottomHW(W : in Word) return HalfWord;