create_data_segment.pl1 05/18/90 1156.2rew 05/18/90 1154.7 88569 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1990 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(90-04-23,Huen), approve(90-04-23,MCR8156), audit(90-04-27,Gray), install(90-05-17,MR12.4-1009): lang_11: Use cv_entry to find the segment so that cds will work even when the working dir is not in the search rules. 2) change(90-05-18,Huen), approve(90-05-18,MCR8156), audit(90-05-18,Gray), install(90-05-18,MR12.4-1010): Post bug fix (lang_11) : to avoid passing an entryname to pathname_ that exceeds 32 characters. END HISTORY COMMENTS */ /* This program is a command interface to the create_data_segment_ subroutine. It creates a link in the process directory named .pl1 to the segment .cds in the working directory and calls the PL/I compiler to compile the program. The compiler is invoked with the -table control argument. If the -list create_data_segment control argument is specified, the name .list (same as above) is added to the entry .list so the listing segment is created appropriately, and the compiler is invoked with the -map control argument. The format of a CDS source segment is a PL/I program with a call to the create_data_segment_ subroutine. The name given to the create_data_segment command is the entry point used to call the program. The argument passed to create_data_segment_ internally as the name of the segment to be created should be this same name to preserve Multics conventions on names of created object segments. Initial coding: 11/20/75 by S. Webber Bug with ".cds" names fixed 07/30/76 by B. Greenberg MCR 3343 -- Error message bug fixed 19 July 1978 by M. Davidoff. Modified 27 February 1981 by M. N. Davidoff to fix bug in which random names are added to the working directory if -list is not specified. */ /* format: style2 */ create_data_segment: cds: procedure options (variable); /* automatic */ dcl arg_count fixed bin; dcl argument_no fixed bin; dcl 1 ca aligned, 2 list bit (1); dcl code fixed bin (35); dcl i fixed bin; dcl list_ca char (8); dcl listp ptr; dcl pdir char (168); dcl seg_ptr ptr; dcl source char (32); dcl source_cds char (32); dcl source_dir char (168); dcl source_list char (32); dcl tc fixed bin (21); dcl tp ptr; dcl unique char (15); dcl unique_list char (32); dcl unique_pl1 char (32); dcl wdir char (168); /* based */ dcl targ char (tc) based (tp); /* builtin */ dcl (addr, after, divide, index, null, reverse, rtrim, substr) builtin; /* condition */ dcl cleanup condition; /* internal static */ dcl command char (19) internal static options (constant) initial ("create_data_segment"); dcl NP char (1) internal static options (constant) initial (" "); /* external static */ dcl error_table_$badopt fixed bin (35) external static; dcl pl1_severity_ fixed bin (35) external static; /* entry */ dcl com_err_ entry options (variable); dcl com_err_$suppress_name entry options (variable); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl cv_entry_ entry (char (*), ptr, fixed bin (35)) returns (entry); dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl form_link_info_ entry (ptr, fixed bin (35)); dcl get_pdir_ entry returns (char (168)); dcl get_wdir_ entry returns (char (168)); dcl hcs_$append_link entry (char (*), char (*), char (*), fixed bin (35)); dcl hcs_$chname_file entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl hcs_$delentry_file entry (char (*), char (*), fixed bin (35)); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35)); dcl ioa_$nnl entry options (variable); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl pl1 entry options (variable); dcl terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35)); dcl unique_chars_ entry (bit (*)) returns (char (15)); %include terminate_file; /* program */ call cu_$arg_count (arg_count, code); if code ^= 0 then do; call com_err_ (code, command); return; end; argument_no = 0; ca = ""b; do i = 1 to arg_count; call cu_$arg_ptr (i, tp, tc, code); if code ^= 0 then do; call com_err_ (code, command, "Argument ^d.", i); return; end; if targ = "-list" | targ = "-ls" then ca.list = "1"b; else if index (targ, "-") = 1 then do; call com_err_ (error_table_$badopt, command, "^a", targ); return; end; else do; argument_no = argument_no + 1; if argument_no = 1 then do; call expand_pathname_$add_suffix (targ, "cds", source_dir, source_cds, code); if code ^= 0 then do; call com_err_ (code, command, "^a", targ); return; end; end; end; end; if argument_no ^= 1 then do; call com_err_$suppress_name (0, command, "Usage: ^a path {-control_args}", command); return; end; source = reverse (after (reverse (source_cds), reverse (".cds"))); source_list = rtrim (source) || ".list"; unique = unique_chars_ (""b); unique_pl1 = unique || ".pl1"; unique_list = unique || ".list"; listp, seg_ptr = null; wdir = get_wdir_ (); pdir = get_pdir_ (); on cleanup call clean_up_segs; /* Make sure the source segment is there. */ call hcs_$initiate (source_dir, source_cds, "", 0, 1, seg_ptr, code); if seg_ptr = null then do; call com_err_ (code, command, "^a^[>^]^a", source_dir, source_dir ^= ">", source_cds); return; end; call terminate_file_ (seg_ptr, 0, TERM_FILE_TERM, code); call translate_cds_source_segment; call clean_up_segs; return; translate_cds_source_segment: procedure; /* Link to source program */ call hcs_$append_link (pdir, unique_pl1, rtrim (source_dir) || ">" || source_cds, code); if code ^= 0 then do; call com_err_ (code, command, "Appending link ^a^[>^]^a to ^a^[>^]^a.", pdir, pdir ^= ">", unique_pl1, source_dir, source_dir ^= ">", source_cds); return; end; if ca.list then do; call hcs_$chname_file (wdir, source_list, "", unique_list, code); list_ca = "-map"; end; else list_ca = "-table"; call ioa_$nnl ("CDS - "); call pl1 (rtrim (pdir) || ">" || unique, "-table", list_ca); if pl1_severity_ > 2 then call com_err_ (0, command, "PL/I errors occured."); else begin; dcl entry_var entry variable; entry_var = cv_entry_ ((pathname_ (wdir, unique) || "$" || source), null, code); if code ^= 0 then do; call com_err_ (code, command, "^a$^a", unique, source); return; end; call entry_var; end; if ca.list then begin; dcl bc fixed bin (24); dcl 1 fli_args aligned, 2 obj_ptr ptr, 2 list_ptr ptr, 2 list_bc fixed bin (24), 2 hd_sw bit (1) unaligned, 2 ln_sw bit (1) unaligned, 2 et_sw bit (1) unaligned, 2 lk_sw bit (1) unaligned, 2 lg_sw bit (1) unaligned; dcl listing_file char (divide (bc, 9, 21)) based (listp); call hcs_$initiate_count (wdir, unique_list, "", bc, 1, listp, code); if listp = null then do; call com_err_ (code, command, "^a^[>^]^a", wdir, wdir ^= ">", unique_list); return; end; bc = bc + 9; substr (listing_file, divide (bc, 9, 21), 1) = NP; call hcs_$initiate (wdir, source, "", 0, 1, seg_ptr, code); if seg_ptr = null then do; call com_err_ (code, command, "^a^[>^]^a", wdir, wdir ^= ">", source); call com_err_ (0, command, "Check arguments to the call of create_data_segment_ in ^a.", source_cds); return; end; fli_args.obj_ptr = seg_ptr; fli_args.list_ptr = listp; fli_args.list_bc = bc; fli_args.hd_sw = "1"b; fli_args.ln_sw = "1"b; fli_args.et_sw = "1"b; fli_args.lk_sw = "1"b; fli_args.lg_sw = "0"b; call form_link_info_ (addr (fli_args), code); if code ^= 0 then do; call com_err_ (code, command, "Getting link information for ^a^[>^]^a.", wdir, wdir ^= ">", source); return; end; call terminate_file_ (listp, fli_args.list_bc, TERM_FILE_TRUNC_BC_TERM, code); end; end translate_cds_source_segment; clean_up_segs: procedure; call hcs_$delentry_file (pdir, unique_pl1, code); call hcs_$delentry_file (wdir, unique, code); call hcs_$chname_file (wdir, unique_list, unique_list, source_list, code); if code ^= 0 then call hcs_$chname_file (wdir, unique_list, unique_list, "", code); call terminate_file_ (listp, 0, TERM_FILE_TERM, code); call terminate_file_ (seg_ptr, 0, TERM_FILE_TERM, code); end clean_up_segs; end create_data_segment;  create_data_segment_.pl1 05/17/90 1515.5rew 05/17/90 1511.5 207927 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1990 * * * * 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-05-02,Elhard), approve(86-05-02,MCR7391), audit(86-09-04,DGHowe), install(86-11-20,MR12.0-1222): Modified to fix definition threading to not thread definition header into backward definition thread and overwrite msf_map_relp value in def header. 2) change(90-04-23,Huen), approve(90-04-23,MCR8166), audit(90-04-27,Gray), install(90-05-17,MR12.4-1009): lang_13: Warn users if a level 2 element which is not aligned on a word boundary is used. END HISTORY COMMENTS */ /* create_data_segment_: A standard object segment generator which uses runtime pl1 structure definitions as templates for defining data segment segdefs. Oct. 15, 1975 by Bernard S. Greenberg. Even source map bug, random pad words fixed 7/30/76 by BSG Runtime symbol simple bit treated properly -- 12/16/76 BSG improved searching for block using return ptr -- 11/07/78 JRDavis Fixed bug in creating data segments without text sections -- 2 Oct 1980 Chris Jones Fixed bug in call to stu_$decode_runtime_value -- 8 October 1980 M. N. Davidoff Changed to use date_time_$format -- 06/19/84 J A Falksen */ /* format: style2 */ create_data_segment_: procedure (infoptr, rcode); dcl rcode fixed bin (35); dcl myname char (32) internal static options (constant) init ("create_data_segment_"); dcl (infop, infoptr) ptr; dcl stucode fixed bin; dcl (slen, tlen, llen) fixed bin (19); dcl movdef bit (1) aligned; dcl (hp, smp, osmp, osymp, defp, class3ptr) ptr; dcl ( DEF init (1), DEFR init (2), LNKR init (3), SYMR init (4), TXTR init (5) ) fixed bin internal static options (constant); dcl scrps (5) ptr; dcl 1 relinfo aligned based, 2 decl_version fixed bin, 2 n_bits fixed bin; dcl 1 rloc aligned based (rlocp), 2 words (0:9999) unal, 3 (l, r) bit (18); dcl 1 vrloc aligned based (ptr (rlocp, next)) like rloc; dcl rp ptr, b18u bit (18) unaligned based; dcl (putp, rlocp) ptr; dcl 1 acc aligned based, 2 acc1 unal, 3 acclen fixed bin (8) unal, 3 accstr char (4 refer (acc.acclen)) unal; dcl (tptr, sptr, lptr) ptr; dcl error_table_$translation_failed external fixed bin (35); dcl tssi_$get_segment entry (char (*), char (*), ptr, ptr, fixed bin (35)); dcl get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl get_wdir_ entry returns (char (168)); dcl match_star_name_ entry (char (*), char (*), fixed bin (35)); dcl check_star_name_$entry entry (char (*), fixed bin (35)); dcl tssi_$finish_segment entry (ptr, fixed bin (24), bit (36) aligned, ptr, fixed bin (35)); dcl (now, dtmc) fixed bin (71); dcl object_info_$brief entry (ptr, fixed bin (24), ptr, fixed bin (35)); dcl 1 oi like object_info aligned; dcl strptr ptr; dcl i fixed bin; dcl hcs_$status_mins entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35)); dcl tssi_$clean_up_segment entry (ptr); dcl cleanup condition; dcl sgp ptr, aclip ptr; dcl dhp ptr; dcl (opp, smrcp) ptr; dcl copy (copylen) bit (36) aligned based; dcl copylen fixed bin (19); dcl wordl fixed bin; dcl n fixed bin; dcl bc fixed bin (24); dcl get_group_id_ entry returns (char (32)); dcl prevdef ptr; dcl pv ptr; dcl next fixed bin (18); dcl ojnxt fixed bin (18); dcl zeroword fixed bin (18); dcl bword bit (36) based; dcl strcopy char (copylen) based; dcl strcopy1 char (strcopy1l) based (strc1p); dcl strc1p ptr; dcl strcopy1l fixed bin; dcl oname char (32); dcl stu_$get_runtime_block entry (ptr, ptr, ptr, fixed bin (18)); dcl (header_ptr, block_ptr) ptr; dcl (tnode, lnode, snode) ptr; dcl cp ptr; dcl code fixed bin (35); dcl date_time_$format entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var); dcl com_err_ entry options (variable); dcl stu_$find_runtime_symbol entry (ptr, char (*) aligned, ptr, fixed bin) returns (ptr); dcl stu_$decode_runtime_value entry (fixed bin (35), ptr, ptr, ptr, ptr, ptr, fixed bin) returns (fixed bin (35)); dcl (addr, addrel, bin, bit, clock, codeptr, divide, fixed, length, mod, null, ptr, rel, rtrim, size, stackframeptr, substr, unspec) builtin; dcl (lsize, sysize, tsize, dsize, ssize) fixed bin (18); dcl (srel, lrel, drel, syrel) fixed bin (18); %include cds_args; %include stack_frame; %include definition; %include segname_def; %include source_map; %include relbts; %include object_info; %include object_map; %include linkdcl; %include std_symbol_header; %include runtime_symbol; /* Check information supplied by caller. Locate necessary runtime symbol nodes. */ infop = infoptr; rcode = 0; do sp = stackframeptr () -> stack_frame.prev_sp repeat sp -> stack_frame.prev_sp while (sp -> stack_frame_flags.support); end; cp = sp -> stack_frame.return_ptr; call stu_$get_runtime_block (sp, header_ptr, block_ptr, bin (rel (cp), 18)); if header_ptr = null then do; call com_err_ (0, myname, "Cannot get symbol table header."); tranfai: rcode = error_table_$translation_failed; return; end; movdef = infop -> cds_args.defs_in_link; /* copy bit */ oname = infop -> cds_args.seg_name; if infop -> cds_args.have_text then do; tptr = infop -> cds_args.sections (1).p; tlen = infop -> cds_args.sections (1).len; tnode = find_runtime_symbol_node ("text", infop -> cds_args.sections (1).struct_name); end; else tnode = null; if infop -> cds_args.have_static & infop -> cds_args.separate_static then do; sptr = infop -> cds_args.sections (2).p; slen = infop -> cds_args.sections (2).len; snode = find_runtime_symbol_node ("static", infop -> cds_args.sections (2).struct_name); end; else snode = null; if infop -> cds_args.have_static & ^infop -> cds_args.separate_static then do; lptr = infop -> cds_args.sections (2).p; llen = infop -> cds_args.sections (2).len; lnode = find_runtime_symbol_node ("linkage", infop -> cds_args.sections (2).struct_name); end; else lnode = null; /* Check legitimacy of all star names */ do i = 1 to infop -> cds_args.num_exclude_names; call check_star_name_$entry (infop -> cds_args.exclude_array_ptr -> exclude_names (i), code); if code < 0 | 2 < code then do; call com_err_ (code, myname, "^a", infop -> cds_args.exclude_array_ptr -> exclude_names (i)); go to tranfai; end; end; /* All parameter checks have been passed. Now actually generate the object segment. */ scrps (*) = null; aclip = null; on cleanup call clupper; clupper: proc; call release_temp_segments_ (myname, scrps, code); if aclip ^= null then call tssi_$clean_up_segment (aclip); end clupper; call get_temp_segments_ (myname, scrps, code); if code ^= 0 then do; call com_err_ (code, myname, "Getting temporary segments."); hell: call clupper; goto tranfai; end; call tssi_$get_segment (get_wdir_ (), oname, sgp, aclip, code); if sgp = null then do; call com_err_ (code, myname, "^a", oname); goto hell; end; /* build definitions */ rlocp = scrps (DEFR); /* defreloc */ putp = scrps (DEF); /* definitions */ dhp = putp; next = 0; putp -> definition.new = "1"b; putp -> definition.ignore, putp -> definition.new = "1"b; rp = ptr (rlocp, next); rp -> definition.forward, rp -> definition.backward = rc_dp; vrloc (1).l, vrloc (1).r = rc_a; prevdef = putp; next = next + 2; /* allocate the zeroword */ putp = ptr (putp, next); putp -> bword = "0"b; vrloc (0).r, vrloc (0).l = rc_a; zeroword = next; next = next + 1; /* put out segname */ putp = ptr (putp, next); prevdef -> definition.forward = rel (putp); putp -> segname_def.backward = bit (bin (zeroword, 18), 18); putp -> segname_def.next = bit (zeroword, 18); prevdef = putp; defp = putp; rp = ptr (rlocp, next); rp -> segname_def.forward, rp -> segname_def.backward, rp -> segname_def.symbol, rp -> segname_def.defblock = rc_dp; rp -> segname_def.next = rc_dp; addr (rp -> segname_def.flags) -> b18u = rc_a; defp -> segname_def.new = "1"b; defp -> segname_def.class = "011"b; next = next + size (segname_def); strptr = alloc_acc (rtrim (oname)); defp -> definition.symbol = rel (strptr); class3ptr = defp; /* define symbol_table */ defp = putp; prevdef -> segname_def.defblock = rel (defp); prevdef -> segname_def.forward = rel (defp); defp -> definition.backward = rel (prevdef); prevdef = defp; defp -> definition.value = "000000000000000000"b; defp -> definition.class = "010"b; /* symbol */ defp -> definition.new = "1"b; defp -> definition.segname = rel (class3ptr); rp = ptr (rlocp, next); next = next + size (definition); defp -> definition.symbol = rel (alloc_acc ("symbol_table")); rp -> definition.forward, rp -> definition.backward, rp -> definition.segname, rp -> definition.symbol = rc_dp; rp -> definition.value = rc_s; addr (rp -> definition.flags) -> b18u = rc_a; /* put out text definitions */ if tnode = null then tlen, tsize = 0; else do; tsize = tlen + mod (tlen, 2); call generate_definitions (tnode, tptr, rc_t, 0); end; /* put out link definitions */ if lnode = null then llen, lsize = 0; else do; lsize = llen + mod (llen, 2); call generate_definitions (lnode, lptr, rc_lp18, 1); end; /* put out static definitions */ if snode = null then slen, ssize = 0; else do; ssize = slen + mod (slen, 2); call generate_definitions (snode, sptr, rc_is18, 4); end; dsize = next + mod (next, 2); prevdef -> definition.forward = bit (zeroword, 18); generate_definitions: proc (nptr, struc_ptr, gen_reloc, gen_class); dcl nptr ptr; dcl struc_ptr ptr; dcl gen_reloc bit (18); dcl gen_class fixed bin (3); dcl v2 fixed bin (35); dcl point ptr; dcl mod_tst (0:7) fixed bin internal static options (constant) init (1, 36, 4, 2, 1, 36, 4, 8); do point = nptr repeat addrel (point, point -> runtime_symbol.brother); code = 1; do i = 1 to infop -> cds_args.num_exclude_names while (code ^= 0); call match_star_name_ (addrel (point, point -> runtime_symbol.name) -> acc.accstr, infop -> cds_args.exclude_array_ptr -> exclude_names (i), code); end; if code ^= 0 then do; if point -> runtime_symbol.bits.simple then stucode, v2 = 0; else do; v2 = stu_$decode_runtime_value (point -> runtime_symbol.offset, block_ptr, sp, null, null, struc_ptr, stucode); if stucode ^= 0 then do; call com_err_ (0, myname, "stu_$decode_runtime_value complains ^d on ^a", stucode, addrel (point, point -> runtime_symbol.name) -> acc.accstr); go to hell; end; if mod (v2, mod_tst (fixed (point -> runtime_symbol.units))) ^= 0 then do; call com_err_ (0, myname, "A level 2 element, ^a, is not word aligned and cannot be turned into an entrypoint.", addrel (point, point -> runtime_symbol.name) -> acc.accstr); go to skip_def; end; end; if gen_class = 1 then v2 = v2 + size (virgin_linkage_header); putp = ptr (putp, next); defp = putp; defp -> definition.class = bit (bin (gen_class, 3), 3); defp -> definition.segname = rel (class3ptr); defp -> definition.value = bit (bin (v2, 18), 18); defp -> definition.new = "1"b; rp = ptr (rlocp, next); rp -> definition.forward, rp -> definition.backward, rp -> definition.symbol = rc_dp; addr (rp -> definition.flags) -> b18u = rc_a; rp -> definition.value = gen_reloc; next = next + size (definition); defp -> definition.symbol = rel (alloc_acc (addrel (point, point -> runtime_symbol.name) -> acc.accstr)); prevdef -> definition.forward = rel (defp); defp -> definition.backward = rel (prevdef); prevdef = defp; skip_def: end; if point -> runtime_symbol.brother = "0"b then return; end; end generate_definitions; /* acc generator, which admittedly does some useless work */ alloc_acc: proc (cstr) returns (ptr); dcl cstr char (*); putp = ptr (putp, next); /* update ptr */ wordl = divide (length (cstr), 4, 17, 0) + 1; do i = 1 to wordl; vrloc (i - 1).r, vrloc (i - 1).l = rc_a; end; putp -> acc.acclen = length (cstr); putp -> acc.accstr = cstr; next = next + wordl; opp = putp; putp = ptr (putp, next); return (opp); end alloc_acc; /* cons some junk together */ ojnxt = 0; putp = ptr (sgp, ojnxt); if tsize > 0 then do; copylen = tlen; putp -> copy = tptr -> copy; ojnxt = ojnxt + tsize; end; if movdef then drel = 0; else do; /* put defs in normal place */ drel = ojnxt; copylen = dsize; putp = ptr (putp, ojnxt); putp -> copy = scrps (DEF) -> copy; ojnxt = ojnxt + dsize; end; /* Generate separate static */ srel = ojnxt; if ssize > 0 then do; copylen = slen; putp = ptr (putp, ojnxt); putp -> copy = sptr -> copy; ojnxt = ojnxt + ssize; end; rlocp = scrps (LNKR); rp = rlocp; next = 0; putp = ptr (sgp, ojnxt); lrel = bin (rel (putp), 18); hp = putp; unspec (putp -> virgin_linkage_header) = "0"b; putp -> virgin_linkage_header.def_offset = bit (drel, 18); putp -> virgin_linkage_header.link_begin = bit (bin (lsize + size (virgin_linkage_header), 18), 18); putp -> virgin_linkage_header.linkage_section_lng = putp -> virgin_linkage_header.link_begin; next = next + size (virgin_linkage_header); putp = addrel (putp, size (virgin_linkage_header)); if lsize > 0 then do; copylen = llen; putp -> copy = lptr -> copy; next = next + lsize; end; ojnxt = ojnxt + next; if movdef then do; /* Throw defs into link-resident static */ hp -> virgin_linkage_header.defs_in_link = "010000"b; hp -> virgin_linkage_header.def_offset = bit (bin (next, 18), 18); drel = ojnxt; copylen = dsize; putp = ptr (putp, ojnxt); putp -> copy = scrps (DEF) -> copy; hp -> virgin_linkage_header.linkage_section_lng = bit (bin (bin (hp -> virgin_linkage_header.linkage_section_lng, 18) + dsize, 18), 18); ojnxt = ojnxt + dsize; next = next + dsize; end; lsize = lsize + size (virgin_linkage_header); do i = 0 to next - 1; /* link relocs */ rloc (i).r, rloc (i).l = rc_a; end; rp -> virgin_linkage_header.def_offset = rc_dp; rp -> virgin_linkage_header.link_begin = rc_lp18; /* Create symbol section */ syrel = ojnxt; putp = ptr (sgp, ojnxt); rlocp = scrps (SYMR); next = 0; dtmc, now = clock (); pv = ptr (codeptr (create_data_segment_), 0); call hcs_$status_mins (pv, 0, bc, code); if code = 0 then do; oi.version_number = object_info_version_2; call object_info_$brief (pv, bc, addr (oi), code); if code = 0 then dtmc = oi.symbp -> std_symbol_header.object_created; end; hp = putp; hp -> std_symbol_header.dcl_version = 1; hp -> std_symbol_header.identifier = "symbol_t"; hp -> std_symbol_header.gen_number = 1; hp -> std_symbol_header.gen_created = dtmc; hp -> std_symbol_header.object_created = now; hp -> std_symbol_header.generator = "cds"; next = size (std_symbol_header); putp = addrel (hp, next); call putstr ("create_data_segment_, Version II of " || date_time_$format ("^dn, ^mn ^dm, ^9999yc", dtmc, "", ""), hp -> std_symbol_header.gen_version, rlocp -> std_symbol_header.gen_version); call putstr (rtrim (get_group_id_ ()), hp -> std_symbol_header.userid, rlocp -> std_symbol_header.userid); putstr: proc (str, struc, rstruc); dcl 1 struc unaligned, 2 (of, sz) bit (18); dcl 1 rstruc unaligned, 2 (rof, rsz) bit (18); dcl str char (*); sz = bit (bin (length (str), 18), 18); wordl = divide (length (str) + 3, 4, 17, 0); rof, rsz = rc_a; /* I take no responsibility for this lie */ copylen = length (str); putp = addrel (hp, next); of = bit (bin (bin (rel (putp), 18) - bin (rel (hp), 18), 18), 18); putp -> strcopy = str; next = next + wordl; putp = addrel (hp, next); end putstr; /* copy other guy's source map */ cp = ptr (cp, 0); call hcs_$status_mins (cp, 0, bc, code); if code = 0 then do; oi.version_number = object_info_version_2; call object_info_$brief (cp, bc, addr (oi), code); end; osymp = oi.symbp; osmp = addrel (osymp, osymp -> std_symbol_header.source_map); next = next + mod (next, 2); /* source map gotta be even */ hp -> std_symbol_header.source_map = bit (bin (next, 18), 18); putp = addrel (hp, next); smp = putp; smp -> source_map.version = osmp -> source_map.version; smp -> source_map.number = osmp -> source_map.number; smrcp = ptr (rlocp, next); n = smp -> source_map.number; next = size (smp -> source_map) + next; putp = addrel (hp, next); do i = 1 to smp -> source_map.number; strc1p = addrel (osymp, osmp -> source_map.offset (i)); strcopy1l = bin (osmp -> source_map.size (i), 18); call putstr (strcopy1, smp -> source_map.pathname (i), smrcp -> source_map.pathname (i)); smp -> source_map.dtm (i) = osmp -> source_map.dtm (i); smp -> source_map.uid (i) = osmp -> source_map.uid (i); end; /* generate symbol section relocation */ rp = scrps (SYMR); rp -> std_symbol_header.source_map, rp -> std_symbol_header.area_pointer, rp -> std_symbol_header.rel_text, rp -> std_symbol_header.rel_def, rp -> std_symbol_header.rel_symbol, rp -> std_symbol_header.rel_link = rc_s; hp -> std_symbol_header.maxi_truncate, hp -> std_symbol_header.mini_truncate = bit (bin (next, 18), 18); hp -> std_symbol_header.text_boundary, hp -> std_symbol_header.stat_boundary = bit (bin (2, 18), 18); putp = addrel (hp, next); if ^movdef then do; call relbits (hp -> std_symbol_header.rel_text, tsize, scrps (TXTR)); call relbits (hp -> std_symbol_header.rel_def, dsize, scrps (DEFR)); call relbits (hp -> std_symbol_header.rel_link, lsize, scrps (LNKR)); call relbits (hp -> std_symbol_header.rel_symbol, (next), scrps (SYMR)); end; sysize = next; ojnxt = ojnxt + next; /* generate the object_map */ putp = ptr (sgp, ojnxt); unspec (putp -> object_map) = "0"b; putp -> object_map.decl_vers = object_map_version_2; putp -> object_map.identifier = "obj_map"; putp -> object_map.text_length = bit (bin (tsize, 18), 18); putp -> object_map.definition_offset = bit (bin (drel, 18), 18); putp -> object_map.definition_length = bit (bin (dsize, 18), 18); putp -> object_map.linkage_offset = bit (bin (lrel, 18), 18); if movdef then putp -> object_map.linkage_length = bit (bin (lsize + dsize, 18), 18); else putp -> object_map.linkage_length = bit (bin (lsize, 18), 18); if ssize > 0 then do; putp -> object_map.static_offset = bit (bin (srel, 18), 18); putp -> object_map.static_length = bit (bin (ssize, 18), 18); putp -> object_map.separate_static = "1"b; end; else do; putp -> object_map.static_offset = bit (bin (lrel + size (virgin_linkage_header), 18), 18); putp -> object_map.static_length = bit (bin (lsize - size (virgin_linkage_header), 18), 18); end; putp -> object_map.symbol_offset = bit (bin (syrel, 18), 18); putp -> object_map.symbol_length = bit (bin (sysize, 18), 18); putp -> object_map.break_map_offset, putp -> object_map.break_map_length = "0"b; putp -> object_map.standard = "1"b; putp -> object_map.relocatable = ^movdef; putp = addrel (putp, size (object_map)); next = bin (rel (putp), 18); putp -> map_ptr = bit (bin (next - size (object_map), 18), 18); next = next + 1; call tssi_$finish_segment (sgp, 36 * next, "1"b, aclip, code); aclip = null; if code ^= 0 then call com_err_ (code, myname, "Finishing up segment."); call clupper; return; find_runtime_symbol_node: procedure (section, structure_name) returns (ptr); dcl section char (*); /* (Input) */ dcl structure_name char (*) aligned; /* (Input) */ dcl node ptr; dcl stufail (-5:-1) char (32) internal static options (constant) initial ("Symbol reference is ambiguous", "No declaration found", "Name too long", "More than 64 structure levels", "Block pointer is null"); node = stu_$find_runtime_symbol (block_ptr, rtrim (structure_name), null, stucode); if stucode < 0 then do; call com_err_ (0, myname, "^a for ^a section structure ^a", stufail (stucode), section, structure_name); goto tranfai; end; if node -> runtime_symbol.son = ""b then do; call com_err_ (0, myname, "Symbol ^a for ^a section is not a structure.", structure_name, section); goto tranfai; end; if node -> runtime_symbol.ndims ^= ""b then do; call com_err_ (0, myname, "Symbol ^a for ^a section is an array.", structure_name, section); goto tranfai; end; return (addrel (node, node -> runtime_symbol.son)); end find_runtime_symbol_node; /* The great relocation hacker */ relbits: proc (relans, words, rptr); dcl rhp ptr; dcl relans bit (18) unal, words fixed bin (18), rptr ptr; dcl bitstr bit (1000000) based (putp) aligned; dcl bitpos fixed bin init (1); putp -> relinfo.decl_version = 2; rhp = putp; next = next + size (relinfo); putp = addrel (hp, next); do i = 0 to words - 1; call irloc (rptr -> rloc (i).l); call irloc (rptr -> rloc (i).r); end; irloc: proc (rfld); dcl rfld bit (18) unaligned; if rfld = "0"b then do; substr (bitstr, bitpos, 1) = "0"b; bitpos = bitpos + 1; end; else do; substr (bitstr, bitpos, 5) = substr (rfld, 14, 5); bitpos = bitpos + 5; end; end irloc; rhp -> relinfo.n_bits = bitpos - 1; bitpos = bitpos + mod (bitpos, 36); bitpos = divide (bitpos, 36, 18, 0); next = next + bitpos; relans = bit (bin (bin (rel (rhp), 18) - bin (rel (hp), 18), 18), 18); putp = addrel (putp, bitpos); end relbits; end create_data_segment_;  extract_message_doc.pl1 11/15/82 1845.8rew 11/15/82 1516.1 37737 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ extract_message_doc: proc; /* EXTRACT_MESSAGE_DOC - Find error message documentation in source program comment. THVV 4/77 */ dcl i fixed bin; dcl ap ptr, al fixed bin, bchr char (al) based (ap) unal; dcl me char (19) static options (constant) init ("extract_message_doc"); dcl segp ptr; dcl scc fixed bin (21); dcl iocbp ptr; dcl bitc fixed bin (24); dcl ec fixed bin (35); dcl dn char (168); dcl en char (32); dcl target char (168); dcl acptr ptr; dcl acsw bit (1) init ("0"b); dcl bfsw bit (1) init ("0"b); dcl extract_msg_doc_ entry (char (*), ptr, fixed bin (21), ptr, fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl com_err_ entry options (variable); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl absolute_pathname_ entry (char (*), char (*), fixed bin (35)); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); dcl unique_chars_ entry (bit (*)) returns (char (15)); dcl iox_$attach_ioname entry (char (*), ptr, char (*), fixed bin (35)); dcl iox_$open entry (ptr, fixed bin, bit (1), fixed bin (35)); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); dcl hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl archive_util_$first_disected entry (ptr, ptr, char (32), fixed bin (24), fixed bin (35)); dcl archive_util_$disected_element entry (ptr, ptr, char (32), fixed bin (24), fixed bin (35)); dcl error_table_$badopt fixed bin (35) ext; dcl (divide, index, length, null, rtrim, substr, verify) builtin; dcl cleanup condition; call cu_$arg_ptr (1, ap, al, ec); if ec ^= 0 then do; er1: call com_err_ (ec, me, ""); return; end; call expand_pathname_ (bchr, dn, en, ec); if ec ^= 0 then do; call com_err_ (ec, me, "^a", bchr); return; end; call hcs_$initiate_count (dn, en, "", bitc, 1, segp, ec); if segp = null then do; er: call com_err_ (ec, me, "^a>^a", dn, en); return; end; if index (en, ".archive") ^= 0 then do; acsw = "1"b; acptr = segp; call archive_util_$first_disected (acptr, segp, en, bitc, ec); if ec ^= 0 then go to er; end; scc = divide (bitc, 9, 17, 0); call cu_$arg_ptr (2, ap, al, ec); if ec ^= 0 then go to er1; call absolute_pathname_ (bchr, target, ec); if ec ^= 0 then do; call com_err_ (ec, "^a", bchr); go to exit; end; call iox_$attach_ioname (unique_chars_ ("0"b), iocbp, "vfile_ " || target || " -extend", ec); if ec ^= 0 then do; call com_err_ (ec, me, "Attaching to ^a", target); go to exit; end; call iox_$open (iocbp, 2, "1"b, ec); call cu_$arg_ptr (3, ap, al, ec); if ec = 0 then if bchr = "-brief" | bchr = "-bf" then bfsw = "1"b; else do; call com_err_ (error_table_$badopt, me, "^a", bchr); go to wump; end; on cleanup begin; call iox_$close (iocbp, 0); call iox_$detach_iocb (iocbp, 0); end; nxac: call extract_msg_doc_ (en, segp, scc, iocbp, ec); if ec = 1 then if bfsw then; else call com_err_ (0, me, "Documentation missing in ^a", en); else if ec ^= 0 then call com_err_ (ec, me, "Error extracting documentation from ^a", en); if acsw then do; call archive_util_$disected_element (acptr, segp, en, bitc, ec); if ec = 0 then do; scc = divide (bitc, 9, 17, 0); go to nxac; end; end; wump: call iox_$close (iocbp, ec); call iox_$detach_iocb (iocbp, ec); exit: call hcs_$terminate_noname (segp, ec); end extract_message_doc;  extract_msg_doc_.pl1 05/22/86 1422.5rew 05/22/86 1419.2 57969 /****^ *********************************************************** * * * 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-05-22,Martinson), approve(86-05-22,MCR7412), audit(86-05-22,GJohnson), install(86-05-22,MR12.0-1060): Improve error message searching and fix bugs in search hueristics. END HISTORY COMMENTS */ extract_msg_doc_: proc (segname, segp, lth, iocbp, ec); /* This procedure extracts message documentation coded in a conventional way out of the source of a program. The extracted information is marked for sorting and editing and appended to an output file. THVV 3/77 Improved by R. Holmstedt 9/82 to find more error messages. */ dcl segname char (*), /* Parameters. Name of segment being scanned */ segp ptr, /* Ptr to input */ lth fixed bin (21), /* Lth of input */ iocbp ptr, /* Ptr to output */ ec fixed bin (35); /* status code */ /* ec = 1 means no documentation but has call to a logging subroutine ec = 2 means has BEGIN but no end ec = 3 means has BEGIN - END but no Message: any other ec came from vfile_ */ dcl START char (28) static options (constant) init ("BEGIN MESSAGE DOCUMENTATION "); dcl END char (25) static options (constant) init ("END MESSAGE DOCUMENTATION"); dcl NL char (1) static options (constant) init (" "); dcl NLNL char (2) static options (constant) init (" "); dcl NL_QUOTE_NL_QUOTE char (4) static options (constant) init (" "" """); dcl MSG char (9) static options (constant) init ("Message: "); dcl (beginning_of_documentation, doc_block_size, cur_msg_index, errmess_lth) fixed bin (21); dcl (pfx_lth, msg_block_start, msg_block_lth) fixed bin (21); dcl pfx char (32) var; /* Chars to discard at begin of each line */ dcl segment char (lth) based (segp); /* Input */ dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl (addr, index, length, reverse, substr, verify) builtin; ec = 1; beginning_of_documentation = index (segment, START); /* Scan for BEGIN */ if beginning_of_documentation = 0 then do; call check_calls; /* Check if any logging */ return; /* Error 1 no message documentation or Error 0 no */ end; /* message documentation because no logging calls */ ec = 2; /* Check Error 2 - Message block has not end */ beginning_of_documentation = beginning_of_documentation + length (START); doc_block_size = index (substr (segment, beginning_of_documentation), END); /* Find END. */ if doc_block_size = 0 then return; ec = 3; cur_msg_index = index (substr (segment, beginning_of_documentation, doc_block_size), MSG); /* Find header */ if cur_msg_index = 0 then do; call check_calls; /* Check if any logging */ return; /* Error 3, empty message block or Error 0, empty message */ end; /* block because no logging calls */ ec = 0; /* All is well */ msg_block_start = beginning_of_documentation+cur_msg_index-1; pfx_lth = index (reverse (substr (segment, 1, msg_block_start-1)), NL)-1; pfx = substr (segment, msg_block_start-pfx_lth, pfx_lth); do while (cur_msg_index < doc_block_size); cur_msg_index = cur_msg_index + length (MSG); msg_block_start = beginning_of_documentation+cur_msg_index-1; msg_block_lth = index (substr (segment, msg_block_start, doc_block_size-cur_msg_index+1), MSG)-1; if msg_block_lth <= 0 then msg_block_lth = doc_block_size-cur_msg_index; errmess_lth = index (substr (segment, msg_block_start, msg_block_lth-1), NLNL); /* Standard end of message PL/I source */ if errmess_lth = 0 then errmess_lth = index (substr (segment, msg_block_start, msg_block_lth-1), NL_QUOTE_NL_QUOTE); /* Standard end of message ALM source */ if errmess_lth > 0 then do; call putc ("["); call iox_$put_chars (iocbp, addr (segname), length (rtrim (segname)), 0); call putc ("]"); call putc (" "); call move_lines (msg_block_start, errmess_lth); call putc ("~"); call putc (NL); call move_lines (msg_block_start+errmess_lth+2-1, msg_block_lth+1-errmess_lth-2); call putc ("!"); call putc (NL); end; cur_msg_index = cur_msg_index + msg_block_lth; end; return; check_calls: proc; if index (segment, "call syserr") ^= 0 then return; if index (segment, "call syserr") ^= 0 then return; /* callTAB... */ if index (segment, "call sys_log_") ^= 0 then return; if index (segment, "call sys_log_") ^= 0 then return; /* callTAB... */ if index (segment, "call admin_gate_$syserr") ^= 0 then return; if index (segment, "call admin_gate_$syserr") ^= 0 then return; /* callTAB... */ if index (segment, "call salv_err_msg") ^= 0 then return; if index (segment, "call salv_err_msg") ^= 0 then return; /* callTAB... */ if index (segment, "call hphcs_$syserr") ^= 0 then return; if index (segment, "call hphcs_$syserr") ^= 0 then return; /* callTAB... */ ec = 0; /* Not an error, no logging calls */ end check_calls; move_lines: proc (a_beg, a_nleft); dcl (a_beg, a_nleft) fixed bin (21); dcl (beg, nleft, llth, trim_lth, tpx, nls) fixed bin (21); beg = a_beg; nleft = a_nleft; nls = 0; do while (nleft > 0); llth = index (substr (segment, beg, nleft), NL); if llth = 0 then llth = nleft+1; tpx = min (llth-1, pfx_lth); /* Discard the "prefix" */ if substr (segment, beg, tpx) ^= pfx /* .. which we noted before the first "Message:" */ then tpx = 0; if llth-tpx > 1 then do while (nls > 0); call putc (NL); nls = nls - 1; end; call iox_$put_chars (iocbp, addr (substr (segment, beg+tpx, 1)), llth-tpx-1, 0); nls = nls + 1; beg = beg + llth; nleft = nleft - llth; end; end move_lines; putc: proc (c); dcl c char (1); call iox_$put_chars (iocbp, addr (c), 1, 0); end putc; end extract_msg_doc_;  gate_sw.pl1 11/15/82 1845.8rew 11/15/82 1515.4 88506 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ gate_sw: proc (name, switch) ; dcl name char (*), switch char (*) ; /* created by A Kobziar to allow the dynamic switching of a gate to one that has calls to user proceedures rather than system proceedures, for the purpose of testing the user enviroment. USAGE: call gate_sw(name,function); 1. name char(*) path name of the gate segment, to be found using standard search rules. 2. function char(*) specification of which function to be performed from the following options: "sim_init" this will initialize the user's gate, make the system's gate known by the name "real_(name of gate)", and set switch to make calls to user's proceedures. "sim" this will set the switch in the user's gate to make calls to user proceedures. "real" this will set the switch in the user's gate to make calls to system proceedures. "revert" this will terminate the user's gate and initiate system's gate with "(gate's name)". This allows the return to system enviroment without doing a new_proc. The old gate is made known to the process by the refname "real_|name|. Switching back and forth is permitted. */ /* NOTES: 1. "sim_init" must be the first function executed if the user wants to replace a system gate. Otherwize the "sim" and "real" functions can be used for a private switchable gate. 2. any number of switchable gates can coexist. 3. Works because kst is hashed with gate name and ring no. */ dcl (save_p, p, gate_ptr, pnamep, dirp, gatedirp, enamep, refp) ptr ; dcl (hcs_sw, reset_sw) bit (1) aligned; dcl (pnamel, len) fixed bin ; dcl code fixed bin (35); dcl (dirname, gatedir) char (168), (refname, ename) char (32) ; dcl schar char (4) ; dcl whoami char (8) aligned ; dcl (addr, length, null) builtin; dcl 1 ret_struc aligned, 2 num fixed bin, 2 names (22) char (168) aligned ; dcl 1 lib_sr_struc aligned, 2 num fixed bin, 2 name char (168) aligned ; /* the following ext entry names, except for hcs_, cannot be used as name of user's gate */ dcl hcs_$get_search_rules ext entry (ptr) ; dcl hcs_$initiate_search_rules ext entry (ptr, fixed bin(35)) ; dcl (hcs_$make_ptr, real_hcs_$make_ptr) ext entry (ptr, char (*), char (*), ptr, fixed bin (35)); dcl (hcs_$initiate, real_hcs_$initiate) ext entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl (hcs_$terminate_name, real_hcs_$terminate_name) ext entry (char (*), fixed bin (35)); dcl term_$nomakeunknown ext entry (ptr, fixed bin(35)) ; dcl (cu_$ptr_call, com_err_) ext entry options (variable); dcl expand_path_ ext entry (ptr, fixed bin, ptr, ptr, fixed bin(35)) ; dcl (hcs_$fs_get_path_name, real_hcs_$fs_get_path_name) ext entry (ptr, char (*), fixed bin, char (*), fixed bin (35)); dcl (hcs_$fs_get_seg_ptr, real_hcs_$fs_get_seg_ptr) ext entry (char(*), ptr, fixed bin (35)); dcl (error_table_$segknown, error_table_$name_not_found) ext fixed bin (35); hcs_sw, reset_sw = "0"b ; /* initialize for gate name not hcs_ */ whoami = "gate_sw" ; pnamep = addr (name) ; pnamel = length (name) ; /* set up for expand path */ dirp = addr (dirname) ; enamep = addr (ename) ; refp = addr (refname) ; gatedirp = addr (gatedir) ; call expand_path_ (pnamep, pnamel, dirp, enamep, code) ; if code ^= 0 then do ; call com_err_ (code, whoami, "Expand_path err on ^a", name) ; return ; end ; if ename = "hcs_" then hcs_sw = "1"b ; /* gate is hcs_ */ if switch = "sim_init" then do ; refname = "real_"||ename ; /* name original gate real_|name| */ save_p = addr (ret_struc) ; p = addr (lib_sr_struc) ; lib_sr_struc.num = 1 ; lib_sr_struc.name = "system_libraries" ; /* must get the pathname of the real gate, which may not be known to process */ call hcs_$get_search_rules (save_p) ; /* pick up user's search rules for safekeeping */ call hcs_$initiate_search_rules (p, code) ; /* search only the sys libraries */ if code ^= 0 then do ; call com_err_ (code, whoami, "Setting search rule error") ; reset_sw = "1"b; goto sr_rl; /* restor user's search rules */ end ; call hcs_$make_ptr (null, ename, "", gate_ptr, code) ; /* get ptr to real gate */ if code ^= 0 then do ; call com_err_ (code, whoami, "Err on init of real gate ^a", ename) ; reset_sw = "1"b; goto sr_rl; end ; call hcs_$fs_get_path_name (gate_ptr, gatedir, len, ename, code); /* get name of real gate */ if code ^= 0 then do ; call com_err_ (code, whoami, "Cannot get real gate pathname, ^a", ename) ; reset_sw = "1"b; goto sr_rl; end ; call hcs_$initiate (gatedir, ename, refname, 0, 1, gate_ptr, code) ; /* add refname real_(name) to old gate */ if code ^= error_table_$segknown then if code ^= 0 then do ; call com_err_ (code, whoami, "Unable to add refname ^a to ^a", refname, ename) ; reset_sw = "1"b; goto sr_rl; end ; sr_rl: call hcs_$initiate_search_rules (save_p, code) ; /* reset user's search rules */ if code ^= 0 then do ; call com_err_ (code, whoami, "Unable to reset user's search rules") ; end ; if reset_sw then return ; /* errors above - quit */ call term_$nomakeunknown (enamep, code) ; /* unlinking references to old gate (name) */ if code ^= 0 then do ; call com_err_ (code, whoami, "Err on term of ^a", ename) ; return ; end ; if hcs_sw then call real_hcs_$terminate_name (ename, code) ; /* removing reference (name) from old gate */ else call hcs_$terminate_name (ename, code) ; if code ^= 0 then if code ^= error_table_$name_not_found then do; call com_err_ (code, whoami, "Unable to remove refname ^a", ename) ; return ; end ; /* now must initiate user's gate */ if hcs_sw then call real_hcs_$initiate (dirname, ename, ename, 0, 1, p, code) ; else call hcs_$initiate (dirname, ename, ename, 0, 1, p, code) ; if code ^= 0 then do ; call com_err_ (code, whoami, "Unable to initiate new gate ^a", ename) ; reset: /* must now init the old gate */ if hcs_sw then call real_hcs_$initiate (gatedir, ename, ename, 0, 1, p, code) ; else call hcs_$initiate (gatedir, ename, ename, 0, 1, p, code) ; if code ^= 0 then do ; call com_err_ (code, whoami, "Unable to reinit real_^a with name", ename); return ; end; call com_err_ (0, whoami, "Real gate reestablished") ; return ; end ; schar = "sim" ; /* get entry ptr to switch in the user's gate */ setsym: if hcs_sw then call real_hcs_$make_ptr (p, ename, schar, gate_ptr, code) ; else call hcs_$make_ptr (p, ename, schar, gate_ptr, code) ; if code ^= 0 then do ; call com_err_ (code, whoami, "Unable to find entry real in ^a", name) ; goto reset ; end ; call cu_$ptr_call (gate_ptr) ; /* set switch in user's gate for function schar */ return ; end; /* the next call must be performed for all other functions */ /* get a pointer to user's gate */ if hcs_sw then call real_hcs_$initiate (dirname, ename, ename, 0, 1, p, code) ; /* get ptr to user's gate */ else call hcs_$initiate (dirname, ename, ename, 0, 1, p, code) ; if code ^= error_table_$segknown then if code ^= 0 then do ; call com_err_ (code, whoami, "Unable to get ptr to ^a", ename) ; return ; end ; if switch = "sim" then do ; schar = "sim" ; goto setsym ; end ; if switch = "real" then do ; schar = "real" ; goto setsym ; end ; if switch = "revert" then do ; /* want to reestablish old gate */ /* p pts to user's gate ename in dir dirname */ refname = "real_"||ename ; if hcs_sw then call real_hcs_$fs_get_seg_ptr (refname, save_p, code) ; /* pick up ptr to old gate */ else call hcs_$fs_get_seg_ptr (refname, save_p, code) ; if code ^= 0 then do ; call com_err_ (code, whoami, "Unable to get ptr to ^a", refname) ; return ; end ; if hcs_sw then call real_hcs_$fs_get_path_name (save_p, gatedir, len, ename, code) ; else call hcs_$fs_get_path_name (save_p, gatedir, len, ename, code) ; if code ^= 0 then do ; call com_err_ (code, whoami, "Unable to get pathname ^p", save_p) ; return ; end ; if hcs_sw then call real_hcs_$terminate_name (ename, code) ; /* terminating user's gate */ else call hcs_$terminate_name (ename, code) ; if code ^= 0 then do ; call com_err_ (code, whoami, "Unable to terminate gate ^a", ename) ; return ; end ; /* must initiate the system gate with refname of |ename| */ if hcs_sw then call real_hcs_$initiate (gatedir, ename, ename, 0, 1, p, code) ; else call hcs_$initiate (gatedir, ename, ename, 0, 1, p, code) ; if code ^= error_table_$segknown then if code ^= 0 then do ; call com_err_ (code, whoami, "Initiate err on ^a", ename) ; return ; end ; /* now will remove name "real_|ename| from sys gate */ call hcs_$terminate_name (refname, code) ; if code ^= 0 then do ; call com_err_ (code, whoami, "Unable to term name ^a on sys gate", refname) ; return ; end ; return ; end; call com_err_ (0, whoami, "Unable to recognize switch setting desired,please consult documentation for correct name") ; return ; end gate_sw ;  reduction_compiler.pl1 11/01/84 0827.8rew 11/01/84 0825.4 90549 /* *************************************************************** * * * * * Copyright (c) 1975 by Massachusetts Institute of Technology * * * * * *************************************************************** */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Status */ /* */ /* 1) Modified: February, 1981 by G. C. Dixon */ /* a) Add the -trace ctl_arg to invoke the internal tracing facility provided by the */ /* SEMANTIC_ANALYSIS routine. When a translator is compiled with -trace, a */ /* special trace routine is invoked each time a reduction is matched. This */ /* routine prints the matching reduction (as it appears in the .rd source), */ /* followed by the tokens which matched the reduction. */ /* b) Upgrade code to 1981 coding standards. */ /* 2) Modified: July 24, 1983 by G. C. Dixon */ /* a) Change long name from reduction_compiler to reductions. Name */ /* reduction_compiler will be retained for compatibility but will be undocumented. */ /* b) Make rdc invoke the pl1 command to compile the generated source, iff the rdc */ /* translation was successful. */ /* c) Make rdc set a severity variable accessible by the severity AF to indicate the */ /* results of both the rdc and pl1 translations. */ /* 3) Modified: Sep 10, 1984 by G. C. Dixon to change name in error messages from */ /* reduction_compiler to reductions. This was left out of change 2 above. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ reduction_compiler: reductions: rdc: procedure; dcl /* automatic variables */ Iarg fixed bin, Larg fixed bin, /* length of our input argument. */ Lobject fixed bin(21), /* length of output object segment (in chars). */ Lsource fixed bin(21), /* length of input source segment (in chars). */ Nargs fixed bin, /* number of input arguments. */ Parea ptr, /* ptr to our temporary allocation segment. */ Pacl_obj ptr, /* ptr to object seg's acl-info structure. */ Parg ptr, /* ptr to our input argument. */ Pobject ptr, /* ptr to object segment we're creating. */ Psource ptr, /* ptr to input source segment. */ 1 Scontrol aligned, (2 long bit(1), 2 brief bit(1), 2 trace bit(1), 2 trace_on_by_default bit(1), 2 pad bit(32)) unal, /* reduction_compiler_ control switches. */ bc_source fixed bin(24), /* bit count of source segment. */ cleanup condition, code fixed bin(35), /* a status code. */ dir char(168), /* dir part of source segment's path name. */ ent_source char(32), /* ent part of source segment's path name. */ ent_object char(32), /* ent part of object segment's path name. */ pl1_args char(300) varying; /* Args to be passed to pl1 compiler. */ dcl /* based variables */ arg char(Larg) based (Parg); /* our input argument. */ dcl /* builtin functions */ (addr, divide, index, length, max, null, string, substr) builtin; dcl /* entries and functions */ com_err_ entry options (variable), cu_$arg_count entry (fixed bin, fixed bin(35)), cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin(35)), cu_$cp entry (ptr, fixed bin(21), fixed bin(35)), expand_pathname_$add_suffix entry (char(*), char(*), char(*), char(*), fixed bin(35)), get_wdir_ entry returns (char(168) aligned), hcs_$initiate_count entry (char(*), char(*), char(*), fixed bin(24), fixed bin(2), ptr, fixed bin(35)), hcs_$terminate_noname entry (ptr, fixed bin(35)), hcs_$truncate_seg entry (ptr, fixed bin, fixed bin(35)), ioa_$nnl entry options(variable), pathname_ entry (char(*), char(*)) returns(char(168)), reduction_compiler_ entry (ptr, fixed bin(21), ptr, ptr, fixed bin(21), char(32), bit(*), fixed bin(35), fixed bin(35)), requote_string_ entry (char(*)) returns(char(*)), suffixed_name_$new_suffix entry (char(*), char(*), char(*), char(32), fixed bin(35)), translator_temp_$get_segment entry (char(*) aligned, ptr, fixed bin(35)), translator_temp_$release_all_segments entry (ptr, fixed bin(35)), tssi_$clean_up_segment entry (ptr), tssi_$finish_segment entry (ptr, fixed bin(24), bit(36) aligned, ptr, fixed bin(35)), tssi_$get_segment entry (char(*), char(*), ptr, ptr, fixed bin(35)); dcl /* static variables */ (error_table_$mdc_path_dup_args, error_table_$no_makeknown, error_table_$noentry, error_table_$wrong_no_of_args) fixed bin(35) ext static, pl1_severity_ fixed bin(35) ext static init(0), proc char(10) aligned int static init ("reductions"), reductions_severity_ fixed bin(35) ext static init(0), sys_info$max_seg_size fixed bin(35) ext static; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ call cu_$arg_count (Nargs, code); /* if we have less than one arg, complain. */ if code ^= 0 then go to NOT_AF; if Nargs < 1 then go to WNOA; string(Scontrol) = "0"b; ent_source = ""; pl1_args = ""; do Iarg = 1 to Nargs; call cu_$arg_ptr (Iarg, Parg, Larg, code); if arg = "-lg" | arg = "-long" then Scontrol.long = "1"b; else if arg = "-bf" | arg = "-brief" then Scontrol.brief = "1"b; else if arg = "-trace" then do; Scontrol.trace = "1"b; Scontrol.trace_on_by_default = "1"b; if Iarg < Nargs then do; Iarg = Iarg + 1; call cu_$arg_ptr (Iarg, Parg, Larg, code); if arg = "on" then; else if arg = "off" then Scontrol.trace_on_by_default = "0"b; else Iarg = Iarg - 1; end; end; else if arg = "-no_trace" then Scontrol.trace = "0"b; else if index(arg,"-") ^= 1 then do; if ent_source ^= "" then go to DUP_PATH; call expand_pathname_$add_suffix (arg, "rd", dir, ent_source, code); if code ^= 0 then go to BAD_PATH; call suffixed_name_$new_suffix (ent_source, "rd", "pl1", ent_object, code); if code ^= 0 then go to BAD_SOURCE; end; else do; /* A pl1 option? Let pl1 diagnose it. */ if arg = "-prefix" & Iarg < Nargs then do; Iarg = Iarg + 1; call cu_$arg_ptr (Iarg, Parg, Larg, code); pl1_args = pl1_args || " "; pl1_args = pl1_args || "-prefix"; pl1_args = pl1_args || " "; pl1_args = pl1_args || requote_string_(arg); end; else do; pl1_args = pl1_args || " "; pl1_args = pl1_args || arg; end; end; end; Parea = null; Psource = null; Pobject = null; /* initialize ptrs used by cleanup on-unit. */ on cleanup call cleaner; /* cleanup when required. */ call hcs_$initiate_count (dir, ent_source, "", bc_source, 0, Psource, code); if Psource = null then go to BAD_SOURCE; /* initiate source segment. */ Lsource = divide (bc_source, 9, 35, 0); /* convert bit count to character count. */ call translator_temp_$get_segment (proc, Parea, code); if Parea = null then go to BAD_AREA; dir = get_wdir_(); /* put object segment in working directory. */ call tssi_$get_segment (dir, ent_object, Pobject, Pacl_obj, code); if code ^= 0 then go to BAD_OBJECT; /* get ptr to object segment we're creating. */ Lobject = sys_info$max_seg_size * 4; call ioa_$nnl ("RDC - "); call reduction_compiler_ (Psource, Lsource, Parea, Pobject, Lobject, ent_source, string(Scontrol), reductions_severity_, code); if Lobject = 0 then /* create object segment. If 0 length, ERROR. */ call hcs_$truncate_seg (Pobject, 0, 0); call tssi_$finish_segment (Pobject, Lobject * 9, "1000"b, Pacl_obj, 0); /* finish up the object segment. */ Pobject = null; /* cleanup now. */ call cleaner; if code ^= 0 then go to ERROR; pl1_args = "[where pl1]$pl1 " || pathname_ (dir, ent_object) || pl1_args; call cu_$cp (addr(substr(pl1_args,1)), length(pl1_args), code); reductions_severity_ = max(reductions_severity_, pl1_severity_); return; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ cleaner: proc; /* cleanup procedure. */ dcl code fixed bin(35); /* It has its own status code. */ if Psource ^= null then call hcs_$terminate_noname (Psource, code); if Parea ^= null then call translator_temp_$release_all_segments (Parea, code); if Pobject ^= null then call tssi_$clean_up_segment (Pacl_obj); end cleaner; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ DUP_PATH: call com_err_ (error_table_$mdc_path_dup_args, proc, "^a Only one pathname may be given.", arg); return; NOT_AF: call com_err_ (code, proc); return; WNOA: call com_err_ (error_table_$wrong_no_of_args, proc, "^/Calling sequence:^-reductions pathname {-ctl_args} control_arg is:^--long, -lg^/^2--brief,-bf^/^2--trace {on|off}^/^2--no_trace, -ntrace"); return; BAD_PATH: call com_err_ (code, proc, " ^a", arg); return; BAD_SOURCE: if code = error_table_$no_makeknown then code = error_table_$noentry; call com_err_ (code, proc, " ^a^[>^]^a", dir, dir^=">", ent_source); return; BAD_AREA: call com_err_ (code, proc, "^/While creating a temporary segment in the process directory."); call cleaner; return; BAD_OBJECT: call com_err_ (code, proc, "^/While creating the object segment^/(^a^[>^]^a).", dir, dir^=">", ent_object); call cleaner; return; ERROR: call com_err_ (code, proc, "^/No object segment will be generated."); return; end reduction_compiler;  reduction_compiler_.rd 03/17/86 1520.8rew 03/17/86 1438.6 671418 /* *************************************************************** * * * Copyright (c) 1986 by Massachusetts Institute of Technology * * * * Copyright (c) 1975 by Massachusetts Institute of Technology * * * *************************************************************** */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* N__a_m_e: reduction_compiler_ */ /* */ /* This procedure is the subroutine interface for the reduction_compiler. It */ /* accepts as input a set of reductions, a temporary segment for use in allocations */ /* of a temporary nature, and a pointer to and maximum length of the object segment to */ /* be generated. It returns the actual length of the compiled object segment. */ /* The reductions to be compiled have been pre-processed by the lex_string_ */ /* subroutine, and are represented by a chain of input tokens. */ /* This subroutine is, itself, driven by a set of reductions which were compiled */ /* by a bootstrapped version of the reduction_compiler. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* HISTORY COMMENTS: 1) change(74-04-05,GDixon), approve(), audit(), install(86-03-17,MR12.0-1032): Version 1.0-- Created the reduction_compiler (rdc) command. 2) change(74-05-06,GDixon), approve(), audit(), install(86-03-17,MR12.0-1032): Version 1.1-- Fixed bugs in initial version. 3) change(74-05-17,GDixon), approve(), audit(), install(86-03-17,MR12.0-1032): Version 1.2-- Changed the following rdc constructs: a) STACK-POP ==> STACK_POP b) (PL/I-stmt) ==> [PL/I-stmt] for semantic statements. 4) change(75-01-30,GDixon), approve(), audit(), install(86-03-17,MR12.0-1032): Version 1.3-- Make relative syntax functions quick PL/I blocks by converting array of entries into relative syntax functions into a label transfer vector into calls to the relative syntax functions. 5) change(75-02-03,GDixon), approve(), audit(), install(86-03-17,MR12.0-1032): Version 2.0-- a) code generated for LEX converted to calls to a subroutine LEX(n). b) new DELETE and DELETE_STMT built-in action routines added. c) new INCLUDE attribute added to force inclusion of include segments. d) code for PUSH DOWN LANGUAGE added but not documented. e) allocate statements changed to calls to translator_temp_$allocate. 6) change(75-04-28,GDixon), approve(), audit(), install(86-03-17,MR12.0-1032): Version 2.1-- a) put a space after all tokens in semantic statement brackets ([]), except tokens, and the following paired token sequences: < = > = ^ = ^ > ^ < - > b) In order to implement this change, four new break characters were added: - ^ = ; c) Commenting delimiters were added: \" begins a comment, which ends with a newline character. 7) change(81-02-16,GDixon), approve(), audit(), install(86-03-17,MR12.0-1032): Version 2.2-- a) INCLUDE LEX stmt added, because of b) code added to detect only use of LEX (rather than LEX(N)). If only LEX used, then the LEX subroutine is NOT included in SEMANTIC_ANALYSIS by default. c) Many data structures declared options(constant) d) VT now acccpted in .rd segments as a whitespace character e) in a PUSH DOWN LANGUAGE checks to see if token on top of push down stack is the final input token (ie, all tokens are on the stack or have been deleted. f) Add code to support rdc's -trace control argument. 8) change(83-07-23,GDixon), approve(), audit(), install(86-03-17,MR12.0-1032): Version 2.3-- a) Place sequence numbers in unlabeled reductions appearing in the .pl1 and .list segments. The same numbers are placed in the reductions printed during tracing. b) Changed implementation of -trace to avoid temporary copying of reduction source. Instead, reduction source is extracted from the stmt descriptors. 9) change(84-09-08,GDixon), approve(), audit(), install(86-03-17,MR12.0-1032): Version 2.4-- a) Allow ERROR (named_constant) in addition to ERROR (decimal_integer) b) Use perprocess date_time format for date put in header comment of translator. 10) change(85-10-21,GDixon), approve(86-02-06,MCR7339), audit(86-02-19,Wallman), install(86-02-19,MR12.0-1022): Version 2.5-- Upgrade the severity of several error messages to severity 3, because these messages describe conditions which are likely to make PL/I compilation fail. Severity 3 errors prevent the PL/I compiler from being invoked. (phx19850) END HISTORY COMMENTS */ /*++ MAX_DEPTH 20 \ BEGIN / / ERROR(1) / stop \ / / reductions_init / attributes \ attributes \" 1) parse and process the reduction attributes. If present, these must precede any \" reduction statements. / BEGIN / [Psave = Pthis_token] / pass1 \ / MAX_DEPTH "\" / LEX set_depth LEX(2) / attributes \ / PUSH DOWN LANGUAGE "\" / LEX(4) [S_PDL = "1"b] / attributes \ / INCLUDE DELETE "\" / LEX(3) [Sinclude_DELETE = "1"b] / attributes \ / INCLUDE DELETE_STMT "\" / LEX(3) [Sinclude_DELETE_STMT = "1"b] / attributes \ / INCLUDE ERROR "\" / LEX(3) [Sinclude_ERROR = "1"b] / attributes \ / INCLUDE NEXT_STMT "\" / LEX(3) [Sinclude_NEXT_STMT = "1"b] / attributes \ / INCLUDE LEX "\" / LEX(3) [Sinclude_LEX = "1"b] / attributes \ / INCLUDE / ERROR(19) NEXT_STMT / attributes \ / / ERROR(1) / stop \ / / ERROR(2) NEXT_STMT / attributes \ pass1 \" 1) create a symbol table giving name and reduction number for all reduction labels. \" 2) count the tokens in the syntax specification field to get an estimate of the amount \" of temporary storage rdc will need to hold the syntax specifications. set_label / /_ / count_reduction LEX / count \ / / set_label LEX / set_label \ / "\" / ERROR(22) LEX / set_label \ / / reductions_begin [Pthis_token = Psave] / pass2 \ / / ERROR(3) LEX / set_label \ count / / count_token(1) LEX(1) / count \ / /_ _ / count_token(1) LEX(3) / count \ / /_ / NEXT_STMT / set_label \ / / count_token(1) LEX / count \ / / ERROR(5) / stop \ pass2 \" Process the reduction statements, as follows: \" 1) skip over any labels on the reduction statement. \" 2) compile the syntax specifications by storing them in rdc's temporary syntax table. \" 3) compile the action specifications by outputting calls to built-in action routines and \" semantic subroutines, and by outputting semantic statements. \" 4) compile the next reduction field by outputting code to transfer to the appropriate reduction. label skip_label / /_ / reduction_begin LEX / first_token \ / / LEX / skip_label \ / "\" / LEX / skip_label \ / / LEX / skip_label \ / / / stop \ first_token / / / token1 \ \" For a non-PUSH DOWN LANGUAGE, followed by any syntax specification is in error \" because tokens are checked from left to right; for a PUSH DOWN LANGUAGE, has \" meaning as the first or last specification in a reduction. As the first spec, it identifies \" the bottom of the push-down stack. As the last spec, it identifies when the list of input tokens \" has run out. / / / tokens \ token1 / / / tokens \ / <_ no - token >_ / compile_token(1) LEX(5) / tokens \ tokens / / compile_token(0) LEX / tokens \ / /_ _ / compile_token(0) LEX(3) / tokens \ / /_ / LEX action_begin / action \ / < _ / compile_token(0) LEX(3) / tokens \ / > _ / compile_token(0) LEX(3) / tokens \ / [ _ / compile_token(0) LEX(3) / tokens \ / ] _ / compile_token(0) LEX(3) / tokens \ / ( _ / compile_token(0) LEX(3) / tokens \ / ) _ / compile_token(0) LEX(3) / tokens \ / <_ no - token >_ /_ / compile_token(1) LEX(6) action_begin / action \ / <_ no - token >_ / LEX(5) ERROR(14) / error_in_red \ / <_ any - token >_ / compile_token(2) LEX(5) / tokens \ / <_ name >_ / compile_token(3) LEX(3) / tokens \ / <_ decimal - integer >_ / compile_token(4) LEX(5) / tokens \ / <_ BS >_ / compile_token(5) LEX(3) / tokens \ / <_ quoted - string >_ / compile_token(6) LEX(5) / tokens \ / <_ >_ / LEX compile_token(7) LEX(2) / tokens \ / "\" / LEX ERROR(22) / label \ / / compile_token(0) LEX / tokens \ / / ERROR(5) / stop \ action / /_ / LEX / next_red \ / LEX ( ) / set_action_with_args LEX(2) PUSH(last_paren) [Sinclude_LEX = "1"b] / args \ / LEX ( - ) / set_action_with_args LEX(2) PUSH(last_paren) [Sinclude_LEX = "1"b] / args \ / LEX ( + ) / set_action_with_args LEX(2) PUSH(last_paren) [Sinclude_LEX = "1"b] / args \ / LEX ( / ERROR(19) / error_in_red \ / LEX / rtn(1) LEX / action \ / NEXT_STMT ( / ERROR(19) / error_in_red \ / NEXT_STMT / set_action LEX [Sinclude_NEXT_STMT = "1"b] / action \ / POP ( / ERROR(19) / error_in_red \ / POP / rtn(2) LEX / action \ / PUSH ( ) / LEX(2) rtn(3) LEX(2) / action \ / PUSH / ERROR(19) / error_in_red \ / DELETE / / DELETE \ \" Remove tests for all of the DELETE cases from main stream of reductions to a subroutine. / DELETE_STMT ( / ERROR(19) / error_in_red \ / DELETE_STMT / set_action LEX [Sinclude_DELETE_STMT = "1"b] / action \ / ERROR ( ) / set_action_with_args LEX(2) [Sinclude_ERROR = "1"b] PUSH(last_paren) / args \ / ERROR ( / set_action_with_args LEX(2) [Sinclude_ERROR = "1"b] PUSH(last_paren) / args \ \" The preceding reduction allows the builtin ERROR routine to accept \" a named constant instead of a decimal integer. / [ / output((6)" " || (4)" ") LEX / stmt \ / ] / ERROR(21) LEX / action \ / ( / ERROR(21) LEX / action \ / ) / ERROR(21) LEX / action \ / / ERROR(23) / error_in_red \ / "\" / ERROR(22) / error_in_red \ / ( / set_action_with_args LEX(2) PUSH(last_paren) / args \ / / set_action LEX / action \ / / ERROR(5) / stop \ error_in_red / / [obj_red.Ilast(Nobj_red) = 0] reduction_end NEXT_STMT / label \ DELETE / DELETE ( , ) / / DELETE_2 \ / DELETE ( , - ) / / DELETE_2 \ / DELETE ( , + ) / / DELETE_2 \ / DELETE ( - , ) / / DELETE_2 \ / DELETE ( - , - ) / / DELETE_2 \ / DELETE ( - , + ) / / DELETE_2 \ / DELETE ( + , ) / / DELETE_2 \ / DELETE ( + , - ) / / DELETE_2 \ / DELETE ( + , + ) / / DELETE_2 \ / DELETE ( ) / / DELETE_1 \ / DELETE ( - ) / / DELETE_1 \ / DELETE ( + ) / / DELETE_1 \ / DELETE ( / ERROR(19) / error_in_red \ / DELETE / set_action_with_args LEX output(" 0, 0 )") [Sinclude_DELETE = "1"b] / last_paren\ \" The only way to reach the next reduction is by branch. All possible cases of DELETE \" have been handled above, including illegal ones. DELETE_1 / / set_action_with_args LEX(2) [Sinclude_DELETE = "1"b] / \ / / output(" ") output(token_value) LEX output(token_value) LEX(-1) output(",") PUSH(last_paren) / args \ / / output(" ") output(token_value) output(",") PUSH(last_paren) / args \ DELETE_2 / / set_action_with_args LEX(2) PUSH(last_paren) [Sinclude_DELETE = "1"b] / args \ stmt \" Process the contents of semantic statements. Special attention is given when generating \" PL/I code for the statements to the following cases: \" 1) No space is placed between the last token of a semantic statement and its \" ending semi-colon statement delimiter. \" 2) No space is placed between an argument in a subprogram call and any comma delimiter \" which may follow it. \" 3) No space is placed between a quoted string and any b, b1, b2, b3 or b4 \" token which follows it in order to handle bit string constants (eg "101"b) \" 4) No space is placed between any of the following pairs of characters which \" have a special meaning in the PL/I language: -> >= <= ^= ^> ^< \" 5) No space is placed between any minus sign (-) and the token which follows, in \" order to handle signed numeric constants. \" 6) Semantic statements appearing in the same pair of brackets in an action specification \" are placed on different lines in the generated code (as if they had appeared in \" separate brackets). / b / / bit_constant \ / b1 / / bit_constant \ / b2 / / bit_constant \ / b3 / / bit_constant \ / b4 / / bit_constant \ / / output(" ") output_quote(token_value) LEX / \ / ( / output(" ") output("(") PUSH(stmt) LEX / args \ / ] / LEX / last_paren \ / ; / output (";" || NL || (6)" " || (4)" ") LEX / stmt \ / "\" / ERROR(24) / error_in_red \ / / PUSH(stmt) PUSH(stmt1) / special_chars \ \" Always branch to special subroutine to check for paired character sequences. \" This subroutine returns to the 1st PUSHed label if a paired character sequence \" is found, and to the second PUSHed label if no paired sequence is found. stmt1 / / POP / \ / / output(" ") output(token_value) LEX / stmt \ / / ERROR(5) / stop \ bit_constant / / output(" ") output_quote(token_value) LEX output(token_value) LEX / stmt \ args \" This reduction subroutine processed the arguments in calls to semantic subroutines, and \" the parenthesized expression or sub-program arguments in semantic statements. It handles \" the special cases described above under "stmt". Nested parentheses are handled to a \" depth of about 17. It returns to the last PUSHed reduction label. / ( / / quoted_arg \ / "\" / / quoted_arg \ / ) / / quoted_arg \ / / output(" ") output_quote(token_value) LEX output(token_value) LEX / args \ quoted_arg / / output(" ") output_quote(token_value) LEX / \ / ( / output(" ") output("(") PUSH(args) LEX / args \ / ) / output(" ") output(")") LEX / STACK_POP \ / ; / ERROR(24) / error_in_red \ / "\" / ERROR(24) / error_in_red \ / / PUSH(args) PUSH(args1) / special_chars \ \" Always branch to special subroutine to check for paired character sequences. \" This subroutine returns to the 1st PUSHed label if a paired character sequence \" is found, and to the second PUSHed label if no paired sequence is found. args1 / / POP / \ / , / output(token_value) LEX / args \ / / output(" ") output(token_value) LEX / args \ / / ERROR(5) / stop \ last_paren/ / output(";") output(NL) / action \ special_chars \" Special reduction subroutine to check for paired character sequences in action specifications. \" Calling sequence is: / / PUSH(label1) PUSH(label2) / special_chars \ \" label2/ / POP / \ \" This subroutine returns through the first PUSHed reduction label if a paired sequence \" is found, and through the second PUSHed label if none if found. / < = / / spec_found \ / > = / / spec_found \ / ^ = / / spec_found \ / ^ > / / spec_found \ / ^ < / / spec_found \ / - > / / spec_found \ / - / / spec_found \ / + / / spec_found\ / / / STACK_POP \ spec_found / / output(" ") output(token_value) LEX output(token_value) LEX POP / STACK_POP \ next_red \" The final group of reductions identifies and compiles code for the various next \" reduction fields of a reduction statement. / "\" / next_reduction reduction_end LEX / label \ / RETURN "\" / terminal_reduction reduction_end LEX(2) / label \ / STACK "\" / stacked_reduction reduction_end LEX(2) / label \ / STACK_POP "\" / stacked_reduction_pop reduction_end LEX(2) / label \ / "\" / specified_label reduction_end LEX(2) / label \ / / specified_label reduction_end ERROR(16) NEXT_STMT / label \ / "\" / next_reduction reduction_end ERROR(4) NEXT_STMT / label \ / / next_reduction reduction_end ERROR(15) NEXT_STMT / label \ / / ERROR(5) / stop \ stop / / reductions_end / RETURN \ / / reductions_end ERROR(6) / RETURN \ ++*/ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ reduction_compiler_: proc (Psource, Lsource, Psegment, APobj, ALobj, Aname_source, Scontrol, Mseverity, Acode); dcl Psource ptr, /* ptr to reduction source segment. (In) */ Lsource fixed bin(21), /* length of reduction source segment (in chars). */ /* (Input) */ Psegment ptr, /* ptr to a segment in which allocations */ /* may be performed. The segment must be a temp */ /* segment provided by translator_temp_. (In) */ APobj ptr, /* ptr to words of the object segment. (In) */ ALobj fixed bin(21), /* maximum number of characters allowed in object */ /* segment. (In) */ /* number of words in constructed object segment. */ /* (Out) */ Aname_source char(32), /* entry name of input source segment. (In) */ Scontrol bit(*), /* error format control bits. (In) */ Mseverity fixed bin(35), /* severity of highest-severity error encountered */ /* during the compilation. (Out) */ Acode fixed bin(35); /* error code. (Out) */ dcl /* automatic variables */ (Ired_start, Ired_end) fixed bin(21), /* index into source of start/end of reductions. */ Llongest_red fixed bin, /* length (in chars) of longest reduction. */ Lobj fixed bin(21), /* length (in chars) of unused part of object */ /* segment being created. */ Lobj_part fixed bin(21) init (0), /* length of a subset of the object segment. */ Lobj_spaces fixed bin, /* number of spaces to be output into object seg. */ Lobj_string fixed bin, /* maximum length of the string containing the */ /* stored object token values. */ Lobj_string_part fixed bin(21), /* length of a particular token value within the */ /* string of all object token values. */ Ltemp fixed bin(21), /* length of temporary character string. */ Ltemp_obj fixed bin(21), /* length of temp copy of object segment contents.*/ Mstack_depth fixed bin, /* user-specified maximum depth of the */ /* next-reduction-label stack. */ Nchar pic "----9" aligned,/* convert fixed bin integers to 4-char numbers. */ Nobj_red fixed bin, /* index of the object reduction being compiled. */ Nobj_token fixed bin, /* index of the object token being compiled. */ Nobj_token_fcn fixed bin, /* index of the object token function being */ /* compiled. */ Nreductions fixed bin, /* number of reductions which can be stored in */ /* object reduction storage structure. */ Ntokens fixed bin, /* number of token requirements which can be */ /* stored in object token storage structure. */ Osc_start fixed bin(21), /* char offset of start of source to be output. */ Pobj ptr, /* ptr to unused part of object segment. */ Pobj_red ptr, /* ptr to temp. storage structure for object */ /* reductions. */ Pobj_spaces ptr, /* ptr to adjustable-length string of spaces. */ Pobj_string ptr, /* ptr to temp. storage string for object token */ /* values. */ Pobj_string_part ptr, /* ptr to a particular token value within the */ /* string of all object token values. */ Pobj_token ptr, /* ptr to temp. storage structure for object */ /* token requirements. */ Pobj_token_quoted ptr, /* ptr to temp. storage for bits which are on if */ /* object token was in quotes when input. */ Psave ptr, /* ptr used in saving/restoring value of */ /* Pthis_token between pass1 and pass2. */ Ptemp ptr, /* ptr to temporary character string. */ Ptemp_obj ptr, /* ptr to temp copy of object segment contents. */ S_PDL bit(1) aligned, /* on if to be in 'PUSH DOWN LANGUAGE' mode. */ S_TRACE bit(1) aligned, /* on if tracing code is to be generated. */ S_TRACE_ON bit(1) aligned, /* on if tracing to be on initially. */ Sinclude_DELETE bit(1) aligned, /* on if DELETE proc to be included in object seg.*/ Sinclude_DELETE_STMT bit(1) aligned, /* on if DELETE_STMT proc to be included in obj. */ Sinclude_ERROR bit(1) aligned, /* on if ERROR proc to be include in object seg. */ Sinclude_NEXT_STMT bit(1) aligned, /* on if NEXT_STMT proc to be included. */ Sinclude_LEX bit(1) aligned, /* on if LEX proc to be included. */ Sinclude_STACK bit(1) aligned, /* on if STACK procs to be included in obj seg. */ Soptimize_possible bit(1) aligned, /* on if optimization of object token storage */ /* allocation is possible for the tokens assoc. */ /* with the reduction being compiled. */ code fixed bin(35), /* a status code. */ date char(53), /* a date/time string. */ form fixed bin, /* form of an object token. */ i fixed bin, /* an integer temporary. */ j fixed bin, /* an integer temporary. */ name_source char(32), /* name of source segment, without its suffix. */ 1 obj_label aligned, /* temp storage for labels on object reductions. */ 2 N fixed bin, /* number of labels currently defined. */ 2 set (1000), /* space for up to 1000 labels. */ 3 name char(32) aligned, /* name of label. */ 3 reduction_no fixed bin, /* number of reduction labelled by this label. */ 1 obj_token_fcn aligned, /* temp storage for relative token requirement */ /* functions. */ 2 N fixed bin, /* number of object token requirements defined. */ 2 name (100) char(32) varying, /* name of token requirement. */ type fixed bin; /* type of an object token. */ dcl /* builtin functions */ (addcharno, addr, addrel, bit, char, charno, dimension, divide, fixed, index, length, log, ltrim, max, min, null, rtrim, size, string, substr, verify) builtin; dcl /* entries */ clock_ entry returns (fixed bin(71)), date_time_$format entry (char(*), fixed bin(71), char(*), char(*)) returns(char(250) var), lex_error_ entry options (variable), lex_string_$lex entry (ptr, fixed bin(21), fixed bin(21), ptr, bit(*) aligned, char(*) aligned, char(*) aligned, char(*) aligned, char(*) aligned, char(*) aligned, char(*) varying aligned, char(*) varying aligned, char(*) varying aligned, char(*) varying aligned, ptr, ptr, fixed bin(35)), lex_string_$init_lex_delims entry (char(*) aligned, char(*) aligned, char(*) aligned, char(*) aligned, char(*) aligned, bit(*) aligned, char(*) varying aligned, char(*) varying aligned, char(*) varying aligned, char(*) varying aligned), suffixed_name_$new_suffix entry (char(*), char(*), char(*), char(32), fixed bin(35)), translator_temp_$allocate entry (ptr, fixed bin) returns (ptr); dcl NL char(1) defined (NP) position (2); dcl /* based variables */ obj char(Lobj) aligned based (Pobj), /* object segment being created. */ 1 obj_red aligned based (Pobj_red), /* temp storage for object reductions, prior */ /* to outputting them into the object segment. */ 2 N fixed bin, /* number of reductions currently defined. */ 2 M fixed bin, /* maximum number which may be defined. */ 2 token_reqd (Nreductions refer (obj_red.M)), 3 Ifirst fixed bin(17) unal, /* index of 1st and last token requirements */ 3 Ilast fixed bin(17) unal, /* associated with this reduction. */ obj_spaces char(Lobj_spaces) based (Pobj_spaces), /* overlay for a number of spaces used to */ /* right-adjust an output line. */ obj_string char(Lobj_string) varying aligned based (Pobj_string), /* temp storage for object token values. */ obj_string_part char(Lobj_string_part) based (Pobj_string_part), /* overlay for a particular token value within */ /* the string of all object token values. */ obj_token_quoted (Ntokens) bit(1) unaligned based (Pobj_token_quoted), /* on if object token was enclosed in quotes. */ 1 obj_token aligned based (Pobj_token), /* temp storage for object token requirements, */ /* prior to outputting them into the object seg. */ 2 N fixed bin, /* number of tokens currently defined. */ 2 M fixed bin, /* maximum number which may be defined. */ 2 token (Ntokens refer (obj_token.M)), 3 form fixed bin(17) unal, /* form of the object token: */ /* -1 = relative token requirement function; */ /* type = index of the particular token */ /* function in the token_fcn array. */ /* 0 = built-in token requirement function; */ /* type = as defined below. */ /* >0 = absolute token requirement: */ /* form = index(token_strings,token_req); */ /* type = length(token_req); */ 3 type fixed bin(17) unal, /* type of the built-in token requirement */ /* function: */ /* 1 = compile test to see if input token */ /* chain is exhausted (). */ /* 2 = compile test for any token value */ /* (). */ /* 3 = compile test for a PL/I identifier */ /* () of 32 or fewer characters. */ /* 4 = compile test for token which is a */ /* . */ /* 5 = compile test for token which is a single */ /* backspace character (). */ /* 6 = compile test for a token which is a */ /* . */ source char(Lsource) based(Psource), /* overlay for reduction source segment. */ temp char(Ltemp) based (Ptemp), /* overlay for part of object segment contents */ /* just generated. */ temp_obj char(Ltemp_obj) based (Ptemp_obj); /* temporary copy of object segment contents. */ dcl /* static variables */ HT char(1) int static options(constant) init(" "), HT_SP char(2) int static options(constant) init(" "), Mreductions fixed bin int static options(constant) init (9999), MMstack_depth fixed bin int static options(constant) init (9999), Mtokens fixed bin int static options(constant) init (9999), NP char(2) int static options(constant) init (" "), /* */ Sinitialization_reqd bit(1) aligned int static init ("1"b), breaks char(19) varying aligned int static options(constant) init (" /\<>[]()-^=;, "), /* BS SP HT NL / \ < > [ ] ( ) - ^ = ; , VT NP */ 1 error_control_table (26) aligned internal static options(constant), /* reduction compiler error message text and */ /* action specifications. */ /* 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 */ /*16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 */ 2 severity fixed bin(17) unaligned init ( 3, 2, 2, 3, 3, 2, 4, 4, 4, 4, 3, 4, 3, 2, 3, 3, 4, 2, 3, 4, 3, 3, 3, 3, 3, 3), /* severity of each error. */ 2 Soutput_stmt bit(1) unaligned init ( "0"b, "1"b, "1"b, "1"b, "0"b, "0"b, "1"b, "1"b, "1"b, "1"b, "1"b, "0"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "0"b, "0"b), /* on if "current" statement should be output */ /* with the error message. */ 2 message char(252) varying init ( /* 1 */ "The reduction source segment does not contain any valid reductions.", /* 2 */ "The statement is not a valid attribute declaration or reduction. (Remember, the label of the first reduction must be 'BEGIN'.)", /* 3 */ "Label '^a' is invalid. The label has been ignored.", /* 4 */ "Label '^a' in the next-reduction field of the reduction statement is invalid. The label has been ignored.", /* 5 */ "Unexpected end encountered. The reduction source segment ends with an incomplete reduction.", /* 6 */ "Unexpected statement encountered when the end of the reduction source segment was expected.", /* 7 */ "Compiler restriction: the reduction source segment contains more than ^d labels. Label '^a' and all labels which follow it have been ignored.", /* 8 */ "Compiler restriction: the reduction source segment contains more than ^d reductions. The reduction on line ^d, and those which follow it, could not be compiled.", /* 9 */ "Compiler restriction: the reduction source segment contains more than ^d tokens. Token '^a' could not be compiled.", /* 10 */ "Compiler restriction: the reduction source segment contains too many different tokens. Because more than ^d token value characters have been defined, token '^a' could not be compiled.", /* 11 */ "Label '^a' is undefined. The reference to this label could not be resolved.", /* 12 */ "The reduction source segment is too large to compile, causing the object segment to overflow.", /* 13 */ "Label '^a' has been multiply-defined.", /* 14 */ "Token requirement '^a' appears in a reduction after a token requirement. This combination of requirements could never be satisfied. Therefore, the reduction will be ignored.", /* 15 */ "Label '^a' in the next-reduction field of a reduction is invalid. In addition, the next-reduction field contains more than one label. This is not allowed.", /* 16 */ "The next-reduction field of a reduction contains more than one label. This is not allowed.", /* 17 */ "Compiler restriction: the reduction source segment contains more than ^d token requirement functions. Function '<^a>' could not be compiled.", /* 18 */ "Compiler restriction: the number specified in a 'MAX_DEPTH' attribute declaration is out of bounds. The allowable range is: ^2-0 < MAX_DEPTH < ^d A maximum depth of ^d will be assumed.", /* 19 */ "The '^a' built-in action routine has been used improperly in a reduction.", /* 20 */ "In attempting to compile the reduction on line ^d, the estimated number of reductions (^d) was exceeded. The reduction on line ^d, and those which follow it, could not be compiled.", /* 21 */ "Unexpected '^a' in the action field of the reduction statement.", /* 22 */ "One or more fields are missing from a reduction. All of the reduction fields (label, syntax, action, & next-label field) must be supplied.", /* 23 */ "A quoted string appears as the name of a semantic subroutine in the action field. This is not permitted. The reduction has been ignored.", /* 24 */ "A right parenthesis ()) is missing from the action field of a reduction.", /* 25 */ "The reduction segment ends with an incomplete reduction.", /* 26 */ "The reduction delimiters in the reduction segment were not found or were positioned improperly."), /* text of the error message. */ 2 brief_message char(64) varying init ( /* 1 */ "No reductions.", /* 2 */ "Invalid statement.", /* 3 */ "Invalid label '^a' ignored.", /* 4 */ "Invalid label '^a' ignored.", /* 5 */ "Reductions are incomplete.", /* 6 */ "Unexpected statement after end of reductions.", /* 7 */ "Restriction: >^d labels. '^a' ignored.", /* 8 */ "Restriction: >^d reductions. Line ^d ignored.", /* 9 */ "Restriction: >^d tokens. '^a' ignored.", /* 10 */ "Restriction: >^d token characters. '^a' ignored.", /* 11 */ "Label '^a' undefined.", /* 12 */ "Object segment overflow.", /* 13 */ "Label '^a' multiply-defined.", /* 14 */ "'^a' appears after .", /* 15 */ "Label '^a' invalid & >1 next-reduction labels.", /* 16 */ ">1 label in next-reduction field.", /* 17 */ "Restriction: >^d token requirement functions. '<^a>' ignored.", /* 18 */ "Restriction: 0 < MAX_DEPTH < ^d. ^d assumed.", /* 19 */ "'^a' built-in used improperly.", /* 20 */ "#_reductions > ^s^d estimate.", /* 21 */ "Unexpected '^a' ignored.", /* 22 */ "Incomplete reduction.", /* 23 */ "Quoted subroutine name.", /* 24 */ "')' missing from action field.", /* 25 */ "Reductions incomplete.", /* 26 */ "Bad reduction delimiters."), ignored_breaks char(5) varying aligned int static options(constant) init (" "), /* SP HT NL VT NP */ (error_table_$fatal_error, error_table_$improper_data_format) fixed bin(35) ext static, lex_control_chars char(128) varying aligned int static, lex_delims char(128) varying aligned int static, nl char(1) aligned int static options(constant) init (" "), spaces char(120) aligned int static options(constant) init ((120)" "); /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ Acode = 0; /* initialize error code. */ SERROR_CONTROL = Scontrol; S_TRACE = substr(bit(Scontrol,36),3,1); if S_TRACE then S_TRACE_ON = substr(bit(Scontrol,36),4,1); else S_TRACE_ON = "0"b; TRACING = S_TRACE; Pobj_spaces = addr(spaces); Pstmt, Pthis_token = null; /* start out with no input tokens. */ Ired_start = index(source,"/*++"); /* find reductions in reduction source segment. */ Ired_end = index(source,"++*/"); if (Ired_start = 0) | (Ired_end = 0) | (Ired_start+4 >= Ired_end-1) then do; call ERROR(26); Acode = error_table_$improper_data_format; go to RETURN; end; Ired_start = Ired_start + 4; /* skip over delimiters. */ Ired_end = Ired_end - 1; if Sinitialization_reqd then do; /* initialize static variables. */ call lex_string_$init_lex_delims ("""", """", "\""", nl, "\", "10"b, breaks, ignored_breaks, lex_delims, lex_control_chars); Sinitialization_reqd = "0"b; end; call lex_string_$lex (Psource, Ired_end-Ired_start+1, Ired_start-1, Psegment, "1"b, """", """", "\""", nl, "\", breaks, ignored_breaks, lex_delims, lex_control_chars, null, Ptoken, code); if code ^= 0 then /* lex source segment into tokens. */ call ERROR(25); if Ptoken = null then do; Acode = code; go to RETURN; end; Pthis_token = Ptoken; call SEMANTIC_ANALYSIS; /* perform semantic analysis of tokens. */ RETURN: Mseverity = MERROR_SEVERITY; if Mseverity > 2 then do; /* Fatal error? Return nothing. */ ALobj = 0; if Acode = 0 then Acode = error_table_$fatal_error; end; return; /* All done! */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* RELATIVE SYNTAX FUNCTIONS */ /* */ /* The relative syntax functions below are invoked to compare the input tokens */ /* with specifications built into the function. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ PUSH_DOWN_LANGUAGE: procedure returns (bit(1) aligned); /* returns "1"b if a 'PUSH DOWN LANGUAGE' is being*/ /* compiled. */ return (S_PDL); end PUSH_DOWN_LANGUAGE; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* ACTION ROUTINES: */ /* */ /* The action routines below are invoked at various stages of the compilation */ /* process to impart semantic meaning to the series of tokens which have passed the */ /* syntactic analysis tests of the input reductions. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ action_begin: procedure; /* invoked when beginning to compile the actions */ /* associated with a particular reduction. */ call output (" RD_ACTION("); /* output label array constant identifying rtn. */ call output_number (Nobj_red); call output ("): /* / */ "); end action_begin; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ compile_token: procedure (type); /* invoked to compile a syntax specification for */ /* the reduction being parsed. */ dcl type fixed bin; /* type of specification to be compiled. (In) */ /* 0 = compile absolute token requirement whose */ /* value is the character string value of */ /* the "current" token. */ /* 1 = compile test to see if input token */ /* chain is exhausted (). */ /* 2 = compile test for any token value */ /* (). */ /* 3 = compile test for a PL/I identifier */ /* () of 32 or fewer characters. */ /* 4 = compile test for token which is a */ /* . */ /* 5 = compile test for token which is a single */ /* backspace character (). */ /* 6 = compile test for token which is a */ /* . */ /* 7 = compile relative token requirement fcn. */ Nobj_token = obj_token.N + 1; /* increment count of object tokens. */ if Nobj_token > obj_token.M then do; /* make sure we don't overflow obj token table. */ call lex_error_ (9, SERROR_PRINTED(9), (error_control_table(9).severity), MERROR_SEVERITY, addrel(token.Pstmt,0), Ptoken, SERROR_CONTROL, (error_control_table(9).message), (error_control_table(9).brief_message), obj_token.M, token_value); go to RETURN; end; obj_token.N = Nobj_token; /* append token to obj token array, and to list */ obj_red.Ilast (Nobj_red) /* of object tokens related to reduction being */ = obj_red.Ilast (Nobj_red) + 1; /* parsed. */ go to comp (type); /* compile the appropriate type of token. */ comp(0): i = index (obj_string, token_value); /* see if current token exists in string */ /* of previously-defined token values. */ if i > 0 then do; /* if so, use previously-defined string. */ obj_token.form (Nobj_token) = i; obj_token.type (Nobj_token) = token.Lvalue; obj_token_quoted (Nobj_token) = token.S.quoted_string; end; else do; /* if not found, add it to obj token string */ /* values. */ Soptimize_possible = "0"b; /* optimization of obj token storage requirements */ /* no longer possible for this reduction. */ if token.Lvalue + length (obj_string) > Lobj_string then do; call lex_error_ (10, SERROR_PRINTED(10), (error_control_table(10).severity), MERROR_SEVERITY, addrel(token.Pstmt,0), Ptoken, SERROR_CONTROL, (error_control_table(10).message), (error_control_table(10).brief_message), Lobj_string, token_value); go to RETURN; /* complain if token too big for object string. */ end; else do; obj_token.form (Nobj_token) = length (obj_string) + 1; obj_token.type (Nobj_token) = token.Lvalue; obj_token_quoted (Nobj_token) = token.S.quoted_string; obj_string = obj_string || token_value; end; end; return; comp(1): comp(2): comp(3): comp(4): comp(5): comp(6): obj_token.form (Nobj_token) = 0; /* indicate built-in nature of object token. */ obj_token.type (Nobj_token) = type; /* set appropriate object token type. */ return; comp(7): obj_token.form (Nobj_token) = -1; do Nobj_token_fcn = 1 to obj_token_fcn.N while (obj_token_fcn.name(Nobj_token_fcn) ^= token_value); end; /* see if it was previously defined. */ if Nobj_token_fcn <= obj_token_fcn.N then do; /* yes, it was. */ obj_token.type (Nobj_token) = Nobj_token_fcn; return; end; if Nobj_token_fcn > dimension (obj_token_fcn.name, 1) then do; call lex_error_ (17, SERROR_PRINTED(17), (error_control_table(17).severity), MERROR_SEVERITY, addrel(token.Pstmt,0), Ptoken, SERROR_CONTROL, (error_control_table(17).message), (error_control_table(17).brief_message), dimension(obj_token_fcn.name,1), token_value); /* complain if no more room to define functions. */ go to RETURN; end; obj_token.type(Nobj_token) = Nobj_token_fcn; obj_token_fcn.N = Nobj_token_fcn; obj_token_fcn.name(Nobj_token_fcn) = token_value; end compile_token; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ count_reduction: proc; /* invoked during pass 1 to count the number of */ /* reductions and tokens being compiled. */ Nreductions = Nreductions + 1; /* count reduction being parsed. */ if Nreductions > Mreductions then do; /* check for too many reductions. */ Nreductions = Mreductions; Ptoken = Pthis_token; Pstmt = token.Pstmt; call lex_error_ (8, SERROR_PRINTED(8), (error_control_table(8).severity), MERROR_SEVERITY, addrel(token.Pstmt,0), Ptoken, SERROR_CONTROL, (error_control_table(8).message), (error_control_table(8).brief_message), Mreductions, fixed (stmt.line_no,35)); go to RETURN; end; Pstmt = token.Pstmt; Llongest_red = min (254, max(Llongest_red, length(stmt_value))); return; count_token: entry (N); dcl N fixed bin; /* number of tokens to be counted. (In) */ Ntokens = min (Mtokens, Ntokens + 1); /* By counting every token requirement of each */ /* reduction, we get an upper limit on the number */ /* of object tokens. */ do i = 1 to N; /* in each reduction, count length of every token */ Lobj_string = min (Mtokens, Lobj_string + token.Lvalue); Ptoken = token.Pnext; /* to get upper limit on length of string in which*/ end; /* tokens will be stored by compiler. */ end count_reduction; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ label_value: procedure (label_sought) /* invoked to obtain the reduction number which */ returns (fixed bin(17)); /* is the value of a given reduction label. */ dcl label_sought char(*), /* name of label whose value is sought. (In) */ i fixed bin; /* do group index. */ do i = 1 to obj_label.N while (obj_label.name(i) ^= label_sought); end; /* search for the sought label in list of defined */ /* labels. */ if i > obj_label.N then do; /* if label not found in list, complain. */ call ERROR(11); return(1); /* return value for first reduction. */ end; else /* if label found, return its value. */ return (obj_label.reduction_no(i)); end label_value; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ next_reduction: procedure; /* invoked to compile the next-reduction field of */ /* a reduction where no label is specified. This */ /* means "proceed with the next reduction". */ call output (" go to RD_NEXT_REDUCTION; /* / \ */ "); end next_reduction; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ number: procedure (no, statement) returns (char(*)); /* Procedure to put a sequence number at the */ /* beginning of each reduction (in label field). */ dcl no fixed bin, statement char(*); dcl Isearch fixed bin, number char(4) varying; number = ltrim(char(no)); if substr(ltrim(statement, HT_SP), 1, 1) = "/" then do; /* Don't put in a sequence number if a label */ /* is already present. */ if substr(statement,1,1) = HT then return (number || statement); if substr(statement,1,length(number)) = "" then return (number || substr(statement, length(number)+1)); if substr(statement,1,1) = "/" then return(statement); end; Isearch = verify(statement, "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_0123456789"); Isearch = (Isearch-1) + verify(substr(statement,Isearch), HT_SP); if substr(statement,Isearch,1) = NL then do; /* Look for label on line by itself, with next */ /* line starting with whitespace. */ Isearch = Isearch + 1; if substr(statement,Isearch,1) = HT then /* line begins with HT. */ return (substr(statement,1,Isearch-1) || number || substr(statement,Isearch)); if substr(statement,Isearch,length(number)) = "" then return (substr(statement,1,Isearch-1) || number || substr(statement,Isearch+length(number))); end; return (statement); end number; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ output: procedure (chars); /* invoked to write a character string into the */ /* object segment. */ dcl chars char(*); /* the character string to be written. (In) */ if length (chars) > Lobj then do; /* make sure character string will fit. */ call ERROR(12); go to RETURN; /* give up completely. This error is very fatal. */ end; substr (obj, 1, length(chars)) = chars; Pobj = addr (substr (obj, length(chars)+1)); Lobj = Lobj - length(chars); Lobj_part = Lobj_part + length(chars); end output; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ output_quote: procedure (chars); /* invoked to write a character string into the */ /* object segment, handling the doubling of quotes*/ /* if necessary. */ dcl chars char(*); /* the character string (possibly containing */ /* quotes which must be doubled) to be output. */ dcl Iquote fixed bin(21), /* index into part of character string. */ Lpart fixed bin(21), /* length of part of character string. */ Ppart ptr, /* ptr to part of character string. */ up_to_quote char(Iquote) based (Ppart), /* part of part up to the next quote. */ part char(Lpart) based (Ppart); /* part of character string. */ call output (""""); Ppart = addr(chars); Lpart = length(chars); Iquote = index(part, """"); do while (Iquote > 0); call output (up_to_quote); call output (""""); Ppart = addr(substr(part,Iquote+1)); Lpart = Lpart - Iquote; Iquote = index(part, """"); end; if Lpart > 0 then call output (part); call output (""""); end output_quote; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ output_number: procedure (number); /* invoked to convert a number to a character */ /* string, strip off leading blanks, and output */ /* the result. */ dcl number fixed bin, /* number to be output. (In) */ ltrim builtin; Nchar = number; /* convert number to a character string. */ call output (ltrim(Nchar)); end output_number; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ output_source: procedure (Ostart, Iend); dcl Ostart fixed bin(21), Iend fixed bin(21); dcl Lsource_part fixed bin(21), Psource_part ptr, source_part char(Lsource_part) based(Psource_part); Psource_part = addcharno(addr(source), Ostart); Lsource_part = Iend - Ostart; call output (source_part); end output_source; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ output_var: procedure (chars); /* invoked to write a varying character string */ /* into the output segment. */ dcl chars char(*) varying aligned; /* the character string to be written. (In) */ if length (chars) > Lobj then do; /* make sure character string will fit. */ call ERROR(12); go to RETURN; end; else do; substr (obj, 1, length(chars)) = chars; Pobj = addr (substr (obj, length(chars)+1)); Lobj = Lobj - length(chars); Lobj_part = Lobj_part + length(chars); end; end output_var; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ reduction_begin: procedure; /* invoked to begin parsing a reduction. */ Nobj_red = obj_red.N + 1; /* address the next object reduction. */ if Nobj_red > obj_red.M then do; /* if there is none, complain. */ Pstmt = token.Pstmt; call lex_error_ (20, SERROR_PRINTED(20), (error_control_table(20).severity), MERROR_SEVERITY, Pstmt, Ptoken, SERROR_CONTROL, (error_control_table(20).message), (error_control_table(20).brief_message), fixed(stmt.line_no,35), obj_red.M, fixed(stmt.line_no,35)); go to RETURN; end; obj_red.Ifirst (Nobj_red) = obj_token.N + 1; /* initiate indices of first/last token req'mts */ obj_red.Ilast (Nobj_red) = obj_token.N; /* to reflect no token requirements (so far). */ Soptimize_possible = "1"b; /* indicate optimization of token requirements is */ /* possible (so far). */ end reduction_begin; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ reduction_end: procedure; /* invoke to end parsing of a reduction. */ obj_red.N = Nobj_red; /* Formally add the completed reduction to the */ /* object reduction array. */ if Soptimize_possible then; /* All end work involves optimization of token */ else /* requirement storage. If optimization not */ return; /* possible, quit while we're ahead. */ if obj_red.Ifirst (Nobj_red) > obj_red.Ilast (Nobj_red) then return; /* same if no token requirements associated with */ /* the reduction. */ form = obj_token.form (obj_red.Ifirst(Nobj_red)); /* for efficiency, save value of first token */ type = obj_token.type (obj_red.Ifirst(Nobj_red)); /* requirement associated with reduction. */ do i = 1 to obj_red.Ifirst(Nobj_red) - 1; /* search through previously-defined token */ if obj_token.form(i) = form then /* requirements for a series which match those */ if obj_token.type(i) = type then do; /* associated with reduction. */ do j = 1 to obj_red.Ilast(Nobj_red) - obj_red.Ifirst(Nobj_red); if obj_token.form(i+j) = obj_token.form(obj_red.Ifirst(Nobj_red)+j) then if obj_token.type(i+j) = obj_token.type(obj_red.Ifirst(Nobj_red)+j) then; else go to no_match; else go to no_match; end; j = j - 1; /* make j = do-group end limit above. */ obj_token.N = max(obj_red.Ifirst(Nobj_red)-1, i+j); obj_red.Ifirst (Nobj_red) = i; /* if search succeeds, use previously-defined */ obj_red.Ilast (Nobj_red) = i + j; /* tokens in this reduction. */ return; no_match: end; end; end reduction_end; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ reductions_begin: procedure; /* invoked before parsing the first reduction to */ /* temporary storage for object reductions, object*/ /* tokens, and object token strings. */ /* Also initialize object segment and maximum */ /* severity value. */ Pobj_red = translator_temp_$allocate (Psegment, size(obj_red)); obj_red.M = Nreductions; Pobj_token = translator_temp_$allocate (Psegment, size(obj_token)); obj_token.M = Ntokens; Pobj_token_quoted = translator_temp_$allocate (Psegment, size(obj_token_quoted)); Pobj_string = translator_temp_$allocate (Psegment, size(obj_string)); if S_TRACE then Llongest_red = min(254, Llongest_red + log(Nreductions)); obj_red.N = 0; obj_token.N = 0; string (obj_token_quoted) = "0"b; obj_token_fcn.N = 0; Pobj = APobj; Lobj = ALobj; end reductions_begin; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ reductions_end: procedure; /* invoked after all reductions have been parsed, */ /* and after action routine calls have been */ /* output. */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* 1) Store maximum severity as an output value. If it is greater than 2, return with */ /* an empty object segment as output. */ /* 2) Otherwise: */ /* a) copy the action routine calls which have already been output into temporary */ /* storage. */ /* b) re-initialize the output object segment to zero length. */ /* c) output declarations for the object reduction and token structures. */ /* d) re-output the copied action routine calls. */ /* e) output an end statement. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ if MERROR_SEVERITY > 2 then go to RETURN; if obj_red.N = 0 then do; /* if there is no output, give up. */ call ERROR(1); go to RETURN; end; Ptemp = APobj; /* copy contents of object segment output so far */ Ltemp = ALobj - Lobj; /* to temp storage so we can reuse */ Ltemp_obj = Ltemp; /* space at head of object segment. */ Ptemp_obj = translator_temp_$allocate (Psegment, size(temp_obj)); temp_obj = temp; Pobj = APobj; Lobj = ALobj; call output(NP); /* output start of SEMANTIC_ANALYSIS subroutine. */ if S_TRACE_ON then call output (" dcl TRACING bit(1) aligned int static init(""1""b); "); else call output (" dcl TRACING bit(1) aligned int static init(""0""b); "); call output (" %include rdc_start_; "); call output (NP); /* output the reduction label stack. */ if S_PDL then call output (" dcl DIRECTION fixed bin init(-1); /* direction in which tokens compared. */ "); else call output (" dcl DIRECTION fixed bin init(+1); /* direction in which tokens compared. */ "); if Sinclude_STACK then do; call output (" dcl STACK ("); call output_number (Mstack_depth); call output (") fixed bin, /* reduction label stack. */ STACK_DEPTH fixed bin init (0); /* index into STACK. */ "); end; /* output declaration for object reductions. */ call output (" dcl 1 REDUCTION ("); call output_number (obj_red.N); call output (") unaligned based (addr (REDUCTIONS)), /* object reductions. */ 2 TOKEN_REQD, "); call output (" 3 IFIRST fixed bin(17), /* index of first required token. */ 3 ILAST fixed bin(17), /* index of last required token. */ REDUCTIONS ("); call output_number (obj_red.N + obj_red.N); call output (") fixed bin(17) unaligned internal static options(constant) initial ( "); do i = 1 to obj_red.N; call output (" "); if S_PDL then Nchar = obj_red.Ilast (i); else Nchar = obj_red.Ifirst(i); call output ((Nchar)); call output (", "); if S_PDL then Nchar = obj_red.Ifirst(i); else Nchar = obj_red.Ilast (i); call output ((Nchar)); if i = obj_red.N then call output ("); /* "); else call output (", /* "); Nchar = i; call output ((Nchar)); call output ("/ "); Lobj_part = 41; do j = obj_red.Ifirst(i) to obj_red.Ilast(i); if obj_token.form(j) > 0 then do; Pobj_string_part = addr(substr(obj_string, obj_token.form(j))); Lobj_string_part = obj_token.type(j); if obj_token_quoted(j) then call output_quote (obj_string_part); else call output (obj_string_part); call output (" "); end; else if obj_token.form(j) = 0 then do; go to comment (obj_token.type(j)); comment(1): call output (" "); go to end_comment; comment(2): call output (" "); go to end_comment; comment(3): call output (" "); go to end_comment; comment(4): call output (" "); go to end_comment; comment(5): call output (" "); go to end_comment; comment(6): call output (" "); end_comment: end; else do; call output ("<"); call output_var (obj_token_fcn.name(obj_token.type(j))); call output ("> "); end; end; Lobj_spaces = max(0, 110-Lobj_part); call output (obj_spaces); call output ("*/ "); end; call output (NP); /* output declaration for object tokens. */ call output (" dcl 1 TOKEN_REQUIREMENT ("); call output_number (obj_token.N); call output (") unaligned based (addr (TOKEN_REQUIREMENTS)), /* object token requirements. */ 2 FORM fixed bin(17), /* form of the token requirement: */"); call output (" /* -1 = relative token requirement function; */ /* TYPE = index of the particular token */ /* function in the token_fcn array. */ /* 0 = built-in token requirement function; */"); call output (" /* TYPE = as defined below. */ /* >0 = absolute token requirement: */ /* FORM = index(TOKEN_STRINGS,TOKEN_REQD); */ /* TYPE = length(TOKEN_REQD); */"); call output (" 2 TYPE fixed bin(17) unal, /* type of the built-in token requirement */ /* function: */ /* 1 = compile test to see if input token */"); call output (" /* chain is exhausted (). */ /* 2 = compile test for any token value */ /* (). */"); call output (" /* 3 = compile test for a PL/I identifier */ /* () of 32 or fewer characters. */ /* 4 = compile test for token which is a */ /* . */"); call output (" /* 5 = compile test for token which is a single */ /* backspace character (). */ /* 6 = compile test for a token which is a */ /* . */"); call output (" TOKEN_REQUIREMENTS ("); call output_number (obj_token.N + obj_token.N); call output (") fixed bin(17) unaligned internal static options(constant) initial ("); do i = 1 to obj_token.N; call output (" "); do i = i to min (obj_token.N, i + 6); Nchar = obj_token.form(i); call output ((Nchar)); call output (","); Nchar = obj_token.type(i); call output ((Nchar)); if i = obj_token.N then call output ("); "); else call output (", "); end; i = i - 1; end; i = length (obj_string); /* output declaration for object token values. */ call output (" dcl TOKEN_STRINGS char("); call output_number (i); call output (") aligned based (addr (TOKEN_STRING_ARRAYS)), /* object token values. */ "); i = divide (length(obj_string),100,17,0) + 1; /* compute number of 100-char substrings. */ call output (" TOKEN_STRING_ARRAYS ("); call output_number (i); call output (") char(100) aligned internal static options(constant) initial ( "); Lobj_string_part = 100; do i = 0 to i-2; call output (" """); Pobj_string_part = addr (substr (obj_string, i*100+1)); call output (obj_string_part); call output (""", "); end; call output (" """); Pobj_string_part = addr (substr (obj_string, i*100+1)); Lobj_string_part = length(obj_string) - i*100; call output (obj_string_part); call output ("""); "); call output (NP); /* output include statement for end semant. */ call output (" %include rdc_end_; "); if obj_token_fcn.N > 0 then do; /* output relative syntax function calls, if any. */ call output (" else do; /* relative syntax function. */ go to RD_TOKEN_FCN(TOKEN_REQD.TYPE); "); do i = 1 to obj_token_fcn.N; call output (" RD_TOKEN_FCN("); call output_number(i); call output("): STOKEN_FCN = "); call output_var (obj_token_fcn.name(i)); call output ("(); go to RD_TEST_RESULT;"); end; call output (" RD_TEST_RESULT: if STOKEN_FCN then go to RD_MATCH; else go to RD_NEXT_REDUCTION; end; "); end; if S_PDL then call output (" RD_MATCH: Ptoken = token.Plast; RD_MATCH_NO_TOKEN: end; Ptoken = Pthis_token; "); else call output (" RD_MATCH: Ptoken = token.Pnext; RD_MATCH_NO_TOKEN: end; Ptoken = Pthis_token; "); if S_TRACE then do; call output (" if TRACING then do; call PRINT_REDUCTION(NRED); call PRINT_TOKENS (DIRECTION, (RED.TOKEN_REQD.IFIRST), (RED.TOKEN_REQD.ILAST)); end; "); end; call output (" go to RD_ACTION(NRED); "); if Sinclude_STACK then do; /* include the label stack functions. */ call output (NP); call output (" %include rdc_stack_fcns_; "); end; call output (NP); /* output action routine calls saved previously. */ call output (temp_obj); if S_TRACE then do; call output (NP); call output ("%include rdc_tracing_fcns_; "); end; call output (" end SEMANTIC_ANALYSIS; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ "); call output (NP); /* define the PUSH DOWN LANGUAGE switch and */ /* include the LEX subroutine in object seg. */ if S_PDL then call output (" dcl SPDL bit(1) aligned init (""1""b); /* on: This compiler parses a PUSH DOWN LANGUAGE. */ "); else call output (" dcl SPDL bit(1) aligned init (""0""b); /* off: This compiler parses a non-PUSH DOWN */ /* LANGUAGE. */ "); if Sinclude_LEX then call output (" %include rdc_lex_; "); if Sinclude_DELETE then do; /* include the DELETE subroutine. */ call output (NP); call output (" %include rdc_delete_; "); end; if Sinclude_DELETE_STMT then do; /* include the DELETE_STMT subroutine. */ call output (NP); call output (" %include rdc_delete_stmt_; "); end; if Sinclude_ERROR then do; /* output include statement for ERROR message proc*/ call output (NP); call output (" %include rdc_error_; "); end; if Sinclude_NEXT_STMT then do; /* output NEXT_STMT proc. */ call output (NP); call output (" %include rdc_next_stmt_; "); end; if S_TRACE then do; call output (NP); call output (" dcl RED_TEXT ("); call output_number (Nreductions); call output (") char ("); call output_number (Llongest_red); Llongest_red = Llongest_red - log(Nreductions); /* leave room for reduction number. */ call output (") varying int static options(constant) init ( "); Pstmt = Psave -> token.Pstmt; call output_quote (number(1, substr(stmt_value,1,min(length(stmt_value), Llongest_red)))); do i = 2 to Nreductions; call output (", "); Pstmt = stmt.Pnext; call output_quote (number(i, substr(stmt_value,1,min(length(stmt_value), Llongest_red)))); end; call output ("); "); end; Ptemp = APobj; /* again, copy what we've generated in obj seg */ Ltemp = ALobj - Lobj; /* so we can reuse beginning. */ Ltemp_obj = Ltemp; Ptemp_obj = translator_temp_$allocate (Psegment, size(temp_obj)); temp_obj = temp; Pobj = APobj; /* output segment header for object segment. */ Lobj = ALobj; call output (" /* * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* COMPILED OUTPUT OF SEGMENT "); call output (Aname_source); call output (" */ /* Compiled by: reduction_compiler, Version 2.5 of Oct 21, 1985 */ /* Compiled on: "); date = date_time_$format ("date_time", clock_(), "", ""); call output (date); call output ("*/ /* */ /* * * * * * * * * * * * * * * * * * * * * * * */ "); call output(NP); Pstmt = Psave -> token.Pstmt; /* copy source into object segment. */ Osc_start = 0; /* each reduction is written separately so it */ do i = 1 to Nreductions; /* can be numbered for ease of debugging. */ call output_source (Osc_start, charno(addr(stmt_value))); call output (number(i, stmt_value)); Osc_start = charno(addr(stmt_value)) + length(stmt_value); Pstmt = stmt.Pnext; end; call output_source (Osc_start, length(source)); call output(temp_obj); /* output object previously generated & saved. */ /* output final end statement for translator. */ call suffixed_name_$new_suffix (Aname_source, "rd", "", name_source, code); call output (" end "); call output (rtrim(name_source)); call output ("; "); ALobj = ALobj - Lobj; /* adjust length of object seg returned to caller.*/ end reductions_end; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ reductions_init: procedure; /* invoked before pass1 of parse to */ /* initialize maximum stack depth, reduction and */ /* token counters, & maximum object string length.*/ /* Set switch to suppress inclusion of ERROR proc */ /* unless is it actually referenced. Do same for */ /* reduction STACK fcns, NEXT_STMT proc, and */ /* DELETE procs. Default to ^'PUSH DOWN LANGUAGE'.*/ Mstack_depth = 10; /* maximum stack depth is 10, by default. */ Nreductions = 0; Ntokens = 0; Llongest_red = 0; Lobj_string = 0; obj_label.N = 0; S_PDL = "0"b; Sinclude_DELETE = "0"b; Sinclude_DELETE_STMT = "0"b; Sinclude_ERROR = "0"b; Sinclude_NEXT_STMT = "0"b; Sinclude_LEX = "0"b; Sinclude_STACK = "0"b; end reductions_init; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ rtn: procedure (type); /* invoked to compile one of the pre-defined */ /* (pre-, mid-, or post-) actions. */ dcl type fixed bin; /* type of action to be compiled. */ /* 1 = LEX */ /* 2 = POP */ /* 3 = PUSH(