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 /* program to generate code for x ** n where n is a constant integer > 1
12 
13    Method used is left-to-right binary scan of n,
14           See Knuth, Volume 2, page 399
15 
16    Initial Version: 3 June 1971 by BLW
17           Modified: 5 July 1972 by BLW  */
18 
19 exp_op:   proc(npx,refs,atom);
20 
21 dcl       npx ptr,            /* points at operator node */
22           refs(3) ptr,                  /* refs for operands */
23           atom(3) bit(1) aligned;       /* "1"b if operand(i) is atom */
24 
25 dcl       node_pt ptr defined (npx),
26           ref(3) ptr defined (refs);
27 
28 dcl       (p,q) ptr,
29           (type,square_macro,mpy_macro,n) fixed bin(15),
30           fw bit(36) aligned;
31 
32 dcl       load entry(ptr,fixed bin);
33 dcl       m_a entry(ptr,bit(2) aligned);
34 dcl       compile_exp$save entry(ptr) returns(ptr),
35           get_reference entry returns(ptr);
36 dcl       state_man$erase_reg entry(bit(19) aligned);
37 dcl       expmac entry(fixed bin(15),ptr),
38           expmac$zero entry(fixed bin(15));
39 
40 dcl       (index,substr) builtin;
41 
42 dcl       full_word bit(36) aligned based;
43 
44 dcl (     square_fx1          init(403),
45           mpy_mac(4)          init(25,0,31,32)) fixed bin(15) int static;
46 
47 %include cgsystem;
48 %include reference;
49 %include symbol;
50 %include operator;
51 
52           /* following prevents use of A and Q as instruction modifiers by forcing
53              into storage any result held in these registers */
54 
55           call state_man$erase_reg("11"b);
56 
57           if atom(2) then call load(ref(2),0); else ref(2) = compile_exp$save((node_pt -> operand(2)));
58 
59           p = get_reference();
60           p -> reference = ref(2) -> reference;
61           if p -> reference.no_address then call m_a(p,"0"b);
62           p -> reference.shared, p -> reference.perm_address = "1"b;
63 
64           if atom(2) then q = p; else q = ref(2);
65 
66           type = p -> reference.data_type;
67           square_macro = square_fx1 - 1 + type;
68           mpy_macro = mpy_mac(type);
69 
70           fw = ref(3) -> reference.symbol -> symbol.initial -> full_word;
71 
72           call expmac(mpy_macro,q);
73 
74           n = index(fw,"1"b) + 1;
75 
76 loop:     if substr(fw,n,1) then call expmac(mpy_macro,p);
77 
78           n = n + 1;
79           if n <= bits_per_word
80           then do;
81                call expmac$zero(square_macro);
82                goto loop;
83                end;
84 
85           end;