Re: TrySetLength not possible !? :(


Shark8 schreef:

It would be nice if Borland would add a TrySetLength to feature
versions of Delphi, since it seems impossible to create it yourself ?

Impossible? Nope!
In fact it's quite easy, here's the code you want:

Writing code is easy, writing correct code is a bit harder ;)

Sigh, from just looking at your code I knew something was wrong.

Your name makes me wonder... "sharkbate" did you just write this to
bate me, me wonders.

None the less, it's interesting to proof your code is flawed.

Here is a nice test program which shows your and mine (adepted) method
to be flawed.
Next time I might write the test program a bit more efficient meaning
in less time ;) It cost me an hour :)

I still need a good TrySetLength though. I might have to find another
solution to my problem ;)

*** Begin of Code ***:

program ProjectTestTrySetLength;

{$APPTYPE CONSOLE}

{

Test program for TrySetLength, an attempt to create a TrySetLength
routine.

version 0.01 created on 2 juli 2006 by Skybuck Flying.

Unfortunately it seems it's not possible to create a general/generic
TrySetLength routine.

Such a routine would be handy to take care of out of memory exceptions.

Me wishes Borland adds it to a next release of Delphi ;) :|

(This code/attempt does not compile).

Posted on usenet on 2 juli 2006.

}

{

version 0.02 created on 4 juli 2006 by Skybuck Flying.

Investigate Shark8's idea.

Nice try Shark, but as I already expected, your method/idea is flawed.

This test program proves it.

The length of the array is supposed to be the number of elements.

Your method messes that up.

My method is also flawed, it does not allocate enough bytes.

I tried to write some other methods but Delphi has no features to get
it right.

One could try and figure out how dynamic arrays work and then mess with
it but ok.

Thanks anyway, it was interesting to write this test program.

See you later.

}

uses
SysUtils;


// Skybuck's version 0.01 (does not compile)
{

function TrySetLength( var ParaVar; const ParaNewLength : integer ) :
boolean;
begin
try
SetLength( ParaVar, ParaNewLength );
result := true;
except
result := false;
end;
end;

}

// Skybuck's version 0.02 using Shark8's dynamic array of byte and
absolute trick
function SkybuckTrySetLength( var ParaVar; const ParaNewLength :
integer ) : boolean;
var
vDynamicArrayOfByte : array of byte absolute ParaVar;
begin
try
SetLength( vDynamicArrayOfByte, ParaNewLength );
result := true;
except
result := false;
end;
end;

// Shark8's version 0.01
function Shark8TrySetLength( var Param; const NewLength, DataSize :
integer ) : boolean;
var
DynamicArray : array of byte absolute Param;
begin
try
SetLength( DynamicArray, NewLength * DataSize );
result := true;
except
result := false;
end;
end;

{

Does not compile.

function Skybuck2TrySetLength( var ParaVar; const ParaNewLength :
integer; const ParaClassType : Tclass ) : boolean;
var
vDynamicArray : array of ParaClassType absolute ParaVar;
begin
try
SetLength( vDynamicArray, ParaNewLength );
result := true;
except
result := false;
end;
end;

}

{

Tried different things, Does not compile

type
TarrayOfVariant = array of variant;
TarrayOfByte = array of byte;
TarrayOfString = array of string;
TarrayOfWord = array of word;
TarrayOfLongword = array of longword;
TarrayOfTestObject = array of TtestObject;

function Skybuck3TrySetLength( var ParaVar; const ParaNewLength :
integer; ParaClassType : TarrayOfVariant ) : boolean;
var
vDynamicArray : TarrayOfVariant absolute ParaVar;
begin
try
SetLength( ParaClassType(vDynamicArray), ParaNewLength );
result := true;
except
result := false;
end;
end;

}

{ --- Test section --- }

type
TtestObject = class
private

public
mField : integer;
end;

const
const_string_length = 100000;
const_byte_length = 200000;
const_word_length = 300000;
const_longword_length = 400000;
const_test_object_length = 500000;

{ --- Skybuck Test --- }

