CloudFlare suffered a massive security issue affecting all of its customers, including Rosetta Code. All passwords not changed since February 19th 2017 have been expired, and session cookie longevity will be reduced until late March.--Michael Mol (talk) 05:15, 25 February 2017 (UTC)

Execute SNUSP/Ada

From Rosetta Code
Execute SNUSP/Ada is an implementation of SNUSP. Other implementations of SNUSP.
Execute SNUSP/Ada is part of RCSNUSP. You may find other members of RCSNUSP at Category:RCSNUSP.
Works with: Ada 2005

Interpreter for Modular SNUSP.

First need some kind of storage for memory. Using Ada.Containers.Ordered_Maps for this. Only storing memory cells that have value /= 0, to save memory.

memory.ads:

with Ada.Finalization;
generic
type Byte is mod <>;
type Key_Type is private;
with function "<" (Left, Right : in Key_Type) return Boolean is <>;
package Memory is
 
type Memory is new Ada.Finalization.Limited_Controlled with private;
 
function Get_Value (Storage : in Memory; Key : in Key_Type) return Byte;
 
procedure Set_Value
(Storage : in out Memory;
Key  : in Key_Type;
Value  : in Byte);
 
procedure Increment (Storage : in out Memory; Key : in Key_Type);
 
procedure Decrement (Storage : in out Memory; Key : in Key_Type);
 
private
 
type Memory_Type;
 
type Memory_Access is access Memory_Type;
 
type Memory is new Ada.Finalization.Limited_Controlled with record
Cells : Memory_Access;
end record;
 
procedure Initialize (Storage : in out Memory);
procedure Finalize (Storage : in out Memory);
 
end Memory;

memory.adb:

with Ada.Containers.Ordered_Maps;
with Ada.Unchecked_Deallocation;
package body Memory is
 
package Memory_Maps is new Ada.Containers.Ordered_Maps (
Key_Type => Key_Type,
Element_Type => Byte);
use type Memory_Maps.Cursor;
 
type Memory_Type is record
Map : Memory_Maps.Map;
end record;
 
function Get_Value (Storage : in Memory; Key : in Key_Type) return Byte is
Result  : Byte  := 0;
Position : Memory_Maps.Cursor :=
Memory_Maps.Find (Storage.Cells.Map, Key);
begin
if Position /= Memory_Maps.No_Element then
Result := Memory_Maps.Element (Position);
end if;
return Result;
end Get_Value;
 
procedure Set_Value
(Storage : in out Memory;
Key  : in Key_Type;
Value  : in Byte)
is
Position : Memory_Maps.Cursor :=
Memory_Maps.Find (Storage.Cells.Map, Key);
begin
if Position = Memory_Maps.No_Element then
if Value /= 0 then
Memory_Maps.Insert (Storage.Cells.Map, Key, Value);
end if;
else
if Value = 0 then
Memory_Maps.Delete (Storage.Cells.Map, Key);
else
Memory_Maps.Replace (Storage.Cells.Map, Key, Value);
end if;
end if;
end Set_Value;
 
procedure Increment (Storage : in out Memory; Key : in Key_Type) is
Value : Byte := Get_Value (Storage, Key) + 1;
begin
Set_Value (Storage, Key, Value);
end Increment;
 
procedure Decrement (Storage : in out Memory; Key : in Key_Type) is
Value : Byte := Get_Value (Storage, Key) - 1;
begin
Set_Value (Storage, Key, Value);
end Decrement;
 
procedure Initialize (Storage : in out Memory) is
begin
Storage.Cells := new Memory_Type;
end Initialize;
 
procedure Finalize (Storage : in out Memory) is
procedure Free is new Ada.Unchecked_Deallocation (
Object => Memory_Type,
Name => Memory_Access);
begin
Memory_Maps.Clear (Storage.Cells.Map);
Free (Storage.Cells);
end Finalize;
 
end Memory;

Next is a Machine for interpreting SNUSP code.

snusp.ads:

with Ada.Containers.Vectors;
with Ada.Strings.Fixed;
with Ada.Text_IO;
with Memory;
package SNUSP is
 
type SNUSP_Machine is limited private;
 
type Code is array (Positive range <>, Positive range <>) of Character;
 
procedure Run (Machine : in out SNUSP_Machine; Input : in Code);
 
private
 
type Byte is mod 2 ** 8;
package Byte_Memory is new Memory (Byte => Byte, Key_Type => Positive);
 
type Direction is (Up, Down, Left, Right);
type Code_Pointer is record
X, Y : Positive  := 1;
Dir  : Direction := Right;
end record;
package Call_Stacks is new Ada.Containers.Vectors (
Index_Type => Positive,
Element_Type => Code_Pointer);
 
type SNUSP_Machine is limited record
Main_Memory  : Byte_Memory.Memory;
Current_Memory_Pointer : Positive := 1;
Call_Stack  : Call_Stacks.Vector;
IP  : Code_Pointer;
end record;
 
end SNUSP;

snusp.adb:

package body SNUSP is
 
procedure Move_IP (IP : in out Code_Pointer) is
begin
case IP.Dir is
when Up =>
IP.Y := IP.Y - 1;
when Down =>
IP.Y := IP.Y + 1;
when Left =>
IP.X := IP.X - 1;
when Right =>
IP.X := IP.X + 1;
end case;
end Move_IP;
 
procedure Process_Next_Instruction
(Machine : in out SNUSP_Machine;
Input  : in Code)
is
Instruction : Character := Input (Machine.IP.Y, Machine.IP.X);
begin
case Instruction is
when '>' =>
Machine.Current_Memory_Pointer := Machine.Current_Memory_Pointer +
1;
when '<' =>
Machine.Current_Memory_Pointer := Machine.Current_Memory_Pointer -
1;
when '+' =>
Byte_Memory.Increment
(Machine.Main_Memory,
Machine.Current_Memory_Pointer);
when '-' =>
Byte_Memory.Decrement
(Machine.Main_Memory,
Machine.Current_Memory_Pointer);
when ',' =>
declare
User_Input : Character;
Value  : Byte;
begin
Ada.Text_IO.Get_Immediate (User_Input);
Value := Character'Pos (User_Input);
Byte_Memory.Set_Value
(Machine.Main_Memory,
Machine.Current_Memory_Pointer,
Value);
end;
when '.' =>
declare
Value  : Byte  :=
Byte_Memory.Get_Value
(Machine.Main_Memory,
Machine.Current_Memory_Pointer);
Output : Character := Character'Val (Value);
begin
Ada.Text_IO.Put (Output);
end;
when '/' =>
case Machine.IP.Dir is
when Up =>
Machine.IP.Dir := Right;
when Down =>
Machine.IP.Dir := Left;
when Left =>
Machine.IP.Dir := Down;
when Right =>
Machine.IP.Dir := Up;
end case;
when '\' =>
case Machine.IP.Dir is
when Up =>
Machine.IP.Dir := Left;
when Down =>
Machine.IP.Dir := Right;
when Left =>
Machine.IP.Dir := Up;
when Right =>
Machine.IP.Dir := Down;
end case;
when '!' =>
Move_IP (Machine.IP);
when '?' =>
if Byte_Memory.Get_Value
(Machine.Main_Memory,
Machine.Current_Memory_Pointer) =
0
then
Move_IP (Machine.IP);
end if;
when '@' =>
Call_Stacks.Append (Machine.Call_Stack, Machine.IP);
when '#' =>
Machine.IP := Call_Stacks.Last_Element (Machine.Call_Stack);
Call_Stacks.Delete_Last (Machine.Call_Stack);
Move_IP (Machine.IP);
when others =>
null;
end case;
Move_IP (Machine.IP);
end Process_Next_Instruction;
 
procedure Run (Machine : in out SNUSP_Machine; Input : in Code) is
begin
-- find begin ($)
declare
Start_Found : Boolean := False;
begin
for Row in Input'Range (1) loop
for Col in Input'Range (2) loop
if Input (Row, Col) = '$' then
if Start_Found then
raise Program_Error;
end if;
Start_Found  := True;
Machine.IP.Y := Row;
Machine.IP.X := Col;
end if;
end loop;
end loop;
end;
 
loop
Process_Next_Instruction (Machine, Input);
end loop;
exception
when Constraint_Error =>
null;
end Run;
 
end SNUSP;

Sample usage:

main.adb:

with Ada.Text_IO;
with SNUSP;
procedure Main is
 
Test_Code : SNUSP.Code :=
(1 => "Example taken from RosettaCode.org ",
2 => " ",
3 => "$@\G.@\o.o.@\d.--b.@\y.@\e.>@\comma.@\.<-@\W.+@\o.+++r.------l.@\d.>+.! #",
4 => " | | \@------|# | \@@+@@++|+++#- \\ - ",
5 => " | \@@@@=+++++# | \===--------!\===!\-----|-------#-------/ ",
6 => " \@@+@@@+++++# \!#+++++++++++++++++++++++#!/ ");
 
My_SNUSP_Machine : SNUSP.SNUSP_Machine;
 
begin
 
SNUSP.Run (My_SNUSP_Machine, Test_Code);
 
end Main;

Output:

Goodbye, World!