home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / a_utils / flex / aflexx-a / aflex.lha / aflex / src / cclB.a < prev    next >
Encoding:
Text File  |  1993-05-31  |  4.1 KB  |  142 lines
  1. -- Copyright (c) 1990 Regents of the University of California.
  2. -- All rights reserved.
  3. --
  4. -- This software was developed by John Self of the Arcadia project
  5. -- at the University of California, Irvine.
  6. --
  7. -- Redistribution and use in source and binary forms are permitted
  8. -- provided that the above copyright notice and this paragraph are
  9. -- duplicated in all such forms and that any documentation,
  10. -- advertising materials, and other materials related to such
  11. -- distribution and use acknowledge that the software was developed
  12. -- by the University of California, Irvine.  The name of the
  13. -- University may not be used to endorse or promote products derived
  14. -- from this software without specific prior written permission.
  15. -- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
  16. -- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
  17. -- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
  18.  
  19. -- TITLE character classes routines
  20. -- AUTHOR: John Self (UCI)
  21. -- DESCRIPTION routines for character classes like [abc]
  22. -- $Header: /dc/uc/self/arcadia/aflex/ada/src/RCS/cclB.a,v 1.7 1993/04/27 23:17:15 self Exp $ 
  23.  
  24. with MISC_DEFS, TEXT_IO, MISC, TSTRING; use MISC_DEFS, TEXT_IO; 
  25. package body CCL is 
  26.  
  27. -- ccladd - add a single character to a ccl
  28.   procedure CCLADD(CCLP : in INTEGER; 
  29.                    CH   : in CHARACTER) is 
  30.     IND, LEN, NEWPOS : INTEGER; 
  31.   begin
  32.     LEN := CCLLEN(CCLP); 
  33.     IND := CCLMAP(CCLP); 
  34.  
  35.     -- check to see if the character is already in the ccl
  36.     for I in 0 .. LEN - 1 loop
  37.       if (CCLTBL(IND + I) = CH) then 
  38.         return; 
  39.       end if; 
  40.     end loop; 
  41.  
  42.     NEWPOS := IND + LEN; 
  43.  
  44.     if (NEWPOS >= CURRENT_MAX_CCL_TBL_SIZE) then 
  45.       CURRENT_MAX_CCL_TBL_SIZE := CURRENT_MAX_CCL_TBL_SIZE + 
  46.         MAX_CCL_TBL_SIZE_INCREMENT; 
  47.  
  48.       NUM_REALLOCS := NUM_REALLOCS + 1; 
  49.  
  50.       REALLOCATE_CHARACTER_ARRAY(CCLTBL, CURRENT_MAX_CCL_TBL_SIZE); 
  51.     end if; 
  52.  
  53.     CCLLEN(CCLP) := LEN + 1; 
  54.     CCLTBL(NEWPOS) := CH; 
  55.  
  56.   end CCLADD; 
  57.  
  58.   -- cclinit - make an empty ccl
  59.  
  60.   function CCLINIT return INTEGER is 
  61.   begin
  62.     LASTCCL := LASTCCL + 1; 
  63.     if (LASTCCL >= CURRENT_MAXCCLS) then 
  64.       CURRENT_MAXCCLS := CURRENT_MAXCCLS + MAX_CCLS_INCREMENT; 
  65.  
  66.       NUM_REALLOCS := NUM_REALLOCS + 1; 
  67.  
  68.       REALLOCATE_INTEGER_ARRAY(CCLMAP, CURRENT_MAXCCLS); 
  69.       REALLOCATE_INTEGER_ARRAY(CCLLEN, CURRENT_MAXCCLS); 
  70.       REALLOCATE_INTEGER_ARRAY(CCLNG, CURRENT_MAXCCLS); 
  71.     end if; 
  72.  
  73.     if (LASTCCL = 1) then 
  74.  
  75.       -- we're making the first ccl
  76.       CCLMAP(LASTCCL) := 0; 
  77.  
  78.     else 
  79.  
  80.       -- the new pointer is just past the end of the last ccl.  Since
  81.       -- the cclmap points to the \first/ character of a ccl, adding the
  82.       -- length of the ccl to the cclmap pointer will produce a cursor
  83.       -- to the first free space
  84.       CCLMAP(LASTCCL) := CCLMAP(LASTCCL - 1) + CCLLEN(LASTCCL - 1); 
  85.     end if; 
  86.  
  87.     CCLLEN(LASTCCL) := 0; 
  88.     CCLNG(LASTCCL) := 0; 
  89.  
  90.     -- ccl's start out life un-negated
  91.     return LASTCCL; 
  92.   end CCLINIT; 
  93.  
  94.   -- cclnegate - negate a ccl
  95.  
  96.   procedure CCLNEGATE(CCLP : in INTEGER) is 
  97.   begin
  98.     CCLNG(CCLP) := 1; 
  99.   end CCLNEGATE; 
  100.  
  101.   -- list_character_set - list the members of a set of characters in CCL form
  102.   --
  103.   -- writes to the given file a character-class representation of those
  104.   -- characters present in the given set.  A character is present if it
  105.   -- has a non-zero value in the set array.
  106.  
  107.   procedure LIST_CHARACTER_SET(F    : in FILE_TYPE; 
  108.                                CSET : in C_SIZE_BOOL_ARRAY) is 
  109.     I, START_CHAR : INTEGER; 
  110.   begin
  111.     TEXT_IO.PUT(F, '['); 
  112.  
  113.     I := 1; 
  114.     while (I <= CSIZE) loop
  115.       if (CSET(I)) then 
  116.         START_CHAR := I; 
  117.  
  118.         TEXT_IO.PUT(F, ' '); 
  119.  
  120.         TSTRING.PUT(F, MISC.READABLE_FORM(CHARACTER'VAL(I))); 
  121.  
  122.         I := I + 1; 
  123.         while ((I <= CSIZE) and then (CSET(I))) loop
  124.           I := I + 1; 
  125.         end loop; 
  126.  
  127.         if (I - 1 > START_CHAR) then 
  128.  
  129.           -- this was a run
  130.           TEXT_IO.PUT(F, "-"); 
  131.           TSTRING.PUT(F, MISC.READABLE_FORM(CHARACTER'VAL(I - 1))); 
  132.         end if; 
  133.  
  134.         TEXT_IO.PUT(F, ' '); 
  135.       end if; 
  136.       I := I + 1; 
  137.     end loop; 
  138.  
  139.     TEXT_IO.PUT(F, ']'); 
  140.   end LIST_CHARACTER_SET; 
  141. end CCL; 
  142.