display_entry_point_dcl.pl1 05/01/86 0830.7rew 05/01/86 0808.2 49437 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(84-12-30,Ranzenbach), approve(86-03-12,MCR7144), audit(86-03-12,GWMay), install(86-05-01,MR12.0-1051): Added support for archive pathnames and ability to requote declaration for active functions (phx11853, phx12764). END HISTORY COMMENTS */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Name: display_entry_point_dcl */ /* */ /* This command/af displays the calling sequence of a PL/I procedure entry point as a */ /* PL/I declare statement. It also displays the PL/I declare statement for error_table_ */ /* code (but not for codes in non-system error tables). */ /* */ /* Status */ /* */ /* 0) Created in May, 1979 by G. C. Dixon */ /* 1) Modified in January, 1981 by G. C. Dixon - (1) remove dir part of pathname from */ /* entry point name display in declaration; (2) for command output, if */ /* get_line_length_ returns nonzero code, don't break declaration at all */ /* (probably file_output). */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * **/ display_entry_point_dcl: depd: procedure options(variable); dcl Larg fixed bin, Parg ptr, arg char(Larg) based(Parg); dcl Lret fixed bin(21), Pret ptr, ret char (Lret) varying based(Pret); dcl Nargs fixed bin, Saf bit(1), cleanup condition, code fixed bin(35), (dcl_style, line_length) fixed bin, ent char(289) varying, /* 32 char ref_name + 256 char ep_name + $ */ type char(32) varying; dcl (active_fnc_err_, com_err_, err variable) entry options(variable), (arg_ptr variable, cu_$af_arg_ptr, cu_$arg_ptr) entry (fixed bin, ptr, fixed bin, fixed bin(35)), cu_$af_return_arg entry (fixed bin, ptr, fixed bin(21), fixed bin(35)), get_entry_point_dcl_ entry (char(*), fixed bin, fixed bin, char(*) var, char(32) var, fixed bin(35)), get_line_length_$switch entry (ptr, fixed bin(35)) returns(fixed bin), (get_temp_segment_, release_temp_segment_) entry (char(*), ptr, fixed bin(35)), requote_string_ entry (char(*)) returns(char(*)), iox_$put_chars entry (ptr, ptr, fixed bin(21), fixed bin(35)), iox_$user_output ptr external static; dcl (addr, before, length, null, reverse, substr) builtin; dcl (FALSE init("0"b), TRUE init("1"b)) bit(1) int static options(constant), NL char(1) int static options(constant) init(" "), error_table_$wrong_no_of_args fixed bin(35) ext static, sys_info$max_seg_size fixed bin(35) ext static; call cu_$af_return_arg (Nargs, Pret, Lret, code); if code = 0 then do; ret = ""; err = active_fnc_err_; arg_ptr = cu_$af_arg_ptr; dcl_style = 0; line_length = 0; Saf = TRUE; end; else do; err = com_err_; arg_ptr = cu_$arg_ptr; Pret = null; on cleanup begin; if Pret ^= null then call release_temp_segment_ ("display_entry_point_dcl", Pret, code); end; call get_temp_segment_ ("display_entry_point_dcl", Pret, code); if code ^= 0 then go to bad_temp_seg; Lret = (sys_info$max_seg_size-1) * 4; ret = ""; Saf = FALSE; dcl_style = 1; line_length = get_line_length_$switch (iox_$user_output, code); if code ^= 0 then do; /* If no line length given in current mode string,*/ line_length = 0; /* probably file_output, so don't break dcl. */ dcl_style = 0; end; end; if Nargs ^= 1 then go to WNOA; call arg_ptr (1, Parg, Larg, code); call get_entry_point_dcl_ (arg, dcl_style, line_length, ret, type, code); if code ^= 0 then go to BAD_ARG; ent = before (reverse(arg), ">"); /* Remove any dir part of pathname from arg. */ ent = before (ent, "::"); /* and archive name... */ ent = reverse(ent); if dcl_style = 0 then ret = "dcl " || ent || " " || ret || ";"; else ret = "dcl " || ent || ret || ";"; if ^Saf then do; ret = ret || NL; call iox_$put_chars (iox_$user_output, addr(substr(ret,1)), length(ret), code); end; else ret = requote_string_ ((ret)); /* requote for active functions... */ RETURN: if ^Saf then if Pret ^= null then call release_temp_segment_ ("display_entry_point_dcl", Pret, code); return; WNOA: call err (error_table_$wrong_no_of_args, "display_entry_point_dcl", " Usage: ^[[^]display_entry_point_dcl entryname^[]^]", Saf, Saf); go to RETURN; BAD_ARG: call err (code, "display_entry_point_dcl", arg); go to RETURN; bad_temp_seg: call err (code, "display_entry_point_dcl", "^/While obtaining temp segment."); return; end display_entry_point_dcl;  dump_machine_cond_.pl1 10/03/83 1732.6rew 10/03/83 1009.5 73026 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ dump_machine_cond_: procedure (cip, fsp, stream, mode); /* DUMP_MACHINE_COND_ - Print out pretty machine conditions at time of fault. This routine can be called with the arguments given it by a condition handler or those returned by find_fault_frame_. It uses the default_error_handler_ routine reinterpret_condition_ and then attempts to print the source line, followed by the machine registers. */ dcl cip ptr, /* ptr to structure returned by find_condition_info_ */ fsp ptr, /* fault sp */ stream char (32) aligned, /* output stream name */ mode fixed bin; /* output mode: 0 = brief */ dcl shortinfo char (8) aligned, /* returned by convert_status_code_ */ (i, j, k) fixed bin, /* counters */ time char (32) aligned, NL char (1) aligned int static init (" "), strp ptr, /* ptr to interpret_ptr_struc */ longinfo char (100) aligned, /* ... explanation of error code in SCU */ prs (0:7) char (4) int static options (constant) init ("(ap)", "(ab)", "(bp)", "(bb)", "(lp)", "(lb)", "(sp)", "(sb)"), (tp, tp1) ptr, /* working pointers */ areap ptr, /* pointer to area, where message allocated */ mp ptr, /* ptr to message, explains fault */ ml fixed bin, /* length of message (see berrm) */ berrm char (ml) based (mp), /* message from reinterpret_condition_ */ barea area ((100)) based (areap), /* dummy for free */ w (8) fixed bin based, /* based words, for regs */ ec fixed bin (35), /* error code, from scu */ faultptr ptr, /* ptr to fault */ iocbp ptr, /* io control block ptr */ faultsp ptr; /* stack ptr at time of fault */ dcl 1 condinfo based (cip) aligned, /* structure returned by find_condition_info_ */ 2 mcptr ptr, 2 version fixed bin, 2 condition_name char (32) var, 2 infoptr ptr, 2 wcptr ptr, 2 loc_ptr ptr, 2 flags, 3 crawlout bit (1) unal, 3 pad1 bit (35) unal, 2 user_loc_ptr ptr, 2 pad (4) bit (36); dcl interpret_ptr_ entry (ptr, ptr, ptr), interpret_ptr_$frame_owner entry (ptr, ptr, ptr), print_source_line_ entry (ptr, char (32) aligned), reinterpret_condition_ entry (ptr, ptr, fixed bin, fixed bin, ptr, char (*) aligned, ptr, ptr, ptr), get_system_free_area_ entry (ptr), convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned), prtscu_$on_line entry (ptr, ptr, bit (1)), iox_$find_iocb entry (char (*), ptr, fixed bin (35)), date_time_ entry (fixed bin (71), char (*) aligned), ioa_$rsnnl entry options (variable), ioa_$ioa_stream entry options (variable); %include interpret_ptr_struc; %include mc; dcl (addr, fixed, index, null, rel, substr, verify) builtin; /* ------------------------------------------------------- */ strp = addr (strbuf); /* initialization. */ faultsp = fsp; /* ..copy args */ mcp = condinfo.mcptr; if condinfo.flags.crawlout then if condinfo.wcptr ^= null then mcp = condinfo.wcptr; if mode = 0 then do; /* brief mode */ call ioa_$ioa_stream (stream, "^a condition:", condinfo.condition_name); return; end; call get_system_free_area_ (areap); /* obtain area for message */ /* This section gets the standard error message which explains the error, and prints it. */ call reinterpret_condition_ (areap, mp, ml, 3, condinfo.mcptr, (condinfo.condition_name), condinfo.wcptr, condinfo.infoptr, faultsp); j = 1; /* got explanation of fault. now print it */ i = index (berrm, "Error"); /* take off "error" */ if i > 0 then if i < 4 then j = i + 6; /* .. if it's on the front */ j = j + verify (substr (berrm, j), " ") - 1; /* Trim leading blanks. */ do k = j repeat k + i while (k < ml); /* Print the error message. */ i = index (substr (berrm, k), NL); /* .. one line at a time. */ call ioa_$ioa_stream (stream, "^a", substr (berrm, k, i - 1)); end; free berrm in (barea); /* done with error msg. free it */ if mode = 0 then go to exit; /* no registers if brief mode */ if mcp = null then do; /* might be given null. */ call ioa_$ioa_stream (stream, "Machine conditions not available.^/"); return; end; scup = addr (mc.scu); /* This section attempts to print the source statement which encountered the fault. */ faultptr = condinfo.user_loc_ptr; call interpret_ptr_$frame_owner (faultptr, faultsp, strp); if struc.text_ptr ^= null then /* if can print source line, do so. */ call print_source_line_ (strp, stream); /* This section formats the machine conditions and prints them out pretty. */ call ioa_$ioa_stream (stream, "^/Machine registers at time of fault^/"); p_mc_only: /* common code for mc_only entry */ do j = 0 to 7; call printreg (j); end; call ioa_$ioa_stream (stream, ""); call ioa_$ioa_stream (stream, "x0 ^6o^3xx1 ^6o^3xx2 ^6o^3xx3 ^6o", fixed (mc.x (0), 18), fixed (mc.x (1), 18), fixed (mc.x (2), 18), fixed (mc.x (3), 18)); call ioa_$ioa_stream (stream, "x4 ^6o^3xx5 ^6o^3xx6 ^6o^3xx7 ^6o", fixed (mc.x (4), 18), fixed (mc.x (5), 18), fixed (mc.x (6), 18), fixed (mc.x (7), 18)); call ioa_$ioa_stream (stream, "a ^w q ^w e ^o", fixed (mc.a, 35), fixed (mc.q, 35), fixed (mc.e, 8)); call ioa_$ioa_stream (stream, "Timer reg - ^o, Ring alarm reg - ^1.3b", fixed (mc.regs.t, 27), mc.regs.ralr); if mc.fault_reg ^= "0"b then /* display fault reg if present */ call ioa_$ioa_stream (stream, "Fault reg - ^12.3b", mc.fault_reg); call ioa_$ioa_stream (stream, "^/SCU Data:^/"); call iox_$find_iocb ((stream), iocbp, ec); /* find iocb ptr */ call prtscu_$on_line (iocbp, scup, "1"b); call ioa_$ioa_stream (stream, " "); /* Put out new line char */ if mc.fault_time then do; /* print out time of day if available */ call date_time_ (fixed (mc.fault_time, 71), time); call ioa_$ioa_stream (stream, "Time stored: ^a (^18.3b)", time, mc.fault_time); end; call ioa_$ioa_stream (stream, "Ring:^10x^d", fixed (scu.ppr.prr, 3)); ec = mc.errcode; if ec ^= 0 then do; /* Interpret code. */ call convert_status_code_ (ec, shortinfo, longinfo); if shortinfo = (8)"x" then call ioa_$rsnnl ("^w", longinfo, i, ec); call ioa_$ioa_stream (stream, "Code:^10x^a", longinfo); end; if substr (scu.even_inst, 28, 1) then do; /* if bit 27 of instruction on display spl data */ call ioa_$ioa_stream (stream, "^/EIS Pointers and Lengths:^/"); tp1 = addr (mc.eis_info); /* set up pointer */ call ioa_$ioa_stream (stream, "^6o^-^w ^w ^w ^w^/^-^w ^w ^w ^w", fixed (rel (tp1)), tp1 -> w (1), tp1 -> w (2), tp1 -> w (3), tp1 -> w (4), tp1 -> w (5), tp1 -> w (6), tp1 -> w (7), tp1 -> w (8)); end; exit: call ioa_$ioa_stream (stream, ""); return; /* -------------------------------------------------------- */ /* mc_only - entry to display a set of machine conditions only */ mc_only: entry (a_mcp, stream); dcl a_mcp ptr; /* machine condition pointer */ mcp = a_mcp; /* copy arguments */ strp = addr (strbuf); scup = addr (mc.scu); go to p_mc_only; /* join common code */ printreg: proc (v1); dcl v1 fixed bin; dcl tpx char (20) aligned; dcl tpxi fixed bin; tp = mc.prs (v1); call ioa_$rsnnl ("^p", tpx, tpxi, tp); call interpret_ptr_ (tp, null, strp); call ioa_$ioa_stream (stream, "pr^d ^4a^2x^20a^a^a|^a ^a ^a", v1, prs (v1), tpx, struc.segment, struc.entryn, struc.offset, struc.modifier, struc.comment); end printreg; end dump_machine_cond_;  find_source_line_.pl1 10/03/83 1732.6rew 10/03/83 1009.5 19890 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ find_source_line_: procedure (strp, Line_no, Dirname, Ename, Offset, Length, Code); dcl strp ptr parameter; dcl Line_no char (*) parameter; dcl Dirname char (*) parameter; dcl Ename char (*) parameter; dcl Offset fixed bin (21) parameter; dcl Length fixed bin (21) parameter; dcl Code fixed bin (35); dcl source_name_ptr ptr; dcl source_name_len fixed bin (21); dcl source_name char (source_name_len) based (source_name_ptr); dcl code fixed bin (35); dcl (l_comp, l_num) fixed bin; dcl source_map_ptr ptr; dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl ioa_$rsnnl entry options (variable); dcl stu_$get_line entry (ptr, fixed bin, fixed bin, fixed bin, fixed bin (21), fixed bin (21), fixed bin); dcl (addrel, binary) builtin; /* * * * * * * * * * FIND_SOURCE_LINE_ * * * * * * * ** */ Code = 0; Offset, Length = 0; Line_no, Dirname, Ename = ""; if ^struc.std_flag then return; call stu_$get_line (struc.symbolp, struc.instruction_counter, 1, l_num, Offset, Length, l_comp); if l_num = -1 then return; call ioa_$rsnnl ("(line ^[^d-^;^s^]^d)", Line_no, (0), (l_comp ^= 0), l_comp, l_num); if struc.sourcemap = 0 then return; source_map_ptr = addrel (struc.symbolp, struc.sourcemap); source_name_ptr = addrel (struc.symbolp, source_map_ptr -> source_map.map (l_comp + 1).pathname.offset); source_name_len = binary (source_map_ptr -> source_map.map (l_comp + 1).pathname.size, 21); call expand_pathname_ (source_name, Dirname, Ename, code); if code ^= 0 then do; Dirname, Ename = ""; return; end; return; /* * * * * * * * * * * * * * * * * * */ %include interpret_ptr_struc; %include source_map; end find_source_line_;  get_entry_arg_descs_.pl1 11/20/86 1410.0r w 11/20/86 1145.0 87129 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(84-11-29,Ranzenbach), approve(86-03-12,MCR7144), audit(86-03-12,GWMay), install(86-05-01,MR12.0-1051): added version 2 entry_desc_info, allowing the processing of archive components. END HISTORY COMMENTS */ get_entry_arg_descs_$info: proc (entry_ptr, nargs, descps, entry_desc_info_ptr, code); ret_info = "1"b; if entry_desc_info.version ^= entry_desc_info_version_1 & entry_desc_info.version ^= entry_desc_info_version_2 then do; code = error_table_$unimplemented_version; return; end; entry_desc_info.flags = "0"b; get_entry_arg_descs_: entry (entry_ptr, nargs, descps, code); /* GET_ENTRY_ARG_DESCS_ - Extract descriptors for procedure parameters. If entry_ptr points to an entry sequence or to a segdef, this procedure will attempt to extract a list of pointers to parameter descriptors for the entrypoint. The expected number of arguments and pointers to descriptors for the arguments will be returned. This only works for standard object segments. based on "get_entry_name_" by Melanie Weaver THVV 1/74 modified 75-08-04 by M. Weaver to handle descriptor pointers in text modified 79-05-09 by J. Falksen and G. Dixon to add the two "info" entries */ dcl entry_ptr ptr; /* ptr to entry sequence (input) */ dcl nargs fixed bin; /* Number of arguments. */ dcl descps (*) ptr; /* array of ptrs to descriptors. */ dcl code fixed bin (35); /* status code (output) */ dcl (addwordno, addr, addrel, bin, min, null, ptr, rel, hbound, size) builtin; dcl (i, j) fixed bin; dcl type fixed bin (2); dcl mode fixed bin (5); dcl bitcnt fixed bin (24); dcl no_descrs bit(1); dcl ret_info bit(1) init("0"b); /* Off by default. Turned on for $info entries. */ dcl (error_table_$nodescr, error_table_$moderr, error_table_$dirseg, error_table_$unimplemented_version) fixed bin (35) ext; dcl (segptr, np, defp, def_ptr, txp, descpp) ptr; dcl hcs_$status_mins entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35)); dcl hcs_$fs_get_mode entry (ptr, fixed bin (5), fixed bin (35)); dcl object_info_$display ext entry (ptr, fixed bin (24), ptr, fixed bin (35)); dcl component_info_$offset ext entry (ptr, fixed bin (18), ptr, fixed bin (35)); dcl condition_ entry (char (*), entry); dcl entry_desc_info_version_1 fixed bin int static options(constant) init(1); %include entry_sequence_info; dcl 1 entry_sequence_w2 aligned like entry_sequence.word2 based (entry_sequence_w2p); dcl entry_sequence_w2p ptr; /* declaration of non class 3 definition (new format) in definition.incl.pl1 */ %include definition; dcl 1 oi aligned like object_info; %include object_info; %include component_info; /* ====================================================== */ /* initialize some stuff */ nargs = -1; OLD_ENTRY_SEQUENCE: if bin (rel (entry_ptr), 18) = 0 then go to no_defs; /* Entry point at seg|0 is not preceded */ /* by a standard entry sequence. */ /* Entry point at seg|1 is preceded by entry flags*/ /* but has no descriptors. */ segptr = ptr (entry_ptr, 0); /* get ptr to base of seg */ def_ptr = segptr; /* till we get something better */ call hcs_$status_mins (segptr, type, bitcnt, code); /* get type and bitcnt */ if code ^= 0 then return; if type = 2 then do; code = error_table_$dirseg; /* dirs don't have entry points */ return; end; call condition_ ("any_other", catch); /* Guard against access faults. */ call hcs_$fs_get_mode (segptr, mode, code); /* get mode wrt validation level */ if code ^= 0 then return; /* don't see how this could happen */ if mode < 4 /* no read or execute access */ then do; /* can't see defs (probably none anyway) */ code = error_table_$moderr; return; end; if entry_desc_info.version = entry_desc_info_version_2 then do; if entry_desc_info.object_ptr ^= null then do;/* previously assumed offset 0... */ segptr = entry_desc_info.object_ptr; /* user knows better... */ def_ptr = segptr; end; if entry_desc_info.bit_count > 0 then bitcnt = entry_desc_info.bit_count; end; oi.version_number = object_info_version_2; call object_info_$display (segptr, bitcnt, addr (oi), code); /* may need def ptr */ if code ^= 0 then return; def_ptr = oi.defp; /* now we have ptr to actual defs */ txp = oi.textp; i = bin (rel (entry_ptr), 18); /* get offset of input ptr */ j = bin (rel (oi.textp), 18); /* get offset of beginning of text */ if i < j then go to no_defs; /* If entry above text begin, or */ if i > j+oi.tlng then go to no_defs; /* .. if entry below end of text, fail. */ if oi.compiler ^= "binder" then /* this compiler generated all entries */ if ^oi.format.standard then go to no_defs; /* This entry must be in std object. */ else; else do; /* consult the bind map for this component */ call component_info_$offset (segptr, bin (rel (entry_ptr), 18), addr (ci), code); if code ^= 0 then go to no_defs; /* offset is illegal. fail. */ if ^ci.standard then go to no_defs; /* Must be a standard object. */ end; entry_sequence_w2p = addrel (entry_ptr, -1); /* get ptr to entry sequence info */ if ret_info then entry_desc_info.flags = entry_sequence_w2.flags; if bin (entry_sequence_w2.def_relp, 18) > oi.dlng then do; no_defs: code = error_table_$nodescr; /* not in def section */ return; end; defp = addrel (oi.defp, entry_sequence_w2.def_relp); /* get ptr to entry's def */ if ^defp -> definition.new then go to no_defs; /* Must be new format. */ if ^defp -> definition.entry then go to no_defs; /* Must have entrypoint flag on. */ nargs = 0; /* Assume proc has no args. */ common: if entry_sequence_w2.flags.revision_1 /* descr ptrs are in text if at all. */ then do; if ^entry_sequence_w2.flags.has_descriptors then goto no_defs; np = addrel (entry_ptr, -2); /* It has descriptors, so safe to reference */ /* the descriptor offset now. */ descpp = addwordno (segptr, bin (np -> entry_sequence.descr_relp_offset)); no_descrs = "0"b; end; else if defp ^= null then do; /* see if there are descr ptrs in def. section */ if ^defp -> definition.argcount then go to no_defs; /* no parameter info */ if ^defp -> definition.descriptors then no_descrs = "1"b; else no_descrs = "0"b; descpp = addrel(defp, size(definition)); /* descr array appended to def */ end; else go to OLD_ENTRY_SEQUENCE; /* defp = null implies that we were entered */ /* via $text_only or $text_only_info entry point */ /* with version 0 entry sequence in which arg */ /* descriptors are located in definition section. */ /* Must go through rigor of calling object_info_ */ /* in this case, even if given a text entry point.*/ nargs = bin (descpp -> parm_desc_ptrs.n_args); /* Return number of arguments expected */ num_descs = nargs; if no_descrs then /* No descriptors, but argcount was available. */ descps (*) = null; else do i = 1 to min (nargs, hbound (descps, 1)); /* Return pointers to descriptors. */ /* .. which are in the text section */ descps (i) = addwordno (txp, bin (descpp -> parm_desc_ptrs.descriptor_relp (i))); end; return; /* Success. */ text_only_info: entry (entry_ptr, nargs, descps, entry_desc_info_ptr, code); ret_info = "1"b; if entry_desc_info.version ^= entry_desc_info_version_1 & entry_desc_info.version ^= entry_desc_info_version_2 then do; code = error_table_$unimplemented_version; return; end; entry_desc_info.flags = "0"b; text_only: entry (entry_ptr, nargs, descps, code); /* assume entry ptr points to a text entry sequence; do no validation */ code = 0; nargs = -1; defp = null; /* don't want ptr to definition */ txp = ptr (entry_ptr, 0); if bin (rel (entry_ptr), 18) = 0 then go to no_defs; /* Entry point at seg|0 is not preceded */ /* by a standard entry sequence. */ /* Entry point at seg|1 is preceded by entry flags*/ /* but has no descriptors. */ entry_sequence_w2p = addrel (entry_ptr, -1); /* get ptr to entry sequence word 2. */ if ret_info then entry_desc_info.flags = entry_sequence_w2.flags; go to common; catch: proc (mcptr, condname, wcptr, infoptr, continue); dcl (mcptr, wcptr, infoptr) ptr; dcl condname char (*); dcl continue bit (1) aligned; if condname = "quit" then go to pass; if condname = "alrm" then go to pass; if condname = "cput" then go to pass; if condname = "program_interrupt" then go to pass; if condname = "finish" then go to pass; if condname = "storage" then go to pass; if condname = "mme2" then do; pass: continue = "1"b; return; end; if condname ^= "cleanup" then go to no_defs; /* probably access fault; in any case, forget it */ return; end catch; end get_entry_arg_descs_$info;  get_entry_point_dcl_.pl1 04/19/88 0934.0rew 04/19/88 0838.0 240561 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(84-12-30,Ranzenbach), approve(86-03-12,MCR7144), audit(86-03-12,GWMay), install(86-05-01,MR12.0-1051): added support for archive component pathnames and repairs for: phx09270 - handle trailing blanks in arg. phx09340 - "" phx09592 - Illegal PL/I coding. 2) change(88-01-01,Gilcrease), approve(88-02-01,MCR7836), audit(88-03-17,RBarstad), install(88-04-19,MR12.2-1040): Make error_table_ produce same out as >sl1>error_table_. Allow argument as ask_$ask_ = ask_ and in .dcl file. END HISTORY COMMENTS */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Name: get_entry_point_dcl_ */ /* */ /* This program obtains PL/I declare attributes for external procedure entry points, */ /* and for error_table_ codes and other, system-wide external data. The program obtains */ /* the entry point dcl attributes from two sources: data files declaring all unusual */ /* procedure entry points (ALM segments, procedures written as subroutines but used as */ /* functions, etc) and system-wide data values (eg, sys_info$max_seg_size); the */ /* argument descriptors included in the procedure entry point itself which describe the */ /* entry point parameters. */ /* */ /* The data files declaring unusual entries are found via the "declare" search list. */ /* The user may set this search list (via add_search_paths, etc) to use his own data */ /* segments, or may use the default data file which get_entry_point_dcl_ sets to pl1.dcl */ /* in its referencing dir if no declare search list has been set. */ /* */ /* The data files contain two kinds of entries, procedure entry point declarations */ /* and user-defined abbreviations used by EMACS in PL/I mode. Each entry appears on a */ /* separate line. Procedure entries have the form: */ /* */ /* proc_name declaration */ /* */ /* For example: */ /* */ /* ioa_ entry options (variable) */ /* */ /* Note that the declaration does NOT end with a ; character. System data entries are */ /* declared in a similar manner. For example */ /* */ /* iox_$user_output ptr external static */ /* */ /* EMACS PL/I mode abbreviation entries have the form */ /* */ /* abbrev_name ==> abbrev_value */ /* */ /* For example: */ /* */ /* fb ==> fixed bin */ /* cond ==> condition */ /* */ /* Abbreviation entries are processed only by the $emacs entry, not */ /* by get_entry_point_dcl_. */ /* */ /* Entry: get_entry_point_dcl_ */ /* */ /* This entry point returns the declaration for an external value, either from one */ /* of the data files, or by using the parameter argument descriptors associated with the */ /* procedure entry point. It special cases error_table_ values by always returning */ /* 'fixed bin(35) ext static' for them. For example, given the name iox_$put_chars, it */ /* might return */ /* */ /* entry (ptr, ptr, fixed bin(21), fixed bin(35)) */ /* */ /* Usage */ /* */ /* dcl get_entry_point_dcl_ entry (char(*), fixed bin, fixed bin, */ /* char(*) varying, char(32) varying, fixed bin(35)); */ /* */ /* call get_entry_point_dcl_ (name, dcl_style, line_length, dcl, type, code); */ /* */ /* where */ /* 1. name */ /* is the name of the external entry point or data item whose declaration must be */ /* obtained. (Input) */ /* */ /* 2. dcl_style */ /* is the style of indentation to be performed for the name. */ /* (Input) */ /* 0 = no indentation, entire dcl on a single line */ /* 1 = indentation as for the indent command */ /* 2 = indentation as preferred by Gary Dixon */ /* */ /* 3. line_length */ /* is maximum length lines in return value are allowed to grow when indentation is */ /* performed. (Input) */ /* */ /* 4. dcl is the declaration which was obtained. (Output) */ /* */ /* 5. type */ /* is the type of declaration. In the current implementation, this is always a */ /* null string. */ /* */ /* 6. code */ /* is a standard status code describing any failure to obtain the declaration. */ /* */ /* Entry: get_entry_point_dcl_$emacs */ /* */ /* dcl get_entry_point_dcl_$emacs entry (char(*), fixed bin, fixed bin, */ /* char(*) var, char(32) var, char(100) var); */ /* */ /* call get_entry_point_dcl_$emacs (name, dcl_type, line_length, dcl, type, error); */ /* */ /* where: */ /* */ /* 1. - 4. */ /* are as above. */ /* */ /* 5. type */ /* is "abbrev" if an abbreviation was found, and "" otherwise. (Output) */ /* */ /* 6. error */ /* is a converted error code (if an error occurred), or a description of how the */ /* declaration was obtained, if not found in one of the data files. (Output) */ /* */ /* Status */ /* */ /* 0) Created May, 1979 by Gary C. Dixon */ /* 1) Modified Jan, 1981 by G. C. Dixon - handle non-system error table codes. */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * **/ get_entry_point_dcl_: procedure (arg, dcl_style, line_length, ret, type, Acode); Semacs = FALSE; Acode = 0; go to COMMON; emacs: entry (arg, dcl_style, line_length, ret, type, error); Semacs = TRUE; error = ""; go to COMMON; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * **/ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * **/ dcl arg char(*), dcl_style fixed bin, line_length fixed bin, ret char(*) varying, type char(32) varying, error char(100) varying, Acode fixed bin(35); dcl (Idir, Ihunt, Istart_of_line) fixed bin, Iparen_depth fixed bin, Lfile fixed bin(21), (Lparm, Lword) fixed bin, (Ldcl_begin, Lindent, Ipos) fixed bin, Nsearch_paths fixed bin, (Pfile, Pparm, Pseg, Pword) ptr, Semacs bit(1), Serror_table bit(1), bc fixed bin(24), cleanup condition, code fixed bin(35), component char(32), dir char(168), ent char(32), long char(100), result char(2000) varying, short char(8); dcl area area based(Parea), file char(Lfile) based(Pfile), file_ch (Lfile) char(1) based(Pfile), parm char(Lparm) based(Pparm), word char(Lword) based(Pword); dcl (addr, addrel, before, codeptr, copy, divide, index, length, ltrim, mod, null, ptr, rel, reverse, rtrim, search, substr, verify) builtin; dcl convert_status_code_ entry (fixed bin(35), char(8), char(100)), expand_pathname_$component entry (char(*), char(*), char(*), char(*), fixed bin(35)), get_system_free_area_ entry returns (ptr), initiate_file_$component entry (char(*), char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35)), search_paths_$get entry (char(*), bit(36), char(*), ptr, ptr, fixed bin, ptr, fixed bin(35)), terminate_file_ entry (ptr, fixed bin(24), bit(*), fixed bin(35)); dcl (error_table_$new_search_list, error_table_$nodescr, error_table_$no_search_list, error_table_$zero_length_seg) fixed bin(35) ext static; dcl (FALSE init("0"b), TRUE init("1"b)) bit(1) int static options(constant), HT char(1) int static options(constant) init(" "), HT_SP char(2) int static options(constant) init(" "), HT_SP_NL char(3) int static options(constant) init(" "), NL char(1) int static options(constant) init(" "), Parea ptr int static init(null), SP char(1) int static options(constant) init(" "); COMMON: ret = ""; /* Initialize return values. */ type = ""; Pseg = null; /* Prepare for cleanup on unit. */ sl_info_p = null; on cleanup call janitor(); result = ""; /* No result found so far. */ if Parea = null then Parea = get_system_free_area_(); call search_paths_$get ("declare", sl_control_default, "", null(), Parea, sl_info_version_1, sl_info_p, code); if code = error_table_$no_search_list then Nsearch_paths = 0; else if code = error_table_$new_search_list | code = 0 then Nsearch_paths = sl_info.num_paths; else if code ^= 0 then go to ERROR; if index (arg, "$") ^= 0 then do; /* is arg in form "frog_$frog_"? */ if substr (arg, 1, index (arg, "$") - 1) = substr (arg, index (arg, "$") + 1, length (rtrim (arg)) - index (arg, "$")) then do Ihunt = index (arg, "$") to length (rtrim (arg)); substr (arg, Ihunt, 1) = " "; /* clear "$frog_" */ end; end; do Idir = 1 to Nsearch_paths while(result = ""); /* In each segment identified in the search */ dir, ent, component = ""; call expand_pathname_$component (sl_info.paths(Idir).pathname, dir, ent, component, code); call initiate_file_$component (dir, ent, component, R_ACCESS, Pseg, bc, code); if Pseg ^= null then do; Pfile = Pseg; /* Address the segment. */ Lfile = divide(bc, 9, 24, 0); do while(Lfile > 0 & result = ""); Ihunt = index(file, rtrim(arg)); /* Make quick check to see if any hope at all */ if Ihunt = 0 then /* of finding entry point dcl, or abbrev. */ Lfile = 0; else do; Istart_of_line = index(reverse(substr(file,1,Ihunt-1)),NL); if Istart_of_line > 0 then do;/* Address potential matching line. */ Pfile = addr(file_ch(Ihunt-Istart_of_line+1)); Lfile = Lfile - (Ihunt-Istart_of_line); end; /* Toss away stuff preceding matching line. */ call find_word_and_skip(); /* If first word on line names entry point or */ if word_equal_arg () then do; /* abbrev we want, then EUREKA! */ call skip_whitespace(); /* Skip whitespace following name. */ result = rest_of_line(); /* Assume entry point dcl, make dcl the result. */ call find_word_and_skip(); if word = "==>" then /* But check for an EMACS abbrev. */ if Semacs then do; /* If looking for EMACS abbrev's, we've found it. */ type = "abbrev"; error = "abbrev"; call skip_whitespace(); result = rest_of_line(); end; else result = ""; /* Other, continue looking since matching EMACS */ end; /* abbrev does not signify end of search for */ /* an entry point dcl. */ call skip_line(); end; end; call terminate_file_ (Pseg, 0, TERM_FILE_TERM, code); Pseg = null; /* Done looking at this seg. */ end; end; if result = "" then do; /* dcl or abbrev not found in dcl segs. */ call get_entry_point_dcl_from_desc (rtrim(arg), result, Serror_table, code); if code ^= 0 then do; /* Check the entry point descriptors. */ ERROR: if Semacs then do; /* Be kind to emacs, do error code conversion. */ call convert_status_code_ (code, short, long); error = rtrim(long); end; else Acode = code; end; else if Semacs then do; /* Tell EMACS user how declaration was found. */ if Serror_table then error = "dcl error_table_ code"; else do; Pfile = addrel(addr(result),1); /* To do this, overlay result so we can use the */ Lfile = length(result); /* find_word_and_skip primitive. */ call find_word_and_skip(); if word = "entry()" then /* entry() ==> all parm descriptors valid. */ error = "dcl via parm descriptors"; else if word = "entry" then do; call find_word_and_skip(); if word = "options(variable)" then error = "no parm descriptors available"; else error = "dcl via parm descriptors"; end; else error = "dcl via parm descriptors"; end; end; end; if result = "" then; else if type = "abbrev" then /* Output abbrev's as they stand. */ ret = result; else if dcl_style = 0 then /* No formatting dcl style. */ ret = result; else do; /* Split non-abbrev's across lines, etc. */ if dcl_style = 1 then do; /* dcl style used by indent. */ Ipos = 6; Ldcl_begin = Ipos + length(arg) + 1; Lindent = 11; end; else do; /* dcl style used by Gary Dixon. */ Ipos = 11; Ldcl_begin = 41; Lindent = 46; end; Ipos = Ipos + length(arg); /* Record current line position. */ if Ipos >= Ldcl_begin then do; /* Entry point name already beyond the dcl */ ret = ret || NL; /* indent column. Skip to next line. */ Ipos = 1; end; if Ipos < Ldcl_begin then do; /* Skip out to dcl column. */ ret = ret || whitespace_to_pos (Ldcl_begin); Ipos = Ldcl_begin; end; if length(result) + Ipos <= line_length then ret = ret || result; /* Handle simple case first. */ else do; /* The dcl is too long to fit on one line. */ Pfile = addrel(addr(result),1); /* Address the dcl. */ Lfile = length(result); Iparen_depth = 0; /* Prepare find_parm_and_skip for use. */ do while (Lfile > 0); /* Add successive parameter descriptors to line */ call find_parm_and_skip(); /* until they no longer fit. Then, skip */ /* to next line. Continue until all of dcl */ /* processed. */ if Ipos + length(parm) <= line_length then do; ret = ret || parm; Ipos = Ipos + length(parm); end; else do; ret = ret || NL; Ipos = 1; ret = ret || whitespace_to_pos(Lindent); Ipos = Lindent; ret = ret || ltrim(parm); Ipos = Ipos + length(ltrim(parm)); end; end; end; end; call janitor(); return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * **/ word_equal_arg: proc returns (bit (1)); /* special-case "frog_$frog_" */ if index (word, "$") ^= 0 then if substr (word, 1, index (word, "$") - 1) = substr (word, index (word, "$") + 1, Lword - index (word, "$")) then return (rtrim (arg) = substr (word, 1, index (word, "$") - 1 )); return (rtrim (arg) = word); end word_equal_arg; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * **/ find_parm_and_skip: /* Simple heuristic to find next parm desc. */ proc; /* Parm ends with first , or ) not inside of (). */ dcl (Idelim) fixed bin, Sparm_not_found bit(1), ch char(1); Pparm = Pfile; Lparm = 0; Sparm_not_found = TRUE; do while(Sparm_not_found); Idelim = search(file,"(),"); if Idelim = 0 then do; Lparm = Lfile; Lfile = 0; Sparm_not_found = FALSE; end; else do; ch = substr(file,Idelim); if ch = "(" then Iparen_depth = Iparen_depth + 1; else if ch = ")" & Iparen_depth = 1 then do; Iparen_depth = 0; Sparm_not_found = FALSE; end; else if ch = ")" then Iparen_depth = Iparen_depth - 1; else if Iparen_depth = 1 then Sparm_not_found = FALSE; Lparm = Lparm + Idelim; if Idelim = Lfile then Lfile = 0; else do; Pfile = addr(file_ch(Idelim+1)); Lfile = Lfile - Idelim; end; end; end; end find_parm_and_skip; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * **/ find_word_and_skip: proc; dcl Iwhite fixed bin; Iwhite = verify (file, HT_SP); if Iwhite = 0 then do; /* Remainder of file is whitespace. */ Lfile = 0; Pword = Pfile; Lword = 0; end; else do; if Iwhite > 1 then do; Pfile = addr(file_ch(Iwhite)); Lfile = Lfile - (Iwhite-1); end; Pword = Pfile; Lword = search (file, HT_SP_NL); if Lword = 0 then do; Lword = Lfile; Lfile = 0; end; else do; Lword = Lword - 1; Pfile = addr(file_ch(Lword+1)); Lfile = Lfile - Lword; end; end; end find_word_and_skip; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * **/ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * **/ get_entry_point_dcl_from_desc: proc (Aep_name, Aret, Serror_table, Acode); dcl Aep_name char(*), /* Name of entry point to be declared. */ Aret char(*) varying, /* Declaration of entry point. (Out) */ Serror_table bit(1), /* On if entry point is an error table code. (Out)*/ Acode fixed bin(35); /* Status code. */ dcl Eproc entry variable options(variable), Nproc_args fixed bin, Pproc ptr, Pproc_desc (100) ptr, ec_Pproc ptr, code fixed bin(35), i fixed bin; dcl Ppacked ptr unal based; dcl cv_entry_ entry (char(*), ptr, fixed bin(35)) returns(entry), cv_ptr_ entry (char(*), fixed bin(35)) returns(ptr), cv_ptr_$terminate entry (ptr), get_pl1_parm_desc_string_ entry (ptr, char(*) var, fixed bin(35)), get_entry_arg_descs_$info entry (ptr, fixed bin, (*) ptr, ptr, fixed bin(35)); edi.version = entry_desc_info_version_2; /* Get entry point parameter descriptors. */ edi.object_ptr = null; edi.bit_count = 0; if index (Aep_name, "::") = 0 then do; /* non-archive component path... */ Eproc = cv_entry_ (Aep_name, null(), Acode); /* Convert entry point name to entry constant. */ if Acode ^= 0 then return; Pproc = codeptr(Eproc); /* Turn entry constant into a ptr. */ end; else do; /* the archive component case... */ Pproc = cv_ptr_ (Aep_name, Acode); /* no sense snapping links... */ if Acode ^= 0 then return; dir, ent, component = ""; call expand_pathname_$component (before (Aep_name, "$"), dir, ent, component, Acode); if Acode ^= 0 then return; call initiate_file_$component (dir, ent, component, R_ACCESS, edi.object_ptr, edi.bit_count, Acode); if edi.object_ptr = null then return; end; Aret = ""; call get_entry_arg_descs_$info (Pproc, Nproc_args, Pproc_desc, addr(edi), Acode); if Acode = error_table_$nodescr then do; if index (Aep_name, "error_table_$") ^= 0 then do; Aret = Aret || "fixed bin(35) ext static"; Acode = 0; /* Check for error_table_ Acodes. */ Serror_table = TRUE; end; else do; /* Handle no args case. */ Acode = 0; go to NO_ARGS; end; end; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Hueristic for determining if entry point is in a non-system error table: */ /* */ /* Non-system error tables have messages in the text pointed to by error table codes */ /* really packed pointers) which are stored in the linkage section for the error */ /* table. At first reference to the table, the linker copies the linkage template for */ /* the table into the combined_linkage area, and a first_ref trap proc gets invoked to */ /* set the segment numbers in all of the packed pointers to the segno of the text */ /* section. */ /* */ /* (1) get_entry_parm_descs_ returns error_table_$zero_length_seg for such beasties, */ /* perhaps because they do not contain any entry points into their text section (ie, */ /* all entry points are into the linkage section. */ /* (2) For this return code, the call to cv_entry_ above will have returned a pointer to */ /* the error code (packed ptr in the linkage section) corresponding to the error */ /* table entry. This code points to the text of the error message. */ /* (3) cv_ptr_ on the other hand, returns a pointer to the error code which appears in */ /* the linkage section template (contained in the error table segment itself). */ /* (4) Thus, it is reasonably safe to assume entry to be a non-system error table if: */ /* baseno(cv_entry_(ep) -> packed_ptr) = baseno(cv_ptr_(ep)); */ /* rel(cv_entry_(ep) -> packed_ptr) = rel(cv_ptr_(ep)); */ /* The above conditions are prima facia evidence that a trap proc was invoked to */ /* change the left half-word of the linkage template for the entry point to the */ /* segment number. Only non-system error tables do this, to best of my knowledge. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ else if Acode = error_table_$zero_length_seg then do; ec_Pproc = cv_ptr_ (Aep_name, code); if ec_Pproc ^= null then do; if Pproc -> Ppacked = ptr(ec_Pproc, rel(ec_Pproc -> Ppacked)) then do; Aret = Aret || "fixed bin(35) ext static"; Acode = 0; Serror_table = TRUE; end; call cv_ptr_$terminate (ec_Pproc); end; else return; end; else if Acode ^= 0 then return; /* Diagnose unknown error. */ else if Nproc_args = 0 then do; /* Check for no args. */ NO_ARGS: if edi.flags.variable then /* Proc says it is options(variable), so */ /* include entry() indicating we are sure. */ Aret = Aret || "entry() options(variable)"; else Aret = Aret || "entry options(variable)";/* Proc does not say options(variable), but */ /* many commands/af do not have */ /* options(variable) in their proc/entry stmt.*/ end; /* So, use entry w/o () to indicate we're not */ /* sure. */ else do; /* Proc has declared args. */ do i = 1 to Nproc_args while (Pproc_desc(i) = null); end; /* Check for old procedure with declared arg */ if i > Nproc_args then go to NO_ARGS; /* count, but no arg descriptors. */ if Nproc_args = 1 & edi.flags.function then Aret = Aret || "entry("; else Aret = Aret || "entry ("; if edi.flags.function then /* Check for functions. */ Nproc_args = Nproc_args - 1; /* Exclude return arg from parm list. */ do i = 1 to Nproc_args; /* Put parms in the parm list. */ call get_pl1_parm_desc_string_ (Pproc_desc(i), Aret, Acode); if Acode ^= 0 then return; Aret = Aret || ", "; end; if Nproc_args > 0 then Aret = substr(Aret, 1, length(Aret)-2); /* Remove trailing ", " after last arg. */ if edi.flags.function then do; /* Handle function subcase. */ Aret = Aret || ") returns("; call get_pl1_parm_desc_string_ (Pproc_desc(i), Aret, Acode); if Acode ^= 0 then return; Aret = Aret || ")"; end; else do; /* Handle subroutine subcase. */ if edi.flags.variable then do; /* Handle options(variable) subroutine. */ Aret = Aret || ") options(variable)"; end; else Aret = Aret || ")"; end; end; end get_entry_point_dcl_from_desc; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * **/ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * **/ janitor: proc(); if Pseg ^= null then do; call terminate_file_ (Pseg, 0, TERM_FILE_TERM, code); Pseg = null; end; if sl_info_p ^= null then free sl_info in (area); end; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * **/ rest_of_line: proc() returns (char(*)); dcl Inl fixed bin, Lrest fixed bin, Prest ptr, rest char(Lrest) based(Prest); Inl = index(file, NL); if Inl = 0 then Inl = Lfile + 1; Prest = Pfile; Lrest = Inl - 1; return (rest); end rest_of_line; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ skip_line: proc(); dcl Inl fixed bin; Inl = index(file, NL); if Inl = 0 | Inl = Lfile then Lfile = 0; else do; Pfile = addr(file_ch(Inl+1)); Lfile = Lfile - Inl; end; end skip_line; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * **/ skip_whitespace: proc; dcl Iwhite fixed bin; Iwhite = verify (file, HT_SP); if Iwhite = 0 then Lfile = 0; else if Iwhite > 1 then do; Pfile = addr(file_ch(Iwhite)); Lfile = Lfile - (Iwhite-1); end; end skip_whitespace; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * **/ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * **/ whitespace_to_pos: proc (Inew_pos) returns(char(*)); dcl Inew_pos fixed bin; dcl (Ispace, Itab) fixed bin; if Inew_pos <= Ipos then /* Already at or beyond desired position. */ return (""); /* Do nothing. */ else do; Ispace = mod(Inew_pos-1, 10); Itab = divide (Inew_pos - Ispace - Ipos + 9, 10, 17, 0); if Itab = 0 then Ispace = Inew_pos - Ipos; return (copy(HT, Itab) || copy(SP, Ispace)); end; end whitespace_to_pos; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * **/ %include access_mode_values; %page; %include entry_desc_info; dcl 1 edi aligned like entry_desc_info; %page; %include sl_info; %include sl_control_s; %page; %include terminate_file; end get_entry_point_dcl_;  get_pl1_parm_desc_string_.pl1 10/03/83 1732.6rew 10/03/83 1009.5 109134 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Name: get_pl1_parm_desc_string_ */ /* */ /* Given a pointer to the argument descriptor for an entry point parameter, and a */ /* string in which the PL/I declaration of the entry point is being constructed, this */ /* subroutine appends a description of the parameter to the string. */ /* */ /* Status */ /* */ /* 0) Created in May, 1979 by G. C. Dixon */ /* 1) Modified in Jan, 1981 by G. C. Dixon - handle decimal unaligned values; */ /* reimplement handling of structure alignment */ /* 2) Modified in Jan, 1983 by T. G. Oke - handle star extents for pl1 and fortran */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * **/ get_pl1_parm_desc_string_: procedure (Pdesc, string, Acode); dcl Pdesc ptr, /* ptr to descriptor to be printed. */ string char(*) varying, /* return string, as supplied by caller. */ Acode fixed bin(35); offset = 0; call recurse (Pdesc, 1, 0, "1"b, "0"b, offset, string, Acode); return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * **/ recurse: entry (Pdesc, level, Nignored_dim, Slast, ASpacked, Aoffset, string, Acode); dcl level fixed bin, /* structure level of this descriptor. */ Nignored_dim fixed bin, /* number of dimension inherited from containing */ /* structure, to be ignored on output. */ Slast bit(1) aligned, /* on if last structure element at this structure */ /* is being output, or on for scalars. */ ASpacked bit(1) aligned, /* on if prev structure level was packed. */ Aoffset fixed bin; /* offset in words of next structure element */ /* descriptor from one being processed. */ dcl j fixed bin; dcl offset fixed bin; dcl (type, Ndim, size, scale) fixed bin, Spacked bit(1) aligned; dcl Pelement_desc ptr; dcl desc (0:Aoffset-1) fixed bin(35) based(Pdesc); dcl decode_descriptor_ entry (ptr, fixed bin, fixed bin, bit(1) aligned, fixed bin, fixed bin, fixed bin); dcl pl1_type (1:46) char(24) varying int static init ( "fixed bin", "fixed bin", "float bin", "float bin", "complex fixed bin", "complex fixed bin", "complex float bin", "complex float bin", "fixed dec", "float dec", "complex fixed dec", "complex float dec", "ptr", "offset", "label", "entry", "", /* structure */ "area", "bit", "bit", "char", "char", "file", (9)*, "uns fixed bin", "uns fixed bin", (8)*, "fixed dec", "float dec", "complex fixed dec", "complex float dec"); dcl star_pl1_bits bit (36) static initial ("400000000000"b3); dcl star_fort_bits bit (36) static initial ("377777777777"b3); dcl star_pl1_size fixed bin(35) based (addr (star_pl1_bits)); dcl star_fort_size fixed bin(35) based (addr (star_fort_bits)); dcl error_table_$bad_segment fixed bin(35) ext static; dcl (addr, addrel, length, ltrim, mod, substr) builtin; Acode = 0; Aoffset = 1; call decode_descriptor_ (Pdesc, 0, type, Spacked, Ndim, size, scale); if (1 <= type & type <= 23) | /* Support only PL/I data types. */ (33 <= type & type <= 34) | (43 <= type & type <= 46) then; else do; /* unimplemented or invalid descriptor. */ Acode = error_table_$bad_segment; return; end; if type = 17 then do; /* Handle structure level. */ string = string || cv_num(level); end; else if level > 1 then do; /* Handle structure element level. */ string = string || cv_num(level); string = string || " "; end; else; /* Do nothing for scalars. */ Aoffset = Aoffset + 3*Ndim; /* Handle arrays. */ if Ndim - Nignored_dim > 0 then do; /* Dimensions reported in prev. recursions are */ string = string || "("; /* ignored. */ do j = 3 * (Ndim-Nignored_dim-1) to 0 by -3; if desc(j+1) = 1 then string = string || cv_desc_num_(desc(j+2)); /* Omit lbound of 1. */ else do; if desc (j+1) = star_pl1_size | desc (j+1) = star_fort_size /* star extent */ then string = string || cv_desc_num_(desc (j+1)); else do; string = string || cv_desc_num_(desc(j+1)); string = string || ":"; string = string || cv_desc_num_(desc(j+2)); end; end; string = string || ","; end; substr(string,length(string),1) = ")"; /* Change final , to ) after last dimension. */ string = string || " "; end; string = string || pl1_type(type); /* Output PL/I data type. */ /* Output precision and scale. */ if (type <= 8) | (33 <= type & type <= 34) then do; /* binary numeric. */ if size = 17 & scale = 0 then; /* omit default size/scale. */ else do; string = string || "("; string = string || cv_num (size); if mod(type-1,4) < 2 then /* signed fixed binary. */ if scale ^= 0 then do; /* include scale when nonzero. */ string = string || ","; string = string || cv_num (scale); end; else; else if (33 <= type & type <= 34) then/* unsigned fixed binary. */ if scale ^= 0 then do; /* include scale when nonzero. */ string = string || ","; string = string || cv_num (scale); end; string = string || ")"; end; end; else if (9 <= type & type <= 12) | /* decimal numeric */ (43 <= type & type <= 46) then do; string = string || "("; string = string || cv_num(size); /* Always include size. Most people don't know */ /* what the default is for decimal data. */ if mod(type,2) = 1 then /* fixed decimal */ if scale ^= 0 then do; /* include scale when nonzero. */ string = string || ","; string = string || cv_num (scale); end; string = string || ")"; end; else if 19 <= type & type <= 22 then do; string = string || "("; /* bit or character string. */ if size = 16777215 then /* star extent. */ string = string || "*"; else string = string || cv_num(size); string = string || ")"; if mod(type,2) = 0 then /* varying bit or char string. */ string = string || " var"; end; else if type = 18 then do; /* area */ string = string || "("; if size = 16777215 then /* star extent. */ string = string || "*"; else string = string || cv_num(size); string = string || ")"; end; /* Handle storage alignment. */ if type = 17 then do; /* structures or substructures. */ if Spacked then; /* If structure packed, all its elements will */ /* be marked unaligned. */ else if all_structure_elements_packed() then /* If structure unpacked, only mark it aligned*/ string = string || " aligned"; /* if all its elements are packed. */ end; else do; /* scalars, array or structure elements. */ if level = 1 then do; /* scalars: assume user know default alignment.*/ if type = 19 | type = 21 then /* Only give alignment if it differs from the */ if Spacked then; /* default. */ else string = string || " aligned"; else if Spacked then string = string || " unal"; end; else do; /* structure elements. */ if ASpacked then /* containing structure is packed. */ string = string || " unal"; /* its elements are packed by definition. */ else /* containing structure not packed. */ if Spacked then /* Explicitly state alignment of structure els. */ string = string || " unal"; else string = string || " aligned"; end; end; if type = 17 then do; /* process the structure elements. */ do j = 1 to size; /* structure contains size elements. */ string = string || ", "; Pelement_desc = addrel(addr(desc(Aoffset-1)), 1); /* Aoffset is offset of next structure element */ /* descriptor from structure descriptor. */ offset = 0; /* Number of descriptors used up by structure */ /* element will be stored in offset by the call.*/ call recurse (Pelement_desc, level+1, Ndim, (j=size&Slast), Spacked, offset, string, Acode); if Acode ^= 0 then return; Aoffset = Aoffset + offset; /* Skip over descriptors for this structure el. */ end; end; RETURN: return; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ cv_num: proc (n) returns (char(16) varying); dcl n fixed bin(17), n_ fixed bin(35), p pic "---------------9"; p = n; go to COMMON; cv_desc_num_: entry (n_) returns (char (16) varying); if n_ = star_pl1_size | n_ = star_fort_size /* star extent */ then return ("*"); else p = n_; go to COMMON; cv_num_: entry (n_) returns (char(16) varying); p = n_; COMMON: return (ltrim(p)); end cv_num; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ all_structure_elements_packed: /* Internal procedure finds out if all elements of*/ proc returns(bit(1)); /* a structure are packed. */ dcl Spacked bit(1) aligned, elem_offset fixed bin, temp_offset fixed bin; elem_offset = Aoffset; /* Save current offset. */ Spacked = "1"b; /* Start by assuming all are packed. Search ends */ do j = 1 to size while (Spacked); /* when first unpacked element is found. */ /* Algorithm in this do loop same as that used */ /* above for actually emitting elem. dcls. */ Pelement_desc = addrel(addr(desc(elem_offset-1)),1); temp_offset = 0; call recurse_structure_elements_packed (Pelement_desc, level+1, Ndim, (j=size&Slast), Spacked, temp_offset, Acode); if Acode ^= 0 then go to RETURN; elem_offset = elem_offset + temp_offset; end; return (Spacked); end all_structure_elements_packed; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ recurse_structure_elements_packed: entry (Pdesc, level, Nignored_dim, Slast, ASpacked, Aoffset, Acode); Acode = 0; /* decode descriptor for structure element, just */ Aoffset = 1; /* as for the $recurse entry point. */ call decode_descriptor_ (Pdesc, 0, type, Spacked, Ndim, size, scale); if (1 <= type & type <= 23) | (33 <= type & type <= 34) | (43 <= type & type <= 46) then; else do; Acode = error_table_$bad_segment; return; end; if ^Spacked then do; /* If structure element unpacked, we can stop now.*/ ASpacked = "0"b; return; end; if type = 17 then /* If structure el is another structure, return */ /* result of testing its elements. */ ASpacked = all_structure_elements_packed (); return; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ end get_pl1_parm_desc_string_;  interpret_ptr_.pl1 11/05/86 1346.8r w 11/04/86 1041.7 129582 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ interpret_ptr_: procedure (a_ptr, a_framep, strp); /* INTERPRET_PTR_ - find out as much as possible about a pointer. This program returns printable information about an input pointer. If a stack frame pointer or machine conditions pointer is also supplied, the program finds out information about the owner of the given stack frame, and remarks that the fault may not have occurred in the frame owner. */ /* modified 24 July 1975 by M. Weaver for separate static */ /* Modified 7/76 to prevent a fault while interpreting a bad pointer */ /* Modified March 1980 by C. Hornig to find source line */ /* Changed to use interpret_link_info.incl.pl1 05/12/83 S. Herbst */ dcl a_ptr ptr, /* ptr to be interpreted (input) */ a_framep ptr, /* ptr to associated stack frame, or null (input) */ strp ptr; /* ptr to return structure (input) */ dcl bcs char (54) based (in_ptr); dcl bit_72 bit (72) based; /* Used to avoid pointer check while copying the argument */ dcl 1 ptrb based aligned, /* breakdown of a pointer */ 2 xx1 bit (3) unal, 2 sn bit (15) unal, 2 rn bit (3) unal, 2 xxx bit (9) unal, 2 its bit (6) unal, 2 yyy bit (36) unal; dcl 1 condinfo aligned like condition_info; /* structure returned by find_condition_info_ */ dcl 1 oi aligned like object_info; dcl 1 situation aligned, 2 bad_frame bit (1) unal, 2 exists_ppr bit (1) unal, 2 ppr_is_owner bit (1) unal, 2 ppr_is_ops bit (1) unal, 2 caller_is_owner bit (1) unal, 2 entry_ptr_invalid bit (1) unal, 2 ret_ptr_is_ops bit (1) unal, 2 pad bit (29) unal; dcl 1 auto_interpret_link_info aligned like interpret_link_info; dcl xp ptr, /* ptr to segment name */ frame_owner_sw bit (1) aligned init ("1"b), coptr ptr init (null), coflg bit (1) init ("0"b), in_ptr ptr, /* copied arg */ framep ptr, /* ptr to stack frame */ hcsct fixed bin, /* highest hardcore segment */ highct fixed bin, /* highest segment number */ txtp ptr, /* ptr into text */ rings (3) fixed bin (6), /* used when checking accessibility */ lev fixed bin, /* ... validation level */ mode fixed bin (5), /* rewa mode of segment */ type fixed bin (2), /* dir, seg, link */ (bc, bc1) fixed bin (24), /* bitcount */ bmp ptr, /* bindmap ptr */ sblkp ptr, namp ptr, /* component name */ naml fixed bin, based_name char (naml) based (namp), /* component name (in defs of bound seg) */ (i, j) fixed bin, /* temps */ dirn char (168) aligned, /* dirname where segment reside */ ename char (32) aligned, /* temp entry name */ pl1_op_name char (32) aligned, /* operator name */ segn char (32) aligned, /* file-system name for seg */ segno fixed bin (18), adjusted_offset fixed bin (18), section char (8) aligned, lang char (8) aligned, op_seg_name char (32) aligned, ec fixed bin (35), /* file-system error code */ ctmp char (65); dcl condition_ entry (char (*), entry), get_entry_name_ entry (ptr, char (*) aligned, fixed bin (18), char (8) aligned, fixed bin (35)), is_condition_frame_ entry (ptr) returns (bit (1)), find_condition_info_ entry (ptr, ptr, fixed bin (35)), find_nonobject_info_ entry (ptr, char (*), fixed bin (18) aligned, char (8) aligned, fixed bin (18) aligned, fixed bin (35)), stack_frame_exit_ entry (ptr, ptr, ptr, bit (1), ptr, char (32) aligned, ptr), find_operator_name_ entry (char (*) aligned, ptr, char (32) aligned), cu_$level_get entry (fixed bin), hcs_$fs_get_brackets entry (ptr, fixed bin (5), (*) fixed bin (6), fixed bin (35)), hcs_$high_low_seg_count entry (fixed bin, fixed bin), ring0_get_$name entry (char (*) aligned, char (*) aligned, ptr, fixed bin (35)), hcs_$fs_get_path_name entry (ptr, char (*) aligned, fixed bin, char (*) aligned, fixed bin (35)), hcs_$status_mins entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35)), object_info_$display entry (ptr, fixed bin (24), ptr, fixed bin (35)), get_bound_seg_info_ entry (ptr, fixed bin (24), ptr, ptr, ptr, fixed bin (35)), component_info_$offset entry (ptr, fixed bin (18), ptr, fixed bin (35)), interpret_link_ entry (ptr, ptr, fixed bin (35)), ioa_$rsnnl entry options (variable); dcl LEGAL char (96) int static init /* Printables except PAD, but with BS */ (" !""#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~"); dcl (addr, baseno, baseptr, ptr, fixed, null, addrel, rel, substr, binary, bit, verify) builtin; /* ------------------------------------------------------ */ frame_owner_sw = "0"b; go to start; frame_owner: entry (a_ptr, a_framep, strp); start: if strp = null then return; /* initialization. check args */ addr (in_ptr) -> bit_72 = addr (a_ptr) -> bit_72; /* copy arg without pointer check */ call condition_ ("any_other", oop); framep = a_framep; /* .. and copy args */ mcp, scup = null; /* assume no machine cond */ if framep ^= null then /* see if condition frame */ if frame_owner_sw then /* un-necessary (& may be harmful) in some cases */ if is_condition_frame_ (framep) then do; call find_condition_info_ (framep, addr (condinfo), ec); if ec = 0 then do; mcp = condinfo.mc_ptr; in_ptr = condinfo.user_loc_ptr; coptr = condinfo.wc_ptr; coflg = condinfo.flags.crawlout; scup = addr (mc.scu); /* Fix ptr to suit Clancy */ end; end; struc.comment, struc.segment, struc.entryn, struc.offset, struc.opname, struc.modifier = ""; struc.instruction_counter = fixed (rel (in_ptr)); /* initialize return values */ struc.compiler = ""; struc.ring = ""; struc.std_flag = "0"b; struc.xpad = "0"b; struc.symbolp = null; struc.text_ptr = in_ptr; struc.stack_ptr = framep; struc.sourcemap = 0; call hcs_$high_low_seg_count (highct, hcsct); /* find range of good segnos */ ename = ""; call ioa_$rsnnl ("^o", struc.offset, i, struc.instruction_counter); j = fixed (baseno (in_ptr), 17); /* if can't get segname. what is segno? */ call ioa_$rsnnl ("#^o", segn, i, j); /* unknown segment. put number */ struc.segment = segn; /* Try to take care of some special cases first. */ xp = addr (in_ptr); /* null ptr is special cased */ if xp -> ptrb.sn = (15)"1"b then do; struc.segment = "null pointer"; return; end; if xp -> ptrb.its = "100110"b then do; /* unsnapped link */ auto_interpret_link_info.version = INTERPRET_LINK_INFO_VERSION_1; call interpret_link_ (addr (auto_interpret_link_info), in_ptr, ec); /* if ft2, ask spier */ if ec = 0 then do; /* good. we can say */ struc.entryn = auto_interpret_link_info.entry_point_name; struc.segment = auto_interpret_link_info.segment_name; struc.offset = auto_interpret_link_info.expression; struc.modifier = auto_interpret_link_info.modifier; end; else struc.segment = "unsnapped link"; /* happens if not in linkage section */ glop: struc.text_ptr = null; /* save everybody else a lot of trouble */ glop1: return; end; if xp -> ptrb.its ^= "100011"b then go to glop; /* not fool with non-ptr */ struc.ring = substr ("01234567", fixed (xp -> ptrb.rn, 3), 1); if binary (baseno (in_ptr)) <= hcsct then do; /* Hardcore segment? */ call ring0_get_$name (dirn, segn, in_ptr, ec); /* yes. obtain name */ if ec = 0 then do; struc.segment = segn; /* oho. */ struc.ring = "0"; call check_access (in_ptr, bc, ec); if ec = 5 then go to nonobj; if ec ^= 0 then go to glop; end; end; /* Special cases are taken care of. In normal case, we examine stack frame to get procedure name. */ txtp = in_ptr; /* Assume return ptr is good, for the moment */ call hcs_$fs_get_path_name (txtp, dirn, j, segn, ec); /* who is he */ if ec = 0 then struc.segment = segn; if frame_owner_sw then if framep ^= null then do; /* Check stack frame. */ call stack_frame_exit_ (framep, mcp, coptr, coflg, txtp, op_seg_name, addr (situation)); if situation.bad_frame then return; end; call check_access (txtp, bc, ec); if ec = 1 then go to glop; if ec ^= 0 then go to nonobj; if mcp ^= null then do; /* if no machine cond, stymied */ call find_operator_name_ (op_seg_name, txtp, pl1_op_name); if pl1_op_name ^= "" then /* If we were in an operator, */ struc.opname = "in operator " || pl1_op_name; end; call hcs_$fs_get_path_name (txtp, dirn, j, segn, ec); /* who is he */ struc.segment = segn; call get_entry_name_ (txtp, ename, segno, lang, ec); if ec ^= 0 then if framep ^= null then call get_entry_name_ (framep -> stack_frame.entry_ptr, ename, segno, lang, ec); if ec = 0 then struc.entryn = "$" || ename; struc.instruction_counter = fixed (rel (txtp)); struc.text_ptr = txtp; call ioa_$rsnnl ("^o", struc.offset, j, struc.instruction_counter); oi.version_number = object_info_version_2; call object_info_$display (ptr (txtp, 0), bc, addr (oi), ec); if ec ^= 0 then go to nonobj; /* if not object seg, jump down */ struc.compiler = oi.compiler; /* was object seg. get info on it */ struc.std_flag = ^oi.format.old_format; struc.symbolp = oi.symbp; /* save ptr to beg of symbol section */ struc.sourcemap = oi.source_map; /* save source map if given */ if oi.format.bound then do; /* is this a bound segment? */ call component_info_$offset (ptr (txtp, 0), binary (rel (txtp)), addr (ci), ec); if ec = 0 then do; /* bound segment. */ struc.compiler = ci.compiler; /* we have better info now. */ struc.std_flag = ci.standard; struc.symbolp = ci.symb_start; struc.sourcemap = ci.source_map; call ioa_$rsnnl ("(^a|^a)", struc.comment, ec, segn, struc.offset); struc.segment = ci.name; struc.instruction_counter = binary (rel (txtp)) - binary (rel (ci.text_start)); call ioa_$rsnnl ("^o", struc.offset, j, struc.instruction_counter); end; end; goto xtarget; /* If ptr is to combined linkage segment, see if we can get any info from the LOT. Or be v1 entry */ nonobj: /* see if location is described by def */ call find_nonobject_info_ (in_ptr, ctmp, segno, section, adjusted_offset, ec); if section = "text" then do; /* text assumed if not in combined linkage segment */ if ctmp = "" then go to xtarget; /* have no further name info */ if segn = "" then struc.entryn = ctmp; else struc.entryn = "$" || ctmp; struc.comment = "(external symbol in separate nonstandard text section)"; go to done; end; /* in_ptr points to static or linkage */ call hcs_$fs_get_path_name (baseptr (segno), dirn, i, segn, ec); if ec ^= 0 then go to xtarget; call ioa_$rsnnl ("(^a|^o for ^a)", struc.comment, i, section, adjusted_offset, segn); call hcs_$status_mins (baseptr (segno), type, bc1, ec); if ec = 0 then do; call get_bound_seg_info_ (baseptr (segno), bc1, addr (oi), bmp, sblkp, ec); if ec = 0 then do; do j = 1 to n_components while (adjusted_offset > fixed (component (j).stat_start) + fixed (component (j).stat_lng)); end; if j <= n_components then do; namp = addrel (sblkp, component (j).name_ptr); naml = fixed (component (j).name_lng); call ioa_$rsnnl ("(internal static|^o for ^a)", struc.comment, i, adjusted_offset - fixed (component (j).stat_start), based_name); end; end; end; if ctmp ^= "" then do; struc.entryn = "$" || ctmp; if section = "linkage" then struc.comment = "(entry sequence)"; end; /* If we cannot say anything else, tell what the pointer points at, if it's ascii. */ xtarget: if struc.comment = "" then do; i = verify (bcs, LEGAL); /* Scan to see how much is ascii. */ if i = 0 then i = 54; /* If all legal. */ if i > 4 then struc.comment = "( -> """ || substr (bcs, 1, i - 1) || """)"; end; done: return; /* ------------------------------------------------------- */ check_access: proc (txtp, bc, code); dcl txtp ptr, bc fixed bin (24), code fixed bin (35); dcl ec fixed bin (35); code = 0; if binary (baseno (txtp)) > hcsct + highct then do; /* dump out if segment invalid */ code = 1; return; end; call hcs_$status_mins (txtp, type, bc, ec); /* check for directory, get length in bits */ if ec ^= 0 then go to ng; /* how can this happen? */ if type ^= 1 then do; /* ignore directories */ ng: code = 4; return; end; call cu_$level_get (lev); /* check ring brackets */ call hcs_$fs_get_brackets (txtp, mode, rings, ec); if ec ^= 0 then go to ng; /* if cannot status segment */ if rings (2) < lev then do; /* outside read bracket? */ code = 2; return; end; if (bit (mode, 5) & "01000"b) ^= "01000"b then do;/* check for read access */ struc.text_ptr = null; code = 3; return; end; if bc = 0 then code = 5; /* if bit count zero, is not object seg. */ end check_access; /* -------------------------------------------------------- */ oop: proc (mcp, cname, cop, infop, cont); dcl (mcp, cop, infop) ptr, cname char (*), cont bit (1); if cname = "cput" then go to xx; if cname = "alrm" then go to xx; if cname = "quit" then go to xx; if cname = "finish" then go to xx; if cname = "stack" then go to xx; if cname = "mme2" then go to xx; if cname = "program_interrupt" then do; xx: cont = "1"b; return; end; if cname ^= "cleanup" then go to glop1; end oop; /* * * * * * * * * * * * * * * * * * * */ %include condition_info; %include interpret_link_info; %include interpret_ptr_struc; %include component_info; %include bind_map; %include object_info; %include stack_frame; %include mc; end interpret_ptr_;  list_frame_args_.pl1 10/24/88 1649.2r w 10/24/88 1400.1 117441 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-09-08,DGHowe), approve(86-09-08,MCR7524), audit(86-09-16,Ginter), install(86-09-24,MR12.0-1158): check for command_name_arglist mbz and pad1 = "0"b and print out the command name if it is available. END HISTORY COMMENTS */ /* format: style3,^indnoniterdo */ list_frame_args_: proc (framep, ss); /* This program is an adaptation of Steve Webber's list_arg_ routine from db, for use by trace_stack_. */ /* rewritten 8/10/81 by Melanie Weaver to use arithmetic_to_ascii_ */ /* Changed to print "(no type information)" if Pascal & if no descriptors 10/18/83 S. Herbst */ /* Modified Aug 7, 1986 by Doug Zwick to fix bug introduced by the command processor argument changes installed for C (MCR 7375). Add functionality to display the command name field if supplied in the arg list, and to display the value of the argument list pointer. Also changed to use arg_list.incl.pl1 so that peruse_crossref will show this module as using the argument list. */ dcl framep ptr, ss char (32) aligned; dcl (addr, addrel, hbound, lbound, min, null, substr, fixed, bin, max, verify, unspec) builtin; dcl argp ptr; dcl ss_ptr ptr; dcl ap ptr; /* ptr to arglist. */ dcl strp ptr; dcl tp ptr; dcl xdesc (64) ptr; dcl (i, j, k) fixed bin; dcl (min_arg, max_arg, type, xtype) fixed bin; dcl (no_args, no_desc, strl, ndims, scale) fixed bin; dcl (xstrl, xndims, xscale, xnargs) fixed bin; dcl ec fixed bin (35); dcl c75 char (75) aligned; dcl (ttype, xttype) char (24); dcl ascii_representation char (132) varying; dcl (packed, xpacked) bit (1) aligned; dcl begin_block_entries (2) bit (36) aligned internal static options (constant) init ("000614272100"b3 /* tsp2 pr0|614 */, "001376272100"b3 /* tsp2 pr0|1376 */); dcl 1 its_ptr aligned like its; dcl condition_ entry (char (*), entry); dcl get_entry_arg_descs_ entry (ptr, fixed bin, (*) ptr, fixed bin (35)); dcl decode_descriptor_ entry (ptr, fixed bin, fixed bin, bit (1) aligned, fixed bin, fixed bin, fixed bin); dcl interpret_ptr_ entry (ptr, ptr, ptr); dcl ioa_$ioa_stream entry options (variable); dcl ioa_$ioa_stream_nnl entry options (variable); dcl ioa_$rsnnl entry options (variable); dcl arithmetic_to_ascii_ entry (ptr, fixed bin, bit (1) aligned, fixed bin, fixed bin, char (132) varying); dcl iox_$look_iocb entry (char (*), ptr, fixed bin (35)); dcl display_file_value_ entry (ptr, file, fixed bin (35)); dcl itsptr ptr based aligned; dcl packptr ptr based unaligned; dcl fword (4) fixed bin (35) based (argp); dcl bcs char (100) based (argp); dcl char_string char (strl) based (argp); dcl based_bit bit (36) aligned based; dcl bit_string bit (strl) based (argp); dcl based_file file based; dcl 1 label_variable based (argp) aligned, 2 ptr ptr, 2 stack ptr; dcl 1 arglist aligned like command_name_arglist based (ap); dcl LEGAL char (96) int static init /* Printables except PAD, but with BS */ ( " !""#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~" ); /* ====================================================================== */ sp = framep; /* Copy argument. */ unspec (ap), unspec (its_ptr) = unspec (stack_frame.arg_ptr); /* Extract argument ptr. */ if its_ptr.its_mod ^= ITS_MODIFIER /* use valid pl1 code */ then go to badap; if ap = null then do; badap: if addr (sp -> stack_frame.entry_ptr) -> its.its_mod = ITS_MODIFIER then if sp -> stack_frame.entry_ptr ^= null then do j = 1 to hbound (begin_block_entries, 1); if addrel (sp -> stack_frame.entry_ptr, 1) -> based_bit = begin_block_entries (j) then do; call ioa_$ioa_stream (ss, "^-Begin block; no arguments."); return; end; end; call ioa_$ioa_stream (ss, "^-Bad argument pointer."); return; end; strp = addr (strbuf); no_args = fixed (arglist.arg_count); /* get the number of arguments */ no_desc = fixed (arglist.desc_count); /* and the number of descriptors */ if arglist.mbz ^= "0"b then go to badah; if arglist.call_type ^= 4 then if arglist.call_type ^= 8 then go to badah; if no_desc ^= 0 then if no_desc ^= no_args then do; badah: call ioa_$ioa_stream (ss, "^-Argument list header invalid."); return; end; call ioa_$ioa_stream (ss, " Argument list pointer: ^p", ap); /* The command processor will fill in the command name field with the name by which the command was invoked. Its there so we might as well display it. */ if arglist.has_command_name then call ioa_$ioa_stream (ss, "^-Command name: ^a", substr (arglist.command_name_ptr -> char_string, 1, arglist.command_name_length)); call get_entry_arg_descs_ (stack_frame.entry_ptr, xnargs, xdesc, ec); if xnargs > 0 then /* Many programs like commands fetch args thru cu_ */ if xnargs ^= no_args then /* .. and so we special-case that. */ call ioa_$ioa_stream (ss, "^-Warning: ^d arguments expected, ^d supplied.", xnargs, no_args); if no_args = 0 then do; /* check for no arguments */ call ioa_$ioa_stream (ss, "^-No arguments."); return; end; if no_args > 64 then do; call ioa_$ioa_stream (ss, "^-Only first 64 args of ^d will be listed.", no_args); no_args = 64; if xnargs > 64 then xnargs = 64; if no_desc ^= 0 then no_desc = 64; end; min_arg = 1; /* print out all arguments */ max_arg = no_args; call condition_ ("any_other", intproc); do j = min_arg to max_arg; /* loop through the desired number of args */ argp = arglist.arg_ptrs (j); /* get pointer to the argument */ if no_desc ^= 0 then do; /* if we have descriptors, look at them */ call decode_descriptor_ (ap, j, type, packed, ndims, strl, scale); if xnargs >= j then /* Does procedure expect arguments? */ if xdesc (j) ^= null then do; /* Yes. Do we know what this arg shd be? */ call decode_descriptor_ (xdesc (j), 0, xtype, xpacked, xndims, xstrl, xscale); if xtype ^= type then do; if type >= lbound (data_type_info_$info, 1) & type <= hbound (data_type_info_$info, 1) then ttype = substr(type_name (type),1,24); else call ioa_$rsnnl ("type ^d", ttype, k, type); if xtype >= lbound (data_type_info_$info, 1) & xtype <= hbound (data_type_info_$info, 1) then xttype = substr(type_name (xtype),1,24); else call ioa_$rsnnl ("type ^d", xttype, k, xtype); call ioa_$ioa_stream (ss, "^-Warning: arg ^d type mismatch: ^a supplied, ^a expected.", j, ttype, xttype); end; if xpacked ^= packed /* Check that packed attributes match */ then call ioa_$ioa_stream (ss, "^-Warning: arg ^d packed mismatch: ^d supplied, ^d expected.", j, bin (packed, 35), bin (xpacked, 35)); if xndims ^= ndims then call ioa_$ioa_stream (ss, "^-Warning: arg ^d ndims mismatch: ^d supplied, ^d expected.", j, ndims, xndims); if xstrl ^= strl then if xtype < pointer_dtype then call ioa_$ioa_stream (ss, "^-Warning: arg ^d precision mismatch: ^d supplied, ^d expected.", j, strl, xstrl); else if xstrl ^= 16777215 then /* No fuss abt char (*) */ call ioa_$ioa_stream (ss, "^-Warning: arg ^d length mismatch: ^d supplied, ^d expected.", j, strl, xstrl); if xscale ^= scale then call ioa_$ioa_stream (ss, "^-Warning: arg ^d scale mismatch: ^d supplied, ^d expected.", j, scale, xscale); end; end; else if xnargs >= j then do; /* Callee might have descriptors for args. */ if xdesc (j) = null then go to guess; /* .. and then again he might not. */ call decode_descriptor_ (xdesc (j), 0, type, packed, ndims, strl, scale); end; else if stack_frame.translator_id = "000010"b3 then type = -1; /* Pascal frame */ else do; /* try to find out what type by heuristics */ guess: packed = "0"b; scale = 0; ndims = 0; if argp -> its.its_mod = ITS_MODIFIER then type = pointer_dtype; /* assume pointer */ else do; strl = verify (bcs, LEGAL) - 1; /* Scan for last legal char in string. */ if strl < 0 then strl = 100; /* If all legal, print first 100. */ if strl >= 2 then type = char_dtype; else type = -1; /* full word octal */ end; end; if type = -1 then do; call ioa_$ioa_stream (ss, "^-ARG ^2d: ^w (no type information)", j, fword (1)); /* no descriptor; print full word octal */ go to skiparg; end; else if type < lbound (data_type_info_$info, 1) | type > hbound (data_type_info_$info, 1) then call ioa_$ioa_stream (ss, "^-ARG ^2d: (bad type ^d at ^p) ^w", j, type, argp, fword (1)); else if data_type_info_$info (type).arithmetic then do; call arithmetic_to_ascii_ (argp, type, packed, strl, scale, ascii_representation); call ioa_$ioa_stream (ss, "^-ARG ^2d: ^a", j, ascii_representation); end; else if type = pointer_dtype then do; /* Pointer */ if packed then do; /* packed ptr */ tp = argp -> packptr; go to pptr; end; if argp -> its.its_mod = ITS_MODIFIER then do; tp = argp -> itsptr; pptr: call interpret_ptr_ (tp, null, strp); call ioa_$ioa_stream (ss, "^-ARG ^2d: ^p ^a^a|^a ^a", j, tp, struc.segment, struc.entryn, struc.offset, struc.comment); end; else call ioa_$ioa_stream (ss, "^-ARG ^2d: ^w ^w", j, fword (1), fword (2)); end; else if type = offset_dtype /* Offset */ then call ioa_$ioa_stream (ss, "^-ARG ^2d: ^w", j, fword (1)); else if type = label_dtype | type = entry_dtype /* Label, Entry */ then do; call interpret_ptr_ (argp -> label_variable.ptr, argp -> label_variable.stack, strp); call ioa_$ioa_stream (ss, "^-ARG ^2d: ^p, ^p ^a^a|^a ^a", j, label_variable.ptr, label_variable.stack, struc.segment, struc.entryn, struc.offset, struc.comment); end; else if type = bit_dtype | type = varying_bit_dtype /* Bit string */ then do; if type = varying_bit_dtype then strl = addrel (argp, -1) -> fword (1); c75 = """"; /* initial quote */ k = 0; /* count 1-bits */ do i = 1 to min (strl, 72); if substr (bit_string, i, 1) then do; k = k + 1; substr (c75, i + 1, 1) = "1"; end; else substr (c75, i + 1, 1) = "0"; end; substr (c75, i + 1, 2) = """b"; if (strl <= 72 & strl > 1) then /* Maybe compress representation */ if k = 0 then call ioa_$rsnnl ("(^d)""0""b", c75, k, strl); else if k = strl then call ioa_$rsnnl ("(^d)""1""b", c75, k, strl); call ioa_$ioa_stream (ss, "^-ARG ^2d: ^a", j, c75); end; else if type = char_dtype | type = varying_char_dtype /* Character string */ then do; if type = varying_char_dtype then strl = min (80, max (addrel (argp, -1) -> fword (1), 0)); call ioa_$ioa_stream (ss, "^-ARG ^2d: ""^va""", j, strl, char_string); end; else if type = file_dtype /* File */ then do; call ioa_$ioa_stream_nnl (ss, "^-ARG ^2d: ", j); call iox_$look_iocb ((ss), ss_ptr, ec); if ec = 0 then call display_file_value_ (ss_ptr, argp -> based_file, ec); if ec ^= 0 then call ioa_$ioa_stream (ss, "(file at ^p)", argp); end; else call ioa_$ioa_stream (ss, "^-ARG ^2d: (^a at ^p) ^w", j, type_name (type), argp, fword (1)); if ndims > 0 then call ioa_$ioa_stream (ss, "^-^-(^d-dim array)", ndims); skiparg: end; /* ------------------------------------------------------- */ intproc: proc (mcp, cname, cop, infop, cont); dcl (mcp, cop, infop) ptr, cname char (*), cont bit (1); /* format: ^delnl */ if cname = "program_interrupt" | cname = "finish" | cname = "quit" then do; cont = "1"b; return; end; /* format: revert */ if cname = "cleanup" then return; if infop ^= null then if infop -> condition_info_header.action_flags.quiet_restart then return; call ioa_$ioa_stream (ss, "^-ARG ^2d not accessible. - ^a", j, cname); go to skiparg; end; %include stack_frame; %include arg_list; %include interpret_ptr_struc; %include its; %include data_type_info_; %include condition_info_header; %include std_descriptor_types; %include probe_data_type_names; end list_frame_args_;  list_onunits_.pl1 11/05/86 1346.8r w 11/04/86 1041.7 28170 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ list_onunits_: proc (a_sp, stream); /* LIST_ONUNITS_ - list enabled condition handlers in a frame. This program is called by trace_stack_ */ dcl a_sp ptr, /* stack frame pointer */ stream char (32) aligned; /* output stream */ dcl tp ptr, /* working ptr */ strp ptr, bchr char (32) unal based (tp), condid char (66) aligned, junk fixed bin, snapw char (4) aligned, on_unit_ptr ptr, on_unit_rel bit (18) aligned; dcl 1 filevar based aligned, 2 fabp ptr, 2 fsbp ptr; dcl 1 fab based aligned, /* File attributes block. */ 2 switch bit (36), 2 filename char (32); dcl interpret_ptr_ entry (ptr, ptr, ptr), ioa_$rsnnl entry options (variable), ioa_$ioa_stream entry options (variable); dcl n_io_conds fixed bin int static init (7); /* Number of conditions which have file name. */ dcl io_cond (7) char (16) aligned int static init ("endfile", "endpage", "name", "record", "transmit", "undefinedfile", "key"); %include on_unit; %include stack_frame; %include interpret_ptr_struc; dcl (addr, addrel, null, substr) builtin; /* ------------------------------------------------------ */ sp = a_sp; /* copy arg */ if ^stack_frame_flags.condition then return; /* check bit 29 of last-sp */ strp = addr (strbuf); on_unit_rel = stack_frame.on_unit_relp1; /* got on-units, so follow chain */ onloop: if on_unit_rel = "0"b then return; /* "0"b means end of chain */ on_unit_ptr = addrel (sp, on_unit_rel); /* these things are relative to sp */ if on_unit_ptr -> on_unit.flags.pl1_snap then snapw = "snap"; else snapw = ""; if on_unit_ptr -> on_unit.size ^= 0 then do; tp = on_unit_ptr -> on_unit.name; /* get ptr to name */ condid = substr (bchr, 1, on_unit_ptr -> on_unit.size); do junk = 1 to n_io_conds while (condid ^= io_cond (junk)); end; if junk <= n_io_conds then /* This unit has associated filename. */ call ioa_$rsnnl ("^a(^a)", condid, junk, substr (bchr, 1, on_unit_ptr -> on_unit.size), on_unit_ptr -> on_unit.file -> filevar.fabp -> fab.filename); if on_unit_ptr -> on_unit.flags.pl1_system then do; call ioa_$ioa_stream (stream, "^-on ""^a"" ^a system;", condid, snapw); end; else do; call interpret_ptr_ (on_unit_ptr -> on_unit.body, null, strp); call ioa_$ioa_stream (stream, "^-on ""^a"" ^a call ^a^a|^a ^a", condid, snapw, struc.segment, struc.entryn, struc.offset, struc.comment); end; end; on_unit_rel = on_unit_ptr -> on_unit.next; /* following chain */ go to onloop; end list_onunits_;  print_source_line_.pl1 10/03/83 1732.6rew 10/03/83 1009.5 75114 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ print_source_line_: proc (strp, stream); /* PRINT_SOURCE_LINE_ - attempt to print out the source line for a given location. This is a subroutine of trace_stack_. Its input data has been set up by interpret_ptr_. THVV */ /* Modified 7/76 by S.E. Barr to delete printing of version I operator names and to recognize "PL/I" compiler name */ /* Changed to use interpret_link_info.incl.pl1 05/12/83 S. Herbst */ dcl strp ptr, stream char (32) aligned; dcl sp ptr, /* ptr to stack frame */ fptr ptr, /* ptr to faulting instruction */ btc fixed bin (24), cip ptr, callp ptr, entry_ptr ptr, link_ptr ptr, lang char (8) aligned, op_seg_name char (32) aligned, segno fixed bin (18), component char (32) aligned, sn char (32) aligned, i fixed bin, insx fixed bin init (1), working_dir_name char (168) aligned, /* name of current wdir, for look for source */ pl1_operator_name char (32) aligned, /* if faulting instr was pl1 op, what? */ line_no char (16), /* line number of source (from symbol table) */ dirname char (168), ename char (32), ec fixed bin (35), /* system errcode */ disassembled_instr char (72) var; /* faulting instruction */ dcl source_ptr ptr; dcl source_seg char (1000000) aligned based (source_ptr); dcl (line_offset, line_length) fixed bin (21); dcl component_info_$offset entry (ptr, fixed bin, ptr, fixed bin (35)), is_condition_frame_ entry (ptr) returns (bit (1)), find_condition_info_ entry (ptr, ptr, fixed bin (35)), stack_frame_exit_ entry (ptr, ptr, ptr, bit (1), ptr, char (32) aligned, ptr), find_operator_name_ entry (char (*) aligned, ptr, char (32) aligned), get_link_ptr_ entry (ptr, ptr, ptr), get_entry_name_ entry (ptr, char (*) aligned, fixed bin (18), char (8) aligned, fixed bin (35)), interpret_link_ entry (ptr, ptr, fixed bin (35)), disassemble entry (ptr, char (*) var, fixed bin), find_source_line_ entry (ptr, char (*), char (*), char (*), fixed bin (21), fixed bin (21), fixed bin (35)), hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)), hcs_$terminate_noname entry (ptr, fixed bin (35)), hcs_$fs_get_brackets entry (ptr, fixed bin (5), (3) fixed bin (6), fixed bin (35)), hcs_$status_mins entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35)), hcs_$high_low_seg_count entry (fixed bin, fixed bin), hcs_$fs_get_path_name entry (ptr, char (*) aligned, fixed bin, char (*) aligned, fixed bin (35)), ioa_$ioa_stream entry options (variable); dcl (addr, ptr, fixed, null, substr, binary, baseno, baseptr, bit, rel) builtin; dcl 1 situation aligned, 2 bad_frame bit (1) unal, 2 exists_ppr bit (1) unal, 2 ppr_is_owner bit (1) unal, 2 ppr_is_ops bit (1) unal, 2 caller_is_owner bit (1) unal, 2 entry_ptr_invalid bit (1) unal, 2 ret_ptr_is_ops bit (1) unal, 2 pad bit (29) unal; dcl 1 condinfo aligned, /* return struc from find_condition_info_ */ 2 mcptr ptr init (null), 2 version fixed bin, 2 condition_name char (32) var, 2 infoptr ptr init (null), 2 wcptr ptr init (null), 2 loc_ptr ptr init (null), 2 flags, 3 crawlout bit (1) unal init ("0"b), 3 pad1 bit (35) unal, 2 user_loc_ptr ptr init (null), 2 pad (4) bit (36); %include interpret_ptr_struc; %include interpret_link_info; dcl 1 auto_interpret_link_info aligned like interpret_link_info; %include component_info; /* ======================================================= */ sp = struc.stack_ptr; /* Copy stack ptr from structure */ fptr = struc.text_ptr; /* ... instruction ptr too. */ if is_condition_frame_ (sp) then do; /* may need machine cond. */ cip = addr (condinfo); call find_condition_info_ (sp, cip, ec); end; call stack_frame_exit_ (sp, condinfo.mcptr, condinfo.wcptr, condinfo.crawlout, callp, op_seg_name, addr (situation)); if situation.bad_frame then return; call find_source_line_ (strp, line_no, dirname, ename, line_offset, line_length, ec); if line_no = "" then do; call ioa_$ioa_stream (stream, " Cannot get line number in ^a", struc.segment); end; else do; call hcs_$initiate (dirname, ename, "", 0, 1, source_ptr, ec); if source_ptr = null () then call ioa_$ioa_stream (stream, " ^a ^a: source not found", ename, line_no); else call ioa_$ioa_stream (stream, " ^a ^a: ^a", ename, line_no, substr (source_seg, 1 + line_offset, line_length)); call hcs_$terminate_noname (source_ptr, ec); end; if fptr = null then return; /* can't print anything if you won't tell me where */ pl1_operator_name = ""; if op_seg_name = "" then if struc.compiler = "v2pl1" | struc.compiler = "PL/I" | struc.compiler = "alm" then op_seg_name = "pl1_operators_"; else if struc.compiler = "pl1" | struc.compiler = "" then op_seg_name = "pl1_operators"; if ^get_access (callp, btc) then pl1_operator_name = "not accessible"; else call find_operator_name_ (op_seg_name, callp, pl1_operator_name); if pl1_operator_name = "alm_call" | substr (pl1_operator_name, 1, 4) = "call" then do; call get_link_ptr_ (callp, link_ptr, entry_ptr); /* Who was he trying to call? */ if link_ptr ^= null then do; auto_interpret_link_info.version = INTERPRET_LINK_INFO_VERSION_1; call interpret_link_ (addr (auto_interpret_link_info), link_ptr, ec); /* Take link ptr if available. */ if ec = 0 then do; call ioa_$ioa_stream (stream, " ^a to ^a^a", pl1_operator_name, auto_interpret_link_info.segment_name, auto_interpret_link_info.entry_point_name); return; end; end; if entry_ptr ^= null then do; /* Have found a snapped link. */ call get_entry_name_ (entry_ptr, sn, segno, lang, ec); /* This shd point to entry sequence. */ if ec = 0 then do; call hcs_$fs_get_path_name (baseptr (segno), working_dir_name, i, component, ec); if ec = 0 then do; if segno = fixed (baseno (fptr)) then do; call component_info_$offset (ptr (entry_ptr, 0), binary (rel (entry_ptr)), addr (ci), ec); if ec = 0 then component = ci.name; end; call ioa_$ioa_stream (stream, " ^a to ^a$^a", pl1_operator_name, component, sn); return; end; end; end; end; /* Print instruction if no other information is available */ call disassemble (fptr, disassembled_instr, insx); call ioa_$ioa_stream (stream, "^a ^a", disassembled_instr, pl1_operator_name); if insx > 1 then do i = 2 to insx; call disassemble (fptr, disassembled_instr, i); call ioa_$ioa_stream (stream, "^a", disassembled_instr); end; /* This function tests the user's access to the object segment to prevent taking a fault while attempting to provide information. It checks for read access, correct ring brackets, a positive bit count and a plausible segment number. */ get_access: proc (txtp, bc) returns (bit (1) unal); dcl txtp ptr, bc fixed bin (24), code fixed bin (35); dcl rings (3) fixed bin (6); dcl type fixed bin (2); dcl mode fixed bin (5); dcl lev fixed bin (6); dcl (hcsct, highct) fixed bin; dcl cu_$level_get entry (fixed bin (6)); call hcs_$high_low_seg_count (highct, hcsct); if binary (baseno (txtp)) <= hcsct + highct then do; call hcs_$status_mins (txtp, type, bc, code); if code = 0 & type = 1 then do; /* 1 = segment (ignore directories) */ call cu_$level_get (lev); call hcs_$fs_get_brackets (txtp, mode, rings, code); if code = 0 & rings (2) >= lev then do; if (bit (mode, 5) & "01000"b) = "01000"b then if bc > 0 then return ("1"b); end; end; end; return ("0"b); end get_access; end print_source_line_;  prtscu_.pl1 10/03/83 1732.6rew 10/03/83 1009.6 114282 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ prtscu_: proc; return; /* should never enter here */ /* Modification History - prtscu_ Initially coded by J. A. Bush - Dec 1975 Modified May 1977 by J. A. Bush to be intellegent about group 7 faults and not print out tsr|ca Modified Aug 1980 by R.L. Coppola to be more intelligent about IOM channels greater than 37 (octal). Also added display of the CT Hold reg in CU status. */ dcl a_iocbp ptr; /* output switch (iox_$user_output is default) */ dcl scup ptr; /* pointer to SCU Data */ dcl a_offset fixed bin; /* relative offset of SCU data */ dcl lg_sw bit (1); /* long format switch "1"b => long */ dcl odsp ptr; /* ptr to ol_dump structure (defined in ol_dump_struc.incl.pl1) */ % include interpret_ptr_struc; dcl (strp, byptr, refptr) ptr; dcl (lnpos, flt_lng, inst6, i, j, reoffset) fixed bin; dcl code fixed bin (35); dcl w (0 : 7) fixed bin based; dcl flt_ln char (100); dcl flt_bf char (24) varying; dcl iocbp ptr; dcl (length, fixed, addr, addrel, baseptr, substr, null, hbound, lbound) builtin; dcl (tsrpr, on_line) bit (1); dcl cvbinbuf char (12); dcl fltdtab (0:35) bit (1) based (byptr) unaligned; dcl cpul (0 : 7) char (1) int static options (constant) init ("a", "b", "c", "d", "e", "f", "g", "h"); dcl at_by_wd char (2); dcl (ioa_$ioa_switch, ioa_$rsnnl) entry options (variable); dcl db_print entry (ptr, char (*) aligned, ptr, char (*), fixed bin, fixed bin, ptr, fixed bin, fixed bin); dcl ol_dump_$namef_ entry (ptr, ptr) returns (char (*)); dcl interpret_ptr_ entry (ptr, ptr, ptr); dcl cv_bin_$oct entry (fixed bin, char (12)); dcl get_line_length_$switch entry (ptr, fixed bin (35)) returns (fixed bin); dcl iox_$user_output ptr ext; dcl 1 scud based (scup) aligned, 2 wd0 unaligned, /* :: */ 3 prr bit (3), /* Procedure Ring Register */ 3 psr bit (15), /* Procedure Segment Register */ 3 apust bit (18), /* APU Status */ 2 wd1 unaligned, /* :: */ 3 fid bit (20), /* fault/interrupt data */ 3 ill_act_lns bit (4), /* Illegal Action Lines */ 3 ill_act_chan bit (3), /* Illegal Action Channel (Port) */ 3 con_chan bit (3), /* Connect Channel (Port) */ 3 fi bit (6), /* Fault/Interrupt Vector Address */ 2 wd2 unaligned, /* :: */ 3 trr bit (3), /* Temporary Ring Register */ 3 tsr bit (15), /* Temporary Segment Register */ 3 mbz bit (9), /* :: */ 3 cpu bit (3), /* Processor Number */ 3 tmd bit (6), /* :: */ 2 wd3 fixed bin (35), /* :: */ 2 wd4 unaligned, /* :: */ 3 ict bit (18), /* Instruction Counter */ 3 ir bit (18), /* Indicator Register */ 2 wd5 unaligned, /* :: */ 3 ca bit (18), /* Computed Address */ 3 cus bit (12), /* CU Status */ 3 ct_hold bit (6), /* remember mod field */ 2 wd6 fixed bin (35), /* Even Instruction */ 2 wd7 fixed bin (35); /* Odd Instruction */ dcl ill_act (0:15) char (37) varying int static options (constant) init ("...", "Unasigned", "Non Existant Address", "Fault on Condition", "Unassigned", "Data Parity (Store -> SCU)", "Data Parity in Store", "Data Parity (Store -> SCU & in Store)", "Not Control", "Port Not Enabled", "Illegal Command", "Store Not Ready", "ZAC Parity (Processor -> SCU)", "Data Parity (Processor -> SCU)", "ZAC parity (SCU -> Store)", "Data Parity (SCU -> Store)"); dcl indrs (18:31) char (4) varying int static options (constant) init ("zero", "neg", "cary", "ovfl", "eovf", "eufl", "oflm", "tro", "par", "parm", "^bar", "tru", "mif", "abs"); dcl APU (18:32) char (6) varying int static options (constant) init ("priv", "xsf", "sdwamm", "sd-on", "ptwamm", "pt-on", "pi-ap", "dsptw", "sdwnp", "sdwp", "ptw", "ptw2", "fap", "fanp", "fabs"); dcl CU (18:29) char (3) varying int static options (constant) init ("rf", "rpt", "rd", "rl", "pot", "pon", "xde", "xdo", "itp", "rfi", "its", "fif"); dcl g1and7flts (5) bit (6) int static options (constant) unaligned init ("01"b3, "11"b3, "21"b3, "31"b3, "37"b3); dcl grp1flt (0:19) char (24) varying int static options (constant) init ("Illegal Ring Order", "Not in Execute Bracket", "Execute Bit off", "Not In Read Bracket", "Read Bit Off", "Not In Write Bracket", "Write Bit Off", "Not A Gate", "Not In Call Bracket", "Outward Call", "Bad Outward Call", "Inward Return", "Cross Ring Transfer", "Ring Alarm", "Associative Memory", "Out of Segment Bounds", "Processor Parity Upper", "Processor Parity Lower", "SC To Proc. Seq. Error 1", "SC To Proc. Seq. Error 2"); dcl grp2flt (0:6) char (24) varying int static options (constant) init ("Illegal Segment Number", "Illegal Op Code", "Illegal Address & Mod", "Illegal Slave Procedure", "Illegal Procedure", "Non Existant Address", "Out Of Bounds"); dcl flt_int_typ (0:63) char (24) varying int static options (constant) init ("...", "Shutdown", "...", "Store", "Bulk Store 0 Term", "MME 1", "...", "Fault Tag 1", "IOM 0 Overhead", "Timer Runout", "IOM 1 Overhead", "Command", "IOM 2 Overhead", "Derail", "IOM 3 Overhead", "Lockup", "IOM 0 Terminate Ch 40-77", "Connect", "IOM 1 Terminate Ch 40-77", "Parity", "Bulk Store 1 Term", "Illegal Procedure", "...", "Op Not Complete", "IOM 0 Terminate", "Startup", "IOM 1 Terminate", "Overflow", "IOM 2 Terminate", "Divide Check", "IOM 3 Terminate", "Execute", "IOM 0 Marker Ch 40-77", "(DF0) Segment", "IOM 1 Marker Ch 40-77", "(DF1) Page", "...", "Directed Fault 2", "...", "Directed Fault 3", "IOM 0 Marker", "Access Violation", "IOM 1 Marker", "MME 2", "IOM 2 Marker", "MME 3", "IOM 3 Marker", "MME 4", "...", "(FT2) Linkage", "...", "Fault Tag 3", "...", "...", "...", "...", "IOM 0 Special", "...", "IOM 1 Special", "...", "IOM 2 Special", "...", "IOM 3 Special", "Trouble"); dcl TAG_ptr ptr; /* pointer to tag table */ dcl tag_prt bit (1) init ("0"b); dcl tag_ char (4) init (""); dcl TAG_table (8) char (40) init ( /* tag table */ " au qu du ic al ql dl ", "x0 x1 x2 x3 x4 x5 x6 x7 ", "n* aau* aqu* ailtg ic* aal* aql* ailtg ", "0* a1* a2* a3* a4* a5* a6* a7* a", "fi itp iltg its sd scr f2 f3 ", "ci i sc ad di dic aid idc a", "*n *au *qu iltg *ic *al *ql iltg ", "*0 *1 *2 *3 *4 *5 *6 *7 "); dcl 1 TAG (64) based (TAG_ptr), 2 code char (4) unal, 2 pad bit (8) unal, 2 chain bit (1); /* */ /* on_line - entry to display scu data from a live on line system */ on_line: entry (a_iocbp, scup, lg_sw); on_line = "1"b; /* set switch for this entry */ reoffset = fixed (rel (scup)); /* form relitive offset */ go to common; /* join common code */ /* dump - entry to display scu data within a dump segment */ dump: entry (a_iocbp, scup, a_offset, lg_sw, odsp); on_line = "0"b; reoffset = a_offset; /* copy relative offset */ common: if a_iocbp = null then /* if null iocb ptr supplied */ iocbp = iox_$user_output; /* default to user output */ else iocbp = a_iocbp; /* else use supplied switch name */ if scud.wd0.psr = "0"b then if scud.wd2.tsr = "0"b then do; call ioa_$ioa_switch (iocbp, "No SCU data stored"); return; end; inst6 = reoffset + 6; if lg_sw then /* user wants octal dump too */ call ioa_$ioa_switch (iocbp, "^6o^-^4(^w ^)^/^-^4(^w ^)^/", reoffset, scup -> w (0), scup -> w (1), scup -> w (2), scup -> w (3), scup -> w (4), scup -> w (5), scup -> w (6), scup -> w (7)); flt_ln, flt_bf = ""; tsrpr = "0"b; flt_bf = flt_int_typ (fixed (scud.wd1.fi, 6)); if substr (flt_bf, 1, 3) = "..." then call ioa_$ioa_switch (iocbp, "Fault/Interrupt (^o), Undefined", fixed (scud.wd1.fi, 6)); else do; flt_lng = length (flt_int_typ (fixed (scud.wd1.fi, 6))); substr (flt_ln, 1, flt_lng) = substr (flt_bf, 1, flt_lng); byptr = addrel (scup, 1); if fltdtab (35) = "1"b then do; substr (flt_ln, flt_lng + 2, 5) = "Fault"; lnpos = flt_lng + 8; do i = 1 to hbound (g1and7flts, 1); /* If grp 1 or 7 faults, don't print out tsr|ca */ if scud.wd1.fi = g1and7flts (i) then tsrpr = "1"b; end; end; else do; substr (flt_ln, flt_lng + 2, 9) = "Interrupt"; lnpos = flt_lng + 12; tsrpr = "1"b; /* don't print out tsr|ca for interrupts */ end; flt_lng = fixed (scud.wd1.fi, 6); call cv_bin_$oct (flt_lng, cvbinbuf); substr (flt_ln, lnpos, 4) = "(" || substr (cvbinbuf, 11, 2) || ")"; lnpos = lnpos + 4; j = lnpos; do i = 0 to hbound (grp1flt, 1); if fltdtab (i) then do; if substr (flt_ln, 1, 5) = "Store"|substr (flt_ln, 1, 12) = "Illegal Proc" then if i <= 6 then call ioa_$rsnnl ("^a, ^a", flt_ln, j, flt_ln, grp2flt (i)); else; else call ioa_$rsnnl ("^a, ^a", flt_ln, j, flt_ln, grp1flt (i)); end; end; call ioa_$ioa_switch (iocbp, "^a", flt_ln); end; if ill_act_lns ^= "0"b then do; /* display illegal action lines if present */ call ioa_$ioa_switch (iocbp, "Illegal Action Code (^o) - ^a", fixed (scud.wd1.ill_act_lns, 4), ill_act (fixed (scud.wd1.ill_act_lns, 4))); end; if tsrpr then at_by_wd = "At"; /* if not printing tsr */ else at_by_wd = "By"; byptr = addrel (baseptr (fixed (scud.wd0.psr, 18)), fixed (scud.wd4.ict, 18)); if ^tsrpr then refptr = addrel (baseptr (fixed (scud.wd2.tsr, 18)), fixed (scud.wd5.ca, 18)); if ^on_line then do; /* if we are looking at a dump */ call ioa_$ioa_switch (iocbp, "^a: ^p ^a", at_by_wd, byptr, ol_dump_$namef_ (byptr, odsp)); if ^tsrpr then /* if we want to print out tsr|ca */ call ioa_$ioa_switch (iocbp, "Referencing: ^p ^a", refptr, ol_dump_$namef_ (refptr, odsp)); end; else do; /* if printing on line info */ strp = addr (strbuf); call interpret_ptr_ (byptr, null, strp); /* get on line name */ call ioa_$ioa_switch (iocbp, "^a: ^p ^a^a|^a ^a ^a", at_by_wd, byptr, struc.segment, struc.entryn, struc.offset, struc.modifier, struc.comment); if ^tsrpr then do; /* if we want to print out tsr|ca */ call interpret_ptr_ (refptr, null, strp); call ioa_$ioa_switch (iocbp, "Referencing: ^p ^a^a|^a ^a ^a", refptr, struc.segment, struc.entryn, struc.offset, struc.modifier, struc.comment); end; end; call ioa_$ioa_switch (iocbp, "On: cpu ^a (#^o)", cpul (fixed (scud.wd2.cpu, 3)), fixed (scud.wd2.cpu, 3)); flt_ln = ""; byptr = addr (scud.wd4); /* display Indicator register if any bits present */ do i = lbound (indrs, 1) to hbound (indrs, 1); if fltdtab (i) then call ioa_$rsnnl ("^a ^a,", flt_ln, j, flt_ln, indrs (i)); end; if flt_ln ^= "" then do; substr (flt_ln, j, 1) = " "; call ioa_$ioa_switch (iocbp, "Indicators: ^a", flt_ln); flt_ln = ""; end; byptr = addr (scud.wd0); /* display interpreted APU status if any bits present */ do i = lbound (APU, 1) to hbound (APU, 1); if fltdtab (i) then call ioa_$rsnnl ("^a ^a,", flt_ln, j, flt_ln, APU (i)); end; if flt_ln ^= "" then do; substr (flt_ln, j, 1) = " "; call ioa_$ioa_switch (iocbp, "APU Status: ^a", flt_ln); flt_ln = ""; end; byptr = addr (scud.wd5); /* display interprted CU status if any bits present */ do i = lbound (CU, 1) to hbound (CU, 1); if fltdtab (i) then call ioa_$rsnnl ("^a ^a,", flt_ln, j, flt_ln, CU (i)); end; TAG_ptr = addr (TAG_table); i = fixed (wd5.ct_hold); if i ^= 0 then do; tag_ = TAG.code (i+1); tag_prt = "1"b; end; if (flt_ln ^= "") | (tag_ ^= "") then do; substr (flt_ln, j, 1) = " "; call ioa_$ioa_switch (iocbp, "CU Status: ^a ^[^/CT Hold: ^a^]", flt_ln, tag_prt, tag_); end; call ioa_$ioa_switch (iocbp, "Instructions: "); /* display Instructions (words 6 & 7) */ call db_print (iocbp, iocbp -> iocb.name, addr (scud.wd6), "i", inst6, 1, null, 0, 0); call db_print (iocbp, iocbp -> iocb.name, addr (scud.wd7), "i", inst6 + 1, 1, null, 0, 0); /* */ % include iocb; end prtscu_;  trace_stack.pl1 10/03/83 1732.6rew 10/03/83 1009.6 33822 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4,delnl,insnl,tree,ifthenstmt,indnoniterend */ trace_stack: ts: procedure options (variable); /* TRACE_STACK - Produce output on the console for debugging. Arguments are: . -bf, -brief short output . -long, -lg print octal dump . -depth N, -dh N go back N frames only . -stack_ptr P, -sp P start with stack frame at P This program is just a small command driver for the guts subroutine "trace_stack_". THVV 7/70 */ /* Modified March 1981 by C. Hornig to fix argument parsing bugs. */ dcl ME char (32) static options (constant) init ("trace_stack"); dcl argl fixed bin (21), /* length of arg */ bchr char (argl) based (tp), /* for looking at argument */ nargs fixed bin, /* number of arguments */ argno fixed bin, /* steps thru argument list to command */ mode fixed bin init (1), /* output verbosity */ depth fixed bin init (-1), /* number of frames to trace back */ stackp ptr, /* pointer to ts's stack frame */ tp ptr, /* work pointer */ ec fixed bin (35); /* file-system error code */ dcl error_table_$badopt fixed bin (35) ext; dcl error_table_$bad_conversion fixed bin (35) ext static; dcl com_err_ entry options (variable), find_condition_frame_ entry (ptr) returns (ptr), trace_stack_ entry (ptr, fixed bin, fixed bin, char (32) aligned), cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin), cv_ptr_ entry (char (*), fixed bin (35)) returns (ptr), cu_$arg_count entry (fixed bin, fixed bin (35)), cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)), ioa_ entry options (variable); dcl null builtin; %page; call cu_$arg_count (nargs, ec); /* get argument count */ if ec ^= 0 then do; call com_err_ (ec, ME, "Usage: ts {-bf|-lg} {-dh N} {-sp PTR}"); return; end; stackp = find_condition_frame_ (null ()); /* default to this stack frame */ do argno = 1 to nargs; call cu_$arg_ptr (argno, tp, argl, ec); /* look at all arguments */ if ec ^= 0 then go to endarg; if /* case */ (bchr = "-long") | (bchr = "-lg") then mode = 2; else if (bchr = "-brief") | (bchr = "-bf") then mode = 0; else if (bchr = "-depth") | (bchr = "-dh") then do; argno = argno + 1; call cu_$arg_ptr (argno, tp, argl, ec); if ec ^= 0 then do; call com_err_ (ec, ME, "A number must follow -depth."); return; end; depth = cv_dec_check_ (bchr, ec); if ec ^= 0 then do; call com_err_ (error_table_$bad_conversion, ME, """^a""", bchr); return; end; end; else if (bchr = "-sp") | (bchr = "-stack_ptr") then do; argno = argno + 1; call cu_$arg_ptr (argno, tp, argl, ec); if ec ^= 0 then do; call com_err_ (ec, ME, "A virtual pointer must follow -stack_ptr."); return; end; stackp = cv_ptr_ (bchr, ec); if ec ^= 0 then do; call com_err_ (ec, ME, """^a""", bchr); return; end; end; else do; call com_err_ (error_table_$badopt, ME, """^a""", bchr); return; end; end; endarg: call trace_stack_ (stackp, mode, depth, "user_output"); if mode > 0 then call ioa_ ("End of trace.^/"); return; end trace_stack;  trace_stack_.pl1 11/05/86 1346.8r w 11/04/86 1041.7 77067 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4,delnl,insnl,tree,ifthenstmt,indnoniterend */ trace_stack_: procedure (stackp, mode, depth, stream); /* TRACE_STACK_ - Subroutine to produce debugging output on console. 1. explanation of fault 2. source line which caused fault (if determinable, otherwise faulting instruction) 3. machine registers at time of fault 4. listing of stack frames, in reverse order from faulting frame. 4.a. segment name and entry point name 4.b. source line or instruction 4.c. arguments to stack frame 4.d. enabled on-units 4.e. octal dump of frame The original idea for this program came from a remark of Bob Daley's. This program owes a great deal to Steve Webber, Melanie Weaver, and Barry Wolman. THVV 7/70 */ /**** Modified 1985-01-15, BIM: pass signal_io_, max number of errors permitted. */ /**** Modified 1985-03-06, BIM: added subroutine that does history regs. */ dcl stackp ptr, /* ptr to highest frame to trace from */ mode fixed bin, /* output mode */ depth fixed bin, /* number of frames to trace */ stream char (32) aligned; /* output stream */ dcl ilc uns fixed bin (18), /* offset from top of segment where instruction is */ (max_depth, cur_depth) fixed bin (17), target_sp ptr, argl fixed bin, gptr ptr, /* pointer for octal dump */ ec fixed bin (35), line_no char (16), strp ptr; /* pointer to stuff for interpret_ptr_ */ dcl fault_count fixed bin; dcl abort_label label variable; dcl ssptr pointer; dcl a_hr_switch fixed bin; dcl hr_switch fixed bin; dcl iocb ptr; dcl ( NO_HREGS init (0), HREGS init (1), HREGS_LONG init (2) ) fixed bin int static options (constant); dcl MAX_FAULT_COUNT fixed bin init (4000) int static options (constant); dcl (addr, addrel, binary, fixed, hbound, lbound, null, ptr, rel, stackframeptr) builtin; dcl (any_other, cleanup) condition; dcl dumary (8) fixed bin based (gptr); dcl 1 condinfo aligned like condition_info; dcl print_source_line_ entry (ptr, char (32) aligned), find_source_line_ entry (ptr, char (*), char (*), char (*), fixed bin (21), fixed bin (21), fixed bin (35)), is_condition_frame_ entry (ptr) returns (bit (1) aligned), find_condition_info_ entry (ptr, ptr, fixed bin (35)), dump_machine_cond_ entry (ptr, ptr, char (32) aligned, fixed bin), interpret_ptr_$frame_owner entry (ptr, ptr, ptr), list_frame_args_ entry (ptr, char (32) aligned), list_onunits_ entry (ptr, char (32) aligned), ioa_$ioa_stream entry options (variable); dcl condition_interpreter_ entry (ptr, ptr, fixed bin (21), fixed bin, ptr, char (*), ptr, ptr); dcl continue_to_signal_ entry (fixed bin (35)); dcl get_system_free_area_ entry () returns (ptr); dcl hran_$hranl entry (pointer, pointer, bit (1)); dcl iox_$find_iocb entry (char (*), ptr, fixed bin (35)); %page; hr_switch = NO_HREGS; go to COMMON; hregs: entry (stackp, mode, depth, stream, a_hr_switch); hr_switch = a_hr_switch; COMMON: iocb = null (); call iox_$find_iocb ((stream), iocb, (0)); condinfo.version = 1; sp, target_sp = stackp; /* copy argument - initial stack level */ if sp = null () then sp, target_sp = stackframeptr (); max_depth = depth; if max_depth < 0 then max_depth = 100000; strp = addr (strbuf); abort_label = abort_trace; on any_other call fault_handler; fault_count = 0; /* This section is the actual back-trace loop on the stack. For each frame, we call "interpret_ptr_$frame_owner" to find the owner of the frame, and then "print_source_line_" to attempt to print the source line, or the faulting instruction. Then we call "list_frame_args_" to list the arguments to the frame. */ do cur_depth = 0 to max_depth while (sp ^= null ()); condinfo.mc_ptr, condinfo.user_loc_ptr = null (); condinfo.condition_name = ""; struc.segment, struc.entryn = "?"; struc.offset, struc.comment, struc.opname = ""; line_no = ""; abort_label = no_mc; if is_condition_frame_ (sp) then do; call find_condition_info_ (sp, addr (condinfo), ec); call dump_machine_cond_ (addr (condinfo), sp, stream, mode); if condinfo.mc_ptr ^= null & hr_switch >= HREGS then do; ssptr = addwordno (condinfo.mc_ptr, -8); /* see signaller_stack.incl.pl1 */ if hr_switch = HREGS then call hran_$hranl (addr (ssptr -> signaller_stack.history_registers), iocb, "0"b); if hr_switch = HREGS_LONG then call hran_$hranl (addr (ssptr -> signaller_stack.history_registers), iocb, "1"b); end; end; no_mc: if cur_depth < max_depth then do; abort_label = no_ilc; if condinfo.mc_ptr = null () then do; ilc = binary (rel (stack_frame.return_ptr), 18); if ilc > 0 then ilc = ilc - 1; /* Get call-out location. */ condinfo.user_loc_ptr = ptr (stack_frame.return_ptr, ilc); /* STCD info is not a pointer */ end; no_ilc: abort_label = no_owner; call interpret_ptr_$frame_owner (condinfo.user_loc_ptr, sp, strp); call find_source_line_ (strp, line_no, (""), (""), (0), (0), ec); no_owner: abort_label = no_brief; call ioa_$ioa_stream (stream, "^p^13t^a^a|^a ^a ^a ^a", target_sp, struc.segment, struc.entryn, struc.offset, struc.comment, line_no, struc.opname); no_brief: if mode > 0 then do; abort_label = no_source; if struc.text_ptr ^= null () /* skip source if looks bad. */ then call print_source_line_ (strp, stream); no_source: abort_label = no_args; call list_frame_args_ (sp, stream);/* what are the arguments */ no_args: abort_label = no_units; call list_onunits_ (sp, stream); /* what handlers */ /* This next section of code dumps the stack frame in octal. Useful only under an "fo", I think. */ no_units: if mode > 1 then do; abort_label = no_long; gptr = sp; /* yes. */ argl = 0; do while (rel (gptr) < rel (stack_frame.next_sp)); /* loop through 8 words at a time */ call ioa_$ioa_stream (stream, "^6o ^5o ^w ^w ^w ^w ^w ^w ^w ^w", fixed (rel (gptr), 18), argl, dumary); argl = argl + 8; gptr = addrel (gptr, 8); end; end; no_long: abort_label = next_frame; call ioa_$ioa_stream (stream, ""); end; end; next_frame: abort_label = abort_trace; sp, target_sp = sp -> stack_frame.prev_sp; end; return; abort_trace: revert any_other; /* If we gave up, we gave up */ call ioa_$ioa_stream (stream, "Trace aborted."); return; %page; fault_handler: procedure; dcl m_ptr ptr; dcl m_len fixed bin (21); dcl msg char (m_len) based (m_ptr); dcl i fixed bin; dcl code fixed bin (35); dcl 1 ci aligned like condition_info; dcl continue_conditions (14) char (32) static options (constant) init ("endpage", "stringsize", "underflow", "command_error", "finish", "command_question", "trm_", "sus_", "cput", "alrm", "wkp_", "mme2", "quit", "signal_io_"); m_ptr = null (); on cleanup begin; if m_ptr ^= null () then do; free msg; m_ptr = null (); end; end; on any_other goto abort_trace; fault_count = fault_count + 1; if fault_count > MAX_FAULT_COUNT then goto abort_trace; call find_condition_info_ (null (), addr (ci), code); if code ^= 0 then do; continue: call continue_to_signal_ ((0)); return; end; if ci.condition_name = "cleanup" then return; do i = lbound (continue_conditions, 1) to hbound (continue_conditions, 1); if ci.condition_name = continue_conditions (i) then goto continue; end; call ioa_$ioa_stream (stream, "^a condition during trace...", ci.condition_name); call condition_interpreter_ (get_system_free_area_ (), m_ptr, m_len, 1, ci.mc_ptr, (ci.condition_name), ci.wc_ptr, ci.info_ptr); call ioa_$ioa_stream (stream, "^a", msg); free msg; goto abort_label; end fault_handler; %page; %include stack_frame; %include interpret_ptr_struc; %include condition_info; %include signaller_stack; end trace_stack_; bull_copyright_notice.txt 08/30/05 1008.4r 08/30/05 1007.3 00020025 ----------------------------------------------------------- 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