home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / compiler / pascal2 / lib / setlib.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-11-03  |  11.6 KB  |  432 lines
  1. (*
  2.  * FileName:   setlib.pas
  3.  * $Source: E:/usr/src/c-code/pascal/RCS/LIB/setlib.pas,v $
  4.  * $Author: wjw $
  5.  * $Date: 1993/11/03 15:55:04 $
  6.  * $Locker: wjw $
  7.  * $State: Exp $
  8.  * $Revision: 1.1 $
  9.  * Description:
  10. D*      Part of the runtime library which comes with PASCAL for OS/2
  11. D*      
  12.  *
  13.  * History:
  14.  *      First created by Willem Jan Withagen ( wjw@eb.ele.tue.nl ),
  15.  *                    on Mon July 26 23:30:03 MET 1993
  16.  * Copyright:
  17.  *      Copyright (c) 1993 by Willem Jan Withagen and 
  18.  *                      Digital Information Systems group, TUE
  19.  *      For copying and distribution information see the file COPYRIGHT.
  20.  *
  21.  *)
  22.  
  23. program setlib;
  24. (* MODULE paslib; *)
  25.  
  26. (* Once this all will be transformed into the PASCAL runtime lib.
  27. (* Currently it is included in every file being translated.
  28. (* And it s being run through the preprocessor first, which does not know
  29. (* about pascal comments. So be carefull with ''s.
  30. (*
  31. (* Notes/limitations:
  32. (*   OS/2:
  33. (*      Maybe I should know beter, but I''m using native OS/2 calls. (wjw)
  34. (*
  35. (*   File I/O:
  36. (*      Although the compiler knows about files, currently the only files 
  37. (*      known are output for writes, input for read. And these are hard coded
  38. (*      into the routines
  39. (*      The runtime lib itself can use file handle 2 as 'stderr'.
  40. (*       
  41. (*      Upon input we assume that input lines are less than 256 chars.
  42. (*      Otherwise routines will break.
  43. (*
  44. (*   Standard routines:
  45. (*      The standard routines are Currently generated by the backend with TWO
  46. (*      leading $''s in the name. This means that here we should only use ONE,
  47. (*      the second one gets added by the compiler.
  48. (*
  49. (*   Local Routines:
  50. (*      Routines to be used only in this module have a '_' prepended to their
  51. (*      name. 
  52. (*
  53. (*   Coding:
  54. (*   1) I''m trying to code this a simple as possible. The reason for this is 
  55. (*      that is library is also used to run the compiler testfiles. And if 
  56. (*      things are hairy in the lib, then it is hard to figure out where the 
  57. (*      real errors are. (And currently WITH-stat are not implemented, so 
  58. (*      complex records do not serve any purpose.)
  59. (*   2) Also is the alignment of local data done manually, since there is
  60. (*      still a bug(read not implemented) in the local allocation.
  61. (*   3) Sets are neither implemented
  62. (*   4) So are CASE-statements.
  63.  *)
  64. #include "os2.inc"
  65. (* define DEBUG_SET 1 *)
  66.  
  67. const
  68.     _intset_size   = 65536;  (* Integer sets contain a max of 65k bits *) 
  69.     _intset_words  = 2048;   (* the number of 32b words to allocate for a set *)
  70.     _intset_last   = 2047;
  71.     _bits_per_word = 32;
  72.     _max_const_set = 3;
  73. type
  74.     byte = 0..256;
  75.     word = integer;
  76.     intp = ^integer;
  77.     intsetp = ^intset;
  78.     regsetp = ^regset;
  79.     
  80.     intset = record
  81.             size   :word;                      (* counting the number of bits *)
  82.             offset :word;                         (* offset for the first bit *)
  83.             bits   :array [0.._intset_last] of word;        (* the actual set *)
  84.         end;
  85.         
  86.     constset = record
  87.             freeset:boolean;
  88. #ifndef ALIGN_FIXED            
  89.             dummy  :array[0..2]of boolean;    (* Align doesnt''t work *)
  90. #endif            
  91.             s      :intsetp;                   (* We need the pointer so we 
  92.                                                (* can compare *)
  93.         end;         
  94.         
  95.     regset = record
  96.             size   :word;                      (* counting the number of bits *)
  97.             offset :word;                      (* offset for the first bit *)
  98.             bits   :array [0..0] of word;      (* the actual set *)
  99.         end;         
  100. var 
  101.     _const_set     : array [0.._max_const_set] of constset;
  102.  
  103. (* routines done in other modules *)
  104. procedure ErrorLib(s :_str); external;
  105.  
  106. (* Some of the real work *)
  107.  
  108. function $StdSetSet(setp :intsetp; i:word) :intsetp;
  109. var
  110.     index, mask :word;
  111. begin
  112. #if DEBUG_SET > 1
  113.     writeln('$SetSet ', i);
  114. #endif
  115.     i     := (i-setp^.offset) 
  116.    ;index := i div _bits_per_word
  117.    ;mask  := $shl(1,i mod _bits_per_word)
  118. #if DEBUG_SET > 3
  119.    ;writeln('Mask: ', mask, ' Org ', setp^.bits[index])
  120. #endif
  121.    ;setp^.bits[index] := $OrWord(setp^.bits[index],mask)
  122. #if DEBUG_SET > 2   
  123.    ;writeln('Result ', setp^.bits[index])
  124. #endif
  125.    ;$StdsetSet := setp
  126. end;
  127.  
  128. function $StdSetIn(val :word; setp :intsetp ) :boolean;
  129. var
  130.     index, off, mask :word;
  131. begin    
  132. #if DEBUG_SET > 0
  133.      writeln('$SetIn ', val);
  134. #endif
  135.     ;val    := val - setp^.offset
  136.     ;index  := val div _bits_per_word
  137.     ;off    := val mod _bits_per_word
  138.     ;mask   := $shl(1,off)
  139. #if DEBUG_SET > 2
  140.     ;writeln('SetIn setting index = ', index, 'offset = ', off)
  141. #endif
  142.         ;$StdSetIn := $AndWord(setp^.bits[index],mask) <> 0
  143.         ;$StdReleaseSetConst(setp)
  144. end;
  145.  
  146. procedure $StdWriteSet(setp :intsetp);
  147. var
  148.     i,index, mask :word;
  149. begin
  150. #if DEBUG_SET > 0
  151.     writeln('$WriteSet: size = ',setp^.size:1,' offset = ', setp^.offset:1);
  152. #endif
  153.      write( '( ')
  154.     ;for i := 0 to setp^.size
  155.      do
  156.        begin
  157.           index  := i div _bits_per_word
  158.          ;mask   := $shl(1,i mod _bits_per_word)
  159. #if DEBUG_SET > 3
  160.    ;writeln('Mask: ', mask, ' Org ', setp^.bits[index], ' Gives: ', $AndWord(setp^.bits[index],mask))
  161. #endif
  162.          ;if ( $AndWord(setp^.bits[index],mask) <> 0 )
  163.           then write(i+setp^.offset:1, ' ')
  164.        end
  165.     ;writeln(' )')
  166. end;
  167.  
  168. function $StdSetRange(setp :intsetp; start, last :word) :intsetp;
  169. (*  Currently the very blunt method.
  170.  *)
  171. var
  172.     i :word;
  173. begin
  174. #if DEBUG_SET > 0
  175.     writeln('$SetRange from ',start:1, ' to ', last:1);
  176. #endif
  177.     for i := start to last
  178.     do setp := $StdSetSet(setp,i)
  179.    ;$StdSetRange := setp
  180. end;
  181.  
  182. function $StdSetUnion(a,b :intsetp):intsetp;
  183. var tmp: intsetp;
  184.     i, newsize, newoffset :word;
  185. begin
  186. #if DEBUG_SET > 0
  187.     writeln('$SetUnion');
  188. #endif
  189.     if A^.size = b^.size
  190.     then
  191.       begin
  192.                  tmp       := $StdGetSetConst(a^.size, a^.offset)
  193.                 ;$StdSetUnion := tmp
  194.         ;for i := 0 to a^.size div _bits_per_word
  195.          do   (* Join both sets *)
  196.               tmp^.bits[i] := $OrWord(a^.bits[i],b^.bits[i] )
  197.        end
  198.      else
  199.        begin
  200.           (* this can only happen if one of the sets is a constant 
  201.            * Take the smallest one.
  202.            *)
  203.           if a^.size < b^.size
  204.           then
  205.             begin
  206.                newsize   := a^.size
  207.               ;newoffset := a^.offset
  208.             end
  209.           else
  210.             begin
  211.                newsize   := b^.size
  212.               ;newoffset := b^.offset
  213.             end
  214.                  ;tmp := $StdGetSetConst(newsize,newoffset) 
  215.           (* The operate bitwise on the sets. A much more painfull thing *)
  216.          ;for i := newoffset to newoffset+newsize
  217.                   do if $StdSetIn(i,a) OR $StdSetIn(i,b) 
  218.                          then tmp := $StdSetSet(tmp,i)
  219.        end
  220.         ;$StdReleaseSetConst(a)
  221.         ;$StdReleaseSetConst(b)
  222. #if DEBUG_SET > 1
  223.    ;writeln('$SetUnion returns:')       
  224.    ;$StdWriteSet(tmp)
  225. #endif
  226. end;
  227.  
  228. function $StdSetDiff(a,b :intsetp):intsetp;
  229. var tmp: intsetp;
  230.     i :word;
  231. begin
  232. #if DEBUG_SET > 0
  233.     writeln('$SetDiff');
  234. #endif
  235.          tmp      := $StdGetSetConst(a^.size, a^.offset)
  236.         ;$StdSetDiff := tmp
  237.     ;for i := 0 to a^.size div _bits_per_word
  238.      do   (* Remove all b''s from a*)
  239.           tmp^.bits[i] := $AndWord(a^.bits[i],$InvWord(b^.bits[i]) )
  240.         ;$StdReleaseSetConst(a)
  241.         ;$StdReleaseSetConst(b)
  242. end;
  243.  
  244. function $StdSetInter(a,b :intsetp):intsetp;
  245. var tmp: intsetp;
  246.     i :word;
  247. begin
  248. #if DEBUG_SET > 0
  249.     writeln('$SetInter');
  250. #endif
  251.          tmp       := $StdGetSetConst(a^.size, a^.offset)
  252.         ;$StdSetInter := tmp
  253.     ;for i := 0 to a^.size div _bits_per_word
  254.      do   (* Remove all bits both in a and b*)
  255.           tmp^.bits[i] := $AndWord(a^.bits[i],b^.bits[i] )
  256.         ;$StdReleaseSetConst(a)
  257.         ;$StdReleaseSetConst(b)
  258. end;
  259.  
  260. function $StdSetEqual(a,b :intsetp):boolean;
  261. var equal :boolean;
  262. #ifndef ALIGN_FIXED            
  263.      dummy  :array[0..2]of boolean;    (* Align doesnt''t work *)
  264. #endif            
  265.     i :word;
  266. begin
  267. #if DEBUG_SET > 0
  268.     writeln('$SetEqual');
  269. #endif
  270.      equal := true
  271.     ;for i := 0 to a^.size div _bits_per_word
  272.      do 
  273.         begin
  274. #if DEBUG_SET > 2
  275.           writeln('a: ', a^.bits[i], ' b: ', b^.bits[i] );
  276. #endif
  277.           equal := equal AND (a^.bits[i] = b^.bits[i])
  278.         end
  279.         ;$StdReleaseSetConst(a)
  280.         ;$StdReleaseSetConst(b)
  281.         ;$StdSetEqual := equal
  282. end;
  283.  
  284. function $StdSetIncl(a,b :intsetp):boolean;
  285. var included :boolean;
  286. #ifndef ALIGN_FIXED            
  287.      dummy  :array[0..2]of boolean;    (* Align doesnt''t work *)
  288. #endif            
  289.     i :word;
  290. begin
  291. #if DEBUG_SET > 0
  292.     writeln('$SetIncl');
  293. #endif
  294.      included := true
  295.     ;for i := 0 to a^.size div _bits_per_word
  296.      do   (* True as long a 'a' does''t have bits other that b''s *)
  297.            included := included 
  298.              AND (b^.bits[i] = $OrWord(a^.bits[i],b^.bits[i]) )
  299.         ;$StdReleaseSetConst(a)
  300.         ;$StdReleaseSetConst(b)
  301.         ;$StdSetIncl := included
  302. end;
  303.  
  304. function $StdGetSetConst(size, offset :word) :intsetp;
  305. var i :integer;
  306.     ret :intsetp;
  307.     found, dummy1, dummy2,dummy3 :boolean;
  308. begin
  309. #if DEBUG_SET > 0
  310.     writeln('GetSetConst');
  311.     writeln('    For size = ', size, '  offset = ', offset );
  312. #endif
  313.     i := 0
  314.    ;found := false;
  315.    ;while( (not found) and (i<=_max_const_set))
  316.     do
  317.       begin
  318.         if _const_set[i].freeset
  319.         then
  320.           begin
  321.              _const_set[i].freeset   := False
  322.             ;_const_set[i].s^.size   := size
  323.             ;_const_set[i].s^.offset := offset
  324.             ;ret                     := _const_set[i].s
  325.             ;found                   := true
  326. #if DEBUG_SET > 1
  327.             ;writeln('Allocated set: ', i:1);
  328. #endif
  329.           end
  330.         else
  331.             i := i+1
  332.       end
  333.     ;for i := 0 to size div _bits_per_word
  334.      do ret^.bits[i] := 0
  335.         ;$StdGetSetConst            := ret
  336. #if DEBUG_SET > 2
  337.     ;Writeln('$GetSetConst returns:');
  338.         ;$StdWriteSet(ret);
  339. #endif    
  340. end;
  341.  
  342. procedure $StdReleaseSetConst(sp :intsetp);
  343. var i :integer;
  344. begin
  345. #if DEBUG_SET > 0
  346.     write('$ReleaseSetConst');
  347. #endif
  348.   for i := 0 to _max_const_set
  349.   do
  350.     if _const_set[i].s = sp
  351.     then
  352.       begin
  353.          _const_set[i].freeset     := True
  354. #if DEBUG_SET > 1
  355.         ;writeln(' Freed: ', i:1);
  356. #endif
  357.       end
  358. #if DEBUG_SET > 0
  359.    ;writeln
  360. #endif
  361. end;
  362.  
  363. procedure $StdSetCpy(fromset, toset :intsetp; size :word);
  364. (* Assuming that the 'to'-set always contains the correct 
  365. (* size and offset.
  366.  *)
  367. var index :word;
  368. begin
  369. #if DEBUG_SET > 0
  370.     writeln('$SetCpy for size = ', size:1);
  371.     if fromset = NIL then WriteLn('    Copy empty set')
  372.                      else Writeln('    Copy fromset size = ', fromset^.size:1, 
  373.                      ' offset = ', fromset^.offset:1 );
  374.     if toset = NIL   then WriteLn('    Copy empty set')
  375.                      else Writeln('    Copy toset size = ', toset^.size:1,
  376.                      ' offset = ', toset^.offset:1 );
  377. #endif
  378.      for index := 0 to (size div _bits_per_word)
  379.      do
  380.        begin
  381. #if DEBUG_SET > 3
  382.     writeln('    Index = ', index);
  383. #endif
  384.          if fromset = NIL 
  385.          then toset^.bits[index] := 0
  386.          else toset^.bits[index] := fromset^.bits[index]
  387.        end
  388.         ;$StdReleaseSetConst(fromset)
  389. #if DEBUG_SET > 1       
  390.    ;$StdWriteSet(toset)
  391. #endif
  392. end;
  393.  
  394. procedure $SetInit;
  395. var i :integer;
  396. begin
  397. #if DEBUG_SET > 0
  398.     writeln('$SetInit');
  399. #endif
  400.     (* allocate the sets *)
  401.     for i := 0 to _max_const_set
  402.     do 
  403.       begin
  404.          new(_const_set[i].s)
  405.         ;_const_set[i].freeset   := True
  406.         ;_const_set[i].s^.size   := 0
  407.         ;_const_set[i].s^.offset := 0
  408.       end
  409. end;
  410.  
  411. procedure $SetExit;
  412. var i :integer;
  413. begin
  414. #if DEBUG_SET > 0
  415.     writeln('$SetEnd');
  416. #endif
  417.     (* Kill what we allocated *)
  418.     for i := 0 to 2
  419.     do dispose(_const_set[i].s)
  420. end;
  421.     begin
  422. end.
  423. (*
  424.  * $Log: setlib.pas,v $
  425.  * Revision 1.1  1993/11/03  15:55:04  wjw
  426.  * Started adminstration for the RUNTIME LIB
  427.  *
  428.  *
  429.  *      First created by Willem Jan Withagen ( wjw@eb.ele.tue.nl ),
  430.  *                    on Mon July 26 23:30:03 MET 1993
  431.  *)
  432.