Experimental Tags

One of the most annoying things about passing an array of const (needed for passing f.e. tagitems) is the somewhat awkward way of creating an tagitemlist.

Not only is it awkward, but the current way that the ReadInTags() function is implemented is plain wrong. It is not possible to use/create two taglists at the same time.

ALB42 tried to implement a more practical solution by creating additional functions AddTags() and GetTagPtr() [1].

Now that Free Pascal has a more convenient way of working with record through advanced records [2], i gave it an experimental try.

And boy, are we in for some troubles along the way.

1. for reasons beyond me, we must use $MODE DELPHI otherwise we are unable to overload assignment operators. (and that's exactly the fun part we want to 'abuse' here).
2. for another reason beyond me, the code completely crashes when passed a NULL, and compiler does not warn on compilation.
3. compiler keeps complaining about uninitialized variables, which is technically correct but, which is highly annoying.
4. i'm unsure the 'resetting' of the item array is required to force freeing the internal array. Unfortunately an advanced record does not have a destructor (in opposite of an constructor, but which Free Pascal currently does not support).
5. there are so many different (extended) implementations possible, that i refrained from adding any additional functionality. The whole source is based on the literal implementation that was already in Free Pascal trunk.

Let's start with wome code for a TagItems list.

unit aros_modern_tags;

{ $MODESWITCH ADVANCEDRECORDS <- does not let us overload assignment operator}
{$MODE DELPHI}{$H+}

(*
  Very basic implementation of modern tags in form of an advanced record.
  Based on ALBs (and previously other people's) work.
  http://svn.freepascal.org/cgi-bin/viewvc.cgi/trunk/packages/arosunits/src/tagsarray.pas?view=markup
*)


interface

// Some conditional code in case compiling for another platform.
{$IFDEF AROS}
uses
  exec, utility;
{$ENDIF}
  
{$IFNDEF AROS}
Const
  TAG_END   = 0;

Type
  IPTR      =  NativeUInt;

  PTagItem  = ^TTagItem;
  TTagItem  = record
    ti_Tag  : LongWord;
    ti_Data : LongWord;
  end;
{$ENDIF}  
  
Type
  TTagsList = array of TTagitem;


  TArosTags = record
   private
    TagsList : TTagsList;
   public
    procedure Add(const Args: array of const);
    procedure Clear;

    // Assignment operators to TArosTags from another type
    class operator := (a: Integer): TArosTags;

    // Assignment operators from TArosTags to another type
    class operator := (a: TArosTags): PTagItem;
  end;
  
  
implementation


procedure TArosTags.Add(const args: array of const);
var
  i  : Integer;
  ii : integer;
begin
  ii := Length(Self.TagsList);
  
  SetLength(Self.TagsList, Length(Self.TagsList) + (Length(Args) div 2));
  
  for i := 0 to High(Args) do
  begin
    if (not Odd(i)) then
    begin
      self.TagsList[ii].ti_tag := IPTR(Args[i].vinteger);
    end 
    else
    begin
      case Args[i].vtype of
        vtinteger : Self.TagsList[ii].ti_data := IPTR(Args[i].vinteger);
        vtboolean : Self.TagsList[ii].ti_data := IPTR(byte(Args[i].vboolean));
        vtpchar   : Self.TagsList[ii].ti_data := IPTR(Args[i].vpchar);
        vtchar    : Self.TagsList[ii].ti_data := IPTR(Args[i].vchar);
        vtstring  : Self.TagsList[ii].ti_data := IPTR(PChar(string(Args[i].vstring^)));
        vtpointer : Self.TagsList[ii].ti_data := IPTR(Args[i].vpointer);
      end;
      inc(ii);
    end;
  end;
end;


procedure TArosTags.Clear;
begin
  SetLength(Self.TagsList, 0);
end;


class operator TArosTags.implicit(a: Integer): TArosTags;
begin
  // dummy function clear
  Result.Clear;
end;


class operator TArosTags.Implicit(a: TArosTags): PTagItem;
var
  i : Integer;
begin
  // writeln('calling TArosTags Implicit assignment, length =', length(a.tagsList));
  
  i := Length(a.TagsList);
  (*
    make sure last tag is TAG_END
    Actually, this might not be a good idea if enduser expects to be adding 
    new tags later on.
    In which case it would be better to make a copy of the tagslist first or 
    alternatively with adding tags first check if there's an end tag and 
    remove the tag before adding new tags
    if (TagsList[i].ti_tag <> TAG_END) then Add([TAG_END, TAG_END]);
  *)
  if (a.TagsList[i].ti_tag <> TAG_END) then a.Add([TAG_END, TAG_END]);

  result := @a.TagsList[0];
end;

end.

And some code to test a the TagItems.

program TestTagItems;

// A simple quick test for modern args
Procedure Test;
var
  Items1 : TArosTags;
  value  : IPTR;
  answer : IPTR;
begin
  Items1.Add([1,1000,2,2000,3,3000, TAG_END]);

  value := 666;
  Answer := GetTagData(1, IPTR(@value), Items1);
  writeln('answer = ', answer);
end;

Begin
  Test;
end.

And when put to practice, it can look somewhat similar like:

Function  GetAttrs(rp: PRastPort; const Tags: array of const): ULONG;
Var TagItems: TArosTags;
begin
  TagItems := 0;
  TagItems.Add(Tags);
  Result := GetAttrsA(rp, TagItems);
  TagItems := 0;
end;