blinklist.pas

   1 { Copyright (C) 2005 Bas Steendijk\r
   2   For conditions of distribution and use, see copyright notice in zlib_license.txt\r
   3   which is included in the package\r
   4   ----------------------------------------------------------------------------- }\r
   5 unit blinklist;\r
   6 \r
   7 {$ifdef fpc}\r
   8   {$mode delphi}\r
   9 {$endif}\r
  10 \r
  11 \r
  12 interface\r
  13 \r
  14 type\r
  15   tlinklist=class(tobject)\r
  16     next:tlinklist;\r
  17     prev:tlinklist;\r
  18     constructor create;\r
  19     destructor destroy; override;\r
  20   end;\r
  21 \r
  22   {linklist with 2 links}\r
  23   tlinklist2=class(tlinklist)\r
  24     next2:tlinklist2;\r
  25     prev2:tlinklist2;\r
  26   end;\r
  27 \r
  28   {linklist with one pointer}\r
  29   tplinklist=class(tlinklist)\r
  30     p:pointer\r
  31   end;\r
  32 \r
  33   tstringlinklist=class(tlinklist)\r
  34     s:ansistring;\r
  35   end;\r
  36 \r
  37   tthing=class(tlinklist)\r
  38     name:ansistring;      {name/nick}\r
  39     hashname:integer; {hash of name}\r
  40   end;\r
  41 \r
  42 {\r
  43 adding new block to list (baseptr)\r
  44 }\r
  45 procedure linklistadd(var baseptr:tlinklist;newptr:tlinklist);\r
  46 procedure linklistdel(var baseptr:tlinklist;item:tlinklist);\r
  47 \r
  48 \r
  49 procedure linklist2add(var baseptr,newptr:tlinklist2);\r
  50 procedure linklist2del(var baseptr:tlinklist2;item:tlinklist2);\r
  51 \r
  52 var\r
  53   linklistdebug:integer;\r
  54 \r
  55 implementation\r
  56 \r
  57 uses sysutils;\r
  58 \r
  59 procedure linklistadd(var baseptr:tlinklist;newptr:tlinklist);\r
  60 var\r
  61   p:tlinklist;\r
  62 begin\r
  63   if (newptr=baseptr) or assigned(newptr.prev) then raise exception.create('linklist double insertion detected');\r
  64   p := baseptr;\r
  65   baseptr := newptr;\r
  66   baseptr.prev := nil;\r
  67   baseptr.next := p;\r
  68   if p <> nil then p.prev := baseptr;\r
  69 end;\r
  70 \r
  71 procedure linklistdel(var baseptr:tlinklist;item:tlinklist);\r
  72 begin\r
  73   if item = baseptr then baseptr := item.next;\r
  74   if item.prev <> nil then item.prev.next := item.next;\r
  75   if item.next <> nil then item.next.prev := item.prev;\r
  76   item.prev := nil;\r
  77   item.next := nil;\r
  78 end;\r
  79 \r
  80 procedure linklist2add(var baseptr,newptr:tlinklist2);\r
  81 var\r
  82   p:tlinklist2;\r
  83 begin\r
  84   if (newptr=baseptr) or assigned(newptr.prev2) then raise exception.create('linklist2 double insertion detected');\r
  85   p := baseptr;\r
  86   baseptr := newptr;\r
  87   baseptr.prev2 := nil;\r
  88   baseptr.next2 := p;\r
  89   if p <> nil then p.prev2 := baseptr;\r
  90 end;\r
  91 \r
  92 procedure linklist2del(var baseptr:tlinklist2;item:tlinklist2);\r
  93 begin\r
  94   if item = baseptr then baseptr := item.next2;\r
  95   if item.prev2 <> nil then item.prev2.next2 := item.next2;\r
  96   if item.next2 <> nil then item.next2.prev2 := item.prev2;\r
  97   item.prev2 := nil;\r
  98   item.next2 := nil;\r
  99 end;\r
 100 \r
 101 constructor tlinklist.create;\r
 102 begin\r
 103   inherited create;\r
 104   inc(linklistdebug);\r
 105 end;\r
 106 \r
 107 destructor tlinklist.destroy;\r
 108 begin\r
 109   dec(linklistdebug);\r
 110   inherited destroy;\r
 111 end;\r
 112 \r
 113 end.\r