1 /* BEGIN INCLUDE FILE ... create_token.incl.pl1 */
  2 
  3 create_token:
  4           procedure (bv_token_string, bv_token_type) returns (ptr);
  5 
  6 /*        Modified on:        April 1977 by RHS for new allocation methods */
  7 /* Modified 770509 by PG to put hash_table in tree and make it bigger */
  8 
  9 /* parameters */
 10 
 11 declare ( bv_token_string char (*),
 12           bv_token_type bit (9) aligned,
 13           bv_protected bit (18) aligned
 14           ) parameter;
 15 
 16 /* automatic */
 17 
 18 declare   (hash_index, i, n, n_chars, n_words) fixed bin,
 19           mod_2_sum bit (36) aligned,
 20           four_chars char (4) aligned,
 21           protected bit (18) aligned,
 22           (old_q, q, p, token_string_ptr) ptr;
 23 
 24 /* based */
 25 
 26 declare   token_array_overlay (64) char (4) based (token_string_ptr),
 27           token_overlay char (n) based (token_string_ptr);
 28 
 29 /* builtins */
 30 
 31 declare   (addr, binary, bool, dim, divide, length, mod, null, substr, unspec) builtin;
 32 
 33 /* external static */
 34 
 35 declare   pl1_stat_$node_uses (18) external fixed bin;
 36 
 37 /* include files */
 38 
 39 %include pl1_token_hash_table;
 40 %include pl1_tree_areas;
 41 %include nodes;
 42 %include token;
 43 
 44 /* program */
 45 
 46           protected = ""b;
 47 
 48 join:
 49           token_string_ptr = addr (bv_token_string);
 50 
 51           n = length (bv_token_string);
 52           n_words = divide (n, 4, 21, 0);
 53           n_chars = n - n_words * 4;
 54           mod_2_sum = ""b;
 55 
 56           do i = 1 to n_words;
 57                four_chars = token_array_overlay (i);
 58                mod_2_sum = bool (mod_2_sum, unspec (four_chars), "0110"b);
 59           end;
 60 
 61           if n_chars ^= 0
 62           then do;
 63                     four_chars = substr (token_array_overlay (i), 1, n_chars);
 64                     mod_2_sum = bool (mod_2_sum, unspec (four_chars), "0110"b);
 65                end;
 66 
 67           hash_index = mod (binary (mod_2_sum, 35), dim (hash_table, 1));
 68           old_q = null;
 69 
 70           do q = hash_table (hash_index) repeat (q -> token.next) while (q ^= null);
 71                if n < q -> token.size
 72                then go to insert_token;
 73 
 74                if n = q -> token.size
 75                then if bv_token_type = q -> token.type
 76                     then if token_overlay = q -> token.string
 77                          then if protected = q -> token.loc
 78                               then return (q);
 79 
 80                old_q = q;
 81           end;
 82 
 83 insert_token:
 84           pl1_stat_$node_uses (5) = pl1_stat_$node_uses (5) + 1;
 85 
 86           allocate token in (tree_area) set (p);
 87           p -> token.node_type = token_node;
 88           p -> token.type = bv_token_type;
 89           p -> token.declaration = null;
 90           p -> token.loc = protected;
 91           p -> token.string = token_overlay;
 92           p -> token.next = q;
 93 
 94           if old_q = null
 95           then hash_table (hash_index) = p;
 96           else old_q -> token.next = p;
 97           return (p);
 98 
 99 create_token$protected:
100           entry (bv_token_string, bv_token_type, bv_protected) returns (ptr);
101 
102           protected = bv_protected;
103           go to join;
104 
105 /* END INCLUDE FILE ... create_token.incl.pl1 */