function TestSkybuckString : boolean;
var
vString : string;
begin
result := false;
if SkybuckTrySetLength( vString, const_string_length ) then
begin
writeln('String length: ', Length( vString ) );
// writeln('String low: ', Low(vString) ); // doesn't work ? useless
crap anyway ;)
// writeln('String high: ', High(vString) ); // doesn't work ?
if Length( vString ) = const_string_length then
begin
try
try
vString[ Length(vString) ] := 'E';
result := true;
finally
vString := '';
end;
except
on ERangeError do
begin
writeln('String range error !');
end;

on EAccessViolation do
begin
writeln('String access violation !');
end;
end;
end else
begin
writeln('String has wrong length: ', Length( vString ), ' correct
length: ', const_string_length );
end;
end;
end;

function TestSkybuckByte : boolean;
var
vByte : array of byte;
begin
result := false;
if SkybuckTrySetLength( vByte, const_byte_length ) then
begin
writeln('Byte length: ', Length( vByte ) );
writeln('Byte low: ', Low( vByte ) );
writeln('Byte high: ', High( vByte ) );
if Length( vByte ) = const_byte_length then
begin
try
try
vByte[ High(vByte) ] := 255;
result := true;
finally
vByte := nil;
end;
except
on ERangeError do
begin
writeln('Byte range error !');
end;

on EAccessViolation do
begin
writeln('Byte access violation !');
end;
end;
end else
begin
writeln('Byte has wrong length: ', Length( vByte ), ' correct
length: ', const_byte_length );
end;
end;
end;

function TestSkybuckWord : boolean;
var
vWord : array of Word;
begin
result := false;
if SkybuckTrySetLength( vWord, const_word_length ) then
begin
writeln('Word length: ', Length( vWord ) );
writeln('Word low: ', Low( vWord ) );
writeln('Word high: ', High( vWord ) );
if Length( vWord ) = const_word_length then
begin
try
try
vWord[ High(vWord) ] := 65000;
result := true;
finally
vWord := nil;
end;
except
on ERangeError do
begin
writeln('Word range error !');
end;

on EAccessViolation do
begin
writeln('Word access violation !');
end;

end;
end else
begin
writeln('Word has wrong length: ', Length( vWord ), ' correct
length: ', const_word_length );
end;
end;
end;

function TestSkybuckLongword : boolean;
var
vLongword : array of Longword;
begin
result := false;
if SkybuckTrySetLength( vLongword, const_longword_length ) then
begin
writeln('Longword length: ', Length( vLongword ) );
writeln('Longword low: ', Low( vLongword ) );
writeln('Longword high: ', High( vLongword ) );
if Length( vLongword ) = const_longword_length then
begin
try
try
vLongword[ High(vLongword) ] := 1024*1024*1024;
result := true;
finally
vLongword := nil;
end;
except
on ERangeError do
begin
writeln('Longword range error !');
end;

on EAccessViolation do
begin
writeln('Longword access violation !');
end;
end;
end else
begin
writeln('Longword has wrong length: ', Length( vLongword ), '
correct length: ', const_longword_length );
end;
end;
end;

function TestSkybuckTestObject : boolean;
var
vTestObject : array of TTestObject;
begin
result := false;
if SkybuckTrySetLength( vTestObject, const_test_object_length ) then
begin
writeln('TestObject length: ', Length( vTestObject ) );
writeln('TestObject low: ', Low( vTestObject ) );
writeln('TestObject high: ', High( vTestObject ) );
if Length( vTestObject ) = const_test_object_length then
begin
try
try
vTestObject[ High(vTestObject) ] := nil;
result := true;
finally
vTestObject := nil;
end;
except
on ERangeError do
begin
writeln('TestObject range error !');
end;

on EAccessViolation do
begin
writeln('TestObject access violation !');
end;
end;
end else
begin
writeln('TestObject has wrong length: ', Length( vTestObject ), '
correct length: ', const_test_object_length );
end;
end;
end;

{ --- Shark Test --- }

function TestShark8String : boolean;
var
vString : string;
begin
result := false;
if Shark8TrySetLength( vString, const_string_length,
SizeOf(vString[1]) ) then
begin
writeln('String length: ', Length( vString ) );
// writeln('String low: ', Low(vString) ); // doesn't work ? useless
crap anyway ;)
// writeln('String high: ', High(vString) ); // doesn't work ?
if Length( vString ) = const_string_length then
begin
try
try
vString[ Length(vString) ] := 'E';
result := true;
finally
vString := '';
end;
except
on ERangeError do
begin
writeln('String range error !');
end;

on EAccessViolation do
begin
writeln('String access violation !');
end;
end;
end else
begin
writeln('String has wrong length: ', Length( vString ), ' correct
length: ', const_string_length );
end;
end;
end;

function TestShark8Byte : boolean;
var
vByte : array of byte;
begin
result := false;
if Shark8TrySetLength( vByte, const_byte_length, SizeOf(vByte[1]) )
then
begin
writeln('Byte length: ', Length( vByte ) );
writeln('Byte low: ', Low( vByte ) );
writeln('Byte high: ', High( vByte ) );
if Length( vByte ) = const_byte_length then
begin
try
try
vByte[ High(vByte) ] := 255;
result := true;
finally
vByte := nil;
end;
except
on ERangeError do
begin
writeln('Byte range error !');
end;

on EAccessViolation do
begin
writeln('Byte access violation !');
end;
end;
end else
begin
writeln('Byte has wrong length: ', Length( vByte ), ' correct
length: ', const_byte_length );
end;
end;
end;

function TestShark8Word : boolean;
var
vWord : array of Word;
begin
result := false;
if Shark8TrySetLength( vWord, const_word_length, SizeOf(vWord[1]) )
then
begin
writeln('Word length: ', Length( vWord ) );
writeln('Word low: ', Low( vWord ) );
writeln('Word high: ', High( vWord ) );
if Length( vWord ) = const_word_length then
begin
try
try
vWord[ High(vWord) ] := 65000;
result := true;
finally
vWord := nil;
end;
except
on ERangeError do
begin
writeln('Word range error !');
end;

on EAccessViolation do
begin
writeln('Word access violation !');
end;

end;
end else
begin
writeln('Word has wrong length: ', Length( vWord ), ' correct
length: ', const_word_length );
end;
end;
end;

function TestShark8Longword : boolean;
var
vLongword : array of Longword;
begin
result := false;
if Shark8TrySetLength( vLongword, const_longword_length,
SizeOf(vLongword[1]) ) then
begin
writeln('Longword length: ', Length( vLongword ) );
writeln('Longword low: ', Low( vLongword ) );
writeln('Longword high: ', High( vLongword ) );
if Length( vLongword ) = const_longword_length then
begin
try
try
vLongword[ High(vLongword) ] := 1024*1024*1024;
result := true;
finally
vLongword := nil;
end;
except
on ERangeError do
begin
writeln('Longword range error !');
end;

on EAccessViolation do
begin
writeln('Longword access violation !');
end;
end;
end else
begin
writeln('Longword has wrong length: ', Length( vLongword ), '
correct length: ', const_longword_length );
end;
end;
end;

function TestShark8TestObject : boolean;
var
vTestObject : array of TTestObject;
begin
result := false;
if Shark8TrySetLength( vTestObject, const_test_object_length,
SizeOf(vTestObject[1]) ) then
begin
writeln('TestObject length: ', Length( vTestObject ) );
writeln('TestObject low: ', Low( vTestObject ) );
writeln('TestObject high: ', High( vTestObject ) );
if Length( vTestObject ) = const_test_object_length then
begin
try
try
vTestObject[ High(vTestObject) ] := nil;
result := true;
finally
vTestObject := nil;
end;
except
on ERangeError do
begin
writeln('TestObject range error !');
end;

on EAccessViolation do
begin
writeln('TestObject access violation !');
end;
end;
end else
begin
writeln('TestObject has wrong length: ', Length( vTestObject ), '
correct length: ', const_test_object_length );
end;
end;
end;

{ --- Main program section --- }

var
vPerformSkybuckTest : boolean;
vPerformShark8Test : boolean;
begin
writeln('program started');

vPerformSkybuckTest := true;

if vPerformSkybuckTest then
begin
try

writeln('TestSkybuckString:');
if TestSkybuckString then
begin
writeln('TestSkybuckString successfull.');
end else
begin
writeln('TestSkybuckString failed.');
end;
writeln;

writeln('TestSkybuckByte:');
if TestSkybuckByte then
begin
writeln('TestSkybuckByte successfull.');
end else
begin
writeln('TestSkybuckByte failed.');
end;
writeln;

writeln('TestSkybuckWord:');
if TestSkybuckWord then
begin
writeln('TestSkybuckWord successfull.');
end else
begin
writeln('TestSkybuckWord failed.');
end;
writeln;

writeln('TestSkybuckLongword:');
if TestSkybuckLongword then
begin
writeln('TestSkybuckLongword successfull.');
end else
begin
writeln('TestSkybuckLongword failed.');
end;
writeln;

writeln('TestSkybuckTestObject:');
if TestSkybuckTestObject then
begin
writeln('TestSkybuckTestObject successfull.');
end else
begin
writeln('TestSkybuckTestObject failed.');
end;
writeln;

except
on E : Exception do
begin
writeln('Something went wrong during SkybuckTest:');
writeln( E.Message );
end;
end;
end;

vPerformShark8Test := true;

if vPerformShark8Test then
begin
try

writeln('TestShark8String:');
if TestShark8String then
begin
writeln('TestShark8String successfull.');
end else
begin
writeln('TestShark8String failed.');
end;
writeln;

writeln('TestShark8Byte:');
if TestShark8Byte then
begin
writeln('TestShark8Byte successfull.');
end else
begin
writeln('TestShark8Byte failed.');
end;
writeln;

writeln('TestShark8Word:');
if TestShark8Word then
begin
writeln('TestShark8Word successfull.');
end else
begin
writeln('TestShark8Word failed.');
end;
writeln;

writeln('TestShark8Longword:');
if TestShark8Longword then
begin
writeln('TestShark8Longword successfull.');
end else
begin
writeln('TestShark8Longword failed.');
end;
writeln;

writeln('TestShark8TestObject:');
if TestShark8TestObject then
begin
writeln('TestShark8TestObject successfull.');
end else
begin
writeln('TestShark8TestObject failed.');
end;
writeln;

except
on E : Exception do
begin
writeln('Something went wrong during Shark8Test:');
writeln( E.Message );
end;
end;
end;

writeln('press enter to exit');
writeln;
writeln('program finished');

readln;
end.

*** End of Code ***

Bye,
Skybuck.

.

Relevant Pages

  • (patch for Bash) regex case statement
    ... Following up on my previous patch for regex conditional tests, ... /* Return an array of strings; ... int dollarflag, zeropad, compareflag; ... SHELL_VAR *var; ...
    (comp.unix.shell)
  • Re: Updated datestamp doesnt work
    ... Public Sub StoreOldVals ... ' store values of current row in array ... Dim n As Integer, intlast As Integer ... Dim var As Variant ...
    (microsoft.public.access.gettingstarted)
  • Re: Updated datestamp doesnt work
    ... Public Sub StoreOldVals ... ' store values of current row in array ... Dim n As Integer, intlast As Integer ... Dim var As Variant ...
    (microsoft.public.access.gettingstarted)
  • Re: Updated datestamp doesnt work
    ... Public Sub StoreOldVals ... ' store values of current row in array ... Dim n As Integer, intlast As Integer ... Dim var As Variant ...
    (microsoft.public.access.gettingstarted)
  • Re: addEvent - The late entry :)
    ... approach used in converting an - arguments - object into an array can be chosen at the point of needing to do it. ... I did include a dedicated function in my tests (one that did little more than create a new array and loop over the 'array index' properties of its argument object copying values to corresponding properties of the new array). ... the number of iterations should be the most that any particular system will allow without putting up the 'A script on this page ... ... var argsIndex = 0; ...
    (comp.lang.javascript)