compdv.rd 03/17/86 1520.3rew 03/17/86 1430.1 1133901 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* format: style2,ind2,ll79,dclind4,idind15,comcol41,linecom */ /*++ INCLUDE ERROR \ BEGIN / / PUSH (BEGIN) [call push ("BEGIN")] /\ \" if "dcl" or "MediaChars" appear first, take them. / dcl : / [if db_start = "dcl" then db_sw, dt_sw = "1"b; if db_sw then call ioa_ ("^[^/^]===Declare", dt_sw)] LEX(2) / dcl \ / MediaChars : / LEX(2) pop [mediachars_p = area_free_p] PUSH (done_MediaChars) [call push ("done_MediaChars")] / MediaChars \ \" any of these need a MediaChars table \" (which may be empty), so define \" a dummy table. / Media / / no_MediaChars \ / View / / no_MediaChars \ / Def / / no_MediaChars \ / Font / / no_MediaChars \ / Size / / no_MediaChars \ / Device / / no_MediaChars \ / <no-token> / / no_MediaChars \ \" anything else here must be a \" global device value. they dont need \" MediaChars. / / / global_device \ no_MediaChars / / pop [call ERROR (missing_MediaChars)] [mediachars_p = area_free_p; mediachars.count = 1; \" supply a dummy one mediachars.name (1) = "<mediachar>"; mediachars.out_r (1) = "0"b] /\ \" finish the MediaChars table done_MediaChars / / [area_free_p = addr_inc (mediachars_p, size (mediachars))] /\ Media / / [if (db_start = "media") then db_sw, dt_sw = "1"b] /\ / / [media_p = area_free_p; media.count = 0] /\ / View / / no_Media \ / Def / / no_Media \ / Font / / no_Media \ / Size / / no_Media \ / Device / / no_Media \ / <no-token> / / no_Media \ Media_ / /PUSH (Media_)[call push ("Media_")] /\ / Media : /LEX(2) / Mwidths \ / View /pop / done_Media \ / Def /pop / done_Media \ / Font /pop / done_Media \ / Size /pop / done_Media \ / Device /pop / done_Media \ / / / global_device \ no_Media / /[call ERROR (missing_Media)] [media.count = 1; \" supply a dummy one media.name (1) = "<media>"; media.rel_units (1) = 0; media.width (1, 1) = 0] /\ done_Media / / [area_free_p = addr_inc (media_p, size (media))] /\ start_View / / [if (db_start = "view") then db_sw, dt_sw = "1"b] /\ / / [view_p = area_free_p; view.count = 0] /\ / Def / / no_View \ / Font / / no_View \ / Size / / no_View \ / Device / / no_View \ / <no-token> / / no_View \ View_ / /PUSH (View_)[call push ("View_")] /\ / View : /LEX(2) / Viewrest \ / Def /pop / done_View \ / Font /pop / done_View \ / Size /pop / done_View \ / Device /pop / done_View \ / / / global_device \ no_View / /[call ERROR (missing_View)] [view.count = 1; \" supply a dummy one view.name (1) = "<view>"; view.media (1) = 1] /\ done_View / / [area_free_p = addr_inc (view_p, size (view))] /\ start_Def / / [if (db_start = "def") then db_sw, dt_sw = "1"b] /\ / / [Def_p = area_free_p; Def.count = 0] /\ / Font / / no_Def \ / Size / / no_Def \ / Device / / no_Def \ / <no-token> / / no_Def \ Def_ / /PUSH (Def_)[call push ("Def_")] /\ / Def : /LEX(2) / Defrest \ / Font /pop / done_Def \ / Size /pop / done_Def \ / Device /pop / done_Def \ / / / global_device \ no_Def / / [Def.count = 1; Def.name (1) = "<Def>"; Def.pt (1) = null()] /\ done_Def / / [area_free_p = addr_inc (Def_p, size (Def))] /\ start_Font / / [if (db_start = "font") then db_sw, dt_sw = "1"b] /\ / Size / / no_Font \ / Device / / no_Font \ / <no-token> / / no_Font \ Font_ / /PUSH (Font_)[call push ("Font_")] /\ / Font : /LEX(2) / Fontrest \ / Size /pop / done_Font \ / Device /pop / done_Font \ / / / global_device \ no_Font / /[call ERROR (missing_Font)] / start_Size \ done_Font / / [area_free_p = addr_inc (oput_p, size (oput))] /\ start_Size / / [if (db_start = "size") then db_sw, dt_sw = "1"b] /\ / / [size_list_p = area_free_p; size_list.count = 0; area_free_p, sizel_p = addr (size_list.start)] /\ / Device / / no_Size \ / <no-token> / / no_Size \ Size / /PUSH (Size)[call push ("Size")] /\ / Size : /LEX(2) / Sizerest \ / Device /pop / done_Size \ / / / global_device \ no_Size / /[call ERROR (missing_Size)] [size_list.count = 1; \" supply a dummy one size_list.name (1) = "<size>"; size_list.pt (1) = addr(size_list.start)] / Device \ done_Size / / [if Sizes = 0 then if size_list.count > 0 then Sizes = 1; tp = Ptoken; do fnt_p = fntl_p (1) repeat (fnt.next) while (fnt_p ^= null ()); Ptoken, Pthis_token = fnt.node; if (font.min_wsp = -1) then call ERROR (no_wordspace_val); end; Ptoken, Pthis_token = tp] /\ Device / / [if (db_start = "dev") then db_sw, dt_sw = "1"b] /\ / / PUSH (Device)[call push ("Device")] /\ / Device : / [Device_Pthis_token = Pthis_token] LEX(2) [if db_sw then call ioa_ ("===Device ^a", token_value)] / Devicerest \ / <no-token> / [if const.devptr = null () then call ERROR (no_Device)] / RETURN \ / / / global_device \ stack_pop / /[if tr_sw then call ioa_(" STACK_POP(^a,^i)",Stack(STACK_DEPTH),STACK_DEPTH)] / STACK_POP \ / /[; push: proc (name); dcl name char (*); Stack (STACK_DEPTH) = name; if tr_sw then call ioa_ (" PUSH(^a,^i)", name,STACK_DEPTH); end push; pop: proc; if tr_sw then call ioa_ (" POP(^a,^i)", Stack (STACK_DEPTH),STACK_DEPTH); STACK_DEPTH = max (STACK_DEPTH - 1, 0); end pop; ] /\ \" define local named symbols for various strings dcl / <ident> , / [dclname = token_value] LEX(2) PUSH (dcl_1)[call push ("dcl_1")] / output_0 \ dcl_1 / ; / [dcl_p = area_free_p; dcl_.leng = length (part_str (1)); dcl_.dcl_v = part_str (1); dcl_.dcl_name = dclname; area_free_p = addr (dcl_.dummy); if dt_sw then call ioa_ ("^p^-dcl ^8a ""^a""", dcl_p, dcl_name, dcl_v); call link (dcl_l_p, dcl_p)] LEX(1) / stack_pop \ / /[call ERROR (syntax_dcl)] NEXT_STMT / stack_pop \ MediaChars / <ident2> / [media1, media2=token_value] / Media_3 \ / <input> / [media1, media2="[" || Input || "]"] LEX(1) / Media_1 \ Media_err / /[call ERROR (syntax_MediaChars)] /\ Media_skip \" scan forward looking for a "," or ";" / , /LEX(1) / MediaChars \ / ; / / Media_9 \ / <any-token> /LEX(1) / Media_skip \ Media_1 / : /LEX(1) / Media_2 \ / /LEX(-1) / Media_3 \ Media_2 / <input> / [media2="[" || Input || "]"] / Media_3 \ / / / Media_err \ Media_3 / / [held_Pthis_token = Pthis_token] \" for error msgs LEX(1) PUSH (Media_4)[call push ("Media_4")] / output_0 \ Media_4 / / [hold_Pthis_token = Pthis_token; Ptoken, Pthis_token = held_Pthis_token; \"in case any ERRORS the_string = part_str (1); if (media1 ^= media2) then do; if (substr (media1, 1, 1) ^= "[") | (substr (media2, 1, 1) ^= "[") then call ERROR (inv_MediaChar_range); else if (media1 > media2) then call ERROR (inv_Multics_char_range); end; do while (media1 <= media2); do i = 1 to mediachars.count; if (mediachars.name (i) = media1) then do; call ERROR (dup_MediaChars); i = mediachars.count; end; end; i = index (the_string, o777); if (i > 0) then do; if (substr (media1, 1, 1) ^= "[") then call ERROR (inv_MediaChar_SELF_ref); substr (the_string, i, 1) = substr (media1, 2, 1); end; mediachars.count = mediachars.count + 1; mediachars.name (mediachars.count) = media1; mediachars.out_r (mediachars.count) = rel (find_str (1)); if (i > 0) then substr (the_string, i, 1) = o777; substr (media1, 2, 1) = byte (rank (substr (media1, 2, 1)) + 1); \" media has form "[x]" when in a range end; Ptoken, Pthis_token = hold_Pthis_token] /\ / , /LEX(1) / MediaChars \ Media_9 / ; / LEX(1) / stack_pop \ / / / Media_err \ Mwidths / / [mediact = 0; mediabase = media.count] /\ Mwidth_1 / <valid_Media_name> / [mediact = mediact + 1; media.count = media.count + 1; media.name (media.count) = token_value; media.rel_units (media.count) = Strokes; media.width (media.count, *) = nulwidth] LEX(1) / Mwidth_2 \ Mwidth_err / /[call ERROR (syntax_Media_sec)] NEXT_STMT / Mwidth_3 \ Mwidth_2 / , /LEX(1) / Mwidth_1 \ / ; /LEX(1) / Mwidth_3 \ / / / Mwidth_err \ Mwidth_3 / strokes : /LEX(2) [media_i = 1] / Mwidth_s1 \ / / / Mwidth_4 \ Mwidth_s1 / <num> / [if (media_i > mediact) then call ERROR (too_many_stroke_values); media.rel_units (media_i+mediabase) = token.Nvalue] LEX(1) /\ / , /LEX(1) [media_i = media_i + 1] / Mwidth_s1 \ / ; /LEX(1) / Mwidth_3 \ / / / Mwidth_err \ Mwidth_4 / <charname> / [charid=token.Nvalue; media1 = media2; \" charname sets media2 media_i = 1; mediawidth = nulwidth] / Mwidth_A \ / / / stack_pop \ Mwidth_A / <input_> /LEX(1) / Mwidth_B \ / /LEX(1) / Mwidth_6 \ Mwidth_B / : /LEX(1) / Mwidth_C \ / / / Mwidth_6 \ Mwidth_C / <charname> / / Mwidth_D \ / / / Mwidth_err \ Mwidth_D / <input_> /LEX(1) / Mwidth_6 \ / / / Mwidth_err \ Mwidth_6 / <num> / / Mwidth_7 \ / <negnum> / / Mwidth_7 \ / = / / Mwidth_8 \ / / / Mwidth_9 \ Mwidth_7 / / [mediawidth = token.Nvalue] /\ Mwidth_8 / /LEX(1) [media_ = media1; charid_ = charid; if (mediawidth = nulwidth) then call ERROR (no_prior_width); else if (media_ > media2) then call ERROR (inv_Media_range); else do while (media_ <= media2); if (media_i > mediact) then do; call ERROR (too_many_widths); media_ = "~" || rtrim (media2); end; else do; media.width (media_i + mediabase, charid_) = mediawidth; if (media_ < media2) then do; substr (media_, 2, 1) = byte (rank (substr (media_, 2, 1))+1); charid_ = 0; do i = 1 to mediachars.count while (charid_ = 0); if (mediachars.name (i) = media_) then charid_ = i; end; if (charid_ = 0) then do; call ERROR (inv_Media_range); media_ = "~" || rtrim (media2); end; end; else media_ = "~" || rtrim (media2); \" force it HI end; end] /\ Mwidth_9 / ; /LEX(1) / Mwidth_3 \ / , / [media_i = media_i + 1] LEX(1) / Mwidth_6 \ / / / Mwidth_err \ Viewrest / <ident> / [viewname=token_value] LEX(1) / View_1 \ View_err / /[call ERROR (syntax_View)] NEXT_STMT / stack_pop \ View_1 / <medianame> / [view.count = view.count + 1; view.name (view.count) = viewname; view.media (view.count) = token.Nvalue] LEX(1) / View_2 \ / / / View_err \ View_2 / , /LEX(1) / Viewrest \ / ; /LEX(1) / stack_pop \ / / / View_err \ Defrest / <ident> ; / [Def.count = Def.count + 1; Def.name (Def.count) = token_value] LEX(2) [Def.pt (Def.count) = Pthis_token; vals_ct = 0] / Def_1 \ \" the token pointer is saved here so that at ref time parsing can be \" temporarily diverted back here. / /[call ERROR (no_name_Def)] NEXT_STMT /\ \" This keeps parsing until either a DEF, FONT, or INVALID STATEMENT occurs. \" Nothing is done with the results of the parse other than invalid statements \" are deleted so they will not cause further errors. Def_1 / Def / / stack_pop \ / Font / / stack_pop \ / Size / / stack_pop \ / Device / / stack_pop \ / <no-token> / / stack_pop \ / / [this_view = -1] PUSH (Def_2)[call push ("Def_2")] / font_char \ Def_2 / ; /LEX(1) / Def_1 \ / /DELETE_STMT / Def_1 \ \" font_char has already said why it is bad. \" Deleting statement is so error won't happen again \" during reparse at ref time. font_char / / [vals_ct = 0] /\ fch_1 / <all_input> /LEX(1) [vals_ct = vals_ct + 1; vals (vals_ct) = rank (Input)] / fch_2 \ / art /LEX(1) / fch_0 \ / /[call ERROR (inv_Mul_char_spec)] / fch_e \ fch_0 / <part> /LEX(1) [vals_ct = vals_ct + 1; vals (vals_ct) = rank (Input)] / fch_5 \ / /[call ERROR (inv_artwork_spec)] / fch_e \ fch_2 / : /LEX(1) / fch_3 \ / / / fch_5 \ fch_3 / <all_input> /LEX(1) [i = rank (Input); if (vals (vals_ct) > i) then do; call ERROR (inv_Multics_char_range); call LEX (-2); \" ******* back up to the ":" to force error exit at fch_4 end; else do; j = vals (vals_ct); do while (j < i); j = j + 1; vals_ct = vals_ct + 1; vals (vals_ct) = j; end; end] / fch_4 \ / /[call ERROR (syntax_after_colon)] / fch_e \ fch_4 / : \" ******* this catches error forced above / / fch_e \ fch_5 / , /LEX(1) / fch_1 \ / <is_viewname> / [if (this_view ^= -1) then this_view = token.Nvalue] LEX(1) /\ \" MC_STRING is an alternate entry point to this routine. mc_string / / [mediawidth, self_ct = 0; the_string = ""] /\ / <quoted-string> / / fch_6 \ / ( /LEX(1) / fch_A \ / <num> ( / / fch_6 \ / SELF / / fch_6 \ / <charname> / / fch_6 \ / /[call ERROR (not_charname)] /\ fch_6 / / [part_nest = 0] PUSH (fch_7)[call push ("fch_7")] / fch_l \ fch_7 / / [the_string = part_str (1); testwidth = nulwidth; mediawidth = part_width (1)] /\ / = /LEX(1) / fch_9 \ fch_8 / ; / / stack_pop \ \" normal return is with ";" token current / , / / stack_pop \ \" but don't complain about a "," either. / /[call ERROR (not_charname)] LEX (1) / fch_6 \ fch_9 / <negnum> / [testwidth = token.Nvalue] LEX(1) / fch_8 \ / <num> / [testwidth = token.Nvalue] LEX(1) / fch_8 \ / /[call ERROR (no_test_width)] / fch_8 \ fch_A / / [part_nest = 0] PUSH (fch_B)[call push ("fch_B")] / fch_l \ fch_B / ) = /LEX (2) [the_string = part_str (1); testwidth = nulwidth] / fch_C \ / /[call ERROR (paren_equal_expected)] / fch_8 \ fch_C / <negnum> / [mediawidth = token.Nvalue] LEX(1) / fch_8 \ / <num> / [mediawidth = token.Nvalue] LEX(1) / fch_8 \ / /[call ERROR (missing_width)] / fch_8 \ fch_e / ; /LEX(-1) / stack_pop \ \" error return can't be with token ";" current / / / stack_pop \ fch_l / / [part_nest = part_nest + 1; part_str (part_nest) = ""; part_width (part_nest) = 0] /\ fch_M / <num> ( / [part_repl (part_nest) = token.Nvalue] LEX(2) PUSH (fch_el)[call push ("fch_el")] / fch_l \ / SELF /LEX(1) [part_str (part_nest) = part_str (part_nest) || o777] / fch_M \ / <charname> /PUSH(fch_M)[call push("fch_M")] / fch_K \ / <quoted-string> /LEX(1) [list_ndx = 1] / fch_L \ / / [part_nest = part_nest - 1] / stack_pop \ fch_L / /LEX(-1) /\ / <charlist> \" peel them off one char at a time /PUSH(fch_L)[call push("fch_L")] / fch_K \ / /LEX(1) / fch_M \ fch_K / / [str_p = ptr (next_str_p, mediachars.out_r (token.Nvalue)); part_str (part_nest) = part_str (part_nest) || bstr.str; if this_view > 0 then do; if (media.rel_units (view.media (this_view)) ^= font.rel_units) then call ERROR (bad_stroke_value); mw = media.width (view.media (this_view), token.Nvalue); if mw = nulwidth then call ERROR_ (no_width_specified, view.name (this_view), show_name (mediachars.name (token.Nvalue))); part_width (part_nest) = part_width (part_nest) + mw; end] LEX(1) / stack_pop \ fch_el / ) /LEX(1) [part_str (part_nest) = part_str (part_nest) || copy (part_str(part_nest+1), part_repl (part_nest)); part_width (part_nest) = part_width (part_nest) + part_width (part_nest+1) * part_repl (part_nest)] / fch_M \ / /[call ERROR (unbal_parens)] / stack_pop \ Fontrest / <ident> / [fnt_p = find_font ("1"b); if fnt.pt ^= null () then call ERROR (dup_fontname); font_ptr, fnt.pt = area_free_p; area_free_p = addr_inc (area_free_p, size (font)); uni_p = area_free_p; area_free_p = addr_inc (area_free_p, size (uni)); call link (unil_p, uni_p); uni.seqno, uni.refno, uni_ct = uni_ct + 1; units_ptr, uni.ref_p = area_free_p; area_free_p = addr_inc (area_free_p, size (units)); opu_p = area_free_p; area_free_p = addr_inc (area_free_p, size (opu)); call link (opul_p, opu_p); opu.refno, opu.seqno = uni_ct; oput_p, opu.ref_p = area_free_p; font.units_r = rel (uni_p); font.oput_r = rel (opu_p); font.rel_units = -1; font.footsep = Footsep; font.min_wsp = MinWordsp; font.avg_wsp = AvgWordsp; font.max_wsp = MaxWordsp; units (*) = 0; oput.data_ct = 0; default_view = 1] LEX(1) / Font_1 \ / /[call ERROR (not_valid_Font_name)] NEXT_STMT / Font_3 \ Font_1 / <is_viewname> / [default_view = token.Nvalue; font.rel_units = media.rel_units (view.media (default_view))] LEX(1) / Font_2 \ / /[call ERROR (not_viewname)] NEXT_STMT / Font_3 \ Font_2 / ; / / Font_3 \ / /[call ERROR (syntax_Font)] /\ Font_3 / / [if Wordspace_p = null() then goto RD_NEXT_REDUCTION; hold_Pthis_token = Pthis_token; Ptoken, Pthis_token = Wordspace_p] PUSH(Font_4)[call push("Font_4")] / wordspace \ / / / Font_5 \ Font_4 / ; / [Ptoken, Pthis_token = hold_Pthis_token] / Font_8 \ / /[call ERROR (syntax_Wordspace)] [Ptoken, Pthis_token = hold_Pthis_token] / Font_5 \ font_err / /[call ERROR (syntax_Font_sec)] NEXT_STMT / stack_pop \ Font_5 / /PUSH (endFont)[call push("endFont")] /\ Font_6 / <all_input> / [this_view = default_view] PUSH (Font_8)[call push ("Font_8")] / font_char \ / art / [this_view = default_view] PUSH (Font_8)[call push ("Font_8")] / font_char \ / Def \" This is here for purposes of ref closure / / stack_pop \ / footrefseparator : /LEX(2) / footrefsep \ / wordspace : /LEX(2) PUSH(Font_9)[call push("Font_9")] / wordspace \ / ref : /LEX(2) / ref \ / Font / / stack_pop \ / Size / / stack_pop \ / Device / / stack_pop \ / <no-token> / / stack_pop \ / /PUSH (Font_6)[call push ("Font_6")] / global_device \ Font_8 / ; / [self_ct = 0; j = index (the_string, o777); if (j = 0) then the_string_r = rel (find_str (2)); else do; do while (j <= length(the_string)); self_ct = self_ct + 1; self_i (self_ct) = j; j = j + 1; if (j < length (the_string)) then do; i = index (substr (the_string, j), o777); if (i = 0) then j = length (the_string)+1; else j = j + i - 1; end; end; end; media1 = "[ ]"; jj= 0; do i = 1 to vals_ct; ii = vals (i); if (self_ct > 0) then do; substr (media1, 2, 1) = byte (ii); do j = 1 to self_ct; substr (the_string, self_i (j), 1) = byte (ii); end; the_string_r = rel (find_str (2)); charid = 0; do jj = 1 to mediachars.count while (charid = 0); if (mediachars.name (jj) = media1) then charid = jj; end; if (charid = 0) \" a MediaChar must be then do; \" defined with this name call ERROR (inv_Font_SELF_ref); jj = 0; end; else do; jj = media.width (view.media (this_view), charid); if jj = nulwidth then call ERROR_ (no_width_specified, view.name (this_view), show_name (mediachars.name (charid))); end; end; units (ii) = mediawidth + jj * self_ct; oput.data_ct = max (oput.data_ct, ii); oput.which (ii) = this_view; oput.what_r (ii) = the_string_r; if (testwidth ^= nulwidth) then if (units (ii) ^= testwidth) then call ERROR_ (bad_width_value, ltrim (char (units (ii))), ltrim (char (testwidth))); end] LEX(1) / Font_6 \ \" the LEX(1) needs to be after so error msg will display \" proper statement. / /NEXT_STMT / Font_6 \ \" font_char already told why in error footrefsep / <all_input> ; /LEX(2) [font.footsep = Input] / Font_6 \ Font_9 / ; /LEX(1) / Font_6 \ / /[call ERROR (syntax_wordspace)] NEXT_STMT LEX(-1) / Font_6 \ wordspace / <num> , / [font.min_wsp = token.Nvalue] LEX(2) / font_s2 \ / / / font_se \ font_s2 / <num> , / [font.avg_wsp = token.Nvalue] LEX(2) / font_s3 \ / / / font_se \ font_s3 / <num> , / [font.max_wsp = token.Nvalue] LEX(2) / font_s4 \ / / / font_se \ font_s4 / <charname> ; / [this_view = default_view; vals_ct = 1; vals (1) = 32] / mc_string \ \" Consistency between AvgWordsp and mediawidth will be checked later. font_se / ; / LEX(-1) / stack_pop \ \" make sure NOT pointing to ";" token when return / / / stack_pop \ endFont / / [tp = unil_p (2); \" see if units is like a prior one done = "0"b; do uni_p = unil_p (1) repeat (uni.next) while ((uni_p ^= unil_p (2)) & ^done); if (uni.refno = uni.seqno) then do; \" check only "real" ones if (unspec (uni.ref_p -> units) = unspec (tp -> uni.ref_p -> units)) then do; tp -> uni.refno = uni.seqno; \"its a duplicate done = "1"b; end; end; end; tp = opul_p (2); \" see if oput is like a prior one done = "0"b; do opu_p = opul_p (1) repeat (opu.next) while ((opu_p ^= opul_p (2)) & ^done); if (opu.refno = opu.seqno) then do; \" check only "real" ones if (unspec (opu.ref_p -> oput) = unspec (tp -> opu.ref_p -> oput)) then do; tp -> opu.refno = opu.seqno; \"its a duplicate done = "1"b; end; end; end] / stack_pop \ \" ---------------------------------------------------------------------------- \" This routine reparses the source following the named Def and then continues \" following the ref statement. ref / <is_Defname> / [i = token.Nvalue] LEX(1) / ref__ \ / /[call ERROR (not_Defname)] NEXT_STMT / Font_6 \ ref__ / ; / / ref_0 \ / /[call ERROR (missing_semicolon)] /\ ref_0 / / [hold_Pthis_token = Pthis_token; Ptoken, Pthis_token = Def.pt (i)] PUSH (ref_1)[call push ("ref_1")] / Font_6 \ \" divert parsing back to the Def source ref_1 / / [Ptoken, Pthis_token = hold_Pthis_token] NEXT_STMT / Font_6 \ \" have reached end of Def, \" continue parsing where we left off \" ---------------------------------------------------------------------- Sizerest / <ident> / [size_list.count = size_list.count + 1; size_list.name (size_list.count) = token_value; size_list.pt (size_list.count) = sizel_p; sizel.val_ct = 0] LEX(1) / point_1 \ / /[call ERROR (no_Size_name)] NEXT_STMT / stack_pop \ point_1 / , <num> /LEX(1) [sizel.val_ct = sizel.val_ct + 1; sizel.val (sizel.val_ct) = scale_unit (1000)] LEX(1) / point_1 \ / / [area_free_p, sizel_p = addr_inc (sizel_p, size (sizel))]/\ / ; /LEX(1) / stack_pop \ / /[call ERROR (syntax_Size)] NEXT_STMT / stack_pop \ \" global_device / Units : <unitkey> ; /LEX(2) [if db_sw then call ioa_ ("^[^/^]===Units ^a", dt_sw, token_value); Hscale = hscales (token.Nvalue); Vscale = vscales (token.Nvalue)] LEX(2) / stack_pop \ / Artproc : <ident> /LEX(2) [ArtProc = token_value] LEX(1) / Artproc \ / Attach : <quoted-string> ; /LEX(2) [the_string = token_value; Atd_r = rel (find_str (2))] LEX(2) / stack_pop \ / Cleanup : /LEX(2) [part_nest = 0] PUSH (Cleanup)[call push ("Cleanup")] / mc_string \ / Font : / / stack_pop \ / Comment : <quoted-string> ; /LEX(2) [the_string = token_value; Com_r = rel (find_str (2))] LEX(2) / stack_pop \ / DefaultMargs : <num> , <num> , <num> , <num> ; /LEX(2) [DefVmt = scale_unit (Vscale)] LEX(2) [DefVmh = scale_unit (Vscale)] LEX(2) [DefVmf = scale_unit (Vscale)] LEX(2) [DefVmb = scale_unit (Vscale)] LEX(2) / stack_pop \ / DevClass : <quoted-string> ; /LEX(2) [if db_sw then call ioa_ ("^[^/^]===DevClass", dt_sw); DevClass = token_value] LEX(2) / stack_pop \ / DevName : <quoted-string> ; /LEX(2) [if db_sw then call ioa_ ("^[^/^]===DevName", dt_sw); DevName = token_value] LEX(2) / stack_pop \ / Endpage : <all_input> ; /LEX(2) [EndPage = unspec (Input)] LEX(2) / stack_pop \ / Footproc : / [if db_sw then call ioa_ ("^[^/^]===Footproc", dt_sw)] LEX(2) / Footproc \ / Footrefseparator : / [if db_sw then call ioa_ ("^[^/^]===Footrefseparator", dt_sw)] LEX(2) / Footrefsep \ / Justify : <switch> ; /LEX(2) [if db_sw then call ioa_ ("^[^/^]===Justify", dt_sw); Justify = (token.Nvalue > 0)] LEX(2) / stack_pop \ / Interleave : <switch> ; /LEX(2) [if db_sw then call ioa_ ("^[^/^]===Interleave", dt_sw); Interleave = (token.Nvalue > 0)] LEX(2) / stack_pop \ / Letterspace : <num> ; /LEX(2) [if db_sw then call ioa_ ("^[^/^]===Letterspace", dt_sw); Letterspace = token.Nvalue] LEX(2) / stack_pop \ / MaxFiles : <limit> ; /LEX(2) [MaxFiles = token.Nvalue] LEX(2) / stack_pop \ / MaxPages : <limit> ; /LEX(2) [MaxPages = token.Nvalue] LEX(2) / stack_pop \ / MaxPageLength : <limit> ; /LEX(2) [MaxPageLength = scale_unit (Vscale)] LEX(2) / stack_pop \ / MaxPageWidth : <num> ; /LEX(2) [if db_sw then call ioa_ ("^[^/^]===MaxPageWidth", dt_sw); MaxPageWidth = scale_unit (Hscale)] LEX(2) / stack_pop \ / MinBotMarg : <num> ; /LEX(2) [MinVmb = scale_unit (Vscale)] LEX(2) / stack_pop \ / MinLead : <num> ; /LEX(2) [if db_sw then call ioa_ ("^[^/^]===MinLead", dt_sw); MinLead = scale_unit (Vscale)] LEX(2) / stack_pop \ / MinSpace : <num> ; /LEX(2) [if db_sw then call ioa_ ("^[^/^]===MinSpace", dt_sw); MinSpace = scale_unit (Hscale)] LEX(2) / stack_pop \ / MinTopMarg : <num> ; /LEX(2) [MinVmt = scale_unit (Vscale)] LEX(2) / stack_pop \ / Outproc : <ident> /LEX(2) [if db_sw then call ioa_ ("^[^/^]===Outproc", dt_sw); OutProc, DisplayProc = token_value] LEX(1) / Outproc \ / Strokes : <num> ; /LEX(2) [if db_sw then call ioa_ ("^[^/^]===Strokes", dt_sw); Strokes = token.Nvalue] LEX(2) / stack_pop \ / Wordspace : /LEX(2) [if db_sw then call ioa_ ("===Wordspace"); Wordspace_p = Pthis_token] NEXT_STMT / stack_pop \ \" just remember where this is for later use. / Sizes : <sizename> ; /LEX(2) [Sizes = token.Nvalue] LEX(2) / stack_pop \ / Stream : <switch> ; /LEX(2) [if db_sw then call ioa_ ("^[^/^]===Stream", dt_sw); Openmode = 5 - 3 * token.Nvalue] LEX(2) / stack_pop \ / TapeRec : <limit> ; /LEX(2) [TapeRec = token.Nvalue] LEX(2) / stack_pop \ / <no-token> /[call ERROR (end_of_source)] / RETURN \ / dcl / / out_of_place \ / MediaChars / / out_of_place \ / Media / / out_of_place \ / View / / out_of_place \ / Def / / out_of_place \ / Font / / out_of_place \ / Size / / out_of_place \ / Device / / out_of_place \ / /[call ERROR (inv_statement)] NEXT_STMT / stack_pop \ out_of_place / /[call ERROR (stmt_out_of_place)] NEXT_STMT / stack_pop \ Artproc / $ <ident> ; /LEX(1) [ArtEntry = token_value] LEX(2) / stack_pop \ / / [ArtEntry = ArtProc] LEX(1) / stack_pop \ Footrefsep / <all_input> ; / [Footsep = Input] LEX(2) / stack_pop \ / /[call ERROR (syntax_Footrefsep)] NEXT_STMT / stack_pop \ Footproc / <ident> / [FootProc = token_value] LEX(1) / Foot_1 \ / , /LEX(1) / Foot_2 \ / /[call ERROR (syntax_Footproc)] NEXT_STMT / stack_pop \ Foot_1 / $ <ident> /LEX(1) [FootEntry = token_value] LEX(1) / Foot_2 \ / / [FootEntry = FootProc] /\ Foot_2 / , <fam_mem> /LEX(2) [FootFamily = font_fam; FootMember = font_mem] /\ / ; /LEX(1) / stack_pop \ / /[call ERROR (syntax_Footproc)] NEXT_STMT / stack_pop \ Outproc / $ <ident> ; /LEX(1) [OutEntry = token_value] LEX(2) / stack_pop \ / ; / [OutEntry = OutProc] LEX(1) / stack_pop \ / /[call ERROR (syntax_Outproc)] NEXT_STMT / stack_pop \ Cleanup / ; /LEX(1) [ Clean_r = rel (find_str (2))] / stack_pop \ / /[call ERROR (syntax_Cleanup)] NEXT_STMT / stack_pop \ output_0 / / [iii, parenct, part_nest = 0] /\ output_1 / / [part_nest = part_nest + 1; part_repl (part_nest) = iii; part_str (part_nest) = ""] /\ output_2 / <octal> / [part_str (part_nest) = part_str (part_nest) || Input] LEX(1) / output_2 \ / <quoted-string> / [part_str (part_nest) = part_str (part_nest) || token_value] LEX(1) / output_2 \ / SELF / [part_str (part_nest) = part_str (part_nest) || o777] LEX(1) / output_2 \ / <num> ( / [iii = token.Nvalue; parenct = parenct + 1] LEX(2) PUSH (output_3)[call push ("output_3")] / output_1 \ / <dcl_ed> / [part_str(part_nest) = part_str(part_nest)||bstr.str] LEX(1) / output_2 \ / / / stack_pop \ output_3 / ) /LEX(1) [part_str (part_nest-1) = part_str (part_nest-1) || copy (part_str (part_nest), part_repl (part_nest)); part_nest = part_nest - 1; parenct = parenct - 1] / output_2 \ / ; /[call ERROR (unbal_parens)] / stack_pop \ / / / stack_pop \ Devicerest / / [comp_dvid_ct = comp_dvid_ct+1; comp_dvid_new="1"b; like_table = -1] /\ Device_0 / <valid_Device_name> / [if (dvid_ct = 0) then dvid_ct = dvid_ct + 1; \" add Device name dvid_p = area_free_p; area_free_p = addr (dvid.dummy); call link (dvidl_p, dvid_p); dvid.ndx = comp_dvid_ct; dvid.real = comp_dvid_new; dvid.refname = token_value; dvid.devname = DevName; dvid.dvt_ndx = dvt_ct + 1; comp_dvid_new = "0"b] LEX(1) / Device_1 \ table_e / /[call ERROR (syntax_Device)] NEXT_STMT / stack_pop \ Device_1 / , /LEX(1) / Device_0 \ / like /LEX(1) / like_table \ / ; /LEX(1) PUSH (startDevice)[call push ("startDevice")] / Device_I \ / / / table_e \ like_table / <table_name> ; / [like_table = token.Nvalue] LEX(2) / like_table2 \ / / / table_e \ like_table3 / / [do dvid_p = dvidl_p (1) repeat (dvid.next) while (dvid_p ^= null ()); if dvid.dvt_ndx = dvt_ct + 1 then dvid.dvt_ndx = like_table; end] / stack_pop \ like_table2 / Device / / like_table3 \ / <no-token> / / like_table3 \ / / PUSH (copy_table)[call push ("copy_table")] / Device_I \ Device_I / / [dvt_p = area_free_p; area_free_p = addr (dvt.dummy); call link (dvtl_p, dvt_p); dvt.ndx, dvt_ct = dvt_ct + 1; dvt.med_sel = area_free_p; med_sel_tab.count = font_count; area_free_p = addr_inc (area_free_p, size (med_sel_tab)); med_sel_tab.ref_r (*) = "0"b; dvt.prent, prent_p = area_free_p; area_free_p = addr (prent.dummy); dvt.ref, const.devptr = area_free_p; dvt_ct = dvt_ct + 1] / stack_pop \ copy_table / / [tp = null (); do dvt_p = dvtl_p (1) repeat (dvt.next) while (dvt_p ^= null () & tp = null ()); if dvt.ndx = like_table then tp = dvt_p; end; dvt_p = tp; med_sel_tab = dvt.med_sel -> med_sel_tab; prent = dvt.prent -> prent; comp_dvt.family_ct = dvt.ref -> comp_dvt.family_ct; comp_dvt = dvt.ref -> comp_dvt] / Device_2 \ startDevice / / [prent.outproc = OutProc || "$" || OutEntry; prent.artproc = ArtProc || "$" || ArtEntry; prent.footproc = FootProc || "$" || FootEntry; initfamily, initmember = ""; footfamily = FootFamily; footmember = FootMember; hscale = Hscale; vscale = Vscale; comp_dvt.devclass = DevClass; comp_dvt.min_WS = MinSpace; comp_dvt.min_lead = MinLead; comp_dvt.vmt_min = MinVmt; comp_dvt.vmb_min = MinVmb; comp_dvt.def_vmt = DefVmt; comp_dvt.def_vmh = DefVmh; comp_dvt.def_vmf = DefVmf; comp_dvt.def_vmb = DefVmb; comp_dvt.pdw_max = MaxPageWidth; comp_dvt.pdl_max = MaxPageLength; comp_dvt.upshift = 0; comp_dvt.init_ps = 0; comp_dvt.lettersp = Letterspace; comp_dvt.max_pages = MaxPages; comp_dvt.max_files = MaxFiles; comp_dvt.init_family = ""; comp_dvt.init_member = ""; comp_dvt.atd_r = Atd_r; comp_dvt.dvc_r = ""b; comp_dvt.comment_r = Com_r; comp_dvt.cleanup_r = Clean_r; comp_dvt.medsel_table_r = ""b; comp_dvt.foot_family = ""; comp_dvt.foot_member = ""; comp_dvt.sws.interleave = Interleave; comp_dvt.sws.justifying = Justify; comp_dvt.sws.mbz = "0"b; comp_dvt.sws.endpage = EndPage; comp_dvt.open_mode = Openmode; comp_dvt.recleng = TapeRec; comp_dvt.family_ct = 0] /\ Device_2 / units : <unitkey> ; /LEX(2) [hscale = hscales (token.Nvalue); vscale = vscales (token.Nvalue)] LEX(2) / Device_2 \ / artproc : <ident> /LEX(2) [prent.artproc = token_value] LEX(1) / artproc \ / attach : <quoted-string> ; /LEX(2) [the_string = token_value; comp_dvt.atd_r = rel (find_str (2))] LEX(2) / Device_2 \ / cleanup : /LEX(2) PUSH (cleanup)[call push ("cleanup")] / mc_string \ / comment : <quoted-string> ; /LEX(2) [the_string = token_value; comp_dvt.comment_r = rel (find_str (2)); if length (token_value) > length (the_string) then call ERROR (comment_gt_8000)] LEX(2) / Device_2 \ / defaultmargs : <num> , <num> , <num> , <num> ; /LEX(2) [comp_dvt.def_vmt = scale_unit (vscale)] LEX(2) [comp_dvt.def_vmh = scale_unit (vscale)] LEX(2) [comp_dvt.def_vmf = scale_unit (vscale)] LEX(2) [comp_dvt.def_vmb = scale_unit (vscale)] LEX(2) / Device_2 \ / devclass : <quoted-string> ; /LEX(2) [comp_dvt.devclass = token_value] LEX(2) / Device_2 \ / devname : <quoted-string> ; /LEX(2) [do dvid_p = dvidl_p (1) repeat (dvid.next) while (dvid_p ^= null ()); if dvid.dvt_ndx = dvt_ct then dvid.devname = token_value; end] LEX(2) / Device_2 \ \" / dvc : <ident> , \" /LEX(2) [dvcname = token_value] \" LEX(2) [dvcproc, the_string = ""] / dvc_1 \ / endpage : <all_input> ; /LEX(2) [comp_dvt.endpage = unspec (Input)] LEX(2) / Device_2 \ / family : / [bach_sw = "0"b] LEX(2) PUSH(family)[call push("family")] / add_family \ / footproc : /LEX(2) / footproc \ / init : /LEX(2) / init_f0 \ / interleave : <switch> ; /LEX(2) [comp_dvt.interleave = (token.Nvalue > 0)] / Device_2 \ / justify : <switch> ; /LEX(2) [comp_dvt.justifying = (token.Nvalue > 0)] / Device_2 \ / letterspace : <num> ; /LEX(2) [comp_dvt.lettersp = token.Nvalue] LEX(2) / Device_2 \ / maxfiles : <limit> ; /LEX(2) [comp_dvt.max_files = token.Nvalue] LEX(2) / Device_2 \ / maxpages : <limit> ; /LEX(2) [comp_dvt.max_pages = token.Nvalue] LEX(2) / Device_2 \ / maxpagelength : <limit> ; /LEX(2) [comp_dvt.pdl_max = scale_unit (vscale)] LEX(2) / Device_2 \ / maxpagewidth : <num> ; /LEX(2) [comp_dvt.pdw_max = scale_unit (hscale)] LEX(2) / Device_2 \ / minbotmarg : <num> ; /LEX(2) [comp_dvt.vmb_min = scale_unit (vscale)] LEX(2) / Device_2 \ / minlead : <num> ; /LEX(2) [comp_dvt.min_lead = scale_unit (vscale)] LEX(2) / Device_2 \ / minspace : <num> ; /LEX(2) [comp_dvt.min_WS = scale_unit (hscale)] LEX(2) / Device_2 \ / mintopmarg : <num> ; /LEX(2) [comp_dvt.vmt_min = scale_unit (vscale)] LEX(2) / Device_2 \ / outproc : <ident> /LEX(2) [prent.outproc = token_value] LEX(1) / outproc \ / stream : <switch> ; /LEX(2) [comp_dvt.open_mode = 5 - 3 * token.Nvalue] LEX(2) / Device_2 \ / taperec : <limit> ; /LEX(2) [comp_dvt.recleng = token.Nvalue] LEX(2) / Device_2 \ / bachelor : / [bach_sw = "1"b] LEX(2) PUSH(bachelor)[call push("bachelor")] / add_family \ / viewselect : /LEX(2) / viewselect \ / Device / / endDevice \ / <no-token> / / endDevice \ / / PUSH (Device_2)[call push ("Device_2")] / global_device \ endDevice / / [tp = Pthis_token; Ptoken, Pthis_token = Device_Pthis_token; done = "0"b; do dvid_p = dvidl_p (1) repeat (dvid.next) while ((dvid_p ^= null ()) & ^done); if (dvid.dvt_ndx = dvt_ct) then if (dvid.devname = "") then do; call ERROR (no_devname); done = "1"b; end; end; dvid_p = dvidl_p (2); if (comp_dvt.family_ct = 0) then call ERROR (no_fonts_selected); if (initfamily = "") then call ERROR (no_init_font); if (footfamily = "") then do; footfamily = initfamily; footmember = initmember; end; views_selected = 0; do i = 1 to view.count; if (med_sel_tab.ref_r (i) ^= "0"b) then views_selected = views_selected + 1; end; do i = 1 to comp_dvt.family_ct; mem_p = ptr (area1_p, comp_dvt.member_r (i)); member_ptr = mem.ref_p; do ii = 1 to member.count; if initfamily = comp_dvt.family (i).name & initmember = member.name (ii) then do; comp_dvt.init_fam = i; comp_dvt.init_family = initfamily; comp_dvt.init_mem = ii; comp_dvt.init_member = initmember; end; if footfamily = comp_dvt.family (i).name & footmember = member.name (ii) then do; comp_dvt.foot_fam = i; comp_dvt.foot_family = footfamily; comp_dvt.foot_mem = ii; comp_dvt.foot_member = footmember; end; if views_selected < view.count then do; fnt_p = ptr (area2_p, member.font_r (ii)); font_ptr = fnt.pt; uni_p = ptr (fnt.pt, font.units_r); units_ptr = uni.ref_p; opu_p = ptr (fnt.pt, font.oput_r); oput_p = opu.ref_p; do iii = 0 to oput.data_ct; j = oput.which (iii); if (j > 0) \" is the char defined? then do; \" YES if (med_sel_tab.ref_r (j) = "0"b) then do; \" but you can't get at it! call ERROR_ (no_viewselect, view.name (j), dvid.refname); med_sel_tab.ref_r (j) = "000001"b3; \" don't want to say this again. views_selected = views_selected + 1; end; end; end; end; end; end; if (comp_dvt.init_family = "") then call ERROR (init_font_not_on_Device); if (comp_dvt.foot_family = "") then call ERROR (foot_font_not_on_Device); Ptoken, Pthis_token = tp; area_free_p = addr_inc (area_free_p, size (comp_dvt))] \" finish allocation / stack_pop \ artproc / $ <ident> ; /LEX(1) [prent.artproc = prent.artproc || "$"; prent.artproc = prent.artproc || token_value] LEX(2) / Device_2 \ / /LEX(1) [prent.artproc = prent.artproc || "$" || prent.artproc] / Device_2 \ outproc / $ <ident> ; /LEX(1) [prent.outproc = prent.outproc || "$" || token_value] LEX(2) / Device_2 \ / ; /LEX(1) / Device_2 \ / /[call ERROR (syntax_outproc)] NEXT_STMT / Device_2 \ cleanup / ; /LEX(1) [comp_dvt.cleanup_r = rel (find_str (2))] / Device_2 \ / /[call ERROR (syntax_cleanup)] NEXT_STMT / Device_2 \ add_family / / [new_family = "1"b] /\ family_1 / <fam_bach> / [if new_family then do; if (member_ptr = null ()) then mem_p = area1_p; else mem_p = addr_inc ((member_ptr), size (member)); call link (meml_p, mem_p); mem.seqno, mem.refno, mem_ct = mem_ct + 1; member_ptr, mem.ref_p = addr (mem.dummy); member.count = 0; new_family = "0"b; end; comp_dvt.family_ct = comp_dvt.family_ct + 1; comp_dvt.member_r (comp_dvt.family_ct) = rel (mem_p); if ^bach_sw then comp_dvt.family (comp_dvt.family_ct).name = translate (token_value, az, AZ); else comp_dvt.family (comp_dvt.family_ct).name = token_value; Scale_x, Scale_y = Scale_scale] LEX(1) / family_2 \ / /[call ERROR (fam_bach_name_expected)] / stack_pop \ family_2 / , /LEX(1) / family_1 \ / / / stack_pop \ family / ; member /LEX(1) / member \ family_err / /[call ERROR (syntax_family)] NEXT_STMT / Device_2 \ member / member : / [new_member = member.count+1] LEX(2) / member_1 \ / / / endmem \ member_1 / <membername> / [member.count = member.count + 1; member.font_r (member.count) = "0"b; member.size_r (member.count) = "0"b; member.name (member.count) = translate (token_value, az, AZ)] LEX(1) / member_2 \ / /[call ERROR (syntax_member)] NEXT_STMT / Device_2 \ member_2 / , /LEX(1) / member_1 \ / /PUSH (member) [call push ("member")] /\ member_3 / <font_name> /LEX(1) / member_4 \ / /[call ERROR (no_fontname)] /\ member_4 / ; /LEX(1) / member_6 \ / /[call ERROR (syntax_member)] NEXT_STMT / stack_pop \ member_6 / Scale : /LEX(2) / member_7 \ / / / member_A \ member_7 / <num> / [Scale_x, Scale_y = convert (fd12_8, token_value)* Scale_scale] LEX(1) / member_8 \ / / / Scale_err \ member_8 / , <num> /LEX(1) [Scale_y = convert (fd12_8, token_value) * Scale_scale] LEX(1) / member_9 \ / / / Scale_err \ member_9 / ; /LEX(1) / member_A \ Scale_err / /[call ERROR (syntax_Scale)] NEXT_STMT /\ member_A / / [the_string_r = rel (find_str (2)); do i = new_member to member.count; member.font_r (i) = rel (the_font); member.Scalex (i) = Scale_x; member.Scaley (i) = Scale_y; addr (member.size_r (i)) -> bfb = Sizes; end] / stack_pop \ init_f0 / <fam_mem> /LEX(1) [initfamily = font_fam; initmember = font_mem] / init_f2 \ / /[call ERROR (missing_font)]NEXT_STMT / Device_2 \ init_f2 / <num> / [comp_dvt.init_ps = scale_unit (1000)] LEX(1) / init_f3 \ / /[call ERROR (no_init_ps)]NEXT_STMT / Device_2 \ init_f3 / ; /LEX(1) / Device_2 \ / /[call ERROR (missing_semicolon)]NEXT_STMT / Device_2 \ bachelor / / [new_member, member.count = 1; member.font_r (1) = "0"b; member.size_r (1) = "0"b; member.Scalex (1) = Scale_x; member.Scaley (1) = Scale_y; member.name (1) = ""] PUSH (endmem) [call push ("endmem")] / member_3 \ endmem / / [done = "0"b; \" put into "normal" form do while (^done); done = "1"b; do i = 1 to member.count-1; call memorder; end; if ^done then do; done = "1"b; do i = member.count-1 to 1 by -1; call memorder; end; end; end; memorder: proc; if member.name (i) > member.name (i+1) then do; member_hold = member.e (i); member.e (i) = member.e (i+1); member.e (i+1) = member_hold; done = "0"b; end; end memorder; tp = meml_p (2); \" see if member is like a prior one done = "0"b; do mem_p = meml_p (1) repeat (mem.next) while (mem_p ^= meml_p (2)); if (mem.seqno = mem.refno) then do; \" check only "real" ones if (unspec (mem.ref_p -> mem) = unspec (tp -> mem.ref_p -> mem)) then do; tp -> mem.refno = mem.seqno; \"its a duplicate done = "1"b; end; end; end] / Device_2 \ \"dvc_1 \" / <ident>$<ident> \" / [dvcproc = token_value] \" LEX(2) [dvcentry = token_value] \" LEX(1) /\ \" / <quoted-string> \" / [the_string = token_value] \" LEX(1) /\ \" / ; /LEX(1) [the_string = ""] / Device_2 \ footproc / <ident> / [prent.footproc = token_value] LEX(1) / foot_1 \ / , /LEX(1) / foot_2 \ / ; /LEX(1) / Device_2 \ / /[call ERROR (syntax_footproc)] NEXT_STMT / Device_2 \ foot_1 / $ <ident> /LEX(1) [prent.footproc = prent.footproc || "$" || token_value] LEX(1) /\ foot_2 / , <fam_mem> /LEX(2) [FootFamily = font_fam; FootMember = font_mem] / foot_3 \ / / / foot_e \ foot_3 / ; /LEX(1) / Device_2 \ foot_e / /[call ERROR (syntax_footproc)] NEXT_STMT / Device_2 \ viewselect / <is_viewname> / [default_view = token.Nvalue; this_view = -1] LEX(1) PUSH (viewsel1)[call push ("viewsel1")] / mc_string \ viewselect_err / /[call ERROR (syntax_viewselect)] NEXT_STMT / Device_2 \ viewsel1 / / [med_sel_tab.ref_r (default_view) = rel (find_str (2))] /\ / ; /LEX(1) / Device_2 \ / , /LEX(1) / viewselect \ / / / viewselect_err \ ++*/ %page; compdv: proc; dcl version char (10) var static options (constant) init ("2.0a"); dcl compdv_severity_ fixed bin (35) ext static; compstat$compconst.ptr = addr (compstat$compconst.ptr); dt_sw = "0"b; /* initialize static on first call in the process */ if first_time then do; breaks, ignored_breaks = substr (collate (), 1, 33) || substr (collate (), 128, 1); breaks = breaks || ":,()$="; call lex_string_$init_lex_delims ("""", """", "/*", "*/", ";", "10"b, /* suppress quote, keep statement */ breaks, ignored_breaks, lex_delims, lex_ctl_chars); first_time = "0"b; /* static init done, reset switch */ end; /* ******************** PROCESS COMMAND LINE******************** */ call cu_$arg_count (nargs); /* how many given? */ compdv_severity_ = 5; /* preset for command parser */ if nargs = 0 /* if none are given ... */ then do; call com_err_ (0, "compdv", "(Vers. ^a) Proper usage is: compdv" || " <input_pathname>{.compdv}^/^-[-check | -ck | -list | -ls]", version); return; end; /**/ /* fetch input pathname */ call cu_$arg_ptr (1, argp, argl, ercd); if ercd ^= 0 then do; call com_err_ (ercd, "compdv", "Reading input pathname."); return; end; if search ("<>", arg) = 0 /* if a search is needed */ then do; /* check entry name length */ if length (before (arg, ".compdv")) > 25 then do; call com_err_ (0, "compdv", "Input entryname ""^a"" is too long", rtrim (arg)); return; end; ename = before (arg, ".compdv");/* strip the suffix */ call search_paths_$find_dir ("compose", /* use compose list */ null (), rtrim (ename) || ".compdv", "", dname, ercd); if ercd ^= 0 then do; call com_err_ (ercd, "compdv", "Searching for ""^a""", rtrim (ename) || ".compdv"); return; end; end; else do; call expand_pathname_$add_suffix (arg, "compdv", dname, ename, ercd); if ercd ^= 0 then do; call com_err_ (ercd, "compdv", "Expanding path for ""^a""", rtrim (arg)); return; end; /**/ /* trim the suffix */ ename = before (ename, ".compdv"); end; check_opt, list_opt = "0"b; /* reset option flags */ if nargs > 1 /* any control args? */ then do; call cu_$arg_ptr (2, argp, argl, ercd); if ercd ^= 0 then do; call com_err_ (ercd, "compdv", "Reading control argument."); return; end; if arg = "-check" | arg = "-ck" then check_opt = "1"b; else if arg = "-list" | arg = "-ls" then list_opt = "1"b; else do; call com_err_ (error_table_$badopt, "compdv", """^a""", arg); return; end; end; call hcs_$initiate_count (dname, rtrim (ename) || ".compdv", "", input_bitcount, 0, input_ptr, ercd); if input_ptr = null () then do; call com_err_ (ercd, "compdv", "Initiating ^a>^a.compdv", rtrim (dname), rtrim (ename)); return; end; on condition (cleanup) call cleaner;/* we now need cleaning */ input_charcount = divide (input_bitcount, 9, 24, 0); call translator_temp_$get_segment ("compdv", lex_temp_ptr, ercd); if ercd ^= 0 /* get a temp seg for lex_string_ */ then do; call com_err_ (ercd, "compdv", "Getting a translator temp seg."); call cleaner; return; end; call get_temp_segments_ ("compdv", temp_ptrs, ercd); if ercd ^= 0 then do; call com_err_ (ercd, "compdv", "Getting temp segments"); call cleaner; return; end; /* ******************** INITIALIZE FOR EXECUTION ******************** */ call ioa_ ("COMPDV ^a-^d", version, comp_dvid_version); compdv_severity_ = 0; /* clear for execution */ dcl_l_p (*) = null (); next_str_p = ptr (string_area_p, 1);/* next string definition */ size_list_p = null (); area_free_p = area2_p; /* next symbol declaration */ mediachars_p = null (); /* good housekeeping */ media_p = null (); view_p = null (); Def_p = null (); dvid_ct = 0; dvidl_p (*) = null (); dvt_ct = 0; dvtl_p (*) = null (); font_count = 0; member_ptr = null (); fntl_p (*) = null (); meml_p (*) = null (); unil_p (*) = null (); opul_p (*) = null (); the_string = ""; if rel (find_str (1)) then ; /* put null string as first */ if rel (find_str (2)) then ; /* string table entries */ ArtProc, FootProc, OutProc, DisplayProc, OutEntry = rtrim (ename) || "_writer_"; FootFamily, FootMember = ""; Com_r, Clean_r = "0"b; Vscale = vscales (6); /* default to points */ Hscale = hscales (6); if input_charcount = 0 then do; code = error_table_$zero_length_seg; goto empty_seg; end; call lex_string_$lex (input_ptr, input_charcount, 0, lex_temp_ptr, "1000"b, """", """", "/*", "*/", ";", breaks, ignored_breaks, lex_delims, lex_ctl_chars, null (), first_token_p, code); if code ^= 0 then do; empty_seg: if code = error_table_$zero_length_seg then call com_err_ (0, "compdv", "Source contains no statements. ^a>^a.compdv.", dname, ename) ; else call com_err_ (code, "compdv", "^a does not end with a statement delimiter.", pathname_ (dname, ename)); call cleaner; return; end; Ptoken, Pthis_token = first_token_p; /* ***************************** GO ***************************** */ call SEMANTIC_ANALYSIS; compdv_severity_ = MERROR_SEVERITY; if MERROR_SEVERITY < 3 then do; dvid_p = dvidl_p (1); ename = rtrim (dvid.refname) || ".comp_dsm"; call iox_$attach_name ("comp_gen_", ALM, "vfile_ " || rtrim (ename) || ".alm", null (), code); call iox_$open (ALM, 2, "0"b, code); call outputter; call iox_$close (ALM, code); call iox_$detach_iocb (ALM, code); if ^check_opt then do; if list_opt then call alm (ename, "-list"); else call alm (ename); do dvid_p = dvidl_p (1) repeat (dvid.next) while (dvid_p ^= null ()); call hcs_$chname_file (get_wdir_ (), ename, "", rtrim (dvid.refname) || ".comp_dsm", code); if (code = error_table_$segnamedup) then code = 0; if code ^= 0 then call com_err_ (code, "compdv", "Trying to add name ^a.comp_dsm to ^a>^a", dvid.refname, get_wdir_ (), ename); end; end; end; call cleaner; return; /**** +++[Syntax Function]++++++++ A_DEBUG +++++++++++++++++++++++++++++++++ */ /* */ /* This routine helps in debugging. To use it a change must be made to the */ /* output of rdc before compilation. At the label RD_MATCH this must be put: */ /* if db_sw then call a_debug; */ a_debug: proc; call ioa_$nnl (" ""^a""", token_value); if (token_value = ",") | (token_value = ";") then call ioa_$nnl ("^/"); end a_debug; /**** +++[Function]+++++++++++++++ ADDR_INC ++++++++++++++++++++++++++++++++ */ /* */ /* this is an addrel function which increments by double words */ addr_inc: proc (a_ptr, an_inc) returns (ptr); dcl a_ptr ptr, an_inc fixed bin (24); return (addrel (a_ptr, divide (an_inc + 1, 2, 17, 0) * 2)); end addr_inc; /**** +++[Syntax Function]++++++++ CHARLIST ++++++++++++++++++++++++++++++++ */ /* */ /* Tests for the chars of a quoted string being defined charnames. Each */ /* entry processes the next char in the list. */ /* USES: token_value - current token */ /* list_ndx - character to process this time */ /* SETS: token.Nvalue - index of found charname */ charlist: proc returns (bit (1) aligned); dcl i fixed bin; if list_ndx > length (token_value) then return ("0"b); media2 = "[" || substr (token_value, list_ndx, 1) || "]"; do i = 1 to mediachars.count; /* look thru the mediachars list */ if (mediachars.name (i) = media2) then do; token.Nvalue = i; if dt_sw then call ioa_$nnl ("<charlist-^i>", list_ndx); list_ndx = list_ndx + 1; return ("1"b); end; end; call ERROR_ (not_charname, show_name (media2), ""); return ("0"b); end charlist; /**** +++[Syntax Function]++++++++ CHARNAME ++++++++++++++++++++++++++++++++ */ /* */ /* Tests for the token being a defined charname. */ /* USES: token_value - current token */ /* SETS: token.Nvalue - index of found charname */ charname: proc returns (bit (1) aligned); dcl i fixed bin; if input_ () /* (sets Input if true) */ then media2 = "[" || Input || "]"; else if ident_ () then media2 = token_value; else return ("0"b); do i = 1 to mediachars.count; /* look thru the mediachars list */ if (mediachars.name (i) = media2) then do; token.Nvalue = i; if dt_sw then call ioa_$nnl ("<charname>"); return ("1"b); end; end; return ("0"b); end charname; /**** +++[Procedure]++++++++++++++ CLEANER +++++++++++++++++++++++++++++++++ */ /* */ /* Does all the needed stuff for condition(cleanup). However, doesn't report */ /* any errors since we may be in trouble. */ cleaner: proc; if db_sw then call ioa_ ("===cleaner"); call hcs_$terminate_noname (input_ptr, code); if lex_temp_ptr ^= null () then call translator_temp_$release_all_segments (lex_temp_ptr, code); if temp_ptrs (1) ^= null () then call release_temp_segments_ ("compdv", temp_ptrs, code); if ALM ^= null () then do; call iox_$close (ALM, code); call iox_$detach_iocb (ALM, code); ALM = null (); end; if ^check_opt then call delete_$path (get_wdir_ (), rtrim (ename) || ".alm", "100100"b, "compdv", code); end cleaner; /**** +++[Syntax Function]+++++++++ DCL_ED +++++++++++++++++++++++++++++++++ */ dcl_ed: proc returns (bit (1) aligned); do dcl_p = dcl_l_p (1) repeat (dcl_.next) while (dcl_p ^= null ()); if (dcl_.dcl_name = token_value) then do; str_p = addr (dcl_.leng); if dt_sw then call ioa_$nnl ("<dcl_ed>"); return ("1"b); end; end; return ("0"b); end dcl_ed; /**** +++[Procedure]+++++++++++++++ ERROR_ +++++++++++++++++++++++++++++++++ */ /* */ /* This routine prints error messages which need "non-standard" insertions. */ ERROR_: proc (Nerror, Arg1, Arg2); dcl Nerror fixed bin, Arg1 char (*), /* The need is currently for 2 */ Arg2 char (*); /* arguments, (may need expansion). */ dcl Pstmt ptr, 1 erring_token aligned based (Perring_token) like token, Perring_token ptr, erring_token_value char (erring_token.Lvalue) based (erring_token.Pvalue); dcl lex_error_ entry options (variable); Perring_token = Pthis_token; if error_control_table.Soutput_stmt (Nerror) then Pstmt = erring_token.Pstmt; /* addr statement descriptor. */ else Pstmt = null (); call lex_error_ (Nerror, SERROR_PRINTED (Nerror), (error_control_table.severity (Nerror)), MERROR_SEVERITY, Pstmt, null (), SERROR_CONTROL, (error_control_table.message (Nerror)), (error_control_table.brief_message (Nerror)), Arg1, Arg2); compdv_severity_ = max (compdv_severity_, error_control_table.severity (Nerror)); end ERROR_; /**** +++[Syntax Function]++++++++ FAM_MEM +++++++++++++++++++++++++++++++++ */ fam_mem: proc returns (bit (1) aligned); if token.quoted_string /* quoted string? */ | token_value = "SELF" /* the reserved word? */ then return ("0"b); /* any of these, return false */ /* extract the first name */ font_fam = before (token_value, "/"); if font_fam = "" /* no family given */ then return ("0"b); /**/ /* extract possible second name */ font_mem = after (token_value, "/");/* invalid names? */ if (verify (font_fam, az_AZ09) ^= 0) | (verify (font_mem, az_AZ09) ^= 0) | (search (font_fam, "0123456789_") = 1) | (search (font_mem, "0123456789_") ^= 0) then return ("0"b); if (index (token_value, "/") ^= 0) then do; font_mem = "/" || rtrim (font_mem); font_fam = translate (font_fam, az, AZ); font_mem = translate (font_mem, az, AZ); end; if dt_sw then call ioa_$nnl ("<fam_mem>"); return ("1"b); end fam_mem; /**** +++[Syntax Function]++++++++ FAM_BACH ++++++++++++++++++++++++++++++++ */ fam_bach: proc returns (bit (1) aligned); dcl i fixed bin; dcl name char (32); if token.quoted_string /* quoted string? */ | token_value = "SELF" /* the reserved word? */ then return ("0"b); /* any of these, return false */ /* invalid names? */ if (verify (token_value, az_AZ09) ^= 0) | (search (token_value, "0123456789_") = 1) then return ("0"b); if ^bach_sw then name = translate (token_value, az, AZ); else name = token_value; do i = 1 to comp_dvt.family_ct; if name = comp_dvt.family (i).name then do; call ERROR (duplicate_font_name); return ("0"b); end; end; if dt_sw then call ioa_$nnl ("<fam_bach>"); return ("1"b); end fam_bach; /**** +++[Function]++++++++++++++ FIND_FONT ++++++++++++++++++++++++++++++++ */ find_font: proc (create) returns (ptr); /* PARAMETERS */ dcl create bit (1); /* 1 = font is to be created */ /* LOCAL STORAGE */ dcl tp ptr; dcl fname char (32); if db_sw then call ioa_ ("===find_font"); fname = token_value; if token_value = "SELF" /* can't use "SELF" as a font name */ | token.quoted_string /* can't be a literal */ | octal_ () /* or an octal value */ | num () /* or a numeric */ then do; if create then goto bad_news; return (null ()); end; /* go thru all defined fonts */ do tp = fntl_p (1) repeat (tp -> fnt.next) while (tp ^= null ()); if tp -> fnt.name = token_value /* is this the one we want? */ then return (tp); /* YES, return its addr */ end; if ^create /* not found; if not creating */ then return (null); /* return a null value */ if ^ident_ () /* but must be a legal name */ then do; bad_news: call ERROR (not_valid_Font_name); fname = ""; /* supply something */ end; if (font_count > 0) then area_free_p = addr_inc (oput_p, size (oput)); tp = area_free_p; area_free_p = addr (tp -> fnt.dummy); font_count = font_count + 1; /* record new font info */ call link (fntl_p, tp); tp -> fnt.name = fname; /* fill in the internal font name */ tp -> fnt.refno = font_count; /* and the reference # */ tp -> fnt.node = Ptoken; /* keep statement ptr for error msgs */ tp -> fnt.pt = null (); /* no table started yet */ return (tp); /* return the new addr */ end find_font; /**** +++[Function]+++++++++++++++ FIND_STR ++++++++++++++++++++++++++++++++ */ /* */ /* Finds the location of a string in a string table. If the string is not */ /* in the table, then it is entered. */ find_str: proc (which) returns (ptr); dcl which fixed bin; /* 1- temporary string area */ /* 2- DSM string area */ dcl i fixed bin; if dt_sw then call ioa_$nnl ("`^a'", the_string); if (string_l (which) > 0) & (length (the_string) = 0) then do; if dt_sw then call ioa_ ("--is ^i,1", which); return (strl_p (which, 1)); end; do i = 1 to string_l (which); str_p = strl_p (which, i); if (length (bstr.str) = length (the_string)) then if (bstr.str = the_string) then do; if dt_sw then call ioa_ ("--found ^i,^i", which, i); return (str_p); end; end; str_p = next_str_p; bstr.leng = length (the_string); bstr.str = the_string; string_l (which), i = string_l (which) + 1; strl_p (which, i) = str_p; next_str_p = addr (bstr.dummy); if dt_sw then call ioa_ ("--new ^i,^i", which, i); return (strl_p (which, i)); end find_str; /**** +++[Syntax Function]+++++++ FONT_NAME ++++++++++++++++++++++++++++++++ */ /* */ /* Test for token being a defined fontname. */ font_name: proc returns (bit (1) aligned); the_font = find_font ("0"b); if the_font ^= null () then do; if dt_sw then call ioa_$nnl ("<font_name>"); return ("1"b); end; the_font = fntl_p (1); /* fill in a value so program will */ /* keep running */ return ("0"b); end font_name; /**** +++[Syntax Function]++++++ IDENT/IDENT2 ++++++++++++++++++++++++++++++ */ /* */ /* check for legal <name> string */ ident: proc returns (bit (1) aligned); ldt_sw = dt_sw; goto start; ident2: entry returns (bit (1) aligned); ldt_sw = dt_sw; if (token.Lvalue = 1) then return ("0"b); goto start; ident_: entry returns (bit (1) aligned); ldt_sw = "0"b; /* never db displays */ dcl ldt_sw bit (1); start: if token.quoted_string /* quoted string? */ | token_value = "SELF" /* the reserved word? */ | verify (token_value, az_AZ09) ^= 0 /* non-(alphanumeric or _)? */ then return ("0"b); /* any of these, return false */ if (index ("0123456789_", substr (token_value, 1, 1)) ^= 0) then return ("0"b); if ldt_sw then call ioa_$nnl ("<ident>"); return ("1"b); /* must not have leading number or _ */ end ident; /**** +++[Syntax Function]++++ INPUT/ALL_INPUT +++++++++++++++++++++++++++++ */ /* */ /* Tests for token being a single char in either octal or quoted form. */ /* ALL_INPUT also checks for a whole slew of builtin char names. */ /* SETS: Input - 9-bit char value which results */ input: proc returns (bit (1) aligned); dcl which char (12); dcl ldt_sw bit (1); which = "<input>"; ldt_sw = dt_sw; goto some; input_: entry returns (bit (1) aligned); ldt_sw = "0"b; /* never db displays */ goto some; all_input: entry returns (bit (1) aligned); which = "<all_input>"; ldt_sw = dt_sw; if (token_value = "EM") then Input = EM; else if (token_value = "EN") then Input = EN; else if (token_value = "THICK") then Input = THICK; else if (token_value = "MEDIUM") then Input = MEDIUM; else if (token_value = "THIN") then Input = THIN; else if (token_value = "HAIR") then Input = HAIR; else if (token_value = "DEVIT") then Input = DEVIT; else if (token_value = "STROKE") then Input = STROKE; else if (token_value = "EM-") then Input = EMdash; else if (token_value = "EN-") then Input = ENd; else if (token_value = "EM_") then Input = EM_; else if (token_value = "EN_") then Input = EN_; else if (token_value = "^0") then Input = sup0; else if (token_value = "^1") then Input = sup1; else if (token_value = "^2") then Input = sup2; else if (token_value = "^3") then Input = sup3; else if (token_value = "^4") then Input = sup4; else if (token_value = "^5") then Input = sup5; else if (token_value = "^6") then Input = sup6; else if (token_value = "^7") then Input = sup7; else if (token_value = "^8") then Input = sup8; else if (token_value = "^9") then Input = sup9; else if (token_value = "''") then Input = rquote; else if (token_value = "``") then Input = lquote; else if (token_value = "PS") then Input = PS; else if (token_value = "lslnt") then Input = lslnt; else if (token_value = "vrule") then Input = vrule; else if (token_value = "bullet") then Input = bullet; else if (token_value = "cright") then Input = cright; else if (token_value = "modmark") then Input = modmark; else if (token_value = "delmark") then Input = delmark; else if (token_value = "multiply") then Input = multiply; else if (token_value = "nabla") then Input = nabla; else if (token_value = "pl_mi") then Input = pl_mi; else some: if token.quoted_string then do; if token.Lvalue ^= 1 then return ("0"b); Input = token_value; end; else if ^octal_ () then return ("0"b); if ldt_sw then call ioa_$nnl ("^a", which); return ("1"b); end input; /**** +++[Syntax Function]+++++++ IS_DEFNAME +++++++++++++++++++++++++++++++ */ /* */ /* Tests for a token being a defined Defname. */ /* SETS: token.Nvalue - index of the found Defname */ is_Defname: proc returns (bit (1) aligned); do i = 1 to Def.count; if (Def.name (i) = token_value) then do; token.Nvalue = i; if dt_sw then call ioa_$nnl ("<is_Defname>"); return ("1"b); end; end; return ("0"b); end is_Defname; /**** +++[Syntax Function]++++++ IS_VIEWNAME +++++++++++++++++++++++++++++++ */ /* */ /* Tests for token being a defined viewname. */ /* SETS: token.Nvalue - index of the found viewname */ is_viewname: proc returns (bit (1) aligned); do i = 1 to view.count; if (view.name (i) = token_value) then do; token.Nvalue = i; if dt_sw then call ioa_$nnl ("<is_viewname>"); return ("1"b); end; end; return ("0"b); end is_viewname; /**** +++[Procedure]++++++++++++++++ LINK ++++++++++++++++++++++++++++++++++ */ /* */ /* link an element to end of a list */ link: proc (l_p, e_p); dcl l_p (2) ptr, /* begin/end list ptrs */ e_p ptr; /* element to be linked */ dcl next ptr based (e_p); /* first word of element -> next */ if (l_p (1) = null ()) then l_p (*) = e_p; /* initialize list */ else do; l_p (2) -> next = e_p; /* last one points to this one */ l_p (2) = e_p; /* this one is now last */ end; next = null (); /* this one points nowhere */ end link; /**** +++[Syntax Function]+++++++ MEDIANAME ++++++++++++++++++++++++++++++++ */ /* */ /* Test for the token being a defined medianame */ /* SETS: token.Nvalue - the index of the found medianame */ medianame: proc returns (bit (1) aligned); dcl i fixed bin; if ^ident_ () then return ("0"b); do i = 1 to media.count; if (media.name (i) = token_value) then do; token.Nvalue = i; if dt_sw then call ioa_$nnl ("<medianame>"); return ("1"b); end; end; return ("0"b); end medianame; /**** +++[Syntax Function]+++++++ MEMBERNAME +++++++++++++++++++++++++++++++ */ membername: proc returns (bit (1) aligned); dcl i fixed bin; if (substr (token_value, 1, 1) ^= "/") then return ("0"b); if (token.Lvalue > 32) then return ("0"b); if (token.Lvalue > 1) then do; if (index ("0123456789", substr (token_value, 2, 1)) ^= 0) then return ("0"b); if (verify (substr (token_value, 2), az_AZ09) ^= 0) then return ("0"b); end; if dt_sw then call ioa_$nnl ("<membername>"); return ("1"b); end membername; /**** +++[Syntax Function]+++++++++ NEGNUM +++++++++++++++++++++++++++++++++ */ /* */ /* Tests token for being a negative number */ negnum: proc returns (bit (1) aligned); /* check negative decimal value */ if (substr (token_value, 1, 1) ^= "-") /* must start with - sign */ then return ("0"b); if (token_value = "-.") /* just in case they throw a curve */ then return ("0"b); if (verify (substr (token_value, 2), "0123456789.") ^= 0) /* and have */ then return ("0"b); /* only legal decimal chars & */ if (index (after (token_value, "."), ".") ^= 0) /* only 1 decimal pt */ then return ("0"b); if dt_sw then call ioa_$nnl ("<negnum>"); token.Nvalue = convert (token.Nvalue, token_value); return ("1"b); end negnum; /**** +++[Syntax Function]+++++++ NUM/LIMIT ++++++++++++++++++++++++++++++++ */ /* */ /* Tests token for being UNLIMITED or being a number */ /* Tests token for being a number */ limit: proc returns (bit (1) aligned); if (token_value = "unlimited") then do; token.Nvalue = -1; return ("1"b); end; num: entry returns (bit (1) aligned); /* check decimal value */ if token_value = "." then return ("0"b); if verify (token_value, "0123456789.") ^= 0 /* legal decimal chars */ then return ("0"b); if (index (after (token_value, "."), ".") ^= 0) /* only 1 dec pt */ then return ("0"b); if dt_sw then call ioa_$nnl ("<num>"); token.Nvalue = convert (token.Nvalue, token_value); return ("1"b); end limit; /**** +++[Syntax Function]+++++++++ OCTAL ++++++++++++++++++++++++++++++++++ */ /* */ /* Tests token for being an octal character representation */ /* SETS: Input - 9-bit char gotten by converting the 3 octal digits */ octal: proc returns (bit (1) aligned); ldt_sw = dt_sw; goto start; octal_: entry returns (bit (1) aligned); ldt_sw = "0"b; /* never db displays */ dcl ldt_sw bit (1); dcl 1 bits (3) unal, /* copy of the 3 token chars as bits */ 2 f bit (6), 2 b bit (3); start: if token.Lvalue ^= 3 /* if token is not exactly 3 chars */ then return ("0"b); /* it can't be octal */ if verify (token_value, "01234567") ^= 0 /* it can't have any chars */ then return ("0"b); /* outside the octal range */ string (bits) = unspec (token_value); /* copy token into structure */ unspec (Input) = b (1) || b (2) || b (3); /* convert octal to binary */ if ldt_sw then call ioa_$nnl ("<octal>"); return ("1"b); end octal; /**** +++[Procedure]+++++++++++++ OUTPUTTER ++++++++++++++++++++++++++++++++ */ /* */ /* Outputs the whole schmeer to an alm source file. */ /* USES: most everything of value */ outputter: proc; dcl addname bit (1); /* 1 = table name is an addname */ /**** format: off */ dcl bitname (0:511) char (16) /* char names for tables */ int static options (constant) init ("000", "001", "002", "003", "004", "005", "006", "007", "010 BSP", "011 HT", "012 NL", "013 VT", "014 FF", "015 CR", "016", "017", "020", "021 ctl-str", "022", "023", "024", "025", "026", "027", "030", "031", "032", "033 ESC", "034", "035", "036", "037", "040 SP", "041 !", "042 """, "043 #", "044 $", "045 %", "046 &", "047 '", "050 Lp", "051 Rp", "052 *", "053 +", "054 ,", "055 -", "056 .", "057 /", "060 0", "061 1", "062 2", "063 3", "064 4", "065 5", "066 6", "067 7", "070 8", "071 9", "072 :", "073 ;", "074 <", "075 =", "076 >", "077 ?", "100 @", "101 A", "102 B", "103 C", "104 D", "105 E", "106 F", "107 G", "110 H", "111 I", "112 J", "113 K", "114 L", "115 M", "116 N", "117 O", "120 P", "121 Q", "122 R", "123 S", "124 T", "125 U", "126 V", "127 W", "130 X", "131 Y", "132 Z", "133 [", "134 \", "135 ]", "136 ^", "137 _", "140 `", "141 a", "142 b", "143 c", "144 d", "145 e", "146 f", "147 g", "150 h", "151 i", "152 j", "153 k", "154 l", "155 m", "156 n", "157 o", "160 p", "161 q", "162 r", "163 s", "164 t", "165 u", "166 v", "167 w", "170 x", "171 y", "172 z", "173 {", "174 |", "175 }", "176 ~", "177 PAD", "200", "201", "202", "203", "204", "205", "206", "207", "210", "211", "212", "213", "214", "215", "216", "217", "220", "221", "222", "223", "224", "225", "226", "227", "230", "231", "232", "233", "234", "235", "236", "237", "240", "241", "242", "243", "244", "245", "246", "247", "250", "251", "252 mlpy", "253 +_", "254 nabla", "255 EMdash", "256", "257 slash", "260", "261 dagger", "262", "263", "264", "265", "266", "267", "270", "271", "272", "273 _|", "274", "275 /=", "276", "277", "300", "301 dbl dagger", "302", "303 copyright", "304 delta", "305", "306", "307", "310", "311", "312", "313", "314", "315 bullet", "316||", "317", "320 PI", "321", "322", "323", "324", "325", "326 therefore", "327", "330", "331", "332 = ", "333", "334", "335", "336", "337 infinity", "340", "341", "342", "343", "344", "345", "346", "347", "350", "351", "352 theta", "353", "354", "355", "356", "357", "360 pi", "361", "362", "363", "364", "365", "366", "367", "370", "371", "372", "373", "374", "375 square", "376 overbar", "377 punct SP", "400 superior 0", "401 superior 1", "402 superior 2", "403 superior 3", "404 superior 4", "405 superior 5", "406 superior 6", "407 superior 7", "410 superior 8", "411 superior 9", "412 EM", "413 EM _dash", "414 EN", "415 EN _dash", "416 EN dash", "417 thin space", "420", "421 ``", "422 ''", "423 1hi X", "424", "425 v|", "426", "427 dia left", "430 delete mark", "431 dia right", "432 dia top", "433 <", "434 1hi {", "435 1hi [", "436 left circle", "437", "440 ->", "441 1hi }", "442 1hi ]", "443 right circle", "444", "445 ^|", "446", "447", "450", "451", "452", "453", "454", "455", "456", "457", "460", "461", "462", "463", "464", "465", "466", "467", "470", "471", "472", "473", "474", "475", "476", "477", "500", "501", "502", "503", "504", "505", "506", "507", "510", "511", "512", "513", "514", "515", "516", "517", "520", "521", "522", "523", "524", "525", "526", "527", "530", "531", "532", "533", "534", "535", "536", "537", "540", "541", "542", "543", "544", "545", "546", "547", "550", "551", "552", "553", "554", "555", "556", "557", "560", "561", "562", "563", "564", "565", "566", "567", "570", "571", "572", "573", "574", "575", "576", "577", "600", "601", "602", "603", "604", "605", "606", "607", "610", "611", "612", "613", "614", "615", "616", "617", "620", "621", "622", "623", "624", "625", "626", "627", "630", "631", "632", "633", "634", "635", "636", "637", "640", "641", "642", "643", "644", "645", "646", "647", "650", "651", "652", "653", "654", "655", "656", "657", "660", "661", "662", "663", "664", "665", "666", "667", "670", "671", "672", "673", "674", "675", "676", "677", "700", "701", "702", "703", "704", "705", "706", "707", "710", "711", "712", "713", "714", "715", "716", "717", "720", "721", "722", "723", "724", "725", "726", "727", "730", "731", "732", "733", "734", "735", "736", "737", "740", "741", "742", "743", "744", "745", "746", "747", "750", "751", "752", "753", "754", "755", "756", "757", "760", "761", "762", "763", "764", "765", "766", "767", "770", "771", "772", "773", "774", "775", "776", "777"); /**** format: on */ dcl (i, j) fixed bin; /* working index */ dcl oct_p ptr; dcl jjj fixed bin; dcl 1 oct based, 2 ct fixed bin (35), 2 e (o_s) fixed bin (35); dcl o_s fixed bin; dcl out entry automatic options (variable); out = ioa_$ioa_switch; /* to shrink the line size below */ /* This writes things in this sequence: */ /* 1) "include compdv" */ /* 2) ({comp_dvid} segdef's)'s */ /* 3) (comp_dvt member's med_sel)'s */ /* 4) font's */ /* 5) sizel's */ /* 6) strings ... */ /* 7) "end" */ if db_sw then call ioa_ ("===outputter"); call out (ALM, "^-include^-compdv"); do dvid_p = dvidl_p (1) repeat (dvid.next) while (dvid_p ^= null ()); if dvid.real then do; call out (ALM, "^/dvid.^i:", dvid.ndx); call out (ALM, "^-dvid.version^-^i", comp_dvid_version); call out (ALM, "^-dvid.devname^-^a,^i", dvid.devname, length (dvid.devname)); call out (ALM, "^-dvid.dvt_r^-dvt.^i", dvid.dvt_ndx); end; call out (ALM, "^/^-dvid_segdef^-^i,^a", dvid.ndx, dvid.refname); end; do dvt_p = dvtl_p (1) repeat (dvt.next) while (dvt_p ^= null ()); prent_p = dvt.prent; const.devptr = dvt.ref; call out (ALM, "^-even^/dvt.^i:", dvt.ndx); call out (ALM, "^-dvt.devclass^-^a,^i", comp_dvt.devclass, length (comp_dvt.devclass)); call out (ALM, "^-dvt.outproc^-^a", prent.outproc); call out (ALM, "^-dvt.footproc^-^a", prent.footproc); call out (ALM, "^-dvt.artproc^-^a", prent.artproc); call out (ALM, "^-dvt.displayproc^-^a", DisplayProc || "$display"); call out (ALM, "^-dvt.min_WS^-^i", comp_dvt.min_WS); call out (ALM, "^-dvt.min_lead^-^i", comp_dvt.min_lead); call out (ALM, "^-dvt.vmt_min^-^i", comp_dvt.vmt_min); call out (ALM, "^-dvt.vmb_min^-^i", comp_dvt.vmb_min); call out (ALM, "^-dvt.def_vmt^-^i", comp_dvt.def_vmt); call out (ALM, "^-dvt.def_vmh^-^i", comp_dvt.def_vmh); call out (ALM, "^-dvt.def_vmf^-^i", comp_dvt.def_vmf); call out (ALM, "^-dvt.def_vmb^-^i", comp_dvt.def_vmb); call out (ALM, "^-dvt.pdw_max^-^i", comp_dvt.pdw_max); call out (ALM, "^-dvt.pdl_max^-^i", comp_dvt.pdl_max); call out (ALM, "^-dvt.upshift^-^i", comp_dvt.upshift); call out (ALM, "^-dvt.init_ps^-^i", comp_dvt.init_ps); call out (ALM, "^-dvt.lettersp^-^i", comp_dvt.lettersp); call out (ALM, "^-dvt.max_pages^-^i", comp_dvt.max_pages); call out (ALM, "^-dvt.max_files^-^i", comp_dvt.max_files); call out (ALM, "^-dvt.init_fam^-^i", comp_dvt.init_fam); call out (ALM, "^-dvt.init_mem^-^i", comp_dvt.init_mem); call out (ALM, "^-dvt.foot_fam^-^i", comp_dvt.foot_fam); call out (ALM, "^-dvt.foot_mem^-^i", comp_dvt.foot_mem); call out (ALM, "^-dvt.init_family^-^a,^i", comp_dvt.init_family, length (comp_dvt.init_family)); call out (ALM, "^-dvt.init_member^-^a,^i", comp_dvt.init_member, length (comp_dvt.init_member)); call out (ALM, "^-dvt.atd_r^2-^a", fmt_str_r (comp_dvt.atd_r)); call out (ALM, "^-dvt.dvc_r^2-dvc^.3b", comp_dvt.dvc_r); call out (ALM, "^-dvt.comment_r^-^a", fmt_str_r (comp_dvt.comment_r)); call out (ALM, "^-dvt.cleanup_r^-^a", fmt_str_r (comp_dvt.cleanup_r)); call out (ALM, "^-dvt.medsel_table_r^-med_sel.^d", dvt.ndx); call out (ALM, "^-dvt.foot_family^-^a,^i", comp_dvt.foot_family, length (comp_dvt.foot_family)); call out (ALM, "^-dvt.foot_member^-^a,^i", comp_dvt.foot_member, length (comp_dvt.foot_member)); call out (ALM, "^-dvt.sws^2-^w", string (comp_dvt.sws)); call out (ALM, "^-dvt.open_mode^-.^[str^;seq^]_out.", (comp_dvt.open_mode = 2)); call out (ALM, "^-dvt.recleng^-^i", comp_dvt.recleng); call out (ALM, "^-dvt.family_ct^-^i", comp_dvt.family_ct); do family_i = 1 to comp_dvt.family_ct; mem_p = ptr (area1_p, comp_dvt.family (family_i).member_r); call out (ALM, "^-dvt..member_r^-mem.^d", mem.refno); call out (ALM, "^-dvt..name^2-^a,^i", comp_dvt.family (family_i).name, 32); end; call out (ALM, "^/med_sel.^i:", dvt.ndx); call out (ALM, "^-med_sel_tab.count^-^i", view.count); do med_sel_i = 1 to view.count; call out (ALM, "^-med_sel_tab..ref_r^-^a^-^i", fmt_str_r (med_sel_tab.ref_r (med_sel_i)), med_sel_i); end; end; do mem_p = meml_p (1) repeat (mem.next) while (mem_p ^= null ()); if mem.refno = mem.seqno then do; member_ptr = mem.ref_p; call out (ALM, "mem.^d:", mem.seqno); call out (ALM, "^-member.count^-^i", member.count); do mem_i = 1 to member.count; fnt_p = ptr (area2_p, member.font_r (mem_i)); call out (ALM, "^-member..font_r^-f.^i", fnt.refno); call out (ALM, "^-member..size_r^-size.^i", addr (member.size_r (mem_i)) -> bfb); call out (ALM, "^-member..Scale^-^i,^i", member.Scalex (mem_i), member.Scaley (mem_i)); call out (ALM, "^-member..name^-^a,^i", member.name (mem_i), length (member.name (mem_i))); end; end; end; call out (ALM, "^|"); /* eject page before fonts */ do fnt_p = fntl_p (1) repeat (fnt.next) while (fnt_p ^= null ()); font_ptr = fnt.pt; uni_p = ptr (fnt.pt, font.units_r); opu_p = ptr (fnt.pt, font.oput_r); call out (ALM, "f.^i:^2-""^a", fnt.refno, fnt.name); call out (ALM, "^-font.oput_r^-opu.^i", opu.refno); call out (ALM, "^-font.units_r^-uni.^i", uni.refno); call out (ALM, "^-font.rel_units^-^i", font.rel_units); call out (ALM, "^-font.footsep^-(^1a)", font.footsep); call out (ALM, "^-font.fill^- "); call out (ALM, "^-font.min_wsp^-^i", font.min_wsp); call out (ALM, "^-font.avg_wsp^-^i", font.avg_wsp); call out (ALM, "^-font.max_wsp^-^i", font.max_wsp); end; do uni_p = unil_p (1) repeat (uni.next) while (uni_p ^= null ()); if uni.refno = uni.seqno then do; call out (ALM, "uni.^i:", uni.seqno); units_ptr = uni.ref_p; mediawidth = units (0); dup_ct = 1; do i = 1 to 511; if (mediawidth = units (i)) then dup_ct = dup_ct + 1; else do; call out (ALM, "^-units (^i),^[0^;^i^]", dup_ct, (mediawidth = nulwidth), mediawidth); mediawidth = units (i); dup_ct = 1; end; end; call out (ALM, "^-units (^i),^[0^;^i^]", dup_ct, (mediawidth = nulwidth), mediawidth); end; end; do opu_p = opul_p (1) repeat (opu.next) while (opu_p ^= null ()); if opu.refno = opu.seqno then do; call out (ALM, "opu.^i:", opu.seqno); oput_p = opu.ref_p; call out (ALM, "^-oput.data_ct^-^i", oput.data_ct); skip_ct = 0; do i = 0 to oput.data_ct; if (oput.what_r (i) = "0"b) then skip_ct = skip_ct + 1; else do; if (skip_ct > 0) then call out (ALM, "^-no_ch (^i)", skip_ct); skip_ct = 0; call out (ALM, "^-ch ^i,^a [^[null^s^;^i^]]^-^a", oput.which (i), fmt_str_r ((oput.what_r (i))), (units (i) = nulwidth), units (i), bitname (i)); end; end; end; end; do i = 1 to size_list.count; sizel_p = size_list.pt (i); call out (ALM, "^/size.^i:", i); call out (ALM, "^-sizel.val_ct^-^i", sizel.val_ct); do j = 1 to sizel.val_ct; call out (ALM, "^-sizel..val^-^d", sizel.val (j)); end; end; call out (ALM, "^/.nul_str.:^-zero"); do j = 2 to string_l (2); oct_p = strl_p (2, j); o_s = divide (oct_p -> bstr.leng + 3, 4, 17, 0); if j = 2 then call out (ALM, "^/str:^-dec^-^d", oct_p -> oct.ct); else call out (ALM, "^/^-dec^-^d^2-^a", oct_p -> oct.ct, fmt_str_r (rel (oct_p))); do jjj = 1 to o_s; call out (ALM, "^-oct^-^w^-^a", oct_p -> oct.e (jjj), fmt_str_cmt (oct_p -> oct.e (jjj), oct_p -> oct.ct - 4 * (jjj - 1))); end; end; call out (ALM, "^/^-end"); end outputter; /**** +++ OUTPUTTER UTILITY: FMT_STR_CMT ++++++++++++++++++++++++++++++++++ */ fmt_str_cmt: proc (Oct, Len) returns (char (4) aligned); dcl Oct fixed bin (35); dcl Len fixed bin; dcl idx fixed bin; dcl str char (4) aligned; unspec (str) = unspec (Oct); if Len < 4 then substr (str, Len + 1) = ""; do idx = 1 to min (4, Len); if substr (str, idx, 1) = ";" | rank (substr (str, idx, 1)) < rank (" ") | rank (substr (str, idx, 1)) > rank ("~") then substr (str, idx, 1) = "."; end; return (str); end fmt_str_cmt; /**** +++ OUTPUTTER UTILITY: FMT_STR_R +++++++++++++++++++++++++++++++++++++ */ fmt_str_r: proc (Rel) returns (char (9)); dcl Rel bit (18) aligned; dcl pic picture "99999"; if Rel = ""b then return (".no_repl."); if Rel = rel (strl_p (2, 1)) then return (".nul_str."); pic = binary (Rel, 18) - wordno (strl_p (2, 2)); return ("str+" || pic); end fmt_str_r; /**** +++[Syntax Function]++++++++++ PART ++++++++++++++++++++++++++++++++++ */ part: proc returns (bit (1) aligned); /**** format: off */ dcl art_tokens char (388) init /* token string */ ("[ ] { } ( ) | || o / X d m \ c t " || "v ^ <- -> D^ D< D> Dv Clf Crt -str-rul-stp|rul/rul\rul" || "[tp ]tp {tp }tp lptprptp|tp ||tp[ht ]ht {ht }ht lphtrpht|ht ||ht" || "[md ]md {md }md lpmdrpmd|md ||md[hb ]hb {hb }hb lphbrphb|hb ||hb" || "[bt ]bt {bt }bt lpbtrpbt|bt ||bt[fl ]fl {fl }fl lpflrpfl|fl ||fl" || "PI pi bxtlbxt bxtrbxl bxx bxr bxblbxb bxbrlztllztrlzl lzr lzbllzbr"); dcl art_codes (97) char (1) init /* codes */ (art.one (1), art.one (2), art.one (3), art.one (4), art.one (5), art.one (6), art.one (7), art.one (8), art.one (9), art.one (10), art.one (11), art.one (12), art.one (13), art.lslnt, cright, tmark, art.daro, art.uparo, art.laro, art.raro, art.diam.top, art.diam.lvert, art.diam.rvert, art.diam.bottom, art.lcirc, art.rcirc, art.horiz.start, art.horiz.line, art.horiz.term, art.vpart, art.rslnt, art.lslnt, art.top (1), art.top (2), art.top (3), art.top (4), art.top (5), art.top (6), art.top (7), art.top (8), art.half_top (1), art.half_top (2), art.half_top (3), art.half_top (4), art.half_top (5), art.half_top (6), art.half_top (7), art.half_top (8), art.middle (1), art.middle (2), art.middle (3), art.middle (4), art.middle (5), art.middle (6), art.middle (7), art.middle (8), art.half_bottom (1), art.half_bottom (2), art.half_bottom (3), art.half_bottom (4), art.half_bottom (5), art.half_bottom (6), art.half_bottom (7), art.half_bottom (8), art.bottom (1), art.bottom (2), art.bottom (3), art.bottom (4), art.bottom (5), art.bottom (6), art.bottom (7), art.bottom (8), art.other_part (1), art.other_part (2), art.other_part (3), art.other_part (4), art.other_part (5), art.other_part (6), art.other_part (7), art.other_part (8), art.PI, art.pi, art.box.tl, art.box.t, art.box.tr, art.box.l, art.box.x, art.box.r, art.box.bl, art.box.b, art.box.br, art.loz.tl, art.loz.tr, art.loz.l, art.loz.r, art.loz.bl, art.loz.br); /**** format: on */ dcl i fixed bin; /* working index */ dcl part_token char (4); /* token expanded to 4 chars */ part_token = token_value; /* copy the token */ i = index (art_tokens, part_token); /* scan art tokens */ if i > 0 /* found? */ then do; i = divide (i, 4, 17, 0) + 1; /* calculate code index */ Input = art_codes (i); /* fetch the code */ if dt_sw then call ioa_$nnl ("<part>"); return ("1"b); /* return true */ end; else return ("0"b); end part; /**** +++[Debug Routine]+++++++++ PUSH/POP +++++++++++++++++++++++++++++++++ */ /* */ dcl Stack (20) char (16); /**** +++[Function]++++++++++++++ SCALE_UNIT +++++++++++++++++++++++++++++++ */ /* */ /* convert units to millipoints */ scale_unit: proc (the_scale) returns (fixed bin (31)); dcl the_scale fixed bin (31); dcl (pi, pt) char (10); if (the_scale > 0) /* not pica/point form */ then return (the_scale * bin (before (token_value, ".")) + divide (the_scale * bin (substr (after (token_value, ".") || "000", 1, 3)), 1000, 17, 0)); return (hscales (5) * bin (before (token_value, ".")) + hscales (6) * bin (after (token_value, "."))); end scale_unit; /**** +++[Syntax Function]++++++++ SIZENAME ++++++++++++++++++++++++++++++++ */ sizename: proc returns (bit (1) aligned); dcl i fixed bin; do i = 1 to size_list.count; /* scan sizetable names */ if size_list.name (i) = token_value then do; token.Nvalue = i; /* set index value */ if dt_sw then call ioa_$nnl ("<sizename>"); return ("1"b); end; end; return ("0"b); end sizename; /**** +++[Function]++++++++++++++ SHOW_NAME ++++++++++++++++++++++++++++++++ */ /* */ /* converts a MediaChar name into display form if needed. */ show_name: proc (str) returns (char (32)); dcl str char (*); dcl bits (3) bit (3) unal; dcl bins (3) fixed bin (3) unsigned unal based (addr (bits)); if (substr (str, 1, 1) ^= "[") then return (str); if (substr (str, 2, 1) > " ") & (substr (str, 2, 1) <= "~") then return ("""" || substr (str, 2, 1) || """"); string (bits) = unspec (substr (str, 2, 1)); return (substr ("01234567", bins (1) + 1, 1) || substr ("01234567", bins (2) + 1, 1) || substr ("01234567", bins (3) + 1, 1)); end show_name; /**** +++[Syntax Function]+++++++++ SWITCH +++++++++++++++++++++++++++++++++ */ /* */ /* check for on/off */ /* SETS: token.Nvalue - 0 (off) 1 (on) */ switch: proc returns (bit (1) aligned); if token_value = "on" then token.Nvalue = 1; else if token_value = "off" then token.Nvalue = 0; else return ("0"b); if dt_sw then call ioa_$nnl ("<switch>"); return ("1"b); end switch; /**** +++[Syntax Function]+++++++ TABLE_NAME +++++++++++++++++++++++++++++++ */ table_name: proc returns (bit (1) aligned); dcl i fixed bin; /* scan dvid list names */ do dvid_p = dvidl_p (1) repeat (dvid.next) while (dvid_p ^= null ()); if dvid.refname = token_value then do; if dvid.dvt_ndx = dvt_ct + 1 then do; call ERROR (circular_Device_def); return ("0"b); end; token.Nvalue = dvid.dvt_ndx; /* set index value */ if dt_sw then call ioa_$nnl ("<table_name>"); return ("1"b); end; end; return ("0"b); end table_name; /**** +++[Syntax Function]++++++++ UNITKEY +++++++++++++++++++++++++++++++++ */ unitkey: proc returns (bit (1) aligned); dcl i fixed bin; /* working index */ dcl unit_key_list (7) char (2) /* list of Units keywords */ static options (constant) init ("pi", "el", "in", "mm", "pc", "pt", "pp"); do i = 1 to hbound (unit_key_list, 1) while (token_value ^= unit_key_list (i)); end; if i > hbound (unit_key_list, 1) then do; call ERROR (inv_Units_keyword); return ("0"b); end; token.Nvalue = i; if dt_sw then call ioa_$nnl ("<unitkey>"); return ("1"b); end unitkey; /**** +++[Syntax Function]+++ VALID_DEVICE_NAME ++++++++++++++++++++++++++++ */ /* */ /* Test for token being a valid Device name, i.e. an <ident> which is not */ /* already defined as a Device name. */ valid_Device_name: proc returns (bit (1) aligned); if ^ident_ () then return ("0"b); do dvid_p = dvidl_p (1) repeat (dvid.next) while (dvid_p ^= null ()); if token_value = dvid.refname then do; call ERROR (dup_Device); return ("0"b); end; end; if dt_sw then call ioa_$nnl ("<valid_Device_name>"); return ("1"b); end valid_Device_name; /**** +++[Syntax Function]+++ VALID_MEDIA_NAME ++++++++++++++++++++++++++++ */ /* */ /* Test for token being a valid Media name, i.e. an <ident> which is not */ /* already defined as a Media name. */ valid_Media_name: proc returns (bit (1) aligned); if ^ident_ () then return ("0"b); do i = 1 to media.count; if (media.name (i) = token_value) then do; call ERROR (dup_Media); return ("0"b); end; end; if dt_sw then call ioa_$nnl ("<valid_Media_name>"); return ("1"b); end valid_Media_name; save_unref: if "0"b then call a_debug; goto save_unref; dbs: entry (xxxx); db_start = xxxx; return; dcl xxxx char (*); dbn: entry; db_sw = "1"b; return; dbf: entry; db_sw = "0"b; return; dtn: entry; dt_sw = "1"b; return; dtf: entry; dt_sw = "0"b; return; trn: entry; tr_sw = "1"b; return; trf: entry; tr_sw = "0"b; return; %page; /* +++++++++++++++++++++++++++ LOOSE VARIABLES +++++++++++++++++++++++++++++ */ dcl ALM ptr init (null ()); /* iocb pointer for alm output file */ dcl arg char (argl) based (argp); /* a command line argument */ dcl argl fixed bin; /* length of arg */ dcl argp ptr; /* pointer to arg */ dcl ArtEntry char (32) var init ("artproc"); /* artwork proc entry */ dcl ArtProc char (32) varying; /* artwork procedure entryname */ dcl Atd_r bit (18) init ("000000"b3); /* default attach descr relp */ dcl attach char (256) var; dcl AvgWordsp fixed bin init (-1); /* global average wordspace */ dcl az_AZ09 char (64) int static options (constant) init ("abcdefghijklmnopqrstuvwxyz_" || "ABCDEFGHIJKLMNOPQRSTUVWXYZ 0123456789"); dcl bach_sw bit (1); dcl bfb fixed bin (35) based aligned; dcl bpptr ptr based; dcl breaks char (128) var static; /* control string for lex_string_ */ dcl ch1 char (1); dcl char_val fixed bin; dcl charid fixed bin; dcl charid_ fixed bin; dcl check_opt bit (1) static; /* check mode flag */ dcl cleanup condition; dcl code fixed bin (35); dcl Com_r bit (18); dcl Clean_r bit (18); dcl db_start char (12) int static init (""); dcl db_sw bit (1) int static init ("0"b); dcl dclname char (8); dcl default_view fixed bin; dcl DefVmt fixed bin (31) init (48000); dcl DefVmh fixed bin (31) init (24000); dcl DefVmf fixed bin (31) init (24000); dcl DefVmb fixed bin (31) init (48000); dcl DevClass char (24) init ("typewriter"); /* default device class */ dcl Device_Pthis_token ptr; dcl DevName char (24) init ("ascii"); /* default device name */ dcl dname char (168); /* name of dir containing ename */ dcl done bit (1); dcl dt_sw bit (1); dcl dup_ct fixed bin; dcl dvt_i fixed bin; dcl ename char (32); /* input entryname (no suffix) */ dcl EndPage bit (9) init ("0"b); dcl ercd fixed bin (35); /* error code */ dcl family_i fixed bin; dcl fd12_8 fixed dec (12, 8); dcl first_time bit (1) static init ("1"b); /* initing control switch */ dcl first_token_p ptr; dcl font_fam char (32); dcl font_mem char (32); dcl FootEntry char (32) varying/* footnote procedure entrypoint */ init ("footproc"); dcl footentry char (32); dcl FootFamily char (32); /* global footnote font family name */ dcl footfamily char (32); dcl FootMember char (32); /* global footnote font member name */ dcl footmember char (32); dcl FootProc char (32) varying; /* footnote procedure entryname */ dcl Footsep char (1) init (","); dcl held_Pthis_token ptr; dcl hold_Pthis_token ptr; dcl Hscale fixed bin (31); /* global hor scale */ dcl hscale fixed bin (31); /* local hor scale */ dcl hscales (7) fixed bin (31) /* hor scale factors */ static options (constant) init (7200, 6000, 72000, 2834.65, 12000, 1000, 0); dcl i fixed bin; dcl ignored_breaks char (128) var static; /* control string for lex_string_ */ dcl ii fixed bin; dcl iii fixed bin; dcl initfamily char (32); dcl initmember char (32); dcl Input char (1); dcl input_bitcount fixed bin (24); /* bit count for ename segment */ dcl input_charcount fixed bin (24); /* char count for ename segment */ dcl input_file char (input_charcount) /* source file overlay */ based (input_ptr); dcl input_ptr ptr; /* point to ename segment */ dcl Interleave bit (1) init ("0"b); dcl j fixed bin; dcl jj fixed bin; dcl Justify bit (1) init ("0"b); dcl Letterspace fixed bin (31) init (0); dcl lex_ctl_chars char (128) var static; /* control string for lex_string_ */ dcl lex_delims char (128) var static; /* control string for lex_string_ */ dcl lex_temp_ptr ptr init (null ()); /* temp seg for lex_string_ */ dcl like_table fixed bin; dcl list_ndx fixed bin; dcl list_opt bit (1); /* list option flag */ /* font locator */ dcl loc_font fixed bin (35) based; dcl ( MaxFiles, /* global maximum file/reel */ MaxWordsp, /* global maximum wordspace */ MaxPages, /* global maximum pages/file */ MaxPageLength ) fixed bin (31) init (-1); dcl MaxPageWidth fixed bin (31) init (979200); dcl media1 char (32); dcl media2 char (32); dcl mediabase fixed bin; dcl mediact fixed bin; dcl mediawidth fixed bin; dcl media_ char (32); dcl media_i fixed bin; dcl 1 member_hold like member.e; dcl mem_i fixed bin; dcl med_sel_i fixed bin; dcl MinLead fixed bin (31) init (7200); /* global minimum lead */ dcl MinSpace fixed bin (31) init (7200); dcl MinWordsp fixed bin init (-1); /* global minimum wordspace */ dcl MinVmb fixed bin (31) init (0); dcl MinVmt fixed bin (31) init (0); dcl mw fixed bin; dcl nargs fixed bin; /* command line arg count */ dcl new_family bit (1); dcl new_member fixed bin; dcl next_dcl_p ptr; dcl next_str_p ptr; dcl nulwidth fixed bin int static options (constant) init (-100000); dcl o777 char (1) int static options (constant) init ("ÿ"); dcl Openmode fixed bin init (5); /* opening mode for compout file */ dcl OutEntry char (32) var; dcl OutProc char (32) var; dcl DisplayProc char (32) var; dcl parenct fixed bin; /* next 4 vars for "n(medchars)" */ /* and "n(output)" */ dcl part_repl (10) fixed bin; /* replication count for a part */ dcl part_str (10) char (400) var; /* the string for a part */ dcl part_width (10) fixed bin; /* the width of a part */ dcl part_nest fixed bin; /* nesting of parts */ dcl Scale_scale fixed bin (35) int static options (constant) init (100000000); dcl Scale_x fixed bin (35); dcl Scale_y fixed bin (35); dcl self_sw bit (1); dcl self_ct fixed bin; /* number of SELFs in mediachar list */ dcl self_i (16) fixed bin; /* location of these SELFs */ dcl Sizes fixed bin init (0); dcl skip_ct fixed bin; dcl string_l (2) fixed bin init (0, 0); dcl Strokes fixed bin init (1); dcl TapeRec fixed bin init (-1); dcl testwidth fixed bin; dcl the_font ptr; dcl the_string char (8000) var; dcl the_string_r bit (18) aligned;/* offset in string table */ dcl this_view fixed bin; dcl top_dcl_p ptr init (null ()); dcl tp ptr; dcl tr_sw bit (1) int static init ("0"b); dcl vals_ct fixed bin; /* count of entries in vals array */ dcl vals (1:512) fixed bin; dcl views_selected fixed bin; dcl viewname char (32); dcl Vscale fixed bin (31); /* global vertical scale */ dcl vscale fixed bin (31); /* local vertical scale */ dcl vscales (7) fixed bin (31) /* vertical scale factors */ static options (constant) init (12000, 9000, 72000, 2834.65, 12000, 1000, 0); dcl Wordspace_p ptr init (null ()); dcl (addr, addrel, after, before, bin, bit, byte, collate, convert, copy, dec, dimension, divide, fixed, hbound, index, length, ptr, rel, size, unspec, verify, max, null, rank, rtrim, search, string, substr, translate) builtin; %page; /* ++++++++++++++++++ ERROR CODES & EXTERNAL PROCEDURES ++++++++++++++++++++ */ dcl error_table_$badopt fixed bin (35) ext static; dcl error_table_$namedup fixed bin (35) ext static; dcl error_table_$segnamedup fixed bin (35) ext static; dcl error_table_$zero_length_seg fixed bin (35) ext static; dcl alm entry options (variable); dcl az char (26) int static init ("abcdefghijklmnopqrstuvwxyz"); dcl AZ char (26) int static init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"); dcl com_err_ entry options (variable); dcl cu_$arg_count entry (fixed bin); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed (35)); dcl delete_$path entry (char (*), char (*), bit (6) aligned, char (*), fixed bin (35)); dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed (35)); dcl get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl get_wdir_ entry returns (char (168)); dcl hcs_$chname_file entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); dcl ioa_$ioa_switch entry options (variable); dcl iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35)); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); dcl iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)); dcl lex_string_$init_lex_delims entry (char (*), char (*), char (*), char (*), char (*), bit (*), char (*) var, char (*) var, char (*) var, char (*) var); dcl lex_string_$lex entry (ptr, fixed bin (24), fixed bin (24), ptr, bit (*), char (*), char (*), char (*), char (*), char (*), char (*) var, char (*) var, char (*) var, char (*) var, ptr, ptr, fixed bin (35)); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl search_paths_$find_dir entry (char (*), ptr, char (*), char (*), char (*), fixed (35)); dcl translator_temp_$get_segment entry (char (*), ptr, fixed bin (35)); dcl translator_temp_$release_all_segments entry (ptr, fixed bin (35)); %page; /* ++++++++++++++++++++++++++++++ STRUCTURES +++++++++++++++++++++++++++++++ */ dcl temp_ptrs (4) ptr init ((4) null ()); /* These 4 segments are used to hold these structures (in order): */ /* 1 2 3 4 */ /* strl_p bstr dcl_ */ /* mediachars */ /* media */ /* view */ /* Def */ /* fnt, font, units, oput ... */ /* size_list, sizel... */ /* mem dvid..., dvt, med_sel, comp_dvt ... */ dcl strl_p (2, 2000) ptr based (temp_ptrs (1)); /* list of strings */ dcl string_area_p ptr defined (temp_ptrs (2)); /* place to hold strings */ dcl area1_p ptr defined (temp_ptrs (3)); dcl area2_p ptr defined (temp_ptrs (4)); dcl area_free_p ptr; /* next free location in area2 */ dcl size_list_p ptr; dcl 1 size_list based (size_list_p), 2 count fixed bin, 2 free ptr, /* where to put next list */ 2 e (50), 3 name char (32), /* name of size list */ 3 pt ptr, /* point to size list */ 2 start ptr; /* start of list area */ /* COMPDV/COMP_DSM STRUCTURE INTERCONNECTION */ /* TABLES USED BY compdv WHILE PARSING, */ /* NAMES MARKED WITH * ARE internal ONLY */ /* Tables are generally shown in order generated */ /* (except for strings, which crop up all over) */ /*++ /* dcl_l_p(1)>----+ */ /* dcl_l_p(2)>-+ | dcls are made first. */ /* | | dcl_* They are strings which */ /* | | ________ are referenced by name */ /* | +->|next >--+ as an aid to understanding */ /* | |dcl_name| | the DSM definition. They */ /* | |leng | | are not necessary to do */ /* | |dcl_v | | the job. */ /* | |________| | */ /* | +--------------+ Strings used by mediachars are */ /* | | dcl_* temporary, i.e. only used by compdv, */ /* | | ________ pointers to these go in strl_p(1,*). */ /* | +->|next >--+ */ /* | |dcl_name| | Strings used by font, cleanup, etc. */ /* | |leng | | are permanent, i.e. they end up in */ /* | |dcl_v | | the DSM, pointers to these go in */ /* | |________| | strl_p(2,*). */ /* | +--------------+ */ /* | | dcl_* strl_p* */ /* | | ________ _________ bstr* */ /* +--+->|next >null |1,1 |2,1 >... ____ */ /* |dcl_name| |1,2 |2,2 >-------->|leng| */ /* |leng | . . . |str | */ /* |dcl_v | : : : |____| */ /* |________| */ dcl str_p ptr; dcl 1 bstr based (str_p), /* based string used for building */ 2 leng fixed bin, /* pseudo-char_var strings */ 2 str char (bstr.leng), 2 dummy bit (36) aligned;/* where next structure will go */ dcl dcl_l_p (2) ptr; /* dcl_ list begin/end */ dcl dcl_p ptr; dcl 1 dcl_ based (dcl_p), /* ** symbol declaration */ 2 next ptr, /* linked list next element */ 2 dcl_name char (8), /* declared name */ 2 leng fixed bin, /* length of definition string */ 2 dcl_v char (dcl_.leng),/* symbol definition string */ 2 dummy ptr; /* where next one is based */ %page; /* mediachars* */ /* _______ Next, all mediachars are defined */ /* |count=n|__ in terms of dcl'ed symbols or */ /* (1)|name|out_r>----------+ literals. */ /* (2)|name|out_r>... | bstr* */ /* . . . | ____ */ /* : : : +---------------------------->|leng| */ /* (n)|name|out_r>... |str | */ /* |____|_____| |____| */ dcl mediachars_p ptr; dcl 1 mediachars based (mediachars_p), 2 count fixed bin, /* how many have been defined */ 2 e (mediachars.count), 3 name char (32), /* name of the char */ 3 out_r bit (18) aligned;/* output string to get it */ /* media* /* _______ Then, all media are */ /* ______|count=m|_________ ... ______ described in terms of the */ /* (1)|name|rel_units|w11 |w12 |... |w1n | mediachars, with the */ /* (2)|name|rel_units|w21 |w22 |... | @ | widths being defined for */ /* . . . . . . . each. Values might not */ /* : : : : : : : exist for all mediachars */ /* (m)|name|rel_units|wm1 | @ |... |wmn | in all media (shown as @). */ /* |____|_________|____|____|... |____| */ /* mediachar # --> (1) (2) ... (n) */ dcl media_p ptr; dcl 1 media based (media_p), 2 count fixed bin, /* how many have been defined */ 2 e (media.count), 3 name char (32), /* name of the media */ 3 rel_units fixed bin, /* its stroke value */ 3 width (mediachars.count) fixed bin; /* for each mediachar */ %page; /* view* */ /* _______ Views are then made up */ /* |count=k|__ from the defined media. */ /* (1)|view1|med4| Views can share a media, */ /* (2)|view2|med2| but will differ media */ /* . . . select string. Each Device */ /* : : : specifies its own set of */ /* (k)|viewk|med4| media select strings. /* |_____|____| */ dcl view_p ptr; dcl 1 view based (view_p), 2 count fixed bin, /* how many defined */ 2 e (view.count), 3 name char (32), /* viewname */ 3 media fixed bin; /* media being referenced */ /* Def* */ /* _______ Def's are a sort of macro definition. */ /* |count=d|_ Whenever a set of Multics chars have the same */ /* (1)|name1|pt1| definition in several fonts, instead of */ /* (2)|name2|pt2| entering the description again and again, a */ /* . . . Def is made containing the needed info and */ /* : : : then they are ref'ed in each table as needed. */ /* (d)|named|ptd| */ /* |_____|___| */ dcl Def_p ptr; dcl 1 Def based (Def_p), 2 count fixed bin, /* how many Def's present */ 2 e (Def.count), 3 name char (32), /* internal name of this Def */ 3 pt ptr; /* Points to the node in the */ /* lex_string_ list at which source */ /* of the Def begins. At ref time, */ /* this source will be be re-parsed */ /* via this pointer. */ %page; /* fntl_p(1)>----+ */ /* fntl_p(2)>---)|(---------------------+ */ /* +----------+ | */ /* | fnt* fnt* | fnt* */ /* | _____ _____ | _____ */ /* +-->|next >------------>|next >---+-------->|next >null */ /* |name | |name | |name | */ /* |refno| |refno| |refno| */ /* |node >... |node >... |node >... */ /* |pt >---+ |pt >... |pt >... */ /* |_____| | |_____| |_____| */ /* +-------------+ */ /* | font Fonts are made up by selecting one */ /* | _________ or more mediachars from a view and */ /* +-->|units_r >-----+ associating them to Multics (input) */ /* |oput_r >--+ | characters. To speed up measuring, */ /* |rel_units| | | the width portion of the font table */ /* |footsep | | | is a fixed size. */ /* |min_spb | | | To save space, however, the output */ /* |avg_spb | | | string portion of the font is only */ /* |max_spb | | | as long as the highest Multics char */ /* |_________| | | defined. */ /* +----------------+ | */ /* | opu* | uni* The oput and units */ /* | _____ | _____ units tables often end up */ /* +-->|next >... +-->|next >... _____ looking like others of */ /* |ref_p>---+ |ref_p>------>|(0) | their kind. Thus when */ /* |seqno| | |seqno| |(1) | each is completed, it */ /* |refno| | |refno| . . is matched against all */ /* |_____| | |_____| : : prior ones & logically */ /* +-------------+ |(511)| removed if already */ /* | oput |_____| there, reducing DSM */ /* | ____________ size. */ /* +-->|data_count=k| */ /* (0)|which|what_r>... */ /* (1)|which|what_r>... From compdv's point of */ /* . . . medchar_sel view, medchar_sel is a */ /* : : : ________..._ bstr. */ /* (k)|which|what_r>------->|len|text... | */ /* |_____|______| |___|________| */ /* */ /* oput.which references an entry in */ /* the Device's med_sel_table. */ %page; dcl font_count fixed bin; /* # font entries present */ dcl fntl_p (2) ptr; /* begin/end fnt list */ dcl fnt_p ptr; dcl 1 fnt based (fnt_p), /* === font info entry */ 2 next ptr, /* next entry */ 2 name char (32), /* internal reference only */ 2 refno fixed bin, /* internal reference # */ 2 node ptr, /* rdc node for Font: statement */ /* used for error messages */ 2 pt ptr, /* points to the font table */ 2 dummy ptr; /* where next structure goes */ dcl uni_ct fixed bin init (0); dcl unil_p (2) ptr; dcl uni_p ptr; dcl 1 uni based (uni_p), /* === units entry */ 2 next ptr, /* next entry */ 2 ref_p ptr, /* points to units table */ 2 seqno fixed bin, /* internal sequence # */ 2 refno fixed bin; /* internal reference # */ /* when seqno=refno this is a "real" */ /* entry, otherwise it's a duplicate */ dcl opul_p (2) ptr; dcl opu_p ptr; dcl 1 opu based (opu_p), /* === oputs entry */ 2 next ptr, /* next entry */ 2 ref_p ptr, /* points to oput table */ 2 seqno fixed bin, /* internal sequence # */ 2 refno fixed bin; /* internal reference # */ /* when seqno=refno this is a "real" */ /* entry, otherwise it's a duplicate */ %page; /* dvid* */ /* _______ */ /* dvidl_p(1)>-------------->|next >------+ dvid* */ /* dvidl_p(2)>----------+ |ndx | | _______ */ /* | |real | +--->|next >null */ /* | |refname| | |ndx | */ /* | |devname| | |real | */ /* | |dvt_ndx| | |refname| */ /* | |_______| | |devname| */ /* | | |dvt_ndx| */ /* +-------------------+ |_______| */ dcl comp_dvid_new bit (1); /* a new comp_dvid is being started */ dcl comp_dvid_ct fixed bin init (0); /* how many actual comp_dvid defined */ dcl dvid_ct fixed bin; /* # dvid entries present */ dcl dvidl_p (2) ptr; /* begin/end of dvid list */ dcl dvid_p ptr; dcl 1 dvid based (dvid_p), /* === comp_dvid data */ 2 next ptr, /* link to next entry */ 2 ndx fixed bin, /* which dvid being referenced */ 2 real bit (1) aligned, /* 1- defines a comp_dvid */ 2 refname char (32), /* external reference name */ 2 devname char (32), /* comp_dvid.devname */ 2 dvt_ndx fixed bin, /* comp_dvid.dvt_r derived from this */ 2 dummy ptr; /* place where next structure goes */ /* This structure contains all the info necessary to generate comp_dvid. */ %page; /* dvt* */ /* dvtl_p(1) >------+ _______ */ /* dvtl_p(2) >-----)|(-------------------------------+---->|next >null */ /* | dvt* | |ndx | */ /* | _______ | |prent >-... */ /* +------>|next >----------------+ |med_sel>--... */ /* |ndx | |ref >-... */ /* |prent >--------+ |_______| */ /* |med_sel>-----+ | */ /* |ref >--+ | | prent* */ /* |_______| | | | __________ */ /* +-------------------------+ | +------------>|outproc | */ /* | | |artproc | */ /* | comp_dvt | med_sel |footproc | */ /* | _________ | _________ |__________| */ /* +---->| details | +-->| details | */ /* | below | | below | */ /* |_________| |_________| */ dcl dvt_ct fixed bin; /* # dvt entries present */ dcl dvtl_p (2) ptr; /* begin/end of dvt list */ dcl dvt_p ptr; dcl 1 dvt based (dvt_p), /* === comp_dvt reference info */ 2 next ptr, /* link to next entry */ 2 ndx fixed bin, /* which index this represents */ 2 prent ptr, /* ptr to prent data */ 2 med_sel ptr, /* ptr to associated med_sel array */ 2 ref ptr, /* ptr to comp_dvt */ 2 dummy ptr; /* place where next structure goes */ dcl prent_p ptr; dcl 1 prent based (prent_p), /* === entryname strings, comp_dvt */ 2 outproc char (68) var, 2 artproc char (68) var, 2 footproc char (68) var, 2 dummy ptr; /* place where next structure goes */ dcl 1 med_sel_tab aligned based (dvt.med_sel), 2 count fixed bin, 2 ref_r (med_sel_tab.count) bit (18) aligned; %page; /* mem* */ /* ______ */ /* meml_p(1) >---- +->|next >--+ */ /* meml_p(2) >--+ |ref_p > | */ /* | |seqno | | */ /* | |______| | */ /* +---------------+ */ /* | mem* */ /* | ______ member */ /* +--->|next >null _________ */ /* |ref_p >-------->| details | */ /* |seqno | | below | */ /* |______| |_________| */ dcl meml_p (2) ptr; /* begin/end member list */ dcl mem_ct fixed bin init (0); /* internal sequence counter */ dcl mem_p ptr; dcl 1 mem based (mem_p), /* === member table (code gen only) */ 2 next ptr, /* next entry */ 2 ref_p ptr, /* pointer to the member table */ 2 seqno fixed bin, /* internal sequence # */ 2 refno fixed bin, /* internal reference # */ /* when seqno=refno this is a "real" */ /* entry, otherwise it's a duplicate */ 2 dummy ptr; /* where next structure goes */ /* EXTERNAL INTERCONNECTION in the DSM */ /* linkage */ /* section comp_dvid */ /* ______ +-----------------------------------------+ _______ */ /* | | | +--->| | */ /* |name1 >----+ |devname| */ /* |name2 >---)|(-------------------+ comp_dvid |dvt_r >--+ */ /* |name3 >----+ comp_dvid | _______ |_______| | */ /* |name4 >--+ _______ +-->| | comp_dvt | */ /* | etc. | +--->| | |devname| ________ | */ /* |______| |devname| |dvt_r >--->| ... | */ /* |dvt_r >--+ |_______| | | */ /* |_______| | | */ /* +-------<----------------+-----------------------------------<-------+ */ /* | comp_dvt */ /* | _____________ bstr */ /* +-->| | ___________ */ /* |atd_r >-------------------------------------->|len|str... | */ /* |dvc_r >... |___|_______| */ /* |med_sel_tab_r>-----------------+ med_sel_tab */ /* | ... | | _______ med_sel */ /* |family_ct=F | +-->|count=K| ___________ */ /* (1)|.member_r >--+ (1)|ref_r>---------->|len|str... | */ /* (1)|.name | | . . |___|_______| */ /* | ... | | (n)|ref_r>nullo */ /* |_____________| | . . */ /* +---------------+ (K)|ref_r>... sizel */ /* | member |_____| ________ */ /* | _______ +--------------------------->|val_ct=S| */ /* +-->|count=L|_________|________________ (1)|val | */ /* (1)|font_r> size_r> | lex|Scaley|name| . . */ /* (2)|font_r> size_r>--+ lex|Scaley|name| : : */ /* . . . . . . (S)|val | */ /* : : : : : : |________| */ /* (L)|font_r>---+ > Scalex|Scaley|name| */ /* |______|___|___|_______|______|____| */ /* | */ /* +-----------------+ */ /* | font units */ /* | _________ _____ */ /* +-->|units_r >-------------------------------------->|(0) | */ /* |oput_r >---+ |(1) | */ /* |rel_units| | . . */ /* |footsep | | oput : : */ /* |min_spb | | _________ |(511)| */ /* |avg_spb | +-->|data_ct=k|__ |_____| */ /* |max_spb | (0)|which|what_r>... */ /* |_________| (1)|which|what_r>... */ /* . . . medchar_sel */ /* : : : ________..._ */ /* (k)|which|what_r>--------->|len|text... | */ /* |_____|______| |___|________| */ /* */ /* oput.which references an entry in */ /* the Device's med_sel_table. */ %page; %include comp_art_parts; %include comp_metacodes; %include comp_dvid; %include comp_dvt; %include comp_fntstk; %include comp_font; %include compstat; %include compdv_msgs;  compose_index.pl1 04/23/85 1100.9rew 04/23/85 0911.1 294669 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * * * *********************************************************** */ /* A compose support tool embodying all the functionality of the older index_process.ted, index_sort.ted, and index_print. */ /* format: style2,ind2,ll79,dclind4,idind15,comcol41,linecom */ compose_index: comp_index: cndx: proc; /* SYNTAX compose_index path {-control_args} where: path the pathname of the compin file producing the raw index data. The compin suffix need not be given. {-control_args} may be: -alpha_header, -ahdr insert centered uppercase alphabetic characters as group separators whenever the first character of the primary key changes. -control_file CTL_PATH, -cf CTL_PATH use CTL_PATH.index.control as the control file for this index. The suffix "cndxctl" is assumed if not given. -number N, -nb N one of the 10 (0 thru 9) possible raw index data files. The default value is 0. See Notes below. UNDOCUMENTED -debug display debug info Notes: The raw index data files are produced by compose when the .hit control is used. See WORDPRO Reference Guide (AZ98) for further information on this control. The default raw data file is <path>.0.cndx. The output file is [wd]><path entryname>.0.index. The raw data in <path>.N.cndx is processed into a arbitrarily chosen format the style of which is partially by constants built into the program and partially by statements in the control file. The default control file is <path>.cndxctl. See Notes on Index Control Files below. Notes on Index Control Files The output file created by this program is to be treated just like any other section of the document to which it applies. That output file contains references to several of the variables defined by the documentation macros; therefore, the first line of a control file must be a call to one of the various init.compin entrypoints. */ /* LOCAL STORAGE */ dcl ahdr_sw bit (1); /* alpha header control switch */ dcl arg /* a command line argument */ char (argl) based (argp); dcl argl fixed bin (21); dcl argp ptr; /**/ /* line array for sorting */ dcl 1 bead aligned based (bead_ptr), 2 ct fixed bin, /* bead count */ 2 e (0 refer (bead.ct)), 3 linptr ptr, /* -> line text */ 3 len fixed bin (24), /* length of given text */ 3 type char (1), /* hit type */ 3 sortptr ptr; /* -> line text to be compared */ dcl bead_ptr ptr; dcl code fixed bin (35); /* error code */ dcl 1 control_file aligned like null_file; dcl d fixed bin; /* bead separation for sorting */ dcl debug bit (1); /* debug option */ dcl 1 delim, /* hit line delimiters */ 2 key char (1), 2 sep char (1), 2 end char (1); /**/ /* default delimiters */ dcl 1 dflt_delim static options (constant), 2 key char (1) init ("|"), 2 sep char (1) init ("~"), 2 end char (1) init (";"); dcl EMPTY char (3) static options (constant) init ("`~'"); dcl EN char (1) static options (constant) init (" "); dcl END char (3) static options (constant) init ("  "); /* = <SP><035><SP> */ dcl excl_ptr ptr; /* exclusions for permuting */ dcl 1 excl aligned based (excl_ptr), 2 ct fixed bin, /* count of entries */ 2 key (0 refer (excl.ct)) char (128) var; dcl hit_type char (1); /* given hit type character */ dcl (i, j, k) fixed bin; /* working index */ dcl iarg fixed bin; /* argument counter */ dcl ignore char (128) var; /* chars to ignore during sorting */ dcl index_nbr char (1); /* index data number, 0-9 */ dcl key_string char (1024) var; /* current key string */ dcl lastkey char (1024) var; /* lastkey string */ dcl 1 last_hit aligned, 2 key (5) char (1024) var, 2 pageref char (64) var; dcl line char (1024) var; /* a working line */ dcl linect fixed bin; /* line counter */ dcl linstr char (1024) based; dcl lower_case char (26) static options (constant) init ("abcdefghijklmnopqrstuvwxyz"); dcl max_chars fixed bin (21); /* limit for chars in a segment */ dcl me char (13) static options (constant) init ("compose_index"); dcl nargs fixed bin; /* command argument count */ dcl NL char (1) static options (constant) init (" "); /**/ /* empty file data structure */ dcl 1 null_file aligned static options (constant), 2 charct fixed bin (24) init (0), 2 entryname char (32) aligned init (""), 2 dir char (168) aligned init (""), 2 lineno fixed bin init (0), 2 name char (32) var init (""), 2 path char (200) var init (""), 2 posn fixed bin (21) init (1), 2 ptr ptr init (null ()); /* -> data file */ dcl 1 output_file aligned like null_file; dcl pageref char (1024) var; /* pageref string */ dcl pct fixed bin; /* pct counter for sort routine */ dcl 1 raw_file aligned like null_file; dcl SEP char (3) static options (constant) init ("  "); /* = <SP><036><SP> */ dcl 1 sorted_file aligned like null_file; dcl sortstr char (1024) var based (sortstr_ptr); dcl sortstr_ptr ptr; dcl swp bit (1); /* swap flag for sorting */ dcl 1 tbead like bead.e; /* temporary for sorting */ dcl 1 this_hit aligned, 2 key (5) char (1024) var, 2 pageref char (64) var; dcl tline char (1024) var; /* a working line */ /* transformations of permuting */ dcl 1 tran aligned based (tran_ptr), 2 ct fixed bin, /* count of pairs */ 2 e (0 refer (tran.ct)), 3 in char (128) var, 3 out char (128) var; dcl tran_ptr ptr; dcl tsegs (6) ptr; /* temp seg pointers */ dcl upper_case char (26) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ") static options (constant); dcl 1 work_file aligned like null_file; dcl (addr, after, before, divide, index, length, null, rtrim, substr, translate) builtin; dcl cleanup condition; dcl error_table_$bad_arg fixed bin (35) ext static; dcl error_table_$badopt fixed bin (35) ext static; dcl error_table_$zero_length_seg fixed bin (35) ext static; dcl sys_info$max_seg_size fixed bin (18) ext static; dcl com_err_ entry options (variable); dcl cu_$arg_count entry (fixed bin); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl expand_pathname_ entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (35)); dcl get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl get_wdir_ entry returns (char (168)); dcl hcs_$initiate_count entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (24), fixed bin (1), ptr, fixed bin (35)); dcl hcs_$make_seg entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (5), ptr, fixed bin (35)); dcl hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)); dcl hcs_$truncate_seg entry (ptr, fixed bin (19), fixed bin (35)); dcl ioa_ entry options (variable); dcl release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl term_$seg_ptr entry (ptr, fixed bin (35)); max_chars = 4 * sys_info$max_seg_size; ahdr_sw, debug = "0"b; /* alpha headers & debug off */ index_nbr = "0"; /* default index data number */ /**** tsegs (*) = null (); /* clean up any garbage */ ignore = ""; /* no ignore chars */ raw_file = null_file; /* pl1 bug 1815 wont allow multiple */ control_file = null_file; /* aggregate assignments */ output_file = null_file; /* PROCESS COMMAND LINE */ call cu_$arg_count (nargs); /* how many args? */ if nargs = 0 /* must have at least one arg */ then do; call ioa_ ("^a: Proper usage is: compose_index path {-control_arg}", me); return; end; else do iarg = 1 to nargs; /* process the args */ call cu_$arg_ptr (iarg, argp, argl, code); if code ^= 0 then do; arg_err: call com_err_ (code, me, "Reading argument ^d", iarg); return; end; if index (arg, "-") = 1 /* control arg? */ then do; if arg = "-alpha_header" | arg = "-ahdr" then ahdr_sw = "1"b; else if arg = "-control_file" | arg = "-cf" then do; iarg = iarg + 1; call cu_$arg_ptr (iarg, argp, argl, code); if code ^= 0 then goto arg_err; control_file.path = before (arg, ".cndxctl") || ".cndxctl"; if index (control_file.path, "<>") ^= 0 then do; call expand_pathname_ ((control_file.path), control_file.dir, control_file.entryname, code); if code ^= 0 then do; call com_err_ (code, me, "Expanding path for ""^a"".", control_file.path); return; end; end; else do; control_file.dir = get_wdir_ (); control_file.entryname = control_file.path; end; control_file.path = rtrim (control_file.dir) || ">" || rtrim (control_file.entryname); end; else if arg = "-number" | arg = "-nb" then do; iarg = iarg + 1; call cu_$arg_ptr (iarg, argp, argl, code); if code ^= 0 then goto arg_err; if argl > 1 | index ("0123456789", arg) = 0 then do; call com_err_ (error_table_$bad_arg, me, "A single decimal digit expected for argument ^d.", iarg); return; end; index_nbr = arg; end; /**/ /* UNDOCUMENTED */ else if arg = "-debug" then debug = "1"b; else do; call com_err_ (error_table_$badopt, me, "Argument ^d - ""^a"".", iarg, arg); return; end; end; else do; /* file name */ raw_file.path = before (arg, ".compin"); if search (raw_file.path, "<>") ^= 0 then do; call expand_pathname_ ((raw_file.path), raw_file.dir, raw_file.entryname, code); if code ^= 0 then do; call com_err_ (code, me, "Expanding path for ""^a"".", raw_file.path); return; end; end; else do; raw_file.dir = get_wdir_ (); raw_file.entryname = raw_file.path; end; raw_file.path = rtrim (raw_file.dir) || ">" || rtrim (raw_file.entryname); end; end; /* PROCESS THE RAW FILE */ raw_file.name = rtrim (raw_file.entryname) || "." || index_nbr || ".cndx"; call hcs_$initiate_count (raw_file.dir, (raw_file.name), "", raw_file.charct, 0, raw_file.ptr, code); if raw_file.ptr = null () then do; call com_err_ (code, me, "Initiating ^a>^a.", rtrim (raw_file.dir), raw_file.name); return; end; on cleanup goto clean; /* we now have something to clean */ if raw_file.charct = 0 then do; call com_err_ (error_table_$zero_length_seg, me, "^a>^a.", rtrim (raw_file.dir), raw_file.name); goto clean; end; /**/ /* we are GO for this run */ work_file = null_file; sorted_file = null_file; output_file.dir = get_wdir_ (); /* hook up to the output file */ output_file.entryname, output_file.name = rtrim (raw_file.entryname) || "." || index_nbr || ".index"; call hcs_$make_seg (output_file.dir, output_file.entryname, "", 10, output_file.ptr, code); if output_file.ptr = null () then do; call com_err_ (code, me, "Accessing the output compin file."); goto clean; end; call hcs_$truncate_seg (output_file.ptr, 0, code); /* get some temp segs */ call get_temp_segments_ (me, tsegs, code); if code ^= 0 then do; call com_err_ (code, me, "Creating temporary segments."); goto clean; end; work_file.ptr = tsegs (1); bead_ptr = tsegs (2); sorted_file.ptr = tsegs (3); tran_ptr = tsegs (4); excl_ptr = tsegs (5); sortstr_ptr = tsegs (6); if control_file.dir = "" /* no control file given? */ then do; /* use raw data file for control */ control_file.dir = raw_file.dir; control_file.entryname = raw_file.entryname; control_file.name = rtrim (control_file.entryname) || ".cndxctl"; end; call hcs_$initiate_count (control_file.dir, (control_file.name), "", control_file.charct, 0, control_file.ptr, code); if control_file.ptr = null () /* no control file? */ then do; no_ctl_file: call write (output_file, "..init """""); call write (output_file, "..l0index"); goto GO; end; if control_file.charct = 0 /* empty control file? */ then do; control_file.ptr = null (); goto no_ctl_file; end; /* in case the user forgets them */ call write (output_file, ".srv MPM_SPACE"); call write (output_file, ".srv INDEXSPACE 1"); /* process control file */ control_file.charct = divide (control_file.charct, 9, 21, 0); tran.ct = 0; excl.ct = 0; do while (control_file.posn < control_file.charct); line = read (control_file); /**/ /* transformations */ if substr (line, 1, 6) = ".*tran" then do; tline = translate (after (line, ".*tran "), lower_case, upper_case); if substr (tline, 1, 1) ^= "," then tran_err: call ioa_ ("^a: Missing comma at line ^d.^/^-^a", me, raw_file.lineno, line); else do; tline = after (tline, ","); if index (tline, ",") = 0 then goto tran_err; else do; i = tran.ct + 1; tran.in (i) = rtrim (before (tline, ",")); tline = after (tline, ","); tran.out (i) = rtrim (before (tline, ",")); tran.ct = i; end; end; end; else if substr (line, 1, 8) = ".*phrase" then do; i = tran.ct + 1; tran.in (i) = tline; tran.out (i) = translate (tline, " ", " "); tran.ct = i; end; else if substr (line, 1, 6) = ".*excl" /* exclusions */ then do; tline = translate (after (line, ".*excl "), lower_case, upper_case); do excl.ct = excl.ct + 1 by 1 while (tline ^= ""); if tline ^= "," & substr (tline, 1, 2) ^= ",," then excl.key (excl.ct) = before (tline, ","); excl_loop: /* convert ~s to SEPs */ j = index (excl.key (excl.ct), "~"); if j > 0 then do; excl.key (excl.ct) = substr (excl.key (excl.ct), 1, j - 1) || SEP || substr (excl.key (excl.ct), j + 1); end; tline = after (tline, ","); end; excl.ct = excl.ct - 1; /* back out extra count */ end; else if substr (line, 1, 8) = ".*ignore" | substr (line, 1, 7) = ".*blind" then ignore = after (line, " "); /* write it to output & let compose */ else call write (output_file, line); /* worry about it */ end; GO: work_file.name = "work_file"; last_hit.key (*), this_hit.key (*) = EMPTY; last_hit.pageref, this_hit.pageref = ""; raw_file.charct = divide (raw_file.charct, 9, 21, 0); linect, bead.ct = 0; /**/ /* run thru raw data file */ do while (raw_file.posn < raw_file.charct); delim = dflt_delim; /* reinitialize delimiters */ line = read (raw_file); /* read a line */ linect = linect + 1; /* and count it */ /* process only those lines having*/ if index (line, ".~ HIT ") ^= 0 /* a hit flag string */ then do; if debug then call ioa_ ("HIT line: ""^a""", line); tline = after (line, ".~ HIT "); /* strip off hit flag string */ if substr (tline, 1, 1) = "=" /* delimiter change for this line? */ then do; delim.key = substr (tline, 2, 1); delim.sep = substr (tline, 3, 1); delim.end = substr (tline, 4, 1); tline = substr (tline, 5); end; /* skip null key strings */ if substr (tline, 1, 1) = delim.end then goto skip_hit; /* copy the hit type char */ hit_type = substr (tline, 1, 1); tline = after (tline, hit_type); /* and strip it off */ if index (tline, delim.key) = 0 /* check for required key delim */ then do; call ioa_ ("No key delimiter for line ^d, one will be provided." || "^/^-^a", raw_file.lineno, line); tline = delim.key || tline; end; i = 0; /* convert given delimiters */ do while (i <= length (tline)); j, k = 0; j = index (tline, delim.sep); if j > 0 then tline = before (tline, delim.sep) || SEP || after (tline, delim.sep); k = index (tline, delim.end); if k > 0 then tline = before (tline, delim.end) || END || after (tline, delim.end); if j > 0 | k > 0 then i = i + min (j, k); else i = length (tline) + 1; end; if substr (tline, 1, 1) ^= delim.key /* is there a lastkey? */ then do; lastkey = before (tline, delim.key); tline = after (tline, lastkey); end; else lastkey = ""; tline = after (tline, delim.key); /* strip key delim */ pageref = /* copy pageref string */ before (ltrim (after (tline, END)), " "); tline = substr (tline, 1, length (tline) - length (pageref)); /* trim pageref string */ if tline = "" /* skip empty key strings */ then goto skip_hit; /* K type - specifed key */ /* S type - "see" reference */ if hit_type = "K" | hit_type = "S" then do while (tline ^= ""); key_string = before (tline, delim.key) || lastkey; if hit_type = "K" then key_string = key_string || pageref; /* make a new bead */ call make_bead (key_string); tline = after (tline, delim.key); end; /* U type - permuted upper case */ /* The key string may be ONLY a level 1 key. Each "word" of the key is translated to uppercase and emitted as a level 1 key and followed by the given key string at level 2. */ if hit_type = "U" then do; /* {trans:="1,$U/^.*%%%/"} " set special translation >(permute) \B(exec) " call permuter 1,$U/^.*~/ 1,$M(rf) " translate all to uppercase and copy to b(rf) :(no_U) */ call permute (tline); end; skip_hit: end; end; /* sort the hits */ if bead.ct > 0 then do; pct = 0; d = bead.ct; sort: d = divide (d + 1, 2, 17, 0); pass: pct = pct + 1; swp = "0"b; do i = 1 to bead.ct - d; j = i + d; if bead.sortptr (i) -> sortstr > bead.sortptr (j) -> sortstr then do; tbead = bead.e (j); bead.e (j) = bead.e (i); bead.e (i) = tbead; swp = "1"b; end; end; if swp then goto pass; if d > 1 then goto sort; end; sorted_file.name = "sorted_file"; do i = 1 to bead.ct; call write (sorted_file, substr (bead.linptr (i) -> linstr, 1, bead.len (i))); end; pageref = ""; /* erase leftovers */ sorted_file.posn = 1; /* "rewind" sorted file */ linect = 0; do while (sorted_file.posn <= sorted_file.charct); /* get key strings from */ call get_keys; /* next sorted file line */ linect = linect + 1; do i = 1 to 5 while (this_hit.key (i) ^= EMPTY); /* break at this level? */ if translate (this_hit.key (i), lower_case, upper_case) ^= translate (last_hit.key (i), lower_case, upper_case) then do; if pageref ^= "" then do; call write (output_file, pageref); pageref = ""; end; if i = 1 /* first level break? */ then do; if ahdr_sw /* alpha headers wanted? */ then do; /* does first char change? */ if translate (substr (this_hit.key (1), 1, 1), lower_case, upper_case) ^= translate (substr (last_hit.key (1), 1, 1), lower_case, upper_case) then do; call write (output_file, ".ur .ur .spt %%{%INDEXSPACE% + %MPM_SPACE%}%%"); call write (output_file, ".tlh 1 0 ||%.fnt HBR%" || translate (substr (this_hit.key (1), 1, 1), upper_case, lower_case) || "%.fnt%||"); end; end; call write (output_file, ".ur .spt %INDEXSPACE%"); /* set split title */ call write (output_file, ".dfu block_split .stl |" || this_hit.key (1) || " (cont.) |"); end; call write (output_file, ".unl " || ltrim (char (2 * (5 - i)))); call write (output_file, this_hit.key (i)); do j = i + 1 to 4; /* clear subordinate keys */ last_hit.key (j) = EMPTY; end; end; end; if pageref = "" then pageref = this_hit.pageref; else if this_hit.pageref ^= last_hit.pageref then pageref = pageref || ", " || this_hit.pageref; last_hit = this_hit; end; /* and finally, the pageref */ if pageref ^= "" then call write (output_file, pageref); clean: call term_$seg_ptr (raw_file.ptr, code); if code ^= 0 then call com_err_ (code, me, "Terminating ^a>^a.", rtrim (raw_file.dir), raw_file.name); code = 0; if control_file.ptr ^= null () then call term_$seg_ptr (control_file.ptr, code); if code ^= 0 then call com_err_ (code, me, "Terminating ^a>^a.", rtrim (control_file.dir), control_file.name); code = 0; if output_file.ptr ^= null () then do; call hcs_$set_bc_seg (output_file.ptr, 9 * output_file.charct, code); if code ^= 0 then call com_err_ (code, me, "Setting bitcount for ^a>^a", rtrim (output_file.dir), rtrim (output_file.entryname)); code = 0; call term_$seg_ptr (output_file.ptr, code); if code ^= 0 then call com_err_ (code, me, "Terminating ^a>^a.", rtrim (output_file.dir), output_file.name); end; code = 0; call release_temp_segments_ (me, tsegs, code); if code ^= 0 then call com_err_ (code, me, "Releasing temporary segments."); %page; /* convert digit strings to pictures for proper sorting */ conv_nbrs: proc (str); /* PARAMETERS */ dcl str char (1024) var; /* LOCAL STORAGE */ dcl (i, j, k) fixed bin; /* working index */ dcl pic pic "(9)9"; /* output pciture */ i = 1; /* scan the string */ do while (i <= length (str)); j = search (substr (str, i), "0123456789"); /* look for numbers */ if j > 0 /* found one */ then do; i = i + j - 1; /* skip to first digit */ k = verify (substr (str, i), "0123456789"); /* how many? */ if k = 0 /* all the rest of str */ then k = length (str) - i + 1; else k = k - 1; pic = convert (pic, substr (str, i, k)); /* convert to picture */ str = substr (str, 1, i - 1) || pic || substr (str, i + k); i = i + 9; end; else i = length (str) + 1; /* for loop control */ end; end conv_nbrs; %page; /* read a line from the sorted data file and break it into keys */ get_keys: proc; dcl i fixed bin; /* working index */ this_hit.key (*) = EMPTY; /* preset to empty */ this_hit.pageref = ""; line = read (sorted_file); /* read a line from the sorted file */ do i = 1 to 5 while (line ^= ""); /* break it into key fields */ j, k = 0; j = index (line, SEP); /* look for a key separator */ if j > 0 /* found a separator? */ then do; this_hit.key (i) = before (line, SEP); line = after (line, SEP); end; else k = index (line, END); /* look a key terminator */ if k > 0 /* found a terminator? */ then do; this_hit.key (i) = before (line, END); line = after (line, END); end; if i = 1 then do; if hit_type = "U" then this_hit.key (1) = translate (this_hit.key (1), upper_case, lower_case); end; else if j = 0 /* found neither, rest is pageno */ then do; this_hit.pageref = ltrim (line); line = ""; end; end; end get_keys; %page; /* cleans up a key string and add it to the list of sortable beads */ make_bead: proc (str); /* PARAMETERS */ dcl str char (1024) var; /* key string (INPUT) */ /* LOCAL STORAGE */ dcl end fixed bin; /* position of END */ dcl (k, l) fixed bin; /* working index */ dcl bdstr char (1024) var; /* working string */ dcl blind_char char (1); /* blind sort character */ bdstr = str; /* copy given string */ k = 1; /* discard pad characters */ do while (k > 0); k = search (bdstr, "ÿ"); /* <177><777> */ if k > 0 then bdstr = substr (bdstr, 1, k - 1) || substr (bdstr, k + 1); end; k = index (bdstr, SEP || END); /* trim trailing SEPs */ if k > 0 then bdstr = substr (bdstr, 1, k - 1) || substr (bdstr, k + 3); bead.ct = bead.ct + 1; /* make a new bead */ bead.linptr (bead.ct) = /* point to given line */ addr (substr (work_file.ptr -> linstr, work_file.posn)); bead.len (bead.ct) = length (bdstr);/* len of cleaned up key string */ bead.type = hit_type; /* record hit type */ call write (work_file, bdstr); /* save given line */ /* force lower case */ bdstr = translate (bdstr, lower_case, upper_case); k = 1; /* discard blind pad char for sort */ do while (k > 0); k = search (bdstr, "¿"); /* <277> */ if k > 0 then bdstr = substr (bdstr, 1, k - 1) || substr (bdstr, k + 1); end; call conv_nbrs (bdstr); /* convert numbers to pictures */ /* process ignore chars */ if hit_type = "S" /* S type? */ then do; /* position of "see" */ end = index (bdstr, "see") - 1; if end > 1 /* parens on it? */ then if substr (bdstr, end, 1) = "(" then end = end - 1; end; else end = index (bdstr, END); l = end - 1; /* length of string to scan */ k = 1; /* massage ignore chars */ if ignore ^= "" then do while (k > 0); k = search (bdstr, ignore); if k > 0 then do; blind_char = substr (bdstr, k, 1); /* copy blind char */ blind_char = byte (rank (blind_char) + 128); /* kick it upstairs */ bdstr = substr (bdstr, 1, k - 1) || substr (bdstr, k + 1, 1) || blind_char || substr (bdstr, k + 2); end; end; sortstr = bdstr; /* string to be sorted */ bead.sortptr (bead.ct) = sortstr_ptr; sortstr_ptr = addrel (sortstr_ptr, bin ((length (bdstr) + 7) / 4, 35, 0)); end make_bead; %page; /* Permutes "words" in given key string and creates beads from them */ permute: proc (str); /* PARAMETERS */ dcl str char (1024) var; /* key string to be permuted */ /* LOCAL STORAGE */ dcl (i, j, k) fixed bin; /* working index */ dcl lstr char (1024) var; /* local string for exclusions */ dcl pkey char (128) var; /* permutation word */ dcl pstr char (1024) var; /* local string for permuting */ dcl tran_sw bit (1); /* control transformation loop */ /* copy key string, translating HTs */ /* to SPs, ltrimming, and */ /* forcing lower case */ pstr = ltrim (translate (before (str, END), " ", " ")); pstr = translate (pstr, lower_case, upper_case); i = 1; /* cast out multiple blanks */ do while (i <= length (pstr)); j = index (substr (pstr, i), " ") - 1; if j > 0 then do; i = i + j; j = verify (substr (pstr, i), " "); /* how many? */ if j > 0 then pstr = substr (pstr, 1, i) || substr (pstr, i + j - 1); i = i + 1; end; else i = length (pstr) + 1; /* loop control */ end; j, k = 1; /* remove underscores */ do while (j + k > 0); j, k = 0; j = index (pstr, "_"); /* <BS>_ */ if j > 0 then pstr = substr (pstr, 1, j - 1) || substr (pstr, j + 2); k = index (pstr, "_"); /* _<BS> */ if k > 0 then pstr = substr (pstr, 1, k - 1) || substr (pstr, k + 2); if j + k > 0 then i = i + min (j, k); else i = length (pstr) + 1; end; pstr = translate (pstr, " ", "_"); /* convert _'s to SPs */ if tran.ct > 0 /* apply tran's to pstr */ then do i = 1 to tran.ct by 2; tran_sw = "1"b; /* condition loop control switch */ k = 1; /* string scan index */ do while (tran_sw); tran_sw = "0"b; j = index (substr (pstr, k), tran.in (i)); if j > 0 then do; pstr = substr (pstr, k, j - 1) || tran.out (i) || substr (pstr, k + j + length (tran.in (i)) - 1, length (pstr) - k - j - length (tran.in (i)) + 2); k = k + j; tran_sw = "1"b; end; end; end; lstr = pstr; /* save final result for exclusions */ /* finally, we get to permute! */ if pstr ^= "" & index (pstr, " ") = 0 /* phsaw! nothing to permute */ then call make_bead (pstr || END || pageref); else do while (pstr ^= ""); /* copy permute word */ pkey = ltrim (rtrim (before (pstr, " "), ")"), "("); if excl.ct > 0 /* apply exclusions */ then do i = 1 to excl.ct; if pkey = excl.key (i) then goto skip_pkey; if substr (pkey || SEP || lstr, 1, length (excl.key (i))) = excl.key (i) then goto skip_pkey; end; call make_bead (pkey || SEP || str || pageref); /* :(permute) " prepend every line with its own 1st string 1,$S/^.*;/&%;&/ " followed by a % 1,$S/;%;/ %%%/ " replace any null prepends with SP%%% 1,$S/|/ / " make |'s SPs " CREATE key,phrase LINES b(hits) l 1,$S/)/ ) / " move parens out of the way {level:=0} :(create) " generate a level of key 1,$S/^(// " remove initial ( 1,$S/^) <<*>>// 1,$S/^ *%%%/~~ %%%/ " remove initial ), drop empty keys created \v{trans} " apply translation for current type \B(tran) " DO SPECIFIED TRANSFORMATIONS 1,$K(index) " copy all lines onto index 1,$S/^.* // " strip off first word of key gd/^ *%%%/ " delete any lines with empty keys ?1,1,$v<<*>>/%%%/ m(excl) b(excl) ?1 t!Improper .*tran causes these lines to appear during permutation; they were deleted.! l 1,$p l 1,$d b(hits) ?1 >(create) " if any lines left, try again b(index) gd/^~~ / " remove an excluded lines 1,$S/ .*%%%/~/ " replace "surplus" key plus separator with tilde 1,$S/ ) /)/ " put paren back together 1,$S/// " remove the padding character \000 1,$S/^~// " remove null keys which may have cropped up. \B(let) " do final changes "1,$S/&/ / " remove linking character 1zif {debug} t|After:| l 1,$P l " return from permute > */ skip_pkey: pstr = after (pstr, " "); end; end permute; %page; /* Reads one line from the given file and puts it in the char (1024) var string 'line' */ read: proc (file) returns (char (*) var); /* PARAMETERS */ dcl 1 file aligned like null_file; /* file being read (INPUT) */ /* LOCAL STORAGE */ dcl input char (max_chars) based (file.ptr); /* input string */ dcl llen fixed bin (24); /* length of line */ dcl lptr ptr; /* -> line */ /* point to line */ lptr = addr (substr (input, file.posn)); /* set input line length */ if file.posn <= file.charct /* if not at EOF, take up to NL */ then llen = index (substr (input, file.posn, file.charct - file.posn + 1), NL) - 1; /* take all the rest */ else llen = file.charct - file.posn + 1; if debug then call ioa_ ("read: (^a,^d) ""^a""", file.name, linect + 1, substr (input, file.posn, llen)); file.posn = file.posn + llen + 1; /* advance file position */ file.lineno = file.lineno + 1; /* count input lines */ return (substr (lptr -> input, 1, llen)); end read; %page; /* Writes the line to the given file */ write: proc (file, line); /* PARAMETERS */ dcl 1 file aligned like null_file; /* file being written */ dcl line char (1024) var; /* line to write */ /* LOCAL STORAGE */ dcl output char (max_chars) based (file.ptr); /* output string */ dcl linlen fixed bin; /* length of written */ /* set output line length */ linlen = length (line) + 1; /* 1 for NL */ substr (output, file.posn, linlen) = line || NL; file.posn = file.posn + linlen; /* advance file position */ file.charct = file.charct + linlen; /* count output chars */ file.lineno = file.lineno + 1; /* and lines */ if debug then call ioa_ ("write: (^a) ""^a""", file.name, line); end write; end compose_index;  convert_runoff.pl1 04/23/85 1100.9rew 04/23/85 0911.3 207378 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * Copyright, (C) Honeywell Information Systems Inc., 1980 * * * * * *********************************************************** */ /* Program to convert runoff source files to compose source files. */ /* format: style2,ind3,ll80,dclind4,idind16,comcol41,linecom */ convert_runoff: cv_rf: proc; /* SYNTAX: convert_runoff X no * convention */ /* Written: JAF ?????? */ /* Modified: 01/??/82 - EJW - Rewritten because of various problems. 10/07/82 - EJW - Fixed bug that truncated input pathname. */ /* LOCAL STORAGE */ dcl arg char (argl) based (argp); /* command line argument */ dcl argl fixed bin; dcl argp ptr; dcl bitct fixed bin (24); /* segment bitcount */ dcl cect fixed bin; /* .ce line count */ dcl code fixed bin (35); /* system error code */ dcl CREATE bit (1) static options (constant) init ("1"b); dcl csd char (1) init ("%"); /* current symbol delimiter */ dcl ctd char (1); /* local title delimiter */ dcl db_line fixed bin init (-1); /* debug ilino */ dcl eqct fixed bin; /* .eq line count */ dcl eqsw bit (1) init ("1"b); /* first .eq switch */ dcl error_table_$badopt fixed bin (35) ext static; dcl error_table_$empty_file fixed bin (35) ext static; dcl ftntglsw bit (1); /* footnote toggle switch */ dcl i fixed bin; /* working index */ dcl ilin char (ilinl) based (ilinp); /* current input line */ dcl ilinl fixed bin (24); /* length of input line */ dcl ilino fixed bin; /* input line counter */ dcl ilinp ptr; /* -> input line */ dcl in_chars fixed bin (24); /* input segment char count */ dcl in_file char (200) var; /* input file entryname */ dcl indx fixed bin (24); /* input file position index */ dcl input_ptr ptr init (null ()); /* pointer to input file */ dcl iseg char (in_chars) based (input_ptr); /* input chars */ dcl lict fixed bin; /* literal count */ dcl ME char (14) static options (constant) init ("convert_runoff"); dcl nargs fixed bin; /* number of command line args */ dcl NL char (1) static options (constant) init (" "); dcl olin char (1024) var; /* output line */ dcl olino fixed bin; /* output line counter */ dcl olinox fixed bin; /* extra olines used */ dcl ondx fixed bin (24); /* output file position index */ dcl oseg char (out_chars) based (output_ptr); /* output chars */ dcl out_chars fixed bin (24); /* output segment char count */ dcl out_file char (200) var; /* output file entryname */ dcl output_ptr ptr init (null ()); /* pointer to output file */ dcl (before, convert, divide, hbound, index, reverse, rtrim, search, substr) builtin; dcl (cleanup, conversion) condition; dcl com_err_ entry options (variable); dcl cu_$arg_count entry (fixed bin); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl ioa_ entry options (variable); /* PROCESS COMMAND LINE */ call ioa_ ("convert_runoff 1.6"); call cu_$arg_count (nargs); if nargs < 1 then do; call com_err_ (0, ME, "Usage: convert_runoff <runoff-file-pathname>"); return; end; call cu_$arg_ptr (1, argp, argl, code); if code ^= 0 then do; call com_err_ (code, ME, "Reading pathname of input segment."); return; end; in_file = before (arg, ".runoff") || ".runoff"; call get_seg_ptr ((in_file), ^CREATE, bitct, input_ptr, code); if code ^= 0 then do; in_file_err: call com_err_ (code, ME, "^a", in_file); return; end; on condition (cleanup) begin; /* we now have something to clean up */ out_chars = 0; call clean; end; if bitct = 0 then do; call clean; code = error_table_$empty_file; goto in_file_err; end; in_chars = divide (bitct, 9, 24, 0); /* if arg is a path, */ i = search (reverse (arg), "<>"); /* take only entryname */ if i = 0 then i = argl + 1; out_file = before (substr (arg, argl + 2 - i), ".runoff") || ".compin"; call get_seg_ptr (out_file, CREATE, 0, output_ptr, code); if code ^= 0 then do; call com_err_ (code, ME, "^a", out_file); goto finish; end; if input_ptr = output_ptr then do; call com_err_ (0, ME, "Attempt to specify same segment as input and output."); goto finish; end; /* any more args? */ call cu_$arg_ptr (2, argp, argl, code); if code = 0 then do; if arg = "-db" then do; call cu_$arg_ptr (3, argp, argl, code); on condition (conversion) begin; call com_err_ (0, ME, "Numeric value expected."); db_line = -1; goto revert; end; if code = 0 then db_line = convert (db_line, arg); else db_line = 1; revert: revert conversion; end; else do; call com_err_ (error_table_$badopt, ME, "^a", arg); return; end; end; indx, ondx = 1; /* initialize */ ilino, olino, olinox, lict, cect, eqct, out_chars = 0; ftntglsw = "0"b; %page; /* SCAN INPUT FILE */ scan_loop: do while (indx <= in_chars); ilinl = index (substr (iseg, indx, in_chars - indx + 1), NL) - 1; if ilinl < 0 /* if no NL, take rest of seg */ /* MSFs SHOULD BE HANDLED HERE */ then ilinl = in_chars - indx + 1; ilinp = addr (substr (iseg, indx)); /* point to input line */ ilino = ilino + 1; /* count input lines */ olino = olino + olinox + 1; /* and output lines */ olinox = 0; /* reset extra line count */ if ilino >= db_line & db_line > 0 then call ioa_ ("^6d^-in = ^a", ilino, ilin); if lict > 0 /* if a literal */ then do; olin = ilin; /* move line to output */ lict = lict - 1; /* count literals */ end; else do; if substr (ilin, 1, 1) ^= "." /* or not a control */ /* or either comment */ | substr (ilin, 1, 2) = ".*" | substr (ilin, 1, 2) = ".~" then olin = ilin; /* move line to output */ else do; olin = ""; /* clear output line */ call lookup; /* check for a runoff control */ if (index (olin, csd) ^= 0) then call builtin; if (index (olin, BSP) ^= 0) then call relational; end; cect = cect - 1; /* count .ce lines */ if cect = 0 then do; olin = olin || NL || ".tbe"; /* end title block */ olin = olin || NL || ".brb"; /* make it an orphan */ olinox = olinox + 2; end; eqct = eqct - 1; /* count .eq lines */ if eqct = 0 then do; olin = olin || NL || ".bet"; /* end title block */ olinox = olinox + 1; if ctd ^= "|" then do; olin = olin || NL || ".ctd"; olinox = olinox + 1; end; end; end; out_chars = out_chars + length (olin) + 1; /* grow the output */ /* MSFs HERE? */ substr (oseg, ondx) = olin || NL; /* append line to output */ ondx = out_chars + 1; /* next output position */ indx = indx + ilinl + 1; /* advance to next input line */ if ilino >= db_line & db_line > 0 then call ioa_ ("^8d^-out = ^a", olino, olin); end scan_loop; finish: call clean; exit: return; %page; /* CONVERT RUNOFF CONTROLS */ lookup: proc; dcl ctl_token char (4); /* the runoff control */ dcl varfld char (512) var; /* variable field for control */ /* 'tokens' declared at the end of the segment */ relook: ctl_token = substr (ilin, 1, min (length (ilin), 4)); if length (ilin) > 4 then varfld = rtrim (substr (ilin, 4)); /* take SP, too */ else varfld = ""; do i = 1 to hbound (tokens, 1); /* go thru token list */ if substr (tokens (i), 1, 4) = ctl_token /* is this the one? */ then do; /* if a 1-to-1 token replacement */ if substr (tokens (i), 5, 1) = " " | substr (tokens (i), 5, 1) = "*" then do; olin = olin || substr (tokens (i), 6); olin = olin || varfld; /* varfld starts with SP */ return; end; else do; goto rtn (index ("123456789.", substr (tokens (i), 6, 1))); rtn (0): call ioa_ ("Line ^i: ^a not handled.", ilino, ctl_token); return; rtn (1): /* .ar */ olin = olin || ".ur .brp " || csd || "PageNo" || csd || " ar"; return; rtn (2): /* .ro */ olin = olin || ".ur .brp " || csd || "PageNo" || csd || " rl"; return; rtn (3): /* .ce */ olin = olin || ".tbb"; /* start a title block */ olin = olin || NL || ".alc"; /* centered */ olin = olin || NL || ".fif"; /* and unfilled */ olinox = olinox + 2; if varfld = "" /* default count is 1 */ then cect = 2; /* must be set one too high because */ /* of the way counting is done in the */ /* main loop */ else do; /* use given count */ on conversion begin; call ioa_ ("^a: Numeric value expected in ^a", ME, ilin); cect = 2; /* again, 1 too high */ goto revert3; end; cect = convert (cect, varfld) + 1; /* 1 too high */ revert3: revert conversion; end; return; rtn (4): /* .eq */ olin = ".bbt"; if varfld = "" /* default count is 1 */ then eqct = 2; /* must be set one too high because */ /* of the way counting is done in the */ /* main loop */ else do; /* use given count */ on conversion begin; call ioa_ ("^a: Numeric value expected in ^a", ME, ilin); eqct = 2; /* again, 1 too high */ goto revert4; end; eqct = convert (eqct, varfld) + 1; /* 1 too high */ revert4: revert conversion; end; /* need a delimiter change? */ ctd = /* get first char of next line */ substr (iseg, indx + ilinl + 1, 1); if ctd ^= "|" then do; olin = olin || NL || ".ctd " || ctd; olinox = olinox + 1; end; return; rtn (5): /* .fr */ varfld = ltrim (varfld); if varfld = "t" then olin = ".ftp"; else if varfld = "f" then olin = ".ftr"; else if varfld = "u" then olin = ".ftu"; else olin = ".ftp"; return; rtn (6): /* .ft */ if ftntglsw then olin = ".bef"; else olin = ".bbf"; ftntglsw = ^ftntglsw; return; rtn (7): /* .li */ if varfld = "" /* default count is 1 */ then varfld = " 1"; on conversion begin; call ioa_ ("^a: Numeric value expected in ^a", ME, ilin); varfld = " 1"; goto revert7; end; lict = convert (lict, varfld); revert7: revert conversion; olin = ".bbl" || varfld; return; rtn (8): /* .ma */ if varfld = "" /* default is 1 */ then varfld = " 1"; olin = ".vmt" || varfld || NL; olinox = olinox + 1; olin = olin || ".vmb" || varfld; return; rtn (9): /* .ur */ do while (substr (ilin, 1, 3) = ".ur"); /* do all .ur's */ olin = olin || ".ur "; /* place a .ur */ j = 2 + /* step over .ur */ verify (substr (ilin, min (ilinl, 4)), " "); indx = indx + j; ilinp = addr (substr (iseg, indx)); /* move input pointer */ ilinl = ilinl - j; end; if length (olin) > 4 then call ioa_ ( "Output line ^i: Multiple .ur's. Check for " || "correct symbol delimiter nesting.", olino); if index (ilin, ".") = 1 /* is it a control? */ then goto relook; else do; olin = olin || ilin; return; end; rtn (10): /* headers/footers */ /* need a delimiter change? */ j = verify (varfld, " 0123456789"); ctd = substr (varfld, j, 1); if ctd ^= "|" then do; olin = olin || ".ctd " || ctd || NL; olinox = olinox + 1; end; olin = olin || substr (tokens (i), 6); olin = olin || varfld; if ctd = "|" then return; olin = olin || NL || ".ctd"; olinox = olinox + 1; return; end; end; end; /* table search failed. line isnt a control */ olin = ilin; end lookup; /* CONVERT RUNOFF BUILTINS */ builtin: proc; /* Scan the line for cds, extracting the contained variable names. If there is no valid variable name, output a csd||PageNo||csd. If there is a valid variable name, then search the builtin list; if found, then process according to the list. if not, then output it, as-is. */ dcl bname char (32) var;/* extracted variable name */ dcl csdct fixed bin; /* count of opening csd's */ dcl (i, j, k) fixed bin; /* working index */ i = 1; /* init line scan index */ do while (i <= length (olin)); j = index (substr (olin, i), csd); /* look for a csd */ if j = 0 /* if none, */ then return; /* we're done */ else i = i + j - 1; /* move to csd */ csdct = verify (substr (olin, i), csd) - 1; /* step over csd's */ if csdct < 0 /* a trailing csd? */ then do; olin = olin || "PageNo" || csd; return; end; i = i + csdct; /* move to first name char */ j = index (substr (olin, i), csd); /* look for next csd */ if j = 0 /* no more in olin? */ then goto Np_ref; else j = j - 1; bname = substr (olin, i, j); /* extract old name, j holds length */ k = verify (bname, /* and validate it */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789") ; if k ^= 0 /* use %PageNo% for invalid names */ then do; Np_ref: olin = substr (olin, 1, i - 1) || "PageNo" || csd || substr (olin, i); i = i + 7; end; else do; do k = 1 to hbound (builtin_name, 1); if (bname = substr (builtin_name (k), 1, 20)) then do; if length (builtin_name (k)) < 21 then do; /* not supported? */ call ioa_ ( "Line ^i: Builtin %^a% is not supported.", ilino, bname); goto found; end; else if substr (builtin_name (k), 21, 1) = "." then do; olin = ".ur " || olin; /* prepend another .ur */ i = i + 4;/* bif ref has moved */ call ioa_ ( "Output line ^i: Multiple .ur's. Check for " || "correct symbol delimiter nesting.", olino); goto bif ( index ("1234", substr (builtin_name (k), 22, 1))); bif (0): /* error */ call ioa_ ("Line ^d: Program error processing " || "builtin ^a", ilino, bname); goto found; bif (1): /* %(%AlignMode% = ""both"")% */ bname = csd || "(" || csd || "AlignMode" || csd || "= ""both"")" || csd; goto found; bif (2): /* %(%FootReset% = ""paged"")% */ bname = csd || "(" || csd || "FootReset" || csd || "= ""paged"")" || csd; goto found; bif (3): /* %(%FootReset% = ""u"")% */ bname = csd || "(" || csd || "FootReset" || csd || "= ""u"")" || csd; goto found; bif (4): /* %(%Device% = ""printer"")% */ bname = csd || "(" || csd || "Device" || csd || "= ""Printer"")" || csd; goto found; end; else do; bname = substr (builtin_name (k), 21); /* get new name */ goto found; end; end; end; found: olin = substr (olin, 1, i - 1) || bname || substr (olin, i + j); i = i + length (bname); /* move to csd */ i = i + csdct; /* step over closing csd's */ end; end; end builtin; relational: proc; dcl (i, k) fixed bin; /* working index */ dcl relop char (3); /* local copy of rel operator */ dcl rels (8) char (6) static options (constant) init ("/= ^=", "=/ ^=", /* these all doubled so */ "<_ <=", "_< <=", /* canonical form isnt needed */ "=_ ==", "_= ==", ">_ >=", "_> >="); i = 1; do while (i <= length (olin)); k = index (substr (olin, i), BSP); /* look for a BSP */ if k = 0 | k = length (olin) /* if none or trailing BSP, */ then return; /* we're done */ else i = i + k - 2; /* move to preceding char */ relop = substr (olin, i, 3); /* extract the rel operator */ do k = 1 to 8; if (relop = substr (rels (k), 1, 3)) then do; olin = substr (olin, 1, i - 1) || substr (rels (k), 5) || substr (olin, i + 3); end; end; i = i + 3; /* step over relop */ end; end relational; %page; get_seg_ptr: proc (pname, create, bitct, ptr, code); dcl pname char (200) var; /* given pathname */ dcl create bit (1); /* create switch */ dcl bitct fixed bin (24); /* bitcount */ dcl ptr ptr; /* seg pointer */ dcl code fixed bin (35); /* error code */ dcl dname char (168); /* file dirname */ dcl ename char (32); /* file entryname */ dcl expand_pathname_ entry (char (*), char (*), char (*), 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)); call expand_pathname_ ((pname), dname, ename, code); if code ^= 0 then return; call hcs_$initiate_count (dname, ename, "", bitct, 0, ptr, code); if ptr ^= null () then do; code = 0; return; end; if create then call hcs_$make_seg (dname, ename, "", 01010b, ptr, code); end get_seg_ptr; %page; release_seg_ptr_: proc (pt, bitct, code); dcl pt ptr, bitct fixed bin (24), code fixed bin (35); dcl hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); code = 0; if (pt = null ()) then return; if (bitct > -1) then call hcs_$set_bc_seg (pt, bitct, code); if (code = 0) then call hcs_$terminate_noname (pt, code); end; clean: proc; if (output_ptr ^= null ()) then call release_seg_ptr_ (output_ptr, out_chars * 9, code); if (input_ptr ^= null ()) then call release_seg_ptr_ (input_ptr, -1, code); end; %page; dcl BSP char (1) int static init (""); dcl iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35)); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); dcl iox_$get_line entry (ptr, ptr, fixed bin, fixed bin, fixed bin (35)) ; dcl iox_$open entry (ptr, fixed bin, bit (1), fixed bin (35)); dcl j fixed bin; dcl recl fixed bin; dcl (addr, length, mod) builtin; %page; /***** CONSTANT ARRAYS */ dcl builtin_name (58) char (50) var static options (constant) init ("Ad .1", "Ce", "CharsTable", "Charsw", "Console UserInput", "ConvTable", "Date Date", "Device Device", "DeviceTable", "Eq", "Eqcnt Eqcnt", "ExtraMargin ExtraMargin", "Fi FillMode", "Filesw OutputFileOpt", "Foot Footcnt", "FootRef", "Fp", "Fr .2", "From", "Ft FootnoteMode", "Hyphenating Hyphenating", "In Indent", "InputFileName InputFileName", "InputLines InputLineno", "LinesLeft LinesLeft", "Ll PageWidth", "Lp", "Ma1 VMargTop", "Ma2 VMargHeader", "Ma3 VMargFooter", "Ma4 VMargBottom", "Ms LineSpace", "MultiplePagecount PageSpace", "NestingDepth InsertIndex", "Nl PageLine", "NNp NextPageNo", "NoFtNo .3", "NoPaging Galley", "Np PageNo", "PadLeft", "PageNo PageNo", /* compose bif needed for */ /* correct handling of .ar and .ro */ "Parameter Parameter", "Passes Pass", "Pi PictureCount", "Pl PageLength", "Printersw .4", "PrintLineNumbers LineNumberOpt", "Roman", "Selsw", "SpecCh SymbolDelimiter", "Start", "Stopsw StopOpt", "TextRef", "Time", "To", "TrTable TrTable", "Un Undent", "Waitsw WaitOpt"); /* entries in this array are coded */ /* chars 1,4 - runoff control */ /* char 5 - action flag */ /* chars 6,$ - replacement or */ /* function index */ /**** format: off */ dcl tokens (55) char (12) var static options (constant) init ( ".ad .alb", ".ar -1", ".bp .brp", ".br .brf", ".cc .csd", ".ce -3", ".ch .tre", ".ds .ls 2", ".ef -.fle", ".eh -.hle", ".eq -4", ".ep .brp e", ".ex .exc", ".fh -.hlf", ".fi .fin", ".fo -.fla", ".fr -5", ".ft -6", ".gb .go", ".gf .go", ".he -.hla", ".if .ifi", ".in .inl", ".la .la", ".li -7", ".ll .pdw", ".m1 .vmt", ".m2 .vmh", ".m3 .vmf", ".m4 .vmb", ".ma -8", ".mp .ps", ".ms .ls", ".na .all", ".ne .brn", ".nf .fif", ".of -.flo", ".oh -.hlo", ".op .brp o", ".pa .brp", ".pi .bbp", ".pl .pdl", ".rd .rd", ".ro -2", ".rt .rt", ".sk .brs", ".sp .spb", ".sr .srv", ".ss .ls 1", ".tr .trn", ".ts .ts", ".ty .ty", ".un .unl", ".ur -9", ".wt .wt"); /*** format: on */ end convert_runoff;  display_comp_dsm.pl1 02/16/88 1455.7r w 02/16/88 1411.9 284742 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* format: style2,ind2,ll79,dclind4,idind15,comcol41,linecom */ /* Written: ??/80 - Jim Falksen /* Modified: 6/83 - Ed Wallman - Added -all, cleaned up and modernized. /* Modified: 9/83 - Ed Wallman - Added lcdsm command entry. Changed /* display_comp_dsm short name to dcdsm. */ display_comp_dsm: dcdsm: proc; /* Usage: dcdsm dsm_path {-linelength N} */ /* This displays all the external DSM names in the specified segment. */ /* Usage: dcdsm dsm_path -device {-linelength N} */ /* This displays all the names and synonyms on the specified device, */ /* also lists all the family/member names and bachelors in the DSM. */ /* Usage: dcdsm dsm_path -long {-linelength N} */ /* This is like the previous one with the addition of a list of many */ /* parameters about the device, max pagelength, etc. */ /* Usage: dcdsm dsm_path family{/member} -{linelength N} */ /* This shows all the defined graphics in the specified family/member */ /* or bachelor with their widths. */ /* Usage: dcdsm dsm_path family{/member} -long {-linelength N} */ /* This shows all the defined graphics with their widths and output */ /* strings. */ /* Usage: lcdsm {starname} */ /* This displays all the matching DSM names found with compose search */ /* list. Default starname is **. */ /* Usage: lcdsm {starname} -pathname PATH */ /* This displays all the matching DSM names found in the directory */ /* PATH. Default starname is **. */ /* Usage: lcdsm {starname} -working_dir */ /* This displays all the matching DSM names found in the working */ /* directory. Default starname is **. */ %page; dcl code fixed bin (35); /* error code */ dcl colwidth fixed bin; dcl dname char (168); /* module dir name */ dcl dsmpath char (200); /* module path name */ dcl dsmptr ptr; /* module object pointer */ dcl DSNAME char (16) int static options (constant) init ("display_comp_dsm"); dcl ename char (32); /* module entry name */ dcl familyname char (32); /* font family name */ dcl i fixed bin; /* working index */ dcl indent fixed bin; /* display indentation */ dcl ipath fixed bin; /* search path coutner */ dcl istar fixed bin; /* star name counter */ dcl linea char (200) var; /* an output line */ dcl lineb char (200) var; /* another */ dcl linelength fixed bin; dcl LSNAME char (16) int static options (constant) init ("list_comp_dsm"); dcl me char (16) var; dcl membername char (32); dcl sl_info_area area (2048); dcl star_area area (2048); dcl star_code fixed bin (35); /* starname type code */ dcl starname char (200); dcl 1 sws, /* control switches */ 2 debug bit (1) unal, /* 1= -debug */ 2 device bit (1) unal, /* 1= -device */ 2 error bit (1) unal, /* 1= command line error */ 2 long bit (1) unal, /* 1= -long */ 2 path bit (1) unal, /* 1= -pathname */ 2 mbz bit (31) unal; dcl (addr, after, before, binary, length, null, ptr, rank, size, substr, sum, unspec) builtin; dcl cleanup condition; dcl error_table_$name_not_found fixed bin (35) ext static; dcl error_table_$no_dir fixed bin (35) ext static; dcl error_table_$no_ext_sym fixed bin (35) ext static; dcl error_table_$nomatch fixed bin (35) ext static; dcl error_table_$unimplemented_version fixed bin (35) ext static; dcl com_err_ entry options (variable); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl hcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35)); dcl ioa_$rsnnl entry options (variable); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl search_paths_$get entry (char (*), bit (36), char (*), ptr, ptr, fixed bin, ptr, fixed bin (35)); me = DSNAME; goto join; list_comp_dsm: lcdsm: entry; me = LSNAME; join: /* set constants structure pointer */ compstat$compconst.ptr = addr (compstat$compconst.ptr); call proc_args; /* process args */ if error /* cant continue */ then return; if (familyname ^= "") | long /* these options need the switch */ then device = "1"b; lineb = ""; on cleanup call clean; if me = LSNAME then do; if path /* was a pathname given? */ then do; /* expand possible relative name */ call expand_pathname_ (dsmpath, dname, ename, code); if (code ^= 0) then do; call com_err_ (code, me, "^/^5xExpanding given pathname, ^a", dsmpath); return; end; dname = pathname_ (dname, ename); call /* get list of dsm's in this dir */ hcs_$star_ (dname, starname, star_ALL_ENTRIES, addr (star_area), star_entry_count, star_entry_ptr, star_names_ptr, code); if (code ^= 0) then do; call com_err_ (code, me, "^/^5xGetting comp_dsm names in ^a", dname); return; end; if debug then call ioa_ ("star used = ^i", size (star_entries) + size (star_names)); do istar = 1 to star_entry_count; ename = star_names (star_entries (istar).nindex); call show_dsm; end; end; else /* user wants them all */ do; call search_paths_$get ("compose", sl_control_default, "", null, addr (sl_info_area), sl_info_version_1, sl_info_p, code); if (code ^= 0) then do; call com_err_ (code, me, "^/^Getting compose search list."); return; end; do ipath = 1 to sl_info.num_paths; dname = sl_info.paths (ipath).pathname; /* dont repeat any dirs */ do i = 1 to ipath while (dname ^= sl_info.paths (i).pathname); end; if i = ipath then do; call /* get list of dsm's in this dir */ hcs_$star_ (dname, starname, star_ALL_ENTRIES, addr (star_area), star_entry_count, star_entry_ptr, star_names_ptr, code); if code ^= 0 & code ^= error_table_$nomatch & code ^= error_table_$no_dir then call com_err_ (code, me, "^/^5xGetting comp_dsm names in ^a", dname); else if code ^= error_table_$nomatch then do; call ioa_ ("^/^-At ^a...", dname); if debug then call ioa_ ("star used = ^i", size (star_entries) + size (star_names)); do istar = 1 to star_entry_count; ename = star_names (star_entries (istar).nindex); call show_dsm; end; end; end; end; end; end; else /* only a module name */ do; call expand_pathname_$add_suffix (dsmpath, "comp_dsm", dname, ename, code); if (code ^= 0) then do; call com_err_ (code, me, "^/^5xExpanding given module name, ^a", dsmpath); return; end; call show_dsm; end; return; %page; show_dsm: proc; dcl ACCptr ptr; /* ACC strings */ dcl 1 ACC aligned based (ACCptr), 2 len fixed bin (8) unal, 2 string char (ACC.len) unal; dcl bitcount fixed bin (24); /* module object bit count */ dcl defptr ptr; /* dsminfo definition pointer */ dcl 1 dsminfo like object_info; dcl dvtcount fixed bin; /* number of device tables to do */ dcl dvtname char (32) var; /* device table name */ dcl 1 objseg (0:100), /* interesting object segment ptrs */ 2 symbolptr ptr, 2 name char (32), 2 dvidptr ptr, 2 dvtptr ptr; dcl addrel builtin; dcl error_table_$improper_data_format fixed bin (35) ext static; dcl initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35)); dcl ioa_$nnl entry options (variable); dcl object_info_$brief entry (ptr, fixed bin (24), ptr, fixed bin (35)); dsmptr = null (); /* intialize auto storage */ dsmpath = pathname_ (dname, ename); call initiate_file_ (dname, ename, R_ACCESS, dsmptr, bitcount, code); if (dsmptr = null ()) then do; call com_err_ (code, me, "^/^5xInitiating ^a", dsmpath); return; end; /* */ /* get object info for the module */ dsminfo.version_number = object_info_version_2; call object_info_$brief (dsmptr, bitcount, addr (dsminfo), code); if (code ^= 0) then do; call com_err_ (code, me, "^/^5xGetting object info for ^a", dsmpath); call clean; return; end; if ^dsminfo.format.standard /* must be a standard object segment */ then do; call com_err_ (error_table_$improper_data_format, me, "^/^5x^a is not a standard object segment.", dsmpath); call clean; return; end; dvtcount = 0; defptr = /* point to first def */ addrel (dsminfo.defp, dsminfo.defp -> definition_header.def_list_relp) ; if device /* is device switch on? */ then /* look for given device */ do; /* form device table name */ dvtname = before (ename, ".comp_dsm") || ".dvt"; do defptr = defptr /* walk the definition thread */ repeat addrel (dsminfo.defp, defptr -> definition.forward_relp) while (defptr -> definition.forward_relp ^= 0); /* point to symbol's ACC */ ACCptr = addrel (dsminfo.defp, defptr -> definition.name_relp); if (defptr -> definition.class = CLASS_TEXT) & (ACC.string = dvtname) then do; dvtcount = dvtcount + 1; /* record interesting stuff */ objseg.symbolptr (dvtcount) = ACCptr; objseg.dvidptr (dvtcount), const.dvidptr = addrel (dsminfo.textp, defptr -> definition.thing_relp); objseg.dvtptr (dvtcount) = ptr (dsminfo.textp, comp_dvid.dvt_r); objseg.name (dvtcount) = before (ACC.string, "."); goto found_device; end; end; call com_err_ (error_table_$no_ext_sym, me, "^/^5x^a symbol definition in ^a.", dvtname, dsmpath); call clean; return; end; else /* device switch is off */ do; /* record module's segname def ptr */ objseg.dvidptr (0) = ptr (dsminfo.defp, 0); do defptr = defptr /* walk definition thread */ repeat addrel (dsminfo.defp, defptr -> definition.forward_relp) while (defptr -> definition.forward_relp ^= 0); /* point to symbol's ACC */ ACCptr = addrel (dsminfo.defp, defptr -> definition.name_relp); /* take only device tables */ if (defptr -> definition.class = CLASS_TEXT) & (after (ACC.string, ".") = "dvt") then do; dvtcount = dvtcount + 1; /* record interesting stuff */ objseg.symbolptr (dvtcount) = ACCptr; objseg.dvidptr (dvtcount), const.dvidptr = addrel (dsminfo.textp, defptr -> definition.thing_relp); objseg.dvtptr (dvtcount) = ptr (dsminfo.textp, comp_dvid.dvt_r); objseg.name (dvtcount) = before (ACC.string, "."); end; end; end; found_device: objseg.dvidptr (dvtcount + 1) = null (); objseg.dvtptr (dvtcount + 1) = null (); /* display the requested info */ do i = dvtcount to 0 by -1; /* do it backwards because defs */ /* are reverse threaded */ if i > 0 then const.dvidptr = objseg.dvidptr (i); /* check structure version */ if comp_dvid.version < 0 | comp_dvid.version > comp_dvid_version then do; call com_err_ (error_table_$unimplemented_version, me, "^/^5x^a is not a valid device table.", dsmpath); call clean; return; end; else do; /* if this device is just an addname */ if objseg.dvidptr (i + 1) = objseg.dvidptr (i) then call ioa_$nnl (", ^a", objseg.name (i)); else /* this is a real device table */ do; /* is it "like" a previous device? */ do j = dvtcount to i + 2 by -1; if (objseg.dvtptr (i + 1) = objseg.dvtptr (j) & objseg.dvidptr (i + 1) ^= objseg.dvidptr (j)) then /* yes */ do; call ioa_ (" like ^a;", objseg.name (j)); goto found; end; end; if i < dvtcount /* don't do this for first device */ then call show_dvt; found: if i > 0 /* don't do this for last device */ then do; call ioa_$nnl ("Device:^-^a", objseg.name (i)); const.dvidptr = objseg.dvidptr (i); const.devptr = pointer (const.dvidptr, comp_dvid.dvt_r); end; end; end; end; call clean; return; %page; show_dvt: proc; dcl charvp ptr; dcl charv char (5000) var based (charvp); call ioa_ (";^/ devclass: ^a;", comp_dvt.devclass); if ^device /* thats all if device switch is off */ then return; call comp_dvt.outproc (1, code); if familyname ^= "" /* was a font given? */ then call show_a_font; else /* just show device info */ do; if long /* long form? */ then do; call /* version ids */ ioa_ ("/* version: ^i (^i) */", comp_dvid.version, comp_dvid_version); call ioa_ (" units: pt;"); /* canned til its implemented */ if comp_dvt.atd_r ^= "0"b /* attach description */ then do; call display_new_str ((comp_dvt.atd_r)); call ioa_ (" attach: ^a;", linea); end; /* */ /* comment */ if comp_dvt.comment_r ^= "0"b then do; charvp = pointer (const.dvidptr, comp_dvt.comment_r); call ioa_ (" comment: ""^a"";", charv); end; /**/ /* cleanup string */ if comp_dvt.cleanup_r ^= "0"b then do; call display_new_str ((comp_dvt.cleanup_r)); call ioa_ (" cleanup: ^a;", linea); end; /**/ /* default page margins */ call ioa_ (" defaultmargs: ^f, ^f, ^f, ^f;", dec (comp_dvt.def_vmt, 11, 3) / 1000, dec (comp_dvt.def_vmh, 11, 3) / 1000, dec (comp_dvt.def_vmf, 11, 3) / 1000, dec (comp_dvt.def_vmb, 11, 3) / 1000); /* minimum top margin */ call ioa_ (" mintopmarg: ^f;", dec (comp_dvt.vmt_min, 11, 3) / 1000); /* minimum bottom margin */ call ioa_ (" minbottommarg: ^f;", dec (comp_dvt.vmb_min, 11, 3) / 1000); /* minimum horizontal whitespace */ call ioa_ (" minspace: ^f;", dec (comp_dvt.min_WS, 11, 3) / 1000); /**/ /* minimum vertical resolution */ call ioa_ (" minlead: ^f;", dec (comp_dvt.min_lead, 11, 3) / 1000) ; call ioa_ (" init: ^a^a ^f;", comp_dvt.init_family, comp_dvt.init_member, dec (comp_dvt.init_ps, 11, 3) / 1000); call ioa_ (" interleave: ^[on^;off^];", comp_dvt.interleave); call ioa_ (" letterspace: ^i;", comp_dvt.lettersp); call ioa_ (" maxpages: ^[unlimited^;^i^];", (comp_dvt.max_pages = -1), comp_dvt.max_pages); call ioa_ (" maxfiles: ^[unlimited^;^i^];", (comp_dvt.max_files = -1), comp_dvt.max_files); call ioa_ (" maxpagelength: ^[unlimited^;^f^];", (comp_dvt.pdl_max = -1), dec (comp_dvt.pdl_max, 11, 3) / 1000) ; call ioa_ (" maxpagewidth: ^f;", dec (comp_dvt.pdw_max, 11, 3) / 1000); call ioa_ (" minbotmarg: ^f;", dec (comp_dvt.vmb_min, 11, 3) / 1000); call ioa_ (" mintopmarg: ^f;", dec (comp_dvt.vmt_min, 11, 3) / 1000); call ioa_ (" stream: ^[on^;off^];", (comp_dvt.open_mode = 2)); call ioa_ (" taperec: ^[unlimited^;^f^];", (comp_dvt.pdl_max = -1), comp_dvt.pdl_max); end; call show_families; end; %page; show_a_font: /* dispaly characters defined for a font */ proc; dcl (f, m) fixed bin; /* working index */ dcl length builtin; do f = 1 to comp_dvt.family_ct; /* search for the font */ if comp_dvt.family.name (f) = familyname then do; member_ptr = ptr (const.dvidptr, comp_dvt.member_r (f)); if (member.count > 1 | member.name (1) ^= "") & membername = "" then membername = "/m"; do m = 1 to member.count; if (member.name (m) = membername) then goto found; end; call com_err_ (error_table_$name_not_found, me, "^a not found in family ^a on device ^a.", membername, familyname, before (dvtname, ".dvt")); return; end; end; call com_err_ (error_table_$name_not_found, me, "Font ^a not found on device ^a.", familyname, before (dvtname, ".dvt")); return; found: if membername = "" then call ioa_ (" bachelor: ^a;", familyname); else call ioa_ (" family: ^a; member: ^a;", familyname, membername); font_ptr = ptr (const.devptr, member.font_r (m)); oput_p = ptr (const.devptr, font.oput_r); medsel_table_ptr = ptr (const.dvidptr, comp_dvt.medsel_table_r); med_sel_p = pointer (const.devptr, medsel_table.ref_r (oput.which (32))); call ioa_ (" strokes: ^i^/ wordspace: ^i,^i,^i^/ footsep: ^a^/ " || "medsel: ""^a""", font.rel_units, font.min_wsp, font.avg_wsp, font.max_wsp, comp_util_$display ((font.footsep), 0, "0"b), comp_util_$display ((med_sel_p -> substr (med_sel.str, 1, med_sel.str_l)), 0, "0"b)); units_ptr = ptr (const.devptr, font.units_r); linea = ""; if long then colwidth = 16; else colwidth = 10; do kk = 0 to oput.data_ct; if oput.what_r (kk) ^= "0"b then do; if kk >= 32 & kk < 127 then linea = linea || byte (kk); else linea = linea || comp_util_$display ((byte (kk)), 0, "0"b); linea = linea || " (" || ltrim (char (units (kk))); if long then do; linea = linea || ","; call display_str (oput.what_r (kk)); end; linea = linea || ")"; call put_str (0); linea = copy (" ", colwidth - mod (length (lineb) + 1, colwidth) + 1); end; end; if (lineb ^= "") then call ioa_ ("^a", lineb); /* *** format: off */ dcl bitname /* char names for tables */ (0:511) char (16) var int static options (constant) init ("NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL", "BSP", "HT", "LF", "VT", "FF", "CR", "SO", "SI", "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB", "CAN", "031", "SUB", "ESC", "FS", "GS", "RS", "US", "SP", """!""", """""""", """#""", """$""", """%""", """&""", """'""", """(""", """)""", """*""", """+""", """,""", """-""", """.""", """/""", """0""", """1""", """2""", """3""", """4""", """5""", """6""", """7""", """8""", """9""", """:""", """;""", """<""", """=""", """>""", """?""", """@""", """A""", """B""", """C""", """D""", """E""", """F""", """G""", """H""", """I""", """J""", """K""", """L""", """M""", """N""", """O""", """P""", """Q""", """R""", """S""", """T""", """U""", """V""", """W""", """X""", """Y""", """Z""", """[""", """\""", """]""", """^""", """_""", """`""", """a""", """b""", """c""", """d""", """e""", """f""", """g""", """h""", """i""", """j""", """k""", """l""", """m""", """n""", """o""", """p""", """q""", """r""", """s""", """t""", """u""", """v""", """w""", """x""", """y""", """z""", """{""", """|""", """}""", """~""", "PAD", "200", "201", "202", "203", "204", "205", "206", "207", "210", "211", "212", "213", "214", "215", "216", "217", "220", "221", "222", "223", "224", "225", "226", "227", "230", "231", "232", "233", "234", "235", "236", "237", "240", "241", "242", "243", "244", "245", "246", "247", "250", "251", "252", "253", "254", "EMdash", "256", "257", "260", "261", "262", "263", "264", "265", "266", "267", "270", "271", "272", "273", "274", "275", "276", "277", "300", "301", "302", "(c)", "304", "305", "306", "307", "310", "311", "312", "313", "314", "o", "316", "317", "320", "321", "322", "323", "324", "325", "326", "327", "330", "331", "332", "333", "334", "335", "336", "337", "340", "341", "342", "343", "344", "345", "346", "347", "350", "351", "352", "353", "354", "355", "356", "357", "360", "361", "362", "363", "364", "365", "366", "367", "370", "371", "372", "373", "374", "375", "376", "PS", "^0", "^1", "^2", "^3", "^4", "^5", "^6", "^7", "^8", "^9", "EM", "EM_", "EN", "EN_", "ENd", "THIN", "DEVIT", "``", "''", "1hi-X", "424", "dn-arrow", "426", "dia-left", "delete-mark", "dia-right", "dia-top", "<", "1hi-{", "1hi-[", "left-circle", "437", "->", "1hi-}", "1hi-]", "right-circle", "444", "up-arrow", "446", "447", "450", "451", "452", "453", "454", "455", "456", "457", "460", "461", "462", "463", "464", "465", "466", "467", "470", "471", "472", "473", "474", "475", "476", "477", "500", "501", "502", "503", "504", "505", "506", "507", "510", "511", "512", "513", "514", "515", "516", "517", "520", "521", "522", "523", "524", "525", "526", "527", "530", "531", "532", "533", "534", "535", "536", "537", "540", "541", "542", "543", "544", "545", "546", "547", "550", "551", "552", "553", "554", "555", "556", "557", "560", "561", "562", "563", "564", "565", "566", "567", "570", "571", "572", "573", "574", "575", "576", "577", "600", "601", "602", "603", "604", "605", "606", "607", "610", "611", "612", "613", "614", "615", "616", "617", "620", "621", "622", "623", "624", "625", "626", "627", "630", "631", "632", "633", "634", "635", "636", "637", "640", "641", "642", "643", "644", "645", "646", "647", "650", "651", "652", "653", "654", "655", "656", "657", "660", "661", "662", "663", "664", "665", "666", "667", "670", "671", "672", "673", "674", "675", "676", "677", "700", "701", "702", "703", "704", "705", "706", "707", "710", "711", "712", "713", "714", "715", "716", "717", "720", "721", "722", "723", "724", "725", "726", "727", "730", "731", "732", "733", "734", "735", "736", "737", "740", "741", "742", "743", "744", "745", "746", "747", "750", "751", "752", "753", "754", "755", "756", "757", "760", "761", "762", "763", "764", "765", "766", "767", "770", "771", "772", "773", "774", "775", "776", "777"); /* *** format: on */ end show_a_font; %page; show_families: proc; dcl bach_sw bit (1); dcl j fixed bin; dcl length builtin; first = "1"b; do j = 1 to comp_dvt.family_ct; member_ptr = ptr (const.dvidptr, comp_dvt.member_r (j)); bach_sw = (member.name (1) = ""); if first then do; if debug then do; if bach_sw then call ioa_$rsnnl ("^.3b", linea, 0, member.font_r (1)); else linea = ""; linea = linea || copy (" ", 10 - length (linea)); end; else linea = " "; if bach_sw then linea = linea || "bachelor:"; else linea = linea || "family:"; end; else do; linea = linea || ","; call put_str (indent); linea = ""; end; linea = linea || " "; linea = linea || rtrim (comp_dvt.name (j)); if debug then do; linea = linea || "("; linea = linea || ltrim (char (j)); linea = linea || ")"; end; first = "0"b; if (j = comp_dvt.family_ct) then call show_members; else if (comp_dvt.member_r (j) ^= comp_dvt.member_r (j + 1)) then call show_members; end; call put_str (indent); %page; show_members: proc; first = "1"b; if (member.name (1) ^= "") then do; didmem (*) = "0"b; do k = 1 to member.count; if ^didmem (k) then do; if first then do; linea = linea || ";"; call put_str (indent); call ioa_ ("^a", lineb); lineb = ""; end; if debug then call ioa_$rsnnl ("^.3b", linea, 0, member.font_r (1)); else linea = ""; linea = linea || " member: "; linea = linea || rtrim (member.name (k)); if debug then do; linea = linea || "("; linea = linea || ltrim (char (k)); linea = linea || ")"; end; first = "0"b; didmem (k) = "1"b; do kk = k + 1 to member.count; if (member.font_r (k) = member.font_r (kk)) then do; linea = linea || ","; call put_str (indent); linea = " "; linea = linea || rtrim (member.name (kk)); if debug then do; linea = linea || "("; linea = linea || ltrim (char (kk)); linea = linea || ")"; end; didmem (kk) = "1"b; end; end; first = "1"b; /* if alt_sw then do; linea = linea || ";"; call put_str (indent); call ioa_ ("^a", lineb); lineb = ""; end; */ end; end; end; linea = linea || ";"; call put_str (indent); call ioa_ ("^a", lineb); lineb = ""; first = "1"b; end show_members; end show_families; end show_dvt; end show_dsm; put_str: proc (indent); dcl indent fixed bin; if (length (linea) + length (lineb) > linelength) then do; if lineb ^= "" then do; call ioa_ ("^a", lineb); lineb = copy (" ", indent); end; else lineb = ""; lineb = lineb || ltrim (linea); end; else lineb = lineb || linea; linea = ""; end put_str; display_new_str: proc (str_r); linea = ""; display_str: entry (str_r); dcl str_r bit (18); dcl ch char (1); dcl bins (3) fixed bin (3) unsigned unal based (addr (ch)); dcl kkk fixed bin; dcl lined char (200) var; medchar_sel_p = ptr (const.devptr, str_r); lined = comp_util_$display ((medchar_sel.str), 0, "0"b); linea = linea || """" || lined; linea = linea || """"; end display_new_str; %page; clean: proc; dcl terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35)); call terminate_file_ (dsmptr, 0, TERM_FILE_TERM, code); if (code ^= 0) then call com_err_ (code, me, "Terminating ^a", dsmpath); end clean; %page; proc_args: proc; dcl arg char (argl) based (argp); dcl argct fixed bin; /* number of args given */ dcl argl fixed bin (21); dcl argno fixed bin; /* arg counter */ dcl argp ptr; dcl (decat, index) builtin; dcl error_table_$badopt fixed bin (35) ext static; dcl error_table_$noarg fixed bin (35) ext static; dcl iox_$user_output ptr ext static; dcl check_star_name_$entry entry (char (*), fixed bin (35)); dcl cu_$af_arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl get_line_length_$switch entry (ptr, fixed bin (35)) returns (fixed bin); dcl get_wdir_ entry returns (char (168)); unspec (sws) = "0"b; /* preset switches */ star_code = 0; dsmpath, familyname, membername = ""; call cu_$af_arg_count (argct, code); if code = 0 then do; call com_err_ (0, me, "Not callable as an active function."); error = "1"b; return; end; if me = DSNAME /* display_comp_dsm args */ then do; if argct = 0 then do; call com_err_ (error_table_$noarg, me, "^/^5xProper usage: dcdsm path {font} {-control_args}"); error = "1"b; return; end; linelength = get_line_length_$switch (iox_$user_output, code); if code ^= 0 then linelength = 80; indent = 10; do argno = 1 to argct; call cu_$arg_ptr (argno, argp, argl, code); if (code = 0) then do; if (index (arg, "-") = 1) then do; if (arg = "-device") | (arg = "-dv") then device = "1"b; else if (arg = "-linelength") | (arg = "-ll") then do; if argno = argct then do; missing_arg: call com_err_ (error_table_$noarg, me, "Value for ^a", arg); error = "1"b; end; else do; argno = argno + 1; call cu_$arg_ptr (argno, argp, argl, code); linelength = cv_dec_check_ (arg, code); if (code ^= 0) then do; call com_err_ (0, me, "Invalid decimal value. ^a", arg); error = "1"b; end; end; end; else if (arg = "-long") | (arg = "-lg") then long = "1"b; else if (arg = "-debug") | (arg = "-db") then do; debug = "1"b; indent = 16; end; else do; badopt: call com_err_ (error_table_$badopt, me, "^a", arg); error = "1"b; end; end; else do; if dsmpath = "" /* first name is the module */ then dsmpath = arg; else if familyname = "" /* second name is a font */ then do; familyname = before (arg, "/"); membername = decat (arg, "/", "011"b); end; else do; call com_err_ (0, me, "Too many positional args. ^a", arg); error = "1"b; end; end; end; else do; call com_err_ (code, me, "Reading argument ^i", argno); error = "1"b; end; end; if dsmpath = "" /* must have a module */ then do; call com_err_ (error_table_$noarg, me, "No dsm_name specified."); error = "1"b; end; end; else /* list_comp_dsm args */ do; starname = ""; do argno = 1 to argct; call cu_$arg_ptr (argno, argp, argl, code); if (code = 0) then do; if (index (arg, "-") = 1) then do; if (arg = "-debug") | (arg = "-db") then do; debug = "1"b; end; else if (arg = "-pathname") | (arg = "-pn") then do; path = "1"b; if argno = argct then goto missing_arg; argno = argno + 1; call cu_$arg_ptr (argno, argp, argl, code); dsmpath = arg; end; else if (arg = "-working_dir") | (arg = "-wd") then do; path = "1"b; dsmpath = get_wdir_ (); end; else goto badopt; end; else if starname ^= "" then do; call com_err_ (0, me, "Only one starname allowed. ^a", arg); error = "1"b; end; else do; call check_star_name_$entry (arg, star_code); if star_code > 2 then do; call com_err_ (star_code, me, " starname ^a", arg); error = "1"b; end; else starname = arg; end; end; end; if starname = "" then starname = "**.comp_dsm"; else do; call expand_pathname_$add_suffix (starname, "comp_dsm", "", starname, code); if code ^= 0 then do; call com_err_ (code, me, "Assuring starname suffix."); error = "1"b; return; end; end; end; end proc_args; dcl didmem (3600) bit (1) unal; dcl first bit (1); dcl j fixed bin; dcl k fixed bin; dcl kk fixed bin; %include access_mode_values; %include compstat; %include comp_dvid; %include comp_dvt; %include comp_entries; %include comp_fntstk; %include comp_font; %include definition_dcls; %include object_info; %include sl_control_s; %include sl_info; %include star_structures; %include terminate_file; end display_comp_dsm;  expand_device_writer.pl1 04/23/85 1100.9rew 04/23/85 0911.5 80046 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* format: style2,ind3,ll80,dclind4,idind16,comcol41,linecom */ expand_device_writer: xdw: proc; me = "xdw"; ME = "XDW"; suffix = ".xdw"; goto start; macro: entry; me = "macro"; ME = "MACRO"; suffix = ".macro"; dcl version char (6) int static init ("1.2b"); dcl me char (32) var; dcl ME char (8) var; start: code = 0; segname = ""; in_p, of_p = null (); in_l, of_l = 0; callp = null (); in_sw, of_sw, pr_sw, long_sw = "0"b; argno = 0; argct = 0; do while (code = 0); argno = argno + 1; call cu_$arg_ptr (argno, arg_p, arg_l, code); if (code = 0) then do; if (substr (arg, 1, 1) = "-") then do; if (arg = "-pr") | (arg = "-print") then pr_sw = "1"b; if (arg = "-npr") | (arg = "-no_print") then pr_sw = "0"b; else if (arg = "-call") then do; argno = argno + 1; call cu_$arg_ptr (argno, arg_p, arg_l, code); if (code ^= 0) then do; call com_err_ (code, me, "-call value"); return; end; callp = arg_p; calll = arg_l; end; else if (arg = "-long") | (arg = "-lg") then long_sw = "1"b; else if (arg = "-brief") | (arg = "-bf") then long_sw = "0"b; else if (arg = "-instr") | (arg = "-input_string") then do; if in_sw then do; call com_err_ (0, me, "Multiple input_strings supplied."); return; end; if (in_p ^= null ()) then goto not_both; argno = argno + 1; call cu_$arg_ptr (argno, arg_p, arg_l, code); if (code ^= 0) then do; call com_err_ (0, me, "Value for -in keyword.") ; return; end; in_sw = "1"b; in_p = arg_p; in_l = arg_l; end; else if (arg = "-ag") | (arg = "-arguments") then do; do i = 1 to 25 while (code = 0); argno = argno + 1; call cu_$arg_ptr (argno, arg_p, arg_l, code); if (code = 0) then do; argct = argct + 1; argl.p (argct) = arg_p; argl.l (argct) = arg_l; end; end; end; else if (arg = "-of") | (arg = "-output_file") then do; of_sw = "1"b; argno = argno + 1; call cu_$arg_ptr (argno, arg_p, arg_l, code); if (code ^= 0) then do; call com_err_ (0, me, "Value for -of keyword.") ; return; end; of_p = arg_p; of_l = arg_l; end; else do; call com_err_ (error_table_$badopt, me, "^a", arg); return; end; end; else do; if (segname ^= "") then do; call com_err_ (0, me, "Multiple source names supplied."); return; end; if (substr (arg, 1, 1) = "&") then do; call com_err_ (0, me, "Must now use -input_string to specify string to be expanded." ); return; end; if (in_p ^= null ()) then do; not_both: call com_err_ (0, me, "Cannot supply both string and segment as input." ); return; end; call expand_pathname_ (arg, dname, ename, code); if (code ^= 0) then do; call com_err_ (code, me, "^a", arg); return; end; ename = before (ename, suffix); segname = rtrim (ename); call hcs_$initiate_count (dname, segname || suffix, "", in_l, 0, in_p, code); if (in_p = null ()) then do; call com_err_ (code, me, "^a>^a^a", dname, ename, suffix); return; end; in_l = divide (in_l, 9, 24, 0); code = 0; end; end; else if argno = 1 then do; call com_err_ (code, ME, "^/Usage is: expand_device_writer {path} {-control_args}"); return; end; end; if (segname = "") & (in_p = null ()) | (argno = 1) then do; if (suffix = ".macro") then call com_err_ (0, me, "(^a) Proper usage is: ^a {path} {-control_args}", version, me); return; end; if ^of_sw then if in_sw then pr_sw = "1"b; else dname = get_wdir_ (); call get_temp_segments_ ((me), ptra, code); out_ptr = ptra (1); if (code ^= 0) then do; call com_err_ (code, me); return; end; out_len = 0; call ioa_ ("^a ^a", ME, version); on condition (cleanup) begin; call xdw_$free (long_sw); call release_temp_segments_ ((me), ptra, code); end; call xdw_$expand (me, segname, "", out_ptr, out_len, addr (argl), (argct), msg, in_p, in_l, code); call xdw_$free (long_sw); if (code ^= 0) then do; if (code = 1) | (code = -1) then icode = 0; else icode = code; call com_err_ (icode, me, "^a", msg); end; if pr_sw then do; call iox_$put_chars (iox_$user_output, out_ptr, out_len, code); end; else if (code = 0) then do; if (of_p ^= null ()) then do; arg_p = of_p; arg_l = of_l; call expand_pathname_ (arg, dname, ename, code); if (code ^= 0) then do; call com_err_ (0, me, "^a", arg); goto done; end; end; call hcs_$make_seg (dname, ename, "", 01010b, out_ptr, code); if (out_ptr = null ()) then call com_err_ (code, me, "^a>^a", dname, ename); else do; substr (out_ptr -> str, 1, out_len) = substr (ptra (1) -> str, 1, out_len); call hcs_$set_bc_seg (out_ptr, out_len * 9, code); call hcs_$terminate_noname (out_ptr, code); if (code ^= 0) then call com_err_ (code, me); if (code = 0) & (callp ^= null ()) then call cu_$cp (callp, calll, 0); end; end; done: call release_temp_segments_ ((me), ptra, code); dcl 1 argl (25), 2 p ptr, 2 l fixed bin (24); dcl argct fixed bin (24); dcl in_p ptr; dcl in_l fixed bin (24); dcl of_p ptr; dcl of_sw bit (1); dcl in_sw bit (1); dcl of_l fixed bin (24); dcl get_wdir_ entry returns (char (168)); dcl icode fixed bin (35); dcl dname char (168); dcl suffix char (32) var; dcl ename char (32); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl arg char (arg_l) based (arg_p); dcl arg_l fixed bin; dcl arg_p ptr; dcl argno fixed bin; dcl calll fixed bin (24); dcl callp ptr; dcl cleanup condition; dcl code fixed bin (35); dcl com_err_ entry options (variable); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl cu_$cp entry (ptr, fixed bin (24), fixed bin (35)); dcl error_table_$badopt fixed bin (35) ext static; dcl get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl i fixed bin; dcl ioa_ entry options (variable); dcl iox_$put_chars entry (ptr, ptr, fixed bin (24), fixed bin (35)); dcl iox_$user_output ptr ext static; dcl long_sw bit (1); dcl segname char (32) var; dcl xdw_$expand entry (char (32) var, char (32) var, char (32) var, ptr, fixed bin (24), ptr, fixed bin, char (1000) var, ptr, fixed bin (24), fixed bin (35)); dcl xdw_$free entry (bit (1)); dcl msg char (1000) var; dcl out_len fixed bin (24); dcl out_ptr ptr; dcl pr_sw bit (1); 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 hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); dcl ptra (1) ptr; dcl release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl str char (262144) based; end expand_device_writer;  process_compout.pl1 04/23/85 1100.9rew 04/23/85 0911.5 884169 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* compose routine to print sequential compout files */ /* format: style2,ind2,ll79,dclind4,idind15,comcol41,linecom */ process_compout: pco: proc; /* This procedure implements one command and two active functions designed for processing compout files. process_compout (pco) writes device images in various formats to mag/paper tape to user output [compout] returns the name of a compout [compask ...] "response" with a memory /* Usage: process_compout {path} {ctlargs} */ /* */ /* Processes one or more sequential compout files to the terminal, paper */ /* tape, or mag tape. It supports various means of page selection and */ /* and several output display modes. */ /* */ /* args: */ /* path */ /* the name of a compout to process, may be a starname. The compout */ /* suffix need not be supplied. If not given, then -pn must be used. */ /* */ /* ctlargs: */ /* -block xx */ /* Override the imbedded output blocking factor, using xx instead. */ /* -brief, -bf */ /* abbreviate various headers and labels */ /* -change_printwheel_for_file, -cpwf */ /* change printwheel and reprint at end of file. */ /* -change-printwheel_for_pages, -cpwp */ /* change printwheel and reprint at end of page. */ /* -comment */ /* same as -mode comment */ /* -control_file path, -cf path ACCEPTED, BUT NOT IMPLEMENTED */ /* path is the name of a control file (see below for format). */ /* -display, -ds */ /* same as -mode display */ /* -dump */ /* same as -mode dump */ /* -from xx, -fm xx */ /* begin output from page xx (see page number conventions) */ /* -header, -he */ /* show the file header with -dump or -mode dump. */ /* -long, -lg */ /* add additional information to what is being displayed. */ /* -mode comment|display|dump|setup|?|xx|"STR" */ /* comment prints the compout control comment information */ /* display prints the image with all device controls interpreted */ /* dump prints and ascii/octal dump of the image */ /* setup prints the machine setup information (font assignments, */ /* print wheel assignments, etc) */ /* ? prints the modes defined in the file header */ /* xx selects the mode with that name from the control comment */ /* "STR" uses STR as an attach descscription (atd) string */ /* -noheader, -nhe */ /* do not show the file header with -dump or -mode dump (default). */ /* -pages xx, -pgs xx, -page xx, -pg xx */ /* selects a series of pages and/or ranges of pages (see page number */ /* conventions). Any number of xx's may follow */ /* -pages_changed {p|s}, -pgs {p|s} */ /* causes only the changed pages to be selected. The "s" option says */ /* that only the single modified pages are wanted. The "p" option */ /* says that the obverse pages are wanted to match all modified */ /* pages. */ /* ---------------- "p" option accepted, but not implemented; gives warning */ /* -pathname xx, -pn xx */ /* causes xx to be used as an input file name without adding */ /* ".compout". May not be used when path is given. */ /* -stop, -sp */ /* stop between pages */ /* -table, -tb */ /* causes a table of all the pages selected to be printed, showing */ /* the page sequence number, front/back status, the changed status */ /* (via "#") and the page identification */ /* -to xx */ /* This causes output to cease after page xx (see page number */ /* conventions) */ /* -volume xx */ /* this specifies the name of an output tape to be used */ /* -wait, -wt */ /* stop before first page (only) */ /* */ /* Note: args apply to all input files. */ /* */ /* CONTROL FILE FORMAT --- NOT IMPLEMENTED */ /* A control file is used to specify what is to be done. Each entry has this */ /* form: */ /* star_paths {ctlargs}; */ /* The ctlargs in a entry apply to only the paths in that entry. In this */ /* manner, different selection can be done on various paths to be processed, */ /* to a single tape. */ /* */ /* PAGE NUMBER CONVENTIONS */ /* !n absolute page number, sequence number in compout */ /* !0 reset to beginning of compout, used to enable output in order */ /* other than compout order */ /* +n relative page number, forward from current position */ /* $-n relative page number, referencing the last page (-n optional) */ /* XXX page identification, the page identifier XXX is searched for. An */ /* exact match must occur, no less/greater than check is possible */ /* */ /* fileheader.comment is used to carry information which is needed to handle */ /* the file. This information consists of lines (i.e. separated by NLs). */ /* Each line begins with a keyword followed by a colon. Below, "xxx" */ /* represents the data pertaining to the keyword. All xxx strings are active */ /* function expanded ("[" and "]" are reserved for this purpose) before */ /* being put to use. A NL need not follow the last line. These options are */ /* available (anything else is ignored): */ /* mode:zzz=xxx This defines a mode, zzz, to have the value xxx. The */ /* first mode present is the default mode. If any others */ /* are present, they represent alternatives available. */ /* A mode defines a method of disposing of the data. The */ /* output type is the first 4 characters of the mode */ /* string. These 3 are currently supported: */ /* 1) output_type=TAPE specified as */ /* "tape_ibm_ attach-description" OR */ /* "tape_ansi_ attach-description" */ /* 2) output_type=PUNCH specified as */ /* "punch K" */ /* 3) output_type=ONLINE (default in none specified at all) */ /* --attach-description is everything needed except for */ /* volume-id -ring -retain xxx */ /* -number nnn -create/-append */ /* These are all supplied as needed by pco. */ /* --K currently can only be "6". punch 6 is used to put */ /* out TTS or reverse TTS information via a modified TN300 */ /* paper tape punch (disable 2 upper punches) */ /* --online causes output to be sent user_output */ /* leader:xxx The string xxx is punched out in "big" letters on the */ /* paper tape leader after the file identification. */ /* setup:xxx The string xxx is placed in the "contents" file which */ /* is written first on mag tape. When multiple files are */ /* being written to the same tape, this information is */ /* included only once (the first file's). This is intended */ /* to be used to convey the font setup, etc. information to */ /* the receiver of the tape. */ /* There may be multiple occurances of this statement. Each */ /* occurance is added to the "contents" file followed by a */ /* CR/LF. */ /* file:xxx The string xxx is placed in the "contents" file which */ /* is written first on mag tape. This information is used */ /* from EACH file written on tape. It is intended to give */ /* information specific to each file (document). */ /* The active function [compout] will contain the name of */ /* each document in turn as this information is processed. */ /* The active function [compask ...] is designed to be of */ /* help in replying to the many occurances of the same */ /* question which will occur in this case. */ /* content_file:{^}seg,{^}tape */ /* This controls the disposition of the "contents" file. */ /* If not specified, the default is "^tape,seg". */ /* seg,^seg do/dont create the segment XXX.contents. This will */ /* happen only if -volume XXX is specified. XXX is the name */ /* of the tape being written. */ /* tape,^tape do/dont place the contents file at the beginning of the */ /* tape. */ /* pack:xxx */ /* where xxx is of the form */ /* {<spec>[,<spec>]...}... */ /* where <spec> is fN | cN | bN | '...' */ /* This signifies that the data is to be packed when */ /* writing to mag tape. */ /* --'...' is a literal bit string to be output, quoted this */ /* way because the comment in compdv is already in "'s */ /* --fN means to move forward N bits in the input byte */ /* --cN means to copy N bits from the input byte */ /* --bN means to move backward N bits in the input byte */ /* (N is a single digit) */ /* --"," separates parts within a "bytes-worth" */ /* --";" separates between input bytes */ /* blkhdr/blktlr recognized but not implemented */ /* DB: xxx xxx is the seg$entry of routine to do the -db display */ /* This entry and any which follow it will not be shown if */ /* -mode comment is requested. */ %page; /* Usage: [compout] */ /* */ /* While the comment string of a compout is being processed, this function */ /* will return the name (less ".compout") of this compout. */ /* If called at any other time it will print the message from */ /* error_table_$out_of_sequence */ %skip (5); /* Usage: [compask question {responses}] */ /* */ /* While the comment string of a compout is being processed, this function */ /* asks a question of the user. It optionally constrains the answer to be */ /* one of a specified set. It also contains provision for the mapping of a */ /* specific user answer into a different return string. This function */ /* remembers the text of each different question asked (within a single pco */ /* execution), and keeps the last answer. Each question is asked, showing */ /* the remembered answer (if any). This last answer may be selected by */ /* answering only a NL. If a null answer is wanted instead of the last */ /* answer, a single "." must be the response. */ /* */ /* question is whatever is to be asked. It is printed, followed by */ /* the last answer to this question in parentheses, but */ /* with no NL. */ /* response if present specifies a value which is a valid response. */ /* This may be in one of two forms: "A" or "A=B". The "A" */ /* is a response to be checked for. If the "=" is present, */ /* whatever follows it (the "B" portion, which may be null) */ /* is returned if the "A" is entered by the user. */ /* For example: (all on one line in a compout comment string) */ /* file:Return[compask "" Pasteup? "" no= ""yes= pasted up""] */ /* [compask ""original/copy? "" o=original original c=copy copy]. */ /* If 2 files are being processed, it will cause this kind of interaction: */ /* Pasteup? () yes */ /* original/copy () copy */ /* Pasteup? (yes) no */ /* original/copy (copy) o */ /* will cause generation of these lines: */ /* Return pasted up copy. */ /* Return original. */ /* Note that the pasteup question returns a null result if the answer is no */ /* and the string " pasted up" if the answer is yes. The yes response must */ /* be quoted because it contains SPs. */ /* The other question allows the user to reply "o" instead of having to type */ /* "original", yet the result is the more meaningful whole word. */ %page; /* LOCAL STORAGE */ dcl af_data_ptr ptr int static init (null ()); dcl 1 af_data based (af_data_ptr), 2 compout char (32) var, /* [compout] data */ 2 count fixed bin, /* [compask "..."] data list */ 2 e (af_data.count), 3 quest char (100) var, /* question */ 3 ans char (168) var; /* answer */ dcl answer char (4) var; /* command_query answer */ /* command argument */ dcl arg char (argl) based (argp); /* arg list structure */ dcl 1 arg_list based (arg_list_ptr), /* 1= use arg as name wo/compout */ 2 asis (argct) bit (1) unal, /* can be an absolute path */ 2 arg (argct) char (200) var, 2 E ptr; /* -> file if arg is a path */ dcl arg_list_ptr ptr defined tempsegs (5); dcl argct fixed bin; /* number of command args given */ dcl argl fixed bin (21); /* length of arg */ dcl argno fixed bin; /* command line arg counter */ dcl argp ptr; /* pointer to arg */ dcl BEGIN fixed bin static options (constant) init (1); dcl BELHT char (2) static options (constant) init (" "); dcl BOF fixed bin static options (constant) init (-1); dcl code fixed bin (35); /* error code */ /* -> tape contents list */ dcl contents_ptr ptr defined tempsegs (3); dcl contents char (262143) var based (contents_ptr); dcl contents_l fixed bin; dcl CR char (1) static options (constant) init (" "); dcl ctl_file (100) char (168) var; /* control file paths */ dcl ctl_file_count fixed bin; /* number of control files */ dcl device_cleanup char (100) var; /* cleanup string for device */ /* dcl display_proc entry (char (*) var, fixed bin (24), bit (1), bit (1)) /* returns (char (*) var) automatic;*/ /* dcl display_rtn char (168) var; /* name of -db/-display routine */ dcl done bit (1); /* loop control switch */ dcl END fixed bin static options (constant) init (2); dcl given_file_count /* # of files given */ fixed bin; dcl file_entry_ptr ptr; /* file entry structure */ dcl 1 file_entry aligned based (file_entry_ptr), 2 link ptr, /* -> next file in linked list */ 2 file char (168) var, /* name of file to process*/ 2 ename char (32) var, /* compout name */ 2 seq_no fixed bin, 2 page_count fixed bin, /* count of selected pages */ 2 sws, 3 pgc bit (1) unal, 3 obverse bit (1) unal, /* not yet implemented */ 3 stop bit (1) unal, 3 wait bit (1) unal, 3 fill bit (32) unal, 2 page_sel_ct fixed bin, /* count of page select fields */ 2 ll (file_entry.page_sel_ct), 3 from, 4 num fixed bin, /* relative page count */ 4 id char (32), /* actual page id to look for */ 4 sign char (1), /* "-" num is $- value */ /* "+" num is + value */ /* "x" num is absolute value */ /* " " id is what to look for */ 3 to like file_entry.from, 2 next fixed bin; dcl file_entry_base_ptr (2) ptr; /* base of linked list of */ /* file entry ptrs */ /* (1) - command line files */ /* (2) - ??? (control files ) */ dcl filno fixed bin; /* file counter */ dcl 1 from_to aligned like file_entry.from based (from_to_ptr); dcl from_to_ptr ptr; dcl FSPREC fixed bin static options (constant) init (0); dcl keyword char (64) var; /* as needed for keyword checking */ dcl header_out_ptr ptr; /* -> header of the current compout */ dcl PADHT char (2) static options (constant) init (" "); dcl ii fixed bin; /* working index */ /* dcl init_proc entry automatic; /* writer init proc */ dcl input_iocbp ptr; /* -> IOCB for input file */ dcl ipage fixed bin; /* page counter */ dcl j fixed bin; /* working index */ dcl leader char (256) var; /* fixed portion of leader */ dcl max_tape_files fixed bin; /* on a tape */ dcl max_outrecs fixed bin; /* max records in an output file */ dcl max_records fixed bin; /* -block value for max_outrecs */ dcl me char (15) static options (constant) init ("process_compout"); dcl mode char (200) var; /* a mode from the file */ dcl mode_arg char (200) var; /* arg given for -mode */ dcl mounted_wheel fixed bin static init (1); dcl next_image bit (36); /* for loop control */ dcl NOVOL char (6) static options (constant) init ("######"); dcl ONLINE char (4) static options (constant) init ("onli"); dcl output_medium char (4); /* = tape/punch/online */ dcl output_text char (output_text_len) based (output_text_ptr); dcl output_text_len fixed bin (21); dcl output_text_ptr ptr defined tempsegs (6); dcl pack_ct fixed bin; /* # entries in bit packing array */ dcl page_length fixed bin (31); dcl page_selected fixed bin; /* pagelist.page ndx of page */ dcl page_wrdct fixed bin; /* word count for page overlay page */ dcl pagelist_base fixed bin; /* base pagelist.page index */ dcl pagelist_last fixed bin; /* last pagelist.page index */ /* contents of all requested files */ dcl pagelist_ptr ptr defined tempsegs (4); dcl 1 pagelist based (pagelist_ptr), 2 file_count fixed bin, /* how many files in the list */ 2 page_count fixed bin, /* how many pages in the list */ 2 file (pagelist.file_count), 3 name char (168) var, /* file name */ 3 from fixed bin, /* beginning pagelist.page index */ 3 to fixed bin, /* ending pagelist.page index */ 2 page (pagelist.page_count), 3 id char (32), /* page identification */ 3 file_no fixed bin, /* pagelist.file index */ 3 seq_no fixed bin, /* abs position in file */ 3 sw, 4 changed bit (1) unal, /* page is changed */ 4 obv_changed bit (1) unal, /* obverse is changed */ 4 front bit (1) unal, /* page is a front */ 4 blank bit (1) unal, /* page is intentionally blank */ 4 no_front bit (1) unal, /* obverse front not present */ 4 no_back bit (1) unal, /* obverse back not present */ 4 select bit (1) unal, /* page is selected for output */ 4 fill bit (29) unal; dcl preface char (500) var; /* place to hold successive prefaces */ dcl PUNCH char (4) static options (constant) init ("punc"); /* internal proc to do the output */ dcl put_out entry (fixed bin) automatic; dcl raw_record char (record_len) based (record_ptr); dcl record_bytes fixed bin (21); /* max tape record length in bytes */ dcl record_count fixed bin; /* record counter */ dcl record_hdrct fixed bin; /* input record header word count */ dcl record_len fixed bin (21); /* input record length from iox_ */ dcl record_wrdct fixed bin; /* input record word count */ dcl reply_text char (256); /* users response to a question */ dcl setup char (2000) var; /* font setup info for contents file */ dcl stop_signal char (5); /* 2 ({BEL||}HT)||CR */ dcl 1 sws, /* control switches */ 2 brief_sw bit (1) unal, /* 1= brief output mode */ 2 comment_sw bit (1) unal, /* 1= print comment value */ 2 contents_seg_sw /* 1= TOC segment wanted */ bit (1) unal, 2 contents_tap_sw /* 1= TOC file on tape wanted */ bit (1) unal, 2 cpwf_sw bit (1) unal, /* 1= change pwheel at EOF */ 2 debug_sw bit (1) unal, /* 1= debugging */ 2 display_sw bit (1) unal, /* 1= interpret file contents */ 2 dump_sw bit (1) unal, /* 1= octal dump of file contents */ 2 error_sw bit (1) unal, /* global error flag */ 2 first_pref_sw /* 1= first preface */ bit (1) unal, 2 from_to_sw bit (1) unal, /* 1= -from/-to arg given */ 2 header_sw bit (1) unal, /* 1= show file header */ 2 long_sw bit (1) unal, /* 1= long output mode */ 2 mode_sw bit (1) unal, /* 1= -mode has been given */ 2 nobell_sw bit (1) unal, /* 1= suppress BELs in stop signal */ 2 rawo_sw bit (1) unal, /* 1= in RAWO mode */ 2 setup_sw bit (1) unal, /* 1= print machine setup values */ 2 skip_pref_sw /* 1= skip preface */ bit (1) unal, 2 start_page_sw /* 1- starting a page output */ bit (1) unal, 2 table_sw bit (1) unal, /* 1= table list wanted */ 2 vol_sw bit (1) unal, /* 1= volume ID has been given */ 2 MBZ bit (15) unal; dcl TAPE char (4) static options (constant) init ("tape"); dcl tape_iocbp ptr; /* -> IOCB for output tape */ dcl tempsegs (6) ptr; /* tempseg pointers */ dcl text_cons (2) char (128) var; dcl text_pages fixed bin; /* # of pages put into output file */ dcl UNLIMITED fixed bin static options (constant) init (-1); dcl volid char (20) var; /* tape label volume ID */ dcl vol_file_ct fixed bin; /* number of files on a tape volume */ dcl wheel_done bit (36); /* which wheels have been processed */ dcl wheel_need bit (36); /* which wheels have been requested */ dcl ( /* page list value types */ NEG_REL init ("-"), /* $-value */ POS_REL init ("+"), /* +value */ ABS init ("x"), /* value */ SEARCH_ID init (" ") /* "PageNo string" */ ) /* search for page id */ char (1) int static options (constant); dcl error_table_$end_of_info fixed bin (35) ext static; dcl error_table_$unimplemented_version fixed bin (35) ext static; dcl (addr, addrel, after, before, char, codeptr, collate, convert, dec, divide, hbound, index, length, ltrim, min, max, mod, null, rtrim, size, string, substr, unspec, verify) builtin; dcl (cleanup, pco_error, quit) condition; dcl com_err_ entry options (variable); dcl command_query_ entry options (variable); dcl continue_to_signal_ entry (fixed bin (35)); 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 dump_segment_ entry (ptr, ptr, fixed bin, fixed bin, fixed bin, bit (*)); dcl hcs_$make_ptr entry (ptr, char (*), char (*), ptr, fixed bin (35)); dcl get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35)); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); dcl iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)); dcl iox_$put_chars entry (ptr, ptr, fixed (21), fixed (35)); dcl iox_$read_record entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); %page; /* INITIALIZE */ call cu_$arg_count (argct, code); /* check the call */ if code ^= 0 then do; call com_err_ (code, me); return; end; if argct = 0 /* show usage message */ then do; call com_err_ (0, me, "Proper usage is: ^a " || "paths {-control_args}", me); return; end; /* preset stuff touched by clean */ unspec (sws) = "0"b; /* clear all switches */ device_cleanup = ""; tempsegs (*), input_iocbp, tape_iocbp = null (); /* get temp segs */ call get_temp_segments_ (me, tempsegs, code); if code ^= 0 then do; call com_err_ (code, me, "Getting temp segments."); goto finish; /* cleanup done at this label */ end; query_info.version = 2; /* set up in case query needed */ query_info.suppress_spacing = "1"b; query_info.yes_or_no_sw = "1"b; fileheader_ptr, record_ptr = tempsegs (1); /* build arg_list array in tempsegs (5) */ /* the list is stored aside because */ /* the control file feature will */ /* change/augment the control args */ do argno = 1 to argct; /* for individual input files */ call cu_$arg_ptr (argno, argp, argl, code); arg_list.arg (argno) = arg; end; /* preset stuff touched by proc_args */ file_entry_base_ptr (*) = null (); max_records, ctl_file_count, given_file_count = 0; mode_arg, mode, volid = ""; call proc_args; /* process the command args */ if error_sw /* any errors processing args? */ then return; if given_file_count = 0 /* check file count */ then do; call com_err_ (0, me, "No compouts specified to process"); return; end; /* finish up initialization */ preface, text_cons (*), /*display_rtn,*/ leader, setup = ""; pack_ct = 0; skip_pref_sw = "1"b; max_tape_files = UNLIMITED; max_outrecs, record_bytes = 99999; output_medium = ONLINE; if volid = "" /* -volume is allowed only in com */ then volid = NOVOL; /* line, not control file */ if nobell_sw then stop_signal = PADHT || PADHT || CR; else stop_signal = BELHT || BELHT || CR; /**** LEAVE THIS IN FOR FUTURE IMPLEMENTATION */ /* do ii = 1 to ctl_file_count; /* process any ctl_file's */ /* call ioa_ ("control file not yet handled. ^a", ctl_file (ii)); /* end;*/ header_out_ptr = addr (file_entry.next); pagelist.file_count = given_file_count; filno, pagelist.page_count = 0; /* make all the entrypoints needed are known (when PCO not in search rules) */ here: call hcs_$make_ptr (codeptr (here), "compout", "compout", null (), 0); call hcs_$make_ptr (codeptr (here), "compask", "compask", null (), 0); on condition (cleanup) call clean; %page; /* go thru everything, making sure all asked for exists */ af_data_ptr = contents_ptr; /* borrow the segment for a while */ af_data.count = 0; if dt_sw then call ioa_ ("FILE LIST ***"); file_loop_1: /* for all files given */ do file_entry_ptr = file_entry_base_ptr (1) repeat (file_entry.link) while (file_entry_ptr ^= null ()); if open_compout () /* open compout and get file header */ then /* returns "1"b if open is OK */ do; af_data.compout = rtrim (file_entry.ename, ".compout"); filno = filno + 1; pagelist.file.name (filno) = file_entry.file; pagelist.file (filno).from = pagelist.page_count + 1; if device_cleanup = "" /* extract device cleanup string */ then do; l_cleanup = fileheader.cleanup_leng; device_cleanup = fileheader.cleanup; end; if debug_sw then call ioa_ ( "header: record_len=^i^/Version: ^i Device: ^a/^a/^a " || "MaxFiles: ^i; MaxPages: ^i;", record_len, fileheader.version, fileheader.device_class, fileheader.device_name, fileheader.device, max_tape_files, fileheader.max_pages); if ^table_sw then do; call proc_comment; if debug_sw then call ioa_ ("Cleanup: ^a", comp_util_$display ( substr (device_cleanup, 1, l_cleanup), 0, "0"b)); end; done = "0"b; /* set up for file processing */ record_count = 0; if ^comment_sw & ^error_sw /* if not just printing Comment: and */ then /* there have been no errors */ do while (^done); call /* read a record */ iox_$read_record (input_iocbp, record_ptr, record_len, record_len, code); /**/ /* EOF? */ if (code = error_table_$end_of_info) then done = "1"b; else if (code ^= 0) /* read error? */ then do; call com_err_ (code, me, "Reading ^a", file_entry.file); done = "1"b; end; else /* we have a valid record */ do; /* count & copy stuff into pagelist */ record_count = record_count + 1; pagelist.file (filno).to, pagelist.page_count = pagelist.page_count + 1; pagelist.page (pagelist.page_count).id = record.pageid; pagelist.page (pagelist.page_count).file_no = filno; pagelist.page (pagelist.page_count).seq_no = record_count; pagelist.page (pagelist.page_count).changed = record.changed; pagelist.page (pagelist.page_count).front = record.front; pagelist.page (pagelist.page_count).blank = record.blank; pagelist.page (pagelist.page_count).select, pagelist.page (pagelist.page_count).no_front, pagelist.page (pagelist.page_count).no_back = "0"b; if (record_count > 1) then if (pagelist.page (pagelist.page_count).front = pagelist.page (pagelist.page_count - 1).front) then if pagelist.page (pagelist.page_count).front then pagelist.page (pagelist.page_count - 1) .no_back = "1"b; else pagelist.page (pagelist.page_count).no_front = "1"b; end; end; if dt_sw & filno > 0 then call ioa_ ("pagendx=^i:^i file=^a", pagelist.file (filno).from, pagelist.file (filno).to, pagelist.file (filno).name); call close_compout (); /* close the compout */ end; else file_entry.file = ""; end file_loop_1; %page; if filno = 0 /* no files to process */ then return; filno = 0; /* now, we know everything we need */ file_loop_2: /* so process the files */ do file_entry_ptr = file_entry_base_ptr (1) repeat (file_entry.link) while (file_entry_ptr ^= null ()); filno = filno + 1; /* count a file */ record_count = 1; /* and set up for processing */ pagelist_base = pagelist.file (filno).from - 1; pagelist_last = pagelist.file.to (filno) - pagelist_base; if file_entry.file ^= "" /* if file hasnt been discarded */ then page_select_loop: /* go thru the pages selected */ do ipage = 1 to file_entry.page_sel_ct; /* resetting to !0? */ if (file_entry.from.sign (ipage) = ABS) & (file_entry.from.num (ipage) = 0) then do; record_count = 0; ipage = ipage + 1; goto end_page_select_loop; end; /**/ /* do a page select pair */ do from_to_ptr = addr (file_entry.from (ipage)), addr (file_entry.to (ipage)); if from_to.sign = NEG_REL /* is this a $-n type? */ then do; page_selected = pagelist_last - from_to.num; if (page_selected < 0) then do; call command_query_ (addr (query_info), answer, me, "File ^a: ^a < BOF. Use first page?", file_entry.file, from_to.id); if (answer ^= "yes") then error_sw = "1"b; page_selected = 1; end; end; /**/ /* need to search for page id? */ else if (from_to.sign = SEARCH_ID) then do; page_selected = record_count; do j = record_count + pagelist_base to pagelist_last + pagelist_base while (from_to.id ^= pagelist.id (j)); end; if j > pagelist_last + pagelist_base then do; call com_err_ (0, me, "Page ""^a"" not found in ^a", from_to.id, file_entry.file); error_sw = "1"b; end; else page_selected = j - pagelist_base; end; else do; page_selected = from_to.num; /* is this +n form */ if (from_to.sign = POS_REL) then page_selected = page_selected + record_count; if (page_selected > pagelist_last) then do; call command_query_ (addr (query_info), answer, me, "File ^a: ^a > EOF. Use last page?", file_entry.file, from_to.id); if (answer ^= "yes") then error_sw = "1"b; page_selected = pagelist_last - 1; end; end; from_to.num, record_count = page_selected; from_to.sign = ABS; /* now we know where we are */ end; if (file_entry.from.num (ipage) > file_entry.to.num (ipage)) then do; call command_query_ (addr (query_info), answer, me, "File ^a: from_value ""^a"" (!^i) > to_value ""^a"" (!^i). Do you wish to ignore specification?", file_entry.file, file_entry.from.id (ipage), file_entry.from.num (ipage), file_entry.to.id (ipage), file_entry.to.num (ipage)); if (answer = "no") then error_sw = "1"b; file_entry.to.num (ipage), file_entry.from.num (ipage) = 0; end; if file_entry.pgc /* looking for changed pages? */ then do; /* obverse needs to be handled here, too. */ do page_selected = file_entry.from.num (ipage) + pagelist_base to file_entry.to.num (ipage) + pagelist_base; if pagelist.changed (page_selected) | pagelist.obv_changed (page_selected) then do; pagelist.select (page_selected) = "1"b; file_entry.page_count = file_entry.page_count + 1; end; end; end; else do page_selected = file_entry.from.num (ipage) + pagelist_base to file_entry.to.num (ipage) + pagelist_base; pagelist.select (page_selected) = "1"b; file_entry.page_count = file_entry.page_count + 1; end; end_page_select_loop: end page_select_loop; end file_loop_2; if dt_sw then do; call ioa_ ("START ***"); filno = 0; do file_entry_ptr = file_entry_base_ptr (1) repeat (file_entry.link) while (file_entry_ptr ^= null ()); filno = filno + 1; call ioa_ ("pagendx=^i:^i file=^a", pagelist.file (filno).from, pagelist.file (filno).to, pagelist.file (filno).name); do i = pagelist.file (filno).from to pagelist.file (filno).to; call ioa_ ("^[*^; ^]^5i ""^a""^[ CHANGED^]^[ FRONT^]^[ BLANK^]", pagelist.page (i).select, i, pagelist.page (i).id, pagelist.page (i).changed, pagelist.page (i).front, pagelist.page (i).blank); end; end; end; af_data_ptr = null (); /* give back the seg we borrowed */ if comment_sw | setup_sw then goto finish; if (max_records ^= 0) then max_outrecs = max_records; if (output_medium = PUNCH) then do; call build_contents; if ^table_sw then call ioa_ ("Information to be punched:^/^a", contents); skip_pref_sw = "0"b; if (mode = "punch 6") then do; if debug_sw | display_sw then put_out = put_online; else put_out = put_punch; end; else do; no_handle: call com_err_ (0, me, "Dont know how to handle ""^a""", mode); error_sw = "1"b; end; end; else if (output_medium = TAPE) then do; call build_contents; if ^table_sw then call ioa_ ("^/Contents file:^/^20(-^)^/^a^20(-^)", contents); if contents_seg_sw then begin; dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl get_wdir_ entry () returns (char (168)); dcl seg_p ptr; dcl seg char (length (contents)) based (seg_p); dcl hcs_$truncate_seg entry (ptr, fixed bin (19), fixed bin (35)); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); dcl hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)); call hcs_$make_seg (get_wdir_ (), volid || ".contents", "", 01010b, seg_p, code); if (seg_p = null ()) then call com_err_ (code, me, "^a>^a.contents", get_wdir_ (), volid); else do; call hcs_$truncate_seg (seg_p, divide (length (contents), 4, 19, 0), code); seg = contents; call hcs_$set_bc_seg (seg_p, length (contents) * 9, code); call hcs_$terminate_noname (seg_p, code); end; end; skip_pref_sw = "0"b; vol_file_ct = 0; if debug_sw | display_sw then put_out = put_online; else put_out = put_tape; end; else do; output_medium = ONLINE; if debug_sw | display_sw then put_out = put_online; end; if error_sw then do; call ioa_ ("An error has occurred, no output will be produced."); if dt_sw then signal condition (pco_error); goto finish; end; if (device_cleanup ^= "") & (output_medium = ONLINE) & ^debug_sw & ^display_sw /* cleanup if QUIT during ONLINE */ then on condition (quit) begin; call set_rawo; call iox_$put_chars (iox_$user_output, addrel (addr (device_cleanup), 1), length (device_cleanup), code); call reset_rawo; call continue_to_signal_ (code); end; %page; /* Now all validity checking is done; go thru the list and get all the */ /* pages wanted. */ preface = ""; filno = 1; file_loop_3: do file_entry_ptr = file_entry_base_ptr (1) repeat (file_entry.link) while (file_entry_ptr ^= null ()); if file_entry.file = "" /* if file has been discarded */ then goto end_file_loop_3; if ^open_compout () /* cant open compout? skip it */ then goto end_file_loop_3; if dump_sw & header_sw /* if file is being dumped */ then do; call /* header label */ ioa_ ("^/Record 0 ^i(^o)8 bytes", record_len, record_len); if ^brief_sw then call /* header contents */ dump_segment_ (iox_$user_output, fileheader_ptr, 0, 0, divide (record_len + 3, 4, 17, 0), format); end; if table_sw /* making a table? */ then call ioa_ ("-pathname ^a -pages", file_entry.ename); if display_sw & ^brief_sw /* display header */ then call ioa_ (" ** From file: ^a", file_entry.file); /* if actually writing the file */ if ^(display_sw | dump_sw | table_sw) then if cpwf_sw & fileheader.version < filedata_version_4 then do; call com_err_ (error_table_$unimplemented_version, me, "^/^5x The -cpwf option cant be used with ^a", file_entry.file); goto end_file_loop_3; end; if file_entry.wait /* wait for a NL before starting */ then call sync (begin_file); begin_file: wheel_need = "0"b; reprint_file: pagelist_base = pagelist.file (filno).from - 1; text_pages, record_count, output_text_len = 0; first_pref_sw = "1"b; done, wheel_done = "0"b; ipage = 1; record_loop_2: do while (^done); /* read all records in this file */ if file_entry.from.num (ipage) = 0 then /* if no (more) pages for this file */ do; /* rewind it */ call iox_$position (input_iocbp, BOF, 0, code); goto next_file; end; record_count = record_count + 1;/* count the record */ /* need to be further down file */ if file_entry.from.num (ipage) > record_count then do; record_count = file_entry.from.num (ipage); call iox_$position (input_iocbp, BOF, 0, code); if code = 0 then call iox_$position (input_iocbp, FSPREC, record_count, code); end; if code = 0 then call iox_$read_record (input_iocbp, record_ptr, 262144, record_len, code); if code ^= 0 then do; if code ^= error_table_$end_of_info then call com_err_ (code, me, "Reading ^a", file_entry.file); goto end_file_loop_3; end; if file_entry.pgc & record.changed | ^file_entry.pgc then do; if debug_sw then call ioa_ ("text: record ^i length=^i", record_count, record_len); /**/ /* erase any trailing garbage */ (nostrg): substr (raw_record, record_len + 1, 8) = NULs; reprint: /* calculate record word count */ record_wrdct = divide (record_len + 3, 4, 17, 0); /* adjust for size of record header */ record_hdrct = size (record) - 1; record_wrdct = record_wrdct - record_hdrct; if dump_sw then do; call ioa_ ("^/Record ^i ^i(^o)8 bytes", record_count, record_len, record_len); if ^brief_sw then call dump_segment_ (iox_$user_output, record_ptr, 0, 0, record_hdrct, format); end; start_page_sw, next_image = "1"b; /* start at top of page */ image_loop: do page_record_ptr = addr (record.page_record) repeat (addr (page_record.nextref)) while (next_image ^= "0"b); if (table_sw & debug_sw) | dump_sw then call ioa_ ("^5x^[ HALT^]^[ 2^]^[ 3^]^[ .wt^]^[ preface^]" || "^[ id_preface^]^[ pwhl=^d^] ^i(^o)8 bytes", page_record.halt, page_record.halt2, page_record.halt3, page_record.halt4, page_record.preface, page_record.id_preface, (page_record.pwheel > 0), page_record.pwheel, page_record.leng, page_record.leng) ; page_wrdct = divide (page_record.leng + 3, 4, 17, 0) + 2; record_wrdct = record_wrdct - page_wrdct; if (record_wrdct < 0) then do; call ioa_ ("Record length error, ^i", record_wrdct); record_wrdct = -record_wrdct; end; /* if page_record.pad ^= "0"b /* then call ioa_ ("Record screwed up!");*/ else if dump_sw then call dump_segment_ (iox_$user_output, page_record_ptr, 0, 0, page_wrdct, format); if page_record.pwheel > 0 then substr (wheel_need, page_record.pwheel, 1) = "1"b; if (dump_sw & debug_sw) | ^(table_sw | dump_sw) then do; do_debug_too: if page_record.preface/* is this a preface? */ then do; if first_pref_sw /* first one? */ then if skip_pref_sw /* be sure its skipped */ then preface = page_record.text; /* be sure its used */ else preface = ""; end; /**/ /* an ID preface? */ else if page_record.id_preface then do; if first_pref_sw then goto add_string; end; else first_pref_sw = "0"b; /**/ /* record text or new preface? */ if ^page_record.preface | (page_record.text ^= preface) then do; add_string: /* writing text online? */ if (output_medium = ONLINE) & ^(debug_sw | display_sw) then do; if ^cpwf_sw then do; call set_rawo; /* pwheel change? */ if page_record.pwheel > 0 & page_record.pwheel ^= mounted_wheel then call change_pwheel ((page_record.pwheel)); call /* write the text */ iox_$put_chars (iox_$user_output, addr (page_record.text), (page_record.leng), code); /**/ /* midpage wait? */ if page_record.halt4 then do; call iox_$control (iox_$user_input, "resetread", null (), code); call iox_$get_line (iox_$user_input, addr (stop_bfr), 80, argl, code); end; start_page_sw = "0"b; end; /**/ end; else if display_sw then do; output_text_len = output_text_len + page_record.leng; substr (output_text, output_text_len - page_record.leng + 1, page_record.leng) = page_record.text; end; else do; if start_page_sw /* at top of page? */ then do; start_page_sw = "0"b; /* record limit for this file? */ if text_pages = max_outrecs & max_outrecs > 0 then do; /* have to cleanup? */ if device_cleanup ^= "" & output_medium = ONLINE & ^(debug_sw | display_sw) then do; output_text_len = output_text_len + length (device_cleanup); substr (output_text, output_text_len - length (device_cleanup) + 1, length (device_cleanup)) = device_cleanup; end; call put_out (END); text_pages = 1; output_text_len = 0; end; else text_pages = text_pages + 1; output_text_len = output_text_len + page_record.leng; substr (output_text, output_text_len - page_record.leng + 1, page_record.leng) = page_record.text; end; if output_text_len = 0 then call put_out (BEGIN); end; end; /**** dcls */ if page_record.preface then preface = page_record.text; end; next_image = page_record.nextref; end image_loop; if (text_pages = max_outrecs) /* if record was just filled, ensure */ then first_pref_sw = "1"b; /* that prefix included on next one */ if table_sw | debug_sw then do; this_page = record_count + pagelist_base; if pagelist.no_front (this_page) then call ioa_ ("^-/* blank front not supplied */"); call ioa_ ("^[^/^8i Page: ^;^s^]!^i^-/*^[ BLANK^]^-^[FRONT^]^-" || "^a^[^-CHANGED^] */", debug_sw, record_len, record_count, record.blank, record.front, record.pageid, record.changed); if pagelist.no_back (this_page) then call ioa_ ("^-/* blank back not supplied */"); end; if ^table_sw then if file_entry.stop then do; wait: call sync (reprint); end; if (record_count = file_entry.to.num (ipage)) then do; next_file: ipage = ipage + 1; if (ipage > file_entry.page_sel_ct) then done = "1"b; end; end; /**/ /* assure the left margin */ /**** call iox_$put_chars (iox_$user_output, addr (CR), 1, code);*/ end record_loop_2; /**/ end_file_loop_3: if rawo_sw then call reset_rawo; if output_text_len > 0 /* anything pending on output record */ then do; if (device_cleanup ^= "") & (output_medium = ONLINE) & ^debug_sw & ^display_sw then do; output_text_len = output_text_len + length (device_cleanup); substr (output_text, output_text_len - length (device_cleanup) + 1, length (device_cleanup)) = device_cleanup; end; call put_out (END); end; if ^cpwf_sw then do; substr (wheel_done, mounted_wheel, 1) = "1"b; i = index (wheel_need & ^wheel_done, "1"b); end; /**/ call close_compout (); end file_loop_3; finish: if ^debug_sw & ^display_sw then do; if output_medium ^= ONLINE then call ioa_ ("process_compout: Tape complete."); else call iox_$put_chars (iox_$user_output, addr (CRLF), 2, code); end; call clean; return; %page; af_proc: proc (str) returns (char (500) var); dcl str char (200) var; dcl res char (500) var; dcl setupX char (256) var; dcl (i, j) fixed bin (21); i = search (str, "|["); /* see if any potential AFs */ if (i > 0) & ((output_medium = TAPE) | long_sw) /* and do we even care */ then do; res = ""; /* start out clean */ j = 1; do while (i ^= 0); res = res || substr (str, j, i - 1); /* copy in-between stuff */ j = j + i - 1; /* and skip over it */ if (substr (str, j, 1) = "[") /* is it a valid AF call */ | (substr (str, j, 2) = "|[") | (substr (str, j, 3) = "||[") then do; /* yes, go get it expanded */ call evaluate_af_ (substr (str, j), i2, setupX, code); if (code ^= 0) then do; call com_err_ (code, me, "Evaluating ""^a"".", substr (str, j)); error_sw = "1"b; end; end; else do; /* no, just use up a single char */ setupX = substr (str, j, 1); i2 = 1; end; res = res || setupX; /* add the result to the output */ j = j + i2; i = search (substr (str, j), "|["); /* see if there's another */ if (i = 0) /* if not, copy the rest over */ then res = res || substr (str, j); end; end; else do; err_exit: res = str; end; return (res); end af_proc; %page; build_contents: proc; contents_l = 0; contents = ""; if (setup ^= "") & (^display_sw | long_sw) then contents = contents || setup || CRLF; contents = contents || "Directory of files,"; if (output_medium = TAPE) then contents = contents || " on tape,"; contents = contents || " by file number" || CRLF; contents = contents || " # --- pageids present ---"; if contents_tap_sw then do; contents = contents || CRLF; contents = contents || " 0 <ASCII information file>"; end; contents = contents || CRLF; /* end of contents header */ filno = 0; /* get file contents info */ do file_entry_ptr = file_entry_base_ptr (1) repeat (file_entry.link) while (file_entry_ptr ^= null ()); if (file_entry.file ^= "") then do; record_count = 0; filno = filno + 1; pagelist_base = pagelist.file (filno).from - 1; contents = contents || "Document: "; contents = contents || before (file_entry.ename, ".compout"); contents = contents || CRLF; do ipage = 1 to file_entry.page_sel_ct; do i = file_entry.from.num (ipage) + pagelist_base to file_entry.to.num (ipage) + pagelist_base; if pagelist.select (i) /* want this page? */ then do; if pagelist.no_front (i) then do; contents = contents || " blank front not supplied"; contents = contents || CRLF; end; if (record_count = 0) then do; contents_l = contents_l + 1; contents = contents || convert (toch_ndx, contents_l); end; else contents = contents || " "; record_count = record_count + 1; if (record_count = max_outrecs) then record_count = 0; if pagelist.blank (i) then contents = contents || "BLANK "; else contents = contents || " "; if pagelist.front (i) then contents = contents || "FRONT "; else contents = contents || " "; contents = contents || rtrim (pagelist.id (i)); contents = contents || CRLF; if pagelist.no_back (i) then do; contents = contents || " blank back not supplied"; contents = contents || CRLF; end; end; end; end; end; if debug_sw then do; /* show what has been determined */ call ioa_ ("^3i ^a (^a)", record_count, file_entry.file, file_entry.ename); call ioa_ (" seq=^i count=^i ^[PGC ^]^[OBV ^]^[SP ^]^[WT ^]", file_entry.seq_no, file_entry.page_count, file_entry.pgc, file_entry.obverse, file_entry.stop, file_entry.wait); do i = 1 to file_entry.page_sel_ct; call ioa_ ("^6i fm ""^1a"" ^i ""^a""", i, file_entry.from (i).sign, file_entry.from (i).num, file_entry.from (i).id); call ioa_ ("^6x to ""^1a"" ^i ""^a""", file_entry.to (i).sign, file_entry.to (i).num, file_entry.to (i).id); end; end; end; end build_contents; %page; change_pwheel: proc (wheel); /* PARAMETERS */ dcl wheel fixed bin; /* wheel needed */ /* LOCAL STORAGE */ dcl change_signal char (128); if nobell_sw then change_signal = copy (PADHT, wheel); else change_signal = copy (BELHT, wheel); call iox_$control (iox_$user_input, "resetread", null (), code); call iox_$put_chars (iox_$user_output, addr (change_signal), 2 * wheel, code); call iox_$get_line (iox_$user_input, addr (stop_bfr), 80, 0, code); call iox_$put_chars (iox_$user_output, addr (stop_signal), 5, code); call iox_$get_line (iox_$user_input, addr (stop_bfr), 80, 0, code); end change_pwheel; %page; gather_cons: proc (str, where); dcl str char (*), where char (*) var; dcl (i, j) fixed bin; i = 1; do while (i <= length (str)); end; end gather_cons; %page; /***** PROCESS THE COMMENT STATEMENT IN THE DSM *****/ proc_comment: proc; /**/ /* the Comment statement */ dcl comment char (l_comment) based (comment_ptr); dcl comment_ptr ptr; dcl j fixed bin; /* working index */ dcl mode_list char (256) var; /**/ /* available options */ dcl option (9) char (16) var int static options (constant) init ("mode:", "leader:", "setup:", "pack:", "DB:", "blkhdr:", "blktlr:", "file:", "content_file:"); dcl option_line char (200) var; /* option line from comment */ dcl option_ndx fixed bin; /* option list index */ dcl scan_ndx fixed bin; /* comment string scan index */ /* point to the Comment statement */ l_comment = fileheader.comment_leng; comment_ptr = addr (fileheader.comment); if comment_sw /* just print the Comment? */ then do; call ioa_ ("^/ ** From file ^a^/^a", file_entry.file, before (comment, NL || "DB:")); return; end; if debug_sw then call ioa_ ("^a", rtrim (rtrim (comment), NL)); mode_list = ""; scan_ndx = 1; scan_comment: /* scan comment for option keywords */ do while (scan_ndx < length (comment)); /* run thru option list */ do option_ndx = 1 to hbound (option, 1); if index (substr (comment, scan_ndx), option (option_ndx)) = 1 then do; /* found one; step over the keyword */ scan_ndx = scan_ndx + length (option (option_ndx)); /* extract the option 'value' */ option_line = before (substr (comment, scan_ndx), NL); goto opt_rtn (option_ndx); /* go process the option */ end; end; /**/ /* no (more) options */ if mode_arg = "" /* if taking default mode */ & scan_ndx = 1 /* and first line is not a keyword, */ & index (comment, TAPE) = 1 /* assume its old style */ then do; mode = before (comment, NL); if debug_sw then call ioa_ ("mode(old style)= ^a", mode); end; opt_rtn_end: /* all opt_rtn (*) return here */ /* step over option 'value' */ j = index (substr (comment, scan_ndx), NL); if j = 0 /* if last option */ then scan_ndx = length (comment); else scan_ndx = scan_ndx + j; end scan_comment; if mode = "" /* if no mode after all that */ then do; if mode_arg ^= "" /* if not taking the default mode */ then do; if mode_list = "" /* shoot! none defined in the compout */ then mode_list = "..(file defines NONE)"; /* mode requested not defined */ call /* find out what to do */ com_err_ (0, me, "Mode ""^a"" is not defined in file ^a." || "^/^2xThese are defined: ^a^/^2xUse mode ? to see " || "details of these modes.", before (mode_arg, ":"), file_entry.file, substr (mode_list, 3)); error_sw = "1"b; end; else mode = ONLINE; end; /* if (debug_sw | display_sw) & (display_rtn = "") /* then /* do; /* call com_err_ (0, me, "Display routine not defined in file. ^a", /* file_entry.file); /* error_sw = "1"b; /* end; /**/ /* check zero length record */ if fileheader.recleng = 0 then do; call com_err_ (0, me, "File ^a (device ^a) has recleng = 0.", file_entry.file, fileheader.device); error_sw = "1"b; end; else record_bytes = min (record_bytes, fileheader.recleng); if (output_medium = TAPE) | (output_medium = PUNCH) | display_sw then do; ii = fileheader.max_pages; if (ii = 0) then do; call com_err_ (0, me, "File ^a (device ^a) has max_pages = 0.", file_entry.file, fileheader.device); error_sw = "1"b; end; else max_outrecs = min (max_outrecs, ii); end; return; opt_rtn (1): /* mode: */ dcl temp char (32) var; if mode_sw /* just print the modes? */ then do; call ioa_ ("^a", option_line); goto opt_rtn_end; end; temp = before (option_line, "="); /* copy the 1st mode */ if temp = "" then do; call com_err_ (0, me, "Missing modename in ^a^/^-^a", file_entry.file, option_line); error_sw = "1"b; end; else if ^(display_sw | dump_sw) then do; mode_list = mode_list || ", "; mode_list = mode_list || temp; i = length (temp) + 1; if (mode = "") then do; if (mode_arg = "") | (temp = mode_arg) then do; mode_name = temp; mode_unproc = option_line; mode = af_proc (after (option_line, "=")); output_medium = substr (mode, 1, 4); if debug_sw then call ioa_ ("mode= ^a", mode); end; end; else if (temp = mode_name) & (mode_unproc ^= option_line) then do; call com_err_ (0, me, "Mode mismatch:^/ ^a (^a)^/ ^a (^a)", option_line, file_entry.file, mode_unproc, file_entry_base_ptr (1) -> file_entry.file); error_sw = "1"b; return; end; end; goto opt_rtn_end; /* finished with this case */ opt_rtn (2): /* leader: */ leader = af_proc (option_line); goto opt_rtn_end; /* finished with this case */ opt_rtn (3): /* setup: */ if setup_sw then call ioa_ ("^a", option_line); else if (debug_sw | (output_medium ^= ONLINE) | long_sw) & (file_entry_ptr = file_entry_base_ptr (1)) then do; /* only for first file */ setup = setup || af_proc (option_line); setup = setup || CRLF; end; goto opt_rtn_end; /* finished with this case */ opt_rtn (5): /* DB: */ if debug_sw | display_sw /* either -db or -display was given */ then do; call hcs_$make_ptr (codeptr (here), rtrim (fileheader.device) || ".comp_dsm", rtrim (fileheader.device) || ".dvt", const.dvidptr, code); if code ^= 0 then do; call com_err_ (code, me, "Making a pointer to ^a$^a", rtrim (fileheader.device) || ".comp_dsm", rtrim (fileheader.device) || ".dvt"); error_sw = "1"b; end; const.devptr = pointer (const.dvidptr, comp_dvid.dvt_r); /* call hcs_$make_entry (codeptr (here), /* rtrim (fileheader.device) || "_writer_", "display", /* comp_dvt.displayproc, code); /* if code ^= 0 /* then /* do; /* call com_err_ (code, me, /* "Setting comp_dvt.displayproc to ^a_writer_$display", /* rtrim (fileheader.device)); /* error_sw = "1"b; /* end;*/ /* call hcs_$make_entry (null (), before (display_rtn, "$"), "init", /* init_proc, code); /* if code ^= 0 /* then /* do; /* call com_err_ (code, me, "^a$init", before (display_rtn, "$")); /* error_sw = "1"b; /* end;*/ end; goto opt_rtn_end; /* finished with this case */ opt_rtn (8): /* file: */ if debug_sw | long_sw | (output_medium ^= ONLINE) & ^(display_sw | dump_sw) then do; setup = setup || af_proc (option_line); setup = setup || CRLF; end; goto opt_rtn_end; /* finished with this case */ dcl setting bit (1); opt_rtn (9): /* content_file: */ if ^display_sw & vol_sw then do; i = 1; do while (i < length (option_line)); if (substr (option_line, i, 1) = "^") then do; i = i + 1; setting = "0"b; end; else setting = "1"b; if (substr (option_line, i, 3) = "seg") then do; contents_seg_sw = setting; i = i + 3; end; else if (substr (option_line, i, 4) = TAPE) then do; contents_tap_sw = setting; i = i + 4; end; else do; call com_err_ (0, me, "Invalid content_file option. ^a", option_line); error_sw = "1"b; end; if substr (option_line, i, 1) = "," then i = i + 1; end; end; goto opt_rtn_end; opt_rtn (6): /* blkhdr:*/ call gather_cons (af_proc (option_line), text_cons (1)); goto opt_rtn_end; /* finished with this case */ %skip (5); opt_rtn (7): /* blktlr: */ call gather_cons (af_proc (option_line), text_cons (2)); goto opt_rtn_end; /* finished with this case */ %page; opt_rtn (4): /* pack: */ done = "0"b; option_line = af_proc (option_line); packi = 1; do while (^done); pack_ct = pack_ct + 1; pack.cct (pack_ct) = 0; pack.con (pack_ct) = "0"b; it = index ("""cfb", substr (option_line, packi, 1)); if (it = 0) then do; bad_pack: call com_err_ (0, me, "Syntax error in pack: statement. ^a", file_entry.file); error_sw = "1"b; goto done_pack; end; pack.type (pack_ct) = it; if (it = 1) then do; con_pack: packi = packi + 1; if (substr (option_line, packi, 1) ^= """") then do; pack.cct (pack_ct) = pack.cct (pack_ct) + 1; if (substr (option_line, packi, 01) = "0") then goto con_pack; if (substr (option_line, packi, 1) ^= "1") then goto bad_pack; substr (pack.con (pack_ct), pack.cct (pack_ct), 1) = "1"b; goto con_pack; end; end; else do; packi = packi + 1; pack.cct (pack_ct) = index ("123456789", substr (option_line, packi, 1)); if (pack.cct (pack_ct) = 0) then goto bad_pack; if (it = 4) then pack.cct (pack_ct) = -pack.cct (pack_ct); end; packi = packi + 1; if (substr (option_line, packi, 1) = ";") then do; pack_ct = pack_ct + 1; pack.type (pack_ct) = 5; end; else if (substr (option_line, packi, 1) ^= ",") then goto bad_pack; packi = packi + 1; if (packi > length (option_line)) then done = "1"b; end; j = 0; do packi = 1 to pack_ct; if pack.type (packi) < 3 then j = j + pack.cct (packi); end; if (mod (j, 8) ^= 0) then do; call com_err_ (0, me, "pack: length not a multiple of 8", file_entry.file); error_sw = "1"b; end; done_pack: goto opt_rtn_end; /* finished with this case */ end proc_comment; %page; sync: /* routine to synchronize printing */ proc (redo); /* with user's paper handling */ dcl redo label; /* transfer label */ dcl reprint_sw bit (1); dcl current_modes char (256); reprint_sw = "0"b; wait: call iox_$control (iox_$user_input, "resetread", null (), code); call iox_$modes (iox_$user_output, "rawo,rawi", current_modes, code); if device_cleanup ^= "" then call iox_$put_chars (iox_$user_output, addrel (addr (device_cleanup), 1), length (device_cleanup), code) ; call iox_$put_chars (iox_$user_output, addr (stop_signal), 5, code); call iox_$get_line (iox_$user_input, addr (stop_bfr), 10, argl, code); call iox_$modes (iox_$user_output, current_modes, "", code); if argl > 1 then do; if substr (stop_bfr, 1, 1) = "q" then goto finish; if substr (stop_bfr, 1, 1) = "r" then do; reprint_sw = "1"b; goto wait; end; end; if reprint_sw then goto redo; end sync; %page; /* open a compout file for reading */ open_compout: proc returns (bit (1)); dcl SEQUENTIAL_INPUT fixed bin static options (constant) init (4); dcl STREAM_INPUT fixed bin static options (constant) init (1); dcl error_table_$bad_file fixed bin (35) ext static; dcl error_table_$improper_data_format fixed bin (35) ext static; dcl iox_$get_chars entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); if file_entry.file = "" /* if this file is to be skipped */ then return ("0"b); call /* attach and open the file */ iox_$attach_name ("pco_", input_iocbp, "vfile_ " || file_entry.file, null (), code); if code = 0 then call iox_$open (input_iocbp, SEQUENTIAL_INPUT, "0"b, code); if code ^= 0 then do; /* if not a proper structured file */ if code = error_table_$bad_file then do; /* try to open as a stream file */ call iox_$open (input_iocbp, STREAM_INPUT, "0"b, code); if code = 0 /* opened OK, try to read it */ then do; call iox_$get_chars (input_iocbp, addr (reply_text), length (reply_text), record_len, code); if code = 0 /* read it OK, is it ASCII stuff? */ then do; if verify (substr (reply_text, 1, record_len), collate ()) = 0 then /* yep */ do; call com_err_ (error_table_$improper_data_format, me, "Appears to be a stream file.^/ ^a", file_entry.file); goto err_return; end; end; end; /**/ /* put back what we had */ code = error_table_$bad_file; end; call com_err_ (code, me, "Opening ^a", file_entry.file); goto err_return; end; /**/ /* read file header */ call iox_$read_record (input_iocbp, fileheader_ptr, 8192, record_len, code) ; if code = 0 then do; if fileheader.version >= filedata_version_3 then max_tape_files = max (max_tape_files, fileheader.max_files); else if fileheader.version = filedata_version_4 then page_length = fileheader.page_len; else if fileheader.version ^= filedata_version_2 then code = error_table_$unimplemented_version; end; if code ^= 0 then do; call com_err_ (code, me, "Reading header record.^/ ^a", file_entry.file); err_return: call close_compout (); file_entry.file = ""; /* dont want to consider this again */ return ("0"b); end; file_entry.seq_no = -1; return ("1"b); end open_compout; %page; clean: proc; if rawo_sw then call reset_rawo; af_data_ptr = null (); if (tempsegs (1) ^= null ()) then call release_temp_segments_ (me, tempsegs, code); close_compout: entry; if (input_iocbp ^= null ()) then do; call iox_$close (input_iocbp, code); call iox_$detach_iocb (input_iocbp, code); end; if (tape_iocbp ^= null ()) then do; call iox_$close (tape_iocbp, code); call iox_$detach_iocb (tape_iocbp, code); end; end clean; %page; proc_args: proc; /* process command line args */ /* LOCAL STORAGE */ dcl ename char (32); /* compout entryname */ dcl tp ptr; dcl system_free_p ptr int static init (null ()); dcl e_c fixed bin; dcl e_p ptr; dcl n_p ptr; dcl 1 entries (e_c) aligned based (e_p), 2 type bit (2) unal, 2 nnames fixed bin (15) unal, 2 nindex fixed bin (17) unal; dcl names (3) char (32) based (n_p); dcl error_table_$badopt fixed bin (35) ext static; dcl check_star_name_$entry entry (char (*), fixed bin (35)); dcl get_system_free_area_ entry returns (ptr); dcl hcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35)); /* this initialzation code is here */ /* in precognition of the fact that */ /* proc_args will be called */ /* recursively to process lines from */ /* the yet-to-be-implemented control */ /* file feature */ if (file_entry_base_ptr (1) = null ()) /* file feature */ then file_entry_base_ptr (*), first_p, file_entry_ptr = tempsegs (2); else file_entry_base_ptr (2), first_p, file_entry_ptr = addr (file_entry.next); file_entry.link = null (); file_entry.file = ""; string (file_entry.sws) = "0"b; file_entry.page_sel_ct = 1; file_entry.from.num (1) = 0; file_entry.from.id (1) = ""; file_entry.from.sign (1) = POS_REL; file_entry.to.num (1) = 0; file_entry.to.id (1) = ""; file_entry.to.sign (1) = NEG_REL; string (arg_list.asis) = "0"b; do argno = 1 to argct; /* first process all control args */ if index (arg_list.arg (argno), "-") = 1 then do; next_ctl_arg: /* copy to automatic */ keyword = arg_list.arg (argno); arg_list.arg (argno) = ""; /* erase it, leaving only paths */ if keyword = "-block" /* blocking factor feature */ then do; /* change # pages/file */ if (argno = argct) then goto missing; argno = argno + 1; max_records = convert (max_records, arg_list.arg (argno)); arg_list.arg (argno) = ""; end; /**/ /* brief output feature */ else if keyword = "-brief" | keyword = "-bf" then do; brief_sw = "1"b; long_sw = "0"b; end; /**/ /* printwheel changing feature */ else if keyword = "-change_printwheel_for_file" | keyword = "-cpwf" then cpwf_sw = "1"b; else if keyword = "-change_printwheel_for_pages" | keyword = "-cpwp" then cpwf_sw = "0"b; /**/ /* print Comment: only */ else if keyword = "-comment" then do; comment_sw = "1"b; end; /**/ /* control file feature */ else if keyword = "-control_file" | keyword = "-cf" then do; if argno = argct /* must not be last */ then goto missing; ctl_file_count = ctl_file_count + 1; argno = argno + 1; ctl_file (ctl_file_count) = arg_list.arg (argno); arg_list.arg (argno) = ""; end; /* debugging feature */ else if keyword = "-debug" | keyword = "-db" then do; debug_sw = "1"b; end; /* display mode */ else if keyword = "-display" | keyword = "-ds" then do; display_sw = "1"b; end; /* dump mode */ else if keyword = "-dump" then do; dump_sw = "1"b; end; /* page selection feature */ else if keyword = "-from" | keyword = "-fm" then do; from_to_ptr = addr (file_entry.from (1)); from_to_rtn: if file_entry.page_sel_ct > 1 then do; error_sw = "1"b; call com_err_ (error_table_$inconsistent, me, "^a cannot be mixed with -pages", keyword); end; else do; if (argno = argct) then goto missing; from_to_sw = "1"b; argno = argno + 1; call from_to_proc (1, length (arg_list.arg (argno))); arg_list.arg (argno) = ""; end; end; else if keyword = "-header" | keyword = "-he" then header_sw = "1"b; else if keyword = "-noheader" | keyword = "-nhe" then header_sw = "0"b; else if keyword = "-pathname" | keyword = "-pn" then /* use next arg as name without */ do; /* adding .compout */ if argno = argct /* no path given? */ then goto missing; arg_list.arg (argno) = ""; argno = argno + 1; /* step to path arg */ arg_list.asis (argno) = "1"b; end; else if keyword = "-mode" then do; /* select non-default mode */ if (argno = argct) then goto missing; argno = argno + 1; mode_arg = arg_list.arg (argno); if (mode_arg = "dump") then do; dump_sw = "1"b; mode_arg = ""; end; else if (mode_arg = "display") then do; display_sw = "1"b; mode_arg = ""; end; else if (mode_arg = "comment") then do; comment_sw = "1"b; mode_arg = ""; end; else if (mode_arg = "setup") then do; setup_sw = "1"b; mode_arg = ""; end; else if (mode_arg = "?") then do; mode_sw = "1"b; mode_arg = ""; end; else do; j = (index (mode_arg, " ")); if (j = 0) then mode_arg = arg_list.arg (argno); else mode = substr (mode_arg, 1, j); end; arg_list.arg (argno) = ""; end; else if keyword = "-no_bell" | keyword = "-nob" then nobell_sw = "1"b; else if keyword = "-pages" | keyword = "-pgs" | keyword = "-page" | keyword = "-pg" then do; /* page selection feature */ if from_to_sw then do; error_sw = "1"b; call com_err_ (error_table_$inconsistent, me, "-pages cannot be mixed with -from/-to"); end; else do; if argno = argct /* none left or another ctl arg */ | index (arg_list.arg (argno + 1), "-") = 1 then goto missing; file_entry.page_sel_ct = 0; /* reset count for loop */ pages_loop: argno = argno + 1; /* its another control arg */ if (substr (arg_list.arg (argno), 1, 1) = "-") then goto next_ctl_arg; i = 1; file_entry.page_sel_ct = file_entry.page_sel_ct + 1; l = index (arg_list.arg (argno), ","); if (l = 0) then l = length (arg_list.arg (argno)); else l = l - 1; from_to_ptr = addr (file_entry.from (file_entry.page_sel_ct)); call from_to_proc (i, l); file_entry.to (file_entry.page_sel_ct) = file_entry.from (file_entry.page_sel_ct); i = l + 2; l = length (arg_list.arg (argno)) - i + 1; if (l > 0) then do; from_to_ptr = addr (file_entry.to (file_entry.page_sel_ct)); call from_to_proc (i, l); end; arg_list.arg (argno) = ""; if (argno < argct) then goto pages_loop; end; end; else if keyword = "-pages_changed" | keyword = "-pgc" then do; file_entry.pgc = "1"b; if (argno < argct) then if (substr (arg_list.arg (argno + 1), 1, 1) ^= "-") then do; argno = argno + 1; if (arg_list.arg (argno) = "p") then do; file_entry.obverse = "1"b; call ioa_ ("WARNING: pco does not yet support" || " the obverse option"); end; else if (arg_list.arg (argno) ^= "s") then do; error_sw = "1"b; call com_err_ (error_table_$inconsistent, me, "Object of ^a is not an allowed value. ^a", keyword, arg_list.arg (argno)); end; arg_list.arg (argno) = ""; end; end; else if keyword = "-stop" | keyword = "-sp" then do; if vol_sw then call com_err_ (error_table_$inconsistent, me, "-stop ignored with -volume"); else file_entry.stop, file_entry.wait = "1"b; end; else if keyword = "-volume" then do; if (argno = argct) then do; missing: error_sw = "1"b; call com_err_ (error_table_$inconsistent, me, "Object of ^a missing.", keyword); return; end; argno = argno + 1; if (volid ^= "") then do; call com_err_ (error_table_$inconsistent, me, "^[-volume not allowed in control file" || "^;duplicate -volume specified", (volid = NOVOL)); error_sw = "1"b; end; else do; volid = arg_list.arg (argno); vol_sw = "1"b; end; arg_list.arg (argno) = ""; if file_entry.stop then do; call com_err_ (error_table_$inconsistent, me, "-stop ignored with -volume"); file_entry.stop = "0"b; end; if file_entry.wait then do; call com_err_ (error_table_$inconsistent, me, "-wait ignored with -volume"); file_entry.wait = "0"b; end; if dump_sw then do; call com_err_ (error_table_$inconsistent, me, "-mode dump -volume"); volid = ""; end; if table_sw then do; call com_err_ (error_table_$inconsistent, me, "-table nullifies -volume"); volid = ""; end; end; else if keyword = "-to" /* page selection feature */ then do; from_to_ptr = addr (file_entry.to (1)); goto from_to_rtn; end; else if keyword = "-table" | keyword = "-tb" then do; table_sw = "1"b; end; else if keyword = "-wait" | keyword = "-wt" then do; if vol_sw then call com_err_ (error_table_$inconsistent, me, "-wait ignored with -volume"); else file_entry.wait = "1"b; end; else if keyword = "-lg" | keyword = "-long" then do; brief_sw = "0"b; long_sw = "1"b; end; else do; call com_err_ (error_table_$badopt, me, """^a""", keyword); error_sw = "1"b; end; end; end; /* its a file name */ do argno = 1 to argct; if arg_list.arg (argno) ^= "" then do; call expand_pathname_ ((arg_list.arg (argno)), dname, ename, code); if code ^= 0 then do; call com_err_ (code, me, "Expanding path for ^a", arg_list.arg (argno)); error_sw = "1"b; return; end; if arg_list.asis (argno) then ename = rtrim (ename); else ename = before (rtrim (ename), ".compout") || ".compout"; call check_star_name_$entry (ename, code); /* check for star name */ if code = 0 /* 0 = not a star name */ then call add_linked_file; /* add a new file to the linked list */ else do; if (code > 2) then call com_err_ (code, me, "^a", ename); else do; if (system_free_p = null ()) then system_free_p = get_system_free_area_ (); call hcs_$star_ (dname, ename, 3, system_free_p, e_c, e_p, n_p, code); if (code ^= 0) then call com_err_ (code, me, "^a>^a", dname, ename); else do; do i = 1 to e_c; argct = argct + 1; ename = names (entries (i).nindex); call add_linked_file; end; free entries; free names; end; end; end; end; end; if vol_sw & ^display_sw then contents_seg_sw = "1"b; dcl dname char (168); add_linked_file: proc; given_file_count = given_file_count + 1; if (file_entry.file ^= "") then do; /* next entry */ tp, file_entry.link = addr (file_entry.next); file_entry_ptr = first_p; /* make sure the reference to */ /* file_entry.page_sel_ct in the */ /* next move refers to the one */ /* being moved */ tp -> file_entry = file_entry; /* copy in all control data */ file_entry_ptr = tp; /* point to the new entry */ file_entry.link = null (); /* make sure list ends */ end; file_entry.ename = rtrim (ename); /* record file name */ file_entry.file = rtrim (dname); /* contruct absolute path */ file_entry.file = file_entry.file || ">"; file_entry.file = file_entry.file || file_entry.ename; end add_linked_file; from_to_proc: proc (beg, len); dcl (beg, len) fixed bin; from_to.id = substr (arg_list.arg (argno), beg, len); if (substr (arg_list.arg (argno), beg, len) = "$") then do; from_to.sign = NEG_REL; from_to.num = 0; end; else if (substr (arg_list.arg (argno), beg, 1) = "+") then do; from_to.sign = POS_REL; from_to.num = convert (from_to.num, substr (arg_list.arg (argno), beg + 1, len - 1)); end; else if index (substr (arg_list.arg (argno), beg), "$-") = 1 then do; from_to.sign = NEG_REL; from_to.num = convert (from_to.num, substr (arg_list.arg (argno), beg + 2, len - 2)); end; else if (substr (arg_list.arg (argno), beg, 1) = "!") then do; from_to.sign = ABS; from_to.num = convert (from_to.num, substr (arg_list.arg (argno), beg + 1, len - 1)); end; else do; from_to.sign = SEARCH_ID; from_to.num = 0; end; end from_to_proc; end proc_args; %page; set_rawo: proc; if ^rawo_sw then do; call iox_$modes (iox_$user_output, "rawo", "", code); if code ^= 0 then call com_err_ (code, me, "Setting RAWO mode."); rawo_sw = "1"b; end; end set_rawo; reset_rawo: proc; call iox_$modes (iox_$user_output, "^rawo", "", code); /* leave RAWO mode */ if code ^= 0 then call com_err_ (code, me, "Resetting RAWO mode."); rawo_sw = "0"b; /* dont want clean_ to try again */ end reset_rawo; %page; /* This routine handles writing the device string to tape. */ put_tape: proc (doing); dcl doing fixed bin; /* 1-begin 2-end */ dcl ii fixed bin (24); dcl tp ptr; dcl tl fixed bin (24); dcl atd char (256) var; dcl bp ptr; dcl bl fixed bin (24); dcl bi9 fixed bin; dcl bit9 bit (9); dcl bit36 bit (36) var; dcl 1 bs (10000) based (bp), 2 x bit (1) unal, /* must be "0"b, thrown away */ 2 d bit (8); /* these bits get on tape */ dcl pack_i fixed bin (24); goto func (doing); func (2): if (record_bytes < 1) | (record_bytes > 99999) then do; call com_err_ (0, me, "Not 0<record_bytes<99999. ^a", file_entry.file); goto finish; end; vol_file_ct = vol_file_ct + 1; /* open next file on volume */ bp, tp = page_record_ptr; bl, tl = output_text_len; if (vol_file_ct = 1) & contents_tap_sw /* first file on tape is the */ then do; /* table-of-contents */ bp = addrel (addr (contents), 1); bl = length (contents); end; if (vol_file_ct > max_tape_files) then do; call com_err_ (0, "Limit of ^a files/tape surpassed. ^a", max_tape_files, file_entry.file); goto finish; end; nnn = vol_file_ct; atd = before (mode, " "); atd = atd || " "; atd = atd || volid; atd = atd || after (mode, " "); if (vol_file_ct <= contents_l) then atd = atd || " -retain all"; atd = atd || " -ring -create -number "; atd = atd || nnn; call iox_$attach_name ("pco_tape_", tape_iocbp, (atd), null (), code); if code ^= 0 then do; call com_err_ (code, me, "Attaching pco_tape_ ^a", atd); goto finish; end; call iox_$open (tape_iocbp, 5, "0"b, code); if code ^= 0 then do; call com_err_ (code, me, "Opening volume ""^a"" -number ^a", volid, nnn); error_sw = "1"b; end; else do; if (vol_file_ct > 1 | ^contents_tap_sw) & pack_ct > 0 then do; (nostrg): substr (output_text, output_text_len + 1, 1) = ""; bp = addr (text_c (divide (output_text_len + 4, 4, 24, 0) * 4)); pack_i = 0; bl = 0; bit36 = ""b; do i = 1 to output_text_len, output_text_len + 1 repeat (output_text_len + 1) while (length (bit36) > 0); bit9 = unspec (substr (output_text, i, 1)); bi9 = 1; pkd: pack_i = pack_i + 1; goto pk (pack.type (pack_i)); pk (1): bit36 = bit36 || substr (pack.con (pack_i), 1, pack.cct (pack_i)); goto pkd; pk (2): bit36 = bit36 || substr (bit9, bi9, pack.cct (pack_i)); pk (4): pk (3): bi9 = bi9 + pack.cct (pack_i); goto pkd; pk (5): if (pack_ct = pack_i) then pack_i = 0; do while (length (bit36) >= 8); bl = bl + 1; bs.x (bl) = "0"b; bs.d (bl) = substr (bit36, 1, 8); if (length (bit36) = 8) then bit36 = ""b; else bit36 = substr (bit36, 9); end; end; end; unspec (substr (bp -> output_text, bl + 1, record_bytes)) = "0"b; /* pad out last record */ do ii = 1 to bl by record_bytes; call iox_$write_record (tape_iocbp, addr (bp -> text_c (ii)), record_bytes, code); if code ^= 0 then do; call com_err_ (code, me, "Writing volume ""^a"" -number ^a", volid, nnn); end; end; call iox_$close (tape_iocbp, code); end; call iox_$detach_iocb (tape_iocbp, code); if (vol_file_ct = 1) & contents_tap_sw then do; bp = tp; bl = tl; goto func (2); end; func (1): return; end put_tape; %page; /* This routine handles the punching of 6-level tape on 8-level specially */ /* modified TN300 punch. */ put_punch: proc (doing); dcl doing fixed bin; /* 1-begin 2-end */ dcl i fixed bin (24); goto func (doing); func (2): call letters (" > > " || what || " ?"); output_text_len = output_text_len + 2; substr (output_text, output_text_len - 1, 1) = "?"; substr (output_text, output_text_len, 1) = PCHoff; do i = 1 to divide (output_text_len + 3, 4, 17, 0); word (i) = word (i) | "100100100100"b3; end; call ioa_ ("(Must be on TN300) Turn transparency ON and hit return."); call ioa_ ("When punch stops, turn transparency OFF and hit return."); call iox_$get_line (iox_$user_input, addr (keyword), 10, 0, code); call iox_$modes (iox_$user_output, "rawo", "", code); call iox_$put_chars (iox_$user_output, page_record_ptr, output_text_len, code); call iox_$modes (iox_$user_output, "^rawo", "", code); call iox_$get_line (iox_$user_input, addr (keyword), 10, 0, code); call ioa_ ("Punched ^i characters, ^.3f feet", output_text_len, dec (output_text_len) / 120); return; func (1): substr (output_text, 1, 1) = PCHon; /* put header */ substr (output_text, 2, 1) = "?"; output_text_len = 2; file_entry.seq_no = file_entry.seq_no + 1; what = file_entry.ename; what = what || "-"; what = what || ltrim (char (file_entry.seq_no)); call letters (" "); call letters ((what)); call letters (" > > "); call letters ((leader)); call letters (" "); return; dcl PCHon char (1) static options (constant) init (""); dcl PCHoff char (1) static options (constant) init (""); letters: proc (s); dcl s char (*); dcl (i, j) fixed bin; do i = 1 to length (s); j = index ( "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz1234567890._->~!" , substr (s, i, 1)); if (j > 26) then j = j - 26; output_text_len = output_text_len + length (holes (j)); substr (output_text, output_text_len - length (holes (j)) + 1, length (holes (j))) = holes (j); end; dcl holes (0:42) char (8) var static options (constant) init ("@@@@@", /* */ "@|J|", /* A */ "@~jjT", /* B */ "@\bb", /* C */ "@~b\", /* D */ "@~jj", /* E */ "@~JJ", /* F */ "@\bjz", /* G */ "@~HH~", /* H */ "@b~b", /* I */ "@``~", /* J */ "@~HTb", /* K */ "@~``", /* L */ "@~DHD~", /* M */ "@~DH~", /* N */ "@~bb~", /* O */ "@~JJD", /* P */ "@\bjRl", /* Q */ "@~JJt", /* R */ "@djjR", /* S */ "@BB~BB", /* T */ "@~`~", /* U */ "@^`^", /* V */ "@~`\`~", /* W */ "@bTHTb", /* X */ "@BDxDB", /* Y */ "@rjfb", /* Z */ "@D~", /* 1 */ "@drjd", /* 2 */ "@RbfZ", /* 3 */ "@NH~H", /* 4 */ "@NjjR", /* 5 */ "@\jjX", /* 6 */ "@BrJF", /* 7 */ "@TjjT", /* 8 */ "@Djj\", /* 9 */ "@\bb\", /* 0 */ "@pp", /* . */ "@````", /* _ */ "@HHHH", /* - */ "@H\~", /* > */ "Wq", /* noFLASH */ "WM"); /* FLASH */ end letters; end put_punch; dcl what char (44) var; /* name of what is being worked on */ %page; /* This routine handles the -db/-display output of the device string. */ put_online: proc (doing); dcl doing fixed bin; /* 1-begin, 2-end */ dcl db_displ_str char (4096) var; /* the interpreted string */ dcl dlen fixed bin; dcl (i, j) fixed bin (24); dcl iblk fixed bin (24); dcl 1 delay internal static aligned, 2 version fixed bin init (1), 2 default fixed bin, 2 values like input_delays; dcl ESC char (1) static options (constant) init (""); dcl 1 input_delays aligned, /* supplied values for delay setting */ 2 vert_nl fixed bin, 2 horz_nl float bin, 2 const_tab fixed bin, 2 var_tab float bin, 2 backspace fixed bin, 2 vt_ff fixed bin; dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); dcl iox_$user_io ptr ext static; if doing = END then do; if iox_$user_output = iox_$user_io then do; call iox_$control (iox_$user_output, "get_delay", addr (delay), code); input_delays = delay.values; delay.horz_nl = 0.3; call iox_$control (iox_$user_output, "set_delay", addr (delay), code); delay.values = input_delays;/* restore for return */ on cleanup call iox_$control (iox_$user_output, "set_delay", addr (delay), code); end; /* call ioa_ ("^/ **** FILE #^i ****^/", filno);*/ filno = filno + 1; i = 1; do while (i <= output_text_len);/* run thru the output record */ /* grab a chunk */ dlen = min (output_text_len - i + 1, 2000); if dlen = 2000 /* dont split ESC sequences */ then do; j = index (reverse (substr (output_text, i, 2000)), ESC); dlen = dlen - j; end; db_displ_str = comp_util_$display (substr (output_text, i, dlen), dlen, "1"b); call iox_$put_chars (iox_$user_output, addr (substr (db_displ_str, 1)), length (db_displ_str), code); if code ^= 0 then do; call com_err_ (code, me, "Writing display output."); if iox_$user_output = iox_$user_io then call iox_$control (iox_$user_output, "set_delay", addr (delay), code); return; end; i = i + dlen; end; if iox_$user_output = iox_$user_io then call iox_$control (iox_$user_output, "set_delay", addr (delay), code); end; end put_online; %page; /* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */ /* ACTIVE FUNCTION ENTRIES */ compout: entry; call cu_$af_return_arg (nargs, ret_p, ret_l, code); if (code = 0) then err_out = active_fnc_err_; else do; err_out = com_err_; ret_p = null (); end; if af_data_ptr = null () then do; call err_out (error_table_$out_of_sequence, "compout"); return; end; if (ret_p = null ()) then call ioa_ ("^a", af_data.compout); else ret_v = af_data.compout; return; compask: entry; call cu_$af_return_arg (nargs, ret_p, ret_l, code); if (code = 0) then do; err_out = active_fnc_err_; end; else do; err_out = com_err_; ret_p = null (); end; if af_data_ptr = null () then do; call err_out (error_table_$out_of_sequence, "compask"); return; end; do argno = 2 to nargs; call cu_$arg_ptr (argno, argp, argl, code); i = index (arg, "="); if (i = 0) then valid_in (argno), valid_out (argno) = arg; else do; valid_in (argno) = before (arg, "="); valid_out (argno) = after (arg, "="); end; end; call cu_$arg_ptr (1, argp, argl, code); if (code ^= 0) then do; call err_out (code, "compask"); return; end; default_ans = ""; do j = af_data.count to 1 by -1; if (arg = af_data.quest (j)) then do; default_ans = af_data.ans (j); j = 0; end; end; query_info.yes_or_no_sw = "0"b; query_info.suppress_name_sw = "1"b; re_ask: call ioa_$nnl ("^a (^a) ", arg, default_ans); re_get: call iox_$get_line (iox_$user_input, addr (reply_text), length (reply_text), reply_l, code); if (code = error_table_$end_of_info)/* in case called in an exec_com */ then goto re_get; compans = substr (reply_text, 1, reply_l - 1); new_sw = "0"b; if (compans = ".") then valid_in (1), valid_out (1) = ""; else if (compans = "") then valid_in (1), valid_out (1) = default_ans; else do; valid_in (1), valid_out (1) = compans; new_sw = "1"b; end; if nargs > 1 then do; do argno = 2 to nargs; if (valid_in (argno) = valid_in (1)) then do; valid_out (1) = valid_out (argno); goto found_reply; end; end; call ioa_ ("Please answer ^a^(, ^a^).", valid_list); goto re_ask; found_reply: end; compans = valid_out (1); query_info.yes_or_no_sw = "1"b; query_info.suppress_name_sw = "0"b; if new_sw then do; af_data.count = af_data.count + 1; af_data.quest (af_data.count) = arg; af_data.ans (af_data.count) = valid_in (1); end; if (ret_p = null ()) then call ioa_ ("^a", compans); else do; if (index (compans, " ") = 0) then ret_v = compans; else ret_v = """" || compans || """"; end; return; dcl dt_sw bit (1) int static init ("0"b); dtn: entry; dt_sw = "1"b; return; dtf: entry; dt_sw = "0"b; return; evaluate_af_: proc (in_str, in_used, out_str, code); dcl in_str char (*), /* str which begins with AF [IN] */ in_used fixed bin (21), /* amount of in_str used up [OUT] */ out_str char (*) var, /* result of expansion [OUT] */ code fixed bin (35); /* return code [OUT] */ if (substr (in_str, 1, 1) = "[") then af_type = 1; else if (substr (in_str, 1, 2) = "|[") then af_type = 2; else if (substr (in_str, 1, 3) = "||[") then af_type = 3; else goto brack; nest = 1; in_used = af_type + 1; keep_on: i = search (substr (in_str, in_used), """[]"); if (i = 0) then do; brack: code = error_table_$unbalanced_brackets; return; end; in_used = in_used + i; ch = substr (in_str, in_used - 1, 1); if (ch = """") then do; i = index (substr (in_str, in_used), """"); if (i = 0) then do; code = error_table_$unbalanced_quotes; return; end; in_used = in_used + i; goto keep_on; end; if (ch = "[") then do; nest = nest + 1; goto keep_on; end; if (ch = "]") then do; nest = nest - 1; if (nest > 0) then goto keep_on; end; in_used = in_used - 1; call cu_$evaluate_active_string (null (), substr (in_str, af_type + 1, in_used - af_type - 1), af_type, out_str, code); dcl af_type fixed bin; dcl nest fixed bin; dcl i fixed bin; dcl ch char (1); dcl cu_$evaluate_active_string entry (ptr, char (*), fixed bin, char (*) var, fixed bin (35)); dcl error_table_$unbalanced_brackets fixed bin (35) ext static; dcl error_table_$unbalanced_quotes fixed bin (35) ext static; end evaluate_af_; %page; dcl compans char (200) var; dcl default_ans char (200) var; dcl cu_$af_arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl err_out entry options (variable) automatic; dcl active_fnc_err_ entry () options (variable); dcl error_table_$out_of_sequence fixed bin (35) ext static; dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl nargs fixed bin; dcl new_sw bit (1); dcl reply_l fixed bin (21); dcl ret_p ptr; dcl ret_l fixed bin (21); dcl ret_v char (ret_l) var based (ret_p); %page; /* * Temp segment usage: */ /* * record_ptr -> record read from input file */ /* * | */ /* * (1) v___________________________________________~ */ /* * */ /* * file_entry_ptr header_out_ptr page_record_ptr */ /* * | | | | */ /* * (2) v______v____________v______________v_________~ */ /* * */ /* * contents_ptr */ /* * | */ /* * (3) v___________________________________________~ */ /* * */ /* * pagelist_ptr */ /* * | */ /* * (4) v___________________________________________~ */ /* * */ /* LOCAL STORAGE */ dcl text_c (output_text_len) char (1) based (page_record_ptr); /* (magtape/papertape) */ dcl file_seq_no fixed bin; dcl first_p ptr; dcl format bit (11) static options (constant) init ("10001"b); /* control for dump_segment_ */ dcl (i, l) fixed bin; /* working index */ dcl i2 fixed bin (21); dcl it fixed bin (24); dcl mode_unproc char (200) var; /* the current mode sans af_proc */ dcl mode_name char (32) var; dcl nnn pic "999"; dcl NL char (1) int static options (constant) init (" "); dcl NULs char (8) static options (constant) init (""); dcl packi fixed bin; dcl stop_bfr char (80); /* buffer to hold users -stop */ /* option response */ /* OR the .wt input */ dcl str char (262144) based; dcl this_page fixed bin; dcl valid_in (15) char (64) var; dcl valid_list (nargs - 1) char (64) var based (addr (valid_in (2))); dcl valid_out (15) char (64) var; dcl word (2000) bit (36) based (page_record_ptr); dcl 1 pack (40), 2 cct fixed bin, /* number of bits in use */ 2 con bit (27) unal, /* constant */ 2 type fixed bin (8) unal; /* 1-literal 2-fwd 3-copy 4-bwd */ dcl toch_ndx pic "zzz9bb"; dcl CRLF char (2) static options (constant) init (" "); dcl error_table_$inconsistent fixed bin (35) ext static; dcl hcs_$make_entry entry (ptr, char (*), char (*), entry, fixed bin (35)); dcl iox_$control entry (ptr, char (*), ptr, fixed (35)); dcl iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl iox_$modes entry (ptr, char (*), char (*), fixed (35)); dcl iox_$position entry options (variable); dcl iox_$write_record entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); %include comp_dvid; %include comp_dvt; %include comp_entries; %include comp_fntstk; %include comp_output; %include comp_page; %include comp_shared; %include comp_text; %include compstat; %include query_info_; end process_compout;  xdw_.pl1 04/23/85 1100.9rew 04/23/85 0911.6 1035549 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * * *********************************************************** */ /* format: style2,ind3,ll80,dclind4,idind16,comcol41,linecom */ /* FUTURE &fileout name ... &filend */ xdw_: macro_: proc (sl_name, segname, macname, out_ptr, out_len, arglp, argct, msg, refseg, ecode); segtype = "MACRO"; if (sl_name = "macro") then who_am_i = "MACRO"; else who_am_i = "EXPANSION"; mac_sw = "1"b; segptr = null (); refp = refseg; goto start; expand: entry (sl_name, segname, macname, out_ptr, out_len, arglp, argct, msg, strptr, strlen, ecode); if (segname = "") then segtype = "STRING"; else segtype = "SEGMENT"; myname = "source " || segtype; mac_sw = "0"b; refp = null (); segptr = strptr; segi = 1; sege = strlen; goto start; dcl sl_name char (32) var,/* search list name */ segname char (32) var,/* name of segment to find */ /* "" -> not specified */ macname char (32) var,/* name of macro to expand */ /* "" -> expanding a string */ out_ptr ptr, /* output string (not aligned) */ out_len fixed bin (24), /* length of output produced (Out) */ arglp ptr, /* pointer to argument list */ argct fixed bin, /* number of arguments */ msg char (1000) var, /* error message text */ refseg ptr, /* pointer to referencing segment */ strptr ptr, /* pointer to string to expand */ strlen fixed bin (24), /* length of string to expand */ ecode fixed bin (35); dcl 1 argl (24) based (arglp), 2 p ptr, 2 l fixed bin (24); dcl arg char (argl.l (num)) based (argl.p (num)); dcl num fixed bin (24); dcl refp ptr; start: if free_area_p = null () then call get_area; local_var_ptr, int_var_ptr = null (); msg_etc = ""; do num = 1 to argct; if (argl.l (num) < 0) then signal condition (argleng_less_than_zero); if (argl.l (num) > 500) then do; msg = "ARG "; msg = msg || ltrim (char (num)); msg = msg || " >500 characters."; ecode = -1; return; end; end; msg = ""; ecode = 0; macro_nest = macro_nest + 1; save_db = db_sw; if (segtype = "STRING") | (segptr ^= null ()) then goto doit; /* name = "macro" | "foo$foo" | "foo$bar" */ if mac_sw then do; c32 = segname; if (c32 = "") then do; if db_sw then call ioa_ (""""" ^a", macname); myname = macname; do maclp = macro_list_p repeat (macro_list.next) while (maclp ^= null ()); if macro_list.int_mac then do; if db_sw then call ioa_ (" ^a/^a", substr (macro_list.dname, 1, 1), macro_list.name); if (macro_list.name = macname) then do; segptr = macro_list.ref; segi = macro_list.from; sege = macro_list.to; goto doit; end; end; end; c32 = macname; /* didn't find an imbedded macro by */ end; /* this name, try for macro$macro. */ if db_sw then call ioa_ ("^a$^a", c32, macname); myname = c32; myname = myname || "$"; myname = myname || macname; do maclp = macro_list_p repeat (macro_list.next) while (maclp ^= null ()); if ^macro_list.int_mac then do; if db_sw then call ioa_ (" ^a/^a", macro_list.ename, macro_list.name); if (macro_list.ename = c32) & (macro_list.name = macname) then do; segptr = macro_list.ref; segi = macro_list.from; sege = macro_list.to; goto doit; end; end; end; end; call find_macro (refp, segname, sl_name, macname); doit: tr_sw = "0"b; if (substr (segment, segi, 7) = "&trace ") then do; segi = segi + 7; tr_sw = "1"b; end; if (substr (segment, segi, 7) = "&debug ") then do; segi = segi + 7; db_sw = "1"b; end; if db_sw | pc_sw | tr_sw | al_sw then do; call ioa_ ("^[EXPAND^s^;^a^](^i) ^a", (who_am_i = "EXPANSION"), segtype, macro_nest, macname); do num = 1 to argct; call ioa_ ("ARG^2i: ""^va""", num, argl.l (num), arg); end; if (argct = 0) then call ioa_ ("ARGs: none"); end; construct_nest = 1; call_err = "0"b; call expand (segptr, segi, sege, out_ptr, out_len, "11"b); quit: if db_sw | pc_sw | tr_sw | al_sw then call ioa_ (" ^[MEND^;EXPEND^](^i) ^a", (who_am_i = "MACRO"), macro_nest, macname); if (segi < sege) then do; misplaced: msg = "Misplaced """; msg = msg || c32; msg = msg || """. "; add_identification: ecode = error_table_$badsyntax; add_id: if call_err then msg = msg || " from"; if segtype = "MACRO" then do; msg = msg || " "; msg = msg || who_am_i; end; msg = msg || " """; msg = msg || myname; msg = msg || """, line "; msg = msg || lineno (segi); if ^call_err then do; msg = " ERROR SEVERITY 4. " || msg; if (msg_etc ^= "") then do; msg = msg || NL; msg = msg || msg_etc; end; end; end; exit: macro_nest = macro_nest - 1; tptr = local_var_ptr; call free_um ("loc"); if (err_ct (3) ^= 0) & (err_ct (4) = 0) then ecode = error_table_$translation_failed; db_sw = save_db; return; syntax_err: msg = "Syntax error in " || msg; msg = msg || ". "; goto add_identification; %page; /* -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- */ /* */ /* add a macro to the list of known macros */ addmacro: proc (dname, segname, macname, int_mac, segp, segi, sege); dcl dname char (168), segname char (32) var, macname char (32) var, int_mac bit (1), /* 1- is &macro/&define */ segp ptr, segi fixed bin (24), sege fixed bin (24); if db_sw then call ioa_ ("addmacro ^a > ^a (^p) ^a^[ INTERNAL^]", dname, segname, segp, macname, int_mac); do maclp = macro_list_p repeat (macro_list.next) while (maclp ^= null ()); if (macro_list.ename = segname) & (macro_list.name = macname) & (macro_list.int_mac = int_mac) then do; if (segptr = macro_list.ref) & (segi = macro_list.from) & (sege = macro_list.to) then do; if db_sw then call ioa_ (" already there"); return; end; msg = who_am_i; msg = msg || " already defined."; goto add_identification; end; end; allocate macro_list in (free_area); if al_sw then call ioa_ ("A macro_list ^i ^p", size (macro_list), maclp); macro_list.name = macname; macro_list.ref = segp; macro_list.dname = dname; macro_list.ename = segname; macro_list.from = segi; macro_list.to = sege; macro_list.int_mac = int_mac; macro_list.next = macro_list_p; macro_list_p = maclp; if db_sw then call ioa_ ("addmac ^16a ^p ^i:^i^/^-^a > ^a", macro_list.name, macro_list.ref, macro_list.from, macro_list.to, macro_list.dname, macro_list.ename); end addmacro; %page; /* -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- */ /* */ /* An ampersand has been found, handle it. */ ampersand: proc (ifp, ifi, ife, ofp, ofe, TF, err_sw) recursive; dcl ifp ptr, /* pointer to input */ ifi fixed bin (24), /* first char of input to use */ ife fixed bin (24), /* last char of input to use */ ofp ptr, /* pointer to output */ ofe fixed bin (24), /* last char of output used */ TF bit (2), err_sw bit (1); /* 0- misplaced are error */ /* 1- misplaced no sweat */ dcl begl fixed bin (24); dcl inputa (ife) char (1) based (ifp); dcl input char (ife) based (ifp); dcl output char (1044480) based (ofp); dcl (i, j, ii, jj) fixed bin (24); begl = ifi; if db_sw then call dumper ("ampr", ifp, ifi, ife, ofp, ofe, TF); if (ifi >= ife) then do; msg = "Orphan &."; goto add_identification; end; i = index ("0123456789", inputa (ifi + 1)); if (i ^= 0) then do; num = i - 1; i = index ("0123456789", inputa (ifi + 2)); if (i ^= 0) then do; num = num * 10 + i - 1; ifi = ifi + 1; end; ifi = ifi + 2; if (num <= argct) then do; substr (output, ofe + 1, argl.l (num)) = arg; ofe = ofe + argl.l (num); end; end; else do; ch_2nd = inputa (ifi + 1); if (ch_2nd = "{") then call arg_range (ifp, ifi, ife, ofp, ofe, TF); else if (ch_2nd = "*") then do; ifi = ifi + 2; c32 = ltrim (char (argct)); substr (output, ofe + 1, length (c32)) = c32; ofe = ofe + length (c32); end; else if (ch_2nd = ".") /* &. null separator */ then ifi = ifi + 2; else if (ch_2nd = "+") /* &+ null separator, */ then call strip2 (ifp, ifi, ife); /* grabs trailing space */ else if (ch_2nd = "[") then call macro_af (ifp, ifi, ife, ofp, ofe, TF); else if (ch_2nd = "(") then call arithmetic (ifp, ifi, ife, ofp, ofe, TF); else if (ch_2nd = """") then call protected (ifp, ifi, ife, ofp, ofe); else if (ch_2nd = ";") then do; c32 = "&;"; return; end; else if (ch_2nd = "&") then do; substr (output, out_len + 1, 1) = "&"; out_len = out_len + 1; ifi = ifi + 2; end; else do; variable: i = verify (substr (input, ifi + 1), token_chars); if (i = 0) then i = ife - ifi + 1; if (i > 1) then do; if (i > 26) then do; msg = who_am_i; msg = msg || " name > 26 chars."; goto add_identification; end; c32 = substr (input, ifi + 1, i - 1); c32x = ""; if (inputa (ifi + i) = "$") then do; ifi = ifi + i; ii = verify (substr (input, ifi + 1), token_chars) ; if (ii = 0) then i = 0; /* error */ else if (inputa (ifi + ii) = "(") then do; i = ii; c32x = c32; c32 = substr (input, ifi + 1, i - 1); end; end; if (inputa (ifi + i) = "(") & (ife > ifi + i) then do; ifi = ifi + i + 1; call macro_call (ifp, ifi, ife, ofp, ofe, TF); end; else if (inputa (ifi + i) = "{") & (ife > ifi + i) then do; ifi = ifi + i + 1; call var_range (ifp, ifi, ife, ofp, ofe, TF); end; /* arg */ else if (c32 = "lbound") then call var_bound (ifp, ifi, ife, ofp, ofe, TF); else if (c32 = "hbound") then call var_bound (ifp, ifi, ife, ofp, ofe, TF); else if (c32 = "empty") then call macro_empty (ifp, ifi, ife, ofp, ofe, TF); else if (c32 = "error") then call macro_error (ifp, ifi, ife, ofp, ofe, TF); else if (c32 = "comment") then do; i = index (substr (input, ifi), "&;"); if (i = 0) then do; msg = "&;"; call error_missing ("comment", begl, ife); end; ifi = ifi + i + 1; return; end; else if (c32 = "usage") then call macro_usage (ifp, ifi, ife, ofp, ofe, TF); else if (c32 = "quote") then call macro_quote (ifp, ifi, ife, ofp, ofe, TF); else if (c32 = "unquote") then call macro_unquote (ifp, ifi, ife, ofp, ofe, TF); else if (c32 = "return") then do; segi = sege + 1; goto quit; end; else if (c32 = "scan") then call macro_scan (ifp, ifi, ife, ofp, ofe, TF); else if (c32 = "define") then call macro_define (ifp, ifi, ife, ofp, ofe, TF); else if (c32 = "substr") then call macro_substr (ifp, ifi, ife, ofp, ofe, TF); else if (c32 = "length") then call macro_length (ifp, ifi, ife, ofp, ofe, TF); else if (c32 = "let") then call macro_let (ifp, ifi, ife, ofp, ofe, TF, 0); else if (c32 = "ext") then call macro_let (ifp, ifi, ife, ofp, ofe, TF, 1); else if (c32 = "int") then call macro_let (ifp, ifi, ife, ofp, ofe, TF, 2); else if (c32 = "loc") then call macro_let (ifp, ifi, ife, ofp, ofe, TF, 3); else if (c32 = "do") then call macro_do (ifp, ifi, ife, ofp, ofe, TF); else if (c32 = "if") then call macro_if (ifp, ifi, ife, ofp, ofe, TF); else if (c32 = "od") | (c32 = "fi") | (c32 = "then") | (c32 = "else") | (c32 = "elseif") | (c32 = "while") then do; c32 = "&" || c32; if ^err_sw then goto misplaced; return; end; else if (c32 = "expand") then do; start_sym = "expand"; end_sym = "expend"; goto macdef; end; else if (c32 = "macro") then do; start_sym = "macro"; end_sym = "mend"; macdef: if construct_nest > 1 then do; macnest_err: msg = "&"; msg = msg || start_sym; msg = msg || " may not be nested in any other construct." ; goto add_id; end; ifi = ifi + i; if (substr (input, ifi, 1) ^= " ") then do; macdef_err: call error_syntax ((start_sym), begl, ifi); end; ifi = ifi + 1; i = verify (substr (input, ifi), "abcdefghijklmnopqrstuvwxyz" || "ABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789"); if (i = 0) then goto macdef_err; if (i < 2) then do; msg = "name"; call error_missing ((start_sym), begl, ifi); end; i = i - 1; c32 = substr (input, ifi, i); ifi = ifi + i; if (inputa (ifi) ^= NL) then goto macdef_err; ifi = ifi + 1; i = index (substr (input, ifi), "&" || end_sym || " "); if (i = 0) then do; no_mend: msg = "&"; msg = msg || end_sym; msg = msg || "<NL>"; call error_missing ((start_sym), begl, ife); end; if (index (substr (input, ifi, i - 1), "&macro ") ^= 0) | ( index (substr (input, ifi, i - 1), "&expand ") ^= 0) then goto no_mend; call hcs_$fs_get_path_name (ifp, dname, 0, ename, 0); call addmacro (" &" || start_sym || " in " || myname, "", c32, "1"b, ifp, ifi, ifi + i - 2); ifi = ifi + i + length (end_sym) + 1; end; else do; call var_ref (ifp, ifi, ife, ofp, ofe, TF); ifi = ifi + i; end; end; else do; msg = "Unrecognized &control """; msg = msg || c32; msg = msg || """. "; goto add_identification; end; end; end; end ampersand; %page; /* -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- */ /* */ /* parse an argument range specification. */ arg_range: proc (ifp, ifi, ife, ofp, ofe, TF); dcl ifp ptr, /* pointer to input */ ifi fixed bin (24), /* first char of input to use */ ife fixed bin (24), /* last char of input to use */ ofp ptr, /* pointer to output */ ofe fixed bin (24), /* last char of output used */ TF bit (2); dcl begl fixed bin (24); dcl inputa (ife) char (1) based (ifp); dcl input char (ife) based (ifp); dcl output char (1044480) based (ofp); dcl (i, j, ii, jj) fixed bin (24); dcl separator char (150) var; /* &{ ARITH } yields argument ARITH */ /* &{ ARITH : ARITH } yields arguments ARITH thru ARITH */ /* separated by a SP */ /* &{ ARITH : ARITH , STRING } yields arguments ARITH thru ARITH */ /* separated by STRING */ begl = ifi; ii = ofe; i = 1; j = argct; call get_range (ifp, ifi, ife, ofp, ofe, TF, i, j); separator = " "; if (inputa (ifi) = ",") then do; ifi = ifi + 1; do while ("1"b); jj = search (substr (input, ifi), "&}"); if (jj = 0) then do; msg = "}"; call error_missing ("{", begl, ife); end; if (jj > 1) then do; jj = jj - 1; substr (output, ofe + 1, jj) = substr (input, ifi, jj); ifi = ifi + jj; ofe = ofe + jj; end; if (inputa (ifi) = "}") then do; separator = substr (output, ii + 1, ofe - ii); ofe = ii; goto end_range; end; call ampersand (ifp, ifi, ife, ofp, ofe, TF, "0"b); end; end; if (inputa (ifi) = "}") then do; end_range: ifi = ifi + 1; if (TF = "00"b) then return; j = min (j, argct); do num = i to j; substr (output, ofe + 1, argl.l (num)) = arg; ofe = ofe + argl.l (num); if (num ^= j) then do; substr (output, ofe + 1, length (separator)) = separator; ofe = ofe + length (separator); end; end; end; else do; call error_syntax ("{", begl, ifi); end; end arg_range; %page; /* -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- */ /* */ /* process an arithmetic expression. */ arithmetic: proc (ifp, ifi, ife, ofp, ofe, TF); dcl ifp ptr, /* pointer to input */ ifi fixed bin (24), /* first char of input to use */ ife fixed bin (24), /* last char of input to use */ ofp ptr, /* pointer to output */ ofe fixed bin (24), /* last char of output used */ TF bit (2); dcl begl fixed bin (24); dcl inputa (ife) char (1) based (ifp); dcl input char (ife) based (ifp); dcl output char (1044480) based (ofp); dcl (i, j, ii, jj) fixed bin (24); dcl level fixed bin (24); dcl (vl, sl) fixed bin (24); dcl val (20) fixed dec (59, 9); dcl stk (20) fixed bin (24); dcl pic60 pic "(49)-9v.(9)9"; dcl ch60 char (60) var; dcl v fixed dec (59, 9); ifi, begl = ifi + 2; if db_sw then call dumper ("arth", ifp, ifi, ife, ofp, ofe, TF); ii = ofe; substr (output, ofe + 1, 1) = "("; ofe = ofe + 1; level = 1; construct_nest = construct_nest + 1; loop: i = search (substr (input, ifi), "&(),:}"); if (i = 0) then do; msg = "Missing arithmetic terminator. "; goto add_identification; end; if (i > 1) then do; i = i - 1; substr (output, ofe + 1, i) = substr (input, ifi, i); ofe = ofe + i; ifi = ifi + i; end; goto type (index ("&(),:}", inputa (ifi))); type (1): /* & */ /* */ if (substr (input, ifi, 2) = "&;") then goto type (4); /* It stops scan, but is not used up */ call ampersand (ifp, ifi, ife, ofp, ofe, TF, "0"b); goto loop; type (2): /* ( */ /* */ substr (output, ofe + 1, 1) = "("; ofe = ofe + 1; level = level + 1; ifi = ifi + 1; goto loop; type (4): /* , */ /* */ type (5): /* : */ /* */ type (6): /* } */ /* */ if (level > 1) then goto arith_err; ifi = ifi - 1; /* don't want to use up this char */ type (3): /* ) */ /* */ substr (output, ofe + 1, 1) = ")"; ofe = ofe + 1; ifi = ifi + 1; level = level - 1; if (level > 0) then goto loop; construct_nest = construct_nest - 1; if (TF = "00"b) then do; ofe = ii; return; end; sl = 1; vl = 0; stk (1) = 16; if db_sw | tr_sw then do; call ioa_$nnl ("#^a:^a^-arith ", lineno (begl), lineno (ifi - 1)); call show_string (substr (output, ii + 1, ofe - ii), " "); end; do i = ii + 1 to ofe; /**** format: off */ /* "---------1111111111222222 22 2 */ /* "---------0123456789012345 67 8 */ dcl arithchar char (28) int static init ("0123456789(=^=<=>=+-*/) ."" "); /**** format: on */ j = index (arithchar, substr (output, i, 1)); if (j = 0) then do; jj = verify (substr (output, i), "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789" ); if (jj = 0) then jj = ife - ifi + 1; if (jj = 1) then goto arith_err; goto arith_err; end; retry: if lg_sw then if db_sw then do; call ioa_ ("^3i :^1a:", i, substr (output, i, 1)); do jj = 1 to sl; call ioa_$nnl (" ^1a", substr (arithchar, stk (jj), 1)); end; call ioa_ ("."); do jj = 1 to vl; call ioa_$nnl (" ^f", val (jj)); end; call ioa_ ("#"); end; if (j > 10) then goto type (j); type (26): /* decimal point */ jj = verify (substr (output, i), ".0123456789") - 1; if (jj = 0) then jj = ife - ifi + 1; vl = vl + 1; val (vl) = convert (val (1), substr (output, i, jj)); sl = sl + 1; stk (sl) = 10; i = i + jj - 1; goto endloop; type (23): /* ) */ /* */ if (stk (sl) ^= 10) then goto arith_err; goto calc (stk (sl - 1)); type (13): /* ^ */ /* */ type (15): /* < */ /* */ type (17): /* > */ /* */ if (substr (output, i + 1, 1) = "=") then do; i = i + 1; j = j + 1; end; if (j = 13) then goto type (11); type (14): /* ^= */ /* */ type (16): /* <= */ /* */ type (18): /* >= */ /* */ type (12): /* = */ /* */ type (21): /* * */ /* */ type (22): /* / */ /* */ if (stk (sl) ^= 10) then do; type (27): /* quoted string not handled yet */ arith_err: msg = "Arithmetic syntax error. "; msg = msg || substr (arithchar, stk (sl), 1); msg = msg || substr (arithchar, j, 1); msg = msg || " """; msg = msg || substr (output, ii + 1, i - ii); msg = msg || """ "; goto add_identification; end; type (19): /* + */ /* */ type (20): /* - */ /* */ if (stk (sl) = 21) then goto arith_err; if (stk (sl) = 22) then goto arith_err; if (stk (sl) > 10) then do; vl = vl + 1; val (vl) = 0; sl = sl + 1; stk (sl) = 10; end; if (stk (sl - 1) >= j) then goto calc (stk (sl - 1)); sl = sl + 1; stk (sl) = j; goto endloop; type (11): /* ( */ /* */ if (stk (sl) = 10) then goto arith_err; sl = sl + 1; stk (sl) = j; goto endloop; calc (12): /* = */ /* */ if (val (vl - 1) = val (vl)) then v = 1; else v = 0; goto calc_common; calc (13): /* ^ */ /* */ if (val (vl) = 0) then val (vl) = 1; else val (vl) = 0; sl = sl - 1; stk (sl) = 10; goto retry; calc (14): /* ^= */ /* */ if (val (vl - 1) ^= val (vl)) then v = 1; else v = 0; goto calc_common; calc (15): /* < */ /* */ if (val (vl - 1) < val (vl)) then v = 1; else v = 0; goto calc_common; calc (16): /* <= */ /* */ if (val (vl - 1) <= val (vl)) then v = 1; else v = 0; goto calc_common; calc (17): /* > */ /* */ if (val (vl - 1) > val (vl)) then v = 1; else v = 0; goto calc_common; calc (18): /* >= */ /* */ if (val (vl - 1) >= val (vl)) then v = 1; else v = 0; goto calc_common; calc (19): /* + */ /* */ v = val (vl - 1) + val (vl); goto calc_common; calc (20): /* - */ /* */ v = val (vl - 1) - val (vl); goto calc_common; calc (21): /* * */ /* */ v = val (vl - 1) * val (vl); goto calc_common; calc (22): /* / */ /* */ v = val (vl - 1) / val (vl); calc_common: vl = vl - 1; val (vl) = v; sl = sl - 2; stk (sl) = 10; goto retry; calc (11): /* ( */ /* */ if (j = 23) then do; sl = sl - 1; stk (sl) = 10; goto endloop; end; goto arith_err; type (24): /* SP */ /* */ type (25): /* HT */ /* */ type (28): /* NL */ /* */ endloop: end; ofe = ii; ch60 = ltrim (rtrim (rtrim (convert (pic60, val (1)), "0"), ".")); substr (output, ofe + 1, length (ch60)) = ch60; ofe = ofe + length (ch60); end arithmetic; %page; /* -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- */ /* */ /* convert a text string for debug display. */ cvt: proc (ifp, ifi, ife) returns (char (32) var); dcl res char (32) var; dcl ifp ptr; dcl (ifi, ife) fixed bin (24); dcl i fixed bin (24); dcl begl fixed bin (24); dcl inputa (ife) char (1) based (ifp); dcl ch char (1); res = """"; do i = ifi to min (ifi + 15, ife); ch = inputa (i); if (ch < " ") then ch = "~"; res = res || ch; end; res = res || """"; return (res); end cvt; %page; /* -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- */ /* */ /* show a bunch of debugging information. */ dumper: proc (text, ifp, ifi, ife, ofp, ofe, TF); dcl text char (4), ifp ptr, (ifi, ife) fixed bin (24), ofp ptr, ofe fixed bin (24), TF bit (2); call ioa_ ("^2i.^2i ^4a TF^.1b ^i:^i ^i^-^a - ^a", macro_nest, construct_nest, text, TF, ifi, ife, ofe, cvt (ifp, ifi, ife), cvt (ofp, max (1, ofe - 15), ofe)); end dumper; %page; /* -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- */ /* */ /* ERROR MESSAGE procs */ error_missing: proc (who, begl, endl); dcl who char (*), begl fixed bin (24), endl fixed bin (24); dcl hold char (1000) var; dcl (cline, eline) char (6) var; hold = "Missing "; hold = hold || msg; goto common; error_syntax: entry (who, begl, endl); hold = "Syntax error"; goto common; error_misplaced: entry (who, begl, endl); hold = "Misplaced "; hold = hold || msg; goto common; error_gen: entry (who, begl, endl); hold = msg; goto common; error_attempt: entry (who, begl, endl); hold = "Attempt to "; hold = hold || msg; goto common; common: hold = hold || " in """; cline = lineno (begl); eline = lineno (endl); msg = " ERROR SEVERITY 4. "; msg = msg || who_am_i; msg = msg || " """; msg = msg || myname; msg = msg || """, line "; msg = msg || eline; msg = msg || ". "; msg = msg || hold; msg = msg || "&"; msg = msg || who; msg = msg || """"; if (eline ^= cline) then do; msg = msg || " (on line "; msg = msg || cline; msg = msg || ")"; end; msg = msg || "."; ecode = error_table_$badsyntax; goto exit; end error_missing; %page; /* -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- */ /* */ /* expand a specified string */ expand: proc (ifp, ifi, ife, ofp, ofe, tf); dcl ifp ptr, /* pointer to input */ ifi fixed bin (24), /* first char of input to use */ ife fixed bin (24), /* last char of input to use */ ofp ptr, /* pointer to output */ ofe fixed bin (24), /* last char of output used */ tf bit (2); dcl begl fixed bin (24); dcl inputa (ife) char (1) based (ifp); dcl input char (ife) based (ifp); dcl output char (1044480) based (ofp); dcl (i, j, ii, jj) fixed bin (24); if db_sw then call dumper ("expn", ifp, ifi, ife, ofp, ofe, tf); do while (ifi <= ife); i = index (substr (input, ifi), "&"); if (i = 0) then i = ife - ifi + 1; else i = i - 1; if (i > 0) then do; substr (output, out_len + 1, i) = substr (input, ifi, i); out_len = out_len + i; ifi = ifi + i; end; if (ifi > ife) then return; ii = ifi; call ampersand (ifp, ifi, ife, ofp, ofe, tf, "1"b); if (ii = ifi) then return; end; end expand; %page; /* -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- */ /* */ /* search for the macro specified */ find_macro: proc (refp, segname, suffix, macname); dcl refp ptr, segname char (32) var, suffix char (32) var, macname char (32) var; dcl hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35)); dcl search_paths_$find_dir entry (char (*), ptr, char (*), char (*), char (*), fixed bin (35)); dcl search_for char (35) var; if (segname = "") then search_for = macname; else search_for = segname; search_for = search_for || "." || suffix; if (refp = null ()) then ref_path = ""; else call hcs_$fs_get_path_name (refp, ref_path, 0, "", 0); if db_sw then call ioa_ ("find_macro ^a ^a (^a)", search_for, macname, ref_path); call search_paths_$find_dir ((suffix), null (), (search_for), ref_path, dname, ecode); if (ecode = error_table_$no_search_list) then do; dcl hcs_$make_ptr entry (ptr, char (*), char (*), ptr, fixed bin (35)); here: call hcs_$make_ptr (codeptr (here), suffix || ".search", suffix || ".search", segptr, ecode); /* fudge a little */ if (segptr = null ()) then call com_err_ (0, (suffix), "Default search segment not in same directory as object segment." ); else call search_paths_$find_dir ((suffix), null (), (search_for), ref_path, dname, ecode); end; if (ecode = 0) then do; call hcs_$initiate_count (dname, (search_for), "", bc, 0, segptr, ecode); if (segptr ^= null ()) then ecode = 0; end; if (ecode ^= 0) then do; msg = "No definition segment found. "; msg = msg || search_for; msg = msg || "$"; msg = msg || macname; ecode = -1; goto exit; end; segi = 1; sege = divide (bc, 9, 24, 0); if mac_sw then do; if (suffix = "macro") then i = index (seg, "&macro " || macname || NL); else i = index (seg, "&expand " || macname || NL); if (i = 0) then do; msg = "No definition found for """; bad_mac: msg = msg || macname; msg = msg || """ "; msg = msg || "in "; msg = msg || rtrim (dname); msg = msg || ">"; msg = msg || search_for; ecode = -1; goto exit; end; segi = i + length (macname) + 8; if (suffix = "macro") then i = index (substr (seg, segi), "&mend "); else do; segi = segi + 1; /* &expand 1 char>than &macro */ i = index (substr (seg, segi), "&expend "); end; if i = 0 then do; msg = "&" || end_sym || " missing on """; goto bad_mac; end; sege = segi + i - 2; call addmacro (dname, before (search_for, "."), (macname), "0"b, segptr, segi, sege); if (segname = "") then do; /* now all that is fine and dandy, but we don't want to let &b() find an */ /* external b$b because nothing has been internally defined and then later */ /* have the same thing find a different macro because there now has been an */ /* internal macro/define encountered. So we dummy up a pseudo-internal entry */ /* to nip such a thing in the bud. */ call addmacro ("", before (search_for, "."), (macname), "1"b, segptr, segi, sege); end; end; end find_macro; %page; /* -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- */ /* */ /* free all the storage used */ free_um: proc (which); dcl which char (3); do while (tptr ^= null ()); var_ptr = tptr; tptr = var.next; if (var.type = 0) then do; if db_sw then do; call ioa_ ("^p ^a ^a", var_ptr, which, var.name); if var.ref ^= null () then call ioa_ (" ^p ""^a""", var.ref, vartext); end; if (var.ref ^= null ()) then do; if al_sw then call ioa_ ("F ^p ""^a""", var.ref, vartext); free vartext in (free_area); end; end; if (var.type >= 1) & (var.type <= 5) then do; arr_ptr = var.ref; if db_sw then call ioa_ ("^p ^a ^a{^i:^i}", var_ptr, which, var.name, array.lower, array.lower + var.len - 1); do arr_elem = 1 to var.len; if (array.ref (arr_elem) ^= null ()) then do; if al_sw then call ioa_ ("^p {^i} ""^a""", array.ref (arr_elem), -array.lower + arr_elem - 1, arrtext); free arrtext in (free_area); end; end; end; if al_sw then call ioa_ ("F var-^a ^p", var.name, var_ptr); free var in (free_area); end; end free_um; %page; /* -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- */ /* */ /* set up an area */ get_area: proc; ai.version = area_info_version_1; string (ai.control) = "0"b; ai.extend = "1"b; ai.owner = sl_name; ai.size = 261120; ai.areap = null (); call define_area_ (addr (ai), ecode); free_area_p = ai.areap; %include area_info; dcl 1 ai like area_info; end get_area; %page; /* -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- */ /* */ /* parse an array range specification. */ get_range: proc (ifp, ifi, ife, ofp, ofe, TF, i, j); dcl ifp ptr, /* pointer to input */ ifi fixed bin (24), /* first char of input to use */ ife fixed bin (24), /* last char of input to use */ ofp ptr, /* pointer to output */ ofe fixed bin (24), /* last char of output used */ TF bit (2); dcl begl fixed bin (24); dcl inputa (ife) char (1) based (ifp); dcl input char (ife) based (ifp); dcl output char (1044480) based (ofp); dcl (i, j, ii, jj) fixed bin (24); if (inputa (ifi + 2) = "}") | (inputa (ifi + 2) = ",") then do; ifi = ifi + 2; return; end; ii = ofe; call arithmetic (ifp, ifi, ife, ofp, ofe, TF); i, j = fixed (substr (output, ii + 1, ofe - ii)); ofe = ii; if (inputa (ifi) = ":") then do; ifi = ifi - 1; call arithmetic (ifp, ifi, ife, ofp, ofe, TF); j = fixed (substr (output, ii + 1, ofe - ii)); ofe = ii; end; end get_range; %page; /* -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- */ /* */ /* parse the next input token */ get_token: proc (ifp, ifi, ife); dcl ifp ptr, ifi fixed bin (24), ife fixed bin (24); dcl input char (ife) based (ifp); call strip (ifp, ifi, ife); if (substr (input, ifi, 1) ^= "&") then do; c32 = ""; return; end; i = verify (substr (input, ifi + 1), "abcdefghijklmnopqrstuvwxyz"); if (i = 0) then i = ife - ifi + 1; else if (i = 1) then i = 2; c32 = substr (input, ifi, i); end get_token; %page; /* -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- */ /* */ /* determine and format the line number of a given point in a segment */ lineno: proc (segi) returns (char (6) var); dcl segi fixed bin (24); dcl c6 pic "zzzzz9"; dcl cv6 char (6) var; dcl j fixed bin (24); dcl line fixed bin (24); dcl e fixed bin (24); line = 0; i = 1; e = min (segi, sege); do while (i <= segi); line = line + 1; j = index (substr (seg, i), NL); if (j = 0) then i = sege + 1; else i = i + j; end; cv6 = ltrim (char (line)); return (cv6); end lineno; %page; /* -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- */ /* */ /* process a logical expression */ logical: proc (ifp, ifi, ife, ofp, ofe, TF); dcl ifp ptr, /* pointer to input */ ifi fixed bin (24), /* first char of input to use */ ife fixed bin (24), /* last char of input to use */ ofp ptr, /* pointer to output */ ofe fixed bin (24), /* last char of output used */ TF bit (2); dcl begl fixed bin (24); dcl inputa (ife) char (1) based (ifp); dcl input char (ife) based (ifp); dcl output char (1044480) based (ofp); dcl (i, j, ii, jj, kk) fixed bin (24); dcl loc (24) fixed bin (24); dcl sep_ct fixed bin (24); dcl argstrl fixed bin (24); dcl rel fixed bin (24); jj = ofe; construct_nest = construct_nest + 1; call strip (ifp, ifi, ife); begl = ifi; loop: i = search (substr (input, ifi), "&=^<>"); if (i = 0) then do; log_err: msg = "Missing termination of logical expression. "; goto add_identification; end; if (i > 1) then do; i = i - 1; substr (output, ofe + 1, i) = substr (input, ifi, i); ofe = ofe + i; ifi = ifi + i; end; rel = index ("&=^=<^>=", inputa (ifi)); goto type (rel); type (1): /* & */ /* & */ if (substr (input, ifi, 5) = "&then") | (substr (input, ifi, 2) = "&;") then do; kk = ofe; if db_sw | tr_sw then do; call ioa_$nnl ("#^a:^a^-log-^.1b (", lineno (begl), lineno (ifi - 1), TF); call show_string (substr (output, jj + 1, kk - jj), ") "); end; ofe = jj; if (TF = "00"b) then return; c32 = translate (substr (output, jj + 1, kk - jj), " ABCDEFGHIJKLMNOPQRSTUVWXYZ", " abcdefghijklmnopqrstuvwxyz"); if (c32 = "0") | (c32 = "FALSE") | (c32 = "F") | (c32 = "NO") then TF = "01"b; else TF = "10"b; return; end; call ampersand (ifp, ifi, ife, ofp, ofe, TF, "0"b); goto loop; type (3): /* ^ */ /* ^ */ type (5): /* < */ /* < */ type (7): /* > */ /* > */ if (inputa (ifi + 1) = "=") then do; rel = rel + 1; ifi = ifi + 1; end; else if (rel = 3) then do; ifi = ifi + 1; substr (output, ofe + 1, 1) = "^"; ofe = ofe + 1; goto loop; end; type (2): /* = */ /* = */ /* 2 = 4 ^= */ /* 5 < 6 <= */ /* 7 > 8 >= */ ifi = ifi + 1; ii = ofe; loop1: call strip (ifp, ifi, ife); j = index (substr (input, ifi), "&"); if (j = 0) then goto log_err; if (j > 1) then do; j = j - 1; substr (output, ofe + 1, j) = substr (input, ifi, j); ifi = ifi + j; ofe = ofe + j; end; if (substr (input, ifi, 5) = "&then") | (substr (input, ifi, 2) = "&;") then do; construct_nest = construct_nest - 1; kk = ofe; if db_sw | tr_sw then do; call ioa_$nnl ("#^a:^a^-log-^.1b (", lineno (begl), lineno (ifi - 1), TF); call show_string (substr (output, jj + 1, ii - jj), ""); call ioa_$nnl (")^a(", relat (rel)); call show_string (substr (output, ii + 1, kk - ii), ") "); end; ofe = jj; if (TF = "00"b) then return; dcl relat (2:8) char (2) int static init ("=", "!!", "^=", "<", "<=", ">", ">="); goto comp (rel); end; call ampersand (ifp, ifi, ife, ofp, ofe, TF, "0"b); goto loop1; comp (2): if (substr (output, jj + 1, ii - jj) = substr (output, ii + 1, kk - ii)) then TF = "10"b; else TF = "01"b; return; comp (4): if (substr (output, jj + 1, ii - jj) ^= substr (output, ii + 1, kk - ii)) then TF = "10"b; else TF = "01"b; return; comp (5): if (substr (output, jj + 1, ii - jj) < substr (output, ii + 1, kk - ii)) then TF = "10"b; else TF = "01"b; return; comp (6): if (substr (output, jj + 1, ii - jj) <= substr (output, ii + 1, kk - ii)) then TF = "10"b; else TF = "01"b; return; comp (7): if (substr (output, jj + 1, ii - jj) > substr (output, ii + 1, kk - ii)) then TF = "10"b; else TF = "01"b; return; comp (8): if (substr (output, jj + 1, ii - jj) >= substr (output, ii + 1, kk - ii)) then TF = "10"b; else TF = "01"b; return; end logical; %page; /* -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- */ /* */ /* look up a specified name in the variable lists */ lookup: proc (vname) returns (fixed bin) recursive; dcl vname char (32) var; /* first look up local variables */ var_ptr = local_var_ptr; do while (var_ptr ^= null ()); if (var.name = vname) then return (3); var_ptr = var.next; end; /* then look up internal static variables */ if (int_var_ptr = null ()) then do; int_var_ptr = int_vars_base; do while (int_var_ptr ^= null ()); if (macname = int_vars.macro) then goto found; else int_var_ptr = int_vars.next; end; allocate int_vars in (free_area); if al_sw then call ioa_ ("A int_vars ^a^i ^p", macname, size (int_vars), int_var_ptr); int_vars.next = int_vars_base; int_vars.ref = null (); int_vars.macro = macname; int_vars_base = int_var_ptr; end; found: var_ptr = int_vars.ref; do while (var_ptr ^= null ()); if (var.name = vname) then return (2); var_ptr = var.next; end; /* then look up external static variables */ var_ptr = ext_var_ptr; do while (var_ptr ^= null ()); if (var.name = vname) then return (1); var_ptr = var.next; end; return (0); end lookup; %page; /* -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- */ /* */ /* handle the active function call */ macro_af: proc (ifp, ifi, ife, ofp, ofe, TF); dcl ifp ptr, /* pointer to input */ ifi fixed bin (24), /* first char of input to use */ ife fixed bin (24), /* last char of input to use */ ofp ptr, /* pointer to output */ ofe fixed bin (24), /* last char of output used */ TF bit (2); dcl begl fixed bin (24); dcl inputa (ife) char (1) based (ifp); dcl input char (ife) based (ifp); dcl output char (1044480) based (ofp); dcl (i, j, ii, jj) fixed bin (24); dcl level fixed bin (24); /* &[ ... ] */ begl = ifi; ifi = ifi + 2; call strip (ifp, ifi, ife); if db_sw then call dumper ("af..", ifp, ifi, ife, ofp, ofe, TF); ii = ofe; level = 1; construct_nest = construct_nest + 1; loop: i = search (substr (input, ifi), "&[]"); if (i = 0) then do; msg = "]"; call error_missing ("[", begl, ife); end; if (i > 1) then do; i = i - 1; substr (output, ofe + 1, i) = substr (input, ifi, i); ofe = ofe + i; ifi = ifi + i; end; goto type (index ("&[]", inputa (ifi))); type (1): /* & */ /* */ call ampersand (ifp, ifi, ife, ofp, ofe, TF, "0"b); if (c32 = "&;") then goto misplaced; goto loop; type (2): /* [ */ /* */ substr (output, ofe + 1, 1) = "["; ofe = ofe + 1; ifi = ifi + 1; level = level + 1; goto loop; type (3): /* ] */ /* */ substr (output, ofe + 1, 1) = "]"; ofe = ofe + 1; ifi = ifi + 1; level = level - 1; if (level > 0) then goto loop; construct_nest = construct_nest - 1; ofe = ofe - 1; if (TF = "00"b) then do; ofe = ii; return; end; begin; dcl rval char (500) var; dcl cu_$evaluate_active_string entry (ptr, char (*), fixed bin, char (*) var, fixed bin (35)); %include cp_active_string_types; call cu_$evaluate_active_string (null (), substr (output, ii + 1, ofe - ii), ATOMIC_ACTIVE_STRING, rval, ecode); if ecode ^= 0 then do; err_ct = 0; msg = "Processing active functtion. "; msg_etc = substr (output, ii + 1, ofe - ii); goto add_id; end; ofe = ii; substr (output, ofe + 1, length (rval)) = rval; ofe = ofe + length (rval); end; return; end macro_af; %page; /* -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- */ /* */ /* handle a macro call */ macro_call: proc (ifp, ifi, ife, ofp, ofe, TF) recursive; dcl ifp ptr, /* pointer to input */ ifi fixed bin (24), /* first char of input to use */ ife fixed bin (24), /* last char of input to use */ ofp ptr, /* pointer to output */ ofe fixed bin (24), /* last char of output used */ TF bit (2); dcl begl fixed bin (24); dcl inputa (ife) char (1) based (ifp); dcl input char (ife) based (ifp); dcl output char (1044480) based (ofp); dcl (i, j, ii, jj) fixed bin (24); dcl loc (100) fixed bin (24); dcl (sep_ct, level) fixed bin (24); dcl argstrl fixed bin (24); dcl callseg char (32) var; dcl callmac char (32) var; /* &xxx( ... , ... , ...) */ /* &xxx$yy( ... , ... , ...) */ begl = ifi; callseg = c32x; callmac = c32; call strip (ifp, ifi, ife); if db_sw then call dumper ("call", ifp, ifi, ife, ofp, ofe, TF); ii = ofe; substr (output, ofe + 1, 1) = "("; ofe, loc (1) = ofe + 1; sep_ct = 1; level = 1; construct_nest = construct_nest + 1; loop: i = search (substr (input, ifi), "&(),"); if (i = 0) then do; msg = ")"; call error_missing (callmac || "(", begl, ife); end; if (i > 1) then do; i = i - 1; substr (output, ofe + 1, i) = substr (input, ifi, i); ofe = ofe + i; ifi = ifi + i; end; goto type (index ("&(),", inputa (ifi))); type (1): /* & */ /* */ call ampersand (ifp, ifi, ife, ofp, ofe, TF, "0"b); goto loop; type (2): /* ( */ /* */ substr (output, ofe + 1, 1) = "("; ofe = ofe + 1; ifi = ifi + 1; level = level + 1; goto loop; type (3): /* ) */ /* */ substr (output, ofe + 1, 1) = ")"; ofe = ofe + 1; ifi = ifi + 1; level = level - 1; if (level > 0) then goto loop; construct_nest = construct_nest - 1; loc (sep_ct + 1) = ofe; argstrl = ofe - loc (1) + 1; if (argstrl > 16384) then do; msg = "&call arg-string > 16384 chrs."; goto add_identification; end; begin; dcl 1 args (sep_ct) like argl; dcl argstr (argstrl) char (1) unal; if db_sw | tr_sw then do; call ioa_$nnl ("#^a:^a^-call ^a$^a ", lineno (begl), lineno (ifi - 1), callseg, callmac); call show_string (substr (output, loc (1), argstrl), " "); end; string (argstr) = substr (output, loc (1), argstrl); ofe = loc (1) - 1; if (argstrl = 2) then sep_ct = 0; do i = 1 to sep_ct; args.l (i) = loc (i + 1) - loc (i) - 1; j = loc (i) - ofe + 1; args.p (i) = addr (argstr (j)); end; call macro_ (sl_name, callseg, callmac, ofp, ofe, addr (args), (sep_ct), msg, ifp, ecode); if (ecode = -1) then call error_gen ("call", begl, ifi); if (ecode ^= 0) then do; ifi = begl; call_err = "1"b; goto add_id; end; end; return; type (4): /* , */ /* */ substr (output, ofe + 1, 1) = ","; ofe = ofe + 1; ifi = ifi + 1; if (level = 1) then do; if (sep_ct >= 100) then do; msg = "Cannot handle over 100 "; msg = msg || who_am_i; msg = msg || " arguments."; goto add_identification; end; sep_ct = sep_ct + 1; loc (sep_ct) = ofe; call strip (ifp, ifi, ife); end; goto loop; end macro_call; %page; /* -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- */ /* */ /* dynamically define a macro */ macro_define: proc (ifp, ifi, ife, ofp, ofe, TF); dcl ifp ptr, /* pointer to input */ ifi fixed bin (24), /* first char of input to use */ ife fixed bin (24), /* last char of input to use */ ofp ptr, /* pointer to output */ ofe fixed bin (24), /* last char of output used */ TF bit (2); dcl begl fixed bin (24); dcl inputa (ife) char (1) based (ifp); dcl input char (ife) based (ifp); dcl output char (1044480) based (ofp); dcl (i, j, ii, jj) fixed bin (24); dcl loc (24) fixed bin (24); dcl sep_ct fixed bin (24); dcl argstrl fixed bin (24); /* &define ... &dend */ begl = ifi; ifi = ifi + 7; call strip (ifp, ifi, ife); if db_sw then call dumper ("defi", ifp, ifi, ife, ofp, ofe, TF); ii = ofe; construct_nest = construct_nest + 1; loop: i = index (substr (input, ifi), "&"); if (i = 0) then do; msg = "&dend"; call error_missing ("define", begl, ife); end; if (i > 1) then do; i = i - 1; substr (output, ofe + 1, i) = substr (input, ifi, i); ofe = ofe + i; ifi = ifi + i; end; if (substr (input, ifi, 5) = "&dend") then do; ifi = ifi + 5; call strip (ifp, ifi, ife); if (TF & "10"b) then do; i = ii + 1; i = i + verify (substr (output, i, ofe - i + 1), space) - 1; j = verify (substr (output, i, ofe - i + 1), "abcdefghijklmnopqrstuvwxyz" || "ABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789"); if (j = 0) then do; def_err: call error_syntax ("define", begl, ifi); end; if (j < 2) then do; msg = "macroname"; call error_missing ("define", begl, ifi); end; j = j - 1; c32 = substr (output, i, j); i = i + j; if (substr (output, i, 1) ^= NL) then goto def_err; macro_holder_l = ofe - i; allocate macro_holder in (free_area); macro_holder = substr (output, i + 1, macro_holder_l); if db_sw | tr_sw then do; call ioa_$nnl ("#^a:^a^-&define ^a^/^-", lineno (begl), lineno (ifi - 1), c32); call show_string (macro_holder, "&dend "); end; call addmacro (" &define'ed in " || myname || " ", "", c32, "1"b, macro_holder_p, 1, macro_holder_l); end; ofe = ii; construct_nest = construct_nest - 1; return; end; call ampersand (ifp, ifi, ife, ofp, ofe, TF, "0"b); goto loop; end macro_define; %page; /* -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- */ /* */ /* handle the iteration construct */ macro_do: proc (ifp, ifi, ife, ofp, ofe, TF); dcl ifp ptr, /* pointer to input */ ifi fixed bin (24), /* first char of input to use */ ife fixed bin (24), /* last char of input to use */ ofp ptr, /* pointer to output */ ofe fixed bin (24), /* last char of output used */ TF bit (2); dcl begl fixed bin (24); dcl inputa (ife) char (1) based (ifp); dcl input char (ife) based (ifp); dcl output char (1044480) based (ofp); dcl (i, j, ii, jj) fixed bin (24); dcl tf bit (2); /* &do EXPAND &while LOGICAL &; EXPAND &od */ /* LOGICAL ::= arithmetic | compare */ begl = ifi; ifi = ifi + 3; call strip (ifp, ifi, ife); if db_sw then call dumper ("do..", ifp, ifi, ife, ofp, ofe, TF); if (TF = "00"b) then goto skip; ii = ifi; jj = 0; construct_nest = construct_nest + 1; loop: call expand (ifp, ifi, ife, ofp, ofe, (TF)); if (c32 = "&while") then do; ifi = ifi + length (c32); jj = 1; tf = TF; call logical (ifp, ifi, ife, ofp, ofe, tf); call get_token (ifp, ifi, ife); if (c32 ^= "&;") then do; msg = "&;"; call error_missing ("while", begl, ifi); end; ifi = ifi + length (c32); call strip (ifp, ifi, ife); if (tf = "01"b) then do; skip: i = index (substr (input, ifi), "&"); if (i = 0) then do; msg = "&od"; call error_missing ("do", begl, ife); end; ifi = ifi + i - 1; call get_token (ifp, ifi, ife); if (c32 = "&do") then call macro_do (ifp, ifi, ife, ofp, ofe, "00"b); else if (c32 = "&""") then call protected (ifp, ifi, ife, ofp, (ofe)); else if (c32 = "&od") then do; jj = 0; goto od; end; else ifi = ifi + 1; goto skip; end; goto loop; end; if (c32 = "&od") then do; od: ifi = ifi + length (c32); call strip (ifp, ifi, ife); if (jj = 0) then do; construct_nest = construct_nest - 1; return; end; ifi = ii; goto loop; end; msg = c32; call error_misplaced ("do", begl, ifi); end macro_do; %page; /* -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- */ /* */ /* make a list or array var be empty again */ macro_empty: proc (ifp, ifi, ife, ofp, ofe, TF); dcl ifp ptr, ifi fixed bin (24), ife fixed bin (24), ofp ptr, ofe fixed bin (24), TF bit (2); dcl begl fixed bin (24); dcl inputa (ife) char (1) based (ifp); dcl input char (ife) based (ifp); dcl output char (1044480) based (ofp); dcl (i, j, ii, jj) fixed bin (24); dcl tf bit (2); dcl vname char (32) var; /* &empty name &; */ begl = ifi; ifi = ifi + 6; call strip (ifp, ifi, ife); if db_sw then call dumper ("empt", ifp, ifi, ife, ofp, ofe, TF); i = verify (substr (input, ifi), "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789"); if (i = 0) then i = ife - ifi + 1; if (i = 1) then do; msg = "array name"; call error_missing ("empty", begl, ifi); end; vname = substr (input, ifi, i - 1); if (length (vname) > 16) then do; msg = """"; msg = msg || vname; msg = msg || """ > 16 characters."; call error_gen ("empty", begl, ifi); end; ifi = ifi + length (vname); call strip (ifp, ifi, ife); if (substr (input, ifi, 2) ^= "&;") then do; msg = "&;"; call error_missing ("empty", begl, ifi); end; call strip2 (ifp, ifi, ife); i = lookup (vname); if (i = 0) then do; msg = """"; msg = msg || vname; msg = msg || """ undefined."; call error_gen ("empty", begl, ifi); end; if (var.type = 0) then do; msg = """"; msg = msg || vname; msg = msg || """ is a scalar."; call error_gen ("empty", begl, ifi); end; arr_ptr = var.ref; /* free any allocated strings */ if (var.type = 2) then do; array.h_bound = array.lower - 1; array.l_bound = array.lower + var.len; end; if (var.type = 3) then do; array.l_bound = 1; array.h_bound = 0; end; end macro_empty; %page; /* -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- */ /* */ /* print a user specified error message */ macro_error: proc (ifp, ifi, ife, ofp, ofe, TF); dcl ifp ptr, /* pointer to input */ ifi fixed bin (24), /* first char of input to use */ ife fixed bin (24), /* last char of input to use */ ofp ptr, /* pointer to output */ ofe fixed bin (24), /* last char of output used */ TF bit (2); dcl begl fixed bin (24); dcl inputa (ife) char (1) based (ifp); dcl input char (ife) based (ifp); dcl output char (1044480) based (ofp); dcl (i, j, ii, jj) fixed bin (24); dcl loc (24) fixed bin (24); dcl sep_ct fixed bin (24); dcl argstrl fixed bin (24); dcl ch8 pic "-------9"; /* &error ARITH , ... &; */ begl = ifi; ifi = ifi + 6; call strip (ifp, ifi, ife); if db_sw then call dumper ("err.", ifp, ifi, ife, ofp, ofe, TF); ii = ofe; msg = ""; construct_nest = construct_nest + 1; ifi = ifi - 2; call arithmetic (ifp, ifi, ife, ofp, ofe, TF); if (ofe ^= ii + 1) | (substr (output, ofe, 1) < "0") | (substr (output, ofe, 1) > "4") then do; substr (output, ii + 1, 38) = "4(Invalid &error severity, 4 assumed.) "; ofe = ii + 38; end; call strip (ifp, ifi, ife); if (inputa (ifi) ^= ",") then do; substr (output, ofe + 1, 39) = "(Missing comma after &error severity.) "; ofe = ofe + 39; end; else ifi = ifi + 1; loop: i = index (substr (input, ifi), "&"); if (i = 0) then do; msg = "&;"; call error_missing ("error", begl, ife); end; if (i > 1) then do; i = i - 1; substr (output, ofe + 1, i) = substr (input, ifi, i); ofe = ofe + i; ifi = ifi + i; end; if (substr (input, ifi, 2) = "&;") then do; call strip2 (ifp, ifi, ife); i = index ("01234", substr (output, ii + 1, 1)) - 1; err_ct (i) = err_ct (i) + 1; msg = NL; if (i = 0) then msg = msg || "NOTE: "; else if (i = 1) then msg = msg || "WARNING. "; else do; msg = msg || "ERROR SEVERITY "; msg = msg || substr (output, ii + 1, 1); msg = msg || ". "; end; msg = msg || who_am_i; msg = msg || " """; msg = msg || macname; msg = msg || """, line "; msg = msg || lineno (ifi); msg = msg || NL; call iox_$put_chars (iox_$error_output, addrel (addr (msg), 1), length (msg), 0); msg = ""; substr (output, ofe + 1, 1) = NL; call iox_$put_chars (iox_$error_output, addr (substr (output, ii + 2, 1)), ofe - ii, 0); if (i = 4) then do; msg = "Error detected by "; msg = msg || who_am_i; msg = msg || " """; msg = msg || macname; msg = msg || """."; ecode = error_table_$translation_aborted; goto exit; end; ofe = ii; construct_nest = construct_nest - 1; return; end; call ampersand (ifp, ifi, ife, ofp, ofe, TF, "0"b); goto loop; dcl iox_$error_output ptr ext static; dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); end macro_error; %page; /* -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- */ /* */ /* handle the "if then [elseif] ... [else] fi" construct */ macro_if: proc (ifp, ifi, ife, ofp, ofe, tf); dcl ifp ptr, /* pointer to input */ ifi fixed bin (24), /* first char of input to use */ ife fixed bin (24), /* last char of input to use */ ofp ptr, /* pointer to output */ ofe fixed bin (24), /* last char of output used */ tf bit (2); /* 1x- process true */ /* x1- process false */ /* value not returned (modified) */ dcl begl fixed bin (24); dcl beglt fixed bin (24); dcl skip_sw bit (1); dcl inputa (ife) char (1) based (ifp); dcl input char (ife) based (ifp); dcl output char (1044480) based (ofp); dcl (i, j, ii, jj) fixed bin (24); dcl TF bit (2); dcl if_lineno char (6) var; dcl elseif bit (1); /* &if LOGICAL &then EXPAND {&elseif EXPAND} ... {&else EXPAND} &fi */ begl, beglt = ifi; ifi = ifi + 3; call strip (ifp, ifi, ife); TF = tf; if db_sw then call dumper ("if..", ifp, ifi, ife, ofp, ofe, TF); elseif = "0"b; if_lineno = lineno (begl); nother_logical: call logical (ifp, ifi, ife, ofp, ofe, TF); if (tf = "00"b) then TF = "00"b; if db_sw | tr_sw then call ioa_ ("#^a:^a^-&^[else^]if (^a) ^[skip^;F^;T^;TF^]", lineno (beglt), lineno (ifi - 1), elseif, if_lineno, fixed (TF) + 1); call get_token (ifp, ifi, ife); if (c32 ^= "&then") then do; msg = "&then"; call error_missing ("if", begl, ifi); end; beglt = ifi; ifi = ifi + length (c32); call strip (ifp, ifi, ife); construct_nest = construct_nest + 1; if (TF & "10"b) then call expand (ifp, ifi, ife, ofp, ofe, (TF)); else call skipper; if db_sw | tr_sw then call ioa_ ("#^a:^a^-&then (^a) ^[done^;skip^]", lineno (beglt), lineno (ifi - 1), if_lineno, (TF & "10"b)); skip_again: beglt = ifi; if (c32 = "&elseif") then do; ifi = ifi + length (c32); call strip (ifp, ifi, ife); if (TF & "01"b) then do; construct_nest = construct_nest - 1; elseif = "1"b; goto nother_logical; end; call skipper; if db_sw | tr_sw then call ioa_ ("#^a:^a^-&elseif (^a) skip", lineno (beglt), lineno (ifi - 1), if_lineno); goto skip_again; end; if (c32 = "&else") then do; ifi = ifi + length (c32); call strip (ifp, ifi, ife); if (TF & "01"b) then call expand (ifp, ifi, ife, ofp, ofe, (TF)); else call skipper; if db_sw | tr_sw then call ioa_ ("#^a:^a^-&else (^a) ^[done^;skip^]", lineno (beglt), lineno (ifi - 1), if_lineno, TF & "01"b); beglt = ifi; end; if (c32 ^= "&fi") then do; msg = "&fi"; call error_missing ("if", begl, ifi); end; construct_nest = construct_nest - 1; ifi = ifi + length (c32); call strip (ifp, ifi, ife); if db_sw | tr_sw then call ioa_ ("#^a:^a^-&fi (^a)", lineno (beglt), lineno (ifi - 1), if_lineno); return; skipper: proc; do while ("1"b); i = index (substr (input, ifi), "&"); if (i = 0) then do; c32 = ""; return; end; ifi = ifi + i - 1; call get_token (ifp, ifi, ife); if (c32 = "&if") then call macro_if (ifp, ifi, ife, ofp, ofe, "00"b); else if (c32 = "&fi") then return; else if (c32 = "&else") then return; else if (c32 = "&elseif") then return; else if (c32 = "&""") then call protected (ifp, ifi, ife, ofp, (ofe)); else ifi = ifi + 1; end; end; end macro_if; %page; /* -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- */ /* */ /* return the length of a string */ macro_length: proc (ifp, ifi, ife, ofp, ofe, TF); dcl ifp ptr, /* pointer to input */ ifi fixed bin (24), /* first char of input to use */ ife fixed bin (24), /* last char of input to use */ ofp ptr, /* pointer to output */ ofe fixed bin (24), /* last char of output used */ TF bit (2); dcl begl fixed bin (24); dcl inputa (ife) char (1) based (ifp); dcl input char (ife) based (ifp); dcl output char (1044480) based (ofp); dcl (i, j, ii, jj) fixed bin (24); dcl loc (24) fixed bin (24); dcl sep_ct fixed bin (24); dcl argstrl fixed bin (24); dcl ch8 pic "-------9"; /* &length ... &; */ begl = ifi; ifi = ifi + 7; call strip (ifp, ifi, ife); if db_sw then call dumper ("leng", ifp, ifi, ife, ofp, ofe, TF); ii = ofe; construct_nest = construct_nest + 1; loop: i = index (substr (input, ifi), "&"); if (i = 0) then do; msg = "&;"; call error_missing ("length", begl, ife); end; if (i > 1) then do; i = i - 1; substr (output, ofe + 1, i) = substr (input, ifi, i); ofe = ofe + i; ifi = ifi + i; end; if (substr (input, ifi, 2) = "&;") then do; call strip2 (ifp, ifi, ife); ch8 = ofe - ii; ofe = ii; i = index (reverse (ch8), " ") - 1; substr (output, ofe + 1, i) = substr (ch8, 9 - i, i); ofe = ofe + i; construct_nest = construct_nest - 1; return; end; call ampersand (ifp, ifi, ife, ofp, ofe, TF, "0"b); goto loop; end macro_length; %page; /* -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- */ /* */ /* process loc/int/ext/let statements (they look very much alike */ macro_let: proc (ifp, ifi, ife, ofp, ofe, TF, which) recursive; dcl ifp ptr, /* pointer to input */ ifi fixed bin (24), /* first char of input to use */ ife fixed bin (24), /* last char of input to use */ ofp ptr, /* pointer to output */ ofe fixed bin (24), /* last char of output used */ TF bit (2), which fixed bin (24); /* 0-let, 1-ext, 2-int, 3-loc */ dcl begl fixed bin (24); dcl inputa (ife) char (1) based (ifp); dcl input char (ife) based (ifp); dcl output char (1044480) based (ofp); dcl (i, j, ii, jj) fixed bin (24); dcl vname char (32) var; dcl vptr ptr; dcl found fixed bin (24); dcl (lower, higher) fixed bin (24); /* &let var = EXPR &; &ext var = EXPR &; &ext var &; &int var = EXPR &; &int var &; &loc var = EXPR &; &loc var &; */ /* EXPR ::= arithmetic | string */ begl = ifi; ifi = ifi + 4; call strip (ifp, ifi, ife); if db_sw then call dumper (cmd (which), ifp, ifi, ife, ofp, ofe, TF); i = verify (substr (input, ifi, 1), "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"); if (i ^= 0) then do; msg = "Variable name must begin with alphabetic char. "; call error_gen (cmd (which), begl, ifi); end; i = verify (substr (input, ifi), "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789"); if (i = 0) then i = ife - ifi + 1; else i = i - 1; vname = substr (input, ifi, i); if (i > 16) then do; msg = "Data name > 16 characters. "; goto add_identification; end; ifi = ifi + i; dcl reserved (29) char (8) int static init ("arg", "comment", "define", "dend", "do", "else", "elseif", "empty", "error", "expand", "expend", "ext", "fi", "hbound", "if", "int", "let", "lbound", "length", "loc", "macro", "mend", "quote", "return", "scan", "substr", "unquote", "usage", "while"); do i = 1 to hbound (reserved, 1); if (vname = reserved (i)) then do; msg = "Attempt to use reserved word """; msg = msg || vname; msg = msg || """ as variable. "; goto add_identification; end; end; found = lookup (vname); if (found < which) then do; allocate var in (free_area) set (var_ptr); if al_sw then call ioa_ ("A var-^a ^i ^p", vname, size (var), var_ptr); var.name = vname; var.ref = null (); var.type = 0; var.len = 0; if (which = 1) then do; var.next = ext_var_ptr; ext_var_ptr = var_ptr; if db_sw then call ioa_ ("^p ext ""^a""", var_ptr, var.name); end; else if (which = 2) then do; var.next = int_vars.ref; int_vars.ref = var_ptr; if db_sw then call ioa_ ("^p int.^a ""^a""", var_ptr, macname, var.name); end; else do; var.next = local_var_ptr; local_var_ptr = var_ptr; if db_sw then call ioa_ ("^p loc ""^a""", var_ptr, var.name); end; end; else if (found = 0) then do; msg = "Attempt to set undeclared variable """; msg = msg || vname; msg = msg || """. "; goto add_identification; end; vptr = var_ptr; call strip (ifp, ifi, ife); if (which > 0) then if (substr (input, ifi, 2) = "&;") then do; call strip2 (ifp, ifi, ife); return; end; if (inputa (ifi) = "{") then do; ifi = ifi - 1; if (var.type = 0) then do; lower, higher = -9999; end; else do; arr_ptr = var.ref; lower = array.l_bound; higher = array.h_bound; end; call get_range (ifp, ifi, ife, ofp, ofe, TF, lower, higher); if (inputa (ifi) ^= "}") then do; msg = "}"; call error_missing (cmd (which), begl, ifi); end; ifi = ifi + 1; call strip (ifp, ifi, ife); var_ptr = vptr; if (which > 0) /* not let */ then do; if (lower = higher) then do; if (lower < 1) then do; msg = "Improper dimension. "; goto add_identification; end; lower = 1; end; if (found ^= which) then do; var.type = 1; var.len = higher - lower + 1; allocate array in (free_area) set (arr_ptr); var.ref = arr_ptr; if al_sw then call ioa_ ("A^a{^i:^i} ^i ^p", vname, lower, higher, size (array), var.ref); do arr_elem = 1 to var.len; array.ref (arr_elem) = null (); array.len (arr_elem) = 0; end; array.lower = lower; end; if (substr (input, ifi, 3) = "var") then do; ifi = ifi + 3; if (found = which) then do; if (var.type ^= 2) | (array.lower ^= lower) | (var.len ^= higher - lower + 1) then do; dcl_err: msg = "Data declaration does not match prior declaration for """ ; msg = msg || vname; msg = msg || """. "; goto add_identification; end; end; else do; var.type = 2; array.l_bound = higher + 1; array.h_bound = lower - 1; end; end; else if (substr (input, ifi, 4) = "list") then do; ifi = ifi + 4; if (found = which) then do; if (var.type ^= 3) | (var.len ^= higher) then goto dcl_err; end; else do; var.type = 3; array.l_bound = 1; array.h_bound = 0; end; end; else if (substr (input, ifi, 4) = "fifo") then do; ifi = ifi + 4; if (found = which) then do; if (var.type ^= 4) | (array.l_bound ^= lower) | (array.h_bound ^= higher) then goto dcl_err; end; else do; var.type = 4; array.l_bound = 1; array.h_bound = 0; end; end; else if (substr (input, ifi, 4) = "lifo") then do; ifi = ifi + 4; if (found = which) then do; if (var.type ^= 5) | (array.l_bound ^= lower) | (array.h_bound ^= higher) then goto dcl_err; end; else do; var.type = 5; array.l_bound = 1; array.h_bound = 0; end; end; else do; if (found = which) then do; if (var.type ^= 1) | (array.l_bound ^= lower) | (array.h_bound ^= higher) then goto dcl_err; end; else do; array.l_bound = lower; array.h_bound = higher; end; end; call strip (ifp, ifi, ife); end; else do; if (var.type ^= 1) & (var.type ^= 2) then do; msg = "Attempt to do array assignment to non-array variable. " ; goto add_identification; end; arr_ptr = var.ref; if (lower < array.lower) then do; msg = "Attempt to set below lower bound. "; goto add_identification; end; if (higher > array.lower + var.len - 1) then do; msg = "Attempt to set above upper bound. "; goto add_identification; end; end; call strip (ifp, ifi, ife); if (which > 0) then if (substr (input, ifi, 2) = "&;") then do; call strip2 (ifp, ifi, ife); return; end; end; else do; if (var.type = 1) | (var.type = 2) then do; msg = "Attempt to do scalar assignment to array variable. "; goto add_identification; end; if (var.type = 4) /* fifo */ then do; arr_ptr = var.ref; if (array.l_bound + var.len - 1 > array.h_bound) then do; msg = "Out-of-bounds on fifo """; msg = msg || vname; msg = msg || """. "; goto add_identification; end; if (array.l_bound + var.len - 1 = array.h_bound) then do; msg = "Attempt to stack too many elements. "; goto add_identification; end; array.h_bound = array.h_bound + 1; lower, higher = mod (array.h_bound, var.len) + 1; end; if (var.type = 5) then do; arr_ptr = var.ref; if (var.len < array.h_bound) then do; msg = "Out-of-bounds on lifo """; msg = msg || vname; msg = msg || """. "; goto add_identification; end; if (var.len = array.h_bound) then do; msg = "Attempt to stack too many elements. "; goto add_identification; end; array.h_bound, lower, higher = array.h_bound + 1; end; end; if (inputa (ifi) ^= "=") then do; msg = "="; call error_missing (cmd (which), begl, ifi); dcl cmd (0:3) char (4) int static init ("let ", "ext ", "int ", "loc "); end; ifi = ifi + 1; call strip (ifp, ifi, ife); jj = ofe; if (inputa (ifi) = "(") then do; msg = "Vector assignment not available yet."; call error_gen (cmd (which), begl, ifi); end; if (substr (input, ifi, 2) = "&(") then do; call arithmetic (ifp, ifi, ife, ofp, ofe, TF); call strip (ifp, ifi, ife); end; else do; construct_nest = construct_nest + 1; loop: i = index (substr (input, ifi), "&"); if (i = 0) then do; msg = "&;"; call error_missing (cmd (which), begl, ife); end; if (i > 1) then do; i = i - 1; substr (output, ofe + 1, i) = substr (input, ifi, i); ofe = ofe + i; ifi = ifi + i; end; if (substr (input, ifi, 2) ^= "&;") then do; call ampersand (ifp, ifi, ife, ofp, ofe, TF, "0"b); goto loop; end; construct_nest = construct_nest - 1; end; if (substr (input, ifi, 2) ^= "&;") then do; msg = "&;"; call error_missing (cmd (which), begl, ife); end; call strip2 (ifp, ifi, ife); if (found = 0) | (which = 0) then do; j = ofe - jj; var_ptr = vptr; if (var.type = 0) then do; if (var.len ^= j) then do; if (var.len > 0) then do; if al_sw then call ioa_ ("F ^a ^i ^p", vname, var.len, var.ref); free vartext in (free_area); end; var.len = j; allocate vartext in (free_area) set (var.ref); if al_sw then call ioa_ ("A ^a ^i ^p", vname, size (vartext), var.ref); end; vartext = substr (output, jj + 1, j); if db_sw | tr_sw then do; call ioa_$nnl ("#^a:^a^-&^a ^a =", lineno (begl), lineno (ifi - 1), cmd (which), var.name); call show_string (vartext, "&; "); end; end; else do; arr_ptr = var.ref; if (var.type = 2) then do; array.l_bound = min (array.l_bound, lower); array.h_bound = max (array.h_bound, higher); end; if (var.type = 3) then do; do arr_elem = array.l_bound to array.h_bound; if (arrtext = substr (output, jj + 1, j)) then do; ofe = jj; return; end; end; if (array.h_bound = var.len) then do; msg = "Attempt to add too many elements to list. " ; goto add_identification; end; array.h_bound, lower, higher = array.h_bound + 1; end; do arr_elem = lower - array.lower + 1 to higher - array.lower + 1; if (array.len (arr_elem) ^= j) then do; if (array.ref (arr_elem) ^= null ()) then do; if al_sw then call ioa_ ("F ^a{^i} ^i ^p", vname, arr_elem, array.len (arr_elem), array.ref (arr_elem)); free arrtext in (free_area); end; array.len (arr_elem) = j; allocate arrtext in (free_area) set (array.ref (arr_elem)); if al_sw then call ioa_ ("A ^a{^i} ^i ^p", vname, arr_elem, size (arrtext), array.ref (arr_elem)); end; arrtext = substr (output, jj + 1, j); end; if db_sw | tr_sw then do; call ioa_$nnl ("#^a:^a^-&^a ^a{^i:^i} =", lineno (begl), lineno (ifi - 1), cmd (which), var.name, lower, higher); call show_string (substr (output, jj + 1, j), "&; "); end; end; end; ofe = jj; end macro_let; %page; /* -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- */ /* */ /* double any quotes in a string */ macro_quote: proc (ifp, ifi, ife, ofp, ofe, tf); dcl ifp ptr, /* pointer to input */ ifi fixed bin (24), /* first char of input to use */ ife fixed bin (24), /* last char of input to use */ ofp ptr, /* pointer to output */ ofe fixed bin (24), /* last char of output used */ tf bit (2); /* 1x- process true */ /* x1- process false */ dcl begl fixed bin (24); dcl inputa (ife) char (1) based (ifp); dcl input char (ife) based (ifp); dcl output char (1044480) based (ofp); dcl (i, j, ii, jj) fixed bin (24); dcl inside bit (1); dcl ch char (1); /* &quote ... &; */ begl = ifi; ifi = ifi + 6; call strip (ifp, ifi, ife); ii = ofe; construct_nest = construct_nest + 1; loop: i = index (substr (input, ifi), "&"); if (i = 0) then do; msg = "&;"; call error_missing ("quote", begl, ife); end; if (i > 1) then do; i = i - 1; substr (output, ofe + 1, i) = substr (input, ifi, i); ofe = ofe + 1; ifi = ifi + 1; end; if (substr (input, ifi, 2) ^= "&;") then do; call ampersand (ifp, ifi, ife, ofp, ofe, tf, "0"b); goto loop; end; call strip2 (ifp, ifi, ife); i = ofe - ii; if (i > 16384) then do; msg = "Sorry, not yet handling &quote strings > 16384 chrs."; goto add_identification; end; construct_nest = construct_nest - 1; if (index (substr (output, ii + 1, i), """") = 0) then do; return; end; begin; dcl argstr char (i); argstr = substr (output, ii + 1, i); ofe = ii; j = 1; loop: ii = index (substr (argstr, j), """"); if (ii = 0) then ii = i - j + 1; substr (output, ofe + 1, ii) = substr (argstr, j, ii); ofe = ofe + ii; j = j + ii; if (substr (output, ofe, 1) = """") then do; substr (output, ofe + 1, 1) = """"; ofe = ofe + 1; end; if (j > i) then return; goto loop; end; end macro_quote; %page; /* -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- */ /* */ /* rescan a result of macro expansion */ macro_scan: proc (ifp, ifi, ife, ofp, ofe, TF); dcl ifp ptr, /* pointer to input */ ifi fixed bin (24), /* first char of input to use */ ife fixed bin (24), /* last char of input to use */ ofp ptr, /* pointer to output */ ofe fixed bin (24), /* last char of output used */ TF bit (2); dcl begl fixed bin (24); dcl inputa (ife) char (1) based (ifp); dcl input char (ife) based (ifp); dcl output char (1044480) based (ofp); dcl (i, j, ii, jj) fixed bin (24); dcl loc (24) fixed bin (24); dcl sep_ct fixed bin (24); dcl argstrl fixed bin (24); /* &scan ... &; */ begl = ifi; ifi = ifi + 5; call strip (ifp, ifi, ife); if db_sw then call dumper ("scan", ifp, ifi, ife, ofp, ofe, TF); ii = ofe; construct_nest = construct_nest + 1; loop: i = index (substr (input, ifi), "&"); if (i = 0) then do; msg = "&;"; call error_missing ("scan", begl, ife); end; if (i > 1) then do; i = i - 1; substr (output, ofe + 1, i) = substr (input, ifi, i); ofe = ofe + i; ifi = ifi + i; end; if (substr (input, ifi, 2) = "&;") then do; call strip2 (ifp, ifi, ife); argstrl = ofe - ii; if (argstrl > 16384) then do; msg = "&scan string > 16384 chars."; goto add_identification; end; begin; dcl argstr char (argstrl); if db_sw | tr_sw then do; call ioa_$nnl ("#^a:^a^-&scan ", lineno (begl), lineno (ifi - 1)); call show_string (substr (output, ii + 1, argstrl), "&; "); end; string (argstr) = substr (output, ii + 1, argstrl); ofe = ii; call expand (addr (argstr), 1, argstrl, ofp, ofe, (TF)); construct_nest = construct_nest - 1; return; end; end; call ampersand (ifp, ifi, ife, ofp, ofe, TF, "0"b); goto loop; end macro_scan; %page; /* -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- */ /* */ /* return part of a string with needed padding */ macro_substr: proc (ifp, ifi, ife, ofp, ofe, TF); dcl ifp ptr, /* pointer to input */ ifi fixed bin (24), /* first char of input to use */ ife fixed bin (24), /* last char of input to use */ ofp ptr, /* pointer to output */ ofe fixed bin (24), /* last char of output used */ TF bit (2); dcl begl fixed bin (24); dcl inputa (ife) char (1) based (ifp); dcl input char (ife) based (ifp); dcl output char (1044480) based (ofp); dcl (i, j, ii, jj) fixed bin (24); dcl loc (24) fixed bin (24); dcl sep_ct fixed bin (24); dcl argstrl fixed bin (24); /* &substr ... , ARITH , ARITH &; &substr ... , ARITH &; &substr ... , ARITH : ARITH &; */ begl = ifi; ifi = ifi + 7; call strip (ifp, ifi, ife); if db_sw then call dumper ("subs", ifp, ifi, ife, ofp, ofe, TF); ii = ofe; construct_nest = construct_nest + 1; loop: i = search (substr (input, ifi), "&,"); if (i = 0) then do; msg = "&;"; call error_missing ("substr", begl, ife); end; if (i > 1) then do; i = i - 1; substr (output, ofe + 1, i) = substr (input, ifi, i); ofe = ofe + i; ifi = ifi + i; end; if (inputa (ifi) = "&") then do; call ampersand (ifp, ifi, ife, ofp, ofe, TF, "0"b); goto loop; end; argstrl = ofe - ii; if (argstrl > 16384) then do; msg = "&substr string > 16384 chrs."; goto add_identification; end; begin; dcl argstr char (argstrl); dcl sepch char (1); argstr = substr (output, ii + 1, argstrl); ofe = ii; ifi = ifi - 1; call arithmetic (ifp, ifi, ife, ofp, ofe, TF); i = fixed (substr (output, ii + 1, ofe - ii)); sepch = " "; ofe = ii; if (inputa (ifi) = ",") | (inputa (ifi) = ":") then do; sepch = inputa (ifi); ifi = ifi - 1; call arithmetic (ifp, ifi, ife, ofp, ofe, TF); j = fixed (substr (output, ii + 1, ofe - ii)); ofe = ii; end; if (substr (input, ifi, 2) ^= "&;") then goto misplaced; call strip2 (ifp, ifi, ife); if (TF ^= "00"b) then do; if (i < 0) then i = argstrl + i + 1; if (sepch = " ") then j = argstrl - i + 1; if (sepch = ":") then do; if (j < 1) then do; msg = "Substr end location <0. "; goto add_identification; end; if (j < i) then do; msg = "Substr end before begin. "; goto add_identification; end; j = j - i + 1; end; if (j < 0) then do; jj = (argstrl - i + 1) + j; if (jj < 0) then do; substr (output, ofe + 1, -jj) = " "; ofe = ofe - jj; j = -j + jj; end; else j = -j; end; if (i < 1) then do; msg = "Substr before string begin. "; goto add_identification; end; if (i > argstrl) then do; msg = "Substr after string end. "; msg_etc = ltrim (char (i)); msg_etc = msg_etc || ","; msg_etc = msg_etc || ltrim (char (j)); msg_etc = msg_etc || " of "; msg_etc = msg_etc || ltrim (char (argstrl)); msg_etc = msg_etc || """"; msg_etc = msg_etc || argstr; msg_etc = msg_etc || """"; goto add_identification; end; substr (output, ofe + 1, j) = substr (argstr, i); ofe = ofe + j; end; end; construct_nest = construct_nest - 1; end macro_substr; %page; /* -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- */ /* */ /* remove doubled quotes and surrounding quotes (if any) from a string */ macro_unquote: proc (ifp, ifi, ife, ofp, ofe, tf); dcl ifp ptr, /* pointer to input */ ifi fixed bin (24), /* first char of input to use */ ife fixed bin (24), /* last char of input to use */ ofp ptr, /* pointer to output */ ofe fixed bin (24), /* last char of output used */ tf bit (2); /* 1x- process true */ /* x1- process false */ dcl begl fixed bin (24); dcl inputa (ife) char (1) based (ifp); dcl input char (ife) based (ifp); dcl output char (1044480) based (ofp); dcl (i, j, ii, jj) fixed bin (24); dcl inside bit (1); dcl ch char (1); /* &unquote ... &; */ begl = ifi; ifi = ifi + 8; call strip (ifp, ifi, ife); ii = ofe; construct_nest = construct_nest + 1; loop: i = index (substr (input, ifi), "&"); if (i = 0) then do; msg = "&;"; call error_missing ("unquote", begl, ife); end; if (i > 1) then do; i = i - 1; substr (output, ofe + 1, i) = substr (input, ifi, i); ofe = ofe + 1; ifi = ifi + 1; end; if (substr (input, ifi, 2) ^= "&;") then do; call ampersand (ifp, ifi, ife, ofp, ofe, tf, "0"b); goto loop; end; call strip2 (ifp, ifi, ife); construct_nest = construct_nest - 1; i = ii; inside = "0"b; do ii = ii + 1 to ofe; ch = substr (output, ii, 1); if (ch = """") then do; if inside then do; if (substr (output, ii + 1, 1) = """") then do; ii = ii + 1; goto use_char; end; else inside = "0"b; end; else inside = "1"b; end; else do; use_char: i = i + 1; substr (output, i, 1) = ch; end; end; ofe = i; end macro_unquote; %page; /* -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- */ /* */ /* show the macros used up to this point */ macro_usage: proc (ifp, ifi, ife, ofp, ofe, TF); dcl ifp ptr, /* pointer to input */ ifi fixed bin (24), /* first char of input to use */ ife fixed bin (24), /* last char of input to use */ ofp ptr, /* pointer to output */ ofe fixed bin (24), /* last char of output used */ TF bit (2); dcl begl fixed bin (24); dcl inputa (ife) char (1) based (ifp); dcl input char (ife) based (ifp); dcl output char (1044480) based (ofp); dcl (i, j, ii, jj) fixed bin (24); dcl loc (24) fixed bin (24); dcl sep_ct fixed bin (24); dcl argstrl fixed bin (24); dcl ctl char (100) var; dcl ret_str char (256); dcl ret_len fixed bin (24); dcl ioa_$rsnpnnl entry options (variable); /* &usage string &; */ begl = ifi; ifi = ifi + 6; call strip (ifp, ifi, ife); if db_sw then call dumper ("usag", ifp, ifi, ife, ofp, ofe, TF); ii = ofe; construct_nest = construct_nest + 1; loop: i = index (substr (input, ifi), "&"); if (i = 0) then do; msg = "&;"; call error_missing ("usage", begl, ife); end; if (i > 1) then do; i = i - 1; substr (output, ofe + 1, i) = substr (input, ifi, i); ofe = ofe + i; ifi = ifi + i; end; if (substr (input, ifi, 2) = "&;") then do; call strip2 (ifp, ifi, ife); ctl = substr (output, ii + 1, ofe - ii); ofe = ii; do maclp = macro_list_p repeat (macro_list.next) while (maclp ^= null ()); call ioa_$rsnpnnl (ctl, ret_str, ret_len, macro_list.dname, macro_list.ename, macro_list.name); substr (output, ofe + 1, ret_len) = substr (ret_str, 1, ret_len); ofe = ofe + ret_len; end; construct_nest = construct_nest - 1; return; end; call ampersand (ifp, ifi, ife, ofp, ofe, TF, "0"b); goto loop; end macro_usage; %page; /* -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- */ /* */ /* process a protected string */ protected: proc (ifp, ifi, ife, ofp, ofe); dcl ifp ptr, /* pointer to input */ ifi fixed bin (24), /* first char of input to use */ ife fixed bin (24), /* last char of input to use */ ofp ptr, /* pointer to output */ ofe fixed bin (24); /* last char of output used */ dcl begl fixed bin (24); dcl inputa (ife) char (1) based (ifp); dcl input char (ife) based (ifp); dcl output char (1044480) based (ofp); dcl (i, j, ii, jj) fixed bin (24); dcl loc (24) fixed bin (24); dcl sep_ct fixed bin (24); dcl argstrl fixed bin (24); /* &" ... {&"&"} ... &" */ begl = ifi; ifi = ifi + 2; do while ("1"b); i = index (substr (input, ifi), "&"""); if (i = 0) then do; msg = "&"""; call error_missing ("""", begl, ife); end; i = i - 1; substr (output, ofe + 1, i) = substr (input, ifi, i); ofe = ofe + i; ifi = ifi + i + 2; if (substr (input, ifi, 2) ^= "&""") then return; substr (output, ofe + 1, 2) = "&"""; ofe = ofe + 2; ifi = ifi + 2; end; end protected; %page; /* -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- */ /* */ /* scan a string and print it indenting 1 HT. */ show_string: proc (str1, str2); dcl (str1, str2) char (*); dcl (i, j, k) fixed bin (24); dcl HT_sw bit (1); i = 1; do while (i <= length (str1)); j = index (substr (str1, i), NL); if (j = 0) then do; j = length (str1) - i + 1; HT_sw = "0"b; end; else HT_sw = "1"b; k = i + j; call ioa_$nnl ("^a^[^-^]", substr (str1, i, j), HT_sw); i = k; end; call ioa_$nnl ("^a", str2); end show_string; %page; /* -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- */ /* */ /* skip over whitespace. strip2 moves ahead 2 first */ strip2: proc (ifp, ifi, ife); ifi = ifi + 2; strip: entry (ifp, ifi, ife); dcl ifp ptr, ifi fixed bin (24), ife fixed bin (24); dcl input char (ife) based (ifp); dcl i fixed bin (24); loop: i = verify (substr (input, ifi), space); if (i = 0) then ifi = ife + 1; else ifi = ifi + i - 1; if (substr (input, ifi, 1) ^= "&") then return; i = verify (substr (input, ifi + 1), token_chars); if (substr (input, ifi + 1, i) ^= "comment") then return; i = index (substr (input, ifi), "&;"); if (i = 0) then do; msg = "&;"; call error_missing ("comment", ifi, ifi + 8); end; ifi = ifi + i + 1; goto loop; /* keep on stripping */ end strip2; %page; /* -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- */ /* */ /* return the lbound/hbound of an array */ var_bound: proc (ifp, ifi, ife, ofp, ofe, TF) recursive; dcl ifp ptr, /* pointer to input */ ifi fixed bin (24), /* first char of input to use */ ife fixed bin (24), /* last char of input to use */ ofp ptr, /* pointer to output */ ofe fixed bin (24), /* last char of output used */ TF bit (2); dcl begl fixed bin (24); dcl inputa (ife) char (1) based (ifp); dcl input char (ife) based (ifp); dcl output char (1044480) based (ofp); dcl (i, j, ii, jj) fixed bin (24); dcl loc (24) fixed bin (24); dcl (sep_ct, level) fixed bin (24); dcl argstrl fixed bin (24); dcl vname char (32) var; /* &lbound xxx&; &hbound xxx&; */ ii = ofe; call strip (ifp, ifi, ife); loop: i = index (substr (input, ifi), "&"); if (i = 0) then do; msg = "Missing terminator on &"; msg = msg || c32; msg = msg || ". "; goto add_identification; end; if (i > 1) then do; i = i - 1; substr (output, ofe + 1, i) = substr (input, ifi, i); ofe = ofe + i; ifi = ifi + i; end; if (substr (input, ifi, 2) ^= "&;") then do; call ampersand (ifp, ifi, ife, ofp, ofe, TF, "0"b); goto loop; end; vname = substr (output, ii + 1, ofe - ii); ofe = ii; j = lookup (vname); if (j = 0) then do; msg = "Attempt to reference undeclared variable """; msg = msg || vname; msg = msg || """. "; goto add_identification; end; if (var.type = 0) then do; msg = "Attempt to get "; msg = msg || c32; msg = msg || " of a scalar. "; goto add_identification; end; arr_ptr = var.ref; if (var.type = 1) /* array */ | (var.type = 2) /* array var */ | (var.type = 3) /* list */ then do; if (c32 = "lbound") then i = array.l_bound; else i = array.h_bound; end; if (var.type = 4) /* fifo */ | (var.type = 5) /* lifo */ then do; msg = "Cannot get "; msg = msg || c32; msg = msg || " of "; if (var.type = 5) then msg = msg || "l"; else msg = msg || "f"; msg = msg || "ifo."; goto add_identification; end; end var_bound; %page; /* -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- */ /* */ /* */ var_range: proc (ifp, ifi, ife, ofp, ofe, TF); dcl ifp ptr, /* pointer to input */ ifi fixed bin (24), /* first char of input to use */ ife fixed bin (24), /* last char of input to use */ ofp ptr, /* pointer to output */ ofe fixed bin (24), /* last char of output used */ TF bit (2); dcl begl fixed bin (24); dcl inputa (ife) char (1) based (ifp); dcl input char (ife) based (ifp); dcl output char (1044480) based (ofp); dcl (i, j, ii, jj) fixed bin (24); dcl separator char (150) var; dcl vptr ptr; dcl limit fixed bin; /* &var{ ARITH } yields argument ARITH */ /* &var{ ARITH : ARITH } yields arguments ARITH thru ARITH */ /* separated by a SP */ /* &var{ ARITH : ARITH , STRING } yields arguments ARITH thru ARITH */ /* separated by STRING */ begl = ifi; ii = ofe; i = lookup (c32); if (i = 0) then do; msg = "Attempt to reference undeclared array. "; goto add_identification; end; if (var.type = 0) then do; msg = "Attempt to make non-scalar ref to scalar variable """; msg = msg || c32; msg = msg || """. "; goto add_identification; end; vptr = var_ptr; arr_ptr = var.ref; i = array.l_bound; j = array.h_bound; ifi = ifi - 2; call get_range (ifp, ifi, ife, ofp, ofe, TF, i, j); var_ptr = vptr; arr_ptr = var.ref; if (TF ^= "00"b) then do; if (var.type = 4) | (var.type = 5) then do; if (i ^= j) then do; msg = "Attempt to make multiple ref to stack """; msg = msg || c32; msg = msg || """. "; goto add_identification; end; if (i > 0) then do; msg = "Attempt to ref positive stack element """; msg = msg || c32; msg = msg || """. "; goto add_identification; end; if (var.type = 4) then do; i, j = array.l_bound - i; if (i > array.h_bound) then do; msg = "Attempt to ref non-existant stack element in """ ; msg = msg || c32; msg = msg || """. "; goto add_identification; end; end; else do; i, j = array.h_bound + i; if (i < array.l_bound) then do; msg = "Attempt to ref non-existant stack element in """ ; msg = msg || c32; msg = msg || """. "; goto add_identification; end; end; end; else do; if (i < array.l_bound) then do; msg = "Attempt to reference below lower bound. "; goto add_identification; end; if (j > array.h_bound) then do; msg = "Attempt to reference above upper bound. "; goto add_identification; end; end; end; separator = " "; if (inputa (ifi) = ",") then do; ifi = ifi + 1; do while ("1"b); jj = search (substr (input, ifi), "&}"); if (jj = 0) then do; msg = "}"; call error_missing ("xxx{", begl, ife); end; if (jj > 1) then do; jj = jj - 1; substr (output, ofe + 1, jj) = substr (input, ifi, jj); ifi = ifi + jj; ofe = ofe + jj; end; if (inputa (ifi) = "}") then do; separator = substr (output, ii + 1, ofe - ii); ofe = ii; goto end_range; end; call ampersand (ifp, ifi, ife, ofp, ofe, TF, "0"b); end; end; if (inputa (ifi) = "}") then do; end_range: ifi = ifi + 1; if (TF = "00"b) then return; var_ptr = vptr; arr_ptr = var.ref; limit = j - array.lower + 1; do arr_elem = i - array.lower + 1 to limit; substr (output, ofe + 1, array.len (arr_elem)) = arrtext; ofe = ofe + array.len (arr_elem); if (arr_elem ^= limit) then do; substr (output, ofe + 1, length (separator)) = separator; ofe = ofe + length (separator); end; end; end; else do; msg = "&var{ ... }"; goto syntax_err; end; end var_range; %page; /* -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- */ /* */ /* reference a variable */ var_ref: proc (ifp, ifi, ife, ofp, ofe, TF) recursive; dcl ifp ptr, /* pointer to input */ ifi fixed bin (24), /* first char of input to use */ ife fixed bin (24), /* last char of input to use */ ofp ptr, /* pointer to output */ ofe fixed bin (24), /* last char of output used */ TF bit (2); dcl begl fixed bin (24); dcl inputa (ife) char (1) based (ifp); dcl input char (ife) based (ifp); dcl output char (1044480) based (ofp); dcl (i, j, ii, jj) fixed bin (24); dcl loc (24) fixed bin (24); dcl (sep_ct, level) fixed bin (24); dcl argstrl fixed bin (24); /* &xxx */ /* xxx can be SCALAR, FIFI, or LIFO */ if (TF = "00"b) then return; begl = ifi; j = lookup (c32); if (j = 0) then do; msg = "Attempt to reference undeclared variable """; msg = msg || c32; msg = msg || """. "; goto add_identification; end; if (var.type = 0) then do; if (c32 = watchword) then call ioa_ ("^a ^i ""^va""", watchword, var.len, var.len, vartext); substr (output, out_len + 1, var.len) = vartext; out_len = out_len + var.len; end; else do; arr_ptr = var.ref; if (var.type = 4) then do; if (array.l_bound > array.h_bound) then do; msg = "Attempt to reference empty fifo """; msg = msg || c32; msg = msg || """. "; goto add_identification; end; arr_elem = mod (array.l_bound, var.len) + 1; if (c32 = watchword) then call ioa_ ("^a{^i} ^i ""^va""", watchword, arr_elem, array.len (arr_elem), array.len (arr_elem), arrtext) ; substr (output, out_len + 1, array.len (arr_elem)) = arrtext; out_len = out_len + array.len (arr_elem); array.l_bound = array.l_bound + 1; if al_sw then call ioa_ ("F ^a{^i} ^i ^p", c32, arr_elem, array.len (arr_elem), array.ref (arr_elem)); free arrtext in (free_area); end; else if (var.type = 5) then do; if (array.l_bound > array.h_bound) then do; msg = "Attempt to reference empty lifo """; msg = msg || c32; msg = msg || """. "; goto add_identification; end; arr_elem = array.h_bound; if (c32 = watchword) then call ioa_ ("^a{^i} ^i ""^va""", watchword, arr_elem, array.len (arr_elem), array.len (arr_elem), arrtext) ; substr (output, out_len + 1, array.len (arr_elem)) = arrtext; out_len = out_len + array.len (arr_elem); array.h_bound = array.h_bound - 1; if al_sw then call ioa_ ("F ^a{^i} ^i ^p", c32, arr_elem, array.len (arr_elem), array.ref (arr_elem)); free arrtext in (free_area); end; else do; msg = "Attempt to make scalar reference to non-scalar """; msg = msg || c32; msg = msg || """. "; goto add_identification; end; end; end var_ref; %page; /* -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- -+- */ /* */ /* EXTERNAL entry to cleanup the processing environment */ dcl ref_path char (168); free: entry (pr_sw); dcl pr_sw bit (1); dcl define_area_ entry (ptr, fixed bin (35)); dcl release_area_ entry (ptr); if free_area_p ^= null () then do; tptr = ext_var_ptr; call free_um ("ext"); ext_var_ptr = null (); do while (int_vars_base ^= null ()); int_var_ptr = int_vars_base; if db_sw then call ioa_ ("^p^-macro ^a", int_var_ptr, int_vars.macro); int_vars_base = int_vars.next; tptr = int_vars.ref; call free_um ("int"); if al_sw then call ioa_ ("F int_vars ^p", int_var_ptr); free int_vars in (free_area); end; tptr = macro_list_p; if (tptr ^= null ()) & pr_sw then call ioa_ ("^aS USED:", who_am_i); do while (tptr ^= null ()); maclp = tptr; if pr_sw & (macro_list.dname ^= "") then do; call ioa_ ("^i:^i ^a>^a -- (^a.macro)", macro_list.from, macro_list.to, macro_list.dname, macro_list.ename, macro_list.name); end; tptr = macro_list.next; macro_holder_p = macro_list.ref; if (substr (macro_list.dname, 1, 4) = " &") then do; macro_holder_l = macro_list.to; if al_sw then call ioa_ ("F macro_holder ^p", macro_holder_p); free macro_holder in (free_area); end; if al_sw then call ioa_ ("F macro_list ^p", maclp); free macro_list in (free_area); end; call release_area_ (free_area_p); free_area_p = null (); end; macro_list_p = null (); err_ct (*) = 0; macro_nest = 0; return; dcl dname char (168); dcl ename char (32); dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed bin (24), char (*), fixed bin (35)); /* * * * * * * * * * * * * * INTERNAL STATIC DATA * * * * * * * * * * * * * */ dcl al_sw bit (1) int static init ("0"b); dcl db_sw bit (1) int static init ("0"b); dcl end_sym char (8) var; dcl err_ct (0:4) fixed bin int static init ((5) 0); dcl ext_var_ptr ptr int static init (null ()); dcl free_area_p ptr int static init (null ()); dcl int_vars_base ptr int static init (null ()); dcl lg_sw bit (1) int static init ("0"b); dcl macro_list_p ptr int static init (null ()); dcl macro_nest fixed bin int static init (0); dcl pc_sw bit (1) int static init ("0"b); dcl watchword char (32) int static init (""); dcl who_am_i char (12) var int static; /* * * * * * * * * * * * * * * * CONSTANTS * * * * * * * * * * * * * * * * */ dcl NL char (1) int static options (constant) init (" "); dcl space char (5) int static options (constant) init (" "); /* * * * * * * * * * * * * * * * STRUCTURES * * * * * * * * * * * * * * * * */ dcl var_ptr ptr; dcl 1 var based (var_ptr), 2 next ptr, /* next variable in list */ 2 name char (16), 2 type fixed bin, /* 0-scalar 1-array 2-array var */ /* 3-list 4-fifo 5-lifo */ 2 len fixed bin, /* length of data string */ 2 ref ptr; /* points to data string */ dcl vartext char (var.len) based (var.ref); dcl arr_ptr ptr; dcl 1 array based (arr_ptr), 2 lower fixed bin, 2 l_bound fixed bin, /* defined lower bound */ 2 h_bound fixed bin, /* defined higher bound */ 2 elem (var.len), 3 len fixed bin, /* length of data string */ 3 ref ptr; /* points to data string */ dcl arrtext char (array.len (arr_elem)) based (array.ref (arr_elem)); dcl arr_elem fixed bin (24); dcl int_var_ptr ptr; dcl 1 int_vars based (int_var_ptr), 2 next ptr, 2 ref ptr, /* points to variable definition */ 2 macro char (32); /* name of macro owning it */ dcl maclp ptr; dcl 1 macro_list based (maclp), 2 next ptr, 2 ref ptr, 2 dname char (168), 2 ename char (32), 2 from fixed bin (24), 2 to fixed bin (24), 2 name char (32), 2 int_mac bit (1); /* 1- &macro/&define'ed */ /* * * * * * * * * * * * * LOOSE ARRAYS and SCALARS * * * * * * * * * * * * */ dcl argleng_less_than_zero condition; dcl bc fixed bin (24); dcl c32 char (32) var; dcl c32x char (32) var; dcl call_err bit (1); dcl ch_2nd char (1); dcl construct_nest fixed bin (24); dcl free_area area based (free_area_p); dcl i fixed bin (24); dcl jaf fixed bin (24); dcl local_var_ptr ptr; dcl macro_holder char (macro_holder_l) based (macro_holder_p); dcl macro_holder_l fixed bin (24); dcl macro_holder_p ptr; dcl msg_etc char (1000) var; dcl myname char (32) var; dcl output char (1044480) based (out_ptr); dcl save_db bit (1); dcl seg char (sege) based (segptr); dcl sega (sege) char (1) based (segptr); dcl sege fixed bin (24); dcl segi fixed bin (24); dcl segii fixed bin (24); dcl segment char (sege) based (segptr); dcl segptr ptr; dcl segtype char (8) var; dcl start_sym char (8) var; dcl tptr ptr; dcl token_chars char (63) int static options (constant) init ("abcdefghijklmnopqrstuvwxyz" || "ABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789"); dcl tr_sw bit (1); dcl error_table_$action_not_performed fixed bin (35) ext static; dcl error_table_$archive_fmt_err fixed bin (35) ext static; dcl error_table_$badsyntax fixed bin (35) ext static; dcl error_table_$new_search_list fixed bin (35) ext static; dcl error_table_$no_search_list fixed bin (35) ext static; dcl error_table_$translation_aborted fixed bin (35) ext static; dcl error_table_$translation_failed fixed bin (35) ext static; dcl ioa_ entry options (variable); dcl com_err_ entry options (variable); dcl archive_util_$first_element entry (ptr, fixed bin (35)); dcl archive_util_$search entry (ptr, ptr, char (32), fixed bin (35)); dcl ioa_$nnl entry options (variable); dcl hcs_$make_ptr entry (ptr, char (*), char (*), ptr, fixed bin (35)); dcl hcs_$fs_get_seg_ptr entry (char (*), ptr, fixed bin (35)); dcl get_seg_ptr_ entry (char (*), bit (6), fixed bin (24), ptr, fixed bin (35)); dcl mac_sw bit (1); dcl (addr, addrel, char, convert, divide, fixed, hbound, index, length, ltrim, max, min, mod, null, reverse, rtrim, search, size, string, substr, translate, verify) builtin; dbn: entry; db_sw = "1"b; return; aln: entry; al_sw = "1"b; return; pcn: entry; pc_sw = "1"b; return; lgn: entry; lg_sw = "1"b; return; lgf: entry; lg_sw = "0"b; return; pcf: entry; pc_sw = "0"b; return; alf: entry; al_sw = "0"b; return; dbf: entry; db_sw = "0"b; return; watch: entry (watchfor); dcl watchfor char (*); watchword = watchfor; return; end;