



		    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_>|[any_to_any_]
	link	ata_round,<any_to_any_>|[any_to_any_round_]
	link	ata_truncate,<any_to_any_>|[any_to_any_truncate_]
	link	ctn_link,<any_to_any_>|[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<number> (<number is interpreted as decimal>).  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
