active_fnc_err_.alm 11/11/89 1144.7r w 11/11/89 0803.9 9909 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** " Transfer vector to appropriate entrypoints in com_err_: Required to allow the entry " active_fnc_err_$suppress_name to exist " Note: This transfer vector must be bound with com_err_ " Created: 15 December 1981 by G. Palter name active_fnc_err_ segdef active_fnc_err_ segdef suppress_name segdef af_suppress_name " compatability active_fnc_err_: getlp tra com_err_$active_fnc_err_ suppress_name: af_suppress_name: getlp tra com_err_$af_suppress_name end  adjust_float_.alm 11/11/89 1144.7rew 11/11/89 0803.9 21987 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1983 * " * * " *********************************************************** bool digit_0,060 " this code is used to adjust a float decimal " number preparatory to the edit step. the float decimal number is " normalized to contain no leading zeros and the PL/I exponent is " returned as a decimal number. The PL/I exponent is " original_exponent - number leading zeros + q - sf " where q is scale (number of digits after v in picture), " and sf is picture scale factor. " call adjust_float_(pt,pp,exp) " where pt ptr points at number " pp ptr points at picture_image block " exp fixed dec(3) is set to exponent to use in edit " " this code runs in the stack frame of its caller. " segdef adjust_float_ " equ prec,56 equ scale,57 equ t,58 equ t1,59 " adjust_float_: epp2 ap|2,* get ptr to float dec number epp2 2|0,* epp3 ap|6,* get ptr to exponent epp4 ap|4,* get ptr to picture info block epp4 4|0,* ldq 4|0 get packed prec & scale lls 18 ana =o777,dl get precision eax7 0,al tct (pr,rl) count leading zeros desc9a 2|0(1),x7 arg zero_table-12 arg sp|t ttn float_zero skip if all zero sta sp|prec save precision lls 9 isolate scale ana =o777,dl sta sp|scale and save ldq =o177,dl isolate number leading digits ansq sp|t mlr (pr,x7),(pr) extract exponent desc9a 2|0(1),1 desc9a sp|t1,1 ldq sp|t1 get exponent qls 1 qrs 28 lxl6 sp|t get number leading zeros tze l1 skip if none lda sp|prec get back precision sba sp|t compute number of digits to move mlr (pr,rl,x6),(pr,rl),fill(digit_0) move digits over to normalize desc9a 2|0(1),al desc9a 2|0(1),x7 sbq sp|t correct exponent l1: asq sp|scale set scale = exponent lda 4|1 get picture scale factor als 9 ars 27 neg 0 asa sp|scale get final exponent ldq 4|1 get length of exponent field lls 27 ana =o777,dl ada 1,dl btd (pr),(pr,rl) desc9a sp|scale,4 desc9ls 3|0,al short_return " float_zero: mlr (0),(pr) move zero into exponent desc9a zero,4 desc9a 3|0,4 short_return " zero: aci "+000" zero_table: oct 000001002003,004005006007,011012000000 end  assign_.alm 11/11/89 1144.7r w 11/11/89 0803.9 140040 " ****************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright (c) 1987 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " ****************************************************** " " Modified: 01/04/79 by PCK to fix bug 1809 " Modified: 12 July 79 by JRD to add computational_ entry pt. " Modified: 12 Nov 79 by JRD fix overpunched table entries " Following 23 Jan 84 Modifications covered by MTB672 " Modified: 23 Jan 84 by TGO fix get_picture_type (pict_type_to_etype has length 0) " Modified: 23 Jan 84 by TGO update computational_ to use re-written " any_to_any_ which understands uns, ts_overp, ls_overp. " Modified: 23 Jan 84 by TGO to use desc9a, rather than desc6a. " Modified: 23 Jan 84 by TGO to recover lp correctly using * tag modification " Modified: 23 Jan 84 by TGO to utilize picture's precision and scale " for ata call. Otherwise we blow conversion to common type. entry arith_to_char_ entry arith_to_bit_ entry bit_to_char_ entry char_to_bit_ entry arith_to_arith_ entry char_to_arith_ entry bit_to_arith_ entry assign_ entry assign_round_ entry assign_truncate_ entry char_to_numeric_ entry computational_ " tempd work(100) " the following temps are only used by the computational_ entry pt. " although I dont object if others use them, too. " temp src_temp(256) "if source must go to int. form temp tar_temp(256) "if target must go to int. form temp type_save "save internal type of target temp temp1 "a temp target for EIS instructions tempd str_ptr_save "save one of the structure ptrs tempd arglist(4) "for calling picture conversion utils " Include Files include stack_frame include stack_header Conversion Calls. arith_to_char_: arith_to_bit_: push lda stack_frame.support_bit,dl orsa sp|stack_frame.flag_word lda 0|4,* target descriptor lrl 28 ana =o177,dl eax6 0,al lda 0,dl qls 4 lls 24 sta work lda 0|8,* source descriptor lrl 28 ana =o177,dl eax7 0,al lls 28+12 lrs 24 qrs 6 lls 18 go: sta work+1 epp1 0|2,* target epp3 0|6,* source epp5 work epp2 * spbp2 sp|38 text base ptr ldaq work tsx0 lp|ata,* epbp7 sp|0 return bit_to_char_: char_to_bit_: push lda stack_frame.support_bit,dl orsa sp|stack_frame.flag_word lda 0|4,* target descriptor lrl 28 ana =o177,dl eax6 0,al lda 0,dl qls 4 lls 24 sta work lda 0|8,* source descriptor lrl 28 ana =o177,dl eax7 0,al lda 0,dl qls 4 lls 24 tra go " arith_to_arith_: push lda stack_frame.support_bit,dl orsa sp|stack_frame.flag_word lda 0|4,* target descriptor lrl 28 ana =o177,dl eax6 0,al lls 28+12 lrs 24 qrs 6 lls 18 sta work lda 0|8,* source descriptor lrl 28 ana =o177,dl eax7 0,al lls 28+12 lrs 24 qrs 6 lls 18 tra go char_to_arith_: bit_to_arith_: push lda stack_frame.support_bit,dl orsa sp|stack_frame.flag_word lda 0|4,* target descriptor lrl 28 ana =o177,dl eax6 0,al lls 28+12 lrs 24 qrs 6 lls 18 sta work lda 0|8,* source descriptor lrl 28 ana =o177,dl eax7 0,al lda 0,dl qls 4 lls 24 tra go " assign_: eax0 ata push lda stack_frame.support_bit,dl orsa sp|stack_frame.flag_word lxl6 ap|4,* target type lxl7 ap|10,* source type lda ap|6,* target length ldq ap|12,* source length epp1 ap|2,* target ptr epp1 1|0,* epp3 ap|8,* source ptr epp3 3|0,* epp5 work cmpb (x6),(0) is target varying descb varying_info,1 zero tze 2,ic epp1 1|1 yes, skip over length cmpb (x7),(0) is source varying descb varying_info,1 zero tze 2,ic epp3 3|1 yes, skip over length epp2 * spbp2 sp|38 tsx0 lp|0,0* epbp7 sp|0 return " assign_round_: eax0 ata_round tra assign_+1 " assign_truncate_: eax0 ata_truncate tra assign_+1 " char_to_numeric_: push lda stack_frame.support_bit,dl orsa sp|stack_frame.flag_word epp3 ap|8,* source ptr epp3 3|0,* epp1 ap|2,* target ptr epp1 1|0,* ldq ap|10,* source length epp5 work epp2 * spbp2 sp|38 tsx0 lp|ctn_link,* epbp7 sp|0 epp0 sp|26,* sta ap|6,* precision & scale stz ap|4,* sxl7 ap|4,* type return " varying_info: oct 0,031400000000,0 " link ata,|[any_to_any_] link ata_round,|[any_to_any_round_] link ata_truncate,|[any_to_any_truncate_] link ctn_link,|[char_to_numeric_] " " Convert any computational type to any other computational type " Most types are handled directly by any_to_any_, but certain types are " handled by us. If the source is "special" we convert it to a type that " any_to_any_ can handle. If the target is "special", we convert to a close " type, then convert to final type ourself. " Because there is certain to be one call to any_to_any_, we need not worry " about scale any_to_any_ will deal with it for us. equ target_str_ptr_arg,2 " offset from ap for arg equ source_str_ptr_arg,4 equ error_code_arg,6 " The computational_ entry point has three arguments, the first " two args, are each a structure given by computational_data.incl.pl1. The " last argument is a standard error code. " " dcl 1 computational_data aligned based, " 2 address ptr aligned, " 2 data_type fixed bin (17), " 2 flags aligned, " 3 packed bit (1) unal, " 3 pad bit (35) unal, " 2 prec_or_length fixed bin (24), " 2 scale fixed bin (35), " 2 picture_image_ptr ptr aligned; " equ address_offset,0 equ data_type_offset,2 equ flags_offset,3 equ prec_or_length_offset,4 equ scale_offset,5 equ picture_image_ptr_offset,6 "REGISTER USAGE "x0 random "x1 random "x2 random "x3 random equ maj_call,4 "x4 return offset for major subroutines equ min_call,5 "x5 return offset for minor subroutines equ tar_type,6 "x6 type code of target equ src_type,7 "x7 type code of source "pr0 is ap equ tar_ptr,1 "pr1 -> target equ src_str_pr,2 "pr2 -> source structure equ src_ptr,3 "pr3 -> source "pr4 is lp equ tar_str_pr,5 "pr5 -> target structure "pr6 is sp "pr7 is sb " A holds target precision, Q holds source precision " There are two levels of subroutines in this program - major and minor. Each " level has a dedicated index register used for saving return linkage. No " " minor routine calls any other routine, no major routine calls any but a " " minor routine. Scale and precision for source and target are setup in the " " target buffer, permitting special source/target handling to modify initial " settings. This is used for PICTURE processing. arg_header: oct 000006000004 " 3 args, inter_seg call oct 0 " no descriptors link ata,any_to_any_$any_to_any_ " Computational assignment/source " This entry will accept any valid MULTICS type for a source or target, " including picture items. computational_: push stz ap|error_code_arg,* " optimism epp src_str_pr,ap|source_str_ptr_arg,* " ptr to arg (ptr to str) epp src_str_pr,src_str_pr|0,* " get ptr to str lxl 0,src_str_pr|data_type_offset tsx min_call,get_internal_type "into x0 " Pre-set source precision and scale. ldq src_str_pr|scale_offset qls 18 orq src_str_pr|prec_or_length_offset stq tar_temp+1 " save scale/prec epp src_ptr,src_str_pr|address_offset,* tsx maj_call,source_dispatch_table,x0* "source has been converted, if necessary "src_ptr and src_type are LIVE - they must be preserved "the prec and scale are that of the source epp tar_str_pr,ap|target_str_ptr_arg,* epp tar_str_pr,tar_str_pr|0,* lxl 0,tar_str_pr|data_type_offset tsx min_call,get_internal_type stx 0,type_save " Pre-set target precision and scale. lda tar_str_pr|scale_offset als 18 " get scale in high half ora tar_str_pr|prec_or_length_offset " this could be > 16383 for string sta tar_temp epp tar_ptr,tar_str_pr|address_offset,* tsx maj_call,target_dispatch_table,x0* "tar_ptr and tar_type are LIVE " it is known that any_to_any_ can handle what we have "now set up for the call to any_to_any_ " " pr1 -> target pr3 -> source " x6 target type x7 source type " A target encoded prec. Q source encoded prec " pr5 -> work area " " a data type to any_to_any_ is a standard Multics type * 2 " with the LSB set if the data is 'packed' " we must shift tar_type and src_type stx tar_type,temp1 adlx tar_type,temp1 " times 2 szn tar_str_pr|flags_offset "packed is in MSB tpl 2,ic adx tar_type,1,du "set LSB for unaligned stx src_type,temp1 adlx src_type,temp1 szn src_str_pr|flags_offset tpl 2,ic adx src_type,1,du epp 5,* spbp 5,sp|38 "calling a pl1 operator! epp 5,work lda tar_temp " pick up target scale/len ldq tar_temp+1 " pick up source scale/len tsx0 lp|ata,* "use x0 for pl1_operator call Processing after any_to_any_ conversion. "everything but ap and sp is now clobbered - recover epbpsb sp|0 epp tar_str_pr,ap|target_str_ptr_arg,* epp tar_str_pr,tar_str_pr|0,* lda tar_str_pr|prec_or_length_offset epp tar_ptr,tar_str_pr|address_offset,* ldx 0,type_save tra final_dispatch_table,x0* " " here are the dispatch tables " equ normal_,0 equ varying,1 equ picture,2 equ not_com,3 source_dispatch_table: arg normal_src "any_to_any_ can handle it arg varying_src "must bump address past varying word arg picture_src arg not_comput_type target_dispatch_table: arg normal_tar arg varying_tar arg picture_tar arg not_comput_type final_dispatch_table: arg just_go arg just_go arg cnv_to_picture arg not_comput_type " Major processing routines. " Now come the major routines - first those that convert from source to " intermediate. Then those that prepare for any_to_any_ to convert to " intermediate. Then those tra'd to to finish up. not_comput_type: lda error_table_$bad_conversion sta ap|error_code_arg,* return varying_src: epp src_ptr,src_ptr|1 normal_src: lxl src_type,src_str_pr|data_type_offset tra 0,maj_call picture_src: ldaq arg_header staq arglist spri5 str_ptr_save "must preserve 2 epp5 src_temp spri5 arglist+2 epp5 src_str_pr|picture_image_ptr_offset,* spri5 arglist+4 epp5 src_str_pr|address_offset,* spri5 arglist+6 call unpack_picture_$unpack_picture_(arglist) epp5 str_ptr_save,* ldx 3,picture_image.type_word,du ldq src_str_pr|picture_image_ptr_offset,*3 tsx min_call,get_picture_type eax src_type,0,ql "what was pic converted to? epp src_ptr,src_temp " Get precision and scale of source. epp2 src_str_pr|picture_image_ptr_offset,* " pointer to picture_image lda pr2|picture_image.prec_word ars picture_image.prec_shift " position ana picture_image.prec_mask,dl " isolate sta tar_temp+1 lda pr2|picture_image.scale_word ars picture_image.scale_shift " position ana picture_image.prec_mask,dl " isolate als 18 orsa tar_temp+1 " integrate tra 0,maj_call " Conversion of any_to_any_ output to final target " routines to set up for any_to_any_ call to int. target varying_tar: epp tar_ptr,tar_ptr|1 normal_tar: lxl tar_type,tar_str_pr|data_type_offset tra 0,maj_call picture_tar: ldx 3,picture_image.type_word,du ldq tar_str_pr|picture_image_ptr_offset,*x3 tsx min_call,get_picture_type "what is most like the target? eax tar_type,0,ql epp tar_ptr,tar_temp " Get precision and scale of target. epp2 tar_str_pr|picture_image_ptr_offset,* " pointer to picture_image lda pr2|picture_image.prec_word ars picture_image.prec_shift " position ana picture_image.prec_mask,dl " isolate sta tar_temp lda pr2|picture_image.scale_word ars picture_image.scale_shift " position ana picture_image.prec_mask,dl " isolate als 18 orsa tar_temp " integrate tra 0,maj_call " " now the final routines " note that lp must be restored - any_to_any_ has clobbered it " just_go: return "target was reachable by any_to_any_ cnv_to_picture: " we must carefully avoid clobberring pr5 it is the tar_str_pr epp lp,sp|stack_frame.lp_ptr,* "must reload, been clobbered ldaq arg_header staq arglist spri1 arglist+2 "target ptr epp2 tar_str_pr|picture_image_ptr_offset,* spri2 arglist+4 epp 2,tar_temp spri2 arglist+6 call pack_picture_$pack_picture_(arglist) return " Minor routines for conversion of data types and picture types. get_internal_type: "given external data type in x0 "return internal type in x0 stz temp1 cmpx0 type_index_limit,du See if we know it tpnz not_comput_type Too big for table mlr (x0),(pr) desc9a type_index,1 desc9a temp1(1),1 ldx 0,temp1 tra 0,min_call get_picture_type: " call with picture_image.type_word in Q " return equivalent external type in QL qrs picture_image.type_shift stz temp1 cmpq pict_type_to_etype_limit,dl Is it in table? tpnz not_comput_type mlr (ql),(pr) desc9a pict_type_to_etype,1 desc9a temp1(3),1 ldq temp1 tra 0,min_call pict_type_to_etype: " 4 entries per word " in octal " macro pict_type vfd 9/&1,9/&2,9/&3,9/&4 &endm maclist object pict_type 00,00,00,00 " 0 - 3 pict_type 00,00,00,00 " 4 - 7 pict_type 00,00,00,00 " 8 - 11 pict_type 00,00,00,00 " 12 - 15 pict_type 00,00,00,00 " 16 - 19 pict_type 00,00,00,00 " 20 - 23 pict_type 21,09,11,10 " 24 - 27 pict_type 12,00,00,00 " 28 - 31 pict_type 00,00,00,00 " 32 - 35 pict_type 00,00,00,00 " 36 - 39 pict_type 00,00,00,00 " 40 - 43 pict_type 00,00,00,00 " 44 - 47 pict_type 00,00,00,00 " 48 - 51 pict_type 00,00,00,00 " 52 - 55 pict_type 00,00,00,00 " 56 - 59 pict_type 00,00,00,00 " 60 - 63 pict_type 00,00,00,00 " 64 - 67 pict_type 00,00,00,00 " 68 - 71 pict_type 00,00,00,00 " 72 - 75 pict_type 00,00,00,00 " 76 - 79 pict_type 00,00,00,00 " 80 - 83 pict_type 00,00,00,00 " 84 - 87 equ pict_type_to_etype_limit,87 Type conversion and picture defintion " map all data types (0 -87) " into internal type code " 4 bits per code " internal type is used as index into dispatch tables macro type_table vfd 9/&1,9/&2,9/&3,9/&4 &endm type_index: type_table normal_,normal_,normal_,normal_ " 00 - 03 type_table normal_,normal_,normal_,normal_ " 04 - 07 type_table normal_,normal_,normal_,normal_ " 08 - 11 type_table normal_,not_com,not_com,not_com " 12 - 15 type_table not_com,not_com,not_com,normal_ " 16 - 19 type_table varying,normal_,varying,not_com " 20 - 23 type_table not_com,not_com,not_com,not_com " 24 - 27 type_table not_com,normal_,normal_,not_com " 28 - 31 type_table not_com,normal_,normal_,normal_ " 32 - 35 type_table normal_,normal_,normal_,normal_ " 36 - 39 type_table normal_,normal_,normal_,normal_ " 40 - 43 type_table normal_,normal_,normal_,normal_ " 44 - 47 type_table normal_,normal_,normal_,not_com " 48 - 51 type_table not_com,not_com,not_com,not_com " 52 - 55 type_table not_com,not_com,not_com,not_com " 56 - 59 type_table not_com,not_com,not_com,picture " 60 - 63 type_table not_com,not_com,not_com,not_com " 64 - 67 type_table not_com,not_com,not_com,not_com " 68 - 71 type_table not_com,not_com,not_com,not_com " 72 - 75 type_table not_com,not_com,not_com,not_com " 76 - 79 type_table not_com,normal_,normal_,normal_ " 80 - 83 type_table normal_,normal_,normal_,not_com " 84 - 87 equ type_index_limit,87 include picture_image end  bcd_to_ascii_.alm 11/11/89 1144.7rew 11/11/89 0803.8 45522 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** """"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""" """"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""" " " " T R A N S L A T E B C D T O A S C I I " " " This routine will translate a number of bcd characters to ascii. It " takes three parameters. Parameter 1 is a pointer to an aligned " bcd string. Parameter 2 is the length of that string (number of bcd " characters). Parameter 3 is a pointer to an aligned receiving field " for the translated ascii output. " " The entry point, bcd_to_ascii_, takes a bit string as input, " and produces a character string of length divide(length(input), 6, 24) " as output. " " PL/I Usage: " dcl bcd_to_ascii_ entry(bit(*), char(*)) " call bcd_to_ascii_ (input bits, output chars) " " The entry point, ascii_to_bcd_, takes a character string " as input and produces a bit string of length divide (length (output),6,24) " as output. If the output string has more bcd char positions " than there are input chars to convert, then the output is blank filled. " " PL/1 Usage: " " dcl ascii_to_bcd_ entry (char (*), bit (*)); " call ascii_to_bcd_ (input_chars, output_bits); " " WRITTEN BY DICK SNYDER JANUARY 3,1972 " MODIFIED BY T. CASEY JUNE 1974, AUGUST 1974 " REWRITTEN BY D. KAYDEN DECEMBER 1974 " ENTRY POINT ADDED BY R.J.C.KISSEL 11/09/76 " MODIFIED BY R.H. MORRISON 5/19/76 " MODIFIED BY R.J.C. KISSEL 09/19/77 to pad with blanks " MODIFIED BY J. A. BUSH 11/10/82 to add ascii_to_bcd_ entry point " """"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""" """"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""" name bcd_to_ascii_ entry gcos_cv_gebcd_ascii_ segdef bcd_to_ascii_ segdef ascii_to_bcd_ gcos_cv_gebcd_ascii_: eppbp ap|2,* bp->input data eppbp bp|0,* lda ap|4,* get char count eppap ap|6,* ap->output buffer eppap ap|0,* mvt (pr,rl),(pr,rl) desc6a bp|0,al desc9a ap|0,al arg bta_tab short_return bcd_to_ascii_: epp1 ap|2,* address of source string to pr1 epp3 ap|4,* address of target string to pr3 ldx3 0,du set x3 not to skip parent pointer if none lxl2 ap|0 load arg list code value canx2 =o0000004,du check for no parent pointer (code 4) tnz *+2 transfer if no parent pointer ldx3 2,du parent pointer, set x3 to skip it ldq ap|6,x3* load source string descriptor anq mask drop all but string size bits div 6,dl get length of input in BCD characters lda ap|8,x3* load target string descriptor ana mask drop all but string size bits even "EIS address must be even mvt (pr,rl),(pr,rl),fill(020) now do the bcd to ascii desc6a 1|0,ql desc9a 3|0,al arg bta_tab short_return ascii_to_bcd_: " ascii to bcd entry epp1 ap|2,* address of source string to pr1 epp3 ap|4,* address of target string to pr3 ldx3 0,du set x3 not to skip parent pointer if none lxl2 ap|0 load arg list code value canx2 =o0000004,du check for no parent pointer (code 4) tnz *+2 transfer if no parent pointer ldx3 2,du parent pointer, set x3 to skip it ldq ap|8,x3* load target string descriptor anq mask drop all but string size bits div 6,dl get length of target in BCD characters lda ap|6,x3* load source string descriptor ana mask drop all but string size bits even "EIS address must be even mvt (pr,rl),(pr,rl),fill(040) now do the ascii to bcd desc9a 1|0,al desc6a 3|0,ql arg atb_tab short_return mask: oct 000077777777 even bta_tab: aci X0123456789[#@:>?X aci X abcdefghi&.](<\X aci X^jklmnopqr-$*);'X aci X+/stuvwxyz_,%="!X atb_tab: " ascii chars 000 - 037 (8) - invalid bcd chars set to bcd "?" (ignore char) oct 017017017017,017017017017,017017017017,017017017017 oct 017017017017,017017017017,017017017017,017017017017 " ascii chars 040 - 057 (8) = " !"#$%&'()*+,-./" oct 020077076013,053074032057,035055054060,073052033061 " ascii chars 060 - 077 (8) = "0123456789:semicolon<=>?" oct 000001002003,004005006007,010011015056,036075016017 " ascii chars 100 - 117 (8) = "@ABCDEFGHIJKLMNO" oct 014021022023,024025026027,030031041042,043044045046 " ascii chars 120 - 137 (8) = "PQRSTUVWXYZ[\]^_" oct 047050051062,063064065066,067070071012,037034040072 " ascii chars 140 - 157 (8) = "`abcdefghijklmno" oct 017021022023,024025026027,030031041042,043044045046 " ascii chars 160 - 177 (8) = "pqrstuvwxyz{|}~PAD" oct 047050051062,063064065066,067070071012,040034017017 end  bce_command_processor_.pl1 11/11/89 1144.7r w 11/11/89 0803.9 57762 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /* Simple command line parser extracted from command_processor_ */ /* BIM 10/82 */ /* This does not have to be as ruthlessly efficient as the */ /* real command processor. */ /* format: style2 */ bce_command_processor_: procedure (Line, Command_finder, Info_ptr, Code); declare Line character (*); declare Command_finder entry (pointer, character (*), fixed binary (35)) returns (entry) variable; declare Info_ptr pointer; declare Code fixed binary (35); /* Remaining declarations */ dcl 1 arg_list aligned, /* the argument list being constructed */ 2 twice_n_arguments fixed binary (18) unaligned unsigned, 2 tag bit (18) unaligned initial ("000004"b3), /* PL/1 */ 2 twice_n_descriptors fixed binary (18) unaligned unsigned, 2 arg_ptrs (32) pointer, 2 descriptor_ptrs (32) pointer; dcl 1 descriptors (32) aligned, /* descriptions of above arguments */ 2 bits bit (12) unaligned,/* flag(1), type(6), packed(1), ndims(4) */ 2 size fixed binary (24) unaligned unsigned; dcl descriptor_ptrs_for_move bit (72 * n_arguments) aligned based; /* to move descriptor pointers to proper place in arglist */ dcl reading_command_name bit (1) aligned; /* ON => picking up command name, not an argument */ dcl end_of_command bit (1) aligned; /* ON => reached the end of a command */ dcl n_arguments fixed binary; /* # of arguments for this command */ dcl (token_lth, next_start) fixed binary (21); dcl command_name character (command_name_lth) unaligned based (command_name_ptr); dcl command_name_ptr pointer; /* -> name of the command to invoke */ dcl command_name_lth fixed binary; dcl command_entry_ptr pointer; /* -> the actual command to be run */ dcl line_lth fixed binary (21); dcl line_ptr pointer; dcl line char (line_lth) based (line_ptr); dcl start fixed binary; dcl command_entry entry (pointer) variable; dcl forbid_semicolons bit (1) aligned; dcl error_table_$cp_reserved_syntax external static fixed binary (35); dcl error_table_$too_many_args external static fixed binary (35); dcl cu_$generate_call entry (entry, pointer); %page; dcl BREAKS character (12) static options (constant) initial (";()[]""| "); /* command language break characters and NL, HT, SP, VT, FF */ dcl TOKEN_BREAKS character (6) static options (constant) initial (""" "); /* breaks for tokens only: " NL HT SP VT FF */ dcl SIMPLE_BREAKS character (6) static options (constant) initial ("; "); /* ; and whitespace (NL HT SP VT FF) */ dcl NON_SIMPLE_BREAKS character (6) static options (constant) initial ("()[]""|"); dcl NON_SIMPLE_BREAKS_SEMI character (7) static options (constant) initial ("()[]""|;"); /* characters requiring special processing */ dcl COMMAND_BREAKS character (2) static options (constant) initial ("; "); /* characters which separate command invocations (;, NL) */ %page; /* bce_command_processor_: proc (Line, Command_finder, Code) */ ss_info_ptr = Info_ptr; forbid_semicolons = ss_info.forbid_semicolons; line_ptr = addr (Line); line_lth = length (Line); /* first estimate */ line_lth = length (rtrim (line, SIMPLE_BREAKS)); start = verify (line, SIMPLE_BREAKS); if start = 0 /* null command line */ then do; Code = 100; /* just like everything else ... */ return; end; if (forbid_semicolons & search (line, NON_SIMPLE_BREAKS_SEMI) ^= 0) | (^forbid_semicolons & search (line, NON_SIMPLE_BREAKS) ^= 0) then do; Code = error_table_$cp_reserved_syntax; return; end; do while (start <= line_lth); reading_command_name = "1"b; end_of_command = "0"b; n_arguments = 0; do while (^end_of_command); token_lth = search (substr (line, start), SIMPLE_BREAKS) - 1; if token_lth = -1 then /* rest of the command line */ token_lth = line_lth - start + 1; /* break is one beyond the end */ if reading_command_name then do; command_name_ptr = addr (substr (line, start, 1)); command_name_lth = token_lth; reading_command_name = "0"b; end; else do; n_arguments = n_arguments + 1; if n_arguments > hbound (arg_list.arg_ptrs, 1) then do; Code = error_table_$too_many_args; return; end; arg_list.arg_ptrs (n_arguments) = addr (substr (line, start, 1)); arg_list.descriptor_ptrs (n_arguments) = addr (descriptors (n_arguments)); descriptors (n_arguments).bits = "5260"b3; /* unaligned, nonvarying string */ descriptors (n_arguments).size = token_lth; end; start = start + token_lth; /* skip over token to delimiters */ if (start > line_lth) then end_of_command = "1"b; /* entire line used */ else do; /* search for next token and check for end of a command invocation (semi-colon or new-line in delimiters) */ next_start = verify (substr (line, start), SIMPLE_BREAKS); if (next_start = 0) then do; /* rest of line is delimiters */ next_start = line_lth - start + 2; end_of_command = "1"b; end; else end_of_command = (search (substr (line, start, (next_start - 1)), COMMAND_BREAKS) ^= 0); start = start + next_start - 1; end; end; arg_list.twice_n_arguments, arg_list.twice_n_descriptors = 2 * n_arguments; if n_arguments < hbound (arg_list.arg_ptrs, 1) then /* need to move descriptor pointers down */ addr (arg_list.arg_ptrs (n_arguments + 1)) -> descriptor_ptrs_for_move = addr (arg_list.descriptor_ptrs) -> descriptor_ptrs_for_move; command_entry = Command_finder (Info_ptr, command_name, Code); if Code ^= 0 then return; ss_info.arg_list_ptr = addr (arg_list); call command_entry (addr (ss_info)); end; %include bce_subsystem_info_; end bce_command_processor_;  bootload_fs_.pl1 11/11/89 1144.7rew 11/11/89 0803.9 221076 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * *********************************************************** */ bootload_fs_: procedure; return; /* format: style4,insnl,delnl,indattr */ /* Coded by Benson I. Margulies late at night(s) in early November 1980 */ /* Modified by Keith Loepere, March 1983 for get_ptr and put_ptr entrypoints. */ /* Modified by Keith Loepere, July 1984 for fixes relating to character lengths and force writing the file sys. */ /* bootload_fs_ manages a primitive file system in a disk partition for Bootload Multics. The file system is intended to be unbreakable, and therefore in no need of salvaging EVER. To this end, linked lists are not used. A finite file table is used, and files are contiguous. Any consistency checks must be possible on a local per-file level. *** ENTRIES *** bootload_fs_$lookup declare bootload_fs_$lookup entry (char (*), fixed bin (21), fixed bin (35)); call bootload_fs_$lookup (file_name, length, code); where: file_name (input) is a file name, 32 characters or less. no checks are made on the legality of the characters. length (output) is the length of the file, in characters. files are always an even number of characters long. code (output) is a standard system status code, error_table_$noentry for a file that isn't there. bootload_fs_$list: declare bootload_fs_$list entry (area (*), pointer, fixed bin (35)); call bootload_fs_$list (work_area, info_pointer, code); where: work_area (input) is an area in which a structure containing the list information can be allocated. info_pointer (output) is a pointer to tthe structure bootload_fs_listing(.incl.pl1) code (output) is a standard system status code. It may be error_table_$noalloc if the work_area was not big enough. bootload_fs_$get: declare bootload_fs_$get (char (*), pointer, fixed bin (21), fixed bin (21), fixed bin (35)); call bootload_fs_$get (file_name, data_pointer, max_length, length, code); where: file_name (input) is the file name, dummy. data_pointer (input) is a pointer to the place to copy the data to. max_length (input) is the maximum length (in characters) of the space pointed to by data_pointer. length (output) is the length of the file. code (output) is a standard system status code. It may be error_table_$long_record if the file cannot be fit into max_length. bootload_fs_$get_ptr: declare bootload_fs_$get_ptr (char (*), pointer, fixed bin (21), fixed bin (35)); call bootload_fs_$get_ptr (file_name, data_pointer, length, code); where: file_name (input) is the file name. data_pointer (output) is a pointer to the file in the partition. length (output) is the length of the file. code (output) is a standard system status code. bootload_fs_$put: declare bootload_fs_$put entry (char (*), pointer, fixed bin (21), bit (1) aligned, fixed bin (35)); call bootload_fs_$put (file_name, data_pointer, length, create_switch, code); where: file_name (input) is the file name to be put. data_pointer (input) is a pointer to the data to be put. length (input) is the length of the data in characters. create_switch (input) if this is "1"b, the file must not already exist in the bootload file system. If it does not, error_table_$namedup is returned. code (output) is a standard system status code. bootload_fs_$put_ptr: declare bootload_fs_$put_ptr entry (char (*), fixed bin (21), bit (1) aligned, ptr, fixed bin (35)); call bootload_fs_$put (file_name, length, create_switch, data_pointer, code); where: file_name (input) is the file name to be put. length (input) is the length of the data to be written in characters. create_switch (input) if this is "1"b, the file must not already exist in the bootload file system. If it does not, error_table_$namedup is returned. data_pointer (output) a ptr to the area in the partition into which to put the file code (output) is a standard system status code. Note: After a put_ptr op, the user should call bootload_fs_$flush_sys. bootload_fs_$delete: declare bootload_fs_$delete entry (char (*), fixed bin (35)); call bootload_fs_$delete (file_name, code); where: file_name (input) is the name of the file to delete. code (output) is a standard system status code. bootload_fs_$rename: declare bootload_fs_$rename entry (char (*), char (*), fixed bin (35)); call bootload_fs_$rename (old_file_name, new_file_name, code); where: old_file_name (input) is the file to be renamed. new_file_name (input) is the new name. code (output) is a standard system status code. bootload_fs_$init: declare bootload_fs_$init entry (bit (1) aligned, fixed bin, fixed bin (35)); call bootload_fs_$init (init_switch, length, code); where: init_switch (input) if this is "1"b, then reinitialize the partition to length length. Otherwise, expect it to be initialized. length (input) if init_switch is "1"b, this is the length in pages of the partition. code (output) is a standard error code. If init_switch is not "1"b, and the partition does not have the correct sentinels, it will be error_table_$improper_data_format. */ %page; /* The following is the basic data structure of the partition. The partition must be accessable before it can be seen as a segment by doing disk io to pick up the correct page. The first two pages of the partition are reserved for the header. This includes the directory and the free block map. Thereafter the partition is considered to consist of 64 word character blocks, to make finding them easy. Files are made of contiguous sets of blocks. Initialization or compaction sweeps the directory to recreate the free map to recover pages lost. All allocations start by clearing the free bit, so that blocks cannot be reused, ever. */ declare 1 bootload_file_partition$ aligned external, 2 part_header aligned, 3 small_things aligned, 4 sentinel char (32), 4 part_pages fixed bin, /* length in pages of partition */ 4 part_blocks fixed bin, /* length in 64 word blocks WITHOUT header */ 3 maps aligned, 4 free_block_map (4048) bit (1) unal, /* max 64 word blocks in 253K */ /* maximum number of 64 word blocks in a 255 word partition */ 4 pad_align1 bit (20) unal, 4 free_file_map (174) bit (1) unal, 4 pad_align2 bit (6) unal, /* brings to 200 octal */ 3 directory (174) aligned, 4 name char (32) unal, 4 length_in_chars fixed bin (21), /* not including fractional blocks */ 4 first_block fixed bin, 4 n_blocks fixed bin, 3 pad_align3 (6) fixed bin; /* bring to 2 pages */ declare 1 partition_storage aligned based (addr (bootload_file_partition$)), 2 header_page (header_size) bit (36) aligned, 2 blocks (part_header.part_blocks) char (256) unal; declare block_map (part_header.part_blocks) bit (1) unal defined (part_header.free_block_map); declare block_map_string bit (part_header.part_blocks) defined (part_header.free_block_map) unal; %include bootload_fs_list; declare ( a_init_switch bit (1) aligned, a_area area (*), a_part_length fixed bin (19), a_file_name char (*), a_new_file_name char (*), a_code fixed bin (35), a_create_switch bit (1) aligned, a_data_pointer pointer, a_length fixed bin (21), a_max_length fixed bin (21) ) parameter; dcl header_size fixed bin (19) init (size (bootload_file_partition$)); /* size of the header in words */ dcl i fixed bin; dcl code fixed bin (35); dcl file_name char (32); dcl new_file_name char (32); dcl copy_length fixed bin (21); dcl copy_data character (copy_length) based; dcl data_pointer pointer; dcl copy_pointer pointer; dcl file_idx fixed bin; dcl file_count fixed bin; dcl i_length fixed bin (21); dcl max_length fixed bin (21); dcl init_switch bit (1) aligned; dcl create_switch bit (1) aligned; dcl part_length fixed bin (19); dcl ptr_entry bit (1) aligned; dcl Sentinel char (32) aligned init ("Bootload Multics File Partition") internal static options (constant); dcl Blocks_per_page fixed bin int static init (16) options (constant); dcl Chars_per_block fixed bin int static init (256) options (constant); dcl (addr, bin, copy, divide, hbound, index, min, null, segno, size, string, substr, sum) builtin; dcl area condition; dcl get_ptrs_$given_segno entry (fixed bin (15)) returns (ptr); dcl get_ring_ entry () returns (fixed bin (3)); dcl pc_wired$write_wait entry (ptr, fixed bin, fixed bin); dcl sub_err_ entry () options (variable); dcl syserr$error_code entry options (variable); dcl ( error_table_$noentry, error_table_$noalloc, error_table_$namedup, error_table_$long_record, error_table_$improper_data_format ) ext static fixed bin (35); dcl sys_info$bce_max_seg_size ext static fixed bin (18); dcl sys_info$initialization_state ext fixed bin; %page; init: entry (a_init_switch, a_part_length, a_code); init_switch = a_init_switch; part_length = a_part_length; call SETUP_init; if ^init_switch then do; /* the partition has to be in good shape */ if part_header.sentinel ^= Sentinel then do; code = error_table_$improper_data_format; goto SET_CODE_RETURN; /* caller should call us back with init_switch */ end; a_code = 0; return; end; else do; /* we are redoing this */ part_header.part_pages = divide (part_length + 1023, 1024, 19, 0); part_header.part_blocks = (part_header.part_pages - divide (header_size + 1023, 1024, 19, 0)) * Blocks_per_page; string (part_header.free_block_map) = ""b; /* allocate all possible blocks */ string (part_header.free_block_map) = copy ("1"b, hbound (part_header.free_block_map, 1)); /* and free those that exist */ string (part_header.free_file_map) = copy ("1"b, hbound (part_header.directory, 1)); do i = 1 to hbound (part_header.directory, 1); part_header.directory (i).name = ""; part_header.directory (i).first_block = -1; /* flag unused entries in case of bad crazyness */ part_header.directory (i).n_blocks = 0; part_header.sentinel = Sentinel; end; call flush_sys; code = 0; SET_CODE_RETURN: a_code = code; return; end; %page; lookup: entry (a_file_name, a_length, a_code); file_name = a_file_name; code = 0; i_length = 0; call LOOKUP (file_name, file_idx, a_code); if code = 0 then do; i_length = part_header.directory (file_idx).length_in_chars; end; a_length = i_length; a_code = code; return; /* how simple */ %page; list: entry (a_area, a_data_pointer, a_code); call SETUP; call COUNT_FILES (file_count); /* dont depend on redundant (possibly inconsistant data) */ if file_count = 0 then do; a_code = error_table_$noentry; /* avoid unnecessary allocation */ a_data_pointer = null (); return; end; bootload_fs_list_n_files = file_count; on area goto LIST_NO_ALLOC; allocate bootload_fs_list in (a_area); revert area; file_count = 0; do i = 1 to hbound (part_header.directory, 1) while (file_count < bootload_fs_list_n_files); if ^part_header.free_file_map (i) then do; file_count = file_count + 1; bootload_fs_list.files (file_count).name = part_header.directory (i).name; bootload_fs_list.files (file_count).length = part_header.directory (i).length_in_chars; end; end; a_code = code; a_data_pointer = bootload_fs_list_ptr; return; LIST_NO_ALLOC: a_code = error_table_$noalloc; a_data_pointer = null (); return; %page; get: entry (a_file_name, a_data_pointer, a_max_length, a_length, a_code); call SETUP; max_length = a_max_length; data_pointer = a_data_pointer; file_name = a_file_name; call LOOKUP (file_name, file_idx, code); if code ^= 0 then goto SET_CODE_RETURN; i_length = part_header.directory (file_idx).length_in_chars; copy_length = min (i_length, max_length); copy_pointer = addr (partition_storage.blocks (part_header.directory (file_idx).first_block)); data_pointer -> copy_data = copy_pointer -> copy_data; if i_length > max_length then code = error_table_$long_record; a_code = code; a_length = i_length; return; get_ptr: entry (a_file_name, a_data_pointer, a_length, a_code); call SETUP; file_name = a_file_name; call LOOKUP (file_name, file_idx, code); if code ^= 0 then goto SET_CODE_RETURN; a_length = part_header.directory (file_idx).length_in_chars; a_data_pointer = addr (partition_storage.blocks (part_header.directory (file_idx).first_block)); a_code = code; return; %page; put: entry (a_file_name, a_data_pointer, a_length, a_create_switch, a_code); ptr_entry = "0"b; data_pointer = a_data_pointer; goto put_join; put_ptr: entry (a_file_name, a_length, a_create_switch, a_data_pointer, a_code); ptr_entry = "1"b; put_join: call SETUP; file_name = a_file_name; i_length = a_length; if i_length > sys_info$bce_max_seg_size * 4 then do; a_code = error_table_$long_record; return; end; create_switch = a_create_switch; call LOOKUP (file_name, file_idx, code); if create_switch then do; /* MUST not exist */ if code = 0 then do; a_code = error_table_$namedup; return; end; end; else do; if code = 0 then do; /* we must delete old entry */ call DELETE (file_name, (0)); /* it will succeed */ end; end; call CREATE (file_name, file_idx, i_length, code);/* perhaps no space */ if code ^= 0 then do; call flush_sys; /* We may have deleted old */ goto SET_CODE_RETURN; end; if ptr_entry then a_data_pointer = addr (partition_storage.blocks (part_header.directory (file_idx).first_block)); else do; copy_length = i_length; copy_pointer = addr (partition_storage.blocks (part_header.directory (file_idx).first_block)); copy_pointer -> copy_data = data_pointer -> copy_data; call flush_sys; end; a_code = 0; return; flush_sys: entry; /* used after a put_ptr op */ call flush_sys; return; %page; rename: entry (a_file_name, a_new_file_name, a_code); call SETUP; file_name = a_file_name; new_file_name = a_new_file_name; call LOOKUP (file_name, file_idx, code); if code ^= 0 then goto SET_CODE_RETURN; call LOOKUP (new_file_name, (0), code); if code = 0 then do; code = error_table_$namedup; goto SET_CODE_RETURN; end; code = 0; part_header.directory (file_idx).name = new_file_name; call flush_sys; a_code = code; return; %page; delete: entry (a_file_name, a_code); call SETUP; file_name = a_file_name; call DELETE (file_name, code); call flush_sys; a_code = code; return; %page; LOOKUP: procedure (l_file_name, l_file_idx, l_code); dcl ( l_file_name char (*), l_file_idx fixed bin, l_code fixed bin (35) ) parameter; dcl l fixed bin; l_code = 0; l_file_idx = -1; do l = 1 to hbound (part_header.directory, 1) while (l_file_idx < 0); if ^part_header.free_file_map (l) /* we could do multiple indexes, but this dosent have to be fast */ then if part_header.directory (l).name = l_file_name then do; l_file_idx = l; end; end; if l_file_idx = -1 then l_code = error_table_$noentry; return; end LOOKUP; DELETE: procedure (d_file_name, d_code); dcl ( d_file_name char (*), d_code fixed bin (35) ) parameter; dcl d fixed bin; dcl done bit (1) aligned; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* the free-ing allocation is as follows -- always turn off in-use FIRST. then if we */ /* crash in the middle, all we will do is lose track of some space, which we will */ /* recover at the next COMPACT, if we ever do one. The other order might leave */ /* offsets to freed storage in the directory. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ d_code = 0; done = ""b; do d = 1 to hbound (part_header.directory, 1) while (^done); if ^part_header.free_file_map (d) then if part_header.directory (d).name = d_file_name then do; part_header.free_file_map (d) = "1"b; /* FREE */ part_header.directory (d).name = ""; /* cleanliness ... */ substr (block_map_string, part_header.directory (d).first_block, part_header.directory (d).n_blocks) = copy ("1"b, part_header.directory (d).n_blocks); done = "1"b; end; end; if ^done then d_code = error_table_$noentry; return; end DELETE; COUNT_FILES: procedure (count); dcl count fixed bin parameter; count = hbound (part_header.directory, 1) - sum (bin (part_header.free_file_map, 1)); /* arent builtins wonderful? */ return; end COUNT_FILES; %page; CREATE: procedure (c_file_name, c_file_idx, c_length, c_code); /* THIS DOES NOT CHECK NAMEDUP */ dcl ( c_file_name char (*), c_file_idx fixed bin, c_length fixed bin (21), c_code fixed bin (35) ) parameter; dcl c_free_block fixed bin; dcl block_need fixed bin; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* strategy: FIRST allocate storage, so that if we compact we will search for a free index */ /* in the compacted file table. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ c_code = 0; block_need = divide (c_length + Chars_per_block - 1, Chars_per_block, 17, 0); c_free_block = FIND_FREE (block_need); /* look for some space */ if c_free_block < 1 then retry: do; call COMPACT; /* Squueeze, wring */ c_free_block = FIND_FREE (block_need); if c_free_block < 1 then goto C_NO_ALLOC; end; substr (block_map_string, c_free_block, block_need) = ""b; /* check them off */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* if we got here, we made an allocation. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ c_file_idx = index (string (part_header.free_file_map), "1"b); if c_file_idx < 1 then do; c_code = error_table_$noalloc; if get_ring_ () = 0 then call syserr$error_code (3, c_code, "bootload_fs_: CREATE: no free file entries."); else call sub_err_ (c_code, "bootload_fs_", "c", null (), (0), "CREATE: no free file entries."); return; end; part_header.free_file_map (c_file_idx) = ""b; /* all ours */ part_header.directory (c_file_idx).first_block = c_free_block; part_header.directory (c_file_idx).name = c_file_name; /* it we die, leave a name that can be deleted */ part_header.directory (c_file_idx).n_blocks = block_need; part_header.directory (c_file_idx).length_in_chars = c_length; return; C_NO_ALLOC: c_code = error_table_$noalloc; if get_ring_ () = 0 then call syserr$error_code (3, c_code, "bootload_fs_ CREATE: partition filled."); else call sub_err_ (c_code, "bootload_fs_", "c", null (), (0), "CREATE: partition filled."); end CREATE; COMPACT: procedure; dcl copy_block_map (hbound (block_map, 1)) bit (1) unal; dcl copy_block_map_string bit (hbound (block_map, 1)) unal defined (copy_block_map); dcl copy_file_map (hbound (part_header.free_file_map, 1)) bit (1) unal; dcl (n_to_free, first_to_free, free_block, next_file, c_file) fixed bin; dcl (copy_pointer, data_pointer) pointer; string (copy_block_map) = copy ("1"b, hbound (block_map, 1)); string (copy_file_map) = copy ("1"b, hbound (part_header.free_file_map, 1)); /* FREE all blocks and files */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* first we make a new block_map and file_map without any garbage -- useless directory */ /* entries or unclaimed blocks. If we get interrupted while putting one of these in */ /* there is no harm donw. Then we can shift down, allocation and freeing blocks one file */ /* at a time. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ do c_file = 1 to hbound (part_header.directory, 1); if ^part_header.free_file_map (c_file) then do; /* claims to be for real */ if part_header.directory (c_file).name ^= "" & part_header.directory (c_file).first_block > 0 & part_header.directory (c_file).n_blocks > 0 then do; /* its reasonable */ copy_file_map (c_file) = ""b; /* IN USE */ substr (copy_block_map_string, part_header.directory (c_file).first_block, part_header.directory (c_file).n_blocks) = ""b; /* IN USE */ end; end; /* do not bother to free garbage in the real maps. If we crash, the next init call will do this over */ end; /* now put in the new maps */ part_header.free_file_map = copy_file_map; block_map = copy_block_map; /* now we do the real compaction, closing up space, one file at a time */ do free_block = FIND_FREE (1) repeat (FIND_FREE (1)) while (free_block > 0); next_file = find_above (free_block); /* are there any files above the first free block? */ if next_file < 1 then goto DONE_COMPACT; /* no more files */ /* move this file down into free_block and cetra */ substr (block_map_string, free_block, part_header.directory (next_file).first_block - free_block) = ""b; /* IN USE */ copy_pointer = addr (partition_storage.blocks (free_block)); data_pointer = addr (partition_storage.blocks (part_header.directory (next_file).first_block)); copy_length = part_header.directory (next_file).length_in_chars; copy_pointer -> copy_data = data_pointer -> copy_data; /* data shifted down */ n_to_free = part_header.directory (next_file).first_block - free_block; first_to_free = part_header.directory (next_file).first_block + part_header.directory (next_file).n_blocks - n_to_free; part_header.directory (next_file).first_block = free_block; substr (block_map_string, first_to_free, n_to_free) = copy ("1"b, n_to_free); end; DONE_COMPACT: return; find_above: procedure (what) returns (fixed bin); dcl what fixed bin; dcl fi fixed bin; /* we have to look for a file that claims to own blocks above what */ /* contract is to return the file index of the file owning the block above */ do fi = 1 to hbound (part_header.directory, 1); if ^part_header.free_file_map (fi) then /* has to be in use to be meaningful */ if part_header.directory (fi).first_block > what then return (fi); end; return (-1); /* no suce beastie */ end find_above; end COMPACT; FIND_FREE: procedure (f_length) returns (fixed bin); dcl f_length fixed bin; return (index (string (block_map), copy ("1"b, f_length))); end FIND_FREE; SETUP: procedure; if part_header.sentinel ^= Sentinel then do; a_code = error_table_$improper_data_format; goto RETURN; end; SETUP_init: entry; code = 0; end SETUP; RETURN: return; %page; flush_sys: proc; if sys_info$initialization_state < 4 then call pc_wired$write_wait (get_ptrs_$given_segno (segno (addr (bootload_file_partition$))), 0, -1); /* force write */ return; end flush_sys; end bootload_fs_;  com_err_.pl1 11/11/89 1144.7r w 11/11/89 0803.9 119592 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4 */ com_err_: procedure options (variable); /* com_err_ formats error messages and signals the condition "command_error". Its calling sequence is of the form: call com_err_(code, callername, ioa_control, arg1, arg2,...);. If code > 0, the corresponding error_table_ message is included. Callername is the name of the calling procedure and is inserted with a colon at the beginning of the error message. It may be either varying or fixed length; if it is null, the colon is omitted. The rest of the arguments are optional; however, if arg1, etc. are present, ioa_control must also be present. ioa_control is a regular ioa_ control string and the argi are the format arguments to ioa_. If print_sw = "1"b after signalling "command_error", the error message is printed. Several other entry points are included in this procedure. The active_fnc_err_ entry is similar to com_err_ except that the condition "active_function_error" is signalled. The suppress_name entry is identical to com_err_ except that the callername is omitted from the error message. There is an entry point for convert_status_code_, which simply looks up the code and returns the error_table_ message. */ /* initially coded by M Weaver June 1969 */ /* recoded in PL/I with several facilities added by M Weaver 2 June 1970 */ /* major surgery by J. Stern on 9/3/71 */ /* minor bug fixes by M. Weaver 3 November 1971 */ /* completely changed error code format and fixed a bug, D. Reed 6/21/72 */ /* fixed bug in argument passing to command_error signalled procedure, D. Reed 7/20/71 */ /* changed check_fs_errcode_ entry to convert_status_code_, R. Mullen 12/13/72 */ /* modified to pass info structures with standard headers, M. Weaver 8/73 */ /* Entry point active_fnc_err_$af_suppress_name added by S. Herbst 8/25/78 */ /* Modified 781203 by PG to accept any computational data type for arg 1. */ /* Modified: 8 August 1980 by G. Palter to recognize error_table_$active_function as a special case and signal active_function_error rather than command_error */ /* Modified: June 1981 to use new include file and set quiet_restart, B. Margulies */ /* Modified: February 1982 to establish any_other handler while reading error table, E. N. Kittlitz */ /* Modified: May 1984 for calling within bce, Keith Loepere */ /* Automatic */ dcl save_code fixed bin (35); dcl (active_fnc_sw, suppress_name_sw, convert_sw, packed) bit (1) aligned; dcl (ndims, scale, len, lng, type, bi, hi, lo) fixed bin (17); dcl (code, ec) fixed bin (35); dcl (q, arg_list_ptr, tp) ptr; dcl arg_ptr ptr; dcl prec fixed bin; dcl buffer char (256) aligned, retstring char (256); %include condition_info_header; %include com_af_error_info; %include mc; dcl 1 error_info aligned like com_af_error_info; /* based */ dcl strlng bit (9) aligned based (tp); /* used to reference long message length */ dcl char8 char (8) aligned based; /* used to reference short message */ dcl num fixed bin (17) based; dcl based_code fixed bin (35) based; dcl callername char (error_info.name_lth) based (error_info.name_ptr), work_string char (lng) aligned based; dcl 1 code_format aligned based (addr (code)), 2 segno bit (18) unal, 2 offset bit (18) unal; /* builtins */ dcl (addr, addrel, baseno, baseptr, bin, binary, bit, fixed, length, null, rtrim, size, string, substr, ptr) builtin; dcl request_abort_ condition; /* for aborting bootload active functions */ /* entries */ dcl bce_error$com_err entry options (variable), condition_ entry (char (*), entry), reversion_ entry (char (*)), cu_$arg_list_ptr ext entry (ptr), cu_$arg_ptr ext entry (fixed bin, ptr, fixed bin, fixed bin (35)), cu_$arg_count ext entry returns (fixed bin), cu_$generate_call entry (entry, ptr), decode_descriptor_ ext entry (ptr, fixed bin, fixed bin, bit (1) aligned, fixed bin, fixed bin, fixed bin), hcs_$high_low_seg_count entry (fixed bin, fixed bin), ioa_$rsnnl ext entry options (variable), ioa_$general_rs ext entry (ptr, fixed bin, fixed bin, char (*), fixed bin, bit (1) aligned, bit (1) aligned), iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)), signal_ ext entry (char (*), ptr, ptr, ptr); /* external static */ dcl error_table_$ ext fixed bin aligned; dcl error_table_$active_function fixed binary (35) external; dcl iox_$error_output ptr external static; dcl sys_info$service_system bit (1) aligned external static; /* internal static */ dcl nl char (1) aligned static init (" "); /* include files */ %include desc_dcls; %include std_descriptor_types; /* program */ active_fnc_sw, suppress_name_sw = "0"b; go to join; suppress_name: entry options (variable); active_fnc_sw = "0"b; suppress_name_sw = "1"b; go to join; active_fnc_err_: entry options (variable); active_fnc_sw = "1"b; suppress_name_sw = "0"b; go to join; af_suppress_name: entry options (variable); active_fnc_sw, suppress_name_sw = "1"b; join: call cu_$arg_list_ptr (arg_list_ptr); if ^sys_info$service_system then do; /* let bootload routine do it */ call cu_$generate_call (bce_error$com_err, arg_list_ptr); if active_fnc_sw then signal request_abort_; return; end; call cu_$arg_ptr (1, arg_ptr, (0), ec); call decode_descriptor_ (arg_list_ptr, 1, type, packed, ndims, prec, scale); if (type = real_fix_bin_1_dtype) & (packed = "0"b) then code = arg_ptr -> based_code; else do; intype = 2 * type + bin (packed, 1); if (type >= bit_dtype) & (type <= varying_char_dtype) then inclength = prec; else do; info.inscale = scale; info.inprec = prec; end; outtype = 2 * real_fix_bin_1_dtype; outfo.outscale = 0; outfo.outprec = 35; call assign_ (addr (code), outtype, outscale_prec, arg_ptr, intype, inscale_prec); end; /* save status code because it will be clobbered by the statements that address the error table. */ save_code = code; /* get callername */ call cu_$arg_ptr (2, error_info.name_ptr, error_info.name_lth, ec); call decode_descriptor_ (arg_list_ptr, 2, type, packed, ndims, error_info.name_lth, scale); if type = varying_char_dtype then /* varying string: use current length */ error_info.name_lth = addrel (error_info.name_ptr, -1) -> num; if suppress_name_sw then do; bi = 1; go to no_name; end; if error_info.name_lth ^= 0 then do; /* put caller name into buffer */ buffer = rtrim (callername) || ": "; bi = length (rtrim (buffer)) + 2; /* index of next character */ if bi = 3 then bi = 1; /* caller name was blank */ end; else bi = 1; /* null callername */ /* get system message */ no_name: if code ^= 0 then do; /* get message from error_table_ */ convert_sw = "0"b; /* this is not the convert_status_code_ entry point */ go to find; /* get pointer to correct message */ continue: bi = bi + lng - 1; end; /* get user message */ if cu_$arg_count () > 2 then do; if code ^= 0 then do; /* put a blank between system message and caller message */ substr (buffer, bi, 1) = " "; /* append blank */ bi = bi + 1; /* update length */ end; call ioa_$general_rs (arg_list_ptr, 3, 4, retstring, len, "0"b, "0"b); /* add new line later */ do len = len by -1 to 1 while (substr (retstring, len, 1) = " "); /* Strip off trailing blanks */ end; if len ^= 0 then do; substr (buffer, bi, len) = substr (retstring, 1, len); bi = bi + len; end; else bi = bi - 1; /* Kill the space we just put in! */ end; substr (buffer, bi, 1) = nl; /* always add new-line */ bi = bi + 1; /* for the last time... */ /* fill in the rest of error_info structure */ string (error_info.action_flags) = ""b; error_info.length = size (error_info); error_info.version = com_af_error_info_version_3; error_info.status_code = save_code; /* the unclobbered code is passed to signal */ error_info.action_flags.quiet_restart = "1"b; /* will be diddled below */ error_info.errmess_ptr = addr (buffer); error_info.errmess_lth = bi - 1; error_info.max_errmess_lth = 256; error_info.info_string = substr (buffer, 1, error_info.errmess_lth); error_info.print_sw = "1"b; /* signal the error condition */ if (active_fnc_sw | (error_info.status_code = error_table_$active_function)) then do; error_info.quiet_restart = "0"b; error_info.action_flags.default_restart = "0"b; call signal_ ("active_function_error", null, addr (error_info), null); end; else do; error_info.action_flags.default_restart = "1"b; call signal_ ("command_error", null, addr (error_info), null); end; if error_info.print_sw then call iox_$put_chars (iox_$error_output, error_info.errmess_ptr, error_info.errmess_lth, ec); return; /* section to look up code in error_table_; "returns" pointer to message */ check_fs_errcode_: /* this entry is obsolete name */ convert_status_code_: entry (P_code, shortinfo, longinfo); dcl P_code fixed bin (35), shortinfo char (8) aligned, longinfo char (100) aligned; code, save_code = P_code; if code = 0 then do; shortinfo = ""; longinfo = ""; return; end; convert_sw = "1"b; find: /* Figure out what sort of message to give back */ call hcs_$high_low_seg_count (hi, lo); /* Have to call every time, since high-seg is dynamic */ hi = hi + lo; /* Get highest valid segment number */ if code_format.segno = "000111111111111111"b then /* 077777(8) segno means code comes from system error table */ code_format.segno = bit (binary (baseno (addr (error_table_$)), 18, 0), 18); else if bin (code_format.segno, 18) <= lo /* Don't want to access supervisor segs */ then go to errdoc; else if bin (code_format.segno, 18) > hi then go to errdoc; /* Similar for large values */ else if code_format.segno & "111"b then go to errdoc; /* negative and large codes too */ q = baseptr (code_format.segno); tp = ptr (q, code_format.offset); /* get location of long string message */ call condition_ ("any_other", any_other_handler); lng = fixed (tp -> strlng, 9) + 1; if convert_sw then do; shortinfo = addrel (tp, -2) -> char8; longinfo = substr (tp -> work_string, 2); return; end; else do; substr (buffer, bi, lng) = substr (tp -> work_string, 2); call reversion_ ("any_other"); go to continue; end; errdoc: /* couldn't find code in error_table_ */ call reversion_ ("any_other"); code = save_code; /* may have been diddled */ if code < 0 /* I/O code? */ then call ioa_$rsnnl (" I/O status ^w", retstring, lng, code); else call ioa_$rsnnl (" Code ^d.", retstring, lng, code); /* Insert a blank in front so that retstring can be referenced the same as an acc string */ if convert_sw then do; /* convert_status_code_ case */ if code < 0 then shortinfo = "iostatus"; /* Return different short message */ else shortinfo = "xxxxxxxx"; longinfo = substr (retstring, 2); return; end; else do; /* com_err_ case */ tp = addr (retstring); substr (buffer, bi, lng) = substr (tp -> work_string, 2); go to continue; /* continue processing */ end; unpack_system_code_: entry (packed_code, bin_code); dcl packed_code bit (*) unaligned, bin_code fixed bin (35) aligned; if packed_code = "0"b then bin_code = 0; /* if zero, then no error */ else bin_code = binary (packed_code, 35) + 111111111111111000000000000000000b; /* add in the magic constant */ return; /* condition hander. This handler is ONLY active when convert_status_code_ or com_err_ is attempting to reference the text of the error table. If it is probable that the fault occured as a result of such a reference, we punt picking up text, and will instead generate a "Code xxx" message. */ any_other_handler: proc (mc_ptr, cname, coptr, infoptr, continue); dcl cname char (*); dcl mc_ptr ptr; dcl coptr ptr; dcl infoptr ptr; dcl continue bit (1); mcp = mc_ptr; scup = addr (mc.scu); if cname = "cleanup" then return; /* already squeaky */ if binary (baseno (tp), 18) = binary (scu.tsr, 15) then /* talking about the right segment? */ if cname = "out_of_bounds" | /* is it a reasonable fault? */ cname = "seg_fault_error" | cname = "not_in_read_bracket" | cname = "no_read_permission" then go to errdoc; /* yep - bogus error code */ continue = "1"b; /* not for us */ end; end;  condition_.alm 11/11/89 1144.7r w 11/11/89 0803.9 83187 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " *********************************************************** %; " ****************************************************** " * * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " * * " ****************************************************** name condition_ " condition_ - This procedure establishes a handler for a " specified condition. " " declare condition_ entry(char(*),entry); " " call condition_(name, handler); " " 1. name is the name of the condition. (Input) " " 2. handler is the entry to be called when the specified " condition is raised. (Input) " include stack_frame include stack_header equ on_name,0 pointer to name of condition equ on_body,2 pointer to handler for this condition equ on_size,4 length of condition name in chars equ on_next,5 thread to next condition null: its -1,1 null pointer blanks: aci " " word of blanks masks1: oct 000777777777 masks for lookin at individual chars oct 777000777777 oct 777777000777 oct 777777777000 masks2: oct 000777777777 masks for comparing strings oct 000000777777 oct 000000000777 oct 000000000000 char_count: oct 1 number of chars in last word oct 2 oct 3 oct 4 " The following conventions are used with respect to index registers: " x0 reserved for subroutine calls " x1 contains relative pointer to on unit " x2 indicates number of words to grow stack frame " x3 contains bit offset of name " x4 for use by subroutines " x5 contains number of chars in last word of condition name " x6 contains the number of words in condition name minus one " x7 reserved for subroutine calls " " pr3 used for pointer to condition name " " Completely recoded by R. J. Feiertag on November 13, 1971 " Modified by R. J. Feiertag on January 13, 1972 " Modified by C. Jensen on July 28, 1972 for the follow-on 645. " Modified by M. Weaver on November 7, 1973 to make entries for the " special handlers act like the main entries " entry condition_ condition_: eppbp ap|2,* get pointer to condition name lxl6 ap|6,* get number of chars in name eppbb ap|4,* get pointer to handler lda ap|3 get bit offset of name ars 9 .. ana =o777,dl .. eax3 0,al remember bit offset join: tsx7 find_unit look for unit for this condition tra found_condition have found unit for this condition eax2 6+1,6 must create unit so grow stack frame tsx0 grow_stack_frame .. stz lp|on_size fill in length of condition name sxl5 lp|on_size .. eaa 0,6 .. ars 16 .. asa lp|on_size .. eax3 0,3 is the name aligned tze aligned if so use aligned code copy_more: lda bp|0,6 copy name ldq bp|1,6 .. lls 0,3 .. sta lp|6,6 .. eax6 -1,6 .. tpl copy_more .. tra fill_on_unit skip aligned code aligned: lda bp|0,6 copy condition name into stack sta lp|6,6 .. eax6 -1,6 .. tpl aligned .. fill_on_unit: eppbp lp|6 place pointer to name in unit spribp lp|on_name .. stz lp|on_next thread into condition stack ldx1 sp|stack_frame.on_unit_rel_ptrs .. stx1 lp|on_next .. eaa sp|0 .. neg 0 .. eax1 lp|0,au .. stx1 sp|stack_frame.on_unit_rel_ptrs .. found_condition: eppbp bb|0,* place pointer to handler in unit spribp sp|on_body,1 .. return: short_return " " reversion_ - This procedure reverts the given condition. " " declare reversion_ entry(char(*)); " " call reversion_(name); " " 1. name name of condition to be reverted. (Input) entry reversion_ reversion_: eppbp ap|2,* get pointer to condition name lxl6 ap|4,* get length of condition name lda ap|3 get bit offset of name ars 9 .. ana =o777,dl .. eax3 0,al .. tsx7 find_unit look for on unit stz sp|on_size,1 unit found so revert it short_return return to caller " " default_handler_$set,establish_cleanup_proc_ - " These procedures establish the named handlers and procedures. " " declare (default_handler_$set,establish_cleanup_proc_) " entry(entry); " " call default_handler_$set(handler); " call establish_cleanup_proc_(handler); " " 1. handler is the entry to be invoked. (Input) any_other: aci 'any_other ' cleanup: aci 'cleanup ' entry set set: eppbp any_other get ptr to condition name eax6 9 get no. of chars in name eppbb ap|2,* get ptr to handler eax3 0 bit offset = 0 tra join use rest of code for condition_ entry establish_cleanup_proc_ establish_cleanup_proc_: eppbp cleanup get ptr to condition name eax6 7 get no. of chars in name eppbb ap|2,* get ptr to handler eax3 0 bit offset of name = 0 tra join use rest of code for condition_ " The following entries were originally intended to revert " the special handlers and are called with no arguments. entry revert revert: eppbp any_other get ptr to condition name eax6 9 get length of name eax3 0 bit offset of name = 0 tsx7 find_unit look for on unit stz sp|on_size,1 unit found so revert it short_return return to caller entry revert_cleanup_proc_ revert_cleanup_proc_: eppbp cleanup get ptr to condition name eax6 7 get length of name eax3 0 bit offset of name = 0 tsx7 find_unit look for on unit stz sp|on_size,1 unit found so revert it short_return return to caller " " The following subroutine grows the stack frame by the amount " indicated in x2. Much of this code was copied from rest_of_cu_$grow_stack_frame grow_stack_frame: epplp sb|stack_header.stack_end_ptr,* set lp to point to next available space eax2 15,2 round to next mod 16 location anx2 =o777760,du .. adlx2 sb|stack_header.stack_end_ptr+1 Add increm. to stack end ptr. stx2 sb|stack_header.stack_end_ptr+1 Save new stack end ptr. stx2 sp|stack_frame.next_sp+1 Reset current stack frame's ptr. to the next stack frame. ldq ap|0 Is this a pl1 frame? canq =o14,dl .. tze 0,0 No, return to caller. stx2 sp|5 record growth in pl1 frame tra 0,0 return to caller " " This subroutine tries to find the unit for the given condition. find_unit: lda stack_frame.condition_bit,dl make sure this is a condition stack cana sp|stack_frame.condition_word .. tnz get_length .. stz sp|stack_frame.on_unit_rel_ptrs .. orsa sp|stack_frame.condition_word .. get_length: eaa 0,6 get length of name in chars tze return if zero then done lrs 20 convert to words eax6 0,al place number of words in x6 qrl 16 get extra chars eax5 1,qu place extra chars in x5 eax3 0,3 set indicators according to value in x3 tnz unaligned if non zero bit offset use unaligned code previous_char: eax5 -1,5 reduce chars by 1 tnz next_word have we gone over word boundary eax6 -1,6 if so reduce number of words tmi return name of all blanks eax5 4 have four chars in new word next_word: lda bp|0,6 get word and check for blanks ldq masks1-1,5 .. cmk blanks .. tze previous_char if blank reduce length by 1 ldx1 sp|stack_frame.on_unit_rel_ptrs get offset of first on unit tra next_length .. next_on_unit: ldx1 sp|on_next,1 get offset of next on unit next_length: tze 1,7 cannot find unit eaa 0,6 compute length of name ars 16 .. ada char_count-1,5 .. cmpa sp|on_size,1 are names the same length tnz next_on_unit if not go to next on unit epplp sp|on_name,1* get pointer to name for this unit lda bp|0,6 compare extra chars ldq masks2-1,5 .. cmk lp|0,6 .. tnz next_on_unit no match, try next eax4 0,6 compare rest of name compare_next_word: eax4 -1,4 .. tmi 0,7 match, we are done lda bp|0,4 .. cmpa lp|0,4 .. tze compare_next_word .. tra next_on_unit no match, try next unaligned: eax5 -1,5 strip off trailing blanks tnz unal_next_word .. eax6 -1,6 .. tmi return .. eax5 4 .. unal_next_word: lda bp|0,6 .. ldq bp|1,6 align string lls 0,3 .. ldq masks1-1,5 .. cmk blanks .. tze unaligned .. ldx1 sp|stack_frame.on_unit_rel_ptrs get offset of first on unit tra unal_next_length .. unaligned_next_on_unit: ldx1 sp|on_next,1 get offset of next on unit unal_next_length: tze 1,7 cannot find unit eaa 0,6 compute length of name ars 16 .. ada char_count-1,5 .. cmpa sp|on_size,1 are names the same length tnz unaligned_next_on_unit if not go to next on unit epplp sp|on_name,1* get pointer to name for this unit lda bp|0,6 align this word of string ldq bp|1,6 .. lls 0,3 .. ldq masks2-1,5 compare extra chars cmk lp|0,6 .. tnz unaligned_next_on_unit continue comparison tnz unaligned_next_on_unit no match, try next unit eax4 0,6 compare rest of name unal_compare_next: eax4 -1,4 .. tmi 0,7 match, done lda bp|0,4 align word of string ldq bp|1,4 .. lls 0,3 .. cmpa lp|0,4 compare word tze unal_compare_next continue comparison tra unaligned_next_on_unit no match, try next unit end  config_data_.cds 11/11/89 1144.7rew 11/11/89 0803.9 200043 /* *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /* HISTORY COMMENTS: 1) change(85-09-09,Farley), approve(85-09-09,MCR6979), audit(86-01-17,CLJones), install(86-03-21,MR12.0-1033): Add support for FIPS type controlers and devices. 2) change(86-04-21,Fawcett), approve(86-04-21,MCR7381), audit(86-05-13,LJAdams), install(86-07-17,MR12.0-1097): Correct the model for the FIPS tape drives for the 4600 series to 8200 only for all drives. 3) change(86-10-02,Fawcett), approve(86-10-02,PBF7383), audit(86-10-23,Farley), install(86-10-28,MR12.0-1200): Changed 3390 to 3381. 4) change(86-10-21,Fawcett), approve(86-10-21,PBF7381), audit(86-10-23,Farley), install(86-10-28,MR12.0-1200): Removed tape drive models 3430, 3470 & 3670. The only supported FIPS tape drive is the STC 8200. END HISTORY COMMENTS */ /* config_data_ -- Database of config cards, model number, etc. */ /* format: style2 */ /* Modified 830523 to add console io_type and line_leng fields for different operator's consoles and to fix a size bug... -E. A. Ranzenbach */ /* Modified 840827 by Paul Farley for DAU (msp800) support. */ /* Modified 841101 by Paul Farley to add device_0_valid for disk & tape devices, controller entries for the IBM 3300 and the STC 3600 & 4600, and device entries for the IBM 3380 & 3390 and STC 3430, 3470, 3670, 4654, 4655 & 4670. Also to remove support of the 191 & 400 disk drive. */ /* Modified 850812 by Paul Farley to change IBM3300 to IBM3880. */ (size,stringsize,stringrange,subscriptrange): config_data_: procedure; declare c_ptr pointer; declare 1 c aligned based (c_ptr), 2 chnl_cardx fixed binary, 2 clok_cardx fixed binary, 2 cpu_cardx fixed binary, 2 fnp_cardx fixed binary, 2 intk_cardx fixed binary, 2 iom_cardx fixed binary, 2 mem_cardx fixed binary, 2 mpc_msp_cardx fixed binary, 2 mpc_mtp_cardx fixed binary, 2 ipc_fips_cardx fixed binary, 2 mpc_urp_cardx fixed binary, 2 mpc_cardx fixed binary, 2 mpcs_msp_cardx fixed binary, 2 mpcs_mtp_cardx fixed binary, 2 mpcs_urp_cardx fixed binary, 2 mpcs_cardx fixed binary, 2 parm_cardx fixed binary, 2 part_cardx fixed binary, 2 prph_dsk_cardx fixed binary, 2 prph_prt_cardx fixed binary, 2 prph_rdr_cardx fixed binary, 2 prph_pun_cardx fixed binary, 2 prph_ccu_cardx fixed binary, 2 prph_tap_cardx fixed binary, 2 prph_opc_cardx fixed binary, 2 prph_cardx fixed binary, 2 root_cardx fixed binary, 2 salv_cardx fixed binary, 2 schd_cardx fixed binary, 2 sst_cardx fixed binary, 2 stok_cardx fixed binary, 2 tbls_cardx fixed binary, 2 udsk_cardx fixed binary, /***** grand data base */ 2 config_cards like config_data_$config_cards aligned, 2 mpc_msp_model_names like config_data_$mpc_msp_model_names aligned, 2 mpc_mtp_model_names like config_data_$mpc_mtp_model_names aligned, 2 mpc_urp_model_names like config_data_$mpc_urp_model_names aligned, 2 ipc_msp_model_names like config_data_$ipc_msp_model_names aligned, 2 ipc_mtp_model_names like config_data_$ipc_mtp_model_names aligned, 2 disk_drive_model_names like config_data_$disk_drive_model_names aligned, 2 tape_drive_model_names like config_data_$tape_drive_model_names aligned, 2 printer_model_names like config_data_$printer_model_names aligned, 2 reader_model_names like config_data_$reader_model_names aligned, 2 ccu_model_names like config_data_$ccu_model_names aligned, 2 punch_model_names like config_data_$punch_model_names aligned, 2 console_model_names like config_data_$console_model_names aligned; declare (get_temp_segment_, release_temp_segment_) entry (char (*), ptr, fixed bin (35)); declare com_err_ entry () options (variable); declare create_data_segment_ entry (ptr, fixed bin (35)); declare code fixed bin (35); declare (ccx, m) fixed bin; declare PADSTAR (1) char (32) init ("pad*") int static options (constant); dcl (addr, char, hbound, ltrim, null, size, string, unspec) builtin; dcl cleanup condition; %include cds_args; %include config_data_dcls; declare 1 CDSA aligned like cds_args; c_ptr = null (); on cleanup begin; goto clean_up; end; call get_temp_segment_ ("config_data_", c_ptr, code); if code ^= 0 then call com_err_ (code, "config_data_", "Could not get a temp segment."); unspec (c) = ""b; c.config_cards.count = hbound (c.config_cards.per_card,1); c.chnl_cardx = 1; c.per_card.second_field = ""; string (c.per_card.flags) = ""b; ccx = 1; c.per_card (ccx).name = "chnl"; ccx = ccx + 1; c.clok_cardx = ccx; c.per_card (ccx).name = "clok"; ccx = ccx + 1; c.cpu_cardx = ccx; c.per_card (ccx).name = "cpu"; ccx = ccx + 1; c.fnp_cardx = ccx; c.per_card (ccx).name = "fnp"; ccx = ccx + 1; c.intk_cardx = ccx; c.per_card (ccx).name = "intk"; ccx = ccx + 1; c.iom_cardx = ccx; c.per_card (ccx).name = "iom"; ccx = ccx + 1; c.mem_cardx = ccx; c.per_card (ccx).name = "mem"; ccx = ccx + 1; c.mpc_msp_cardx = ccx; c.per_card (ccx).name = "mpc"; c.per_card (ccx).second_field = "msp"; c.per_card (ccx).match_second, c.per_card (ccx).match_only_3 = "1"b; ccx = ccx + 1; c.mpc_mtp_cardx = ccx; c.per_card (ccx).name = "mpc"; c.per_card (ccx).second_field = "mtp"; c.per_card (ccx).match_second, c.per_card (ccx).match_only_3 = "1"b; ccx = ccx + 1; c.ipc_fips_cardx = ccx; c.per_card (ccx).name = "ipc"; c.per_card (ccx).second_field = "fips"; c.per_card (ccx).match_second = "1"b; ccx = ccx + 1; c.mpc_urp_cardx = ccx; c.per_card (ccx).name = "mpc"; c.per_card (ccx).second_field = "urp"; c.per_card (ccx).match_second, c.per_card (ccx).match_only_3 = "1"b; ccx = ccx + 1; c.mpc_cardx = ccx; c.per_card (ccx).name = "mpc"; ccx = ccx + 1; c.mpcs_msp_cardx = ccx; c.per_card (ccx).name = "mpcs"; c.per_card (ccx).second_field = "msp"; c.per_card (ccx).match_second, c.per_card (ccx).match_only_3 = "1"b; ccx = ccx + 1; c.mpcs_mtp_cardx = ccx; c.per_card (ccx).name = "mpcs"; c.per_card (ccx).second_field = "mtp"; c.per_card (ccx).match_second, c.per_card (ccx).match_only_3 = "1"b; ccx = ccx + 1; c.mpcs_urp_cardx = ccx; c.per_card (ccx).name = "mpcs"; c.per_card (ccx).second_field = "urp"; c.per_card (ccx).match_second, c.per_card (ccx).match_only_3 = "1"b; ccx = ccx + 1; c.mpcs_cardx = ccx; c.per_card (ccx).name = "mpcs"; ccx = ccx + 1; c.parm_cardx = ccx; c.per_card (ccx).name = "parm"; ccx = ccx + 1; c.prph_dsk_cardx = ccx; c.per_card (ccx).name = "prph"; c.per_card (ccx).second_field = "dsk"; c.per_card (ccx).match_second = "1"b; c.per_card (ccx).match_only_3 = "1"b; ccx = ccx + 1; c.prph_prt_cardx = ccx; c.per_card (ccx).name = "prph"; c.per_card (ccx).second_field = "prt"; c.per_card (ccx).match_second = "1"b; c.per_card (ccx).match_only_3 = "1"b; ccx = ccx + 1; c.prph_rdr_cardx = ccx; c.per_card (ccx).name = "prph"; c.per_card (ccx).second_field = "rdr"; c.per_card (ccx).match_second = "1"b; c.per_card (ccx).match_only_3 = "1"b; ccx = ccx + 1; c.prph_pun_cardx = ccx; c.per_card (ccx).name = "prph"; c.per_card (ccx).second_field = "pun"; c.per_card (ccx).match_second = "1"b; c.per_card (ccx).match_only_3 = "1"b; ccx = ccx + 1; c.prph_ccu_cardx = ccx; c.per_card (ccx).name = "prph"; c.per_card (ccx).second_field = "ccu"; c.per_card (ccx).match_second = "1"b; c.per_card (ccx).match_only_3 = "1"b; ccx = ccx + 1; c.prph_tap_cardx = ccx; c.per_card (ccx).name = "prph"; c.per_card (ccx).second_field = "tap"; c.per_card (ccx).match_second = "1"b; c.per_card (ccx).match_only_3 = "1"b; ccx = ccx + 1; c.prph_opc_cardx = ccx; c.per_card (ccx).name = "prph"; c.per_card (ccx).second_field = "opc"; c.per_card (ccx).match_second = "1"b; c.per_card (ccx).match_only_3 = "1"b; ccx = ccx + 1; c.prph_cardx = ccx; c.per_card (ccx).name = "prph"; ccx = ccx + 1; c.root_cardx = ccx; c.per_card (ccx).name = "root"; ccx = ccx + 1; c.salv_cardx = ccx; c.per_card (ccx).name = "salv"; ccx = ccx + 1; c.schd_cardx = ccx; c.per_card (ccx).name = "schd"; ccx = ccx + 1; c.sst_cardx = ccx; c.per_card (ccx).name = "sst"; ccx = ccx + 1; c.stok_cardx = ccx; c.per_card (ccx).name = "stok"; ccx = ccx + 1; c.tbls_cardx = ccx; c.per_card (ccx).name = "tcd"; ccx = ccx + 1; c.udsk_cardx = ccx; c.per_card (ccx).name = "udsk"; ccx = 1; c.mpc_msp_model_names.count = hbound (c.mpc_msp_model_names.names,1); c.mpc_msp_model_names (ccx).model = 451; c.mpc_msp_model_names (ccx).name = "dsc0451"; c.mpc_msp_model_names (ccx).fw_tag = "dsc191.m191"; c.mpc_msp_model_names (ccx).valid_drives (*) = 0; c.mpc_msp_model_names (ccx).valid_drives (1) = 450; c.mpc_msp_model_names (ccx).valid_drives (2) = 451; ccx = ccx + 1; c.mpc_msp_model_names (ccx).model = 451; c.mpc_msp_model_names (ccx).name = "msp0451"; c.mpc_msp_model_names (ccx).fw_tag = "dsc191.m191"; c.mpc_msp_model_names (ccx).valid_drives (*) = 0; c.mpc_msp_model_names (ccx).valid_drives (1) = 450; c.mpc_msp_model_names (ccx).valid_drives (2) = 451; ccx = ccx + 1; c.mpc_msp_model_names (ccx).model = 601; c.mpc_msp_model_names (ccx).name = "msp0601"; c.mpc_msp_model_names (ccx).fw_tag = "dsc500.d500"; c.mpc_msp_model_names (ccx).valid_drives (*) = 0; c.mpc_msp_model_names (ccx).valid_drives (1) = 450; c.mpc_msp_model_names (ccx).valid_drives (2) = 451; c.mpc_msp_model_names (ccx).valid_drives (3) = 500; c.mpc_msp_model_names (ccx).valid_drives (4) = 501; ccx = ccx + 1; c.mpc_msp_model_names (ccx).model = 603; c.mpc_msp_model_names (ccx).name = "msp0603"; c.mpc_msp_model_names (ccx).fw_tag = "dsc500.d500"; c.mpc_msp_model_names (ccx).valid_drives (*) = 0; c.mpc_msp_model_names (ccx).valid_drives (1) = 450; c.mpc_msp_model_names (ccx).valid_drives (2) = 451; c.mpc_msp_model_names (ccx).valid_drives (3) = 500; c.mpc_msp_model_names (ccx).valid_drives (4) = 501; ccx = ccx + 1; c.mpc_msp_model_names (ccx).model = 607; c.mpc_msp_model_names (ccx).name = "msp0607"; c.mpc_msp_model_names (ccx).fw_tag = "dsc500.d500"; c.mpc_msp_model_names (ccx).valid_drives (*) = 0; c.mpc_msp_model_names (ccx).valid_drives (1) = 450; c.mpc_msp_model_names (ccx).valid_drives (2) = 451; c.mpc_msp_model_names (ccx).valid_drives (3) = 500; c.mpc_msp_model_names (ccx).valid_drives (4) = 501; ccx = ccx + 1; c.mpc_msp_model_names (ccx).model = 609; c.mpc_msp_model_names (ccx).name = "msp0609"; c.mpc_msp_model_names (ccx).fw_tag = "dsc500.d500"; c.mpc_msp_model_names (ccx).valid_drives (*) = 0; c.mpc_msp_model_names (ccx).valid_drives (1) = 450; c.mpc_msp_model_names (ccx).valid_drives (2) = 451; c.mpc_msp_model_names (ccx).valid_drives (3) = 500; c.mpc_msp_model_names (ccx).valid_drives (4) = 501; ccx = ccx + 1; c.mpc_msp_model_names (ccx).model = 611; c.mpc_msp_model_names (ccx).name = "msp0611"; c.mpc_msp_model_names (ccx).fw_tag = "dsc500.d500"; c.mpc_msp_model_names (ccx).valid_drives (*) = 0; c.mpc_msp_model_names (ccx).valid_drives (1) = 450; c.mpc_msp_model_names (ccx).valid_drives (2) = 451; c.mpc_msp_model_names (ccx).valid_drives (3) = 500; c.mpc_msp_model_names (ccx).valid_drives (4) = 501; ccx = ccx + 1; c.mpc_msp_model_names (ccx).model = 612; c.mpc_msp_model_names (ccx).name = "msp0612"; c.mpc_msp_model_names (ccx).fw_tag = "dsc500.d500"; c.mpc_msp_model_names (ccx).valid_drives (*) = 0; c.mpc_msp_model_names (ccx).valid_drives (1) = 450; c.mpc_msp_model_names (ccx).valid_drives (2) = 451; c.mpc_msp_model_names (ccx).valid_drives (3) = 500; c.mpc_msp_model_names (ccx).valid_drives (4) = 501; ccx = ccx + 1; c.mpc_msp_model_names (ccx).model = 800; c.mpc_msp_model_names (ccx).name = "msp800"; c.mpc_msp_model_names (ccx).fw_tag = "msp800.msp8"; c.mpc_msp_model_names (ccx).valid_drives (*) = 0; c.mpc_msp_model_names (ccx).valid_drives (1) = 450; c.mpc_msp_model_names (ccx).valid_drives (2) = 451; c.mpc_msp_model_names (ccx).valid_drives (3) = 500; c.mpc_msp_model_names (ccx).valid_drives (4) = 501; c.mpc_mtp_model_names.count = hbound (c.mpc_mtp_model_names.names,1); ccx = 1; c.mpc_mtp_model_names (ccx).model = 501; c.mpc_mtp_model_names (ccx).name = "mtc501"; c.mpc_mtp_model_names (ccx).fw_tag = "mtc500.m500"; c.mpc_mtp_model_names (ccx).valid_drives (*) = 0; c.mpc_mtp_model_names (ccx).valid_drives (1) = 500; c.mpc_mtp_model_names (ccx).valid_drives (2) = 507; ccx = ccx + 1; c.mpc_mtp_model_names (ccx).model = 502; c.mpc_mtp_model_names (ccx).name = "mtc502"; c.mpc_mtp_model_names (ccx).fw_tag = "mtc500.m500"; c.mpc_mtp_model_names (ccx).valid_drives (*) = 0; c.mpc_mtp_model_names (ccx).valid_drives (1) = 500; c.mpc_mtp_model_names (ccx).valid_drives (2) = 507; ccx = ccx + 1; c.mpc_mtp_model_names (ccx).model = 600; c.mpc_mtp_model_names (ccx).name = "mtp0600"; c.mpc_mtp_model_names (ccx).fw_tag = "mtp601.m601"; c.mpc_mtp_model_names (ccx).valid_drives (*) = 0; c.mpc_mtp_model_names (ccx).valid_drives (1) = 500; c.mpc_mtp_model_names (ccx).valid_drives (2) = 507; c.mpc_mtp_model_names (ccx).valid_drives (3) = 600; c.mpc_mtp_model_names (ccx).valid_drives (4) = 601; c.mpc_mtp_model_names (ccx).valid_drives (5) = 602; ccx = ccx + 1; c.mpc_mtp_model_names (ccx).model = 601; c.mpc_mtp_model_names (ccx).name = "mtp0601"; c.mpc_mtp_model_names (ccx).fw_tag = "mtp601.m601"; c.mpc_mtp_model_names (ccx).valid_drives (*) = 0; c.mpc_mtp_model_names (ccx).valid_drives (1) = 500; c.mpc_mtp_model_names (ccx).valid_drives (2) = 507; c.mpc_mtp_model_names (ccx).valid_drives (3) = 600; c.mpc_mtp_model_names (ccx).valid_drives (4) = 601; c.mpc_mtp_model_names (ccx).valid_drives (5) = 602; ccx = ccx + 1; c.mpc_mtp_model_names (ccx).model = 602; c.mpc_mtp_model_names (ccx).name = "mtc0602"; c.mpc_mtp_model_names (ccx).fw_tag = "mtp601.m601"; c.mpc_mtp_model_names (ccx).valid_drives (*) = 0; c.mpc_mtp_model_names (ccx).valid_drives (1) = 500; c.mpc_mtp_model_names (ccx).valid_drives (2) = 507; c.mpc_mtp_model_names (ccx).valid_drives (3) = 600; c.mpc_mtp_model_names (ccx).valid_drives (4) = 601; c.mpc_mtp_model_names (ccx).valid_drives (5) = 602; ccx = ccx + 1; c.mpc_mtp_model_names (ccx).model = 610; c.mpc_mtp_model_names (ccx).name = "mtp0610"; c.mpc_mtp_model_names (ccx).fw_tag = "mtp610.m610"; c.mpc_mtp_model_names (ccx).valid_drives (*) = 0; c.mpc_mtp_model_names (ccx).valid_drives (1) = 500; c.mpc_mtp_model_names (ccx).valid_drives (2) = 507; c.mpc_mtp_model_names (ccx).valid_drives (3) = 600; c.mpc_mtp_model_names (ccx).valid_drives (4) = 601; c.mpc_mtp_model_names (ccx).valid_drives (5) = 602; c.mpc_mtp_model_names (ccx).valid_drives (6) = 610; c.mpc_mtp_model_names (ccx).valid_drives (7) = 630; ccx = ccx + 1; c.mpc_mtp_model_names (ccx).model = 611; c.mpc_mtp_model_names (ccx).name = "mtp0611"; c.mpc_mtp_model_names (ccx).fw_tag = "mtp610.m610"; c.mpc_mtp_model_names (ccx).valid_drives (*) = 0; c.mpc_mtp_model_names (ccx).valid_drives (1) = 500; c.mpc_mtp_model_names (ccx).valid_drives (2) = 507; c.mpc_mtp_model_names (ccx).valid_drives (3) = 600; c.mpc_mtp_model_names (ccx).valid_drives (4) = 601; c.mpc_mtp_model_names (ccx).valid_drives (5) = 602; c.mpc_mtp_model_names (ccx).valid_drives (6) = 610; c.mpc_mtp_model_names (ccx).valid_drives (7) = 630; ccx = 1; c.ipc_msp_model_names.count = 1; c.ipc_msp_model_names (ccx).model = -1; c.ipc_msp_model_names (ccx).name = "fips-ipc"; c.ipc_msp_model_names (ccx).fw_tag = ""; c.ipc_msp_model_names (ccx).valid_drives (*) = 0; c.ipc_msp_model_names (ccx).valid_drives (1) = 3380; c.ipc_msp_model_names (ccx).valid_drives (2) = 3381; c.ipc_mtp_model_names.count = 1; ccx = 1; c.ipc_mtp_model_names (ccx).model = -1; c.ipc_mtp_model_names (ccx).name = "fips-ipc"; c.ipc_mtp_model_names (ccx).fw_tag = ""; c.ipc_mtp_model_names (ccx).valid_drives (*) = 0; c.ipc_mtp_model_names (ccx).valid_drives (1) = 8200; c.mpc_urp_model_names.count = hbound (c.mpc_urp_model_names.names,1); c.mpc_urp_model_names.model (1) = 2; c.mpc_urp_model_names.name (1) = "urc002"; c.mpc_urp_model_names.fw_tag (1) = "urcmpc.ucmn"; c.mpc_urp_model_names.model (2) = 600; c.mpc_urp_model_names.name (2) = "urp0600"; c.mpc_urp_model_names.fw_tag (2) = "urcmpc.ucmn"; ccx = 2; do m = 8001 to 8004; ccx = ccx + 1; c.mpc_urp_model_names.model (ccx) = m; c.mpc_urp_model_names.name (ccx) = "urp" || ltrim (char (m)); c.mpc_urp_model_names.fw_tag (ccx) = "EURC"; end; c.disk_drive_model_names.count = hbound (c.disk_drive_model_names.names,1); ccx = 1; c.disk_drive_model_names.model (ccx) = 451; c.disk_drive_model_names.name (ccx) = "msu0451"; c.disk_drive_model_names.device_0_valid (ccx) = "0"b; ccx = ccx + 1; c.disk_drive_model_names.model (ccx) = 500; c.disk_drive_model_names.name (ccx) = "msu0500"; c.disk_drive_model_names.device_0_valid (ccx) = "0"b; ccx = ccx + 1; c.disk_drive_model_names.model (ccx) = 501; c.disk_drive_model_names.name (ccx) = "msu0501"; c.disk_drive_model_names.device_0_valid (ccx) = "0"b; ccx = ccx + 1; c.disk_drive_model_names.model (ccx) = 3380; c.disk_drive_model_names.name (ccx) = "msu3380"; c.disk_drive_model_names.device_0_valid (ccx) = "1"b; ccx = ccx + 1; c.disk_drive_model_names.model (ccx) = 3381; c.disk_drive_model_names.name (ccx) = "msu3381"; c.disk_drive_model_names.device_0_valid (ccx) = "1"b; ccx = 1; c.tape_drive_model_names.count = hbound (c.tape_drive_model_names.names,1); c.tape_drive_model_names.model (ccx) = 500; c.tape_drive_model_names.name (ccx) = "mtc501"; c.tape_drive_model_names.device_0_valid (ccx) = "0"b; ccx = ccx + 1; c.tape_drive_model_names.model (ccx) = 500; c.tape_drive_model_names.name (ccx) = "mtc502"; c.tape_drive_model_names.device_0_valid (ccx) = "0"b; ccx = ccx + 1; c.tape_drive_model_names.model (ccx) = 507; c.tape_drive_model_names.name (ccx) = "mtc502"; c.tape_drive_model_names.device_0_valid (ccx) = "0"b; ccx = ccx + 1; c.tape_drive_model_names.model (ccx) = 600; c.tape_drive_model_names.name (ccx) = "mtp0600"; c.tape_drive_model_names.device_0_valid (ccx) = "0"b; ccx = ccx + 1; c.tape_drive_model_names.model (ccx) = 601; c.tape_drive_model_names.name (ccx) = "mtp0601"; c.tape_drive_model_names.device_0_valid (ccx) = "0"b; ccx = ccx + 1; c.tape_drive_model_names.model (ccx) = 602; c.tape_drive_model_names.name (ccx) = "mtp0602"; c.tape_drive_model_names.device_0_valid (ccx) = "0"b; ccx = ccx + 1; c.tape_drive_model_names.model (ccx) = 610; c.tape_drive_model_names.name (ccx) = "mtp0610"; c.tape_drive_model_names.device_0_valid (ccx) = "0"b; ccx = ccx + 1; c.tape_drive_model_names.model (ccx) = 630; c.tape_drive_model_names.name (ccx) = "mtp0630"; c.tape_drive_model_names.device_0_valid (ccx) = "0"b; ccx = ccx + 1; c.tape_drive_model_names.model (ccx) = 8200; c.tape_drive_model_names.name (ccx) = "mtu8200"; c.tape_drive_model_names.device_0_valid (ccx) = "1"b; ccx = 1; c.printer_model_names.count = hbound (c.printer_model_names.names,1); c.printer_model_names.model (ccx) = 301; c.printer_model_names.name (ccx) = "prt301"; ccx = ccx + 1; c.printer_model_names.model (ccx) = 1000; c.printer_model_names.name (ccx) = "pru1000"; ccx = ccx + 1; c.printer_model_names.model (ccx) = 1200; c.printer_model_names.name (ccx) = "pru1200"; ccx = ccx + 1; c.printer_model_names.model (ccx) = 1600; c.printer_model_names.name (ccx) = "pru1600"; ccx = ccx + 1; c.printer_model_names.model (ccx) = 901; c.printer_model_names.name (ccx) = "pru0901"; c.reader_model_names.count = hbound (c.reader_model_names.names,1); ccx = 1; c.reader_model_names.model (ccx) = 500; c.reader_model_names.name (ccx) = "cru0500"; ccx = ccx + 1; c.reader_model_names.model (ccx) = 501; c.reader_model_names.name (ccx) = "cru0501"; ccx = ccx + 1; c.reader_model_names.model (ccx) = 301; c.reader_model_names.name (ccx) = "crz301"; ccx = ccx + 1; c.reader_model_names.model (ccx) = 201; c.reader_model_names.name (ccx) = "crz201"; c.ccu_model_names.count = hbound (c.ccu_model_names.names,1); c.ccu_model_names.model (1) = 401; c.ccu_model_names.name (1) = "ccu401"; c.punch_model_names.count = hbound (c.punch_model_names.names,1); ccx = 1; c.punch_model_names.model (ccx) = 301; c.punch_model_names.name (ccx) = "cpz301"; ccx = ccx + 1; c.punch_model_names.model (ccx) = 300; c.punch_model_names.name (ccx) = "cpz300"; ccx = ccx + 1; c.punch_model_names.model (ccx) = 201; c.punch_model_names.name (ccx) = "cpz201"; c.console_model_names.count = hbound (c.console_model_names.names,1); ccx = 1; c.console_model_names.model (ccx) = 6001; c.console_model_names.name (ccx) = "csu6001"; c.console_model_names.io_type (ccx) = "pcw"; ccx = ccx + 1; c.console_model_names.model (ccx) = 6004; c.console_model_names.name (ccx) = "csu6004"; c.console_model_names.io_type (ccx) = "pcw"; ccx = ccx + 1; c.console_model_names.model (ccx) = 6601; c.console_model_names.name (ccx) = "csu6601"; c.console_model_names.io_type (ccx) = "idcw"; unspec (CDSA) = ""b; CDSA.sections (1).p = addr (c); CDSA.sections (1).len = size (c); CDSA.sections (2).p = null (); CDSA.sections (2).len = 0; CDSA.sections (1).struct_name = "c"; CDSA.num_exclude_names = 1; CDSA.exclude_array_ptr = addr (PADSTAR); CDSA.have_text = "1"b; CDSA.seg_name = "config_data_"; call create_data_segment_ (addr (CDSA), code); if code ^= 0 then call com_err_ (code, "config_data_"); clean_up: if c_ptr ^= null () then call release_temp_segment_ ("config_data_", c_ptr, code); return; end config_data_;  cu_.alm 11/11/89 1144.7rew 11/11/89 0803.9 454851 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** " HISTORY COMMENTS: " 1) change(86-05-15,DGHowe), approve(86-05-15,MCR7375), " audit(86-07-15,Schroth), install(86-08-01,MR12.0-1108): " add the entry points get_command_name and get_command_name_rel. Added " the constants fb21_mask and null. " 2) change(86-12-10,DGHowe), approve(86-12-10,PBF7375), " audit(86-12-10,McInnis), install(86-12-17,MR12.0-1250): " Bug fix to get_command_name_common. Redefine has_command_name_mask to be " a full word 400000000000. Take the du modifier off of the anx0 for the " has_command_name_mask. " END HISTORY COMMENTS " Command system utility subroutines " Initially coded in December 1969 by R. C. Daley " Modified by R Feiertag in 1970 to add entries arg_ptr_rel, grow_stack_frame, " shrink_stack_frame, get_cp, and get_cl " Modified by V. Voydock in October 1970 as part of reworking of process environment " Modified by C. Tavares in May 1971 to add entry caller_ptr " Modified by V. Voydock in June 1971 to add entries "ready_proc", " "get_ready_proc", and "set_ready_proc" " Modified by V. Voydock in May 1972 to add entries get_ready_mode and set_ready_mode, " and to make cu_$grow_stack_frame round up to mod 16 boundaries " Split into two pieces in May 1972 by V. Voydock as part of fast command loop " Modified 21 June 1972 by P. Green to fix arg_ptr not to assume descriptors are present, " and to handle Version 2 descriptors properly. " Modified for follow-on by R. Snyder July 20, 1972 " Modified 11/19/76 by M. Weaver to add entries generate_call, (get set)_command_processor, " and (get set)_ready_procedure " Modified May 1977 by Larry Johnson for arg_count_rel entry. " Modified Aug 12, 1977 by S. Webber to remerge with rest_of_cu_ " Modified: August 1980 by G. Palter to add reset_(command_processor ready_procedure " cl_intermediary), make cu_$(generate_call cl cp ready_proc) work with internal " procedures, add an optional second argument to cu_$arg_count, and add " cu_$evaluate_active_string and cu_$(get set reset)_evaluate_active_string. " Modified September 1982 by C. Hornig to remove reference to pl1_operators. " Modified: 16 September 1982 by G. Palter to make cu_$stack_frame_size work (phx13864) " Modified: 16 January 1983 by G. Palter to make cu_$arg_ptr and friends reject invalid " argument numbers (phx14511) " Modified: 1 March 1984 by G. Palter to not use LDAQ/STAQ for copying pointers (phx15722) " and to always initialize the pointer and length arguments of cu_$*arg_ptr* to null and " zero, respectively (phx16016) " name cu_ " TABLE OF CONTENTS entry af_arg_count " return # arguments if an AF entry af_arg_count_rel " ... for given arg list entry af_arg_ptr " get ptr/lth of an argument if an AF entry af_arg_ptr_rel " ... for given arg list entry af_return_arg " return # args and ptr/lth of AF return value entry af_return_arg_rel " ... for given arg list entry arg_count " get number of arguments entry arg_count_rel " ... for given arg list entry arg_list_ptr " get ptr to argument list entry arg_ptr " get ptr to argument(n) entry arg_ptr_rel " ... for given arg list entry caller_ptr " get codeptr to invoker's caller entry cl " entry to call to re-enter environment entry cp " entry to call current command processor entry decode_entry_value " extract ptrs from pl1 entry variable entry evaluate_active_string " call to evaluate an active string entry gen_call " call, given codeptr and arg list ptr entry generate_call " call, given entry variable and arg list ptr entry get_cl " get codeptr to current command level re-entry procedure entry get_cl_intermediary " get entry variable for current command level re-entry procedure entry get_command_processor " get entry variable for current command processor entry get_command_name_rel " get command name entry get_command_name " get command name entry get_cp " get codeptr to current command processor entry get_evaluate_active_string " get entry variable to evaluate an active string entry get_ready_mode " get value of internal ready flags entry get_ready_proc " get codeptr to procedure to be called after each command line entry get_ready_procedure " get entry variable to be called after each command line entry grow_stack_frame " allocate space in stack frame (mod 16) entry level_get " get current validation level entry level_set " set current validation level entry make_entry_value " create pl1 entry variable from codeptr and enironmentptr entry ptr_call " call, given codeptr in arg list entry ready_proc " entry to call after each command line is processed entry reset_cl_intermediary " reset to default command level re-entry procedure entry reset_command_processor " reset to default command processor entry reset_evaluate_active_string " reset to default entry to evaluate an active string entry reset_ready_procedure " reset to default ready message printer entry set_cl " set external entry for re-entry to command level entry set_cl_intermediary " set entry for re-entry to command level entry set_command_processor " set entry for current command processor entry set_cp " set external entry for current command processor entry set_evaluate_active_string " set entry to evaluate an active string entry set_ready_mode " set value of internal ready flags entry set_ready_proc " set external entry to be called after each command line entry set_ready_procedure " set entry to be called after each command line entry shrink_stack_frame " free up space in stack frame entry stack_frame_ptr " get ptr to stack frame entry stack_frame_size " get size of stack frame " include stack_header include stack_frame " tempd temp_ptr,temp_ptr2 " temporaries for ptr_call " Constants bool var_desc,10120 " identifies PL1 version 1 varying character string bool v2_var,130000 " identifies PL1 version 2 varying character string fb21_mask: oct 000017777777 " mask off fixed bin 21 descriptor_mask: oct 000077777777 " mask off top 12 bits desc_mask: " mask for PL1 version 1 descriptor (ignore sets/uses) vfd 15/0,21/-1 has_command_name_mask: oct 400000000000 v2_mask: vfd 1/1,6/0,29/-1 " Mask for PL1 version 2 (modern style) even null: its -1,1 " null pointer ptrmask: oct 077777000077,777777077077 " mask for pointer comparisons " Variables use int_stat internal static storage join /static/int_stat cl_arg: oct 400000000000 ready_mode: oct 400000000000 even cl_entry: its -1,1 " entry to re-enter command level its -1,1 cl_arglist: vfd 18/2,18/4 vfd 18/0,18/0 its -1,1 cp_entry: its -1,1 " entry for current command processor its -1,1 ready_entry: " entry for current ready procedure its -1,1 its -1,1 ready_arglist: vfd 18/2,18/4 arglist for call to ready procedure dec 0 its -1,1 eas_entry: " entry for current active string evalauator its -1,1 its -1,1 use main " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " cl ..... entry to re-enter command level upon receipt of error conditions " " call cu_$cl (cl_modes); " " dcl 1 cl_modes aligned, /* optional argument */ " 2 resetread bit (1) unaligned, /* ON => do a resetread on user_i/o */ " 2 pad bit (34) unaligned; " " If cl_modes isn't supplied, a canned structure is passed to request a resetread " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " cl: lda ap|0 " pick up arg list header cana =o777777,du " any arguments passed? tnz cl_with_args " ... yes -- use supplied arglist eppap pr5|cl_arglist " ... no -- use canned arglist epp2 pr5|cl_arg " ... which requests resetread spri2 pr5|cl_arglist+2 cl_with_args: epp1 pr5|cl_entry " will be calling this entry variable ldaq pr1|0 " is it a user specified value? eraq null anaq ptrmask tnz generate_call_common " ... yes -- go off and perform the call callsp get_to_cl_$unclaimed_signal " ... no -- use default (external) proc short_return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " get_cl_intermediary .... entry to retrieve entry var to re-enter command level " " call cu_$get_cl_intermediary(cl_entry); " " 1. cl_entry (entry) - entry variable to procedure to re-enter command level " " " " " " " " " " " " " " " " " " " " " " " " " " " " "" " " " " " " " " " " " " get_cl_intermediary: epp2 ap|2,* " get ptr to entry variable argument ldaq pr5|cl_entry " is it the default procedure? eraq null anaq ptrmask tnz get_cl_intermediary_non_default " ... no -- return the static one epp3 get_to_cl_$unclaimed_signal " ... yes -- return default value spri3 pr2|0 ldaq null " (it's external) staq pr2|2 short_return get_cl_intermediary_non_default: epp3 pr5|cl_entry,* " copy from our internal static spri3 pr2|0 epp3 pr5|cl_entry+2,* spri3 pr2|2 short_return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " get_cl .... entry to retrieve procedure ptr to re-enter command level " " call cu_$get_cl(cl_ptr); " " 1. cl_ptr (ptr) - pointer to procedure to re-enter command level " " " " " " " " " " " " " " " " " " " " " " " " " " " " "" " " " " " " " " " " " " get_cl: epp2 pr5|cl_entry,* " pick up current command level proc ptr spri2 ap|2,* short_return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " set_cl_intermediary ..... entry to specify procedure to call to re-enter command level " " call cu_$set_cl_intermediary(cl_entry) " " 1. cl_entry (entry) - entry to procedure to re-enter command level " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " set_cl_intermediary: epp2 ap|2,* " get pointer to caller's entry var epp3 pr2|0,* " copy entry variable to our static spri3 pr5|cl_entry epp3 pr2|2,* spri3 pr5|cl_entry+2 short_return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " set_cl ..... entry to specify external proc to call to re-enter command level " " call cu_$set_cl(cl_ptr) " " 1. cl_ptr (ptr) - pointer to external proc to re-enter command level; " if null, the default procedure is used " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " set_cl: epp2 ap|2,* " get ptr to the codeptr epp2 pr2|0,* " copy codeptr to our static spri2 pr5|cl_entry ldaq null " indicate external procedure staq pr5|cl_entry+2 short_return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " reset_cl_intermediary .... entry to reset to default re-enter command level proc " " call cu_$reset_cl_intermediary () " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " reset_cl_intermediary: ldaq null " set to null -- cu_$cl will special case staq pr5|cl_entry staq pr5|cl_entry+2 short_return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " cp ..... entry to-call currently specified command processor " " call cu_$cp (line_ptr, line_lth, code) " " 1. line_ptr (ptr) - pointer to command line to execute " 2. line_lth (fixed bin(21)) - length of command line " 3. code (fixed bin(35)) - standard status code (Output) " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " cp: epp1 pr5|cp_entry " will be calling this entry variable ldaq pr1|0 " is it user supplied procedure? eraq null anaq ptrmask tnz generate_call_common " ... yes -- go off and perform the call callsp command_processor_$command_processor_ " ... no -- use default proc short_return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " get_command_processor .... entry to retrieve entry var of current command processor " " call cu_$get_command_processor (cp_entry); " " 1. cp_entry (entry) - entry variable of current command processor " " " " " " " " " " " " " " " " " " " " " " " " " " " " "" " " " " " " " " " " " " get_command_processor: epp2 ap|2,* " get pointer to user's entry variable ldaq pr5|cp_entry " is default procedure in use? eraq null anaq ptrmask tnz get_cp_non_default " ... no epp3 command_processor_$command_processor_ " ... yes -- return it spri3 pr2|0 ldaq null staq pr2|2 " (it's external) short_return get_cp_non_default: epp3 pr5|cp_entry,* " copy from our internal static spri3 pr2|0 epp3 pr5|cp_entry+2,* spri3 pr2|2 short_return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " get_cp .... entry to retrieve procedure ptr to current command processor " " call cu_$get_cp (cp_ptr); " " 1. cp_ptr (ptr) - pointer to current command processor " " " " " " " " " " " " " " " " " " " " " " " " " " " " "" " " " " " " " " " " " " get_cp: epp2 pr5|cp_entry,* " pick up current command processor spri2 ap|2,* short_return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " set_command_processor ..... entry to specify procedure to call as the command processor " " call cu_$set_command_processor (cp_entry) " " 1. cp_entry (entry) - entry to become the command processor " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " set_command_processor: epp2 ap|2,* " get pointer to caller's entry var epp3 pr2|0,* " copy entry variable to our static spri3 pr5|cp_entry epp3 pr2|2,* spri3 pr5|cp_entry+2 short_return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " set_cp ..... entry to specify external proc to be command processor " " call cu_$set_cp (cp_ptr) " " 1. cp_ptr (ptr) - pointer to external proc to be the command processor; " if null, the default procedure is used " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " set_cp: epp2 ap|2,* " get ptr to the codeptr epp2 pr2|0,* " copy codeptr to our static spri2 pr5|cp_entry ldaq null " indicate external procedure staq pr5|cp_entry+2 short_return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " reset_command_processor .... entry to reset to default command processor " " call cu_$reset_command_processor () " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " reset_command_processor: ldaq null " reset to null -- cu_$cp will then staq pr5|cp_entry " ... transfer to the default staq pr5|cp_entry+2 short_return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " ready_proc ..... entry to be called after each command line is processed -- " (default procedure prints a ready message if on) " " call cu_$ready_proc (ready_modes); " " dcl 1 ready_modes aligned, /* optional argument */ " 2 ready_sw bit(1) unaligned, /* ON => print a ready message */ " 2 pad bit(35) unaligned; " " If ready_modes isn't supplied, an internal static structure is passed whose " contents may be changed via cu_$set_ready_mode and read via cu_$get_ready_mode; " the default value for ready_modes.ready_sw in the static structure is "1"b. " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " ready_proc: lda ap|0 " pick up arg list header cana =o777777,du " any arguments passed? tnz ready_with_args " ... yes -- use supplied arglist eppap pr5|ready_arglist " ... no -- use current setting epp2 pr5|ready_mode " ... controlled by ready_on/off spri2 pr5|ready_arglist+2 ready_with_args: epp1 pr5|ready_entry " will be calling this entry variable ldaq pr1|0 " user supplied procedure? eraq null anaq ptrmask tnz generate_call_common " ... yes -- go off and perform the call callsp print_ready_message_$print_ready_message_ " ... no -- use default short_return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " get_ready_procedure .... entry to retrieve entry var of current ready procedure " (procedure called after each command line normally to " print a ready message) " " call cu_$get_ready_procedure (ready_entry); " " 1. ready_entry (entry) - entry variable of current ready procedure " " " " " " " " " " " " " " " " " " " " " " " " " " " " "" " " " " " " " " " " " " get_ready_procedure: epp2 ap|2,* " get ptr to entry variable argument ldaq pr5|ready_entry " using default procedure? eraq null anaq ptrmask tnz get_ready_procedure_non_default " ... no epp3 print_ready_message_$print_ready_message_ " ... yes -- return it spri3 pr2|0 ldaq null " (it's external) staq pr2|2 short_return get_ready_procedure_non_default: epp3 pr5|ready_entry,* " copy from our internal static spri3 bp|0 epp3 pr5|ready_entry+2,* spri3 bp|2 short_return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " get_ready_proc .... entry to retrieve procedure ptr to current ready procedure " " call cu_$get_ready_proc (ready_ptr); " " 1. ready_ptr (ptr) - pointer to current ready procedure " " " " " " " " " " " " " " " " " " " " " " " " " " " " "" " " " " " " " " " " " " get_ready_proc: epp2 pr5|ready_entry,* " pick up current command processor spri2 ap|2,* short_return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " set_ready_procedure ..... entry to specify procedure to call as the command processor " " call cu_$set_ready_procedure (ready_entry) " " 1. ready_entry (entry) - entry to become the command processor " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " set_ready_procedure: epp2 ap|2,* " get pointer to caller's entry var epp3 pr2|0,* " copy entry variable to our static spri3 pr5|ready_entry epp3 pr2|2,* spri3 pr5|ready_entry+2 short_return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " set_ready_proc ..... entry to specify external proc to be ready procedure " " call cu_$set_ready_proc (ready_ptr) " " 1. ready_ptr (ptr) - pointer to external proc to be the ready procedure; " if null, the default procedure is used " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " set_ready_proc: epp2 ap|2,* " get ptr to the codeptr epp2 pr2|0,* " copy codeptr to our static spri2 pr5|ready_entry ldaq null " indicate external procedure staq pr5|ready_entry+2 short_return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " reset_ready_procedure .... entry to reset to default ready procedure " " call cu_$reset_ready_procedure () " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " reset_ready_procedure: ldaq null " reset to null -- cu_$ready_proc will staq pr5|ready_entry " transfer to the default staq pr5|ready_entry+2 short_return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " set_ready_mode ..... entry to set the internal ready flags for controlling ready " message printing " " call cu_$set_ready_mode (ready_flags); " " 1. ready_flags (see description of cu_$ready_proc) (INPUT) " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " set_ready_mode: lda ap|2,* " copy flags to out static sta pr5|ready_mode short_return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " get_ready_mode ..... entry to return the value of the ready flags " " call cu_$get_ready_mode (ready_flags); " " 1. ready_flags (see description of cu_$ready_proc) (OUTPUT) " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " get_ready_mode: lda pr5|ready_mode " copy ready flags to caller sta ap|2,* short_return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " evaluate_active_string ..... entry to-call current active-string evaluator " " call cu_$evaluate_active_string (info_ptr, active_string, string_type, " return_value, code); " " 1. info_ptr (ptr) - reserved for future expansion and must be null " 2. active_string (char (*)) - string to evaluate without outermost brackets " 3. string_type (fixed bin) - type of active string (see cp_active_string_types.incl.pl1) " 4. return_value (char (*) var) - result of the evaluation (Output) " 5. code (fixed bin(35)) - standard status code (Output) " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " evaluate_active_string: epp1 pr5|eas_entry " will be calling this entry variable ldaq pr1|0 " user supplied procedure? eraq null anaq ptrmask tnz generate_call_common " ... yes -- go off and perform the call callsp command_processor_$eval_string " ... no -- use default short_return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " get_evaluate_active_string .... entry to retrieve entry var of current active " string evaluator " " call cu_$get_evaluate_active_string (eas_entry); " " 1. eas_entry (entry) - entry variable of current active-string evaluator " " " " " " " " " " " " " " " " " " " " " " " " " " " " "" " " " " " " " " " " " " get_evaluate_active_string: epp2 ap|2,* " get ptr to entry variable argument ldaq pr5|eas_entry " using defaulr procedure? eraq null anaq ptrmask tnz get_eas_non_default " ... no epp3 command_processor_$eval_string " ... yes -- return it spri3 pr2|0 ldaq null " (it's external) staq pr2|2 short_return get_eas_non_default: epp3 pr5|eas_entry,* " copy from our internal static spri3 pr2|0 epp3 pr5|eas_entry+2,* spri3 pr2|2 short_return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " set_evaluate_active_string ..... entry to specify procedure to call as the active " string evaluator " " call cu_$set_evaluate_active_string (eas_entry) " " 1. eas_entry (entry) - entry to become the active-string evaluator " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " set_evaluate_active_string: epp2 ap|2,* " get pointer to caller's entry var epp3 pr2|0,* " copy entry variable to our static spri3 pr5|eas_entry epp3 pr2|2,* spri3 pr5|eas_entry+2 short_return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " reset_evaluate_active_string .... entry to reset to default active-string evaluator " " call cu_$reset_evaluate_active_string () " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " reset_evaluate_active_string: ldaq null " reset to null -- staq pr5|eas_entry " ... cu_$evaluate_active_string will staq pr5|eas_entry+2 " ... transfer to default short_return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " generate_call ... entry to call an entry variable with the supplied argument list " " call cu_$generate_call (entry_variable, arg_list_ptr); " " 1. entry_variable (entry) -- the entry to be called. It may be an internal " procedure;" this entry will take care of the display " ptr in the argument list. " 2. arg_list_ptr (ptr) -- pointer to the argument list to be given to the entry " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " generate_call: epp1 ap|2,* " get ptr to entry variable eppap ap|4,* " get ptr to argument list for call eppap ap|0,* " ... and point to actual arglist " Control reaches here from the cu_$cl, etc. entries to invoke their specific entry variable generate_call_common: lxl0 ap|0 " pick up argument list code anx0 8+2,du " check if display pointer present tnz 3,ic " ... yes -- go get it ldaq null " ... no -- use null (external call) tra 3,ic " and goto common code ldx2 ap|0 " ... 2*nargs ldaq ap|2,2 " ... fetch display pointer eraq pr1|2 " compare with entry's environmentptr anaq ptrmask tnz 2,ic " ... not equal -- must copy arglist callsp pr1|0,* " display ptrs agree -- make the call " Entry variable's environmentptr is different from arglist's display ptr -- the arglist " must be copied and the proper display pointer inserted... eax1 0 " assume that entry is external ldaq pr1|2 " check if entry is external or internal eraq null anaq ptrmask tze 2,ic " ... external -- no display ptr in arglist eax1 2 " ... internal -- must insert display ptr eax7 stack_frame.min_length+17,1 " miniumum stack frame size + display " ... pointer (if used) + rounding adx7 ap|0 " ... plus argument pointers adx7 ap|1 " ... plus descriptor pointers anx7 =o777760,du " ... round to mod 16 tsp2 sb|stack_header.push_op_ptr,* " get a stack frame lda stack_frame.support_bit,dl " ... which is a support frame orsa sp|stack_frame.flag_word epp2 sp|stack_frame.min_length " arglist goes here ldaq ap|0 " copy argument list header staq pr2|0 eax2 4 " assume no display pointer cmpx1 0,du " putting in a display pointer? tze 2,ic " ... no -- have correct code already eax2 8 " ... yes -- get proper code for header sxl2 pr2|0 " update code in arglist header ldx2 pr2|0 " 2*nargs tze 6,ic " ... no arguments to copy epp3 ap|0,2* " copy argument list pointers spri3 pr2|0,2 eax2 -2,2 " ... done? tpnz -3,ic " ... ... no ldx2 pr2|0 " 2*nargs again eppap ap|0,2 " ... ptr to last argptr in original list epp3 pr2|0,2 " ... ptr to last argptr in new list cmpx1 0,du " copy entry's environment ptr? tze 4,ic " ... no epp5 pr1|2,* " ... yes spri5 pr3|2 epp3 pr3|2 " ... indicate descriptors after display ldx2 pr2|1 " check if descriptors to copy tze generate_call_call " ... no cmpx0 0,du " copy descriptors -- skip old display? tze 2,ic " ... no eppap ap|2 " ... yes ldx2 pr2|1 " 2*ndescs epp5 ap|0,2* " copy descriptors spri5 pr3|0,2 eax2 -2,2 " ... done? tpnz -3,ic " ... ... no generate_call_call: call pr1|0,*(pr2|0) " make the call return " ... and return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " gen_call ..... call specified external procedure with specified argument list " " call cu_$gen_call(proc_ptr, arg_list_ptr) " " 1. proc_ptr (ptr) - pointer to external procedure to be called " 2. arg_list_ptr (ptr) - pointer to argument list for procedure call " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " gen_call: eppbp ap|2,* get pointer to procedure pointer eppap ap|4,* pick up argument list pointer eppap ap|0,* .. callsp bp|0,* call procedure entry point " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " ptr_call ..... call external procedure specified by first argument in call " " call cu_$ptr_call (proc_ptr, arg1, ... , argN) " " 1. proc_ptr (ptr) - pointer to external procedure to be called " 2. arg1 ... argN - optional - arguments to be supplied in the call " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " ptr_call: eax7 stack_frame.min_length+19 " minimum stack frame plus 4 words " ... temporary storage plus rounding adx7 ap|0 " ... plus room for argument pointers adx7 ap|1 " ... plus room for descriptors anx7 =o777760,du " ... round to mod 16 tsp2 sb|stack_header.push_op_ptr,* " get a stack frame lda stack_frame.support_bit,dl " ... which is a support frame orsa sp|stack_frame.flag_word epp2 sp|stack_frame.min_length " start of temporaries epp3 ap|2,* " save codeptr of procedure to call epp3 pr3|0,* spri3 pr2|0 ldaq ap|0 " copy arglist header staq pr2|2 ldx1 pr2|2 " decrement number of arguments eax1 -2,1 stx1 pr2|2 tze 5,ic " no arguments in call ... skip copying epp3 ap|2,1* " copy argument pointers spri3 pr2|2,1 eax1 -2,1 " ... done? tpnz -3,ic " ... ... no ldx1 pr2|3 " get descriptors count tze ptr_call_call " none -- go make the call eax1 -2,1 " flush first descriptor stx1 pr2|3 tze ptr_call_call " none left ldx2 ap|0 " move ap past argptrs and 1st eppap ap|2,2 " ... descriptor ldx2 pr2|2 " move past argptrs in new arglist epp3 pr2|2,2 epp5 ap|0,1* " copy descriptors spri5 pr3|0,1 eax1 -2,1 " ... done? tpnz -3,ic " ... ... no ptr_call_call: call pr2|0,*(pr2|2) " make the call return " ... and return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " arg_count ..... get number of arguments passed to caller of arg_count " " call cu_$arg_count (nargs, code) " " 1. nargs (fixed bin(17)) - number of arguments (returned). " 2. code (fixed bin(35)) - optional - set to one of zero, error_table_$nodescr, or " error_table_$active_function. " " If code is supplied, a check is made that the last argument is not char(*) varying " which is indicative of being invoked as an active function. This check provides a " mechanism for command-only procedures to detect improper usage. " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " arg_count: eax0 4 " code (if present) is second argument epp1 sp|stack_frame.arg_ptr,* " ptr to caller's stack frame tra arg_count_common " join main section of code " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " arg_count_rel ..... get number of arguments in specified argument list " " call cu_$arg_count_rel (nargs, arg_list_ptr, code); " " 1. nargs (fixed bin(17)) - number of args in that list (output) " 2. arg_list_ptr (ptr) - pointer to arg list in question (input) " 3. code (fixed bin(35)) - optional - see cu_$arg_count above " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " arg_count_rel: eax0 6 " code (if present) is third argument epp1 ap|4,* " get arglist pointer epp1 pr1|0,* arg_count_common: lda pr1|0 " return the argument count arl 18+1 " ... which was in au and was also doubled sta ap|2,* cmpx0 ap|0 " did caller supply a code argument? tmoz arg_count_hard " ... yes short_return " ... no -- all done, return to caller " Status code is specified: check that last argument is not character(*) varying which would " indicate active function usage. arg_count_hard: stz ap|0,0* " initialize return code ldx1 pr1|0 " any arguments? tnz ach_continue " ... yes short_return " ... no -- OK for command to have no args ach_continue: lda pr1|0 " pick up argument list header cana 4+8,dl " make sure its a PL1 call tze ach_err_no_descs " ... it isn't ldx1 pr1|0 " 2*nargs to x1 cmpx1 pr1|1 " same number of descriptors present? tnz ach_err_no_descs " ... no -- can't determine if valid adx1 pr1|1 " take descriptors into account also lxl2 pr1|0 " check if display pointer is present anx2 8+2,du tze 2,ic " ... no eax1 2,1 " ... yes -- skip past it also lda pr1|0,1* " fetch the descriptor tpl ach_check_v1 " might be a version 1 descriptor ldq v2_mask " mask out all but datatype cmk v2_var,du " is it char(*) varying? tze ach_err_af " ... yes -- invoked as an active function short_return " ... no -- all is OK ach_check_v1: ldq desc_mask " pick up mask for version 1 descriptors cmk var_desc,du " is it char(*) varying? tze ach_err_af " ... yes short_return " ... no ach_err_no_descs: " no descriptors in arglist lda error_table_$nodescr sta ap|0,0* short_return ach_err_af: " called as active function lda error_table_$active_function sta ap|0,0* short_return " " " " " " " " " " " " " " " " " " " " " "" " " " " " " " "" " "" " " "" " "" "" " arg_ptr_rel ..... get nth argument of specified argument list " " call cu_$arg_ptr_rel(argno, argptr, arglen, code, arg_list_ptr); " " 1. argno (fixed bin(17)) - specifies the desired argument. " 2. argptr (ptr) - pointer to specified argument (returned). " 3. arglen (fixed bin(17)) - size of specified argument (returned). " 4. code (fixed bin(17)) - error status code (returned). " 5. arg_list_ptr (ptr) - pointer to desired argument list. " " " " " " " " " " " " " " " " "" " "" " " " " "" " " " " " " " "" "" " " "" "" " arg_ptr_rel: eppbp ap|10,* " get the argument list pointer eppbp bp|0,* " ... tra arg_ptr_common " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " arg_ptr ..... get ptr (and size) of caller's nth argument " " call cu_$arg_ptr(argno, argptr, arglen, code) " " 1. argno (fixed bin(17)) - specifies the desired argument. " 2. argptr (ptr) - pointer to specified argument (returned). " 3. arglen (fixed bin(17)) - size of specified argument (returned). " 4. code (fixed bin(17)) - error status code (returned). " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " arg_ptr: eppbp sp|stack_frame.arg_ptr,* " get pointer to caller's argument list arg_ptr_common: ldaq null " initialize output values staq ap|4,* " ... null argument pointer stz ap|6,* " ... zero length stz ap|8,* " ... zero error code lda ap|2,* " pick up argument number tmoz arg_ptr_noarg " ... must be positive als 1 eax1 0,al " 2*argument_idx -> X1 cmpx1 bp|0 " check against the argument count tpnz arg_ptr_noarg " ... argument_idx is too large eppbb bp|0,1* " copy the argument pointer spribb ap|4,* lda bp|1 " get descriptor word count tze arg_ptr_no_descriptors " ... no descriptors adx1 bp|0 " compute offset to the descriptor lxl0 bp|0 " ... check for an environment pointer anx0 8+2,du tze 2,ic eax1 2,1 " ... skip over environment pointer lda bp|0,1* " pick up the descriptor tmi *+2 ana =o777777,dl " mask for version 1 descriptors ana descriptor_mask " mask for version 2 descriptors sta ap|6,* " return the argument length arg_ptr_no_descriptors: short_return arg_ptr_noarg: " unknown argument specified lda error_table_$noarg sta ap|8,* short_return " " " " " " " " " " " " " " " " " " " " " "" " " " " " " " "" " "" " " "" " "" "" " get_command_name_rel ..... get the command name from the passed arg list " " call cu_$get_command_name_rel( command_name_ptr, command_name_length, " code, arg_list_ptr); " " 1. command_name_ptr (pointer) - ptr to command_name (returned) " 2. command_name_length (fixed bin (21)) - size of command_name (returned) " 3. code (fixed bin(35)) - error status code (returned). " 4. arg_list_ptr (pointer) - pointer to desired argument list. " " " " " " " " " " " " " " " " "" " "" " " " " "" " " " " " " " "" "" " " "" """ get_command_name_rel: eppbp ap|8,* " get the argument list pointer eppbp bp|0,* " ... tra get_command_name_common " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " get_command_name ..... get command name from callers arg list " " call cu_$get_command_name(command_name_ptr, command_name_length, code) " " 1. command_name_ptr (pointer) - ptr to command_name (returned) " 2. command_name_length (fixed bin (21)) - size of command_name (returned) " 3. code (fixed bin(35)) - error status code (returned). " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " get_command_name: eppbp sp|stack_frame.arg_ptr,* " get pointer to caller's argument list get_command_name_common: ldaq null " initialize output values staq ap|2,* " ... command nm ptr = null stz ap|4,* " ... size = 0 stz ap|6,* " ... zero error code " check if has name is set lxl0 bp|1 " get has name flag anx0 has_command_name_mask " and upper bit of 2nd half tze get_command_name_no_name " has name not set return error code " check if non-quick internal procedure lxl0 bp|0 " get call type anx0 8,du " compare to 000010 octal tnz get_command_name_no_name " internal call therfore don't have a command name " get effective ptr to name and size is + 2 past ldx0 bp|0 " get arg count eppbb bp|2,x0 " get ptr past args ldx0 bp|1 " get desc count eppbb bb|0,x0 " got ptr to name ptr " set return values of name ptr and size epplb bb|0,* " get name ptr sprilb ap|2,* " store name ptr lda bb|2 " get size ana fb21_mask "get fixed bin 21 value sta ap|4,* " store size short_return get_command_name_no_name: " name not available lda error_table_$command_name_not_available sta ap|6,* short_return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " af_return_arg ..... returns info on active function arg lists " " call cu_$af_return_arg (n_args, return_ptr, return_len, code); " " 1. n_args number of args (output) (not including return arg) " 2. return_ptr pointer to return arg (output) " 3. return_len max length of return arg (output) " 4. code standard status code " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " af_return_arg: ldaq null " initialize output arguments staq ap|4,* stz ap|6,* eax2 8 " error code is 4th argument tsx1 verify_af " check the call arg af_return_arg_return " ... error return af_return_arg_common: sta ap|6,* " set return value's maximum length eppbb bb|0,* " get pointer to return value eppbb bb|-1 " ... and adjust to its length word spribb ap|4,* af_return_arg_return: stq ap|2,* " set the argument count (from verify_af) short_return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " af_return_arg_rel ..... like af_return arg, but the fifth argument is " a pointer to the argument list to use " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " af_return_arg_rel: ldaq null " initialize output arguments staq ap|4,* stz ap|6,* eax2 8 " error code is 4th argument eppbp ap|10,* " get the real argument list pointer eppbp bp|0,* " ... tsx1 verify_af_rel " verify that the call is OK arg af_return_arg_return " ... error return tra af_return_arg_common " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " af_arg_count ..... return active function arg count " " call cu_$af_arg_count (n_args, code); " " 1. n_args number of arguments (output) " 2. code standard status code " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " af_arg_count: eax2 4 " error code is 2nd argument tsx1 verify_af " check the call arg af_arg_count_return " ... error return af_arg_count_return: stq ap|2,* " set the argument count short_return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " af_arg_count_rel ..... like af_arg_count but the third arg is " a pointer to the argument list to use " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " af_arg_count_rel: eppbp ap|6,* " get a pointer to the argument list eppbp bp|0,* " ... eax2 4 " error code is 2nd argument tsx1 verify_af_rel " check the call arg af_arg_count_rel_return " ... error return af_arg_count_rel_return: stq ap|2,* " set the argument count short_return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " af_arg_ptr ..... returns pointer to an active function argument " " call cu_$af_arg_ptr (arg_no, arg_ptr, arg_len, code); " " 1. arg_no the number of the argument desired (input) " 2. arg_ptr pointer to that argument (output) " 3. arg_len its length (output) " 4. code standard status code " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " af_arg_ptr: ldaq null " initialize output arguments staq ap|4,* stz ap|6,* eax2 8 " error code is 4th argument tsx1 verify_af " check the call arg af_arg_ptr_return " ... error return af_arg_ptr_common: cmpq ap|2,* " check argument_idx against n_argument tmi af_arg_ptr_noarg " ... too large ldq ap|2,* " pick up the argument_idx tmoz af_arg_ptr_noarg " ... must be positive qls 18+1 " convert to pointer offset eppbp bp|0,qu " make bp -> the argument pointer ldq bp|0,3* " fetch the argument descriptor tmi 2,ic anq -1,dl " version 1 descriptor length mask anq =o77777777 " mask all but the length stq ap|6,* " set the length eppbb bp|0,* " get the argument pointer spribb ap|4,* af_arg_ptr_return: short_return af_arg_ptr_noarg: lda error_table_$noarg sta ap|8,* short_return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " af_arg_ptr_rel ..... like af_arg_ptr " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " af_arg_ptr_rel: ldaq null " initialize output arguments staq ap|4,* stz ap|6,* eppbp ap|10,* " get the argument list pointer eppbp bp|0,* " ... eax2 8 " error code is 4th argument tsx1 verify_af_rel " check the call arg af_arg_ptr_return " ... error return tra af_arg_ptr_common " go do the work " " Verifies that the given argument list belongs to an active function. Ie: The last " argument must be a varying character string verify_af: eppbp sp|stack_frame.arg_ptr,* " use caller's argument list verify_af_rel: " use argument list pointer already in bp stz ap|0,2* " clear status code lda bp|0 " pick up argument list header cana 4+8,dl " must be a PL/I call tze af_error_not_af eax0 0,au " argument count to X0 tze af_error_not_af " ... no arguments: can't be an AF cmpx0 bp|1 " last argument must have a descriptor tnz af_error_nodescr eppbb bp|0,0 " set to locate the descriptors eax3 0,0 " ... check for an environment pointer ana 8+2,dl tze 2,ic " ... no environment pointer eax3 2,3 " ... skip over environment pointer lda bb|0,3* " get the descriptor tpl check_v1_desc " ... it's a version 1 descriptor ldq v2_mask " get mask to look at data type cmk v2_var,du " and check if it's a varying string tnz af_error_not_af " ... no ana =o77777777 " get the return value's length eaq -2,0 " compute actual argument count qrl 18+1 " ... which excludes the return value tra 1,1 " normal return check_v1_desc: " version 1 argument descriptor ldq desc_mask " get mask to look at data type cmk var_desc,du " and check if it's a varying string tnz af_error_not_af " ... no ana -1,dl " get the return value's length eaq -2,0 " compute actual argument count qrl 18+1 " ... which excludes the return value tra 1,1 " normal return af_error_nodescr: " no descriptors in argument list lda error_table_$nodescr tra af_error_return af_error_not_af: " last argument isn't character(*) varying lda error_table_$not_act_fnc af_error_return: sta ap|0,2* " set return code eaq 0,0 " put argument count into the Q qrl 18+1 " ... tra 0,1* " take error return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " caller_ptr ..... get pointer to text section of invoker's caller " " call cu_$caller_ptr (pointer); " " 1. pointer (ptr) is the pointer to invoker's caller's text section " provided he had a stack frame, or null if no caller exists. " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " caller_ptr: eppbp sp|stack_frame.prev_sp,* get pointer to previous frame eppbb bp|stack_frame.return_ptr,* pick up the caller's pointer spribb ap|2,* return pointer to caller short_return return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " arg_list_ptr ..... get pointer to caller's argument list " " call cu_$arg_list_ptr(ap) " " 1. ap (ptr) - pointer to caller's argument list (OUTPUT) " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " arg_list_ptr: eppbp sp|stack_frame.arg_ptr,* " pick up caller's argument list pointer spribp ap|2,* " return it to caller short_return " return control to caller " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " stack_frame_ptr ..... get pointer to caller's stack frame " " call cu_$stack_frame_ptr(sp) " " 1. sp (ptr) - pointer to caller's stack frame (returned). " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " stack_frame_ptr: sprisp ap|2,* return stack frame pointer to caller short_return return control to caller " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " stack_frame_size ..... get size of caller's stack frame " " call cu_$stack_frame_size(len) " " 1. len (fixed bin(17)) - size of caller's stack frame (returned). " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " stack_frame_size: ldq sp|stack_frame.next_sp+1 " get offset of next stack frame ... qrl 18 " ... into lower half of Q sblq sp|0,dl " subtract offset of our stack frame ... stq ap|2,* " ... and you have the stack frame size short_return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " grow_stack_frame ..... allocate space at end of caller's stack frame " " call cu_$grow_stack_frame(len, ptr, code) " " 1. len (fixed bin(17)) - length (in words) by which to grow frame. " 2. ptr (ptr) - pointer to space allocated in frame (returned). " 3. code (fixed bin(17)) - error status code (returned). " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " grow_stack_frame: eppbp sb|stack_header.stack_end_ptr,* pick up pointer to next stack frame spribp ap|4,* return it as ptr to allocated space stz ap|6,* preset error code to zero (OK) lda ap|2,* pick up size by which to grow frame ada 15,dl force size to mod 16 ana =o777760,dl .. eax1 0,al place size (now mod 16) into index 1 adx1 sb|stack_header.stack_end_ptr+1 add size to stack end pointer stx1 sp|stack_frame.next_sp+1 bump next frame pointer stx1 sb|stack_header.stack_end_ptr+1 update stack end pointer too lda ap|0 check for call from PL/I procedure cana =o14,dl .. tze sb|stack_header.ret_no_pop_op_ptr,* .. skip if not called by PL/I procedure stx1 sp|5 .. otherwise, correct sp|5 for PL/I short_return return control to caller " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "" " " " " " shrink_stack_frame ..... reduce the size of the present stack frame " " call cu_$shrink_stack_frame (stack_ptr, code); " " 1. stack_ptr (ptr) - pointer to position in the present stack frame which " will be the beginning of the next stack frame. " The pointer must be sixteen word aligned. " 2. code (fixed bin(17)) - error status code (returned). " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " shrink_stack_frame: stz ap|4,* zero out code eppbp ap|2,* get stack pointer eax1 bp|0,* .. canx1 =o000017,du check for sixteen aligned tze aligned .. lda error_table_$eight_unaligned if not aligned return code sta ap|4,* .. short_return .. aligned: eax2 sp|stack_frame.min_length check to see if before this frame cmpx2 bp|1 .. tmi inscope1 .. lda error_table_$frame_scope_err if so return error code sta ap|4,* .. short_return .. inscope1: cmpx1 sb|stack_header.stack_end_ptr+1 check to see if after this frame tmi inscope2 .. lda error_table_$frame_scope_err if so return error code sta ap|4,* .. short_return .. inscope2: stx1 sp|stack_frame.next_sp+1 if all ok, set next frame pointer stx1 sb|stack_header.stack_end_ptr+1 set end ptr lda ap|0 check for PL/1 call cana =o14,dl .. tze sb|stack_header.ret_no_pop_op_ptr,* skip if not PL/1 stx1 sp|5 correct sp|5 for PL/1 short_return return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " decode_entry_value ..... extract ptrs from PL/I entry variable " " call cu_$decode_entry_value(entry_value, ep_ptr, env_ptr) " " 1. entry_value (entry) - entry value to be decoded " 2. ep_ptr (ptr) - entry point pointer " 3. env_ptr (ptr) - environment pointer " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " decode_entry_value: epp5 ap|2,* get ptr to entry value epp3 pr5|0,* pick up entry ptr from entry variable spri3 ap|4,* store entry ptr in second arg epp3 pr5|2,* pick up environment ptr from entry variable spri3 ap|6,* store environment ptr in third arg short_return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " make_entry_value ..... construct PL/I entry value from input pointer " " call cu_$make_entry_value (ep_ptr, entry_var) " " 1. ep_ptr (ptr) - points to external entry point " 2. entry_var (entry) - entry variable to be filled in " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " make_entry_value: epp5 ap|2,* get ptr to first arg epp5 pr5|0,* pick up ep_ptr epp3 ap|4,* get ptr to entrry variable spri5 pr3|0 store ep_ptr into it ldaq null pick up null ptr staq pr3|2 and store in entry variable short_return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " level_get ..... entry to get (return) the current validation level " " call cu_$level_get (level) " " 1. level (fixed bin(17)) - current validation level (returned). " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " level_get: callsp hcs_$level_get " only hardcore knows for sure " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " level_set ..... entry to set the current validation level " " call cu_$level_set(level) " " 1. level (fixed bin(17)) - validation level to be set. " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " level_set: callsp hcs_$level_set " hardcore will do this end  cv_bin_.pl1 11/11/89 1144.7rew 11/11/89 0803.8 27135 /****^ ****************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright (c) 1987 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * ****************************************************** */ /* cv_bin .......... procedure to convert binary integer to ascii in decimal, octal or other specified base */ /* Converted to v2pl1, Nov 73, RE Mullen */ cv_bin_: procedure(a_n, a_string, a_base); declare a_n fixed bin(17), /* binary integer to be converted */ a_string char(12) aligned, /* character string in which to return ascii */ a_base fixed bin(17); /* conversion base */ declare (addr, divide, fixed, mod) builtin; declare base fixed bin(17), /* temporary storage */ p ptr, (n, i, z) fixed bin(17), (minus bit(1), bin_4 fixed bin (4)) aligned; declare digits (0:15) char (1) unal init ("0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "a", "b", "c", "d", "e", "f") static options (constant); declare word(3) char(4) based aligned; /* based array for initializing a_string */ declare 1 c based aligned, /* based, aligned, packed character array */ 2 a(0:11) char(1) unaligned; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ base = a_base; /* primary entry, initialize conversion base */ /* if base > 10 | base <= 0 then signal condition(cv_bin_base_error); */ go to common; dec: entry(a_n, a_string); /* entry to convert to decimal base */ base = 10; /* initialize conversion base to 10 */ go to common; oct: entry(a_n, a_string); /* entry to convert to octal base */ base = 8; /* initialize conversion base to 8 */ common: p = addr(a_string); /* get pointer to string (must be alligned) */ p -> word(1), p -> word(2), p -> word(3) = " "; /* initialize output string to blanks */ n = a_n; if n < 0 /* check for and adjust negative number */ then do; n = -n; minus = "1"b; end; else minus = "0"b; z = -1; /* Initialize to force at least one traversal of loop */ do i = 11 by -1 to 0 while(n ^= z); /* convert into string, last digit(11) first */ bin_4 = fixed(mod(n,base),4); p -> c.a(i) = digits (bin_4); n = divide(n, base, 17, 0); z = 0; /* Clear flag that forces "0" if zero value */ end; if minus then if i >= 0 /* value of "i" is correct for insertion of "-" */ then p -> c.a(i) = "-"; /* magnitude converted, add - sign if necessary */ /* else signal condition(cv_bin_minus_or_size); */ end cv_bin_;  cv_config_card_.pl1 11/11/89 1144.7rew 11/11/89 0803.9 77895 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-04-11,Fawcett), approve(86-04-11,MCR7383), audit(86-05-13,LJAdams), install(86-07-17,MR12.0-1097): special case the root and part card for subvolume implementation. END HISTORY COMMENTS */ /* CV_CONFIG_CARD_.PL1 -- translates a putative config card to */ /* a binary image. This is a syntactic translation only; no checks */ /* are made that the specified fields make any sense for the particular */ /* card. */ /* format: style2 */ /* BIM 8/82 */ /* Modified by RAF May 1985 special case the root card for subvolume implementation */ /* Modified by RAF Jul 1985 special case the part card for subvolume implementation */ cv_config_card_: procedure (text, card_ptr, code); declare ( text char (*), card_ptr pointer, code fixed bin (35) ) parameter; /* format: off */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* declare cv_config_card_ entry (char (*), pointer, fixed bin (35)); */ /* call cv_config_card_ (text_config, bin_card_ptr, code); */ /* code = 1 for null card */ /* code = 2 for invalid format card */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* format: on */ declare 1 single_card like config_card aligned automatic; declare i fixed bin; declare is_special bit (1); declare (line_left, pos, new_pos, token_end, comment) fixed bin (21); declare token char (32) varying; declare four_char char (4); declare Useful char (60) init ("abcdefghijklmnnopqrstuvwxyz1234567890.*!@#$%^&()_-+=~`\|?,:;") int static options (constant); declare Upper char (26) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ") int static options (constant); declare Lower char (26) init ("abcdefghijklmnopqrstuvwxyz") int static options (constant); declare Whitespace char (4) init (" ") /* SP TAB FF VT */ int static options (constant); declare (bit, length, min, rank, rtrim, substr, translate, index, verify, search, unspec) builtin; if verify (text, Useful || Whitespace) > 0 then INVALID_CARD: do; code = 2; return; end; pos = search (text, Useful); if pos = 0 then NULL_CARD: do; code = 1; return; end; line_left = length (text) - pos + 1; single_card.data_field (*) = "777777777777"b3; /* Initialize it */ unspec (single_card.type_word) = ""b; begin; declare left char (line_left) defined (text) position (pos); line_left = length (rtrim (left)); if line_left = 0 then goto NULL_CARD; end; /* begin block */ begin; declare left char (line_left) defined (text) position (pos); comment = index (text, "*"); if comment = 0 then comment = length (left); else comment = comment - 1; /* toss the * */ line_left = min ((line_left), comment); /* trim off comment */ if line_left = 0 then goto NULL_CARD; end; /* begin block */ begin; declare left char (line_left) defined (text) position (pos); if verify (left, Whitespace) = 0 then goto NULL_CARD; line_left = line_left - verify (reverse (left), Whitespace) + 1; /* and any training whiteness */ end; /* now we have a good starting pos and line_left */ /* */ single_card.n_fields = 0; PARSE: do i = 0 to 14 while (line_left > 0); LEFT_BLOCK: begin; declare left char (line_left) defined (text) position (pos); token_end = search (left, Whitespace) - 1; /* do not include the space */ if token_end < 0 then token_end = line_left; TOKEN_BLOCK: begin; declare a_token char (token_end) defined (text) position (pos); /* just what we want */ token = ""; token = translate (a_token, Lower, Upper); /* Lower Case */ if i = 0 then do; /* word card */ if length (token) > 4 then /* some simple checks */ goto INVALID_CARD; if verify (token, VALID_CARD_WORD_CHARACTERS) > 0 then goto INVALID_CARD; single_card.word = substr (token, 1, min (length (token), 4)); if single_card.word = "root" | single_card.word = "part" then /* special case the root */ is_special = "1"b; else is_special = "0"b; end; else do; single_card.n_fields = single_card.n_fields + 1; if is_special then /* all fileds on the root are STRING type but may look like oct or dec */ goto special_case; else if /* case */ octal_field (token, single_card.data_field (i)) then single_card.field_type (i) = CONFIG_OCTAL_TYPE; else if decimal_field (token, single_card.data_field (i)) then single_card.field_type (i) = CONFIG_DECIMAL_TYPE; else if single_char_field (token, single_card.data_field (i)) then single_card.field_type (i) = CONFIG_SINGLE_CHAR_TYPE; else do; special_case: if length (token) > 4 then goto INVALID_CARD; four_char = token; /* this will pad with SPACE */ unspec (single_card.data_field (i)) = unspec (four_char); single_card.field_type (i) = CONFIG_STRING_TYPE; end; end; end TOKEN_BLOCK; /* begin block */ new_pos = search (left, Whitespace) - 1;/* find some whitespace */ if new_pos < 0 then new_pos = line_left; pos = pos + new_pos; line_left = line_left - new_pos; end LEFT_BLOCK; /* begin block */ begin; declare left char (line_left) defined (text) position (pos); /* now find beginning of next token */ new_pos = verify (left, Whitespace) - 1;/* anybody home ? */ if new_pos < 0 then new_pos = line_left; pos = pos + new_pos; line_left = line_left - new_pos; end; /* begin block */ end PARSE; card_ptr -> config_card = single_card; /* copy out our result */ code = 0; return; /* All done converting */ /* */ octal_field: procedure (token, value) returns (bit (1)); dcl token char (*) varying; dcl value bit (36) aligned; dcl odigits char (8) init ("01234567") int static options (constant); if verify (token, odigits) ^= 0 then return (""b); else begin; declare f_value fixed bin (35); declare power_of_8 fixed bin (35); declare one_char char (1); declare charx fixed bin; f_value = 0; power_of_8 = 1; do charx = length (rtrim (token)) to 1 by -1; one_char = substr (token, charx, 1); f_value = f_value + (power_of_8 * (rank (one_char) - rank ("0"))); power_of_8 = power_of_8 * 8; end; value = "0"b || bit (f_value, 35); return ("1"b); end; decimal_field: entry (token, value) returns (bit (1)); dcl ddigits char (10) init ("0123456789") int static options (constant); dcl point char (1) init (".") int static options (constant); if verify (token, ddigits) = 0 | (substr (reverse (token), 1, 1) = point & verify (substr (token, 1, length (token) - 1), ddigits) = 0) then begin; declare f_value fixed bin (35); declare power_of_10 fixed bin (35); declare charx fixed bin; declare one_char char (1); charx = length (rtrim (token)); if substr (token, charx, 1) = point then charx = charx - 1; f_value = 0; power_of_10 = 1; do charx = charx to 1 by -1; one_char = substr (token, charx, 1); f_value = f_value + (power_of_10 * (rank (one_char) - rank ("0"))); power_of_10 = power_of_10 * 10; end; value = "0"b || bit (f_value, 35); return ("1"b); end; return (""b); /* no dice */ single_char_field: entry (token, value) returns (bit (1)); dcl a_to_h char (8) init ("abcdefgh") int static options (constant); dcl tag fixed bin (4); if length (token) > 1 then return (""b); /* easy case */ tag = index (a_to_h, token); /* find our victim */ if tag = 0 then return (""b); value = (32)"0"b || bit (tag, 4); return ("1"b); end octal_field; %page; %include config_deck; end cv_config_card_; /* Main procedure */  cv_dec_.pl1 11/11/89 1144.7r w 11/11/89 0803.8 72567 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Input Conversion Procedures: cv_dec_ cv_dec_check_ Converts decimal string to fixed bin (35). cv_oct_ cv_oct_check_ Converts octal string to fixed bin (35) or fixed bin (36) unsigned. cv_hex_ cv_hex_check_ Converts hexadecimal string to fixed bin (35) or fixed bin (36) unsigned. cv_binary_ cv_binary_check_ Converts binary string to fixed bin (35) or fixed bin (36) unsigned. Recoded 25 August 1976 by Noel I. Morris Modified 21 January 1981 by J. Spencer Love to detect overflow and sign without digits. Modified 16 November 1983 by Keith Loepere for cv_binary_ and cv_binary_check_. */ /* format: style3,ll122,idind30,ifthenstmt */ cv_dec_: procedure (P_string) returns (fixed bin (35)); declare P_string char (*), /* input string */ P_status fixed bin (35); /* error code: index of losing character */ declare (index, length, substr, subtract, unspec, verify) builtin; declare base fixed bin (5), /* number base for conversion */ digit fixed bin (5), /* current integer value */ dp_number fixed bin (39), /* result of multiply may be too big for number */ maximum fixed bin (36), /* Largest magnitude before overflow */ minus bit (1) aligned, /* "1"b if final result is negative */ number fixed bin (35), /* resultant number */ report_error bit (1) aligned, /* "1"b if error code returned */ string_pos fixed bin (21), /* zero based index of current character to examine */ valid_digits fixed bin (5); /* for character string scan */ declare DIGITS char (22) static options (constant) initial ("0123456789abcdefABCDEF"); %page; /* cv_dec_: procedure (P_string) returns (fixed bin (35)); */ base = 10; report_error = "0"b; /* P_status parameter not given. */ go to COMMON; cv_dec_check_: entry (P_string, P_status) returns (fixed bin (35)); base = 10; report_error = "1"b; /* P_status parameter given. */ go to COMMON; cv_oct_: entry (P_string) returns (fixed bin (35)); base = 8; report_error = "0"b; /* P_status parameter not given. */ go to COMMON; cv_oct_check_: entry (P_string, P_status) returns (fixed bin (35)); base = 8; report_error = "1"b; /* P_status parameter given. */ go to COMMON; cv_hex_: entry (P_string) returns (fixed bin (35)); base = 16; report_error = "0"b; /* P_status parameter not given. */ go to COMMON; cv_hex_check_: entry (P_string, P_status) returns (fixed bin (35)); base = 16; report_error = "1"b; /* P_status parameter given. */ go to COMMON; cv_binary_: entry (P_string) returns (fixed bin (35)); base = 2; report_error = "0"b; /* P_status parameter not given. */ go to COMMON; cv_binary_check_: entry (P_string, P_status) returns (fixed bin (35)); base = 2; report_error = "1"b; /* P_status parameter given. */ go to COMMON; %page; COMMON: minus = "0"b; /* Default is positive. */ if length (P_string) = 0 then do; /* Trivial case: return zero */ number = 0; go to VALID_NUMBER; end; string_pos = 0; /* Zero base index saves instructions. */ valid_digits = base; /* Set number of characters to compare. */ if valid_digits = 16 then valid_digits = 22; /* Allow both lower and upper case for HEX. */ if base = 10 then maximum = 34359738367; /* 2**35-1 (max for fixed bin (35)) */ else maximum = 68719476735; /* 2**36-1 (max for fixed bin (36) unsigned) */ GET_FIRST_DIGIT: number = index (substr (DIGITS, 1, valid_digits), substr (P_string, string_pos + 1, 1)) - 1; if number < 0 then do; /* Is this character a valid digit? */ number = 0; /* No digits yet. */ if index (" -+", substr (P_string, string_pos + 1, 1)) - 1 = 0 then do; /* Space: skip over all leading whitespace */ string_pos = verify (P_string, " ") - 1; if string_pos >= 0 then go to GET_FIRST_DIGIT; /* Try again; will never come back here. */ else go to VALID_NUMBER; /* No nonblank characters; return zero. */ end; /* Next: punt for invalid char or solitary sign */ else if index (" -+", substr (P_string, string_pos + 1, 1)) - 1 < 0 | substr (P_string, string_pos + 2) = "" then go to BAD_DIGIT; else if index (" -+", substr (P_string, string_pos + 1, 1)) - 1 = 1 then do; /* Minus sign. */ minus = "1"b; maximum = 34359738368; /* -2**35 (max for negative number) */ end; else maximum = 34359738367; /* 2**35-1 (max for positive number) */ end; else if number > 15 then number = subtract (number, 6, 35, 0); /* Using the subtract builtin prevents the compiler from emitting 3 gratuitious scaling instructions (SIGH). */ %page; /* Now build up the number. We already have the first digit, or at least the sign, so gobble up digits until we 1) run out, 2) encounter an invalid digit, or 3) the number gets too large. Note that trailing spaces are handled as a special case of invalid digit since we assume that most numbers we get will be rtrimmed. In the case of an invalid digit, we return its position by way of indicating an error. When the number gets too large, we treat the first digit that could not be accomodated as if it were an illegal character. */ do string_pos = string_pos + 1 to length (P_string) - 1; digit = index (substr (DIGITS, 1, valid_digits), substr (P_string, string_pos + 1, 1)) - 1; if digit < 0 then if substr (P_string, string_pos + 1) = "" then go to VALID_NUMBER; /* Check if only trailing whitespace. */ else go to BAD_DIGIT; /* Otherwise have illegal character. */ else if digit > 15 then digit = digit - 6; /* Adjust for uppercase HEX. */ /* The following statements shift in a digit. The multiply and add step generates a 72 bit number. This number may be too large to assign to a fixed bin (35) number. However, we permit several cases that would require such an invalid assignment. 1) -34359738368 (decimal) can be input. We read negative numbers in a digit at a time and negate them afterwards. This won't work for this value. 2) In octal and hexadecimal, we permit unsigned input. Positive values between 34359738368 and 68719476735 are too large to fit in fixed bin (35). So we use unspec to make sure these numbers don't cause size conditions and the like. Next time around, if number is negative, we know that we already have one of these oversized numbers and thus this digit is one too many. At VALID_NUMBER, we also check the number to see if it is already "negative" and don't negate -34359738368 since it would cause an overflow. Unsigned numbers (case 2) could never have minus = "1"b. */ if number < 0 then goto BAD_DIGIT; /* Too many digits; punt */ dp_number = number * base + digit; /* So what would new number be... */ if dp_number > maximum then go to BAD_DIGIT; /* if it fits? */ unspec (number) = substr (unspec (dp_number), 37); end; VALID_NUMBER: if report_error then P_status = 0; /* Indicate no error */ if minus & number > 0 then return (-number); /* Can't negate 2**35, but that's OK, it already is. */ else return (number); BAD_DIGIT: if report_error then P_status = string_pos + 1; /* Tell caller where we lost */ if minus & number > 0 then return (-number); /* Can't negate 2**35, but that's OK, it already is. */ else return (number); end cv_dec_;  cv_float_.pl1 11/11/89 1144.7rew 11/11/89 0803.9 64728 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-28,Vu), approve(89-04-28,MCR8099), audit(89-06-12,Lee), install(89-09-29,MR12.3-1074): Modify cv_float_.pl1 to accept a string that contains a decimal point followed by an exponential character. The following builtin functions are now declared explicitly: addr, divide, fixed, float, length, mod, substr. END HISTORY COMMENTS */ cv_float_: proc(string, code) returns (float bin); /* This procedure converts a number in character string form into floating point form */ /* initially coded by M Weaver 23 June 1970 */ /* last modified by M. Weaver 28 August 1970 18:25 */ /* minor bug fix by steve tepper 24 nov 71 */ /* Modified 09/04/84 by Jim Lippard to use returns (float bin) */ dcl (len, i, j, k, cstart, exp, digit) fixed bin; dcl code fixed bin (35); dcl cv_dec_check_ entry (char(*), fixed bin(35)) returns (fixed bin); dcl fltval float bin(63); /* tempoary for accumulating number */ dcl rflt1 float bin, rflt2 float bin(63); /* return arguments */ dcl fxval fixed bin(35); dcl (neg_bit, dbsw) bit(1) aligned; /* indicates positive or negative number */ dcl lsw bit(1) aligned int static init("1"b); /* indicates whether to initialize labels */ dcl p ptr; dcl string char(*) parm; /* contains input string */ dcl retlab(0:1) label local int static; dcl fini(0:1) label local int static; dcl 1 c based, /* used to reference string and digit */ 2 s(0:63) char(1); dcl (max, rank, verify) builtin; dcl (addr, divide, fixed, float, length, mod, substr) builtin; /* * * * * * * * * * * * * * * * * * * * * * * * * * */ rflt1 = 0.0e0; dbsw = "0"b; /* single precision argument */ go to init; cv_float_double_: entry(string, code) returns (float bin(63)); rflt2 = 0.0e0; dbsw = "1"b; /* double precision argument */ /* initialize */ init: p = addr(digit); if lsw then do; retlab(0) = ret0; retlab(1) = ret1; fini(0) = finish; fini(1) = ret1; lsw = "0"b; end; digit, code, fltval, exp = 0; neg_bit = "0"b; /* assume positive */ len = length(string) - 1; /* get length of input string */ p = addr(string); cstart = verify (string, " ") - 1; /* skip over leading blanks */ cstart = max (0, cstart); k = 0; /* want first set of labels */ go to convert; /* evaluate part of number before decimal point, if any, or before exponent */ ret0: /* get here if we are still in the middle of string */ if p->c.s(i) ^= "." then go to tryexp; /* here the only non-digit can be "." */ k = 1; /* use second set of labels */ cstart = i + 1; /* continue with next character */ go to convert; ret1: if i > cstart then exp = cstart - i; /* had a fraction */ if i > len then go to reduce; /* there is no explicit exponent */ if p->c.s(i) = " " then go to reduce; tryexp: if p->c.s(i) ^= "e" then go to error; /* explicit exponent must start with "e" */ /**** vp: phx19667; a string that contains the decimal point followed immediately by an exponential character (ie. 1.e3) is valid. ****/ if i=len then go to error; /* can't have a number ending in "e" */ if i=cstart then do; /* can't have a number starting in "e" or ".e" or "+.e" or "-.e" */ if i=0 | i =1 then go to error; if i=2 & (p->c.s(0) = "-" | p->c.s(0) = "+") then go to error; end; digit = cv_dec_check_(substr(string, i+2), code); /* get value of exponent which is an integer */ if code > 0 then do; /* check code from cv_dec_check_ */ code = i + code + 1; /* set code to appropriate value for floating pt. number */ return ((0)); end; exp = exp + digit; /* add explicit to implicit exponent */ reduce: /* finish evaluating the number */ if fltval < 1.0e8 then do; /* temporary value is single precision */ /* many fractions, such as .25 and .0625, can be expressed exactly in binary form but this won't happen with ordinary floating point conversion; thus for up to 5 iterations, we will divide by 5 (fixed point), multiply by 10 and divide by 2 (floating point) */ fxval = fixed(fltval, 35); do j = 1 to 5 while(mod(fxval,5) = 0); fxval = divide(fxval,5,35,0); exp = exp + 1; end; fltval = float(fxval, 63); end; else j = 1; /* number can't necessarily be represented exactly as a floating point number in binary form */ /* Because the decimal places are kept in the exponent, and because of the above adjustment for even powers of 2, the exponent may appear to be out of range even though the input number is within range. In this case, the number is partially evaluated first. */ if exp > 38 then do; fltval = fltval * 10.0e0 ** 38; exp = exp - 38; end; if exp < -38 then do; fltval = fltval * 10.0e0 ** -38; exp = exp + 38; end; /* finish evaluating number; using the expontiation operator, **, produces results different from dividing ot multiplying by 10. */ if exp ^= 0 then fltval = fltval * 10.0e0 ** exp; if j > 1 then fltval = fltval / 2.0e0 ** (j-1); finish: if neg_bit then fltval = -fltval; if dbsw then do; rflt2 = fltval; /* return double precision */ return (rflt2); end; else do; rflt1 = fltval; /* return single precision */ return (rflt1); end; /* section to actually do the conversion from character string to floating point */ convert: do i = cstart to len; digit = rank (p->c.s(i)); /* copy character into digit */ if digit >= 48 then do; /* could be a digit */ if digit > 57 then if digit = 101 then go to retlab(k); /* "e" */ else go to error; /* not a digit */ fltval = fltval * 10 + digit - 48; /* update temporary */ end; else do; /* not a digit; check for special characters */ if digit = 46 then go to retlab(k); /* decimal point or error */ if digit = 32 /* blank */ then if substr(string,i+1) = " " /* ignore trailing blanks */ then go to fini(k); else go to error; if k = 0 then if i = cstart then do; /* look for + or - only at beg of number */ if digit = 45 then neg_bit = "1"b; /* minus */ else if digit ^= 43 /* plus */ then go to error; go to end_conv; /* continue processing string */ end; go to error; /* bad character */ end; end_conv: end; /* end of loop on characters */ go to fini(k); error: code = i + 1; /* set error code */ return ((0)); end cv_float_;  cv_fsdisk_error_.pl1 11/11/89 1144.7rew 11/11/89 0803.9 13698 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /* CV_FSDISK_ERROR_ -- converts fsdisk_error_message to error_table_ */ /* format: style2 */ cv_fsdisk_error_: procedure (Code); declare Code fixed binary (35); /* format: off */ declare et_codes (1:9) fixed bin (35) init ( error_table_$fsdisk_pvtx_oob, error_table_$fsdisk_drive_in_use, error_table_$fsdisk_not_salv, error_table_$fsdisk_old_label, error_table_$fsdisk_old_vtoc, 0, error_table_$fsdisk_phydev_err, error_table_$fsdisk_not_storage, error_table_$fsdisk_not_ready); /* format: on */ declare ( error_table_$fsdisk_pvtx_oob, error_table_$fsdisk_drive_in_use, error_table_$fsdisk_not_salv, error_table_$fsdisk_old_label, error_table_$fsdisk_old_vtoc, error_table_$fsdisk_phydev_err, error_table_$fsdisk_not_storage, error_table_$fsdisk_not_ready ) fixed bin (35) external static; if Code < 10 & Code > 0 then Code = et_codes (Code); return; end cv_fsdisk_error_;  cv_integer_string_.pl1 11/11/89 1144.7r 11/11/89 0803.9 77229 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * *********************************************************** */ /* routines to convert strings to integers */ /* Written May 1984 by Chris Jones */ /* Modified November 1984 by Keith Loepere to explictly validate radix base. (avoids signalling condition in bce). Also for negative octal values. */ /* format: style4,delnl,insnl,indattr,ifthen,dclind10 */ cv_integer_string_: proc (p_string, p_default_base) returns (fixed bin (35)) options (support); dcl p_string char (*) parameter; /* (I) string to be converted */ dcl p_default_base fixed bin parameter; /* (I) base to use if none is specified */ dcl p_code fixed bin (35) parameter; /* (O) system status code */ dcl base fixed bin; dcl char_idx fixed bin; dcl check_entry bit (1) aligned; dcl digit fixed bin; dcl negative bit (1) aligned; /* set if the result is to be negative */ dcl reason char (128); dcl result fixed bin (71); dcl return_result fixed bin (35); dcl digits_string char (digits_string_length) based (digits_string_ptr); dcl digits_string_ptr ptr; dcl digits_string_length fixed bin (21); dcl MINUS_SIGN char (1) static options (constant) init ("-"); dcl PLUS_SIGN char (1) static options (constant) init ("+"); dcl UNDERSCORE char (1) static options (constant) init ("_"); dcl WHITESPACE char (2) static options (constant) init (" "); /* SP HT */ dcl VALID_DECIMAL_DIGITS char (10) static options (constant) init ("0123456789"); dcl VALID_DIGITS char (22) static options (constant) init ("0123456789AaBbCcDdEeFf"); dcl digit_value (22) fixed bin static options (constant) init (0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 10, 11, 11, 12, 12, 13, 13, 14, 14, 15, 15); dcl RADIX_INDICATORS char (4) static options (constant) init ("bodx"); dcl RADIX_INDICATORS_UPPER_CASE char (4) static options (constant) init ("BODX"); dcl base_values (4) fixed bin static options (constant) init (2, 8, 10, 16); dcl error_table_$bad_conversion fixed bin (35) ext static; dcl (addcharno, addr, convert, index, length, null, reverse, search, string, substr, translate, unspec, verify) builtin; dcl (conversion, fixedoverflow) condition; dcl signal_ entry () options (variable); check_entry = "0"b; goto COMMON; cv_integer_string_check_: entry (p_string, p_default_base, p_code) returns (fixed bin (35)); check_entry = "1"b; on conversion, fixedoverflow go to BADNUM; COMMON: digits_string_length = length (p_string); /* setup to point at string */ digits_string_ptr = addr (p_string); call trim_whitespace; if substr (digits_string, 1, 1) = MINUS_SIGN then do; negative = "1"b; call adjust_from_left (1); call trim_whitespace; end; else if substr (digits_string, 1, 1) = PLUS_SIGN then do; negative = "0"b; call adjust_from_left (1); call trim_whitespace; end; else negative = "0"b; /* implicit positive number */ call get_base; result = 0; do char_idx = 1 to length (digits_string); digit = digit_value (index (VALID_DIGITS, substr (digits_string, char_idx, 1))); result = result * base + digit; end; if negative then result = -result; if check_entry then p_code = 0; if result < -34359738368 /* 2**35 (max for fixed bin (35)) */ | result > 68719476735 /* 2**36-1 (max for fixed bin (36) unsigned) */ then do; reason = "The converted string does not fit in 36 bits."; go to BADNUM; end; /* The above, plus the unspec assignment below, is to allow the input of (mostly octal) values up to 777777777777o. */ unspec (return_result) = substr (unspec (result), 37, 36); return (return_result); get_base: proc; /**** This is actually where the most interesting work takes place. If no radix indicator exists to tell us otherwise, we'll use the default base. Radix indicators can be specified by a single character (b, o, d, x), or by the construct r (). Both are optionally preceded by an underscore. If there's a possibility that a character is a valid digit as well as a radix indicator (as is the case with b and d with a base of 16), we assume the character is a digit. ****/ dcl radix_string char (radix_string_length) based (radix_string_ptr); dcl radix_string_ptr ptr; dcl radix_string_length fixed bin (21); dcl radix_char char (1); dcl radix_char_valid bit (1) aligned; base = p_default_base; /* start out assuming there's no radix indicator */ char_idx = search (reverse (digits_string), "Rr"); if char_idx ^= 0 then do; /* there MUST be a radix indicator */ radix_string_ptr = addcharno (digits_string_ptr, digits_string_length - char_idx + 1); radix_string_length = char_idx - 1; call adjust_from_right (char_idx); if substr (digits_string, length (digits_string), 1) = UNDERSCORE then call adjust_from_right (1); if verify (radix_string, VALID_DECIMAL_DIGITS) > 0 then go to BADNUM; base = convert (base, radix_string); end; else do; radix_char = translate (substr (digits_string, length (digits_string), 1), RADIX_INDICATORS, RADIX_INDICATORS_UPPER_CASE); if search (RADIX_INDICATORS, radix_char) ^= 0 then do; /* this MIGHT be a radix character */ if substr (digits_string, length (digits_string) - 1, 1) = UNDERSCORE then do; call adjust_from_right (2); /* strip off the underscore and indicator */ radix_char_valid = "1"b; end; else do; if (base <= 10) | (base <= 12 & radix_char ^= "b") | (base <= 14 & radix_char ^= "b" & radix_char ^= "d") then do; call adjust_from_right (1); radix_char_valid = "1"b; end; else radix_char_valid = "0"b; end; if radix_char_valid then base = base_values (search (RADIX_INDICATORS, radix_char)); end; end; if base < 2 | base > 16 then do; reason = "The base is not in the range 2-16."; goto BADNUM; end; if base <= 10 then char_idx = base; else char_idx = base + base - 10; if verify (digits_string, substr (VALID_DIGITS, 1, char_idx)) ^= 0 then do; reason = "The string contains invalid digits."; goto BADNUM; end; end get_base; BADNUM: if check_entry then do; p_code = error_table_$bad_conversion; return (0); end; else begin options (non_quick); dcl 1 auto_pl1_info like pl1_info; dcl size builtin; pl1_info_ptr = addr (auto_pl1_info); unspec (pl1_info.header) = ""b; pl1_info.header.length = size (pl1_info); pl1_info.header.version = 1; pl1_info.header.action_flags.cant_restart = "1"b; pl1_info.header.info_string = reason; pl1_info.header.status_code = error_table_$bad_conversion; pl1_info.id = "pliocond"; string (pl1_info.content_flags) = ""b; pl1_info.oncode_sw = "1"b; pl1_info.oncode = 720; /* see oncode_messages_ */ pl1_info.onsource_sw = "1"b; pl1_info.onsource = p_string; call signal_ ("conversion", null (), pl1_info_ptr); return (0); end; trim_whitespace: proc; char_idx = verify (digits_string, WHITESPACE); if char_idx = 0 then do; reason = "The string consists only of whitespace."; goto BADNUM; /* consisted only of whitespace characters */ end; call adjust_from_left (char_idx - 1); char_idx = verify (reverse (digits_string), WHITESPACE); if char_idx = 0 then do; reason = "The string consists only of whitespace."; goto BADNUM; end; call adjust_from_right (char_idx - 1); call quit_if_empty_string; end trim_whitespace; quit_if_empty_string: proc; if digits_string_length = 0 then do; reason = "There are no digits to process."; goto BADNUM; end; end quit_if_empty_string; adjust_from_left: proc (count); dcl count fixed bin parameter; digits_string_ptr = addcharno (digits_string_ptr, count); adjust_from_right: entry (count); digits_string_length = digits_string_length - count; end adjust_from_left; %include pl1_info; %include condition_info_header; end cv_integer_string_;  decode_descriptor_.pl1 11/11/89 1144.7r w 11/11/89 0803.9 38718 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Name: decode_descriptor_ */ /* */ /* This subroutine decodes an argument descriptor, returning from the descriptor */ /* the argument type, a packing indicator, the number of dimensions in the argument, */ /* and the size and scale of the argument. */ /* */ /* Status */ /* */ /* 1) Modified on: September 16, 1975 by Gary C. Dixon */ /* a) bug fixed in decoding of new area descriptors; they had been treated as having */ /* both size and scale; they now have only size. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* Last modified (date and reason): Aug 9, 1977 by S. Webber to make better use of static storage Modified 771026 by PG to handle packed-decimal and unsigned descriptor types Modified 780407 by PG to delete packed-ptr descriptor code */ /* Changed for extended data types, removed V1 support 10/20/83 M. Weaver */ /* Modified Dec.14, 1983 by M. Weaver to make size arg fixed bin (24) */ decode_descriptor_: proc (P_arg_list_ptr, P_num, P_type, P_packed, P_ndims, P_size, P_scale); /* Parameters */ dcl P_arg_list_ptr ptr; /* Points to either arg_list or descriptor (Input) */ dcl P_num fixed bin; /* index of arg, 0 => P_arg_list_ptr points to descrip */ dcl P_type fixed bin; /* data type (Output) */ dcl P_packed bit (1) aligned; /* "1"b if P_packed (Output) */ dcl P_ndims fixed bin; /* number of array dims (Output) */ dcl P_size fixed bin (24); /* string size or arithmetic precision (Output) */ dcl P_scale fixed bin; /* arithmetic scale (Output) */ /* Automatic */ dcl arg_count fixed bin; /* Constants */ dcl new_type (518:528) fixed bin int static options (constant) /* Conversion table for old-style to new-style */ init (18, /* 518 -> Area */ 19, /* 519 -> BS */ 21, /* 520 -> CS */ 20, /* 521 -> VBS */ 22, /* 522 -> VCS */ 17, /* 523 -> A-structure */ 18, /* 524 -> A-area */ 19, /* 525 -> ABS */ 21, /* 526 -> ACS */ 20, /* 527 -> AVBS */ 22); /* 528 -> AVCS */ dcl (AREA_TYPE init (18), REAL_FIXED_DEC_LS_OVER_TYPE init (29), EXTENSION_TYPE init (58)) fixed bin int static options (constant); /* Based */ %include arg_descriptor; %include arg_list; %page; if P_num = 0 then do; arg_descriptor_ptr = P_arg_list_ptr; /* points directly at the descriptor */ go to CHECK; end; arg_count = P_arg_list_ptr -> arg_list.header.arg_count; if P_num > arg_count then do; BAD_DESCRIPTOR: P_type = -1; return; end; if P_arg_list_ptr -> arg_list.header.desc_count = 0 then go to BAD_DESCRIPTOR; if P_arg_list_ptr -> arg_list.header.call_type = Envptr_supplied_call_type then arg_descriptor_ptr = P_arg_list_ptr -> arg_list_with_envptr.desc_ptrs (P_num); else arg_descriptor_ptr = P_arg_list_ptr -> arg_list.desc_ptrs (P_num); CHECK: if ^arg_descriptor.flag then go to BAD_DESCRIPTOR; /* Version 1 or invalid */ P_type = arg_descriptor.type; P_packed = arg_descriptor.packed; P_ndims = arg_descriptor.number_dims; if P_type = EXTENSION_TYPE | (P_type >= AREA_TYPE & P_type < REAL_FIXED_DEC_LS_OVER_TYPE) then do; P_size = arg_descriptor.size; P_scale = 0; end; else do; P_size = fixed_arg_descriptor.precision; P_scale = fixed_arg_descriptor.scale; end; if P_type = EXTENSION_TYPE then P_type = extended_arg_descriptor.real_type; return; end decode_descriptor_;  define_area_.pl1 11/11/89 1144.7rew 11/11/89 0803.9 121293 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ define_area_: proc (a_area_infop, a_code); /****^ HISTORY COMMENTS: 1) change(75-01-01,Webber), approve(), audit(), install(): Unknown date, coded by S. Webber. 2) change(76-08-01,Weaver), approve(), audit(), install(): Modified by M. Weaver to fix get_next_area_ptr_. 3) change(76-08-01,RBarnes), approve(), audit(), install(): Modified for extendable no_free areas. 4) change(77-04-01,Weaver), approve(), audit(), install(): Modified to make release_area_ safer and easier to use. 5) change(77-08-01,RBarnes), approve(), audit(), install(): Modified to implement zero_on_alloc for no_free areas. 6) change(77-08-20,Green), approve(), audit(), install(): Modified by PG to fix bug (must init zero_on_free areas to zero). 7) change(78-09-01,Carlyle), approve(), audit(), install(): Modified by K. Carlyle to fix bug (area size must be at least 32). 8) change(80-01-01,Weaver), approve(), audit(), install(): Modified to make release_area_ zero only to next_virgin. 9) change(81-06-01,Donner), approve(), audit(), install(): Modified by E. Donner to set ring brackets on extensible area segment. 10) change(86-05-15,Lippard), approve(86-06-23,MCR7438), audit(86-08-04,Hartogs), install(86-08-19,MR12.0-1120): Modified by Jim Lippard to set ring brackets on additional segments in area to be the same as component 0 regardless of system bit; and to not allow an area to be defined starting at an odd address. 11) change(86-09-18,Lippard), approve(86-06-23,PBF7438), audit(86-09-24,Farley), install(86-09-25,MR12.0-1164): Modified to not always zero out new components of extensible areas. END HISTORY COMMENTS */ /* Automatic */ dcl code fixed bin (35); dcl next_areap ptr; dcl new_extend_blockp ptr; dcl defined bit (1) aligned; dcl 1 info aligned like area_info; dcl area_size fixed bin (18); dcl len fixed bin; dcl dirname char (168); dcl entname char (32); dcl dlng fixed bin; dcl rings (3) fixed bin (3); dcl set_ring_brackets bit (1) aligned; /* Parameters */ dcl a_area_infop ptr; dcl a_code fixed bin (35); dcl 1 a_control aligned like area_control; dcl a_areap ptr; dcl a_next_componentp ptr; /* Constants */ dcl Max_Components fixed bin static init (1000) options (constant); /* Based */ dcl based_area area (area_size) aligned based (areap); /* Entries */ dcl unique_chars_ entry (bit (*)) returns (char (15)); dcl get_temp_segment_ entry (char(*), ptr, fixed bin(35)); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl hcs_$get_ring_brackets entry (char (*), char (*), (3) fixed bin (3), fixed bin (35)); dcl hcs_$set_ring_brackets entry (char (*), char (*), (3) fixed bin (3), fixed bin (35)); dcl release_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl get_ring_ entry () returns (fixed bin); dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)); dcl delete_$ptr entry (ptr, bit (6), char (*), fixed bin (35)); /* Builtins */ dcl (bit, empty, rel, null, bin, substr, addr, addrel, index, length, mod, unspec, wordno, size) builtin; /* External */ dcl sys_info$max_seg_size fixed bin (18) ext; dcl error_table_$unimplemented_version fixed bin (35) ext; dcl error_table_$area_too_small fixed bin (35) ext; dcl error_table_$boundviol fixed bin (35) ext; dcl error_table_$noalloc fixed bin (35) ext; dcl error_table_$no_odd_areas fixed bin (35) ext; /* Conditions */ dcl area condition; dcl bad_area_initialization condition; dcl cleanup condition; /* */ /* This routine creates and initializes an area segment. It takes control information from its input structure and sets special bits in the area header to reflect the desired result. if the area is extensible, an extension blocks is allocated in the area and initialized appropriately. */ area_infop = a_area_infop; if area_info.version ^= area_info_version_1 then do; a_code = error_table_$unimplemented_version; return; end; else a_code = 0; if area_info.extend | (area_info.areap = null) then if area_info.size < size (area_header) + min_block_size + size (extend_block) then go to MIN_SIZE_ERROR; else ; else if area_info.size < size (area_header) + min_block_size then go to MIN_SIZE_ERROR; if area_info.size > sys_info$max_seg_size then go to MAX_SIZE_ERROR; /* First create the area segment if necessary. The nullness of the input area pointer indicates what we are to do. */ if area_info.areap = null then do; /* null means we should get an area segment */ len = index (area_info.owner, " ") - 1; if len < 0 then len = length (area_info.owner); if area_info.system | (get_ring_ () = 0) then call hcs_$make_seg ("", unique_chars_ (""b) || ".area." || substr (area_info.owner, 1, 10), "", 01110b, area_info.areap, code); else call get_temp_segment_ (substr (area_info.owner, 1, len) || ".area", area_info.areap, code); if code ^= 0 then goto ERROR; defined = "1"b; end; else do; if mod (wordno (area_info.areap), 2) ^= 0 then goto ODD_AREA_ERROR; defined = "0"b; end; areap = area_info.areap; /* this is the pointer we will use */ /* First we must empty the area */ area_size = area_info.size; /* get requested size of area */ /* implement zero_on_alloc for no_freeing areas */ /* (system areas are assumed to be zero to start with...) */ if ^defined then if ^area_info.system & ((area_info.no_freeing & area_info.zero_on_alloc) | area_info.zero_on_free) then unspec (areap -> based_area) = "0"b; on bad_area_initialization goto ERROR; areap -> based_area = empty; /* Now we must fill in the control bits in the area header before attempting to allocate any extend structure */ if area_info.no_freeing then do; area_header.allocation_method = NO_FREEING_ALLOCATION_METHOD; no_free_area_header.current_component = areap; end; else area_header.allocation_method = STANDARD_ALLOCATION_METHOD; area_header.zero_on_free = area_info.zero_on_free; area_header.zero_on_alloc = area_info.zero_on_alloc; area_header.dont_free = area_info.dont_free; area_header.extend = area_info.extend; area_header.system = area_info.system; area_header.defined_by_call = defined; /* Now see if we must allocate an extend block */ if area_header.extend | area_header.defined_by_call then do; /* yes, do it */ on condition (area) goto ERROR; allocate extend_block in (based_area) set (extend_blockp); extend_block.first_area = areap; extend_block.next_area = null; extend_block.sequence_no = 1; extend_block.name = area_info.owner; area_header.extend_info = bit (bin (bin (rel (extend_blockp), 18) - bin (rel (areap), 18), 18), 18); end; return; ERROR: a_code = error_table_$noalloc; return; ODD_AREA_ERROR: a_code = error_table_$no_odd_areas; return; MIN_SIZE_ERROR: a_code = error_table_$area_too_small; return; MAX_SIZE_ERROR: a_code = error_table_$boundviol; return; change_area_attributes_: entry (a_areap, a_control, a_code); do areap = a_areap repeat next_areap while (areap ^= null); area_header.extend = a_control.extend; area_header.zero_on_alloc = a_control.zero_on_alloc; area_header.zero_on_free = a_control.zero_on_free; area_header.dont_free = a_control.dont_free; area_header.system = a_control.system; if a_control.no_freeing then area_header.allocation_method = NO_FREEING_ALLOCATION_METHOD; if area_header.extend_info then next_areap = addrel (areap, area_header.extend_info) -> extend_block.next_area; else next_areap = null; end; return; get_next_area_ptr_: entry (a_areap, a_next_componentp); /* This entry is called by alloc_ when it runs off the end of an extensible area segment */ areap = a_areap; extend_blockp = addrel (areap, area_header.extend_info); if extend_block.next_area = null then do; if extend_blockp -> extend_block.sequence_no >= Max_Components then do; abort: a_next_componentp = null; return; end; if area_header.system | (get_ring_ () = 0) then do; call hcs_$fs_get_path_name (areap, dirname, dlng, entname, code); /* find out what directory area is in */ call hcs_$get_ring_brackets (dirname, entname, rings, code); /* save ring brackets of original area segment */ if code ^= 0 then go to abort; entname = (unique_chars_ (""b) || ".area." || substr (extend_block.name, 1, 10)); call hcs_$make_seg (dirname, entname, "", 01110b, info.areap, code); /* create new component in same directory */ if code ^= 0 then goto abort; call hcs_$set_ring_brackets (dirname, entname, rings, code); if code ^= 0 then go to abort; set_ring_brackets = "0"b; end; else do; info.areap = null (); set_ring_brackets = "1"b; end; info.version = area_info_version_1; info.extend = area_header.extend; info.zero_on_alloc = area_header.zero_on_alloc; info.zero_on_free = area_header.zero_on_free; info.dont_free = area_header.dont_free; info.no_freeing = (area_header.allocation_method = NO_FREEING_ALLOCATION_METHOD); info.system = area_header.system; info.size = sys_info$max_seg_size; info.owner = extend_block.name; call define_area_ (addr (info), code); if code ^= 0 then go to abort; info.areap -> area_header.flags.defined_by_call = "1"b; /* extended components are defined by call */ extend_block.next_area = info.areap; new_extend_blockp = addrel (info.areap, info.areap -> area_header.extend_info); new_extend_blockp -> extend_block.sequence_no = extend_block.sequence_no + 1; new_extend_blockp -> extend_block.first_area = extend_block.first_area; if set_ring_brackets then do; call hcs_$fs_get_path_name (areap, dirname, dlng, entname, code); if code ^= 0 then go to abort; call hcs_$get_ring_brackets (dirname, entname, rings, code); if code ^= 0 then go to abort; call hcs_$fs_get_path_name (info.areap, dirname, dlng, entname, code); if code ^= 0 then go to abort; call hcs_$set_ring_brackets (dirname, entname, rings, code); if code ^= 0 then go to abort; end; end; a_next_componentp = extend_block.next_area; return; release_area_: entry (a_areap); /* This entry, given a pointer to the first component of a possible multi-component area, deletes all components created by the define_area_ interface. */ /* THIS ENTRY MUST NOT BE CALLED IN RING ZERO! */ dcl (mask, oldmask) bit (36) aligned; dcl i fixed bin; dcl ips_names char (32) aligned; dcl create_ips_mask_ entry (ptr, fixed bin, bit (36) aligned); dcl (hcs_$set_ips_mask, hcs_$reset_ips_mask) entry (bit (36) aligned, bit (36) aligned); ips_names = "-all"; call create_ips_mask_ (addr (ips_names), 1, mask); oldmask = "0"b; on cleanup begin; if substr (oldmask, 36, 1) then do; mask = oldmask; call hcs_$reset_ips_mask (mask, oldmask); end; end; call hcs_$set_ips_mask (mask, oldmask); areap = a_areap; a_areap = null; /* indicate to caller that we were called */ do i = 1 to Max_Components while (areap ^= null); if area_header.extend | area_header.defined_by_call then do; extend_blockp = addrel (areap, area_header.extend_info); next_areap = extend_block.next_area; extend_block.next_area = null; end; else next_areap = null; if area_header.defined_by_call then do; if ^area_header.flags.system then do; len = index (extend_block.name, " ") - 1; if len < 0 then len = length (extend_block.name); call release_temp_segment_ (substr (extend_block.name, 1, len) || ".area", areap, code); if code ^= 0 then call delete_$ptr (areap, "000100"b, "release_area_", code); /* this is to delete segments created in ring 0 */ end; else call delete_$ptr (areap, "000100"b, "release_area_", code); end; else do; if area_header.flags.zero_on_free then do; area_size = bin (area_header.next_virgin, 18); unspec (areap -> based_area) = "0"b; end; area_size = bin (area_header.last_usable, 18); /* be sure area size is correct for empty */ areap -> based_area = empty; end; areap = next_areap; end; mask = oldmask; call hcs_$reset_ips_mask (mask, oldmask); return; /* */ %include area_structures; %include area_info; end define_area_;  display_access_class_.pl1 11/11/89 1144.7rew 11/11/89 0803.8 22536 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style2 */ /**** DISPLAY_ACCESS_CLASS_ - This module converts a bit (72) representation of the Multics Access Isolation Mechanism (AIM) access class marking into a string of the form: LLL...L:CCC...C where "LLL...L" is a octal sensitivity level number (generally one digit) and "CCC...C" is an octal for the access category set. for a range, L:CCCCCC-L:CCCCC is used. for an authorization, L:CCCCCC,PPPPPP is used, where P are the privileges. /* Originally coded 8/21/74 by Lee J. Scheffler */ /* 84-04-02 BIM : Range entrypoint added. */ /* 84-04-27 BIM : display_authorization_ added, modernized. */ display_access_class_: convert_aim_attributes_: procedure (aim_attributes) returns (char (32) aligned); dcl aim_attributes bit (72) aligned parameter; /* access authorization or class */ dcl aim_string char (32); dcl display_privileges bit (1) aligned; dcl ioa_$rsnnl entry () options (variable); %include aim_template; declare 1 AIM aligned like aim_template; display_privileges = "0"b; go to COMMON; display_authorization_: entry (aim_attributes) returns (char (32) aligned); display_privileges = "1"b; COMMON: unspec (AIM) = aim_attributes; aim_string = ""; call ioa_$rsnnl ("^o:^.3b^[,^.3b^]", aim_string, (0), AIM.level, substr (AIM.categories, 1, 18), display_privileges, string (AIM.privileges)); return (aim_string); range: entry (aim_range) returns (char (32) aligned); declare aim_range (2) bit (72) aligned; declare range_string (2) char (32) aligned; declare rx fixed bin; do rx = 1, 2; range_string (rx) = display_access_class_ (aim_range (rx)); end; aim_string = rtrim (range_string (1)) || "-" || range_string (2); return (aim_string); end display_access_class_;  filemap_checksum_.alm 11/11/89 1144.7r w 11/11/89 0803.9 23922 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " *********************************************************** " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " Routine to compute exclusive-or checksums of the used " portion of the file map " " " Written January 1982 by J. Bongiovanni " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " name filemap_checksum_ entry filemap_checksum_ temp checksum_temp " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " filemap_checksum_ - external entry " " call filemap_checksum_ (addr (begin_word), csl, cksum) " " where: " " begin_word is the first word to checksum " " csl is the current segment length " " cksum is the returned checksum value " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " filemap_checksum_: push epplb ap|2,* " lb -> ptr -> first word epplb lb|0,* " lb -> first word lda ap|4,* " Areg = current segment length ada 1,dl " Compute number of words in file map arl 1 eax0 0,al " Number of words tsx7 checksum " compute the checksum sta ap|6,* " Areg = computed checksum return " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " checksum - Internal subroutine " " tsx7 checksum " " On entry " lb -> first word to checksum " x0 = number of words to checksum " " On exit " Areg = computed checksum " x1, Qreg destroyed " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " even zero_value: dec 0,0 checksum: ldaq zero_value " Initially zero eax0 0,x0 " Number of words tze checksum_returns " Easy case eax1 lb|0,x0 " x1 = offset of word beyond end canx1 1,du " Is last word to checksum at odd offset tze checksum_loop " Yes lda lb|-1,x0 " No, adjust so that it is eax0 -1,x0 tze checksum_returns " first is last checksum_loop: eax0 -2,x0 " Setup for next double word tze checksum_even " Next double word exhausts list tmi checksum_odd " Next word exhausts list eraq lb|0,x0 " Exclusive-or next double word tra checksum_loop " And continue checksum_even: eraq lb|0 " Fold in first double word tra checksum_returns checksum_odd: era lb|0 " Fold in first word checksum_returns: stq checksum_temp " Fold Qreg into Areg era checksum_temp tra 0,x7 " And return end  fill_vol_extents_.pl1 11/11/89 1144.7r w 11/11/89 0803.8 165294 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style2 */ fill_vol_extents_: procedure (a_labelp, interlace, a_nvtoce, a_baseadd, a_num_pages, a_defaultsw, a_device_type, a_code); /* fill_vol_extents_: excerpted by BSG from init_disk_pack_, commoned with disk_rebuild_caller, as per MCR 2105 08/31/76 */ /* Used to be called "get_special_vol_data". Also made mandantory at this time. */ /* Modified by Mike Grady 9/79 to fix really trivial bug */ /* Modified April 1982 by J. Bongiovanni to print low partition address correctly */ /* Modified 821018 BIM parameterize, bootload entry, simple_command_processor_ */ /* Modified 2/83 by Keith Loepere to use bce_command_processor_ and environment */ /* Modified 9/83 by Keith Loepere for bce and file partitions. */ /* Modified 2/84 by Keith Loepere to fix asl <-> vtoc_size computations. */ /****^ HISTORY COMMENTS: 1) change(85-09-09,Farley), approve(85-09-09,MCR6979), audit(85-12-02,CLJones), install(86-03-21,MR12.0-1033): Support of FIPS by not allow vtoc_size to go over the max. 2) change(86-01-07,Fawcett), approve(86-04-11,MCR7383), audit(86-05-13,LJAdams), install(86-07-17,MR12.0-1097): Add support for MSU3380 and MSU3390 512_word_io one vtoc per sector. 3) change(86-04-22,Farley), approve(86-07-18,MCR7439), audit(86-08-18,Fawcett), install(86-10-20,MR12.0-1189): Changed to initialize all possible ss_info.flags. END HISTORY COMMENTS */ dcl a_code fixed bin (35); dcl a_device_type fixed bin; dcl a_labelp ptr; dcl (a_num_pages, a_baseadd, a_nvtoce) fixed bin; dcl a_defaultsw bit (1) aligned; dcl interlace fixed bin; dcl loc_dev_type fixed bin; /* the index for things in fs_dev_types constants */ dcl bootload_sw bit (1) aligned; /* controls get/put */ dcl inbuf char (120); dcl 1 my_ss_info aligned like ss_info; dcl (asl_given, vtoc_constrained) bit (1); dcl (ioa_$nnl, ioa_) entry options (variable); dcl bce_query entry options (variable); dcl iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl iox_$user_input ptr ext static; dcl cu_$arg_list_ptr entry (ptr); dcl cu_$arg_count_rel entry (fixed bin, ptr, fixed bin (35)); dcl cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl bce_command_processor_ entry (char (*), entry (ptr, char (*), fixed bin (35)) returns (entry), ptr, fixed bin (35)); dcl conversion condition; dcl ec fixed bin (35); dcl num_pages fixed bin (18); dcl NORMAL_ASL float bin static init (5.0e0) options (constant); dcl RPV_ASL float bin static init (2.0e0) options (constant); dcl ( DEFAULT_RPV_HC_SIZE_char char (4) init ("2500"), DEFAULT_RPV_CONF_SIZE_char char (1) init ("4"), DEFAULT_RPV_LOG_SIZE_char char (3) init ("256"), DEFAULT_RPV_BOS_SIZE_char char (3) init ("270"), DEFAULT_RPV_FILE_SIZE_char char (3) init ("255"), DEFAULT_RPV_DUMP_SIZE_char char (4) init ("2000") ) internal static options (constant); dcl baseadd fixed bin (18); dcl rebuild_call bit (1); dcl nrec fixed bin; dcl (hibase, lobase) fixed bin; dcl asl float; dcl (put, put_nnl) entry options (variable) variable; dcl code fixed bin (35); dcl j fixed bin; dcl addr builtin; dcl ceil builtin; dcl char builtin; dcl convert builtin; dcl divide builtin; dcl hbound builtin; dcl length builtin; dcl ltrim builtin; dcl min builtin; dcl null builtin; dcl string builtin; rebuild_call = (interlace > 0); labelp = a_labelp; loc_dev_type = a_device_type; bootload_sw = "0"b; put = ioa_; put_nnl = ioa_$nnl; call startover_rq (null); if a_defaultsw then call end_rq (null); /* finish up, say nothing */ if rebuild_call then call list_rq (null); go to LISTEN; cold_rpv: entry (a_labelp, interlace, a_nvtoce, a_baseadd, a_num_pages, a_defaultsw, a_device_type); /* DIFFERENT FROM MAIN ENTRY ! */ labelp = a_labelp; put = ioa_; put_nnl = ioa_$nnl; bootload_sw = "1"b; loc_dev_type = a_device_type; call ioa_ ("^/Default RPV layout: (Respond ""end"" to use it.)^/"); call default_rq (null); call list_rq (null); LISTEN: ss_info_ptr = addr (my_ss_info); ss_info.request_table_ptr = null (); /* we find our own commands */ ss_info.abort_label = LISTEN_again; ss_info.name = "fill_vol_extents_"; ss_info.arg_list_ptr = null (); ss_info.info_ptr = null (); string (ss_info.flags) = ""b; ss_info.flags.forbid_semicolons = "1"b; do while ("1"b); /* exit via nonlocal goto */ LISTEN_again: call prompt_read ("request: ", inbuf); call bce_command_processor_ (inbuf, Find_Request, ss_info_ptr, code); if code ^= 0 & code ^= 100 then call put ("Syntax error in request. Please reenter."); end; startover_rq: procedure (Info_ptr); dcl Info_ptr ptr; label.nparts = 0; baseadd = -1; vtoc_constrained, asl_given = "0"b; interlace = 2; hibase, num_pages = label.vol_size; asl = NORMAL_ASL; lobase = 0; end startover_rq; /* These are RPV Cold Boot defaults! */ /* This should not be called from the non-bootload entrypoints */ default_rq: procedure (Info_ptr); dcl Info_ptr ptr; call startover_rq (null); asl = RPV_ASL; call part_side_door ("hc", "low", DEFAULT_RPV_HC_SIZE_char); call part_side_door ("conf", "low", DEFAULT_RPV_CONF_SIZE_char); if needs_alt_part (loc_dev_type) then call part_side_door ("alt", "high", ltrim ( char ( divide (last_alt_sect_num (loc_dev_type) - first_alt_sect_num (loc_dev_type) + 1, sect_per_cyl (loc_dev_type), 17) * rec_per_cyl (loc_dev_type)))); call part_side_door ("bos", "high", DEFAULT_RPV_BOS_SIZE_char); call part_side_door ("dump", "high", DEFAULT_RPV_DUMP_SIZE_char); call part_side_door ("log", "high", DEFAULT_RPV_LOG_SIZE_char); call part_side_door ("file", "high", DEFAULT_RPV_FILE_SIZE_char); call part_side_door ("bce", "high", ltrim (char (BCE_PART_LTH))); end default_rq; end_rq: procedure (Info_ptr); declare Info_ptr pointer; declare 1 found aligned, 2 hc bit (1) unaligned, 2 conf bit (1) unaligned, 2 bos bit (1) aligned, 2 bce bit (1) aligned, 2 file bit (1) aligned; string (found) = ""b; call eval_vtoc_size; /* Call place to order */ num_pages = num_pages - vtoc_size; if vtoc_size > label.vol_size then do; call put ("not enough room for vtoc. start over"); call startover_rq (null); go to LISTEN_again; end; if baseadd = -1 then baseadd = vtoc_size + lobase; else baseadd = vtoc_size; do j = 1 to label.nparts; if label.parts (j).part = "hc" then found.hc = "1"b; else if label.parts (j).part = "bos" then found.bos = "1"b; else if label.parts (j).part = "conf" then do; found.conf = "1"b; if label.parts (j).nrec ^= 4 then do; call put ("The size of the conf partition must be 4 records."); return; end; end; else if label.parts (j).part = "bce" then do; found.bce = "1"b; if label.parts (j).nrec < BCE_PART_LTH then do; call put ("The size of the bce partition must be at least ^d records.", BCE_PART_LTH); return; end; end; else if label.parts (j).part = "file" then do; found.file = "1"b; if label.parts (j).nrec < 30 | label.parts (j).nrec > 255 then do; call put ("The size of the file partition must be between 30 and 255 records."); return; end; end; if label.parts (j).frec < lobase then label.parts (j).frec = label.parts (j).frec + vtoc_size; if label.parts (j).frec + label.parts (j).nrec > label.vol_size then do; call put ("Not enough room for part ^a. start over", label.parts (j).part); call startover_rq (null); go to LISTEN_again; end; end; if bootload_sw then do; if ^found.hc | ^found.conf | ^found.bce | ^found.file then do; call put ("Hardcore (hc), config (conf), bootload file system (file), and"); call put ("bootload command environment (bce) partitions required on rpv."); return; end; end; label.vtoc_size = vtoc_size; a_baseadd = baseadd; a_num_pages = num_pages; a_nvtoce = (vtoc_size - VTOC_ORIGIN) * VTOCES_PER_RECORD (loc_dev_type); if ^bootload_sw then a_code = 0; go to RETURN; end end_rq; asl_rq: procedure (Info_ptr); declare Info_ptr pointer; declare arg_count fixed bin; declare arg_list_ptr pointer; declare ap ptr, al fixed bin (21), arg char (al) based (ap); arg_list_ptr = Info_ptr -> ss_info.arg_list_ptr; call cu_$arg_count_rel (arg_count, arg_list_ptr, (0)); if arg_count ^= 1 then do; call put ("Usage: asl FLOAT_AVG"); return; end; call cu_$arg_ptr_rel (1, ap, al, (0), arg_list_ptr); on conversion go to badavg; asl = convert (asl, arg); revert conversion; if asl < 0e0 then do; /* could be less than 1 */ badavg: call put ("Bad average ^a", arg); return; end; if vtoc_constrained then call put ("Using segment length constraint instead of VTOC size."); vtoc_constrained = "0"b; asl_given = "1"b; end asl_rq; lace_rq: procedure (Info_ptr); declare Info_ptr pointer; declare arg_count fixed bin, arg_list_ptr pointer, ap ptr, al fixed bin (21), arg char (al) based (ap); arg_list_ptr = Info_ptr -> ss_info.arg_list_ptr; call cu_$arg_count_rel (arg_count, arg_list_ptr, (0)); if arg_count ^= 1 then do; call put ("Usage: lace LACE_COUNT"); return; end; call cu_$arg_ptr_rel (1, ap, al, (0), arg_list_ptr); j = cv_dec_check_ (arg, ec); if ec ^= 0 | j < 1 then do; call put ("Bad interlace: ^a", arg); return; end; interlace = j; end lace_rq; list_rq: procedure (Info_ptr); declare Info_ptr pointer; call eval_vtoc_size; /* Get right stuff */ call put ("Average seg length = ^.2f", asl); call put ("VTOC size = ^d pages, ^d vtoces.", vtoc_size, (vtoc_size - VTOC_ORIGIN) * VTOCES_PER_RECORD (loc_dev_type)); call put ("^d paging records.", num_pages - vtoc_size); call put ("Constrained by ^[VTOC size^;average seg length^].", vtoc_constrained); do j = 1 to label.nparts; call put ("part ^a ^[^1s^d.^;^d.^1s^] ^d.", label.parts (j).part, (label.parts (j).frec < lobase), label.parts (j).frec, label.parts (j).frec + vtoc_size, label.parts (j).nrec); end; end list_rq; quit_rq: procedure (Info_ptr); dcl Info_ptr ptr; dcl error_table_$action_not_performed fixed bin (35) ext static; a_code = error_table_$action_not_performed; go to RETURN; end quit_rq; part_side_door: procedure (Name, High_Low, Size) options (non_quick); declare arg_list_ptr ptr; declare (Name, High_Low, Size) char (*); declare 1 local_ss_info aligned like ss_info; call cu_$arg_list_ptr (arg_list_ptr); local_ss_info.arg_list_ptr = arg_list_ptr; call part_rq (addr (local_ss_info)); return; end part_side_door; part_rq: procedure (Info_ptr); declare Info_ptr pointer; declare arg_count fixed bin, arg_list_ptr ptr, al fixed bin (21), ap ptr, arg char (al) based (ap); arg_list_ptr = Info_ptr -> ss_info.arg_list_ptr; call cu_$arg_count_rel (arg_count, arg_list_ptr, (0)); if arg_count ^= 3 then do; call put ("usage: part name high/low nrec."); return; end; call cu_$arg_ptr_rel (1, ap, al, (0), arg_list_ptr); do j = 1 to label.nparts while (label.parts (j).part ^= arg); end; if j <= label.nparts then do; call put ("Cannot redefine part ^a (^d. for ^d.)^/Type ""startover"" if necessary.", arg, label.parts (j).frec, label.parts (j).nrec); return; end; if label.nparts >= hbound (label.parts, 1) then do; call put ("No more room in label for partitions"); return; end; label.parts (j).part = arg; call cu_$arg_ptr_rel (3, ap, al, (0), arg_list_ptr); /* NREC */ nrec = cv_dec_check_ (arg, ec); if ec ^= 0 | nrec < 1 then do; call put ("Bad nrec ^a.", arg); return; end; call cu_$arg_ptr_rel (2, ap, al, (0), arg_list_ptr); if arg = "low" then do; if lobase + nrec > label.vol_size then do; call put ("part ^a ^a ^d too big for volume", label.parts (j).part, arg, nrec); return; end; label.parts (j).frec = lobase; lobase = lobase + nrec; baseadd = -1; end; else if arg = "high" then do; if hibase - nrec < lobase + VTOC_ORIGIN then do; /* doesn't account for vtoc */ call put ("part ^a ^a ^d too big for volume", label.parts (j).part, arg, nrec); return; end; hibase = hibase - nrec; label.parts (j).frec = hibase; end; else do; call put ("^a neither high nor low", arg); return; end; num_pages = num_pages - nrec; label.parts (j).nrec = nrec; if j > label.nparts then label.nparts = j; end part_rq; vtoc_rq: procedure (Info_ptr); declare Info_ptr pointer; declare vtoc_entry bit (1) aligned; declare arg_count fixed bin, arg_list_ptr pointer, al fixed bin (21), ap pointer, arg char (al) based (ap); vtoc_entry = "1"b; go to COMMON; nvtoce_rq: entry (Info_ptr); vtoc_entry = "0"b; COMMON: arg_list_ptr = Info_ptr -> ss_info.arg_list_ptr; call cu_$arg_count_rel (arg_count, arg_list_ptr, (0)); if arg_count ^= 1 then do; call put ("Usage: ^[nvtoce N_VTOCEs^;vtoc N_VTOC_RECORDS^]", vtoc_entry); return; end; call cu_$arg_ptr_rel (1, ap, al, (0), arg_list_ptr); j = cv_dec_check_ (arg, ec); if ec ^= 0 | j < VTOC_ORIGIN + 1 then do; call put ("Bad vtoc size: ^a", arg); return; end; if ^vtoc_entry /* nvtoces */ then j = ceil (j / VTOCES_PER_RECORD (loc_dev_type)) + VTOC_ORIGIN; if (j - VTOC_ORIGIN) * VTOCES_PER_RECORD (loc_dev_type) > MAX_VTOCE_PER_PACK then do; if vtoc_entry then call put ("Input value too large, max vtoc size is ^d records.", (MAX_VTOCE_PER_PACK / VTOCES_PER_RECORD (loc_dev_type)) + VTOC_ORIGIN); else call put ("Input value to large, max nvtoce is ^d.", MAX_VTOCE_PER_PACK); return; end; if asl_given then do; asl_given = "0"b; call put ("Using VTOC size constraint instead of seg. length constraint."); end; vtoc_constrained = "1"b; vtoc_size = j; end vtoc_rq; help_rq: procedure (Info_ptr); dcl Info_ptr ptr; call put ("Requests are:^/^5xstartover, ^[default^;quit^], part, list, avg, vtoc, nvtoce, ^[lace, ^]or end.", bootload_sw, rebuild_call); end help_rq; Find_Request: procedure (Info_ptr, Command, Code) returns (entry); declare Command character (*); declare Code fixed bin (35); /* not used -- we nonlocal goto instead */ declare Info_ptr pointer; Code = 0; if Command = "part" then return (part_rq); else if Command = "startover" then return (startover_rq); else if Command = "list" | Command = "ls" then return (list_rq); else if Command = "avg" | Command = "asl" then return (asl_rq); else if Command = "vtoc" then return (vtoc_rq); else if Command = "nvtoce" then return (nvtoce_rq); else if rebuild_call & Command = "lace" then return (lace_rq); else if ^bootload_sw & Command = "quit" then return (quit_rq); else if bootload_sw & Command = "default" then return (default_rq); else if Command = "end" then return (end_rq); else if Command = "help" then return (help_rq); else do; call put ("Unknown request ""^a""", Command); return (help_rq); end; end Find_Request; eval_vtoc_size: proc; if vtoc_constrained then asl = (num_pages - vtoc_size) / ((vtoc_size - VTOC_ORIGIN) * VTOCES_PER_RECORD (loc_dev_type)); else do; vtoc_size = (num_pages + asl * VTOCES_PER_RECORD (loc_dev_type) * VTOC_ORIGIN) / (1 + asl * VTOCES_PER_RECORD (loc_dev_type)) + .5; /* I got A's in algebra */ vtoc_size = min (vtoc_size, (MAX_VTOCE_PER_PACK / VTOCES_PER_RECORD (loc_dev_type)) + VTOC_ORIGIN); end; end eval_vtoc_size; prompt_read: procedure (prompt, result); dcl prompt char (*); dcl result char (*); if bootload_sw then call prompt_read_bootload (prompt, result); else call prompt_read_iox (prompt, result); return; prompt_read_bootload: procedure (prompt, result); dcl prompt char (*); dcl result char (*); call bce_query (result, "^a ", prompt); /* sp cause ^a rtrims */ return; end prompt_read_bootload; prompt_read_iox: procedure (prompt, result); dcl prompt char (*); dcl result char (*); dcl code fixed bin (35); dcl n_read fixed bin (21); dcl error_table_$long_record fixed bin (35) ext static; REREAD: call ioa_$nnl ("^a", prompt); result = ""; call iox_$get_line (iox_$user_input, addr (result), length (result), n_read, code); if code = error_table_$long_record then do; call ioa_ ("Line too long. Please reenter."); go to REREAD; end; else if n_read = 0 then go to REREAD; return; end prompt_read_iox; end prompt_read; RETURN: return; /* format: off */ %page; %include bce_partition_layout; %page; %include bce_subsystem_info_; %page; %include disk_pack; %page; %include fs_dev_types; %page; %include fs_vol_label; end fill_vol_extents_;  get_defptr_.alm 11/11/89 1144.7rew 11/11/89 0804.0 77211 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** " " get_defptr_ " " Usage: " " call get_defptr_ (defp, segnamep, extnamep, definitionp, code) " " where " " defp is a pointer to definition section for segment whose defs are " to be searched " segnamep is a pointer to the segment name of segment " " extnamep is a pointer to the symbol being searched for " " definitionp returned pointing to the definition containing the matched name " " code returned error code. " " First written by Steve Webber. " Calling seq. changed 8/18/76, B. Greenberg " Further modified 8/24/76 by Noel I. Morris " Modified for defs hash table 12/6/76 by Noel I. Morris " Modified to get around hardware bug 095 10/13/77 by Richard A. Barnes " " " The following code searches in the external segment's " definition section for an offset designated by an external symbol. " It does this in one or two passes. For the new object format (new " format bit on), a pass is made over the definitions for the " designated segment name, and, if it is found, a search is made in its " definition block for the designated external symbol. If either of " segment name or the external symbol name is not found, then in a " second pass, a search is made of all external symbols in the " definition section for the designated external symbol. " This external symbol name mustt be unique. " " " The following register assignments are used: " " ab points to the extname or segname. " lp points to the current definition we are looking at. " bp points to the definitions header. " bb points to a definitions hash table. " lb is a temporary used for string copies and compares. " lp points to the definition. " " X0 holds count and first char of extname or segname. " X1 is loop counter. " X2 is used to save def ptr. " X3 has the length of the extname or segname. " X4 has the offset of the next definition. " X5 is definitions thread offset index. " X6 is 0 for new format defs, 2 for old. " X7 is used for internal calls. " " segdef get_defptr_ get_defptr_: eppbp ap|2,* bp -> definitions section eppbp bp|0,* .. eax6 0 turn off old format flag lxl0 bp|1 old or new format? tpl old_format TRA if old format canx0 =o200000,du first def an ignore def? tze no_hash if not, cannot have hash table ldx0 bp|1 get addr of symbol hash table tze no_hash if zero, no hash table " Look for symbol in hash table. eppbb bp|0,0 bb -> sym hash table eppab ap|6,* ab -> symbol name ptr tsx7 acc_setup get pointer and length tsx7 hash_search search for symbol tra no_sym if not found, return error eax2 0,6 was name unique? tze found if so, found definition " Look for segment name in hash table. lxl0 bb|0 get size of sym hash table eppbb bb|1,0 bb -> segment name hash table eppab ap|4,* ab -> segment name ptr tsx7 acc_setup get pointer and length tsx7 hash_search search for segment name tra dup_name if not found, ambiguous name " Look for definition matching segment name. lda bb|1,al head segname def pointer in AL eppbb bp|0,2 bb -> list of duplicate symbol defs ldq bb|0 get count of duplicates in Q qls 36-8 shift to position for RPT eax0 64,qu place in X0 with TZE bit ldq =o777777,du comparison mask in Q eax6 1 initialize index rptx 0,1 search list cmk bb|0,6 .. ttn dup_name if not found, give error ldx4 bb|-1,6 get def pointer in X4 epplp bp|0,4 lp -> definition tra found got it " " The following internal subroutine is called to search " a symbol definition or segment name definition hash table. " It is used as follows: " " eppbb hash_table_head " tsx7 hash_search " tra notfound " hash_search: ldq ab|0 first word of symbol in Q div bb|0 compute hash code in A lxl1 bb|0 X1 is loop counter hash_loop: ldx4 bb|1,al pick up hash table entry tze 0,7 if zero, name not found eax1 -1,1 count interations tmoz defs_loop error if too many ldx6 bp|0,4 look at definition forward pointer tze dup_hash if zero, we have duplicate names eax6 0 if unique name, clear X6 tra no_dup_hash and continue dup_hash: eax6 0,4 save offset of duplicate table ldx4 bp|1,4 use first duplicate name def no_dup_hash: epplp bp|0,4 lp -> definition ldq lp|2 get name ptr from definition epplb bp|0,qu lb -> name cmpx0 lb|0 quicky compare of first word tnz hash_next if not equal, try another cmpc (pr,rl),(pr,rl) now do full compare desc9a ab|0,x3 desc9a lb|0,x3 tze 1,7 if equal, success hash_next: ada 1,dl bump hash index cmpa bb|0 check for end of table tmi hash_loop if not, continue search lda 0,dl go back to top of table tra hash_loop .. " " Look for first class 3 def. old_format: eax6 2 old format, set index no_hash: eax4 0 start at beginning of defs eax5 0 follow thread at lp|0 tsx7 searchd look for first class 3 def tra pass_2 if none, do second pass tra *+1 wrest control from subroutine tnz nextd if not class 3, keep looking " Now look for segment name. eppab ap|4,* ab -> segment name pointer tsx7 acc_setup get pointer and length eax5 1 follow thread at lp|1 tsx7 searchd3 follow thread of class 3 defs tra pass_2 at end of thread, do second pass tnz pass_2 if non class 3 encountered, do second pass " Segment name found. Search for symbol. eppab ap|6,* ab -> external symbol pointer tsx7 acc_setup make ab -> external name lxl4 lp|2 get pointer to defs for this seg eax5 0 follow thread at lp|0 tsx7 searchd search them tra pass_2 if not found, do second pass tze pass_2 if another class 3 found, do second pass tra found gotcha! " Do second pass over definitions. pass_2: eppab ap|6,* ab -> external symbol pointer tsx7 acc_setup make ap -> external name eax4 0 start at beginning of defs eax5 0 follow thread at lp|0 tsx7 searchd and search all of them tra no_sym to the end of the thread tze nextd ignore class 3 defs eax2 0,4 save def ptr in X2 tsx7 nextd continue search to check for dup tra unique success, if never found again tze nextd ignore class 3 defs tra dup_name if found, we have a name conflict unique: epplp bp|0,2 lp -> unique definition tra found definition found " " The following internal subroutine is called to follow a definitions " thread. It is used as follows: " " eppab name pointer to segname or extname " lxl3 length length of segname or extname " eax4 defoffset offset from base of defs to start search " tsx7 searchd " tra endofthread return here at end of thread " ... execute this if class 3 def " ... name found, normal return " searchd: eax1 8192 initialize infinite loop counter tra nextd1 enter loop nextd: ldx4 lp|0,5 step to next def eax1 -1,1 check for infinite loop tmoz defs_loop .. nextd1: epplp bp|0,4 lp -> next def szn lp|0 at end of thread? tze 0,7 take return if so lda lp|1 look at class cana =o200000,dl ignore bit on? tnz nextd if so, try next def ana =o7,dl mask the class cmpa 3,dl class 3? xec 1,7 take appropriate action searchd3: even "GET AROUND HARDWARE BUG 095 xed point_to_name,6 make lb point to name cmpx0 lb|0 quicky compare first tnz nextd .. cmpc (pr,rl),(pr,rl),fill(040) compare names desc9a ab|0,x3 desc9a lb|0,x3 tnz nextd not found, keep looking tra 2,7 name found, return even point_to_name: ldq lp|2 new format, use pointer epplb bp|0,qu epplb lp|2 old format, name follows def nop 0,du " acc_setup: eppab ab|0,* ab -> acc string lda ab|0 first word in A eax0 0,au count and first char retained in X0 arl 27 extract character count eax3 1,al in X3 tra 0,7 return to caller found: sprilp ap|8,* return def pointer stz ap|10,* clear error code short_return no_sym: getlp lda error_table_$no_ext_sym tra error dup_name: getlp lda error_table_$dup_ent_name tra error defs_loop:getlp lda error_table_$defs_loop error: sta ap|10,* return error code epplp =its(-1,1),* make lp null sprilp ap|8,* return null pointer short_return end  get_equal_name_.pl1 11/11/89 1144.7r w 11/11/89 0804.1 367038 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* N__a_m_e: get_equal_name_ */ /* */ /* This subroutine implements the Multics Storage System Equals Convention. */ /* A target name is constructed by combining components and subcomponents from an */ /* entry name and an equal name which are supplied as arguments. The construction */ /* follows the rules given under "Equal Names" in Section 3 of the MPM Reference Guide. */ /* */ /* U__s_a_g_e */ /* */ /* dcl get_equal_name_ entry (char(*), char(*), char(32), fixed bin(35)); */ /* */ /* call get_equal_name_ (entry, equal, target, code); */ /* */ /* 1) entry is the entry name. (In) */ /* */ /* 2) equal is the equal name. (In) */ /* */ /* 3) target is the target name which is constructed. (Out) */ /* */ /* 4) code is a status code, which may be one of the following. (Out) */ /* */ /* 0 the target name was constructed without error. */ /* */ /* error_table_$bad_equal_name */ /* the equal name has a bad format. */ /* */ /* error_table_$badequal */ /* there was no letter or component in the entry name which corresponds */ /* to a % or = in the equal name. A null string will be used for the */ /* missing letter or component in the target name which is returned. */ /* */ /* error_table_$longeql */ /* the target name to be constructed is longer than 32 characters. */ /* Only the first 32 characters are returned. */ /* */ /* S__t_a_t_u_s */ /* */ /* 0) Created: July, 1973 by G. C. Dixon */ /* a) This program replaces equal_, which is now obsolete. */ /* 1) Modified: June 15, 1979 by G. Palter */ /* a) Added the triple equal component. */ /* 2) Modified: 3 April 1981 by G. Palter */ /* a) Added the component entrypoint for the archive component equal name */ /* convention */ /* b) Added the check_equal_name_ entrypoint which validates the syntax and */ /* of a supplied equal name */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* A__l_g_o_r_i_t_h_m */ /* */ /* The basic algorithm used to construct the target name is: */ /* */ /* 1) Parse the equal name into components and subcomponents. */ /* a) each name component is classified into one of the following types: */ /* _t_y_p_e _f_o_r_m_a_t _d_e_s_c_r_i_p_t_i_o_n */ /* 13 === a triple equal sign component */ /* 14 == a double equal sign component */ /* 15 OO a component of one or more other characters */ /* (characters besides "=", "%", or ".") */ /* 16 O=% a component containing %'s or ='s and other chars */ /* 17 = a single equal sign component */ /* 18 BAD a bad equal name component format. */ /* b) each component is, in turn, divided into one or more subcomponents of the */ /* following types: */ /* _t_y_p_e _f_o_r_m_a_t _d_e_s_c_r_i_p_t_i_o_n */ /* 1 O's a string of one or more consecutive other chars. */ /* 2 %'s a string of one or more consecutive %'s. */ /* 3 ='s a string of one, two, or three consecutive ='s. */ /* Thus, component types === (13), == (14), OO (15), and = (17) are each composed */ /* of a single subcomponent, and component type O=% (16) is composed of two */ /* or more components. */ /* */ /* 2) Parse the entry name into components. */ /* */ /* 3) Construct the target name from the parsed equal and entry names. */ /* */ /* The hardest part of this process is the parsing of the equal name into components */ /* and subcomponents, while at the same time checking for a bad equal name. The */ /* current restraints on the format of equal names are: */ /* */ /* 1) The equal name is an entry name composed of 32 or fewer ASCII characters */ /* or spaces, excluding ">" and "<". That is, */ /* 0 < length(equal) <= 32 */ /* E_i <= PAD */ /* E_i ^= ">" */ /* E_i ^= "<" */ /* where E_i are the characters of the equal name. */ /* */ /* 2) The equal name is composed of from one to sixteen components, none of which may */ /* be null. That is, the equal name may not begin or end with a period ("."), and */ /* may not contain two or more consecutive periods. */ /* */ /* 3) Each component of an equal name may contain one or more %'s, each of which */ /* represents the corresponding letter in the corresponding component of the entry */ /* name. */ /* */ /* 4) Each equal name component may contain one =, which represents the corresponding */ /* component of the entry name. An equal component which contains an = may not */ /* contain %'s. */ /* */ /* 5) An equal name may contain, at most, one == (double equal sign) component in */ /* any component position which represents all components of the entry name */ /* which are not represented by other components of the equal name. */ /* */ /* 6) An equal name may contain one or more === (triple equal sign) components in any */ /* component position which represents the original name. If === is used, no */ /* == component or component containing %'s or ='s may be used. */ /* */ /* */ /* */ /* Each component of the equal name is parsed by a finite state machine, the diagram */ /* of which is shown below. The process of parsing each component begins in state _s_t_a_r_t */ /* and it continues through the machine, according to the characters of the equal name */ /* component ("=", "%", ".", or another character) until a period ends the component, or */ /* until all of the characters of the equal name have been exhausted. The parsing */ /* process identifies bad equal names (terminal state B_A_D_), and it also classifies each */ /* valid component as being one of the component types mentioned above. The type is */ /* defined to be the state value of the finite state machine when the component has been */ /* parsed. During the parsing, information about the location and length of each */ /* component and subcomponent is gathered for later use during the construction of the */ /* target name. */ /* _________ | | ------------------| start |-------------- | %|________0_|= | | .| |O | | | | | | V | | | 18(BAD) | | | | | | _______V__ | | | | | | ------------| O |-------- | | | %|________1_|= | | | | .| |O | | | | | | | | 16(O%=) 18(BAD) | | V | | | A A | | 15(OO) | | | | | | | | | | .__|_______|=_ % _V______V__ _______V__ O | | --->| |-------->| | %| |---- | | | | %OO | ------>| % |<--------| OO | | | | ----|________7_| | -----|________4_| |________5_|<--- | | O A | | O .| %| |= .| |= | | | | | | | | | | | | | | | V | V V | | | | | | 16(O%=) | 18(BAD) 15(OO) | | | | | | | | | | ___O__|____ % | | ____V_____ % _______V__ | | | |--- | | |---- | | | | | %O |<---- | %% | | | O= |<------- | |________3_|<--------|________8_|<--- |________9_| | .| |= O .| |= .| |O | | | | | | | | V V V V V | | 16(O%=) 18(BAD) 16(O%=) 18(BAD) 16(O%=) | | | | _______V__ ___V______ %=| | O| |% 18(BAD)<---| =O |<--------| = |--->18(BAD) |________2_| |_______1_0_| .| |O .| |= | | | | V | V | 16(O%=) | 17(=) | -------| | | | ___V______ _______V___ O _______V___ | | |O%= %=| |---- | |O% | | == |--->18(BAD) 18(BAD)<---| =OO | | | == |--->18(BAD) | |______1_2__| |________6_|<--- |_______1_1_| | .| .| =| .| | | | | | | V V | V | 13(===) 16(O%=) | 14(==) | | --------------------------------------------------------------- */ /* The finite state machine is defined by the variable, nstate, in the program below. */ get_equal_name_: procedure (Aentry, Aequal, Atarget, code); dcl Aentry char(*), /* the entry name. (In) */ Aequal char(*), /* the equal name. (In) */ Atarget char(32), /* the target name. (Out) */ code fixed bin(35); /* the status code returned.(Out) */ dcl P_entryname char(*) parameter, /* archive/entry name. (In) */ P_component char(*) parameter, /* component name. (In) */ P_equal_entryname char(*) parameter, /* archive/entry equal name. (In) */ P_equal_component char(*) parameter, /* component equal name. (In) */ P_target_entryname char(32) parameter, /* target archive/entry name. (Out) */ P_target_component char(32) parameter; /* target component name. (Out) */ dcl P_equalname char(*) parameter; /* equal name to be validated. (In) */ dcl 1 Cen (33) aligned automatic, /* array elements identify entry name components. */ 2 Ien fixed bin, /* index of component into entry name. */ 2 Len fixed bin, /* length of component. */ 1 Ceq (17) aligned automatic, /* array elements identify equal name components. */ 2 Ieq fixed bin, /* index of component into equal name. */ 2 Leq fixed bin, /* length of component. */ 2 Teq fixed bin, /* type of component: */ /* 13 = === (triple equal sign component) */ /* 14 = == (double equal sign component) */ /* 15 = O or OO */ /* 16 = O=, =O, =OO, %, %%, %O, or %OO */ /* 17 = = (single equal sign component) */ /* 18 = bad equal name format */ 2 SCeq fixed bin, /* index into Csub of 1st subcomponent of this */ /* component. */ 1 Csub (32) aligned, /* table of subcomoponents of the equal name. */ 2 Isub fixed bin, /* index into component of start of subcomponent. */ 2 Lsub fixed bin, /* length of subcomponent. */ 2 Tsub fixed bin, /* type of subcomponent: */ /* 1 = O's (other chars besides =, %, or .) */ /* 2 = %'s */ /* 3 = = */ Lentry fixed bin, /* real length of the entry name. */ Lequal fixed bin, /* real length of the equal name. */ Nen fixed bin, /* number of components in the entry name. */ Neq fixed bin, /* number of components in the equal name. */ Nequalequal fixed bin, /* number of any double equal sign component. */ Nsub fixed bin, /* number of subcomponents in the equal name. */ archive_equal_code fixed bin(35), /* status code for archive name's processing. */ char char(1) aligned, /* a character temp. */ double_equal bit(1) aligned, /* on if == component has already been parsed. */ triple_equal bit(1) aligned, /* on if one or more === components found. */ other_equal bit(1) aligned, /* on if components with %'s or ='s found. */ check_entry bit(1) aligned, /* on if check_equal_name_ called. */ original_archive bit(1) aligned, /* on if original name has archive & component. */ target_archive bit(1) aligned, /* on if target will have archive & component. */ entry char(32) aligned, /* aligned copy of entry name. */ equal char(32) aligned, /* aligned copy of equal name. */ entryname char(32), /* copy of input archive name w/o ".archive". */ equal_entryname char(32), /* copy of archive equal name w/o ".archive". */ i fixed bin, /* a do-group index. */ j fixed bin, /* a do-group index. */ state fixed bin, /* number of finite state machine's current state.*/ target char(34) varying aligned; /* target name being constructed. Its 1st char */ /* is always a "." which is ignored. After */ /* construction, if its length is greater than */ /* 33 (32 + 1st char), then it is too long. */ dcl 1 Oentry aligned based (addr (entry)), 2 char (33) char(1) unal, /* overlay for entry name. */ 1 Oequal aligned based (addr (equal)), 2 char (33) char(1) unal; /* overlay for equal name. */ dcl (addr, length, rtrim, substr) builtin; dcl PAD char(1) aligned static options (constant) initial (""), /* An ASCII PAD character \177. */ Tbad fixed binary static options (constant) initial (18), /* type code used for bad star name. */ Tequal fixed binary static options (constant) initial (17), /* type code used for single equal name component */ Totherother fixed binary static options (constant) initial (15), /* type code used for simple component. */ Tequalequal fixed binary static options (constant) initial (14), /* type code used for double equal name component.*/ Tequalequalequal fixed binary static options (constant) initial (13), /* type code used for triple equal name component.*/ (error_table_$bad_equal_name, error_table_$badequal, error_table_$entlong, error_table_$longeql, error_table_$no_archive_for_equal) fixed binary (35) external, nstate (0:12, 4) fixed binary static options (constant) initial ( /* */ /* TABLE OF NEXT STATES */ /* */ /* Current E q u a l N a m e C h a r a c t e r */ /* _S__t_a_t_e_ "_._"_ "_=_"_ "_%_"_ O__t_h_e_r */ /* */ /* 0 */ 18, 10, 4, 1, /* 1 */ 15, 9, 4, 5, /* 2 */ 16, 18, 18, 6, /* 3 */ 16, 18, 4, 7, /* 4 */ 16, 18, 8, 3, /* 5 */ 15, 9, 4, 5, /* 6 */ 16, 18, 18, 6, /* 7 */ 16, 18, 4, 7, /* 8 */ 16, 18, 8, 3, /* 9 */ 16, 18, 18, 2, /* 10 */ 17, 11, 18, 2, /* 11 */ 14, 12, 18, 18, /* 12 */ 13, 18, 18, 18); /* */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* 1) compute and validate real length of equal name. */ /* 2) parse equal name into components and subcomponents. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ check_entry = "0"b; Lequal = length (rtrim (Aequal)); if Lequal > 32 then /* an equal name longer than 32 chars is bad. */ go to bad_equal_name; if Lequal = 0 then /* a null equal name is bad. */ go to bad_equal_name; equal = Aequal; /* copy equal name to aligned temp for efficiency.*/ call parse_equal_name; /* parse it into components and subcomponents. */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* 1) compute real length of entry name, making sure its not too long. */ /* 2) if equal name was "===", "==", "==.=", or "=.==" then look no further. */ /* Target is a copy of the entry name. */ /* 3) else finish computing length of entry name. */ /* 4) parse entry name into components. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ Lentry = length (rtrim (Aentry)); if Lentry > 32 then /* ignore any chars beyond the 32nd. */ Lentry = 32; if Neq = 1 then if (Teq(1) = Tequalequalequal) | (Teq(1) = Tequalequal) then go to copy; /* equal = "===" or "==" */ else; else if Neq = 2 then if Teq(1) = Tequalequal then if Teq(2) = Tequal then go to copy; /* equal = "==.=" */ else; else if Teq(1) = Tequal then if Teq(2) = Tequalequal then go to copy; /* equal = "=.==" */ entry = Aentry; /* copy entry name to aligned temp for efficiency.*/ Nen = 1; /* parse entry name into components. */ Ien(1) = 1; Len(1) = 0; do i = 1 to Lentry; if Oentry.char(i) = "." then do; Nen = Nen + 1; Ien(Nen) = i + 1; Len(Nen) = 0; end; else Len(Nen) = Len(Nen) + 1; end; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Build target name from entry name and equal name by: */ /* 1) constructing target components corresponding to the equal name components */ /* appearing before any double equal sign component. */ /* 2) constructing target components corresponding to the double equal sign. */ /* 3) constructing target components corresponding to the equal name components */ /* appearing after any double equal sign component. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ target = ""; /* initialize the target. So far, it has 0 length.*/ code = 0; /* initialize return code, so that copy programs */ /* can fill in error code if they find one. */ if double_equal then do; /* if a double equal sign component was found, */ do i = 1 to Nequalequal - 1; /* first process equal components up to ==. */ target = target || "."; /* append "." to target ("." preceding 1st */ /* component will be ignored when copying target */ /* into Atarget, below). */ call copy_ (i, i); end; do i = Nequalequal to Nen - (Neq - Nequalequal); target = target || "."; /* then process components of entry name which */ call copy_ (Nequalequal, i); /* correspond to the ==. */ end; Nequalequal = i - Nequalequal - 1; do i = i to Nen; /* finally, process remaining components of */ target = target || "."; /* the equal name. */ call copy_ (i - Nequalequal, i); end; do i = i + 1 to Neq; /* if there were no components of entry name */ target = target || "."; /* which correspond to the == component, then */ call copy_ (i, i); /* copy any remaining components of equal name */ end; /* into the target name. */ end; else /* if no double equal sign component was found, */ do i = 1 to Neq; /* then just process each equal name component. */ target = target || "."; call copy_ (i, i); end; Atarget = substr (target, 2); /* copy target into parm, ignoring 1st "." */ if length (target) > 33 then /* if target (minus leading ".") was too long, */ go to long; /* then tell caller. */ return; copy: Atarget = Aentry; /* The target name is the same as the entry name. */ code = 0; return; bad_equal_name: code = error_table_$bad_equal_name; /* The equal name has a bad format. */ if ^check_entry then Atarget = ""; return; long: code = error_table_$longeql; /* the target would be too long. */ return; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ /* */ /* Implement the archive component pathname equal convention: See MPM Reference Guide for a description of this convention */ component: entry (P_entryname, P_component, P_equal_entryname, P_equal_component, P_target_entryname, P_target_component, code); P_target_entryname, P_target_component = ""; /* initialize output parameters */ code = 0; if (length (rtrim (P_entryname)) > 32) | (length (rtrim (P_component)) > 32) then do; /* original name is too long */ code = error_table_$entlong; return; end; if (length (rtrim (P_equal_entryname)) > 32) | (length (rtrim (P_equal_component)) > 32) then do; /* equal name is too long */ COMPONENT_BAD_EQUAL_NAMES: code = error_table_$bad_equal_name; return; end; if (P_equal_entryname = "") then /* this one can not be a null string */ go to COMPONENT_BAD_EQUAL_NAMES; /* Classify the original and target names with respect to archive components */ original_archive = (P_component ^= ""); /* original name uses archive components */ target_archive = (P_equal_component ^= ""); /* target name will use archive components */ if ^original_archive & ^target_archive then do; /* Case 1: original and target names are not archive component names */ call get_equal_name_ (P_entryname, P_equal_entryname, P_target_entryname, code); end; /* do the actual work */ else if original_archive & ^target_archive then do; /* Case 2: original is archive component name and target is not an archive component name: Apply the equal name specified for the target to the component name of the original */ call get_equal_name_ (P_component, P_equal_entryname, P_target_entryname, code); end; else if ^original_archive & target_archive then do; /* Case 3: original name is not an archive name and the target is an archive name: Apply the equal name provided for the target component to the original entryname; if an equal name is specified for the target archive, this use of the archive component pathname equal name convention is in error */ call check_equal_name_ (P_equal_entryname, archive_equal_code); if (archive_equal_code ^= 0) then /* bad syntax or equal convention is used */ if (archive_equal_code = 1) | (archive_equal_code = 2) then code = error_table_$no_archive_for_equal; else code = archive_equal_code; /* bad syntax in equal name */ else /* archive name doesn't use equal convention: OK so far */ if add_archive_suffix (P_equal_entryname, P_target_entryname) then call get_equal_name_ (P_entryname, P_equal_component, P_target_component, code); else code = error_table_$entlong; /* archive name too long for ".archive" suffix */ end; else do; /* Case 4: both original and target are archive component pathnames: Apply the equal name to each part; strip the ".archive" suffix from the archive names first, however */ call check_equal_name_ (P_equal_entryname, code); if (code > 2) then return; /* illegal equal name */ call check_equal_name_ (P_equal_component, code); if (code > 2) then return; entryname = strip_archive_suffix (P_entryname); equal_entryname = strip_archive_suffix (P_equal_entryname); call get_equal_name_ (entryname, equal_entryname, P_target_entryname, archive_equal_code); if (archive_equal_code = 0) | (archive_equal_code = error_table_$longeql) then call get_equal_name_ (P_component, P_equal_component, P_target_component, code); else do; /* bad syntax or something */ code = archive_equal_code; return; end; if add_archive_suffix (P_target_entryname, P_target_entryname) then; /* archive name is fine: use code from component */ else code = error_table_$longeql; /* couldn't form the archive name */ end; return; /* */ /* Validates the syntax of a supplied equal name and whether the name actually employs the equal convention */ check_equal_name_: entry (P_equalname, code); check_entry = "1"b; Lequal = length (rtrim (P_equalname)); if (Lequal = 0) | (Lequal > 32) then /* too long or short */ code = error_table_$bad_equal_name; equal = P_equalname; /* copy into area used for parsing */ call parse_equal_name (); /* parse it as best you can */ if (other_equal | double_equal | triple_equal) then /* some form of equal convention is used */ if (Neq = 1) then /* 1 component */ if (Teq(1) = Tequalequalequal) | (Teq(1) = Tequalequal) then code = 2; /* "===" or "==": target will be same as original */ else code = 1; /* target is some variant of original */ else if (Neq = 2) then /* 2 components */ if ((Teq(1) = Tequalequal) & (Teq(2) = Tequal)) | ((Teq(1) = Tequal) & (Teq(2) = Tequalequal)) then code = 2; /* "==.=" or "=.==": target will be same as original */ else code = 1; /* target is some variant of original */ else code = 1; /* > 2 components: target is some variant of original */ else code = 0; /* equal convention not used: target bears no resemblence to the original name */ return; /* */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* This internal procedure parses an equal name into classified components, */ /* and further parses each component into classified subcomponents. The */ /* equal name is assumed to reside in _e_q_u_a_l, and L__e_q_u_a_l is assumed to be */ /* its length. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ parse_equal_name: procedure; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* 1) Initialize variables used to parse the equal name. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ state = 0; /* start parsing with finite state machine in */ double_equal = "0"b; /* state zero. No == components encountered yet. */ Nequalequal = 0; triple_equal = "0"b; other_equal = "0"b; Neq = 1; /* Start parsing 1st equal name component. */ Ieq(1) = 1; /* 1st component starts with 1st char of equal */ Leq(1) = 0; /* name, and has zero length so far. */ SCeq(1) = 1; /* 1st subcomponent in 1st component */ Nsub = 0; /* No subcomponents have been found so far. */ /* is subcomponent number 1. */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Use the finite state machine to parse the equal name, 1 char at a time. */ /* 1) validate each character (char ^= ">", ^= "<", <= PAD) */ /* 2) transfer to next parsing state, according to character value (".", "=", "%", */ /* or another char. */ /* 3) each non-terminal state updates the information in the component and */ /* subcomponent array tables which record the location and length of each */ /* component, and the location (relative to the start of the component), and */ /* length of each subcomponent. Each terminal state updates the indices into */ /* these arrays, prior to starting to parse the next component and subcomponent.*/ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ do i = 1 to Lequal; char = Oequal.char(i); /* copy char for efficiency. */ if char = "." then state = nstate (state, 1); else if char = "=" then state = nstate (state, 2); else if char = "%" then state = nstate (state, 3); else if char = ">" then go to bad_equal_name; else if char = "<" then go to bad_equal_name; else if char > PAD then go to bad_equal_name; else state = nstate (state, 4); go to parse (state); parse(1): /* state = O; input char was another. */ parse(2): /* state = O=; input char was another. */ parse(3): /* state = %O; input char was another. */ Nsub = Nsub + 1; /* this char starts a new subcomponent. */ Isub(Nsub) = Leq(Neq) + 1; /* record index into component of start of */ Lsub(Nsub) = 1; /* subcomponent, and start with length of 1. */ Tsub(Nsub) = 1; /* record subcomponent type of 1 (O's). */ go to next_char; parse(4): /* state = %; input char was %. */ Nsub = Nsub + 1; /* this char starts a new subcomponent. */ Isub(Nsub) = Leq(Neq) + 1; /* record index into component of start of */ Lsub(Nsub) = 1; /* subcomponent, and start with length of 1. */ Tsub(Nsub) = 2; /* record subcomponent type of 2 (%'s). */ go to next_char; parse(5): /* state = OO; input char was another. */ parse(6): /* state = =OO; input char was another. */ parse(7): /* state = %OO; input char was another. */ parse(8): /* state = %%; input char was %. */ Lsub(Nsub) = Lsub(Nsub) + 1; /* add this char to length count of subcomponent. */ go to next_char; parse(9): /* state = O=; input char was = */ parse(10): /* state = =; input char was = */ Nsub = Nsub + 1; /* this char begins a new subcomponent. */ Isub(Nsub) = Leq(Neq) + 1; /* record index into component of start of */ Lsub(Nsub) = 1; /* subcomponent, and start with a length of 1. */ Tsub(Nsub) = 3; /* record subcomponent type of 3 (=). */ go to next_char; parse(11): /* state = ==; input char was = */ parse(12): /* state = ===; input char was = */ go to next_char; /* nothing req'd for == or === component. */ parse(13): /* terminal state = ===; input char was "." */ triple_equal = "1"b; go to finish_component; parse(14): /* terminal state = ==; input char was "." */ if double_equal then /* make sure there's only 1 double equal sign */ go to bad_equal_name; /* in the equal name. */ double_equal = "1"b; Nequalequal = Neq; go to finish_component; parse(15): /* terminal state = O or OO */ parse(16): /* terminal state = O=, =O, =OO, %, %%, %O or %OO */ parse(17): /* terminal state = = */ /* input char was "." */ if state ^= Totherother then /* have some use of equals convention. */ other_equal = "1"b; finish_component: Teq(Neq) = state; /* type of this component is state number. */ Neq = Neq + 1; /* prepare to process the next component. */ Ieq(Neq) = i+1; /* next component begins with next character. */ Leq(Neq) = -1; /* it has 0 length so far. */ /* (This value will be 0 when it is updated to */ /* reflect the "." we're processing now.) */ SCeq(Neq) = Nsub + 1; /* component begins with next subcomponent. */ state = 0; /* switch to the state used to begin parsing a */ go to next_char; /* component. */ parse(18): /* terminal state = bad equal name format. */ go to bad_equal_name; next_char: Leq(Neq) = Leq(Neq) + 1; /* update component's length to include current */ end; /* input char, then parse the next input char. */ state = nstate (state, 1); /* fudge contents of component array to make it */ if state = Tbad then /* look like equal name ended with a null */ go to bad_equal_name; /* component. Fill in state of last component */ else if state = Tequalequal then do; /* if state is valid (not bad equal name state, */ if double_equal then /* or 2nd double equal component). */ go to bad_equal_name; double_equal = "1"b; Nequalequal = Neq; end; else if state = Tequalequalequal then triple_equal = "1"b; else if state ^= Totherother then other_equal = "1"b; Teq(Neq) = state; SCeq(Neq + 1) = Nsub + 1; if triple_equal & (other_equal | double_equal) then go to bad_equal_name; /* may not have === with any other type. */ end parse_equal_name; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ /* */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* This internal procedure constructs a target name component from an entry name */ /* component and an equal name component. A different type of construction is */ /* used to each type of equal name component. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ copy_: procedure (Xeq, Xen); dcl Xeq fixed bin, /* number of equal name component. */ Xen fixed bin; /* number of entry name component. */ dcl Is fixed bin, /* index of subcomponent to be copied, relative to*/ /* start of component in entry name or equal name.*/ Leq fixed bin, /* length of equal name component. */ Len fixed bin, /* length of entry name component. */ Ls fixed bin, /* length of subcomponent. */ Peq ptr, /* ptr to equal name component. */ Pen ptr, /* ptr to entry name component. */ Ps ptr; /* ptr to subcomponent to be copied. */ dcl en char(Len) based (Pen), /* the entry name component. */ eq char(Leq) based (Peq), /* the equal name component. */ s char(Ls) based (Ps);/* subcomponent to be copied. */ Peq = addr (Oequal.char(Ieq(Xeq))); /* overlay the equal name component. */ Leq = Ceq(Xeq).Leq; if Xen <= Nen then do; /* if an entry component corresponding to the */ /* equal component exists, then */ Pen = addr (Oentry.char(Ien(Xen))); /* overlay the entry name component. */ Len = Cen(Xen).Len; end; else do; /* otherwise, use a null entry component. */ Pen = Peq; Len = 0; end; go to copy (Teq(Xeq)); /* perform construction, according to type of */ /* equal name component. */ copy(13): /* equal component is === */ target = target || substr (entry, 1, Lentry); /* add original name to target. */ return; copy(14): /* equal component is == */ target = target || en; /* add entry name component to target. */ return; copy(15): /* equal component is O or OO */ target = target || eq; /* add equal name component to the target. */ return; copy(16): /* equal component is %, %%, %O, %OO, O=, =O, */ /* or =OO */ if Xen > Nen then /* an entry name component corresponding to the */ code = error_table_$badequal; /* equal name component must exist. If it doesn't*/ /* report the error and assume a null entry name */ /* component exists. */ do j = SCeq(Xeq) to SCeq(Xeq+1) - 1; /* process each subcomponent of equal name, */ go to sub_comp(Tsub(j)); /* where each subcomponent type is a special case */ sub_comp(1): /* type 1: OO's */ Ps = addr (substr (eq, Isub(j))); /* overlay subcomponent of equal component. */ Ls = Lsub(j); target = target || s; /* add subcomponent to target. */ go to end_sub_loop; sub_comp(2): /* type 2: %%'s */ Is = Isub(j); /* get index and length of subcomponent. */ Ls = Lsub(j); if Is+Ls-1 > Len then do; /* if entry component isn't long enough to */ code = error_table_$badequal; /* have characters corresponding to the %'s of the*/ if Is > Len then do; /* equal component, then report error to caller, */ Is = 1; /* and adjust index and length of subcomponent to */ Ls = 0; /* use whatever corresponding characters are there*/ end; else Ls = Len - Is + 1; end; Ps = addr (substr (en, Is)); /* get ptr to entry name subcomponent. */ target = target || s; /* add subcomponent to target name. */ go to end_sub_loop; sub_comp(3): /* type 3: = */ target = target || en; /* add entry name to target. */ end_sub_loop: end; return; copy(17): /* equal component is = */ if Xen > Nen then /* if entry component corresponding to equal */ code = error_table_$badequal; /* component, tell caller and assume null entry */ /* component. */ else /* otherwise, add entry component to target. */ target = target || en; end copy_; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ /* */ /* Adds the suffix ".archive" to the supplied name if not already present and returns "1"b if the resulting name is OK */ add_archive_suffix: procedure (p_input_name, p_output_name) returns (bit (1) aligned); dcl (p_input_name, p_output_name) character (*) parameter; dcl temporary_name character (33) varying; temporary_name = rtrim (p_input_name); if (temporary_name = ".archive") then /* bad format */ go to COMPONENT_BAD_EQUAL_NAMES; else if (length (temporary_name) < length ("X.archive")) then temporary_name = temporary_name || ".archive"; else if (substr (temporary_name, (length (temporary_name) - length (".archive") + 1)) ^= ".archive") then temporary_name = temporary_name || ".archive"; p_output_name = temporary_name; if length (temporary_name) > 32 then return ("0"b); /* adding the suffix made the name too long */ else return ("1"b); end add_archive_suffix; /* */ /* Strip the ".archive" suffix from the name, if present */ strip_archive_suffix: procedure (p_input_name) returns (character (32)); dcl p_input_name character (*) parameter; dcl temporary_name character (32) varying; temporary_name = rtrim (p_input_name); if (temporary_name = ".archive") then go to COMPONENT_BAD_EQUAL_NAMES; else if (length (temporary_name) < length ("X.archive")) then return (temporary_name); else if (substr (temporary_name, (length (temporary_name) - length (".archive") + 1)) ^= ".archive") then return (temporary_name); else return (substr (temporary_name, 1, (length (temporary_name) - length (".archive")))); end strip_archive_suffix; end get_equal_name_;  get_temp_segments_.pl1 11/11/89 1144.7rew 11/11/89 0804.1 117261 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4,delnl,insnl,ifthenstmt,indnoniterend */ get_temp_segments_: proc (a_caller, a_ptrs, a_code); /* This program implements the temporary segment management features as used by the get_temp_segments_, release_temp_segments_, get_temp_segment_, release_temp_segment_, and list_temp_segments interfaces. All of these entries are included in this external procedure as they must share static. Last Modified: (date and reason): 11/21/75 by S. Webber (Initial coding) 11/15/76 by Larry Johnson to add arguments to list_temp_segments 08/29/77 by Melanie Weaver to add entry list_segnos 11/2/77 by Richard A. Barnes to add get_temp_segment_ & release_temp_segment_ 03/20/81 by S. Herbst to clean up lts interface and make gts turn on safety switches. 07/14/81 by S. Herbst to resinstate listing all when given no args. 03/14/83 by E. N. Kittlitz to reset max length to sys_info$max_seg_size. 04/14/83 by K. Loepere for bootload Multics 83-12-01 by BIM to only reset max_length if neccessary. 83-12-20 by C Spitzer. use copy of caller id for tests. */ /****^ HISTORY COMMENTS: 1) change(87-04-27,Farley), approve(87-07-06,MCR7717), audit(87-07-13,Lippard), install(87-07-17,MR12.1-1043): Changed get_new_segments to return a non-zero error code when unable to get a good pointer to one of the bootload_temp_N segments. END HISTORY COMMENTS */ /* Parameters */ dcl a_caller char (*); dcl a_ptrs (*) ptr; dcl a_code fixed bin (35); /* Automatic */ dcl max_length fixed bin (19); dcl new_block_ptr ptr; dcl caller char (32); dcl array_ptr ptr; dcl j fixed bin; dcl n_segs fixed bin; dcl new_blocks fixed bin; dcl i fixed bin; dcl n_found fixed bin; dcl old_blocks fixed bin; dcl code fixed bin (35); dcl ename char (20); dcl ename2 char (32); dcl segno (4) char (1) defined (ename2) pos (22); dcl segment_number fixed bin; dcl found_it bit (1); dcl arg_count fixed bin; dcl arg_list_ptr ptr; dcl arg_ptr ptr; dcl arg_len fixed bin; dcl bootload_sw bit (1) aligned; /* Based */ dcl ptrs (n_segs) ptr based (array_ptr); dcl arg char (arg_len) based (arg_ptr); dcl 1 octal_digits aligned based (addr (segment_number)), 2 filler bit (24) unal, 2 digit (4) bit (3) unal; dcl 1 new_block (new_blocks) aligned based (new_block_ptr) like block; dcl 1 block (n_blocks) aligned based (block_ptr), 2 caller char (32), 2 segptr ptr, 2 name char (25), 2 used bit (1); dcl area area based (areap); /* Static */ dcl block_ptr ptr static init (null); dcl areap ptr static init (null); dcl n_blocks fixed bin static init (0); /* Builtin */ dcl (addr, baseno, bin, character, dim, index, length, ltrim, max, null, substr) builtin; /* Entries */ dcl com_err_ entry options (variable); dcl hcs_$chname_seg entry (ptr, char (*), char (*), fixed bin (35)); dcl get_system_free_area_ entry returns (ptr); dcl hcs_$delentry_seg entry (ptr, fixed bin (35)); dcl unique_chars_ entry (bit (*)) returns (char (15)); dcl unique_bits_ entry returns (bit (70)); dcl hcs_$truncate_seg entry (ptr, fixed bin, fixed bin (35)); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl hcs_$set_safety_sw_seg entry (ptr, bit (1), fixed bin (35)); dcl hcs_$get_max_length_seg entry (ptr, fixed bin (19), fixed bin (35)); dcl hcs_$set_max_length_seg entry (ptr, fixed bin (19), fixed bin (35)); dcl ioa_ entry options (variable); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_list_ptr entry (ptr); dcl cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin, fixed bin (35), ptr); dcl slt_manager$get_seg_ptr entry (char (32) aligned) returns (ptr); /* External */ dcl error_table_$argerr fixed bin (35) ext; dcl error_table_$badopt fixed bin (35) ext; dcl error_table_$illegal_activation fixed bin (35) ext; dcl sys_info$max_seg_size fixed bin (18) ext static; dcl sys_info$service_system bit (1) aligned ext; /* */ /* Execution of get_temp_segments_ begins here */ n_segs = dim (a_ptrs, 1); /* get number of segments wanted */ array_ptr = addr (a_ptrs); /* get ptr to the array of ptrs */ gts_join: bootload_sw = ^sys_info$service_system; caller = a_caller; a_code = 0; n_found = 0; /* initialize indicating we've found no free entries */ if block_ptr = null then do; /* we haven't yet gotten any segments */ n_blocks = n_segs; /* so get the exact amount requested */ areap = get_system_free_area_ (); /* get pointer to standard area to use */ allocate block in (area) set (block_ptr); /* get the needed storage */ old_blocks = 0; /* needed by get_new_segments routine */ call get_new_segments; /* do the work in this subr */ return; end; do i = 1 to n_blocks while (n_found < n_segs); /* search for the necessary free segments */ if ^block (i).used then do; /* we found another free one */ block (i).used = "1"b; /* mark entry as being used */ block (i).caller = caller; /* save name of whose using it */ n_found = n_found + 1; ptrs (n_found) = block (i).segptr; end; end; if n_found < n_segs then do; /* there weren't enough free ones */ new_blocks = n_blocks + n_segs - n_found; /* get more storage, just large enough */ old_blocks = n_blocks; if areap = null then areap = get_system_free_area_ (); /* get pointer to area */ allocate new_block in (area) set (new_block_ptr); /* get the needed storage */ new_block_ptr -> block = block; /* copy the current structure */ free block in (area); n_blocks = new_blocks; block_ptr = new_block_ptr; call get_new_segments; /* get the needed segments */ end; return; get_new_segments: proc; dcl (i, j) fixed bin; do i = old_blocks + 1 to n_blocks; /* initialize the new entries */ block (i).used = "1"b; /* the caller will use these blocks */ block (i).caller = caller; /* ditto */ if bootload_sw then do; ename2 = "bootload_temp_" || ltrim (character (i)); block (i).segptr = slt_manager$get_seg_ptr ((ename2)); if block (i).segptr = null then do; code = error_table_$illegal_activation; call undo; return; end; end; else do; ename2 = unique_chars_ (unique_bits_ ()) || ".temp."; ename = substr (ename2, 1, length (ename)); call hcs_$make_seg ("", ename, "", 01110b, block (i).segptr, code); if code ^= 0 then do; call undo; return; end; segment_number = bin (baseno (block (i).segptr), 18); do j = 1 to 4; segno (j) = substr ("01234567", bin (digit (j), 3) + 1, 1); end; call hcs_$chname_seg (block (i).segptr, ename, ename2, code); if code ^= 0 then do; call undo; return; end; call hcs_$set_safety_sw_seg (block (i).segptr, "1"b, code); end; block (i).name = substr (ename2, 1, length (block (i).name)); n_found = n_found + 1; ptrs (n_found) = block (i).segptr; end; undo: proc; a_code = code; n_blocks = old_blocks; /* reset to the way things were */ if ^bootload_sw then do j = old_blocks + 1 to i - 1; /* clean up the segments we already got */ call hcs_$delentry_seg (block (j).segptr, code); end; end; end; /* */ get_temp_segment_: entry (a_caller, a_ptr, a_code); dcl a_ptr ptr parameter; n_segs = 1; /* only 1 segment is being processed */ array_ptr = addr (a_ptr); go to gts_join; /* */ release_temp_segments_: entry (a_caller, a_ptrs, a_code); n_segs = dim (a_ptrs, 1); /* get number of segments wanted */ array_ptr = addr (a_ptrs); /* get ptr to the array of ptrs */ rts_join: bootload_sw = ^sys_info$service_system; caller = a_caller; a_code = 0; do i = 1 to n_segs; /* release each segment passed in */ if ptrs (i) ^= null then do; found_it = "0"b; /* flag says we've not yet found this segment */ do j = 1 to n_blocks while (^found_it); /* search for segment in array */ if block (j).used then do; /* candidate, see if right one */ if ptrs (i) = block (j).segptr then do; /* we found the given segment */ if block (j).caller ^= caller then a_code = error_table_$argerr; else do; /* the right guy (as far as we care) */ if ^bootload_sw then do; call hcs_$truncate_seg (block (j).segptr, 0, code); /* truncate now */ if code ^= 0 then a_code = code; /* accumulate error */ call hcs_$get_max_length_seg (block (j).segptr, max_length, code); if code ^= 0 then a_code = code; if max_length ^= sys_info$max_seg_size then do; call hcs_$set_max_length_seg (block (j).segptr, (sys_info$max_seg_size), code); /* ensure no funny business */ if code ^= 0 then a_code = code; /* accumulate error */ end; end; block (j).used = "0"b; /* ditto */ block (j).caller = ""; ptrs (i) = null; found_it = "1"b; end; end; end; end; if ^found_it then a_code = error_table_$argerr; end; end; return; /* */ release_temp_segment_: entry (a_caller, a_ptr, a_code); n_segs = 1; /* only 1 segment is being processed */ array_ptr = addr (a_ptr); goto rts_join; /* */ list_temp_segments: entry; if n_blocks = 0 then do; /* nothing ever allocated */ call ioa_ ("No temporary segments."); RETURN: return; end; call cu_$arg_count (arg_count, code); if code ^= 0 then do; call com_err_ (code, "list_temp_segments"); return; end; call cu_$arg_list_ptr (arg_list_ptr); begin; /* to allocate storage */ dcl treq char (32); dcl req (max (1, arg_count)) char (32); dcl nreq fixed bin; /* number of names requested */ dcl all_sw bit (1); /* set if -all given */ dcl (i, j, cnt) fixed bin; dcl dup_sw bit (1); nreq = 0; all_sw = "0"b; do i = 1 to arg_count; /* get table of requests */ call cu_$arg_ptr_rel (i, arg_ptr, arg_len, code, arg_list_ptr); if index (arg, "-") = 1 then if arg = "-all" | arg = "-a" then all_sw = "1"b; else do; call com_err_ (error_table_$badopt, "list_temp_segments", "^a", arg); go to RETURN; end; else do; dup_sw = "0"b; /* be sure not given dup args */ treq = arg; do j = 1 to nreq; if req (j) = treq then dup_sw = "1"b; end; if ^dup_sw then do; /* new one */ nreq = nreq + 1; req (nreq) = treq; end; end; end; if all_sw then do; if nreq > 0 then do; call com_err_ (0, "list_temp_segments", "-all is inconsistent with name arguments."); go to RETURN; end; end; if nreq = 0 then do; /* if no special requests */ cnt = 0; do i = 1 to n_blocks; /* count free segs */ if ^block.used (i) then cnt = cnt + 1; end; call ioa_ ("^/^-^d Segment^[s^], ^d Free^/", n_blocks, (n_blocks ^= 1), cnt); end; else do; /* count segments that match requests */ cnt = 0; do i = 1 to n_blocks; if block.used (i) then do j = 1 to nreq; if block.caller (i) = req (j) then cnt = cnt + 1; end; end; call ioa_ ("^/^-^d Segment^[s^] used.^/", cnt, (cnt ^= 1)); end; do i = 1 to n_blocks; /* now print them */ if all_sw then go to print_it; else if block.used (i) then do; if nreq = 0 then go to print_it; else do j = 1 to nreq; if block.caller (i) = req (j) then go to print_it; end; end; go to next_block; print_it: call ioa_ ("^a ^[^a^;(free)^]", block.name (i), block.used (i), block.caller (i)); next_block: end; call ioa_ (""); end; return; /* */ list_segnos: entry (struc_ptr); dcl struc_ptr ptr; dcl 1 segno_struc aligned based (struc_ptr), 2 num_segs fixed bin, 2 segno (n_blocks) fixed bin; if (block_ptr = null) | (areap = null) then do; struc_ptr = null; return; end; allocate segno_struc in (area) set (struc_ptr); segno_struc.num_segs = n_blocks; do i = 1 to n_blocks; segno_struc.segno (i) = bin (baseno (block (i).segptr), 15); end; return; end get_temp_segments_;  hash_index_.alm 11/11/89 1144.7rew 11/11/89 0804.1 31941 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** " " Coded by who knows who who knows when " Modified March 1981 Benson I. Margulies for no stack. " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " hash_index_ " " Calling sequence is: " " index = hash_index_ (nameptr,length,bias,tablesize) " " nameptr is a pointer to the name to be hashed " length is the number of (significant) characters in the name, fixed (35) " bias is an integer used in the hash algorithm(may be anything), fixed (35) " tablesize is the size of the hash table of interest, fixed (35) " index is the returned hash index, fixed (35) " " All variables are fixed except the first which is pointer " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " name hash_index_ segdef hash_index_,hash_id set string,2 set length,4 set bias,6 set tablesize,8 set index,10 hash_index_: epp2 ap|string,* get pointer to pointer to string epp2 pr2|0,* get pointer to string szn ap|tablesize,* check for zero divide tze err trouble eaa 0 clear the a register ldq ap|length,* get length of string cmpq =32,dl is it an entry name? tnz compare no, go to compare qrs 2 yes, ignore trailing blanks strip: lda pr2|-1,ql get end word cmpa blanks all blanks? tnz add1 no, go to compare sbq =1,dl yes, backup 1 word tra strip loop back and try again compare: llr 70 divide by 4 and save remainder arl 16 shift remainder to upper a eax2 0,au divisible by 4? tze add1 yes go to compare lda pr2|0,ql no, make blanks out of last chars ana mask,2 ora bits,2 tra add2 add1: eaa 0 zero a reg-init sum add2: qls 0 set sign of q tze noadd no words to be added in adla pr2|-1,ql sblq 1,dl go to next word tpl add2 noadd: sta ap|index,* save temporarily ldq ap|bias,* get bias mpy =99991,dl multipy by large prime number adq ap|index,* add in sum of the words div ap|tablesize,* divide by hash table size als 0 set zero indicator from remainder (in a-reg) tpl *+2 must be positive answer neg sta ap|index,* return the remainder of the division .rt: short_return err: stz ap|index,* return zero as hash index if error tra .rt blanks: aci " " mask: oct 0,777000000000,777777000000,777777777000 bits: oct 0,000040040040,000000040040,000000000040 " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " hash_id " " Calling sequence is: " " index = hash_index_$hash_id (id, tablesize) " " id is the unique identifier (bit (36)) to be hashed " " This is an awful algorithm. If you are not using it now, " do not start. It is here only for compatability. " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " set uid,2 set tablesize,4 set index,6 hash_id: ldq ap|uid,* pick up id word mpy ap|uid,* multiply it by itself ana =o377777,dl leave 17 bits (force positive) lrl 18 div ap|tablesize,* divide by table size sta ap|index,* return the hash index short_return end  init_vol_header_.pl1 11/11/89 1144.7r w 11/11/89 0804.1 48510 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-01-16,Fawcett), approve(86-04-11,MCR7383), audit(86-05-13,LJAdams), install(86-07-17,MR12.0-1097): Add support for subvolumes, and 512_WORD_IO, 3380 and 3390. END HISTORY COMMENTS */ init_vol_header_: procedure (a_pvtx, a_dev_type, a_pagep, a_write_routine, a_errpart, a_nvtoces, a_baseadd, a_numpag, a_code); /* Routine to initialize VTOC, Vol Map, and rest of header, given a label. Commoned from init_empty_root and init_disk_pack_, 06/25/76, Bernard Greenberg. General map generator `a la fsout_vol added at this time too. Modified March 1982 by J. Bongiovanni for VTOC Map */ dcl (pvtx, a_pvtx) fixed bin; dcl (pagep, a_pagep) ptr; dcl (dev_type, a_dev_type) fixed bin; dcl (n_vtoces, a_nvtoces) fixed bin; dcl (baseadd, a_baseadd) fixed bin; dcl (num_pages, a_numpag) fixed bin; dcl a_errpart char (*), thing char (20); dcl null builtin; dcl (code, a_code) fixed bin (35); dcl (a_write_routine, write_disk) entry (fixed bin, fixed bin, ptr, fixed bin (35)) variable; dcl tablen fixed bin; dcl Srel fixed bin; dcl (i, j) fixed bin; dcl page bit (36*1024) based (pagep); dcl (vtoc_end, current, vtoc_size, last, recno, map_addr) fixed bin; dcl ALL_FREE bit (36) static options (constant) init ("011111111111111111111111111111111000"b); dcl (addr, addrel, divide, fixed, mod, rel, substr) builtin; %page; write_disk = a_write_routine; pvtx = a_pvtx; dev_type = a_dev_type; pagep = a_pagep; labelp = pagep; n_vtoces = a_nvtoces; baseadd = a_baseadd; num_pages = a_numpag; if n_vtoces > MAX_VTOCE_PER_PACK then do; a_code = 99; a_errpart = "vtoc too big"; return; end; /* Write the label to the disk */ label.volmap_version = 1; thing = "label"; call write_disk (pvtx, LABEL_ADDR, labelp, code); if code ^= 0 then go to ERR; /* Initialize the volume map */ page = "0"b; labelp = null; vol_mapp = pagep; /* New Pointer */ vol_map.base_add = baseadd; vol_map.n_rec = num_pages; vol_map.n_free_rec = num_pages; tablen = divide (num_pages + 31, 32, 17, 0); vol_map.bit_map_n_words = tablen; Srel = fixed (rel (addr (vol_map.bit_map)), 18) - fixed (rel (vol_mapp), 18); map_addr = VOLMAP_ADDR; do i = 1 to tablen; if mod (i, 1024) = 1025 - Srel then do; call write_disk (pvtx, map_addr, pagep, code); if code ^= 0 then go to ERR; map_addr = map_addr + 1; vol_mapp = addrel (vol_mapp, -1024); page = "0"b; end; vol_map.bit_map (i) = ALL_FREE; end; j = mod (num_pages, 32); if j ^= 0 then substr (vol_map.bit_map (tablen), j + 2) = "0"b; /* Truncate the tail */ do map_addr = map_addr to DUMPER_BIT_MAP_ADDR - 1 by 1; /* Clear out last buf, zeros to rest. */ call write_disk (pvtx, map_addr, pagep, code); if code ^= 0 then go to ERR; page = "0"b; end; vol_mapp = null; /* Initialize the VTOC header (for compatibility with pre-MR10) */ page = "0"b; vtoc_headerp = pagep; vtoc_size = VTOC_ORIGIN + divide (n_vtoces + VTOCES_PER_RECORD (dev_type) - 1, VTOCES_PER_RECORD (dev_type), 17, 0); vtoc_end = vtoc_size - 1; vtoc_header.version = 1; vtoc_header.n_vtoce = n_vtoces; vtoc_header.vtoc_last_recno = vtoc_end; vtoc_header.n_free_vtoce = n_vtoces; vtoc_header.first_free_vtocx = 0; thing = "vtoc hdr"; call write_disk (pvtx, DUMPER_BIT_MAP_ADDR, pagep, code); if code ^= 0 then goto ERR; page = "0"b; do recno = DUMPER_BIT_MAP_ADDR + 1 to VTOC_ORIGIN -1; call write_disk (pvtx, recno, pagep, code); if code ^= 0 then go to ERR; end; /* Initialize the VTOC Map */ page = ""b; vtoc_mapp = pagep; vtoc_map.n_vtoce = n_vtoces; vtoc_map.n_free_vtoce = n_vtoces; vtoc_map.vtoc_last_recno = vtoc_end; vtoc_map.bit_map_n_words = divide (n_vtoces + 31, 32, 17); do i = 0 to vtoc_map.bit_map_n_words - 1; vtoc_map.bit_map (i) = ALL_FREE; end; j = mod (n_vtoces, 32); if j ^= 0 then substr (vtoc_map.bit_map (vtoc_map.bit_map_n_words - 1), j + 2) = ""b; thing = "vtoc map"; call write_disk (pvtx, VTOC_MAP_ADDR, vtoc_mapp, code); if code ^= 0 then goto ERR; /* Initialize the VTOC array from record 8 to the last record assigned to the VTOC. */ /* The VTOCE's are all zero. */ thing = "vtoc"; current = 0; last = n_vtoces - 1; page = ""b; do recno = VTOC_ORIGIN to vtoc_end; call write_disk (pvtx, recno, pagep, code); if code ^= 0 then goto ERR; end; a_code = 0; return; ERR: a_errpart = thing; a_code = code; return; %page; %include disk_pack; %page; %include fs_vol_label; %page; %include vtoc_header; %page; %include vol_map; %page; %include vtoc_map; end;  match_star_name_.pl1 11/11/89 1144.7rew 11/11/89 0804.1 726822 /****^ ***************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright (C) 1982 by Massachusetts Institute of * * Technology and Honeywell Information Systems Inc. * * * ***************************************************** */ /*^ Match Star Name This module implements the Multics Star Convention, as described in the MPM Reference Guide, Honeywell publication AG91. It is a complete reimplementation of the Star Convention for MR12, and is redefined in an upward compatible manner to accept previously invalid input. The Star Convention is used to partition sets of names or named entities into two subsets: those that match, and those that don't. Either subset may be empty. For example, a directory may contain a set of files, and each file may have several entrynames. A starname can be used to select all the files which have at least one entryname which matches the starname. Further processing is generally done on the selected subset. This procedure implements the comparison of a single starname to an entryname. Two results are interesting: either they match, or they do not. It is left to the caller to iterate over sets of entrynames and starnames as appropriate. The starname may be invalid, in which case a match is impossible, although a mismatch can in some cases be detected before the syntax error is found. The Star Convention is defined as follows: 1. Names, whether entrynames or starnames, are PL/I character strings. Trailing ASCII space characters are not significant for purposes of comparison, so that names stored in variables of different length can be considered equal. The end of the name precedes any such spaces. 2. Names are divided into components. Any name has at least one component, which is bounded by the beginning and end of the name. If Dots (periods) are present, they delimit the name into multiple components. If two component boundaries are consecutive, they define a null component between them. 3. Starnames are comparison templates which contain literal characters, component delimiters, and wildcard characters. Components are delimited by Dots. Star (asterisk) and Query (question mark) characters can be grouped to form four different wildcard constructs. Any character other than Dot, Star, Query or a trailing space matches itself only. 4. A starname which contains no wildcard characters can be compared to an entryname using standard PL/I rules for character string equality. 5. Each Query character stands alone, so a string of three Query characters is three occurences of the Query construct. Each Query matches exactly one character in the entryname, but may not match a Dot, so that it can't cross a component boundary. 6. Each isolated Star character can match any number of characters within a component, including none at all. A single Star may not match a Dot in the entryname, so that it can't cross component boundaries. 7. A Doublestar consists of two consecutive Star characters. A run of more than two consecutive Star characters is illegal. A Doublestar has one of two meanings, depending on its context. 8. A Doublestar component is a Doublestar which has a component boundary on both sides. Any other Doublestar is said to be floating. 9. A floating Doublestar matches any number of characters in the entryname, including none. It can even match a Dot, so that it can cross component boundaries. 10. A Doublestar component matches any number of entire components in the entryname, including none. It can't match partial components. Dots in the starname act like literal characters in all other situations, but when they delimit a Doublestar component they need not correspond to a Dot in the entryname. When a Doublestar component matches zero components in the entryname, it nevertheless must occur at a component boundary in the entryname. Examples: "foobar" and "foo?ar" each match "foobar", but do not match "fobar", "foo.ar" or "fooobar". "foo*" matches "foo" and "foobar" but does not match "foo.bar". "**bar" matches "foobar" and "foo.bar" but does not match "bar.foo". ".**." matches ".", ".." and ".foo." but does not match "" or "foo.". "foo***" and "*.***" are invalid. Implementation The old match_star_name_ completely parsed the starname into components and subcomponents (delimited by a Star in the component) before starting comparison. That implementation imposed a number of restrictions which have been removed. Starnames and entrynames were limited to 32 characters in length; null in starnames components were illegal; only one Star was permitted in each component, except for a single Doublestar component. Permitting the starname and entryname to each be up to a segment in length, permitting multiple Stars per component and permitting multiple Doublestars per starname required a complete rethinking of the matching strategy. Since the description of a parsed starname can easily take up more space than the starname does, parsing the whole name in advance is no longer feasible. Instead, the parser obtains a certain amount of information, and then the matching routines are called. If they succeed, more parse and match iterations are done until either a mismatch is found, the star name is exhausted, or an invalid construct is found. The parser is designed to recover as much information as can be easily represented. What is returns is an encoding which is described by the following diagram: [Star construct][Query count][literal string][boundary] First, combinations of Stars and Dots are parsed, to develop the Star construct. This phase ends if a character other than Dot or Star is found, the starname is exhausted, if two consecutive dots are found, or if more than two consecutive Star components are found. If the terminating character is a Query, a count of consecutive Queries is made in phase 2. Stars embeded in Queries in most cases can be either ignored or added to the Star construct, because "?*" is equivalent to "*?". When a character which is neither a Query not a Star is encountered, we begin phase 3, the collection of a literal character string. The literal string ends when a Query or a Star is found, or when the starname is exhausted. If the string is terminated by a Star which is immediately preceded by a Dot, that final Dot is part of the Star construct and not part of the literal string. The parser returns this information in an integer which encodes the Star construct and several binary choices. Were there any Queries? Any literal string? Is the starname exhausted? Did the literal string end on a component boundary? In addition, a Query count is returned. If there was a literal string, its position and length are returned. The encoded value is used to select a comparison routine. If the comparison succeeds, and the star name is not exhausted, then the parser will be reinvoked to continue parsing from where it left off. The parser position and state are remembered against this eventuality. For example, if a Star is found following a literal string, then parsing resumes with the first character beyond that Star; the Star is already remembered in the new parser state that will be used if the literal compares sucessfully. When matching following a Star or a Doublestar, a mismatch might not be detected until the parser had been reinvoked, perhaps several times. For example, the starname "*x?y" would first parse the first two characters, then match the first two, next parse the last two characters, and finally match the last two. If the second comparison step failed, it might be possible for the first comparison step to match at different place where the second comparison could succeed. In this case, a failing comparison invokes a backup routine which tries to find an alternative match and restores the parser to a former position and state. Because Stars match within a component, and Doublestars match the whole name, there are two possible retry levels. If Star retry fails, Doublestar retry can attempt another component. Extensive optimizations have been performed to permit the PL/I compiler to generate the most efficient possible code. The most streamlined operation is matching, which may be used to iterate over large locked directories in ring zero. The parser recognizes starnames which match all possible names in a single call, so it isn't even necessary to look at the entryname in that case. The parser is also used for analyzing names, which is less time critical. To improve space efficiency without hurting performance, some tables have been paired so that each word contains one entry from each table, one in the high halfword and the other in the low halfword. Check Star Name There are 4 classes of star names: 1) names which contain no wildcard characters, 2) names which match all possible names, 3) invalid names, and 4) names which contain wildcard characters but don't match all possible names. If there are no wildcard characters, then PL/I comparison can be used. Indeed, the name can be looked up in a hash table, or by binary search. Detecting and specially processing such names can greatly improve performance. If a starname matches all possible names, then there is no need to actually compare them; all the entities are selected for processing. Names which contain three or more consecutive Stars are invalid; such names select nothing. Only the remaining class of names *requires* the use of match_star_name_. Although all four classes of names can be used with match_star_name_, it may be much more efficient to classify them in advance. The check_star_name_ subroutine is provided for this purpose. However, because starnames are often used with the Multics file system, a number of optional validity checks can be performed by check_star_name_. There are three entrypoints: 1. check_star_name_ is the most general and convenient. It validates and classifies star names. A bit string parameter permits an arbitrary combination of the optional tests. An include file, check_star_name.incl.pl1, exists to aid in constructing control bit strings and interpreting the classification. A number of error codes can be returned depending on the tests selected. 2. check_star_name_$entry is an obsolete entrypoint retained for compatibility with the many existing programs which call it. It is used to validate file system entrynames. A fixed set of validity checks is always made. The starname classification is returned as a nonstandard error code rather than as a separate argument. The only standard error code returned is error_table_$badstar, which for compatibility must cover all error cases. The selected tests include rejecting null components, nonASCII characters, pathname delimiters, the archive pathname delimiter, and names more than 32 characters long. 3. check_star_name_$path is an obsolete entrypoint retained for compatibility with the many existing programs which call it. It is used to validate file system pathnames. A fixed set of validity checks is always made. The starname classification is returned as a nonstandard error code rather than as a separate argument. The only standard error code returned is error_table_$badstar, which for compatibility must cover all error cases. The selected tests include processing pathname delimiters and the archive convention, and rejecting null components, nonASCII characters and names more than 32 characters long. The checks for invalid delimiters and null components could have been added as additional steps in the testing process. However, a separate TCT table for finding the various delimiters would have increased the size of the program, and the additional tests would have made check_star_name_ slower. Instead, these tests are made in the parsing routine at the cost of some additional complexity. History Author Modification 8 Jul 1982 J. Spencer Love Initial coding. 19 Nov 1984 J. Spencer Love Audit and MCR changes for MR11. 25 Jan 1985 J. Spencer Love Fix bug in check_star_name_$path. */ /****^ HISTORY COMMENTS: 1) change(86-08-12,JSLove), approve(86-08-14,MCR7518), audit(86-08-14,FCSmith), install(86-10-02,MR12.0-1174): Changed new check_star_name_ entrypoint to take 4 arguments, adding the test selection control mask and separate star_type arguments. 2) change(88-03-15,Parisek), approve(88-03-29,MCR7872), audit(88-04-14,LJAdams), install(88-04-26,MR12.2-1042): Set pi.match_name_exhausted during COMPARE_STAR_UNDOTTED_LITERAL_DOT when all of the match_name has been parsed. phx21106. END HISTORY COMMENTS */ /* format: style3,ifthenstmt,indcomtxt,indproc,idind30 */ %page; match_star_name_: procedure (P_match_entry_name, P_match_star_name, P_match_status); declare P_check_control bit (36) parameter, P_check_star_name char (*) parameter, P_check_star_type fixed bin (2) parameter, P_check_status fixed bin (35) parameter, P_match_entry_name char (*) parameter, P_match_star_name char (*) parameter, P_match_status fixed bin (35) parameter, P_nonstandard_status fixed bin (35) parameter; declare (addr, index, length, maxlength, rank, reverse, rtrim, search, string, substr, unspec) builtin; declare match_name_length fixed bin (21), /* The length of the string to be matched to the star name. */ match_name_ptr ptr, /* The address of the string to be matched to the starname. */ star_name_length fixed bin (21), /* The length of the star name to be parsed. */ star_name_ptr ptr, /* The address of the star name to be parsed. */ star_type fixed bin (2), /* The classification according to check_star_name_. */ status fixed bin (35), /* Internal error code for the check procedures. */ temp fixed bin (21); /* Temporary used in comparison routines. */ declare 1 cs aligned like check_star; declare 1 pi aligned, /* The complete current state of the parse and match. */ 2 starstar, /* The state subset that must be restored for ** retry. */ 3 star, /* The state subset that must be restored for * retry. */ 4 operations, /* These two are grouped for efficient assignment. */ 5 comparison fixed bin unaligned,/* The comparison routine to be invoked. */ 5 state fixed bin unaligned,/* The state of the parser Finite State Machine. */ 4 parse_position fixed bin (21), /* Zero origin index of the next star name char to parse. */ 4 parse_query_count fixed bin (21), /* The number of Queries for the next or final comparison. */ 4 literal_position fixed bin (21), /* Zero origin index of a literal substring of star name. */ 4 literal_length fixed bin (21), /* Length of a literal substring of the star name. */ 4 dot_count fixed bin (21), /* The number of Dots in the current literal substring. */ 4 match_position fixed bin (21), /* Zero origin position of the remaining match string. */ 4 match_length fixed bin (21), /* The length of the remaining match string. */ 3 compare_query_count fixed bin (21), /* The number of Queries for the current comparison. */ 2 match_name_exhausted bit (1) aligned; /* Have already matched against last component. */ declare 1 star_retry_info aligned like pi.star, 1 starstar_retry_info aligned like pi.starstar; declare match_name char (match_name_length) based (match_name_ptr), star_name char (star_name_length) based (star_name_ptr); declare ARCHIVE_DELIM initial ("::") char (2) static options (constant), ASCII_HIGH initial (127) fixed bin (9) static options (constant), DOT initial (".") char (1) static options (constant), ENTRYPOINT_CHARS initial ("$|") char (2) static options (constant), EQUAL_CHARS initial ("=%") char (2) static options (constant), MAXIMUM_FILESYS_LENGTH initial (32) fixed bin (17) static options (constant), PATH_CHARS initial ("<>") char (2) static options (constant); declare ( error_table_$archive_pathname, error_table_$bad_arg, error_table_$bad_file_name, error_table_$badequal, error_table_$badpath, error_table_$badstar, error_table_$entlong, error_table_$inconsistent, error_table_$invalid_ascii, error_table_$nostars, error_table_$nomatch, error_table_$null_name_component ) fixed bin (35) external; %page; /* The comparison codes are generated by tables in the parse subroutine, and used as subscripts on the COMPARE label array. The following particular codes are used by the check_star_name_ entrypoints. MATCHES_EVERYTHING identifies a type 2 star name if it is returned on the first call to the parser. MATCHES_LITERAL and MATCHES_NOTHING identify a type 0 star name if either is returned on the first call to the parser. Comparisons less than MATCHES_ERROR indicate that the end of the star name has been reached, and comparisons greater than MATCHES_ERROR indicate that further parsing remains to be done. */ declare ( MATCHES_ANYTHING initial (-17), MATCHES_ERROR initial (0), MATCHES_LITERAL initial (-1), MATCHES_NOTHING initial (-4) ) fixed bin static options (constant); %page; %include check_star_name; %page; /* match_star_name_: procedure (P_match_entry_name, P_match_star_name, P_match_status); */ star_name_length = maxlength (P_match_star_name); /* Pick up star name parameter for analysis. Here we get */ star_name_ptr = addr (P_match_star_name); /* the length and the address, then trim off trailing */ star_name_length = length (rtrim (star_name)); /* blanks. We look at the parameter only once. */ string (cs) = CHECK_STAR_IGNORE_ALL; unspec (pi.operations) = ""b; /* Initialize parser. */ pi.parse_position, pi.parse_query_count = 0; call parse (); /* Take our first look at the starname. */ if pi.comparison = MATCHES_ANYTHING then go to MATCH_EXIT; match_name_length = maxlength (P_match_entry_name); /* We have to look at the string to match, so get it and */ match_name_ptr = addr (P_match_entry_name); /* rtrim it. We don't copy the match name; it costs too */ match_name_length = length (rtrim (match_name)); /* much and can be of any length. */ pi.match_name_exhausted = "0"b; /* Initialize for the comparison routines. */ pi.match_length = match_name_length; pi.match_position = 0; /* Start here. */ unspec (star_retry_info.operations) = ""b; /* No checkpoint yet. */ unspec (starstar_retry_info.operations) = ""b; /* Bo checkpoint yet. */ go to COMPARE (pi.comparison); /* Start comparing star name to match name. */ %page; COMPARE (-29): /* Compare **.?oE */ call literal_end (); /* Reduce to **.?E */ COMPARE (-28): /* Compare **.?E */ pi.match_length = pi.match_length - pi.parse_query_count; if pi.match_length < 0 then go to NO_MATCH_EXIT; /* Make sure there is enough room for the Queries. */ if index (substr (match_name, pi.match_position + pi.match_length + 1, pi.parse_query_count), DOT) - 1 >= 0 then go to NO_MATCH_EXIT; /* Reject if a Dot is found where one shouldn't be. */ go to COMPARE_MUST_END_ON_COMPONENT_BOUNDARY; COMPARE (-27): /* Compare *.**.E */ call skip_component (); /* Reduce to C**.E */ if ^pi.match_name_exhausted then go to COMPARE_MUST_END_ON_COMPONENT_BOUNDARY; else go to NO_MATCH_EXIT; /* Final component must be null, but if we have already */ /* matched END then we are short on components. */ COMPARE (-26): /* Compare *.**.oE */ call skip_component (); /* Reduce to **.oE */ COMPARE (-25): /* Compare **.oE */ call literal_end (); /* Reduce to **.E */ COMPARE (-24): /* Compare **.E */ COMPARE_MUST_END_ON_COMPONENT_BOUNDARY: if pi.match_length = 0 then if ^pi.match_name_exhausted then go to MATCH_EXIT; /* If we are at end, nevertheless the END must not have */ else go to NO_MATCH_EXIT; /* already been matched, or we are short on components. */ if substr (match_name, pi.match_position + pi.match_length, 1) = DOT then go to MATCH_EXIT; /* Since not at end, must have literal Dot. */ NO_MATCH_EXIT: /* Indicate that star name does not match string. */ P_match_status = error_table_$nomatch; return; %page; COMPARE (-23): /* Compare **?oE */ call literal_end (); /* Reduce to **?E */ COMPARE (-22): /* Compare **?E */ pi.match_length = pi.match_length - pi.parse_query_count; if pi.match_length < 0 then go to NO_MATCH_EXIT; /* Make sure there is enough room for the Queries. */ if index (substr (match_name, pi.match_position + pi.match_length + 1, pi.parse_query_count), DOT) - 1 >= 0 then go to NO_MATCH_EXIT; /* Reject if a Dot is found where one shouldn't be. */ go to MATCH_EXIT; COMPARE (-21): /* Compare *.**oE */ call skip_component (); /* Reduce to **oE */ COMPARE (-20): /* Compare **oE */ call literal_end (); /* Reduce to **E */ go to MATCH_EXIT; COMPARE (-19): /* Compare *.**.*E */ call skip_component (); /* Reduce to C**.*E */ COMPARE (-18): /* Compare C**.*E */ if pi.match_name_exhausted then go to NO_MATCH_EXIT; /* There must be at least one component left. */ COMPARE (-17): /* Compare ** (MATCHES_ANYTHING) */ MATCH_EXIT: /* Indicate that star name matches string. */ P_match_status = 0; return; %page; COMPARE (-16): /* Compare o.*oE */ call literal_end (); /* Reduce to o.*E */ COMPARE (-15): /* Compare o.*E */ call must_be_at_dot (); /* Reduce to *E */ go to COMPARE_MUST_BE_LAST_COMPONENT; COMPARE (-14): /* Compare *.*E */ call skip_component (); /* Reduce to C*E */ COMPARE (-13): /* Compare C*E */ if ^pi.match_name_exhausted then go to COMPARE_MUST_BE_LAST_COMPONENT; /* END of match name must not already have been matched or */ else go to NO_MATCH_EXIT; /* match name has too few components. */ COMPARE (-12): /* Compare *?oE */ call literal_end (); /* Reduce to *?E */ COMPARE (-11): /* Compare *?E */ if pi.match_length >= pi.parse_query_count then go to COMPARE_MUST_BE_LAST_COMPONENT; /* There must be enough room for the Queries. */ else go to NO_MATCH_EXIT; COMPARE (-10): /* Compare *.*oE */ call skip_component (); /* Reduce to *oE */ COMPARE (-9): /* Compare *oE */ call literal_end (); /* Reduce to *E */ COMPARE (-8): /* Compare *E */ COMPARE_MUST_BE_LAST_COMPONENT: if index (substr (match_name, pi.match_position + 1, pi.match_length), DOT) - 1 < 0 then go to MATCH_EXIT; /* Last component can't contain any Dots. */ else go to RETRY_STARSTAR; %page; COMPARE (-7): /* Compare ?E */ if pi.match_length ^= pi.parse_query_count then if pi.match_length < pi.parse_query_count then go to NO_MATCH_EXIT; /* There must be exactly enough room. If there is too much */ else go to RETRY_STAR; /* we can retry but too little is immediately fatal. */ if index (substr (match_name, pi.match_position + 1, pi.match_length), DOT) - 1 < 0 then go to MATCH_EXIT; /* Queries can't match Dots. */ else go to NO_MATCH_EXIT; COMPARE (-6): /* Compare *.E */ call skip_component (); /* Reduce to CE */ COMPARE (-5): /* Compare CE */ if pi.match_name_exhausted then go to NO_MATCH_EXIT; /* We must be at end, but END must not already have been */ /* matched. */ COMPARE (-4): /* Compare BE (MATCHES_NOTHING) */ if pi.match_length = 0 then go to MATCH_EXIT; /* Requires that no match name be left. */ else go to RETRY_STARSTAR; /* Needed for CE but Doublestars can't preceded BE */ COMPARE (-3): /* Compare ?oE */ pi.compare_query_count = pi.parse_query_count; /* Adjust environment for (non-terminal) skip_queries. */ call skip_queries (); /* Reduce to oE */ go to COMPARE_LITERAL_END; COMPARE (-2): /* Compare *.oE */ call skip_component (); /* Reduce to oE */ unspec (star_retry_info.operations) = ""b; /* We are in a new component, so no Star retry is possible. */ COMPARE (-1): /* Compare oE (MATCHES_LITERAL) */ COMPARE_LITERAL_END: if substr (star_name, pi.literal_position + 1) = substr (match_name, pi.match_position + 1, pi.match_length) then go to MATCH_EXIT; else go to RETRY_STAR; COMPARE (0): /* MATCHES_ERROR */ P_match_status = error_table_$badstar; /* Indicate that star name is not valid. */ return; %page; /* Here follows a procedure which is used to match literals found at the ends of star names. The following restrictions apply to its use: if used by the same star name, components must be skipped by calling skip_component BEFORE calling literal_end, and the literal must be matched first, which effectively shortens the match name by subtracting from pi.match_length, before Queries can be matched. */ literal_end: procedure (); /* Procedure to match string at end of match name. */ pi.literal_length = star_name_length - pi.literal_position; /* Trim characters to be matched for Queries, if any. */ pi.match_length = pi.match_length - pi.literal_length; if pi.match_length < 0 then go to NO_MATCH_EXIT; /* Make sure there is enough room for the literal. */ if substr (star_name, pi.literal_position + 1, pi.literal_length) ^= substr (match_name, pi.match_position + pi.match_length + 1, pi.literal_length) then go to NO_MATCH_EXIT; /* Reject if character mismatch. */ return; end literal_end; %page; RETRY_COMPARE (1): /* Retry **.?o */ RETRY_STARSTAR_DOT_QUERY_LITERAL: /* CROCK: Saved pi.match_length is adjustment value. */ pi.match_position = pi.match_position + pi.match_length + 1; pi.match_length = match_name_length - pi.match_position; if pi.match_length < 0 then go to NO_MATCH_EXIT; /* Punt if match name is exhausted. */ COMPARE (1): /* Compare **.?o */ COMPARE_STARSTAR_DOT_QUERY_LITERAL: temp = index (substr (match_name, pi.match_position + 1, pi.match_length), DOT) - 1; if temp < 0 then temp = pi.match_length; /* Find end of current component. */ else if temp < pi.compare_query_count then do; /* Loop until component holds Queries or last component. */ pi.match_position = pi.match_position + (temp + 1); pi.match_length = pi.match_length - (temp + 1); go to COMPARE_STARSTAR_DOT_QUERY_LITERAL; end; pi.match_position = pi.match_position + pi.compare_query_count; pi.match_length = pi.match_length - pi.compare_query_count; /* Skip over Queries. */ if pi.literal_length > pi.match_length then go to NO_MATCH_EXIT; /* Give up if match name exhausted. */ if substr (star_name, pi.literal_position + 1, pi.literal_length) ^= substr (match_name, pi.match_position + 1, pi.literal_length) then do; /* Does match name match literal substring at this point? */ pi.match_length = temp - pi.compare_query_count; /* Calculate retry offset. */ go to RETRY_STARSTAR_DOT_QUERY_LITERAL; /* If not, try next component. */ end; starstar_retry_info = pi.starstar; /* Save in case of retry and calculate retry offset. */ starstar_retry_info.match_length = temp - pi.compare_query_count; pi.match_position = pi.match_position + pi.literal_length; pi.match_length = pi.match_length - pi.literal_length; /* Skip literal substring and get next installment. */ go to PARSE_NEW_COMPONENT; %page; COMPARE (2): /* Compare **?o */ pi.match_position = pi.match_position + pi.compare_query_count; pi.match_length = pi.match_length - pi.compare_query_count; if pi.match_length < 0 then go to NO_MATCH_EXIT; /* There must be at least Query count characters left. */ /* Skip over them ONCE before doing first index. */ COMPARE_STARSTAR_QUERY_LITERAL: /* Retry enters here. */ temp = index (substr (match_name, pi.match_position + 1, pi.match_length), substr (star_name, pi.literal_position + 1, pi.literal_length)) - 1; if temp < 0 then do; /* Check for zero length literal substring. */ if pi.literal_length > 0 then go to NO_MATCH_EXIT; /* If there is a literal string then index failed. */ /* Otherwise skip to end of component, but not over Dot. */ /* This is valid because the only way we can have a null */ /* literal string is if the next thing is a Dot Star. */ temp = index (substr (match_name, pi.match_position + 1, pi.match_length), DOT) - 1; if temp < 0 then temp = pi.match_length;/* Make it the whole rest of the last component. */ end; pi.match_position = pi.match_position + temp; /* Skip over the intervening characters. */ pi.match_length = pi.match_length - temp; if index (substr (match_name, pi.match_position - pi.compare_query_count + 1, pi.compare_query_count), DOT) - 1 < 0 then go to HAVE_STARSTAR_MATCH; /* If no Dot is found where Queries are, then success. */ RETRY_COMPARE (2): /* Retry **?o */ pi.match_position = pi.match_position + 1; /* Space ove character beyond previous match to try again. */ pi.match_length = pi.match_length - 1; /* Give up if the match name is exhausted. */ if pi.match_length < 0 then go to NO_MATCH_EXIT; go to COMPARE_STARSTAR_QUERY_LITERAL; /* Go search for literal substring. */ %page; COMPARE (5): /* Compare *.**.o */ call skip_component (); /* Convert to **.o */ pi.comparison = 3; /* Update comparison index for retry if needed. */ COMPARE (3): /* Compare **.o */ if pi.literal_length > pi.match_length then go to NO_MATCH_EXIT; if substr (match_name, pi.match_position + 1, pi.literal_length) = substr (star_name, pi.literal_position + 1, pi.literal_length) then go to HAVE_STARSTAR_MATCH; RETRY_COMPARE (3): /* Retry **.o */ pi.comparison = 4; /* Change to **o */ pi.literal_position = pi.literal_position - 1; /* Since it wasn't immediate, include the Dot into the */ pi.literal_length = pi.literal_length + 1; /* literal substring and use **o comparison. */ go to COMPARE_STARSTAR_LITERAL; RETRY_COMPARE (4): /* Retry **o */ pi.match_position = pi.match_position + 1; /* Set position one character beyond previous match and try */ pi.match_length = pi.match_length - 1; /* again. Give up if match name is exhausted. */ if pi.match_length <= 0 then go to NO_MATCH_EXIT; COMPARE (4): /* Compare **o */ COMPARE_STARSTAR_LITERAL: temp = index (substr (match_name, pi.match_position + 1, pi.match_length), substr (star_name, pi.literal_position + 1, pi.literal_length)) - 1; if temp < 0 then go to NO_MATCH_EXIT; /* Find the next occurance of the literal string, if any. */ pi.match_position = pi.match_position + temp; /* Skip over intervening characters. */ pi.match_length = pi.match_length - temp; HAVE_STARSTAR_MATCH: starstar_retry_info = pi.starstar; /* Save current state in case this match attempt fails. */ pi.match_position = pi.match_position + pi.literal_length; pi.match_length = pi.match_length - pi.literal_length; /* Skip over the actual literal string. */ go to PARSE_NEW_COMPONENT; /* Doublestar supercedes any previous Star construct info. */ COMPARE (6): /* Compare *.**o */ call skip_component (); /* Convert to **o */ pi.comparison = 4; /* Update comparison index for retry if needed. */ go to COMPARE_STARSTAR_LITERAL; /* Finish comparison. */ %page; COMPARE (7): /* Compare ?o */ call skip_queries (); /* Reduce to o */ go to COMPARE_LITERAL; COMPARE (8): /* Compare *.o */ call skip_component (); /* Reduce to o */ unspec (star_retry_info.operations) = ""b; /* We are in a new component now. */ COMPARE (9): /* Compare o */ COMPARE_LITERAL: pi.match_length = pi.match_length - pi.literal_length; if pi.match_length < 0 then go to NO_MATCH_EXIT; /* Give up if there isn't room for literal substring. */ if substr (star_name, pi.literal_position + 1, pi.literal_length) ^= substr (match_name, pi.match_position + 1, pi.literal_length) then go to RETRY_STAR; /* Try again if the literal substring doesn't match here. */ pi.match_position = pi.match_position + pi.literal_length; /* Skip over matched literal string. */ call parse (); /* Get next installment. */ go to COMPARE (pi.comparison); /* Deliver it. */ RETRY_STAR: /* Retry *o (not at component boundary) */ if unspec (star_retry_info.operations) ^= ""b then do; /* Handle Star checkpoint, if any. */ pi.star = star_retry_info; /* Restore parser to point of most recent Star. */ pi.match_position = pi.match_position + 1; pi.match_length = pi.match_length - 1; /* Start scanning beyond previous match. */ go to COMPARE_STAR_LITERAL; /* We know that literal is Dotless, of nonzero length and */ /* that it is not followed by a Dot, or we couldn't be */ /* here, so we needn't check. */ RETRY_STARSTAR: unspec (star_retry_info.operations) = ""b; end; /* Doublestar retry supercedes Star checkpoint info. */ if unspec (starstar_retry_info.operations) = ""b then go to NO_MATCH_EXIT; /* If no saved checkpoint, match fails. */ pi.starstar = starstar_retry_info; /* Restore parser to point of most recent DoubleStar. */ /* One of comparisons 1 to 4 will be retried. */ go to RETRY_COMPARE (pi.comparison); %page; COMPARE (10): /* Compare o.*o (not at component boundary) */ call must_be_at_dot (); /* Reduce to *o */ go to COMPARE_STAR_LITERAL; COMPARE (11): /* Compare ?*o (not at component boundary) */ call skip_queries (); /* Reduce to *o */ go to COMPARE_STAR_LITERAL; COMPARE (12): /* Compare *.*o (not at component boundary) */ call skip_component (); /* Reduce to *o */ COMPARE (13): /* Compare *o (not at component boundary) */ COMPARE_STAR_LITERAL: /* Retry comes here. */ if pi.dot_count > 0 then do; /* If crossed component boundary, can't retry. */ call compare_star_dotted_literal (); go to PARSE_NEW_COMPONENT; /* Skip over literal and get next installment. */ end; temp = index (substr (match_name, pi.match_position + 1, pi.match_length), DOT) - 1; if temp < 0 then temp = pi.match_length; /* Find out length of this component. */ temp = index (substr (match_name, pi.match_position + 1, temp), substr (star_name, pi.literal_position + 1, pi.literal_length)) - 1; if temp < 0 then go to RETRY_STARSTAR; /* Search this component for the literal string. */ pi.match_position = pi.match_position + temp; /* Skip intervening characters. */ pi.match_length = pi.match_length - temp; star_retry_info = pi.star; /* Save in case of retry. */ pi.match_position = pi.match_position + pi.literal_length; pi.match_length = pi.match_length - pi.literal_length; /* Skip over literal AFTER save. */ call parse (); /* Get next installment. */ go to COMPARE (pi.comparison); /* Deliver it. */ %page; COMPARE (14): /* Compare o.*oC */ call must_be_at_dot (); /* Reduce to *oC */ if pi.dot_count = 0 then go to COMPARE_STAR_UNDOTTED_LITERAL_DOT; /* Select easy or hard comparison based on whether literal */ else go to COMPARE_STAR_DOTTED_LITERAL_DOT; /* string crosses component boundary. */ COMPARE (15): /* Compare ?*oC */ if pi.dot_count = 0 then go to COMPARE_STAR_UNDOTTED_LITERAL_DOT; /* If easy case, don't need to explicitly skip Queries. */ call skip_queries (); COMPARE_STAR_DOTTED_LITERAL_DOT: call compare_star_dotted_literal (); if pi.match_length > 0 then do; /* Must be at component boundary. */ unspec (star_retry_info.operations) = ""b; call must_be_at_dot (); end; go to PARSE_NEW_COMPONENT; /* Get next installment. */ compare_star_dotted_literal: procedure (); /* Take advantage of knowing literal contains a Dot to */ /* avoid using multi-char index operators which are slower. */ temp = index (substr (match_name, pi.match_position + 1, pi.match_length), DOT) - index (substr (star_name, pi.literal_position + 1, pi.literal_length), DOT); if temp < 0 then go to RETRY_STARSTAR; /* Line up the first Dots, if any in match name. */ pi.match_position = pi.match_position + temp; /* Skip over intervening characters. */ pi.match_length = pi.match_length - temp; if substr (star_name, pi.literal_position + 1, pi.literal_length) ^= substr (match_name, pi.match_position + 1, pi.literal_length) then go to RETRY_STARSTAR; /* See if literal string is at designated position. If */ /* not, no RETRY_STAR because component bound crossed. */ pi.match_position = pi.match_position + pi.literal_length; pi.match_length = pi.match_length - pi.literal_length; /* Skip over literal substring. */ return; end compare_star_dotted_literal; %page; COMPARE (16): /* Compare *.*oC */ call skip_component (); /* Reduce to *oC */ COMPARE (17): /* Compare *oC */ COMPARE_STAR_LITERAL_DOT: /* If there are any Dots in the literal then it crosses */ /* component boundaries. Use the harder comparison. */ if pi.dot_count > 0 then go to COMPARE_STAR_DOTTED_LITERAL_DOT; COMPARE_STAR_UNDOTTED_LITERAL_DOT: /* Fast comparison for simple case. */ temp = index (substr (match_name, pi.match_position + 1, pi.match_length), DOT) - 1; if temp < 0 then temp = pi.match_length; /* Find the end of the current component. */ temp = temp - pi.literal_length; /* Back up by the number of literal characters. */ if temp < pi.compare_query_count then go to NO_MATCH_EXIT; /* There must be room in the component for all Queries and */ pi.match_position = pi.match_position + temp; /* literals. Skip over intervening characters. */ if substr (star_name, pi.literal_position + 1, pi.literal_length) ^= substr (match_name, pi.match_position + 1, pi.literal_length) then go to RETRY_STARSTAR; /* If it doesn't match, can't be in this component. */ pi.match_position = pi.match_position + pi.literal_length; pi.match_length = match_name_length - pi.match_position; if pi.match_length > 0 then do; /* Skip over Dot if present. End of match name is OK too. */ pi.match_position = pi.match_position + 1; pi.match_length = pi.match_length - 1; end; else pi.match_name_exhausted = "1"b; /* End of match name */ go to PARSE_NEW_COMPONENT; /* Get next installment. */ %page; COMPARE (18): /* Compare at boundary (for case o.** => C**) */ if pi.match_position < match_name_length then call must_be_at_dot (); /* If any chars left, then boundary is literal Dot. */ else pi.match_name_exhausted = "1"b; /* Otherwise end of match name is boundary. */ go to PARSE_NEW_COMPONENT; /* Get next installment. */ COMPARE (19): /* Compare . (for case o.*? => *?) */ call must_be_at_dot (); /* Reduce to C */ go to PARSE_NEW_COMPONENT; /* Get next installment. */ COMPARE (20): /* Compare o.*. */ call must_be_at_dot (); /* Reduce to *. */ call skip_component (); /* Reduce to C */ go to PARSE_NEW_COMPONENT; /* Get next installment. */ must_be_at_dot: procedure (); /* The Dot turned out to be a literal one. */ pi.match_length = pi.match_length - 1; /* See if the Dot fits in the name. */ if pi.match_length < 0 then go to NO_MATCH_EXIT; if substr (match_name, pi.match_position + 1, 1) ^= DOT then go to RETRY_STAR; /* If not a Dot, then still in the same component. */ pi.match_position = pi.match_position + 1; /* Yup. Skip over the Dot. */ return; end must_be_at_dot; %page; COMPARE (21): /* Compare *.*. */ call skip_component (); /* Reduce to *. */ COMPARE (22): /* Compare *. (for cases *.? => ? and o**. => C**.) */ call skip_component (); /* Reduce to C */ PARSE_NEW_COMPONENT: unspec (star_retry_info.operations) = ""b; /* In a new component, now, so no Star can be retried. */ call parse (); /* Continue with next installment of the star name. */ go to COMPARE (pi.comparison); skip_component: procedure (); /* Find the next Dot in the match name or its end. If the */ /* end has already been reached by a previous call, there */ /* are not enough components. pi.match_name_exhausted is */ /* required to indicate that an imaginary END character */ /* beyond the end of the match name has also been matched. */ temp = index (substr (match_name, pi.match_position + 1, pi.match_length), DOT); if temp = 0 then do; /* No Dots left. */ if pi.match_name_exhausted then go to NO_MATCH_EXIT; pi.match_name_exhausted = "1"b; /* Have matched END as well as last character. */ pi.match_length = 0; /* Nothing left. */ end; else do; /* Skip over component. */ pi.match_position = pi.match_position + temp; pi.match_length = pi.match_length - temp; end; return; end skip_component; %page; COMPARE (23): /* Compare ? (for case ?** => o**) */ call skip_queries (); /* After this comparison, we can't depend on being at a */ /* component boundary in the match name. */ call parse (); /* Get next installment. */ go to COMPARE (pi.comparison); /* Deliver it. */ COMPARE (24): /* Compare **? (for case **?** => o**) */ do while (pi.match_length >= pi.compare_query_count); /* Find the first Dotless substring at least long enough */ /* to contain the designated number of consecutive Queries. */ temp = index (substr (match_name, pi.match_position + 1, pi.compare_query_count), DOT); if temp = 0 | temp > pi.compare_query_count then do; /* Eureka. */ pi.match_position = pi.match_position + pi.compare_query_count; pi.match_length = pi.match_length - pi.compare_query_count; go to PARSE_NEW_COMPONENT; /* Get next installment. */ end; pi.match_position = pi.match_position + temp;/* Skip past the Dot we found and try again. */ pi.match_length = pi.match_length - temp; end; go to NO_MATCH_EXIT; skip_queries: procedure (); /* See if the match name has enough non-Dot characters at */ /* the current position to match the star name here. */ pi.match_length = pi.match_length - pi.compare_query_count; if pi.match_length < 0 then go to NO_MATCH_EXIT; /* There must be at least the requisite number of chars. */ if index (substr (match_name, pi.match_position + 1, pi.compare_query_count), DOT) - 1 >= 0 then go to RETRY_STARSTAR; /* If we found a Dot then RETRY_STAR is out of the running. */ pi.match_position = pi.match_position + pi.compare_query_count; /* Skip over the designated substring. */ return; end skip_queries; %page; /* The check_star_name_ entrypoint permits flexible validation and classification of starnames. See check_star_name.incl.pl1 for the values which can be used to construct the P_check_control argument and the values which can be returned in the P_check_star_type argument. Please refer to the code in the following procedures for comments explaining the action of each control flag in detail. */ check_star_name_: entry (P_check_star_name, P_check_control, P_check_star_type, P_check_status); string (cs) = P_check_control; /* This entrypoint lets caller specify. */ call check (); /* Do the work. */ P_check_star_type = star_type; P_check_status = status; return; %page; /* The check_star_name_$entry entrypoint is obsolete and is retained for compatibility with its many callers. The use of the check_star_name_ entrypoint (next page) is recommended for new applications and when updating old programs. Except for returning a nonstandard code, its operation is the same as check_star_name_ with the following control bits set: IGNORE_ENTRYPOINT, IGNORE_EQUAL. */ check_star_name_$entry: entry (P_check_star_name, P_nonstandard_status); string (cs) = CHECK_STAR_ENTRY_DEFAULT; /* Select options as listed above. */ go to CHECK_FILESYS_COMMON; /* The check_star_name_$path entrypoint is obsolete and is retained for compatibility with its many callers. The use of the check_star_name_ entrypoint (next page) is recommended for new applications and when updating old programs. Except for returning a nonstandard code, its operation is the same as check_star_name_ with the following control bits set: IGNORE_ENTRYPOINT, IGNORE_EQUAL, PROCESS_ARCHIVE, PROCESS_PATH. */ check_star_name_$path: entry (P_check_star_name, P_nonstandard_status); string (cs) = CHECK_STAR_PATH_DEFAULT; /* Select options as listed above. */ CHECK_FILESYS_COMMON: call check (); /* Do the work. */ if status = 0 then P_nonstandard_status = star_type; /* Construct nonstandard code. */ else P_nonstandard_status = error_table_$badstar; return; %page; check: procedure (); declare idx fixed bin (21), multi_part_name bit (1) aligned, saved_length fixed bin (21), saved_position fixed bin (21); if cs.unimplemented ^= ""b then do; status = error_table_$bad_arg; /* UNIMPLEMENTED test(s) were selected. */ go to ERROR; end; if (cs.ignore_archive & cs.process_archive) | (cs.ignore_entrypoint & cs.process_entrypoint) | (cs.ignore_path & cs.process_path) then do; /* Incompatible tests were selected. */ status = error_table_$inconsistent; go to ERROR; end; star_name_length = maxlength (P_check_star_name); /* Pick up star name and rtrim it. The check entrypoints */ star_name_ptr = addr (P_check_star_name); /* use different parameter names so the compiler doesn't */ star_name_length = length (rtrim (star_name)); /* helpfully generate useless code to permit the same */ /* parameter to appear in more than one position. */ multi_part_name = "0"b; pi.parse_position = 0; /* Initially assume that the whole string is to be tested. */ star_type = STAR_TYPE_USE_PL1_COMPARE; status = 0; /**** The absolute pathname of the root (">") and relative pathnames consisting only of one or more "<" characters are valid, so accept a null entryname after either delimiter. Do not automatically accept an entirely null path. We are not responsible for validating pathname syntax, as expand_pathname_ can do a better job. */ if cs.process_path then do; pi.parse_position = search (reverse (star_name), PATH_CHARS) - 1; if pi.parse_position < 0 then pi.parse_position = 0; else pi.parse_position = star_name_length - pi.parse_position; if pi.parse_position > 0 then do; if ^cs.ignore_nonascii then do idx = 1 to pi.parse_position; if rank (substr (star_name, idx, 1)) > ASCII_HIGH then do; status = error_table_$badpath; go to ERROR; end; end; if pi.parse_position = star_name_length then return; end; end; if cs.process_archive then do; idx = index (substr (star_name, pi.parse_position + 1), ARCHIVE_DELIM) - 1; if idx >= 0 then do; saved_length = star_name_length; star_name_length = pi.parse_position + idx; saved_position = star_name_length + length (ARCHIVE_DELIM); call check_substring (); if status ^= 0 then go to ERROR; pi.parse_position = saved_position; star_name_length = saved_length; if pi.parse_position = star_name_length then go to BAD_FILE_NAME; multi_part_name = "1"b; end; end; if cs.process_entrypoint then do; idx = search (substr (star_name, pi.parse_position + 1), ENTRYPOINT_CHARS) - 1; if idx = 0 then go to BAD_FILE_NAME; else if idx > 0 then do; saved_length = star_name_length; star_name_length = pi.parse_position + idx; saved_position = star_name_length + 1; call check_substring (); if status ^= 0 then go to ERROR; pi.parse_position = saved_position; star_name_length = saved_length; cs.ignore_length = "1"b; if pi.parse_position = star_name_length then cs.ignore_null = "1"b; multi_part_name = "1"b; end; end; call check_substring (); if status ^= 0 then go to ERROR; if star_type ^= STAR_TYPE_USE_PL1_COMPARE then if cs.reject_wild then status = error_table_$nostars; else if multi_part_name then star_type = STAR_TYPE_USE_MATCH_PROCEDURE; return; BAD_FILE_NAME: status = error_table_$bad_file_name; ERROR: star_type = STAR_TYPE_USE_PL1_COMPARE; if status = 0 then status = error_table_$badstar; return; %page; /*^This routine analyzes star names for the check_star_name_ entrypoints. It does no matching, and is not as speed critical as the match_star_name_ entrypoint. It doesn't know much about the parser. It knows enough to put the parser in its initial state, and it knows three comparison index values and the fact that comparison values greater than MATCH_ERROR mean that the star name is not yet entirely parsed. */ check_substring: procedure (); if ^cs.ignore_length & star_name_length - pi.parse_position > MAXIMUM_FILESYS_LENGTH then do; status = error_table_$entlong; return; end; if ^cs.ignore_archive & index (substr (star_name, pi.parse_position + 1), ARCHIVE_DELIM) ^= 0 then do; status = error_table_$archive_pathname; return; end; if ^cs.ignore_nonascii & ^multi_part_name then do idx = pi.parse_position + 1 to star_name_length; if rank (substr (star_name, idx, 1)) > ASCII_HIGH then do; status = error_table_$invalid_ascii; return; end; end; unspec (pi.operations) = ""b; /* Initialize parser. */ pi.parse_query_count = 0; status = 0; call parse (); /* Start scanning the star name. */ if pi.comparison = MATCHES_ANYTHING then do; star_type = STAR_TYPE_MATCHES_EVERYTHING; return; end; if pi.comparison = MATCHES_LITERAL | pi.comparison = MATCHES_NOTHING then return; do while ("1"b); if pi.comparison <= MATCHES_ERROR then do; if pi.comparison = MATCHES_ERROR then go to ERROR; star_type = STAR_TYPE_USE_MATCH_PROCEDURE; return; end; call parse (); /* Continue scanning the star name. */ end; end check_substring; end check; %page; /*^This is where the knowledge of star name format resides. The contract of the parser is to be able to identify type 0 and type 2 star names in a single call, to detect bad star names, and to provide information to drive the comparison routines when called repeatedly while matching type 1 star names. The parser states are shown on the next page. Each time the parser is called, it returns up to four items of information: 1) a Star construct (made up of Stars and Dots), 2) a string of Queries, 3) a literal string, and 4) why parsing stopped. The parser returns when: 1) the Star construct becomes more complex than can be represented in an assigned state value, 2) a string of Queries is ended by a Star, 3) a literal string is ended by a Star or a Query, or 4) the end of the star name is encountered. Once as much of the star name as possible has been parsed, we return up to 5 numbers. The index of the comparison routine for a subscripted goto, the count of Queries, and the position, and length of a literal substring of the star name. The count of the number of Dots in the literal string is also returned to determine whether the literal crosses a component boundary (an actual count is used rather than just a flag, because the count can be decremented if a Star follows a Dot at the end of a literal). The comparison index is based on the Star construct (if any) and whether Queries or a Literal are present. In many cases, only some of the numbers are valid, but the comparison index is always valid. The parser postpones the comparison of a Doublestar as long as possible in the hope of finding a literal to index for or reaching the end of the star name. This is done purely for reasons of efficiency: the Doublestar compare routines must back up the parser if certain kinds of mismatch occur so they can retry the comparison farther down the match name. An example of a star name that might require this is "**a?a". The first "a" is indexed for, then the parser is called again to get the "?a". If it doesn't match, the parser is backed up and the next "a" is indexed for. An example of such postponement is converting "**.*.*.a" effectively into "*.*.**.a". The parser also postpones comparison of Stars by commuting Stars and Queries (e.g., "?*?*?" is the same as "*???") because they may need to also back up within a component. Star names like "*a?a" can fail at the query and require repositioning. */ parse: procedure (); declare break_pos fixed bin (21); declare BREAK_CHARS initial (".*?<>=%$|") char (9) static options (constant), STAR_CHARS initial (".*?") char (3) static options (constant); %page; /* format: off */ /* PARSE STATE TABLE 0 B 12 **?* 24 o 37 o. 1 B* 13 *? 25 *o 38 *o. 2 *. 14 ? 26 *.o 39 *.o. 3 *.* 15 ?* 27 *.*o 40 *.*o. 4 *.** 16 C 28 *.**o 41 *.**o. 5 *.**. 17 C* 29 *.**.o 42 *.**.o. 6 *.**.* 18 C** 30 **o 43 **o. 7 B** 19 C**. 31 **.o 44 **.o. 8 B**. 20 C**.* 32 **.?o 45 **.?o. 9 B**.* 21 o* 33 **?o 46 **?o. 10 **.? 22 o** 34 *?o 47 *?o. 11 **? 23 o.* 35 ?o 48 ?o. 36 o.*o 49 o.*o. Notes on nomenclature: B Represents the beginning of the star name. C Represents a component boundary (may include B). o Represents a literal, which may be null. See next paragraph. E (not shown here, but in the comparison routines) represents the end of the star name. The Star, Dot and Query characters represent themselves. When a literal is shown to the left of a star construct, it means that a literal or Query preceded the star construct. The comparison routine has already matched that literal or Query. However, its presence must still be remembered. State 21 exists so that state 22 can be detected. State 22 is required in order to handle a Doublestar which does not begin at a component boundary. States 23, 36 and 49 are used when a literal is ended by a ".*" because the Dot hasn't yet been compared but may not be a literal dot. States 18 and 19 exist so that state 20 can be detected. States 16, 17 and 20 respectively differ from states 0, 1 and 9 because they have already skipped to the end of the preceding component in the match name and must check that the end of the match name has not already been reached. One of the design constraints of the parser is that it be able to digest any type 0 or type 2 star names in the first call. This is done for higher performance. This requires the most complex state 6 "*.**.*" to parse type 2 names like "**.*.**.**". Queries where they occur indicate the presence of at least one Query. The actual number of Queries is in pi.compare_query_count for nonterminal comparisons, and pi.parse_query_count at the end. Although 24 states are needed to represent all the distinct Star constructs which don't have literals, only 13 are needed when a literal is present, because some state information can be discarded. To keep track of null components and to recognize state 23 "o.*", an additional 13 states are used which indicate that a Dot is the last character of the literal. */ %page; /* The END_OPS array selects the comparison routine for the last part of the star name. All the values are negative numbers, so that the check_star_name_ entrypoints can tell that the end of the star name has been reached. A value of zero (i.e., MATCHES_ERROR) is also interpreted as the end of the star name, but a positive value indicates that further parsing is required. The END_OPS array does not need a "state" value, since the parser is never reentered when the end of the star name is reached. The HAVE_LITERAL array has been combined with it in place of the unneeded state table to save space. The HAVE_LITERAL array is used without structure qualification because I judged it more confusing to emphasize the irrelevant connection to END_OPS. HAVE_LITERAL is used to change the parser state when a literal is started. It is used in a number of action routines to save creating additional state tables. */ declare 1 END_OPS (0:49) aligned static options (constant), 2 comparison fixed bin unaligned initial /* +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 */ /* NO LITERAL 0+ */ ( -4, -8, -6, -14, -17, -27, -19, -17, -24, -17, -28, -22, /* 12+ */ -22, -11, -7, -11, -5, -13, -17, -24, -18, -8, -17, -15, /* LITERAL LAST 24+ */ -1, -9, -2, -10, -21, -26, -20, -25, -29, -23, -12, -3, -16, /* DOT LAST 37+ */ -1, -9, -2, -10, -21, -26, -20, -25, -29, -23, -12, -3, -16), 2 HAVE_LITERAL fixed bin unaligned initial /* +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11, +12 */ /* NO LITERAL 0+ */ ( 24, 25, 26, 27, 28, 29, 28, 30, 31, 30, 32, 33, /* 12+ */ 33, 34, 35, 34, 24, 25, 30, 31, 30, 25, 30, 36, /* LITERAL LAST 24+ */ 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, /* DOT LAST 37+ */ 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36); %page; /*^This array contains the comparison and future state values used when Dots are encountered. The comparison value is negative when no comparison is to be performed. In this case, the state is updated and the parser continues. However, in some cases, the Dot must be interpreted as a literal Dot, (e.g. following a Query). In this case, the Dot could cause a null component (either at the beginning of the star name or two consecutive Dots). So there are three negative values: -1) The parser continues with only a state change. -2) A literal starts, but it is a null component. -3) A literal starts. When there is no literal, a positive comparison value causes the corresponding comparison routine to be invoked. This reduces the amount of encoded state we have to remember. For example, if we have state 3 "*.*" then we invoke a comparison routine. This means we don't need a state value for "*.*.". When there is already a literal, no comparison routine is ever invoked. The dot is simply added to the end of the literal. There are 13 basic literal prefix states (see states 24 through 36), but an additional 13 states are used to remember that the literal ends with a Dot. This is used to detect null components and literals anding in ".*". */ declare 1 DOT_OPS (0:49) aligned static options (constant), 2 comparison fixed bin unaligned initial /* +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 */ /* NO LITERAL 0+ */ ( -2, -1, -2, 21, -1, -2, 21, -1, -2, -1, -3, -3, /* 12+ */ -3, -3, -3, -3, -2, 22, -1, -2, 22, -1, 22, 20, /* LITERAL LAST 24+ */ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* DOT LAST 37+ */ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), 2 state fixed bin unaligned initial /* +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 */ /* NO LITERAL 0+ */ ( 37, 2, 39, 16, 5, 42, 19, 8, 44, 5, 45, 46, /* 12+ */ 46, 47, 48, 47, 37, 16, 19, 44, 19, 2, 19, 16, /* LITERAL LAST 24+ */ 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, /* DOT LAST 37+ */ 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49); /* The DOT_LAST table below is used to detect null components and to determine when a Star following a literal is immediately preceded by a Dot. When detecting null components, it is convenient to assume that a Dot precedes the beginning of the star name, but no literal is present in this case so it does not affect the parsing of an initial Star. */ declare DOT_LAST (0:49) bit (1) aligned static options (constant) initial /* +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 */ /* NO LITERAL 0+ */ ( "1"b, "0"b, "1"b, "0"b, "0"b, "1"b, "0"b, "0"b, "1"b, "0"b, "0"b, "0"b, /* 12+ */ "0"b, "0"b, "0"b, "0"b, "1"b, "0"b, "0"b, "1"b, "0"b, "0"b, "0"b, "0"b, /* LITERAL LAST */ (13) ("0"b), /* DOT LAST */ (13) ("1"b)); %page; /* This array contains the comparison and future state values used when Stars are encountered. It can be thought of as conceptually divided into three regions. The first 24 values are used when there is no literal. The next 13 values are used when there is a literal which does not end in a Dot, and the last 13 values are used when there is a literal which ends in a Dot. When the comparison value is negative, it means that no comparison is performed. In this case, the state is updated and parsing continues. In all other cases, parsing is suspended and some comparison is selected. When there is no literal, parsing is suspended either because the Star construct has become obviously not of type 2 (matches anything), or because a Doublestar has been detected following a Query. Any Star following a literal forces comparison. When the literal ends in a Dot, the Dot is removed from the literal and becomes part of the new Star construct if comparison succeeds, since the Dot could be followed by a Doublestar. NOTE: the literal may be reduced to zero length by the removal of the Dot. Identities are used to minimize the number of parser states: Simplest More complex B** B**.** C** C**.** *.** *.**.** *.**. B**.*. *? ?* *?* **? **?* */ declare 1 STAR_OPS (0:49) aligned static options (constant), 2 comparison fixed bin unaligned initial /* +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 */ /* NO LITERAL 0+ */ ( -1, -1, -1, -1, 0, -1, -1, 0, -1, -1, -1, -1, /* 12+ */ 24, -1, -1, 23, -1, -1, 0, -1, -1, -1, 0, 18, /* LITERAL LAST 24+ */ 9, 13, 8, 12, 6, 5, 4, 3, 1, 2, 11, 7, 10, /* DOT LAST 37+ */ 9, 17, 8, 16, 6, 5, 4, 3, 1, 2, 15, 7, 14), 2 state fixed bin unaligned initial /* +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 */ /* NO LITERAL 0+ */ ( 1, 7, 3, 4, 0, 6, 4, 0, 9, 7, 12, 12, /* 12+ */ 22, 15, 15, 22, 17, 18, 0, 20, 18, 22, 0, 18, /* LITERAL LAST 24+ */ 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, /* DOT LAST 37+ */ 23, 17, 23, 17, 23, 23, 23, 23, 23, 23, 17, 23, 17); %page; /* Here are the state and comparison values used when Queries are encountered. The comparison value is negative when no comparison need be performed. In this case, the Query is counted, the state is updated, and parsing continues. The cases where a Query forces a comparison when there is no literal are all cases where a complex Star construct must be simplified before the Query can be assimilated. For example, "*.*?" is reduced to "*?" by doing the comparison for "*.". This helps keep the number of states down. Queries always force comparisons when there is already a literal since it would be too complex to try to continue accumulating state information. No table entries are needed for the cases where a literal is ended by a Dot because when the Query is preceded by a literal the state value is obtained from the HAVE_LITERAL array, which doesn't contain those values. */ declare 1 QUERY_OPS (0:36) aligned static options (constant), 2 comparison fixed bin unaligned initial /* +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 */ /* NO LITERAL 0+ */ ( -1, -1, 22, 22, 22, 22, 22, -1, -1, -1, -1, -1, /* 12+ */ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 19, /* LITERAL LAST 24+ */ 9, 13, 8, 12, 6, 5, 4, 3, 1, 2, 11, 7, 10), 2 state fixed bin unaligned initial /* +0 +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +11 +12 */ /* NO LITERAL 0+ */ ( 14, 13, 14, 13, 11, 10, 11, 11, 10, 11, 10, 11, /* 12+ */ 11, 13, 14, 13, 14, 13, 11, 10, 11, 13, 11, 13, /* LITERAL LAST 24+ */ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14); /* format: on */ %page; /*^Here is where we start parsing. When the parser is entered, we have no literal, and to keep the size of some of the dispatch tables down and increase efficiency we have two different scanners: this one and another for when we have a literal. We find the first break character, if any. There are three cases: 1. If there is no break character, we branch to an action routine which determines whether there is a trailing literal and sets up the final comparison. 2. If there is a break character but no literal, we branch to the appropriate action routine which will arrange any state transformations and comparisons. 3. If there is a break character with a preceding literal, we branch to a different action routine, after first saving the position of the start of the literal and stepping the parser over the new literal and break char. */ SCAN_NO_LITERAL: break_pos = search (substr (star_name, pi.parse_position + 1), BREAK_CHARS) - 1; if break_pos < 0 then go to STAR_NAME_EXHAUSTED; if break_pos = 0 then do; /* Skip parser over break char, and dispatch on it. */ pi.parse_position = pi.parse_position + 1; go to BREAK (index (STAR_CHARS, substr (star_name, pi.parse_position, 1))); end; pi.literal_position = pi.parse_position; /* Remember where the literal starts. */ pi.parse_position = pi.parse_position + break_pos + 1; /* Skip parser over literal substring and following break. */ go to LITERAL_BREAK (index (STAR_CHARS, substr (star_name, pi.parse_position, 1))); /* We come here when we are finished parsing the star name. If we never before encountered a literal, we come to STAR_NAME_EXHAUSTED, otherwise to LITERAL_EXHAUSTED on the next page. On this page, there is no old literal, but there may be a new literal. If we were already at the end of the star name, there is no literal. */ STAR_NAME_EXHAUSTED: /* No breaks left in star name. */ if pi.parse_position = star_name_length then do; /* Star name ends with Dot, Star or Query. */ if DOT_LAST (pi.state) & ^cs.ignore_null then go to REJECT_NULL; pi.operations = END_OPS (pi.state); /* Set final comparison type. */ return; /* Go to final comparison. */ end; pi.operations = END_OPS (HAVE_LITERAL (pi.state));/* First note existence of literal, and then select the */ /* comparison. */ pi.literal_position = pi.parse_position; /* Remember where literal begins. */ return; /* Go to final comparison. */ %page; /*^Here is the other scanner. In this case, we know we have scanned before, and that we have a literal. The three cases are slightly different: 1. There is no break character. The star name is known to end in a literal, but we must check that it does not end in a null component. 2. There is no new literal string, so this break follows the preceding one consecutively. A dispatch table is used which aids in detecting null components (two Dots in a row), since the first break must be valid in a literal (i.e., not a Star or a Query). 3. Like #3 above, but dispatched differently to extend the literal. */ SCAN_LITERAL: break_pos = search (substr (star_name, pi.parse_position + 1), BREAK_CHARS) - 1; if break_pos < 0 then go to LITERAL_EXHAUSTED; /* If none left then finish up star name. */ if break_pos = 0 then do; /* Skip parser over break char, and dispatch on it. */ pi.parse_position = pi.parse_position + 1; go to LITERAL_BREAK_BREAK (index (STAR_CHARS, substr (star_name, pi.parse_position, 1))); end; pi.parse_position = pi.parse_position + break_pos + 1; /* Skip parser over literal substring and following break. */ go to LITERAL_LITERAL_BREAK (index (STAR_CHARS, substr (star_name, pi.parse_position, 1))); /* If the last component is null, we may reject it. This was not an issue above since the trailing literal ensured a nonnull last component. For LITERAL_EXHAUSTED, trailing nonbreak characters ensure that a Dot can't be the final character. If a Dot is last, and we are checking a file system name, we reject it. Otherwise, we have a simpler state transition than on the preceding page. */ LITERAL_EXHAUSTED: /* Literal terminated by end of star name. */ if pi.parse_position = star_name_length then if DOT_LAST (pi.state) & ^cs.ignore_null then go to REJECT_NULL; /* Null final components forbidden in file names. */ pi.operations = END_OPS (pi.state); /* Set final comparison type. */ return; /* Go to final comparison. */ %page; /* Here we handle Dots. */ BREAK (1): /* Dot, with no literal under construction. */ pi.operations = DOT_OPS (pi.state); /* Update FSM. UNSPEC used for benefit of the following */ /* statement after -list and -long_profile. */ if substr (unspec (pi.operations), 1, 1) then go to DOT_ACTION (pi.comparison); /* If comparison is negative, then scanning may continue */ /* with one of the following three actions. Otherwise, */ /* we must return and perform the comparison first. */ return; DOT_ACTION (-1): /* Dot is part of Star construct (e.g., "*." or "**.") */ go to SCAN_NO_LITERAL; /* Find the NEXT break character. */ DOT_ACTION (-2): /* Dot is first character of star name or follows another */ if ^cs.ignore_null then go to REJECT_NULL; /* Dot immediately. Null components are forbidden in */ /* file system names and this may be enforced by the */ /* check_star_name_ entrypoints. */ DOT_ACTION (-3): /* Dot is first character of literal. */ pi.literal_position = pi.parse_position - 1; /* Remember that literal begins here, and includes Dot. */ pi.dot_count = 1; /* There is one Dot in this literal so far (this one). */ go to SCAN_LITERAL; /* Find the NEXT break character, if any. */ LITERAL_BREAK (1): /* Dot, preceded by one or more nobreak characters. */ pi.operations = DOT_OPS (HAVE_LITERAL (pi.state));/* Note existence of literal and that Dot is last. */ pi.dot_count = 1; /* This literal has one Dot in it (this one) so far. */ go to SCAN_LITERAL; /* Go scan some more. */ LITERAL_BREAK_BREAK (1): /* Dot, preceded by a literal Dot or invalid char. */ if DOT_LAST (pi.state) & ^cs.ignore_null then go to REJECT_NULL; /* Have ".." and null components are prohibited in filesys. */ LITERAL_LITERAL_BREAK (1): /* Dot, preceded by two or more nonbreak characters. */ pi.operations = DOT_OPS (pi.state); /* Remember that literal now ends in a Dot. */ pi.dot_count = pi.dot_count + 1; go to SCAN_LITERAL; /* Find NEXT break character. */ %page; /* Here we handle Stars. */ BREAK (2): /* Star, with no literal under construction. */ pi.operations = STAR_OPS (pi.state); /* Update FSM. UNSPEC used for benefit of the following */ /* statement after -list and -long_profile. */ if substr (unspec (pi.operations), 1, 1) then go to SCAN_NO_LITERAL; /* If comparison is negative (high bit set) then no */ /* comparison need be performed, and scanning continues. */ /* (Negative comparisons indicate that the star name has */ /* ended, which can't happen here.) */ go to JOIN_STAR; /* Otherwise, merge into return path. */ LITERAL_BREAK_BREAK (2): /* Star, preceded by a literal Dot or invalid char. */ if ^DOT_LAST (pi.state) then go to LITERAL_STAR; pi.operations = STAR_OPS (pi.state); /* We know that the last character was a Dot. */ pi.literal_length = pi.parse_position - pi.literal_position - 2; /* Compute literal length not to include the Dot and Star. */ pi.dot_count = pi.dot_count - 1; /* And uncount the Dot we removed. */ go to JOIN_STAR; /* Merge into return path. */ LITERAL_BREAK (2): /* Star, preceded by one or more nonbreak chars. */ pi.dot_count = 0; /* Literal has no Dots in it and never will. */ LITERAL_LITERAL_BREAK (2): /* Star, preceded by two or more nonbreak characters. */ LITERAL_STAR: /* Note we have a literal, which does not end in a Dot. */ pi.operations = STAR_OPS (HAVE_LITERAL (pi.state)); pi.literal_length = pi.parse_position - pi.literal_position - 1; /* Calculate length of literal, not to include the Star. */ JOIN_STAR: /* Do final accounting and exit. */ pi.compare_query_count = pi.parse_query_count; /* Tell compare routines about Queries, if any. */ pi.parse_query_count = 0; /* No Queries for next parse since break is a Star. */ return; /* Go to the comparison routine. */ %page; /* Here we handle Queries that are not immediately preceded by literals. In most cases, we can adjust the FSM state to note that the last character is a Query, increment the count of Queries, and continue parsing. In some cases, a comparison is required to simplify the state (e.g., turning "*.*?" into "*?"). */ BREAK (3): /* Query, with no literal under construction. */ pi.parse_query_count = pi.parse_query_count + 1; /* Count the query. */ pi.operations = QUERY_OPS (pi.state); /* Update FSM state. UNSPEC used here for next statement */ /* after examining -list file and -long_profile. */ if substr (unspec (pi.operations), 1, 1) then go to SCAN_NO_LITERAL; /* Indicates no comparison case. */ return; /* Go to the comparison routine. */ /* Needn't set pi.compare_query_count because the selected */ /* comparison will never check for Queries. */ /* Here we handle Queries that are immediately preceded by literals. In this case, it is always necessary to do a comparison, since the parser is gravid with state information and cannot continue. So we make all the preparations for a full blown comparison, including calculating the length of the literal (which is always nonzero) and making the old Query count available (which may be zero). The parser's internal Query count is set to one so that this Query need not be reparsed. */ LITERAL_BREAK (3): /* Query preceded by one or more nonbreak characters. */ pi.dot_count = 0; /* Literal has no Dots in it and never can. */ LITERAL_BREAK_BREAK (3): /* Query preceded by a literal Dot or invalid char. */ LITERAL_LITERAL_BREAK (3): /* Query preceded by two or more nonbreak characters. */ pi.operations = QUERY_OPS (HAVE_LITERAL (pi.state)); /* Arrange to invoke the correct comparison routine and */ /* update the FSM state for later. */ pi.literal_length = pi.parse_position - pi.literal_position - 1; /* Calculate length of literal string not to include Query. */ pi.compare_query_count = pi.parse_query_count; /* Copy count of leading Queries for compare routines. */ pi.parse_query_count = 1; /* Count this new Query for later. */ return; /* Go to the comparison routine. */ %page; /* We come here if we encounter an invalid break character. If we are matching, or checking with all invalid character tests disabled, then we just treat the invalid break as a literal character. Otherwise, we must identify the invalid break character, and reject it if so required. Because this is only required when checking star names, it could be argued that this might be better done outside the parser. This is faster, more compact, and perhaps illustrative of literal processing. */ BREAK (0): /* Invalid break, with no literal started yet. */ pi.literal_position = pi.parse_position - 1; /* Remember literal starts here, and includes invalid char. */ LITERAL_BREAK (0): /* Invalid break, preceded by one or more nonbreaks. */ pi.dot_count = 0; /* Constant has no Dots in it yet. */ LITERAL_BREAK_BREAK (0): /* Invalid break, preceded by a literal ending in a break. */ LITERAL_LITERAL_BREAK (0): /* Invalid break, preceded by two or more nonbreaks. */ pi.operations = END_OPS (pi.state); /* Set state to HAVE_LITERAL, which is folded into the */ /* END_OPS structure to save space. This assignment is */ /* more efficient than pi.state = HAVE_LITERAL (pi.state); */ if index (ENTRYPOINT_CHARS, substr (star_name, pi.parse_position, 1)) ^= 0 then do; if cs.ignore_entrypoint then go to SCAN_LITERAL; status = error_table_$bad_file_name; go to REJECT; end; if index (EQUAL_CHARS, substr (star_name, pi.parse_position, 1)) ^= 0 then do; if cs.ignore_equal then go to SCAN_LITERAL; status = error_table_$badequal; go to REJECT; end; if index (PATH_CHARS, substr (star_name, pi.parse_position, 1)) ^= 0 then do; if cs.ignore_path then go to SCAN_LITERAL; status = error_table_$bad_file_name; go to REJECT; end; REJECT_NULL: /* Here for null component or reserved characters. */ status = error_table_$null_name_component; REJECT: pi.comparison = MATCHES_ERROR; /* Set fatal comparison type. */ return; /* Go to fatal comparison routine. */ end parse; end match_star_name_;  nonlocal_goto_.alm 11/11/89 1144.7r w 11/11/89 0804.2 30816 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** " UNWINDER_UTIL_ - Utility Programs for the unwinder. " 9/20/72 - Noel I. Morris " partly recoded and generalized to work with given entry pointer " 5/17/73 - M. B. Weaver " modified to set stack ent pointer 3/10/78 - M. B. Weaver name nonlocal_goto_ include stack_header include stack_frame " " NEW_RING - Switch to another stack and "call" a specified procedure. " A stack frame representing a call to the procedure has been " manufactured in the target stack. This entry is called " when "calling" across stack segments. " " Calling sequence: " call nonlocal_goto_$different_ring (sp, entry_ptr) " " Where: " sp -> stack frame for procedure caller " " entry_ptr -> procedure entry to be called " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " entry different_ring different_ring: " the next 3 instructions must be first because we want " to take everything we need out of the current stack before " abandoning it in case we get a fault in the middle " eppbp ap|2,* bp -> current stack frame pointer eppbb ap|4,* bb -> location to transfer to eppsp bp|0,* sp -> new stack frame eppbp sb|stack_header.stack_begin_ptr,* reset the stack end ptr spribp sb|stack_header.stack_end_ptr abandon the current stack " now we would like to call the procedure in the higher ring; " however, since one cannot directly call into a higher ring " an rtcd instruction will be used, and pr7 will be set ahead of time " epbpsb sp|0 set sb to new stack header eppap sp|stack_frame.operator_ptr,* ldi 0,dl must reset overflow mask for pl1 rtcd bb|0 bye bye " " SAME_RING - Return to target stack frame. Target pointer " has been placed in stack_frame's return pointer. " Intended to be called by the unwinder_. " " Calling sequence: " call nonlocal_goto_$same_ring (sp, entry_ptr) " " Where: " sp -> target stack frame. " " entry_ptr -> procedure entry to be called " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " entry same_ring same_ring: eppbp ap|2,* bp -> current stack frame pointer eppbb ap|4,* bb -> location to transfer to epbpsb bp|0,* set sb to stack header eppap bp|0,* ap -> current (new) stack frame eppbp ap|stack_frame.next_sp,* bp -> new stack end inhibit on spribp sb|stack_header.stack_end_ptr reset stack end pointer eppsp ap|0 sp -> current stack frame inhibit off " we would now like to say "return" to invoke the normal return " macro. However, doing this would cause a transfer (cross-ring) " to the user-ring version of pl1_oerators_ to invoke the operator. " Instead, we just hand code the same instructions ... " except that we use the supplied entry ptr in stead of return ptr eppap sp|stack_frame.operator_ptr,* ldi 0,dl must reset overflow mask for pl1 rtcd bb|0 end  oc_trans_input_.pl1 11/11/89 1144.7rew 11/11/89 0804.2 87579 /****^ ****************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright (c) 1987 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * ****************************************************** */ /****^ HISTORY COMMENTS: 1) change(87-07-16,Farley), approve(87-07-17,MCR7735), audit(87-07-20,Fawcett), install(87-07-22,MR12.1-1044): Corrected handling of input escape sequences.. END HISTORY COMMENTS */ /* format: style2 */ oc_trans_input_: procedure (tptr, mnum, tlen, iptr, ilen); /* format: off */ /* Originally coded by Bill Silver July, 73. * Modified by N. I. Morris, March 1974 for ASCII input. * Modified by Bill Silver, May 1976 to fix EMC bugs. * BCD support expunged BIM 8/82. * * This procedure is called to transliterate an operator's console input string * into a canonicalized ASCII string. * * ASCII INPUT * * The ASCII string will be examined character by character. This will be done * with the help of a state transition table: "state_table". While we are converting * the input string we are always in one of three possible states. The ASCII * character set has been divided into five groups. For each group, depending upon * the current state, there is a routine which will process the current character. * * The three states are: * 1. DIRECT (D) The preceding character has no relationship to this character. * 2. ESCAPE (E) The preceding character was an escape character: "\". * 2. OCTAL (O) We are currently processing an octal escape sequence. * * The five character groups or types are: * 1. KILL The kill character "@". * 2. ERASE The erase character "#". * 3. ESCAPE The escape character "\". * 4. OCTAL The eight octal digits. * 5. OTHERS All other characters. * * The seven routines that can be used and the states that they return to are: * 1. (K) -> (D) KILL - kill the whole line. * 2. (E) -> (D) ERASE - delete the last character. * 3. (D) -> (D) DIRECT - convert directly from BCD to OCTAL. * 4. (SE) -> (E) SET ESCAPE - just switch to the escape (E) state. * 5. (CE) -> (D) CONVERT ESCAPE - convert to ASCII acording to escape mapping. * 6. (O) -> (O) OCTAL - convert one octal digit. * 7. (OE) -> (D) OCTAL END - end the octal conversion. * * A more symbolic representation of the state transition table "state_table": * * | KILL | ERASE | ESCAPE| OCTAL | OTHERS * __________|_______|_______|_______|_______|_______ * DIRECT | K | E | SE | D | D * __________|_______|_______|_______|_______|_______ * ESCAPE | CE | CE | CE | O | CE * __________|_______|_______|_______|_______|_______ * OCTAL | K | OE | OE | O | OE */ /* format: on */ /* PARAMETER DATA */ dcl tptr ptr, /* (I) Pointer to the translated ASCII string. */ mnum fixed bin, /* (I) Max num of ASCII chars caller will accept. */ tlen fixed bin, /* (O) Num of ASCII characters in translated string. */ iptr ptr, /* (I) Pointer to the INPUT (ASCII) string. */ ilen fixed bin; /* (I) Length of the INPUT string in characters. */ /* AUTOMATIC DATA */ dcl bindex fixed bin (35), /* Binary form of an ASCII character. */ charx fixed bin, /* character group number. */ icount fixed bin, /* The number of the input character being processed. */ ocount fixed bin, /* Num of octal digits processed for an ASCII char. */ statex fixed bin, /* state number. */ oct fixed bin, /* Used to build an ASCII char from octal input. */ temp_char char (1) aligned; /* Used to hold ASCII character. */ /* BASED DATA */ dcl tstring char (mnum) based (tptr); /* An overlay of the translated ASCII string. */ dcl astring char (80) based (iptr) unal; /* Used to reference the input ASCII string. */ dcl (byte, max, rank, substr) builtin; /* INTERNAL STATIC DATA */ /* This is the state transition table. There are 3 states and 5 character * types. For each state and character type there is a number which represents * a routine which will process that combination. */ dcl state_table (3, 5) fixed bin internal static options (constant) init ( /** */ 1, 2, 4, 3, 3, /* STATE 1 */ 5, 5, 5, 6, 5, /* STATE 2 */ 1, 7, 7, 6, 7); /* STATE 3 */ /* This table contains the character types. */ dcl char_types (0:127) fixed bin (8) unaligned internal static options (constant) init ( /** **/ 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, /* 000 - 017 */ 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, /* 020 - 037 */ 5, 5, 5, 2, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, /* 040 - 057 */ 4, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 5, 5, 5, /* 060 - 077 */ 1, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, /* 100 - 117 */ 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 3, 5, 5, 5, /* 120 - 137 */ 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, /* 140 - 157 */ 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5); /* 160 - 177 */ tlen, icount = 0; /* Initialize counters. */ statex = 1; /* Start out in DIRECT state. */ call RESET_OCTAL; LOOP: /* Each iteration of loop will process 1 char. */ if (tlen = mnum) | /** Have we got all caller wants (less new line)? */ (icount = ilen) /* Have we got all there is? */ then goto END_OF_TRANS; /* YES. */ icount = icount + 1; /* Work on next character. */ temp_char = substr (astring, icount, 1); bindex = rank (temp_char); charx = char_types (bindex); /* Get appropriate character type code. */ /* Using state transition table go to correct routine for this character type * and current state. */ goto ACTION (state_table (statex, charx)); /* We come here when we have finished processing the input string. * We have to do two more tasks: * 1. Strip off all white space (blanks and tabs) from the end of the translated * ASCII string. * 2. Put a new line character at the end of the ASCII string. */ END_OF_TRANS: STRIP_LOOP: /* Each iteration processes one ASCII character. */ if tlen = 0 /* Check for null string. */ then goto ADD_NEW_LINE; if (substr (tstring, tlen, 1) ^= " ") & /** If not a blank or tab. */ (substr (tstring, tlen, 1) ^= " ") then goto ADD_NEW_LINE; /* Then we are all done stripping. */ tlen = tlen - 1; /* Delete this white space character. */ goto STRIP_LOOP; /* Process next character at end of string. */ ADD_NEW_LINE: tlen = tlen + 1; /* Add new line at end of string. */ substr (tstring, tlen, 1) = " "; return; /* Now we are all done. */ ACTION (1): /* KILL */ tlen = 0; /* Delete all the ASCII characters. */ statex = 1; /* Now in DIRECT state. */ call RESET_OCTAL; goto LOOP; ACTION (2): /* ERASE */ tlen = max (tlen - 1, 0); /* Delete last translated char, never go below zero. */ statex = 1; /* Now in DIRECT state. */ call RESET_OCTAL; goto LOOP; ACTION (3): /* DIRECT */ call SET_CHAR; /* Place character directly in output. */ goto LOOP; ACTION (4): /* SET ESCAPE */ statex = 2; /* Go to escape state. */ goto LOOP; ACTION (5): /* CONVERT ESCAPE */ statex = 1; /* Go to direct state. */ if (charx ^= 5) /* a special character. */ then call SET_CHAR; /* just copy it. */ else do; temp_char = "\"; /* insert leading ESCAPE */ call SET_CHAR; temp_char = substr (astring, icount, 1); /* now add character. */ call SET_CHAR; end; goto LOOP; ACTION (6): /* OCTAL */ statex = 3; /* Go to octal state. */ /* Shift octal digits left one place and * add new digit in low order position. */ oct = (oct * 8) + (bindex - rank ("0")); ocount = ocount + 1; /* Up count of octal digits processed. */ if ocount = 3 /* Is this the third and last octal digit? */ then do; /* YES. */ call SET_OCTAL; /* Now we can set up the ASCII character. */ statex = 1; /* Leave octal state. */ end; goto LOOP; /* Go process the next character. */ ACTION (7): /* OCTAL END */ call SET_OCTAL; /* Use all the digits we have. */ statex = 1; /* Go back to direct state. */ icount = icount - 1; /* Last char not really processed - try again. */ goto LOOP; SET_CHAR: procedure; /* This procedure is called to move one character into * the output string. */ tlen = tlen + 1; substr (tstring, tlen, 1) = temp_char; end SET_CHAR; SET_OCTAL: procedure; /* This procedure is called to set up one ASCII character from the octal digits * that have been put into "oct". */ tlen = tlen + 1; /* Build the translated ASCII character from * the three octal digits we have. */ temp_char = byte (oct); substr (tstring, tlen, 1) = temp_char; /* Then into translated string. */ call RESET_OCTAL; /* Make sure everything is reset. */ end SET_OCTAL; RESET_OCTAL: procedure; /* This procedure is called to reset the octal work array and the octal count. */ oct = 0; ocount = 0; end RESET_OCTAL; end oc_trans_input_;  ondata_.alm 11/11/89 1144.7r w 11/11/89 0804.2 34164 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** " " ondata_ " " " static stuff for condition handlers within PL/1 procedures " " P.A.Belmont " 5-29-70 " updated by P.A.Belmont 2-17-72 " As of 2/72 a single bound segment is to house " all of the PL/I signalling stuff. This ONDATA_ " will be a part of it as will pl1_signal_, " used for signalling all PL/I conditions, and " default_pl1_handler, the handler for all PL/I " conditions. Since version 1 and version 2 " PL/I I/O must co-exist for an indefinite time, " the mechanisms of pl1_signal_ and default_pl1_handler " will be . . . . . obscure " updated by M. Weaver 12/28/73 to remove segdefs for handler " name ondata_ " segdef ondatalength segdef fileptr segdef onfile,datafield,oncharindex,onsource,onkey,onloc segdef oncode,condition_name segdef scratchfileptr " " " " " use linkc join /link/linkc " even " " " " ondatalength: vfd 18/0,18/endondata-ondatalength dec 0 " **************************************************************** fileptr: its -1,1 " points to the "file", i.e., to (FAB1p,FSBp) " this is the file associated with the ONFILE below " which changes only for file-related conditions (FR=1) " " **************************************************************** scratchfileptr: its -1,1 " if I/O routine leaves a fileptr here, it should " remove it (null it) when it is no longer required. " This scratch fileptr will identify the associated file " when the conversion package is called. A strategy for " "cleaning up" this scratch fileptr will ultimately be needed. " " **************************************************************** datafield: dec 0 bss datafieldstr,64 " datafield - bad identifier in GET DATA statement " **************************************************************** " onfile: dec 0 bss onfilestr,8 " " onfile - filename " **************************************************************** onloc: dec 0 bss onlocstr,73 " " onloc - name, as characterstring, of faulting procedure /* ?? */ " allowing a name of the form "32"$"256" " **************************************************************** onsource: dec 0 bss onsourcestr,64 " onsource - bad string causing CONVERSION ERROR aci " " " the unused value of onchar is blank " this is the blank: see that oncharindex is 260 initially " **************************************************************** " onkey: dec 0 bss onkeystr,64 " onkey - bad key or key involved in bad something else " **************************************************************** " oncharindex: dec 260 " oncharindex - index in onsourcestr of the offending character " **************************************************************** " oncode: dec 0 " oncode - Multics PL/1 error code /* not assigned */ " **************************************************************** " condition_name: dec 0 bss condition_namestr,8 " the name of the last condition signalled by pl1_signal_ or friends " **************************************************************** " endondata: dec 0 bss padding,75 " " when changing the length of ondata_ " also change wherever save_ondata is declared. " (pl1_signal_, plio1_..., plio2_... ) " " " " end  picture_info_.pl1 11/11/89 1144.7rew 11/11/89 0804.2 119493 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style2 */ /* Modified 831010 BIM to initialize strings */ picture_info_: proc (string, info_pt, error_code); dcl string char (*), info_pt ptr, error_code fixed bin; dcl (i, j, n, count, indx, number, value) fixed bin, state fixed bin init (1), (switch, minus_bit) bit (1) aligned init ("0"b), char char (1) aligned, sign3 char (3) aligned init ("s+-") int static options (constant), test_string char (64) var init (""), normalized_string char (64) var init (""); dcl picture_char char (32) aligned init ("axek9yvz*$+-scrdb.,/") int static options (constant); dcl digit char (10) aligned init ("1234567890") int static options (constant); dcl (divide, index, length, mod, substr) builtin; dcl 1 picture_constant aligned based (info_pt) like picture_image; picture_constant.type, picture_constant.scalefactor, picture_constant.explength, error_code, number, n, value = 0; do i = 1 to length (string); char = substr (string, i, 1); goto pl (state); pl (1): if char = "(" then do; state = 2; goto next; end; if char = "f" then do; state = 5; goto next; end; value = 1; pl (4): indx = index (picture_char, char); if indx = 0 then goto err440; if indx = 4 | indx = 7 /* k and v does not count in the picture */ then number = number + 1; if indx < 3 then picture_constant.type = char_picture; else if indx < 5 then picture_constant.type = real_float_picture; switch = "1"b; /* we have at least one picture character */ do j = 1 to value; normalized_string = normalized_string || char; end; if indx < 17 then do j = 1 to value; test_string = test_string || char; end; n = n + value; state = 1; value = 0; goto next; pl (2): indx = index (digit, char); if indx = 0 then goto err440; value = value * 10 + mod (indx, 10); state = 3; goto next; pl (3): if char = ")" then do; state = 4; goto next; end; goto pl (2); pl (5): if char = "(" then do; state = 6; goto next; end; goto err440; pl (6): if char = "+" then do; state = 7; goto next; end; if char = "-" then do; state = 7; minus_bit = "1"b; goto next; end; pl (7): indx = index (digit, char); if indx = 0 then goto err440; value = value * 10 + mod (indx, 10); state = 8; goto next; pl (8): if char = ")" then do; if i ^= length (string) then goto err440; if value > 255 | value > 256 & ^minus_bit then goto err434; if minus_bit then value = -value; picture_constant.scalefactor = value; goto next; end; goto pl (7); next: end; if ^switch then goto err440; if n - number > 63 then goto err414; if picture_constant.type = 0 then picture_constant.type = real_fixed_picture; picture_constant.prec, picture_constant.scale = 0; picture_constant.varlength = n - number; picture_constant.piclength = n; picture_constant.drift_character = " "; picture_constant.chars = normalized_string; if picture_constant.type = char_picture then do; if verify (substr (normalized_string, 1, n), "9ax") ^= 0 then goto err457; picture_constant.prec = n; return; end; if picture_constant.type = real_float_picture then do; i = 0; state = 1; n = length (test_string); switch = "0"b; fl: i = i + 1; if i > n then do; picture_constant.explength = count; return; end; char = substr (test_string, i, 1); goto ll (state); ll (1): indx = index (sign3, char); if indx ^= 0 then do; state = 2; goto fl; end; ll (2): if ^digit_positions (i) then do; i = 1; goto ll (3); end; state = 4; goto fl; ll (3): if ^drifting_sign (i) then goto err458; state = 4; goto fl; ll (4): if char ^= "e" & char ^= "k" then goto err458; count = 0; state = 5; goto fl; ll (5): state = 6; indx = index (sign3, char); if indx ^= 0 then goto fl; ll (6): count = count + 1; if count > 3 then goto err458; if char = "9" then do; switch = "1"b; goto fl; end; if char = "z" then if switch then goto err458; else goto fl; goto err458; end; if picture_constant.type = real_fixed_picture then do; n = length (test_string); if fixed_field () then return; if drifting_field () then return; goto err459; end; return; fixed_field: proc () returns (bit (1) aligned); dcl (digit_position, dollar, sign) bit (1) aligned init ("0"b); i = 0; fx: i = i + 1; if i > n then if ^digit_position then goto fx_ret0; else goto fx_ret1; char = substr (test_string, i, 1); if char = "$" then do; if dollar then goto fx_ret0; dollar = "1"b; goto fx; end; if index (sign3, char) ^= 0 then do; if sign then goto fx_ret0; sign = "1"b; goto fx; end; if digit_positions (i) then do; if digit_position then goto fx_ret0; digit_position = "1"b; goto fx; end; if char = "c" & substr (test_string, i + 1, 1) = "r" | char = "d" & substr (normalized_string, picture_constant.piclength, 1) = "b" then do; if sign then goto fx_ret0; if char = "d" & i = n then goto fx_ret1; if i + 1 ^= n then goto fx_ret0; goto fx_ret1; end; fx_ret0: return ("0"b); fx_ret1: return ("1"b); end; digit_positions: proc (i) returns (bit (1) aligned); dcl c char (1) aligned init (""); dcl (i, k) fixed bin; do k = i to n while (index ("z*", substr (test_string, k, 1)) = 0); end; if k <= n then c = substr (test_string, k, 1); if digit_v_digit (i) then if number >= 1000 | mod (number, 100) ^= 0 then goto dp_ret1; if c = "" then goto dp_ret0; if sandwich (c, i) then if mod (number, 100) ^= 0 then goto dp_ret1; else do; picture_constant.prec = divide (number, 1000, 15, 0); if substr (test_string, i, 1) = c then ; else i = i - 1; end; else goto dp_ret0; i = i + 1; if ^digit_v_digit (i) then i = i - 1; goto dp_ret1; dp_ret0: return ("0"b); dp_ret1: picture_constant.scale = mod (number, 100); picture_constant.prec = picture_constant.prec + divide (number, 1000, 15, 0) + picture_constant.scale; /* i = k-1; purposely deleted */ return ("1"b); end; drifting_field: proc () returns (bit (1) aligned); dcl (dr_dollar, dr_sign, dollar, sign) bit (1) aligned init ("0"b); i = 0; state = 1; df: i = i + 1; if i > n then if dr_sign | dr_dollar then goto df1; else goto df0; char = substr (test_string, i, 1); goto dfl (state); dfl (1): if char = "$" then do; if dollar then goto df0; dollar = "1"b; state = 2; goto df; end; dfl (2): if drifting_sign (i) then do; if dr_sign then goto df0; dr_sign = "1"b; state = 1; goto df; end; i = 1; state = 3; dfl (3): if index (sign3, char) ^= 0 then do; if sign then goto df0; sign = "1"b; state = 4; goto df; end; dfl (4): if drifting_dollar (i) then do; if dr_dollar then goto df0; dr_dollar = "1"b; state = 3; goto df; end; dfl (5): if char = "c" & substr (test_string, i + 1, 1) = "r" | char = "d" & substr (normalized_string, picture_constant.piclength, 1) = "b" then do; if sign then goto df0; if char = "d" & i = n then goto df1; if i + 1 ^= n then goto df0; goto df1; end; df0: return ("0"b); df1: return ("1"b); end; drifting_sign: proc (i) returns (bit (1) aligned); dcl c char (1) aligned; dcl (i, k) fixed bin; do k = i to n while (index (sign3, substr (test_string, k, 1)) ^= 0); end; if k >= 3 then c = substr (test_string, 1, 1); else goto ds0; if sandwich (c, i) then if number >= 1000 then if mod (number, 100) ^= 0 then goto ds1; else if substr (test_string, i, 1) = c then i = i - divide (number, 1000, 15, 0) + 1; else i = i - divide (number, 1000, 15, 0); else i = i - mod (number, 100); if ^signs (i) then goto ds0; picture_constant.prec = count; i = i + 1; if ^digit_v_digit (i) then i = i - 1; goto ds1; ds0: return ("0"b); ds1: /* i = k-1; purposely deleted */ picture_constant.scale = mod (number, 100); picture_constant.prec = picture_constant.prec + divide (number, 1000, 15, 0) + picture_constant.scale - 1; picture_constant.drift_character = c; return ("1"b); end; drifting_dollar: proc (i) returns (bit (1) aligned); dcl (i, k, count) fixed bin; number, count = 0; state = 1; k = i - 1; dd_next: k = k + 1; if k > n then goto ddl1; char = substr (test_string, k, 1); goto ddl (state); ddl (1): if char = "$" then do; state = 2; goto dd_next; end; goto ddl0; ddl (2): if char = "$" then do; count = count + 1; state = 3; goto dd_next; end; if char = "v" then do; state = 5; goto dd_next; end; goto ddl0; ddl (3): if char = "$" then do; count = count + 1; goto dd_next; end; if digit_v_digit (k) then do; if number = 100 then state = 5; else state = 4; goto dd_next; end; ddl (4): goto ddl1; ddl (5): if char = "$" then do; state = 6; picture_constant.scale = picture_constant.scale + 1; goto dd_next; end; goto ddl0; ddl (6): if char = "$" then do; picture_constant.scale = picture_constant.scale + 1; goto dd_next; end; goto ddl1; ddl0: return ("0"b); ddl1: i = k - 1; picture_constant.scale = picture_constant.scale + mod (number, 100); picture_constant.prec = divide (number, 1000, 15, 0) + count + picture_constant.scale; picture_constant.drift_character = "$"; return ("1"b); end; digits: proc (i) returns (bit (1) aligned); dcl (i, k) fixed bin; count = 0; do k = i to n; char = substr (test_string, k, 1); if char = "9" | char = "y" then count = count + 1; else goto digits_return; end; digits_return: if count = 0 then return ("0"b); i = k - 1; return ("1"b); end; signs: proc (i) returns (bit (1) aligned); dcl (i, k) fixed bin; dcl c char (1) aligned; count = 0; do k = i to n; char = substr (test_string, k, 1); indx = index (sign3, char); if indx ^= 0 then if count = 0 then do; count = 1; c = char; end; else if c ^= char then goto signs_return; else count = count + 1; else goto signs_return; end; signs_return: if count < 2 then return ("0"b); i = k - 1; return ("1"b); end; digit_v_digit: proc (i) returns (bit (1) aligned); dcl (i, k) fixed bin; number = 0; state = 1; k = i - 1; dvd: k = k + 1; if k > n then goto dvd_ret1; char = substr (test_string, k, 1); goto dvdl (state); dvdl (1): if digits (k) then do; number = 1000 * count; state = 2; goto dvd; end; dvdl (2): if char = "v" then do; number = number + 100; state = 3; goto dvd; end; if state ^= 1 then goto dvd_ret1; return ("0"b); dvdl (3): if digits (k) then do; number = number + count; state = 4; goto dvd; end; dvdl (4): goto dvd_ret1; dvd_ret1: i = k - 1; return ("1"b); end; sandwich: proc (c, i) returns (bit (1) aligned); dcl c char (1) aligned; dcl (i, k) fixed bin; number = 0; state = 1; k = i - 1; sand: k = k + 1; if k > n then goto sand_ret1; char = substr (test_string, k, 1); goto sandl (state); sandl (1): if char = c then do; number = number + 1000; goto sand; end; if char = "v" then do; state = 2; number = number + 100; goto sand; end; if number ^= 0 then goto sand_ret1; return ("0"b); sandl (2): if char = c then do; number = number + 1; goto sand; end; goto sand_ret1; sand_ret1: i = k - 1; return ("1"b); ; end; err414: error_code = 414; return; err434: error_code = 434; return; err440: error_code = 440; return; err457: error_code = 457; return; err458: error_code = 458; return; err459: error_code = 459; return; %include picture_image; %include picture_types; end picture_info_;  pl1_signal_.pl1 11/11/89 1144.7rew 11/11/89 0804.2 71154 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(87-05-21,RBarstad), approve(87-07-13,MCR7710), audit(87-05-21,GDixon), install(87-08-04,MR12.1-1055): Add quit_info structure if quit condition. END HISTORY COMMENTS */ pl1_signal_: proc options(support); /* This procedure is called to signal all pl1 conditions. It was originally coded by P. A. Belmont and also contained a default handler for the pl1 conditions. It was recoded by M. Weaver 12/27/73 to delete the handler portion and the entry for version 1 programs and to call signal_ with the new structure for pl1 conditions. The old method of storing ondata in an external data base must also be maintained temporarily for compatibility. */ /* Modified April 81 Benson I. Margulies for quiet_restart of stringsize */ /* Modified Febrary 84 Tom Oke to accept 415 code (invalid or unimp conversion) from any_to_any_. */ %page; dcl psp ptr; dcl (fsbp, file_p, fabptr) ptr; dcl based_ptr ptr based; dcl cond_ptr ptr; dcl tc256v char(256) var; dcl cname char(*); dcl conname char(32); dcl where char(4) aligned; dcl vchar256 char(256) var; dcl vchar256p char(256) var; dcl filename33 char(33) aligned; dcl based_bit bit(36) aligned based; dcl tc256vsw fixed bin; dcl (codex, code) fixed bin(35); dcl (file_related, numb, numbp, j) fixed bin; dcl save_ondata_based(ondata_$ondatalength) fixed bin(35) based; dcl save_ondata(300) fixed bin(35); dcl (addr, index, size, substr, null, unspec) builtin; dcl signal_ entry options(variable); dcl pl1_signal_$help_plio2_signal_ entry(char(*), ptr, fixed bin(35), char(256) var, fixed bin); dcl cleanup condition; dcl 1 v2fab aligned based, 2 sw bit(36), 2 name char(32); declare 1 auto_pl1_info aligned like pl1_info automatic; dcl 1 pl1_quit_info aligned like quit_info; dcl TRUE bit(1) int static options (constant) init ("1"b); %page; return; /* this entry used to be for area */ math_error_: entry (code); where = "math"; pl1_info_ptr = addr (auto_pl1_info); codex = code; if codex < 1 | codex > 100 then go to bad_oncode; file_p = null; file_related = 0; conname = "error"; go to copy_ondata; pl1_signal_from_ops_: entry (cname256, cnamelen, qualifier, code, fileaddr); /* format:off */ /* oncode usage: 1000 - signal statement 415 - invalid or unimp 701 - stringrange 702 - stringsize 703 - size 704 - subscriptrange 710 - undefined pl1_operator_ */ /* format:on */ dcl (fileaddr, qualifier) ptr; dcl cname256 char(256) unaligned; dcl cnamelen fixed bin; pl1_info_ptr = addr (auto_pl1_info); numb = 1; vchar256 = ""; file_p = fileaddr; codex = code; if (codex < 701 & codex ^= 415) | codex > 1000 then go to bad_oncode; conname = substr(cname256, 1, cnamelen); where = "ops "; go to copy_ondata; help_plio2_signal_: entry(cname, qualifier, code, vchar256p, numbp); pl1_info_ptr = addr (auto_pl1_info); vchar256 = vchar256p; numb = numbp; if code = -1 then codex = 600; /* stringsize sends the code -1 */ else codex = code + 200; /* convention to place the version 2 oncodes in the range 301 - 600 */ if codex < 301 | codex > 600 then go to bad_oncode; where = "ver2"; conname = cname; /* ASSERT that qualifier = addr(PS) */ if qualifier = null then fsbp = null; else do; fsbp = qualifier -> ps.fsbp; if cname ^= "undefinedfile" /* protect open statements */ then if qualifier -> ps.job.string then fsbp = null; /* since job bits are trash for open statements */ end; if fsbp ^= null then file_p = qualifier -> ps.file_p; /* if file_p ^= null then status_code = fsbp->fsbr.lnzc */ else file_p = null; go to copy_ondata; pl1_ops_join: cond_ptr = null; if numb = -1 | (conname = "key" & where = "ops ") then do; pl1_info.onkey_sw = "1"b; ondata_$onkey, pl1_info.onkey_onfield = vchar256; end; if conname = "stringsize" then pl1_info.action_flags.quiet_restart = "1"b; if conname = "conversion" then do; ondata_$onsource, pl1_info.onsource = vchar256; ondata_$oncharindex = numb + 3; /* 1st char becomes offset 4 in var char string */ pl1_info.oncharindex = numb; /* newer routines use substr */ pl1_info.onsource_sw, pl1_info.onchar_sw = "1"b; end; else if conname = "name" then do; pl1_info.onkey_onfield, ondata_$datafield = vchar256; pl1_info.onfield_sw = "1"b; end; if file_p ^= null then file_related = 2; else file_related = 0; if conname = "endpage" /* see if we need a file */ | conname = "endfile" | conname = "transmit" | conname = "record" | conname = "undefinedfile" | conname = "name" | conname = "key" then do; file_related = 1; /* must have a file */ if file_p = null then call pl1_signal_$help_plio2_signal_ ("error", null, 169, "", 0); /* 169 + 200 = 369 - a v2 error code */ /* no one should restart this */ ondata_$fileptr = file_p; /* preserve old fileptr unless have new one */ pl1_info.file_ptr_sw = "1"b; pl1_info.file_ptr = file_p; end; signal_it: if (conname = "quit") then do; cond_ptr = addr (pl1_quit_info); /* special info for quit */ unspec(pl1_quit_info) = "0"b; pl1_quit_info.header.length = size (pl1_quit_info); pl1_quit_info.header.version = condition_info_version_1; pl1_quit_info.switches.ips_quit = TRUE; /* this is the important switch */ end; else do; /* as before */ cond_ptr = addr(pl1_info); ondata_$oncode, pl1_info.oncode = codex; pl1_info.oncode_sw = "1"b; if file_related = 1 | (file_related = 2 & conname = "conversion") then do; fabptr = file_p -> based_ptr; filename33 = fabptr -> v2fab.name; j = index(filename33, " "); ondata_$onfile, pl1_info.onfile = substr(filename33, 1, j-1); pl1_info.onfile_sw = "1"b; end; ondata_$condition_name = conname; ondata_$onloc = "?"; /* don't set for old procs--make them recompile */ pl1_info.length = size(pl1_info); pl1_info.version = 1; pl1_info.info_string = ""; pl1_info.status_code = 0; pl1_info.id = "pliocond"; end; call signal_(conname, null, cond_ptr); /* signal at last */ if conname = "conversion" then if where = "ver2" then vchar256p = ondata_$onsource; call restoreondata(); return; copy_ondata: addr(pl1_info.action_flags) -> based_bit, addr(pl1_info.content_flags) -> based_bit = "0"b; addr(save_ondata) -> save_ondata_based = addr(ondata_$fileptr) -> save_ondata_based; on cleanup call restoreondata(); if where = "math" then go to signal_it; go to pl1_ops_join; bad_oncode: call pl1_signal_$help_plio2_signal_ ("error", null, 174, "", 0); return; /* illegal oncode value */ restoreondata: proc; if ondata_$condition_name ^= "conversion" then do; tc256v = ondata_$onsource; tc256vsw = 1; end; else tc256vsw = 0; addr(ondata_$fileptr) -> save_ondata_based = addr(save_ondata) -> save_ondata_based; if tc256vsw = 1 then ondata_$onsource = tc256v; end; %page; %include condition_info; %page; %include condition_info_header; %page; %include pl1_info; %page; %include quit_info; %page; %include on_data_; %page; %include plio2_ps; end;  pl1_signal_conversion_.pl1 11/11/89 1144.7rew 11/11/89 0804.2 13644 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /* format: style2 */ pl1_signal_conversion_: proc (pspp, msg, erno, chp, n1, n2, n3) options (support); /* DECLARATION */ dcl (n1, n2, n3, oncharind) fixed bin (15); dcl (addr, substr) builtin; dcl msg char (*); dcl CN char (20) aligned; dcl erno fixed bin (15); dcl (pspp, chp) ptr; dcl based_chars char (1044480) based; dcl onsource char (256) varying; dcl pl1_signal_$help_plio2_signal_ ext entry (char (*), ptr, fixed bin (15), char (256) varying, fixed bin (15)); CN = "conversion"; /* pspp is always null for this call */ oncharind = 0; onsource = ""; if n1 > n2 | n3 < n1 | n3 > n2 then /* illegal substr */ call pl1_signal_$help_plio2_signal_ ("error", null (), 116, "", 0); onsource = substr (chp -> based_chars, n1, n2 + 1 - n1); oncharind = n3 - n1 + 1; call pl1_signal_$help_plio2_signal_ ((CN), pspp, erno, onsource, oncharind); substr (chp -> based_chars, n1, n2 + 1 - n1) = onsource; return; end pl1_signal_conversion_;  requote_string_.pl1 11/11/89 1144.7r w 11/11/89 0804.2 18090 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ requote_string_: proc (instring) returns (char (*)); /* How difficult is PL/I for character string manipulation */ /* B. Greenberg 5/31/77 */ /* E. N. Kittlitz. added quote_string entry. */ dcl instring char (*); dcl outstringl fixed bin (21); dcl QUOTE char (1) static init ("""") options (constant); dcl QUOTEQUOTE char (2) static init ("""""") options (constant); dcl outstring char (2 * length (instring) + 2); dcl (i, j) fixed bin (21); dcl requote_sw bit (1) aligned; dcl (index, length, substr) builtin; requote_sw = "1"b; outstringl = 1; substr (outstring, 1, 1) = QUOTE; i = 1; nextj: j = index (substr (instring, i), QUOTE); if j = 0 then do; substr (outstring, outstringl + 1, length (instring) - i + 1) = substr (instring, i); outstringl = outstringl + length (instring) - i + 1; if requote_sw then do; outstringl = outstringl + 1; substr (outstring, outstringl, 1) = QUOTE; end; return (substr (outstring, 1, outstringl)); end; substr (outstring, outstringl + 1, j - 1) = substr (instring, i, j - 1); outstringl = outstringl + j; substr (outstring, outstringl, 2) = QUOTEQUOTE; outstringl = outstringl + 1; i = i + j; go to nextj; quote_string: entry (instring) returns (char (*)); requote_sw = "0"b; outstringl = 0; i = 1; go to nextj; end;  sct_manager_.pl1 11/11/89 1144.7r w 11/11/89 0804.2 34353 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4,insnl,delnl,ifthendo */ sct_manager_$call_handler: proc (mcptr, cname, info_ptr, wc_ptr, continue) options (support); /* This procedure manages the SCT (System Condition Table). Entries are provided for setting and getting the value of an entry in the SCT. (An entry in the SCT is merely a procedure entry pointer.) An entry is also provided for use by the signal_ procedure to call to check if a particular condition has a static handler enabled. Static handlers are not general and should be used with caution. Initial coding: 4/75 S. Webber Modified July 1981 Benson I. Margulies to set the support bit. Modified September 1981 Benson I. Margulies for info_ptr. */ /* Parameters */ dcl continue bit (1) aligned; dcl code fixed bin (35); dcl cname char (*); /* condition name */ dcl (info_ptr, wc_ptr) ptr; dcl mcptr ptr; /* pointer to machine conditions passed from signal_ */ dcl handler ptr; /* entry pointer for handler being set */ dcl fcode fixed bin; /* FIM fault code, used to index into SCT */ /* Automatic */ dcl entry_variable entry (pointer, character (*), pointer, pointer, bit (1) aligned) variable; dcl sp ptr; dcl sct_ptr ptr; /* Based */ dcl 1 entry aligned, 2 ep ptr, 2 environment ptr; dcl ptr_array (0:127) ptr unaligned based; /* External */ dcl error_table_$argerr fixed bin (35) external; /* Constants */ dcl (addr, baseptr, bin, hbound, null, ptr, unspec) builtin; %include stack_header; %include mc; /* Entry to call_handler entry */ call get_sct_ptr; /* get SCT pointer from stack header */ if sct_ptr = null then goto no; if unspec (sct_ptr -> ptr_array (bin (mcptr -> mc.fcode, 17))) = "0"b then do; no: continue = "1"b; /* return so stack will be searched */ return; end; if sct_ptr -> ptr_array (bin (mcptr -> mc.fcode, 17)) = null then goto no; entry.ep = sct_ptr -> ptr_array (bin (mcptr -> mc.fcode, 17)); entry.environment = null; unspec (entry_variable) = unspec (entry); /* Legal PL/1 ! */ call entry_variable (mcptr, cname, info_ptr, wc_ptr, continue); /* call the handler, it sets continue */ return; /**** Entry to set entry */ set: entry (fcode, handler, code); call get_sct_ptr; /* get SCT pointer from stack header */ if sct_ptr = null then goto badx; if fcode < 0 | fcode > hbound (sct_ptr -> ptr_array, 1) then do; badx: code = error_table_$argerr; return; end; sct_ptr -> ptr_array (fcode) = handler; code = 0; return; /* */ /* Entry to get entry */ get: entry (fcode, handler, code); call get_sct_ptr; /* get SCT pointer from stack header */ if sct_ptr = null then goto badx; if fcode < 0 | fcode > hbound (sct_ptr -> ptr_array, 1) then goto badx; handler = sct_ptr -> ptr_array (fcode); if unspec (handler) = ""b then handler = null (); code = 0; return; get_sct_ptr: proc; /* subroutine to get SCT pointer from stack header */ sct_ptr = stackbaseptr () -> stack_header.sct_ptr;/* extract SCT pointer */ return; end; end sct_manager_$call_handler;  signal_.pl1 11/11/89 1144.7rew 11/11/89 0804.2 217836 /****^ ****************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright (c) 1987 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * ****************************************************** */ /* This procedure implements the Multics PL/1 condition handling mechanism. This procedure is called with the name of a condition and searches back up the condition stack which is embedded in the standard Multics stack until a handler for the condition is found. This handler is then invoked. If the beginning of the stack is reached, a new stack frame is built at the end of the calling ring's stack and the unwinder is called to repeat the above process. Modified on November 14, 1971 by R. J. Feiertag to handle special conditions. */ /* Modified on January 13, 1972 by R. J. Feiertag */ /* Recoded on September 14, 1972 for the 645F by Noel I. Morris */ /* Modified July 1973 by M. Weaver for any_other, new stack frame flags, and to use nonlocal_goto_ */ /* Modified October 1973 by M. Weaver to re-separate the unwinder, process pl1 snap and system, eliminate special handlers, make use of the new pl1 info structure for I/O conditions and copy more stuff on crawlouts Modified 4/75 by S. Webber to add static handler code Emergency fix 760427 by PG to initialize continue flag before calling static handlers. Modified 7/14/76 by Noel I. Morris for virtual time metering Modified 6/76 by D. Vinograd to more correctly determine if fault occured in fim stack frame. Modified 1/26/81 by J. A. Bush to set up any_other condition handler for stack access problems Modified April 2 1981 Benson I. Margulies to special case null_pointer_ versus simfault_nnnnnn. This code can be removed for MR10 or 11. The special case consists of the flag null_pointer_condition and code in the proc found_specific_condition. Modified September 1981 by Benson I. Margulies for: 1) passing info_ptr to static handler 2) continue_to_signal_ for static handlers. Modified '82 BIM for any_other handler while running. */ /****^ HISTORY COMMENTS: 1) change(87-02-13,Farley), approve(87-04-15,MCR7665), audit(87-04-20,Lippard), install(87-04-28,MR12.1-1028): (phx20748) Changed to revert the any_other handler before calling crawlout_default_handler_ so that any recursive calls that it makes back to us will not invoke our any_other handler. 2) change(87-04-15,Farley), approve(87-04-15,MCR7665), audit(87-04-20,Lippard), install(87-04-28,MR12.1-1028): Changed to continue to the previous stack frame after handling a specific condition and the handler wishes to continue to signal. The any_other condition handler, when defined, was being called erroneously. END HISTORY COMMENTS */ /* format: style2 */ signal: signal_: procedure (a_name, a_mcptr, a_info_ptr, a_wcptr); static_okay = "1"b; go to common; dcl a_name char (*), /* condition being signalled */ a_info_ptr ptr, /* information about software signal */ a_wcptr ptr, /* info about wall crossing from this ring before crawlout */ a_mcptr ptr; /* optional machine conditions ptr */ dcl mcptr ptr, /* pointer to machine conditions */ info_ptr ptr, /* pointer to software signal info */ wcptr ptr, /* pointer to wall crossing mc */ condition_name char (32), /* local copy of condition being signalled */ l_name fixed bin, /* length of condition name */ loops fixed bin init (0),/* count of separate stack frames found */ ou_count fixed bin, /* count of on units in thread */ code fixed bin (35), /* status code for unwind_stack_ */ onlistp ptr, /* pointer to on condition unit in stack frame */ onlistrel bit (18), /* offset within stack frame of on unit */ oldp ptr, /* pointer to previous on unit */ prev_sp ptr, /* used for threading new signal_ stack frame */ next_sp ptr, /* used in back-tracing the stack */ my_sp ptr, /* pointer to original signal_ stack frame */ filep ptr, /* pointer to pl1 file descriptor */ arglistptr ptr, /* pointer to fim or ii arglist */ args fixed bin, /* argument count to signal_ */ unclp ptr, /* pointer to unclaimed signal on unit */ signal_caller_frame_size fixed bin (18) unsigned, /* size of frame to call signal_ */ io bit (1) aligned, /* "1"b if I/O condition being signalled */ retsw bit (1) aligned, /* used by default handler before crawling out */ continue bit (1) aligned; /* "1"b after return from condition handler causes signal_ to continue searching for more. */ dcl static_okay bit (1) aligned; /* used to prevent infinite recursion with static handlers */ dcl null_pointer_condition bit (1) aligned; /* null_pointer_ */ dcl any_other condition; dcl 1 based_machine_conditions aligned based, /* used to copy the machine conditions */ 2 words (24) fixed bin (71); dcl based_ptr ptr based; /* used in picking up ptr from arg list */ dcl based_array (info_ptr -> condition_info_header.length) fixed bin (35) based; /* used in copying info structures */ dcl 1 descriptor based aligned, /* PL/1 argument descriptor */ ( 2 flag bit (1), /* non-zero for V2PL/1 */ 2 type bit (6), /* data type */ 2 packed bit (1), /* non-zero for packed data */ 2 number_dims bit (4), /* number of array dimensions */ 2 size bit (24) ) unal; /* size of data */ dcl 1 signal_caller_frame based (sp) aligned,/* stack frame for caller of signal_ */ 2 frame_header like stack_frame, /* stack frame header */ 2 machine_conditions like based_machine_conditions, /* machine conditions */ 2 mcptr ptr, /* pointer to machine conditions */ 2 infoptr ptr, /* pointer to info structure */ 2 wcptr ptr, /* pointer to wall crossing conditions */ 2 condition_name char (32), /* condition being signalled */ 2 condition_name_desc like descriptor, /* descriptor for condition name */ 2 mcptr_desc like descriptor, /* descriptor for pointer */ 2 infoptr_desc like descriptor, /* descriptor for pointer */ 2 wcptr_desc like descriptor, /* descriptor for pointer */ 2 arglist, /* argument list to signal_ */ 3 arg_count fixed bin (17) unal, /* 2 * number of args */ 3 flag fixed bin (17) unal, /* =4 for pl/1 call */ 3 desc_count fixed bin (17) unal, /* 2 * number of descriptors */ 3 pad fixed bin (17) unal, 3 condition_name_ptr ptr, 3 mcptr_ptr ptr, 3 infoptr_ptr ptr, 3 wcptr_ptr ptr, 3 condition_name_desc_ptr ptr, 3 mcptr_desc_ptr ptr, 3 infoptr_desc_ptr ptr, 3 wcptr_desc_ptr ptr, 2 additions fixed bin; /* info structure and/or wc will be copied here */ dcl arg_count_ external entry (fixed bin); dcl sct_manager_$call_handler entry (ptr, char (*), ptr, ptr, bit (1) aligned); dcl unwind_stack_ entry (ptr, ptr, fixed bin (35)); dcl nonlocal_goto_$different_ring entry (ptr, ptr); dcl crawlout_default_handler_ entry (ptr, char (*), ptr, ptr, bit (1) aligned); dcl pl1_snap_ entry (char (*)); dcl default_error_handler_$wall_ignore_pi entry options (variable); dcl get_ring_ entry () returns (fixed bin); dcl fim$ ext fixed bin; dcl pds$vtime_count fixed bin ext; dcl verify_lock$condition entry (char (*), ptr); dcl (addr, addrel, baseno, bin, bit, divide, length, min, max, null, pointer, rtrim, size, stackframeptr, string, substr, unspec) builtin; %page; %include on_unit; dcl char_string char (onlistp -> on_unit.size) aligned based (onlistp -> on_unit.name), /* used to reference condition name in stack */ tpp (2) ptr based (onlistp -> on_unit.file); /* part of file descriptor */ %page; %include condition_info_header; dcl 1 pl1_info_struc based (info_ptr) aligned like pl1_info; /* info structure for pl1 conditions */ %include pl1_info; %page; %include its; dcl 1 fim_arglist based aligned, 2 arg_count fixed bin (17) unal, 2 flag fixed bin (17) unal, 2 desc_count fixed bin (17) unal, 2 pad fixed bin (17) unal, 2 first_arg ptr; /* ptr to machine conditions */ %page; %include stack_header; %include stack_frame; %include mc; common: /* to all except io */ io = "0"b; /* not i/o condition */ go to join; /* join common code */ /* This entry is called when signalling certain io conditions so that only the handler pertaining to a certain file is invoked */ io_signal: entry (a_name, a_mcptr, a_info_ptr); io = "1"b; /* The arg count stuff below just happens to work for this entrypoint */ /* Initialize variables. Find out how many arguments were supplied in call to signal_. Copy the ones supplied and provide dummy values for the others. */ join: on any_other call terminate_minus_2 (-2); call arg_count_ (args); /* get number or arguments */ mcptr, info_ptr, wcptr = null; args = max (min (args, 4), 0); /* Force computed goto safety */ goto ARGS (args); ARGS (4): wcptr = a_wcptr; ARGS (3): info_ptr = a_info_ptr; ARGS (2): mcptr = a_mcptr; ARGS (1): ARGS (0): /**** Find the point on the stack from which we will start to signal. set the "signal" bit so that find_condition_info_ and continue_to_signal_ will work in static handlers. The rest of these variables will be used after the static handler case is dealt with. */ next_sp, my_sp = stackframeptr (); /* Extract our stack pointer */ sp = my_sp -> stack_frame.prev_sp; /* Start from the previous stack frame. */ my_sp -> stack_frame_flags.signal = "1"b; /* indicate this is signal frame */ my_sp -> stack_frame_flags.support = "1"b; /* use option when available */ if mcptr ^= null & ^io & static_okay then do; continue = "0"b; /* default is to not continue. */ revert any_other; /* may resignal */ call sct_manager_$call_handler (mcptr, a_name, info_ptr, wcptr, continue); /**** Note that continue_to_signal_ will find this continue bit and set it for the handler. */ if ^continue then return; on any_other call terminate_minus_2 (-2); end; l_name = length (rtrim (a_name)); /* Get true length of condition name. */ condition_name = substr (a_name, 1, l_name); /* Copy the condition name into stack. */ null_pointer_condition = (condition_name = "null_pointer"); if io then do; /* used io_signal entry */ filep = info_ptr; /* info_ptr points directly to file */ info_ptr = null; /* dont dare crawl out with info_ptr set the way it was */ end; else if info_ptr ^= null then if pl1_info_struc.id = "pliocond" then if pl1_info_struc.content_flags.file_ptr_sw then do; filep = pl1_info_struc.file_ptr; io = "1"b; /* have to look for file as well as condition */ end; /* Search back down the stack, examining each frame. */ stack_loop: /**** Search the condition stack. When an on unit for this condition is found, call the indicated handler. Unless the variable "continue" is set by the handler, signal_ will then return to its caller. If "continue" is set, signal_ will continue the search down the stack. */ if sp -> stack_frame_flags.condition then do; /* Has any condition been set in this frame? */ onlistrel = sp -> stack_frame.on_unit_relp1; /* Get start of on list thread. */ unclp = null; /* Initialize pointer to unclaimed_signal unit. */ oldp = null; /* Initialize pointer to previous on unit. */ ou_count = 0; /* initialize on unit count */ do while (onlistrel); /* Search the on unit thread. */ onlistp = addrel (sp, onlistrel); /* Generate a pointer to the on unit. */ if found_specific_condition (l_name, condition_name, onlistp) then do; if io then /* If an I/O condition ... */ if onlistp -> on_unit.file -> tpp (2) ^= filep -> tpp (2) then go to skip_invoke; /* Skip invocation if not the desired file. */ revert any_other; call caller (onlistp); /* Invoke the handler. */ on any_other call terminate_minus_2 (-2); goto end_loop; /* continue up the stack */ end; if onlistp -> on_unit.size = length ("any_other") then if onlistp -> on_unit.name -> char_string = "any_other" then /* is this "any_other" */ unclp = onlistp; /* save loc'n of on unit for any_other */ if onlistp -> on_unit.size = length ("unclaimed_signal") then /* Is this "unclaimed_signal"? */ if onlistp -> on_unit.name -> char_string = "unclaimed_signal" then unclp = onlistp; /* Save loc'n of on unit for unclaimed signal. */ skip_invoke: oldp = onlistp; /* Save pointer to previous on unit. */ onlistrel = onlistp -> on_unit.next; /* Step to next unit and continue. */ ou_count = ou_count + 1; /* increment count of on units */ if ou_count > 200 then call terminate_minus_2 (-2); /* term process if too many */ end; /* If the desired on unit was not found, check for an unclaimed_signal handler or for a default handler. If unwinding, check for a cleanup handler. */ if unclp ^= null then /* If there is an unclaimed_signal handler ... */ do; revert any_other; call caller (unclp); /* Invoke the unclaimed signal handler. */ on any_other call terminate_minus_2 (-2); end; end; /* Step back to the next stack frame. Determine if the previous stack frame is in another stack segment. If not, continue looping. */ end_loop: next_sp = sp; /* Save pointer to this stack frame. */ sp = sp -> stack_frame.prev_sp; /* Step stack pointer back to previous frame. */ loops = loops + 1; /* increment count of stack frames found */ if loops > 5000 then call terminate_minus_2 (-2); if baseno (next_sp) = baseno (sp) then goto stack_loop; /* Continue search if on same stack. */ /* The signal was unclaimed on this stack. If possible, an attempt will be made to signal this condition on the calling stack. This will be done by simulating a call to signal_ on that stack. */ end_scan: if sp = null then call terminate_minus_2 (-2); /* before we crawl out, see if the system default handling is nonfatal; if so, do it and return */ retsw = "0"b; revert any_other; call crawlout_default_handler_ (mcptr, substr (condition_name, 1, l_name), wcptr, info_ptr, retsw); if retsw then go to return; /* assume condition was handled adequately */ on any_other call terminate_minus_2 (-2); /* If signalling, we must unwind to get to the calling stack. */ call unwind_stack_ (my_sp, null, code); /* code always 0 in this case */ /* In case there are access/parity problems with stack, set up any_other handler to terminate process. The any_other handler will be reverted on call to non_local_goto_$different_ring */ on any_other call terminate_minus_2 (-5); /* -5 will be translated to error_table_$bad_stack_access by terminate_proc */ /* Construct a new stack frame on the calling stack. This frame will contain an argument list and arguments for a call to signal_. */ sb = pointer (sp, "0"b); /* Get pointer to base of outer ring stack. */ prev_sp = sp; /* Save pointer to last frame on that stack. */ sp = sb -> stack_header.stack_end_ptr; /* Get pointer to new frame. */ signal_caller_frame_size = size (signal_caller_frame) - 1; /* Compute min length of signal_caller stack frame */ sp -> stack_frame.prev_sp = prev_sp; /* Thread new frame in. */ sp -> stack_frame_flags.condition = "0"b; /* "prev_sp" may have had condition bit set. */ sp -> stack_frame_flags.crawl_out = "1"b; /* indicate we're doing a crawl out */ sp -> stack_frame_flags.support = "1"b; /* Set up stack variables in signal caller frame. */ if mcptr ^= null then do; /* If machine conditions were supplied ... */ signal_caller_frame.machine_conditions = mcptr -> based_machine_conditions; /* Copy the machine conditions into our frame. */ signal_caller_frame.mcptr = addr (signal_caller_frame.machine_conditions); /* Set pointer in caller frame. */ end; else /* Otherwise, set null ptr. */ signal_caller_frame.mcptr = null; /* copy conditions from system fault in outer ring if available */ if get_ring_ () = 0 then do; /* fim doesn't operate in other rings */ call verify_lock$condition (condition_name, mcptr); /* Unlock all locks in Ring 0 */ pds$vtime_count = -1; /* Reset virtual time counters. */ if ^next_sp -> stack_frame_flags.signaller & baseno (next_sp -> stack_frame.return_ptr) = baseno (addr (fim$)) then do; arglistptr = next_sp -> stack_frame.next_sp -> stack_frame.arg_ptr; /* get ptr to callee's arg list */ unclp = arglistptr -> fim_arglist.first_arg -> based_ptr; /* first arg points to mc */ /* be sure that wall crossing conditions are relevant for target ring */ if addr (unclp -> mc.scu (0)) -> scu.ppr.prr ^= addr (sp) -> its.ringno then go to no_wc; /* not for target ring */ signal_caller_frame.wcptr = addr (signal_caller_frame.additions); signal_caller_frame.wcptr -> based_machine_conditions = unclp -> based_machine_conditions; signal_caller_frame_size = signal_caller_frame_size + size (mc); /* add length of wc */ end; else go to no_wc; end; /* end of checks for ring 0 */ else no_wc: signal_caller_frame.wcptr = null; /* copy info structure into outer ring */ if info_ptr ^= null then do; /* there is a structure to copy */ signal_caller_frame.infoptr = addrel (sp, signal_caller_frame_size); signal_caller_frame.infoptr -> based_array = info_ptr -> based_array; signal_caller_frame_size = signal_caller_frame_size + info_ptr -> pl1_info_struc.length; /* all info structures have length first */ end; else signal_caller_frame.infoptr = null; /* indicate no structure */ signal_caller_frame_size = divide (signal_caller_frame_size + 15, 16, 18, 0) * 16; /* round size up to nearest 16 */ next_sp, /* Set new pointer to end of stack. */ sb -> stack_header.stack_end_ptr, sp -> stack_frame.next_sp = addrel (sp, signal_caller_frame_size); sp -> stack_frame_flags.old_crawl_out = "1"b; /* must set after next_sp */ string (signal_caller_frame.mcptr_desc) = "0"b; /* Set descriptor for mcptr. */ signal_caller_frame.mcptr_desc.flag = "1"b; signal_caller_frame.mcptr_desc.type = bit (bin (13, 6), 6); string (signal_caller_frame.infoptr_desc) = "0"b; /* Set descriptor for infoptr */ signal_caller_frame.infoptr_desc.flag = "1"b; signal_caller_frame.infoptr_desc.type = bit (bin (13, 6), 6); string (signal_caller_frame.wcptr_desc) = "0"b; /* Set descriptor for wcptr */ signal_caller_frame.wcptr_desc.flag = "1"b; signal_caller_frame.wcptr_desc.type = bit (bin (13, 6), 6); /* set translator id to special value (3) for debugging */ signal_caller_frame.translator_id = bit (bin (3, 18), 18); signal_caller_frame.entry_ptr = null; /* so won't be confused by garbage */ signal_caller_frame.condition_name = condition_name; /* Place condition name in caller frame. */ string (signal_caller_frame.condition_name_desc) = "0"b; /* Set descriptor for condition_name. */ signal_caller_frame.condition_name_desc.flag = "1"b; signal_caller_frame.condition_name_desc.type = bit (bin (21, 6), 6); signal_caller_frame.condition_name_desc.size = bit (bin (l_name, 24), 24); /* Set argument list to signal_. */ signal_caller_frame.arglist.arg_count = 8; /* Four arguments. */ signal_caller_frame.arglist.flag = 4; /* Indicate PL/1 call. */ signal_caller_frame.arglist.desc_count = 8; /* Four descriptors. */ signal_caller_frame.arglist.pad = 0; signal_caller_frame.arglist.condition_name_ptr = addr (signal_caller_frame.condition_name); signal_caller_frame.arglist.mcptr_ptr = addr (signal_caller_frame.mcptr); signal_caller_frame.arglist.infoptr_ptr = addr (signal_caller_frame.infoptr); signal_caller_frame.arglist.wcptr_ptr = addr (signal_caller_frame.wcptr); signal_caller_frame.arglist.condition_name_desc_ptr = addr (signal_caller_frame.condition_name_desc); signal_caller_frame.arglist.mcptr_desc_ptr = addr (signal_caller_frame.mcptr_desc); signal_caller_frame.arglist.infoptr_desc_ptr = addr (signal_caller_frame.infoptr_desc); signal_caller_frame.arglist.wcptr_desc_ptr = addr (signal_caller_frame.wcptr_desc); /* Set operator pointer in caller frame to point to argument list. The unwinder will place this value in ap when it performs the non-local goto. Beware --- THIS IS A KLUDGE. */ stack_frame.operator_and_lp_ptr = addr (signal_caller_frame.arglist); sp -> stack_frame.return_ptr = sb -> stack_header.signal_ptr; /* Set return pointer to enter signal_. */ /* Perform a non-local goto be calling the unwinder_'s ALM utility routine. */ call nonlocal_goto_$different_ring (sp, sp -> stack_frame.return_ptr); /* Call signal_ again on target stack */ return; /* CALLER - Internal procedure to call handler */ caller: proc (p); dcl p ptr; declare entry_variable entry variable options (variable); declare 1 entry_overlay aligned, 2 codeptr pointer, 2 environmentptr pointer; if p -> on_unit.flags.pl1_snap then call pl1_snap_ (condition_name); /* perform snap */ if p -> on_unit.flags.pl1_system then /* use system's handler */ entry_overlay.codeptr = addr (default_error_handler_$wall_ignore_pi); else entry_overlay.codeptr = p -> on_unit.body; /* otherwise use entry from on unit */ entry_overlay.environmentptr = sp; unspec (entry_variable) = unspec (entry_overlay); continue = "0"b; /* clear the continue flag */ call entry_variable (mcptr, substr (condition_name, 1, l_name), wcptr, info_ptr, continue); /* call the handler */ /**** Note that continue_to_signal_ will reach into the arglist and change the continue bit. */ if ^continue then go to return; /* if finished, then return from signal_ */ return; /* return to caller for more searching */ end caller; found_specific_condition: procedure (name_length, name, on_unit_ptr) returns (bit (1) aligned); declare name_length fixed bin; /* number of non-spaces leading in name */ declare name character (*); /* name of condition sought */ declare on_unit_ptr pointer; /* unit under scrutiny */ declare 1 OU aligned like on_unit based (on_unit_ptr); declare on_unit_name character (OU.size) based (OU.name) aligned; if name_length = length (on_unit_name) then if condition_name = on_unit_name then return ("1"b); /* really there */ if null_pointer_condition /* global bit flag to avoid repeating this test */ then if length (on_unit_name) = length ("simfault_000000") then if substr (on_unit_name, 1, length ("simfault_")) = "simfault_" then return ("1"b); return ("0"b); /* no such luck */ end found_specific_condition; return: return; /* return to caller of signal_ */ terminate_minus_2: procedure (offset); declare offset fixed bin; declare baseptr builtin; declare killer_ptr pointer; declare killer fixed bin (35) aligned based (killer_ptr); killer_ptr = pointer (baseptr (-2), offset); killer = 0; end terminate_minus_2; end signal_;  stack_header_util_.alm 11/11/89 1144.7r w 11/11/89 0803.8 10926 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** name stack_header_util_ " " Written by C. Hornig, July 1979 " entry get_system_free_area_ entry set_system_free_area_ entry get_user_free_area_ entry set_user_free_area_ get_system_free_area_: eppbp sb|stack_header.system_free_ptr,* tra get_common get_user_free_area_: eppbp sb|stack_header.user_free_ptr,* get_common: spribp ap|2,* short_return set_system_free_area_: eppbp sb|stack_header.system_free_ptr tra set_common set_user_free_area_: eppbp sb|stack_header.user_free_ptr set_common: eppab ap|2,* eppbb ab|0,* spribb bp|0 short_return include stack_header end  sub_err_.pl1 11/11/89 1144.7r w 11/11/89 0804.3 52380 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Written by who knows who who knows when. */ /* Modified by Benson I. Margulies April 81 for new include file and q flag */ /* Modified by Benson I. Margulies November 81 for new calling sequence */ /* format: style2 */ sub_err_: procedure (P_code, name, flags, info_ptr, retval) options (support); /* parameters */ dcl P_code fixed bin (35), /* (input) status code */ name char (*), /* (input) subsystem name */ flags bit (*), /* (input) how to restart. "c" to continue, "s" to die "q" to restart silently */ info_ptr ptr, /* (input) optional further information */ retval fixed bin (35); /* (input/output) return value from environment */ /* automatic */ dcl arg_list_ptr ptr, /* ptr to our argument list */ arg_ptr ptr, /* ptr to arg */ arg_len fixed bin (21), arg_count fixed bin, code fixed bin (35), /* convert copy of status code */ cs char (256), /* Formatted string */ lt fixed bin, /* length of it */ cant_restart bit (1), /* t if cnnnot restart */ ndims fixed bin, /* junk for decode_descriptor_ */ packed bit (1) aligned, /* .. */ prec fixed bin, /* .. */ scale fixed bin, /* .. */ type fixed bin; /* .. */ declare 1 sub_err_info aligned like sub_error_info automatic; /* entries */ dcl cu_$arg_list_ptr entry (ptr); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl decode_descriptor_ entry (ptr, fixed bin, fixed bin, fixed bin, bit (1) aligned, fixed bin, fixed bin); dcl ioa_$general_rs entry (ptr, fixed bin, fixed bin, char (*), fixed bin, bit (1), bit (1)); dcl signal_ entry (char (*), ptr, ptr, ptr); /* builtins */ dcl (addr, bin, index, null, size, substr) builtin; /* include files */ %include condition_info_header; %include sub_error_info; %include desc_dcls; %include std_descriptor_types; /* program */ call cu_$arg_list_ptr (arg_list_ptr); call cu_$arg_count (arg_count, (0)); if arg_count < 1 then call error_no_args; call cu_$arg_ptr (1, arg_ptr, (0), code); call decode_descriptor_ (arg_list_ptr, 1, type, ndims, packed, prec, scale); if (type = real_fix_bin_1_dtype) & (packed = "0"b) then code = P_code; else do; intype = 2 * type + bin (packed, 1); if (type >= bit_dtype) & (type <= varying_char_dtype) then inclength = prec; else do; info.inprec = prec; info.inscale = scale; end; outtype = 2 * real_fix_bin_1_dtype; outfo.outprec = 35; outfo.outscale = 0; call assign_ (addr (code), outtype, outscale_prec, arg_ptr, intype, inscale_prec); end; sub_err_info.length = size (sub_err_info); /* Fill in structure */ sub_err_info.version = sub_error_info_version_1; cant_restart = "0"b; string (sub_err_info.action_flags) = ""b; sub_err_info.status_code = code; sub_err_info.retval = 0; sub_err_info.info_ptr = null (); sub_err_info.info_string = ""; sub_err_info.name = ""; if arg_count < 2 then goto SIGNAL; sub_err_info.name = name; if arg_count < 3 then go to SIGNAL; call cu_$arg_ptr (3, arg_ptr, arg_len, (0)); call decode_descriptor_ (arg_list_ptr, 3, type, ndims, packed, prec, scale); if type = bit_dtype /* new style call */ then string (sub_err_info.action_flags) = string (flags); else begin; /* This depends on the fact that an aligned char string is just an unaligned bit string that has some restrictions on its storage layout. Thus calling an aligned string unaligned is a harmless thing. */ declare flags character (arg_len) based (arg_ptr) unaligned; sub_err_info.action_flags.cant_restart = (index (flags, "s") ^= 0); /* Fatal? */ sub_err_info.action_flags.default_restart = (index (flags, "c") ^= 0); /* Continue? */ sub_err_info.action_flags.quiet_restart = (index (flags, "q") ^= 0); end; cant_restart = sub_err_info.action_flags.cant_restart; if arg_count < 4 then go to SIGNAL; sub_err_info.retval = retval; if arg_count < 5 then go to SIGNAL; sub_err_info.info_ptr = info_ptr; if arg_count < 6 then go to SIGNAL; call ioa_$general_rs (arg_list_ptr, 6, 7, cs, lt, "0"b, "0"b); sub_err_info.info_string = substr (cs, 1, lt); SIGNAL: call signal_ ("sub_error_", null, addr (sub_err_info), null); /* Blap out message */ do while (cant_restart); /* If user can't hack return */ call signal_ ("illegal_return", null, addr (sub_err_info), null); end; if arg_count >= 4 then retval = sub_err_info.retval; /* Return's ok, what did environment do? */ RETURN: return; error_no_args: procedure; declare error_table_$badcall fixed bin (35) ext static; declare sub_err_ entry external options (variable); /* get descriptors onto this call */ call sub_err_ (error_table_$badcall, "sub_err_", ""b, (0), null (), "^a", "No arguments supplied in a call to sub_err_."); /* and why not recurse */ go to RETURN; end error_no_args; end sub_err_;  tape_checksum_.alm 11/11/89 1144.7rew 11/11/89 0804.3 18432 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1983 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** name tape_checksum_ " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " Calling Sequence: " call tape_checksum_ (physical_record_pointer, checksum_pointer) " " Where: " physical_record_pointer - pointer to beginning of physical tape record " checksum_pointer - pointer to word to contain checksum " " The checksum will be computed as described in MPM " Reference Guide Section 8.4. " The format of the physical record header and " the physical record trailer are described in MPM " Reference Guide Section 5.3. " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " segdef tape_checksum_ tape_checksum_: eppbp ap|2,* bp -> physical record pointer eppbp bp|0,* bp -> physical record eax1 0 x1 is physical record header index ldq bp|4 get length of data in bits anq =o777777,dl isolate record size div 36,dl compute word count eax2 8,ql x2 is physical record trailer index eax3 1 x3 is rotate index lda 0,dl clear the a register ldi =o4000,dl clear indicators and set overflow mask odd; rpda 6,1 do the record header awca bp|0,1 compute checksum on header alr 0,3 .. awca bp|1,1 add in last word of header alr 0,3 .. odd; rpda 8,1 now do the trailer awca bp|0,2 compute checksum on trailer alr 0,3 .. awca 0,dl add in any remaining carries eppbp ap|4,* bp -> checksum pointer sta bp|0,* store the checksum short_return end  unpack_picture_.pl1 11/11/89 1144.7rew 11/11/89 0804.2 151893 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Program to picture unpacking, packing, and validation for PL/I Initial Version: 22 November 1973 by BLW Modified: 27 April 1974 by BLW to fix bugs 1063, 1068, 1071, 1072, 1089 Modified: 16 July 1974 by BLW to fix bug 1172 Modified: 17 November 1976 by RAB to fix 1550 Modified: 7 February 19885 by Steve Herbst to prevent zero-suppressing a decimal point. */ unpack_picture_: proc(target_value,picture,source_value); dcl (target_value,source_value) char(1) unaligned, picture fixed bin; dcl (tp,pp,sp) ptr, (i,j,k,last_non_zero,picture_pos,source_pos,type,prec,scale,dr1,dr2,start, scalefactor,picture_length,source_length,target_pos,exp_sign,exp,code,delta) fixed bin, (had_exponent,zero_surpression,first_z,first_star,negative,no_digit,have_drift) bit(1) aligned, digits char(64) aligned, exponent fixed dec(3), (pc,sc,drift) char(1) aligned, source(source_length) char(1) unaligned based(sp), input char(source_length) unaligned based(sp), target char(64) unaligned based(tp), target_array(0:1) char(1) unaligned based(tp); dcl (addr,index,null,substr) builtin; dcl ALPHABETIC char(53) int static init(" abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"); dcl plio2_signal_$s_ entry(ptr,aligned char(*),aligned char(*),fixed bin), plio2_signal_$conversion_error_ entry(ptr,char(*),fixed bin,ptr,fixed bin,fixed bin,fixed bin), cu_$grow_stack_frame entry(fixed bin,ptr,fixed bin), adjust_float_ entry(ptr,ptr,fixed dec(3)); dcl fudge(24:28) fixed bin int static init(0,1,1,2,2); dcl 1 float_decimal unaligned based(tp), 2 sign char(1), 2 mantissa char(prec), 2 skip bit(1), 2 exponent fixed bin(7); dcl decimal_value char(prec + 1) unaligned based(sp); dcl 1 info aligned based(pp) like picture_image; %include picture_image; %include picture_types; call open_picture; sp = addr(source_value); tp = addr(target_value); call unpack; if type = cplx_fixed_picture | type = cplx_float_picture then do; sp = addr(source(source_length + 1)); tp = addr(target_array(prec + fudge(type))); call unpack; end; return; pl1_valid_picture_: entry(picture_value,picture,answer); dcl picture_value char(1) unal, answer bit(1) aligned; call open_picture; sp = addr(picture_value); call validate; if code = 0 then if type = cplx_fixed_picture | type = cplx_float_picture then do; sp = addr(source(source_length + 1)); call validate; end; answer = code = 0; return; validate_picture_: entry(picture_value,picture,error_code,error_index); dcl (error_code,error_index) fixed bin; call open_picture; sp = addr(picture_value); delta = 0; call validate; if code = 0 then if type = cplx_fixed_picture | type = cplx_float_picture then do; delta = source_length; sp = addr(source(source_length + 1)); call validate; end; error_code = code; error_index = source_pos + delta; return; pack_picture_: entry(target_value,picture,source_value); call open_picture; sp = addr(source_value); tp = addr(target_value); if type = char_picture then call pack_char; else do; call pack; if type = cplx_fixed_picture | type = cplx_float_picture then do; sp = addr(addr(source_value) -> source(prec + fudge(type) + 1)); tp = addr(target_array(source_length)); call pack; end; end; return; open_picture: proc; pp = addr(picture); type = info.type; prec = info.prec; scale = info.scale; picture_length = info.piclength; source_length = info.varlength; scalefactor = info.scalefactor; end; pack: proc; if fudge(type) = 2 then do; /* have floating point value, we have to copy because we may have been called with constant value */ substr(digits,1,prec+2) = substr(input,1,prec+2); sp = addr(digits); /* now adjust the floating decimal value */ call adjust_float_(sp,pp,exponent); end; negative = source(1) = "-"; source_pos = 2; zero_surpression, have_drift = "0"b; first_z, first_star, no_digit = "1"b; start, target_pos = 1; do picture_pos = 1 to picture_length; pc = substr(info.chars,picture_pos,1); goto case(index("9y*z$s+-cd/.,bvek",pc)); /* 9 */ case(1): call put_digit; source_pos = source_pos + 1; goto place; /* y */ case(2): if source(source_pos) = "0" then pc = " "; else call put_digit; zero_surpression = "0"b; source_pos = source_pos + 1; goto place; /* * */ case(3): if first_star then do; zero_surpression = "1"b; first_star = "0"b; end; if zero_surpression & (source(source_pos) = "0") then pc = "*"; else call put_digit; source_pos = source_pos + 1; goto place; /* z */ case(4): if first_z then do; zero_surpression = "1"b; first_z = "0"b; end; if zero_surpression & (source(source_pos) = "0") then pc = " "; else call put_digit; source_pos = source_pos + 1; goto place; /* $ */ case(5): if info.drift_character ^= "$" then goto place; if ^ no_digit then goto case(1); if have_drift then goto case(4); drift = "$"; zero_surpression, have_drift = "1"b; pc = " "; goto place; /* s */ case(6): pc = source(1); call drifting_sign; /* + */ case(7): if negative then pc = " "; call drifting_sign; /* - */ case(8): if ^ negative then pc = " "; call drifting_sign; /* c */ case(9): if negative then substr(target,target_pos,2) = "cr"; else substr(target,target_pos,2) = " "; picture_pos = picture_pos + 1; goto step; /* d */ case(10): if negative then substr(target,target_pos,2) = "db"; else substr(target,target_pos,2) = " "; picture_pos = picture_pos + 1; goto step; /* / . , */ case(11): case(12): case(13): if zero_surpression then if substr(target,target_pos - 1,1) = "*" then pc = "*"; else if pc ^= "." then pc = " "; /* don't want to suppress the decimal point */ goto place; /* b */ case(14): if zero_surpression then if substr(target,target_pos - 1,1) = "*" then pc = "*"; else pc = " "; else pc = " "; goto place; /* v */ case(15): if zero_surpression then if search(decimal_value,"123456789") ^= 0 then call force_significance; goto step; /* e */ case(16): call switch_to_exp; goto place; /* k */ case(17): call switch_to_exp; goto step; /* place character pc in target string */ place: substr(target,target_pos,1) = pc; target_pos = target_pos + 1; step: end; if no_digit then substr(target,start,target_pos - start) = " "; drifting_sign: proc; if start ^= 1 then goto place; if info.drift_character ^= substr(info.chars,picture_pos,1) then goto place; if ^ no_digit then goto case(1); if have_drift then goto case(4); drift = pc; have_drift, zero_surpression = "1"b; pc = " "; goto place; end; put_digit: proc; pc = source(source_pos); force_significance: entry; if have_drift then do; substr(target,target_pos - 1,1) = drift; have_drift = "0"b; end; zero_surpression, no_digit = "0"b; end; switch_to_exp: proc; if no_digit then substr(target,1,target_pos - 1) = " "; start = target_pos; sp = addr(exponent); negative = source(1) = "-"; zero_surpression, have_drift = "0"b; first_z, no_digit = "1"b; source_pos = 2; end; end; pack_char: proc; dcl p ptr, (code,errno) fixed bin; start: do source_pos = 1 to source_length; sc = source(source_pos); pc = substr(info.chars,source_pos,1); if pc = "9" then if index(" 0123456789",sc) = 0 then do; errno = 312; goto edit_err; end; else; else if pc = "a" then if index(ALPHABETIC,sc) = 0 then do; errno = 313; goto edit_err; end; substr(target,source_pos,1) = sc; end; return; edit_err: if sp = addr(source_value) then do; /* copy source for use in signalling conversion */ call cu_$grow_stack_frame(4*source_length,p,code); p -> source = sp -> source; sp = p; end; call plio2_signal_$conversion_error_(null,"pack_picture_",errno,sp,1,source_length,source_pos); goto start; end; unpack: proc; last_non_zero = 0; source_pos, target_pos = 0; substr(target,1,1) = "+"; had_exponent = "0"b; digits = (64)"0"; do picture_pos = 1 to picture_length; k = index("9y*z$s+-cd/.,bvek",substr(info.chars,picture_pos,1)); if k >= 16 then do; /* process exponent field */ had_exponent = "1"b; exp = 0; exp_sign = 1; if k = 16 then source_pos = source_pos + 1; do while(source_pos < source_length); source_pos = source_pos + 1; sc = source(source_pos); j = index(" 0123456789+-",sc); if j > 12 then exp_sign = -1; if j < 12 then if j > 1 then exp = exp * 10 + j - 2; end; goto end_picture; end; if k = 15 then goto loop; source_pos = source_pos + 1; if k > 10 then goto loop; sc = source(source_pos); if sc = " " then sc = "0"; j = index("0123456789$+-cd",sc); if k > 4 then do; /* $ or sign */ if j > 12 then substr(target,1,1) = "-"; if k > 8 then do; /* skip over cr or db */ source_pos = source_pos + 1; picture_pos = picture_pos + 1; goto loop; end; if j = 0 then goto loop; if j > 10 then goto loop; end; target_pos = target_pos + 1; if j > 1 then do; last_non_zero = target_pos; substr(digits,target_pos,1) = sc; end; loop: end; end_picture: i = target_pos - prec; last_non_zero = last_non_zero - i; i = i + 1; if had_exponent then do; if last_non_zero < prec then substr(target,2,prec-last_non_zero) = substr((64)"0",1,prec-last_non_zero); if last_non_zero > 0 then substr(target,prec-last_non_zero+2,last_non_zero) = substr(digits,i,last_non_zero); exp = exp * exp_sign; exp = exp - scale + prec - last_non_zero + scalefactor; if exp > 127 then call signal_and_return("overflow",289); if exp < -128 then call signal_and_return("underflow",290); float_decimal.exponent = exp; end; else substr(target,2,prec) = substr(digits,i,prec); signal_and_return: proc(name,erno); dcl name char(9) aligned, erno fixed bin; call plio2_signal_$s_(null,name,"pic",erno); goto exit; end; end; validate: proc; if type = char_picture then do; do source_pos = 1 to source_length; sc = source(source_pos); pc = substr(info.chars,source_pos,1); if pc = "9" then if index(" 0123456789",sc) = 0 then goto ve12; else; else if pc = "a" then if index(ALPHABETIC,sc) = 0 then goto ve13; end; code = 0; return; end; if input = " " then do; source_pos = index(info.chars,"9"); if source_pos ^= 0 then goto ve14; code = 0; return; end; zero_surpression = "0"b; first_z, first_star = "1"b; if info.drift_character = " " then dr1, dr2 = 0; else do; dr1 = index(info.chars,info.drift_character); if info.drift_character = "$" then do; dr2 = index(input,"$"); if dr2 = 0 then goto ve1; end; else do; dr2 = search(input,"+-"); if info.drift_character = "s" then if dr2 = 0 then goto ve2; else; else if dr2 ^= 0 then if substr(input,dr2,1) ^= info.drift_character then goto ve2; end; if dr2 = 0 then dr1 = 0; else do; if dr2 > dr1 then if substr(input,dr1,dr2-dr1) ^= " " then goto ve3; if substr(input,dr2+1,1) = " " then goto ve3; end; end; source_pos = 0; do picture_pos = 1 to picture_length; pc = substr(info.chars,picture_pos,1); k = index("9yz*$s+-cd/.,bvek",pc); if k < 15 then do; source_pos = source_pos + 1; if source_pos = dr1 then sc = source(dr2); else if source_pos = dr2 then sc = " "; else sc = source(source_pos); j = index(" 0123456789*$+-cd/.,",sc); if j = 0 then goto ve5; end; if k < 4 then if j > 11 then goto ve11; goto case(k); /* 9 */ case(1): if sc = " " then goto ve10; zero_surpression = "0"b; goto loop; /* y */ case(2): if sc = "0" then goto ve10; if j > 2 then zero_surpression = "0"b; goto loop; /* z */ case(3): if first_z then do; zero_surpression = "1"b; first_z = "0"b; end; if sc = " " then if zero_surpression then goto loop; else goto ve9; goto valid_star; /* * */ case(4): if first_star then do; zero_surpression = "1"b; first_star = "0"b; end; if sc = "*" then if zero_surpression then goto loop; else goto ve9; valid_star: if sc = "0" then if zero_surpression then goto ve9; else goto loop; if j > 2 then zero_surpression = "0"b; goto loop; /* $ */ case(5): if dr1 = 0 | source_pos <= dr1 then if sc ^= "$" then goto ve8; else goto loop; goto case(3); /* s */ case(6): if dr1 = 0 | source_pos <= dr1 then if search(sc,"+-") = 0 then goto ve8; else goto loop; goto case(3); /* + - */ case(7): case(8): if info.drift_character = " " | source_pos <= dr1 then if (sc ^= pc) & (sc ^= " ") then goto ve8; else goto loop; goto case(3); /* c d */ case(9): case(10): if substr(input,source_pos,2) = " " then do; picture_pos = picture_pos + 2; source_pos = source_pos + 2; end; else do; if sc ^= pc then goto ve7; picture_pos = picture_pos + 1; source_pos = source_pos + 1; if source(source_pos) ^= substr(info.chars,picture_pos,1) then goto ve7; end; goto loop; /* / . , b */ case(11): case(12): case(13): case(14): if zero_surpression then do; if source(source_pos - 1) = "*" then if sc ^= "*" then goto ve6; else; else if sc ^= " " then goto ve6; end; else if (j - 17) ^= (k - 10) then if sc ^= " " | pc ^= "b" then goto ve6; goto loop; /* v */ case(15): if search(input,"123456789") ^= 0 then zero_surpression = "0"b; goto loop; /* e */ case(16): source_pos = source_pos + 1; if source(source_pos) ^= "e" then do; if substr(input,source_pos) ^= " " then goto ve4; if index(substr(info.chars,picture_pos+1),"9") ^= 0 then goto ve14; code = 0; return; end; /* k */ case(17): zero_surpression = "0"b; first_z, first_star = "1"b; dr1 = 0; loop: end; code = 0; return; /* "$" not present in picture variable */ ve1: code = 301; do source_pos = dr1 to source_length while(source(source_pos) = " "); end; source_pos = source_pos - 1; return; /* "+" or "-" not present in variable */ ve2: code = 302; source_pos = dr2; return; /* Drifting character not preceded by blank */ ve3: code = 303; source_pos = dr2; return; /* "e" not present where expected */ ve4: code = 304; return; /* illegal character in variable */ ve5: code = 305; return; /* Insertion character error */ ve6: code = 306; return; /* "cr" or "db" not found where expected */ ve7: code = 307; return; /* Drifting character not found where expected */ ve8: code = 308; return; /* Blank or asterisk found instead of digit */ ve9: code = 309; return; /* "$" not present in variable */ /* zero surpression error */ ve10: code = 310; return; /* non-digit found where digit expected */ ve11: code = 311; return; /* non-digit found in "9" position in char variable */ ve12: code = 312; return; /* non-alphabetic found in "a" position in char variable */ ve13: code = 313; return; /* picture all blank when digit expected */ ve14: code = 314; end; exit: end;  unwind_stack_.pl1 11/11/89 1144.7r w 11/11/89 0804.2 51561 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style2 */ unwind_stack_: proc (a_start_sp, a_target_sp, code); /* This procedure actually does the unwinding for the unwinder. It examines all the stack frames from the frame before start_sp to target_sp looking for cleanup handlers. When one is found, cleanup is signalled (signal_ is sure to find the handler). If target_sp is null, the whole stack is unwound. */ /* coded 1 November 1973 by M. Weaver (much of code copied from signal_) */ /* modified to protect against terminated cleanup handlers, Benson I. Margulies, December 1981 */ dcl a_start_sp ptr, a_target_sp ptr, code fixed bin (35); dcl (start_sp, target_sp, entryp, onlistp, oldp) ptr; dcl based_p ptr based; dcl loops fixed bin init (0); dcl ou_count fixed bin; dcl error_table_$not_done ext fixed bin (35); dcl onlistrel bit (18) aligned; dcl allsw bit (1) aligned; dcl char_string char (onlistp -> on_unit.size) aligned based (onlistp -> on_unit.name); dcl (addrel, baseno, baseptr, bin, length, null, rel) builtin; dcl entry_variable variable entry (ptr, char (*), ptr, ptr, bit (1) aligned); dcl 1 label based aligned, /* template for label or entry variable */ 2 target ptr, 2 stack ptr; %include on_unit; %include stack_frame; /* */ start_sp = a_start_sp; /* copy aRGS */ target_sp = a_target_sp; code = 0; if target_sp = null then allsw = "1"b; /* unwind whole stack */ else allsw = "0"b; entryp = addr (entry_variable); /* set pointer to entry */ sp = start_sp -> stack_frame.prev_sp; /* start from previous frame */ stack_loop: /* check to determine if target stack level has been reached */ if target_sp = sp then return; /* all done; don't unwind target */ /* see if we have already passed the target frame; this could happen if target_sp does not point to the beginning of a stack frame */ if bin (rel (target_sp), 18) > bin (rel (sp), 18) then if ^allsw then do; code = error_table_$not_done; /* caller can better signal unwinder_error */ return; end; /* Search the condition stack for a cleanup on unit. If found, signal cleanup. */ if sp -> stack_frame_flags.condition then do; /* have on units in this frame */ onlistrel = sp -> stack_frame.on_unit_relp1; /* pick up ptr to on unit thread */ ou_count = 0; /* keep track of on units to check for loops */ oldp = null; /* works as back thread */ do while (onlistrel); /* search the on unit thread */ onlistp = addrel (sp, onlistrel); /* get pr to next on unit */ if onlistp -> on_unit.size = length ("cleanup") then if char_string = "cleanup" then do; /* unthread on unit and call handler */ if oldp = null then /* test for beginning of condition thread */ sp -> stack_frame.on_unit_relp1 = onlistp -> on_unit.next; else /* unthread cleanup on unit */ oldp -> on_unit.next = onlistp -> on_unit.next; entryp -> label.target = onlistp -> on_unit.body; /* fill in entry variable */ entryp -> label.stack = sp; /**** The following block contains all the error trapping stuff to avoid bad pointers as cleanup handlers. The code just above does not actually reference through any pointers to the program handler. */ begin; declare (seg_fault_error, no_read_permission, no_execute_permission, not_in_read_bracket, null_pointer, undefined_pointer, illegal_opcode, illegal_modifier, not_in_call_bracket, illegal_procedure, linkage_error) condition; on seg_fault_error, no_read_permission, no_execute_permission, not_in_read_bracket, null_pointer, undefined_pointer, illegal_opcode, illegal_modifier, not_in_call_bracket, illegal_procedure, linkage_error goto THIS_HANDLER_DONT; call entry_variable (null (), "cleanup", null (), null, ("0"b)); /* call this cleanup handler procedure */ THIS_HANDLER_DONT: end; go to end_loop; /* done with this frame */ end; oldp = onlistp; /* save pointer to previous on unit */ onlistrel = onlistp -> on_unit.next; /* step to the next on unit and continue */ ou_count = ou_count + 1; /* increment count of on units found */ if ou_count > 200 then ptr (baseptr (-2), -2) -> based_p = sp; /* term process if too many */ end; end; end_loop: sp -> stack_frame_flags.condition = "0"b; /* frame has disappeared as far as condition mechanism is concerned */ sp = sp -> stack_frame.prev_sp; /* step stack ptr back to previous frame */ loops = loops + 1; /* increment count of stack frames found */ if loops > 5000 then ptr (baseptr (-2), -2) -> based_p = sp; /* term process if too many */ if baseno (start_sp) = baseno (sp) then go to stack_loop; /* continue search if on same stack */ return; /* caller will continue on another stack */ end unwind_stack_;  unwinder_.pl1 11/11/89 1144.7r w 11/11/89 0804.3 78867 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4 */ /* UNWINDER - This procedure performs all non-local goto's. It is passed a label that specifies the location and stack frame to which to return. The stack is popped one frame at a time until the correct frame is reached. As each frame is popped, its condition stack is checked for a cleanup condition. Unwinding across rings is handled in a manner similar to signal_, except that the non-local goto required by this technique is performed with the aid of an ALM utility program. Coded in PL/1 on July 21, 1970 by R. J. Feiertag Code added for special handlers on November 14, 1971 by R. J. Feiertag Code modified on January 13, 1972 by R. J. Feiertag Modified for 645F and combined with signal_ - September 20, 1972 by N. I. Morris */ /* Recoded 6 November 1973 by M. Weaver to separate from signal_ again, divide into 2 pieces (other is unwind_stack_) and signal cleanup */ /* Modified March 9, 1978 by M. Weaver to not set stack end pointer when unwinding in same ring */ /* Modified 1985-04-05, E. Swenson to zero out unused condition info flags */ unwinder_: proc (a_target_label); dcl (a_target_label, target_label) label; /* target of non-local goto */ dcl target_loc ptr, /* target location of non-local goto */ target_sp ptr, /* target stack level of non-local goto */ p_target_sp ptr; dcl (prev_sp, my_sp, labelp) ptr; dcl label_variable label; dcl code fixed bin (35); dcl (addr, addrel, baseno, baseptr, bit, divide, fixed, index, length, null, ptr, rel, size, substr) builtin; dcl 1 label based (labelp), /* overlay for label variable */ 2 target ptr, /* target of label */ 2 stack ptr; /* stack offset for label */ dcl 1 unwinder_caller_frame based (sp) aligned, /* stack frame for caller of unwinder_ */ 2 frame_header like stack_frame, /* stack frame header */ 2 target_label label, /* target of non-local goto. */ 2 arglist, /* argument list to unwinder_ */ 3 arg_count fixed bin (17) unal, /* 2 * number of args */ 3 flag fixed bin (17) unal, /* =4 for pl/1 call */ 3 desc_count fixed bin (17) unal, /* 2 * number of descriptors */ 3 pad fixed bin (17) unal, 3 target_label_ptr ptr; /* pointer to label variable */ dcl unwinder_caller_frame_size fixed bin; /* size of created frame */ dcl 1 unwind_err aligned, /* structure for signalling unwinder_error */ 2 header like condition_info_header, 2 label label; /* copy of offending label */ dcl nonlocal_goto_$different_ring ext entry (ptr, ptr), nonlocal_goto_$same_ring ext entry (ptr, ptr), unwind_stack_ entry (ptr, ptr, fixed bin (35)), signal_ entry (char (*), ptr, ptr); %page; /* Program */ target_label = a_target_label; begin: labelp = addr (target_label); /* Get pointer to target. */ target_loc = labelp -> label.target; /* Extract target of non-local goto. */ target_sp = labelp -> label.stack; /* Extract target stack pointer. */ /* do the actual unwinding */ labelp = addr (label_variable); label_variable = sig_error; /* set to something to get sp */ my_sp = labelp -> label.stack; my_sp -> stack_frame_flags.support = "1"b; /* turn on support bit */ /* see whether we unwind all or part of stack */ if baseno (my_sp) ^= baseno (target_sp) then do; /* unwind all of this stack first */ sp = ptr (my_sp, 0) -> stack_header.stack_begin_ptr -> stack_frame.prev_sp; /* get ptr to previous stack */ if sp = null then go to sig_error; /* no other stack; will never find target */ p_target_sp = null; end; else sp, p_target_sp = target_sp; /* look for target in this stack */ call unwind_stack_ (my_sp, p_target_sp, code); /* unwind ... */ if code ^= 0 then go to sig_error; /* couldn't find target frame */ /* */ if p_target_sp ^= null then do; /* target is on this stack */ /* Arrive here when the target stack frame for the non-local goto has been reached. Must restore the indicators; get them from the mc if the frame was faulted out of and from the return pointer otherwise. Set the target frame's return pointer to the target of the goto and call an ALM utility program to perform a return sequence. */ sp -> stack_frame_flags.signaller = "0"b; /* erase FIM flag */ sp -> stack_frame_flags.old_signaller = "0"b;/* erase old FIM flag */ sp -> stack_frame.return_ptr = target_loc; /* Set return pointer to target. */ call nonlocal_goto_$same_ring (sp, sp -> stack_frame.return_ptr); /* Let utility program do the return */ end; /* Arrive here when switching stacks on a non-local goto. */ /* Construct a new stack frame on the outer ring stack. This frame will contain an argument list and arguments for a call to signal_. */ sb = ptr (sp, "0"b); /* Get pointer to base of outer ring stack. */ prev_sp = sp; /* Save pointer to last frame on that stack. */ sp = sb -> stack_header.stack_end_ptr; /* Get pointer to new frame. */ unwinder_caller_frame_size = divide (size (unwinder_caller_frame) + 15, 16, 18, 0) * 16; /* Compute length of unwinder_caller stack frame. Round size up to nearest 16. */ sb -> stack_header.stack_end_ptr, /* set new pointers to end of stack */ sp -> stack_frame.next_sp = addrel (sp, unwinder_caller_frame_size); sp -> stack_frame.prev_sp = prev_sp; /* Thread new frame in. */ sp -> stack_frame_flags.condition = "0"b; /* "prev_sp" may have had condition bit set. */ sp -> stack_frame_flags.crawl_out = "1"b; /* indicate we're doing a crawl out */ sp -> stack_frame_flags.old_crawl_out = "1"b; sp -> stack_frame_flags.support = "1"b; /* indicate support frame */ /* Construct an argument list to unwinder_ and simulate an unwinder_ call on the target stack in a manner similar to signal_'s call for crawlouts */ set_unwinder_arglist: labelp -> label.target = target_loc; /* Reconstruct label passed to unwinder_. */ labelp -> label.stack = target_sp; /* .. */ unwinder_caller_frame.target_label = label_variable; /* Set label in stack frame. */ unwinder_caller_frame.entry_ptr = null; /* so won't be confused by garbage */ unwinder_caller_frame.arglist.arg_count = 2; /* Indicate 1 argument. */ unwinder_caller_frame.arglist.flag = 4; unwinder_caller_frame.arglist.desc_count = 0; /* Indicate no descriptors. */ unwinder_caller_frame.arglist.pad = 0; unwinder_caller_frame.arglist.target_label_ptr = addr (unwinder_caller_frame.target_label); /* Set pointer to label in stack. */ /* Set operator pointer in caller frame to point to argument list. The ALM utility routine will place this value in pr0 when it performs the non-local goto. Beware -- this is a KLUDGE */ stack_frame.operator_and_lp_ptr = addr (unwinder_caller_frame.arglist); sp -> stack_frame.return_ptr = sb -> stack_header.unwinder_ptr; /* Set return info to call unwinder_. */ /* Perform the non-local goto to call the unwinder_ by calling an ALM utility routine. This program will abandon the stack that we are currently running on. */ call nonlocal_goto_$different_ring (sp, sp -> stack_frame.return_ptr); /* See you in the next stack */ return; %page; sig_error: /* code for signalling unwinder_error */ unwind_err.header.length = size (unwind_err); unwind_err.header.version = 1; /**** Zero out all flags. We do not allow any restarting. */ unspec (unwind_err.header.action_flags) = ""b; unwind_err.header.info_string = "Attempt to perform non-local goto to invalid label."; unwind_err.header.status_code = 0; unwind_err.label = target_label; /* fill in offending label */ call signal_ ("unwinder_error", null, addr (unwind_err)); /* tell user */ target_label = unwind_err.label; /* assume if restart that label has been fixed */ go to begin; /* start over */ /* format: off */ %page; %include condition_info_header; %page; %include mc; %page; %include stack_frame; %page; %include stack_header; end unwinder_; bull_copyright_notice.txt 08/30/05 1008.4r 08/30/05 1007.3 00020025 ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull and Bull HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by Bull HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved