display.pl1 11/15/82 1819.8rew 11/15/82 1502.6 56799 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ di: display: proc; /* Modified: 29 November 1979 by PCK to produce tree level indented output */ dcl display_block entry(ptr,bit(1) aligned,bit(1) aligned, bit(1) aligned,fixed bin); dcl display_statement entry(ptr,bit(1) aligned,fixed bin); dcl display_source entry(ptr,fixed bin); dcl (display_array, display_list, display_exp, display_symbol) entry(ptr,fixed bin); dcl show_ms$pt entry(ptr); dcl show_statement ext entry(char(*) aligned), show_declaration ext entry(char(*) aligned,char(*) aligned), display_any_node_name ext entry(char(*) aligned,ptr,fixed bin); dcl ioa_ entry options(variable), cv_dec_ entry(char(*) aligned) returns(fixed bin), cu_$arg_count entry(fixed bin(15)), cu_$arg_ptr entry(fixed bin(15),ptr,fixed bin(15),fixed bin(15)), cu_$gen_call entry(entry,ptr), cu_$arg_list_ptr entry(ptr); dcl (k,tree_level) fixed bin; dcl (string,string2,string3) char(12) aligned; dcl display_stat_$brief_display bit(1) ext static; dcl argstring char(arglen) based(argpt); dcl (code,arglen) fixed bin(15), (ap1,argpt) pointer; dcl (addr,baseptr,fixed,index,min,null,ptr,substr) builtin; dcl program_interrupt condition; dcl p ptr, (no_dcls,sourceb,walk) bit(1) aligned, (i,j,n) fixed bin(15), (pl1_stat_$root,pl1_stat_$cur_block,pl1_stat_$cur_statement) ptr ext, cv_oct_ entry(char(*) aligned) returns(fixed); dcl disp_xeq bit(1) aligned; %include pl1_tree_areas; %include token_list; %include token_types; %include source_list; %include nodes; dcl based_ptr ptr based; dcl 1 arglist based, 2 number bit(17), 2 filler fixed, 2 arg(1) ptr; %include block; /*eject */ begin: disp_xeq = "0"b; common: on condition(program_interrupt) goto done; no_dcls, sourceb, walk = "0"b; tree_level = 0; call cu_$arg_count(i); if i = 0 then do; call ioa_("display | di -options-^/^a^/^a", "options are: root | main | cur_block | cur_statement (walk) (no_dcls) (source)", " brief | long token_list (_n)"); call ioa_( " source_list (_n) (min'ed with pl1_stat_$last_source) arg arg# offset# seg#|offset# (default seg is tree_) statement file#.line#.statement# dcl iden1 iden2 ... (10 max)"); return; end; call cu_$arg_ptr(1,argpt,arglen,code); ap1=argpt; string=argstring; if substr(string,1,4) = "dcl " then go to show_dcl; if substr(string,1,8) = "brief " then do; display_stat_$brief_display = "1"b; return; end; if substr(string,1,8) = "long " then do; display_stat_$brief_display = "0"b; return; end; call cu_$arg_ptr(2,argpt,arglen,code); if code ^= 0 then string2=""; else string2=argstring; call cu_$arg_ptr(3,argpt,arglen,code); if code ^= 0 then string3=""; else string3=argstring; if substr(string,1,8) = "source_l" then go to source_list_; if substr(string,1,8) = "token_li" then go to token_list_; if substr(string,1,8) = "statemen" then go to show_stm; if substr(string,1,4) = "root" then p = pl1_stat_$root; else if substr(string,1,8) = "cur_bloc" then p = pl1_stat_$cur_block; else if substr(string,1,8) = "cur_stat" then p = pl1_stat_$cur_statement; else if substr(string,1,4) = "main" then if pl1_stat_$root ^= null then p = pl1_stat_$root -> block.son; else goto null_ptr; else if substr(string,1,4) = "arg " then do; n = cv_oct_(string2); p = addr(p); p = ptr(p,cv_oct_(string3)); if n > fixed(p -> arglist.number,17) then do; call ioa_("no arg ^d",n); return; end; p = p -> arglist.arg(n) -> based_ptr; end; else do; if disp_xeq then p = pl1_stat_$xeq_tree_area_ptr; else p = pl1_stat_$root; n = index(string,"|"); if n = 0 then p = ptr(p,cv_oct_(string)); else p = ptr(baseptr(cv_oct_(substr(string,1,n-1))), cv_oct_(substr(string,n+1))); end; if p = null then do; null_ptr: call ioa_("Pointer is null"); return; end; if substr(string2,1,4) = "walk" then walk="1"b; else if substr(string3,1,4) = "walk" then walk="1"b; if substr(string2,1,8) = "no_dcls " then no_dcls="1"b; else if substr(string3,1,8) = "no_dcls " then no_dcls="1"b; if substr(string2,1,8) = "source " then sourceb="1"b; else if substr(string3,1,8) = "source " then sourceb="1"b; n = fixed(p -> node.type,17,0); if n > fixed(temporary_node,9,0) then n = 0; call ioa_("Displaying ^p",p); goto switch(n); switch(0): switch(7): switch(17): call display_any_node_name("No display program for",p,tree_level+1); return; switch(1): call display_block(p,walk,no_dcls,sourceb,tree_level+1); return; switch(3): switch(4): switch(5): switch(10): switch(16): switch(18): call display_exp(p,tree_level+1); return; switch(8): switch(9): call display_array(p,tree_level+1); return; switch(11): call display_list(p,tree_level+1); return; switch(2): call display_statement(p,sourceb,tree_level+1); return; switch(6): switch(12): switch(15): call display_symbol(p,tree_level+1); return; switch(13): call show_ms$pt(p); return; switch(14): call display_source(p,tree_level+1); return; show_stm: call show_statement(string2); return; show_dcl: ap1->argstring=""; /* zap "dcl" */ call cu_$arg_list_ptr(argpt); call cu_$gen_call(show_declaration,argpt); done: return; token_list_: n = cv_dec_(string2); if n = 0 then n = 3000; do k = 1 to n; if token_list(k)=null then return; if t_table.type = semi_colon & n = 3000 then return; call display_exp(token_list(k),tree_level+1); end; return; source_list_: m = pl1_stat_$last_source; n = cv_dec_(string2); if n = 0 then do; n = m; j = 0; end; else j, n = min(n,m); do i = j to n; call display_source(source_list(i),tree_level+1); end; return; dix: display_xeq: entry; disp_xeq = "1"b; go to common; end display;  display_any_node_name.pl1 11/15/82 1819.8rew 11/15/82 1502.7 13464 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ display_any_node_name: proc(string,p,tree_level); /* Modified: 26 July 1971 by PG Modified: 9 Oct 1975 by RAB Modified: 25 Dec 1977 by RAB Modified: 29 Nov 1979 by PCK to produce tree level indented output */ dcl p ptr, tree_level fixed bin, ioa_ ext entry options(variable), (fixed,hbound,null) builtin, j fixed bin(17), string char(*); dcl names(0:20) char(20) aligned int static options(constant) init( " zero"," block"," statement","n operator"," reference", " token"," symbol"," context","n array"," bound"," format value", " list"," default"," machine state"," source"," label"," cross ref", " sf par"," temporary"," label_array_element","n ILLEGAL"); %include nodes; if p = null then do; call ioa_("^/^vx^a NULL^/",tree_level,string); return; end; j = fixed(p->node.type,17,0); if j >= hbound(names,1) then j = hbound(names,1); call ioa_("^/^vx^a ^p, a^a node.^/",tree_level,string,p,names(j)); return; end display_any_node_name;  display_array.pl1 11/15/82 1819.8rew 11/15/82 1502.8 48339 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* display array|bound nodes, modified on 26 August by PAG for Version II */ /* Modified again on: 19 October 1970 PG */ /* Modified on: 2 December 1970 jk */ /* Modified on: 7 January 1971 by BLW */ /* Modified on: 25 April 1979 by PCK to implement 4-bit decimal */ /* Modified on: 29 November 1979 by PCK to display tree level indented output */ display_array: proc(a,tree_level); dcl tree_level fixed bin; dcl (a,p,b) ptr; dcl units(0:7) char(5) int aligned static init("----","bits","digit","byte","half","word","mod2","mod4"); dcl i fixed bin(31); dcl c char(16) varying; dcl display_exp external entry(ptr,fixed bin), display_any_node_name ext entry(char(*) aligned,ptr,fixed bin), ioa_ entry options(variable), (fixed,null) builtin; dcl display_stat_$brief_display bit(1) ext static; dcl boundary_type(7) char(5) aligned int static init("bit", "digit", "byte", "half", "word", "mod2", "mod4"); %include array; %include nodes; begin: p = a; if p = null then do; call ioa_("^/^vxdisplay_array: ptr is NULL^/",tree_level); return; end; if p -> node.type = bound_node then do; call display_bounds(p,tree_level+1); return; end; if p -> node.type ^= array_node then do; call display_any_node_name("display_array: arg is not an array node, arg =",p,tree_level+1); return; end; if p -> array.interleaved then c = " is interleaved"; else c = ""; call ioa_("^/^vxARRAY ^p^a, dimensions = ^d",tree_level,p,c,p -> array.number_of_dimensions); i=p->array.own_number_of_dimensions; if i ^= 0 then call ioa_("^vxown_number_of_dimensions = ^d",tree_level,i); i = p -> array.element_boundary; if i ^= 0 then call ioa_("^vxelement boundary is ^a",tree_level,(boundary_type(i))); i = p -> array.size_units; if i ^= 0 then call ioa_("^vxsize units are ^a",tree_level,(boundary_type(i))); call ioa_("^vxoffset units are ^a",tree_level,units(p->array.offset_units)); b=p->array.element_descriptor; if b ^= null then call show_exp("element descriptor",tree_level); b=p->array.virtual_origin; if b ^= null then call show_exp("virtual origin",tree_level); b = p -> array.symtab_virtual_origin; if b ^= null then call show_exp("symtab virtual origin",tree_level); i=p->array.c_virtual_origin; if i ^= 0 then call ioa_("^vxc_virtual_origin = ^d",tree_level,i); b=p->array.element_size; if b ^= null then call show_exp("element size",tree_level); b = p -> array.symtab_element_size; if b ^= null then call show_exp("symtab element size",tree_level); i=p->array.c_element_size; if i ^= 0 then call ioa_("^vxc_element_size = ^d",tree_level,i); b=p->array.element_size_bits; if b ^= null then call show_exp("bit element size",tree_level); i=p->array.c_element_size_bits; if i ^= 0 then call ioa_("^vxc_element_size_bits = ^d",tree_level,i); p=p->array.bounds; call ioa_("^vxbounds of ARRAY ^p:",tree_level,p); call display_bounds(p,tree_level+1); call ioa_("^vxEND ARRAY ^p^/",tree_level,p); return; display_bounds: procedure (s,tree_level); dcl (p,s) ptr; dcl tree_level fixed bin; p=s; test_bounds: if p = null then do; call ioa_("^/^vxbounds ptr is NULL^/b",tree_level); return; end; if p->node.type ^= bound_node then do; call display_any_node_name("display_array: arg is not a bound node, arg =",p,tree_level+1); return; end; next: if p = null then return; call ioa_("^/^vxBOUND ^p",tree_level,p); b = p->bound.lower; if b ^= null then call show_exp("lower bound",tree_level); i=p->bound.c_lower; if i ^= 0 then call ioa_("^vxc_lower bound = ^d",tree_level,i); b=p->bound.upper; if b ^= null then call show_exp("upper bound",tree_level); i=p->bound.c_upper; if i ^= 0 then call ioa_("^vxc_upper bound = ^d",tree_level,i); b=p->bound.multiplier; if b ^= null then call show_exp("multiplier",tree_level); i=p->bound.c_multiplier; if i ^= 0 then call ioa_("^vxc_multiplier = ^d",tree_level,i); b=p->bound.desc_multiplier; if b ^= null then call show_exp("descriptor multiplier",tree_level); i=p->bound.c_desc_multiplier; if i ^= 0 then call ioa_("^vxc_desc_multiplier = ^d",tree_level,i); b = p -> bound.symtab_lower; if b ^= null then call show_exp("symtab lower",tree_level); b = p -> bound.symtab_upper; if b ^= null then call show_exp("symtab upper",tree_level); b = p -> bound.symtab_multiplier; if b ^= null then call show_exp("symtab multiplier",tree_level); call ioa_("^vxEND BOUND ^p^/",tree_level,p); p = p->bound.next; go to next; end display_bounds; show_exp: proc(mess,tree_level); dcl tree_level fixed bin; dcl mess char(*) aligned; if display_stat_$brief_display then call ioa_("^vx^a = ^p",tree_level,mess,b); else do; call ioa_("^vx^a exp follows",tree_level,mess); call display_exp(b,tree_level+1); call ioa_("^vx^a ended",tree_level,mess); end; end; end;  display_block.pl1 11/15/82 1819.8rew 11/15/82 1502.8 91746 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ display_block: procedure(node_ptr,walk,no_dcls,source,tree_level); /* Modified on: 11 August 1971 by PG */ /* Modified on: 22 September 1971 by PAB */ /* Modified on: 28 February 1978 by PCK for options(main) */ /* Modified on: 29 November 1979 by PCK to display output with tree level indentation */ dcl (p, q, node_ptr) ptr; dcl (addr, fixed, null, length, string, substr) builtin; dcl display_exp entry(ptr,fixed bin); dcl display_any_node_name ext entry(char(*) aligned,ptr,fixed bin), display_statement ext entry(ptr,bit(1) aligned,fixed bin), display_symbol ext entry(ptr,fixed bin), display_block ext entry(ptr,bit(1) aligned,bit(1) aligned,bit(1) aligned,fixed bin), ioa_ ext entry options(variable), decode_node_id entry(ptr,bit(1) aligned) returns(char(120) varying), convert_binary_integer_$decimal_string entry(fixed bin(15)) returns(char(12) varying), ii fixed bin(18), tree_level fixed bin, (no_dcls,source,walk) bit(1) aligned, (i,j) fixed bin(17); dcl display_stat_$brief_display bit(1) ext static; dcl context_bits(20) bit(1) unaligned based(addr(q->context.types)), context_bit_names(20) char(11) aligned int static init( "structure","fixed","float","bit","char","ptr","offset","area","label", "entry","file","label_const","entry_const","file_const","condition", "format","builtin","generic","picture","parameter"); dcl n fixed bin(15); dcl btype char(12), block_type(6) char(12) int static init(" root block", "n ext proc", "n int proc", " begin block", "n on unit", " quick sub"), itype fixed bin(15); dcl bit_names(5) char(16) static varying init("like ", "no_stack ", "get_data ", "flush_at_call ", "text_displayed "); dcl nonquick_reasons (13) char (24) internal static varying init ("auto_adjustable ", "returns_star ", "stack_extended ", "invoked_by_format ", "format_stmt ", "io_stmts ", "assigned_to_entry_var ", "condition_stmts ", "no_owner ", "recursive_call ", "options_non_quick ", "options_variable ", "never_referenced "); dcl line char(80) varying, word bit(36) unaligned based, b36 bit(36) aligned; dcl pl1_stat_$constant_list ptr ext static, pl1_stat_$defined_list ptr ext static, pl1_stat_$temporary_list ptr ext static; %include token; %include block; %include default; %include list; %include statement; %include symbol; %include context; %include nodes; /*eject */ p=node_ptr; start: if p=null then do; call ioa_("^vxblock ptr is NULL",tree_level); go to ret; end; if p->node.type^=block_node then do; call display_any_node_name("display_block: arg is not a block node, arg =",p,tree_level+1); go to ret; end; itype= fixed(p->block.block_type,9); if itype<=6 & itype>=1 then btype=block_type(itype); else btype = convert_binary_integer_$decimal_string(itype); call ioa_("^/^vxBLOCK ^p is a^a",tree_level,p,btype); call ioa_("^vx^a",tree_level,decode_node_id(p,"0"b)); i=p->block.level; if i ^= 0 then call ioa_("^vxlevel = ^d",tree_level,i); ii=p->block.symbol_block; if ii ^= 0 then call ioa_("^vxruntime symbol block is ^6w",tree_level,ii); i = p -> block.last_auto_loc; if i ^= 0 then call ioa_("^vxlast auto loc = ^6w",tree_level,i); i = p -> block.number_of_entries; if i ^= 0 then call ioa_("^vxnumber of entries = ^d",tree_level,i); call ioa_("^vxprefix = ^4o",tree_level,fixed(p->block.prefix,12)); call ioa_("^vxfather = ^p",tree_level,p->block.father); if p->block.options_main then call ioa_("^vxoptions_main",tree_level); line = ""; b36 = addr(p -> block.like_attribute) -> word; do i = 1 to hbound(bit_names,1); if substr(b36,i,1) then line = line || bit_names(i); end; if length(line) ^= 0 then call ioa_("^vx^a",tree_level,line); line = "nonquick reasons: "; do i = 1 to hbound (nonquick_reasons, 1); if substr (string (p -> block.why_nonquick), i, 1) = "1"b then do; if length (line) + length (nonquick_reasons (i)) > 80 then do; call ioa_ ("^vx^a",tree_level,line); line = " "; end; line = line || nonquick_reasons (i); end; end; if length (line) > length ("nonquick reasons: ") then call ioa_ ("^vx^a",tree_level,line); call ioa_("^vxnumber = ^d",tree_level,p->block.number); if p->block.owner ^= null then call ioa_("^vxowner = ^p",tree_level,p->block.owner); q = p -> block.return_values; if q^=null then do; if display_stat_$brief_display then call ioa_("^vxreturn values = ^p",tree_level,q); else do; call ioa_("^vxreturn values:",tree_level); do while(q^=null); call display_exp((q->list.element(2)),tree_level+1); q=q->list.element(1); end; end; end; q = p -> block.return_count; if q^=null then do; if display_stat_$brief_display then call ioa_("^vxreturn count = ^p",tree_level,q); else do; call ioa_("^vxreturn count:",tree_level); call display_exp(q,tree_level+1); end; end; do i = 1 to 3; q = p -> block.free_temps(i); if q ^= null then call ioa_("^vxfree temps(^d) = ^p",tree_level,i,q); end; i = p -> block.enter.start; j = p -> block.enter.end; if i + j ^= 0 then call ioa_("^vxenter.start = ^o, enter.end = ^o",tree_level,i,j); i = p -> block.leave.start; j = p -> block.leave.end; if i + j ^= 0 then call ioa_("^vxleave.start = ^o, leave.end = ^o",tree_level,i,j); q = p -> block.entry_list; if q ^= null then call ioa_("^vxentry list = ^p",tree_level,q); q=p->block.plio_ps; if q ^= null then call ioa_("^vxplio_ps= ^p",tree_level,q); q=p->block.plio_fa; if q ^= null then call ioa_("^vxplio_format_area= ^p",tree_level,q); q=p->block.plio_ffsb; if q ^= null then call ioa_("^vxplio_ffsb= ^p",tree_level,q); q=p->block.plio_ssl; if q ^= null then call ioa_("^vxplio_ssl= ^p",tree_level,q); q=p->block.plio_fab2; if q ^= null then call ioa_("^vxplio_fab2= ^p",tree_level,q); q = p -> block.declaration; if q = null then call ioa_("^vxno dcls",tree_level); else do; if display_stat_$brief_display | no_dcls then call ioa_("^vxdeclarations = ^p",tree_level,q); else do; call ioa_("^vxdeclarations:",tree_level); dcl_loop: call display_symbol(q,tree_level+1); q=q->symbol.next; if q^=null then go to dcl_loop; end; end; ck_context: q=p->block.context; if q = null then call ioa_("^vxno context",tree_level); else do; if display_stat_$brief_display then call ioa_("^vxcontext = ^p",tree_level,q); else do; call ioa_("^vxcontext:",tree_level); ctxt_loop: call ioa_("^vxidentifier is ^a, attributes are:",tree_level,q->context.token->token.string); do i = 1 to 20; if context_bits(i) then call ioa_("^vx^a",tree_level,context_bit_names(i)); end; q=q->context.next; if q^=null then go to ctxt_loop; end; end; if p->block.father=null then do; if pl1_stat_$constant_list^=null then do; if display_stat_$brief_display then call ioa_("^vxconstants = ^p",tree_level,pl1_stat_$constant_list); else do; call ioa_("^vxconstants:",tree_level); q=pl1_stat_$constant_list; do while(q^=null); call display_symbol(q,tree_level+1); q=q->symbol.multi_use; end; end; end; if pl1_stat_$temporary_list^=null then do; if display_stat_$brief_display then call ioa_("^vxtemporaries = ^p",tree_level,pl1_stat_$temporary_list); else do; call ioa_("^vxtemporaries:",tree_level); q=pl1_stat_$temporary_list; do while(q^=null); call display_symbol(q,tree_level+1); q=q->symbol.multi_use; end; end; end; if pl1_stat_$defined_list ^= null then do; if display_stat_$brief_display then call ioa_("^vxdefined overlays = ^p",tree_level,pl1_stat_$defined_list); else do; call ioa_("^vxdefined overlays:",tree_level); do q = pl1_stat_$defined_list repeat q -> symbol.multi_use while(q ^= null); call display_symbol(q,tree_level+1); end; end; end; end; q=p->block.default; if q^=null then do; if display_stat_$brief_display then call ioa_("^vx^vxdefaults = ^p",tree_level,tree_level,q); else do; call ioa_("^vxdefault:",tree_level); default_loop: call display_symbol(q,tree_level+1); q=q->default.next; if q^=null then go to default_loop; end; end; q = p -> block.prologue; if q = null then call ioa_("^vxno prologue",tree_level); else do; if display_stat_$brief_display then call ioa_("^vxprologue = ^p",tree_level,q); else do; call ioa_("^vxprologue:",tree_level); pro_loop: call display_statement(q,"0"b,tree_level+1); q=q->statement.next; if q^=null then go to pro_loop; end; end; q = p -> block.main; if q = null then call ioa_("^vxno main",tree_level); else do; if display_stat_$brief_display then call ioa_("^vxmain = ^p",tree_level,q); else do; call ioa_("^vxmain:",tree_level); main_loop: call display_statement(q,source,tree_level+1); q=q->statement.next; if q^=null then go to main_loop; end; end; q=p->block.son; if q = null then call ioa_("^vxno sons",tree_level); else if ^walk | display_stat_$brief_display then call ioa_("^vxson = ^p",tree_level,q); else do; call ioa_("^vxson:",tree_level); call display_block(q,walk,no_dcls,source,tree_level+1); end; if p->block.brother=null then call ioa_("^vxno brothers",tree_level); else if ^walk | display_stat_$brief_display then call ioa_("^vxbrother = ^p",tree_level,p->block.brother); else do; call ioa_("^vxEND BLOCK ^p^/",tree_level,p); p=p->block.brother; call ioa_("^vxbrother:",tree_level); go to start; end; ret: call ioa_("^vxEND BLOCK ^p^/",tree_level,p); return; end display_block;  display_constant.pl1 11/15/82 1819.8rew 11/15/82 1502.9 7974 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ display_constant: proc(pt,tree_level); /* Modified: 29 November 1979 by PCK to print tree level indented output */ dcl pt ptr, tree_level fixed bin, fixed_bin fixed bin based, ioa_ entry options(variable); %include symbol; call ioa_("^/^vxCONSTANT ^p",tree_level,pt -> symbol.initial); call ioa_("^vxvalue = ^w^/",tree_level,pt -> symbol.initial -> fixed_bin); end;  display_exp.pl1 11/15/82 1819.8rew 11/15/82 1503.1 152613 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* prints expressions Modified on: 22 September 1970 by P. Green for Version II Modified on: 28 February 1978 by PCK for the stop operator Modified on: Dec 1978 by David Spector for cross_reference.set_reference bit Modified on: 25 April 1979 by PCK to implement 4-bit decimal Modified on: 17 May 1979 by RAB for reference.substr Modified on: 6 June 1979 by PG for rank and byte Modified 791017 by PG to print all info in a temporary node Modified on: 29 November 1979 by PCK to print tree level indented output Modified on: 26 Dec 1979 by PCK for by name assignment Modified on: 23 March 1980 by RAB for reference.(padded aligned)_for_store_ref Modified on: 24 June 1980 by PCK to correctly indent list nodes Modified on: 27 June 1980 by PCK to decode data type of reference node Modified on: 11 September 1980 by M. N. Davidoff to print temporary node info instead of garbage Modified on: 15 September 1980 by M. N. Davidoff to decode reference.address */ /* format: style3 */ display_exp: proc (a, tree_level); dcl (a, p, q, s) ptr, tree_level fixed bin, display_stat_$brief_display bit (1) ext static, display_any_node_name entry (char (*) aligned, ptr, fixed bin); dcl (binary, substr, addr, fixed, string, length, null, hbound, baseno, rel) builtin; dcl decode_node_id entry (ptr, bit (1) aligned) returns (char (120) varying), display_list entry (ptr, fixed bin), display_constant entry (ptr, fixed bin); dcl ioa_ entry options (variable); dcl ioa_$nnl entry options (variable); dcl (i, n) fixed bin (15), line char (96), lp fixed bin; dcl b36 bit (36) aligned, m fixed bin (18), word_bit bit (36) aligned based (p), op_name char (20) aligned, op_number bit (9) aligned, 1 op_number_structure based (addr (op_number)) aligned, 2 op_class bit (5) unaligned, 2 op_relative bit (4) unaligned; /* include files */ %include op_codes; %include cross_reference; %include label; %include nodes; %include symbol; %include operator; %include temporary; %include token; %include token_types; %include reference; /* internal static */ dcl units (7) char (5) int static options (constant) aligned init ("bit ", "digit", "char", "half", "word", "mod2", "mod4"); dcl bit_names (30) char (20) varying static init ("array", "varying", "shared", "put_data", "processed", "inhibit", "big_offset", "big_length", "has_modword", "padded", "aligned", "long", "forward", "ic", "temp", "defined", "evaluated", "allocate", "allocated", "aliasable", "even", "", "aggregate", "hit_zero", "dont_save", "fo_in_qual", "hard_to_load", "substr", "padded_for_store", "aligned_for_store"); dcl data_type_name (1:24) char (20) var aligned init ("real_fix_bin_1", "real_fix_bin_2", "real_flt_bin_1", "real_flt_bin_2", "complex_fix_bin_1", "complex_fix_bin_2", "complex_flt_bin_1", "complex_flt_bin_2", "real_fix_dec", "real_flt_dec", "complex_fix_dec", "complex_flt_dec", "char_string", "bit_string", "label_constant", "local_label_variable", "label_variable", "entry_variable", "ext_entry_in", "ext_entry_out", "int_entry", "int_entry_other", "unpacked_ptr", "packed_ptr") int static options (constant); dcl address_name (9) char (8) varying static init ("b0", "b1", "b2", "b3", "b4", "b5", "b6", "b7", "storage"); dcl value_name (24) char (12) varying static init ("a", "q", "aq", "string_aq", "complex_aq", "decimal_aq", "b0", "b1", "b2", "b3", "b4", "b5", "b6", "b7", "storage", "indicators", "x0", "x1", "x2", "x3", "x4", "x5", "x6", "x7"); dcl op_offset (0:20) fixed bin (15) int static initial (0, 1, 8, 15, 25, 35, 46, 61, 65, 81, 92, 108, 117, 120, 131, 137, 153, 169, 185, 194, 210); /* format: ^delnl */ dcl op_names (0:210) char (20) aligned internal static initial ( "ZERO!!", "UNUSED 1-0", /* class 1 1 */ "add", "sub", "mult", "div", "negate", "exp", "UNUSED 2-0", /* class 2 8 */ "and_bits", "or_bits", "xor_bits", "not_bits", "cat_string", "bool_fun", "UNUSED 3-0", /* class 3 15 */ "assign", "assign_size_ck", "assign_zero", "copy_words", "copy_string", "make_desc", "assign_round", "pack", "unpack", "UNUSED 4-0", /* class 4 25 */ "UNUSED 4-1", "UNUSED 4-2", "UNUSED 4-3", "less_than", "greater_than", "equal", "not_equal", "less_or_equal", "greater_or_equal", "UNUSED 5-0", /* class 5 35 */ "jump", "jump_true", "jump_false", "jump_if_lt", "jump_if_gt", "jump_if_eq", "jump_if_ne", "jump_if_le", "jump_if_ge", "jump_three_way", "UNUSED 6-0", /* class 6 46 */ "std_arg_list", "return_words", "std_call", "return_bits", "std_entry", "return_string", "ex_prologue", "allot_auto", "param_ptr", "param_desc_ptr", "std_return", "allot_ctl", "free_ctl", "stop", "mod_bit", /* class 7 61 */ "mod_byte", "mod_half", "mod_word", "bit_to_char", /* class 8 65 */ "bit_to_word", "char_to_word", "half_to_word", "word_to_mod2", "word_to_mod4", "word_to_mod8", "rel_fun", "baseno_fun", "desc_size", "bit_pointer", "index_before_fun", "index_after_fun", "verify_ltrim_fun", "verify_rtrim_fun", "digit_to_bit", "ceil_fun", /* class 9 81 */ "floor_fun", "round_fun", "sign_fun", "abs_fun", "trunc_fun", "byte", "rank", "index_rev_fun", "search_rev_fun", "verify_rev_fun", "index_fun", /* class 10 92 */ "off_fun", "complex_fun", "conjg_fun", "mod_fun", "repeat_fun", "verify_fun", "translate_fun", "UNUSED 10-8", "real_fun", "imag_fun", "length_fun", "pl1_mod_fun", "search_fun", "allocation_fun", "reverse_fun", "addr_fun", /* class 11 108 */ "addr_fun_bits", "ptr_fun", "baseptr_fun", "addrel_fun", "codeptr_fun", "environmentptr_fun", "stackbaseptr_fun", "stackframeptr_fun", "min_fun", /* class 12 117 */ "max_fun", "pos_dif_fun", "UNUSED 13-0", /* class 13 120 */ "stack_ptr", "empty_area", "UNUSED 13-3", "enable_on", "revert_on", "signal_on", "lock_fun", "stacq_fun", "clock_fun", "vclock_fun", "bound_ck", /* class 14 131 */ "range_ck", "loop", "join", "allot_based", "free_based", "UNUSED 15-0", /* class 15 137 */ "r_parn", "l_parn", "r_format", "c_format", "f_format", "e_format", "b_format", "a_format", "x_format", "skip_format", "column_format", "page_format", "line_format", "picture_format", "bn_format", "get_list_trans", /* class 16 153 */ "get_edit_trans", "get_data_trans", "put_list_trans", "put_edit_trans", "put_data_trans", "terminate_trans", "stream_prep", "record_io", "fortran_read", "fortran_write", "ftn_file_manip", "ftn_trans_loop", "put_control", "put_field", "put_field_chk", "UNUSED 17-0", /* class 17 169 */ "UNUSED 17-1", "return_value", "allot_var", "free_var", "get_file", "get_string", "put_file", "put_string", "open_file", "close_file", "read_file", "write_file", "locate_file", "do_fun", "do_spec", "rewrite_file", /* class 18 185 */ "delete_file", "unlock_file", "lock_file", "UNUSED 18-4", "refer", "prefix_plus", "nop", "assign_by_name", "sqrt_fun", /* class 19 194 */ "sin_fun", "sind_fun", "cos_fun", "cosd_fun", "tan_fun", "tand_fun", "asin_fun", "asind_fun", "acos_fun", "acosd_fun", "atan_fun", "atand_fun", "log2_fun", "log_fun", "log10_fun", "exp_fun"); /* class 20 (end) 210 */ /* format: revert */ /* program */ p = a; if p = null then do; call ioa_ ("^/^vxdisplay_exp: pointer is NULL^/", tree_level); return; end; if p -> node.type = token_node then do; call ioa_ ("^/^vxTOKEN ^p is ^a", tree_level, p, p -> token.string); if p -> token.type = bit_string then call ioa_ ("^vxtype is bit_string", tree_level); else if p -> token.type = char_string then call ioa_ ("^vxtype is char_string", tree_level); call ioa_ (""); return; end; if p -> node.type = block_node then do; call ioa_ ("^/^vxBLOCK ^p^/", tree_level, p); return; end; if p -> node.type = label_node then do; call ioa_ ("^/^vxLABEL ^p is ^a^/", tree_level, p, p -> label.token -> token.string); return; end; if p -> node.type = cross_reference_node then do; do p = p repeat p -> cross_reference.next while (p ^= null); call ioa_ ("^/^vxXREF ^p, ^a^[ set^]^/", tree_level, p, decode_node_id (p, "0"b), p -> cross_reference.set_reference); end; return; end; if p -> node.type = symbol_node then do; call ioa_ ("^/^vxSYMBOL ^p is ^a^/", tree_level, p, p -> symbol.token -> token.string); return; end; if p -> node.type = reference_node then do; s, q = p -> reference.symbol; if s = null then call ioa_ ("^/^vxREFERENCE ^p", tree_level, p); else do; if q -> node.type = symbol_node | q -> node.type = label_node then q = q -> symbol.token; else ; /* is already token from parse */ call ioa_$nnl ("^/^vxREFERENCE ^p is ^a, symbol is ^p", tree_level, p, q -> token.string, p -> reference.symbol); if p -> reference.data_type ^= 0 then call ioa_$nnl (", data type is ^d (^a)", p -> reference.data_type, data_type_name (p -> reference.data_type)); call ioa_ (""); if s -> node.type = symbol_node then if s -> symbol.constant & ^s -> symbol.entry & s -> symbol.initial ^= null then call display_constant (s, tree_level + 1); end; m = p -> reference.c_offset; if m ^= 0 then call ioa_ ("^vxc_offset = ^d", tree_level, m); m = p -> reference.c_length; if m ^= 0 then call ioa_ ("^vxc_length = ^d", tree_level, m); b36 = substr (p -> word_bit, 10, 5) || p -> reference.inhibit || string (p -> reference.other) || string (p -> reference.bits) || string (p -> reference.more_bits); if b36 ^= "0"b then do; line = ""; lp = 1; do i = 1 to hbound (bit_names, 1); if substr (b36, i, 1) then do; n = length (bit_names (i)); if n > 0 then do; substr (line, lp, n) = bit_names (i); lp = lp + n + 1; if lp > 72 then do; call ioa_ ("^vx^a", tree_level, line); lp = 1; line = ""; end; end; end; end; if lp > 1 then call ioa_ ("^vx^a", tree_level, line); end; if ^p -> reference.no_address then call ioa_ ( "^vx^[perm ^]address = ^[^spr^.3b|^;^[^s^;(base = ^.3b)^] ^]^.3b^a^[^s^; (tag = ^.3b)^]^[ inhibit^]^[^s^; (op = ^.3b)^]" , tree_level, p -> reference.perm_address, p -> reference.address.ext_base, p -> reference.address.base = ""b, p -> reference.address.base, p -> reference.address.offset, decode_tag (p -> reference.address.tag), p -> reference.address.tag = ""b, p -> reference.address.tag, p -> reference.address.inhibit, p -> reference.address.op = ""b, p -> reference.address.op); b36 = string (p -> reference.address_in); if b36 ^= "0"b then do; line = "address is in:"; lp = 16; do i = 1 to length (string (p -> reference.address_in)); if substr (b36, i, 1) then do; n = length (address_name (i)); substr (line, lp, n) = address_name (i); lp = lp + n + 1; end; end; call ioa_ ("^vx^a", tree_level, line); end; b36 = string (p -> reference.value_in); if b36 ^= "0"b then do; line = "value is in:"; lp = 14; do i = 1 to length (string (p -> reference.value_in)); if substr (b36, i, 1) then do; n = length (value_name (i)); substr (line, lp, n) = value_name (i); lp = lp + n + 1; if lp > 72 then do; call ioa_ ("^vx^a", tree_level, line); lp = 1; line = ""; end; end; end; if lp > 1 then call ioa_ ("^vx^a", tree_level, line); end; i = p -> reference.ref_count; if i ^= 0 then call ioa_ ("^vxreference count = ^d", tree_level, i); m = fixed (p -> reference.units, 3); if m ^= 0 then call ioa_ ("^vxunits = ^a", tree_level, units (m)); i = fixed (p -> reference.store_ins, 18); if i ^= 0 then call ioa_ ("^vxstored into at ^6w", tree_level, i); q = p -> reference.offset; if q ^= null then call show_exp ("offset"); q = p -> reference.length; if q ^= null then call show_exp ("length"); q = p -> reference.qualifier; if q ^= null then call show_exp ("qualifier"); q = p -> reference.subscript_list; if baseno (q) ^= (18)"0"b then if q ^= null then call show_exp ("subscript list"); else ; else do; i = fixed (rel (q), 18); if i ^= 0 then call ioa_ ("^vxfractional offset is ^6w", tree_level, i); end; call ioa_ ("^vxEND REFERENCE ^p^/", tree_level, p); return; end; if p -> node.type = list_node then do; call display_list (p, tree_level); return; end; if p -> node.type = temporary_node then do; call ioa_ ("^/^vxTEMPORARY ^p", tree_level, p); call ioa_ ("^vxnext = ^p", tree_level, p -> temporary.next); call ioa_ ("^vxsize = ^d", tree_level, p -> temporary.size); call ioa_ ("^vxlocation = sp|^6w", tree_level, (p -> temporary.location)); call ioa_ ("^vxref_count = ^d", tree_level, p -> temporary.ref_count); call ioa_ ("^vxsymbol = ^p", tree_level, p -> temporary.symbol); call ioa_ ("^vxlast_freed = ^6w", tree_level, (p -> temporary.last_freed)); call ioa_ ("^vxEND TEMPORARY ^p^/", tree_level, p); return; end; if p -> node.type ^= operator_node then do; call display_any_node_name ("display_exp: arg node not handled by display_exp, arg =", p, tree_level + 1); return; end; n = p -> operator.number; op_number = p -> operator.op_code; op_name = op_names (op_offset (fixed (op_class, 5)) + fixed (op_relative, 4)); line = ""; lp = 1; if p -> operator.shared then do; substr (line, lp, 6) = "shared"; lp = lp + 7; end; if p -> operator.optimized then do; substr (line, lp, 9) = "optimized"; lp = lp + 10; end; if p -> operator.processed then do; substr (line, lp, 9) = "processed"; lp = lp + 10; end; if lp = 1 then call ioa_ ("^/^vxOPERATOR ^p is ^a, ^d operands", tree_level, p, op_name, n); else call ioa_ ("^/^vxOPERATOR ^p is ^a, (^va), ^d operands", tree_level, p, op_name, lp - 2, line, n); do i = 1 to n; if p -> operator.operand (i) = null then call ioa_ ("^vxOPERAND (^d) of ^p = NULL", tree_level, i, p); else do; call ioa_ ("^vxOPERAND (^d) of ^p =", tree_level, i, p); call display_exp ((p -> operator.operand (i)), tree_level + 1); end; end; if n ^= 0 then call ioa_ ("^vxEND OPERATOR ^p, ^d operands^/", tree_level, p, n); else call ioa_ (""); return; show_exp: proc (message); dcl message char (*); if display_stat_$brief_display then call ioa_ ("^vx^a exp = ^p", tree_level, message, q); else do; call ioa_ ("^vx^a follows:", tree_level, message); call display_exp (q, tree_level + 1); call ioa_ ("^vx^a ended", tree_level, message); end; end show_exp; decode_tag: procedure (tag) returns (char (4) varying); dcl tag bit (6); dcl designator fixed bin (4); dcl designator_names (0:15) char (2) varying internal static options (constant) initial ("n", "au", "qu", "du", "ic", "al", "ql", "dl", "x0", "x1", "x2", "x3", "x4", "x5", "x6", "x7"); dcl it_designator_names (0:15) char (3) varying internal static options (constant) initial ("f1", "itp", "42", "its", "sd", "scr", "f2", "f3", "ci", "i", "sc", "ad", "di", "dic", "id", "idc"); designator = binary (substr (tag, 3), 4); goto modification (binary (substr (tag, 1, 2), 2)); modification (0): /* register (r) */ if designator = 0 then return (""); else return ("," || designator_names (designator)); modification (1): /* register then indirect (ri) */ if designator = 0 then return (",*"); else return ("," || designator_names (designator) || "*"); modification (2): /* indirect then tally (it) */ return ("," || it_designator_names (designator)); modification (3): /* indirect then register (ir) */ return (",*" || designator_names (designator)); end decode_tag; end display_exp;  display_list.pl1 11/15/82 1819.8rew 11/15/82 1503.1 13824 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ display_list: proc(q,tree_level) recursive; /* prints initial lists */ /* Modified on: 23 October 1970 by PG */ /* Modified on: 19 November 1979 by PCK to print a tree level indented listing */ dcl (p,q,r) ptr, tree_level fixed bin, (ioa_,ioa_$nnl) entry options(variable), display_any_node_name entry(char(*) aligned,ptr,fixed bin), display_exp entry(ptr,fixed bin), (i,n) fixed bin(15); dcl null builtin; %include token; %include list; %include nodes; p = q; begin: if p=null then return; if p->node.type ^= list_node then do; call display_any_node_name("display_list: arg is not a list node, arg=",p,tree_level+1); return; end; n=p->list.number; call ioa_("^/^vxLIST ^p, ^d elements",tree_level,p,n); do i=1 to n; r=p->list.element(i); if r ^= null then do; call ioa_("^vxELEMENT (^d) of ^p =",tree_level,i,p); call display_exp(r,tree_level+1); end; else call ioa_("^vxELEMENT (^d) of ^p = NULL",tree_level,i,p); end; call ioa_("^vxEND LIST ^p^/",tree_level,p); return; end display_list;  display_source.pl1 11/15/82 1819.8rew 11/15/82 1503.2 16497 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ display_source: proc(pt,tree_level); /* Modified: 29 Nov 1979 by PCK to print a tree level indented listing */ dcl tree_level fixed bin; dcl (p,pt) ptr; dcl (addr,null) builtin; dcl 1 based_words based aligned, 2 word1 bit(36), 2 word2 bit(36); dcl date char(24) aligned; dcl ioa_ entry options(variable); dcl decode_node_id entry(ptr,bit(1) aligned) returns(char(120) varying); dcl date_time_ entry(fixed bin(71), char(*) aligned); dcl display_any_node_name entry(char(*) aligned,ptr,fixed bin); %include nodes; %include token; %include token_list; %include source_list; p = pt; if p = null then do; call ioa_("^/^vxdisplay_source: ptr is NULL^/",tree_level); return; end; if p->node.type ^= source_node then do; call display_any_node_name("display_source: node is not a source_node, arg=",p,tree_level+1); return; end; call ioa_("^/^vxSOURCE ^p, ^a",tree_level,p,p -> source.name->token.string); call ioa_("^vx^a",tree_level,decode_node_id(p,"0"b)); call ioa_("^vxseg_ptr = ^p, length = ^d, pathname = ^a",tree_level,p -> source.seg_ptr,p -> source.source_length,p -> source.pathname); call date_time_(p -> source.dtm,date); call ioa_("^vxuid = ^w, dtm = ^w^w (^a)^/",tree_level, p -> source.uid, p -> source.dtm, addr(p -> source.dtm) -> word2, date); return; end display_source;  display_stat_.alm 11/15/82 1819.8rew 11/15/82 1533.1 3825 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " *********************************************************** " display_stat_ name display_stat_ use linkc join /link/linkc " segdef brief_display bss brief_display,1 end  display_statement.pl1 11/15/82 1819.8rew 11/15/82 1503.3 44766 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ display_statement: procedure(p,sourceb,tree_level); /* Modified on: 22 September 1970 by PG. */ /* Modified on: 7 January 1971 by BLW */ /* Modified on: 24 May 1971 by ACF */ /* Modified on: 25 July 1971 by PG */ /* Modified on: 6 June 1977 by RAB */ /* Modified on: 29 Nov 1979 by PCK to print a tree level indented listing */ /* Modified on: 17 Mar 1980 by PCK to display expanded_by_name */ dcl (p, q) ptr, tree_level fixed bin, sourceb bit(1) aligned, cu_$arg_count entry returns(fixed bin), display_any_node_name ext entry(char(*) aligned, ptr,fixed bin), (ioa_,ioa_$nnl) ext entry options(variable), display_exp ext entry(ptr,fixed bin), decode_node_id entry(ptr,bit(1) aligned) returns(char(120) varying), ios_$write_ptr entry(ptr,fixed bin,fixed bin), (addr,fixed,length,min,null,ptr) builtin, n fixed bin(15); dcl itype fixed bin(15), line char(132) aligned varying, st(0:38) char(12) int static options(constant) init("unknown", "allocate", "assignment", "begin", "call", "close", "declare", "delay", "delete", "display", "do", "else clause", "end", "entry", "exit", "format", "free", "get", "go to", "if", "locate", "null", "on", "open", "procedure", "put", "read", "return", "revert", "rewrite", "signal", "stop", "system", "unlock", "wait", "write", "default","continue","pause"); %include list; %include nodes; %include source_list; %include statement; %include token_list; begin: if p=null then do; call ioa_("^/^vxdisplay_statement: ptr is NULL^/",tree_level); return; end; if p->node.type^=statement_node then do; call display_any_node_name("display_statement: arg is not a statement node, arg =",p,tree_level+1); return; end; itype=fixed(p->statement.statement_type,17,0); if itype > hbound(st,1) then itype = 0; call ioa_("^/^vx^a STATEMENT ^p, next = ^p, back = ^p",tree_level,st(itype),p,p->statement.next, p->statement.back); call ioa_("^vx^a",tree_level,decode_node_id(p,"0"b)); if cu_$arg_count() > 1 then if sourceb then do; m = p->statement.source.segment; if p->statement.source.length ^= 0 then do; call ioa_$nnl("^vxSOURCE: ",tree_level); call ios_$write_ptr((source.seg_ptr),(p->statement. source.start),min(p->statement.source.length,120)); call ioa_(""); end; end; m = p -> object.start; if m ^= 0 then if m = p->object.finish then call ioa_("^vxno object code, ic = ^o",tree_level,m); else call ioa_("^vxobject code start = ^o, finish = ^o",tree_level,m,p->object.finish); if p->statement.prefix ^= "111110000000"b then call ioa_("^vxprefix = o^4o",tree_level, fixed(p->statement.prefix,12,0)); line = ""; if p->statement.optimized then line = "optimized "; if p->statement.generated then line = line || "generated "; if p->statement.free_temps then line = line || "free_temps "; if p->statement.LHS_in_RHS then line = line || "LHS_in_RHS "; if p->statement.processed then line = line || "processed "; if p->statement.put_in_profile then line = line || "put_in_profile "; if p->statement.snap then line = line || "snap "; if p->statement.system then line = line || "system "; if p->statement.irreducible then line = line || "irreducible "; if p->statement.checked then line = line || "checked "; if p->statement.save_temps then line = line || "save_temps "; if p->statement.suppress_warnings then line = line || "suppress_warnings "; if p->statement.force_nonquick then line = line || "force_nonquick "; if p->statement.expanded_by_name then line = line || "expanded_by_name "; if length(line) ^= 0 then call ioa_("^vx^a",tree_level,line); m=p->statement.reference_count; if m ^= 0 then call ioa_("^vxreference count = ^d",tree_level,m); q=p->statement.reference_list; if q ^= null then call ioa_("^vxreference list = ^p",tree_level,q); q = p -> statement.state_list; if q ^= null then call ioa_("^vxstate list = ^p",tree_level,q); q=p->statement.labels; if q ^= null then do; call ioa_("^vxlabels:",tree_level); do while(q^=null); if q->list.element(2)->node.type=token_node then call ioa_(q->list.element(2)->t_table.string); else call display_exp((q->list.element(2)),tree_level+1); /* for arrays */ q=q->list.element(1); end; end; q=p->statement.root; if q ^= null then do; call ioa_("^vxroot:",tree_level); call display_exp(q,tree_level+1); end; call ioa_("^vxEND ^a STATEMENT ^p^/",tree_level,st(itype),p); return; end display_statement;  display_symbol.pl1 11/15/82 1819.8rew 11/15/82 1503.4 95292 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Modified on: 10 August 1971 by PG */ /* Modified on: 14 July 1978 by PCK for unsigned binary */ /* Modified on: 25 April 1979 by PCK to implement 4-bit decimal */ /* Modified on: 29 November 1979 by PCK to print a tree level indented listing */ /* This program prints a formatted dump of the symbol table pointed to by p. */ display_symbol: proc(a,tree_level); dcl (a,p,q,vector) ptr, line char(96), tree_level fixed bin, lp fixed bin; dcl i fixed bin(31); dcl n fixed bin(15); dcl k fixed bin; dcl based_bitstring bit(36) aligned based; dcl display_any_node_name ext entry(char(*) aligned, ptr,fixed bin); dcl ioa_ ext entry options(variable); dcl decode_node_id entry(ptr,bit(1)) returns(char(120) varying); dcl ( display_array, display_exp, display_constant) ext entry(ptr,fixed bin); dcl (fixed,string,length,null) builtin; dcl display_stat_$brief_display bit(1) ext static; dcl boundary_type(0:7) char(5) int static aligned init("----","bit ","digit","byte","half","word","mod2","mod4"); dcl declare_type(0:5) char(8) int static init("--------","declare ","expl ctx","context ", "implicit","compiler"); % include symbol; %include default; %include label; %include statement; % include nodes; %include token_list; %include list; %include label_array_element; %include declare_type; dcl names(89) char(20) varying int static initial( /* data_type */ "structure", "fixed", "float", "bit", "char", "ptr", "offset", "area", "label", "entry", "file", "arg_descriptor", "storage_block", "unused_1", "condition", "format", "builtin", "generic", "picture", /* misc_attributes */ "dimensioned", "initialed", "aligned", "unaligned", "signed", "unsigned", "precision", "varying", "local", "decimal", "binary", "real", "complex", "variable", "reducible", "irreducible", "returns", "position", "internal", "external", "like", "member", "non_varying", "options", "variable_arg_list", /* options(variable) */ "alloc_in_text", /* options(constant) */ /* storage_class */ "auto", "based", "static", "controlled", "defined", "parameter", "param_desc", "constant", "temporary", "return_value", /* file_attributes */ "print", "input", "output", "update", "stream", "reserved_1", "record", "sequential", "direct", "interactive", /* env(interactive) */ "reserved_2", "reserved_3", "stringvalue", /* env(stringvalue) */ "keyed", "reserved_4", "environment", /* compiler_developed */ "aliasable", "packed", "passed_as_arg", "allocate", "set", "exp_extents", "refer_extents", "star_extents", "isub", "put_in_symtab", "contiguous", "put_data", "overlayed", "error", "symtab_processed", "overlayed_by_builtin", "defaulted", "connected" ); p=a; if p = null then do; call ioa_("^/^vxdisplay_symbol: ptr is NULL^/",tree_level); return; end; if p->node.type=label_node then do; call ioa_("^/^vxLABEL ^p is ^a",tree_level,p,p->label.token->t_table.string); if p->label.statement ^= null then if ^ p->label.array then call ioa_("^vxfor ^a",tree_level,decode_node_id((p -> label.statement),"0"b)); else do; call ioa_("^vxfor:",tree_level); vector = p->label.statement; if vector -> node.type = label_array_element_node then do while(vector ^= null); call ioa_("^vx^4x^a",tree_level,decode_node_id((vector->label_array_element.statement),"0"b)); vector = vector->label_array_element.next; end; else do i = 1 to vector->list.number; if vector->element(i) = null then call ioa_("^vx^4xNULL",tree_level); else call ioa_("^vx^4x^a",tree_level,decode_node_id((vector->element(i)),"0"b)); end; end; call ioa_("^vxdeclared by ^a",tree_level,declare_type(fixed(p->label.dcl_type,3,0))); call ioa_("^vxblock = ^p, token = ^p, next = ^p, statement = ^p",tree_level, p->label.block_node,p->label.token,p->label.next,p->label.statement); if p->label.allocated then call ioa_("^vxallocated bit is ON",tree_level); i=p->label.location; if i ^= 0 then call ioa_("^vxlocation = ^6w",tree_level,i); if p->label.array then call ioa_("^vxarray bit is ON, low bound = ^d, high bound = ^d",tree_level, p -> label.low_bound,p -> label.high_bound); call ioa_("^vxEND LABEL ^p^/",tree_level,p); return; end; if p->node.type = default_node then do; call ioa_("^/^vxDEFAULT ^p, ^a",tree_level,p,decode_node_id(p,"0"b)); q = p -> default.predicate; if q ^= null then call show_exp("predicate"); if p->default.system then call ioa_("^vxdefault is system",tree_level); if p->default.error then call ioa_("^vxdefault is error",tree_level); if p->default.no_defaults then call ioa_("^vxdefault is no defaults",tree_level); call ioa_("^vxsymbol for default follows",tree_level); call display_symbol((p -> default.symbol),tree_level+1); call ioa_("^vxEND DEFAULT ^p^/",tree_level,p); return; end; if p->symbol.node_type ^= symbol_node then do; call display_any_node_name("display_symbol: arg is not a symbol node, arg =",p,tree_level+1); return; end; call ioa_("^/^vxSYMBOL ^p, is ^a",tree_level,p,p->symbol.token->t_table.string); if p -> symbol.dcl_type = by_declare then call ioa_("^vxdeclared by declare on ^a",tree_level,decode_node_id(p,"0"b)); else call ioa_("^vxdeclared by ^a",tree_level,declare_type(fixed(p -> symbol.dcl_type,17,0))); call ioa_("^vxblock = ^p, token = ^p, next = ^p",tree_level, p->symbol.block_node,p->symbol.token, p->symbol.next); if p->symbol.multi_use ^= null then call ioa_("^vxmulti_use = ^p",tree_level,p->symbol.multi_use); k = p->symbol.level; if k ^= 0 then call ioa_("^vxlevel = ^d",tree_level,k); k = p->symbol.scale; if k ^= 0 then call ioa_("^vxscale = ^d",tree_level,k); k = fixed(p -> symbol.runtime,18); if k ^= 0 then call ioa_("^vxruntime = ^o",tree_level,k); k = fixed(p -> symbol.runtime_offset,18); if k ^= 0 then call ioa_("^vxruntime offset = ^o",tree_level,k); if p->symbol.father ^= null then call ioa_("^vxfather = ^p",tree_level,p->symbol.father); if p->symbol.brother ^= null then call ioa_("^vxbrother = ^p",tree_level,p->symbol.brother); if p->symbol.son ^= null then call ioa_("^vxson = ^p",tree_level,p->symbol.son); i=p->symbol.boundary; if i ^= 0 then call ioa_("^vxboundary is ^a",tree_level,boundary_type(i)); if p->symbol.allocated then call ioa_("^vxallocated bit is ON",tree_level); i=p->symbol.location; if i^= 0 then call ioa_("^vxlocation = ^6w (^d decimal)",tree_level,i,i); q=p->symbol.cross_references; if q ^= null then call ioa_("^vxcross_ref = ^p",tree_level,q); i=p->symbol.c_word_size; if i ^= 0 then call ioa_("^vxc_word_size = ^d",tree_level,i); i=p->symbol.c_bit_size; if i ^= 0 then call ioa_("^vxc_bit_size = ^d",tree_level,i); i=p->symbol.c_dcl_size; if i ^= 0 then call ioa_("^vxc_dcl_size = ^d",tree_level,i); if string(p -> symbol.attributes) = "0"b then do; call ioa_("^vxNo attributes",tree_level); goto long; end; line = "Attributes:"; lp = 13; do i = 1 to length(string(p -> symbol.attributes)); if substr(string(p -> symbol.attributes),i,1) then if i <= hbound(names,1) then do; n = length(names(i)); substr(line,lp,n) = names(i); lp = lp + n + 1; if lp > 72 then do; call ioa_("^vx^a",tree_level,line); line = ""; lp = 1; end; end; end; if lp > 1 then call ioa_("^vx^a",tree_level,line); long: if p -> node.type ^= symbol_node then goto done; q=p->symbol.initial; if p->symbol.constant then if q = null then call ioa_("^vxconstant value ptr is NULL",tree_level); else call display_constant(p,tree_level+1); else do; if q ^= null then if q->node.type ^= list_node then call display_any_node_name("initial= ",q,tree_level+1); else call show("initial attributes",display_initial); end; if p->symbol.picture then do; call ioa_("^vxpicture attributes follows:",tree_level); if p->pic_fixed then call ioa_("^vxpic_fixed",tree_level); if p->pic_float then call ioa_("^vxpic_float",tree_level); if p->pic_char then call ioa_("^vxpic_char ",tree_level); call ioa_("^vxpic_scale = ^d, pic_size = ^d",tree_level,p->pic_scale,p->pic_size); call ioa_("^vxend of picture attributes",tree_level); end; q=p->symbol.array; if q ^= null then call show("array data",display_array); q=p->symbol.descriptor; if q ^= null then call show_exp("descriptor"); q=p->symbol.equivalence; if q ^= null then call show_exp("equivalences"); q=p->symbol.reference; if q ^= null then do; call ioa_("^vxreference follows:",tree_level); call display_exp(q,tree_level+1); end; q = p->symbol.general; if q ^= null then call display_any_node_name("general = ",q,tree_level+1); q = p -> symbol.word_size; if q ^= null then call show_exp("word size exp"); q=p->symbol.bit_size; if q ^= null then call show_exp("bit size exp"); q=p->symbol.dcl_size; if q ^= null then call show_exp("dcl size exp"); q = p -> symbol.symtab_size; if q ^= null then call show_exp("symtab size exp"); done: call ioa_("^vxEND SYMBOL ^p^/",tree_level,p); return; show_exp: proc(message); dcl message char(*) aligned; if display_stat_$brief_display then call ioa_("^vx^a = ^p",tree_level,message,q); else do; call ioa_("^vx^a:",tree_level,message); call display_exp(q,tree_level+1); end; end; show: proc(message,prog); dcl message char(*) aligned, prog entry(ptr,fixed bin); if display_stat_$brief_display then call ioa_("^vx^a = ^p",tree_level,message,q); else do; call ioa_("^vx^a:",tree_level,message); call prog(q,tree_level+1); end; end; display_initial: proc(listp); dcl (listp,q) ptr; q=listp; do while(q^=null); call ioa_("^vxfactor = ",tree_level); call display_exp((q->list.element(1)),tree_level+1); if q->list.element(2) ^= null then if q->list.element(2)->node.type ^= list_node then do; call ioa_("^vxvalue =",tree_level); call display_exp((q->list.element(2)),tree_level+1); end; else call display_initial((q->list.element(2))); else call ioa_("vx^a",tree_level,"value = ""*"""); q=q->list.element(3); end; end display_initial; end display_symbol;  display_xfer_vector.alm 11/15/82 1819.8rew 11/15/82 1533.2 5409 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** name display_xfer_vector entry decode_node_id decode_node_id: tra |[decode_node_id] end  meter_token_table.pl1 11/15/82 1819.8rew 11/15/82 1503.4 16668 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Entry to gather some statistics about the hash table. */ meter_token_table: procedure; /* automatic */ dcl (tokcnt,tokwords,empty_slots,maximum) fixed bin(15); dcl n fixed bin; dcl p ptr; dcl sysprint file print; dcl i fixed bin; /* builtins */ dcl (currentsize, null) builtin; /* entries */ dcl com_err_ entry options (variable); /* external static */ dcl cg_static_$debug bit (1) aligned external static; /* include files */ %include pl1_token_hash_table; %include token; %include system; /* program */ if ^cg_static_$debug then do; call com_err_ (0, "meter_token_table", "No tree available. -debug control argument must be used."); return; end; maximum, n, tokcnt, tokwords, empty_slots = 0; do i = lbound (hash_table, 1) to hbound (hash_table, 1); p = hash_table (i); if p = null then empty_slots = empty_slots + 1; do while (p ^= null); tokcnt = tokcnt + 1; tokwords = tokwords + currentsize (p -> token); n = n + 1; p = p -> token.next; end; maximum = max (maximum, n); /* find the maximum # of tokens in a slot */ n = 0; end; put file (sysprint) skip data (tokcnt, tokwords, empty_slots, maximum); put file (sysprint) skip list ("Average tokens/slot = ", tokcnt / float (dim (hash_table, 1))); put file (sysprint) skip; return; end;  peek.pl1 11/15/82 1819.8rew 11/15/82 1503.5 17253 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ peek: proc(string); /* Modified: 1 April 1980 by PCK to add by_name_agg */ dcl string char(*); dcl p ptr static, set bit(1) aligned, debug entry, (index,null,ptr,substr) builtin, pl1_stat_$root ptr ext, cu_$arg_count entry returns(fixed bin), cv_oct_ entry(char(*) aligned) returns(fixed bin), n fixed bin; %include by_name_agg; %include reference; %include operator; %include symbol; %include statement; %include label; %include list; %include block; %include context; %include token; %include cross_reference; %include machine_state; %include temporary; %include array; %include default; %include sf_par; %include fdata_nodes; set = "0"b; join: if cu_$arg_count() = 0 then p = null; else do; n = index(string,"|"); if n = 0 then p = ptr(pl1_stat_$root,cv_oct_((string))); else p = ptr(baseptr(cv_oct_(substr(string,1,n-1))),cv_oct_(substr(string,n+1))); end; if ^ set then call debug; return; l: p -> reference.symbol, p -> symbol.reference, p -> operator.operand(1), p -> block.son, p -> token.next, p -> temporary.next, p -> context.next, p -> label.next, p -> cross_reference.next, p -> list.element(1), p -> machine_state.next, p -> array.bounds, p -> bound.lower, p -> default.next, p -> sf_par.parsym, p -> data_list.next, p -> by_name_agg.next, p -> statement.root = p; return; peek$set: entry(string); set = "1"b; goto join; end;  show_declaration.pl1 11/15/82 1819.8rew 11/15/82 1503.7 23481 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ show_declaration: proc; /* Modified: 29 Nov 1979 by PCK to print tree level indented listing */ /* Modified: 25 Jun 1980 by PCK to properly indent block listing */ dcl missing(10) bit(1) int static, (i,j,n,code) fixed bin(17), tree_level fixed bin initial(0), p ptr, display_symbol ext entry(ptr,fixed bin), symb(10) char(68) varying int static, cu_$arg_count ext entry(fixed bin(17)), cu_$arg_ptr ext entry(fixed bin(17),ptr,fixed bin(17),fixed bin(17)), n_args fixed bin(17) int static, ioa_ ext entry options(variable), pl1_stat_$root ptr ext static; dcl (length,null) builtin; dcl arg_string char(n) based; %include block; %include symbol; call cu_$arg_count(n_args); if n_args=0 then return; j = 0; do i = 1 to n_args; call cu_$arg_ptr(i,p,n,code); if code ^= 0 then do; call ioa_("NO ARG ^d",i); return; end; if n = 0 then go to loop; if j >= 10 then do; call ioa_("Only 10 symbols allowed"); n_args = 10; goto l; end; j = j + 1; symb(j) = p -> arg_string; missing(j) = "1"b; loop: end; if j = 0 then return; n_args=j; l: call search(pl1_stat_$root,tree_level+1); do i = 1 to n_args; if missing(i) then call ioa_("No declaration found for ^a",symb(i)); end; return; search: proc(pt,tree_level); dcl pt ptr; /* points at block node */ dcl tree_level fixed bin; dcl (p,q) ptr; %include token; if pt = null then return; call ioa_("^/^vxStart of block ^p",tree_level,pt); p = pt -> block.declaration; do while(p ^= null); q = p -> symbol.token; n = q -> token.size; do i = 1 to n_args; if n = length(symb(i)) then if symb(i) = q -> token.string then do; missing(i) = "0"b; call display_symbol(p,tree_level+1); goto do_next; end; end; do_next: p = p -> symbol.next; end; q = pt -> block.son; do while(q^=null); call search((q),tree_level+1); q = q -> block.brother; end; call ioa_("^vxEnd of block ^p^/",tree_level,pt); end; end show_declaration;  show_ms.pl1 11/15/82 1819.8rew 11/15/82 1503.8 37593 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ show_ms: proc; dcl (i,n) fixed bin, p ptr unal, lword char(8), ioa_ entry options(variable); dcl (abs,null) builtin; %include machine_state; show: if m_s_p = null then do; call ioa_("Machine state pointer is null"); return; end; call ioa_("MACHINE STATE ^p: indicators = ^d, next = ^p",m_s_p,indicators,next); if indicators = -2 then do; call ioa_("^/INDICATOR REFERENCES:"); call prt(indicators_ref(2)); call prt(indicators_ref(3)); end; if a_reg.number ^= 0 then do; call ioa_("^/A REGISTER: # = ^d, size = ^d, length = ^d, offset = ^d, constant = ^d", a_reg.number,a_reg.size,a_reg.length,a_reg.offset,a_reg.constant); call ioa_("changed by ^12w at ^o",a_reg.instruction,a_reg.changed); do i = 1 to a_reg.number; call prt(a_reg.variable(i)); end; if a_reg.locked then do; call ioa_("locked"); if a_reg.number_h_o ^= 0 then do; call ioa_("has offset of ^d references",a_reg.number_h_o); do i = 1 to a_reg.number_h_o; call prt(a_reg.has_offset(i)); end; end; end; end; if q_reg.number ^= 0 then do; call ioa_("^/Q REGISTER: # = ^d, size = ^d, length = ^d, offset = ^d, constant = ^d", q_reg.number,q_reg.size,q_reg.length,q_reg.offset,q_reg.constant); call ioa_("changed by ^12w at ^o",q_reg.instruction,q_reg.changed); do i = 1 to q_reg.number; call prt(q_reg.variable(i)); end; if q_reg.locked then do; call ioa_("locked"); if q_reg.number_h_o ^= 0 then do; call ioa_("has offset of ^d references",q_reg.number_h_o); do i = 1 to q_reg.number_h_o; call prt(q_reg.has_offset(i)); end; end; end; end; p = string_reg.variable; if p ^= null then do; call ioa_("^/STRING REGISTER: size = ^d, offset = ^d",string_reg.size,string_reg.offset); call prt(p); end; p = complex_reg.variable; if p ^= null then do; call ioa_("^/COMPLEX REGISTER: size = ^d, scale = ^d",complex_reg.size,complex_reg.scale); call prt(p); end; p = decimal_reg.variable; if p ^= null then do; call ioa_("^/DECIMAL REGISTER: size = ^d, scale = ^d",decimal_reg.size,decimal_reg.scale); call prt(p); end; do i = 0 to 7; n = index_regs(i).type; if n ^= 0 then do; call ioa_("^/INDEX REGISTER ^d: type = ^d, constant = ^o",i, n,index_regs(i).constant); call ioa_("used at ^o, changed by ^12w at ^o",index_regs(i).used, index_regs(i).instruction,index_regs(i).changed); if abs(n) >= 2 then call prt(index_regs(i).variable); end; end; do i = 1 to 6; n = base_regs(i).type; if n ^= 0 then do; call ioa_("^/BASE REGISTER ^d: type = ^d, constant = ^o",i, n,base_regs(i).constant); call ioa_("used at ^o, changed by ^12w at ^o",base_regs(i).used, base_regs(i).instruction,base_regs(i).changed); p = base_regs(i).variable; if n < 3 then call prt(p); else if substr("110001101100"b,n,1) then call ioa_("variable is ^p",p); if base_regs(i).locked ^= 0 then call ioa_("locked = ^d",base_regs(i).locked); end; end; call ioa_("^/END MACHINE STATE ^p^/",m_s_p); return; show_ms$pt: entry(pt); dcl pt ptr; m_s_p = pt; goto show; prt: proc(q); %include reference; %include symbol; %include token; dcl (q,t) ptr unal; if q = null then return; t = q -> reference.symbol -> symbol.token; if q -> reference.shared then call ioa_("variable ^p is ^a",q,t -> token.string); else call ioa_("variable ^p is ^a, ref count = ^d",q,t -> token.string,q -> ref_count); end; end;  show_statement.pl1 11/15/82 1819.8rew 11/15/82 1503.9 28332 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ show_statement: proc(string); /* Modified: 29 Nov 1979 by PCK to print a tree level indented listing */ /* Modified: 24 Jun 1980 by PCK to properly indent the output of show_stm */ dcl string char(*); /* source id of statement to show */ dcl (k,n) fixed bin(15), tree_level fixed bin initial(0), ln fixed bin(15), (sn,fn) fixed bin(6), p ptr, number int static fixed bin(31), any int static bit(1), pl1_stat_$root ptr ext, ioa_ entry options(variable), cv_dec_ entry(char(*) aligned) returns(fixed bin), display_statement entry(ptr,bit(1) aligned,fixed bin); dcl (fixed,index,null,substr) builtin; %include block; %include statement; if pl1_stat_$root = null then do; call ioa_("No tree available"); return; end; if string = "" then do; call ioa_("show_statement line#.statement# (s# is opt.)"); return; end; fn = 0; n = index(string,"."); if n = 0 then do; any = "1"b; ln = cv_dec_((string)); sn = 0; end; else do; any = "0"b; k = index(substr(string,n+1),"."); if k = 0 then do; ln = cv_dec_(substr(string,1,n-1)); sn = cv_dec_(substr(string,n+1)); end; else do; fn = cv_dec_(substr(string,1,n-1)); ln = cv_dec_(substr(string,n+1,k-1)); sn = cv_dec_(substr(string,n+k+1)); end; end; if any then call ioa_("Searching for line ^d",ln); else call ioa_("Searching for statement ^d on line ^d",sn,ln); number = 0; call show_stm(pl1_stat_$root -> block.son,tree_level+1); if number = 0 then call ioa_("Statement not found."); show_stm: proc(ptx,tree_level); dcl ptx ptr unaligned; dcl tree_level fixed bin; dcl (p,q,pt) ptr; pt = ptx; if pt = null then return; call ioa_("^/^vxStart of block ^p",tree_level,pt); p = pt -> block.prologue; call check_stm(p,tree_level); p = pt -> block.main; call check_stm(p,tree_level); q = pt -> block.son; do while(q^=null); call show_stm((q),tree_level+1); q = q -> block.brother; end; call ioa_("^vxEnd of block ^p^/",tree_level,pt); end; check_stm: proc(pt,tree_level); dcl (pt,q) ptr, tree_level fixed bin, this_sn fixed bin(9); q = pt; do while(q ^= null); if any then this_sn = 0; else this_sn = fixed(q -> statement.statement_number,5); if fixed(q -> statement.line_number,14) = ln then if this_sn = sn then if fixed(q -> statement.file_number,8) = fn then do; number = number + 1; call display_statement(q,"1"b,tree_level+1); end; q = q -> statement.next; end; end; end;  stop_at.pl1 11/15/82 1819.8rew 11/15/82 1504.0 11772 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ stop_at: proc(string); dcl string char(*) unaligned, (index, substr) builtin, ln fixed bin(14), fn fixed bin(8), sn fixed bin(5), (k,n) fixed bin, cv_dec_ entry(char(*) aligned) returns(fixed bin), (pl1_stat_$stop_id, cg_static_$stop_id) bit(27) external static; n = index(string,"."); fn = 0; if n = 0 then do; ln = cv_dec_((string)); sn = 1; end; else do; k = index(substr(string,n+1),"."); if k = 0 then do; ln = cv_dec_(substr(string,1,n-1)); sn = cv_dec_(substr(string,n+1)); end; else do; fn = cv_dec_(substr(string,1,n-1)); ln = cv_dec_(substr(string,n+1,k-1)); sn = cv_dec_(substr(string,n+k+1)); end; end; cg_static_$stop_id, pl1_stat_$stop_id = bit(fn,8) || bit(ln,14) || bit(sn,5); end; 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