COMPILATION LISTING OF SEGMENT getonsource Compiled by: Multics PL/I Compiler, Release 29, of July 28, 1986 Compiled at: Honeywell Multics Op. - System M Compiled on: 11/05/86 1034.5 mst Wed Options: optimize map 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 1 1 /* declarations for users of 1 2* ondata_$ 1 3*installed in >ldd>include>on_data_.incl.pl1 1 4*fixed up in PAB>others>on_data_.incl.pl1 1 5**/ 1 6 1 7 1 8 1 9 dcl ( 1 10 ondata_$ondatalength fixed bin(15), 1 11 ondata_$callersegname char(32) varying, 1 12 ondata_$callerpathname char(168) varying, 1 13 ondata_$calleroffset fixed bin(17), 1 14 ondata_$infoptr ptr, 1 15 ondata_$onreturnp ptr, 1 16 ondata_$this_file ptr, 1 17 ondata_$who char(4) aligned, 1 18 ondata_$handled fixed bin(15), 1 19 ondata_$file_related fixed bin(15), 1 20 ondata_$fileptr ptr, 1 21 ondata_$pliopsp ptr, 1 22 ondata_$datafield char(256) var, 1 23 ondata_$oncalled char(256) var, 1 24 ondata_$onfile char(32) var, 1 25 ondata_$onloc char(292) var, 1 26 ondata_$onsource char(256) var, 1 27 ondata_$onkey char(256) var, 1 28 ondata_$oncharindex fixed bin(15), 1 29 ondata_$onchar char(1000) aligned, 1 30 ondata_$oncode fixed bin(15), 1 31 ondata_$oncount fixed bin(15), 1 32 ondata_$plio_code fixed bin(15), 1 33 ondata_$condition_name char(32) var ) external; 13 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 /* */ 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 2 1 /* BEGIN INCLUDE FILE ... condition_info.incl.pl1 */ 2 2 2 3 /* Structure for find_condition_info_. 2 4* 2 5* Written 1-Mar-79 by M. N. Davidoff. 2 6**/ 2 7 2 8 /* automatic */ 2 9 2 10 declare condition_info_ptr pointer; 2 11 2 12 /* based */ 2 13 2 14 declare 1 condition_info aligned based (condition_info_ptr), 2 15 2 mc_ptr pointer, /* pointer to machine conditions at fault time */ 2 16 2 version fixed binary, /* Must be 1 */ 2 17 2 condition_name char (32) varying, /* name of condition */ 2 18 2 info_ptr pointer, /* pointer to the condition data structure */ 2 19 2 wc_ptr pointer, /* pointer to wall crossing machine conditions */ 2 20 2 loc_ptr pointer, /* pointer to location where condition occured */ 2 21 2 flags unaligned, 2 22 3 crawlout bit (1), /* on if condition occured in lower ring */ 2 23 3 pad1 bit (35), 2 24 2 pad2 bit (36), 2 25 2 user_loc_ptr pointer, /* ptr to most recent nonsupport loc before condition occurred */ 2 26 2 pad3 (4) bit (36); 2 27 2 28 /* internal static */ 2 29 2 30 declare condition_info_version_1 2 31 fixed binary internal static options (constant) initial (1); 2 32 2 33 /* END INCLUDE FILE ... condition_info.incl.pl1 */ 51 52 declare 1 CI aligned like condition_info; 53 3 1 /* BEGIN INCLUDE FILE ... pl1_info.incl.pl1 */ 3 2 /* This is intended to be used by all procedures raising pl1 conditions and by the default handler */ 3 3 /* Created June 1981 by Benson I. Margulies from pl1_info_struc.incl.pl1 */ 3 4 /* This include file must be used with condition_info_header.incl.pl1. Both must be %included */ 3 5 3 6 declare pl1_info_ptr pointer; 3 7 declare 1 pl1_info aligned based (pl1_info_ptr), 3 8 2 header aligned like condition_info_header, 3 9 2 id char(8) aligned, /* init "pliocond"; indicates pl1 structure */ 3 10 2 content_flags aligned, 3 11 (3 v1_sw, /* on if raised by version 1 */ 3 12 3 oncode_sw, /* "1"b->valid oncode */ 3 13 3 onfile_sw, /* "1"b->file name is in structure */ 3 14 3 file_ptr_sw, /* "1"b->file is associated with this condition */ 3 15 3 onsource_sw, /* "1"b->valid onsource string for this condition */ 3 16 3 onchar_sw, /* "1"b->valid onchar index in this structure */ 3 17 3 onkey_sw, /* "1"b->valid onkey string in this structure */ 3 18 3 onfield_sw) bit(1) unaligned, /* "1"b->valid onfield string in this structure */ 3 19 2 oncode fixed bin(35), /* oncode for condition */ 3 20 2 onfile char(32) aligned, /* onfile string */ 3 21 2 file_ptr ptr, /* pointer to file value */ 3 22 2 onsource char(256) var, /* onsource string */ 3 23 2 oncharindex fixed bin, /* char offset in onsource of offending char */ 3 24 2 onkey_onfield char(256) var; /* either onkey string or onfield string */ 3 25 3 26 /* END INCLUDE FILE ... pl1_info.incl.pl1 */ 54 4 1 /* BEGIN INCLUDE FILE condition_info_header.incl.pl1 BIM 1981 */ 4 2 /* format: style2 */ 4 3 4 4 declare condition_info_header_ptr 4 5 pointer; 4 6 declare 1 condition_info_header 4 7 aligned based (condition_info_header_ptr), 4 8 2 length fixed bin, /* length in words of this structure */ 4 9 2 version fixed bin, /* version number of this structure */ 4 10 2 action_flags aligned, /* tell handler how to proceed */ 4 11 3 cant_restart bit (1) unaligned, /* caller doesn't ever want to be returned to */ 4 12 3 default_restart bit (1) unaligned, /* caller can be returned to with no further action */ 4 13 3 quiet_restart bit (1) unaligned, /* return, and print no message */ 4 14 3 support_signal bit (1) unaligned, /* treat this signal as if the signalling procedure had the support bit set */ 4 15 /* if the signalling procedure had the support bit set, do the same for its caller */ 4 16 3 pad bit (32) unaligned, 4 17 2 info_string char (256) varying, /* may contain printable message */ 4 18 2 status_code fixed bin (35); /* if^=0, code interpretable by com_err_ */ 4 19 4 20 /* END INCLUDE FILE condition_info_header.incl.pl1 */ 55 56 57 /* */ 58 5 1 /* BEGIN INCLUDE FILE ... stack_frame.incl.pl1 ... */ 5 2 5 3 /* format: off */ 5 4 5 5 /* Modified: 16 Dec 1977, D. Levin - to add fio_ps_ptr and pl1_ps_ptr */ 5 6 /* Modified: 3 Feb 1978, P. Krupp - to add run_unit_manager bit & main_proc bit */ 5 7 /* Modified: 21 March 1978, D. Levin - change fio_ps_ptr to support_ptr */ 5 8 /* Modified: 03/01/84, S. Herbst - Added RETURN_PTR_MASK */ 5 9 5 10 5 11 /****^ HISTORY COMMENTS: 5 12* 1) change(86-09-15,Kissel), approve(86-09-15,MCR7473), 5 13* audit(86-10-01,Fawcett), install(86-11-03,MR12.0-1206): 5 14* Modified to add constants for the translator_id field in the stack_frame 5 15* structure. 5 16* END HISTORY COMMENTS */ 5 17 5 18 5 19 dcl RETURN_PTR_MASK bit (72) int static options (constant) /* mask to be AND'd with stack_frame.return_ptr */ 5 20 init ("777777777777777777000000"b3); /* when copying, to ignore bits that a call fills */ 5 21 /* with indicators (nonzero for Fortran hexfp caller) */ 5 22 /* say: unspec(ptr) = unspec(stack_frame.return_ptr) & RETURN_PTR_MASK; */ 5 23 5 24 dcl TRANSLATOR_ID_PL1V2 bit (18) internal static options (constant) init ("000000"b3); 5 25 dcl TRANSLATOR_ID_ALM bit (18) internal static options (constant) init ("000001"b3); 5 26 dcl TRANSLATOR_ID_PL1V1 bit (18) internal static options (constant) init ("000002"b3); 5 27 dcl TRANSLATOR_ID_SIGNAL_CALLER bit (18) internal static options (constant) init ("000003"b3); 5 28 dcl TRANSLATOR_ID_SIGNALLER bit (18) internal static options (constant) init ("000004"b3); 5 29 5 30 5 31 dcl sp pointer; /* pointer to beginning of stack frame */ 5 32 5 33 dcl stack_frame_min_length fixed bin static init(48); 5 34 5 35 5 36 dcl 1 stack_frame based(sp) aligned, 5 37 2 pointer_registers(0 : 7) ptr, 5 38 2 prev_sp pointer, 5 39 2 next_sp pointer, 5 40 2 return_ptr pointer, 5 41 2 entry_ptr pointer, 5 42 2 operator_and_lp_ptr ptr, /* serves as both */ 5 43 2 arg_ptr pointer, 5 44 2 static_ptr ptr unaligned, 5 45 2 support_ptr ptr unal, /* only used by fortran I/O */ 5 46 2 on_unit_relp1 bit(18) unaligned, 5 47 2 on_unit_relp2 bit(18) unaligned, 5 48 2 translator_id bit(18) unaligned, /* Translator ID (see constants above) 5 49* 0 => PL/I version II 5 50* 1 => ALM 5 51* 2 => PL/I version I 5 52* 3 => signal caller frame 5 53* 4 => signaller frame */ 5 54 2 operator_return_offset bit(18) unaligned, 5 55 2 x(0: 7) bit(18) unaligned, /* index registers */ 5 56 2 a bit(36), /* accumulator */ 5 57 2 q bit(36), /* q-register */ 5 58 2 e bit(36), /* exponent */ 5 59 2 timer bit(27) unaligned, /* timer */ 5 60 2 pad bit(6) unaligned, 5 61 2 ring_alarm_reg bit(3) unaligned; 5 62 5 63 5 64 dcl 1 stack_frame_flags based(sp) aligned, 5 65 2 pad(0 : 7) bit(72), /* skip over prs */ 5 66 2 xx0 bit(22) unal, 5 67 2 main_proc bit(1) unal, /* on if frame belongs to a main procedure */ 5 68 2 run_unit_manager bit(1) unal, /* on if frame belongs to run unit manager */ 5 69 2 signal bit(1) unal, /* on if frame belongs to logical signal_ */ 5 70 2 crawl_out bit(1) unal, /* on if this is a signal caller frame */ 5 71 2 signaller bit(1) unal, /* on if next frame is signaller's */ 5 72 2 link_trap bit(1) unal, /* on if this frame was made by the linker */ 5 73 2 support bit(1) unal, /* on if frame belongs to a support proc */ 5 74 2 condition bit(1) unal, /* on if condition established in this frame */ 5 75 2 xx0a bit(6) unal, 5 76 2 xx1 fixed bin, 5 77 2 xx2 fixed bin, 5 78 2 xx3 bit(25) unal, 5 79 2 old_crawl_out bit (1) unal, /* on if this is a signal caller frame */ 5 80 2 old_signaller bit(1) unal, /* on if next frame is signaller's */ 5 81 2 xx3a bit(9) unaligned, 5 82 2 xx4(9) bit(72) aligned, 5 83 2 v2_pl1_op_ret_base ptr, /* When a V2 PL/I program calls an operator the 5 84* * operator puts a pointer to the base of 5 85* * the calling procedure here. (text base ptr) */ 5 86 2 xx5 bit(72) aligned, 5 87 2 pl1_ps_ptr ptr; /* ptr to ps for this frame; also used by fio. */ 5 88 5 89 /* format: on */ 5 90 5 91 /* END INCLUDE FILE ... stack_frame.incl.pl1 */ 59 60 61 62 /* */ 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; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 11/04/86 1042.3 getonsource.pl1 >special_ldd>install>MR12.0-1206>getonsource.pl1 13 1 05/06/74 1742.5 on_data_.incl.pl1 >ldd>include>on_data_.incl.pl1 51 2 06/28/79 1204.8 condition_info.incl.pl1 >ldd>include>condition_info.incl.pl1 54 3 07/18/81 1100.0 pl1_info.incl.pl1 >ldd>include>pl1_info.incl.pl1 55 4 03/24/82 1347.2 condition_info_header.incl.pl1 >ldd>include>condition_info_header.incl.pl1 59 5 11/03/86 1114.7 stack_frame.incl.pl1 >special_ldd>install>MR12.0-1206>stack_frame.incl.pl1 NAMES DECLARED IN THIS COMPILATION. IDENTIFIER OFFSET LOC STORAGE CLASS DATA TYPE ATTRIBUTES AND REFERENCES (* indicates a set context) NAMES DECLARED BY DECLARE STATEMENT. CI 000210 automatic structure level 1 dcl 52 set ref 70 70 addr builtin function dcl 45 ref 70 70 baseno builtin function dcl 45 ref 75 76 code 000102 automatic fixed bin(35,0) dcl 36 set ref 70* 71 83* 85 85 condition_info based structure level 1 dcl 2-14 condition_info_header based structure level 1 dcl 4-6 ename 000104 automatic char(256) dcl 40 set ref 83* 90* 91 94 entry_ptr 26 based pointer level 2 dcl 5-36 set ref 83* error_table_$begin_block 000026 external static fixed bin(35,0) dcl 49 ref 85 find_condition_frame_ 000022 constant entry external dcl 47 ref 67 find_condition_info_ 000020 constant entry external dcl 46 ref 70 get_entry_name_ 000024 constant entry external dcl 48 ref 83 i 000100 automatic fixed bin(17,0) dcl 34 set ref 91* 92 92* 94 index builtin function dcl 45 ref 91 lang 000204 automatic char(8) dcl 41 set ref 83* loc_ptr 20 000210 automatic pointer level 2 dcl 52 set ref 74 nsp 000206 automatic pointer dcl 43 set ref 73* 76 77* 77 78 80* 83 87* 87 null builtin function dcl 45 ref 67 67 68 ondata_$datafield 000010 external static varying char(256) dcl 1-9 ref 20 ondata_$onfile 000012 external static varying char(32) dcl 1-9 ref 24 ondata_$onkey 000016 external static varying char(256) dcl 1-9 ref 28 ondata_$onsource 000014 external static varying char(256) dcl 1-9 ref 16 prev_sp 20 based pointer level 2 dcl 5-36 ref 76 77 87 segno 000101 automatic fixed bin(18,0) dcl 35 set ref 83* sp 000242 automatic pointer dcl 5-31 set ref 67* 68 70* 73 75 80 spno 000103 automatic bit(18) dcl 38 set ref 75* 76 stack_frame based structure level 1 dcl 5-36 stack_frame_flags based structure level 1 dcl 5-64 substr builtin function dcl 45 ref 94 support 20(28) based bit(1) level 2 packed unaligned dcl 5-64 ref 78 user_loc_ptr 24 000210 automatic pointer level 2 dcl 52 set ref 74 NAMES DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. RETURN_PTR_MASK internal static bit(72) initial unaligned dcl 5-19 TRANSLATOR_ID_ALM internal static bit(18) initial unaligned dcl 5-25 TRANSLATOR_ID_PL1V1 internal static bit(18) initial unaligned dcl 5-26 TRANSLATOR_ID_PL1V2 internal static bit(18) initial unaligned dcl 5-24 TRANSLATOR_ID_SIGNALLER internal static bit(18) initial unaligned dcl 5-28 TRANSLATOR_ID_SIGNAL_CALLER internal static bit(18) initial unaligned dcl 5-27 condition_info_header_ptr automatic pointer dcl 4-4 condition_info_ptr automatic pointer dcl 2-10 condition_info_version_1 internal static fixed bin(17,0) initial dcl 2-30 ondata_$calleroffset external static fixed bin(17,0) dcl 1-9 ondata_$callerpathname external static varying char(168) dcl 1-9 ondata_$callersegname external static varying char(32) dcl 1-9 ondata_$condition_name external static varying char(32) dcl 1-9 ondata_$file_related external static fixed bin(15,0) dcl 1-9 ondata_$fileptr external static pointer dcl 1-9 ondata_$handled external static fixed bin(15,0) dcl 1-9 ondata_$infoptr external static pointer dcl 1-9 ondata_$oncalled external static varying char(256) dcl 1-9 ondata_$onchar external static char(1000) dcl 1-9 ondata_$oncharindex external static fixed bin(15,0) dcl 1-9 ondata_$oncode external static fixed bin(15,0) dcl 1-9 ondata_$oncount external static fixed bin(15,0) dcl 1-9 ondata_$ondatalength external static fixed bin(15,0) dcl 1-9 ondata_$onloc external static varying char(292) dcl 1-9 ondata_$onreturnp external static pointer dcl 1-9 ondata_$plio_code external static fixed bin(15,0) dcl 1-9 ondata_$pliopsp external static pointer dcl 1-9 ondata_$this_file external static pointer dcl 1-9 ondata_$who external static char(4) dcl 1-9 pl1_info based structure level 1 dcl 3-7 pl1_info_ptr automatic pointer dcl 3-6 stack_frame_min_length internal static fixed bin(17,0) initial dcl 5-33 NAMES DECLARED BY EXPLICIT CONTEXT. get_name 000237 constant label dcl 83 ref 78 88 get_onfield 000036 constant entry external dcl 18 get_onfile 000060 constant entry external dcl 22 get_onkey 000102 constant entry external dcl 26 get_onloc 000124 constant entry external dcl 31 getonsource 000015 constant entry external dcl 11 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 500 530 331 510 Length 1026 331 30 261 147 0 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME getonsource 202 external procedure is an external procedure. STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME getonsource 000100 i getonsource 000101 segno getonsource 000102 code getonsource 000103 spno getonsource 000104 ename getonsource 000204 lang getonsource 000206 nsp getonsource 000210 CI getonsource 000242 sp getonsource THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. call_ext_out_desc call_ext_out ext_entry_desc return_chars_eis set_support THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. find_condition_frame_ find_condition_info_ get_entry_name_ THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. error_table_$begin_block ondata_$datafield ondata_$onfile ondata_$onkey ondata_$onsource LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 11 000012 16 000023 18 000034 20 000044 22 000056 24 000066 26 000100 28 000110 31 000122 67 000132 68 000145 70 000161 71 000176 73 000210 74 000212 75 000216 76 000221 77 000227 78 000231 79 000234 80 000235 83 000237 85 000271 87 000276 88 000301 90 000302 91 000305 92 000315 94 000320 ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group BULL including BULL HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell BULL Inc., Groupe BULL and BULL HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato. Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, BULL or BULL HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by BULL HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved