I am trying to set a service's failure actions using Inno Setup's Pascal scripting language. I receive the classic "access violation at address..." error. Seems that it is impossible because the language don't have any support to pointers. Any ideas? Here is the code snippet:
type
TScAction = record
aType1 : Longword;
Delay1 : Longword;
aType2 : Longword;
Delay2 : Longword;
aType3 : Longword;
Delay3 : Longword;
end;
type
TServiceFailureActionsA = record
dwResetPeriod : DWORD;
pRebootMsg : String;
pCommand : String;
cActions : DWORD;
saActions : TScAction;
end;
function ChangeServiceConfig2(hService: Longword; dwInfoLevel: Longword; lpInfo: TServiceFailureActionsA): BOOL;
external 'ChangeServiceConfig2A#advapi32.dll stdcall';
procedure SimpleChangeServiceConfig(AService: string);
var
SCMHandle: Longword;
ServiceHandle: Longword;
sfActions: TServiceFailureActionsA;
sActions: TScAction;
begin
try
SCMHandle := OpenSCManager('', '', SC_MANAGER_ALL_ACCESS);
if SCMHandle = 0 then
RaiseException('SimpleChangeServiceConfig#OpenSCManager: ' + AService + ' ' +
SysErrorMessage(DLLGetLastError));
try
ServiceHandle := OpenService(SCMHandle, AService, SERVICE_ALL_ACCESS);
if ServiceHandle = 0 then
RaiseException('SimpleChangeServiceConfig#OpenService: ' + AService + ' ' +
SysErrorMessage(DLLGetLastError));
try
sActions.aType1 := SC_ACTION_RESTART;
sActions.Delay1 := 60000; // First.nDelay: in milliseconds, MMC displayed in minutes
sActions.aType2 := SC_ACTION_RESTART;
sActions.Delay2 := 60000;
sActions.aType3 := SC_ACTION_RESTART;
sActions.Delay3 := 60000;
sfActions.dwResetPeriod := 1; // in seconds, MMC displayes in days
//sfActions.pRebootMsg := null; // reboot message unchanged
//sfActions.pCommand := null; // command line unchanged
sfActions.cActions := 3; // first, second and subsequent failures
sfActions.saActions := sActions;
if not ChangeServiceConfig2(
ServiceHandle, // handle to service
SERVICE_CONFIG_FAILURE_ACTIONS, // change: description
sfActions) // new description
then
RaiseException('SimpleChangeServiceConfig#ChangeServiceConfig2: ' + AService + ' ' +
SysErrorMessage(DLLGetLastError));
finally
if ServiceHandle <> 0 then
CloseServiceHandle(ServiceHandle);
end;
finally
if SCMHandle <> 0 then
CloseServiceHandle(SCMHandle);
end;
except
ShowExceptionMessage;
end;
end;
You have two problems in your script. Like Deanna suggested you have to use the var keyword in the declaration of the lpInfo parameter.
Also you need to change the TScAction type to an array with two elements.
Here is my script that you can include in your Inno Setup script.
const
SERVICE_CONFIG_DELAYED_AUTO_START_INFO = 3; //The lpInfo parameter is a pointer to a SERVICE_DELAYED_AUTO_START_INFO structure.
//Windows Server 2003 and Windows XP: This value is not supported.
SERVICE_CONFIG_DESCRIPTION = 1; //The lpInfo parameter is a pointer to a SERVICE_DESCRIPTION structure.
SERVICE_CONFIG_FAILURE_ACTIONS = 2; //The lpInfo parameter is a pointer to a SERVICE_FAILURE_ACTIONS structure.
//If the service controller handles the SC_ACTION_REBOOT action, the caller must have
// the SE_SHUTDOWN_NAME privilege. For more information, see Running with Special Privileges.
SERVICE_CONFIG_FAILURE_ACTIONS_FLAG = 4; //The lpInfo parameter is a pointer to a SERVICE_FAILURE_ACTIONS_FLAG structure.
//Windows Server 2003 and Windows XP: This value is not supported.
SERVICE_CONFIG_PREFERRED_NODE = 9; //The lpInfo parameter is a pointer to a SERVICE_PREFERRED_NODE_INFO structure.
//Windows Server 2008, Windows Vista, Windows Server 2003, and Windows XP: This value is not supported.
SERVICE_CONFIG_PRESHUTDOWN_INFO = 7; //The lpInfo parameter is a pointer to a SERVICE_PRESHUTDOWN_INFO structure.
//Windows Server 2003 and Windows XP: This value is not supported.
SERVICE_CONFIG_REQUIRED_PRIVILEGES_INFO = 6; //The lpInfo parameter is a pointer to a SERVICE_REQUIRED_PRIVILEGES_INFO structure.
//Windows Server 2003 and Windows XP: This value is not supported.
SERVICE_CONFIG_SERVICE_SID_INFO = 5; //The lpInfo parameter is a pointer to a SERVICE_SID_INFO structure.
SERVICE_CONFIG_TRIGGER_INFO = 8; //The lpInfo parameter is a pointer to a SERVICE_TRIGGER_INFO structure.
//This value is not supported by the ANSI version of ChangeServiceConfig2.
//Windows Server 2008, Windows Vista, Windows Server 2003, and Windows XP: This value is not supported until Windows Server 2008 R2.
SC_ACTION_NONE = 0; // No action.
SC_ACTION_REBOOT = 2; // Reboot the computer.
SC_ACTION_RESTART = 1; // Restart the service.
SC_ACTION_RUN_COMMAND = 3; // Run a command.
type
TScAction = record
aType1 : Longword;
Delay1 : Longword;
end;
type
TServiceFailureActionsA = record
dwResetPeriod : DWORD;
pRebootMsg : String;
pCommand : String;
cActions : DWORD;
saActions : array of TScAction;
end;
function ChangeServiceConfig2(
hService: Longword;
dwInfoLevel: Longword;
var lpInfo: TServiceFailureActionsA): BOOL;
external 'ChangeServiceConfig2A#advapi32.dll stdcall';
procedure SimpleChangeServiceConfig(AService: string);
var
SCMHandle: Longword;
ServiceHandle: Longword;
sfActions: TServiceFailureActionsA;
sActions: array of TScAction;
begin
SetArrayLength(sActions ,3);
try
SCMHandle := OpenSCManager('', '', SC_MANAGER_ALL_ACCESS);
if SCMHandle = 0 then
RaiseException('SimpleChangeServiceConfig#OpenSCManager: ' + AService + ' ' +
SysErrorMessage(DLLGetLastError));
try
ServiceHandle := OpenService(SCMHandle, AService, SERVICE_ALL_ACCESS);
if ServiceHandle = 0 then
RaiseException('SimpleChangeServiceConfig#OpenService: ' + AService + ' ' +
SysErrorMessage(DLLGetLastError));
try
sActions[0].aType1 := SC_ACTION_RESTART;
sActions[0].Delay1 := 60000; // First.nDelay: in milliseconds, MMC displayed in minutes
sActions[1].aType1 := SC_ACTION_RESTART;
sActions[1].Delay1 := 60000;
sActions[2].aType1 := SC_ACTION_NONE;
sActions[2].Delay1 := 60000;
sfActions.dwResetPeriod := 1; // in seconds, MMC displayes in days
//sfActions.pRebootMsg := null; // reboot message unchanged
//sfActions.pCommand := null; // command line unchanged
sfActions.cActions := 3; // first, second and subsequent failures
sfActions.saActions := sActions;
if not ChangeServiceConfig2(
ServiceHandle, // handle to service
SERVICE_CONFIG_FAILURE_ACTIONS, // change: description
sfActions) // new description
then
RaiseException('SimpleChangeServiceConfig#ChangeServiceConfig2: ' + AService + ' ' +
SysErrorMessage(DLLGetLastError));
finally
if ServiceHandle <> 0 then
CloseServiceHandle(ServiceHandle);
end;
finally
if SCMHandle <> 0 then
CloseServiceHandle(SCMHandle);
end;
except
ShowExceptionMessage;
end;
end;
Try using the var keyword in the declaration for the lpInfo parameter to specify that it's to pass a pointer to the structure to the function.
Related
I'm attempting to write code for a buffer in NuSMV. The buffer has 6 wires. 4 input wires (reset, clock, read_enable, and write_enable) and 2 output wires(full and empty). Wires are modeled as boolean true|false (true being high voltage). The first
wire is an asynchronous (instant) reset. If there is a high voltage, the buffer
goes instantly to the empty configuration. Other wires are operated in the
synchronous mode triggered by a rising edge on the clock wire. The buffer is of Size 3. There are specific behaviors.
I created the following code but I cannot think of what the Main Module could be.
MODULE buffer (reset, clock, read_enable, write_enable, full, empty)
-- inputs
-- reset : boolean; -- asynchronous (instant) reset
-- clock : boolean; -- clock
-- read_enable : boolean; -- data read request = enqueue
-- write_enable : boolean; -- data write request = dequeue
-- outputs
-- full : boolean; -- is the buffer full?
-- empty : boolean; -- is the buffer empty?
-- use SIZE for the maximal buffer size
-- TODO ....
VAR
reset: {False, True};
clock: {False, True};
read_enable: {False, True};
write_enable: {False, True};
full: {False, True};
empty: {False, True};
ASSIGN
SIZE := 0;
init (reset) := True;
next (reset) := case
reset = True : empty = True;
esac;
next (clock) := case
write_enable = True : clock = True & empty = False;
esac;
next (write_enable):= case
write_enable = True : SIZE + 1 & SIZE <=3;
esac;
next (read_enable) := case
write_enable = True & read_enable = True : SIZE != SIZE +1;
esac;
next (full) := case
full = True & SIZE = 3 & write_enable = True : reset = True;
esac;
MODULE main
VAR
reset: boolean;
turn: boolean;
pro0: process buffer(reset, 0, clock, read_enable, write_enable);
pro1: process buffer(reset, 1, clock, read_enable, write_enable);
ASSIGN
init(turn) := 0;
FAIRNESS !(reset = True)
FAIRNESS !(reset = False)
MODULE prc(reset, turn, pro0, pro1)
ASSIGN
init(reset) := 0;
next (reset) := case
(reset = 0) : {0,1};
(reset = 1) : {0};
1 : reset;
esac;
Please assist
I've tried following basic NuSMV guides on how to write the code but I have no experience in this language.
I have downloaded this program from Github: https://github.com/raph-amiard/ada-synth-lib
I have attemted the first example and I am presented with an exception. If anybody would be able to give me an insight into why this is, it would be massively appreciated. I've been stumped on this for a long time and I'm really keen to get this working.
The error I recieve is: raised PROGRAM_ERROR : waves.adb:110 accessibility check failed
Here is the main file:
with Waves; use Waves;
with Write_To_Stdout;
procedure Main is
Sine_Gen : constant access Sine_Generator := Create_Sine (Fixed (440.0));
begin
Write_To_Stdout (Sine_Gen);
end Main;
Here is the waves.adb file
with Effects; use Effects;
with Interfaces; use Interfaces;
package body Waves is
function Mod_To_Int (A : Unsigned_32) return Integer_32;
-------------------
-- Update_Period --
-------------------
procedure Update_Period
(Self : in out Wave_Generator'Class; Buffer : in out Period_Buffer)
is
begin
Self.Frequency_Provider.Next_Samples (Buffer);
for I in Buffer'Range loop
Buffer (I) :=
Utils.Period_In_Samples
(Frequency (Buffer (I)));
end loop;
end Update_Period;
------------
-- Create --
------------
function Create_Saw
(Freq_Provider : Generator_Access) return access Saw_Generator
is
begin
return new Saw_Generator'(Frequency_Provider => Freq_Provider,
Current => -1.0, others => <>);
end Create_Saw;
-----------------
-- Next_Sample --
-----------------
overriding procedure Next_Samples
(Self : in out Saw_Generator; Buffer : in out Generator_Buffer)
is
P_Buffer : Period_Buffer;
begin
Update_Period (Self, P_Buffer);
for I in Buffer'Range loop
Self.Step := 2.0 / Float (P_Buffer (I));
Self.Current := Self.Current + Sample (Self.Step);
if Self.Current > 1.0 then
Self.Current := Self.Current - 2.0;
end if;
Buffer (I) := Self.Current;
end loop;
end Next_Samples;
------------
-- Create --
------------
function Create_Square
(Freq_Provider : access Generator'Class) return access Square_Generator is
begin
return new Square_Generator'(Frequency_Provider =>
Generator_Access (Freq_Provider),
Is_High => True,
Current_Sample => 0,
others => <>);
end Create_Square;
-----------------
-- Next_Sample --
-----------------
overriding procedure Next_Samples
(Self : in out Square_Generator; Buffer : in out Generator_Buffer)
is
P_Buffer : Period_Buffer;
begin
Update_Period (Self, P_Buffer);
for I in Buffer'Range loop
Self.Current_Sample := Self.Current_Sample + 1;
declare
A : constant Period := Period (Self.Current_Sample)
/ P_Buffer (I);
begin
if A >= 1.0 then
Self.Current_Sample := 0;
Buffer (I) := 1.0;
end if;
Buffer (I) := (if A >= 0.5 then 1.0 else -1.0);
end;
end loop;
end Next_Samples;
------------
-- Create --
------------
function Create_Sine
(Freq_Provider : access Generator'Class) return access Sine_Generator
is
Ret : constant access Sine_Generator :=
new Sine_Generator'(Frequency_Provider =>
Generator_Access (Freq_Provider),
Current_Sample => 0,
Current_P => 0.0,
others => <>);
begin
Ret.Current_P := 0.0;
return Ret;
end Create_Sine;
-----------------
-- Next_Sample --
-----------------
overriding procedure Next_Samples
(Self : in out Sine_Generator; Buffer : in out Generator_Buffer)
is
P_Buffer : Period_Buffer;
begin
Update_Period (Self, P_Buffer);
for I in Buffer'Range loop
Self.Current_Sample := Self.Current_Sample + 1;
if Period (Self.Current_Sample) >= Self.Current_P then
Self.Current_P := P_Buffer (I) * 2.0;
Self.Current_Sample := 0;
end if;
Buffer (I) :=
Sample
(Sin
(Float (Self.Current_Sample)
/ Float (Self.Current_P) * Pi * 2.0));
end loop;
end Next_Samples;
------------
-- Create --
------------
function Create_Chain
(Gen : access Generator'Class;
Sig_Procs : Signal_Processors
:= No_Signal_Processors) return access Chain
is
Ret : constant access Chain :=
new Chain'(Gen => Generator_Access (Gen), others => <>);
begin
for P of Sig_Procs loop
Ret.Add_Processor (P);
end loop;
return Ret;
end Create_Chain;
-------------------
-- Add_Processor --
-------------------
procedure Add_Processor
(Self : in out Chain; P : Signal_Processor_Access) is
begin
Self.Processors (Self.Nb_Processors) := P;
Self.Nb_Processors := Self.Nb_Processors + 1;
end Add_Processor;
-----------------
-- Next_Sample --
-----------------
overriding procedure Next_Samples
(Self : in out Chain; Buffer : in out Generator_Buffer)
is
S : Sample;
begin
Self.Gen.Next_Samples (Buffer);
for J in Buffer'Range loop
S := Buffer (J);
for I in 0 .. Self.Nb_Processors - 1 loop
S := Self.Processors (I).Process (S);
end loop;
Buffer (J) := S;
end loop;
end Next_Samples;
---------
-- LFO --
---------
function LFO (Freq : Frequency; Amplitude : Float) return Generator_Access
is
Sin : constant Generator_Access := Create_Sine (Fixed (Freq));
begin
return new Attenuator'
(Level => Amplitude,
Source => new Transposer'(Source => Sin, others => <>), others => <>);
end LFO;
------------
-- Create --
------------
function Create_ADSR
(Attack, Decay, Release : Millisecond; Sustain : Scale;
Source : access Note_Generator'Class := null) return access ADSR
is
begin
return new ADSR'
(State => Off,
Source => Source,
Attack => Msec_To_Period (Attack),
Decay => Msec_To_Period (Decay),
Release => Msec_To_Period (Release),
Sustain => Sustain,
Current_P => 0, others => <>);
end Create_ADSR;
-----------------
-- Next_Sample --
-----------------
overriding procedure Next_Samples
(Self : in out ADSR; Buffer : in out Generator_Buffer)
is
Ret : Sample;
begin
for I in Buffer'Range loop
case Self.Source.Buffer (I).Kind is
when On =>
Self.Current_P := 0;
Self.State := Running;
when Off =>
Self.State := Release;
Self.Cur_Sustain := Scale (Self.Memo_Sample);
Self.Current_P := 0;
when No_Signal => null;
end case;
Self.Current_P := Self.Current_P + 1;
case Self.State is
when Running =>
if Self.Current_P in 0 .. Self.Attack then
Ret := Exp8_Transfer
(Sample (Self.Current_P) / Sample (Self.Attack));
elsif
Self.Current_P in Self.Attack + 1 .. Self.Attack + Self.Decay
then
Ret :=
Exp8_Transfer
(Float (Self.Decay + Self.Attack - Self.Current_P)
/ Float (Self.Decay));
Ret := Ret
* Sample (1.0 - Self.Sustain)
+ Sample (Self.Sustain);
else
Ret := Sample (Self.Sustain);
end if;
Self.Memo_Sample := Ret;
when Release =>
if Self.Current_P in 0 .. Self.Release then
Ret :=
Exp8_Transfer
(Sample (Self.Release - Self.Current_P)
/ Sample (Self.Release))
* Sample (Self.Cur_Sustain);
else
Self.State := Off;
Ret := 0.0;
end if;
when Off => Ret := 0.0;
end case;
Buffer (I) := Ret;
end loop;
end Next_Samples;
----------------------
-- Next_Sample --
----------------------
overriding procedure Next_Samples
(Self : in out Pitch_Gen; Buffer : in out Generator_Buffer)
is
Ret : Sample;
begin
if Self.Proc /= null then
Self.Proc.Next_Samples (Buffer);
end if;
for I in Buffer'Range loop
case Self.Source.Buffer (I).Kind is
when On =>
Self.Current_Note := Self.Source.Buffer (I).Note;
Self.Current_Freq :=
Note_To_Freq (Self.Current_Note, Self.Relative_Pitch);
when others => null;
end case;
Ret := Sample (Self.Current_Freq);
if Self.Proc /= null then
Ret := Ret + Buffer (I);
end if;
Buffer (I) := Ret;
end loop;
end Next_Samples;
------------------
-- Create_Noise --
------------------
function Create_Noise return access Noise_Generator
is
N : constant access Noise_Generator := new Noise_Generator;
begin
return N;
end Create_Noise;
F_Level : constant Sample := 2.0 / Sample (16#FFFFFFFF#);
G_X1 : Unsigned_32 := 16#67452301#;
G_X2 : Unsigned_32 := 16#EFCDAB89#;
Z : constant := 2 ** 31;
----------------
-- Mod_To_Int --
----------------
function Mod_To_Int (A : Unsigned_32) return Integer_32 is
Res : Integer_32;
begin
if A < Z then
return Integer_32 (A);
else
Res := Integer_32 (A - Z);
Res := Res - (Z - 1) - 1;
return Res;
end if;
end Mod_To_Int;
------------------
-- Next_Samples --
------------------
overriding procedure Next_Samples
(Self : in out Noise_Generator; Buffer : in out Generator_Buffer)
is
pragma Unreferenced (Self);
begin
for I in Buffer'Range loop
G_X1 := G_X1 xor G_X2;
Buffer (I) := Sample (Mod_To_Int (G_X2)) * F_Level;
G_X2 := G_X2 + G_X1;
end loop;
end Next_Samples;
------------------
-- Next_Samples --
------------------
overriding procedure Next_Samples
(Self : in out Fixed_Gen; Buffer : in out Generator_Buffer) is
begin
if Self.Proc /= null then
Self.Proc.Next_Samples (Buffer);
for I in Buffer'Range loop
Buffer (I) := Self.Val + Buffer (I);
end loop;
else
for I in Buffer'Range loop
Buffer (I) := Self.Val;
end loop;
end if;
end Next_Samples;
-----------
-- Reset --
-----------
overriding procedure Reset (Self : in out ADSR) is
begin
Base_Reset (Self);
Reset_Not_Null (Self.Source);
Self.Memo_Sample := 0.0;
end Reset;
-----------
-- Reset --
-----------
overriding procedure Reset (Self : in out Saw_Generator) is
begin
Base_Reset (Self);
Reset_Not_Null (Self.Frequency_Provider);
Self.Current := -1.0;
end Reset;
-----------
-- Reset --
-----------
overriding procedure Reset (Self : in out Square_Generator) is
begin
Base_Reset (Self);
Reset_Not_Null (Self.Frequency_Provider);
Self.Current_Sample := 0;
Self.Is_High := True;
end Reset;
-----------
-- Reset --
-----------
overriding procedure Reset (Self : in out Sine_Generator) is
begin
Base_Reset (Self);
Reset_Not_Null (Self.Frequency_Provider);
Self.Current_Sample := 0;
end Reset;
-----------
-- Reset --
-----------
overriding procedure Reset (Self : in out Noise_Generator) is
begin
Base_Reset (Self);
Reset_Not_Null (Self.Frequency_Provider);
end Reset;
-----------
-- Reset --
-----------
overriding procedure Reset (Self : in out Pitch_Gen) is
begin
Base_Reset (Self);
Reset_Not_Null (Self.Source);
Reset_Not_Null (Self.Proc);
end Reset;
-----------
-- Reset --
-----------
overriding procedure Reset (Self : in out Fixed_Gen) is
begin
Base_Reset (Self);
Reset_Not_Null (Self.Proc);
end Reset;
-----------
-- Reset --
-----------
overriding procedure Reset (Self : in out Chain) is
begin
Base_Reset (Self);
Reset_Not_Null (Self.Gen);
end Reset;
-----------
-- Fixed --
-----------
function Fixed
(Freq : Frequency;
Modulator : Generator_Access := null;
Name : String := "";
Min : Float := 0.0;
Max : Float := 5_000.0;
Param_Scale : Param_Scale_T := Linear)
return access Fixed_Gen
is
begin
return new
Fixed_Gen'
(Val => Sample (Freq),
Proc => Modulator,
Name => To_Unbounded_String (Name),
Min => Min,
Max => Max,
Param_Scale => Param_Scale,
others => <>);
end Fixed;
---------------
-- Set_Value --
---------------
overriding procedure Set_Value
(Self : in out Fixed_Gen; I : Natural; Val : Float)
is
pragma Unreferenced (I);
begin
Self.Val := Sample (Val);
end Set_Value;
---------------
-- Set_Value --
---------------
overriding procedure Set_Value
(Self : in out ADSR; I : Natural; Val : Float)
is
begin
case I is
when 0 => Self.Attack := Sec_To_Period (Val);
when 1 => Self.Decay := Sec_To_Period (Val);
when 2 => Self.Sustain := Scale (Val);
when 3 => Self.Release := Sec_To_Period (Val);
when others => raise Constraint_Error;
end case;
end Set_Value;
end Waves;
And lastly, the write_to_stdout.adb file
with Utils; use Utils;
with GNAT.OS_Lib;
procedure Write_To_Stdout (G : access Generator'Class)
is
function Sample_To_Int16 is new Sample_To_Int (Short_Integer);
Int_Smp : Short_Integer := 0;
Ignore : Integer;
Buffer : Generator_Buffer;
begin
loop
Next_Steps;
G.Next_Samples (Buffer);
for I in Buffer'Range loop
Int_Smp := Sample_To_Int16 (Buffer (I));
Ignore := GNAT.OS_Lib.Write
(GNAT.OS_Lib.Standout, Int_Smp'Address, Int_Smp'Size / 8);
end loop;
exit when Sample_Nb > 10_000_000;
Sample_Nb := Sample_Nb + Generator_Buffer_Length;
end loop;
end Write_To_Stdout;
Thank you for reading, and any guidance into solving this would be most appreicated.
Cheers,
Lloyd
The function in question :
function Create_Sine
(Freq_Provider : access Generator'Class) return access Sine_Generator
is
Ret : constant access Sine_Generator :=
new Sine_Generator'(Frequency_Provider =>
Generator_Access (Freq_Provider),
Current_Sample => 0,
Current_P => 0.0,
others => <>);
begin
Ret.Current_P := 0.0;
return Ret;
end Create_Sine;
creates a new object, accessed by an access type in its local scope and returns a copy of the access. In this case it is probably OK but there is the possibility of similar cases where the object itself goes out of scope when the function returns, leaving a dangling access.
In this case it's probably overcautious since the only reference to the object is that returned, but the accessibility checks prohibit this whole class of potentially bug-ridden constructs. I say "probably" because the object could theoretically be allocated on the stack by some compilers, or in a locally owned storage pool rather than "the heap" for more reliable object lifetime management.
There is a solution : create the access in place in the returned object, rather than in an immediately discarded local object. Ada-2005 and later provide an "extended return" construct to allow this. It looks something like:
function Create_Sine
(Freq_Provider : access Generator'Class) return access Sine_Generator
is
begin
return Ret : constant access Sine_Generator :=
new Sine_Generator'( Frequency_Provider =>
Generator_Access (Freq_Provider),
Current_Sample => 0,
Current_P => 0.0,
others => <>)
do
-- initialisation actions here
Ret.Current_P := 0.0;
end return;
end Create_Sine;
not tested! but any of the usual sources should keep you straight now you know its name.
Here the caller owns the access type being initialised with the new object, so there is no danger of the access type out-living the accessed object.
There may be a better answer to this question overall. I have just addressed the immediate point, but the wider question is, do you need an access type here at all? In Ada the answer usually (but not always) is No. There are many cases where programmers coming from other languages just reach for the pointers, when there is a simpler or better way of doing things in Ada.
I need to write a value consisting of all 0 except for bit Bit in a hardware register, where the register is somewhat like
type Bit_Number is range 0 .. 31;
type Bits_1 is array (Bit_Number) of Boolean
with
Component_Size => 1,
Size => 32;
Register_1 : Bits_1
with
Volatile,
Address => System'To_Address (16#1234_5678#);
Register_1 (typical of registers in Atmel's ATSAM3X8E, as in the Arduino Due) is defined as write-only, and it's unspecified what you get back if you read it, and it's unspecified what access widths are legal; all we are told is that when we write to the register only the 1 bits have any effect. (Incidentally, this means that the GNAT-specific aspect Volatile_Full_Access or the changes proposed in AI12-0128 won't help).
Enabling a pin in a GPIO peripheral involves setting its Bit in several registers. For reasons which I can't change (AdaCore's SVD2Ada), each register has its own equivalent of the Bits_1 array type above.
I want to write
procedure Set_Bit (Bit : Bit_Number) is
begin
Register_1 := (Bit => True, others => False);
Register_2 := (Bit => True, others => False);
...
end Set_Bit;
but the compiler says
19. procedure Set_Bit (Bit : Bit_Number) is
20. begin
21. Register_1 := (Bit => True, others => False);
|
>>> dynamic or empty choice in aggregate must be the only choice
which is a reference to ARM 4.3.3(17),
The discrete_choice_list of an array_component_association is allowed to have a discrete_choice that is a nonstatic choice_expression or that is a subtype_indication or range that defines a nonstatic or null range, only if it is the single discrete_choice of its discrete_choice_list, and there is only one array_component_association in the array_aggregate.
I can work round this,
procedure Set_Bit (Bit : Bit_Number) is
begin
declare
B : Bits_1 := (others => False);
begin
B (Bit) := True;
Register_1 := B;
end;
... ad nauseam
end Set_Bit;
but this seems very clumsy! Any other suggestions?
Does it have to be an array?
An alternative could be:
with Interfaces;
procedure Set_Bit is
Register : Interfaces.Unsigned_32;
begin
for J in 0..31 loop
Register := 2**J;
end loop;
end Set_Bit;
I think that this can be a little cumbersome , but if you need an array you could initialize it as a whole using concatenated sliced aggregates:
for J in 0 .. 31 loop
Register := Bits'(others => False)(0..J-1) &
True & Bits'(others => False)(J+1..31);
end loop;
It looks like a candidate for a function:
function Single_Bit (Set : in Bit_Number) return Bits_1 is
begin
return Result : Bits_1 := (others => False) do
Result (Set) := True;
end return;
end Single_Bit;
And then:
Register_1 := Single_Bit (Set => Some_Bit);
Register_2 := Single_Bit (Set => Another_Bit);
Example 1
This uses the Shift_Left operation.
with Ada.Integer_Text_IO; use Ada.Integer_Text_IO;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Unchecked_Conversion;
with Interfaces; use Interfaces;
procedure Main_Test is
function One_Bit (Index : Natural) return Unsigned_32 is (Shift_Left (1, Index));
type Bit_Array_32_Index is range 0 .. 31;
type Bit_Array_17_Index is range 0 .. 16;
type Bit_Array_32 is array (Bit_Array_32_Index) of Boolean with Component_Size => 1, Size => 32;
type Bit_Array_17 is array (Bit_Array_17_Index) of Boolean with Component_Size => 1, Size => 17;
-- For every new array type instantiate a convert function.
function Convert is new Ada.Unchecked_Conversion (Unsigned_32, Bit_Array_32);
function Convert is new Ada.Unchecked_Conversion (Unsigned_32, Bit_Array_17);
B32 : Bit_Array_32 with Volatile;
B17 : Bit_Array_17 with Volatile;
begin
B17 := Convert (One_Bit (2)) or Convert (One_Bit (5));
B32 := Convert (One_Bit (2) or One_Bit (5));
for E of B17 loop
Put (Boolean'Pos (E), 1);
end loop;
New_Line;
for E of B32 loop
Put (Boolean'Pos (E), 1);
end loop;
end;
Result
00100100000000000
00100100000000000000000000000000
Warnings
main.adb:21:04: warning: types for unchecked conversion have different sizes
main.adb:21:04: warning: size of "Unsigned_32" is 32, size of "Bit_Array_17" is 17
main.adb:21:04: warning: 15 high order bits of source will be ignored
Example generics
This uses the Shift_Left operation but with generics.
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Unchecked_Conversion;
with Interfaces; use Interfaces;
procedure Main is
package Unsigned_32_IO is new Ada.Text_IO.Modular_IO (Unsigned_32);
type Bit_Array_32_Index is range 0 .. 31;
type Bit_Array_17_Index is range 0 .. 16;
type Bit_Array_32 is array (Bit_Array_32_Index) of Boolean with Component_Size => 1, Size => 32;
type Bit_Array_17 is array (Bit_Array_17_Index) of Boolean with Component_Size => 1, Size => 32;
generic
type I is (<>);
type T is array (I) of Boolean;
procedure Generic_Put (Item : T; Width : Field; Base : Number_Base);
procedure Generic_Put (Item : T; Width : Field; Base : Number_Base) is
function Convert_To_Unsigned_32 is new Ada.Unchecked_Conversion (T, Unsigned_32);
begin
Unsigned_32_IO.Put (Convert_To_Unsigned_32 (Item), Width, Base);
end;
generic
type I is (<>);
type T is array (I) of Boolean;
function Generic_Shift_Left (Value : Unsigned_32; Amount : Natural) return T;
function Generic_Shift_Left (Value : Unsigned_32; Amount : Natural) return T is
function Convert_To_Bit_Array_32 is new Ada.Unchecked_Conversion (Unsigned_32, T);
begin
return Convert_To_Bit_Array_32 (Interfaces.Shift_Left (Value, Amount));
end;
function Shift_Left is new Generic_Shift_Left (Bit_Array_32_Index, Bit_Array_32);
function Shift_Left is new Generic_Shift_Left (Bit_Array_17_Index, Bit_Array_17);
procedure Put is new Generic_Put (Bit_Array_32_Index, Bit_Array_32);
procedure Put is new Generic_Put (Bit_Array_17_Index, Bit_Array_17);
B32 : Bit_Array_32 with Volatile;
B17 : Bit_Array_17 with Volatile;
begin
B32 := Shift_Left (1, 2) or Shift_Left (1, 5);
B17 := Shift_Left (1, 2) or Shift_Left (1, 5);
Put (B17, 0, 2);
New_Line;
Put (B32, 0, 2);
end;
Result
2#100100#
2#100100#
gprbuild -v
GPRBUILD GPL 2015 (20150428) (i686-pc-mingw32)
Questions
Does it work on big-endian machine?
I haven't tested. See does bit-shift depend on endianness?
I've FreeDos OS installed on VirtualBox on a windows xp, dual core, host machine. I installed FreeDos because I wanted to run a Pascal code using Turbo Pascal. When I run the code, it throws error 'Error 200: Division by zero.'. How can I solve this?
-Turbo Pascal 7.0, Free DOS 1.1, Virtual Box 4.3.6, Windows XP Service Pack 3 Host machine
-This error is unfortunately caused by fast Pentium CPUs and I found a patch on the internet that will resolve the error. (www.filewatcher.com/m/bp7patch.zip.62550-0.html) Now the other problem is, when i was tracing the code, it hangs at 'RxWait procedure when trying to execute while not odd(port[RXTX + 5]) do;'
uses crt;
const
{ COM1: RS232 port address }
RXTX = $3F8; { $2F8 if COM2: is used }
ACK = 6;
NAK = 21;
ESC = 27;
var
dummy,
checkSum : integer;
key : char;
protocol : integer;
procedure InitComm;
{ Set baudrate to 9600, 8 bits, no parity, 1 stop bit }
var i : integer;
begin
i := 1843200 div 9600 div 16;
port[RXTX + 3] := $80;
port[RXTX + 1] := hi(i);
port[RXTX]:= lo(i);
port[RXTX + 3] := 3;
port[RXTX + 4] := $A;
while odd(port[RXTX + 5]) do
begin
dummy := port[RXTX];
delay(10);
end;
end; { InitComm }
procedure Tx(data : integer);
{ Transmit a character on serial channel }
begin
while port[RXTX + 5] and $20 = 0 do;
port[RXTX] := data and $FF;
end; { Tx }
function RxWait : integer;
{ Waits for a character from serial channel }
begin
while not odd(port[RXTX + 5]) do;
RxWait := port[RXTX];
end; { RxWait }
procedure Tx2(data : integer);
{ Transmit a char on serial channel + Calculate check sum }
begin
Tx(data);
checkSum := (checkSum + data) and $FF;
end; { Tx2 }
procedure TxCommand(c1, c2 : char;
sendCheckSum : boolean);
{ Transmit command (no data) on serial channel }
begin
Tx(ESC);
checkSum := 0;
Tx2(ord(c1));
Tx2(ord(c2));
if sendCheckSum then
begin
Tx2(checkSum);
dummy := RxWait;
end;
end; { TxCommand }
function ReadNumber(n : integer) : real;
{ Read n bytes from serial channel }
var
number: real;
i : integer;
begin
number := 0;
checkSum := 0;
for i := 1 to n do
number := number * 256 + RxWait;
dummy := RxWait;
ReadNumber := number;
end; { ReadNumber }
procedure Revisions;
var
tmp : integer;
sw,
prot : real;
begin
TxCommand('P', 'R', FALSE);
checkSum := 0;
tmp := RxWait;
sw := tmp + RxWait / 100.0;
protocol := RxWait;
prot := protocol + RxWait / 100.0;
dummy := RxWait;
tmp := RxWait;
writeln('Software revision: ', sw:4:2);
writeln('Protocol revision: ', prot:4:2);
end; { Revisions }
procedure ReadCountReg;
begin
TxCommand('R', 'C', FALSE);
writeln(ReadNumber(4):11:0, ' coins counted.');
dummy := RxWait;
end; { ReadCountReg }
procedure ReadAccReg;
begin
TxCommand('R', 'A', FALSE);
writeln(ReadNumber(4):11:0, ' coins in accumulator.');
dummy := RxWait;
end; { ReadAccReg }
procedure Setbatch(limit : longint);
begin
TxCommand('W', 'L', FALSE);
case protocol of
1 : begin
Tx2(limit div 256);
Tx2(limit mod 256);
end;
2 : begin
Tx2( limit div 16777216);
Tx2((limit div 65536) mod 256);
Tx2((limit div 256) mod 256);
Tx2( limit mod 256);
end;
end; { case protocol }
Tx2(checkSum);
dummy := RxWait;
end; { Setbatch }
As far as I remember (more than 12 years ago), CRT unit had problems about Pentium CPUs and giving that division by zero error. I was using Turbo Pascal 7 those days. What I mean is that it may not be your coding error, but just CRT unit itself.
Old question I know, but there is another way to write Turbo Pascal code without incurring the wrath of the infamous RTE 200 bug. FreePascal (www.freepascal.org) is fully TP7 compatible and runs under a number of OSes including DOS, Windows and Linux.
Hope this helps!
I solved it setting the Execution Cap to 20%. So the processor is probably as slower as expected in those days. You can play with percentages until the error disappear
Regards
I am programming a Windows CE 6 device (Motorola MC3100 scanner Terminal). Using Lazarus FPC to compile it.
After 3 weeks work I reluctantly post here in the hope someone can suggest why I am getting garbled output from the serial port.
The code I am using is posted below. This is the standard code I have found from several places.
The OpenPort works OK.
When I send the string using SendString('ABCDEF') I get garbled input to the PC Serial port such as:
4[#131][#26][#0][#0][#0][#0] (the bracketed data indicates that it is a non-printable character ASCII Code)
Obviously it is connecting to the port OK AND it is sending the correct no of characters (7).
I have tried all combinations of Baud Rate, Data Bits, Parity and Stop Bits without any joy. Also tried changing cable, on a different PC etc.
Could it be I need to set something else in the DCB?
Any help or suggestions would be GREATLY appreciated.
unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls, ExtCtrls,
Windows, LResources;
type
{ TForm1 }
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
Label1: TLabel;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
function OpenPort(ComPort:String;BaudRate,ByteSize,Parity,StopBits:integer):String;
procedure SendString(str:String);
private
{ private declarations }
public
{ public declarations }
end;
var
Form1: TForm1;
cc:TCOMMCONFIG;
Connected:Boolean;
implementation
{$R *.lfm}
var F: TextFile;
var hComm: THandle;
str: String;
lrc: LongWord;
{ TForm1 }
function
OpenPort(ComPort:String;BaudRate,ByteSize,Parity,StopBits:integer):String;
var
cc:TCOMMCONFIG;
SWide:WideString;
Port:LPCWSTR;
begin
SWide:=ComPort;
Port:=PWideChar(SWide);
result:='';
if (1=1) then begin
Connected:=False;
hComm:=CreateFile(Port, GENERIC_READ or GENERIC_WRITE,0, nil,OPEN_EXISTING,0,0);
if (hComm = INVALID_HANDLE_VALUE) then begin
ShowMessage('Fail to Open');
exit;
end;
GetCommState(hComm,cc.dcb);
cc.dcb.BaudRate:=BaudRate;
cc.dcb.ByteSize:=ByteSize;
cc.dcb.Parity:=Parity;
cc.dcb.StopBits:=StopBits;
if not SetCommState(hComm, cc.dcb) then begin
result:='SetCommState Error!';
CloseHandle(hComm);
exit;
end;
Connected:=True;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
OpenPort('COM1:',9600,8,0,0);
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
SendString('ABCDEFG');
end;
procedure TForm1.SendString(str:String);
var
lrc:LongWord;
begin
if (hComm=0) then exit;
try
if not PurgeComm(hComm, PURGE_TXABORT or PURGE_TXCLEAR) then
raise Exception.Create('Unable to purge com: ');
except
Exit;
end;
WriteFile(hComm,str,Length(str), lrc, nil);
end;
end.
Found the answer to this.
WriteFile(hComm,str,Length(str), lrc, nil);
The "str" parameter was in fact a pointer to the string, not the string itself
Changing it to this works.
WriteFile(hComm,str[1],Length(str), lrc, nil);