1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28 create_block:
29 procedure (type, father) returns (ptr);
30
31 dcl type bit (9) aligned;
32 dcl father ptr;
33
34
35
36 dcl p ptr;
37 dcl q ptr;
38
39
40
41 dcl (char, ltrim, null) builtin;
42
43
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
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;