1 /* ***********************************************************
 2    *                                                         *
 3    * Copyright, (C) Honeywell Information Systems Inc., 1983 *
 4    *                                                         *
 5    *********************************************************** */
 6 setonsource:        proc(str) options(support);
 7 
 8 /* recoded by M. Weaver 1/14/74 for new pl1 signalling discipline */
 9 
10 dcl  str char(256) var;
11 
12 dcl  type fixed bin;
13 
14 dcl (addr, null, substr) builtin;
15 dcl  pl1_signal_$help_plio2_signal_ entry(char(*), ptr, fixed bin(35), char(256) var, fixed bin);
16 
17 %include on_data_;
18 
19 %include condition_info;
20 declare 1 CI aligned like condition_info;
21 
22 %include pl1_info;
23 %include condition_info_header;
24 
25 /*^L*/
26 /* This procedure must change the onsource string in both the old ondata_
27    segment and in the relevant structure.
28    If there is no relevant structure to change, the calling procedure is in error */
29 
30           type = 1;                                         /* indicate onsource */
31           if find_struc() then do;                          /* true if relevant struc()ture found */
32                ondata_$onsource = str;                      /* set in old way */
33                pl1_info.onsource = str;                     /* set in new way */
34                return;
35           end;
36 
37 sig_err:                                          /* no relevant structure found */
38           call pl1_signal_$help_plio2_signal_("error", null, 170, "", 0);
39           return;
40 
41 
42 set_onchar:         entry(ch);
43 
44 dcl  ch char(1);
45 
46           type = 2;                                         /* indicate onchar */
47           if find_struc() then do;
48                substr(ondata_$onsource, ondata_$oncharindex-3, 1) = ch;
49                substr(pl1_info.onsource, pl1_info.oncharindex, 1) = ch;
50                return;
51           end;
52 
53           go to sig_err;
54 
55 /*^L*/
56 find_struc:         proc() returns(bit(1) aligned);
57 
58 /* internal procedure to find  the info structure associated with the
59    most recent condition to set onsource/onchar */
60 
61 dcl  code fixed bin(35);
62 dcl (nsp, sp) ptr;
63 dcl find_condition_frame_ entry(ptr) returns(ptr);
64 dcl find_condition_info_ entry(ptr, ptr, fixed bin(35));
65 
66           nsp, sp = null;
67 next_frame:
68           nsp = find_condition_frame_(sp);                  /* look for the next condition frame */
69           if nsp = null then return("0"b);                  /* can't even find frame */
70           call find_condition_info_(nsp, addr(CI), code);
71           if code ^= 0 then return("0"b);                   /* something must be wrong; stop here */
72 
73           pl1_info_ptr = CI.info_ptr;
74           if pl1_info_ptr ^= null
75           then if pl1_info.id = "pliocond" then do;         /* have a pl1 structure */
76                if type = 1 then if pl1_info.onsource_sw then return("1"b);
77                if type = 2 then if pl1_info.onchar_sw then return("1"b);
78           end;
79 
80           sp = nsp;
81           go to next_frame;                                 /* look for next */
82 
83           end;
84 
85           end;