1 /* ******************************************************
 2    *                                                    *
 3    *                                                    *
 4    * Copyright (c) 1972 by Massachusetts Institute of   *
 5    * Technology and Honeywell Information Systems, Inc. *
 6    *                                                    *
 7    *                                                    *
 8    ****************************************************** */
 9 
10 return_to: rt:
11           procedure;                    /* return to a given stack frame offset */
12 
13 /* Original program by C Garman.
14    Documentation and suggestions by P Green, July 1971
15    Converted to Version 2 and fixed for the 6180 by PG on 27 July 1973.
16    Commented and given reasonable variable names by PG on 15 January 1974. */
17 
18 
19 dcl com_err_ entry options (variable),
20     cv_oct_check_ entry (char (*), fixed bin, fixed bin),
21     legal_f_ entry (ptr) returns (fixed bin),
22     pl1_frame_ entry (ptr) returns (bit (1) aligned),
23     cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin);
24 
25 dcl (addr, baseno, pointer) builtin;
26 
27 dcl (ptr_to_return_ptr, ptr_to_stack_frame, number_ptr) ptr,
28     (stack_frame_offset, code, number_length) fixed bin,
29     dummy_label label based,
30     number char (number_length) based (number_ptr);
31 
32 dcl my_name char (9) internal static initial ("return_to");
33 
34 declare 1 label aligned,
35           2 text_ptr ptr,
36           2 stack_ptr ptr;
37 
38 declare 1 stack aligned based,
39           2 pointers dim (0:7) bit (72),
40           2 (backward, forward, callout) ptr;
41 
42 declare 1 its aligned based,
43           2 (segn bit (18),
44              ring bit (3),
45              trash1 bit (9),
46              its_flag bit (6)) unal,
47           2 (offset bit (18),
48              trash2 bit (12),
49              modifier bit (6)) unal;
50 ^L
51           call cu_$arg_ptr (1, number_ptr, number_length, code);
52           if code ^= 0
53           then do;
54 
55                call com_err_ (code, my_name, "Usage: return_to octal_stack_offset");
56                return;
57 
58                end;
59 
60           call cv_oct_check_ (number, code, stack_frame_offset);
61           if code ^= 0
62           then do;
63 
64                call com_err_ (0, my_name, "Error in digit ^d of octal string ""^a"".", code, number);
65                return;
66 
67                end;
68 
69           /* Get a pointer to the requested stack frame. Note that the frame must be
70              on the same stack segment due to the kludgy way we get a pointer
71              to the stack--by taking the addr of an automatic variable! */
72 
73           ptr_to_stack_frame = pointer (addr (ptr_to_stack_frame), stack_frame_offset);
74           ptr_to_return_ptr = addr (ptr_to_stack_frame -> stack.callout);
75 
76           if legal_f_ (ptr_to_stack_frame) = 0                        /* Is this a legitimate stack-frame? */
77           then if ptr_to_return_ptr -> its.its_flag = "100011"b       /* Does sp|20 have ITS-pointer */
78                then if ptr_to_return_ptr -> its.trash1 = "0"b         /* and is even word clean */
79                     then if baseno (ptr_to_stack_frame) ^= baseno (ptr_to_stack_frame -> stack.callout)
80                          then do;                                     /* (and not pointer to stack) */
81 
82                                    label.text_ptr = ptr_to_stack_frame -> stack.callout;
83                                    label.stack_ptr = ptr_to_stack_frame;
84 
85                                    go to addr (label) -> dummy_label; /* That's it. Do the "return" */
86 
87                               end;
88 
89           call com_err_ (0, my_name, "Invalid frame at stack|^a", number);
90 
91 end return_to;