blinklist.pas

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