1 /* ***********************************************************
 2    *                                                         *
 3    * Copyright, (C) Honeywell Information Systems Inc., 1983 *
 4    *                                                         *
 5    * Copyright (c) 1972 by Massachusetts Institute of        *
 6    * Technology and Honeywell Information Systems, Inc.      *
 7    *                                                         *
 8    *********************************************************** */
 9 
10 
11 getonsource:        proc() returns(char(*)) options(support);
12 
13 %include on_data_;
14 
15 
16           return(ondata_$onsource);
17 
18 get_onfield:        entry() returns(char(*));
19 
20           return(ondata_$datafield);
21 
22 get_onfile:         entry() returns(char(*));
23 
24           return(ondata_$onfile);
25 
26 get_onkey:          entry() returns(char(*));
27 
28           return(ondata_$onkey);
29 
30 /*^L*/
31 get_onloc:          entry() returns(char(*));
32 
33 
34 dcl  i fixed bin;
35 dcl  segno fixed bin(18);
36 dcl  code fixed bin(35);
37 
38 dcl  spno bit(18) aligned;
39 
40 dcl  ename char(256) aligned;
41 dcl  lang char(8) aligned;
42 
43 dcl  nsp ptr;
44 
45 dcl (baseno, addr, null, index, substr) builtin;
46 dcl  find_condition_info_ entry(ptr, ptr, fixed bin(35));
47 dcl  find_condition_frame_ entry(ptr) returns(ptr);
48 dcl  get_entry_name_ entry(ptr, char(*) aligned, fixed bin(18), char(8) aligned, fixed bin(35));
49 dcl  error_table_$begin_block fixed bin(35) external;
50 
51 %include condition_info;
52 declare 1 CI aligned like condition_info;
53 
54 %include pl1_info;
55 %include condition_info_header;
56 
57 /*^L*/
58 
59 %include stack_frame;
60 
61 
62 /*^L*/
63 /* onloc is valid for all conditions.  This procedure looks for the  stack frame
64    belonging to the most recent non-support procedure before the most recent condition
65    and returns the entry name associated with the frame */
66 
67           sp = find_condition_frame_(null);                 /* get ptr to stack frame */
68           if sp = null then return ("");
69 
70           call find_condition_info_(sp, addr(CI), code);
71           if code ^= 0 then return ("");
72 
73           nsp = sp;                                         /* initialize ptr to be used */
74           if CI.loc_ptr ^= CI.user_loc_ptr then do;                   /* look for non-support frame */
75                spno = baseno (sp);
76                do while (baseno(nsp -> stack_frame.prev_sp) = spno); /* look thru current stack */
77                     nsp = nsp -> stack_frame.prev_sp;
78                     if ^nsp -> stack_frame_flags.support then go to get_name; /* found one */
79                end;
80                nsp = sp;                                    /* can't find non-support; use condition frame */
81           end;
82 
83 get_name:
84           call get_entry_name_(nsp -> stack_frame.entry_ptr, ename, segno, lang, code);
85           if code ^= 0 then if code = error_table_$begin_block
86                then do;
87                     nsp = nsp -> stack_frame.prev_sp;
88                     go to get_name;
89                end;
90                else ename = " ";
91           i = index(ename, " ") - 1;                        /* need exact length for return */
92           if i = -1 then i = 0;
93 
94           return (substr(ename, 1, i));
95 
96           end;