1 /* ***********************************************************
 2    *                                                         *
 3    * Copyright, (C) Honeywell Information Systems Inc., 1982 *
 4    *                                                         *
 5    * Copyright (c) 1972 by Massachusetts Institute of        *
 6    * Technology and Honeywell Information Systems, Inc.      *
 7    *                                                         *
 8    *********************************************************** */
 9 
10 
11 /*        This procedure allocates and initializes a block node.
12 
13           Modified on:        10 August 1970 by P. Green for Version II
14           Modified on:        30 October 1970 by PG for updated node format
15           Modified on:         5 January 1971 by BLW for updated node format
16           Modified on:        1 July 1971 by JDM for these changes to the block node:
17                                  1) descriptors_used replaced by filler_field
18                                  2) max_arg_no replaced by filler
19                                  3) max_par_no replaced by filler1
20                                  4) last_temp replaced by entry_info
21           Modified on:        22 September 1971 by PAB to add IO items to node
22           Modified on:        11 February 1977 to add text_displayed bit
23           Modified on:        April 1977 by RHS for new allocation methods
24           Modified on:        April 3 1977 by P.Green to tell why blocks are non-quick
25           Modified on:        22 Ocober 1980 by M. N. Davidoff to diagnose block.number too big; fixes 1960.
26 */
27 /* format: style3 */
28 create_block:
29      procedure (type, father) returns (ptr);
30 
31 dcl       type                bit (9) aligned;
32 dcl       father              ptr;
33 
34 /* automatic */
35 
36 dcl       p                   ptr;
37 dcl       q                   ptr;
38 
39 /* builtin */
40 
41 dcl       (char, ltrim, null) builtin;
42 
43 /* external static */
44 
45 dcl       1 pl1_nodes_template_$block_template
46                               aligned like block external static;
47 dcl       pl1_stat_$node_uses (32) fixed bin external static;
48 dcl       1 pl1_stat_$statement_id
49                               external static,
50             2 file_number     bit (8),
51             2 line_number     bit (14),
52             2 statement_number
53                               bit (5);
54 ^L
55 %include block;
56 %include block_types;
57 %include nodes;
58 %include pl1_tree_areas;
59 %include token_types;
60 %include language_utility;
61 ^L
62 /* program */
63 
64           pl1_stat_$node_uses (1) = pl1_stat_$node_uses (1) + 1;
65           if pl1_stat_$node_uses (1) > max_block_number
66           then call parse_error$no_text (385, create_token (ltrim (char (max_block_number)), dec_integer));
67 
68           allocate block in (tree_area) set (p);
69 
70           p -> block = pl1_nodes_template_$block_template;
71           p -> block.node_type = block_node;
72           p -> block.source_id = pl1_stat_$statement_id;
73           p -> block.father = father;
74           p -> block.block_type = type;
75           p -> block.no_stack = type = internal_procedure | type = begin_block;
76           p -> block.number = pl1_stat_$node_uses (1);
77           p -> block.owner = null;
78 
79           if father ^= null
80           then if father -> block.son = null
81                then father -> block.son = p;
82                else do;
83                          do q = father -> block.son repeat q -> block.brother while (q -> block.brother ^= null);
84                          end;
85 
86                          q -> block.brother = p;
87                     end;
88 
89           return (p);
90      end create_block;