1 /* ***********************************************************
 2    *                                                         *
 3    * Copyright, (C) Honeywell Information Systems Inc., 1982 *
 4    *                                                         *
 5    *********************************************************** */
 6 %;
 7 /* ******************************************************
 8    *                                                    *
 9    *                                                    *
10    * Copyright (c) 1972 by Massachusetts Institute of   *
11    * Technology and Honeywell Information Systems, Inc. *
12    *                                                    *
13    *                                                    *
14    ****************************************************** */
15 
16 create_reference: proc(s) returns(ptr);
17 /*        Modified on:        April 1977 by RHS for new allocation methods */
18 
19 dcl       1 pl1_nodes_template_$reference_template external like reference aligned;
20 
21 dcl       (p,s) ptr,
22 
23           nodetype fixed bin(15);
24 
25 dcl       pl1_stat_$free_ptr(18) ptr ext static;
26 
27 dcl       (addr,fixed,null,string) builtin;
28 dcl       pl1_stat_$node_uses(32) fixed bin ext;
29 
30 dcl       use_xeq bit(1) aligned;
31 
32 %include pl1_tree_areas;
33 %include nodes;
34 %include reference;
35 
36           use_xeq = "1"b;
37 
38 begin:
39           nodetype = fixed(reference_node,15,0);
40           p = pl1_stat_$free_ptr(nodetype);
41 
42           if p^=null
43           then      pl1_stat_$free_ptr(nodetype) = p->reference.symbol;
44           else do;
45                pl1_stat_$node_uses(4) = pl1_stat_$node_uses(4) + 1;
46                if use_xeq
47                     then allocate reference in(xeq_tree_area) set(p);
48                     else allocate reference in(tree_area) set(p);
49                end;
50 
51           p->reference = pl1_nodes_template_$reference_template;
52 
53           p -> reference.symbol = s;
54 
55           return(p);
56 
57 for_symbol:         entry(s) returns(ptr);
58           use_xeq = "0"b;
59           go to begin;
60 
61           end;