



		    PNOTICE_exec.alm                11/14/89  1127.9r w 11/14/89  1127.9        2853



	dec	1			"version 1 structure
	dec	1			"no. of pnotices
	dec	3			"no. of STIs
	dec	100			"lgth of all pnotices + no. of pnotices
          acc       "Copyright (c) 1989 by Massachusetts Institute of
Technology and Honeywell Information Systems, Inc."

	aci	"C1MXSM0E0000"
	aci	"C2MXSM0E0000"
	aci	"C3MXSM0E0000"
	end




		    alloc_.alm                      11/11/89  1150.6r w 11/11/89  0805.2      342936



" ***********************************************************
" *                                                         *
" * 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.      *
" *                                                         *
" ***********************************************************

"
"	alloc_, freen_, area_
"
"	This module implements the Multics standard area programs.
"
"	Initial coding October 1975 by S Webber.
"	Modified 3 June 1976 by R Barnes for use with pl1_operators_
"		and to properly handle area condition.
"	Modified 16 August 1976 by R Barnes to fix more bugs and
"		implement extendable no_free areas
"	Modified September 1976 by M. Weaver to fix redef entrypoint
"	Modified 2 November 1976 by M. Weaver to fix zero_on_free bug
"	Modified 16 November 1976 by R. Barnes to fix bug in extensible areas
"	Modified 30 November 1976 by M. Asherman to fix bug causing excessive zeroing
"		on free, which may cause lockup fault
"	Modified 6 January 1977 to fix area retry for subr call
"	Modified 3/14/77 (Asherman) to prevent loop creating temp segs on large allocations
"	Modified 31 May 1977 by RAB to fix 1628
"	Modified 12 July 1977 by RAB to fix a bug in which "lcx3 bp|area.next_virgin"
"		got fixedoverflow
"	Modified 26 July 1977 by RAB to have alloc_ subr entry init sp|tbp
"	Modified 9 August 1977 by RAB to not allow allocations of greater than 2**18 words
"	Modified 10 August 1977 by RAB to change size of largest allocation by 2 words
"	Modified 13 September 1977 by RAB to fix bug in 9 Aug 1977 change which erroneously
"		limited allocations to 2**17 words
"	Modified 14 September 1977 by RAB to fix another fixedoverflow bug in freen_1
"	Modified 771018 by PG to add optimization to area_assign_ and fix bugs in it.
"	Modified 6 September 1978 by RAB to have no_free_alloc do a push if entered by
"		external call.  This is necessary so that area can be properly
"		signalled and get_next_area_ptr_ can be properly called.
"	Modified 800109 by PG to run MLR's in area_assign_ uninhibited (MCR 4292).
"	Modified September 1981 by J. Bongiovanni for IPS protection
"
""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
"
"	The following entries are included:
"
"	p = alloc_ (size, areap);
"	p = alloc_$storage_ (size, areap);
"	call freen_ (p);
"	call area_ (size, areap);
"	call area_$no_freeing (size, areap, extend);
"	call area_$redef (size, areap);
"	call area_assign_ (new_areap, old_areap);
"	call area_$extend (areap, flags);
"
"	The following segdef's are included for the use of
"	pl1_operators_:
"
"	op_alloc_
"	op_storage_
"	op_freen_
"	op_empty_
"
" " "  " " " " " " " " " " " " " " " " " " " " " "
"
"	NOTE	NOTE	NOTE	NOTE	NOTE
"
"
"	This routine is used by pl1_operators_ and MUST be bound in with
"	pl1_operators_. It makes references to code in pl1_operators_
"	without establishing its linkage pointer and vice versa.
"
"	NOTE	NOTE	NOTE	NOTE	NOTE
"
"	This routine assumes index register 6 (x6) is not changed by the
"	standard "push" operator. This is because we must remember a
"	value set before the push and used after the push and there
"	is no convenient place to save it.
"
"	NOTE	NOTE	NOTE	NOTE	NOTE
"
"	This routine protects itself from asynchronous reinvocations within
"	the same process (IPS signals which interrupt it, and which call
"	routines while allocate to the area in allocation at the
"	interruption).  It does this by maintaining a counter
"	(area.allocation_p_clock), which is incremented by 1 in routines
"	which could conflict with allocation if called asynchronously (other
"	allocations and frees).  After finding a suitable free block, the
"	saved value is checked in inhibited code against the current value in
"	the area header.  If different, allocation is retried.  If the same,
"	the free block is allocated, unthreaded, etc.  in inhibited code.
"
"	This routine is NOT protected against multiple invocations
"	on different CPUs against the same area. If this is possible
"	for a given area, it is the responsibility of the caller
"	to make allocation a critical section.
"
"
"	Strategy and conventions.
"
"	The following register assignments are used within this module:
"
"	x0	used to indicate whether or not called as an
"		operator from a PL/I program. If x0 = 0 then it was called
"		explicitly as an external entry. If x0 is nonzero, it is
"		the operator return offset used by standard pl1_operators_.
"	x1	used as a temporary at various times.
"	x2	always points to the block being allocated or freed.
"	x3	points to the block after the one pointed to by x2. Also used
"		as temporary in certain places.
"	x4	Used as a pointer to the block to be unthreaded by the
"		unthread subroutine. Also used as a temporary.
"	x5	Used to point to the second block after the one pointed to by x2.
"		Also used as a temporary.
"	x6	Used to indicate whether "area" or "storage" should be signalled.
"	x7	Used as temporary.
"
"	ap	points to argument list. Not changed.
"	ab	used to hold the return location for the freen_1 subroutine.
"	bp	points at base of area header during execution. At the interface
"		level, bp points to the block being freed and is returned as
"		a pointer to the allocated block (operators interface only).
"	bb	used to hold the return location for the unthread
"		subroutine.
"	lb	points at words containing ptr to block being freed
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"
"	Format of a block header:
"
"
"	|				|
"	|				|
"	_|________________________________________|  /_______  pointed to by x2
"	|		|		|  \
"	|  PREV SIZE	|  CURRENT SIZE	|
"	_|____________________|____________________|
"	|	| |	|		|
"	|   MBZ	|B| Q_NO	|   HEADER PTR	|
"	_|__________|__|________|____________________|  /_______  allocated storage starts here
"	|		|		|  \
"	|  FORWARD POINTER	| BACKWARD POINTER	|
"	_|____________________|____________________|
"	|				|
"	|				|
"
"
"	The FORWARD and BACKWARD pointers are only filled in and meaningful
"	if the block is free. If the block is not free, the storage for these
"	pointers is the first word available for use by the caller.
"	The flag "B" is the busy bit for the _p_r_e_v_i_o_u_s block.
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	The following template is used to define area offsets as well as for intialization of a new area.

	include	area_structures
	include	stack_frame
	include	stack_header

"
"	The following must be the same as used by pl1_operators_.
"
	equ	tbp,38
	equ	buddy_area.size,2
	equ	buddy_area.inited,3

	entry	alloc_,storage_,freen_,area_,area_assign_,no_freeing,extend,redef
	entry	old_alloc_,old_freen_,old_area_
	segdef	op_alloc_,op_storage_,op_freen_,op_empty_

"
"	The following EQU's define stack variables used by this program. Since
"	the program is called as an operator as well as externally,
"	stack variables not used by pl1_operators_ at the time of the
"	invocation must be used. The regions chosen are the words from 8 to 15,
"	and 56 to 63.
"
"
	equ	lsize,8
	equ	rsize,9
	equ	blocksize,10
	equ	temp,11
	equ	save_x2,12	UPPER
	equ	save_x6,12	LOWER
	equ	save_x0,12	LOWER
	equ	max_size,13
	equ	save_bp,14
	equ	free_count,15
	equ	dtemp1,44		used only for buddy_alloc_op
	equ	dtemp2,46		..
	equ	arglist,56
	equ	saved_p_clock,56	shared with arglist
	equ	ret_bp,62
	equ	min_block_size,8	NOTE. this must be at least 8 because
				"area.freep has lbound of 4.
	equ	max_version,1	maximum expected version number
	equ	max_method,1	maximum expected allocation method


"
"
"	alloc_
"	storage_
"	op_alloc_
"	op_storage_
"
"	These entries allocate a block of the specified size in the specified
"	area. If there is not enough room in the area "area" is signalled
"	unless the area is extensible in which case a new component is found
"	and the block allocated therein.
"
"	The storage_ entries signal "storage" instead of "area" but are
"	otherwise identical.
"
"	The alloc_ (and storage_) entry is called as follows:
"
"	blockp = alloc_ (size, areap)
"
"	The operator op_alloc_ (and op_storage_) is called as follows:
"
"	retry:
"		ldq	size
"		eppbp	area_header
"		tsx0	pr0|allocate_op
"		tra	retry
"
"	a pointer to the allocated block is returned in pr2.
"
"          ________________________________________________
"
"	The size of the block allocated is increased by 2 to account
"	for the block header. A fill word may also be allocated in order
"	to insure that all blocks begin on even word boundaries.
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

	inhibit	on		<+><+><+><+><+><+><+><+><+><+><+>
op_storage_:
	eax6	1		indicates we signal "storage" if need arises
	tra	*+2
op_alloc_:
	eax6	0		indicates we signal "area" if need arises
	eax0	1,0		we want to return one word later
	lda	bp|area.version	check for buddy system areas
	tze	buddy_alloc_op	it is buddy system, perform external call
	tmi	signal_area_3	"bad_area_format"
	cmpa	max_version,dl	check for expected version
	tpnz	signal_area_3	"bad_area_format"
	lda	bp|area.allocation_method
	tmi	signal_area_3	"bad_area_format"
	tze	standard_alloc_op	standard allocation method wanted
	cmpa	max_method,dl	check for expected allocation method
	tpnz	signal_area_3	"bad_area_format"
	tra	no_free_alloc_op

storage_:	eax6	1		indicates we signal "storage" if need arises
	tra	*+2
old_alloc_:
alloc_:	eax6	0		indicates we signal "area" if need arises
	eppbp	ap|4,*		get pointer to area header
	eppbp	bp|0,*		..
	lda	bp|area.version	check for old version
	tze	buddy_alloc	old version, transfer directly
	tmi	signal_area_p3	bad area format, signal "bad_area_format"
	cmpa	max_version,dl	see if expected version number
	tpnz	signal_area_p3	not expected, signal "bad_area_format"
	lda	bp|area.allocation_method dispatch on allocation method
	tmi	signal_area_p3	"bad_area_format"
	tze	standard_alloc	standard allocation method needed
	cmpa	max_method,dl	check for expected allocation method
	tpnz	signal_area_p3	"bad_area_format"

no_free_alloc:
	push	80		get stack frame
	lda	stack_frame.support_bit,dl
	orsa	sp|stack_frame.flag_word
	epbpbp	*		give sp|tbp a non-faulting value
	spribp	sp|tbp		..
	eppbp	ap|4,*		get area header pointer
	eppbp	bp|0,*		..
retry_no_free_alloc_after_area:
	eax0	0		indicates we are not an operator ref
	ldq	ap|2,*		fetch size of block to allocate

no_free_alloc_op:
	eax1	1,ql		force even word alignment
	anx1	-2,du		..
	lda	bp|area.next_virgin	get pointer to new block
	adlx1	bp|area.next_virgin	calculate what will be next next_virgin
	trc	no_room_no_free
	cmpx1	bp|area.last_usable	see if overflows
	trc	no_room_no_free	yes, overflows. Go handle it.
	stx1	bp|area.next_virgin update next_virgin pointer
	eppbp	bp|no_free_area.current_component,*au	generate return pointer
	cmpx0	0,du		see whether called as operator
	tnz	sp|tbp,*0		was operator, just return
	spribp	ap|6,*		external call. return blockp
	return

buddy_alloc:
	xec	get_ptr,6		get pointer to entry to forward call to
	callsp	bp|0		transfer forward...

get_ptr:	eppbp	<buddy_alloc_>|[buddy_alloc_]
	eppbp	<buddy_alloc_>|[buddy_storage_]

buddy_alloc_op:
"
"	We must make an external call to buddy_alloc_$whatever.
"
	spribp	sp|dtemp1		save pointer to area
	sreg	sp|8		save registers
	epbpsb	sp|0		get pointer to stack base so we can get lp
	epaq	*		get segno of this program
	lprplp	sb|stack_header.lot_ptr,*au get lp
	eppbp	sp|13		get pointer to block size (saved in q with regs)
	spribp	sp|arglist+2	save in argument list
	eppbp	sp|dtemp1		get pointer to area pointer
	spribp	sp|arglist+4	save in argument list
	eppbp	sp|dtemp2		we want  buddy_alloc_ to store blockp here
	spribp	sp|arglist+6
	fld	3*2048,dl		generate arg list header
	staq	sp|arglist	..
	xec	get_ptr,6		get pointer to routine to call
	eppap	sp|arglist	get pointer to argument list
	stcd	sp|stack_frame.return_ptr	standard call...
	callsp	bp|0		..
	lreg	sp|8		restore registers
	eppbp	sp|tbp,*		must restore return pointer for pl1 frame
	spribp	sp|stack_frame.return_ptr	..
	eppbp	sp|dtemp2,*	get blockp
	tra	sp|tbp,*0		return to object program
" 
standard_alloc:
	push	80		get stack frame large enough
	lda	stack_frame.support_bit,dl
	orsa	sp|stack_frame.flag_word
	epbpbp	*		give sp|tbp a non-faulting value
	spribp	sp|tbp		..
	eppbp	ap|4,*		get area header pointer
	eppbp	bp|0,*		..
retry_alloc_after_area:
	ldq	ap|2,*		get size of block to allocate
	tpnz	*+2		positive and nonzero is OK
	ldq	min_block_size,dl	if negative or zero use min size
	eax0	0		indicates not operator ref
standard_alloc_op:
	adlq	alloc_blkhdrsz+1,dl		1 for rounding
	canq	=o777777,du	is the requested block too large to be ever allocated?
	tnz	signal_area	yes, then give up.
	anq	-2,dl		complete the rounding function
	qls	18		left justify for compares
	cmpq	min_block_size,du	see if requested block is too small
	trc	*+2		large enough, use input value
	ldq	min_block_size,du	too small, use minimum value from header
	stq	sp|lsize		save in left justified form
	qrl	18		now right justify
	stq	sp|rsize		and save in right justified form

"	Increment and save a counter identifying this allocation
"	instance (uniquely over small intervals of time)

retry_alloc:
	lda	bp|area.allocation_p_clock	allocation instance
	adla	1,dl		this instance (overflows to 0)
	sta	bp|area.allocation_p_clock
	sta	sp|saved_p_clock

"
"	Now search for a large enough block on the free list.
"	First find the appropriate stratum number and save it.
"
	inhibit	off		<-><-><-><-><-><-><-><-><-><-><->

	fld	sp|rsize		get desired size
	lde	=26b25,du		convert to correct floating pt. value
	fad	=0.0e0,du		normalize to get correct exponent
	ste	sp|temp		get log2 (size)
	ldq	sp|temp		..
	qrl	28-18		leave in q-upper
	cmpq	16,du		clip value
	tmoz	stratum_loop	if too high
	ldq	16,du
stratum_loop:
	ldx2	bp|area.freep-3,qu	see if anything in free list
	tze	next_stratum	nothing on this free list, try next
	lxl3	bp|area.freep-3,qu	get max size for this stratum
	tze	try		if the field is zero, we don't know max
	cmpx3	sp|lsize		compare against size we want
	tnc	next_stratum	not a large enough block, goto next stratum
try:	stx2	sp|temp		save pointer to head of free list
	ldx1	40000,du		loop check...only allow 40000 steps
	stz	sp|max_size	initialize cell used in calculating max size
"
"	Before using the fields in any block, we will check for an IPS
"	race (asynchronous invocation).  The reason for this is that
"	an asynchronous invocation could have invalidated the block
"	we are about to examine.  If this happen, we will retry from
"	the beginning.

	lda	sp|saved_p_clock	to check for IPS race
test_size:
	cmpa	bp|area.allocation_p_clock	check for IPS race
	tnz	retry_alloc	one has occurred--retry
	lxl3	bp|block.cur_size,2	get size of this free block from header
	cmpx3	sp|lsize		see if large enough
	trc	large_enough	yes...
	cmpx3	sp|max_size	update max size value
	tnc	*+2		..
	stx3	sp|max_size	..
	ldx2	bp|block.fp,2	chain to next free block
	cmpx2	sp|temp		see if we're back to the beginning
	tze	next_stratum_1	yes, try the next stratum
	eax1	-1,1		count steps
	tpl	test_size		loop back if not too many steps
	tra	signal_area_3	signal "bad_area_format"

next_stratum_1:
	ldx1	sp|max_size	reset max size for this stratum list
	sxl1	bp|area.freep-3,qu	..
next_stratum:
	eaq	1,qu		skip to next stratum
	cmpq	17,du		see if we've done them all
	tnc	stratum_loop	no, keep searching
	tra	use_virgin	all used up, take from virgin territory

	inhibit	on		<+><+><+><+><+><+><+><+><+><+><+>
large_enough:

"	Check for race with asynchronous invocation (IPS signal)
"	Race exists if saved allocation instance doesn't match
"	the one in the header.

	lda	sp|saved_p_clock	saved allocation instance
	cmpa	bp|area.allocation_p_clock	lose race?
	tnz	retry_alloc		yes--retry allocation

	lca	1,dl		update free count in header
	asa	bp|area.n_free	..
	eax4	0,2		needed by unthread routine
	tspbb	unthread		remove block from free list
	tra	*+2		don't save free pointer if nothing in list
	stx7	bp|area.freep-3,qu	implement roving pointer
free_merge:
	stz	sp|temp		save size of the block
	stx3	sp|temp		..
	eax4	sp|temp,*2	x4 -> next block after free block
	sblx3	sp|lsize		get left over size
	cmpx3	min_block_size,du	see if left over will be too small
	tmoz	correct_size	the block is the right size, take it
	stx3	bp|block.prev_size,4 save size of left over free block
"
"	Make a header for the left over block. Also update current header.
"
	ldx5	sp|lsize		get size of current block
	sxl5	bp|block.cur_size,2	save in current header
	eax5	sp|lsize,*2	get pointer to left over region
	lda	bp|block.header,2	calculate header ptr for new block
	ana	-1,dl		..
	sbla	sp|rsize		leaves size of left over region
	ora	block.prev_busy,du	turn on busy bit for preceding block
	sta	bp|block.header,5	assumes busy bit in same word with header ptr
	sxl3	bp|block.cur_size,5	save size of left over block
	ldx3	sp|lsize		get size of newly allocated block
	stx3	bp|block.prev_size,5 save in new header
"
"	Now make a call to the freen_1 subroutine to free up the left over
"	block. We must save bp and x2 which are used by that routine.
"
	sprpbp	sp|save_bp	save what gets wiped by freen_1
	stx2	sp|save_x2
	eax2	0,5		make x2 -> block to be freed
	tspab	freen_1		free it up
	lprpbp	sp|save_bp
	ldx2	sp|save_x2
	tra	return_ptr

correct_size:
	lda	block.prev_busy,du	turn on busy bit for this block
	orsa	bp|block.prev_busy_word,4	..
	tra	return_ptr

use_virgin:
	lda	bp|area.last_usable	get size of virgin storage remaining
	sbla	bp|area.next_virgin	..
	cmpa	sp|lsize		see if requested size is too large
	tnc	no_room		yes, overflow condition
	ldx2	bp|area.next_virgin	get index to last word used
	ldx3	bp|area.last_size	generate header for new block
	stx3	bp|block.prev_size,2 ..
	adlx3	bp|area.last_block	update pointer to last allocated block
	stx3	bp|area.last_block	..
	ldx3	bp|area.next_virgin	(we cannot complement 400000(8) in an xreg)
	cmpx3	=o400000,du
	tze	2,ic
	lcx3	bp|area.next_virgin	 ..
	sxl3	bp|block.header,2	 ..
	ldx3	block.prev_busy,du	turn busy bit on for previous block
	stx3	bp|block.prev_busy_word,2 ..
	lxl3	sp|rsize		now update area header
	stx3	bp|area.last_size	..
	sxl3	bp|block.cur_size,2
	adlx3	bp|area.next_virgin	update next available pointer
	stx3	bp|area.next_virgin	..

return_ptr:
	lda	1,du
	asa	bp|area.n_allocated
	stz	bp|2,2	always zero this word in case the area is being
			"zerod on free to get zero blocks
	lda	bp|area.flags	now see if we should zero the block
	cana	area.zero_on_alloc,du	..
	tze	dont_zero		no, just return pointer
	eppbb	bp|3,2		get pointer to first word to zero
	lda	sp|rsize		get number of words to clear
	sbla	3,dl		don't zero block header
	als	2		multiply by 4 for MLR

	inhibit	off		<-><-><-><-><-><-><-><-><-><-><->
	mlr	(),(pr,rl),fill(0)
	desc9a	0,0
	desc9a	bb|0,al
dont_zero:
	eppbp	bp|2,2		get actual pointer to block
	cmpx0	0,du		see if operator ref
	tnz	sp|tbp,*0	 	yes, return immediately
	spribp	ap|6,*		return it to caller
	return
"
"	Come here when there is no room in the current area component
"	for the requested allocation. Check to see if the area is
"	extensible, and, if so, call to get a pointer to the next
"	component of the area.
"
no_room:
	lda	bp|area.flags	get flags word from header
	cana	area.extend,du	see if the area is extensible
	tze	signal_area	no, we must signal "area"
	ldq	sp|rsize		see if allocation is impossibly large (rsize includes header size)
	cmpq	262144-1024-area_size-extend_block_size-alloc_blkhdrsz+1,dl  includes extend block and allocated block header overhead
	trc	signal_area	block too large even for empty area
"
"	The area is extensible. Get a pointer to the next component.
"
	sxl0	sp|save_x0
	epbpsb	sp|0		generate linkage pointer
	epaq	*		..
	lprplp	sb|stack_header.lot_ptr,*au
	spribp	sp|save_bp		prepare arglist
	lda	4,du			..
	ldq	0,du
	staq	sp|arglist
	eppbp	sp|save_bp	generate argument list
	spribp	sp|arglist+2
	eppbp	sp|ret_bp
	spribp	sp|arglist+4
	eppap	sp|arglist	..
	stcd	sp|stack_frame.return_ptr
	callsp	<get_next_area_ptr_>|[get_next_area_ptr_]

	lxl0	sp|save_x0
	eppbp	sp|tbp,*		must restore pl1 frame's return pointer
	spribp	sp|stack_frame.return_ptr
	eppbp	sp|ret_bp,*		get pointer to next component
	cmpx0	0,du		don't load ap if operator
	tnz	retry_alloc
	eppap	sp|stack_frame.arg_ptr,*	must restore argument list pointer
	tra	retry_alloc

no_room_no_free:
	lda	bp|area.flags	get flags word from header
	cana	area.extend,du	see if the area  is extendable
	tze	signal_area	no, we must signal "area"
	cmpq	262144-1024-area_size-extend_block_size+1,dl  is size too big for empty area?
	trc	signal_area	yes--abort
"
"	The no_free area area is extendable, get a pointer to the next component
"
	sreg	sp|8
	epbpsb	sp|0		generate linkage ptr
	epaq	*
	lprplp	sb|stack_header.lot_ptr,*au
	eppbp	bp|no_free_area.current_component generate arg list
	spribp	sp|arglist+2
	eppbp	sp|ret_bp
	spribp	sp|arglist+4
	fld	2*2048,dl
	staq	sp|arglist
	eppap	sp|arglist
	stcd	sp|stack_frame.return_ptr
	callsp	<get_next_area_ptr_>|[get_next_area_ptr_]

	lreg	sp|8
	eppbp	sp|tbp,*		must restore pl1 frame stuff
	spribp	sp|stack_frame.return_ptr
	cmpx0	0,du		don't load ap if operator
	tnz	2,ic
	eppap	sp|stack_frame.arg_ptr,*
"
"	Hook up new component to first component
"
	epplp	sp|ret_bp,*		get ptr to new component
	lda	lp|area.extend_info
	lprpbp	lp|extend_block.first_area,au	get ptr to first component
	sprilp	bp|no_free_area.current_component
	lda	lp|area.last_usable	refresh area info
	sta	bp|area.last_usable	..
	lda	lp|area.next_virgin	..
	sta	bp|area.next_virgin	..
	tra	no_free_alloc_op	and try again

" 
"
"	area_
"	op_empty_
"
"	These routines initialize a given area in the specified way.
"	The various calling sequences are:
"
"	call area_ (size, areap)
"	call area_$no_freeing (size, areap, extend)
"	call area_$extend (size, areap)
"	call area_$redef (size, areap);
"
"	The op_empty_ entry is called after loading the bp with a
"	pointer to the area and the q-reg with the size.
"
"		ldq	size
"		eppbp	area_header
"		tsx0	pr0|empty_operator
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

	inhibit	on		<+><+><+><+><+><+><+><+><+><+><+>
old_area_:
area_:	eax1	0		describes type of area being initialized
areajoin:	eax0	0		indicates not an operator call
	eppbp	ap|4,*		get a pointer to what will be the initialized header
	eppbp	bp|0,*		..
	ldq	ap|2,*		get size of the area
	tmoz	signal_area_p1	bad value
op_join:	qls	18		left justify

	eppbb	<template_area_header>|[template_area_header]
	mlr	(pr),(pr)
	desc9a	bb|0,area_size*4
	desc9a	bp|0,area_size*4

	stq	bp|area.last_usable	fill in variable items
	tra	*+1,1*		dispatch on initialization type
	arg	standard_area
	arg	no_free_area
	arg	extend_area

no_free_area:
	lda	area.dont_free,du	make sure free requests are ignored
	orsa	bp|area.flags	..
	spribp	bp|no_free_area.current_component
	aos	bp|area.allocation_method set method type to 1
	lda	ap|6,*		get extend flag
	tze	standard_area	extensible area not wanted
"
"	Now allocate a block large enough to hold the extend information.
"
extend_area:
	lda	area.extend,du	set extend flag ON in header
	orsa	bp|area.flags
	lda	extend_block_size+2,du get size for the extend block
	ldq	bp|area.next_virgin	get start of new last block
	asa	bp|area.next_virgin	update header for new block
	stq	bp|area.extend_info	..
	stq	bp|area.last_block	..
	sta	bp|area.last_size	..
	eppbb	=its(-1,1),*	initialize variables in extend block
	sprpbb	bp|extend_block.next_area,qu
	sprpbp	bp|extend_block.first_area,qu
standard_area:
	cmpx0	0,du		see if called as operator
	tnz	sp|tbp,*0		yes, return in standard way
	short_return

no_freeing:
	eax1	1		set initialization type
	tra	areajoin
extend:
	eax1	2		set initialization type
	tra	areajoin

op_empty_:
	eax1	0		set initialization type
	tra	op_join

redef:	eppbp	ap|4,*		get pointer to the area
	eppbp	bp|0,*		..
	lda	bp|area.version	check version of area
	tze	<buddy_area_>|[buddy_redef]

	lxl0	ap|2,*		get size to redefine area to have
	cmpx0	bp|area.next_virgin	see if we fit
	tnc	signal_area_p0	no, complain by signalling area
	stx0	bp|area.last_usable	reset end of area
	short_return

"
"
"	area_assign_
"
"	This entry copies one area into the storage of an already initialized other area.
"	If the receiving area is not large enough, "area" is signalled.
"
"	call is:
"
"	call area_assign_ (new_areap, old_areap)
"
"	where:
"		new_areap is the target, pointed to by bp.
"		old_areap is the source, pointed to by bb.
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

area_assign_:
	eppbp	ap|2,*		get pointer to new area
	eppbp	bp|0,*		..
	eppbb	ap|4,*		get pointer to old area
	eppbb	bb|0,*		..

	lda	bp|area.version	check new for buddy or empty area
	tze	new_is_buddy_or_empty
new_is_new:
	lda	bb|area.version	check old for buddy or empty
	tze	old_is_buddy_or_empty
both_are_new:
	lda	bb|area.next_virgin	see if enough room
	cmpa	bp|area.last_usable	..
	tze	*+2		ok if equal
	trc	signal_area_p0
	ldq	bb|area.flags	check for need to zero past virgin portion
	canq	area.zero_on_free,du ..
	tnz	assign_and_fill	is zero_on_free...needs fill
	canq	area.zero_on_alloc,du check for NO_FREEING & zero_on_alloc
	tze	assign_no_fill	isn't zero_on_alloc...don't need fill
	ldq	bb|area.allocation_method
	cmpq	NO_FREEING_ALLOCATION_METHOD,dl
	tnz	assign_no_fill	isn't NO_FREEING...doesn't need fill
"				fall through...is both zero_on_alloc & NO_FREEING
"
assign_and_fill:
	ldq	bp|area.last_usable	get length of target (new)
	lrl	18-2		get char count in AL, QL
	inhibit	off		<-><-><-><-><-><-><-><-><-><-><->
	mlr	(pr,rl),(pr,rl),fill(000)
	desc9a	bb|0,al		source
	desc9a	bp|0,ql		target
	inhibit	on		<+><+><+><+><+><+><+><+><+><+><+>
	qls	18-2		restore word count to QU
	stq	bp|area.last_usable	restore size of area
	short_return
"
assign_no_fill:
	ldq	bp|area.last_usable	hold length of target (new)
	arl	18-2		get char count in AL
	inhibit	off		<-><-><-><-><-><-><-><-><-><-><->
	mlr	(pr,rl),(pr,rl)
	desc9a	bb|0,al		source
	desc9a	bp|0,al		target
	inhibit	on		<+><+><+><+><+><+><+><+><+><+><+>
	stq	bp|area.last_usable	restore size of area
	short_return
"
new_is_buddy_or_empty:
	lda	bp|buddy_area.inited see if empty
	tnz	new_is_buddy	not empty, is buddy
	eppab	<template_area_header>|[template_area_header]
	lda	bp|buddy_area.size
	als	18
	inhibit	off		<-><-><-><-><-><-><-><-><-><-><->
	mlr	(pr),(pr)
	desc9a	ab|0,area_size*4
	desc9a	bp|0,area_size*4
	inhibit	on		<+><+><+><+><+><+><+><+><+><+><+>
	sta	bp|area.last_usable
	tra	new_is_new
new_is_buddy:
	lda	bb|area.version	check version of old area
	tnz	signal_area_p2	old is not buddy - error
	lda	bb|buddy_area.inited see if empty
	tnz	<buddy_area_assign_>|[buddy_area_assign_] both are buddy - ok
	tra	signal_area_p2	old is empty, new is buddy - error
old_is_buddy_or_empty:	"already know new is not buddy
	lda	bb|area.version	check if buddy or empty
	tnz	both_are_new
	lda	bb|buddy_area.inited
	tnz	signal_area_p2
	eppab	<template_area_header>|[template_area_header]
	lda	bb|buddy_area.size
	als	18
	inhibit	off		<-><-><-><-><-><-><-><-><-><-><->
	mlr	(pr),(pr)
	desc9a	ab|0,area_size*4
	desc9a	bb|0,area_size*4
	inhibit	on		<+><+><+><+><+><+><+><+><+><+><+>
	sta	bb|area.last_usable
	tra	both_are_new

signal_area_p0:
	eax6	0		"area"
	tra	signal_area_p
signal_area_p1:
	eax6	2		"bad_area_initialization"
	tra	signal_area_p
signal_area_p2:
	eax6	3		"bad_area_assignment"
	tra	signal_area_p
signal_area_p3:
	eax6	4		"bad_area_format"
signal_area_p:
	push	80
	lda	stack_frame.support_bit,dl
	orsa	sp|stack_frame.flag_word
	eax0	0		indicates not pl1_operator_ call
	tra	signal_area

	inhibit	off		<-><-><-><-><-><-><-><-><-><-><->
" 
"
"	freen_
"	op_freen_
"
"	These entries free up the block pointed to by the input pointer.
"	The block is merged with adjacent blocks if they are free.
"
"	The call for the external entry is:
"
"	call freen_ (blockp)
"
"	The operator entry (op_freen_) is invoked as follows:
"
"		epplb	addr(pointer to block_to_free)
"		tsx0	pr0|free_op
"
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

	inhibit	on		<+><+><+><+><+><+><+><+><+><+><+>
old_freen_:
freen_:
	eppbp	ap|2,*		make a check for buddy area before doing push
	eppbp	bp|0,*		get pointer to block
	lda	bp|-1		see if buddy area
	tmi	<buddy_freen_>|[buddy_freen_] yes, forward the call
	push	80		now get a stack frame
	lda	stack_frame.support_bit,dl
	orsa	sp|stack_frame.flag_word
	epplb	ap|2,*		get pointer to block to free
	eppbp	lb|0,*		..
	eax0	0		not operator use
op_freen_join:
"
"	Get standard register values. x2 -> block, bp -> header.
"
	lxl2	bp|block.header-2	fetch header pointer from block header
	eppbp	bp|-2,2		make bp -> header
	erx2	-1,du		complement C(x2)
	adlx2	1,du		..

	lda	bp|area.flags	check if freeing is enabled
	cana	area.dont_free,du	..
	tnz	free_ret		disabled, skip freen_1 subroutine work
"
	lca	1,du		decrement used blocks
	asa	bp|area.n_allocated
	tspab	freen_1		do the work in this subroutine
free_ret:
	eppbb	=its(-1,1),*	null out return pointer
	spribb	lb|0		passed by caller
	cmpx0	0,du		perform appropriate return
	tnz	sp|tbp,*0	
	return

op_freen_:
	eppbp	lb|0,*		get pointer to block
	lda	bp|-1		check if buddy area
	tpl	op_freen_join	no, use standard code
"
"	We were called as operator to free up old style area's block.
"	We must make an external call to buddy_freen_.
"
	sprilb	sp|arglist+2	save pointer to block pointer
	sreg	sp|8		save registers
	epbpsb	sp|0		get pointer to stack base so we can get lp
	epaq	*		get segno of this program
	lprplp	sb|stack_header.lot_ptr,*au get lp
	lda	4,du		generate arg list header
	ldq	0,du		..
	staq	sp|arglist	..
	eppap	sp|arglist	get pointer to argument list
	stcd	sp|stack_frame.return_ptr	standard call...
	callsp	<buddy_freen_>|[buddy_freen_]
	lreg	sp|8		restore registers
	eppbp	sp|tbp,*		must restore return pointer for pl1 frame
	spribp	sp|stack_frame.return_ptr	..
	tra	sp|tbp,*0		return to object program

"
"
"	Subroutine to free the block pointed to by x2. The base
"	of the area is pointed to by bp.
"
freen_1:
	inhibit	off		<-><-><-><-><-><-><-><-><-><-><->

	lda	1,dl		keep track of how many blocks are freed
	sta	sp|free_count
	ldaq	bp|0,2		fetch entire header
	als	18		left justify
	sta	sp|blocksize	save for now in accumulating total
	ldx3	bp|area.flags	see if must zero block
	canx3	area.zero_on_free,du ..
	tze	not_zof		dont bother
	epplp	bp|0,2		pointer to block being freed
	eaa	-3,au		count of words to zero
	als 	2		count of bytes to zero
	mlr	(),(pr,rl)	zero block contents
	desc9a	0,0		zeroes
	desc9a	lp|3,au		bytes to be zeroed after block header
not_zof:
	inhibit	on		<+><+><+><+><+><+><+><+><+><+><+>
	lda	bp|area.allocation_p_clock	guard against IPS race
	adla	1,dl			..
	sta	bp|area.allocation_p_clock	..
	eax3	sp|blocksize,*2	x3 -> nextblock
	canq	block.prev_busy,du	see if previous block is free
	tze	prev_free		no
	cmpx2	bp|area.last_block	see if freeing last block
	tze	free_last_block	yes, special case
	tra	check_next	no, see if next block is free
prev_free:
"
"	The previous block is free. Merge it with the current block.
"	Accumulate the size of the ultimate free block in blocksize.
"
	lca	1,dl		already free, undo previous subtraction
	asa	sp|free_count	..
	ldx4	bp|block.prev_size,2 get size of previous block
	stx4	sp|temp
	adlx4	sp|blocksize	update blocksize
	stx4	sp|blocksize	..
	stz	bp|0,2		in case of zero_on_free
	stz	bp|1,2		clear intervening header words
	stz	bp|2,2		 ..
"
"	Thread previous block out of its free list.
"
	eax4	0,2		make x4 point to previous block
	sblx4	sp|temp		..
	tspbb	unthread		thread block out of list
	nop			"ignore if just zerod list
	cmpx2	bp|area.last_block	see if we are freeing the last block
	tnz	not_last		no, proceed normally
	stx4	bp|area.last_block	yes, update header variables
	eax2	0,4		pretend we are freeing the merged block
	tra	free_last_block

not_last:	eax2	0,4		pretend we are freeing the merged block

"	See if next block is free.

check_next:
	cmpx3	bp|area.last_block	see if next block is last in area
	tze	next_busy		yes, it therefore can't be free
	ldaq	bp|0,3		get header for next block
	als	18		left justify current size
	sta	sp|temp		so we can generate a pointer to next header
	eax4	0,3		set x4 in case needed by unthread
	eax5	sp|temp,*3	get pointer to following header
	ldq	bp|block.prev_busy_word,5	check if block is free
	canq	block.prev_busy,du	..
	tnz	next_busy
"
"	Next block is free. Merge it with current block.
"
	lcq	1,dl
	asq	sp|free_count
	adla	sp|blocksize	update size of free block
	sta	sp|blocksize	..
	tspbb	unthread		thread the block out of the free list
	nop			"ignore if just zerod list
	eax3	0,5		x3 -> next block after free block
	stz	bp|0,4		in case zero_on_free
	stz	bp|1,4		clear header of unthreaded block
	stz	bp|2,4		 ..

next_busy:

	ldx1	sp|blocksize	get accumulated size of block being freed
	sxl1	bp|block.cur_size,2	update header of block being freed
	stx1	bp|block.prev_size,3	..
	lcx1	block.prev_busy+1,du	turn off busy bit
	ansx1	bp|block.prev_busy_word,3	..


"	Thread the block into free list.
"	First get stratum number for list to thread into.

	lda	sp|blocksize	get size of total block
	arl	18		convert to integer
	sta	sp|temp		save integer form
	fld	sp|temp		now perform conversion as in alloc_ entry
	lde	=26b25,du		..
	fad	=0.0e0,du		..
	ste	sp|temp		..
	ldq	sp|temp		..
	qrl	28-18		..
	cmpq	16,du		clip if too high
	tmoz	*+2
	ldq	16,du
	eppbb	bp|block.q_no_word,2 get pointer to header for storing q_no
	stcq	bb|0,10		save q_no in current header

	ldx1	bp|area.freep-3,qu	get free list pointer
	tze	empty		nothing there yet, special case
	lxl5	bp|block.bp,1
	sxl2	bp|block.bp,1
	stx1	bp|block.fp,2
	stx2	bp|block.fp,5
	sxl5	bp|block.bp,2
	stx2	bp|area.freep-3,qu	roving pointer ...
	lxl5	bp|area.freep-3,qu	update max size if needed
	tze	all_done	if zero, must recalculate next full search
	cmpx5	sp|blocksize	see if adding largest block
	trc	all_done	no, don't need to change max
	ldx5	sp|blocksize	get new max value
out:	sxl5	bp|area.freep-3,qu	update max size for this list
all_done:	ldq	sp|free_count	update count of free blocks
	asq	bp|area.n_free	..
	tra	ab|0

empty:	stx2	bp|area.freep-3,qu	set free ptr to single entry in list
	stx2	bp|block.fp,2	make entry point to itself
	sxl2	bp|block.bp,2	..
	ldx5	sp|blocksize	get set to update max free size for this list
	tra	out

"
"	The following subroutine is used to thread the block pointed to
"	by index 4 out of the free list. If this results in an empty free list,
"	the return is made to bb|0, otherwise, the return is made to
"	bb|1.
"
unthread:
	ldq	bp|block.q_no_word,4 get stratum number for this free block
	anq	block.q_no_mask,du	..
	lxl7	bp|area.freep-3,qu	get max entry in list to see if unthreading largest
	stx7	sp|temp		save for compare
	lxl7	bp|block.cur_size,4	see if unthreading largest entry
	cmpx7	sp|temp		..
	tnz	not_big		not largest, ok
	eax7	0		zero max size to indicate we don't know it
	sxl7	bp|area.freep-3,qu	..
not_big:	ldx7	bp|block.fp,4	x7 -> next link in free chain
	lxl1	bp|block.bp,4	x1 -> previous link in free chain
	cmpx4	bp|block.fp,4	are they the same?
	tze	last_free		yes, last free block in free list
	stx7	bp|block.fp,1	thread around the block
	sxl1	bp|block.bp,7	..
	cmpx4	bp|area.freep-3,qu	see if pointing to head of list
	tnz	bb|1		no, continue
	stx7	bp|area.freep-3,qu	yes, change head of list
	tra	bb|1

last_free:stz	bp|area.freep-3,qu	free list now empty, clear pointer word
	tra	bb|0		continue

"
"
"	Come here when freeing the last block before virgin territory.
"
free_last_block:
	lcq	1,dl		decrement count of free blocks
	asq	sp|free_count
	lda	bp|area.last_block	update header of area
	sta	bp|area.next_virgin	..
	ldx3	bp|block.prev_size,2	get size of previous block for header
	stx3	bp|area.last_size	save in header
	erx3	-1,du		complement C(x3)
	adlx3	1,du
	adlx3	bp|area.last_block	update pointer to last allocated block
	stx3	bp|area.last_block	..

	lda	sp|blocksize	get size of the block
	stz	bp|0,2		clear header words--they will be in virgin territory
	stz	bp|1,2		 ..
	stz	bp|2,2		 ..
	tra	all_done
	inhibit	off		<-><-><-><-><-><-><-><-><-><-><->



"

"
"	Come here when we must signal "area", "storage", or "bad_area_initialization"
"
signal_area_3:
	eax6	4		"bad_area_format"
	tra	signal_area
signal_area_2:
	eax6	3		"bad_area_assignment"
	tra	signal_area
signal_area_1:
	eax6	2		"bad_area_initialization"
signal_area:
	cmpx0	0,du		were we called as an operator?
	tze	signal_for_subr	yes, branch
	eax0	-1,0		subtract one to point to retry location in caller
	sxl0	sp|stack_frame.operator_ret_ptr	save for call_signal_
	tra	signal_join
signal_for_subr:
	sxl6	sp|save_x6	save for retry
	eax1	*		set up stack frame for call_signal_
	sxl1	sp|stack_frame.operator_ret_ptr
	epbpbp	*
	spribp	sp|tbp
signal_join:
	eppbp	name,6*		get pointer to name to signal
	ldx6	length,6		get length of name in x6
	ldq	1000,dl		get oncode in q
	tsx1	<pl1_operators_>|[call_signal_]
	stz	sp|stack_frame.operator_ret_ptr	clear after signal
	ldx0	sp|8		restore index 0 saved by call_signal_
	tnz	sp|tbp,*0		return to pl1 program to retry allocation
"
	lxl6	sp|save_x6	restore for retry
	eppap	sp|stack_frame.arg_ptr,*	restore arg pointer
	eppbp	ap|4,*		get area header pointer
	eppbp	bp|0,*		..
	lda	bp|area.allocation_method	see if no_freeing method used
	tze	retry_alloc_after_area	no, go retry it
	tra	retry_no_free_alloc_after_area

name:	arg	area_name
	arg	storage_name
	arg	area_init_name
	arg	bad_assign_name
	arg	bad_area_format_name
length:	zero	4,0
	zero	7,0
	zero	23,0
	zero	19,0
	zero	15,0
area_name:	aci	"area"
storage_name:	aci	"storage"
area_init_name:	aci	"bad_area_initialization"
bad_assign_name:	aci	"bad_area_assignment"
bad_area_format_name:
		aci	"bad_area_format"

	end




		    any_to_any_.alm                 10/01/90  1629.0rew 10/01/90  1626.2     1655631



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Bull Inc., 1987                *
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1984 *
" *                                                         *
" ***********************************************************

" HISTORY COMMENTS:
"  1) change(86-04-29,Oke), approve(86-05-30,MCR7424), audit(86-05-30,Mabey),
"     install(86-06-12,MR12.0-1075):
"     flt_dec.fix_bin.zero case after mp3d or dv3d assumed length in x3 was
"     valid, it needed copy from x4.
"  2) change(86-04-29,Oke), approve(86-05-30,MCR7424), audit(86-05-30,Mabey),
"     install(86-06-12,MR12.0-1075):
"     Scan for bad characters before skipping leading blanks in
"     char_to_arithmetic_.  Otherwise we run off the blank skip table to other
"     tables, and invalidly accept some bad inputs.
"  3) change(86-07-15,Ginter), approve(86-07-15,MCR7435),
"     audit(86-07-16,Mabey), install(86-07-28,MR12.0-1104):
"     Change by M Mabey (installed by Ginter) - Conversions from fixed bin
"     numbers with negative scale factors to float decimal, character, and
"     bits would fail.
"  4) change(90-08-27,Blackmore), approve(90-08-27,MCR8194),
"     audit(90-09-14,Oke), install(90-10-01,MR12.4-1035):
"     Fix entry 40 in the arrays 'stype' and 'ttype' to fix treatment of fixed
"     decimal unsigned 4-bit values (Multics type 40).  Also fix treatment of
"     exponent to floating decimal values during conversion into a bitstring.
"                                                      END HISTORY COMMENTS


"	PL/I Conversion Package
"
"	BLW, Spring 1973
"	Re-written by T. Oke 1983. SEE MTB-672 for details.

"	Character input of "" mis-handled.  Fixed 84-03-13 by T. Oke
"	Char to bit fills "0"b to wrong target.  Fixed 84-03-14 by T. Oke
"	Flt Dec to Scaled bin forms bad on zero. Fixed 84-03-16 by T. Oke
"	Flt Dec to Bit did no offset when replacing exponent.  Fixed 84-03-16
"	     by T. Oke
"	varying char and bit target routines did not limit to source length.
"	     Fixed 84-04-16 by T. Oke
"	optimization of flt_bin_to_flt_dec omitted converting the last bit
"	     of the flt bin mantissa.  Fixed 84-04-16 by T. Oke
"	original_source_length length not saved prior to error_205 detection
"	     which calls error_xxx, which uses uninitialized
"	     original_source_length. error_205 now forces string to 256.
"	      PHX17351  Fixed 84-04-19 by T. Oke
"	Full conversion precision from flt_decimal to flt_bin.  Maintained
"	     through use of precision correction determined from upper non-0
"	     digit of flt_decimal.  We convert to flt_bin 70 to flt_bin 71.
"	Correct error_176 to become error_191.  Oncode message 376 does not
"	     exist, but 391 was correct message.
"	Correct handling of scaled fixed bin to correct the scale factor with
"	     a fixed exponent and produce the right values.
"
"     Installed into MR11 - October 1984.

"	put_bit of aligned target must pre-clear 1st and possible 2nd word to
"	     avoid padded reference bug.  Fixed 84-11-09 by T. Oke
"	load_flt_dec.target needs to validate 0.0  number to prevent size
"	     condition falsely signalled.  Fixed 84-11-09 by T. Oke
"	flt_dec.fix_bin.zero used length of flt_dec source rather than needed
"	     fix_dec target to convert causing size error.  Fixed 84-11-12 by
"	     T. Oke
"	end_get_fix_dec.normalized used X2 as length of fixed decimal
"	     generic.  X2 is invalid at this point, should use X3 instead as
"	     length of float decimal generic to fix exponent.
"	     Fixed 84-11-12 by T. Oke
"	recognize.no_sign did not skip leading 0's to prevent conversion
"	     errors indicating too many digits.  Now leading 0's don't count.
"	     Fixed 84-11-13 by T. Oke
"	move_char_to_numeric needs to recognize 0-length input.
"	     Fixed 84-11-16 by T. Oke
"	Fix minimum recognized precision to 1 in case of blank or 0 input.
"	     Fixed 84-11-19 by T. Oke
"	rtrim source string for char_to_numeric_ input.  84-11-19 by T. Oke
"	Use pl1_signal_conversion_ rather than
"	     plio2_signal_$conversion_error_.  84-11-20 by T. Oke
"	84-11-29 by T. Oke.  What is hoped to be the final fix to skipping
"	     leading zeros.  Now we remember that an integer part was seen
"	     then remove leading zeros from precision calculation.
"	85-02-07 by T. Oke.  Moved code in convert_flt_bin_to_flt_hex to
"	     correct rounding test.  Somehow mask index code got moved.
"	     Fixed rounding.

	segdef	real_to_real_
	segdef	real_to_real_round_
	segdef	real_to_real_truncate_
	segdef	any_to_any_
	segdef	any_to_any_round_
	segdef	any_to_any_truncate_
	segdef	char_to_numeric_

	include	eis_micro_ops
	include	pl1_system
	include	stack_header
	include	stack_frame
"
"	mnemonics for CSL instruction
"
	bool	move,03
"
"	description of error extension of stack
"
	equ	error_extension,128	size of extension
	equ	save_ptrs,0
	equ	save_regs,16
	equ	call_ptr,24
	equ	arglist,26
	equ	oncode,save_regs+4
	equ	onchar_index,save_regs+5
	equ	name_length,save_regs+5
	equ	onsource_ptr,save_ptrs+4	assumes s = 2
	equ	onsource,64
"	WORK AREA DESCRIPTION.
"
"     There are two work areas of:
"	 28 words - Normal numeric to numeric, bit to bit.
"	118 words - to character, character to numeric.
"     Old programs (compiled before release 24) reference two work areas,
"     of 36 and 156 words.

"     Token information for character to numeric input.  Used by recognize to
"     build token information from input stream.

	equ	sign_part,0
	equ	integer_part,1
	equ	fractional_part,2
	equ	exponent_part,3
	equ	type_part,4
	equ	prec_part,5		" precision and scale
	equ	token_size,6		" number of words in token
	equ	token_length,token_size*4	" five words of 4 chars each

	macro	token_info
	equ	&1_token,&2		" start of token
	equ	&1.sign.index,&2+0		" sign index in DL
	equ	&1.sign.length,&2+0		" sign length in DU
	equ	&1.integer.index,&2+1	" integer part index in DL
	equ	&1.integer.length,&2+1	" integer length in DU
	equ	&1.fraction.index,&2+2	" fraction index in DL
	equ	&1.fraction.length,&2+2	" fraction length in DU
	equ	&1.exponent.value,&2+3	" exponent value
	equ	&1.type,&2+4		" type in DU
	equ	&1.term,&2+4		" encoded terminator in DL
	equ	&1.scale,&2+5		" scale in DU
	equ	&1.prec,&2+5		" prec in DL
	&endm



	equ	scales,0
	equ	target_scale,0		(DU) target scale
	equ	target_precision,0		(DL) target precision
	equ	source_scale,1		(DU) source scale
	equ	source_precision,1		(DL) source precision
	equ	source_string_length,1	FULL word
	equ	original_source,2		copy of orig source ptr 

"     GENERIC storage.

	equ	fix_bin_generic,4		DOUBLE WORD

	equ	flt_bin_generic,6		DOUBLE WORD float bin
	equ	flt_bin_generic_exp,10	Exponent for float bin

	equ	flt_dec_generic_exp,11	Exponent for float decimal
	equ	flt_dec_generic,12		float decimal (64) bytes
	equ	fix_dec_generic,12		OVERLAY fix dec (64) bytes
	equ	bit_generic,12		** OVERLAY flt_dec_generic
"
"	end of short work area (28 words)

	equ	return,28			save_target return pointer
	equ	save_target_ptr,30		t ptr during binary -> char
	equ	generic_ptr,32		source ptr char_to_arithmetic_
	equ	save_pr4,34		PR4 storage if we destroy
	equ	error_return,36
	equ	save_target_precision,38
	equ	save_rounding,39
	equ	char_generic,40 		GENERIC char (256 B, 64 W)
	equ	char_flt_dec_gen,72		generic flt_dec for char
	equ	original_source_length,104
	equ	save_target_type,105

	maclist	off save
	token_info real,106
	token_info imag,106+token_size
	maclist	restore

"	end of long work area (118 words)
"	character constants

	bool	blank,040
	bool	plus_sign,053
	bool	minus_sign,055
	bool	period,056
	bool	digit_0,060
	bool	digit_1,061
	bool	letter_I,111
	bool	letter_e,145
	bool	letter_f,146
	bool	letter_i,151
"
"	character classes
"
	equ	illegal_class,0
	equ	sign_class,1
	equ	period_class,2
	equ	b_class,3
	equ	de_class,4
	equ	i_class,5
	equ	blank_class,6
	equ	digit_class,7
	equ	f_class,8

"	base register assignments

	equ	target,1		" points to user's target
	equ	generic,2		" points to current generic (char/bit)
	equ	source,3		" points to user's source
	equ	linkage,4		" destroyed in format/recognize
	equ	work,5		" points to working storage area
	equ	sp,6		" points to current caller's stack

"	text base ptr in stack frame

	equ	tbp,38

"     Indicator bits.

	bool	ind_zero,400000
	bool	ind_negative,200000
	bool	ind_carry,100000
	bool	ind_overflow,040000
	bool	ind_exp_overflow,020000
	bool	ind_exp_underflow,010000
	bool	ind_overflow_mask,004000

"     Indicator register fault mask.

	bool	mask_faults,ind_overflow_mask
	bool	unmask_faults,0

"     Length of power of two table.

	equ	two_table_limit,197

"     Type Codes for numeric to character conversion.

	equ	fix_dec_type,2*9		" real_fix_dec_9bit_ls
	equ	flt_dec_type,2*83		" real_flt_dec_gen

"     Type code for generic float decimal.

	equ	real_flt_dec_generic,83
	equ	cplx_flt_dec_generic,84

"     Error declaration and handling.
"     
"     Errors are managed by masking overflow faults throughout the code, using
"     the constants "mask_faults" and "unmask_faults".  Overflows are detected
"     through code sequences for range testing, or through the hardware
"     setting the overflow or exponent overflow bits.  Then the correct error
"     is signalled through a pl1-style call.
"     
"     At the moment all errors signalled in this manner are restartable, even
"     though a "size_error" is declared in documentation as not being
"     restartable.
"     
"     Decimal and float binary range error declaration as underflow or
"     overflow depend upon the correct sign being present in the
"     flt_dec_generic_exp and the flt_bin_generic_exp respectively.  The
"     contents can well be shifted to the upper bits, the the word sign bit
"     must be correct.
"     
"     
"     		TESTING
"     
"     This program has been tested through the test sub-system "test_a" and
"     its associated test scripts to assure correct functioning.  This test
"     sub-system should be used to pinpoint and duplicate all reported errors
"     and to verify correct functioning after error removal.
"
"     Three basic test suites are used:
"
"	fetch_tests.test_a	Tests ability to fetch values with minimum
"			converison done.
"	store_tests.test_a	Tests ability to store results with minimum
"			conversion done.  Pre-requisite is fetch_tests.
"    	c_test.rnd.test_a	Tests conversion and fixups with rounding.
"			Pre-requisites are fetch and store tests.
"
"     When you do any work on assign_ or any_to_any_ please add to these test
"     suites.

"     Work Area allocation has been done in two areas, rather than the
" previous three areas.
" 
"     The first area matches the previous smallest area, and is 28 words in
" length.  The second area is a total of 118 words in length.  The previous
" second area was 44 words in length and had a decimal temporary within it.
" This functionality has been absorbed within the first area.
" 
"     The previous third area was a total of 158 words in length, and its
" functionality has been absorbed by the new second area's 118 word length.
" 
"     The first area is used for all numeric to numeric conversions, pl1
" bit to bit, and pl1 character to character conversions.  The second area is
" used for numeric to character and character to numeric and bit conversions.
" It is also required if conversions of bit or character input, other than pl1
" type descriptors, are done, where a re-structure of the stream is needed.ANY_TO_ANY_ CALLERS as of: 84-03-19


" References to any_to_any_:  (bound_library_wired_ in HARDCORE)
"    assign_.alm		200 words
"    put_format_.alm	156 words
" References to any_to_any_$any_to_any_round_:  (bound_library_wired_ in HARDCORE)
"    assign_.alm		200 words
"    formline_.alm		160 words
"    pl1_operators_.alm	passed by user program 'convert' = 164 words
"    put_format_.alm	156 words
" References to any_to_any_$any_to_any_truncate_:  (bound_library_wired_ in HARDCORE)
"    assign_.alm		200 words
"    formline_.alm		160 words
"    pl1_operators_.alm	passed by user program 'convert' = 164 words
" References to any_to_any_$char_to_numeric_:  (bound_library_wired_ in HARDCORE)
"    assign_.alm		200 words
" References to any_to_any_$real_to_real_round_:  (bound_library_wired_ in HARDCORE)
"    pl1_operators_.alm	passed by user program 'convert' = 164 words
"    pl1_operators_.alm	passed by user program 'convert' = 164 words

" Calling sequence and register conventions:
"
" Entries:
"	any_to_any_
"	any_to_any_round_
"	any_to_any_truncate_
"	real_to_real_
"	real_to_real_round_
"	real_to_real_truncate_
"
"	(pr0)	pl1_operators_$operator_table (Not used...must not be changed)
"	pr1	points to the target. (Input)
"	pr3	points to the source. (Input)
"	pr5	caller-supplied work area.  See "WORK AREA DESCRIPTION" above.
"		(Input)
"	pr6	points to caller's stack frame. (Input)
"	a	contains the length of the target if it
"		is a string, or the scale of the target in AU
"		and the precision in AL. (Input)
"	q	contains the length of the source if it
"		is a string, or the scale of the source in QU
"		and the precision in QL. (Input)
"	x0	return offset in calling program. (Input)
"	x6	contains the type code of the target. (Input)
"	x7	contains the type code of the source. (Input)


"     NOTE.  We run with overflow faults masked.  All exit is done through
"
"	tra	unmask_exit
"
"     or by similarly doing an:
"
"	ldi	unmask_faults,dl
"
"     prior to exiting routine.  Without faults masked we can normally take
"     overflow conditions and not know to signal properly within the code.

any_to_any_truncate_:
real_to_real_truncate_:
	eax5	0			" no rounding
	tra	xfer

any_to_any_:
real_to_real_:
	eax5	0			" assume no rounding
	ldx1	target_type_map,x6		" get flags for target
	canx1	round,du			" check targetfor rounding
	tze	xfer			" no rounding, process

any_to_any_round_:
real_to_real_round_:
	eax5	1			" round


"     Dispatch

"     Scales and precision share the same word.  Scales are upper (ldxN).
"     Precision is lower (lxlN).

xfer:	staq	work|scales		" Scales in DU, precision DL
	cmpx7	source_map_size,du		" See if source convertable
	trc	error_bad_type
	cmpx6	target_map_size,du		" See if target convertable
	trc	error_bad_type

"     Find source conversion to GENERIC

	stz	work|original_source	" no stack error extension
	ldi	mask_faults,dl		" overflows noted by software
	lxl3	source_type_map,x7		" get source conversion addr
	tsp7	0,x3			" conversion
	ldi	mask_faults,dl		" reset to permit faults
"     through with conversion, check for complex target
"     (Note that char & bit targets return directly to the user,
"     not to the caller via pr7).
"
"     Source and target pointers have been updated by get and put routines
"     and are correct for imaginary parts.


	ldx1	target_type_map,x6		" get flag word for target
	canx1	complex,du		" complex?
	tze	unmask_exit		" real target, return

	lxl1	source_type_map,x7		" get source routine
	ldx2	source_type_map,x7
	canx2	simple,du			" check if source is simple
	tnz	unmask_exit
	canx2	complex,du		" check if source is complex
	tnz	convert_complex		" convert complex source

"     Source is not complex, target is, assume zero imaginary part.
"     Zero generic type of source in work area and then convert it.

	ldx3	source_type_map,x6		" Get GENERIC type
	anx3	generic_mask,du
	tra	zero_generic,x3*		" zero work area

zero_fixed_bin:				" Zero GENERIC fixed bin
	stz	work|fix_bin_generic
	stz	work|fix_bin_generic+1
	ldx1	fix_bin_generic_conversion,du
	tra	convert_complex

zero_float_bin:				" Zero GENERIC float bin
	stz	work|flt_bin_generic_exp
	stz	work|flt_bin_generic
	stz	work|flt_bin_generic+1
	ldx1	flt_bin_generic_conversion,du
	tra	convert_complex

zero_float_dec:				" Zero GENERIC float decimal
	ldx3	default_flt_dec_p,du	" length of decimal
	mvn	(),(pr,rl)
	desc9ls	dec_zero,2
	desc9fl	work|flt_dec_generic,x3
	stz	work|flt_dec_generic_exp
	ldx1	flt_dec_generic_conversion,du
"	tra	convert_complex

convert_complex:
	ldi	mask_faults,dl		" mask for conversion faults
	tsp7	0,x1			" Convert imaginary to target
				
"     Unmask faults for exit.		
				
unmask_exit:
	ldi	unmask_faults,dl
	szn	work|original_source	" was stack extended?
	tze	exit.1
	epbp7	sp|0			" get ptr to base of stack
	inhibit	on		<+><+><+><+><+><+><+><+><+><+><+>
	epp2	sb|stack_header.stack_end_ptr,*	" throw extension
	epp2	pr2|-error_extension
	spri2	sb|stack_header.stack_end_ptr
	spri2	sp|stack_frame.next_sp
	inhibit	off		<-><-><-><-><-><-><-><-><-><-><->

"     Setup A and X7 as if for char_to_numeric_

exit.1:
	lda	work|target_precision	" scale (DU), precision (DL)
	eax7	0,x6			" source type used
	tra	sp|tbp,*x0		" return to caller
"CHAR_TO_NUMERIC_

"	Externally available interface.
"
"	procedure to convert a number to its syntactic numeric form
"	and return such information to caller
"	entered with:
"		source ptr in pr3
"		target ptr in pr1	(must be double-word aligned)
"		work   ptr in pr5
"		source length in q
"		rounding called if x5 non-zero
"
"	exits with:
"		number stored in target
"		number type in x7
"		number precision in al
"		number scale in au

char_to_numeric_:
	ldi	mask_faults,dl		" mask fault on indicators
	ldx6	0,du			" flag target of opportunity
	stq	work|source_string_length
	epp	generic,source|0		" point to source
	tra	char_to_arithmetic		" convert


"     Case table used for zeroing source GENERIC work area

zero_generic:
	arg	error_bad_type
	arg	zero_fixed_bin		" fixed bin signed
	arg	zero_float_bin		" float bin
	arg	zero_float_dec		" float decimal
	arg	zero_fixed_bin		" fixed bin unsigned



"     Following is both a 2 character fixed decimal 0 and a 3 character
"     float decimal 0.0 (normalized).

dec_zero:	aci	"+0"



"     Following instruction sets are used by execute instructions.  Double
"     pairing is typically used for no-round/round with X5 keying exec.

mvn.pr_rl.pr_rl:
	mvn	(pr,rl),(pr,rl)
	mvn	(pr,rl),(pr,rl),round

dv3d.id.pr.pr_rl:
	dv3d	(id),(pr),(pr,rl)
	dv3d	(id),(pr),(pr,rl),round

dv3d.id.pr_rl.pr_rl:
	dv3d	(id),(pr,rl),(pr,rl)
	dv3d	(id),(pr,rl),(pr,rl),round

mp3d.id.pr_rl.pr_rl:
	mp3d	(id),(pr,rl),(pr,rl)	" index 0 (truncate)
	mp3d	(id),(pr,rl),(pr,rl),round	" index 1 (round)

dv3d.id.pr_rl.pr:
	dv3d	(id),(pr,rl),(pr)
	dv3d	(id),(pr,rl),(pr),round

mp3d.id.pr_rl.pr:
	mp3d	(id),(pr,rl),(pr)
	mp3d	(id),(pr,rl),(pr),round

"Macro Definitions for table driving.

"	macros to define type tables.
"
"	arg1 - Internal routine to convert source or target.
"	arg2 - Generic internal data type.
"	arg3 - FLAGS expression.
"
	maclist	off save

"     Table for source conversion

	macro	stype
	vfd	12/(&3)/64,6/&2,18/get_&1
	vfd	12/(&3)/64,6/&2,18/get_&1_packed
	&end

"     Table for target conversion

	macro	ttype
	vfd	12/(&3)/64,6/&2,18/put_&1
	vfd	12/(&3)/64,6/&2,18/put_&1_packed
	&end


"     Following flags are used to determine what should be done with a
"     data type.
"
"	round 	indicates the default is to round the target.
"	complex	indicates the target or source is complex.
"	short	indicates the target is 1 word float bin for rounding.

	bool	round,400000		" round
	bool	complex,200000		" complex
	bool	short,100000		" single word flt bin
	bool	varying,040000		" varying bit or char string
	bool	simple,020000		" type is not complex
	bool	fix,010000		" data type is fixed

"     The following fields are used to mask out portions of the source and
"     target tables to recover fields.  DU, DL is significant.
"
"	flag_mask		recovers the field containing flags.
"	generic_mask	recovers the field indicating GENERIC type.
"	type_mask		recovers the offset to the conversion routine.

	bool	flag_mask,777700		" DU
	bool	generic_mask,000077		" DU
	bool	type_mask,777777		" DL


"     The following table contains the the GENERIC data type numbers.

	equ	FIXED_BIN,1
	equ	FLOAT_BIN,2
	equ	FLOAT_DEC,3
	equ	FIXED_BIN_UNS,4

	equ	BIT,5
	equ	CHAR,6

"     Fixed binary is divided into FIXED_BIN and FIXED_BIN_UNS because there
"     are distinct operational differences between the two, particularly since
"     a FIXED_BIN_UNS number can appear negative if viewed as a FIXED_BIN
"     number, and right shifts to normalize a FIXED_BIN_UNS number need to be
"     done with LOGICAL rather than arithmetic operations.
"		mapped	input	type

source_type_map:
"( 0);	stype ERROR,0			" FILLER of ERROR
"( 1);	stype fix_bin_1,FIXED_BIN,fix		" fixed binary short
"( 2);	stype fix_bin_2,FIXED_BIN,fix		" fixed binary long
"( 3);	stype flt_bin_1,FLOAT_BIN,round	" float binary short
"( 4);	stype flt_bin_2,FLOAT_BIN,round	" float binary long
"( 5);	stype fix_bin_1,FIXED_BIN,(complex+fix)	" complex fixed binary short
"( 6);	stype fix_bin_2,FIXED_BIN,(complex+fix)	" complex fixed binary long
"( 7);	stype flt_bin_1,FLOAT_BIN,(round+complex)" complex float binary short
"( 8);	stype flt_bin_2,FLOAT_BIN,(round+complex)" complex float binary long
"( 9);	stype fix_dec_9ls,FLOAT_DEC,fix	" fixed decimal 9-bit
"(10);	stype flt_dec_9,FLOAT_DEC,round	" float decimal 9-bit
"(11);	stype fix_dec_9ls,FLOAT_DEC,(complex+fix) " complex fixed decimal 9-bit
"(12);	stype flt_dec_9,FLOAT_DEC,(round+complex) " complex float decimal 9-bit
"(13);	stype ERROR,0			" pointer
"(14);	stype ERROR,0			" offset
"(15);	stype ERROR,0			" label
"(16);	stype ERROR,0			" entry
"(17);	stype ERROR,0			" structure
"(18);	stype ERROR,0			" area
"(19);	stype bit,BIT			" bit
"(20);	stype varying_bit,BIT,varying		" varying bit
"(21);	stype char,CHAR			" character
"(22);	stype varying_char,CHAR,varying	" varying character
"(23);	stype ERROR,0			" file
"(24);	stype ERROR,0			" label constant runtime
"(25);	stype ERROR,0			" int entry runtime
"(26);	stype ERROR,0			" ext entry runtime
"(27);	stype ERROR,0			" ext procedure runtime
"(28);	stype ERROR,0			" RESERVED (type 28)
"(29);	stype fix_dec_9ls_ovrp,FLOAT_DEC,fix	" fixed dec leading overpunch 9-bit
"(30);	stype fix_dec_9ts_ovrp,FLOAT_DEC,fix	" fixed dec trailing overpunch 9-bit
"(31);	stype ERROR,0			" RESERVED (type 31)
"(32);	stype ERROR,0			" RESERVED (type 32)
"(33);	stype fix_bin_1uns,FIXED_BIN_UNS,fix	" fixed binary unsigned short
"(34);	stype fix_bin_2uns,FIXED_BIN_UNS,fix	" fixed binary unsigned long
"(35);	stype fix_dec_9uns,FLOAT_DEC,fix	" fixed decimal unsigned 9-bit
"(36);	stype fix_dec_9ts,FLOAT_DEC,fix	" fixed decimal trailing sign 9-bit
"(37);	stype fix_dec_9ts,FLOAT_DEC,(complex+fix) " complex fixed decimal trailing sign (future??)
"(38);	stype fix_dec_4uns,FLOAT_DEC,fix	" fixed decimal unsigned 4-bit
"(39);	stype fix_dec_4ts,FLOAT_DEC,fix	" fixed decimal trailing sign 4-bit
"(40);	stype fix_dec_4uns,FLOAT_DEC,fix        " fixed decimal unsigned 4-bit byte-aligned
"(41);	stype fix_dec_4ls,FLOAT_DEC,fix	" fixed decimal leading sign 4-bit
"(42);	stype flt_dec_4,FLOAT_DEC,round	" float decimal 4-bit
"(43);	stype fix_dec_4ls,FLOAT_DEC,fix	" decimal leading sign 4-bit byte-aligned
"(44);	stype flt_dec_4,FLOAT_DEC,round	" float decimal 4-bit byte-aligned
"(45);	stype fix_dec_4ls,FLOAT_DEC,(complex+fix) " complex fixed decimal leading sign 4-bit byte-aligned
"(46);	stype flt_dec_4,FLOAT_DEC,(complex+round) " cplx float decimal 4-bit byte-aligned
"(47);	stype flt_hex_1,FLOAT_BIN,round	" float hex single
"(48);	stype flt_hex_2,FLOAT_BIN,round	" float hex double
"(49);	stype flt_hex_1,FLOAT_BIN,(round+complex) " complex float hex single
"(50);	stype flt_hex_2,FLOAT_BIN,(round+complex) " complex float hex double
"(51);	stype ERROR,0			" RESERVED (type 51)
"(52);	stype ERROR,0			" RESERVED (type 52)
"(53);	stype ERROR,0			" RESERVED (type 53)
"(54);	stype ERROR,0			" RESERVED (type 54)
"(55);	stype ERROR,0			" RESERVED (type 55)
"(56);	stype ERROR,0			" RESERVED (type 56)
"(57);	stype ERROR,0			" RESERVED (type 57)
"(58);	stype ERROR,0			" ESCAPE (type 58)
"(59);	stype ERROR,0			" algol68 straight
"(60);	stype ERROR,0			" algol68 format
"(61);	stype ERROR,0			" algol68 array descriptor
"(62);	stype ERROR,0			" algol68 union
"(63);	stype ERROR,0			" picture runtime
"(64);	stype ERROR,0			" EXTRA (64)
"(65);	stype ERROR,0			" EXTRA (65)
"(66);	stype ERROR,0			" EXTRA (66)
"(67);	stype ERROR,0			" EXTRA (67)
"(68);	stype ERROR,0			" EXTRA (68)
"(69);	stype ERROR,0			" EXTRA (69)
"(70);	stype ERROR,0			" EXTRA (70)
"(71);	stype ERROR,0			" EXTRA (71)
"(72);	stype ERROR,0			" EXTRA (72)
"(73);	stype ERROR,0			" EXTRA (73)
"(74);	stype ERROR,0			" EXTRA (74)
"(75);	stype ERROR,0			" EXTRA (75)
"(76);	stype ERROR,0			" EXTRA (76)
"(77);	stype ERROR,0			" EXTRA (77)
"(78);	stype ERROR,0			" EXTRA (78)
"(79);	stype ERROR,0			" EXTRA (79)
"(80);	stype ERROR,0			" EXTRA (80)
"(81);	stype flt_dec_ext,FLOAT_DEC,round	" float dec extended
"(82);	stype flt_dec_ext,FLOAT_DEC,(round+complex) " complex float dec extended
"(83);	stype flt_dec_gen,FLOAT_DEC,round	" float dec generic
"(84);	stype flt_dec_gen,FLOAT_DEC,(round+complex) " complex float dec generic
"(85);	stype flt_bin_gen,FLOAT_BIN,round	" float bin generic
"(86);	stype flt_bin_gen,FLOAT_BIN,(round+complex) " complex float bin generic

	equ	source_map_size,*-source_type_map
"		mapped	output	type

target_type_map:
"( 0);	ttype ERROR,0			" FILLER of ERROR
"( 1);	ttype fix_bin_1,FIXED_BIN		" fixed binary short
"( 2);	ttype fix_bin_2,FIXED_BIN		" fixed binary long
"( 3);	ttype flt_bin_1,FLOAT_BIN,(round+short)	" float binary short
"( 4);	ttype flt_bin_2,FLOAT_BIN,round	" float binary long
"( 5);	ttype fix_bin_1,FIXED_BIN,complex	" complex fixed binary short
"( 6);	ttype fix_bin_2,FIXED_BIN,complex	" complex fixed binary long
"( 7);	ttype flt_bin_1,FLOAT_BIN,(round+complex+short)" complex float binary short
"( 8);	ttype flt_bin_2,FLOAT_BIN,(round+complex)" complex float binary long
"( 9);	ttype fix_dec_9ls,FLOAT_DEC		" fixed decimal 9-bit
"(10);	ttype flt_dec_9,FLOAT_DEC,round	" float decimal 9-bit
"(11);	ttype fix_dec_9ls,FLOAT_DEC,complex	" complex fixed decimal 9-bit
"(12);	ttype flt_dec_9,FLOAT_DEC,(round+complex) " complex float decimal 9-bit
"(13);	ttype ERROR,0			" pointer
"(14);	ttype ERROR,0			" offset
"(15);	ttype ERROR,0			" label
"(16);	ttype ERROR,0			" entry
"(17);	ttype ERROR,0			" structure
"(18);	ttype ERROR,0			" area
"(19);	ttype bit,BIT			" bit
"(20);	ttype varying_bit,BIT,varying		" varying bit
"(21);	ttype char,CHAR			" character
"(22);	ttype varying_char,CHAR,varying	" varying character
"(23);	ttype ERROR,0			" file
"(24);	ttype ERROR,0			" label constant runtime
"(25);	ttype ERROR,0			" int entry runtime
"(26);	ttype ERROR,0			" ext entry runtime
"(27);	ttype ERROR,0			" ext procedure runtime
"(28);	ttype ERROR,0			" RESERVED (type 28)
"(29);	ttype fix_dec_9ls_ovrp,FLOAT_DEC	" fixed dec leading overpunch 9-bit
"(30);	ttype fix_dec_9ts_ovrp,FLOAT_DEC	" fixed dec trailing overpunch 9-bit
"(31);	ttype ERROR,0			" RESERVED (type 31)
"(32);	ttype ERROR,0			" RESERVED (type 32)
"(33);	ttype fix_bin_1uns,FIXED_BIN_UNS	" fixed binary unsigned short
"(34);	ttype fix_bin_2uns,FIXED_BIN_UNS	" fixed binary unsigned long
"(35);	ttype fix_dec_9uns,FLOAT_DEC		" fixed decimal unsigned 9-bit
"(36);	ttype fix_dec_9ts,FLOAT_DEC		" fixed decimal trailing sign 9-bit
"(37);	ttype fix_dec_9ts,FLOAT_DEC,complex	" complex fixed decimal trailing sign (future??)
"(38);	ttype fix_dec_4uns,FLOAT_DEC		" fixed decimal unsigned 4-bit
"(39);	ttype fix_dec_4ts,FLOAT_DEC		" fixed decimal trailing sign 4-bit
"(40);	ttype fix_dec_4uns,FLOAT_DEC		" fixed decimal unsigned 4-bit byte-aligned
"(41);	ttype fix_dec_4ls,FLOAT_DEC		" fixed decimal leading sign 4-bit
"(42);	ttype flt_dec_4,FLOAT_DEC,round	" float decimal 4-bit
"(43);	ttype fix_dec_4ls,FLOAT_DEC		" decimal leading sign 4-bit byte-aligned
"(44);	ttype flt_dec_4,FLOAT_DEC,round	" float decimal 4-bit byte-aligned
"(45);	ttype fix_dec_4ls,FLOAT_DEC,complex	" complex fixed decimal leading sign 4-bit byte-aligned
"(46);	ttype flt_dec_4,FLOAT_DEC,(complex+round) " cplx float decimal 4-bit byte-aligned
"(47);	ttype flt_hex_1,FLOAT_BIN,round	" float hex single
"(48);	ttype flt_hex_2,FLOAT_BIN,round	" float hex double
"(49);	ttype flt_hex_1,FLOAT_BIN,(round+complex) " complex float hex single
"(50);	ttype flt_hex_2,FLOAT_BIN,(round+complex) " complex float hex double
"(51);	ttype ERROR,0			" RESERVED (type 51)
"(52);	ttype ERROR,0			" RESERVED (type 52)
"(53);	ttype ERROR,0			" RESERVED (type 53)
"(54);	ttype ERROR,0			" RESERVED (type 54)
"(55);	ttype ERROR,0			" RESERVED (type 55)
"(56);	ttype ERROR,0			" RESERVED (type 56)
"(57);	ttype ERROR,0			" RESERVED (type 57)
"(58);	ttype ERROR,0			" ESCAPE (type 58)
"(59);	ttype ERROR,0			" algol68 straight
"(60);	ttype ERROR,0			" algol68 format
"(61);	ttype ERROR,0			" algol68 array descriptor
"(62);	ttype ERROR,0			" algol68 union
"(63);	ttype ERROR,0			" picture runtime
"(64);	ttype ERROR,0			" EXTRA (64)
"(65);	ttype ERROR,0			" EXTRA (65)
"(66);	ttype ERROR,0			" EXTRA (66)
"(67);	ttype ERROR,0			" EXTRA (67)
"(68);	ttype ERROR,0			" EXTRA (68)
"(69);	ttype ERROR,0			" EXTRA (69)
"(70);	ttype ERROR,0			" EXTRA (70)
"(71);	ttype ERROR,0			" EXTRA (71)
"(72);	ttype ERROR,0			" EXTRA (72)
"(73);	ttype ERROR,0			" EXTRA (73)
"(74);	ttype ERROR,0			" EXTRA (74)
"(75);	ttype ERROR,0			" EXTRA (75)
"(76);	ttype ERROR,0			" EXTRA (76)
"(77);	ttype ERROR,0			" EXTRA (77)
"(78);	ttype ERROR,0			" EXTRA (78)
"(79);	ttype ERROR,0			" EXTRA (79)
"(80);	ttype ERROR,0			" EXTRA (80)
"(81);	ttype flt_dec_ext,FLOAT_DEC,round	" float dec extended
"(82);	ttype flt_dec_ext,FLOAT_DEC,(round+complex) " complex float dec extended
"(83);	ttype flt_dec_gen,FLOAT_DEC,round	" float dec generic
"(84);	ttype flt_dec_gen,FLOAT_DEC,(round+complex) " complex float dec generic
"(85);	ttype flt_bin_gen,FLOAT_BIN,round	" float bin generic
"(86);	ttype flt_bin_gen,FLOAT_BIN,(round+complex) " complex float bin generic

	equ	target_map_size,*-target_type_map

	maclist	restore
" Register conventions for source GET routines.
" (all routines specified in the table below).  All registers named below,
" must be preserved by the conversion routine.
"
"	pr0	(reserved - pl1_operators_ ptr)
"	pr1	points to target.
"	pr2	points to generic data area
"	pr3	points to source.
"	pr5	points to work area.
"	pr6	(reserved - stack_frame ptr)
"	pr7	points to return location in any_to_any_.
"	x0	return offset in user program.
"	x5	0 if no round, 1 if round.
"	x6	target type.
"	x7	source type.

"	work|scales	stored scales (in upper halves)
"	work|precisions	stored precisions (in lower halves)
"
"     Decimal GET routines leave X3 as the size of the floating decimal
"     generic variable, including sign and hardware exponent.

" Conversion rules go that source and target pointers are updated by the GET
"     and PUT routines respectively, thus they are always up-to-date by the
"     end of the conversion.  This makes converting real and imaginary parts
"     quite easy.  If range errors are detected, they are signalled as
"     appropriate through the singalling routines at the end of this program.
"     Depending upon the type of error signalled, return is done to a float
"     bin or float decimal generic converison, to continue the conversion of a
"     0.0 quantity.  Fixed bin conversion errors simply return.
"
" Conditions of calling conversion routines:
"
"     Fixed Bin:	72-bit value is expected in work|fix_bin_generic.
"     Float Bin:	72-bit value is expected in work|flt_bin_generic,
"		36-bit exponent is expected in work|flt_bin_generic_exp.
"     Float Decimal:X3 has the length of the float decimal number, including
"		the sign and a byte for the hardware exponent.  The float
"		decimal number is left in work|flt_dec_generic and the
"		36-bit software exponent is in work|flt_dec_generic_exp.
"     Fixed Bin uns:72-bit value is expected in work|fix_bin_generic.
"     Bit:	Bit value is pointed to by generic|0.  If necessary the
"		area work|bit_generic can be used for internal storage, BUT
"		it overlays work|flt_dec_generic.  This conflict must be
"		remembered in conversion routines.  In a varying bit string
"		the pointer points at the start of the bit stream, which is
"		one word beyond the length word.  X3 is the length of the
"		bit string (up to 256 bits).
"     Char:	Character string is pointed to by generic|0.  If necessary
"		the area work|char_generic can be used for internal storage
"		and does not conflict with other storage.  X3 is the length
"		of the character string (up to 256 characters).  In a
"		varying character string the pointer points at the start of
"		the character stream, which is one word beyond the length
"		word.
"
" All character conversions require the large work area.Fixed Binary Source Conversion to GENERIC


"     Unsigned Cases


get_fix_bin_1uns:			" Fixed bin single word unsigned
	lda	source|0			" load value
	lrl	36			" position to Q, clear A
	staq	work|fix_bin_generic
	epp	source,source|1		" update source pointer
	tra	fix_bin_uns_generic_conversion


get_fix_bin_1uns_packed:		" Packed fixed bin single unsigned
get_fix_bin_2uns_packed:		" Packed fixed bin double unsigned
	lxl2	work|source_precision
	csl	(pr,rl),(pr,rl),bool(move)
	descb	source|0,x2
	descb	work|fix_bin_generic,x2
	abd	source|0,x2		" update source pointer
	ldaq	work|fix_bin_generic
	erx2	=o777777,du		" form 2's complement precision
	lrl	72+1,2			" position result unsigned
	staq	work|fix_bin_generic
	tra	fix_bin_uns_generic_conversion


get_fix_bin_2uns:			" Fixed bin double word to GENERIC
	ldaq	source|0			" load value
	staq	work|fix_bin_generic
	epp	source,source|2		" update source pointer
	tra	fix_bin_uns_generic_conversion




"     Signed Cases


get_fix_bin_1:			" Fixed bin single word to GENERIC
	lda	source|0			" load value
	lrs	36			" position and sign extend
	staq	work|fix_bin_generic
	epp	source,source|1
	tra	fix_bin_generic_conversion


get_fix_bin_1_packed:		" Packed fixed bin single to GENERIC
get_fix_bin_2_packed:		" Packed fixed bin double to GENERIC
	lxl2	work|source_precision
	adx2	=1,du			" account for sign
	csl	(pr,rl),(pr,rl),bool(move)
	descb	source|0,x2
	descb	work|fix_bin_generic,x2
	abd	source|0,x2		" update source pointer
	ldaq	work|fix_bin_generic
	erx2	=o777777,du		" form 2's complement precision
	lrs	72+1,2			" position result
	staq	work|fix_bin_generic
	tra	fix_bin_generic_conversion


get_fix_bin_2:			" Fixed bin double word to GENERIC fb (71)
	ldaq	source|0			" load value
	staq	work|fix_bin_generic
	epp	source,source|2		" update source pointer
	tra	fix_bin_generic_conversion
"Floating Binary Source Conversion to GENERIC


get_flt_bin_1:			" Floating binary single to generic
	fld	source|0
	epp	source,source|1		" update source pointer
	tra	end_get_flt_bin

get_flt_bin_1_packed:		" Floating binary single packed to generic
get_flt_bin_2_packed:		" Floating binary double packed to generic
	lxl2	work|source_precision
	adx2	=9,du			" account for sign and exponent
	csl	(pr,rl),(pr),bool(move),fill(0)
	descb	source|0,x2
	descb	work|flt_bin_generic,72
	dfld	work|flt_bin_generic
	abd	source|0,x2		" update source pointer
	tra	end_get_flt_bin

get_flt_bin_2:			" Floating binary double to generic
	dfld	source|0
	epp	source,source|2		" update source pointer
"	tra	end_get_flt_bin

end_get_flt_bin:
	tnz	get_flt_bin.zero		" Not zero store as indicated
	stz	work|flt_bin_generic_exp
	stz	work|flt_bin_generic
	stz	work|flt_bin_generic+1
	tra	flt_bin_generic_conversion	" Store absolute zero

get_flt_bin.zero:
	ste	work|flt_bin_generic_exp
	staq	work|flt_bin_generic
	lda	work|flt_bin_generic_exp
	ars	36-8			" position in full exponent
	sta	work|flt_bin_generic_exp
	tra	flt_bin_generic_conversion


"     Get a GENERIC floating binary value.  Storage form is:
"
"	Double word aligned.
"
"	AQ portion of EAQ.  Full 72 bits stored.
"	fixed bin (35) exponent value.
"	PAD word.

get_flt_bin_gen:			" Floating binary generic to internal
	dfld	source|0			" move mantissa, 0->exp
	staq	work|flt_bin_generic
	lde	0,du
	lda	source|2
	sta	work|flt_bin_generic_exp
	epp	source,source|4		" update source pointer
	tra	flt_bin_generic_conversion
"Floating Hexadecimal Source Conversion to GENERIC


get_flt_hex_1:			" Floating hex single to generic
	fld	source|0
	epp	source,source|1		" update source pointer
	tra	end_get_flt_hex

get_flt_hex_1_packed:		" Floating hex single packed to generic
get_flt_hex_2_packed:		" Floating hex double packed to generic
	lxl2	work|source_precision
	adx2	=9,du			" account for sign and exponent
	csl	(pr,rl),(pr),bool(move),fill(0)
	descb	source|0,x2
	descb	work|flt_bin_generic,72
	dfld	work|flt_bin_generic
	abd	source|0,x2		" update source pointer
	tra	end_get_flt_hex

get_flt_hex_2:			" Floating hex double to generic
	dfld	source|0
	epp	source,source|2		" update source pointer
"	tra	end_get_flt_hex

end_get_flt_hex:
	tnz	get_flt_hex.nz		" Not zero - store as indicated
	stz	work|flt_bin_generic_exp
	stz	work|flt_bin_generic
	stz	work|flt_bin_generic+1
	tra	flt_bin_generic_conversion	" Store absolute zero


"     Non-Zero Floating HEXADECIMAL - convert to extended floating binary

get_flt_hex.nz:			
	ste	work|flt_bin_generic_exp
	lde	=0,du			" normalize to binary from hex
	fno
	ste	work|flt_dec_generic_exp
	lde	=0,du			" save 0 exponent
	staq	work|flt_bin_generic
	lda	work|flt_bin_generic_exp	" position for full range
	ars	36-8-2			" single bit shift
	sta	work|flt_bin_generic_exp
	lda	work|flt_dec_generic_exp	" get binary correction
	ars	36-8
	asa	work|flt_bin_generic_exp	" include hex exponent
	tra	flt_bin_generic_conversion
"Fixed Decimal 9-bit Source Conversion to GENERIC

"     ****NOTE**** - X2 MUST contain the fixed decimal length at the point
"	end_get_fix_dec.normalize is called.  These initial routines leave
"	generic pointing to a 9-bit leading signed fixed decimal number.  The
"	final conversion to GENERIC float dec is done by
"	end_get_fix_dec.normalize.

"     9-bit Leading Sign Case

get_fix_dec_9ls:				" Actual work done in
get_fix_dec_9ls_packed:			" end_get_fix_dec.normalize
	lxl2	work|source_precision
	adx2	=1,du			" count sign in size
	epp	generic,source|0			" point to source
	a9bd	source|0,x2		" update source pointer
	tra	end_get_fix_dec.normalize

"     9-bit Leading Sign Overpunched Case

get_fix_dec_9ls_ovrp:
get_fix_dec_9ls_ovrp_packed:
	lxl3	work|source_precision
	eax2	1,x3			" Count sign

"     Move mantissa including overpunched sign, skip sign of generic FD

	mlr	(pr,rl),(pr,rl)
	desc9a	source|0,x3
	desc9a	work|fix_dec_generic(1),x3

"     Translate overpunched sign to sign and leading digit

	scm	(),(pr),mask(000)		" Determine index of sign
	desc9a	overpunch_9_source,20	" Conversion table
	desc9a	source|0,1		" overpunch
	arg	work|flt_dec_generic_exp	" index result
	ttn	error_bad_type		" not convertable

	lda	work|flt_dec_generic_exp
	als	1			" *2 for char index
	mlr	(al),(pr)			" Move in correct codes
	desc9a	overpunch_9_chars,2
	desc9a	work|fix_dec_generic,2
	epp	generic,work|flt_dec_generic	" point to 9bit_ls
	a9bd	source|0,x3		" update source pointer
	tra	end_get_fix_dec.normalize

"     9-bit Trailing Sign Overpunched Case

get_fix_dec_9ts_ovrp:
get_fix_dec_9ts_ovrp_packed:
	lxl3	work|source_precision
	eax2	1,x3			" Count sign

"     Move mantissa including overpunched sign, skip sign of generic FD

	mlr	(pr,rl),(pr,rl)
	desc9a	source|0,x3
	desc9a	work|fix_dec_generic(1),x3

"     Translate overpunched sign to sign and leading digit

	scm	(),(pr,x3),mask(000)	" Determine index of sign
	desc9a	overpunch_9_source,20	" Conversion table
	desc9a	source|-1(3),1		" overpunch
	arg	work|flt_dec_generic_exp	" index result
	ttn	error_bad_type		" not convertable

	lda	work|flt_dec_generic_exp
	mlr	(al),(pr)			" Move sign
	desc9a	overpunch_9_signs,1
	desc9a	work|fix_dec_generic,1
	mlr	(al),(pr,x3)		" Fixup trailing digit
	desc9a	overpunch_9_digits,1
	desc9a	work|fix_dec_generic,1
	epp	generic,work|flt_dec_generic	" point to 9bit_ls
	a9bd	source|0,x3		" update source pointer
	tra	end_get_fix_dec.normalizeFixed Decimal 9-bit Source Conversion to GENERIC


"     9-bit Unsigned Case

get_fix_dec_9uns:
get_fix_dec_9uns_packed:
	lxl4	work|source_precision
	eax2	1,x4			" length of leading sign result
	eax3	1,x2			" size of floating result
	mvn	(pr,rl),(pr,rl)
	desc9ns	source|0,x4
	desc9fl	work|flt_dec_generic,x3
	a9bd	source|0,x3		" update source pointer
	tra	end_get_fix_dec.normalized



"     9-bit Trailing Sign Case

get_fix_dec_9ts:
get_fix_dec_9ts_packed:
	lxl3	work|source_precision
	eax2	1,x3			" size of signed result
	eax3	1,x2			" size of floating result
	mvn	(pr,rl),(pr,rl)
	desc9ts	source|0,x2
	desc9fl	work|flt_dec_generic,x3
	a9bd	source|0,x2		" update source pointer
	tra	end_get_fix_dec.normalized




"     Table used to determine overpunch conversion.  Index provides
"     conversion reference to an overpunch character table.

overpunch_9_source:		" used to translate overpunch to table index
	aci /{ABCDEFGHI}JKLMNOPQR/,20
"	     ++++++++++----------
"	     01234567890123456789

overpunch_9_signs:		" overpunch sign
	aci /++++++++++----------/,20

overpunch_9_digits:		" overpunch digit
	aci /01234567890123456789/,20

overpunch_9_chars:		" index*2 to get sign and leading digit
	aci /+0+1+2+3+4+5+6+7+8+9-0-1-2-3-4-5-6-7-8-9/,40
"Fixed Decimal 4-bit Source Conversion to GENERIC

"     Fourbit source is byte aligned.  Thus we round to next byte in setting
"     the source pointer update.


"     4-bit Leading Sign Case


get_fix_dec_4ls:
get_fix_dec_4ls_packed:
	lxl2	work|source_precision
	adx2	1,du			" count sign in size
	eax3	1,x2			" size of floating result
	mvn	(pr,rl),(pr,rl)
	desc4ls	source|0,x2
	desc9fl	work|flt_dec_generic,x3
	eax2	1,x2			" byte align update
	anx2	=o777776,du
	a4bd	source|0,x2		" update source pointer
	tra	end_get_fix_dec.normalized



"     4-bit Unsigned Case

get_fix_dec_4uns:
get_fix_dec_4uns_packed:
	lxl4	work|source_precision
	eax2	1,x4			" count sign in size
	eax3	1,x2			" size of floating result
	mvn	(pr,rl),(pr,rl)
	desc4ns	source|0,x4
	desc9fl	work|flt_dec_generic,x3
	eax4	1,x4			" byte align update
	anx4	=o777776,du
	a4bd	source|0,x4		" update source pointer
	tra	end_get_fix_dec.normalized



"     4-bit Trailing Sign Case

get_fix_dec_4ts:
get_fix_dec_4ts_packed:
	lxl3	work|source_precision
	eax2	1,x3			" size of signed result
	eax3	1,x2			" size of floating result
	mvn	(pr,rl),(pr,rl)		" move unsigned mantissa
	desc4ts	source|0,x2
	desc9fl	work|flt_dec_generic,x3
	eax2	1,x2			" byte align update
	anx2	=o777776,du
	a4bd	source|0,x2		" update source pointer
	tra	end_get_fix_dec.normalized
"Normalize fixed decimal to floating decimal


"     A source decimal mantissa is currently setup with a correct
"     fixed decimal value.  This is now moved in place to a floating decimal
"     format to establish the 8-bit exponent and round as necessary.  From this
"     the full floating decimal extended exponent is formed, taking into
"     account a possible fixed decimal scale factor.
"
"     On entry generic points to source to convert.  This is simple source pointer
"	for 9bit_ls, or flt_dec_generic pre-cooked to 9bit_ls for others.
"
"     X3 is precision on exit including exponent and sign.


end_get_fix_dec.normalize:
	eax3	1,x2			" Count byte for exponent
	xec	mvn.pr_rl.pr_rl,x5		" float and ?round?
	desc9ls	generic|0,x2
	desc9fl	work|flt_dec_generic,x3

"     The rounded move may alter the exponent value.  We pick up what it
"     set to account for this possibility and integrate the fixed scale
"     factor into the 36-bit exponent.


"     Entry to this point presumes that X3 is the length of the floating
"     decimal number, and that it is already in work|flt_dec_generic.
"     At this point we take the 8-bit hardware exponent and extend it to
"     a full 35 bit signed exponent.

end_get_fix_dec.normalized:			" have floating number
	stz	work|flt_dec_generic_exp	" pre_set exponent
	mlr	(pr,x3),(pr)		" get new exponent
	desc9a	work|flt_dec_generic-1(3),1
	desc9a	work|flt_dec_generic_exp(3),1

	lda	work|source_scale
	ars	18			" full extension
	neg				" and form negative scale
	asa	work|flt_dec_generic_exp	" in full exponent
	tra	flt_dec_generic_conversion	
"Floating Decimal Source Conversion to GENERIC
"     9-bit Case

get_flt_dec_9:
get_flt_dec_9_packed:
	lxl3	work|source_precision
	adx3	1+1,du			" account for sign/exponent
	mvn	(pr,rl),(pr,rl)
	desc9fl	source|0,x3
	desc9fl	work|flt_dec_generic,x3

	mlr	(pr,x3),(pr)		" 8-bit to 36-bit exponent
	desc9a	work|flt_dec_generic-1(3),1
	desc9a	work|flt_dec_generic_exp,1
	lda	work|flt_dec_generic_exp
	alr	1			" skip pad bit in exponent
	ars	36-8			" sign extend
	sta	work|flt_dec_generic_exp
	a9bd	source|0,x3		" update source pointer
	tra	flt_dec_generic_conversion

"     4-bit Case

get_flt_dec_4:
get_flt_dec_4_packed:
	lxl3	work|source_precision
	eax2	1+2,x3			" 4-bit sign/exponent
	adx3	1+1,du			" form length 9-bit
	mvn	(pr,rl),(pr,rl)
	desc4fl	source|0,x2
	desc9fl	work|flt_dec_generic,x3
	mlr	(pr,x3),(pr)		" Expand the exponent
	desc9a	work|flt_dec_generic-1(3),1
	desc9a	work|flt_dec_generic_exp,1
	lda	work|flt_dec_generic_exp
	alr	1			" skip pad bit in exponent
	ars	36-8			" sign extend
	sta	work|flt_dec_generic_exp
	eax2	1,x2			" byte align update
	anx2	=o777776,du
	a4bd	source|0,x2		" update source pointer
	tra	flt_dec_generic_conversion

"     9-bit extended Case (has 9-bit rather than 8-bit exponent)

get_flt_dec_ext:
get_flt_dec_ext_packed:
	lxl3	work|source_precision
	adx3	1+1,du			" account for sign/exponent
	mvn	(pr,rl),(pr,rl)
	desc9fl	source|0,x3
	desc9fl	work|flt_dec_generic,x3

"     Expand the exponent (pick from source since mvn kills high bit)

	mlr	(pr,x3),(pr)		" 9-bit to 36-bit exponent
	desc9a	source|-1(3),1
	desc9a	work|flt_dec_generic_exp,1
	lda	work|flt_dec_generic_exp
	ars	36-9			" sign extend
	sta	work|flt_dec_generic_exp
	a9bd	source|0,x3		" update source pointer
	tra	flt_dec_generic_conversion

"     9-bit generic Case.  Has leading 36-bit exponent.

get_flt_dec_gen:		" move to generic to get hardware exponent.
	lda	source|0			" get exponent
	sta	work|flt_dec_generic_exp
	lxl2	work|source_precision
	adx2	1,du			" account for sign
	eax3	1,x2			" account for hard exponent
	mlr	(pr,rl),(pr,rl),fill(000)	" move and clear exp
	desc9a	source|1,x2
	desc9a	work|flt_dec_generic,x3
	eax2	3,x2			" set round of mantissa len
	a9bd	source|0,x2		" increment and round
	adwp	source,1,du
	tra	flt_dec_generic_conversionBit Source Conversion to FINA

"     Bit conversion to final target.
"
"     Conversion to numeric converts to fixed bin (71, 0) or fixed bin
"     unsigned (72, 0) and continues to final target.  A bit source is
"     non-complex, so normal conversion to 0 of the imaginary part will
"     occur.  Since we have no imaginary part for source, we do not move
"     the source pointer.  Source length is left in X3.  We use generic to 
"     point to the source to be converted.  This permits us to later add
"     other boolean types converting to a generic form.

get_varying_bit:
	lxl3	source|-1			" load length of varying
	sxl3	work|source_precision
	tra	get_bit.set_source

get_bit:
get_bit_packed:
	lxl3	work|source_precision	" get length of bits

"     Set pointer to bit source.  For now it is in true source.

get_bit.set_source:
	epp	generic,source|0			" point to source of bits.
	tra	bit_generic_conversion





"Character source conversion to TARGET

"     Character input routines convert a varying string to a fixed length
"     string, and make a pointer to the string.

"     Standard is string is pointed to by generic, and current length is in
"     work|source_precision.
"     If we are converting to a numeric form, then we take over control and
"     convert to float decimal, then continue with a float decimal to TARGET
"     conversion.  If we are converting to bit we do a simple conversion, as
"     with conversion to character.

get_varying_char:
	lda	source|-1			" get length of varying char
	sta	work|source_precision

get_char:
get_char_packed:
	epp	generic,source|0
	lxl3	work|source_precision
	eaa	0,x3			" save source length
	ars	18
	sta	work|source_string_length
	tra	char_to_generic
"Conversion Routines - Fixed bin to target GENERIC

fix_bin_generic_conversion:
	ldx1	target_type_map,x6		" determine target GENERIC
	anx1	generic_mask,du		" mask for type
	tra	fix_bin_generic_case,x1*

fix_bin_generic_case:
	arg	error_bad_type
	arg	fix_bin_to_fix_bin
	arg	fix_bin_to_flt_bin
	arg	fix_bin_to_flt_dec
	arg	fix_bin_to_fix_bin_uns
	arg	fix_bin_to_bit
	arg	fix_bin_to_char

"     Fixed bin to fixed bin unsigned differs from fixed bin to fixed bin for
"     left scaling since moving a bit into the sign position would erroneously
"     trigger a size error.  Right shift is fine since sign bit is clear.

fix_bin_to_fix_bin_uns:			" convert to unsigned target
	ldaq	work|fix_bin_generic
	tmi	size_error		" cannot convert negative
	ldx2	work|target_scale		" determine cross-scaling
	sbx2	work|source_scale
fix_bin.fix_bin_uns.flt:			" entry from flt_bin_to_fixun
	tze	generic_to_target		" scales match
	tmi	fix_bin.scale_right		" need right shift and ?round?

"     Overflow detection means generating a mask of the number of bits to
"     be shifted left to determine if this area is non-zero, if so then we
"     will overflow.

	lda	=o400000,du		" get mask bit
	ldq	=0,dl
	lrs	-1,x2			" generate mask
	anaq	work|fix_bin_generic
	tnz	size_error		" we would overflow

	ldaq	work|fix_bin_generic
	lls	0,x2
	tra	fix_bin.noscale

"     Convert fixed bin to fixed bin.  Here it is mainly a matter of scaling
"     to ensure the target scale factor is correct.

fix_bin_to_fix_bin:
	ldx2	work|target_scale		" determine cross-scaling
	sbx2	work|source_scale
fix_bin.fix_bin.flt:			" entry from flt_bin_to_fix
	tze	generic_to_target		" scales match
	tmi	fix_bin.scale_right		" need right shift and ?round?

fix_bin.scale_left:				" left shift zero fill
	ldaq	work|fix_bin_generic
	lls	0,x2
	trc	size_error		" overflow
	tra	fix_bin.noscale

"     Right scaling may require a round.  Negative rounds down, positive
"     rounds up.  Do this by determining the bit position to round at.  This
"     rounding bit will be good for both positive and negative values.

fix_bin.scale_right:			" right shift and ?round?
	erx2	=o777777,du		" form shift count-1
	eax4	0,x5			" determine if rounding
	tze	fix_bin.noround
	ldaq	one			" load mask for rounding
	lls	0,x2			" determine round bit
	anaq	work|fix_bin_generic
	tnz	fix_bin.noround
	eax4	0			" force no round
fix_bin.noround:
	ldaq	work|fix_bin_generic
	tpl	fix_bin.scale.posConversion Routines - Fixed bin to GENERIC right scaling.

"     Right scale is done by negate, scale/round and negate again, since
"     right shift is not a true arithmetic divide unless positive.
"     In the special case of 400000000000000000000000 we overflow the negate
"     and special case correct through fix_bin.right.ovfl.

	negl
	tov	fix_bin.right.ovfl		" special case overflow
	lrs	1,x2			" scale
	xec	binary_round,4		" round as appropriate
	tov	size_error
	negl				" correct result
	tra	fix_bin.noscale

"     Single special case of only high order bit set.  Positive would set
"     bit above top of register.  Do signed shift right since shift count
"     cannot be beyond end of word.  And no round can occur in this case.

"     We still are masked for overflows and cannot detect further hardware
"     overflows without clearing and resetting the indicator mask.
"     When we enter the high order bit is set by negl and is still correct
"     as signed value.

fix_bin.right.ovfl:
	lrs	1,x2			" scale
	tra	fix_bin.noscale

fix_bin.scale.pos:
	lrs	1,x2			" scale number
	xec	binary_round,4		" round positive or negative
	tov	size_error		" out-of-range
fix_bin.noscale:				" no scaling needed, no round
	staq	work|fix_bin_generic
	tra	generic_to_target

	even
one:	dec	0,1			" must be double word aligned

binary_round:
	nop	0			" no round positive (index 0)
	adl	=1,dl			" round positive	(index 1)
"Conversion Routines - Fixed bin to target GENERIC (float bin)


"     Convert fixed bin to float bin by floating the AQ, setting the
"     exponent and normalizing.  Then move the final exponent to the generic
"     float bin exponent field and set the generic float bin mantissa.

"     Rounding of short and long targets is done here since fixed bin is longer
"     than 63 bits and we would otherwise be numerically incorrect in certain
"     cases.  Since we are rounding anyway we do short at the same time.

fix_bin_to_flt_bin:
	lda	work|source_scale		" exponent including scale
	ars	18			" clip precision
	neg	0			" form -scale (b25)
	ada	=71,dl			" add integer scaling
	als	36-8
	sta	work|flt_bin_generic_exp
	ldaq	work|fix_bin_generic
	lde	work|flt_bin_generic_exp
	fno
	tze	fix_bin.flt.zero		" store extended 0.0
	ste	work|flt_bin_generic_exp	" save exponent
	staq	work|flt_bin_generic
	lda	work|flt_bin_generic_exp
	ars	36-8			" form 36-bit exp
	sta	work|flt_bin_generic_exp
	tra	generic_to_target

"     Store an exact 0.0 in internal generic.  This has exponent of 0.

fix_bin.flt.zero:			" zero float bin then convert to target
	stz	work|flt_bin_generic_exp
	stz	work|flt_bin_generic
	stz	work|flt_bin_generic+1
	tra	generic_to_target		" convert to target
"Conversion Routines - Fixed bin to target GENERIC (float decimal)


"     On exit X3 is the precision of the flt_dec_generic value.

"     Initial coding uses BTD instruction and EIS divide to provide result of
"     scaling.  This may be improved later.


fix_bin_to_flt_dec:
	ldaq	work|fix_bin_generic	" see if zero
	tze	force_zero		" which is fast conversion

"     Determine precision of conversion.

	lde	=72b25,du			" pre-set bit count
	fno				" find high bit
	ste	work|flt_bin_generic
	lda	work|flt_bin_generic	" find true precision
	ars	36-8
	ldx4	bin_prec_to_dec_prec,al	" get digits needed
	lxl2	bin_prec_to_dec_prec,al	" get size of source bytes
	eax1	-9,x2			" determine offset of source
	erx1	=o777777,du
	btd	(pr,x1,rl),(pr,rl)
	desc9a	work|fix_bin_generic,x2
	desc9ls	work|flt_dec_generic,x4
	stz	work|flt_dec_generic_exp	" kill flt dec exponent

	eax3	1,x4			" size of float decimal
	ldx2	work|source_scale		" determine power to divide
	tze	generic_to_target		" simple move
	tmi	fix_bin_to_flt_dec.neg_scale

"     Divide will provide a leading 0 in most cases.  So we divide to one
"     digit more precision.  Convert fixed decimal to float decimal.

	adx3	1,du			" one more digit for divide
	xec	dv3d.id.pr_rl.pr_rl,x5	" scale the output
	arg	two_table,x2		" power of two
	desc9ls	work|flt_dec_generic,x4
	desc9fl	work|flt_dec_generic,x3
	tra	fix_bin_to_flt_dec.common

fix_bin_to_flt_dec.neg_scale:
	erx2	=o777777,du
	adx2	=1,du			" negate x2
	xec	mp3d.id.pr_rl.pr_rl,x5	" scale the output
	arg	two_table,x2		" power of two
	desc9ls	work|flt_dec_generic,x4
	desc9fl	work|flt_dec_generic,x3

fix_bin_to_flt_dec.common:
	mlr	(pr,x3),(pr)		" pick and extend exponent
	desc9a	work|flt_dec_generic-1(3),1
	desc9a	work|flt_dec_generic_exp,1
	lda	work|flt_dec_generic_exp
	als	1
	ars	36-8
	sta	work|flt_dec_generic_exp
	tra	generic_to_target
"Conversion Routines - Fixed bin to target GENERIC (bit)

"     Entry condition is a fixed bin value in fix_bin_generic.
"     We convert the fix bin source to fixed bin (71, 0), obeying all normal
"     conversion rules.  Code highly congruent with fix_bin_to_fix_bin.


fix_bin_to_bit:
	ldx2	work|source_scale
fix_bin.bit.flt:				" entry from flt_bin_to_bit
	tze	to_bit			" scales match
	tpl	fix_bin.bit.scale_right	" need right shift and ?round?

fix_bin.bit.scale_left:			" left shift zero fill
	ldaq	work|fix_bin_generic
	erx2	=o777777,du
	adx2	=1,du			" negate x2
	lls	0,x2
	trc	size_error		" overflow
	tra	to_bit			" value is good

fix_bin.bit.scale_right:			" right shift with round
	eax4	0,x5			" determine if rounding
	tze	fix_bin.bit.noround
	ldaq	one			" load mask for rounding
	lls	-1,x2			" determine round bit
	anaq	work|fix_bin_generic
	tnz	fix_bin.bit.noround
	eax4	0			" force no round

fix_bin.bit.noround:
	ldaq	work|fix_bin_generic
	tpl	fix_bin.bit.scale.pos
	negl				" result left as positive
	tov	fix_bin.bit.right.ovfl	" special case overflow
	lrs	0,x2			" scale
	xec	binary_round,4		" round as appropriate
	tov	size_error
	tra	to_bit

fix_bin.bit.right.ovfl:
	lrs	0,x2			" scale
	tra	to_bit

fix_bin.bit.scale.pos:
	lrs	0,x2			" scale number
	xec	binary_round,4		" round positive or negative
	tov	size_error		" out-of-range

"     Convert to generic bit string.  This is done by moving bits for the
"     precision of the source, subtracting the scale factor first.
"     On entry the AQ holds a fixed bin (71, 0) number.

to_bit:
	ldi	mask_faults,dl		" reset faults
	staq	work|fix_bin_generic	" save fix bin (71, 0)
	szn	work|fix_bin_generic	" see if negative
	tpl	to_bit.pos
	negl
	tov	size_error		" won't fit in (71,0)
	staq	work|fix_bin_generic

to_bit.pos:
	epp	generic,work|bit_generic	" set generic area
	lxl2	work|source_precision	" determine start bit to move
	sbx2	work|source_scale
	eax4	-73,x2
	erx4	=o777777,du		" start = 72-precision
	tpl	fix_bin.bit.non_null	" string not null
	ldx3	0,du			" length is 0
	tra	generic_to_target		" output "0" bits

fix_bin.bit.non_null:
	lls	-1,x4			" shift out skipped part
	trc	size_error		" number is too big
	lxl3	work|target_precision
	csl	(pr,x4,rl),(pr,rl),bool(move),fill(0)
	descb	work|fix_bin_generic,x2
	descb	generic|0,x3
	tra	generic_to_target		" store resultConversion Routines - Float bin to target GENERIC


"     Entry condition is the flt_bin_generic value.  Only global register
"     assignments hold for other registers, like X6, X7, etc.

flt_bin_generic_conversion:
	ldx1	target_type_map,x6		" determine target GENERIC
	anx1	generic_mask,du		" mask for type
	tra	flt_bin_generic_case,x1*

flt_bin_generic_case:
	arg	error_bad_type
	arg	flt_bin_to_fix_bin
	arg	generic_to_target		" trivial conversion
	arg	flt_bin_to_flt_dec
	arg	flt_bin_to_fix_bin_uns
	arg	flt_bin_to_bit
	arg	flt_bin_to_char

"     Fixed bin signed and unsigned are similar conversions.  Conversion is
"     done by considering the floating point mantissa to be a scaled fixed
"     binary number.  The scale is determined to be fixed bin (71,71-exp).

flt_bin_to_fix_bin_uns:
	ldaq	work|flt_bin_generic
	tmi	size_error		" must be positive
	staq	work|fix_bin_generic

"     Form scale factor from exponent.

	lda	=72,dl			" scaling
	sba	work|flt_bin_generic_exp	" - exponent
	tmi	size_error
	sba	1,dl			" correct for ranging
	eax2	0,al
	als	36-8			" initial ranging
	trc	size_error
	cmpx2	=72,du			" unsigned limit
	tpnz	size_error		" too big

"     Form shift factor according to target scale.

	sbx2	work|target_scale
	erx2	=o777777,du		" form target-source
	adx2	1,du
	tra	fix_bin.fix_bin_uns.flt


"     Convert float binary to fixed binary signed.

flt_bin_to_fix_bin:
	ldaq	work|flt_bin_generic	" save integer bits of AQ
	staq	work|fix_bin_generic

"     Form scale factor from exponent

	lda	=71,dl			" scaling
	sba	work|flt_bin_generic_exp	" - exponent
	tmi	size_error
	eax2	0,al			" xfer for store
	als	36-8			" initial ranging
	trc	size_error
	cmpx2	=71,du			" signed limit
	tpnz	size_error		" too big

"     Form shift factor according to target scale.

	sbx2	work|target_scale
	erx2	=o777777,du		" form target-source
	adx2	1,du
	tra	fix_bin.fix_bin.flt		" enter and process
"Conversion Routines - Float Binary to Float Decimal GENERIC

"     Floating binary conversion utilizes a sectioning technique to
"     convert through the total range.  This will produce errors towards
"     the limits of the range unfortunately.  Hopefully this technique
"     will be replaced in the near future.

"     Essentially we find a corrected exponent for the float binary number
"     to account for the precision.  This will be a power of two multiplier.
"     The mantissa is converted to an integer of precision 63, by storing
"     the EAQ's AQ after shifting 8 bits.

"     We convert this to hardware float decimal with a zero exponent, and
"     store a zero exponent in the flt_dec_generic.

"     We convert from this decimal value to the final decimal value by
"     adjusting for the floating point bin's original exponent, by multiplying
"     or dividing by two as appropriate.  We section through the range of
"     the table taking into account that 2**m is equivalent to 2**(n+o) by
"     using the limit of the table as the limit of powers of two for each step.
"     Multiply has an extra digit of precision and divide has two.

"     Due to the hardware characteristic that a divide may result in a leading
"     0 on the float dec mantissa, we use extra precision and move the result
"     to normalize and round.

"     On exit, X3 is length of final floating result.
"     During operations X4 is the length of the current result.  It starts as
"     the length of the initial BTD, and continues during mult or division.

flt_bin_to_flt_dec:
	ldaq	work|flt_bin_generic
	tze	force_zero		" zero float bin

"     Form the initial decimal estimate.

	lrs	8			" clear out 8-dummy bits
	staq	work|flt_bin_generic
	lda	63,dl			" precision is flt bin (63)
	cmpq	=0,dl			" see if q is clear
	tnz	flt_bin_to_flt_dec.go	" use full precision
	lda	27,dl			" precision is flt bin (27)

"     We have precision in al.  Do the work.

flt_bin_to_flt_dec.go:
	ldx4	bin_prec_to_dec_prec+1,al	" get precision of target
	lxl1	bin_prec_to_dec_prec+1,al	" get size of source
	lxl3	work|target_precision	" setup target precision
	adx3	2,du			" sign+exp
	eax2	2,x3			" over-length for divide
	sbx4	1,du			" fixed decimal length
	stz	work|flt_dec_generic_exp	" output number exponent

"     Convert mantissa to decimal.

	btd	(pr,rl),(pr,rl)
	desc9a	work|flt_bin_generic,x1
	desc9ls	work|flt_dec_generic,x4
	adx4	1,du			" account for exponent
	mlr	(),(pr,x4),fill(000)	" clear exponent
	zero
	desc9a	work|flt_dec_generic-1(3),1

"     Correct exponent to power of two of representation.

	ldx1	two_table_limit,du		" load range limit
	neg				" -precision
	ada	work|flt_bin_generic_exp	" now power of two
	tze	flt_bin.flt_dec.to_target	" no work at all
	tpl	flt_bin.flt_dec.start_pos	" positive power of two
	neg				" correct exponent
	tra	flt_bin.flt_dec.start_neg	" -ve power of two

"     Start a section of conversion.

flt_bin.flt_dec.start_pos:
	cmpa	two_table_limit,dl		" within table range?
	tpl	flt_bin.flt_dec.set_pos	" above range
	eax1	0,al			" use exponent remainder

flt_bin.flt_dec.set_pos:
	xec	mp3d.id.pr_rl.pr_rl,x5	" power and round
	arg	two_table,x1
	desc9fl	work|flt_dec_generic,x4	" initial length
	desc9fl	work|flt_dec_generic,x3

"     Build generic float decimal exponent.

	mlr	(pr,x3),(pr)		" X4 is current fix dec len
	desc9a	work|flt_dec_generic-1(3),1	" hardware exponent
	desc9a	work|fix_bin_generic,1

	ldq	work|fix_bin_generic	" sign extend and add
	qls	1
	qrs	36-8
	asq	work|flt_dec_generic_exp

"     See if all done the binary exponent.

	sba	two_table_limit,dl
	tmoz	generic_to_target		" done
	eax4	0,x3			" flt dec length
	mlr	(),(pr,x4),fill(000)	" clear exponent
	zero
	desc9a	work|flt_dec_generic-1(3),1
	tra	flt_bin.flt_dec.start_pos

flt_bin.flt_dec.to_target:
	eax3	0,x4			" length of BTD output
	tra	generic_to_target
"Conversion Routine - Float Binary to Float Decimal GENERIC (Continued)

"     Negative power of two done by divide.  We divide overlength to
"     preserve precision and account for divide characteristic where the
"     mantissa gets a leading zero if the divisor is greater than or equal
"     to the dividend.  A later MVN collapsing the precision will fix the
"     leading zero.

flt_bin.flt_dec.start_neg:
	cmpa	two_table_limit,dl		" check range of section
	tpl	flt_bin.flt_dec.set_neg	" above range
	eax1	0,al			" get remaining exp

flt_bin.flt_dec.set_neg:
	dv3d	(id),(pr,rl),(pr,rl)
	arg	two_table,x1
	desc9fl	work|flt_dec_generic,x4
	desc9fl	work|flt_dec_generic,x2	" one byte larger
	cmpa	two_table_limit,dl		" will we continue?
	tpl	flt_bin.flt_dec.neg_continue
	eax3	0,x2			" done, finish exp move
	tra	flt_bin.flt_dec.neg_done

flt_bin.flt_dec.neg_continue:			" needs move to normalize
	xec	mvn.pr_rl.pr_rl,x5
	desc9fl	work|flt_dec_generic,x2
	desc9fl	work|flt_dec_generic,x3

"     Powering section done.  Pick up hardware exponent and add to the
"     generic exponent.  Clear hardware exponent and continue.

flt_bin.flt_dec.neg_done:
	mlr	(pr,x3),(pr)		" X4 is current fix dec len
	desc9a	work|flt_dec_generic-1(3),1	" hardware exponent
	desc9a	work|fix_bin_generic,1

	ldq	work|fix_bin_generic	" sign extend and add
	qls	1
	qrs	36-8
	asq	work|flt_dec_generic_exp

	sba	two_table_limit,dl		" account for work done
	tmoz	generic_to_target		" done
	eax4	0,x3			" float decimal length
	mlr	(),(pr,x4),fill(000)	" clear exponent
	zero
	desc9a	work|flt_dec_generic-1(3),1
	tra	flt_bin.flt_dec.start_neg
"Conversion Routines - Float bin to target GENERIC (bit)

"     Entry condition is a generic float bin value in flt_bin_generic.
"     We convert the flt bin source to fixed bin (71, 0), obeying all normal
"     conversion rules. 


flt_bin_to_bit:
	ldaq	work|flt_bin_generic	" save integer bits of AQ
	staq	work|fix_bin_generic

"     Form scale factor from exponent

	lda	=71,dl			" scaling
	sba	work|flt_bin_generic_exp	" - exponent
	tmi	size_error
	eax2	0,al			" xfer for store
	als	36-8			" initial ranging
	trc	size_error
	cmpx2	=71,du			" signed limit
	tpnz	size_error		" too big
	cmpx2	0,du			" set indicators
	tra	fix_bin.bit.flt		" continue in fixed binConversion Routines - Float decimal to target GENERIC

"     Entry condition is float decimal source in flt_dec_generic with X3
"     as the precision of this number.  Extended exponent is in
"     flt_dec_generic_exp, with the vestigial hardware float decimal exponent
"     of flt_dec_generic_exp as a don't-care value.

"     This routine ensures that the hardware float decimal exponent is set to
"     0 prior to conversion, to ensure ease of conversion.

flt_dec_generic_conversion:
	mlr	(),(pr,x3),fill(000)
	zero				" put in a 0 value
	desc9a	work|flt_dec_generic-1(3),1	" to the exponent

	ldx1	target_type_map,x6		" find target GENERIC
	anx1	generic_mask,du		" mask for type
	tra	flt_dec_generic_case,x1*

"     flt_dec_to_flt_dec is a trivial conversion since on entry X3 has the
"     precision of the flt_dec_generic and this is what the put routines use.
"     Thus we match at this point by design.

flt_dec_generic_case:
	arg	error_bad_type
	arg	flt_dec_to_fix_bin
	arg	flt_dec_to_flt_bin
	arg	generic_to_target		" trivial conversion
	arg	flt_dec_to_fix_bin_uns
	arg	flt_dec_to_bit
	arg	flt_dec_to_char

"     Convert float decimal to scaled or unscaled fixed binary.

flt_dec_to_fix_bin:
	lxl4	work|target_precision	" find conversion precision
	ldx4	bin_prec_to_dec_prec,x4
	ldx2	work|target_scale		" is bin an integer?
	tze	flt_dec.fix_bin.no_scale	" yes
	tmi	flt_dec.fix_bin.neg_scale	" negative scale

"     Scale the float decimal value by the integer's power of two scale

	mp3d	(id),(pr,rl),(pr,rl)
	arg	two_table,x2
	desc9fl	work|flt_dec_generic,x3
	desc9fl	work|flt_dec_generic,x4
	tnz	flt_dec.fix_bin.exp_change

"     flt_dec.fix_bin.zero assumes x3 is current position of exp and
"     therefore the length of the source.  Make this true in case of
"     zero value, since x4 now holds length after mp3d or dv3d.

flt_dec.fix_bin.zero_fix:
	eax3	0,x4			" mp3d or dv3d length is x4
	tra	flt_dec.fix_bin.zero

flt_dec.fix_bin.neg_scale:			" negative scale is divide
	adx4	1,du			" extra digit for hardware
	lcx2	work|target_scale		" get |scale|
	dv3d	(id),(pr,rl),(pr,rl)
	arg	two_table,x2
	desc9fl	work|flt_dec_generic,x3
	desc9fl	work|flt_dec_generic,x4
	tze	flt_dec.fix_bin.zero_fix	" zero value
"	tra	flt_dec.fix_bin.exp_change

"     Integrate possible exponent change.

flt_dec.fix_bin.exp_change:
	eax3	0,x4			" x3 is now exp offset
	mlr	(pr,x3),(pr)
	desc9a	work|flt_dec_generic-1(3),1
	desc9a	work|flt_bin_generic_exp,1
	lda	work|flt_bin_generic_exp
	als	1
	ars	36-8
	asa	work|flt_dec_generic_exp
"     See if exponent is too big.  If not, then convert to fixed decimal
"     and then to binary.  We leave it in place as correct.  Exp offset is
"     assumed to be in x3.

flt_dec.fix_bin.no_scale:
	lda	work|flt_dec_generic_exp
	als	36-8
	trc	decimal_range_error		" range outside of flt dec
	mlr	(pr),(pr,x3)		" install hardware exp
	desc9a	work|flt_dec_generic_exp(3),1
	desc9a	work|flt_dec_generic-1(3),1

flt_dec.fix_bin.zero:			" x3 is assumed source length
	eax4	-1,x4			" target leading sign length
	xec	mvn.pr_rl.pr_rl,x5		" create fixed decimal
	desc9fl	work|flt_dec_generic,x3
	desc9ls	work|flt_dec_generic,x4
	dtb	(pr,rl),(pr)
	desc9ls	work|flt_dec_generic,x4
	desc9a	work|fix_bin_generic,8
	tov	flt_dec.fix_bin.ovfl	" may be bad may be -2**71
	tra	generic_to_target

"     Check if we had the value -2361183241434822606848, if not - size_error.

flt_dec.fix_bin.ovfl:
	cmpn	(pr,rl),()
	desc9ls	work|flt_dec_generic,x4
	desc4ls	max_fix_bin.dec,23
	tnz	size_error		" was out-of-range
	fld	=1b26,du			" get high-order bit
	staq	work|fix_bin_generic
	ldi	mask_faults,dl		" clear overflow and mask
	tra	generic_to_target

max_fix_bin.dec:
	ac4 /-2361183241434822606848/,23
"Conversion Routines - Flt Decimal to target GENERIC (flt bin)

"     Convert float decimal value to an appropriate fixed decimal value
"     which will have all bits of significance for the final float bin
"     value.

"     On entry X3 contains the precision of the flt_dec_generic.

"     Algorithm finds the power of ten expressed in the float decimal, by
"     finding the leading zero's, the exponent and the precision as:
"
"	mag = precision + exponent - leading_zeros
"
"     From this and the log identity of base conversion, we determine a
"     top binary exponent which will cover this number as:
"
"	bin_exp = ceil (mag*log2(10))	- log2(10) = 3.321928095
"
"     This provides a power of two by which to scale the floating number, prior
"     to converting it to binary.  This power is adjusted by the binary point
"     position of the floating point number.

flt_dec_to_flt_bin:
	lxl3	work|source_precision
	tct	(pr,rl)			" count leading zeros
	desc9a	work|flt_dec_generic(1),x3	" miss sign and exponent
	desc9a	zero_skip
	arg	work|fix_bin_generic
	ttn	store_float_bin_zero	" all digits are "0"

"     At this point fix_bin_generic has the leading zero count.
	lda	=o177,dl			" mask for zero count
	ansa	work|fix_bin_generic
	lxl1	work|fix_bin_generic	" leading zero count
	ldq	work|flt_dec_generic_exp	" exponent in Q
	eaa	-1,x3			" precision
	ars	18
	ssa	work|fix_bin_generic	" precision - lead zero
	tmi	store_float_bin_zero

"     Setup registers for scale series.  Determine precision ceiling needed
"     from precision of both source and target.  Take the larger to govern
"     sufficient precision for operation.  Use extra digit for extension
"     precision needed for floating round.
"
"	x2 is overlength precision of divide
"	x3 is running precision (starts at flt dec input length)
"	x4 is output precision of normalize

	eax3	2,x3			" precision+sign+exp
	lxl4	work|target_precision	" form output from target
	ldx4	bin_prec_to_dec_prec,x4	" including sign/exp
	adx4	2,du			" with extra digit+extension
	eax2	1,x4			" extra again for divide
	stx3	work|flt_bin_generic	" save for max
	cmpx4	work|flt_bin_generic	" see if source or target larget
	tpnz	flt_dec.flt_bin.max_prec
	eax4	1,x3			" take precision from source
	eax2	2,x3			" overlength for divide
flt_dec.flt_bin.max_prec:
	adq	work|fix_bin_generic	" exp + prec - LZ
	mpy	log2.10
	lls	3			" scale back
	sta	work|flt_bin_generic_exp	" save initial exponent stab
"Precision correction.

"     In order to maximize conversion precision, we determine the precision
"     needed to contain the high order digit of the mantissa.  This is
"     subtracted from the precision of the EAQ to determine the power of two
"     needed to produce maximum possible conversion precision.

"     From leading zero count, determine the first non-zero digit value and
"     move to work|fix_bin_generic filling high with zero.  Determine the 
"     precision correction needed to bring us to float_bin 70 to 71.

	mrl	(pr,x1),(pr),fill(000)	" zero fill for ldx1 pickup
	desc9a	work|flt_dec_generic(1),1
	desc9a	work|fix_bin_generic,2
	ldx1	work|fix_bin_generic	" get high digit - convert
	ldx1	digit_to_prec-48,x1		" pick up precision-correct 0
	stz	work|fix_bin_generic	" clear storage
	sxl1	work|fix_bin_generic	" save precision correction
	ada	work|fix_bin_generic	" correct float_bin 71 prec
	sba	=71,dl			" correct alignment
	sta	work|fix_bin_generic	" save as final power
	tmi	flt_dec.flt_bin.scale_up

flt_dec.flt_bin.scale_dwn:			" Scale down by power of two
	cmpa	two_table_limit,dl		" within table range?
	tmoz	flt_dec.flt_bin.dwn.final	" yes final to fixed
	lda	two_table_limit,dl		" scale-down section
	dv3d	(id),(pr,rl),(pr,rl)	" down-scale mantissa
	arg	two_table,al
	desc9fl	work|flt_dec_generic,x3
	desc9fl	work|flt_dec_generic,x2	" overlength for precision
	xec	mvn.pr_rl.pr_rl,x5
	desc9fl	work|flt_dec_generic,x2
	desc9fl	work|flt_dec_generic,x4
	neg				" subtract work done
	tra	flt_dec.flt_bin.done
"     Scale up by appropriate power of two.

flt_dec.flt_bin.scale_up:
	neg				" form absolute
	cmpa	two_table_limit,dl		" within table range?
	tmoz	flt_dec.flt_bin.up.final	" yes final to fixed
	lda	two_table_limit,dl		" scale-up section
	xec	mp3d.id.pr_rl.pr_rl,x5	" up-scale mantissa ?round?
	arg	two_table,al
	desc9fl	work|flt_dec_generic,x3
	desc9fl	work|flt_dec_generic,x4	" overlength for precision
"	tra	flt_dec.flt_bin.done


"     Powering section done.  Fix up work done is scaling to bin exp.

flt_dec.flt_bin.done:
	eax3	0,x4			" expand size of flt_dec
	asa	work|fix_bin_generic	" count work done

	mlr	(pr,x4),(pr)		" update exponent
	desc9a	work|flt_dec_generic-1(3),1
	desc9a	work|fix_bin_generic+1,1
	lda	work|fix_bin_generic+1
	als	1
	ars	36-8
	asa	work|flt_dec_generic_exp

	mlr	(),(pr,x4),fill(000)	" clear decimal exponet
	zero
	desc9a	work|flt_dec_generic-1(3),1	" to avoid over/underflow
	lda	work|fix_bin_generic	" check completion.
	tmi	flt_dec.flt_bin.scale_up	" scale up
	tra	flt_dec.flt_bin.scale_dwn	" scale down

"     Final multiply to correct range.  Result goes to fixed decimal to
"     position for DTB conversion to binary.

flt_dec.flt_bin.up.final:
	mlr	(pr),(pr,x3)		" move exponent
	desc9a	work|flt_dec_generic_exp(3),1
	desc9a	work|flt_dec_generic-1(3),1

	xec	mp3d.id.pr_rl.pr,x5	" up-scale mantissa ?round?
	arg	two_table,al
	desc9fl	work|flt_dec_generic,x3
	desc9ls	work|flt_dec_generic,24	" overlength for precision
	tra	flt_dec.flt_bin.up.enter

"     Final divide to correct range.  Result goes to fixed decimal to position
"     for DTB conversion to binary.

flt_dec.flt_bin.dwn.final:
	mlr	(pr),(pr,x3)		" move exponent
	desc9a	work|flt_dec_generic_exp(3),1
	desc9a	work|flt_dec_generic-1(3),1

	xec	dv3d.id.pr_rl.pr,x5
	arg	two_table,al
	desc9fl	work|flt_dec_generic,x3
	desc9ls	work|flt_dec_generic,24

"     Convert the fixed decimal value to bits, and normalize float bin result.

flt_dec.flt_bin.up.enter:
	dtb	(pr),(pr)
	desc9ls	work|flt_dec_generic,24
	desc9a	work|flt_bin_generic,8

"     Get the precision correction for the high order decimal input digit and
"     formulate the initial binary exponent.

	eaa	0,x1
	als	18-8			" to exponent position
	sta	work|fix_bin_generic
	ldaq	work|flt_bin_generic
	lde	work|fix_bin_generic
	fno
	ste	work|fix_bin_generic
	staq	work|flt_bin_generic
	lda	work|fix_bin_generic
	ars	36-8
	asa	work|flt_bin_generic_exp
	tra	generic_to_target
"Conversion Routines - Flt Decimal to target generic (fix bin uns)

"     Convert float decimal to scaled or unscaled fixed binary unsigned.

flt_dec_to_fix_bin_uns:
	cmpc	(pr),(),fill(plus_sign)	" Ensure positive number.
	desc9a	work|flt_dec_generic,1
	zero
	tnz	size_error		" converting negative
	lxl4	work|target_precision	" determine precision needed
	ldx4	bin_prec_to_dec_prec,x4
	ldx2	work|target_scale		" is bin an integer?
	tze	flt_dec.fix_bin_uns.no_scale	" yes
	tmi	flt_dec.fix_bin_uns.neg_scale	" negative scale

"     Scale the float decimal value by the integer's power of two scale

	mp3d	(id),(pr,rl),(pr,rl)
	arg	two_table,x2
	desc9fl	work|flt_dec_generic,x3
	desc9fl	work|flt_dec_generic,x4
	tnz	flt_dec.fix_bin_uns.exp_change

"     Assumption at flt_dec.fix_bin_uns.zero is x3 is size of target, which is
"     currently held only in x4.  Copy x4 to x3 to correct for assumption.

flt_dec.fix_bin_uns.zero_fix:
	eax3	0,x4			" size of zero target
	tra	flt_dec.fix_bin_uns.zero	" zero value

flt_dec.fix_bin_uns.neg_scale:		" negative scale is divide
	lcx2	work|target_scale		" |scale|
	adx4	1,du			" extra digit for hardware
	dv3d	(id),(pr,rl),(pr,rl)
	arg	two_table,x2
	desc9fl	work|flt_dec_generic,x3
	desc9fl	work|flt_dec_generic,x4
	tze	flt_dec.fix_bin_uns.zero_fix	" zero value
"	tra	flt_dec.fix_bin_uns.exp_change

flt_dec.fix_bin_uns.exp_change:		" Add any exponent change
	eax3	0,x4
	mlr	(pr,x3),(pr)
	desc9a	work|flt_dec_generic-1(3),1
	desc9a	work|flt_bin_generic_exp,1
	lda	work|flt_bin_generic_exp
	als	1
	ars	36-8
	asa	work|flt_dec_generic_exp

"     See if exponent is too big.  If not, then convert to fixed decimal
"     and then to binary.  We leave it in place as correct.

flt_dec.fix_bin_uns.no_scale:
	lda	work|flt_dec_generic_exp
	als	36-8
	trc	decimal_range_error		" range outside of flt dec
	mlr	(pr),(pr,x3)		" install hardware exp
	desc9a	work|flt_dec_generic_exp(3),1
	desc9a	work|flt_dec_generic-1(3),1

flt_dec.fix_bin_uns.zero:
	eax4	-1,x4			" leading signed precision
	xec	mvn.pr_rl.pr_rl,x5		" create fixed decimal
	desc9fl	work|flt_dec_generic,x3
	desc9ls	work|flt_dec_generic,x4

"     Convert.  An overflow is acceptable since the bit pattern is right.

	dtb	(pr,rl),(pr)
	desc9ls	work|flt_dec_generic,x4
	desc9a	work|fix_bin_generic,8
	tov	flt_dec.fix_bin_uns.ovfl	" too big, only 71 bits done
	tra	generic_to_target

"     We got an overflow on the conversion.  Thus set the high order bit.

flt_dec.fix_bin_uns.ovfl:
	cmpn	(pr,rl),()		" See if above 72 bit limit.
	desc9ls	work|flt_dec_generic,x4
	desc4ns	two_72,22
	tmoz	size_error
	lda	=o400000,du		" include the sign bit
	orsa	work|fix_bin_generic
	ldi	mask_faults,dl		" permits overflow again
	tra	generic_to_targetConversion Routines - Flt Decimal to target GENERIC (bit)

"     Entry condition is a float decimal value in flt_dec_generic
"     We convert the flt dec source to fixed bin (71, 0), obeying all normal
"     conversion rules.


flt_dec_to_bit:
	lda	work|flt_dec_generic_exp	" incorporate exponent
	als	36-8
	trc	decimal_range_error		" range outside of flt dec
	mlr	(pr),(pr,x3)       		" install hardware exp
	desc9a	work|flt_dec_generic_exp(3),1
	desc9a	work|flt_dec_generic-1(3),1

	ldx4	23,du
	xec	mvn.pr_rl.pr_rl,x5		" create fixed decimal
	desc9fl	work|flt_dec_generic,x3
	desc9ls	work|flt_dec_generic,x4
	dtb	(pr,rl),(pr)		" convert to fixed bin (71,0)
	desc9ls	work|flt_dec_generic,x4
	desc9a	work|fix_bin_generic,8
	tov	size_error

"     Determine the precision equivalent of the result with 0 scale.

	lxl2	work|source_precision
	sbx2	work|source_scale
	eaq	0,x2
	qrs	18
	mpy	log2.10			" convert precision to bin
	lls	3
	cmpq	0,dl			" take ceiling
	tze	flt_dec.bit.ceil
	ada	1,dl
flt_dec.bit.ceil:
	cmpa	71,dl			" take min (71, a)
	tmi	flt_dec.bit.min
	lda	71,dl
flt_dec.bit.min:
	sta	work|source_precision
	ldaq	work|fix_bin_generic	" pick up value
	tra	to_bit			" convert fix bin (71, 0) to bit


"     Log conversion to convert decimal exponent into binary exponent.

log2.10:
	dec	3.321928095b2		" log2(10) at scale 34
"Conversion Routines - Fixed bin unsigned to target GENERIC

fix_bin_uns_generic_conversion:
	ldx1	target_type_map,x6		" determine target GENERIC
	anx1	generic_mask,du		" mask for type
	tra	fix_bin_uns_generic_case,x1*

fix_bin_uns_generic_case:
	arg	error_bad_type
	arg	fix_bin_uns_to_fix_bin
	arg	fix_bin_uns_to_flt_bin
	arg	fix_bin_uns_to_flt_dec
	arg	fix_bin_uns_to_fix_bin_uns
	arg	fix_bin_uns_to_bit
	arg	fix_bin_uns_to_char

"     Convert fixed bin to fixed bin.  Here it is mainly a matter of scaling
"     to ensure the target scale factor is correct.  The difference between
"     conversion to signed and unsigned targets is to assure that the output
"     value is within the range of the target, and an unsigned to signed
"     conversion must result in a positive signed result.


fix_bin_uns_to_fix_bin:			" target signed
fix_bin_uns_to_fix_bin_uns:			" target unsigned
	ldaq	work|fix_bin_generic	" load for .check_target
	ldx2	work|target_scale		" determine cross-scaling
	sbx2	work|source_scale
	tze	fix_bin_uns.check_target	" scales match
	tmi	fix_bin_uns.scale_right	" need right shift and ?round?

"     Overflow detection means generating a mask of the number of bits to
"     be shifted left to determine if this area is non-zero, if so then we
"     will overflow.

fix_bin_uns.scale_left:			" left shift zero fill
	fld	=1b26,du			" get mask bit
	lrs	-1,x2			" generate mask
	anaq	work|fix_bin_generic
	tnz	size_error		" we would overflow

	ldaq	work|fix_bin_generic
	lls	0,x2
	tra	fix_bin_uns.noscale

"     Right scaling may require a round.  Positive rounds up.  Do this by
"     determining the bit position to round at.

fix_bin_uns.scale_right:			" right shift and ?round?
	erx2	=o777777,du		" form shift count-1
	eax4	0,x5			" determine if rounding
	tze	fix_bin_uns.noround
	ldaq	one			" load mask for rounding
	lls	0,x2			" determine round bit
	anaq	work|fix_bin_generic
	tnz	fix_bin_uns.noround
	eax4	0			" force no round
fix_bin_uns.noround:
	ldaq	work|fix_bin_generic
	lrl	1,x2			" do total scale
	xec	binary_round,4		" round if necessary
fix_bin_uns.noscale:			" no scaling needed, no round
	staq	work|fix_bin_generic

"     Ensure target is big enough to hold result.  Do this through shifting.
"     Fixed bin uns to Fixed bin signed checked by precision difference.

fix_bin_uns.check_target:
	lxl2	work|target_precision	" find precision
	lrl	0,x2			" see what is above it
	tnz	size_error		" too big to fit
	tra	generic_to_target		" convert to target
"Conversion Routines - Fixed bin unsigned to target GENERIC (float bin)


"     Conversion is almost identical to normal fixed bin conversion, with
"     the additional condition that the result must be unsigned, thus if
"     the source is a full fixed bin (72) unsigned and has the upper bit set,
"     we pre-scale by one to remove an erroneous negative indication.

fix_bin_uns_to_flt_bin:
	lda	work|source_scale		" form exponent including scale
	ars	18			" clip precision
	als	36-8			" move to exp field
	neg	0			" form -scale (b25)
	ada	=71b25,du			" add integer scaling
	sta	work|flt_bin_generic_exp
	ldaq	work|fix_bin_generic
	tpl	fix_bin_uns.positive	" high bit is clear
	aos	work|flt_bin_generic_exp	" scale exponent
	lrl	1			" protect high bit
fix_bin_uns.positive:
	lde	work|flt_bin_generic_exp	" load and normalize
	fno
	tze	fix_bin_uns.flt.zero	" store extended 0.0
	ste	work|flt_bin_generic_exp	" save exponent
	staq	work|flt_bin_generic
	lda	work|flt_bin_generic_exp
	ars	36-8			" form 36-bit exp
	sta	work|flt_bin_generic_exp
	tra	generic_to_target


fix_bin_uns.flt.zero:		" zero float bin then convert to target
	stz	work|flt_bin_generic_exp
	stz	work|flt_bin_generic
	stz	work|flt_bin_generic+1
	tra	generic_to_target		" convert to target
"Conversion Routines - Fixed bin unsigned to target GENERIC (float decimal)


"     Initial coding uses BTD instruction and divides to provide result of
"     scaling.  This may be improved later.


fix_bin_uns_to_flt_dec:
	ldaq	work|fix_bin_generic	" see if high order bit set
	tze	force_zero		" total is 0.0
	cana	=o400000,du
	tze	fix_bin_uns.flt_dec.short
	ana	=o400000,du		" mask off high bit
	ersa	work|fix_bin_generic	" turn it off

	ldx4	23,du			" set length of conversion
	btd	(pr),(pr,rl)		" convert 71 bits
	desc9a	work|fix_bin_generic,8
	desc9ls	work|flt_dec_generic,x4

	ad2d	(),(pr,rl)		" correct for high bit
	desc4ns	two_71,22			" add 71's bit power
	desc9ls	work|flt_dec_generic,x4
	tra	fix_bin_uns.flt_dec.long

"     Determine length needed to convert.  Method from fix_bin_to_flt_dec.
"     At fix_bin_uns.flt_dec.long X4 has length of the fixed decimal number.

fix_bin_uns.flt_dec.short:
	lde	=72b25,du			" find true precision
	fno
	ste	work|flt_bin_generic
	lda	work|flt_bin_generic
	ars	36-8
	ldx4	bin_prec_to_dec_prec,al	" get digits needed
	lxl2	bin_prec_to_dec_prec,al	" get size of source
	eax1	-9,x2			" get offset of source
	erx1	=o777777,du
	btd	(pr,x1,rl),(pr,rl)
	desc9a	work|fix_bin_generic,x2
	desc9ls	work|flt_dec_generic,x4

fix_bin_uns.flt_dec.long:
	stz	work|flt_dec_generic_exp	" pre-set 0 exponent

	eax3	1,x4			" size of float decimal
	ldx2	work|source_scale		" determine power to divide
	tze	generic_to_target		" simple move
	tmi	fix_bin_uns.flt_dec.neg_scale

	adx3	1,du			" one extra digit for divide
	xec	dv3d.id.pr_rl.pr_rl,x5	" scale the output
	arg	two_table,x2		" power of two
	desc9ls	work|flt_dec_generic,x4
	desc9fl	work|flt_dec_generic,x3
	tra	fix_bin_uns.flt_dec.common

fix_bin_uns.flt_dec.neg_scale:
	erx2	=o777777,du
	adx2	=1,du			" negate x2
	xec	mp3d.id.pr_rl.pr_rl,x5	" scale the output
	arg	two_table,x2		" power of two
	desc9ls	work|flt_dec_generic,x4
	desc9fl	work|flt_dec_generic,x3

fix_bin_uns.flt_dec.common:
	mlr	(pr,x3),(pr)		" pick and extend exponent
	desc9a	work|flt_dec_generic-1(3),1
	desc9a	work|flt_dec_generic_exp,1
	lda	work|flt_dec_generic_exp
	als	1
	ars	36-8
	sta	work|flt_dec_generic_exp
	tra	generic_to_target
"Conversion Routines - Fixed bin unsigned to target GENERIC (bit)

"     Entry condition is a fixed bin unsigned value in fix_bin_generic.
"     We convert the fix bin uns source to fixed bin uns (72, 0), obeying
"     all normal conversion rules.

fix_bin_uns_to_bit:
	ldaq	work|fix_bin_generic	" load for to_bit
	ldx2	work|source_scale		" unscaled is (72, 0)
	tze	to_bit_uns		" convert to final bits
	tpl	fix_bin_uns.bit.scale_right	" need shift right and ?round?

fix_bin_uns.bit.scale_left:			" left shift zero fill
	erx2	=o777777,du		" negate x2
	adx2	=1,du
	lls	0,x2
	trc	size_error		" overflow
	tra	to_bit_uns		" value is good

fix_bin_uns.bit.scale_right:
	eax4	0,x5			" determine if rounding
	tze	fix_bin_uns.bit.noround
	ldaq	one			" load mask for rounding
	lls	-1,x2			" determine round bit
	anaq	work|fix_bin_generic
	tnz	fix_bin_uns.bit.noround
	eax4	0			" force no round
fix_bin_uns.bit.noround:
	ldaq	work|fix_bin_generic
	lrl	0,x2			" do total scale
	xec	binary_round,4		" round if necessary

"     Determine if it fits within the bit stream target and move to generic.

to_bit_uns:
	staq	work|fix_bin_generic	" save fix bin (71, 0)
	epp	generic,work|bit_generic	" set generic area
	lxl2	work|source_precision	" determine start bit to move
	sbx2	work|source_scale
	eax4	-73,x2
	erx4	=o777777,du		" start = 72-precision
	tpl	fix_bin_uns.bit.non_null	" string not null
	ldx3	0,du			" length is 0
	tra	generic_to_target		" output "0" bits

fix_bin_uns.bit.non_null:
	lxl1	work|target_precision	" see if fits within bits
	lrl	0,x1			" okay if "0"b left over
	tnz	size_error		" number is too big
	lxl3	work|target_precision
	csl	(pr,x4,rl),(pr,rl),bool(move),fill(0)
	descb	work|fix_bin_generic,x2
	descb	generic|0,x3
	tra	generic_to_target		" store result
"Conversion Routines - Bit to target GENERIC

"     Expects generic to point to bit source, and length to be in X3.

bit_generic_conversion:
	ldx1	target_type_map,x6		" Call to target routine
	anx1	generic_mask,du
	tra	bit_generic_case,x1*

bit_generic_case:
	arg	error_bad_type
	arg	bit_to_fix_bin
	arg	bit_to_flt_bin
	arg	bit_to_flt_dec
	arg	bit_to_fix_bin_uns
	arg	bit_to_bit
	arg	bit_to_char

"     Conversion to fixed bin is done in a simple manner, as is conversion
"     to float bin and float decimal.  For all these we convert to fixed bin
"     (71, 0), and then call the fixed bin conversion to target GENERIC.

bit_to_fix_bin:
bit_to_flt_bin:
bit_to_flt_dec:
	stz	work|fix_bin_generic	" clear sign bit

"     Copy bits reverse to get from end of string.

	csr	(pr,rl),(pr),bool(move),fill(0)
	descb	generic|0,x3
	descb	work|fix_bin_generic(1),71
	trtf	fix_bin_generic_conversion	" bit string < 71 bits
	eax3	-71,x3			" check upper bits
	cmpb	(pr,rl),(),fill(0)		" to ensure leading "0"b
	descb	generic|0,x3
	zero
	tnz	size_error		" too big
	tra	fix_bin_generic_conversion	" convert it



"     Unsigned target case.

bit_to_fix_bin_uns:				" copy clears sign bit
	csr	(pr,rl),(pr),bool(move),fill(0)
	descb	generic|0,x3
	descb	work|fix_bin_generic,72
	trtf	fix_bin_uns_generic_conversion " bit string <= 72 bits
	eax3	-72,x3			" check upper bits
	cmpb	(pr,rl),(),fill(0)		" to ensure leading "0"b
	descb	generic|0,x3
	zero
	tnz	size_error		" too big
	tra	fix_bin_uns_generic_conversion " convert it
"Converison Routine - bit to bit.

"     Bit to bit conversion is simple.  We simply determine if varying or
"     simple target, and copy sufficient bits to fill the target.  Return
"     is directly to user since we cannot be complex.  For a varying string
"     we only copy up to the length of the source, for a non-varying string,
"     we fill "0" beyond the length of the source.  Source len in X3.  Source
"     is pointed to by generic.  We leave generic pointing to bit_generic.

bit_to_bit:
	lxl2	work|target_precision
	csl	(pr,rl),(pr,rl),bool(move),fill(0)
	descb	generic|0,x3
	descb	work|bit_generic,x2		" copy all bits needed
	epp	generic,work|bit_generic	" point to generic source.
	tra	generic_to_target


"Conversion Routines - bit to character.

"     Bit to character is done by converting to the limit of the target's
"     precision the input bits in a loop.  Much of the code, except the final
"     copy is identical to the bit-to-bit situation, since the only difference
"     is that the source bits become target digits.  Source len in X3.  Source
"     is addressed by generic.  On exit we set generic to the generic
"     character, X3 is length of string.  We use fix_bin_generic to temp-store
"     the string length of output.

bit_to_char:
	lxl2	work|target_precision
	ldx4	0,du			" source bit index
	stx2	work|fix_bin_generic	" save precision
	ldx1	target_type_map,x6		" see if varying
	canx1	varying,du
	tze	bit.char.loop

"     Varying target, adjust conversion length in X2 if bit < char length.

	cmpx3	work|fix_bin_generic
	tpnz	bit.char.loop		" Source > target
	stx3	work|fix_bin_generic	" save precision
	eax2	0,x3

bit.char.loop:
	cmpb	(pr,x4),()		" check if bit 1/0
	descb	generic|0,1
	zero
	tze	bit.char.zero
	mlr	(),(pr,x4),fill(digit_1)	" fill in "1"
	zero
	desc9a	work|char_generic,1
	tra	bit.char.done_digit

bit.char.zero:
	mlr	(),(pr,x4),fill(digit_0)	" fill in "0"
	zero
	desc9a	work|char_generic,1

bit.char.done_digit:
	eax4	1,x4
	sbx3	1,du			" count source done
	tmoz	bit.char.fill_blank		" beyond the source
	sbx2	1,du			" count target done
	tpnz	bit.char.loop
	tra	bit.char.exit

"     Beyond source, fill target with " " characters.

bit.char.fill_blank:
	mlr	(),(pr,rl,x4),fill(blank)
	zero
	desc9a	work|char_generic,x2

bit.char.exit:				" setup chars and exit
	ldx3	work|fix_bin_generic	" precision of generic chars
	epp	generic,work|char_generic	" base of chars
	tra	generic_to_targetConversion Routines - Character to target GENERIC (char to bit) (char to char)

char_to_generic:
	ldx1	target_type_map,x6		" determine target GENERIC
	anx1	generic_mask,du		" mask for type
	tra	char_generic_case,x1*

char_generic_case:
	arg	error_bad_type
	arg	char_to_arithmetic		" char_to_fix_bin
	arg	char_to_arithmetic		" char_to_flt_bin
	arg	char_to_arithmetic		" char_to_flt_dec
	arg	char_to_arithmetic		" char_to_fix_bin_uns
	arg	char_to_bit
	arg	char_to_char

"     Char to bit conversion is simple.  We simply determine if varying or
"     simple target, and copy sufficient bits to fill the target.  Return
"     is directly to user since we cannot be complex.  For a varying string
"     we only copy up to the length of the source, for a non-varying string,
"     we fill "0" beyond the length of the source.  We receive generic pointing
"     to the character string, X3 as the length.  We leave generic as base of
"     bit string and X3 as length.  We use fix_bin_generic as the working
"     target length, permitting correct varying target conversion.

char_to_bit:
char.bit.restart:				" enter and restart
	lxl3	work|source_precision
	lxl2	work|target_precision
	ldx4	0,du			" save length of target
	stx2	work|fix_bin_generic	" save precision
	ldx1	target_type_map,x6		" see if varying
	canx1	varying,du
	tze	char.bit.loop.enter

"     Varying target, adjust conversion length in X2 if char < bit length.

	cmpx3	work|fix_bin_generic
	tpnz	char.bit.loop.enter		" Source > target
	stx3	work|fix_bin_generic	" save precision
	eax2	0,x3

char.bit.loop.enter:
	cmpx3	0,du
	tmoz	char.bit.fill_0		" no work - fill 0
char.bit.loop:
	scm	(),(pr,x4)
	desc9a	char.bit.01,2		" see if character is 0 or 1
	desc9a	generic|0,1
	arg	work|fix_bin_generic+1
	ttf	char.bit.good		" valid digit

"     Digit is invalid.  We correct values to declare a conversion error.

	eaq	1,x4			" index in Q
	qrs	18
	lda	191,dl			" oncode
	tsx1	conversion_error
	tra	char.bit.restart		" re-try conversion again

"     Character was good.  Fill in correct bit.

char.bit.good:
	csl	(pr),(pr,x4),bool(move)	" fill bit
	descb	work|fix_bin_generic+1(35),1	" using low order of index
	descb	work|bit_generic,1
	eax4	1,x4
	sbx3	1,du			" see if beyond source
	tmoz	char.bit.fill_0		" fill with 0 bits
	sbx2	1,du			" see if more target
	tpnz	char.bit.loop
	tra	char.bit.exit

"     Fill in "0" bits for remainder of target.

char.bit.fill_0:
	csl	(),(pr,x4,rl),bool(move),fill(0)
	zero
	descb	work|bit_generic,x2

char.bit.exit:				" setup bit info for exit
	ldx3	work|fix_bin_generic	" number of bits
	epp	generic,work|bit_generic	" location of bits
	tra	generic_to_target

"     String used to check if characters are 0 or 1.

char.bit.01:
	aci	/01/,2


"Conversion Routines - Character to Character

"     Source length is in work|source_precision.  generic points to the string.

char_to_char:
	lxl3	work|source_precision	" pick up length
	tra	generic_to_target
"Conversion Routines - Numeric to character

"     This routine utilizes the existing _to_flt_dec
"     conversion, and sets up for such a conversion.  It sets the
"     target precision according to the log conversion from the
"     precision of the incoming number.  Set X4 to conversion routine address
"     since source get for real part is already done.

fix_bin_to_char:
	ldx4	fix_bin_to_flt_dec,du	" convert to float decimal
	tra	to_char.enter

flt_bin_to_char:
	ldx4	flt_bin_to_flt_dec,du	" convert to float decimal
	tra	to_char.enter


"     At this point X3 contains the length of the float decimal GENERIC.
"     It must be preserved through to the "to_char.float_type" label.

flt_dec_to_char:
	ldx4	generic_to_target,du	" convert to float decimal
	tsx1	save_target		" save old target info
	lda	work|source_precision	" source to target prec/scale
	sta	work|target_precision
	epp	target,work|char_flt_dec_gen	" past guard band
	ldx6	flt_dec_type,du		" presume float
	ldx1	source_type_map,x7		" determine if float or fix
	canx1	fix,du
	tze	to_char.float_type
	ldx6	fix_dec_type,du		" fixed target
	tra	to_char.float_type

fix_bin_uns_to_char:
	ldx4	fix_bin_uns_to_flt_dec,du	" convert to float decimal

to_char.enter:				" common processing
	tsx1	save_target		" save old target info

"     Float decimal precision is ceil ((fixed bin precision)/3.32).
"     This considers the bin precision and the decimal precision to be
"     logarithm expressions and is simply the bin precision changed from
"     log(2) to log(10).

	ldq	work|source_precision
	anq	=o777777,dl		" mask out scale
	mpy	=.3012056b-1
	cmpq	0,dl
	tze	to_char.precision.ceil	" ceiling
	ada	1,dl			" round up

to_char.precision.ceil:
	sta	work|target_precision	" store in DL

"     Put output into work|char_flt_dec_gen.  Set target type to float decimal.

	epp	target,work|char_flt_dec_gen	" past guard band
	ldx6	flt_dec_type,du		" presume float
	ldx1	source_type_map,x7		" determine if float or fix
	canx1	fix,du
	tze	to_char.float_type
	ldx6	fix_dec_type,du		" fixed target
	aos	work|target_precision	" get additional precision
	ldq	work|source_scale		" find scale digits
	tpl	to_char.pos_scale		" don't keep neg scale
	ldq	0,dl
to_char.pos_scale:
	qrs	18
	tze	to_char.float_type
	mpy	=.301205b-1		" form scale conversion
	cmpq	0,dl			" round up
	tze	to_char.scale.ceiling
	ada	1,dl
to_char.scale.ceiling:
	als	18
	asa	work|target_scale		" integrate with precision

to_char.float_type:
	tsp7	0,x4			" Convert real part
	ldi	mask_faults,dl		" re-enable overflow detect
"Determine if source is complex.  If so convert complex part too.

	ldx1	source_type_map,x7
	canx1	complex,du
	tze	to_char.simple_source
	lxl4	source_type_map,x7
	tsp7	0,x4
	ldi	mask_faults,dl		" re-enable overflow detect

"     Restore target info for character, and CASE to data type of source
"     to get correct conversion.

to_char.simple_source:
	epp	source,work|char_flt_dec_gen	" take flt/fix dec from temp
	ldx1	source_type_map,x7		" determine source GENERIC
	anx1	generic_mask,du
	tra	to_char.formatter,x1*

to_char.formatter:
	arg	error_bad_type
	arg	format_fix
	arg	format_flt_bin
	arg	format_flt_dec
	arg	format_fix
	arg	error_bad_type		" bits grabbed earlier
	arg	error_bad_type		" characters grabbed earlier
"Conversion Routines - Formated fixed bin output.


"     Format fixed.

format_fix:
	epp4	format_integer		" presume an integer
	ldx1	work|source_scale
	tmoz	to_char.call_format		" format as integer
	epp4	format_fixed
	tra	to_char.call_format		" format as fractional


"     Format float decimal.
"
"     This requires that we determine if the original source was fixed or
"     float decimal to determine scale information.

format_flt_dec:
	ldx1	source_type_map,x7
	canx1	fix,du			" was source fixed decimal
	tze	format_flt_bin		" no - format float

	epp4	format_integer
	ldx4	work|source_scale		" if no scale, format integer
	tze	to_char.call_format

"     Format as scaled fixed decimal.

	epp4	format_scaled		" use F format
	tmi	to_char.call_format		" scale below precision

	lxl4	work|source_precision	" is scale beyond precision
	cmpx4	work|source_scale
	tmi	to_char.call_format
	epp4	format_fixed		" simple format
	tra	to_char.call_format


"     Format float binary.

format_flt_bin:
	epp4	format_float

"     Call formatter for real and possibly imaginary parts.

to_char.call_format:
	epp	generic,work|char_generic	" pointer to target w/guard
	eax4	0			" flag for real part
	lxl3	work|target_precision	" form target precision
	tsp7	pr4|0			" call formatter

"     X2 contains the number of characters output, X3 contains p+2, source
"     pointer is updated.

	ldx1	source_type_map,x7		" do imaginary if complex
	canx1	complex,du
	tze	to_char.copy_to_target	" only real part

	a9bd	generic|0,x2		" point to imaginary part
	stx2	work|save_target_precision	" save length output
	eax4	1			" flag for imaginary part
	lxl3	work|target_precision	" form target precision
	tsp7	pr4|0			" format
"     Squeeze blanks from imaginary part and add trailing "i".

	scmr	(pr,rl),(du)
	desc9a	generic|0,x2
	vfd	9/blank
	arg	work|fix_bin_generic
	eaa	0,x2			" length of field
	ars	18
	sba	work|fix_bin_generic	" form number of leading 0's
	ldq	work|fix_bin_generic	" number of non-blank chars
	eax4	1,ql			" space for "i"
	mlr	(pr,rl,al),(pr,rl),fill(letter_i)
	desc9a	generic|0,ql
	desc9a	generic|0,x4
	cmpa	0,dl			" need to fill spaces at end?
	tze	to_char.no_fill		" and skip if none
	mlr	(),(pr,rl,x4),fill(blank)	" put spaces right of field
	zero
	desc9a	generic|0,al

to_char.no_fill:
	adx2	1,du			" allow for i at end
	adx2	work|save_target_precision	" form total length of string

"     assign char temporary to final target

to_char.copy_to_target:
	tsx1	restore_target		" restore target info

	epp	generic,work|char_generic	" get ptr to characters
	eax3	0,x2			" get source length in al
	tra	generic_to_target		" and go move
"Conversion Routines - Format decimal integer.


"     entered with p in x3, x4 = 0(1) for real(imag) part,
"     generic = ptr to output buffer, pr4 = ptr to ourselves,
"     and pr7 = return loc

"     returns with p+1 in x3 and x2 = number of chars output (p+3), source
"     pointing after used portion.

format_integer:
	eax3	1,x3
	eax2	2,x3			" length of output = p + 3
	cmpn	(pr,rl),()		" is field 0
	desc9ls	source|0,x3
	desc9ls	char_zero,2
	tze	format_integer.zero
	mvne	(pr,rl),(id),(pr,rl)	" no, do editing
	desc9ls	source|0,x3
	arg	int_edit_desc,x4
	desc9a	generic|0,x2
	a9bd	source|0,x3		" update source used
	tra	pr7|0

format_integer.zero:
	mrl	(id),(pr,rl),fill(blank)	" zero field (edit would IPR)
	arg	zero_field,x4
	desc9a	generic|0,x2
	a9bd	source|0,x3		" update source used
	tra	pr7|0

int_edit_desc:
	desc9a	int_edit,7	real
	desc9a	int_edit(2),5	imag

int_edit:	vfd	9/lte+3,9/blank,9/insm+2,9/mfls,9/mfls,9/mfls,9/mfls

zero_field:
	desc9a	char_zero(1),1		real
	desc9a	char_zero,2		imag

"     Character zero forms.

char_zero:
	aci	"+0-0"
"Conversion Routines - Format Fixed scaled 0 < scale <= precision.


"     entered with p in x3, x4 = 0(1) for real(imag) part,
"     generic = ptr to output buffer, pr4 = ptr to ourselves,
"     and pr7 = return loc

"     returns with p+1 in x3 and x2 = number of chars output (p+3), source
"     points after used part.

format_fixed:
	eax3	1,x3			" form p+1
	sbx3	work|target_scale		" get p-q+1
	eax2	1,x3			" first part of field
	cmpx3	2,du			" need at least 2 digits
	tmi	format_fixed.no_lead_digits	" no, special action needed
	cmpn	(pr,rl),()		" are first p-q digits zero?
	desc9ls	source|0,x3
	desc9ls	char_zero,2
	tze	format_fixed.zero
	mvne	(pr,rl),(id),(pr,rl)	" non-zero, form Sdddd
	desc9ls	source|0,x3
	arg	fixed_edit_desc,x4
	desc9a	generic|0,x2

"     Format right hand side after decimal point.

format_fixed.right:
	ldq	work|target_scale		" q+1 digits of form .ddddd
	eaa	1,qu
	mrl	(pr,rl,x3),(pr,rl,x2),fill(period)
	desc9a	source|0,qu
	desc9a	generic|0,au
	adx3	work|target_scale		" get back p+1
	eax2	2,x3			" total size of field
	a9bd	source|0,x3		" update source pointer
	tra	pr7|0

"     Format integer part as zero.

format_fixed.zero:
	cmpc	(pr),(),fill(plus_sign)
	desc9a	source|0,1
	zero
	tze	format_fixed.zero_pos	" skip if number positive
	mrl	(),(pr,rl),fill(blank)	" move in -0
	desc9a	char_zero(2),2
	desc9a	generic|0,x2
	tra	format_fixed.right		" format fractional part

format_fixed.zero_pos:
	mrl	(id),(pr,rl),fill(blank)	" zero, edit would  IPR
	arg	zero_field,4
	desc9a	generic|0,x2
	tra	format_fixed.right		" format fractional part

format_fixed.no_lead_digits:
	mvne	(pr),(id),(pr)		" put s0 at start of field
	desc9ls	source|0,2
	arg	no_leading_edit_desc,x4
	desc9a	generic|0,2
	tra	format_fixed.right		" format fractional part

fixed_edit_desc:
	desc9a	fixed_edit,7
	desc9a	fixed_edit(2),5

fixed_edit:
	vfd	9/lte+3,9/blank,9/insm+1,9/mfls,9/mfls,9/mfls,9/mfls

no_leading_edit_desc:
	desc9a	no_leading_edit,4
	desc9a	no_leading_edit(2),2

no_leading_edit:
	vfd	9/lte+3,9/blank,9/enf,9/insb+8
"Conversion Routines - Format fixed scaled scale < 0 | precision < scale

"	Call:	x4 = 0 (1) for real (imag) part
"		generic = ptr to output buffer
"		pr4 = ptr to ourselves
"		tsp7	pr4|0
"		x2 = number of chars output (p+4, p+5 or p+6)
"		x3 = p

"	Destroys: a, q, x1
"	Updates:  source	to point after used part.


format_scaled:
	eax3	1,x3			" account for sign
	cmpn	(pr,rl),()		" Is number zero?
	desc9ls	source|0,x3
	desc9ls	char_zero,2
	tnz	format_scaled.nonzero	" No:  edit number with mvne
	mrl	(id),(pr,rl),fill(blank)	" Yes: mvne would IPR
	arg	zero_field,x4
	desc9a	generic|0,x3
	tra	format_scaled.scale_factor

"     Non-zero number.

format_scaled.nonzero:
	mvne	(pr,rl),(id),(pr,rl)	" convert pic "(p)-9vf(-q)"
	desc9ls	source|0,x3
	arg	format_scaled.edit_desc,x4
	desc9a	generic|0,x3

"     Format scale factor for number.

format_scaled.scale_factor:			" convert the scale factor
	mlr	(),(pr,x3),fill(letter_f)	" tack on "f"
	zero
	desc9a	generic|0,1
	lda	work|source_scale		" au = scale_factor
	ars	18			" a = scale_factor
	eax2	1+1			" assume 1 digit scale factor
	cmg	10,dl			" Is one digit enough?
	tmi	format_scaled.have_length	" Yes: format it
	eax2	2+1			" No:  assume 2 digit factor
	cmg	100,dl			" Are two digits enough?
	tmi	format_scaled.have_length	" Yes: format it
	eax2	3+1			" No:  three digit factor

format_scaled.have_length:			" x2 = digits in factor + 1
	neg				" a = -scale_factor
	sta	work|fix_bin_generic	" work|b = -scale_factor
	btd	(pr),(pr,rl,x3)		" convert -scale_factor
	desc9a	work|fix_bin_generic,4
	desc9ls	generic|0(1),x2
	eaa	2,x2
	ars	18
	ada	work|source_precision	" A = p+digits_in_factor+1+2
	eax2	0,al			" into X2
	a9bd	source|0,x3		" update source pointer
	tra	pr7|0

format_scaled.edit_desc:
	desc9a	format_scaled.edit,6
	desc9a	format_scaled.edit(2),4

format_scaled.edit:
	vfd	9/lte+3,9/blank,9/mfls,9/mfls,9/mfls,9/mfls
"Conversion Routines - Format Decimal float.

"     entered with:
"	source|0 -> float decimal generic
"	x3	  has precision of mantissa
"	x4	  has 0/1 for real/imag
"	generic  -> output buffer
"	pr4      -> formatting routine
"	pr7      -> return loc

"     returns with x2 = number of chars output (p+7), updates source to point
"     after used part.

format_float:
	tct	(pr,rl)			" count leading zeros
	desc9a	source|1(1),x3		" miss sign and exponent
	desc9a	zero_skip
	arg	work|fix_bin_generic
	ttn	zero_float		" all digits are "0"

	lxl2	work|fix_bin_generic	" get number of leading zeros
	eaa	0,x2
	ars	18
	neg
	ada	work|target_precision	" form # of non-zero digits
	ana	=o777777,dl
	mlr	(pr),(pr)			" copy sign into temp
	desc9a	source|1,1
	desc9a	work|fix_dec_generic,1
	mlr	(pr,rl,x2),(pr,rl),fill(digit_0) " copy sans leading zeros
	desc9a	source|1(1),al
	desc9a	work|fix_dec_generic(1),x3
	sba	1,dl			" form output exponent
	ada	source|0			" include generic exponent
	sta	work|fix_bin_generic	" save to stop overwrite
	adx3	1,du			" get p+1
	eax2	1,3			" get p+2
	mvne	(pr,rl),(id),(pr,rl)	" generate Sd.dddddddd
	desc9ls	work|fix_dec_generic,x3
	arg	float_edit_desc,4
	desc9a	generic|0,x2
	mlr	(),(pr,x2),fill(letter_e)	" move in "e"
	zero
	desc9a	generic|0,1
	btd	(pr),(pr,x2)		" convert exponent
	desc9a	work|fix_bin_generic,4
	desc9ls	generic|0(1),11
	adx2	2,du			" add length of "e+"
	tct	(pr,x2)			" count most leading zeros
	desc9a	generic|0,7
	desc9a	zero_skip
	arg	work|fix_bin_generic
	eaq	0,x2			" get index
	qrs	18
	adq	work|fix_bin_generic	" add offset
	anq	=o777777,dl		" mask for index
	lda	work|fix_bin_generic	" get length
	ana	=o777777,dl
	neg
	eax4	10,al			" length of move
	mrl	(pr,ql,rl),(pr,x2,rl)
	desc9a	generic|0,x4
	desc9a	generic|0,x4
	stx4	work|fix_bin_generic	" store exponent length
	adx2	work|fix_bin_generic	" add length of digits
	adx3	3,du			" round up
	a9bd	source|0,x3		" update source pointer
	adwp	source,1,du		" align to word
	tra	pr7|0Zero floating point value.

zero_float:
	adx3	2,du			" get p + 2
	mlr	(id),(pr,rl),fill(digit_0)	" form b0.00000 or +0.0000
	arg	zero_fl_desc,x4
	desc9a	generic|0,x3
	mlr	(),(pr,x3),fill(digit_0)	" tack on e+000
	desc9a	eplus,2
	desc9a	generic|0,5
	eax2	5,x3			" get length of field
	adx3	2,du			" sign+mantissa+3 to round
	a9bd	source|0,x3		" update source pointer
	adwp	source,1,du		" align to word
	tra	pr7|0


"     Constants and formatting descriptors

zero_fl_desc:
	desc9a	real_zero_fl,3
	desc9a	imag_zero_fl,3

real_zero_fl:
	aci	" 0."
imag_zero_fl:
	aci	"+0."
eplus:	aci	"e+"

float_edit_desc:
	desc9a	float_edit,8	real
	desc9a	float_edit(2),6	imag

float_edit:
	vfd	9/lte+3,9/blank,9/mfls+1,9/insb+7,9/mvc,9/mvc,9/mvc,9/mvc



"     Save target information and return pointer.

save_target:
	lda	work|target_precision	" combined prec(DL), scale(DU)
	sta	work|save_target_precision
	spri1	work|save_target_ptr
	spri7	work|return
	spri4	work|save_pr4
	stx6	work|save_target_type
	tra	0,1


"     Restore target information and return pointer.

restore_target:
	lda	work|save_target_precision
	sta	work|target_precision
	epp1	work|save_target_ptr,*
	epp7	work|return,*
	epp4	work|save_pr4,*
	ldx6	work|save_target_type
	tra	0,1Conversion Routines - Character to Arithmetic.

"     On entry original_source is zero'd, to indicate no stack extension.

"     We receive the input string in the character temporary and translate it
"     as we go as necessary.  One initial translate test is done to permit the
"     use of short translate/test tables.  It finds the first illegal char.
"     For this translation and the CASE tests, the code is:
"
"     0 (illegal_class) - illegal character
"     1 (sign_class)    - plus or minus sign
"     2 (period_class)  - period (as for decimal point)
"     3 (b_class)       - b or B, used to indicate binary
"     4 (de_class)      - d,D e,E, used to indicate exponential format
"     5 (i_class)       - i or I, used to indicate end of Imaginary part
"     6 (blank_class)   - Whitespace
"     7 (digit_class)   - 0 thru 9, numeric digit
"     8 (f_class)       - f or F, used to indicated fixed format

"     Recognize is used to build a token list for a numeric part, and to
"     recognize the numeric type provided.  It is first called to parse the
"     real part, and then the imaginary part of the input number.  If in
"     scanning the real part, it finds a termination of I or i, we have
"     found the imaginary part instead, and move it to the imaginary token
"     list and clear the real token list.

"     The token list is initialized to zero, which will setup exponent, type,
"     index and length.  This is used with fill in later moves to setup the
"     float decimal source number.

"     After recognize has been run on the translated token source, we determine
"     the dominant numeric type for output, and the dominant scale and
"     precision of the real and imaginary parts.
"
"     Dominant scale is: max (scale_real, scale_imaginary)
"	The scale is determined by the length of the fractional parts.
"
"     Dominant precision is: max (integer_real, integer_imaginary)+1 +
"	dominant scale.
"
"     After determining dominant scale and precision and type, we copy
"     information according to the token list into the character temporary
"     from the source string.  The sign is moved with a "+" fill, thus it
"     defaults to +.  The integer part is moved right to left with 0 fill,
"     the fractional part left to right with 0 fill.  The exponent has already
"     been parsed and determined.  We correct it by subtracting the dominant
"     scale to produce a true float decimal GENERIC form for the input real
"     and imaginary parts.
"
"     When this numeric input has been built, we simply enter any_to_any_
"     to do conversion to the target.
"
"     There are four basic types of data.

	equ	fixbin,1		" fixed binary
	equ	fltbin,2		" float binary
	equ	fixdec,3		" fixed decimal
	equ	fltdec,4		" float decimal

"     These are later converted to the true internal data type*2 by a
"     conversion table.  Float decimal will normally use real_flt_dec_9bit, but
"     if the range does not fit, then we escape to real_flt_dec_ext for a 9-bit
"     exponent.
"Converision Routines - Character to numeric

"     Uses PR4 to point to token area in current use.

char_to_arithmetic:
	stz	work|original_source	" clear extension flag
	stx5	work|save_rounding		" save rounding requested
	lda	work|source_string_length	" get length of source
	ana	=o777777,dl
	tze	char.arith.zero
	cmpa	256,dl			" check length
	tpnz	error_205			" input string too long
	tra	char.arith.save_len

"     Restart point to pick up string from "conversion" error recover routine.
"     Here we may have a different length than before.

char_to_arithmetic_restart:
	lda	work|source_string_length	" get length of source
	tze	char.arith.zero
	cmpa	256,dl			" deal with max of 256 chars
	tmi	char.arith.save_len
	lda	256,dl			" force length, no error

"     Save length of string supplied.  Length in A.

char.arith.save_len:
	sta	work|original_source_length 	" save for conversion error

" NOTE - Here it should be spri generic,work|generic_ptr, but ALM won't do it.
	spri2	work|generic_ptr		" save string pointer

	tct	(pr,rl)			" find illegal or end
	desc9a	generic|0,al
	arg	error_table
	arg	work|flt_bin_generic
	ttn	char.arith.good_string

"     Bad character seen.  Find index of it.

	ldq	work|flt_bin_generic	" get index
	anq	=o777777,dl
	tra	error_203			" illegal character

char.arith.good_string:
	tctr	(pr,rl)			" rtrim (string)
	desc9a	generic|0,al
	arg	blank_skip
	arg	work|fix_bin_generic
	lca	work|fix_bin_generic	" - blanks
	alr	9			" sign extend
	ars	9
	ada	work|original_source_length	" length - blanks
	tze	char.arith.zero		" all blank

"     Start index at first non-whitespace.
"     Build token information into imaginary token.  Will move it later.

	mlr	(),(pr),fill(000)		" init real token
	zero
	desc9a	work|real_token,token_length
	mlr	(),(pr),fill(000)		" init imag token
	zero
	desc9a	work|imag_token,token_length
	tct	(pr,rl)			" skip over leading blanks
	desc9a	generic|0,al
	arg	blank_skip
	arg	work|fix_bin_generic
	stba	work|fix_bin_generic,40	" clear high byte blank count
	sba	work|fix_bin_generic	" account for blanks
	tmoz	char.arith.zero		" all blank - is 0.0

"     Not all character input was blank.  Start on real part.

	ldq	work|fix_bin_generic	" initialize offset
	tsx2	recognize			" look for a number
	mlr	(pr),(pr)			" move imag to real
	desc9a	work|imag_token,token_length
	desc9a	work|real_token,token_length
	cmpa	0,dl			" did we reach end of input
	tpnz	char.arith.more_input	" continue
	stz	work|imag.type		" indicate no imaginary
	tra	char.arith.end_of_input

"     have some characters after the number, process as terminator.
"     Use X2 as error index for trailing blank check.

char.arith.more_input:
	ldx2	error_203,du		" indicate bad character

	lxl4	work|real.term		" get terminator class
	tra	*+1,x4			" case process terminator
	tra	error_203			" illegal
	tra	char.arith.have_real_part	" sign - imag follows
	tra	error_203			" period
	tra	error_203			" b
	tra	error_203			" d e
	tra	char.arith.got_imag_part	" i    - we saw imag part
	tra	char.arith.blank_imag	" blank
	tra	error_203			" digit (can't happen)
	tra	error_203			" f


"     Blank trailing real part.  Clear imaginary part and check blanks.

char.arith.blank_imag:
	stz	work|imag.type		" no imaginary type
	tra	char.arith.check_blank

"     We have just seen the imaginary part, and the real part is empty.
"     The imaginary token list entry is okay, clear the real token.

char.arith.got_imag_part:
	mlr	(),(pr),fill(000)		" init real
	zero
	desc9a	work|real_token,token_length
	tra	char.arith.have_imag_part	" we have imaginary

"     Capture token info in imaginary part.

char.arith.have_real_part:
	mlr	(),(pr),fill(000)		" init imag
	zero
	desc9a	work|imag_token,token_length

	tsx2	recognize			" look for a number
	cmpa	0,dl			" did we reach end of input
	tmoz	error_219			" must have the "i"

"     We have both parts of the number, real and imaginary.
"     Check if we terminate correctly.  We must have blanks.

char.arith.have_imag_part:
	lxl4	work|imag.term		" check terminator
	cmpx4	i_class,du		" must be "i"
	tnz	error_219
	adq	1,dl			" skip the blank
	sba	1,dl			" one less to check
	tmoz	char.arith.end_of_input
	ldx2	error_211,du		" bad char after "i"

char.arith.check_blank:
	tct	(pr,rl,ql)		" skip trailing blanks
	desc9a	generic|0,al
	arg	blank_skip
	arg	work|fix_bin_generic
	ttf	0,x2			" complain

"     From token list, form the generic input, using char.flt_dec_generic.

char.arith.end_of_input:			" Set dominant conversion type.
	eax6	0,x6			" target of opportunity
	tnz	char.arith.supplied

	ldx7	work|real.type
	ldx1	work|imag.type
	epp	generic,dominant_type,x7*	" select imaginary table
	ldx7	generic|0,x1		" get dominant type
	lxl2	generic|0,x1		" get precision routine

"     If we alter the precision and scale, for a decimal to binary conversion.
"     The precision will appear in AL, and the scale in X5.  We indicate the
"     modified scale/precision tokenlist word by X3 as an offset in the
"     work area.

	lda	0,dl			" preset precision
	ldx5	0,du			" preset scale
	ldx3	0,du			" preset token prec/scale mod
	tra	0,x2			" manage precision

"     Transform the precision of the real part to binary from decimal.

r_dec_to_xbin:		" Convert real part decimal prec/scale to bin
	ldx3	real.scale,du
	tra	dec_to_bin.scale

r_dec_to_bin:		" Convert real part decimal prec to bin
	ldx3	real.prec,du
	tra	dec_to_bin.prec

i_dec_to_bin:		" Convert imaginary part decimal prec/scale to bin
	ldx3	imag.prec,du
	tra	dec_to_bin.prec

i_dec_to_xbin:		" Convert imaginary part decimal prec to bin
	ldx3	imag.scale,du
"	tra	dec_to_bin.scale		" fall through to routine

"     Convert the indicated scale to X5.

dec_to_bin.scale:
	ldq	work|0,x3		" scale = ceil (log2(10)*scale)
	qrs	18			" position
	tmi	dec_to_bin.prec		" negative scale set to 0
	mpy	log2.10			" convert base
	lls	3
	cmpq	0,dl			" ceiling
	tze	dec_to_bin.prec
	ada	1,dl
"	tra	dec_to_bin.prec		" find dominant precision

dec_to_bin.prec:
	ldx3	1,du
	ldq	work|0,x3		" prec = ceil (log2(10)*prec)
	anq	=o777777,dl		" mask from DL
	mpy	log2.10			" convert base
	lls	3
	cmpq	0,dl			" ceiling
	tze	char.arith.save_prec
	ada	1,dl
	tra	char.arith.save_prec	" find dominant precision

"     Save updated precision and scale.

char.arith.save_prec:
	sta	work|0,x3			" save precision
	stx5	work|0,x3			" save scale

"     Take precisions as is:  From dominant, process precision and scale.

as_is:
	eax4	0,x7			" save type
	xec	calculate_precision,x7	" target_precision
	ldx5	work|imag.type		" determine if complex
	tze	char.arith.real_type
	eax4	4,x4			" change to complex
char.arith.real_type:			" set type of source
	ldx6	final_type,x4		" presume short
	ldx5	work|target_precision
	xec	calculate_type,x7		" compare to limit
	tmoz	char.arith.set_round	" within short
	lxl6	final_type,x4		" pick up long type

char.arith.set_round:
	stz	work|save_rounding		" presume no round
	ldx1	target_type_map,x7		" get default
	canx1	round,du
	tze	char.arith.supplied		" no round
	lda	1,dl
	sta	work|save_rounding		" round

"     Caller supplied target type and precision.  Convert input.

char.arith.supplied:
	epp	generic,work|generic_ptr,*	" get ptr to source
	tsx1	move_char_to_generic	" move and set scale/prec, type
	ldx5	work|save_rounding
	epp7	char.arith.real_return	" setup return
	lxl3	work|real.prec		" setup float dec precision
	eax3	2,x3			" extend for sign and hard exp
	ldx2	work|real.type		" get internal type
	tra	*+1,x2			" process generic
	tra	flt_dec_generic_conversion	" presume 0.0
	tra	fix_bin_generic_conversion
	tra	flt_bin_generic_conversion
	tra	flt_dec_generic_conversion
	tra	flt_dec_generic_conversion

char.arith.real_return:
	ldi	mask_faults,dl		" clear for faults again
	ldx1	target_type_map,x6		" get flag word for target
	canx1	complex,du		" complex?
	tze	unmask_exit		" real target, return

"     Convert imaginary part.

	mlr	(pr),(pr)			" move imag to real
	desc9a	work|imag_token,token_length
	desc9a	work|real_token,token_length

	epp	generic,work|generic_ptr,*	" get ptr to source
	tsx1	move_char_to_generic	" move and set scale/prec
	ldx5	work|save_rounding
	epp7	unmask_exit		" setup return
	lxl3	work|real.prec		" setup float dec precision
	eax3	2,x3			" extend for sign and hard exp
	ldx2	work|real.type		" get internal type
	tra	*+1,x2			" process generic
	tra	flt_dec_generic_conversion	" +0 already set
	tra	fix_bin_generic_conversion
	tra	flt_bin_generic_conversion
	tra	flt_dec_generic_conversion
	tra	flt_dec_generic_conversion


"     Input of real and imaginary is zero.  Use a default input.

char.arith.zero:
	epp	generic,char.arith.zero_char
	lda	1,dl			" one character long
	sta	work|source_string_length
	tra	char_to_arithmetic_restart

char.arith.zero_char:
	aci	/0/,1
"Tables for type conversion.


"     Dominant type table.  Used to convert a real and imaginary type into
"     the dominant complex type.  First table references the other four.
"     Here we have a 0 entry for a non-existant token type default of 0.

"     The following matrix provides conversions and determines precision
"     conversion.
"
"   REAL TYPE
"
"     0 type | error  | fixbin | fltbin | fixdec | fltdec |
"	   |        | as is  | as is  | as is  | as is  |
"	   ---------------------------------------------|
"     fixbin | fixbin | fixbin | fltbin | fixbin | fltbin |
"	   | as is  | as is  | as is  |dec->bin|dec->bin|
"	   ---------------------------------------------|
"     fltbin | fltbin | fltbin | fltbin | fltbin | fltbin |
"	   | as is  | as is   | as is |dec->bin|dec->bin|
"	   ---------------------------------------------|
"     fixdec | fixdec | fixbin | fltbin | fixdec | fltdec |
"	   | as is  |dec->bin|dec->bin| as is  | as is  |
"	   ---------------------------------------------|
"     fltdec | fltdec | fltbin | fltbin | fltdec | fltdec |
"	   | as is  |dec->bin|dec->bin| as is  | as is  |
"	   ---------------------------------------------|
"  IMAG TYPE   0 type   fixbin   fltbin   fixdec   fltdec


dominant_type:
	arg	fixdec_type	" use default if real is 0
	arg	fixbin_type
	arg	fltbin_type
	arg	fixdec_type
	arg	fltdec_type

"     Table element has DU type and DL conversion routine.  This conversion
"     routine is used to convert precision and scale as necessary according
"     to the output type and the real and imaginary sources.  as_is just
"     passes on the scale and precision.

fixbin_type:
	vfd	18/fixbin,18/as_is		" stay in type, use real part
	vfd	18/fixbin,18/as_is		" stay in type, prec/scale
	vfd	18/fltbin,18/as_is		" co-erce fixbin to fltbin
	vfd	18/fixbin,18/i_dec_to_xbin	" co-erce fixdec to fixbin
	vfd	18/fltbin,18/i_dec_to_bin	" co-erce fltdec to fltbin

fltbin_type:
	vfd	18/fltbin,18/as_is		" stay in type
	vfd	18/fltbin,18/as_is		" co-erce fixbin to fltbin
	vfd	18/fltbin,18/as_is		" stay in type
	vfd	18/fltbin,18/i_dec_to_bin	" co-erce fixdec to fltbin
	vfd	18/fltbin,18/i_dec_to_bin	" co-erce fltdec to fltbin

fixdec_type:
	vfd	18/fixdec,18/as_is		" stay in type
	vfd	18/fixbin,18/r_dec_to_xbin	" co-erce fixdec to fixbin
	vfd	18/fltbin,18/r_dec_to_bin	" co-erce fixdec to fltbin
	vfd	18/fixdec,18/as_is		" stay in type
	vfd	18/fltdec,18/as_is		" co-erce fixdec to fltdec

fltdec_type:
	vfd	18/fltdec,18/as_is		" stay in type
	vfd	18/fltbin,18/r_dec_to_bin	" co-erce fixbin to fltbin
	vfd	18/fltbin,18/r_dec_to_bin	" co-erce fltdec to fltbin
	vfd	18/fltdec,18/as_is		" co-erce fixdec to fltdec
	vfd	18/fltdec,18/as_is		" stay in type
"     Type table for conversion of internal to real data type.  DU is
"     short form, DL is long form.

	equ	real_fix_bin_1,1
	equ	real_fix_bin_2,2
	equ	real_flt_bin_1,3
	equ	real_flt_bin_2,4
	equ	cplx_fix_bin_1,5
	equ	cplx_fix_bin_2,6
	equ	cplx_flt_bin_1,7
	equ	cplx_flt_bin_2,8
	equ	real_fix_dec_9bit_ls,9
	equ	real_flt_dec_9bit,10
	equ	cplx_fix_dec_9bit_ls,11
	equ	cplx_flt_dec_9bit,12

final_type:
	vfd	18/real_fix_bin_2*2,18/real_fix_bin_2*2	" default 0 type
	vfd	18/real_fix_bin_1*2,18/real_fix_bin_2*2
	vfd	18/real_flt_bin_1*2,18/real_flt_bin_2*2
	vfd	18/real_fix_dec_9bit_ls*2,18/real_fix_dec_9bit_ls*2
	vfd	18/real_flt_dec_9bit*2,18/real_flt_dec_9bit*2
	vfd	18/cplx_fix_bin_1*2,18/cplx_fix_bin_2*2
	vfd	18/cplx_flt_bin_1*2,18/cplx_flt_bin_2*2
	vfd	18/cplx_fix_dec_9bit_ls*2,18/cplx_fix_dec_9bit_ls*2
	vfd	18/cplx_flt_dec_9bit*2,18/cplx_flt_dec_9bit*2
"Compute precision and scale of final result

"     scale = max(real_scale,imag_scale)
"     precision = scale + max(real_prec-real_scale, imag_prec-imag_scale)
"
"     Result left in source_scale and source_precision fields in work area.


fixed_prec_and_scale:
	ldx2	work|imag.type		" take real if no imag
	tze	fixed_prec_and_scale.real

"     Calculate precisions.

	lxl2	work|real.prec
	sbx2	work|real.scale		" real prec-scale
	lxl3	work|imag.prec
	sbx3	work|imag.scale
	stx3	work|target_precision	" imag prec-scale
	cmpx2	work|target_precision
	tpl	2,ic			" real>imag
	eax2	0,x3			" take imaginary
	adx2	1,du
	ldx3	work|real.scale		" calculate max scale
	cmpx3	work|imag.scale
	tpl	2,ic
	ldx3	work|imag.scale
	stx3	work|target_scale		" set new scale (DU)
	adx2	work|target_scale		" add max scale
	sxl2	work|target_precision	" set new precision (DL)
	tpnz	0,x1
	aos	work|target_precision	" max (prec, 1)
	tra	0,x1

fixed_prec_and_scale.real:
	lda	work|real.prec
	sta	work|target_precision
	ana	=o777777,dl		" mask for precision
	tpnz	0,x1
	aos	work|target_precision	" max (prec, 1)
	tra	0,x1

"     Calculate float precision.

"     precision = max(real_prec, imag_prec)
"
"     Result left in target_precision field in work area.  Scale set to 0.


float_prec:
	lxl2	work|real.prec
	ldx3	work|imag.type		" take real if no imag
	tze	float_prec.real
	lxl3	work|imag.prec
	cmpx2	work|imag.prec
	tpl	2,ic
	eax2	0,x3
float_prec.real:
	sxl2	work|target_precision	" set new precision (DL)
	ldx2	0,du
	stx2	work|target_precision	" zero scale
	lxl2	work|target_precision	" ensure precision >= 1
	tpnz	0,x1
	aos	work|target_precision	" max (prec, 1)
	tra	0,x1



"     Execute table used for calculation of precision and scale according to
"     the dominant target type.

calculate_precision:
	tra	error_bad_type		" must have a type by now
	tsx1	fixed_prec_and_scale
	tsx1	float_prec
	tsx1	fixed_prec_and_scale
	tsx1	float_prec

"     Execute table used for comparison of precision limit to determine
"     long/short data type.

calculate_type:
	tra	error_bad_type		" must have type by now
	cmpx5	35,du			" short limit of fixed bin
	cmpx5	27,du			" short limit of float bin
	cmpx5	59,du			" upper limit of fixed dec
	cmpx5	59,du			" upper limit of float decMove float decimal generic from source character stream.

"     Routine to move character input to float decimal generic form for
"     char_to_arithmetic.  It creates a 36-bit exponent, moves the sign
"     and moves the integer and fractional parts.

"     On entry:
"	X1	is return offset
"	generic	points to source string
"	type of numer in work|imag.type (DU)
"
"     On exit we have stored the appropriate type of float decimal generic,
"	fix_bin_generic or flt_bin_generic.
"	We have also set source_precision and source_scale and X7.

move_char_to_generic:
	ldx2	work|real.type
	tra	*+1,x2
	tra	char_to_generic.zero_dec
	tra	char_to_generic.fixbin
	tra	char_to_generic.fltbin
	tra	char_to_generic.fixdec
	tra	char_to_generic.fltdec

char_to_generic.zero_dec:
	lda	1,dl			" set source scale/prec
	sta	work|source_precision
	sta	work|real.prec		" same in token
	stz	work|flt_dec_generic_exp	" clear exponent
	lda	dec_zero			" implant +0
	sta	work|flt_dec_generic
	tra	0,x1
	
char_to_generic.fixdec:
char_to_generic.fltdec:
	stz	work|source_scale		" kill the scale
	ldx7	real_flt_dec_generic*2,du	" set type of data moved to
	ldx2	work|real.integer.length	" get precision (DU)
	adx2	work|real.fraction.length
	tmoz	char_to_generic.zero_dec	" default to 0.0
	cmpx2	max_p_dec,du		" see if too many digits
	tpnz	error_218
	sxl2	work|source_precision	" save precision
	lda	work|real.fraction.length	" get fractional length
	ars	18		
	ssa	work|real.exponent.value	" form fraction - exponent
	lca	work|real.exponent.value	" save generic's exponent
	sta	work|flt_dec_generic_exp

"     Move in sign.

	ldx2	work|real.sign.length	" length in DU
	lxl3	work|real.sign.index	" index in DL
	ldx4	1,du			" move 1 char
	mlr	(pr,rl,x3),(pr,rl),fill(plus_sign)
	desc9a	generic|0,x2		" fills "+" if no sign
	desc9a	work|flt_dec_generic,x4

"     Move integer part.

	ldx2	work|real.integer.length	" length of source DU
	lxl4	work|real.integer.index	" index in source DL
	mlr	(pr,rl,x4),(pr,rl),fill(digit_0)
	desc9a	generic|0,x2
	desc9a	work|flt_dec_generic(1),x2

"     Move fractional part.

	lxl4	work|real.fraction.index	" index in source DL
	ldx3	work|real.fraction.length	" length of source DU
	mlr	(pr,rl,x4),(pr,rl,x2),fill(digit_0)
	desc9a	generic|0,x3
	desc9a	work|flt_dec_generic(1),x3
	tra	0,x1			" return for next section
"Move fixed bin generic from source character stream.

"     Here we will receive an integer and a fractional part.  They must
"     be converted to bits and stored.  They have been pre-checked.
"
"     Number is converted from the lower bits to the higher bits.
"     Precision is set, scale was set by recognize.

char_to_generic.fixbin:
	ldx7	real_fix_bin_2*2,du		" set type of output
	ldx2	work|real.scale		" copy scale
	stx2	work|source_scale
	ldx2	work|real.fraction.length	" length of fraction
	adx2	work|real.integer.length	" plus length of integer
	cmpx2	max_p_fix_bin_2,du		" see if too many digits
	tpnz	error_218
	sxl2	work|source_precision	" gives precision
	epp	source,work|fix_bin_generic	" point to target area
	stz	source|0			" pre-set
	stz	source|1
	ldx5	71,du			" bit index of target
	ldx4	work|real.fraction.length	" get length
	tze	char.gen.fixbin.int

	lxl3	work|real.fraction.index	" get index
	adx3	work|real.fraction.length	" plus length +1
	tsx2	move_char_to_bit_right	" move right to left

"     Do integer part next.  Abbut to fraction.

char.gen.fixbin.int:
	ldx4	work|real.integer.length	" get length
	tze	char.gen.fixbin.exit_1	" set precision and exit
	lxl3	work|real.integer.index	" get index
	adx3	work|real.integer.length	" plus length+1
	tsx2	move_char_to_bit_right	" move right to left
	tra	char.gen.fixbin.exit

char.gen.fixbin.exit_1:
	ldx3	1,du
	sxl3	work|real.prec		" indicate source prec is 1

char.gen.fixbin.exit:
	ldx4	work|real.sign.length	" length of sign
	tze	0,x1			" default + sign
	lxl3	work|real.sign.index	" index of sign
	cmpc	(pr,x3),(),fill(plus_sign)
	desc9a	generic|0,1
	zero
	tze	0,x1			" + sign
	ldaq	work|fix_bin_generic	" form negative
	negl
	tov	size_error		" -2**72 won't fit
	staq	work|fix_bin_generic
	tra	0,x1
"Move float bin generic from source character stream.
"     Here we will receive an integer and a fractional part.  They must
"     be converted to bits and stored.  They have been pre-checked.
"     Number is converted from the lower bits to the higher bits, it is
"     stored starting from integer+fractional length from the top, and
"     the exponent is set to integer length + exponent.

char_to_generic.fltbin:
	ldx7	real_flt_bin_2*2,du		" set type of output
	ldx2	work|real.fraction.length	" length of fraction
	stz	work|source_scale
	adx2	work|real.integer.length	" plus length of integer
	cmpx2	max_p_flt_bin_2,du		" see if too many digits
	tpnz	error_218
	sxl2	work|source_precision	" gives precision
	lda	work|real.integer.length	" get length DU
	ars	18
	ada	work|real.exponent.value
	sta	work|flt_bin_generic_exp	" store the flt bin gen exp
	epp	source,work|flt_bin_generic	" point to target area
	stz	source|0
	stz	source|1			" pre-set mantissa
	ldx5	work|real.fraction.index	" bit index of target
	adx5	work|real.integer.length
	ldx4	work|real.fraction.length	" get length
	tze	char.gen.fltbin.int

	lxl3	work|real.fraction.index	" get index
	adx3	work|real.fraction.length
	tsx2	move_char_to_bit_right	" move right to left

"     Do integer part next.  Abbut to fraction.

char.gen.fltbin.int:
	ldx4	work|real.integer.length	" get length
	tze	char.gen.fltbin.exit_1
	lxl3	work|real.integer.index	" get index
	adx3	work|real.integer.length
	tsx2	move_char_to_bit_right	" move right to left
	tra	char.gen.fltbin.exit

char.gen.fltbin.exit_1:
	ldx3	1,du			" indicate source precision 1
	sxl3	work|real.prec

char.gen.fltbin.exit:
	ldx4	work|real.sign.length	" length of sign
	tze	0,x1			" default + sign
	lxl3	work|real.sign.index	" index of sign
	cmpc	(pr,x3),(),fill(plus_sign)
	desc9a	generic|0,1
	zero
	tze	0,x1			" + sign
	ldaq	work|flt_bin_generic	" form negative
	lde	0,du
	fneg
	staq	work|flt_bin_generic
	lda	=-1,du			" form -1 to correct exp
	ars	18
	asa	work|flt_bin_generic_exp	" account for shift in fneg
	tra	0,x1

"     x3 is index into character string and is pre-decremented.
"     x4 is length of character string and is decremented.
"     x5 is index into bit string and is decremented.

move_char_to_bit_right:
	sbx3	1,du			" move source index
	scm	(),(pr,x3),mask(000)	" check 0 or 1
	desc9a	char.bit.01,2	
	desc9a	generic|0,1
	arg	work|flt_dec_generic_exp	" lowermost bit will be good
	csl	(pr),(pr,x5),bool(move)	" as true digit value
	descb	work|flt_dec_generic_exp(35),1
	descb	source|0,1
	sbx5	1,du			" move target index
	sbx4	1,du			" count bit done
	tpnz	move_char_to_bit_right
	tra	0,x2RECOGNIZE A REAL CONSTANT

"     recognize a <real constant>
"     entered with
"	char offset in ql
"	char length in al
"	token area to use is imag_token
"	return offset in x2
"	pointer to source string in generic
"
"     exits with
"	char offset in ql
"	char length (remaining) in al
"	type in x7
"	token area filled in

recognize:
	ldx7	fixdec,du			" preset to fixed decimal

"     Check for sign.  Translate and test next character.

	mvt	(pr,ql),(pr)		" translate first character
	desc9a	generic|0,1
	desc9a	work|flt_bin_generic_exp,1
	arg	translate_table

	cmpc	(pr),(),fill(sign_class)	" test if in classification
	desc9a	work|flt_bin_generic_exp,1
	zero
	tnz	recognize.no_sign

"     Note sign index and length of 1.

	stq	work|imag.sign.index	" index in DL
	ldx3	1,du
	stx3	work|imag.sign.length	" length of 1
	sba	1,dl			" done one character
	tmoz	error_202			" error - no digits found
	adq	1,dl			" skip sign

"     Check for integer part.

recognize.no_sign:
	tct	(pr,rl,ql)		" skip over string of digits
	desc9a	generic|0,al
	arg	digit_skip
	arg	work|fix_bin_generic
	lxl3	work|fix_bin_generic	" get number of digits found
	tze	recognize.no_integer	" skip if none

"     Note that a mantissa exists by leaving a non-zero X3, and clip the
"     leading 0's from it to remove them from significance checks.

	eax4	0,x3			" remember mantissa size
	tct	(pr,rl,ql)		" skip over leading 0's
	desc9a	generic|0,x3
	arg	zero_skip
	arg	work|flt_bin_generic
	lxl5	work|flt_bin_generic
	stx5	work|flt_bin_generic	" move to upper
	eax5	0,ql			" setup index
	sbx4	work|flt_bin_generic	" length of non-zero int
	adx5	work|flt_bin_generic	" index of 1st non-zero

"     Store length of integer part, and its index.

	sxl5	work|imag.integer.index	" significance index in DL
	stx4	work|imag.integer.length	" length of sig string in DU
	stba	work|fix_bin_generic,40	" clear upper byte
	adq	work|fix_bin_generic	" move string index
	sba	work|fix_bin_generic	" count all digits done
	tmoz	recognize.no_more_input	" no chars left

"     Check for decimal point, or other situations.

recognize.no_integer:
	mvt	(pr,ql),(pr)		" translate terminator
	desc9a	generic|0,1
	desc9a	work|fix_bin_generic(1),1
	arg	translate_table
	ldx4	work|fix_bin_generic	" get character class
	anx4	=o777,du			" mask for it
	tra	*+1,4
	tra	error_203			" illegal
	tra	recognize.finish_up		" sign (start imag?)
	tra	recognize.start_fractional	" period
	tra	recognize.have_bin		" b
	tra	recognize.start_exponent_flt	" d e
	tra	recognize.finish_up		" i
	tra	recognize.finish_up		" blank
	zero	0			" digit (can't happen)
	tra	recognize.start_scaled_fix	" f

"	have "." after (possibly empty) string of digits

recognize.start_fractional:
	adq	1,dl			" account for .
	sba	1,dl
	tpnz	recognize.scan_fraction	" fractional digits
	cmpx3	0,du			" legitimate integer?
	tpnz	recognize.finish_up		" digits already seen
	sbq	1,dl			" no digits before/after "."
	tra	error_202

"     Find limits of fractional digits.

recognize.scan_fraction:
	tct	(pr,rl,ql)		" skip over string of digits
	desc9a	generic|0,al
	arg	digit_skip
	arg	work|fix_bin_generic
	lxl5	work|fix_bin_generic	" get number of digits
	tze	recognize.no_fraction

"     Fractional digits present.  Note where and how many.

	stq	work|imag.fraction.index	" save index in DL
	stx5	work|imag.fraction.length	" save length in DU
	adx3	work|imag.fraction.length	" form total precision
	stbq	work|fix_bin_generic,40	" clear high byte digit count
	adq	work|fix_bin_generic	" account for digits
	sba	work|fix_bin_generic
	tmoz	recognize.no_more_input	" exit if end reached

"     we are scanning character after string of fractional digits

recognize.no_fraction:
	mvt	(pr,ql),(pr)		" translate terminator
	desc9a	generic|0,1
	desc9a	work|fix_bin_generic(1),1
	arg	translate_table
	ldx4	work|fix_bin_generic	" get char type
	anx4	=o777,du
	tra	*+1,4
	tra	error_203			" illegal
	tra	recognize.finish_up		" sign
	tra	error_204			" period
	tra	recognize.have_bin		" b
	tra	recognize.start_exponent_flt	" d e
	tra	recognize.finish_up		" i
	tra	recognize.finish_up		" blank
	zero	0			" digit (can't happen)
	tra	recognize.start_scaled_fix	" f

"     we have "d" or "e" after mantissa

recognize.start_exponent_flt:
	eax7	fltdec			" change type

"     we have "f" after mantissa

recognize.start_scaled_fix:
	cmpx3	0,dl
	tze	error_214			" no digits before e or f
	adq	1,dl			" account for exponent start
	sba	1,dl
	tmoz	error_201
	mvt	(pr,ql),(pr)		" translate terminator
	desc9a	generic|0,1
	desc9a	work|fix_bin_generic,1
	arg	translate_table
	cmpc	(pr),(),fill(sign_class)	" check for sign
	desc9a	work|fix_bin_generic,1
	zero
	tnz	recognize.unsigned_exponent

"      have start of signed exponent

	adq	1,dl			" account for sign
	sba	1,dl
	tmoz	error_201
	tct	(pr,rl,ql)		" skip over string of digits
	desc9a	generic|0,al
	arg	digit_skip
	arg	work|fix_bin_generic
	lxl5	work|fix_bin_generic	" get number of digits
	tze	error_201			" no digits in exponent
	cmpx5	11,du			" check for max digits
	tpl	error_213			" too many digits
	adx5	1,du			" allow for sign
	dtb	(pr,rl,ql),(pr)		" convert exponent to binary
	desc9ls	source|-1(3),x5
	desc9a	work|imag.exponent.value,4
	tra	recognize.common_exponent

"     have start of unsigned exponent

recognize.unsigned_exponent:
	tct	(pr,rl,ql)		" skip over string of digits
	desc9a	generic|0,al
	arg	digit_skip
	arg	work|fix_bin_generic
	lxl5	work|fix_bin_generic	" get number of digits
	tze	error_201			" no digits
	cmpx5	11,du			" check for max digits
	tpl	error_213
	dtb	(pr,rl,ql),(pr)		" convert exponent to binary
	desc9ns	generic|0,x5
	desc9a	work|imag.exponent.value,4

recognize.common_exponent:
	stbq	work|fix_bin_generic,40	" clear high byte digit count
	adq	work|fix_bin_generic	" count exponent digits
	sba	work|fix_bin_generic
	tmoz	recognize.no_more_input

"	we are scanning character after exponent field

	mvt	(pr,ql),(pr)		" translate terminator
	desc9a	generic|0,1
	desc9a	work|fix_bin_generic(1),1
	arg	translate_table
	ldx4	work|fix_bin_generic	" get character class
	anx4	=o777,du
	tra	*+1,4
	tra	error_203			" illegal
	tra	recognize.finish_up		" sign
	tra	error_204			" period
	tra	recognize.have_bin		" b
	tra	error_207			" d e
	tra	recognize.finish_up		" i
	tra	recognize.finish_up		" blank
	zero	0			" digit (can't happen)
	tra	error_207			" f

"     have "b" at end, validate bit input form of 0 or 1.

recognize.have_bin:
	ldx3	work|imag.integer.length	" get length of integer
	tze	recognize.bin.int		" nothing to check
	lxl4	work|imag.integer.index	" get index of integer
	tct	(pr,rl,x4)		" validate integer part
	desc9a	generic|0,x3
	arg	bit_test
	arg	work|fix_bin_generic	" dummy
	ttf	error_191			" invalid digit

recognize.bin.int:
	ldx3	work|imag.fraction.length	" get length of fraction
	tze	recognize.bin.frac		" nothing to check
	lxl4	work|imag.fraction.index	" get index of fraction
	tct	(pr,rl,x4)		" validate fraction part
	desc9a	generic|0,x3
	arg	bit_test
	arg	work|fix_bin_generic	" dummy
	ttf	error_191			" invalid digit

recognize.bin.frac:
	adq	1,dl			" account for "b"
	sba	1,dl
	eax7	-2,7			" base from dec to bin

"     Entry if input scan is done.  Now fixup terminator.

recognize.end_of_input:
	mvt	(pr,ql),(pr)		" translate terminator
	desc9a	generic|0,1
	desc9a	work|fix_bin_generic(1),1
	arg	translate_table
	ldx4	work|fix_bin_generic	" get character class
	anx4	=o777,du
	tra	recognize.finish_up

"     Entry if input exhausted.

recognize.no_more_input:
	ldx4	blank_class,du		" presume ended on blank
recognize.finish_up:			" accept terminator found
	ldx3	work|imag.integer.length	" for digit count
	adx3	work|imag.fraction.length
	stx7	work|imag.type		" save internal type code
	sxl4	work|imag.term		" save termination character
	ldx3	work|imag.integer.length	" form precision
	adx3	work|imag.fraction.length
	sxl3	work|imag.prec		" save in DL
	ldx4	work|imag.fraction.length
	stx4	work|imag.scale		" save scale in DU

"     Scaled fixed numbers should have the scale corrected for any exponent
"     which may have been specified.

	cmpx7	fixbin,du
	tze	recognize.fix_scale		" fixup scale from exp
	cmpx7	fixdec,du
	tnz	0,2			" not a fixed type

recognize.fix_scale:
	ldx4	work|imag.exponent.value	" load upper part
	tze	recognize.finish_scale	" okay if clear
	tpl	error_208			" big
	cmpx4	=o777777,du		" okay if -1
	tnz	error_209			" small

recognize.finish_scale:
	lxl4	work|imag.exponent.value	" get exponent
	sbx4	work|imag.scale		" -scale
	tmi	recognize.scale_pos		" negative scale
	cmpx4	-min_scale,du
	tpnz	error_209			" scale too small
	erx4	=o777777,du		" complement
	adx4	1,du			" add one
	stx4	work|imag.scale		" save scale
	tra	0,2			" return

recognize.scale_pos:
	erx4	=o777777,du		" complement
	adx4	1,du			" add one
	cmpx4	max_scale,du
	tpnz	error_208			" scale too big
	stx4	work|imag.scale		" save scale
	tra	0,2			" returnTable of translations for errors.  Only valid info will be 0.

"     This table is used to initially check the incoming string, and is a full
"     9-bit translation.  This permits the other tables to be much smaller and
"     only encompass the contiguous zero-area of this table.

error_table:
	oct	777777777777,777777777777	000 - 007
	oct	777777777777,777777777777	010 - 017
	oct	777777777777,777777777777	020 - 027
	oct	777777777777,777777777777	030 - 037
	oct	000777777777,777777777777	040 - 047 blank
	oct	777777777000,777000000777	050 - 057 + - .
	oct	000000000000,000000000000	060 - 061 01234567
	oct	000000777777,777777777777	070 - 077 89
	oct	777777000777,000000000777	100 - 107 B D E F
	oct	777000777777,777777777777	110 - 117 I
	oct	777777777777,777777777777	120 - 127
	oct	777777777777,777777777777	130 - 137
	oct	777777000777,000000000777	140 - 147 b d e f
	oct	777000777777,777777777777	150 - 157 i
	oct	777777777777,777777777777	160 - 167
	oct	777777777777,777777777777	170 - 177
	oct	777777777777,777777777777	200 - 207
	oct	777777777777,777777777777	210 - 217
	oct	777777777777,777777777777	220 - 227
	oct	777777777777,777777777777	230 - 237
	oct	777777777777,777777777777	240 - 247
	oct	777777777777,777777777777	250 - 257
	oct	777777777777,777777777777	260 - 267
	oct	777777777777,777777777777	270 - 277
	oct	777777777777,777777777777	300 - 307
	oct	777777777777,777777777777	310 - 317
	oct	777777777777,777777777777	320 - 327
	oct	777777777777,777777777777	330 - 337
	oct	777777777777,777777777777	340 - 347
	oct	777777777777,777777777777	350 - 357
	oct	777777777777,777777777777	360 - 367
	oct	777777777777,777777777777	370 - 377
	oct	777777777777,777777777777	400 - 407
	oct	777777777777,777777777777	410 - 417
	oct	777777777777,777777777777	420 - 427
	oct	777777777777,777777777777	430 - 437
	oct	777777777777,777777777777	440 - 447
	oct	777777777777,777777777777	450 - 457
	oct	777777777777,777777777777	460 - 467
	oct	777777777777,777777777777	470 - 477
	oct	777777777777,777777777777	500 - 507
	oct	777777777777,777777777777	510 - 517
	oct	777777777777,777777777777	520 - 527
	oct	777777777777,777777777777	530 - 537
	oct	777777777777,777777777777	540 - 547
	oct	777777777777,777777777777	550 - 557
	oct	777777777777,777777777777	560 - 567
	oct	777777777777,777777777777	570 - 577
	oct	777777777777,777777777777	600 - 607
	oct	777777777777,777777777777	610 - 617
	oct	777777777777,777777777777	620 - 627
	oct	777777777777,777777777777	630 - 637
	oct	777777777777,777777777777	640 - 647
	oct	777777777777,777777777777	650 - 657
	oct	777777777777,777777777777	660 - 667
	oct	777777777777,777777777777	670 - 677
	oct	777777777777,777777777777	700 - 707
	oct	777777777777,777777777777	710 - 717
	oct	777777777777,777777777777	720 - 727
	oct	777777777777,777777777777	730 - 737
	oct	777777777777,777777777777	740 - 747
	oct	777777777777,777777777777	750 - 757
	oct	777777777777,777777777777	760 - 767
	oct	777777777777,777777777777	770 - 777Source checking tables.

"	Table used to encode the input string:
"
"       encoding  characters
"	0	(Any other characters)
"	1	+ -
"	2	.
"	3	B b
"	4	D E d e
"	5	I i
"	6	SP
"	7	0 1 2 3 4 5 6 7 8 9
"	8	F f

translate_tab:
	oct	006000000000,000000000000	040 - 047
	oct	000000000001,000001002000	050 - 057
	oct	007007007007,007007007007	060 - 061
	oct	007007000000,000000000000	070 - 077
	oct	000000003000,004004010000	100 - 107
	oct	000005000000,000000000000	110 - 117
	oct	000000000000,000000000000	120 - 127
	oct	000000000000,000000000000	130 - 137
	oct	000000003000,004004010000	140 - 147
	oct	000005000000		150 - 153

	equ	translate_table,translate_tab-8

"     Table for finding contiguous digit streams.

digit_tab:
	oct	777777777777,777777777777	040 - 047
	oct	777777777777,777777777777	050 - 057
	oct	000000000000,000000000000	060 - 067
	oct	000000777777,777777777777	070 - 077
	oct	777777777777,777777777777	100 - 107
	oct	777777777777,777777777777	110 - 117
	oct	777777777777,777777777777	120 - 127
	oct	777777777777,777777777777	130 - 137
	oct	777777777777,777777777777	140 - 147
	oct	777777777777		150 - 153

	equ	digit_skip,digit_tab-8


"     Table for finding contiguous spaces.

blank_tab:
	oct	000777777777,777777777777	040 - 047
	oct	777777777777,777777777777	050 - 057
	oct	777777777777,777777777777	060 - 067
	oct	777777777777,777777777777	070 - 077
	oct	777777777777,777777777777	100 - 107
	oct	777777777777,777777777777	110 - 117
	oct	777777777777,777777777777	120 - 127
	oct	777777777777,777777777777	130 - 137
	oct	777777777777,777777777777	140 - 147
	oct	777777777777		150 - 153

	equ	blank_skip,blank_tab-8

"     Table used to validate bit input.  Very short since we know input is
"     pre-validated numeric digits.

bit_tab:
	oct	000000777777,777777777777	060 - 061 only 0 and 1
	oct	777777777777		070 - 073

	equ	bit_test,bit_tab-8-4


"     Table of translation values to check leading zeros.
"     True beginning is offset 40(8) characters above true table.

zero_tab:
	oct	777777777777,777777777777	040 - 047
	oct	777777777777,777777777777	050 - 057
	oct	000777777777,777777777777	060 - 067
	oct	777777777777,777777777777	070 - 077
	oct	777777777777,777777777777	100 - 107
	oct	777777777777,777777777777	110 - 117
	oct	777777777777,777777777777	120 - 127
	oct	777777777777,777777777777	130 - 137
	oct	777777777777,777777777777	140 - 147
	oct	777777777777		150 - 153

	equ	zero_skip,zero_tab-8
"Call GENERIC to target conversion
" Register conventions for source PUT routines.
" (all routines specified in the table below).  All registers named below,
" must be preserved by the conversion routine.
"
"	pr0	(reserved - pl1_operators_ ptr)
"	pr1	points to target.
"	pr3	points to source.
"	pr5	points to work area.
"	pr6	(reserved - stack_frame ptr)
"	pr7	points to return location in any_to_any_.
"	x0	return offset in user program.
"	x3	for decimal target routines is size of flt_dec_generic.
"	x5	0 if no round, 1 if round.
"	x6	target type.
"	x7	source type.

"	work|scales	stored scales (in upper halves)
"	work|precisions	stored precisions (in lower halves)
"
"     Decimal PUT routines require X3 as the size of the floating decimal
"     generic variable, including sign and hardware exponent.

"     In this calling sequence x6 is the target type and the GENERIC form
"     is correctly stored in the work area.  Store in target form and update
"     target pointer.



generic_to_target:
	lxl1	target_type_map,x6
	tra	0,x1			" call for target conversion
"GENERIC to Fixed Binary Target Conversion


"     GENERIC to Fixed Binary Target Conversion
"     Unsigned Cases and some Signed Cases

put_fix_bin_1uns:
	ldaq	work|fix_bin_generic	" size the value
	stq	target|0			" and put to target
	lxl2	work|target_precision	" check overflow
	lrl	0,x2
	tnz	size_error
	epp	target,target|1		" update target pointer
	tra	pr7|0			" return

put_fix_bin_1:
	ldaq	work|fix_bin_generic
	stq	target|0			" and store
	lxl2	work|target_precision	" check precision
	erx2	=o777777,du		" -precision-1
	lls	72,x2			" 72-precision-sign
	trc	size_error		" too big
	epp	target,target|1		" update target pointer
	tra	pr7|0			" return

put_fix_bin_2uns:
	ldaq	work|fix_bin_generic
	staq	target|0			" and store
	lxl2	work|target_precision	" check overflow
	lrl	0,x2
	tnz	size_error
	epp	target,target|2		" update target pointer
	tra	pr7|0			" return

put_fix_bin_2:
	ldaq	work|fix_bin_generic
	staq	target|0			" and store
	lxl2	work|target_precision	" check overflow
	erx2	=o777777,du		" -precision-1
	lls	72,x2			" 72-precision-sign
	trc	size_error		" too big
	epp	target,target|2		" update target pointer
	tra	pr7|0			" return

"     Calculate first bit position from: -(precision-72-1)-1

put_fix_bin_1uns_packed:
put_fix_bin_2uns_packed:
	lxl3	work|target_precision
	ldaq	work|fix_bin_generic
	lrl	0,x3			" check overflow
	tnz	size_error		" leftover bits
	eax2	-73,x3			" form start bit position
	erx2	=o777777,du
	csl	(pr,rl,x2),(pr,rl),bool(move)
	descb	work|fix_bin_generic,x3
	descb	target|0,x3
	abd	target|0,x3		" update target pointer
	tra	pr7|0			" return

"     Packed Signed Cases

"     Calculate first bit position from: -((precision+1)-72-1)-1

put_fix_bin_1_packed:
put_fix_bin_2_packed:
	lxl3	work|target_precision
	eax3	1,x3			" account for sign
	ldaq	work|fix_bin_generic
	eax2	-73,x3			" form start bit position
	erx2	=o777777,du
	lls	0,x2			" check overflow
	trc	size_error		" sign change due to shift
	csl	(pr,rl,x2),(pr,rl),bool(move)
	descb	work|fix_bin_generic,x3
	descb	target|0,x3
	abd	target|0,x3		" update target pointer
	tra	pr7|0			" return
"GENERIC to Float Binary Target Conversion

"     Rounding is done to the desired precision.

put_flt_bin_1:
	ldx2	27,du			" round precision
	tsx1	load_rounded_flt_bin
	fst	target|0			" store away
	epp	target,target|1		" update target pointer
	tra	pr7|0			" return


put_flt_bin_2:			" target store double precision
	ldx2	63,du			" round precision
	tsx1	load_rounded_flt_bin
	dfst	target|0			" store away
	epp	target,target|2		" update target pointer
	tra	pr7|0			" return


put_flt_bin_1_packed:
put_flt_bin_2_packed:
	lxl2	work|target_precision	" get round precision
	tsx1	load_rounded_flt_bin
	dfst	work|flt_bin_generic

	eax2	8+1,x2			" account for sign and exp
	csl	(pr,rl),(pr,rl),bool(move)	" move to target
	descb	work|flt_bin_generic,x2
	descb	target|0,x2
	abd	target|0,x2		" update target pointer
	tra	pr7|0			" return



"     Output float binary generic form.

put_flt_bin_gen:
	lda	work|flt_bin_generic_exp	" move exponent
	sta	target|2
	stz	work|flt_bin_generic_exp	" clear for load_round
	ldaq	work|flt_bin_generic	" check for zero
	tze	put_flt_bin_gen.zero

	ldx2	63,du			" round to 63
	tsx1	load_rounded_flt_bin
	ste	work|flt_bin_generic_exp
	lde	0,du			" clear exponent
	dfst	target|0			" move mantissa
	lda	work|flt_bin_generic_exp
	ars	36-8
	asa	target|2
	epp	target,target|4		" update target pointer
	tra	pr7|0

put_flt_bin_gen.zero:
	stz	target|0			" zero output
	stz	target|1
	stz	target|2
	epp	target,target|4		" update target pointer
	tra	pr7|0
"     Load the float bin generic to a true float bin and round to the
"     precision specified.

"     Called with:
"	x1 = return address.
"	x2 = precision to round to.

load_rounded_flt_bin:
	lda	work|flt_bin_generic_exp
	als	36-8			" make short exponent
	trc	flt_range_error		" won't fit
	sta	work|flt_bin_generic_exp
	ldaq	work|flt_bin_generic	" get mantissa
	lde	work|flt_bin_generic_exp	" get exponent
	fno				" find 0.0
	tze	0,x1			" cannot round
	cmpx5	0,du
	tze	0,x1			" no round
	
	stx2	work|flt_bin_generic_exp	" two word mask entries
	eax3	0,x2
	adx3	work|flt_bin_generic_exp
	cmpa	0,du
	tmi	load_rounded_flt_bin.negative
	adaq	mask_table+2,x3		" round

"     Normalize to recover any possible overflow situation.

	fno
	ldi	mask_faults,dl		" clear possible overflow
	tra	0,x1

load_rounded_flt_bin.negative:
	fneg
	adaq	mask_table+2,x3		" round
	fno				" fix overflow
	staq	work|fix_bin_generic	" temp save
	ldi	mask_faults,dl		" clear possible overflow
	lda	=o400000,du		" generate mask
	ldq	=0,dl
	lrs	0,x2			" mask for precision+sign
	anaq	work|fix_bin_generic
	fneg
	tra	0,x1
"GENERIC to Float Hexadecimal Target Conversion

"     Here we must convert the generic flt_bin value to hexadecimal and
"     output it to the target.  We will do a round here, since hex round is
"     different that normal binary round and therefore must be an additional
"     treatment.

put_flt_hex_1:
	ldx2	27,du			" do single prec round
	tsx1	convert_flt_bin_to_flt_hex	" common conversion
	fst	target|0
	epp	target,target|1		" update target pointer
	tra	pr7|0			" return


put_flt_hex_2:
	ldx2	63,du		" do double prec round
	tsx1	convert_flt_bin_to_flt_hex	" common conversion
	dfst	target|0
	epp	target,target|2		" update target pointer
	tra	pr7|0			" return


put_flt_hex_1_packed:
put_flt_hex_2_packed:
	lxl2	work|target_precision
	tsx1	convert_flt_bin_to_flt_hex	" common conversion
	dfst	work|flt_bin_generic
	eax2	8+1,x2			" account for sign and exp
	csl	(pr,rl),(pr,rl),bool(move)
	descb	work|flt_bin_generic,x2
	descb	target|0,x2
	abd	target|0,x2		" update target pointer
	tra	pr7|0
"Convert float bin generic to rounded float hexadecimal.

"     Common conversion routine since there are four calls to convert bin to
"     hex.  Converts in place in the flt_bin_generic.  Rounding is done if
"     requested by X5^=0.  X2 has rounding precision.
"     Result after round is left normalized.
"
"     Called by:
"	tsx1	convert_flt_bin_to_flt_hex
"
"     Leaves double float hex value in EAQ.

convert_flt_bin_to_flt_hex:
	lca	work|flt_bin_generic_exp	" form shift in x3
	ana	=3,dl			" mask for count 0-3
	eax3	0,al
	lda	work|flt_bin_generic_exp	" form hex exp
	ada	=3,dl			" correct exp ceiling
	ars	2			" divide by 4
	als	36-8			" shift to check range
	trc	flt_range_error		" too big
	sta	work|flt_bin_generic_exp
	ldaq	work|flt_bin_generic	" get value
	tze	c_flt_bin_to_flt_hex.zero	" get normalized zero
	lrs	0,3			" hex normalize
	lde	work|flt_bin_generic_exp	" form full hex with exp

"     Rounding is done according to PL/I rules.  Round up for positive, round
"     down for negative.  Result is left normalized.

	cmpx5	0,du			" see if rounding
	tze	0,x1			" none - return
	stx2	work|flt_bin_generic_exp	" 2 word mask entries
	eax3	0,x2
	adx3	work|flt_bin_generic_exp
	canaq	mask_table+2,x3		" if zero bits, then won't round
	tze	0,x1
	cmpa	=0,dl			" determine sign of mantissa
	tmi	c_flt_bin_to_flt_hex.neg

	adaq	mask_table+2,x3		" round AQ
	tov	c_flt_bin_to_flt_hex.norm_pos	" normalize needed
	tra	0,x1			" return to put routine

c_flt_bin_to_flt_hex.zero:
	fld	=0.0,du			" load normalized 0.0
	tra	0,x1			" return to put routine

c_flt_bin_to_flt_hex.neg:			" round down
	negl
	adaq	mask_table+2,x3		" 1 bit higher
	tov	c_flt_bin_to_flt_hex.norm_neg	" normalize needed
	tra	c_flt_bin_to_flt_hex.normal

"     Overflow bit indicates sign changed on positive mantissa.  Thus the
"     Logical Right shift recovers the sign bit as the carry.

c_flt_bin_to_flt_hex.norm_neg:		" shift right 4 and gen sign
	lrl	4
	ade	=1b25,du			" adjust exponent
	teo	flt_range_error		" too big rounded
c_flt_bin_to_flt_hex.normal:
	staq	work|fix_bin_generic	" temp save
	lda	=o400000,du		" generate mask
	ldq	=0,dl
	lrs	0,x2			" mask for precision+sign
	anaq	work|fix_bin_generic
	negl
	tra	0,x1			" return to put routine

c_flt_bin_to_flt_hex.norm_pos:		" shift right 4 and inc exp
	lrl	4
	ade	=1b25,du
	teo	flt_range_error		" too big rounded
	tra	0,x1			" return to put routine
"GENERIC to Float Decimal 9 Target Conversion
"     On entry X3 holds the length of the floating decimal number, including
"     sign and exponent byte.

put_flt_dec_9:
put_flt_dec_9_packed:
	lxl2	work|target_precision
	eax2	2,x2			" form true target length
	lda	work|flt_dec_generic_exp	" range the exponent
	als	36-8
	trc	decimal_range_error
	mlr	(pr),(pr,x3)		" move to generic
	desc9a	work|flt_dec_generic_exp(3),1
	desc9a	work|flt_dec_generic-1(3),1
	xec	mvn.pr_rl.pr_rl,x5		" move and round mantissa
	desc9fl	work|flt_dec_generic,x3
	desc9fl	target|0,x2
	teo	decimal_overflow		" blew up
	teu	decimal_underflow		" blew up
	a9bd	target|0,x2		" update target pointer
	tra	pr7|0

put_flt_dec_ext:				" Float Decimal Extended Case
put_flt_dec_ext_packed:
	lxl2	work|target_precision
	eax2	2,x2			" form true target length
	sbx3	1,du			" form lead sign source len
	xec	mvn.pr_rl.pr_rl,x5		" move and round mantissa
	desc9ls	work|flt_dec_generic,x3
	desc9fl	target|0,x2
	tze	put_flt_dec_ext.zero_exp

"     Update the true exponent, account for target exponent changes due to
"     rounding and truncation/expansion of the mantissa.

	mlr	(pr,x2),(pr)
	desc9a	target|-1(3),1
	desc9a	work|flt_dec_generic,1	" RE-USE mantissa
	lda	work|flt_dec_generic	" sign extend exp
	als	1
	ars	36-8
	ada	work|flt_dec_generic_exp	" integrate with big exp
	als	36-9			" use 9-bit exponent
	trc	decimal_range_error		" test after exp is valid
	sta	work|flt_dec_generic_exp
	mlr	(pr),(pr,x2)		" implant exponent
	desc9a	work|flt_dec_generic_exp,1
	desc9a	target|-1(3),1
put_flt_dec_ext.zero_exp:			" take exponent planted
	a9bd	target|0,x2		" update target pointer
	tra	pr7|0

"     Float Decimal 9-bit generic Case.  Has leading 36-bit exponent.

put_flt_dec_gen:
	lxl2	work|target_precision
	adx2	2,du			" account for sign and exp
	sbx3	1,du			" form lead sign source len
	xec	mvn.pr_rl.pr_rl,x5		" move and round
	desc9ls	work|flt_dec_generic,x3	" collapse/expand to target
	desc9fl	work|flt_dec_generic,x2
	tnz	put_flt_dec_gen.non_zero
	stz	work|flt_dec_generic_exp	" zero exponent
put_flt_dec_gen.non_zero:
	mlr	(pr,x2),(pr)		" update exponent for length
	desc9a	work|flt_dec_generic-1(3),1
	desc9a	work|fix_bin_generic,1
	sbx2	1,du			" correct for no exponent
	mlr	(pr,rl),(pr,rl)		" move mantissa to target
	desc9a	work|flt_dec_generic,x2
	desc9a	target|1,x2
	lda	work|fix_bin_generic	" sign extend corrector
	als	1
	ars	36-8
	ada	work|flt_dec_generic_exp	" get exponent
	sta	target|0
	eax2	3,x2			" set round of mantissa
	a9bd	target|0,x2		" increment and round
	adwp	target,1,du
	tra	pr7|0			" return to callGENERIC to Float Decimal 4 Target Conversion

"     On entry X3 holds the length of the floating decimal number, including
"     sign and exponent byte.  The hardware exponent byte (8-bit) is 0.

put_flt_dec_4:
put_flt_dec_4_packed:
	lxl2	work|target_precision
	eax2	3,x2			" form true target length
	lda	work|flt_dec_generic_exp	" range the exponent
	als	36-8
	trc	decimal_range_error
	mlr	(pr),(pr,x3)		" move to generic
	desc9a	work|flt_dec_generic_exp(3),1
	desc9a	work|flt_dec_generic-1(3),1
	xec	mvn.pr_rl.pr_rl,x5		" move and round mantissa
	desc9fl	work|flt_dec_generic,x3
	desc4fl	target|0,x2
	teo	decimal_overflow		" blew up
	teu	decimal_overflow		" blew up
	eax2	1,x2			" byte align target
	anx2	=o777776,du
	a4bd	target|0,x2		" update target pointer
	tra	pr7|0
"GENERIC to Fixed Decimal (9-bit) Target Conversion

"     For these conversions X3 holds the length of the float decimal number,
"     including the exponent and sign.
"
"     Fixed decimal target capacity depends upon scale and precision.  
"     We preset the floating decimal exponent to account for the fixed decimal
"     scale factor then do the move.  If we overflow the move, then a
"     size is generated.

"     9-bit Leading Sign Case

put_fix_dec_9ls:
put_fix_dec_9ls_packed:
	tsx2	load_flt_dec.target		" load for conversion
	eax1	1,x1			" count in sign
	xec	mvn.pr_rl.pr_rl,x5
	desc9fl	work|flt_dec_generic,x3
	desc9ls	target|0,x1
	tov	size_error		" did not fit
	a9bd	target|0,x1		" update target pointer
	tra	pr7|0


"     9-bit Un-signed Case

put_fix_dec_9uns:
put_fix_dec_9uns_packed:
	tsx2	load_flt_dec.target		" load for conversion
	cmpc	(pr),(),fill(minus_sign)	" see if negative
	desc9a	work|flt_dec_generic,1
	zero
	tze	size_error		" cannot put -ve in uns
	xec	mvn.pr_rl.pr_rl,x5
	desc9fl	work|flt_dec_generic,x3
	desc9ns	target|0,x1
	tov	size_error		" did not fit
	a9bd	target|0,x1		" update target pointer
	tra	pr7|0



"     9-bit Trailing Sign Case

put_fix_dec_9ts:
put_fix_dec_9ts_packed:
	tsx2	load_flt_dec.target		" load for conversion

	eax1	1,x1			" length of signed result
	xec	mvn.pr_rl.pr_rl,x5
	desc9fl	work|flt_dec_generic,x3
	desc9ts	target|0,x1
	tov	size_error		" did not fit
	a9bd	target|0,x1		" update target pointer
	tra	pr7|0
"GENERIC to Fixed Decimal Target Conversion (overpunched sign 9-bit)


"     Conversion of leading sign overpunched value is done by making the float
"     decimal generic a positive, and then moving unsigned to the high part of
"     the fixed_decimal value, then moving the overpunched sign to the leading
"     character position.
"
"	NOTE.  This uses flt_dec_generic_exp to store the original sign.
"	       This uses fix_bin_generic to store the digit/sign index.

put_fix_dec_9ls_ovrp:
put_fix_dec_9ls_ovrp_packed:
	tsx2	load_flt_dec.target		" load for conversion
	mlr	(pr),(pr)			" save true sign
	desc9a	work|flt_dec_generic,1
	desc9a	work|flt_dec_generic_exp,1
	mlr	(),(pr),fill(plus_sign)	" make flt_dec positive
	zero
	desc9a	work|flt_dec_generic,1

	xec	mvn.pr_rl.pr_rl,x5
	desc9fl	work|flt_dec_generic,x3
	desc9ns	target|0,x1
	tov	size_error		" did not fit

"     Determine the leading digit and the sign.

	scm	(),(pr),mask(000)
	desc9a	overpunch_9_digits,10
	desc9a	target|0,1
	arg	work|fix_bin_generic	" holds value
	lda	work|fix_bin_generic
	cmpc	(pr),(),fill(minus_sign)	" determine sign
	desc9a	work|flt_dec_generic_exp,1
	zero
	tnz	put_fix_dec_9ls_ovrp.pos	" positive, digit as index
	ada	=10,dl			" increment index to negative
put_fix_dec_9ls_ovrp.pos:
	mlr	(al),(pr)			" move in overpunch sign
	desc9a	overpunch_9_source,1
	desc9a	target|0,1
	a9bd	target|0,x1		" update target pointer
	tra	pr7|0
"     Conversion of trailing sign overpunched value is done by making the float
"     decimal generic a positive, and then moving unsigned to the high part of
"     the fixed_decimal value, then moving the overpunched sign to the trailing
"     character position.
"
"	NOTE.  This uses flt_dec_generic_exp to store the original sign.
"	       This uses fix_bin_generic to store the digit/sign index.

put_fix_dec_9ts_ovrp:
put_fix_dec_9ts_ovrp_packed:
	tsx2	load_flt_dec.target		" load for conversion
	mlr	(pr),(pr)			" save true sign
	desc9a	work|flt_dec_generic,1
	desc9a	work|flt_dec_generic_exp,1
	mlr	(),(pr),fill(plus_sign)	" make flt_dec positive
	zero
	desc9a	work|flt_dec_generic,1

	xec	mvn.pr_rl.pr_rl,x5
	desc9fl	work|flt_dec_generic,x3
	desc9ns	target|0,x1
	tov	size_error		" did not fit

"     Determine the trailing digit and the sign.

	scm	(),(pr,x1),mask(000)
	desc9a	overpunch_9_digits,10
	desc9a	target|-1(3),1
	arg	work|fix_bin_generic	" holds value
	lda	work|fix_bin_generic
	cmpc	(pr),(),fill(minus_sign)	" determine sign
	desc9a	work|flt_dec_generic_exp,1
	zero
	tnz	put_fix_dec_9ts_ovrp.pos	" positive, digit as index
	ada	=10,dl			" increment index to negative
put_fix_dec_9ts_ovrp.pos:
	mlr	(al),(pr,x1)		" move in overpunch sign
	desc9a	overpunch_9_source,1
	desc9a	target|-1(3),1
	a9bd	target|0,x1		" update target pointer
	tra	pr7|0
"GENERIC to Fixed Decimal (4-bit) Target Conversion

"     For these conversions X3 holds the length of the float decimal number,
"     including the exponent and sign.
"
"     Fixed decimal target capacity depends upon scale and precision.  
"     We preset the floating decimal exponent to account for the fixed decimal
"     scale factor then do the move.  If we overflow the move, then a
"     size is generated.

"     4-bit Leading Sign Case

put_fix_dec_4ls:
put_fix_dec_4ls_packed:
	tsx2	load_flt_dec.target		" load for conversion
	eax1	1,x1			" count in sign
	xec	mvn.pr_rl.pr_rl,x5
	desc9fl	work|flt_dec_generic,x3
	desc4ls	target|0,x1
	tov	size_error		" did not fit
	eax1	1,x1			" byte align target
	anx1	=o777776,du
	a4bd	target|0,x1		" update target pointer
	tra	pr7|0

"     4-bit Un-signed Case

put_fix_dec_4uns:
put_fix_dec_4uns_packed:
	tsx2	load_flt_dec.target		" load for conversion
	cmpc	(pr),(),fill(minus_sign)	" see if negative
	desc9a	work|flt_dec_generic,1
	zero
	tze	size_error		" cannot put -ve in uns
	xec	mvn.pr_rl.pr_rl,x5
	desc9fl	work|flt_dec_generic,x3
	desc4ns	target|0,x1
	tov	size_error		" did not fit
	eax1	1,x1			" byte align target
	anx1	=o777776,du
	a4bd	target|0,x1		" update target pointer
	tra	pr7|0

"     4-bit Trailing Sign Case


put_fix_dec_4ts:
put_fix_dec_4ts_packed:
	tsx2	load_flt_dec.target		" load for conversion
	eax1	1,x1			" account for sign
	xec	mvn.pr_rl.pr_rl,x5
	desc9fl	work|flt_dec_generic,x3
	desc4ts	target|0,x1
	tov	size_error		" did not fit
	eax1	1,x1			" byte align target
	anx1	=o777776,du
	a4bd	target|0,x1		" update target pointer
	tra	pr7|0
"Load and start conversion of flt_dec_generic to fixed decimal target


"     Load float decimal information and setup precision of target.
"     Precurser of most float to fixed target routines.
"
"     Calling sequence:
"	tsx2	load_flt_dec.target
"
"     Returns:
"	1. True scaled exponent for floating decimal number in the hardware
"	   exponent field of the flt_dec_generic variable.  This has the
"	   exponent adjusted for the scale of the target fixed decimal.
"	2. X1 holds to target precision (does not include sign).
"	3. X3 holds length of flt_dec_generic, including sign and exponent.

load_flt_dec.target:
	lda	work|target_scale		" setup scale offset
	ars	18
	ada	work|flt_dec_generic_exp	" get exponent range
	sta	work|flt_dec_generic_exp	" save for testing
	als	36-8			" fit to normal 8-bit
	trc	load_flt_dec.range		" exponent won't fit
	arl	1
load_flt_dec.range_continue:			" re-enter with max neg exp
	sta	work|flt_dec_generic_exp
	mlr	(pr),(pr,x3)		" plant true scaled exp
	desc9a	work|flt_dec_generic_exp,1
	desc9a	work|flt_dec_generic-1(3),1	" as hardware exponent
	lxl1	work|target_precision
	tra	0,x2

"     Exponent won't fit in 7-bits, see if too big or too small.

load_flt_dec.range:
	eax1	-1,x3			" size less exponent
	cmpn	(pr,rl),()		" Is number zero?
	desc9ls	work|flt_dec_generic,x1	" If so good by definition
	desc9ls	char_zero,2
	tze	load_flt_dec.range.fix	" No:  edit number with mvne
	lda	work|flt_dec_generic_exp	" get exponent
	tpl	size_error		" it was too big
load_flt_dec.range.fix:
	lda	=o400000,du		" force max neg exponent
	tra	load_flt_dec.range_continue	
"GENERIC to Bit Target Conversion

"     Bit to target conversion.  Expects pointer to bit string in generic and
"     length in X3.
"
"     For varying bit, the target pointer is one beyond the length word,
"     so we negative index to the length word.
"

"     NOTE.  In all cases we return immediately to the user after unmasking.

put_varying_bit:
	eaa	0,x3			" get length of bits
	ars	18			" position to DL
	sta	target|-1			" save varying length
	lxl2	work|target_precision
	stx2	work|target_precision
	cmpx3	work|target_precision	" take min (length, prec)
	tmoz	put_bit			" have min
	lxl2	work|target_precision	" get min
	sxl2	target|-1			" save target length
	tra	put_bit.common.aligned	" copy all

put_bit:					" determine max copy length
	lxl2	work|target_precision

put_bit.common.aligned:			" Remove padded reference
	stz	target|0			" pre-clear 1st word
	cmpx2	36,du
	tmoz	put_bit.common		" if one word or less
	stz	target|1			" pre_clear 2nd word
	tra	put_bit.common

put_bit_packed:
	lxl2	work|target_precision
put_bit.common:
	csl	(pr,rl),(pr,rl),bool(move),fill(0)
	descb	generic|0,x3
	descb	target|0,x2
	tra	unmask_exit		" return to user
"GENERIC to Character Target Conversion

"     Character target routine.  Expects pointer to source in generic and
"     length in X3.  These routines return directly to the user.

put_varying_char:
	lda	=o777777,dl		" mask for string length
	ansa	work|target_precision
	eaa	0,x3
	ars	18
	cmpa	work|target_precision	" limit to length of target
	tmoz	put_varying_char.in_range
	lda	work|target_precision
put_varying_char.in_range:
	sta	target|-1			" save string length
	tra	put_char.common		" move and fill all

"     Put simple fixed length character string.

put_char:
put_char_packed:
	lda	work|target_precision
	ana	=o777777,dl		" mask for just length

"     Copy string to target, filling with spaces.

put_char.common:
	mlr	(pr,rl),(pr,rl),fill(blank)	" move to target
	desc9a	generic|0,x3
	desc9a	target|0,al
	tra	unmask_exit		" return direct to user
"ERROR BRANCHES

"     The following branches all signal the conversion
"     condition. On entry, the Q contains the current
"     index into the string being converted.

"     oncodes are documented and determined according to the ASCII segment
"     >sss>oncode_messages_

error_191:
	lda	191,dl		" Bin digit not 0 or 1
	tra	error_xxx

error_201:
	lda	201,dl		" no digit after d/e/f

error_xxx:
	adq	1,dl			" get pl1 index
	stz	work|source_string_length	" restore string length
	lxl2	work|original_source_length
	sxl2	work|source_string_length
	tsx1	conversion_error
	tra	char_to_arithmetic_restart

error_202:
	lda	202,dl		" no digit in a numeric field
	tra	error_xxx

error_203:
	lda	203,dl		" illegal char after numeric field
	tra	error_xxx

error_204:
	lda	204,dl		" too many decimal points
	tra	error_xxx

error_205:
	lda	256,dl		" force to 256 character limit
	sta	work|original_source_length 	" save for conversion error
	lda	205,dl		" >256 chars to convert
	tra	error_xxx

error_207:
	lda	207,dl		" too many exponents
	tra	error_xxx

error_208:
	lda	208,dl		" scale factor too big
	tra	error_xxx

error_209:
	lda	209,dl		" scale factor too small
	tra	error_xxx

error_211:
	lda	211,dl		" wrong character after "i"
	tra	error_xxx

error_213:
	lda	213,dl		" too many digits in exponent
	tra	error_xxx

error_214:
	lda	214,dl		" no digits in mantissa
	tra	error_xxx

error_218:
	lda	218,dl		" prec > dec(59) or bin(71)
	tra	error_xxx

error_219:
	lda	219,dl		" 2nd half of complex number must be imaginary
	tra	error_xxx
"SIGNALLING SUBROUTINES
"
"	subroutine to signal conversion conditions
"	calling sequence is
"		epp	generic,character_string
"		lda	oncode
"		ldq	onchar_index
"		tsx1	conversion_error
"
"     Presumes work|source_string_length is length of string of error
"     Presumes availability of work|original_source pointer area.
"     work|source_string_length is fixed bin (35) length.
"
"     When returns, source pointer is changed to point to onsource area
"     of stack extension, to permit user to change it.
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

conversion_error:
	spri7	work|error_return		" save return ptr
	epbp7	sp|0			" so we can get ptr to stack base again
	sxl0	sp|stack_frame.operator_ret_ptr  " save x0 for default_error_handler_
	szn	work|original_source	" already extended?
	tnz	have_extension		" yes - use it
	epp4	sb|stack_header.stack_end_ptr,*
	epp4	pr4|error_extension		" extend stack
	spri4	sb|stack_header.stack_end_ptr
	spri4	sp|stack_frame.next_sp
	epp4	pr4|-error_extension
	lxl0	work|source_string_length	" make copy of source for signalling
	mlr	(pr,rl),(pr,rl)
	desc9a	generic|0,x0
	desc9a	pr4|onsource,x0
	sprp4	work|original_source	" remember ptr to extension
	epp	generic,pr4|onsource	" change onsource ptr
have_extension:
	cmpq	work|source_string_length	" make sure onindex is in range
	tmoz	conversion_error.in_range
	ldq	work|source_string_length

conversion_error.in_range:
	lprp4	work|original_source	" get ptr to old extension
	spri	pr4|save_ptrs		" now save ptrs
	sreg	pr4|save_regs		" and registers

	epp0	null			" build arg list
	spri0	pr4|arglist+2		" ARG 1 - null
	epp0	my_name
	spri0	pr4|arglist+4		" ARG 2 - ptr to "any_to_any_"
	epp0	pr4|oncode
	spri0	pr4|arglist+6		" ARG 3 - oncode
	epp0	pr4|onsource_ptr
	spri0	pr4|arglist+8		" ARG 4 - ptr to source string
	epp0	=1
	spri0	pr4|arglist+10		" ARG 5 - start character (1)
	epp0	work|source_string_length
	spri0	pr4|arglist+12		" ARG 6 - len of source string
	epp0	pr4|onchar_index
	spri0	pr4|arglist+14		" ARG 7 - index of char error

	epp0	pointer_desc		" fill in descriptors
	spri0	pr4|arglist+16		" ARG 1 - pointer
	spri0	pr4|arglist+22		" ARG 4 - pointer
	epp0	my_name_desc
	spri0	pr4|arglist+18		" ARG 2 - character (11) packed
	epp0	fixbin_15_desc
	spri0	pr4|arglist+20		" ARG 3 - fixed bin (15)
	spri0	pr4|arglist+24		" ARG 5 - fixed bin (15)
	spri0	pr4|arglist+26		" ARG 6 - fixed bin (15)
	spri0	pr4|arglist+28		" ARG 7 - fixed bin (15)
	ldaq	conversion_arg_header	" 7 arguments, 7 descriptors
	eax0	ce_link			" get routine to call
	epp2	pr4|0			" use PR2 for rest

call_it:
	ora	=4,dl
	staq	pr2|arglist		" comple arglist
	epaq	*			" get our linkage ptr
	lprplp	sb|stack_header.lot_ptr,*au
	epp0	pr2|arglist
	stcd	sp|stack_frame.return_ptr
	callsp	lp|0,0*			" call error routine
"
	epbp2	sp|tbp,*			" restore original value
	spri2	sp|stack_frame.return_ptr	" of return pointer
	epp2	sb|stack_header.stack_end_ptr,* " get ptr to extension
	epp2	pr2|-error_extension
	lreg	pr2|save_regs
	lpri	pr2|save_ptrs		" restores generic ptr
	epp7	work|error_return,*
	lxl0	sp|stack_frame.operator_ret_ptr " restore x0
	stz	sp|stack_frame.operator_ret_ptr " and clear switch
	tra	0,1
"
"	signal size error
"
size_error:
	lda	=703,dl			" size condition raised
	ldq	=4,dl
	epp4	size_name
	tsx1	signal_from_ops
	tra	7|0


"     Floating point range errors.

flt_range_error:
	lda	work|flt_bin_generic_exp	" see if positive or negative
	tmi	underflow_error		" underflow
"	tra	overflow_error		" overflow

"	signal overflow error
"
overflow_error:
	lda	=705,dl			" overflow condition raised
	ldq	=8,dl
	epp4	overflow_name
	tsx1	signal_from_ops
	tra	store_float_bin_zero
"
"	signal underflow condition
"
underflow_error:
	lda	=706,dl			" underflow condition raised
	ldq	=9,dl
	epp4	underflow_name
	tsx1	signal_from_ops
store_float_bin_zero:			" zero float bin and finish
	stz	work|flt_bin_generic_exp
	stz	work|flt_bin_generic
	stz	work|flt_bin_generic+1
	tra	flt_bin_generic_conversion



"     Decimal fixed/float range errors.

decimal_range_error:
	lda	work|flt_dec_generic_exp	" see if positive or negative
	tmi	decimal_underflow		" underflow
"	tra	decimal_overflow		" overflow

"
"	signal overflow for conversion to decimal
"
decimal_overflow:
	lda	=705,dl			" overflow condition raised
	ldq	=8,dl
	epp4	overflow_name
	tsx1	signal_from_ops
	tra	force_zero
"
"	signal underflow for conversion to decimal
"
decimal_underflow:
	lda	=706,dl		underflow condition raised
	ldq	=9,dl
	epp4	underflow_name
	tsx1	signal_from_ops
force_zero:				" Zero GENERIC float decimal
	ldx3	default_flt_dec_p,du	" length of decimal
	mvn	(),(pr,rl)
	desc9ls	dec_zero,2
	desc9fl	work|flt_dec_generic,x3
	stz	work|flt_dec_generic_exp
	tra	flt_dec_generic_conversion

"
"	signal error condition for unimplemented conversion
"
get_ERROR:
get_ERROR_packed:
put_ERROR:
put_ERROR_packed:

"     Bad data types.

get_varying_char_packed:
get_varying_bit_packed:
put_varying_char_packed:
put_varying_bit_packed:
get_flt_dec_gen_packed:
put_flt_dec_gen_packed:
get_flt_bin_gen_packed:
put_flt_bin_gen_packed:

error_bad_type:
	lda	=415,dl		attempted invalid or unimp conversion
	ldq	=5,dl		= length ("error")
	epp4	error_name
	tsx1	signal_from_ops	do it
	tra	pr7|0		standard action is to ignore conversionSignal an error condition from the operators.

"     All conditions other than conversion error come through here.
"     We do an error extension of the stack to create an argument/descriptor
"     area for the call.  Descriptors are filled in to make trace-stack
"     cleaner.

signal_from_ops:
	sxl0	sp|stack_frame.operator_ret_ptr  " x0 for default_error_handler
	spri7	work|error_return

"     Error extension of stack for ERROR_EXTENSION words.

	epbp7	sp|0			" get stack header
	epp2	sb|stack_header.stack_end_ptr,*
	epp2	pr2|error_extension
	spri2	sb|stack_header.stack_end_ptr
	spri2	sp|stack_frame.next_sp
	epp2	pr2|-error_extension	" save end of stack ptr

"     Save all registers and pick up arguments from them.

	spri	pr2|save_ptrs
	sreg	pr2|save_regs

"     Create argument list.

	spri4	pr2|arglist+2		" ARG 1 - ptr to condition name
	epp0	pr2|name_length
	spri0	pr2|arglist+4		" ARG 2 - len of condition name
	epp0	sp|tbp,*0
	epp0	0|-1
	spri0	pr2|call_ptr
	epp0	pr2|call_ptr
	spri0	pr2|arglist+6		" ARG 3 - ptr to caller
	epp0	pr2|oncode
	spri0	pr2|arglist+8		" ARG 4 - oncode value
	epp0	null
	spri0	pr2|arglist+10		" ARG 5 - null

"     Build descriptors.

	adq	string_desc		" form character descriptor
	stq	pr2|arglist+24		" store away
	epp0	pr2|arglist+24
	spri0	pr2|arglist+12		" ARG 1 - character (n)
	epp0	fixbin_17_desc
	spri0	pr2|arglist+14		" ARG 2 - condition string len
	epp0	fixbin_35_desc
	spri0	pr2|arglist+18		" ARG 4 - oncode
	epp0	pointer_desc
	spri0	pr2|arglist+16		" ARG 3 - pointer
	spri0	pr2|arglist+20		" ARG 5 - pointer
	ldaq	ops_arg_header		" 5 arguments, 5 descriptors
	eax0	fo_link			" get routine to call
	tra	call_it
"Error call tables and data.

"     Various constants required for setting up pointers, descriptors and
"     character strings for error calls.

	even
null:	its	-1,1,n
ops_arg_header:
	vfd	17/5,1/0,18/0		" 5 args, call type filled later
	vfd	17/5,19/0			" 5 descriptors
conversion_arg_header:
	vfd	17/7,1/0,18/0		" 7 args, call type filled later
	vfd	17/7,19/0			" 7 descriptors
"
my_name:	aci	"any_to_any_"
"
fixbin_15_desc:
	oct	404000000017		" fix bin 15
fixbin_17_desc:
	oct	404000000021		" fix bin 17
fixbin_35_desc:
	oct	404000000043		" fix bin 35
pointer_desc:
	oct	464000000000		" pointer
my_name_desc:
	oct	526000000013		" char 11
string_desc:
	oct	526000000000		" string (*) desc len=0
"
size_name:
	aci	"size"
overflow_name:
	aci	"overflow"
underflow_name:
	aci	"underflow"
error_name:
	aci	"error"
"
	link	ce_link,pl1_signal_conversion_$pl1_signal_conversion_
	link	fo_link,<pl1_signal_from_ops_>|[pl1_signal_from_ops_]
"Two table for fixed binary conversion.


	include	 two_table
"Table of mask constants for precision masking and generation.

	even			" table must be double aligned

mask_table:
	oct	377777777777,777777777777
	oct	177777777777,777777777777
	oct	077777777777,777777777777
	oct	037777777777,777777777777
	oct	017777777777,777777777777
	oct	007777777777,777777777777
	oct	003777777777,777777777777
	oct	001777777777,777777777777
	oct	000777777777,777777777777
	oct	000377777777,777777777777
	oct	000177777777,777777777777
	oct	000077777777,777777777777
	oct	000037777777,777777777777
	oct	000017777777,777777777777
	oct	000007777777,777777777777
	oct	000003777777,777777777777
	oct	000001777777,777777777777
	oct	000000777777,777777777777
	oct	000000377777,777777777777
	oct	000000177777,777777777777
	oct	000000077777,777777777777
	oct	000000037777,777777777777
	oct	000000017777,777777777777
	oct	000000007777,777777777777
	oct	000000003777,777777777777
	oct	000000001777,777777777777
	oct	000000000777,777777777777
	oct	000000000377,777777777777
	oct	000000000177,777777777777
	oct	000000000077,777777777777
	oct	000000000037,777777777777
	oct	000000000017,777777777777
	oct	000000000007,777777777777
	oct	000000000003,777777777777
	oct	000000000001,777777777777
	oct	000000000000,777777777777
	oct	000000000000,377777777777
	oct	000000000000,177777777777
	oct	000000000000,077777777777
	oct	000000000000,037777777777
	oct	000000000000,017777777777
	oct	000000000000,007777777777
	oct	000000000000,003777777777
	oct	000000000000,001777777777
	oct	000000000000,000777777777
	oct	000000000000,000377777777
	oct	000000000000,000177777777
	oct	000000000000,000077777777
	oct	000000000000,000037777777
	oct	000000000000,000017777777
	oct	000000000000,000007777777
	oct	000000000000,000003777777
	oct	000000000000,000001777777
	oct	000000000000,000000777777
	oct	000000000000,000000377777
	oct	000000000000,000000177777
	oct	000000000000,000000077777
	oct	000000000000,000000037777
	oct	000000000000,000000017777
	oct	000000000000,000000007777
	oct	000000000000,000000003777
	oct	000000000000,000000001777
	oct	000000000000,000000000777
	oct	000000000000,000000000377
	oct	000000000000,000000000177
	oct	000000000000,000000000077
	oct	000000000000,000000000037
	oct	000000000000,000000000017
	oct	000000000000,000000000007
	oct	000000000000,000000000003
	oct	000000000000,000000000001
"Precision Conversion Table

"     Convert binary precision to necessary decimal precision, including
"     sign and hardware exponent.  DU has decimal precision for indexed
"     binary precision.  DL has number of bytes of binary source for that
"     binary precision.

bin_prec_to_dec_prec:
	vfd	18/2,18/0		" binary prec  0
	vfd	18/3,18/1		" binary prec  1
	vfd	18/3,18/1		" binary prec  2
	vfd	18/3,18/1		" binary prec  3
	vfd	18/4,18/1		" binary prec  4
	vfd	18/4,18/1		" binary prec  5
	vfd	18/4,18/1		" binary prec  6
	vfd	18/5,18/1		" binary prec  7
	vfd	18/5,18/1		" binary prec  8
	vfd	18/5,18/1		" binary prec  9
	vfd	18/6,18/2		" binary prec 10
	vfd	18/6,18/2		" binary prec 11
	vfd	18/6,18/2		" binary prec 12
	vfd	18/6,18/2		" binary prec 13
	vfd	18/7,18/2		" binary prec 14
	vfd	18/7,18/2		" binary prec 15
	vfd	18/7,18/2		" binary prec 16
	vfd	18/8,18/2		" binary prec 17
	vfd	18/8,18/2		" binary prec 18
	vfd	18/8,18/3		" binary prec 19
	vfd	18/9,18/3		" binary prec 20
	vfd	18/9,18/3		" binary prec 21
	vfd	18/9,18/3		" binary prec 22
	vfd	18/9,18/3		" binary prec 23
	vfd	18/10,18/3	" binary prec 24
	vfd	18/10,18/3	" binary prec 25
	vfd	18/10,18/3	" binary prec 26
	vfd	18/11,18/3	" binary prec 27
	vfd	18/11,18/4	" binary prec 28
	vfd	18/11,18/4	" binary prec 29
	vfd	18/12,18/4	" binary prec 30
	vfd	18/12,18/4	" binary prec 31
	vfd	18/12,18/4	" binary prec 32
	vfd	18/12,18/4	" binary prec 33
	vfd	18/13,18/4	" binary prec 34
	vfd	18/13,18/4	" binary prec 35
	vfd	18/13,18/4	" binary prec 36
	vfd	18/14,18/5	" binary prec 37
	vfd	18/14,18/5	" binary prec 38
	vfd	18/14,18/5	" binary prec 39
	vfd	18/15,18/5	" binary prec 40
	vfd	18/15,18/5	" binary prec 41
	vfd	18/15,18/5	" binary prec 42
	vfd	18/15,18/5	" binary prec 43
	vfd	18/16,18/5	" binary prec 44
	vfd	18/16,18/5	" binary prec 45
	vfd	18/16,18/6	" binary prec 46
	vfd	18/17,18/6	" binary prec 47
	vfd	18/17,18/6	" binary prec 48
	vfd	18/17,18/6	" binary prec 49
	vfd	18/18,18/6	" binary prec 50
	vfd	18/18,18/6	" binary prec 51
	vfd	18/18,18/6	" binary prec 52
	vfd	18/18,18/6	" binary prec 53
	vfd	18/19,18/6	" binary prec 54
	vfd	18/19,18/7	" binary prec 55
	vfd	18/19,18/7	" binary prec 56
	vfd	18/20,18/7	" binary prec 57
	vfd	18/20,18/7	" binary prec 58
	vfd	18/20,18/7	" binary prec 59
	vfd	18/21,18/7	" binary prec 60
	vfd	18/21,18/7	" binary prec 61
	vfd	18/21,18/7	" binary prec 62
	vfd	18/21,18/7	" binary prec 63
	vfd	18/22,18/8	" binary prec 64
	vfd	18/22,18/8	" binary prec 65
	vfd	18/22,18/8	" binary prec 66
	vfd	18/23,18/8	" binary prec 67
	vfd	18/23,18/8	" binary prec 68
	vfd	18/23,18/8	" binary prec 69
	vfd	18/24,18/8	" binary prec 70
	vfd	18/24,18/8	" binary prec 71
	vfd	18/24,18/8	" binary prec 72


"     Convert decimal digit to binary precision needed to hold it.
"     Used by flt_dec_to_flt_bin to maintain maximum converison precision.

digit_to_prec:
	zero	1,0		" digit 0.0-0.99...
	zero	2,0		" digit 1.0-1.99...
	zero	3,0		" digit 2.0-2.99...
	zero	3,0		" digit 3.0-3.99...
	zero	4,0		" digit 4.0-4.99...
	zero	4,0		" digit 5.0-5.99...
	zero	4,0		" digit 6.0-6.99...
	zero	4,0		" digit 7.0-7.99...
	zero	5,0		" digit 8.0-8.99...
	zero	5,0		" digit 9.0-9.99...
	end




		    arc_sine_.alm                   11/11/89  1150.6rew 11/11/89  0805.3       78282



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Bull Inc., 1987                *
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1985 *
" *                                                         *
" ***********************************************************

" HISTORY COMMENTS:
"  1) change(86-07-15,Ginter), approve(86-07-15,MCR7287),
"     audit(86-07-16,Mabey), install(86-07-28,MR12.0-1104):
"     Change by M Mabey (installed by Ginter) to normalize input with frd.
"                                                      END HISTORY COMMENTS


name	arc_sine_
" Modification history:
"	Written by H. Hoover, M. Mabey, and B. Wong, April 1985,
"	based on the GCOS routine '7nah'.
"
"	Modified: May 10, 1985 by M Mabey - normalize input with a frd.
"
" Function:  Approximate to single precision the arcsine or arccosine of
"	a value in the range [-1:1].
"
" Entry:	through the appropriately named entry point with:
"	EAQ = a value in the range [-1:1]
"	PR2 = the address of a 20 word, even-word aligned scratch area.
"	      12 words are used in this program and another 8 are allocated
"	      for the double_square_root_ routine.
"	PR3 = the return address.
"
" Exit:	EAQ = the desired angle.
"
" Uses:	X2, X3, X4, PR5
"	X2 = indicates BFP or HFP mode - all the floating point math
"	     routines use this register for the same purpose.
"	X3 = saves a return address from arcsine.
"         X4 = saves a return address from part_arcsine.
"	PR5 = a temporary
"	The X register usage starts at X2 because this function calls
"	double_square_root_ which uses registers X0 through X2.  Register X2
"	is used for the same purpose in both routines.
"
"	Since double_square_root_ expects the return address in PR3,
"	this register must be saved before the call is made.  In addition,
"	double_square_root_ expects PR2 to point to an even-word aligned,
"	8 word long working storage area.

	segdef	arc_sine_radians_
	segdef	hfp_arc_sine_radians_
	segdef	arc_sine_degrees_
	segdef	hfp_arc_sine_degrees_
	segdef	arc_cosine_radians_
	segdef	hfp_arc_cosine_radians_
	segdef	arc_cosine_degrees_
	segdef	hfp_arc_cosine_degrees_

	segref	math_constants_,half_pi,hfp_half_pi,hfp_one_radian,one_radian,pi,quarter_pi

	equ	abs_x,0
	equ	arg_x,2
	equ	y,4
	equ	yy,6
	equ	p,8
	equ	space_used,10
	equ	pp,p
	equ	temp,abs_x
	equ	BFP,0
	equ	HFP,2

	bool	P90.0H,004264	" yields HFP +90.0 under 'du' modification

hfp_arc_sine_radians_:
	eax2	HFP		" 2 word offset for HFP constants
	tsx3	arcsine
	frd	0
	tra	pr3|0		" Return to caller

arc_sine_radians_:
	eax2	BFP
	tsx3	arcsine
	frd	0
	tra	pr3|0		" Return to caller

hfp_arc_sine_degrees_:
	eax2	HFP
	tsx3	arcsine
	dfmp	hfp_one_radian	" Convert to degrees
	frd	0
	tra	pr3|0		" Return to caller

arc_sine_degrees_:
	eax2	BFP
	tsx3	arcsine
	dfmp	one_radian	" Convert to degrees
	frd	0
	tra	pr3|0		" Return to caller

hfp_arc_cosine_radians_:
	eax2	HFP
	tsx3	arcsine
	fneg	0
	dfad	hfp_half_pi	" convert to cosine
	frd	0
	tra	pr3|0		" Return to caller

arc_cosine_radians_:
	eax2	BFP
	tsx3	arcsine
	fneg	0
	dfad	half_pi		" convert to cosine
	frd	0
	tra	pr3|0		" Return to caller

hfp_arc_cosine_degrees_:
	eax2	HFP
	tsx3	arcsine
	dfmp	hfp_one_radian	" convert to degrees
	fneg	0
	anq	kill_nine_bits	" clean out unnecessary bottom bits
	fad	P90.0H,du		" convert to cosine
	frd	0
	tra	pr3|0		" Return to caller

arc_cosine_degrees_:
	eax2	BFP
	tsx3	arcsine
	dfmp	one_radian,x2	" convert to degrees
	fneg	0
	dfrd	0		" clean out unnecessary bottom bits
	fad	=90.0,du		" convert to cosine
	frd	0
	tra	pr3|0		" Return to caller

arcsine:
	frd	0		" round and normalize input ("arg_x")
	fst	pr2|arg_x		" store sign of arg_x.
	tpl	2,ic		" abs_x=abs(arg_x)
	  fneg	0
	fst	pr2|abs_x

" determine what range abs_x is in.  A binary search is not used as
" each higher range is much smaller than the previous one.  Once the
" range is determined, perform the appropriate polynomial scaling to
" get abs_x into [0, .5], and then transfer to part_arcsine.
" Upon return, scale the result back.

	fcmg	=0.5,du		" is abs_x in the range [0,.5)
	tpl	above_bound_1	" no, find the correct range
	fld	pr2|arg_x
	tsx4	part_arcsine
	tra	0,x3		" Return to entry

above_bound_1:
	fcmg	bound_2,x2	" is abs_x in the range [.5, .866)
	tpl	above_bound_2	" no, find correct range
	fmp	pr2|abs_x		" EAQ = abs_x**2
	fmp	two,x2		" EAQ = 2 * abs_x**2
	fsb	one,x2		" EAQ = 2 * abs_x**2 - 1
	tsx4	part_arcsine
	dfad	half_pi,x2	" EAQ = part_asin + pi/2
	fmp	=0.5,du		" EAQ = .5*part_asin + pi/4
	fszn	pr2|arg_x		" was arg_x negative
	tpl	0,x3		" no, return to entry
	fneg	0		" EAQ = -EAQ
	tra	0,x3		" Return to entry

above_bound_2:
	fcmg	bound_3,x2	" is abs_x in the range [.866, .966)
	tpl	above_bound_3	" no, find correct range
	fmp	pr2|abs_x		" EAQ = abs_x**2
	dfst	pr2|temp
	fmp	eight,x2		" EAQ = 8*abs_x**2
	fsb	eight,x2		" EAQ = 8*abs_x**2 - 8
	dfmp	pr2|temp		" EAQ = 8*abs_x**4 - 8*abs_x**2
	fad	one,x2		" EAQ = 8*abs_x**4 - 8*abs_x**2 + 1
	tsx4	part_arcsine
	dfad	three_pi_by_two,x2	" EAQ = part_asin + 3*pi/2
	dfmp	one_quarter,x2	" EAQ = part_asin/4 + 3*pi/8
	fszn	pr2|arg_x		" was arg_x negative
	tpl	0,x3		" no, return to entry
	fneg	0		" EAQ = -EAQ
	tra	0,x3		" return to entry

above_bound_3:
	fcmg	bound_4,x2	" is abs_x in the range [.966, 1]
	tpnz	arcsine_domain_error
	fmp	=0.5,du		" EAQ = abs_x/2
	fneg	0		" EAQ = - abs_x/2
	fad	=0.5,du		" EAQ = .5 - abs_x/2 or (1-abs_x)/2

	epp5	pr3|0		" save the return address
	epp2	pr2|space_used	" increment PR2 for sqrt
	tsp3	square_root,x2	" call sqrt function
	epp2	pr2|-space_used	" restore PR2
	epp3	pr5|0		" restore PR3
	tsx4	part_arcsine	" EAQ = sqrt ((1 - abs_x)/2)
	fmp	two,x2		" EAQ = 2*part_asin
	fneg	0		" EAQ = - 2*part_asin
	dfad	half_pi,x2	" EAQ = pi/2 - 2*part_asin
	fszn	pr2|arg_x		" was arg_x negative
	tpl	0,x3		" no, return to entry
	fneg	0		" EAQ = -EAQ
	tra	0,x3		" return to entry

" Transfer Table

" We call double_square_root_ instead of square_root_ because we need
" the additional accuracy.  If we call the single precision version
" we can sometimes end up with a final result that will be wrong in the
" second last bit of the mantissa.

square_root:
	tra	<double_square_root_>|[double_square_root_]
	nop
	tra	<double_square_root_>|[hfp_double_square_root_]


arcsine_domain_error:		" abs_x > 1
	ldq	58,dl
	tsx0	<call_math_error_>|[call_math_error_]
	fld	=0.0,du
	tra	pr3|0		" return to caller

" This next subroutine calculates the arcsine of a value in the
" range [0, .5].

part_arcsine:
	fcmg	formula_bound,x2	" Can we use a short polynomial?
	tmi	small_formula	" Yup.

	dfst	pr2|y
	dfmp	pr2|y
	dfst	pr2|yy		" yy = y*y
	dfmp	p2,x2		" EAQ = yy*p2
	dfad	p1,x2		" EAQ = p1 + yy*p2
	dfmp	pr2|yy		" EAQ = yy*(p1 + yy*p2)
	dfad	p0,x2		" EAQ = p0 + yy*(p1 + yy*p2)
	dfst	pr2|p
	dfld	pr2|yy		" EAQ = yy
	dfad	q1,x2		" EAQ = q1 + yy
	dfmp	pr2|yy		" EAQ = yy*(q1 + yy)
	dfad	q0,x2		" EAQ = q0 + yy*(q1 + yy)
	dfdi	pr2|p		" EAQ = p/q
	dfmp	pr2|y		" EAQ = y*p/q
	tra	0,x4		" Return from part_arcsine

small_formula:
	fcmg	epsilon,x2	" Is any calculation necessary?
	tmi	0,x4		" No. Small number. Just return.

	dfst	pr2|y
	dfmp	pr2|y
	dfst	pr2|yy		" yy = y*y
	dfmp	pp1,x2		" EAQ = yy*pp1
	dfad	pp0,x2		" EAQ = pp0 + yy*pp1
	dfst	pr2|pp
	dfld	pr2|yy
	dfad	qq0,x2		" EAQ = qq0 + yy
	dfdi	pr2|pp		" EAQ = pp/qq
	dfmp	pr2|y		" EAQ = y*pp/qq
	tra	0,x4		" Return from part_arcsine


" Constants:  (Hex values are given in octal)

	even
p0:	dec	.5603629044813127d01
	oct	002263241667,336306551630
p1:	dec	-.46145309466645d01
	oct	003554253414,621544301723
p2:	dec	.49559947478731d00
	oct	000375576333,402012333277
pp0:	dec	-2.21393498174243d00
	oct	003671116707,231744233462
pp1:	dec	.63101484054356d00
	oct	000503050602,166633467044
q0:	dec	.5603629030606043d01
	oct	002263241667,241274777175
q1:	dec	-.554846659934668d01
	oct	003516345730,544667102152
qq0:	dec	-2.21393497792717d00
	oct	003671116707,252252114363

bound_2:	dec	.866025404d0
hfp_bound_2:
	oct	000673317272,000000000000	" sin(pi/3)
bound_3:	dec	.965925826d0
	oct	000756433521,000000000000	" sin(5*pi/12)
bound_4:	dec	1.0d0
	oct	002040000000,000000000000

three_pi_by_two:
	dec 	.471238898038468985787763d01
	oct	002226627617,714620722152
one_quarter:
	dec	0.25d0
	oct	000200000000,000000000000
one:	dec	1.0d0
	oct	002040000000,000000000000
two:	dec	2.0d0
	oct	002100000000,000000000000
eight:	dec	8d0
	oct	002400000000,000000000000
formula_bound:
	dec	0.13052619d0
	oct	000102650520,000000000000
epsilon:	dec	5.7031627d-10
	oct	762116304341,000000000000
kill_nine_bits:
	oct	777777777000

	end




		    arc_tangent_.alm                11/11/89  1150.6rew 11/11/89  0804.2       98820



" ******************************************
" *                                        *
" * Copyright, (C) Honeywell Limited, 1985 *
" *                                        *
" ******************************************

" HISTORY COMMENTS:
"  1) change(86-07-14,BWong), approve(86-07-14,MCR7413),
"     audit(86-07-16,Ginter), install(86-07-28,MR12.0-1104):
"     Make code more efficient.
"                                                      END HISTORY COMMENTS


name	arc_tangent_
" Modification history:
"	Written by H. Hoover, M. Mabey, and B. Wong, April 1985,
"	based on the GCOS routine '7naj'.
"
" Function:  Approximate to single precision the principal value, in radians
"	or degrees, of the arctangent of (x, y) or z where z=x/y for any
"         valid input argument(s).  For atan(z) the answer is in quadrant 1
"	or 4 (-pi/2<=atan<=pi/2, -90<=atan<=90).  For atan(x,y) the answer
"	will be in the correct quadrant (-pi<=atan2<=pi, -180<=atan2<=180).
"
"	Modified: March 18, 1986 by B. Wong - Make code more efficient by
"		replacing 
"
"		  range_0_to_1:	fcmg	tan_pi_by_32,x2
"				tmi	range_0
"		  range_1:	tra	calculate_for_range_1_to_7
"		  range_0:
"
"		with
"
"		  range_0_to_1:	fcmg	tan_pi_by_32,x2
"		  range_1:	tpl	calculate_for_range_1_to_7
"		  range_0:
"
" Entry:	through the appropriately named entry point with:
" 	EAQ = the first argument (z or x).
"	PR1 = the address of the second argument (y).
"	PR2 = the address of a 8 word, even-word aligned scratch area.
"	PR3 = the return address.
"
" Exit:	EAQ = the desired arctangent in radians or degrees.
"
" Uses:	X0, X1, X2, X3, X4
"	X0 = saves a return address from arctan
"	X1 = saves a return address from arctan2
"	X2 = indicates BFP or HFP mode - all the floating point math
"	     routines use this register for the same purpose.
"	X3 = saves a return address from part_arctan
"	X4 = index to tables


	segref	math_constants_,half_pi,hfp_one_radian,one_radian,pi

	equ	BFP,0
	equ	HFP,2
	equ	z,0
	equ	zz,2
	equ	arctan_z,3
	equ	x,4
	equ	y,5
	equ	indicators,6

	segdef	arc_tangent_degrees_,hfp_arc_tangent_degrees_
	segdef	arc_tangent_degrees_2_,hfp_arc_tangent_degrees_2_
	segdef	arc_tangent_radians_,hfp_arc_tangent_radians_
	segdef	arc_tangent_radians_2_,hfp_arc_tangent_radians_2_


arc_tangent_degrees_:
	eax2      BFP		" no offset for BFP constants
	tsx0      arctan		" EAQ := arctan (x)
	dfmp      one_radian	" convert radians to degrees
	frd	0
	tra       pr3|0		" return

arc_tangent_degrees_2_:
	eax2      BFP		" no offset for BFP constants
	tsx1      arctan2		" EAQ := arctan2 (x,y)
	dfmp      one_radian	" convert radians to degrees
	frd	0
	tra       pr3|0		" return

arc_tangent_radians_:
	eax2      BFP		" no offset for BFP constants
	tsx0      arctan		" EAQ := arctan (x)
	frd	0
	tra       pr3|0		" return

arc_tangent_radians_2_:
	eax2      BFP		" no offset for BFP constants
	tsx1      arctan2		" EAQ := arctan2 (x,y)
	frd	0
	tra       pr3|0		" return

hfp_arc_tangent_degrees_:
	eax2      HFP		" 2 word offset for HFP constants
	tsx0      arctan		" EAQ := arctan (x)
	dfmp      hfp_one_radian	" convert radians to degrees
	frd	0
	tra       pr3|0		" return

hfp_arc_tangent_degrees_2_:
	eax2      HFP		" 2 word offset for HFP constants
	tsx1      arctan2		" EAQ := arctan2 (x,y)
	dfmp      hfp_one_radian	" convert radians to degrees
	frd	0
	tra       pr3|0		" return

hfp_arc_tangent_radians_:
	eax2      HFP		" 2 word offset for HFP constants
	tsx0      arctan		" EAQ := arctan (x)
	frd	0
	tra       pr3|0		" return

hfp_arc_tangent_radians_2_:
	eax2      HFP		" 2 word offset for HFP constants
	tsx1      arctan2		" EAQ := arctan2 (x,y)
	frd	0
	tra       pr3|0		" return

arctan:
	fad	=0.0,du		" normalize input
	fst	pr2|arctan_z	" store argument z

" Find which of the 9 ranges abs(z) lies in using a binary search.

" Set X4 as the range indicator.  X4 is set to X2+4*(range-1) since double
" precision tables with decimal BFP and octal HFP values are used.

	eax4	0,x2		" initialize the table index with BFP or HFP offset

	fcmg	tan_7_pi_by_32,x2
	tmi	range_0_to_3

	fcmg	tan_13_pi_by_32,x2
	tmi	range_4_to_6

	fcmg	tan_15_pi_by_32,x2
	tmi	range_7

range_8:
				" range = 8, abs (z) >= tan_15_pi_by_32
	fcmg	eps1,x2
	tmi	3,ic		" if abs (z) < 1e71b:
	  fld	half_pi,x2	"   EAQ := radians = half_pi
	  tra	set_to_quadrant_1_or_4
				" else:
	fcmp	=0.0,du
	tpl	2,ic
	   fneg	0		"   EAQ := abs (z)
	fdi	=-1.0,du		"   EAQ := -1/abs_z
	tsx3	part_arctan	"   calculate part_arctan (-1/abs_z)
				"     which is equivalent to - (part_arctan (1/abs_z))
	fad	half_pi,x2	"   EAQ := radians = half_pi - part_arctan (1/abs_z)
	tra	set_to_quadrant_1_or_4

range_7:
	adx4	=24,du		" range = 7, tan_13_pi_by_32 <= abs (z) < tan_15_pi_by_32
	tra	calculate_for_range_1_to_7

range_4_to_6:
	fcmg	tan_11_pi_by_32,x2
	tmi	range_4_to_5

range_6:
	adx4	=20,du		" range = 6, tan_11_pi_by_32 <= abs (z) < tan_13_pi_by_32
	tra	calculate_for_range_1_to_7

range_4_to_5:
	fcmg	tan_9_pi_by_32,x2
	tmi	range_4

range_5:
	adx4	=16,du		" range = 5, tan_9_pi_by_32 <= abs (z) < tan_11_pi_by_32
	tra	calculate_for_range_1_to_7

range_4:
	adx4	=12,du		" range = 4, tan_7_pi_by_32 <= abs (z) < tan_9_pi_by_32
	tra	calculate_for_range_1_to_7

range_0_to_3:
	fcmg	tan_3_pi_by_32,x2
	tmi	range_0_to_1

	fcmg	tan_5_pi_by_32,x2
	tmi	range_2

range_3:
	adx4	=8,du		" range = 3, tan_5_pi_by_32 <= abs (z) < tan_7_pi_by_32
	tra	calculate_for_range_1_to_7

range_2:
	adx4	=4,du		" range = 2, tan_3_pi_by_32 <= abs (z) < tan_5_pi_by_32
	tra	calculate_for_range_1_to_7

range_0_to_1:
	fcmg	tan_pi_by_32,x2

range_1:
				" range = 1, tan_pi_by_32 <= abs (z) < tan_3_pi_by_32
	tpl	calculate_for_range_1_to_7

range_0:
				" range = 0, abs (z) < tan_pi_by_32
	fcmp	=0.0,du
	tpl	2,ic
	  fneg	0		" EAQ := abs (z)
	tsx3	part_arctan	" EAQ := part_arctan (abs_z)
	tra	set_to_quadrant_1_or_4

calculate_for_range_1_to_7:
	fcmp	=0.0,du
	tpl	2,ic
	  fneg	0		" EAQ := abs (z)
	dfad	one_over_u,x4	" EAQ := t = 1/u(range) - (1/(u(range)**2)+1) / (1/u(range) + abs_z)
	dfdi	one_plus_one_over_u_squared,x4
	dfad	one_over_u,x4
	tsx3	part_arctan	" EAQ := part_arctan (t)
	dfad	arctan_of_u,x4	" EAQ := radians = part_arctan (t) + arctan(u(range))

set_to_quadrant_1_or_4:
	fszn	pr2|arctan_z	" set indicators
	tpl	0,x0		" if z >= 0 then return (radians)
	  fneg	0		" else return (-radians)
	  tra	0,x0

part_arctan:
				" EAQ contains z arg
	fcmg	eps2,x2		" if abs (z) < 5.7031627e10
	tmi	0,x3		" then return (z)

	dfstr	pr2|z
	dfmp	pr2|z		" calculate zz = z*z
	fstr	pr2|zz
	fmp	p3,x2		" calculate p(zz)
	dfad	p2,x2
	fmp	pr2|zz
	dfad	p1,x2
	fmp	pr2|zz
	dfad	p0,x2
	fmp	pr2|z		" calculate z*p(zz)
	tra	0,x3		" return

arctan2:
	fad	=0.0,du		" normalize x
	fst	pr2|x		" save normalized x for quadrant check
	fld	pr1|0		" load y
	fad	=0.0,du		" normalize y
	fst	pr2|y		" save normalized y for quadrant check
	tnz	y_not_zero
	fszn	pr2|x		" test if x = 0 also
	tze	arctan2_domain_err	" 0/0 is error
	dfld	half_pi,x2	" atan(x/0) =  + or - (half_pi)
	fszn	pr2|x
	tpl	0,x1		" if x >= 0 then return (radians)
	  fneg	0		" else return (-radians)
	  tra	0,x1


y_not_zero:
	sti	pr2|indicators	" save indicators
	ldi	no_overflow,x2
	fdi	pr2|x		" EAQ := x/y
	teo	quotient_too_large	" if overflow, atan(x,y) = pi/2 or -pi/2
	teu	quotient_too_small	" if underflow, atan(x,y) = 0
	ldi	pr2|indicators	" restore previous indicators
	fad	=0.0,du		" set indicators
	tpl	2,ic		" calculate z = abs (x,y)
	  fneg	0
	tsx0	arctan		" EAQ := arctan(z)

set_quadrant:
	fszn	pr2|y		" set the quadrant
	tpl	3,ic		" if y < 0 then
	  fneg	0		"   radians = pi-radians
	  dfad	pi,x2
	fszn	pr2|x
	tpl	0,x1		" if x >= 0 then return (radians)
	  fneg	0		" else return (-radians)
	  tra	0,x1

				" error when x=0 and y=0
arctan2_domain_err:
	ldq	11,dl
	tsx0	<call_math_error_>|[call_math_error_]
	fld	=0.0,du
	tra	pr3|0		" return to caller

quotient_too_small:
	ldi	pr2|indicators	" restore indicators
	fld	=0.0,du		" radians = 0.0
	tra	set_quadrant

quotient_too_large:
	ldi	pr2|indicators	" restore indicators
	dfld	half_pi,x2	" radians = half_pi
	tra	set_quadrant

	even

eps1:	oct	220400000000,000000000000	" 2**71 = 2.36e21
	oct	044400000000,000000000000
eps2:	dec	5.7031627d-10
	oct	762116304341,000000000000
no_overflow:
	oct	000000004000,000000000000	" bit 25 is the overflow mask
	oct	000000004010,000000000000	" bit 33 is the hex indicator

" This is the table of ranges.

tan_pi_by_32:
	dec	.98491403d-1		" tan(pi/32)
	oct	000062332734,000000000000
tan_3_pi_by_32:
	dec	.30334668d00		" tan(3*pi/32)
	oct	000233240406,000000000000
tan_5_pi_by_32:
	dec	.53451114d00		" tan(5*pi/32)
	oct	000421526707,000000000000
tan_7_pi_by_32:
	dec	.82067879d00		" tan(7*pi/32)
	oct	000644140013,000000000000
tan_9_pi_by_32:
	dec	1.2185035d00		" tan(9*pi/32)
	oct	002046773754,000000000000
tan_11_pi_by_32:
	dec	1.8708684d00		" tan(11*pi/32)
	oct	002073674236,000000000000
tan_13_pi_by_32:
	dec	3.2965582d00		" tan(13*pi/32)
	oct	002151372636,000000000000
tan_15_pi_by_32:
	dec	10.153170d00		" tan(15*pi/32)
	oct	002504715423,000000000000

" This table is the value of 1/u(i), where 1/u(i)=....

one_over_u:
	dec	5.0273394921258481045d0	" 1/tan(pi/16)
	oct	002240677734,220443561021
	dec	2.4142135623730950488d0	" 1/tan(2*pi/16)
	oct	002115202363,147747363110
	dec	1.4966057626654890176d0	" 1/tan(3*pi/16)
	oct	002057710307,045516430250
	dec	1.0d0			" 1/tan(4*pi/16)
	oct	002040000000,000000000000
	dec	.66817863791929891999d0	" 1/tan(5*pi/16)
	oct	000526067012,533771440572
	dec	.41421356237309504880d0	" 1/tan(6*pi/16)
	oct	000324047463,177167462204
	dec	.19891236737965800691d0	" 1/tan(7*pi/16)
	oct	000145657536,012514254010

" This table is values of 1/(u(i)**2) + 1.

one_plus_one_over_u_squared:
	dec	-.26274142369088180356d02
	oct	005713347216,344112137060
	dec	-.68284271247461900976d01
	oct	003445373031,460061031557
	dec	-.32398288088435500410d01
	oct	003630246512,105301545417
	dec	-.20d1
	oct	003700000000,000000000000
	dec	-.14464626921716895685d01
	oct	003721555117,372172063463
	dec	-.11715728752538099024d01
	oct	003732404746,317716746221
	dec	-.10395661298965800348d01
	oct	003736567577,176041165302

" This table is values of arctan(u(i)).

arctan_of_u:
	dec	.19634954084936207740d00	" pi/16
	oct	000144417665,210413214107
	dec	.39269908169872415481d00	" 2*pi/16
	oct	000311037552,421026430215
	dec	.58904862254808623221d00	" 3*pi/16
	oct	000455457437,631441644324
	dec	.78539816339744830962d00	" 4*pi/16
	oct	000622077325,042055060432
	dec	.98174770424681038702d00	" 5*pi/16
	oct	000766517212,252470274541
	dec	1.17809724509617246442d00	" 6*pi/16
	oct	002045545743,763144164432
	dec	1.37444678594553454182d00	" 7*pi/16
	oct	002053766737,233564735237

" These constants are used to approximate atan over the range [0,tan(pi/32)].

p0:	dec	.9999999999924517d00
	oct	000777777777,777366325725
p1:	dec	-.33333330840148d00
	oct	001525252530,533760740143
p2:	dec	.199987124164d00
	oct	000146311331,336371476042
p3:	dec	-.14072538d00
	oct	001667745537,162731562146

	end




		    bfp_to_hfp_.alm                 11/11/89  1150.6rew 11/11/89  0804.2       10647



" ******************************************
" *                                        *
" * Copyright, (C) Honeywell Limited, 1983 *
" *                                        *
" ******************************************

"	Function:	Convert a Binary Floating Point number to the
"		nearest Hexadecimal Floating Point number.
"
"	Entry:	EAQ = BFP number to convert.
"		PR2 = address of 2 word work area.
"		PR3 = return address.
"
"	Exit:	EAQ = HFP equivalent of original BFP number.
"		X1 = number of bits of precision lost (0 to 3).

"	Written 20 Dec 83 by HH.

	segdef	bfp_to_hfp_

	equ	accum,0
	equ	exponent,1

bfp_to_hfp_:
	sta	pr2|accum		save A
	ste	pr2|exponent	store exponent
	lda	pr2|exponent	A := 8/exponent,28/0
	ars	2		A := 10/exponent,26/0
	ada	=o001400,du	A := 10/exponent+3,26/0
	sta	pr2|exponent
	lde	pr2|exponent	E := floor((exponent+3)/4)
	ars	26		A := exponent+3
	ana	3,dl		A := mod(exponent+3, 4)
	neg	0		A := -mod(exponent+3, 4)
	eax1	3,al		X1 := 3 - mod(exponent+3, 4)
	lda	pr2|accum		restore A
	lrs	0,x1		normalize (discards 0 to 3 bits)
	tnz	return		done if mantissa is nonzero
	fld	=0.0		load "normalized" floating zero

return:
	tra	pr3|0		return

	end




		    call_math_error_.alm            11/11/89  1150.6r w 11/11/89  0804.2       32031



" ***********************************************************
" *                                                         *
" * 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-07-14,BWong), approve(86-07-14,MCR7413),
"     audit(86-07-16,Ginter), install(86-07-28,MR12.0-1104):
"     Fix fortran bug 495.
"                                                      END HISTORY COMMENTS


" This routine is called when an error is detected by an ALM math routine.
" Calling sequence is
"		ldq	error_code
"		tsx0	call_math_error_
" This routine must be bound with the other math routines in order to work!
"
" At entry,	pr0 -> pl1_operators_ | arglist of caller and must be preserved
" 		pr2 -> work area of math routines and must be preserved
"		pr3 -> return loc of real math routine which may be
"		in the PL/I program or in an alm write-around.
"
"	Modified by BW 86-03-18 to store PR3 in 'stack_frame.return_ptr'.
"		This is needed by 'trace_stack' and 'probe' to correctly
"		diagnose the line on which the math error occurs.  In
"		the case of a math routine calling another math routine,
"		the called math routine must not encounter an error
"		which requires a call to 'call_math_error_'.  It is up
"		to the math routine which calls the other math routine
"		to ensure this.  'double_square_root_' is currently the
"		only routine which is called by other math routines 
"		(arc_sine_ and double_arc_sine_).  Fixes Fortran error
"		number 495.
"	Modified by HH 84-01-13 to not store PR3 in 'stack_frame.return_ptr'.
"		This was of no value since control is always returned
"		through PR3, but was of great harm if the calling math
"		routine was called from another math routine, since that
"		would change the segment number in 'stack_frame.return_ptr'
"		from that of the owner of the stack frame to that of our
"		caller's caller (which means that the next call to
"		'pl1_operators_' could return to our caller's caller
"		at a random offset, rather than to the owner of the frame).
"
	segdef	call_math_error_
"
	tempd	work_ptr,ops_ptr,arglist(5)
	temp	code
"
	include	stack_frame
	include	stack_header
"
call_math_error_:
	epp4	2|0		save work ptr in pr4
	spri3	sp|stack_frame.return_ptr	save return pointer
	epbpsb	sp|0		get ptr to base of stack
	push
	stq	code		save error code
	ldq	stack_frame.support_bit,dl	set support bit
	orsq	sp|stack_frame.flag_word
	spri0	ops_ptr		save ptr to pl1_operators_
	epp2	<call_math_error_>|[error_in_math_routine_]+1	set entry ptr
	spri2	sp|stack_frame.entry_ptr
	spri4	work_ptr		save work ptr where we can get at it
	epp2	code		1st arg = code
	spri2	arglist+2
	fld	1*2048,dl
	staq	arglist
	epaq	*
	lprplp	sb|stack_header.lot_ptr,*au
	call	<math_error_>|[math_error_](arglist)
	epp2	work_ptr,*	restore work ptr
	epp0	ops_ptr,*		restore operator ptr
	sprisp	sb|stack_header.stack_end_ptr	pop stack
	eppsp	sp|stack_frame.prev_sp,*
	tra	0,0		and return to caller
"
"	this entry is here just so entry_pt field in stack
"	frame can point to an ALM entry.  it must be retained.
"
	entry	error_in_math_routine_
error_in_math_routine_:
	end




		    char_bit_offset_fcns_.alm       11/11/89  1150.6rew 11/11/89  0805.2       54909



" ***********************************************************
" *                                                         *
" * 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.      *
" *                                                         *
" ***********************************************************

" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
" Subroutines to manipulate the word and bit numbers of an ITS pointer as
" either a character or bit offset from the base of the segment referenced
" by the ITS pointer
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

" Created: September 1980 by G. Palter


	name	char_bit_offset_fcns_

	segdef	char_offset_		" return character offset of pointer
	segdef	add_char_offset_		" increment the character offset
	segdef	set_char_offset_		" set the character offset

	segdef	bit_offset_
	segdef	add_bit_offset_		" as above but for bit offsets
	segdef	set_bit_offset_


" Constants

	even
word_bit_mask:				" mask to obtain word and bit offsets
	vfd	36/0			" nothing usefull in the A
	vfd	18/-1,3/0,6/-1,9/0


bit_to_char_offset:				" converts bit offset to character offset
	vfd	36/0,36/0,36/0,36/0,36/0,36/0,36/0,36/0,36/0
	vfd	36/1,36/1,36/1,36/1,36/1,36/1,36/1,36/1,36/1
	vfd	36/2,36/2,36/2,36/2,36/2,36/2,36/2,36/2,36/2
	vfd	36/3,36/3,36/3,36/3,36/3,36/3,36/3,36/3,36/3

" 

" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
" char_offset_: Returns the character offset relative to the base of the
"	      segment of the character addressed by the given pointer
"
"    dcl  char_offset_ entry (pointer) returns (fixed binary (21)) reducible;
"    character_offset = char_offset_ (pointer_value);
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

char_offset_:
	ldaq	pr0|2,*			" pickup the pointer
	anaq	word_bit_mask		" clear unwanted bits from pointer
	llr	18+2			" puts character offset into A
	qrl	9+18+2			" puts bit offset into QL
	ada	bit_to_char_offset,ql	" add in converted bit offset
	sta	pr0|4,*			" and return it
	short_return


" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
" add_char_offset_: Constructs a pointer to a character relative to the
"		character referenced by the input pointer;" the
"		displacement to the new character may be positive/negative
"
"    dcl  add_char_offset_ entry (pointer, fixed binary (21)) returns (pointer)
"		       reducible;
"    new_pointer_value = add_char_offset_ (pointer_value, char_displacement);
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

add_char_offset_:
	epp3	pr0|2,*			" pick up pointer
	epp3	pr3|0,*
	lda	pr0|4,*			" get character displacement
	a9bd	pr3|0,al			" ZAP!
	spri3	pr0|6,*			" set output pointer
	short_return


" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
" set_char_offset_: Constructs a pointer to a character in the segment
"		referenced by the input pointer
"
"    dcl  set_char_offset_ entry (pointer, fixed binary (21)) returns (pointer)
"		       reducible;
"    new_pointer_value = set_char_offset_ (pointer_value, character_offset);
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

set_char_offset_:
	epp3	pr0|2,*			" get pointer to segment ...
	epbp3	pr3|0,*			" ... base of input pointer
	lda	pr0|4,*			" get new character offset
	a9bd	pr3|0,al			" ZAP!
	spri3	pr0|6,*			" store into output value
	short_return

" 

" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
" bit_offset_: Returns the bit offset relative to the base of the segment of
"	     the bit addressed by the given pointer
"
"    dcl  bit_offset entry (pointer) returns (fixed binary (24)) reducible;
"    bit_offset = bit_offset_ (pointer_value);
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

bit_offset_:
	ldaq	pr0|2,*			" pickup the pointer
	anaq	word_bit_mask		" mask out the useless bits
	llr	18			" puts word offset into A
	eax0	0,al			" copy word offset
	alr	5			" 32 * word offset into A
	qrl	9+18			" puts bit offset into QL
	stq	pr0|4,*			" save it here
	eaq	0,x0			" get back the word offset
	qrl	18-2			" 4 * word offset into Q
	asq	pr0|4,*			" add to bit offset in word
	asa	pr0|4,*			" add 32 * word offset to get 36*WO + BO
	short_return


" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
" add_bit_offset_: Constructs a pointer to a bit relative to the bit referenced
"	         by the input pointer;" the displacement to the new bit may
"	         be positive or negative
"
"    dcl  add_bit_offset_ entry (pointer, fixed binary (24)) returns (pointer)
"		      reducible;
"    new_pointer_value = add_bit_offset_ (pointer_value, bit_displacement);
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

add_bit_offset_:
	epp3	pr0|2,*			" pick up pointer
	epp3	pr3|0,*
	lda	pr0|4,*			" get bit displacement
	abd	pr3|0,al			" ZAP!
	spri3	pr0|6,*			" set output pointer
	short_return


" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
" set_bit_offset_: Constructs a pointer to a bit in the segment referenced by
"	         the input pointer
"
"    dcl  set_bit_offset_ entry (pointer, fixed binary (24)) returns (pointer)
"		      reducible;
"    new_pointer_value = set_bit_offset_ (pointer_value, bit_offset);
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

set_bit_offset_:
	epp3	pr0|2,*			" get pointer to segment ...
	epbp3	pr3|0,*			" ... base of input pointer
	lda	pr0|4,*			" get new bit offset
	abd	pr3|0,al			" ZAP!
	spri3	pr0|6,*			" store into output value
	short_return

	end




		    clock_.alm                      11/11/89  1150.6rew 11/11/89  0805.3       10728



" ***********************************************************
" *                                                         *
" * 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.      *
" *                                                         *
" ***********************************************************

" " " " " " " " " " " " " " " " " " " " " " " " " " "  "
"
"	clock_	subroutine to read the calander clock.
"
"	Usage:
"
"		clock_reading = clock_();"
"
"	returns fixed bin (71)
"
" " " " " " " " " " " " " " " " " " " " " " " " "

	name	clock_
	entry	clock_

clock_:
	rccl	<sys_info>|[clock_],*	read th clock
	cmpaq	lp|clock_time		make sure still going
	tnc	clock_			loop if trouble
	staq	lp|clock_time		save for next time
	staq	ap|2,*			return to caller
	short_return

"	internal static

	use	internal_static
	join	/link/internal_static

	even
clock_time:
	oct	0,0

	end




		    config_.pl1                     11/11/89  1150.6rew 11/11/89  0805.3      201168



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(86-05-13,GJohnson), approve(86-05-13,MCR7387),
     audit(86-05-13,Martinson), install(86-05-14,MR12.0-1056):
     Correct error message documentation.
                                                   END HISTORY COMMENTS */


/* format: style2 */


config:
config_:
     proc ();

/* *	This is an all rings program which manages the config_deck segment. It has entries
   *	for locating various types of information in the config_deck, as well as entries
   *	for manipulating it. During Service Multics operation, the config_deck is protected
   *	against simulataneous updates by wired_hardcore_data$config_lock; all updates also
   *	automatically cause it to be immediately force updated to disk. At other times, it
   *	is not protected (there being only one process), and any updates must be manually
   *	requested by a call to config_$update.
   */

/* *	Completely rewritten, for Bootload Multics, 11/13/80 W. Olin Sibert
	Considerable rearranged for installation, BIM, 7/82.
	Modified to write out deck to partition in update entry '82.
	Modified to not run off end of deck. K. Loepere, April '84.
   */

/* *	Entrypoints for extracting information:
   *
   *	call config_$find (card_word, cardp);
   *
   *	   Locates a card whose name field is card_word. If cardp is null, the first such card
   *	   in the config_deck is returned. Otherwise, the first one following the one pointed
   *	   to by cardp is used.
   *
   *	call config_$find_2 (card_word, field_name, cardp);
   *
   *	   Similar to config_$find, but locates a card whose name is card_word, and whose first
   *	   data field contains field_name.
   *
   *	call config_$find_periph (peripheral_name, cardp);
   *
   *	   Locates the (first) PRPH config card for the peripheral named peripheral_name.
   *
   *	call config_$find_peripheral (peripheral_name, iom_no, channel_no, info, code);
   *
   *	   Locates the (first) PRPH config card for the peripheral named peripheral_name,
   *	   and returns the iom number, channel number, and first information parameter
   *	   from the card. If no such card can be found, code is set nonzero.
   *
   *	call config_$find_parm (parameter_name, parm_ptr);
   *
   *	   Locates some PARM card which contains an entry for parameter_name, and returns
   *	   a pointer to the first field following the parameter name. Note that parm_ptr
   *	   therefore points into the middle of a card.
   *
   *	call config_$find_table (table_name, table_size);
   *
   *	   Locates some TBLS card which contains an entry for table_name and returns
   *	   the number following the table name. If no appropriate card can be found,
   *	   -1 is returned for table_size.
   */


/* *	Entrypoints for modifying the config_deck:
   *
   *	call config_$clear ();
   *
   *	   This initializes the config_deck segment by completely filling it with "free" cards.
   *
   *	call config_$init_card (card_word, cardp);
   *
   *	   This initializes the card image pointed to by cardp to be an empty card with the supplied name.
   *	   If cardp is null on input, it is returned as a pointer to a card in the config_deck; otherwise,
   *	   it is assumed to point to a user-supplied card buffer.
   *
   *	call config_$replace (cardp1, cardp2);
   *
   *	   This replaces the contents of the card pointed to by cardp1 by the new card image
   *	   pointed to by cardp2. Neither pointer may be null.
   *
   *	call config_$add (cardp, after_cardp);
   *
   *	   This adds the card image pointed to by cardp to the config_deck, at the end if
   *	   after_cardp is null, or immediately following the card pointed to by after_cardp.
   *
   *	call config_$delete (cardp);
   *
   *	   This removes the card pointed to by cardp from the config_deck.
   *
   *	call config_$update ();
   *
   *	   This updates the config_deck image to its disk partition, for use in circumstances
   *	   where that is not being done automatically.
   */


	dcl     (
	        P_cardp		 pointer,
	        P_cardp1		 pointer,
	        P_cardp2		 pointer,
	        P_after_cardp	 pointer,
	        P_card_word		 char (4) aligned,
	        P_field_name	 char (4) aligned,
	        P_peripheral_name	 char (4) aligned,
	        P_parm_name		 char (4) aligned,
	        P_parm_ptr		 pointer,
	        P_table_name	 char (4) aligned,
	        P_table_size	 fixed bin,
	        P_iom_no		 fixed bin (3),
	        P_channel_no	 fixed bin (8),
	        P_peripheral_info	 bit (36) aligned,
	        P_code		 fixed bin (35)
	        )			 parameter;

	dcl     config_seg_size	 fixed bin (19);
	dcl     whoami		 char (32);
	dcl     idx		 fixed bin;
	dcl     lock_sw		 bit (1) aligned;	/* This is set if the config must be unlocked */
	dcl     (delete_idx, after_idx)
				 fixed bin;
	dcl     after_cardp		 pointer;
	dcl     card_word		 char (4) aligned;
	dcl     field_data		 bit (36) aligned;

	dcl     1 card_image	 aligned like config_card automatic;

	dcl     dseg$		 (0:1023) fixed bin (71) external static;
	dcl     sys_info$initialization_state
				 fixed bin external static;

	dcl     get_ring_		 entry () returns (fixed bin (3));
	dcl     sub_err_		 entry () options (variable);
	dcl     syserr		 entry options (variable);
	dcl     get_ptrs_$given_segno	 entry (fixed bin (15)) returns (pointer);
	dcl     pc_wired$write_wait	 entry (pointer, fixed bin, fixed bin);

	dcl     astep		 pointer;

	dcl     (addr, addrel, baseno, bin, binary, divide, mod, null, rel, rtrim, size, substr, unspec, verify)
				 builtin;


/* Note that none of the $find entrypoints bother to lock the config_deck. This is because their
   callers expect card pointers to be valid when returned, and hence must implement their own
   locking mechanism (calling config_$lock and config_$unlock as necessary) to make this work at
   all. Since most config deck hacking is done only in initialization code, anyway, this turns
   out not to be a problem: once initialization is over, nobody ever adds or deletes cards, so
   individual card pointers remain valid forever.
   */


find:
     entry (P_card_word, P_cardp);

/* Find a card with a specified name */

	whoami = "config_$find";

	if P_cardp ^= null ()
	then cardp = addrel (validate_cardp (P_cardp), size (config_card));
						/* SKIP the one we got */
	else cardp = addr (config_deck$);		/* Start with first card if none specified */

	config_max_cards = divide (4 * 1024 - 1, size (config_card), 17, 0);
						/* Assume four page default (other programs know this limit, this might as well) */
	config_n_cards = divide (wordno (cardp), size (config_card), 17, 0);

	card_word = P_card_word;

	do idx = config_n_cards + 1 to config_max_cards while (config_card.word ^= FREE_CARD_WORD);
	     if config_card.word = card_word
	     then do;				/* Found one */
		     P_cardp = cardp;
		     return;			/* Return it */
		end;

	     cardp = addrel (cardp, size (config_card));	/* on to the next card */
	end;					/* of looking */

	P_cardp = null ();				/* Sorry... no more left */

	return;					/* End of config_$find */

/*  */

find_2:
     entry (P_card_word, P_field_name, P_cardp);

/* Find a card with a specified name and first field */

	whoami = "config_$find_2";

	cardp = addr (config_deck$);			/* Start looking from the beginning */

	config_max_cards = divide (4 * 1024 - 1, size (config_card), 17, 0);
						/* Assume four page default (other programs know this limit, this might as well) */
	config_n_cards = divide (wordno (cardp), size (config_card), 17, 0);

	card_word = P_card_word;

	field_data = unspec (P_field_name);		/* Translate to a bitstring */

	do idx = config_n_cards + 1 to config_max_cards while (config_card.word ^= FREE_CARD_WORD);
	     if config_card.word = card_word
	     then if config_card.data_field (1) = field_data
		then do;
			P_cardp = cardp;		/* Found one */
			return;			/* Return it */
		     end;

	     cardp = addrel (cardp, size (config_card));	/* on to the next card */
	end;					/* of looking */

	P_cardp = null ();				/* Sorry... no more left */

	return;					/* End of config_$find */

/*  */

find_2_next:
     entry (P_card_word, P_field_name, P_cardp);

/* Like config_$find_2, except it finds the NEXT matching card after the one at P_cardp. */

	whoami = "config_$find_2_next";

	if P_cardp ^= null ()
	then cardp = addrel (validate_cardp (P_cardp), size (config_card));
						/* SKIP the one we got */
	else cardp = addr (config_deck$);		/* Start with first card if none specified */

	config_max_cards = divide (4 * 1024 - 1, size (config_card), 17, 0);
						/* Assume four page default (other programs know this limit, this might as well) */
	config_n_cards = divide (wordno (cardp), size (config_card), 17, 0);

	card_word = P_card_word;
	field_data = unspec (P_field_name);

	do idx = config_n_cards + 1 to config_max_cards while (config_card.word ^= FREE_CARD_WORD);
	     if config_card.word = card_word
	     then if config_card.data_field (1) = field_data
		then do;
			P_cardp = cardp;		/* Found one */
			return;
		     end;

	     cardp = addrel (cardp, size (config_card));	/* on to the next card */
	end;					/* of looking */

	P_cardp = null ();				/* Sorry... no more left */

	return;					/* End of config_$find */


find_periph:
     entry (P_peripheral_name, P_cardp);

/* Find a PRPH card for a specified peripheral */

	whoami = "config_$find_periph";

	call find_2 ("prph", P_peripheral_name, P_cardp); /* Very simple */

	return;					/* End of config_$find_periph */



find_peripheral:
     entry (P_peripheral_name, P_iom_no, P_channel_no, P_peripheral_info, P_code);

/* Find a PRPH card for a specified peripheral, and return info about the peripheral */

	whoami = "config_$find_peripheral";

	cardp = null ();				/* Prepare to call ourselves to locate the card */
	call find_2 ("prph", P_peripheral_name, cardp);

	if cardp = null ()
	then do;					/* Not found */
		P_iom_no = -1;
		P_channel_no = -1;
		P_peripheral_info = ""b;
		P_code = 1;			/* Indicate error */
		return;
	     end;

	P_iom_no = cardp -> prph_card.iom;		/* Otherwise, return the info */
	P_channel_no = cardp -> prph_card.chan;
	P_peripheral_info = unspec (cardp -> prph_card.model);
	P_code = 0;				/* Indicate success */

	return;					/* End of config_$find_peripheral */


find_parm:
     entry (P_parm_name, P_parm_ptr);

/* Find a PARM card with the specified field */

	whoami = "config_$find_parm";

	field_data = unspec (P_parm_name);		/* We must search for it as bit patterns */

	cardp = null ();

FIND_PARM_LOOP:
	call find ("parm", cardp);			/* Look through all the PARM cards */
	if cardp ^= null ()
	then do;					/* Found one */
		do idx = 1 to config_card.n_fields;	/* Do any match? */
		     if config_card.data_field (idx) = field_data
		     then if config_card.field_type (idx) = CONFIG_STRING_TYPE
			then do;
				P_parm_ptr = addr (config_card.data_field (idx));
				return;		/* Return a pointer to the matching parameter */
			     end;
		end;				/* of search of a single card */

		goto FIND_PARM_LOOP;		/* Isn't it a KLUDGE that pl1 doesn't have do ... until? */
	     end;

	P_parm_ptr = null ();			/* If not found, return null */

	return;					/* End of config_$find_parm */


find_table:
     entry (P_table_name, P_table_size);

/* Find a TBLS card for the specified field, and return the size it specifies */

	whoami = "config_$find_table";

	field_data = unspec (P_table_name);		/* We must search for it as bit patterns */

	cardp = null ();

FIND_TABLE_LOOP:
	call find ("tbls", cardp);			/* Look through all the PARM cards */
	if cardp ^= null ()
	then do;					/* Found one */
		do idx = 1 to config_card.n_fields;	/* Do any match? */
		     if config_card.data_field (idx) = field_data
		     then if config_card.field_type (idx) = CONFIG_STRING_TYPE
			then do;
				if idx = config_card.n_fields
				then /* Nothing after the name. Grump. */
				     if get_ring_ () = 0
				     then call syserr (BEEP, "^a: TBLS card specifies no value for ^a", whoami,
					     P_table_name);
				     else call sub_err_ (0, whoami, ACTION_DEFAULT_RESTART, null (), (0),
					     "TBLS card specified no value for ^a", P_table_name);

				else if (config_card.field_type (idx + 1) ^= CONFIG_OCTAL_TYPE)
					& (config_card.field_type (idx + 1) ^= CONFIG_DECIMAL_TYPE)
				then if get_ring_ () = 0
				     then call syserr (BEEP,
					     "^a: TBLS card specifies invalid type of value for ^a", whoami,
					     P_table_name);
				     else call sub_err_ (0, whoami, ACTION_DEFAULT_RESTART, null (), (0),
					     "TBLS card specifies invalid type of value for ^a", P_table_name);

				else do;		/* At last, it's OK to return the value */
					P_table_size = binary (config_card.data_field (idx + 1), 35);
					return;	/* Return the size */
				     end;
			     end;			/* Of having found the right table name */
		end;				/* Of loop through fields on a single card */

		goto FIND_TABLE_LOOP;		/* Isn't it a KLUDGE that pl1 doesn't have do ... until? */
	     end;

	P_table_size = -1;				/* If not found, return clearly invalid value */

	return;					/* End of config_$find_table */


clear:
     entry ();

/* Clear the whole config deck */

	whoami = "config_$clear";

	call get_config_size ();			/* This will always work for clearing; if not the first */
						/* time, then in the second, recursive, invocation. */

	config_n_cards = config_max_cards;

	do idx = 1 to config_max_cards;		/* Clear out each card */
	     cardp = addr (config_deck.cards (idx));

	     config_card.word = FREE_CARD_WORD;		/* The "free" pattern */
	     config_card.data_field (*) = EMPTY_FIELD;
	     unspec (config_card.type_word) = ""b;	/* And nothing in the type fields */
	end;

	call unlock_config_deck ();

	return;					/* End of config_$clear */


init_card:
     entry (P_card_word, P_cardp);

/* Initialize a card image, possibly first getting space for it from the config deck. */

	whoami = "config_$init_card";

	cardp = P_cardp;				/* Get the pointer */

	if cardp = null ()
	then do;					/* Caller wants to get a card from the deck */

		call get_config_size ();		/* Locks the config deck */
		if config_n_cards >= config_max_cards
		then /* Not bloody likely.... */
		     if get_ring_ () = 0
		     then call syserr (CRASH, "^a: The config_deck is full.", whoami);
		     else call sub_err_ (0, whoami, ACTION_CANT_RESTART, null (), (0), "The config_deck is full.");

		config_n_cards = config_n_cards + 1;	/* It has gotten larger */

		cardp = addr (config_deck.cards (config_n_cards));
						/* Get a pointer to the newly allocated image */
	     end;					/* Of allocating new image */

	config_card.word = P_card_word;		/* Initialize it */
	config_card.data_field (*) = EMPTY_FIELD;
	unspec (config_card.type_word) = ""b;

	if P_cardp = null ()
	then do;					/* We had to allocate a new one, so: */
		call unlock_config_deck ();		/* unlock, and */
		P_cardp = cardp;			/* return the pointer */
	     end;

	return;					/* End of config_$init_card */


replace:
     entry (P_cardp1, P_cardp2);

/* Replace card1 with card2 */

	whoami = "config_$replace";

	cardp = validate_cardp (P_cardp1);

	card_image = P_cardp2 -> config_card;		/* Copy it into our stack frame */

	call get_config_size ();			/* Locks the config_deck */

	cardp -> config_card = card_image;		/* Copy the image in */

	call unlock_config_deck ();			/* All done */

	return;					/* End of config_$replace */


add:
     entry (P_cardp, P_after_cardp);

/* Add a card, after after_card if non-null -- note that this cannot make a card first in the deck */

	whoami = "config_$add";

	card_image = P_cardp -> config_card;		/* Copy it into our stack frame */

	if P_after_cardp ^= null ()
	then after_cardp = validate_cardp (P_after_cardp);
	else after_cardp = null ();

	call get_config_size ();			/* Locks the config_deck */

	if config_n_cards >= config_max_cards
	then /* Not bloody likely.... */
	     if get_ring_ () = 0
	     then call syserr (CRASH, "^a: The config_deck is full.", whoami);
	     else call sub_err_ (0, whoami, ACTION_CANT_RESTART, null (), (0), "The config deck is full.");

	if after_cardp ^= null ()
	then /* Find the card we are to add this after */
	     after_idx = divide (binary (rel (after_cardp), 18), size (config_card), 17, 0) + 1;
	else after_idx = config_n_cards;		/* If none specified, add after the last */

	config_n_cards = config_n_cards + 1;		/* It has gotten larger */

	do idx = (config_n_cards - 1) to (after_idx + 1) by -1;
						/* Move the later ones up */
	     config_deck.cards (idx + 1) = config_deck.cards (idx);
	end;

	config_deck.cards (after_idx + 1) = card_image;	/* Pop it in */

	call unlock_config_deck ();			/* All done */

	return;					/* End of config_$add */


delete:
     entry (P_cardp);

/* Delete a card */

	whoami = "config_$delete";

	cardp = validate_cardp (P_cardp);

	call get_config_size ();			/* Locks the config_deck */

	delete_idx = divide (binary (rel (cardp), 18), size (config_card), 17, 0) + 1;

	do idx = delete_idx + 1 to config_n_cards;	/* Move the remaining ones down */
	     config_deck.cards (idx - 1) = config_deck.cards (idx);
	end;

	config_deck.cards (config_n_cards).word = FREE_CARD_WORD;
						/* Clear out the last card */
	config_deck.cards (config_n_cards).data_field (*) = EMPTY_FIELD;
	unspec (config_deck.cards (config_n_cards).type_word) = ""b;

	call unlock_config_deck ();			/* All done */

	return;					/* End of config_$delete */


update:
     entry ();

/* Writes the config_deck back to disk, synchronously */

	whoami = "config_$update";

	if (get_ring_ ()) ^= 0
	then /* Do nothing in test environment */
	     return;
	if sys_info$initialization_state < 2
	then return;				/* and nothing within bce */

	call get_config_size;			/* sets config_seg_size */

	astep = get_ptrs_$given_segno (bin (baseno (configp), 15));
	call pc_wired$write_wait (astep, 0, 4);

	call unlock_config_deck;
	return;


get_config_size:
     proc ();

/* *	This procedure sets n_cards and max_cards appropriately, by examining
   *	the information in the config_deck segment. If the segment is empty,
   *	it is initialized appropriately.
   */

	dcl     idx		 fixed bin;


/* First, lock the config_deck to this process. This is always done before any operation which references
   or modifies the config_deck. However, any putative card pointers should be validated before this step.
   */

	call lock_config_deck ();

	config_max_cards = divide (4 * 1024 - 1, size (config_card), 17, 0);
						/* Assume four page default (other programs know this limit, this might as well) */

	configp = addr (config_deck$);		/* Make addressable */

	if config_deck.cards (1).word = ZERO_CARD_WORD
	then do;					/* It's empty already */
		config_deck.cards (1).word = FREE_CARD_WORD;
						/* Make config_$clear work */
		call clear ();			/* Clear it out completely */
		config_n_cards = 0;			/* And return a size of zero */
		return;				/* All done */
	     end;

	do idx = 1 to config_max_cards;		/* Otherwise, look for the first free card */
	     if config_deck.cards (idx).word = FREE_CARD_WORD
	     then goto FOUND_FREE_CARD;
	end;

FOUND_FREE_CARD:
	config_n_cards = idx - 1;			/* Last card used is one before the free one */

	return;					/* All done */
     end get_config_size;


validate_cardp:
     proc (P_validate_cardp) returns (pointer);

/* *	This procedure verifies that cardp is, indeed, a pointer into the config_deck
   *	and points at the beginning of a config card. It does not, however, catch all
   *	possible cases which would result from format errors in the config_deck.
   */

	dcl     P_validate_cardp	 pointer parameter;

	dcl     return_cardp	 pointer;


	if substr (unspec (P_validate_cardp), (37 - 6), 6) ^= "43"b3
	then do;
INVALID_CARD_POINTER:
		if get_ring_ () = 0
		then call syserr (CRASH, "^a: Invalid card pointer ^p does not point to a valid config card.", whoami,
			P_validate_cardp);
		else call sub_err_ (0, whoami, ACTION_CAN_RESTART, null (), (0),
			"Invalid card pointer ^p does not point to a valid config card.", P_validate_cardp);
		return (null ());			/* In case someone typed GO */
	     end;

	return_cardp = P_validate_cardp;

	if baseno (return_cardp) ^= baseno (addr (config_deck$))
	then goto INVALID_CARD_POINTER;

	if mod (binary (rel (return_cardp), 18), size (config_card)) ^= 0
	then goto INVALID_CARD_POINTER;

	if verify (rtrim (return_cardp -> config_card.word), VALID_CARD_WORD_CHARACTERS) ^= 0
	then goto INVALID_CARD_POINTER;

	return (return_cardp);
     end validate_cardp;


lock_config_deck:
     proc ();

/* This procedure locks the config_deck lock if it can, and sets lock_sw if it does. If it can't
   be locked because of a mylock error, this is ignored, and lock_sw is not set.
   */

/* For now, it does nothing at all */

	lock_sw = "0"b;

	if (get_ring_ ()) ^= 0
	then /* Test environment, do nothing */
	     return;

	return;
     end lock_config_deck;



unlock_config_deck:
     proc ();

/* This procedure unlocks the config_deck lock if lock_sw is set.
   */

/* For now, it does nothing at all */

	lock_sw = "0"b;

	if (get_ring_ ()) ^= 0
	then /* Test environment, do nothing */
	     return;

	return;
     end unlock_config_deck;

/* format: off */

%page; %include config_deck;
%page; %include config_prph_card;
%page; %include sub_err_flags;
%page; %include syserr_constants;


/* BEGIN MESSAGE DOCUMENTATION

   Message:
   config_$find_table: TBLS card specifies no value for NAME.

   S:  $beep

   M:  The config deck does not specify a value for NAME.

   A:  One should be added.

   Message: 
   config_$ENTRY: the config deck is full.

   S:  $crash

   M:  No space remained in the config deck for additional cards.

   A:  If this recurs, try another boot tape. Remove unneccessary
   config cards.

   END MESSAGE DOCUMENTATION */

     end config_;




		    cplx_dec_ops_.alm               11/11/89  1150.6rew 11/11/89  0805.2       68013



" ***********************************************************
" *                                                         *
" * 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.      *
" *                                                         *
" ***********************************************************

"
"	cplx_dec_ops_ -- a set of operators to do complex decimal multiplication and division
"
"	Written 8 October 1973 by RAB
"
"	These routines are called with a pointer to a work area in the ab and a pointer
"	to a string of 2 or 3 descriptors in the bp.
"

	name	cplx_dec_ops_
"
	equ	tbp,38	contains segment number of calling program
	equ	dtemp1,0
	equ	dtemp2,16
	equ	dtemp3,32
"
"	mpcdec -- complex decimal multiplication
"
"	(a + bi) * (c + di) = (ac - bd) + (ad + bc)i
"
	segdef	mpcdec
mpcdec:
	tsx4	cplx_setup
"
	mp3d	(pr,id),(pr,id),(pr),round
	arg	bp|1
	arg	bp|2
	desc9fl	ab|dtemp1,61
	mp3d	(pr,id,x2),(pr,id,x3),(pr),round
	arg	bp|1
	arg	bp|2
	desc9fl	ab|dtemp2,61
	xec	sb3d,al		pick the instruction on the basis of target type
	desc9fl	ab|dtemp2,61
	desc9fl	ab|dtemp1,61
	arg	bp|0
"
	mp3d	(pr,id),(pr,id,x3),(pr),round
	arg	bp|1
	arg	bp|2
	desc9fl	ab|dtemp1,61
	mp3d	(pr,id,x2),(pr,id),(pr),round
	arg	bp|1
	arg	bp|2
	desc9fl	ab|dtemp2,61
	xec	ad3d,al
	desc9fl	ab|dtemp1,61
	desc9fl	ab|dtemp2,61
	arg	bp|0
	tra	sp|tbp,*0
"
sb3d:	sb3d	(pr),(pr),(pr,id),round
	sb3d	(pr),(pr),(pr,id)
ad3d:	ad3d	(pr),(pr),(pr,id,x1),round
	ad3d	(pr),(pr),(pr,id,x1)
"
"	dvcdec -- complex decimal / complex decimal
"
"	(a + bi)   (ac + bd)   (bc - ad)i
"	-------- = --------- + ----------
"	(c + di)    2    2      2    2
"		 c  + d      c  + d
"
	segdef	dvcdec
dvcdec:
	tsx4	cplx_setup
"
	mp3d	(pr,id),(pr,id),(pr),round
	arg	bp|2
	arg	bp|2
	desc9fl	ab|dtemp1,61
	mp3d	(pr,id,x3),(pr,id,x3),(pr),round
	arg	bp|2
	arg	bp|2
	desc9fl	ab|dtemp2,61
	ad2d	(pr),(pr),round
	desc9fl	ab|dtemp2,61
	desc9fl	ab|dtemp1,61
"
	mp3d	(pr,id),(pr,id),(pr),round
	arg	bp|1
	arg	bp|2
	desc9fl	ab|dtemp2,61
	mp3d	(pr,id,x2),(pr,id,x3),(pr),round
	arg	bp|1
	arg	bp|2
	desc9fl	ab|dtemp3,61
	ad2d	(pr),(pr),round
	desc9fl	ab|dtemp3,61
	desc9fl	ab|dtemp2,61
	tsx4	dv3d_real_vector,al		divide sequence depends on target type
"
	mp3d	(pr,id,x2),(pr,id),(pr),round
	arg	bp|1
	arg	bp|2
	desc9fl	ab|dtemp2,61
	mp3d	(pr,id),(pr,id,x3),(pr),round
	arg	bp|1
	arg	bp|2
	desc9fl	ab|dtemp3,61
	sb2d	(pr),(pr),round
	desc9fl	ab|dtemp3,61
	desc9fl	ab|dtemp2,61
	tra	dv3d_imag_vector,al
"
"	dvrcdec -- real decimal / complex decimal
"
"	  a         ac       (ad)i
"	------ = ------- - -------
"	c + di    2    2    2    2
"	         c  + d    c  + d
	segdef	dvrcdec
dvrcdec:
	tsx4	cplx_setup
"
	mp3d	(pr,id),(pr,id),(pr),round
	arg	bp|2
	arg	bp|2
	desc9fl	ab|dtemp1,61
	mp3d	(pr,id,x3),(pr,id,x3),(pr),round
	arg	bp|2
	arg	bp|2
	desc9fl	ab|dtemp2,61
	ad2d	(pr),(pr),round
	desc9fl	ab|dtemp2,61
	desc9fl	ab|dtemp1,61
"
	mp3d	(pr,id),(pr,id),(pr),round
	arg	bp|1
	arg	bp|2
	desc9fl	ab|dtemp2,61
	tsx4	dv3d_real_vector,al
"
	mp3d	(pr,id),(pr,id,x3),(pr),round
	arg	bp|1
	arg	bp|2
	desc9fl	ab|dtemp2,61
	mp2d	(0),(pr),round
	desc9ls	minus_1,2,0
	desc9fl	ab|dtemp2,61
	tra	dv3d_imag_vector,al
"
minus_1:	aci	"-1"
"
dv3d_real_vector:
	tra	dv3d_float_real
	tra	dv3d_fixed_real
dv3d_imag_vector:
	tra	dv3d_float_imag
	tra	dv3d_fixed_imag
"
dv3d_float_real:
	dv3d	(pr),(pr),(pr)
	desc9fl	ab|dtemp1,61
	desc9fl	ab|dtemp2,61
	desc9fl	ab|dtemp3,63
	mvn	(pr),(pr,id),round
	desc9fl	ab|dtemp3,63
	arg	bp|0
	tra	0,4
"
dv3d_fixed_real:
	dv3d	(pr),(pr),(pr,id)
	desc9fl	ab|dtemp1,61
	desc9fl	ab|dtemp2,61
	arg	bp|0
	tra	0,4
"
"
dv3d_float_imag:
	dv3d	(pr),(pr),(pr)
	desc9fl	ab|dtemp1,61
	desc9fl	ab|dtemp2,61
	desc9fl	ab|dtemp3,63
	mvn	(pr),(pr,id,x1),round
	desc9fl	ab|dtemp3,63
	arg	bp|0
	tra	sp|tbp,*0
"
dv3d_fixed_imag:
	dv3d	(pr),(pr),(pr,id,x1)
	desc9fl	ab|dtemp1,61
	desc9fl	ab|dtemp2,61
	arg	bp|0
	tra	sp|tbp,*0
"
"
cplx_setup:
	lda	bp|0	get first descriptor
	eax1	0,al	put lower half into x1
	anx1	63,du	mask to get the length
	ars	12	shift type code into low order bit
	ana	1,dl	mask out rest of a
	lxl2	bp|1	get second descriptor
	anx2	63,du	mask to get length
	lxl3	bp|2
	anx3	63,du
	tra	0,4	return
"
"
"	                    2    2
"	abs(a + bi) = sqrt(a  + b )
"
	segdef	cabs
cabs:
	tsx4	cplx_setup
"
	mp3d	(pr,id),(pr,id),(pr),round
	arg	bp|1
	arg	bp|1
	desc9fl	ab|dtemp1,61
	mp3d	(pr,id,x2),(pr,id,x2),(pr),round
	arg	bp|1
	arg	bp|1
	desc9fl	ab|dtemp2,61
	ad2d	(pr),(pr),round
	desc9fl	ab|dtemp2,61
	desc9fl	ab|dtemp1,61
"
	tsx4	decimal_sqrt_
"
	tra	sp|tbp,*0
"
	equ	result,dtemp2
	equ	arg,dtemp3
	equ	atemp,48
	equ	i,64
"
"	decimal_sqrt_ uses repeated subtractions to calculate its result.
"	It expects a float dec(59) argument at ab|dtemp1 and calculates
"	a float dec(59) result which it then assigns to the target at bp|0,*.
"
decimal_sqrt_:
	sreg	sp|8	save registers
"
	ldq	ab|dtemp1+15	get exponent
	qls	1		"
	qrs	28		"
"
"	This algorithm requires that we imagine the decimal point to be at
"	the left of the string, so we add 59 to the exponent.
"
	adq	59,dl
"
"	Our intermediate calculations will use fixed dec(61)
"
	mvn	(0),(pr)
	desc9ls	zero,2,0
	desc9ls	ab|result,62,0
	mvn	(0),(pr)
	desc9ls	zero,2,0
	desc9ls	ab|arg,62,0
"
"	Move in the argument left normalized
"
	tct	(pr)	scan for first non-zero
	desc9a	ab|dtemp1(1),59
	arg	zero_table-12
	arg	sp|46
	ttn	ds_done
"
	lda	sp|46	get offset of non-zero character
	ana	262143,dl	mask
	eax2	0,al	save
	neg	0
	sta	sp|46	store negated result
	adq	sp|46	adjust exponent by amount chopped off
	eax3	59,al	get length to move
"
	mlr	(pr,rl,x2),(pr,rl)
	desc9a	ab|dtemp1(1),x3
	desc9a	ab|arg(1),x3
"
"	Initialize length registers
"
	eax2	62	iprec = 61
	eax3	2	rprec1 = 1
	eax4	3	iprec1 = 2
"
"	Initialize i to +01000...0 
"
	mvn	(0),(pr)
	desc9ls	zero,2,0
	desc9ls	ab|i,62,0
	lda	=o061000,dl
	stba	ab|i,10
"
"	If the exponent is odd, i and the exponent must be adjusted.
"
	canq	1,dl
	tze	set_exp
"
	adq	1,dl	exp = exp + 1
	eax4	2	iprec1 = 1
	lda	=o000061060000	change i to +1000...0
	stba	ab|i,30
"
"	Get result exponent by dividing by 2
"
set_exp:
	qrs	1
"
"	We repeatedly subtract until we get a negative number
"
sloop:
	sb3d	(pr,rl),(pr),(pr)	atemp = arg - i
	desc9ls	ab|i,x2,0
	desc9ls	ab|arg,62,0
	desc9ls	ab|atemp,62,0
	tmi	new_round
"
	mvn	(pr),(pr)	arg = atemp
	desc9ls	ab|atemp,62,0
	desc9ls	ab|arg,62,0
	ad2d	(0),(pr,rl)	i = i + 2
	desc9ls	two,2,0
	desc9ls	ab|i,x4,0
	ad2d	(0),(pr,rl)	result = result + 1
	desc9ls	one,2,0
	desc9ls	ab|result,x3,0
	tra	sloop
"
"	Shift precisions for next round
"
new_round:
	eax3	1,x3	rprec1 = rprec1 + 1
	cmpx3	60,du
	tpnz	ds_done
"
	eax4	1,4	iprec1 = iprec1 + 1
	sb2d	(0),(pr,rl)	i = i - 9
	desc9ls	nine,2,0
	desc9ls	ab|i,x4,0
	sbx2	1,du	iprec = iprec - 1
	tra	sloop
"
"	Return sequence
"
"	First move decimal pt back to right end of string
"
ds_done:
	sbq	59,dl
"
"	Convert result to floating point
"
	anq	255,dl	form a fixed bin(7) and convert to string
	qls	27	shift into position
	stbq	ab|result+15,40	store exponent
	lreg	sp|8	restore registers
	xec	dsmove,al
	desc9fl	ab|result,61
	arg	bp|0
	tra	0,4	return
"
dsmove:	mvn	(pr),(pr,id),round
	mvn	(pr),(pr,id)
"
zero:	aci	"+0"
one:	aci	"+1"
two:	aci	"+2"
nine:	aci	"+9"
"
zero_table:
	oct	000001002003,004005006007,010011000000
	end




		    dec_ops_.alm                    11/11/89  1150.6r w 11/11/89  0805.3       36900



" ***********************************************************
" *                                                         *
" * 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.      *
" *                                                         *
" ***********************************************************

"
"	dec_ops_  a package of runtime routines to support decimal arithmetic
"
"	Written by Richard A. Barnes 17 October 1973.
"	Modified by RAB 11 September 1975 to fix 1398
"	Modified by RAB 23 September 1975 to fix 1422
"
	name	dec_ops_
"
	include	stack_frame
"
	include	stack_header
"
	equ	mod_extension_size,32
	equ	tbp,38
	equ	indicators,46
	equ	qmask,55
"
	segdef	truncate
truncate:
	tsx2	trunc
	tra	sp|tbp,*0
"
	segdef	ceil
ceil:
	tsx2	trunc
	tmi	sp|tbp,*0	ceil(neg x) = trunc(x)
	cmpx1	0,du
	tze	sp|tbp,*0	exit if no truncation
	xec	ad2d,al	ceil(pos x) = trunc(x) + 1
	desc9ls	one,2,0
	arg	bp|0
	tra 	sp|tbp,*0
"
ad2d:	ad2d	(0),(pr,id),round
	ad2d	(0),(pr,id)
"
	segdef	floor
floor:
	tsx2	trunc
	tpl	sp|tbp,*0	floor(pos x) = trunc(x)
	cmpx1	0,du
	tze	sp|tbp,*0	exit if no truncation
	xec	sb2d,al	floor(neg x) = trunc(x) - 1
	desc9ls	one,2,0
	arg	bp|0
	tra	sp|tbp,*0
"
sb2d:	sb2d	(0),(pr,id),round
	sb2d	(0),(pr,id)
"
one:	aci	"+1"
"
trunc:
	tsx1	setup
"
	cmpn	(0),(pr,id)	set indicators for source
	desc9ls	zero,2,0
	arg	bp|1
	sti	sp|indicators	save indicators
	ldi	=o4000,dl		and suppress overflows
"
	cmpa	0,dl
	tnz	2,ic
	sbq	1,dl	adjust precision if float
"
	eax1	0	assume no truncation
	mvn	(pr,id),(pr,rl)
	arg	bp|1
	desc9ls	ab|0,ql,0
	tov	trunc1
	cmpn	(pr,id),(pr,rl)	check for truncation of nonzero digits
	arg	bp|1
	desc9ls	ab|0,ql,0
	tze	2,ic
	eax1	1	remember truncation
	xec	mv_temp,al
	desc9ls	ab|0,ql,0
	arg	bp|0
restore:	ldi	sp|indicators	restore indicators with source info
	tra	0,2
"
trunc1:
	xec	move,al
	arg	bp|1
	arg	bp|0
	tra	restore
"
mv_temp:	mvn	(pr,rl),(pr,id),round
	mvn	(pr,rl),(pr,id)
move:	mvn	(pr,id),(pr,id),round
	mvn	(pr,id),(pr,id)
"
	segdef	sign
sign:
	cmpn	(0),(pr,id)
	desc9ls	zero,2,0
	arg	bp|0
	tmi	s_neg
	tze	s_zero
	ldq	1,dl
	tra	sp|tbp,*0
s_zero:	ldq	0,dl
	tra	sp|tbp,*0
s_neg:	lcq	1,dl
	tra	sp|tbp,*0
"
zero:	aci	"+0"
"
	segdef	mod
mod:
	tsx1	setup
"
"	must check for case mod(x,0) = x
"
	cmpn	(0),(pr,id)
	desc9ls	zero,2,0
	arg	bp|2
	tnz	m_start
	xec	move,al
	arg	bp|1
	arg	bp|0
	tra	sp|tbp,*0
"
"	get work space
"
m_start:
	eax1	sp|0		get offset of stack frame
	stx1	sp|qmask
	lcx1	sp|qmask		get - offset
	eppap	sp|stack_frame.next_sp,*   get ptr to extension
	eax2	mod_extension_size
	asx2	sp|stack_frame.next_sp+1
	asx2	sp|stack_header.stack_end_ptr+1,1
"
"	compute float temp = op2/op3
"
	dv3d	(pr,id),(pr,id),(pr)
	arg	bp|2
	arg	bp|1
	desc9fl	ap|16,63
	mvn	(pr),(pr),round
	desc9fl	ap|16,63
	desc9fl	ap|0,61
"
"	compute float temp = floor(op2/op3)
"
	sti	sp|indicators	save indicators (and sign of op2/op3)
	ldi	=o4000,dl		prevent overflow fault
"
	mvn	(pr),(pr)
	desc9fl	ap|0,61
	desc9ls	ap|16,60,0
	tov	mod1
	ldi	sp|indicators	get sign of op2/op3
	tpl	mod2
	cmpn	(pr),(pr)
	desc9fl	ap|0,61
	desc9ls	ap|16,60,0
	tze	mod2
"
	sb2d	(0),(pr)
	desc9ls	one,2,0
	desc9ls	ap|16,60,0
"
mod2:	mvn	(pr),(pr),round
	desc9ls	ap|16,60,0
	desc9fl	ap|0,61
"
"	compute float temp = op3 * floor(op2/op3)
"
mod1:	mp2d	(pr,id),(pr),round
	arg	bp|2
	desc9fl	ap|0,61
"
"	subtract from op2 to get answer
"
	xec	sb3d,al
	desc9fl	ap|0,61
	arg	bp|1
	arg	bp|0
"
"	free work space and return
"
	eax2	-mod_extension_size
	asx2	sp|stack_frame.next_sp+1
	asx2	sp|stack_header.stack_end_ptr+1,1
	eppap	<pl1_operators_>|[operator_table]
	ldi	sp|indicators
	tra 	sp|tbp,*0
"
sb3d:	sb3d	(pr),(pr,id),(pr,id),round
	sb3d	(pr),(pr,id),(pr,id)
"
setup:
	lda	bp|0	get type of target
	ars	12	""
	ana	1,dl	"
	ldq	bp|1	get length of source
	anq	63,dl	"
	tra	0,1
	end




		    double_arc_sine_.alm            11/11/89  1150.6rew 11/11/89  0805.3      119151



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Bull Inc., 1987                *
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1985 *
" *                                                         *
" ***********************************************************

" HISTORY COMMENTS:
"  1) change(86-07-15,Ginter), approve(86-07-15,MCR7287),
"     audit(86-07-16,Mabey), install(86-07-28,MR12.0-1104):
"     Change by M Mabey (installed by Ginter) to do a dfcmg instead of fcmg
"     when testing for the upper bound on input (bound_4).
"                                                      END HISTORY COMMENTS


name	double_arc_sine_
" Modification history:
"	Written by H. Hoover, M. Mabey, and B. Wong, April 1985,
"	based on the GCOS routine '7nam'.
"
" Function:  Approximate to double precision the arcsine or arccosine of
"	a value in the range [-1:1].
"
"	Modified: May 10, 1985 by M Mabey - do a dfcmg instead of fcmg when
"		testing for the upper bound on input (bound_4).
"
" Entry:	through the appropriately named entry point with:
"	EAQ = a value in the range [-1:1]
"	PR2 = the address of a 20 word, even-word aligned scratch area.
"	      12 words are used in this program and another 8 are allocated
"	      for the double_square_root_ routine.
"	PR3 = the return address.
"
" Exit:	EAQ = the desired angle.
"
" Uses:	X2, X3, X4, PR5
"	X2 = indicates BFP or HFP mode - all the floating point math
"	     routines use this register for the same purpose.
"	X3 = saves a return address from arcsine.
"         X4 = saves a return address from part_arcsine.
"	PR5 = a temporary
"	The X register usage starts at X2 because this function calls
"	double_square_root_ which uses registers X0 through X2. Register
"	X2 is used for the same purpose in both routines.
"
"	Since double_square_root_ expects the return address in PR3,
"	this register must be saved before the call is made.  In addition,
"	double_square_root_ expects PR2 to point to an even-word aligned,
"	8 word long working storage area.

	segdef	double_arc_sine_radians_
	segdef	hfp_double_arc_sine_radians_
	segdef	double_arc_sine_degrees_
	segdef	hfp_double_arc_sine_degrees_
	segdef	double_arc_cosine_radians_
	segdef	hfp_double_arc_cosine_radians_
	segdef	double_arc_cosine_degrees_
	segdef	hfp_double_arc_cosine_degrees_

	segref	math_constants_,half_pi,hfp_half_pi,hfp_one_radian,one_radian,pi,quarter_pi

	equ	abs_x,0
	equ	arg_x,2
	equ	y,4
	equ	yy,6
	equ	q,8
	equ	space_used,10
	equ	qq,q
	equ	temp,abs_x
	equ	x_minus_one,temp
	equ	BFP,0
	equ	HFP,2
	equ	ACOS,0
	equ	ASIN,1

	bool	P1.0H,002040	" yields HFP +1.0 under 'du' modification
	bool	P2.0H,002100	" yields HFP +2.0 under 'du' modification
	bool	P90.0H,004264	" yields HFP +90.0 under 'du' modification

hfp_double_arc_sine_radians_:
	eax2	HFP		" 2 word offset for HFP constants
	tsx3	arcsine
	dfrd	0
	tra	pr3|0		" Return to caller

double_arc_sine_radians_:
	eax2	BFP
	tsx3	arcsine
	dfrd	0
	tra	pr3|0		" Return to caller

hfp_double_arc_sine_degrees_:
	eax2	HFP
	tsx3	arcsine
	dfmp	hfp_one_radian	" Convert to degrees
	dfrd	0
	tra	pr3|0		" Return to caller

double_arc_sine_degrees_:
	eax2	BFP
	tsx3	arcsine
	dfmp	one_radian	" Convert to degrees
	dfrd	0
	tra	pr3|0		" Return to caller

hfp_double_arc_cosine_radians_:
	eax2	HFP

	fcmp	hfp_bound_2	" is the number close to one?
	tmi	hfp_acos_rad_not_near_one
	dfcmg	hfp_bound_4	" is the number greater than one?
	tpnz	arcsine_domain_error
	fsb	P1.0H,du		" EAQ := x - 1
	dfst	pr2|x_minus_one
	fad	P2.0H,du		" EAQ := 1 + x
	fneg	0		" EAQ := -(1 + x)
	dfmp	pr2|x_minus_one	" EAQ := -(1+x)(x-1) = 1+x**2
	epp5	pr3|0		" save return pointer
	tsp3	<double_square_root_>|[hfp_double_square_root_]
	epp3	pr5|0		" restore return pointer
	tsx3	arcsine		" EAQ := asin (sqrt(1+x**2))
	dfrd	0
	tra	pr3|0		" return to caller

hfp_acos_rad_not_near_one:
	tsx3	arcsine
	fneg	0
	dfad	hfp_half_pi	" convert to cosine
	dfrd	0
	tra	pr3|0		" Return to caller

double_arc_cosine_radians_:
	eax2	BFP

	fcmp	bound_2		" is the number close to one?
	tmi	acos_rad_not_near_one
	dfcmg	bound_4		" is the number greater than one?
	tpnz	arcsine_domain_error
	fsb	=1.0,du		" EAQ := x - 1
	dfst	pr2|x_minus_one
	fad	=2.0,du		" EAQ := 1 + x
	fneg	0		" EAQ := -(1 + x)
	dfmp	pr2|x_minus_one	" EAQ := -(1+x)(x-1) = 1+x**2
	epp5	pr3|0		" save return pointer
	tsp3	<double_square_root_>|[double_square_root_]
	epp3	pr5|0		" restore return pointer
	tsx3	arcsine		" EAQ := asin (sqrt(1+x**2))
	dfrd	0
	tra	pr3|0		" return to caller

acos_rad_not_near_one:
	tsx3	arcsine
	fneg	0
	dfad	half_pi		" convert to cosine
	dfrd	0
	tra	pr3|0		" Return to caller

hfp_double_arc_cosine_degrees_:
	eax2	HFP

	fcmp	hfp_bound_2	" is the number close to one?
	tmi	hfp_acos_deg_not_near_one
	dfcmg	hfp_bound_4	" is the number greater than one?
	tpnz	arcsine_domain_error
	fsb	P1.0H,du		" EAQ := x - 1
	dfst	pr2|x_minus_one
	fad	P2.0H,du		" EAQ := 1 + x
	fneg	0		" EAQ := -(1 + x)
	dfmp	pr2|x_minus_one	" EAQ := -(1+x)(x-1) = 1+x**2
	epp5	pr3|0		" save return pointer
	tsp3	<double_square_root_>|[hfp_double_square_root_]
	epp3	pr5|0		" restore return pointer
	tsx3	arcsine		" EAQ := asin (sqrt(1+x**2))
	dfmp	hfp_one_radian	" convert to degrees
	dfrd	0
	tra	pr3|0		" return to caller

hfp_acos_deg_not_near_one:
	tsx3	arcsine
	dfmp	hfp_one_radian	" convert to degrees
	fneg	0
	fad	P90.0H,du		" convert to cosine
	dfrd	0
	tra	pr3|0		" Return to caller

double_arc_cosine_degrees_:
	eax2	BFP

	fcmp	bound_2		" is the number close to one?
	tmi	acos_deg_not_near_one
	dfcmg	bound_4		" is the number greater than one?
	tpnz	arcsine_domain_error
	fsb	=1.0,du		" EAQ := x - 1
	dfst	pr2|x_minus_one
	fad	=2.0,du		" EAQ := 1 + x
	fneg	0		" EAQ := -(1 + x)
	dfmp	pr2|x_minus_one	" EAQ := -(1+x)(x-1) = 1+x**2
	epp5	pr3|0		" save return pointer
	tsp3	<double_square_root_>|[double_square_root_]
	epp3	pr5|0		" restore return pointer
	tsx3	arcsine		" EAQ := asin (sqrt(1+x**2))
	dfmp	one_radian	" convert to degrees
	dfrd	0
	tra	pr3|0		" return to caller

acos_deg_not_near_one:
	tsx3	arcsine
	dfmp	one_radian	" convert to degrees
	fneg	0
	fad	=90.0,du		" convert to cosine
	dfrd	0
	tra	pr3|0		" Return to caller

arcsine:
	fad	=0.0,du		" normalize input ("arg_x")
	dfst	pr2|arg_x		" store sign of arg_x.
	tpl	2,ic		" abs_x=abs(arg_x)
	  fneg	0
	dfst	pr2|abs_x

" determine what range abs_x is in.  A binary search is not used as
" each higher range is much smaller than the previous one.  Once the
" range is determined, perform the appropriate polynomial scaling to
" get abs_x into [0, .5], and then transfer to part_arcsine.
" Upon return, scale the result back.

	fcmg	=0.5,du		" is abs_x in the range [0,.5)
	tpl	above_bound_1	" no, find the correct range
	dfld	pr2|arg_x
	tsx4	part_arcsine
	tra	0,x3		" Return to entry

above_bound_1:
	fcmg	bound_2,x2	" is abs_x in the range [.5, .866)
	tpl	above_bound_2	" no, find correct range
	dfmp	pr2|abs_x		" EAQ = abs_x**2
	fmp	two,x2		" EAQ = 2 * abs_x**2
	fsb	one,x2		" EAQ = 2 * abs_x**2 - 1
	tsx4	part_arcsine
	dfad	half_pi,x2	" EAQ = part_asin + pi/2
	fmp	=0.5,du		" EAQ = .5*part_asin + pi/4
	fszn	pr2|arg_x		" was arg_x negative
	tpl	0,x3		" no, return to entry
	fneg	0		" EAQ = -EAQ
	tra	0,x3		" Return to entry

above_bound_2:
	fcmg	bound_3,x2	" is abs_x in the range [.866, .966)
	tpl	above_bound_3	" no, find correct range
	dfmp	pr2|abs_x		" EAQ = abs_x**2
	dfstr	pr2|temp
	fmp	eight,x2		" EAQ = 8*abs_x**2
	fsb	eight,x2		" EAQ = 8*abs_x**2 - 8
	dfmp	pr2|temp		" EAQ = 8*abs_x**4 - 8*abs_x**2
	fad	one,x2		" EAQ = 8*abs_x**4 - 8*abs_x**2 + 1
	tsx4	part_arcsine
	dfad	three_pi_by_two,x2	" EAQ = part_asin + 3*pi/2
	dfmp	one_quarter,x2	" EAQ = part_asin/4 + 3*pi/8
	fszn	pr2|arg_x		" was arg_x negative
	tpl	0,x3		" no, return to entry
	fneg	0		" EAQ = -EAQ
	tra	0,x3		" return to entry

above_bound_3:
	dfcmg	bound_4,x2	" is abs_x in the range [.966, 1]
	tpnz	arcsine_domain_error
	fmp	=0.5,du		" EAQ = abs_x/2
	fneg	0		" EAQ = - abs_x/2
	fad	=0.5,du		" EAQ = .5 - abs_x/2 or (1-abs_x)/2

	epp5	pr3|0		" save the return address
	epp2	pr2|space_used	" increment PR2 for sqrt
	tsp3	double_square_root,x2
				" call sqrt function
	epp2	pr2|-space_used	" restore PR2
	epp3	pr5|0		" restore PR3
	tsx4	part_arcsine	" EAQ = sqrt ((1 - abs_x)/2)
	fmp	two,x2		" EAQ = 2*part_asin
	fneg	0		" EAQ = - 2*part_asin
	dfad	half_pi,x2	" EAQ = pi/2 - 2*part_asin
	fszn	pr2|arg_x		" was arg_x negative
	tpl	0,x3		" no, return to entry
	fneg	0		" EAQ = -EAQ
	tra	0,x3		" return to entry

" Transfer Table

double_square_root:
	tra	<double_square_root_>|[double_square_root_]
	nop
	tra	<double_square_root_>|[hfp_double_square_root_]


arcsine_domain_error:		" abs_x > 1
	ldq	65,dl
	tsx0	<call_math_error_>|[call_math_error_]
	fld	=0.0,du
	tra	pr3|0		" return to caller

" This next subroutine calculates the arcsine of a value in the
" range [0, .5].

part_arcsine:
	fcmg	formula_bound,x2	" Can we use a short polynomial?
	tmi	small_formula	" Yup.

	dfstr	pr2|y
	dfmp	pr2|y
	dfstr	pr2|yy		" yy = y*y
	dfad	q5,x2		" EAQ = q5+yy
	dfmp	pr2|yy		" EAQ = yy*(q5+yy)
	dfad	q4,x2		" EAQ = q4+yy*(q5+yy)
	dfmp	pr2|yy		" EAQ = yy*(q4+yy*(q5+yy))
	dfad	q3,x2		" EAQ = q3+yy*(q4+yy*(q5+yy))
	dfmp	pr2|yy		" EAQ = yy*(q3+yy*(q4+yy*(q5+yy)))
	dfad	q2,x2		" EAQ = q2+yy*(q3+yy*(q4+yy*(q5+yy)))
	dfmp	pr2|yy		" EAQ = yy*(q2+yy*(q3+yy*(q4+yy*(q5+yy))))
	dfad	q1,x2		" EAQ = q1+yy*(q2+yy*(q3+yy*(q4+yy*(q5+yy))))
	dfmp	pr2|yy		" EAQ = yy*(q1+yy*(q2+yy*(q3+yy*(q4+yy*(q5+yy)))))
	dfad	q0,x2		" EAQ = q0+yy*(q1+yy*(q2+yy*(q3+yy*(q4+yy*(q5+yy)))))
	dfstr	pr2|q
	dfld	pr2|yy
	dfmp	p6,x2		" EAQ = yy*p6
	dfad	p5,x2		" EAQ = p5+yy*p6
	dfmp	pr2|yy		" EAQ = yy*(p5+yy*p6)
	dfad	p4,x2		" EAQ = p4+yy*(p5+yy*p6)
	dfmp	pr2|yy		" EAQ = yy*(p4+yy*(p5+yy*p6))
	dfad	p3,x2		" EAQ = p3+yy*(p4+yy*(p5+yy*p6))
	dfmp	pr2|yy		" EAQ = yy*(p3+yy*(p4+yy*(p5+yy*p6)))
	dfad	p2,x2		" EAQ = p2+yy*(p3+yy*(p4+yy*(p5+yy*p6)))
	dfmp	pr2|yy		" EAQ = yy*(p2+yy*(p3+yy*(p4+yy*(p5+yy*p6))))
	dfad	p1,x2		" EAQ = p1+yy*(p2+yy*(p3+yy*(p4+yy*(p5+yy*p6))))
	dfmp	pr2|yy		" EAQ = yy*(p1+yy*(p2+yy*(p3+yy*(p4+yy*(p5+yy*p6)))))
	dfad	p0,x2		" EAQ = p0+yy*(p1+yy*(p2+yy*(p3+yy*(p4+yy*(p5+yy*p6)))))
	dfmp	pr2|y		" EAQ = y*p
	dfdv	pr2|q		" EAQ = y*p/q
	tra	0,x4		" Return from part_arcsine

small_formula:
	fcmg	epsilon,x2	" Is any calculation necessary?
	tmi	0,x4		" No. Small number. Just return.

	dfstr	pr2|y
	dfmp	pr2|y
	dfstr	pr2|yy		" yy = y*y
	dfad	qq3,x2		" EAQ = qq3+yy
	dfmp	pr2|yy		" EAQ = yy*(qq3+yy)
	dfad	qq2,x2		" EAQ = qq2+yy*(qq3+yy)
	dfmp	pr2|yy		" EAQ = yy*(qq2+yy*(qq3+yy))
	dfad	qq1,x2		" EAQ = qq1+yy*(qq2+yy*(qq3+yy))
	dfmp	pr2|yy		" EAQ = yy*(qq1+yy*(qq2+yy*(qq3+yy)))
	dfad	qq0,x2		" EAQ = qq0+yy*(qq1+yy*(qq2+yy*(qq3+yy)))
	dfstr	pr2|qq
	dfld	pr2|yy		" EAQ = yy
	dfmp	pp3,x2		" EAQ = yy*pp3
	dfad	pp2,x2		" EAQ = pp2+yy*pp3
	dfmp	pr2|yy		" EAQ = yy*(pp2+yy*pp3)
	dfad	pp1,x2		" EAQ = pp1+yy*(pp2+yy*pp3)
	dfmp	pr2|yy		" EAQ = yy*(pp1+yy*(pp2+yy*pp3))
	dfad	pp0,x2		" EAQ = pp0+yy*(pp1+yy*(pp2+yy*pp3))
	dfmp	pr2|y		" EAQ = y*pp
	dfdv	pr2|qq		" EAQ = y*pp/qq
	tra	0,x4		" Return from part_arcsine

" Constants:  (Hex values are given in octal)

	even
p0:	dec	.53849190607669366114d03
	oct	006103237366,616400151323
p1:	dec	-.15568739285411701684d04
	oct	007475310043,070061210252
p2:	dec	.16924399892857508174d04
	oct	006323434121,443221617414
p3:	dec	-.85268159839800034482d03
	oct	007625324301,304347124404
p4:	dec	.19645634637912159609d03
	oct	004610723230,734277152672
p5:	dec	-.17029424630829249399d02
	oct	005735741675,011634416260
p6:	dec	.27091596623264652521d00
	oct	000212552775,356736703045
pp0:	dec	.44005608326359226844d03
	oct	006067003455,571015755233
pp1:	dec	-.67036113799980663993d03
	oct	007654150706,165612763251
pp2:	dec	.28631086818069079154d03
	oct	006043623712,416472674304
pp3:	dec	-.30034170270689843770d02
	oct	005703735004,737634420665
q0:	dec	.53849190607669366114d03
	oct	006103237366,616400151323
q1:	dec	-.16466225795539524453d04
	oct	007462130117,240261166607
q2:	dec	.19264901929223241968d04
	oct	006360637276,510424163636
q3:	dec	-.10743064209874076849d04
	oct	007571554307,144720432455
q4:	dec	.28817015748752908509d03
	oct	006044012707,560730155410
q5:	dec	-.32508459966449899385d02
	oct	005676767254,425030557322
qq0:	dec	.44005608326359226844d03
	oct	006067003455,571015755233
qq1:	dec	-.74370381854373868468d03
	oct	007643022751,214210513617
qq2:	dec	.37725729835987782917d03
	oct	006057120357,116121765360
qq3:	dec	-.56777961133209015623d02
	oct	005616343274,240351671144

bound_2:	dec	.866025404d0
hfp_bound_2:
	oct	000673317272,000000000000	" sin(pi/3)

bound_3:	dec	.965925826d0
	oct	000756433521,000000000000	" sin(5*pi/12)

bound_4:	dec	1.0d0
hfp_bound_4:
	oct	002040000000,000000000000

three_pi_by_two:
	dec 	.471238898038468985787763d01
	oct	002226627617,714620722152
one_quarter:
	dec	0.25d0
	oct	000200000000,000000000000
one:	dec	1.0d0
	oct	002040000000,000000000000
two:	dec	2.0d0
	oct	002100000000,000000000000
eight:	dec	8d0
	oct	002400000000,000000000000
formula_bound:
	dec	0.13052619d0
	oct	000102650520,000000000000
epsilon:	dec	5.7031627d-10
	oct	762116304341,000000000000

	end




		    double_arc_tangent_.alm         11/11/89  1150.6rew 11/11/89  0805.3      101493



" ******************************************
" *                                        *
" * Copyright, (C) Honeywell Limited, 1985 *
" *                                        *
" ******************************************

" HISTORY COMMENTS:
"  1) change(86-07-14,BWong), approve(86-07-14,MCR7413),
"     audit(86-07-16,Ginter), install(86-07-28,MR12.0-1104):
"     Make code more efficient.
"                                                      END HISTORY COMMENTS


name	double_arc_tangent_
" Modification history:
"	Written by H. Hoover, M. Mabey, and B. Wong, April 1985,
"	based on the GCOS routine '7nan'.
"
" Function:  Approximate to double precision the principal value, in radians
"	or degrees, of the arctangent of (x, y) or z where z=x/y for any
"         valid input argument(s).  For atan(z) the answer is in quadrant 1
"	or 4 (-pi/2<=atan<=pi/2, -90<=atan<=90).  For atan(x,y) the answer
"	will be in the correct quadrant (-pi<=atan2<=pi, -180<=atan2<=180).
"
"	Modified: March 18, 1986 by B. Wong - Make code more efficient by
"		replacing 
"
"		  range_0_to_1:	fcmg	tan_pi_by_32,x2
"				tmi	range_0
"		  range_1:	tra	calculate_for_range_1_to_7
"		  range_0:
"
"		with
"
"		  range_0_to_1:	fcmg	tan_pi_by_32,x2
"		  range_1:	tpl	calculate_for_range_1_to_7
"		  range_0:
"
" Entry:	through the appropriately named entry point with:
" 	EAQ = the first argument (z or x).
"	PR1 = the address of the second argument (y).
"	PR2 = the address of a 14 word, even-word aligned scratch area.
"	PR3 = the return address.
"
" Exit:	EAQ = the desired arctangent in radians or degrees.
"
" Uses:	X0, X1, X2, X3, X4
"	X0 = saves a return address from arctan
"	X1 = saves a return address from arctan2
"	X2 = indicates BFP or HFP mode - all the floating point math
"	     routines use this register for the same purpose.
"	X3 = saves a return address from part_arctan
"	X4 = index to tables


	segref	math_constants_,half_pi,hfp_one_radian,one_radian,pi

	equ	BFP,0
	equ	HFP,2
	equ	z,0
	equ	zz,2
	equ	arctan_z,4
	equ	x,6
	equ	y,8
	equ	indicators,10
	equ	abs_z_minus_u,12

	segdef	double_arc_tan_degrees_,double_arc_tangent_degrees_
	segdef	double_arc_tan_degrees_2_,double_arc_tangent_degrees_2_
	segdef	double_arc_tan_radians_,double_arc_tangent_radians_
	segdef	double_arc_tan_radians_2_,double_arc_tangent_radians_2_
	segdef	hfp_double_arc_tan_degrees_
	segdef	hfp_double_arc_tan_degrees_2_
	segdef	hfp_double_arc_tan_radians_
	segdef	hfp_double_arc_tan_radians_2_

double_arc_tangent_degrees_:
double_arc_tan_degrees_:
	eax2      BFP		" no offset for BFP constants
	tsx0      arctan		" EAQ := arctan (x)
	dfmp      one_radian	" convert radians to degrees
	dfrd	0
	tra       pr3|0		" return

double_arc_tangent_degrees_2_:
double_arc_tan_degrees_2_:
	eax2      BFP		" no offset for BFP constants
	tsx1      arctan2		" EAQ := arctan2 (x,y)
	dfmp      one_radian	" convert radians to degrees
	dfrd	0
	tra       pr3|0		" return

double_arc_tangent_radians_:
double_arc_tan_radians_:
	eax2      BFP		" no offset for BFP constants
	tsx0      arctan		" EAQ := arctan (x)
	dfrd	0
	tra       pr3|0		" return

double_arc_tangent_radians_2_:
double_arc_tan_radians_2_:
	eax2      BFP		" no offset for BFP constants
	tsx1      arctan2		" EAQ := arctan2 (x,y)
	dfrd	0
	tra       pr3|0		" return

hfp_double_arc_tan_degrees_:
	eax2      HFP		" 2 word offset for HFP constants
	tsx0      arctan		" EAQ := arctan (x)
	dfmp      hfp_one_radian	" convert radians to degrees
	dfrd	0
	tra       pr3|0		" return

hfp_double_arc_tan_degrees_2_:
	eax2      HFP		" 2 word offset for HFP constants
	tsx1      arctan2		" EAQ := arctan2 (x,y)
	dfmp      hfp_one_radian	" convert radians to degrees
	dfrd	0
	tra       pr3|0		" return

hfp_double_arc_tan_radians_:
	eax2      HFP		" 2 word offset for HFP constants
	tsx0      arctan		" EAQ := arctan (x)
	dfrd	0
	tra       pr3|0		" return

hfp_double_arc_tan_radians_2_:
	eax2      HFP		" 2 word offset for HFP constants
	tsx1      arctan2		" EAQ := arctan2 (x,y)
	dfrd	0
	tra       pr3|0		" return

arctan:
	fad	=0.0,du		" normalize input and set indicators
	dfst	pr2|arctan_z	" store argument z

" Find which of the 9 ranges abs(z) lies in using a binary search.

" Set X4 as the range indicator.  X4 is set to X4+4*(range-1) since double
" precision tables with decimal BFP and octal HFP values are used.

	eax4	0,x2		" initialize the table index with BFP or HFP offset

	fcmg	tan_7_pi_by_32,x2
	tmi	range_0_to_3

	fcmg	tan_13_pi_by_32,x2
	tmi	range_4_to_6

	fcmg	tan_15_pi_by_32,x2
	tmi	range_7

range_8:
				" range = 8, abs (z) >= tan_15_pi_by_32
	dfcmg	eps1,x2
	tmi	3,ic		" if abs (z) < 1e71b:
	  dfld	half_pi,x2	"   EAQ := radians = half_pi
	  tra	set_to_quadrant_1_or_4
				" else:
	fad	=0.0,du
	tpl	2,ic
	  fneg	0		"   EAQ := abs (z)
	dfdi	=-1.0d0		"   EAQ := -1/abs_z
	tsx3	part_arctan	"   calculate part_arctan (-1/abs_z)
				"     which is equivalent to - (part_arctan (1/abs_z))
	dfad	half_pi,x2	"   EAQ := radians = half_pi - part_arctan (1/abs_z)
	tra	set_to_quadrant_1_or_4

range_7:
	adx4	=24,du		" range = 7, tan_13_pi_by_32 <= abs (z) < tan_15_pi_by_32
	tra	calculate_for_range_1_to_7

range_4_to_6:
	fcmg	tan_11_pi_by_32,x2
	tmi	range_4_to_5

range_6:
	adx4	=20,du		" range = 6, tan_11_pi_by_32 <= abs (z) < tan_13_pi_by_32
	tra	calculate_for_range_1_to_7

range_4_to_5:
	fcmg	tan_9_pi_by_32,x2
	tmi	range_4

range_5:
	adx4	=16,du		" range = 5, tan_9_pi_by_32 <= abs (z) < tan_11_pi_by_32
	tra	calculate_for_range_1_to_7

range_4:
	adx4	=12,du		" range = 4, tan_7_pi_by_32 <= abs (z) < tan_9_pi_by_32
	tra	calculate_for_range_1_to_7

range_0_to_3:
	fcmg	tan_3_pi_by_32,x2
	tmi	range_0_to_1

	fcmg	tan_5_pi_by_32,x2
	tmi	range_2

range_3:
	adx4	=8,du		" range = 3, tan_5_pi_by_32 <= abs (z) < tan_7_pi_by_32
	tra	calculate_for_range_1_to_7

range_2:
	adx4	=4,du		" range = 2, tan_3_pi_by_32 <= abs (z) < tan_5_pi_by_32
	tra	calculate_for_range_1_to_7

range_0_to_1:
	fcmg	tan_pi_by_32,x2

range_1:
				" range = 1, tan_pi_by_32 <= abs (z) < tan_3_pi_by_32
	tpl	calculate_for_range_1_to_7

range_0:
				" range = 0, abs (z) < tan_pi_by_32
	fad	=0.0,du
	tpl	2,ic
	  fneg	0		" EAQ := abs (z)
	tsx3	part_arctan	" EAQ := part_arctan (abs_z)
	tra	set_to_quadrant_1_or_4

calculate_for_range_1_to_7:
	fad	=0.0,du
	tpl	2,ic
	  fneg	0		" EAQ := abs (z)

	dfsb	u,x4		" EAQ := abs_z - u(range)
	dfst	pr2|abs_z_minus_u
	dfad	u,x4		" EAQ := abs_z
	dfmp	u,x4		" EAQ := abs_z * u(range)
	fad	one,x2		" EAQ := 1 + abs_z*u(range)
	dfdi	pr2|abs_z_minus_u	" EAQ := t

	tsx3	part_arctan	" EAQ := part_arctan (t)
	dfad	arctan_of_u,x4	" EAQ := radians = part_arctan (t) + arctan(u(range))

set_to_quadrant_1_or_4:
	fszn	pr2|arctan_z	" set indicators
	tpl	0,x0		" if z >= 0 then return (radians)
	  fneg	0		" else return (-radians)
	  tra	0,x0

part_arctan:
				" EAQ contains z arg
	fcmg	eps2,x2		" if abs (z) < 5.7031627e10
	tmi	0,x3		" then return (z)

	dfstr	pr2|z
	dfmp	pr2|z		" calculate zz = z*z
	dfstr	pr2|zz
	dfmp	p7,x2		" calculate p(zz)
	dfad	p6,x2
	dfmp	pr2|zz
	dfad	p5,x2
	dfmp	pr2|zz
	dfad	p4,x2
	dfmp	pr2|zz
	dfad	p3,x2
	dfmp	pr2|zz
	dfad	p2,x2
	dfmp	pr2|zz
	dfad	p1,x2
	dfmp	pr2|zz
	dfad	one,x2
	dfmp	pr2|z		" calculate z*p(zz)
	tra	0,x3		" return

arctan2:
	fad	=0.0,du		" normalize x
	dfst	pr2|x		" save normalized x for quadrant check
	dfld	pr1|0		" load y
	fad	=0.0,du		" normalize y
	dfst	pr2|y		" save normalized y for quadrant check
	tnz	y_not_zero
	fszn	pr2|x		" test if x = 0 also
	tze	arctan2_domain_err	" 0/0 is error
	dfld	half_pi,x2	" atan(x/0) =  + or - (half_pi)
	fszn	pr2|x
	tpl	0,x1		" if x >= 0 then return (radians)
	  fneg	0		" else return (-radians)
	  tra	0,x1


y_not_zero:
	sti	pr2|indicators	" save indicators
	ldi	no_overflow,x2
	dfdi	pr2|x		" EAQ := x/y
	teo	quotient_too_large	" if overflow, atan(x,y) = pi/2 or -pi/2
	teu	quotient_too_small	" if underflow, atan(x,y) = 0
	ldi	pr2|indicators	" restore previous indicators
	fad	=0.0,du		" set indicators
	tpl	2,ic		" calculate z = abs (x,y)
	  fneg	0
	tsx0	arctan		" EAQ := arctan(z)

set_quadrant:
	fszn	pr2|y		" set the quadrant
	tpl	3,ic		" if y < 0 then
	  fneg	0		"   radians = pi-radians
	  dfad	pi,x2
	fszn	pr2|x
	tpl	0,x1		" if x >= 0 then return (radians)
	  fneg	0		" else return (-radians)
	  tra	0,x1

				" error when x=0 and y=0
arctan2_domain_err:
	ldq	24,dl
	tsx0	<call_math_error_>|[call_math_error_]
	fld	=0.0,du
	tra	pr3|0		" return to caller

quotient_too_small:
	ldi	pr2|indicators	" restore indicators
	fld	=0.0,du		" radians = 0.0
	tra	set_quadrant

quotient_too_large:
	ldi	pr2|indicators	" restore indicators
	dfld	half_pi,x2	" radians = half_pi
	tra	set_quadrant

	even

eps1:	oct	220400000000,000000000000	" 2**71 = 2.36e21
	oct	044400000000,000000000000
eps2:	dec	5.7031627d-10
	oct	762116304341,000000000000
no_overflow:
	oct	000000004000,000000000000	" bit 25 is the overflow mask
	oct	000000004010,000000000000	" bit 33 is the hex indicator

" This is the table of ranges.

tan_pi_by_32:
	dec	.98491403d-1		" tan(pi/32)
	oct	000062332734,000000000000
tan_3_pi_by_32:
	dec	.30334668d00		" tan(3*pi/32)
	oct	000233240406,000000000000
tan_5_pi_by_32:
	dec	.53451114d00		" tan(5*pi/32)
	oct	000421526707,000000000000
tan_7_pi_by_32:
	dec	.82067879d00		" tan(7*pi/32)
	oct	000644140013,000000000000
tan_9_pi_by_32:
	dec	1.2185035d00		" tan(9*pi/32)
	oct	002046773754,000000000000
tan_11_pi_by_32:
	dec	1.8708684d00		" tan(11*pi/32)
	oct	002073674236,000000000000
tan_13_pi_by_32:
	dec	3.2965582d00		" tan(13*pi/32)
	oct	002151372636,000000000000
tan_15_pi_by_32:
	dec	10.153170d00		" tan(15*pi/32)
	oct	002504715423,000000000000

" This table is values of u, where u(i)=...

u:	dec	1.98912367379658006912d-01    " tan(pi/16)
	oct	000145657536,012514254010
	dec	4.14213562373095048802d-01	" tan(2*pi/16)
	oct	000324047463,177167462204
	dec	6.68178637919298919998d-01	" tan(3*pi/16)
	oct	000526067012,533771440573
	dec	1.0d0			" tan(4*pi/16)
	oct	002040000000,000000000000
	dec	1.49660576266548901760d00	" tan(5*pi/16)
	oct	002057710307,045516430250
	dec	2.41421356237309504880d00	" tan(6*pi/16)
	oct	002115202363,147747363110
	dec	5.02733949212584810451d00	" tan(7*pi/16)
	oct	002240677734,220443561021

" This table is values of arctan(u(i)).

arctan_of_u:
	dec	.19634954084936207740d00	" pi/16
	oct	000144417665,210413214107
	dec	.39269908169872415481d00	" 2*pi/16
	oct	000311037552,421026430215
	dec	.58904862254808623221d00	" 3*pi/16
	oct	000455457437,631441644324
	dec	.78539816339744830962d00	" 4*pi/16
	oct	000622077325,042055060432
	dec	.98174770424681038702d00	" 5*pi/16
	oct	000766517212,252470274541
	dec	1.17809724509617246442d00	" 6*pi/16
	oct	002045545743,763144164432
	dec	1.37444678594553454182d00	" 7*pi/16
	oct	002053766737,233564735237

" These constants are used to approximate atan over the range [0,tan(pi/32)].

one:      dec	1.0d0
	oct	002040000000,000000000000
p1:	dec	-.33333333333333333154d00
	oct	001525252525,252525252546
p2:	dec	+.19999999999999612046d00
	oct	000146314631,463146206723
p3:	dec	-.14285714285394000547d00
	oct	001666666666,667047430233
p4:	dec	+.1111111098121285609d00
	oct	000070707070,555661001627
p5:	dec	-.9090880462996335d-01
	oct	001721350632,623104337257
p6:	dec	+.76888077127566d-01
	oct	000047273577,013343060615
p7:	dec	-.64430854376d-01
	oct	001737005655,071501356653

	end




		    double_exponential_.alm         11/11/89  1150.6rew 11/11/89  0804.2       54378



" ******************************************
" *                                        *
" * Copyright, (C) Honeywell Limited, 1985 *
" *                                        *
" ******************************************
	name	double_exponential_
" Modification history:
"	Written by H. Hoover, M. Mabey, and B. Wong, April 1985,
"	based on GCOS routine '7naq'.
"
" Function:  Calculates the exponential function 'e**x' to double precision
"	accuracy in either BFP or HFP mode.
"
" Entry:	through the appropriately named entry point with:
" 	EAQ = the argument x.
"	PR2 = the address of a 8 word, even-word aligned scratch area.
"	PR3 = the return address.
"
" Exit:	EAQ = the desired exponential
"
" Uses:	X0, X1, X2
"	X0 = saves a return address from part_exp2
"	X1 = index to the table 'two_to_the'
"	X2 = indicates BFP or HFP mode - all the floating point math
"	     routines use this register for the same purpose.

	segref	math_constants_,almost_one,hfp_almost_one,log_2_of_e,max_value

	equ	BFP,0
	equ	HFP,2
	equ	iy,0
	equ 	four_ry,2
	equ 	z,2
	equ	zz,4
	equ 	p,2
	equ	q_minus_p,6
	equ	result,6
	equ	x,0

	bool	bfp_exponent_of_log2_of_e,002000
	bool	hfp_exponent_of_log16_of_e,000000
	bool	M0.5H,001400	" yields HFP -0.5 under 'du' modification
	bool	P1.0H,002040	" yields HFP +1.0 under 'du' modification
	bool	P2.0H,002100	" yields HFP +2.0 under 'du' modification

	segdef	double_exponential_,hfp_double_exponential_


double_exponential_:
	eax2	BFP		" 2 word offset for BFP constants
	dfcmp	lb		" if x <= -89.4159862922329449148:
	tpnz	3,ic
	   fld	   =0.0,du	"    result = 0
	   tra	   pr3|0		"    return
	dfcmp	ub		" if x >= 88.0296919311130543 goto overflow_error
	tpl	overflow_error
	dfst	pr2|x
	ldaq	bfp_mantissa_of_log2_of_e
	lde	bfp_exponent_of_log2_of_e,du
	dfmp	pr2|x
	
	fad	=1.0,du		" EAQ := y + 1

	ufa	=7b25,du		" AQ := 8/floor(y+1),64/fraction part of y
	sta	pr2|iy
	ora	=o776000,du	" AQ := 8/-1,64/fraction part of y
	lde	=7b25,du		" EAQ := ry = unnormalized y - floor(y+1)
	fad	=0.0,du		" EAQ := ry = normalized y - floor(y+1)

	dfcmp	=-0.5d0
	tmi	3,ic		" if ry >= -0.5
	   tsx0	   part_exp2	"    then result = part_exp2 (ry)

	tra	4,ic		" else
	   fad	   =1.0,du	"    EAQ := ry + 1
	   tsx0	   part_exp2	"    EAQ := part_exp2 (ry + 1)
	   fmp	   =0.5,du	"    result = 0.5*part_exp2 (ry + 1)

	ade	pr2|iy		" addr (result) -> expon = addr (result) -> expon + iy
	tra	pr3|0		" return result in EAQ


hfp_double_exponential_:
	eax2	HFP		" 2 word offset for HFP constants
	dfcmp	hfp_lb		" if x <= -357.663945168931779659:
	tpnz	3,ic
	   fld	   =0.0,du	"    result = 0
	   tra	   pr3|0		"    return
	dfcmp	hfp_ub		" if x >= 352.1187677244522171839 goto overflow_error
	tpl	overflow_error
	dfcmg	hfp_eps		" if abs (x) < 1.08420217248550443e-19:
	tpl	3,ic
	   fld	   P1.0H,du	"   result = 1.0
	   tra	   pr3|0		"   return
	dfst	pr2|x
	ldaq	hfp_mantissa_of_log16_of_e
	lde	hfp_exponent_of_log16_of_e,du
	dfmp	pr2|x
	fad	P1.0H,du		" EAQ := y + 1

	fmp	P2.0H,du
	ufa	=2b25,du		" AQ := 8/floor(y+1),64/fraction part of y
	sta	pr2|iy
	ora	=o776000,du	" AQ := 8/-1,64/fraction part of y
	lde	=2b25,du		" EAQ := unnormalized 2*(y - floor(y+1))
	fad	=0.0,du		" EAQ := 2*(y - floor(y+1))
	fmp	P2.0H,du		" EAQ := 4*(y - floor(y+1))

	dfst	pr2|four_ry
	fad	=0.5,du		" EAQ := 4 * ry + 0.5

" The next four instructions truncate a floating point number in the EAQ 
" to an integer in the AQ in effect calculating s = floor (4 * ry + 0.5).

	dufa	hfp_almost_one
 	dufs	hfp_almost_one
	ufm	P2.0H,du
	ufa	=18b25,du		" AQ := s = floor (4*ry + 0.5)

	eax1	0,ql		" X2 := s = floor (4*ry + 0.5)

" The next two instructions will convert the current representation of s
" to a floating point representation.

	fad	=0.0,du
	fmp	M0.5H,du		" EAQ := -(s)

	dfad	pr2|four_ry	" EAQ := 4*ry - s

	tsx0	part_exp2		" result = part_exp2 (4*ry -s)
	
	fmp	two_to_the,x1	" result = two_to_the (s) * part_exp2 (4*ry - s)
	ade	pr2|iy		" addr (result) -> expon = addr (result) -> expon + iy
	tra	pr3|0		" return result in EAQ


"  The function part_exp2 calculates 2**z, given z in the range [-0.5, 0.5)
"  in the EAQ.

part_exp2:
	fad	=0.0,du		" normalize z
	fcmg	eps,x2
	tpl	3,ic		" if abs (z) < 1.56417309e-19:
	   fld	   one,x2		"    result = 1.0
	   tra	   0,x0		"    return

	dfstr	pr2|z
	dfmp	pr2|z		" zz = z*z
	dfstr	pr2|zz

	dfmp	p2,x2		" calculate p = z*(p0 + zz*(p1 + zz*p2))
	dfad	p1,x2
	dfmp	pr2|zz
	dfad	p0,x2
	dfmp	pr2|z
	dfstr	pr2|p

	dfld	pr2|zz		" calculate q = q0 + zz*(q1 + zz*(q2 + zz))
	dfad	q2,x2
	dfmp	pr2|zz
	dfad	q1,x2
	dfmp	pr2|zz
	dfad	q0,x2

	dfsb	pr2|p		" calculate q - p
	dfstr	pr2|q_minus_p
	dfad	pr2|p		" restore q
	dfad	pr2|p		" calculate q + p
	dfdv	pr2|q_minus_p	" calculate result = (q + p) / (q - p)

	tra	0,x0		" return to caller	


overflow_error:
	dfld	max_value
	dfad	max_value		" cause an overflow
	dfld	max_value
	tra	pr3|0		" return to caller

	even

eps:	dec	1.56417309d-19
	oct	742134252166,000000000000
hfp_eps:	oct	742100000427,165257035710	" 1.0842202172485504434d-19
bfp_mantissa_of_log2_of_e:
          oct	270524354512,701376056737
hfp_mantissa_of_log16_of_e:
	oct	134252166245,340577027370
one:	dec	1.0d0
	oct	002040000000,000000000000
p0:	dec	2.0803843466946630014d6
	oct	014077372002,614037317645
p1:	dec	3.0286971697440362990d4
	oct	010354473706,022472775644
p2:	dec	6.0614853300610808416d1
	oct	004171165470,152076602243
q0:	dec	6.0027203602388325282d6
	oct	014267140402,703423455073
q1:	dec	3.2772515180829144230d5
	oct	012240013223,334720774015
q2:	dec	1.7492876890930764038d3
	oct	006332522322,776034267264
ub:	dec	8.80296919311130543d01	" 2**127 - 2**64 = e**88.0296919311130543
lb:	dec	-8.94159862922329449148d01	" 2**(-129) = e**-89.4159862922329449148
hfp_lb:	oct	007723225403,660372147166	" 16**(-129) = e**-357.663945168931779659
hfp_ub:	oct	006054007463,617610536654	" 16**127 - 16**64 = e**352.1187677244522171839

" Table of two_to_the
	oct	000040000000		" 0.0625
	oct	000100000000		" 0.125
	oct	000200000000		" 0.25
	oct	000400000000		" 0.5
two_to_the:
	oct	002040000000		" 1.0

	end




		    double_logarithm_.alm           11/11/89  1150.6rew 11/11/89  0805.3       59220



" ******************************************
" *                                        *
" * Copyright, (C) Honeywell Limited, 1985 *
" *                                        *
" ******************************************
	name	double_logarithm_
" Modification history:
"	Written by H. Hoover, M. Mabey, and B. Wong, April 1985,
"	based on GCOS routine '7nar'.
"
" Function:  Calculates the logarithm functions log_base_e(x), log_base_2(x),
"	and log_base_10(x) to double precision accuracy in either BFP or
"	HFP mode.
"
" Entry:	through the appropriately named entry point with:
" 	EAQ = the argument x.
"	PR2 = the address of a 16 word, even-word aligned scratch area.
"	PR3 = the return address.
"
" Exit:	EAQ = the desired logarithm
"
" Uses:	X0, X1, X2, X3
"	X0 = saves a return address from call_math_error_
"	     or saves a return address from log2
"	X1 = saves a return address from part_log2_of_ratio
"	X2 = indicates BFP or HFP mode - all the floating point math
"	     routines use this register for the same purpose.
"	X3 = address of second argument for part_log2_of_ratio

	segref	math_constants_,hfp_log_10_of_2,hfp_log_e_of_2,log_10_of_2,log_e_of_2,max_value

	equ	BFP,0
	equ	HFP,2
	equ	xe,0
	equ	xm,2
	equ	bias,4
	equ	shift,6
	equ	x_plus_y,8
	equ	z,10
	equ	zz,12
	equ	zp,14

	segdef	double_log_base_10_,hfp_double_log_base_10_
	segdef	double_log_base_2_,hfp_double_log_base_2_
	segdef	double_log_base_e_,hfp_double_log_base_e_


double_log_base_10_:
	tsx0	log2		" calculate log2 (x)
	dfmp	log_10_of_2	" EAQ := log_10_of_2 * log2 (x)
	dfrd	0
	tra	pr3|0		" return to caller

double_log_base_2_:
	tsx0	log2		" calculate log2 (x)
	dfrd	0
	tra	pr3|0		" return to caller

double_log_base_e_:
	tsx0	log2		" calculate log2 (x)
	dfmp	log_e_of_2	" EAQ := log_e_of_2 * log2 (x)
	dfrd	0
	tra	pr3|0		" return to caller

hfp_double_log_base_10_:
	tsx0	hfp_log2		" calculate log2 (x)
	dfmp	hfp_log_10_of_2	" EAQ := hfp_log_10_of_2 * log2 (x)
	dfrd	0
	tra	pr3|0		" return to caller

hfp_double_log_base_2_:
	tsx0	hfp_log2		" calculate log2 (x)
	dfrd	0
	tra	pr3|0		" return to caller

hfp_double_log_base_e_:
	tsx0	hfp_log2		" calculate log2 (x)
	dfmp	hfp_log_e_of_2	" EAQ := hfp_log_e_of_2 * log2 (x)
	dfrd	0
	tra	pr3|0		" return to caller

log_of_negative:
	ldq	21,dl
	tsx0	<call_math_error_>|[call_math_error_]
	dfld	max_value
	fneg	0
	tra	pr3|0

log_of_zero:
	ldq	20,dl
	tsx0	<call_math_error_>|[call_math_error_]
	dfld	max_value
	fneg	0
	tra	pr3|0

log2:
	eax2	BFP		" no offset for BFP constants
	fad	=0.0,du		" normalize input and set indicators
	tmi	log_of_negative
	tze	log_of_zero

	dfcmp	square_root_two	" check for x in the range [.707,1.414]
	tpl	6,ic
	  dfcmp	square_root_half
	  tmi	4,ic		" if square_root_half >= x & x <= square_root_two
	    eax3	one		"   X3 := addr (1.0)
	    eax1	0,x0		"   copy return address
	    tra	part_log2_of_ratio	"   result = part_log2_of_ratio (x, 1)
				" else
	ste	pr2|xe		"   store addr (x) -> expon in xe 
	lde	=0,du		"   addr (xm) -> expon = 0
	dfst	pr2|xm
	lda	pr2|xe		"   A := 8/xe,10/0,18/garbage
	lrs	72-18		"   AQ := 62/xe,10/0
	lde	=61b25,du		"   EAQ := unnormalized float(xe)
	fsb	=0.5,du		"   EAQ := float(xe) - 0.5
	fst	pr2|bias
	dfld	pr2|xm
	eax3	square_root_half	"   X3 := addr (square_root_half)
	tsx1	part_log2_of_ratio	"   EAQ := part_log2_of_ratio (x, square_root_half)
          fad       pr2|bias            "   EAQ := part_log2_of_ratio (x, square_root_half) + bias  (= log2(x))
	tra	0,x0		"   return result


hfp_log2:
	eax2	HFP		" 2 word offset for HFP constants
	fad	=0.0,du		" normalize input and set indicators
	tmi	log_of_negative
	tze	log_of_zero

	dfcmp	hfp_square_root_two	" check for x in the range [.707,1.414]
	tpl	6,ic
	  dfcmp	hfp_square_root_half
	  tmi	4,ic		" if square_root_half >= x & x <= square_root_two
	    eax3	hfp_one		"   X3 := addr (1.0)
	    eax1	0,x0		"   copy return address
	    tra	part_log2_of_ratio
				"   result = part_log2_of_ratio (x, 1)
				" else
	ste	pr2|xe		"   store addr (x) -> expon in xe
	lde	=0,du		"   addr (xm) -> expon = 0
				"   EAQ := xm
	stz	pr2|shift		"   shift := 0

	even
do_while:				"   do while (xm < 0.5)
	dfcmp	=0.5d0
	tpl	end_do_while
	lls	1		"      xm = 2*xm
          aos	pr2|shift		"      shift := shift + 1
	tra	do_while		"   end do_while
end_do_while:

	dfst	pr2|xm
	lda	pr2|xe		"   A := 8/xe,10/0,18/garbage
	lrs	36-10		"   AQ := 36/4*xe,8/0,28/garbage
	sba	pr2|shift		"   AQ := 36/4*xe-shift,8/0,28/garbage
	lrs	29		"   AQ := 65/4*xe-shift,7/0
	lde	=16b25,du		"   EAQ := unnormalized float(4*xe-shift)
	fsb	=0.5,du		"   EAQ := float(4*xe-shift)-0.5
	fst	pr2|bias
	dfld	pr2|xm
	eax3	hfp_square_root_half
				"   X3 := addr (square_root_half)
	tsx1	part_log2_of_ratio
				"   EAQ := part_log2_of_ratio (x, square_root_half)
	fad	pr2|bias		"   EAQ := part_log2_of_ratio (x, square_root_half) + bias
	tra	0,x0		"   return result


" part_log2_of_ratio (x, y) calculates log2(x/y), where x/y is in the
" range [0.5*2**0.5, 2**0.5], given x in the EAQ and the address of y in X3.

part_log2_of_ratio:

	dfad	0,x3		" EAQ := x + y
	dfst	pr2|x_plus_y
	dfsb	0,x3		" EAQ := x
	dfsb	0,x3		" EAQ := x - y
	dfdv	pr2|x_plus_y	" calculate z = (x - y) / (x + y)
	fcmg	eps,x2
	tpnz	4,ic		" if abs(z) < 1.27420168d-11
	  dfmp	p0,x2		"   EAQ = z * p0
	  dfdv	q0,x2		"   EAQ = z * p0 / q0
	  tra	0,x1		"   return to caller
	dfstr	pr2|z
	dfmp	pr2|z		" calculate zz = z*z
	dfstr	pr2|zz		" calculate p(zz)
	dfmp	p3,x2
	dfad	p2,x2
	dfmp	pr2|zz
	dfad	p1,x2
	dfmp	pr2|zz
	dfad	p0,x2
	dfmp	pr2|z		" calculate z*p(zz)
	dfstr	pr2|zp
	dfld	pr2|zz		" calculate q(zz)
	dfad	q3,x2
	dfmp	pr2|zz
	dfad	q2,x2
	dfmp	pr2|zz
	dfad	q1,x2
	dfmp	pr2|zz
	dfad	q0,x2
	dfdi	pr2|zp		" calculate z*p(zz)/q(zz)

	tra	0,x1		" return to caller

	even
eps:	dec	1.27420168d-11
	oct	756700243611,000000000000
one:	dec	1.0d0
hfp_one:	oct	002040000000,000000000000
p0:	dec	.51390458864923992069d03
	oct	006100171711,437121505724
p1:	dec	-.79210250577344319906d03
	oct	007634771341,056376644076
p2:	dec	.34070763364903118663d03
	oct	006052455223,572450215316
p3:	dec	-.35419160305337449948d02
	oct	005671122617,220231325351
q0:	dec	.17810575834951956203d03
	oct	004544154227,652616712022
q1:	dec	-.33389039541217149928d03
	oct	007726207007,413660334102
q2:	dec	.19375591463035879517d03
	oct	004603406034,760376537401
q3:	dec	-.35526251110400238735d02
	oct	005670745074,667153071771
square_root_half:
	dec	7.071067811865475244008d-01
hfp_square_root_half:
	oct	000552023631,477473631102
square_root_two:
	dec	1.414213562373095048801d+00
hfp_square_root_two:
	oct	002055202363,147747363110

	end




		    double_principal_angle_.alm     11/11/89  1150.6rew 11/11/89  0805.3       62811



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Bull Inc., 1987                *
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1985 *
" *                                                         *
" ***********************************************************
	name	double_principal_angle_
" Modification history:
"	Written by H. Hoover, M. Mabey and B. Wong, April 1985.
"
" Function:  Scale an angle into the range -pi/4 to pi/4.
"
" Entry:  through the appropriately named entry point with:
"	EAQ = input angle to be scaled.
"	X0  = the return address.
"	X2  = a two word offset for HFP constants - this register is used
"	      by all of the floting point math_routines for the same thing.
"	PR2 = points to an even word aligned, 14 word long, scratch area.
"
" Exit:	EAQ = the scaled angle.
"	X1  = mod ((input EAQ)/HALF_PI + 0.5), 4)
"
" Uses:	X1
"	X1  = used to return mod ((input EAQ)/HALF_PI + 0.5), 4)

	segdef	double_principal_degrees_,double_principal_radians_

	segref	math_constants_,pi,half_pi,almost_one

	bool	P2.0H,002100		" yields HFP +2.0 under 'du' modification
	bool	P45.0H,004132		" yields HFP +45.0 under 'du' modification

	equ	angle,0
	equ	temp,angle
	equ	n1,2
	equ	n2,3
	equ	t1,4
	equ	t2,6
	equ	t3,8
	equ	t4,10
	equ	t5,12
	equ	HFP,2


double_principal_degrees_:
	cmpx2	HFP,du
	tze	hfp_principal_degrees

bfp_principal_degrees:
	dfrd	0
	dfcmg	two_pwr_54	" is the EAQ too large
	tpnz	angle_too_big	" Yup.

	dfst	pr2|angle
	dfdv	ninety		" EAQ = EAQ/90
	fad	=0.5,du		" EAQ = EAQ/90 + 0.5
	dufa	almost_one
	dufs	almost_one
	ufa	=71b25,du		" AQ = EAQ/90 + 0.5 in integer form

	eax1	0,ql
	anx1	=3,du		" X1 = mod(AQ,4)

	fad	=0.0,du		" EAQ = floor(EAQ/90 + 0.5) in floating point form
	fmp	=90.0,du		" EAQ = floor(EAQ/90 + 0.5)*90
	fneg	0		" EAQ = -floor(EAQ/90 + 0.5)*90
	dfad	pr2|angle		" EAQ = angle-floor(EAQ/90 + 0.5)*180
	tra	0,x0		" return to caller

hfp_principal_degrees:
	dfrd	0
	dfcmg	hfp_two_pwr_48	" is the EAQ too large
	tpnz	angle_too_big	" Yup.

	dfst	pr2|angle
	dfdv	ninety,x2		" EAQ = EAQ/90
	fad	=0.5,du		" EAQ = EAQ/90 + 0.5
	dufa	almost_one
	dufs	almost_one
	ufm	P2.0H,du
	ufa	=18b25,du		" AQ = EAQ/90 + 0.5

	eax1	0,ql
	anx1	=3,du		" X1 = mod(AQ,4)

	fad	=0.0,du		" EAQ = floor(EAQ/90 + 0.5)*2
	fmp	P45.0H,du		" EAQ = floor(EAQ/90 + 0.5)*90 in floating point form
	fneg	0		" EAQ = -floor(EAQ/90 + 0.5)*90
	dfad	pr2|angle		" EAQ = angle-floor(EAQ/90 + 0.5)*90
	tra	0,x0		" return to caller


double_principal_radians_:
	cmpx2	HFP,du
	tze	hfp_principal_radians

bfp_principal_radians:
	dfrd	0
	dfst	pr2|angle
	dfcmg	two_pwr_27	" is the EAQ too large
	tpnz	bfp_big_angle	" Yup.

	dfmp	one_over_half_pi	" EAQ = EAQ/half_pi
	fad	=0.5,du		" EAQ = EAQ/half_pi + 0.5
	dufa	almost_one
	dufs	almost_one
	ufa	=71b25,du		" AQ = EAQ/half_pi + 0.5 in integer form

	eax1	0,ql
	anx1	=3,du		" X1 = mod(AQ,4)

	fad	=0.0,du		" EAQ = floor(EAQ/half_pi + 0.5) in floating point form
	fst	pr2|n1		" n1 = EAQ
	tra	small_angle_join	" goto common code for HFP and BFP


hfp_principal_radians:
	dfrd	0
	dfst	pr2|angle
	dfcmg	hfp_two_pwr_24	" is the EAQ too large
	tpnz	hfp_big_angle	" Yup.

	dfmp	one_over_half_pi,x2	" EAQ = EAQ/half_pi
	fad	=0.5,du		" EAQ = EAQ/half_pi + 0.5
	dufa	almost_one
	dufs	almost_one
	ufm	P2.0H,du
	ufa	=18b25,du		" AQ = EAQ/half_pi + 0.5 in integer form

	eax1	0,ql
	anx1	=3,du		" X1 = mod(AQ,4)

	fad	=0.0,du		" EAQ = floor(EAQ/half_pi + 0.5)*2
	fmp	=0.5,du		" EAQ = floor(EAQ/half_pi + 0.5) in floating point form
	fst	pr2|n1		" n1 = EAQ

small_angle_join:
	fmp	half_pi1,x2
	dfst	pr2|t1		" t1 = n1*half_pi1

	fld	pr2|n1
	fmp	half_pi2,x2
	dfst	pr2|t2		" t2 = n1*half_pi2

	fld	pr2|n1
	fmp	half_pi3,x2
	dfst	pr2|t3		" t3 = n1*half_pi3

	fld	pr2|n1
	fmp	half_pi4,x2
	dfst	pr2|t4		" t4 = n1*half_pi4

	fld	pr2|n1
	dfmp	half_pi5,x2
	dfst	pr2|t5		" t5 = n1*half_pi5

	dfld	pr2|angle		" answer = angle - t1 - t2 - t3 - t4 - t5
	dfsb	pr2|t1
	dfsb	pr2|t2
	dfsb	pr2|t3
	dfsb	pr2|t4
	dfsb	pr2|t5
	tra	0,x0

hfp_big_angle:
	dfcmg	hfp_two_pwr_48	" is the EAQ too large?
	tpnz	angle_too_big	" Yup.

	dfmp	one_over_half_pi,x2	" EAQ = EAQ/half_pi
	fad	=0.5,du		" EAQ = EAQ/half_pi + 0.5
	dufa	almost_one
	dufs	almost_one
	ufm	P2.0H,du
	ufa	=18b25,du		" AQ = EAQ/half_pi + 0.5 in integer form

	eax1	0,ql
	anx1	=3,du		" X1 = mod(AQ,4)

	fad	=0.0,du		" EAQ = floor(EAQ/half_pi + 0.5)*2
	fmp	=0.5,du		" EAQ = floor(EAQ/half_pi + 0.5) in floating point form
	fst	pr2|n1		" n1 = EAQ
	tra	big_angle_join

bfp_big_angle:
	dfcmg	two_pwr_54	" is the EAQ too large?
	tpnz	angle_too_big	" Yup.

	dfmp	one_over_half_pi	" EAQ = EAQ/half_pi
	fad	=0.5,du		" EAQ = EAQ/half_pi + 0.5
	dufa	almost_one
	dufs	almost_one
	ufa	=71b25,du		" AQ = EAQ/half_pi + 0.5 in integer form

	eax1	0,ql
	anx1	=3,du		" X1 = mod(AQ,4)

	fad	=0.0,du		" EAQ = floor(EAQ/half_pi + 0.5) in floating point form
	fst	pr2|n1		" n1 = EAQ
	
big_angle_join:
	fsb	pr2|n1
	fst	pr2|n2		" n2 = n - n1

	fld	pr2|n1
	fmp	half_pi1,x2
	dfst	pr2|t1		" t1 = n1*half_pi1

	fld	pr2|n1		" calculate n1*half_pi2 + n2*half_pi1
	fmp	half_pi2,x2
	dfst	pr2|t2
	fld	pr2|n2
	fmp	half_pi1,x2
	dfad	pr2|t2
	dfst	pr2|t2		" t2 = (n1*half_pi2 + n2*half_pi1)

	fld	pr2|n1		" calculate n1*half_pi3 + n2*half_pi2
	fmp	half_pi3,x2
	dfst	pr2|t3
	fld	pr2|n2
	fmp	half_pi2,x2
	dfad	pr2|t3
	dfst	pr2|t3		" t3 = (n1*half_pi3 + n2*half_pi2)

	fld	pr2|n1		" calculate n1*half_pi4 + n2*half_pi3
	fmp	half_pi4,x2
	dfst	pr2|t4
	fld	pr2|n2
	fmp	half_pi3,x2
	dfad	pr2|t4
	dfst	pr2|t4		" t4 = (n1*half_pi4 + n2*half_pi3)

	fld	pr2|n1		" calculate n1*half_pi5 + n2*half_pi4
	dfmp	half_pi5,x2
	dfst	pr2|t5
	fld	pr2|n2
	fmp	half_pi4,x2
	dfad	pr2|t5
	dfst	pr2|t5		" t5 = (n1*half_pi5 + n2*half_pi4)

	dfld	pr2|angle		" answer = angle - t1 - t2 - t3 - t4 - t5
	dfsb	pr2|t1
	dfsb	pr2|t2
	dfsb	pr2|t3
	dfsb	pr2|t4
	dfsb	pr2|t5

	tra	0,x0		" return to caller.  The indicators are set.

angle_too_big:
	ldq	code,x2		" load the error code
	stx0	pr2|temp		" save X0
	tsx0	<call_math_error_>|[call_math_error_]
	ldx0	pr2|temp		" restore X0

	eax1	0		" X1 = 0
	fld	=0.0,du		" EAQ = 0, set indicators
	tra	0,x0		" return to caller


" Constants:

	even
ninety:	dec	90.0d0
	oct	004264000000,000000000000
one_over_half_pi:
	dec	6.3661977236758134307553d-1
	oct	000505746033,344710405225
hfp_two_pwr_24:
	oct	016040000000,000000000000
two_pwr_27:
	oct	070400000000,000000000000
hfp_two_pwr_48:
	oct	032040000000,000000000000
two_pwr_54:
	oct	156400000000,000000000000
	oct	034200000000,000000000000
half_pi1:	oct	002622077325,000000000000
	oct	002062207732,000000000000
half_pi2:	oct	706420550604,000000000000
	oct	766050420550,000000000000
half_pi3: oct	616646114314,000000000000
	oct	752060432304,000000000000
half_pi4: oct	526505600670,000000000000
	oct	736061461213,000000000000
half_pi5:	oct	434715045101,000000000000
	oct	722040156034,642244022341
code:	dec	72,0,73

	end




		    double_sine_.alm                11/11/89  1150.6rew 11/11/89  0805.3       56736



" ******************************************
" *                                        *
" * Copyright, (C) Honeywell Limited, 1985 *
" *                                        *
" ******************************************
	name	double_sine_
" Modification history:
"	Written by H. Hoover, M. Mabey, and B. Wong, April 1985,
"	based on the GCOS routine '7nat'.
"
" Function:  Approximate to double precision the sine or cosine of an
"	angle given in degrees or radians.
"
" Entry:	through the appropriately named entry point with:
" 	EAQ = the angle whose sine or cosine is desired.
"	PR2 = the address of a 14 word, even-word aligned scratch area.
"	      4 words are used in this program and 14 are used by the
"	      routine "double_principal_angle_".  The storage for
"	      double_sine_ and double_principal_angle_ overlap.
"	PR3 = the return address.
"
" Exit:	EAQ = the desired sine or cosine.
"
" Uses:	X0, X1, X2.
"	X0 = saves a return address from double_principal_angle_ routines
"	X1 = shift (returned by double_principal_angle_ routines)
"	X2 = indicates BFP or HFP mode - all of the floating point math
"	      math routines use this register for the same thing.
"	The double_principal_angle_ routines use registers X1 and X2.


	segref	math_constants_,half_pi,one_degree,pi
	segref	double_principal_angle_,double_principal_radians_,double_principal_degrees_

	equ	BFP,0
	equ	HFP,2
	equ	x,0
	equ	xx,2

	segdef	double_cosine_degrees_,hfp_double_cosine_degrees_
	segdef	double_cosine_radians_,hfp_double_cosine_radians_
	segdef	double_sine_degrees_,hfp_double_sine_degrees_
	segdef	double_sine_radians_,hfp_double_sine_radians_


hfp_double_cosine_degrees_:
	eax2	HFP		" 2 word offset for HFP constants
	tra	double_cosine_degrees

double_cosine_degrees_:
	eax2	BFP		" no offset for BFP constants

double_cosine_degrees:
	fad	=0.0,du		" normalize input
	dfcmg	one_eighty,x2	" if abs_angle <= 180:
	tmi	case1_degrees	" then no angle reduction is necessary
	tsx0	double_principal_degrees_
	tra	case_degrees+1,x1	" select appropriate case


hfp_double_cosine_radians_:
	eax2	HFP		" 2 word offset for HFP constants
	tra	double_cosine_radians

double_cosine_radians_:
	eax2	BFP		" no offset for BFP constants

double_cosine_radians:
	fad	=0.0,du		" normalize input and set indicators
	dfcmg	pi,x2		" if abs (angle) <= pi
	tmi	case1_radians	" then no angle reduction is necessary
	tsx0	double_principal_radians_
	tra	case_radians+1,x1	" select appropriate case
				

hfp_double_sine_degrees_:
	eax2	HFP		" 2 word offset for HFP constants
	tra	double_sine_degrees

double_sine_degrees_:
	eax2	BFP		" no offset for BFP constants

double_sine_degrees:
	fad	=0.0,du		" normalize input
	dfcmg	ninety,x2		" if abs (angle) < pi/2
	tmi	case0_degrees	" then no angle reduction is necessary
	tsx0	double_principal_degrees_
	tra	case_degrees,x1	" select appropriate case


hfp_double_sine_radians_:
	eax2	HFP		" 2 word offset for HFP constants
	tra	double_sine_radians

double_sine_radians_:
	eax2	BFP		" no offset for BFP constants

double_sine_radians:
	fad	=0.0,du		" normalize input
	dfcmg	half_pi,x2	" if abs (angle) <= pi/2
	tmoz	case0_radians	" then no angle reduction is necessary
	tsx0	double_principal_radians_
	tra	case_radians,x1	" Case select appropriate case_radians

case_radians:
	tra	case0_radians
	tra	case1_radians
	tra	case2_radians
	tra	case3_radians
	tra	case0_radians

case1_radians:
	fad	=0.0,du		" set indicators
	tmi	2,ic		" EAQ = - abs (EAQ)
	  negl	0		" fneg underflows at o400400000000

	dfad	half_pi1,x2
	dfad	half_pi2,x2
	tra	part_sine_radians

case2_radians:
	fneg	0
	tra	part_sine_radians

case3_radians:
	fad	=0.0,du		" set indicators
	tpl	2,ic		" EAQ = abs (EAQ)
	  fneg	0

	dfsb	half_pi1,x2
	dfsb	half_pi2,x2
	tra	part_sine_radians

case_degrees:
	tra	case0_degrees
	tra	case1_degrees
	tra	case2_degrees
	tra	case3_degrees
	tra	case0_degrees

case1_degrees:
	fad	=0.0,du		" set indicators
	tmi	2,ic		" EAQ = - abs (EAQ)
	  negl	0		" fneg underflows at o400400000000

	fad	ninety,x2
	tra	part_sine_degrees

case2_degrees:
	fneg	0
	tra	part_sine_degrees

case3_degrees:
	fad	=0.0,du		" set indicators
	tpl	2,ic		" EAQ = abs (EAQ)
	fneg

	fsb	ninety,x2
"	tra	part_sine_degrees

case0_degrees:			" case0_degrees is just part_sine_degrees

part_sine_degrees:
	dfcmg	eps2,x2		" if conversion to radians underflows
	tpl	2,ic
	  fld	=0.0,du		" then use zero
	dfmp	one_degree,x2	" convert to radians.
"	tra	part_sine_radians

case0_radians:			" case0_radians is just part_sine_radians


" Procedure part_sine (x) calculates 'sin(x)' for 'x' in the range
" [-pi/2, pi/2] given 'x' in the EAQ.

part_sine_radians:
	dfrd	0
	dfcmg	eps3,x2		"if abs (x) < 5e-10:
	tmi	pr3|0		"    sine is x for small x
	dfst	pr2|x
	dfmp	pr2|x		" calculate xx = x*x
	dfstr	pr2|xx
	dfmp	p9,x2		" calculate p(xx)
	dfad	p8,x2
	dfmp	pr2|xx
	dfad	p7,x2
	dfmp	pr2|xx
	dfad	p6,x2
	dfmp	pr2|xx
	dfad	p5,x2
	dfmp	pr2|xx
	dfad	p4,x2
	dfmp	pr2|xx
	dfad	p3,x2
	dfmp	pr2|xx
	dfad	p2,x2
	dfmp	pr2|xx
	dfad	p1,x2
	dfmp	pr2|xx
	fad	p0,x2
	dfmp	pr2|x		" return x*p(xx)
	dfrd	0
	tra	pr3|0


" Constants:

	even
eps1:	dec	1.886591d-8
	oct	764242035115,000000000000
eps2:	dec	8.418858142948452884d-38
	oct	402162456701,514360373670	" 2.670821537926801391d-154
eps3:	dec	5.0d-10
	oct	762104560276,404665512263
half_pi1:	oct	002622077325,042055060432	" 1.570796326794896619d0
	oct	002062207732,504205506043	" 1.570796326794896619d0
half_pi2:	oct	602611431424,270033407150	" 8.333742918520878328d-20
	oct	742461143142,427003340714	" 5.170182981794105568d-19
ninety:	dec	90.0d0
	oct	004264000000,000000000000
one_eighty:
	dec	180.0d0
	oct	004550000000,000000000000
p0:	dec	 9.9999999999999999998d-1	" this rounds to 1.0d0
	oct	002040000000,000000000000
p1:	dec	-1.6666666666666666664d-1
	oct	001652525252,525252525253
p2:	dec	 8.333333333333332952d-3
	oct	776104210421,042104210331
p3:	dec	-1.9841269841269648946d-4
	oct	773137713771,377140131713
p4:	dec	 2.7557319223936401884d-6
	oct	770134357072,252646307133
p5:	dec	-2.5052108378101760587d-8
	oct	765450633523,013112232534
p6:	dec	 1.60590431721336921d-10
	oct	760541110601,052315030325
p7:	dec	-7.647126379076958d-13
	oct	755121402455,333370604367
p8:	dec	 2.8101852815318d-15
	oct	750624773046,213725310300
p9:	dec	-7.9798971356d-18
	oct	745331460002,411662206514

	end




		    double_square_root_.alm         11/11/89  1150.6rew 11/11/89  0805.3       38835



" ******************************************
" *                                        *
" * Copyright, (C) Honeywell Limited, 1985 *
" *                                        *
" ******************************************
	name	double_square_root_
" Modification history:
"	Written by H. Hoover, M. Mabey, and B. Wong, April 1985,
"	based on GCOS routine '7nau'.
"
" Function:  Approximate to double precision the square root of a number.
"
" Entry:	through the appropriately named entry point with:
" 	EAQ = the number whose square root is desired.
"	PR2 = the address of an 8 word, even-word aligned scratch area.
"	PR3 = the return address.
"
" Exit:	EAQ = the desired square root.
"
" Uses:	X0, X1
"	X0 = temporary storage for exponent of input argument
"	     and saves a return address from call_math_error_
"	X1 = index to scale table

	equ	root_m,0
	equ	x,2
	equ	m,4
	equ	e,6

	bool	P4.0H,002200	" yields HFP +4.0 under 'du' modification

	segdef	double_square_root_,hfp_double_square_root_


hfp_double_square_root_:
	fad	=0.0,du		" normalize input arg
	tze	pr3|0		" if x = 0 return (0)
	tpl	hfp_calc_square_root " if x < 0:
	  fneg	0		"   x = -x
	  dfst	pr2|x
	  ldq	22,dl
	  tsx0	<call_math_error_>|[call_math_error_]
	  dfld	pr2|x

hfp_calc_square_root:
	dfst	pr2|x		" store EAQ := input arg
	ldx0	pr2|x		" X0 := addr (x) -> expon
				" m = x
	lde	=0b25,du		" addr (m) -> expon = 0
	eax1	0		" scale = 0.5
	dfcmp	one_quarter
	tpl	3,ic		" if m >= .25:  scale = 0.5
	  eax1	2		"  else:         scale = 0.25
	  fmp	P4.0H,du		"                EAQ := m = 4*m

	canx0	=1b25,du		" calculate mod (e, 2)
	tze	2,ic		" if mod (e, 2) = 1:
	  adx1	=1,du		"   scale = 0.25*scale

	dfst	pr2|m		" store EAQ := m
	ldq	pr2|x		" Q := 8/expon,28/garbage
	qrs	28		" Q := 28/0,8/expon
	adq	=1,dl		" calculate e+1
	qrs	1		" calculate divide (e+1, 2, 7)
	qls	28		" position result in exponent field
	stq	pr2|e		" store Q := e = divide (e+1, 2, 7)
	dfld	pr2|m
	fmp	hfp_p2		" calculate root_m_top = p(m)
	fad	hfp_p1
	fmp	pr2|m
	fad	hfp_p0

	fst	pr2|root_m
	fdi	pr2|m		" calculate root_m = .5 * (root_m_top + m_top/root_m_top)
	fad	pr2|root_m
	fmp	=0.5,du

	dfrd	0
	dfst	pr2|root_m
	dfdi	pr2|m		" calculate root_m = .5 * (root_m + m/root_m)
	dfad	pr2|root_m
	fmp	=0.5,du

	dfrd	0
	dfst	pr2|root_m	" calculate root_m + m/root_m
	dfdi	pr2|m
	dfad	pr2|root_m
	fmp	scale,x1		" root_m = scale * (root_m + float (m, 63)/root_m)
				" root_x = root_m
	ade	pr2|e		" calculate addr (root_x) -> expon =
				"    addr (root_x) -> expon + divide (e+1, 2, 7)
	dfrd	0
	tra	pr3|0		" return (root_x)


double_square_root_:
	fad	=0.0,du		" normalize input arg
	tze	pr3|0		" if x = 0 return (0)
	tpl	calc_square_root	" if x < 0:
	  fneg	0		"   x = -x
	  dfst	pr2|x
	  ldq	22,dl
	  tsx0	<call_math_error_>|[call_math_error_]
	  dfld	pr2|x

calc_square_root:
	dfst	pr2|x		" store EAQ := input arg
	ldx0	pr2|x		" X0 := addr (x) -> expon
				" m = x
	lde	=0b25,du		" addr (m) -> expon = 0

	canx0	=1b25,du		" calculate mod (e, 2)
	tze	2,ic		" if mod (e, 2) = 1:
	  lde	=-1b25,du		"   EAQ := m = .5*m

	dfst	pr2|m		" store EAQ := m
	ldq	pr2|x		" Q := 8/expon,28/garbage
	qrs	28		" Q := 28/0,8/expon
	adq	=1,dl		" calculate e+1
	qrs	1		" calculate divide (e+1, 2, 7)
	qls	28		" position result in exponent field
	stq	pr2|e		" store Q := e = divide (e+1, 2, 7)
	dfld	pr2|m
	fmp	p2		" calculate root_m_top = p(m)
	fad	p1
	fmp	pr2|m
	fad	p0

	fst	pr2|root_m
	fdi	pr2|m		" calculate root_m = .5 * (root_m_top + m_top/root_m_top)
	fad	pr2|root_m
	fmp	=0.5,du

	dfrd	0
	dfst	pr2|root_m
	dfdi	pr2|m		" calculate root_m = .5 * (root_m + m/root_m)
	dfad	pr2|root_m
	fmp	=0.5,du

	dfrd	0
	dfst	pr2|root_m	" calculate root_m + m/root_m
	dfdi	pr2|m
	dfad	pr2|root_m
	ade	=-1b25,du		" root_m = .5 * (root_m + float (m, 63)/root_m)
				" root_x = root_m
	ade	pr2|e		" calculate addr (root_x) -> expon =
				"    addr (root_x) -> expon + divide (e+1, 2, 7)
	dfrd	0
	tra	pr3|0		" return (root_x)

	even
one_quarter:
	oct	000200000000,000000000000	" 0.25
p0:	dec	2.5927688d-1
hfp_p0:	oct	000204577702,000000000000
p1:	dec	1.0521212d0
hfp_p1:	oct	002041525750,000000000000
p2:	dec	-3.1632214d-1
hfp_p2:	oct	001536026031,000000000000
scale:	oct	000400000000	" 0.5
	oct	000100000000	" 0.25*0.5 = 0.125
	oct	000200000000	" 0.25
	oct	000040000000	" 0.25*0.25 = 0.0625

	end




		    double_tangent_.alm             11/11/89  1150.6rew 11/11/89  0805.3       66978



" ******************************************
" *                                        *
" * Copyright, (C) Honeywell Limited, 1985 *
" *                                        *
" ******************************************
	name	double_tangent_
" Modification history:
"	Written by H. Hoover, M. Mabey, and B. Wong, April 1985,
"	based on GCOS routine '7nav'.
"
" Function:  Approximate to double precision the tangent or cotangent of an
"	angle given in degrees or radians.
"
" Entry:	through the appropriately named entry point with:
" 	EAQ = the angle whose tangent is desired.
"	PR2 = the address of a 14 word, even-word aligned scratch area.
"	      6 words are used in this program and 14 are used by the
"	      routine "double_principal_angle_".  The storage for
"	      double_tangent_ and double_principal_angle_ overlap.
"	PR3 = the return address.
"
" Exit:	EAQ = the desired tangent or cotangent.
"
" Uses:	X0, X1, X2, X3.
"	X0 = saves a return address from double_principal_angle_ routines
"	X1 = shift (returned by double_principal_angle_ routines)
"	X2 = indicates BFP or HFP mode - all of the floating point math
"	     routines use this register for the same thing.
"	X3 = indicates Tangent or Cotangent function
"	The double_principal_angle_ routines use registers X1 and X2.


	segref	math_constants_,max_value,one_degree,quarter_pi
	segref	double_principal_angle_,double_principal_radians_,double_principal_degrees_

	equ	BFP,0
	equ	HFP,2
	equ	Cotangent,-1
	equ	Tangent,1
	equ	sign,0
	equ	x,0
	equ	xx,2
	equ	q,4

	segdef	double_cotangent_degrees_,hfp_double_cotangent_degrees_
	segdef	double_cotangent_radians_,hfp_double_cotangent_radians_
	segdef	double_tangent_degrees_,hfp_double_tangent_degrees_
	segdef	double_tangent_radians_,hfp_double_tangent_radians_


hfp_double_cotangent_degrees_:
	eax2	HFP		" 2 word offset for HFP constants
	tra	cotangent_degrees

double_cotangent_degrees_:
	eax2	BFP		" no offset for BFP constants

cotangent_degrees:
	fad	=0.0,du		" normalize input
	eax1	0		" initialize X1 := shift = 1
	dfcmg	forty_five,x2
	tmoz	2,ic		" if abs (angle) > 45:
				"   call double_principal_degrees_
	  tsx0	double_principal_degrees_

	dfcmg	eps1,x2		" if conversion to radians underflows
	tmi	infinity		"   return (infinity (degrees))
				" else:
	dfmp	one_degree,x2	"   EAQ := degrees * one_degree

	canx1	=1,du
	tnz	3,ic		" if shift = 0 | shift = 2:
	  eax3	Cotangent		"   X3 := Cotangent
	  tra	part_tan_or_cot	"   return (part_tan_or_cot (Cotangent, degrees*one_degree))
				" else if shift = 1 | shift = 3
	eax3	Tangent		"   X3 := Cotangent
	fneg	0		"   EAQ := -degrees*one_degree
	tra	part_tan_or_cot	"   return (part_tan_or_cot (Tangent, -(degrees*one_degree)))


hfp_double_cotangent_radians_:
	eax2	HFP		" 2 word offset for HFP constants
	tra	cotangent_radians

double_cotangent_radians_:
	eax2	BFP		" no offset for BFP constants

cotangent_radians:
	fad	=0.0,du		" normalize input
	dfcmg	quarter_pi,x2
	tpl	3,ic		" if abs (angle) > quarter_pi:
	  eax3	Cotangent		"   X3 := Cotangent
	  tra	part_tan_or_cot	"   return (part_tan_or_cot (Cotangent, radians)
				" call double_principal_radians_
	tsx0	double_principal_radians_

	canx1	=1,du
	tnz	3,ic		" if shift = 0 | shift = 2:
	  eax3	Cotangent		"   X3 := Cotangent
	  tra	part_tan_or_cot	"   return (part_tan_or_cot (Cotangent, radians))
				" else if shift = 1 | shift = 3
	eax3	Tangent		"   X3 := Cotangent
	fneg	0		"   EAQ := -radians
	tra	part_tan_or_cot	"   return (part_tan_or_cot (Tangent, -radians))


hfp_double_tangent_degrees_:
	eax2	HFP		" 2 word offset for HFP constants
	tra	tangent_degrees

double_tangent_degrees_:
	eax2	BFP		" no offset for BFP constants

tangent_degrees:
	fad	=0.0,du		" normalize input
	eax1	0		" initialize X1 := shift = 1
	dfcmg	forty_five,x2
	tmoz	2,ic		" if abs (angle) > 45:
				"   call double_principal_degrees_
	  tsx0	double_principal_degrees_

	dfcmg	eps1,x2		" if conversion to radians underflows
	tpl	2,ic
	  fld	=0.0,du	  	"   then use zero
				" else:
	dfmp	one_degree,x2	"   EAQ := degrees * one_degree

	canx1	=1,du
	tnz	3,ic		" if shift = 0 | shift = 2:
	  eax3	Tangent		"   X3 := Tangent
	  tra	part_tan_or_cot	"   return (part_tan_or_cot (Tangent, degrees*one_degree))
				" else if shift = 1 | shift = 3
	eax3	Cotangent		"   X3 := Cotangent
	fneg	0		"   EAQ := -radians
	tra	part_tan_or_cot	"   return (part_tan_or_cot (Cotangent, -(degrees*one_degree)))


hfp_double_tangent_radians_:
	eax2	HFP		" 2 word offset for HFP constants
	tra	tangent_radians

double_tangent_radians_:
	eax2	BFP		" no offset for BFP constants

tangent_radians:
	fad	=0.0,du		" normalize input
	dfcmg	quarter_pi,x2
	tpl	3,ic		" if abs (angle) <= quarter_pi:
	  eax3	Tangent
	  tra	part_tan_or_cot	"   return (part_tan_or_cot (Tangent, radians))

				" call double_principal_radians_
	tsx0	double_principal_radians_

	canx1	=1,du
	tnz	3,ic		" if shift = 0 | shift = 2:
	  eax3	Tangent		"   X3 := Tangent
	  tra	part_tan_or_cot	"   return (part_tan_or_cot (Tangent, radians))
				" else if shift = 1 | shift = 3
	eax3	Cotangent		"   X3 := Cotangent
	fneg	0		"   EAQ := -radians
"	tra	part_tan_or_cot	"   return (part_tan_or_cot (Cotangent, -radians))


" Procedure 'part_tan_or_cot' (function, x) calculates either 'tan(x)'
" or 'cot(x)' to double precision accuracy, for 'x' in [-pi/4, pi/4].
" Argument 'x' is given in the EAQ and the function to be calculated is
" given in X3.  X3=-1 indicates 'cot' and X3=1 indicates 'tan'.

part_tan_or_cot:
	fcmg	eps2		" if abs(x) < 5e-10:
	tpl	use_polynomial
	  cmpx3	Tangent,du	"   if function = Tangent
	  tnz	3,ic
	    dfrd	0		"     then return (result)
	    tra	pr3|0
	  dfcmg	eps3,x2		"   else if 1/result overflows
	    tmoz	infinity		"     then return (infinity (result))
	    dfdi  one,x2    	"     else return (1/result)
	    tra	pr3|0

use_polynomial:
	dfstr	pr2|x
	dfmp	pr2|x		" calculate xx = x*x
	dfstr	pr2|xx
	dfad	q3,x2		" calculate q = q(xx)
	dfmp	pr2|xx
	dfad	q2,x2
	dfmp	pr2|xx
	dfad	q1,x2
	dfmp	pr2|xx
	dfad	q0,x2
	dfstr	pr2|q
	dfld	pr2|xx		" calculate p(xx)
	dfmp	p4,x2
	dfad	p3,x2
	dfmp	pr2|xx
	dfad	p2,x2
	dfmp	pr2|xx
	dfad	p1,x2
	dfmp	pr2|xx
	dfad	p0,x2
	dfmp	pr2|x		" calculate p = x*p(xx)
	cmpx3	Tangent,du
	tnz	3,ic		" if function = Tangent
	  dfdv	pr2|q		" then return (p/q)
	  tra	pr3|0
	dfdi	pr2|q		" else return (q/p)
	tra	pr3|0


infinity:
	fst	pr2|sign
	fld	max_value
	fad	max_value		" signal overflow
	dfld	max_value
	fszn	pr2|sign		" if sign >= 0
	tpl	pr3|0		" then return (max_value)
	fneg	0		" else return (-max_value)
	tra	pr3|0


" Constants:

	even
eps1:	dec	8.418858142948452884d-38
	oct	402162456701,514360373670	" 2.670821537926801391d-154
eps2:	dec	5.0d-10
	oct	762104560277,000000000000
eps3:	oct	404400000000,000000000001
	oct	404040000000,000000000001
forty_five:
	dec	45.0d0
	oct	004132000000,000000000000
one:	dec	1.d0
	oct	002040000000,000000000000
p0:	dec	 7.61637646334745151d5
	oct	012563711322,566143202611
p1:	dec	-1.045644297708972282d5
	oct	013714742710,772421516417
p2:	dec	 2.990139654186652781d3
	oct	006565610740,140350661251
p3:	dec	-2.195407375452258719d1
	oct	005724057016,450513240522
p4:	dec	 2.229548191006262686d-2
	oct	776266512016,646767353442
q0:	dec	 7.61637646334745151d5
	oct	012563711322,566143202611
q1:	dec	-3.584436452158122785d5
	oct	013520765055,323105715467
q2:	dec	 2.091966854815805879d4
	oct	010243336531,137433252357
q3:	dec	-3.069448235422934591d2
	oct	007731503420,013262557251

	end




		    exponential_.alm                11/11/89  1150.6rew 11/11/89  0805.5       44658



" ******************************************
" *                                        *
" * Copyright, (C) Honeywell Limited, 1985 *
" *                                        *
" ******************************************
	name	exponential_
" Modification history:
"	Written by H. Hoover, M. Mabey, and B. Wong, April 1985,
"	based on GCOS routine '7naz'.
"
" Function:  Calculates the exponential function 'e**x' to single precision
"	accuracy in either BFP or HFP mode.
"
" Entry:	through the appropriately named entry point with:
" 	EAQ = the argument x.
"	PR2 = the address of a 4 word, even-word aligned scratch area.
"	PR3 = the return address.
"
" Exit:	EAQ = the desired exponential
"
" Uses:	X0
"	X0 = index to the table "scale"


	segref	math_constants_,almost_one,hfp_almost_one,log_2_of_e,max_value

	equ	iy,0
	equ 	z,2

	bool	M0.5H,001400	" yields HFP -0.5 under 'du' modification
	bool	P1.0H,002040	" yields HFP +1.0 under 'du' modification
	bool	P2.0H,002100	" yields HFP +2.0 under 'du' modification

	segdef	exponential_,hfp_exponential_


exponential_:
	fcmp	lb		" if x <= -89.415987: 
	tpnz	3,ic
	   fld	   =0.0,du	"    result = 0
	   tra	   pr3|0		"    return
	fcmp	ub		" if x >= 88.0296926 goto overflow_error
	tpl	overflow_error
	dfmp	log_2_of_e	" y = x*log_2_of_e
	fad	=1.0,du		" EAQ := y + 1

	ufa	=7b25,du		" AQ := 8/floor(y+1),64/fraction part of y
	sta	pr2|iy
	ora	=o776000,du	" AQ := 8/-1,64/fraction part of y
	lde	=7b25,du		" EAQ := ry = unnormalized y - floor(y+1)
	fad	=0.0,du		" EAQ := ry = normalized y - floor(y+1)
				" result = part_exp2 (ry)

" The function part_exp2 calculates 2**z, given z in the range [-1, 0)
" in the EAQ.

part_exp2:
	fcmg	eps
	tpl	3,ic		" if abs (z) < 1.56417309e-19:
	   fld	   =1.0,du	"    result = 1.0
	   tra	   pr3|0		"    return

	frd	0
	fst	pr2|z

	fmp	p7		" result = p(z)
	dfad	p6
	fmp	pr2|z
	dfad	p5
	fmp	pr2|z
	dfad	p4
	fmp	pr2|z
	dfad	p3
	fmp	pr2|z
	dfad	p2
	fmp	pr2|z
	dfad	p1
	fmp	pr2|z
	dfad	p0

	ade	pr2|iy		" addr (result) -> expon = addr (result) -> expon + iy
	tra	pr3|0		" return result in EAQ



hfp_exponential_:
	fcmp	hfp_lb		" if x <= -357.6639451:
	tpnz	3,ic
	   fld	   =0.0,du	"    result = 0
	   tra	   pr3|0		"    return
	fcmp	hfp_ub		" if x >= 352.1187677 goto overflow_error
	tpl	overflow_error
	fcmg	hfp_eps		" if abs (x) < 1.0842021e-19:
	tpl	3,ic
	   fld	   P1.0H,du	"   result = 1.0
	   tra	   pr3|0		"   return
	dfmp	hfp_log_16_of_e	" y = x*log_16_of_e
	fad	P1.0H,du		" EAQ := y + 1

	fmp	P2.0H,du
	ufa	=2b25,du		" AQ := 8/floor(y+1),64/fraction part of y
	sta	pr2|iy
	ora	=o776000,du	" AQ := 8/-1,64/fraction part of y
	lde	=2b25,du		" EAQ := unnormalized 2*(y - floor(y+1))
	fad	=0.0,du		" EAQ := 2*(y - floor(y+1))
	fmp	P2.0H,du		" EAQ := ry = 4*(y - floor(y+1))

	eax0	0		" scale = 1.0

	even
do_while_ry_less_than_neg_one:
	dfcmp	=-1.0d0		" do while ry < -1.0:
	tpl	hfp_part_exp2
	   adx0	   =1,du		"    scale = 0.5*scale
	   fad	   P1.0H,du	"    ry = ry + 1
	   tra	   do_while_ry_less_than_neg_one

				" result = part_exp2 (ry)

" The function hfp_part_exp2 calculates 2**z, given z in the range [-1, 0)
" in the EAQ.

hfp_part_exp2:
	fcmg	hfp_eps1
	tpl	3,ic		" if abs (z) < 1.56417309e-19:
	   fld	   P1.0H,du	"   result = 1.0
	   tra	   pr3|0		"   return

	frd	0
	fst	pr2|z

	fmp	hfp_p7		" result = p(z)
	dfad	hfp_p6
	fmp	pr2|z
	dfad	hfp_p5
	fmp	pr2|z
	dfad	hfp_p4
	fmp	pr2|z
	dfad	hfp_p3
	fmp	pr2|z
	dfad	hfp_p2
	fmp	pr2|z
	dfad	hfp_p1
	fmp	pr2|z
	dfad	hfp_p0

	fmp	scale,x0		" result = scale * part_exp2 (ry)
	ade	pr2|iy		" addr (result) -> expon = addr (result) -> expon + iy
	tra	pr3|0		" return result in EAQ


overflow_error:
	fld	max_value
	fad	max_value		" cause an overflow
	fld	max_value
	tra	pr3|0		" return to caller

	even

eps:	dec	1.56417309d-19
hfp_eps:	oct	742100000427,000000000000	" 1.08422022d-19
hfp_eps1:
	oct	742134252166,000000000000	" 1.56417309d-19
hfp_log_16_of_e:
	oct	000270524354,512701376057	" log_16_of_e = 0.36067376022224085183998d0

p0:	dec	0.999999999959788989221d00
hfp_p0:	oct	000777777777,775171146650
p1:	dec	0.693147175773076184335d00
hfp_p1:	oct	000542710277,064122746306
p2:	dec	0.240226411617528907564d00
hfp_p2:	oct	000172775723,130414032243
p3:	dec	0.555033746338694398430d-01
hfp_p3:	oct	776706536015,336576334575
p4:	dec	0.961531912935043645900d-02
hfp_p4:	oct	776116611444,463376701613
p5:	dec	0.132743818109838796600d-02
hfp_p5:	oct	774255772674,464260106540
p6:	dec	0.147007243118869978000d-03
hfp_p6:	oct	772464227646,455135010071
p7:	dec	0.107493818486964670000d-04
hfp_p7:	oct	770550540762,530201244720

ub:	dec	8.802969265d01		" 2**127 - 2**100 = e**88.0296926
lb:	dec	-8.9415987d01		" 2**(-129) = e**-89.415987
hfp_ub:	oct	006054007464,000000000000	" 16**127 - 16**100 = e**352.1187677
hfp_lb:	oct	007723225403,000000000000	" 16**(-129) = e**-357.6639541

scale:	oct	002040000000		" 1
	oct	000400000000		" 0.5
	oct	000200000000		" 0.25
	oct	000100000000		" 0.125
	oct	000040000000		" 0.0625

	end




		    find_bit_.alm                   11/11/89  1150.6rew 11/11/89  0805.2      305811



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Bull Inc., 1987                *
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1986 *
" *                                                         *
" ***********************************************************

" HISTORY COMMENTS:
"  1) change(86-05-08,GDixon), approve(86-05-16,MCR7357),
"     audit(86-07-10,Farley), install(86-07-17,MR12.0-1097):
"     Created find_bit_ subroutine.
"                                                      END HISTORY COMMENTS

" *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *
"
" Name:  find_bit_
"
"      This subroutine uses the EIS compare bit (CMPB) and test character and
" translate (TCT) instructions to search for an on or off bit in a bit string.
" The bit index of the first bit found in the desired state is returned.
" Searching is performed either from the left (beginning) or from the
" right-hand side (end) of the string.  The code uses a pre-defined
" test/translate table for the TCT portion of the scanning.
"
" Entry:	find_bit_$first_on
"
" Function:  This entrypoint returns the index (bit position) of the first
" (leftmost) bit which is on ("1"b) in a bit string.
" 
" Syntax:
"   dcl find_bit_$first_on entry (bit(*)) returns (fixed bin(24)) reducible;
"   index = find_bit_$first_on (bit_string);
" 
" Arguments:
" bit_string
"    is the bit string to be examined. (In)
" index
"    is the bit position of the first "1"b bit within the bit string.  If no
"    "1"b bits are found, then 0 is returned. (Out)
"
" Entry:	find_bit_$first_off
"
" Function:  This entrypoint returns the index (bit position) of the first
" (leftmost) bit which is off ("0"b) in a bit string.
" 
" Syntax:
"   dcl find_bit_$first_off entry (bit(*)) returns (fixed bin(24)) reducible;
"   index = find_bit_$first_off (bit_string);
" 
" Arguments:
" bit_string
"    is the bit string to be examined. (In)
" index
"    is the bit position of the first "0"b bit within the bit string.  If no
"    "0"b bits are found, then 0 is returned. (Out)
"
" Entry:	find_bit_$last_on
"
" Function:  This entrypoint returns the index (bit position) of the last
" (rightmost) bit which is on ("1"b) in a bit string.
" 
" Syntax:
"   dcl find_bit_$last_on entry (bit(*)) returns (fixed bin(24)) reducible;
"   index = find_bit_$last_on (bit_string);
" 
" Arguments:
" bit_string
"    is the bit string to be examined. (In)
" index
"    is the bit position of the last "1"b bit within the bit string.  If no
"    "1"b bits are found, then 0 is returned. (Out)
"
" Entry:	find_bit_$last_off
"
" Function:  This entrypoint returns the index (bit position) of the last
" (rightmost) bit which is on ("0"b) in a bit string.
" 
" Syntax:
"   dcl find_bit_$last_on entry (bit(*)) returns (fixed bin(24)) reducible;
"   index = find_bit_$last_off (bit_string);
" 
" Arguments:
" bit_string
"    is the bit string to be examined. (In)
" index
"    is the bit position of the last "0"b bit within the bit string.  If no
"    "0"b bits are found, then 0 is returned. (Out)
"
" *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *


	include	its	

" -----------------------------------------------------------------------------
" Segname definitions: 
" -----------------------------------------------------------------------------

	name	find_bit_

	segdef	first_on
	segdef	first_off
	segdef	last_on
	segdef	last_off

" -----------------------------------------------------------------------------
" Data Values and Register name assignments: 
" -----------------------------------------------------------------------------

	equ	arg_list,0	" pr0 -> argument list
	equ	bit_string,1	" pr1 -> bit_string
	equ	index,2		" pr2 -> result          (after return)
	equ	bit_length,2	" pr2 -> length(bit_string)
				"		    (before return)
	equ	byte_str,3	" pr3 -> 1st full byte of bit_string
	equ	table,4		" pr4 -> tct table
	equ	test_bit,5	" pr5 -> type of bit we are looking
				"        for (either on or off)
	equ	direction,0	  " x0 = entrypoint indicator.
	equ	 FIRST,0		  "        find first desired bit
	equ	 LAST,1		  "	 find last  desired bit
	equ	bits_prior_1st_byte,1 " x1 = bits prior to first full byte
				  "      of bit_string.
	equ	bits_after_Nth_byte,2 " x2 = bits after last full byte
				  "      of bit_string.
	equ	do_index,3	  " x3 = a do group index.
	equ	table_char,4	  " x4 = tctr translated result char.
	equ	BITS_PER_BYTE,9

	even			" Selected bit values: 
on_bit:				" on  bit ("1"b), one of the possible
	oct	400000000000	"   values we can search for.
off_bit:				" off bit ("0"b), the other possible
	oct	000000000000	"   value we can search for.

desc_length_mask:			" ANDing mask to extract char string
	oct	000077777777	"   length from an argument descriptor.
string_index_mask:			" ANDing mask to extract char offset
	oct	000777777777	"   from result of TCT instruction.

" -----------------------------------------------------------------------------
" Code for find_bit_$(first last)_(on off):
"    Setup entrypoint indicator, table pointer, and test bit pointer.
"
"  Out:	pr(table)    -> TCT test/translate table for selecting first/last 
"		      on/off bit from a string of full bytes.
"	pr(test_bit) -> type of bit we are looking for (on or off).
"	x(direction)  = choice of first/last, based upon entrypoint.
"
" -----------------------------------------------------------------------------
" first_on: entry (bit_string) returns(index);
" -----------------------------------------------------------------------------
first_on:	ldx	direction,FIRST,du
	epp	table,first_on_bit_table
	epp	test_bit,on_bit
	tra	common

" -----------------------------------------------------------------------------
" first_off: entry (bit_string) returns(index);
" -----------------------------------------------------------------------------
first_off:
	ldx	direction,FIRST,du 
	epp	table,first_off_bit_table
	epp	test_bit,off_bit
	tra	common

" -----------------------------------------------------------------------------
" last_on: entry (bit_string) returns(index);
" -----------------------------------------------------------------------------
last_on:	ldx	direction,LAST,du
	epp	table,last_on_bit_table
	epp	test_bit,on_bit
	tra	common

" -----------------------------------------------------------------------------
" last_off: entry (bit_string) returns(index);
" -----------------------------------------------------------------------------
last_off: ldx	direction,LAST,du
	epp	table,last_off_bit_table
	epp	test_bit,off_bit
	tra	common

" -----------------------------------------------------------------------------
" Get address of input and output parm.
"   In:	pr(arg_list)         -> the argument list.
"  Out:	pr(bit_string)       -> bit string to be searched (input parm).
"	pr(index)		 -> bit index within string  (output parm).
" -----------------------------------------------------------------------------
common:
	epp	bit_string,arg_list|2,* 
				" get addr(bit_string).
	epp	index,arg_list|4,*	" get addr(index).

" -----------------------------------------------------------------------------
" Since the TCT instruction is byte-oriented, we must special-case bits which
" precede the first full byte, and which follow the last full byte of
" bit_string.  Compute number of bits which precede the first full byte of the
" bit_string.
"   In:	pr(bit_string)        -> bit string to be searched.
"  Out:	x(bits_prior_1st_byte) = bits preceding first full byte of bit_string
" -----------------------------------------------------------------------------
	ldx	bits_prior_1st_byte,0,du
	epaq	bit_string|0	" get bit offset of addr(bit_string)
	anq	its.bit_offset_mask,dl	
				" QL now contains bit offset
	div	BITS_PER_BYTE,dl	" test if bit_string is byte_aligned
	cmpa	0,dl		" mod(bit_offset,9) = 0?
	tze	get_length	" yes.  There are no bits before byte
	neg
	ada	BITS_PER_BYTE,dl
	eax	bits_prior_1st_byte,0,al
				" number of bits in bit_string which
				" precede the first full byte.

" -----------------------------------------------------------------------------
" Get length (bit_string).  Because we don't want to pay the expense of pushing
" a stack frame, this program writes in only one word of memory, its output
" argument (index).  length(bit_string) will be saved temporarily in index.
"
" NB: bit_length and index are two names for the same pointer register 
"     (pr2).  When the location pointed by pr2 contains length(bit_string), it
"     is referenced as bit_length|0.  When it contains the resulting index
"     within bit_string, it is referenced as index|0.
"   In:	pr(arg_list)         -> the argument list.
"  Out:	pr(bit_length)       -> length(bit_string).
" -----------------------------------------------------------------------------
get_length: 
	lxl3	arg_list|0	" get length(bit_string):  
	cmpx3	4,du		"   compensate for arg lists which
	tze	no_parent		"   have a parent_ptr.
parent:	 			" bit_string descriptor is 1st in 
	ldq	arg_list|8,*	"   arg_list (after bit_string arg,
				"   index arg and parent_ptr).
	tra	compute_length
no_parent:
	ldq	arg_list|6,*	" bit_string descriptor is 1st in
				"   arg_list (after bit_string arg
				"   and index arg).
compute_length:
	anq	desc_length_mask	" mask out all but bit length from desc
	stq	bit_length|0

" -----------------------------------------------------------------------------
" Branch depending upon whether search is for first (left-to-right) or 
" last (right-to-left) on/off bit.
"   In:	x(direction) = choice of first/last.
" -----------------------------------------------------------------------------
	tra	direction_vector,direction
direction_vector:
	tra	find_first_in_lead_bits
	tra	find_last_in_trail_bits

" -----------------------------------------------------------------------------
" LOOKING FOR FIRST BIT (left-to-right search): 
" Loop thru bits prior to first full byte: check for desired (on or off) bit.
"   In:	x(bits_prior_1st_byte) = bits preceding first full byte of 
"			     bit_string.  These must be processed one at
"			     a time.  Full bytes are processed later.
"	pr(bit_length) 	  -> length(bit_string).
"	pr(bit_string)	  -> bit_string to be searched.
"	pr(test_bit)	  -> bit value searching for (on or off).
"  Out:	q-reg		   = index in bit_string of desired bit, if match
"			     occurs.
" -----------------------------------------------------------------------------
find_first_in_lead_bits:
fflb:	eaq	0,bits_prior_1st_byte
	tmoz	find_first_in_bytes " Byte-aligned bit string?  Skip
				"    checking of leading bits.
				" if bits_prior_first_byte > 0 then
	qrs	18		" do do_index = min(length(bit_string),
	cmpq	bit_length|0	"    bits_prior_1st_byte) to 0 by -1
	tmi	fflb_long_bit_string
	ldq	bit_length|0	
fflb_long_bit_string: 		
	eax	do_index,1,ql
	ldq	1,dl
fflb_loop: 
	sbx	do_index,1,du	
	tze	find_first_in_bytes	" Leading bits exhausted, no match.
	even
	cmpb	(pr,ql),(pr)	" Compare leading bit with test_bit.
	descb	bit_string|-1(35),1	"  substr(bit_string,q-reg,1)=test_bit?
	descb	test_bit|0,1
	tze	match		" Yes, match found.
	adq	1,dl		" No, match not found.  Continue loop.
	tra	fflb_loop	

" -----------------------------------------------------------------------------
" Desired bit not found.  Compute number of full bytes (byte-aligned bytes)
" in bit_string.
"   In:	x(bits_prior_1st_byte) = bits preceding first full byte of bit_string
"	pr(bit_length)	  -> length(bit_string).
"  Out:	x(bits_after_Nth_byte) = bits following last full byte of bit_string.
"	q-reg		   = count of full bytes in bit_string.
" -----------------------------------------------------------------------------
find_first_in_bytes: 		" Compute bits in full bytes in a-reg: 
	eaa	0,bits_prior_1st_byte
	ars	18		"   Put bits_prior_1st_byte into a-reg.
	neg			"   Negate value for subtraction.
	ada	bit_length|0	"   Subtract from length(bit_string).
	lrl	36		"   Put result in q-reg for division.
	div	BITS_PER_BYTE,dl
	eax	bits_after_Nth_byte,0,al
				" Remainder of division is bits after
				"   last byte.
	cmpq	0,dl		" Are there any full bytes?
	tze	find_first_in_trail_bits
				" No.  Branch to test trailing bits.

" -----------------------------------------------------------------------------
" Test full bytes to find first containing desired bit, using TCT instruction.
"   In:	pr(bit_length)	  -> length(bit_string).
"	pr(bit_string)	  -> bit_string.
"	x(bits_prior_1st_byte) = bits preceding first full byte of bit_string
"	q-reg		   = count of full bytes in bit_string.
"	pr(table)		  -> test/translate table appropriate for desired
"			     bit and direction.
"  Out:	pr(index)		  -> result of TCT instruction, if match found.
"	pr(bit_length)	  -> length(bit_string), if match not found.
" -----------------------------------------------------------------------------
	lda 	bit_length|0	" Save full length of bit_string in 
				"   a-reg while bit_length loc holds
				"   result of tct instruction.
	epp	byte_str,bit_string|0 
	abd	byte_str|0,bits_prior_1st_byte
				" Compute loc of first full byte
	even
	tct	(pr,rl),fill(000)	" Look for first instance of desired
	desc9a	byte_str|0,ql	"   (on/off) bit.
	arg	table|0
	arg	index|0		"    result goes into index loc
	ttf	store_tct_result	" Match found in some byte?  We won!
	sta	bit_length|0	" Restore length(bit_string) into 
				" storage to undo temp-save done above.

" -----------------------------------------------------------------------------
" Loop thru bits after last full byte, checking for desired (on/off) bit.
"   In:	x(bits_after_Nth_byte) = bits following last full byte of bit_string.
"	pr(bit_length)	  -> length(bit_string).
"	pr(bit_string)	  -> bit_string to be searched.
"	pr(test_bit)	  -> bit value searching for (on or off).
"  Out:	q-reg		   = index of desired bit, if match found.
" -----------------------------------------------------------------------------
find_first_in_trail_bits:
fftb:	eaa	0,bits_after_Nth_byte
				" Are there any bits after last byte?
	tmoz	no_match		" No, no match found.
	ars	18		" Yes, a-reg contains number of bits.
	neg			" a-reg = length(bit_string) - 
	ada	bit_length|0	"         bits_after_Nth_byte + 1
				"       = index of 1st bit after
	ada	1,dl		"         Nth byte.
	lrl	36		" Shift result to q-reg
	eax	do_index,1,bits_after_Nth_byte
fftb_loop: 			" do do_index = bits_after_Nth_byte
	sbx	do_index,1,du	"    to 0 by -1
				
	tze	no_match		" Trailing bits exhausted, no match.
	even
	cmpb	(pr,ql),(pr)	" Compare trailing bit with test_bit.
	descb	bit_string|-1(35),1	"  substr(bit_string,q-reg,1)=test_bit?
	descb	test_bit|0,1
	tze	match		" Match found.
	adq	1,dl
	tra	fftb_loop		" No match found-- loop.

" -----------------------------------------------------------------------------
" Matching bit found in full byte.
" Convert tct result to bit index, stored in q-reg.
"   In:	pr(index)		  -> result of TCT instruction.
"	x(bits_prior_1st_byte) = bits preceding first full byte of bit_string
"  Out:	q-reg		   = index in bit_string of desired bit.
" -----------------------------------------------------------------------------
store_tct_result: 
	ldq	index|0		" Match found, compute bit index: 
	anq	string_index_mask	"   Start with byte offset (not index)
	mpy	BITS_PER_BYTE,dl	"   * 9 = bit offset of selected byte
	lda	index|0		"   + translated byte value (index of
	arl	27		"     first desired bit within byte
	sta	index|0		"     copied from test/translate 
	adq	index|0		"     table by TCT into 1st byte of
				"     TCT result)
	stz	index|0		"   + bits prior to first byte.
	sxl	bits_prior_1st_byte,index|0
	adq	index|0

" -----------------------------------------------------------------------------
" Success return point:
"   In:	q-reg		   = index in bit_string of desired bit.
"  Out:	pr(index)		  -> index in bit_string of desired bit (result).
" -----------------------------------------------------------------------------
match: 	stq	index|0
	short_return

" -----------------------------------------------------------------------------
" Failure return point:
"  Out:	pr(index)		  -> 0 (desired bit not found).
" -----------------------------------------------------------------------------
no_match: stz	index|0
	short_return

" -----------------------------------------------------------------------------
" LOOKING FOR LAST BIT (right-to-left search): 
" Compute how many bits of bit_string follow the last full byte.
"   In:	x(bits_prior_1st_byte) = bits preceding first full byte of 
"			     bit_string.  These must be processed 
"			     separately from full (byte-aligned) bytes.
"	pr(bit_length) 	  -> length(bit_string).
"  Out:	x(bits_after_Nth_byte) = bits following last full byte of bit_string.
"	a-reg		   = count of full bytes in bit_string.
" -----------------------------------------------------------------------------
find_last_in_trail_bits:
fltb:	ldx	bits_after_Nth_byte,0,du   " assume no trailing bits.
	eaa	0,bits_prior_1st_byte      " length(bit_string) -
	ars	18		       "   bits_prior_1st_byte 
	neg
	ada	bit_length|0	       
	tmi	find_last_in_lead_bits     " Negative?  No bits follow.
	lrl	36
	div	BITS_PER_BYTE,dl	       " mod(length,9) =  
	eax	bits_after_Nth_byte,0,al   "   bits after last full byte
	lls	36		       " a-reg = number of full bytes

" -----------------------------------------------------------------------------
" Loop thru bits after last full byte, checking for a desired (on/off) bit
"   In:	pr(bit_length) 	  -> length(bit_string).
"  	x(bits_after_Nth_byte) = bits following last full byte of bit_string.
"	pr(bit_string)	  -> bit_string to be searched.
"	pr(test_bit)	  -> bit value searching for (on or off).
"  Out:	q-reg		   = index of desired bit, if match found.
" -----------------------------------------------------------------------------
	ldq	bit_length|0
	eax	do_index,1,bits_after_Nth_byte
fltb_loop: 			" do do_index = bits_after_Nth_byte
	sbx	do_index,1,du	"    to 0 by -1
	tze	find_last_in_bytes
				" Trailing bits exhausted, no match.
	even
	cmpb	(pr,ql),(pr)	" Compare trailing bit with test_bit.
	descb	bit_string|-1(35),1	"  substr(bit_string,q-req,1)=test_bit?
	descb	test_bit|0,1
	tze	match		" Match found.
	sbq	1,dl
	tra	fltb_loop		" No match found.  Continue loop.

" -----------------------------------------------------------------------------
" Test full bytes to find last containing desired bit, using TCTR instruction.
"   In:	a-reg		   = count of full bytes in bit_string.
"	pr(bit_length)	  -> length(bit_string).
"	pr(bit_string)	  -> bit_string.
"	x(bits_prior_1st_byte) = bits preceding first full byte of bit_string
"	pr(table)		  -> test/translate table appropriate for desired
"			     bit and direction.
"  Out:	pr(index)		  -> result of TCT instruction, if match found.
"	pr(bit_length)	  -> length(bit_string), if match not found.
"	q-reg		   = count of full bytes in bit_string.
" -----------------------------------------------------------------------------
find_last_in_bytes: 
	lrl	36		" put number full bytes in q-reg
	lda 	bit_length|0	" Save length (bit_string) in a-reg
				"   while bit_length holds tctr result.
	epp	byte_str,bit_string|0 
	abd	byte_str|0,bits_prior_1st_byte
				" Compute loc of first full byte.
	even
	tctr	(pr,rl),fill(000)	" Look for last instance of desired
	desc9a	byte_str|0,ql	"   (on/off) bit.
	arg	table|0
	arg	index|0		"    result goes into index location.
	ttf	store_tctr_result	" Match found in some byte?  We won!
	sta	bit_length|0	" Restore length(bit_string) into 
				" storage to undo temp-save done above.

" -----------------------------------------------------------------------------
" Loop thru bits prior to first full byte, checking for desired (on/off) bit.
"   In:	x(bits_prior_1st_byte) = bits preceding first full byte of 
"			     bit_string.
"	pr(bit_length) 	  -> length(bit_string).
"	pr(bit_string)	  -> bit_string to be searched.
"	pr(test_bit)	  -> bit value searching for (on or off).
"  Out:	q-reg		   = index in bit_string of desired bit, if match
"			     occurs.
" -----------------------------------------------------------------------------
find_last_in_lead_bits: 
fllb:	eaq	0,bits_prior_1st_byte
	tmoz	no_match		" No leading bits? Then desired bit
				"   not found.
	qrs	18
	cmpq	bit_length|0	" do q-reg = min (length(bit_string),
	tmi	fllb_long_bit_string"    bits_prior_to_1st_byte) to 0 by -1
	ldq	bit_length|0	
fllb_long_bit_string: 		
	adq	1,dl
fllb_loop: 
	sbq	1,dl
	tmoz	no_match		" Leading bits exhausted, no match.
	even
	cmpb	(pr,ql),(pr)	" Compare leading bit with test_bit.
	descb	bit_string|-1(35),1	"  substr(bit_string,q-reg,1)=test_bit?
	descb	test_bit|0,1
	tze	match		" Yes, match found.
	tra	fllb_loop		" No, match not found.  Continue loop.

" -----------------------------------------------------------------------------
" Matching bit found in full byte.
" Convert tctr result to bit index, stored in q-reg.
"   In:	pr(index)		  -> result of TCTR instruction.
"	x(bits_prior_1st_byte) = bits preceding first full byte of bit_string
"	q-reg		   = count of full bytes in bit_string.
"  Out:	q-reg		   = index in bit_string of desired bit.
" -----------------------------------------------------------------------------
store_tctr_result:
	ldx	table_char,index|0
				" Save selected char from
				"   test/translate table which TCTR
				"   instruction put in 1st byte of
				"   TCTR result.
	lda	index|0		" a-reg = byte_offset_from_right_end
	ana	string_index_mask	" 
	stq	index|0		" q-reg = full_bytes_in_bit_string
				"  (saved at find_last_in_bytes above)

	sba	index|0		"   full_bytes_in_bit_string
	neg			" - byte_offset_from_right_end
	sba	1,dl		" - 1
				" = bytes_before_wanted_byte

	lrl	36		" * 9 
	mpy	BITS_PER_BYTE,dl	" = bits_in_bytes_before_wanted_byte

	eaa	0,table_char	" + translated byte value (index of
	arl	27		"     first desired bit within byte)
	sta	index|0		" = bit index of wanted bit, excluding
	adq	index|0		"   bits prior to first byte.

	stz	index|0		" + bits prior to first byte.
	sxl	bits_prior_1st_byte,index|0
	adq	index|0		" = bit index of wanted bit (in q-reg)

	tra 	match

" -----------------------------------------------------------------------------
" TCT test/translate tables:
"
" Each of the following test/translate tables is designed to work with the
" TCT and TCTR instructions.  The bit string being examined is broken up into
" full bytes.  The byte value (rank) of each byte is used as an index into the
" 512 entry test/translate table.  The numeric value stored in the table entry
" gives the index within the byte of the desired bit (eg, the first on bit
" within the byte).
" 
" For example, when looking for the first on bit, suppose the byte being
" tested has the value 003 (octal).  Using PL/I bit string notation, this is
" expressed as "003"b3 = "000000011"b.  The index of the first on bit
" within the byte is 8.  8 (decimal) = "010"b3.
"
" Therefore, the number 8 (= "010"b3) is stored in the test/translate table
" entry corresponding to the byte "003"b in the table below.
" -----------------------------------------------------------------------------

	even
first_on_bit_table:
	oct	000011010010,007007007007	" 000-007  (entry 003
					"           has value 010)
	oct	006006006006,006006006006	" 010-017
	oct	005005005005,005005005005	" 020-027
	oct	005005005005,005005005005	" 030-037
	oct	004004004004,004004004004	" 040-047
	oct	004004004004,004004004004	" 050-057
	oct	004004004004,004004004004	" 060-067
	oct	004004004004,004004004004	" 070-077
	oct	003003003003,003003003003	" 100-107
	oct	003003003003,003003003003	" 110-117
	oct	003003003003,003003003003	" 120-127
	oct	003003003003,003003003003	" 130-137
	oct	003003003003,003003003003	" 140-147
	oct	003003003003,003003003003	" 150-157
	oct	003003003003,003003003003	" 160-167
	oct	003003003003,003003003003	" 170-177
	oct	002002002002,002002002002	" 200-207
	oct	002002002002,002002002002	" 210-217
	oct	002002002002,002002002002	" 220-227
	oct	002002002002,002002002002	" 230-237
	oct	002002002002,002002002002	" 240-247
	oct	002002002002,002002002002	" 250-257
	oct	002002002002,002002002002	" 260-267
	oct	002002002002,002002002002	" 270-277
	oct	002002002002,002002002002	" 300-307
	oct	002002002002,002002002002	" 310-317
	oct	002002002002,002002002002	" 320-327
	oct	002002002002,002002002002	" 330-337
	oct	002002002002,002002002002	" 340-347
	oct	002002002002,002002002002	" 350-357
	oct	002002002002,002002002002	" 360-367
	oct	002002002002,002002002002	" 370-377
	oct	001001001001,001001001001	" 400-407
	oct	001001001001,001001001001	" 410-417
	oct	001001001001,001001001001	" 420-427
	oct	001001001001,001001001001	" 430-437
	oct	001001001001,001001001001	" 440-447
	oct	001001001001,001001001001	" 450-457
	oct	001001001001,001001001001	" 460-467
	oct	001001001001,001001001001	" 470-477
	oct	001001001001,001001001001	" 500-507
	oct	001001001001,001001001001	" 510-517
	oct	001001001001,001001001001	" 520-527
	oct	001001001001,001001001001	" 530-537
	oct	001001001001,001001001001	" 540-547
	oct	001001001001,001001001001	" 550-557
	oct	001001001001,001001001001	" 560-567
	oct	001001001001,001001001001	" 570-577
	oct	001001001001,001001001001	" 600-607
	oct	001001001001,001001001001	" 610-617
	oct	001001001001,001001001001	" 620-627
	oct	001001001001,001001001001	" 630-637
	oct	001001001001,001001001001	" 640-647
	oct	001001001001,001001001001	" 650-657
	oct	001001001001,001001001001	" 660-667
	oct	001001001001,001001001001	" 670-677
	oct	001001001001,001001001001	" 700-707
	oct	001001001001,001001001001	" 710-717
	oct	001001001001,001001001001	" 720-727
	oct	001001001001,001001001001	" 730-737
	oct	001001001001,001001001001	" 740-747
	oct	001001001001,001001001001	" 750-757
	oct	001001001001,001001001001	" 760-767
	oct	001001001001,001001001001	" 770-777
	
	even
first_off_bit_table:
	oct	001001001001,001001001001	" 000-007
	oct	001001001001,001001001001	" 010-017
	oct	001001001001,001001001001	" 020-027
	oct	001001001001,001001001001	" 030-037
	oct	001001001001,001001001001	" 040-047
	oct	001001001001,001001001001	" 050-057
	oct	001001001001,001001001001	" 060-067
	oct	001001001001,001001001001	" 070-077
	oct	001001001001,001001001001	" 100-107
	oct	001001001001,001001001001	" 110-117
	oct	001001001001,001001001001	" 120-127
	oct	001001001001,001001001001	" 130-137
	oct	001001001001,001001001001	" 140-147
	oct	001001001001,001001001001	" 150-157
	oct	001001001001,001001001001	" 160-167
	oct	001001001001,001001001001	" 170-177
	oct	001001001001,001001001001	" 200-207
	oct	001001001001,001001001001	" 210-217
	oct	001001001001,001001001001	" 220-227
	oct	001001001001,001001001001	" 230-237
	oct	001001001001,001001001001	" 240-247
	oct	001001001001,001001001001	" 250-257
	oct	001001001001,001001001001	" 260-267
	oct	001001001001,001001001001	" 270-277
	oct	001001001001,001001001001	" 300-307
	oct	001001001001,001001001001	" 310-317
	oct	001001001001,001001001001	" 320-327
	oct	001001001001,001001001001	" 330-337
	oct	001001001001,001001001001	" 340-347
	oct	001001001001,001001001001	" 350-357
	oct	001001001001,001001001001	" 360-367
	oct	001001001001,001001001001	" 370-377
	oct	002002002002,002002002002	" 400-407
	oct	002002002002,002002002002	" 410-417
	oct	002002002002,002002002002	" 420-427
	oct	002002002002,002002002002	" 430-437
	oct	002002002002,002002002002	" 440-447
	oct	002002002002,002002002002	" 450-457
	oct	002002002002,002002002002	" 460-467
	oct	002002002002,002002002002	" 470-477
	oct	002002002002,002002002002	" 500-507
	oct	002002002002,002002002002	" 510-517
	oct	002002002002,002002002002	" 520-527
	oct	002002002002,002002002002	" 530-537
	oct	002002002002,002002002002	" 540-547
	oct	002002002002,002002002002	" 550-557
	oct	002002002002,002002002002	" 560-567
	oct	002002002002,002002002002	" 570-577
	oct	003003003003,003003003003	" 600-607
	oct	003003003003,003003003003	" 610-617
	oct	003003003003,003003003003	" 620-627
	oct	003003003003,003003003003	" 630-637
	oct	003003003003,003003003003	" 640-647
	oct	003003003003,003003003003	" 650-657
	oct	003003003003,003003003003	" 660-667
	oct	003003003003,003003003003	" 670-677
	oct	004004004004,004004004004	" 700-707
	oct	004004004004,004004004004	" 710-717
	oct	004004004004,004004004004	" 720-727
	oct	004004004004,004004004004	" 730-737
	oct	005005005005,005005005005	" 740-747
	oct	005005005005,005005005005	" 750-757
	oct	006006006006,006006006006	" 760-767
	oct	007007007007,010010011000	" 770-777

	even
last_on_bit_table: 
	oct	000011010011,007011010011	" 000-007
	oct	006011010011,007011010011	" 010-017
	oct	005011010011,007011010011	" 020-027
	oct	006011010011,007011010011	" 030-037
	oct	004011010011,007011010011	" 040-047
	oct	006011010011,007011010011	" 050-057
	oct	005011010011,007011010011	" 060-067
	oct	006011010011,007011010011	" 070-077
	oct	003011010011,007011010011	" 100-107
	oct	006011010011,007011010011	" 110-117
	oct	005011010011,007011010011	" 120-127
	oct	006011010011,007011010011	" 130-137
	oct	004011010011,007011010011	" 140-147
	oct	006011010011,007011010011	" 150-157
	oct	005011010011,007011010011	" 160-167
	oct	006011010011,007011010011	" 170-177
	oct	002011010011,007011010011	" 200-207
	oct	006011010011,007011010011	" 210-217
	oct	005011010011,007011010011	" 220-227
	oct	006011010011,007011010011	" 230-237
	oct	004011010011,007011010011	" 240-247
	oct	006011010011,007011010011	" 250-257
	oct	005011010011,007011010011	" 260-267
	oct	006011010011,007011010011	" 270-277
	oct	003011010011,007011010011	" 300-307
	oct	006011010011,007011010011	" 310-317
	oct	005011010011,007011010011	" 320-327
	oct	006011010011,007011010011	" 330-337
	oct	004011010011,007011010011	" 340-347
	oct	006011010011,007011010011	" 350-357
	oct	005011010011,007011010011	" 360-367
	oct	006011010011,007011010011	" 370-377
	oct	001011010011,007011010011	" 400-407
	oct	006011010011,007011010011	" 410-417
	oct	005011010011,007011010011	" 420-427
	oct	006011010011,007011010011	" 430-437
	oct	004011010011,007011010011	" 440-447
	oct	006011010011,007011010011	" 450-457
	oct	005011010011,007011010011	" 460-467
	oct	006011010011,007011010011	" 470-477
	oct	003011010011,007011010011	" 500-507
	oct	006011010011,007011010011	" 510-517
	oct	005011010011,007011010011	" 520-527
	oct	006011010011,007011010011	" 530-537
	oct	004011010011,007011010011	" 540-547
	oct	006011010011,007011010011	" 550-557
	oct	005011010011,007011010011	" 560-567
	oct	006011010011,007011010011	" 570-577
	oct	002011010011,007011010011	" 600-607
	oct	006011010011,007011010011	" 610-617
	oct	005011010011,007011010011	" 620-627
	oct	006011010011,007011010011	" 630-637
	oct	004011010011,007011010011	" 640-647
	oct	006011010011,007011010011	" 650-657
	oct	005011010011,007011010011	" 660-667
	oct	006011010011,007011010011	" 670-677
	oct	003011010011,007011010011	" 700-707
	oct	006011010011,007011010011	" 710-717
	oct	005011010011,007011010011	" 720-727
	oct	006011010011,007011010011	" 730-737
	oct	004011010011,007011010011	" 740-747
	oct	006011010011,007011010011	" 750-757
	oct	005011010011,007011010011	" 760-767
	oct	006011010011,007011010011	" 770-777

	even
last_off_bit_table: 
	oct	011010011007,011010011006	" 000-007
	oct	011010011007,011010011005	" 010-017
	oct	011010011007,011010011006	" 020-027
	oct	011010011007,011010011004	" 030-037
	oct	011010011007,011010011006	" 040-047
	oct	011010011007,011010011005	" 050-057
	oct	011010011007,011010011006	" 060-067
	oct	011010011007,011010011003	" 070-077
	oct	011010011007,011010011006	" 100-107
	oct	011010011007,011010011005	" 110-117
	oct	011010011007,011010011006	" 120-127
	oct	011010011007,011010011004	" 130-137
	oct	011010011007,011010011006	" 140-147
	oct	011010011007,011010011005	" 150-157
	oct	011010011007,011010011006	" 160-167
	oct	011010011007,011010011002	" 170-177
	oct	011010011007,011010011006	" 200-207
	oct	011010011007,011010011005	" 210-217
	oct	011010011007,011010011006	" 220-227
	oct	011010011007,011010011004	" 230-237
	oct	011010011007,011010011006	" 240-247
	oct	011010011007,011010011005	" 250-257
	oct	011010011007,011010011006	" 260-267
	oct	011010011007,011010011003	" 270-277
	oct	011010011007,011010011006	" 300-307
	oct	011010011007,011010011005	" 310-317
	oct	011010011007,011010011006	" 320-327
	oct	011010011007,011010011004	" 330-337
	oct	011010011007,011010011006	" 340-347
	oct	011010011007,011010011005	" 350-357
	oct	011010011007,011010011006	" 360-367
	oct	011010011007,011010011001	" 370-377
	oct	011010011007,011010011006	" 400-407
	oct	011010011007,011010011005	" 410-417
	oct	011010011007,011010011006	" 420-427
	oct	011010011007,011010011004	" 430-437
	oct	011010011007,011010011006	" 440-447
	oct	011010011007,011010011005	" 450-457
	oct	011010011007,011010011006	" 460-467
	oct	011010011007,011010011003	" 470-477
	oct	011010011007,011010011006	" 500-507
	oct	011010011007,011010011005	" 510-517
	oct	011010011007,011010011006	" 520-527
	oct	011010011007,011010011004	" 530-537
	oct	011010011007,011010011006	" 540-547
	oct	011010011007,011010011005	" 550-557
	oct	011010011007,011010011006	" 560-567
	oct	011010011007,011010011002	" 570-577
	oct	011010011007,011010011006	" 600-607
	oct	011010011007,011010011005	" 610-617
	oct	011010011007,011010011006	" 620-627
	oct	011010011007,011010011004	" 630-637
	oct	011010011007,011010011006	" 640-647
	oct	011010011007,011010011005	" 650-657
	oct	011010011007,011010011006	" 660-667
	oct	011010011007,011010011003	" 670-677
	oct	011010011007,011010011006	" 700-707
	oct	011010011007,011010011005	" 710-717
	oct	011010011007,011010011006	" 720-727
	oct	011010011007,011010011004	" 730-737
	oct	011010011007,011010011006	" 740-747
	oct	011010011007,011010011005	" 750-757
	oct	011010011007,011010011006	" 760-767
	oct	011010011007,011010011000	" 770-777

	end




		    find_char_.alm                  11/11/89  1150.6rew 11/11/89  0805.5      300600



" ***********************************************************
" *                                                         *
" * 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(74-07-01,GDixon), approve(), audit(), install():
"     Create initial version of the program, called tct_.
"  2) change(75-09-25,GDixon), approve(), audit(), install():
"     Add $quote table segdef.
"  3) change(76-03-12,GDixon), approve(), audit(), install():
"     Add $verify, $reverse_verify, $search, and $reverse_search entrypoints.
"  4) change(86-02-05,GDixon), approve(86-05-16,MCR7357),
"     audit(86-07-10,Farley), install(86-07-17,MR12.0-1097):
"     Renamed subr from tct_ to find_char_.  Renamed all entrypoints.
"     Added the $make_table_of_chars_in_list and
"     $make_table_of_chars_not_in_list entrypoints.
"     Also fixed bug which prevents find_char_$last_in_table,
"     $translate_last_in_table, $last_in_list and $last_not_in_list
"     from working properly.
"                                                      END HISTORY COMMENTS

" *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *
"
" Name:  find_char_
"
"      This subroutine uses the EIS test character and translate (TCT) 
" instruction to perform the function of the PL/I search and verify builtins.
" The code uses either a pre-defined test/translate table, or it constructs
" one "on the fly".
"
" Entry:  find_char_$first_in_table
"
" Function: This entry point implements the PL/I search builtin function 
" with a predefined test/translate table.
"
" Syntax: 
"      dcl find_char_$first_in_table entry (char(*), char(512) aligned)
"	 returns (fixed bin(21)) reducible;
"      index = find_char_$first_in_table (string, table);
"
" Arguments:
" string
"    is the character string to be searched. (In)
" table
"    is the translation table.  (See Notes below.) (In)
" index
"    is the result of the search.  It is a PL/I string index (character 
"    position). (Out)
"
" Entry: find_char_$last_in_table
"
" Function: This entry point is like find_char_$first_in_table, but searches
" the string in reverse, from last character to first.  A PL/I string index
" (character position relative to the beginning of the string) is returned.
" It performs the PL/I function:
"	i = length(string) - search (reverse(string), table_chars) + 1
"		[when char searched for is found in string]
"	i = 0     [when char searched for is not found.]
"
"
" Syntax: 
"      dcl find_char_$last_in_table entry (char(*), char(512) aligned) 
"         returns (fixed bin(21)) reducible;
"      index = find_char_$last_in_table (string, table);
"
" Arguments:
" string
"    is the character string to be searched. (In)
" table
"    is the translation table.  (See Notes below.) (In)
" index
"    is the result of the search.  It is a PL/I string index (character 
"    position). (Out)
"
" Entry: find_char_$translate_first_in_table
"
" Function: This entry point performs the PL/I search function, but also
" returns the translate table entry for the character which stopped the search.
" See Notes below for a more explicit description of the returned
" character.
"
" Syntax: 
"      dcl find_char_$translate_first_in_table entry (char(*), 
"	 char(512) aligned, fixed bin(21)) returns (char(1));
"      char = find_char_$translate_first_in_table (string, table, index);
"
" Arguments:
" string
"    is the character string to be searched. (In)
" table
"    is the translation table.  (See Notes below.) (In)
" index
"    is the result of the search.  It is a PL/I string index (character 
"    position). (Out)
" char
"    is the character from the translation table into which the indexed 
"    character of string has been translated. (Out)
"
" Entry: find_char_$translate_last_in_table
"
" Function: This entry is like find_char_$translate_first_in_table, but does
" the search function in reverse, from last char of string to first.
"
" Syntax: 
"      dcl find_char_$translate_last_in_table entry (char(*),
"          char(512) aligned, fixed bin(21)) returns (char(1));
"      char = find_char_$translate_last_in_table (string, table, index);
"
" Arguments:
" string
"    is the character string to be searched. (In)
" table
"    is the translation table.  (See Notes below.) (In)
" index
"    is the result of the search.  It is a PL/I string index (character 
"    position). (Out)
" char
"    is the character from the translation table into which the indexed 
"    character of string has been translated. (Out)
"
" Entry: find_char_$first_in_list
"
" Function:  This entry performs the PL/I function:
"	index = search (string, chars);
"
" Syntax:
"      dcl find_char_$first_in_list entry (char(*), char(*))
"	 returns(fixed bin(21)) reducible;
"      index = find_char_$first_in_list (string, search_list);
"	
" Arguments:
" string
"    is the character string to be searched. (In)
" search_list
"    are characters to be found in the string.  (In)
" index
"    is the result of the search.  It is the PL/I string index (character 
"    position) of the first occurrence of any of the search characters in
"    string. (Out)
"
" Entry:  find_char_$last_in_list
"
" Function: This entry returns the index (character position relative to the
" beginning of the string) of the rightmost occurrence of any of the characters
" being searched for.  It performs the PL/I function:
"     index = length(string) - search (reverse(string), chars) + 1
"		[when char searched for is found in string]
"     index = 0     [when char searched for is not found.]
"
" Syntax:
"      dcl find_char_$last_in_list entry (char(*), char(*))
"	 returns(fixed bin(21)) reducible;
"      i = find_char_$last_in_list (string, search_list);
"
" Arguments:
" string
"    is the character string to be searched. (In)
" search_list
"    are characters to be found in the string.  (In)
" index
"    is the result of the search.  It is the PL/I string index (character 
"    position) of the last occurrence of any of the search characters in
"    string. (Out)
"
" Entry:  find_char_$first_not_in_list
"
" Function:  This entry performs the PL/I function:
"	index = verify(string, chars)
"
" Syntax: 
"      dcl find_char_$first_not_in_list entry (char(*), char(*))
"	 returns(fixed bin(21)) reducible;
"      i = find_char_$first_not_in_list (string, verify_list);
"
" Arguments:
" string
"    is the character string to be searched. (In)
" verify_list
"    are characters whose existence in the string is to be verified.  (In)
" index
"    is the result of the verify.  It is the PL/I string index (character 
"    position) of the first occurrence of a string character which is not
"    an element in verify_list. (Out)
"
" Entry:  find_char_$last_not_in_list
"
" Function: This entry returns the index (character position relative to the
" beginning of the string) of the rightmost occurrence of a char in string
" which is not an element of verify_chars.  It performs the PL/I function:
"     index = length(string) - verify (reverse(string), chars) + 1
"		[when character not in chars is found in string]
"     index = 0     [when character not in chars is not found in string.]
"
" Syntax: 
"      dcl find_char_$last_not_in_list entry (char(*), char(*))
"	 returns(fixed bin(21)) reducible;
"      i = find_char_$last_not_in_list (string, verify_list);
"
" Arguments:
" string
"    is the character string to be searched. (In)
" verify_list
"    are characters whose existence in the string is to be verified.  (In)
" index
"    is the result of the verify.  It is the PL/I string index (character 
"    position) of the last occurrence of a string character which is not
"    an element in verify_list. (Out)
" 
" Entry:  find_char_$make_table_of_chars_in_list
" 
" Function:  This entry constructs a test/translate table for use with the
" find_char_$first_in_table and find_char_$last_in_table entrypoints.
" Table entries corresponding to characters of search_list are marked with
" \777 in the search table.  Other table entries are filled with \000.
" 
" Syntax:
"    dcl find_char_$make_table_of_chars_in_list (char(*), char(512) aligned);
"    call find_char_$make_table_of_chars_in_list (search_list, table);
" 
" Arguments:
" search_list
"    is a string of characters whose corresponding entries are to be marked in
"    the resulting translate table. (In)
" table
"    is the translate table. (Out)
"
" Entry:  find_char_$make_table_of_chars_not_in_list
" 
" Function:  This entry constructs a test/translate table for use with the
" find_char_$first_in_table and find_char_$last_in_table entrypoints.
" Table entries corresponding to characters of verify_list are marked with
" \000 in the search table.  Other table entries are filled with \777.
" 
" Syntax:
"    dcl find_char_$make_table_of_chars_not_in_list
"	(char(*), char(512) aligned);
"    call find_char_$make_table_of_chars_not_in_list (verify_list, table);
" 
" Arguments:
" verify_list
"    is a string of characters whose corresponding entries are to remain
"    unmarked in the resulting translate table. (In)
" table
"    is the translate table. (Out)
"
" Notes
"
"      The test/translate table is a fixed length character string.  It
" should be 512 characters long to cover all possible Multics
" 9-bit byte values.
"
"      The test/translate table consists of "\000" characters and
" characters which are not "\000".  The search progresses as follows:
"
" 1) Examine the first (or next) character of the source string.
"    If i is the index of the character being examined, then
"    	source_char = substr(string, i, 1)
" 2) For each source_char, examine its corresponding table_char:
"	table_char = substr(table,rank(source_char)+1,1)
" 3) If table_char = "\000", then the test fails and the search
"    continues with step 1.
" 4) If table_char ^= "\000", then the test succeeds and the search
"    stops.  The current value of i is returned as the index 
"    value.  For the $translate entry points, table_char is returned
"    as the char argument.
" 5) If the source string is exhausted before the test succeeds, then
"    a value of 0 is returned as the index argument, and for the
"    $translate entry point, "\000" is returned as the char argument.
"
" Table:  find_char_$not_ascii_table
"
"      This is a translation table which can be used to detect any
" non-ASCII characters in a character string.  Non-ASCII characters
" are those in which one or both of the 2 leftmost bits of the
" 9-bit character byte are "1"b (i.e., character > "\177").  The
" first 128 values in the table are "\000".  The next 384 table
" characters are set to their character offset within the table.
" This means that:
"      substr(table,n+1,1) = "\000", for n:  000 <= n <= 127
"      substr(table,n+1,1) = "\n",   for n:  128 <= n <= 511
"
" *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *

" -----------------------------------------------------------------------------
" Segname, and entrypoint definitions.
" -----------------------------------------------------------------------------

	name	find_char_

	segdef	first_in_table
	segdef	last_in_table
	segdef	translate_first_in_table
	segdef	translate_last_in_table

	entry	first_in_list
	entry	first_not_in_list
	entry	last_in_list
	entry	last_not_in_list
	entry	make_table_of_chars_in_list
	entry	make_table_of_chars_not_in_list

	segdef	not_ascii_table

" -----------------------------------------------------------------------------
" Code for find_char_$first_in_table, $translate_first_in_table,
" $last_in_table, and $translate_last_in_table, $first_in_list,
" $first_not_in_list, $last_in_list and $last_not_in_list.
" -----------------------------------------------------------------------------

" Register name assignments: 
	equ	arg_list,0	" pr0 -> argument list
	equ	string,1		" pr1 -> string to be searched.
	equ	search_list,2	" pr2 -> search_list, verify_list.
	equ	table,3		" pr3 -> test/translate table.
	equ	char,4		" pr4 -> value of test/translate table
				"        element corresponding to the
				"        string character found by tct.
	equ	search_list_char,4	" pr4 -> a char from search_list.
	equ	index,5		" pr5 -> character index of string
				"        character found by tct instr.
	equ	auto_storage,6	" pr6 -> stack frame, containing
				"        storage for automatic vars.

	equ	desc_offset,2	"   x2 = word offset of 1st arg
				"        descriptor in arg_list.
	equ	do_index,3	"   x3 = a do group index.
	equ	return_loc,6	"   x6 = subroutine return location.

	temp	table_var(128)	" automatic char(512) aligned table
				"   for use in tct/tctr instructions
				"   when $XXX_in_list make their
				"   own table.
	temp	search_list_char_var(1)
				" automatic char(1) aligned word to
				"   hold one search_list char at
				"   a time so its rank can be computed.

desc_length_mask:			" ANDing mask to extract char string
	oct	000077777777	"   length from an argument descriptor.
string_index_mask:			" ANDing mask to extract char offset
	oct	000777777777	"   from result of TCT instruction.

" -----------------------------------------------------------------------------
" find_char_$first_in_table: proc (string, table) returns (index);
" -----------------------------------------------------------------------------
first_in_table:
	ldx	desc_offset,8,du	" set offset of first argument 
				"   descriptor from head of arglist.
	tsx	return_loc,get_table_parms
				" get parm ptr/lengths
	tsx	return_loc,tct	" execute tct instruction
	ttf	first_in_table_match
				" Branch if tct found a match
	stz	index|0		" tct failed... store 0 in result
	short_return

first_in_table_match:		" tct succeeded
	tsx	return_loc,set_tct_index_parm
	short_return

" -----------------------------------------------------------------------------
" find_char_$last_in_table: entry (string, table) returns (index);
" -----------------------------------------------------------------------------
last_in_table:
	ldx	desc_offset,8,du	" set offset of 1st arg desc
	tsx	return_loc,get_table_parms
				" get parm ptr/lengths
	tsx	return_loc,tctr	" execute tctr instruction
	ttf	last_in_table_match	" Branch if tctr found a match.

	stz	index|0		" tctr failed... store 0 in result
	short_return

last_in_table_match:		" tctr succeeded
	tsx	return_loc,set_tctr_index_parm
	short_return

" -----------------------------------------------------------------------------
" find_char_$translate_first_in_table: entry (string, table, index)
"     returns (char);
" -----------------------------------------------------------------------------
translate_first_in_table:
	ldx	desc_offset,10,du	" set offset of first argument
				"   descriptor		
	tsx	return_loc,get_table_parms
				" get parm ptr/lengths
	tsx	return_loc,tct	" execute tct instruction
	ttf	translate_first_in_table_match
				" Branch if tct found a match.
	stz	index|0		" tct failed... store 0 in result
	tsx	return_loc,set_char_parm
				" move \000 from index into char parm.
	short_return		" tct failed.

translate_first_in_table_match:	" tct succeeded.
	tsx	return_loc,set_char_parm
				" move translated char into char parm.
	tsx	return_loc,set_tct_index_parm
	short_return

" -----------------------------------------------------------------------------
" find_char_$translate_last_in_table: entry (string, table, index)
"		      returns (char);
" -----------------------------------------------------------------------------
translate_last_in_table:
	ldx	desc_offset,10,du	" set offset of 1st arg desc
	tsx	return_loc,get_table_parms
				" get parm ptr/lengths
	tsx	return_loc,tctr	" execute tctr instruction
	ttf	translate_last_in_table_match
				" Branch if tctr found a match.
	stz	index|0		" tctr failed... store 0 in result
	tsx	return_loc,set_char_parm
				" move \000 from index into char parm.
	short_return

translate_last_in_table_match: 
	tsx	return_loc,set_char_parm
				" move translated char into char parm.
	tsx	return_loc,set_tctr_index_parm
	short_return

" -----------------------------------------------------------------------------
" make_table_of_chars_not_in_list: entry (verify_list, table);
" -----------------------------------------------------------------------------
make_table_of_chars_not_in_list: 
	push			" Need automatic variables when
				"   filling the search table.
	tsx	return_loc,get_make_table_parms
	tsx	return_loc,fill_table_from_list
	tsx	return_loc,invert_table_entries
	return

" -----------------------------------------------------------------------------
" make_table_of_chars_in_list: entry (search_list, table);
" -----------------------------------------------------------------------------
make_table_of_chars_in_list: 
	push			" Need automatic variables when
				"   filling the search table.
	tsx	return_loc,get_make_table_parms
	tsx	return_loc,fill_table_from_list
	return

" -----------------------------------------------------------------------------
" first_in_list: entry (string, search_list) returns (index);
" -----------------------------------------------------------------------------
first_in_list:
	push			" Need automatic variables when
				"   filling the search table.
	tsx	return_loc,get_list_parms
	tsx	return_loc,fill_table_from_list
				" build table from search_list
	tsx	return_loc,tct	" execute tct instruction
	ttf	first_in_list_match	" Branch if it succeeds.
	stz	index|0		" tct failed... store 0 result.
	return

first_in_list_match:		" tct succeeded
	tsx	return_loc,set_tct_index_parm
	return

" -----------------------------------------------------------------------------
" last_in_list: entry (string, search_list) returns (index);
" -----------------------------------------------------------------------------
last_in_list:
	push			" Need automatic variables when
				"   filling the search table.
	tsx	return_loc,get_list_parms
	tsx	return_loc,fill_table_from_list
				" build table from search_list
	tsx	return_loc,tctr	" execute tctr instruction
	ttf	last_in_list_match
				" Branch if it succeeds.
	stz	index|0		" tctr failed... store 0 result.
	return

last_in_list_match:			" tctr succeeded
	tsx	return_loc,set_tctr_index_parm
	return

" -----------------------------------------------------------------------------
" first_not_in_list: entry (string, verify_list) returns (index);
" -----------------------------------------------------------------------------
first_not_in_list:
	push			" Need automatic variables when
				"   filling the search table.
	tsx	return_loc,get_list_parms
				" get parms
	tsx	return_loc,fill_table_from_list
				" build table from verify_list
	tsx	return_loc,invert_table_entries
				" convert search table to verify table
	tsx	return_loc,tct	" execute tct instruction
	ttf	first_not_in_list_match
				" Branch if it succeeds.
	stz	index|0		" tct failed... store 0 result.
	return

first_not_in_list_match:		" tct succeeded
	tsx	return_loc,set_tct_index_parm
	return

" -----------------------------------------------------------------------------
" last_not_in_list: entry (string, verify_list) returns (index);
" -----------------------------------------------------------------------------
last_not_in_list:
	push			" Need automatic variables 
				"   filling the search table.
	tsx	return_loc,get_list_parms
	tsx	return_loc,fill_table_from_list
				" build table from verify_list
	tsx	return_loc,invert_table_entries
				" convert search table to verify table
	tsx	return_loc,tctr	" execute tctr instruction
	ttf	last_not_in_list_match
				" Branch if it succeeds.
	stz	index|0		" tctr failed... store 0 result.
	return

last_not_in_list_match:		" tctr succeeded
	tsx	return_loc,set_tctr_index_parm
	return

" =============================================================================
" QUICK-BLOCK SUBROUTINES WHICH ACTUALLY DO THE WORK
" =============================================================================

" -----------------------------------------------------------------------------
" Fill test/translate table, using specs in search_list string.
"   In:	pr(table)            -> translate/test table to be filled in.
"	pr(search_list)	 -> search_list character string to be turned
"			    into a table.
"	x(do_index)	  = length(search_list).
"	pr(search_list_char) -> space to hold one char from search list,
"			    so its rank can be computed.
"	x(return_loc)	  = location this subroutine should return to.
"  Out:	pr(table)            -> filled-in translate/test table.
" -----------------------------------------------------------------------------
fill_table_from_list: 
	even
	mlr	(pr),(pr),fill(000)	" fill table with 000's
	desc9a	table|0,0
	desc9a	table|0,512

	stz	search_list_char|0	" clear search_list_char variable
loop:	cmpx	do_index,0,du	" exit loop when search_list exhausted
	tze	0,return_loc
	sbx	do_index,1,du	" decrement length(search_list)
	even
	mlr	(pr,x3),(pr),fill(000) 
	desc9a	search_list|0,1	" search_list_char =
				"   substr(search_list,do_index,1)
	desc9a	search_list_char|0(3),1	
	ldq	search_list_char|0	
	even
	mlr	(pr),(pr,ql),fill(777)
	desc9a	table|0,0		" move 777 into 
	desc9a	table|0,1		"   table(rank(search_list_char))
	tra 	loop

" -----------------------------------------------------------------------------
" Get addr/length of string, search_list or verify_list and index parms
"   In:	pr(arg_list)         -> the argument list.
"	x(return_loc)	  = location this subroutine should return to.
"  Out:	pr(string)           -> string to be searched.
"	pr(search_list)      -> chars in search_list or verify_list.
"	pr(index)		 -> character index within string.
"	a-reg                 = length(string).
"	x(do-index)	  = length(search_list).
"	pr(table)            -> test/translate table.
"	pr(search_list_char) -> automatic variable to hold one
"			    search_list char.
" -----------------------------------------------------------------------------
get_list_parms:
	epp	string,arg_list|2,*	" get addr(string)      [arg1]
	epp	search_list,arg_list|4,*
				" get addr(search_list) [arg2]
	epp	index,arg_list|6,*	" get addr(index)  [arg3]
				" get length(string) into a-reg.
	ldx	desc_offset,8,du	"   offset of arg1 descriptor in
	lxl3	arg_list|0	"     arg_list.
	cmpx3	4,du		"   does arglist have parent ptr?
	tze	2,ic		"   4 means no parent ptr.
	adx	desc_offset,2,du	"   otherwise, skip parent ptr.
	lda	arg_list|0,desc_offset*
				"   get length of string in a-reg.
	ana	desc_length_mask	"   mask out all but length.
	ldq	arg_list|2,desc_offset* 
	anq	desc_length_mask	" get length(search_list) into q-reg.
	eax	do_index,0,ql	" get length(search_list) into x3.
	epp	table,auto_storage|table_var
	epp	search_list_char,auto_storage|search_list_char_var
				" get pointers to automatic variables
	tra	0,return_loc	

" -----------------------------------------------------------------------------
" Get addr/length of search_list or verify_list parm, and output table parm.
"   In:	pr(arg_list)         -> the argument list.
"	x(return_loc)	  = location this subroutine should return to.
"  Out:	pr(search_list)	 -> chars in search_list, verify_list.
"	pr(table)		 -> test/translate table.
"	pr(search_list_char) -> automatic variable to hold one search_list
"			    char.
"	x(do_index)	  = length(search_list).
" -----------------------------------------------------------------------------
get_make_table_parms: 
	epp	search_list,arg_list|2,*
				" get addr(search_list) [arg1]
	epp	table,arg_list|4,*	" get addr(table)       [arg2]
	ldx	desc_offset,6,du	" get length(search_list) from its arg
	lxl3	arg_list|0	"   descriptor into a-reg.
	cmpx3	4,du		"   compensate if arglist has parent
	tze	2,ic		"     ptr.  4 means no parent ptr.
	adx	desc_offset,2,du	"   if there, skip parent ptr.
	lda	arg_list|0,desc_offset*
				"   load 1st arg desc into a-reg.
	ana	desc_length_mask	"   mask off all but the length.
	eax	do_index,0,al	" get length(search_list) into x3.
	epp	search_list_char,auto_storage|search_list_char_var
				" get addr(search_list_char), making it
	tra	0,return_loc	"   point to an automatic variable.

" -----------------------------------------------------------------------------
" Get pointers/length of find_char_$XXX_in_table parm: string, table, index.
"   In:	pr(arg_list)         -> the argument list.
"	x(desc_offset)        = offset in arg list of arg1 descriptor.
"	x(return_loc)	  = location this subroutine should return to.
"  Out:	pr(string)           -> string to be searched.
"	pr(table)            -> test/translate table.
"	pr(index)		 -> character index within string.
"	a-reg                 = length(string).
" -----------------------------------------------------------------------------
get_table_parms:
	epp	string,arg_list|2,*	" get addr(string) [arg1]
	epp	table,arg_list|4,*	" get addr(table)  [arg2]
	epp	index,arg_list|6,*	" get addr(index)  [arg3]
				" get length(string) into a-reg.
	lxl3	arg_list|0	"   compensate if arg list has parent
	cmpx3	4,du		"     ptr.
	tze	2,ic		"   4 means no parent ptr.
	adx	desc_offset,2,du	"   else, skip over parent ptr.
	lda	arg_list|0,desc_offset*
				"   load descriptor for string.
	ana	desc_length_mask	"   mask out all but string length from
				"    descriptor.
	tra	0,return_loc

" -----------------------------------------------------------------------------
" Convert from a search table to a verify table by inverting all table bits.
"   In: 	pr(table)     -> the search table (char(512) aligned)
"	x(return_loc)  = location this subroutine should return to.
"  Out: 	pr(table)	    -> the verify table
" -----------------------------------------------------------------------------
invert_table_entries:	 	" invert bytes in test/translate table
	lxl7	(512*9),dl	" (make off bytes on, on bytes off)
	even			" since:  verify(x) <=> search(^x)
	bool	invert,014	
	csl	(pr,rl),(pr,rl),fill(0),bool(invert)
	descb	table|0,x7	" See fill_table_from_list below.
	descb	table|0,x7	" Remember that the search table has
	tra	0,return_loc	"   bytes containing either \000 or
				"   \777.  ^\777 = \000, ^\000 = \777

" -----------------------------------------------------------------------------
" Move translated char (char selected from table by tct/tctr instruction)
" from first byte of index (where tct/tctr put it) into translate table
" char output parm (arg4).
"   In:	pr(arg_list)   -> the argument list.
"	pr(index)	     -> result of TCT or TCTR instruction: character offset
"		        from right end of string, preceded by char
"		        from selected table entry.
"	x(return_loc)   = location this subroutine should return to.
"  Out:	pr(char)	     -> char parm in which table char is returned.
" -----------------------------------------------------------------------------
set_char_parm: 
	epp	char,arg_list|8,* 	" get addr(char) [arg4]
	even
	mlr	(pr),(pr),fill(000)	" move translated char to 4th arg
	desc9a	index|0,1		"   TCT result: 1st byte is trans_char
	desc9a	char|0,1		"   4th arg
	tra	0,return_loc

" -----------------------------------------------------------------------------
" Adjust index to remove translated char, and convert byte offset to a
" byte index.
"   In:	pr(index)	     -> result of TCT or TCTR instruction: character offset
"		        from right end of string, preceded by char
"		        from selected table entry.
"	x(return_loc)   = location this subroutine should return to.
"  Out:	pr(index)	     -> character index within string of selected char.
" -----------------------------------------------------------------------------
set_tct_index_parm: 
	ldq	index|0		" load string offset
	anq	string_index_mask	" mask away translated char
	adq	1,dl		" make string offset into index
	stq	index|0		" store index
	tra	0,return_loc

" -----------------------------------------------------------------------------
" Adjust index to remove translated char, convert byte offset to a
" byte index, and shift from byte-index-relative-to-right-end of string to
" byte-index-relative-to-left-end of string.
"   In:	pr(index)	     -> result of TCT or TCTR instruction: character offset
"		        from right end of string, preceded by char
"		        from selected table entry.
"	x(return_loc)   = location this subroutine should return to.
"  Out:	pr(index)	     -> character index within string of selected char.
" -----------------------------------------------------------------------------
set_tctr_index_parm: 
	ldq	index|0		" load string reverse_offset
	anq	string_index_mask	" mask away translated char
	adq	1,dl		" make string reverse_offset into
				"   reverse_index
	stq	index|0		" store reverse_index
	sba	index|0		" index = length(string) 
	ada	1,dl		"       - reverse_index + 1
	sta	index|0
	tra	0,return_loc

" -----------------------------------------------------------------------------
" Execute tct instruction on string, using table.
"   In:	pr(string)           -> string to be searched.
"	a-reg                 = length(string).
"	pr(table)            -> test/translate table.
"	x(return_loc)	  = location this subroutine should return to.
"  Out:	pr(index)		 -> result of TCT instruction: character offset
"			    within string, preceded by char from selected
"			    table entry.
" -----------------------------------------------------------------------------
	even
tct:	tct	(pr,rl),fill(000)	" test and translate, using the table
	desc9a	string|0,al	"   string,length-in-'a'-register
	arg	table|0		"   table
	arg	index|0		"   result of find_char_ stored in
				"     index parm
	tra	0,return_loc

" -----------------------------------------------------------------------------
" Execute tctr instruction on string, using table.
"   In:	pr(string)           -> string to be searched.
"	a-reg                 = length(string).
"	pr(table)            -> test/translate table.
"	x(return_loc)	  = location this subroutine should return to.
"  Out:	pr(index)		 -> result of TCTR instruction: character offset
"			    from right end of string, preceded by char
"			    from selected table entry.
" -----------------------------------------------------------------------------
	even
tctr:	tctr	(pr,rl),fill(000)	" test/translate in reverse
	desc9a	string|0,al	"   string, length in 'a'-reg
	arg	table|0		"   table
	arg 	index|0		"   result
	tra	0,return_loc

		even
not_ascii_table:	oct	000000000000,000000000000	" 000-007
		oct	000000000000,000000000000	" 010-017
		oct	000000000000,000000000000	" 020-027
		oct	000000000000,000000000000	" 030-037
		oct	000000000000,000000000000	" 040-047
		oct	000000000000,000000000000	" 050-057
		oct	000000000000,000000000000	" 060-067
		oct	000000000000,000000000000	" 070-077
		oct	000000000000,000000000000	" 100-107
		oct	000000000000,000000000000	" 110-117
		oct	000000000000,000000000000	" 120-127
		oct	000000000000,000000000000	" 130-137
		oct	000000000000,000000000000	" 140-147
		oct	000000000000,000000000000	" 150-157
		oct	000000000000,000000000000	" 160-167
		oct	000000000000,000000000000	" 170-177
		oct	200201202203,204205206207	" 200-207
		oct	210211212213,214215216217	" 210-217
		oct	220221222223,224225226227	" 220-227
		oct	230231232233,234235236237	" 230-237
		oct	240241242243,244245246247	" 240-247
		oct	250251252253,254255256257	" 250-257
		oct	260261262263,264265266267	" 260-267
		oct	270271272273,274275276277	" 270-277
		oct	300301302303,304305306307	" 300-307
		oct	310311312313,314315316317	" 310-317
		oct	320321322323,324325326327	" 320-327
		oct	330331332333,334335336337	" 330-337
		oct	340341342343,344345346347	" 340-347
		oct	350351352353,354355356357	" 350-357
		oct	360361362363,364365366367	" 360-367
		oct	370371372373,374375376377	" 370-377
		oct	400401402403,404405406407	" 400-407
		oct	410411412413,414415416417	" 410-417
		oct	420421422423,424425426427	" 420-427
		oct	430431432433,434435436437	" 430-437
		oct	440441442443,444445446447	" 440-447
		oct	450451452453,454455456457	" 450-457
		oct	460461462463,464465466467	" 460-467
		oct	470471472473,474475476477	" 470-477
		oct	500501502503,504505506507	" 500-507
		oct	510511512513,514515516517	" 510-517
		oct	520521522523,524525526527	" 520-527
		oct	530531532533,534535536537	" 530-537
		oct	540541542543,544545546547	" 540-547
		oct	550551552553,554555556557	" 550-557
		oct	560561562563,564565566567	" 560-567
		oct	570571572573,574575576577	" 570-577
		oct	600601602603,604605606607	" 600-607
		oct	610611612613,614615616617	" 610-617
		oct	620621622623,624625626627	" 620-627
		oct	630631632633,634635636637	" 630-637
		oct	640641642643,644645646647	" 640-647
		oct	650651652653,654655656657	" 650-657
		oct	660661662663,664665666667	" 660-667
		oct	670671672673,674675676677	" 670-677
		oct	700701702703,704705706707	" 700-707
		oct	710711712713,714715716717	" 710-717
		oct	720721722723,724725726727	" 720-727
		oct	730731732733,734735736737	" 730-737
		oct	740741742743,744745746747	" 740-747
		oct	750751752753,754755756757	" 750-757
		oct	760761762763,764765766767	" 760-767
		oct	770771772773,774775776777	" 770-777

		end




		    formline_.alm                   11/11/89  1150.6r w 11/11/89  0803.9      500202



" ******************************************************
" *                                                    *
" * 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. *
" *                                                    *
" ******************************************************

" Completely rewritten by B. L. Wolman on 2/3/74 to use EIS
" Modified by R. K. Kanodia on 2/27/75   so that in
" ASCII strings mlr would not move zero length sring. See the label mc.
" Modified March 75 by Larry Johnson to fix several bugs and modify iteration logic
" Modified July 75 by Larry Johnson to enable ^p to handle invalid pointers and to
"	implement array processing.
" Modified August 1976 by Larry Johnson to implement if/then/else and
"	case features.
" Modified May 1978 by Larry Johnson to support ^np, and to accept character
"	arguments for ^d,^f,^e,^o,^[,^vX etc.
" Modified September 1978 by Larry Johnson to support all new pl1 and cobol
"	data types (primarily unsigned and 4-bit decimal). All argument
"	type processing was cleaned up to remove all internal coding
"	of data types. The include file std_descriptor_types is used.
" Modified November 1978 by Larry Johnson to add ^t. The entire program was
"	changed to use a common procedure to move data to the output buffer.
" Modified July 1979 by Larry Johnson to implement formline_$switch.  This
"	allows formline_ to generate an unlimited amout of output to be
"	to be written to an I/O switch instead of using a fixed size buffer
"	supplied by the caller.
" Modified December 1983 by Keith Loepere so i/o switch write works in bce.
" Modified January 29 1984 by Tom Oke to utilize any_to_any_ re-write and
"	generic float decimal data type for extended exponent ranges.

" call formline_(control,arg,prs,lrs,pad,alp)

" control		number of control string in arg list
" arg		number of first arg to control list in arg list
" prs		pointer to return string (INPUT) aligned
" lrs		length of return string in characters
" pad		one if padding required otherwise zero
" alp		arglist ptr -- optional (default alp is taken from preceding stack frame)

" call formline_$switch(control,arg,iocbp,nl,code,alp)

" control		as above
" arg		as above
" iocbp		pointer to iocb of switch to write upon
" nl		one if newline required, otherwise 0
" code		standard error code, returned by iox_$put_chars
" alp		as above, also optional

	name	formline_

	entry	formline_		Primary entry, as called by ioa_
	entry	ge		for output in GEBCD
	entry	switch		write output directly to I/O switch

	tempd	argp,inptr,buffptr
	tempd	pal,size,sizesp
	tempd	t1,t2,t3,t4
	temp	precision,exponent	EXPONENT MUST PRECEED TEMP1
	tempd	temp1(8),temp2(9),work(80)

	tempd	save_inptr	pointer to after ^ of current cmd
	temp	save_inlen	chars remaining after save_inptr
	temp	save_x7.x5	temp storage in ext calls X7/du, X5/dl

	temp	inlen
	temp	dpd,length
	temp	entry_switch	-1 for switch, 0 for normal, 1 for ge
	temp	default_precision,cur_arg,num_args,no_more_args

	temp	movinh		if >0 output movement inhibited by ^0( or bracket
	temp	depth		combined depth of parens and brackets
	temp	iter_count(4)	count of iterations - goes from negative to 0
	temp	iter_pointer(4)	ptr to ctrl string where iteration started
	temp	iter_length(4)	chars remaining in control string at iterate start
	temp	iter_cur_arg(4)	position in argument list at start of iteration
	temp	iter_argp(4)	argument pointer when iteration started
	temp	bracket_clause(4)	current clause in brackets
	temp	bracket_search(4)	clause that should be performed
	temp	brflags(4)	flags for each level of paren and brackket
	bool	brflags.movinh,400000	setting of movinh from previouss level
	bool	brflags.iteration,200000	on means in parens, off means in brackets
	bool	brflags.indefinite,100000	indefinite iteration - no count given


	temp	array_in_progress	+ if in array, 0 if not, - if array checking inhibited
	temp	array_mult	multiplier (words or bits) to step thru array
	temp	array_packed	non-zero if packed array (array_mult in bits)
	temp	array_desc	description word is saved here
	temp	array_length	total elements in array (product of all dims)
	temp	array_position	current position in array

	temp	v_not_done	this switch is set if a ^vX was not evaluated because
"				the movinh switch prevented an arg fetch

	equ	max_depth,4	combined max depth of parens and brackets


	include	stack_frame
	include	stack_header
	include	eis_micro_ops
	include	std_descriptor_types

" Miscellaneous character definitions

	bool	blank,040
	bool	minus,055		-
	bool	nl,012		new line
	bool	ht,011		horizontal tab
	bool	ff,014		Form-feed/new-page
	bool	rs,016		redshift
	bool	bs,017		black shift
	bool	zero,60		0
	bool	.,56		period
	bool	plus,53		+
	bool	star,52		*
	bool	lp,50		(
	bool	rp,51		)
	bool	esc,136		^
	bool	bar,174		|
	bool	e,145		e
	bool	v,166		v

"	Version II descriptor types

	bool	packed,1
	even
nullptr:	its	-1,1		a null pointer
ptrmask:	oct	077777000077,777777077077 a pointer mask

ge:	save
	lda	1,dl
	tra	form

formline_:
	save
	lda	0,dl
	tra	form

switch:	save
	lca	1,dl

form:	sta	entry_switch	save setting of output switch

	ldx2	ap|0		get current arglist header
	cmpx2	12,du		six arguments?
	tnz	no_alp		No

	ldaq	ap|12,*		Yes, get arglist ptr
	eraq	nullptr		Is it null?
	anaq	ptrmask		mask out non-unique ptr bits
	tze	no_alp		it's null

	eppbp	ap|12,*		get ptr to arg 6
	eppbp	bp|0,*		get arglist ptr supplied by caller
	tra	*+3

no_alp:	eppbp	sp|stack_frame.prev_sp,* go back one stack frame
	eppbp	bp|stack_frame.arg_ptr,* get arglist ptr from this frame

	spribp	pal		pointer to arg list
	ldaq	bp|0		get header of arg list
	sta	num_args		save 2*number of args
	ldx6	num_args
	tnz	args		are there args
	szn	entry_switch	switch entry?
	tmi	setup_output
	stz	ap|8,*		return null string
	return			we are done
args:	cana	=o10,dl		account for space used for internal
	tze	*+2		procedures in computing
	eaa	2,au
	sta	dpd		displacement to descriptor pointers
"
"	get ptr to and length of control string
"
	lca	1,dl		load a -1
	sta	array_in_progress	inhibit getarg from checking for arrays
	lda	ap|2,*
	als	1
	eax6	0,al
	tsx2	getarg
	stz	array_in_progress	we care about arrays now
	eax2	cstype		we want char string
	tsx3	fillin
	tra	done		exit if not char string
	spri2	inptr		save ptr and length
	stq	inlen

	stz	no_more_args	init to "there are more args"
	lda	ap|4,*		get number of first arg
	sba	1,dl		start 1 before 1st arg so "nextarg" will be the first
	als	1		multiply by 2
	eax6	0,al		and move to x6
	stx6	cur_arg

	stz	depth		init nesting depth
	stz	movinh		output movement not inhibited
"
"	set up output string
"
setup_output:
	stz	out_moved		number of characters stored
	lda	1,dl		starting column
	sta	out_column
	stz	out_to_borrow
	szn	entry_switch	which entry?
	tpl	not_switch
	epp2	ap|6,*		ptr to switch argument
	spri2	put_chars_arglist+2	setup argument list for put_chars
	epp2	out_moved
	spri2	put_chars_arglist+6
	epp2	ap|10,*		address of error code
	spri2	put_chars_arglist+8
	stz	put_chars_arglist+8,*	zero error code
	lda	sys_info$service_system
	tnz	call_iox
	epp3	put_chars_arglist+2,*	-> bce_iocb_ptr
	epp3	pr3|0,*			-> bce_iocb
	epp3	pr3|0,*			-> io routine
	tra	2,ic
call_iox:	epp3	iox_$put_chars
	spri3	put_chars_codeptr
	lda	=o000010000004	arglist header
	sta	put_chars_arglist
	stz	put_chars_arglist+1
	ldq	256,dl		use 256 character buffer in stack
	stq	out_left
	stq	out_size
	tra	grow_stack
not_switch:
	ldq	ap|8,*		set size
	stq	out_left
	stq	out_size
	szn	entry_switch	is this 6-bit mode?
	tze	notge		no, skip
grow_stack: 
	adq	3,dl		convert char count to word count
	qrs	2
	adq	15,dl		make multiple of 16
	anq	=o777760,dl
	epp3	sb|stack_header.stack_end_ptr,*	extend stack
	epp2	3|0,ql		by enough to hold output
	spri2	sb|stack_header.stack_end_ptr
	spri2	sp|stack_frame.next_sp
	tra	setout		join common section
notge:	epp3	ap|6,*		not 6-bit, get ptr to caller's buffer
	epp3	3|0,*
setout:	spri3	out_next
	spri3	buffptr		save ptr to buffer
	ldx2	num_args
	tze	done
"
"	locate next ^ in control string
"
nextarg:	tsx2	getargptr		get ptr to next arg
loop:	epp2	inptr,*		get ptr to input

	lda	inlen
	tze	no_control	no ^ if zero length string
	scm	(pr,rl),(du)	look for a ^
	desc9a	2|0,al
	vfd	o9/esc,27/0
	arg	t1
	ttf	have_control
"
"	no ^ found in rest of string, copy rest of control string into output
"
no_control:
	ldq	inlen		remaining length
	lda	0,dl
	tsx2	move_to_outbuf
	szn	entry_switch	$switch entry?
	tmi	finish_switch	yes, nothing to return
	ldq	out_moved		total characters generated
	stq	ap|8,*		return to caller
	szn	ap|10,*		padding requested?
	tze	done		no
	lda	out_left		move blanks to rest of buffer
	ldq	0,dl
	stz	movinh		don't let this be inhibited
	tsx2	move_to_outbuf


done:	szn	entry_switch	should we convert go GEBCD?
	tze	thru		no
	tpnz	convert_ge
finish_switch:
	szn	ap|8,*		need to append nl?
	tze	skip_newline	no
	stz	movinh		in case output inhibited
	epp2	new_line_char
	lda	1,dl
	ldq	1,dl
	tsx2	move_to_outbuf
skip_newline:
	tsx2	put_chars_buffer
	tra	thru
convert_ge:
	ldq	ap|8,*		get number of chars (including padding)
	epp3	ap|6,*		get ptr to beginning of caller's buffer
	epp3	3|0,*
	epp2	buffptr,*		get ptr to 6-bit buffer
	mvt	(pr,rl),(pr,rl)	now translate to GEBCD in caller's buffer
	desc9a	2|0,ql
	desc6a	3|0,ql
	arg	ascii_to_gebcd
"
thru:	return			and exit
"
"	move string of characters before the ^
"
have_control:
	ldq	t1		get number of chars preceding the ^
	tze	hc1		no work to do if zero
	lda	0,dl
	tsx2	move_to_outbuf
	lca	t1		-number of chars moved
	asa	inlen
	s9bd	2|0,al		bump ptr

hc1:	lca	1,dl		account for the ^
	s9bd	2|0,al
	asa	inlen
"
"	pick up size(s) from field
"
	spri2	save_inptr	save current location in control string
	lda	inlen
	sta	save_inlen
	tze	bad_field		must have some
rescan_control:
	eax0	0		x0 counts chars in field
	stz	v_not_done	reset this switch
	mlr	(0),(pr),fill(0)	zero size,size+1,sizesp,sizesp+1
	vfd	36/0
	desc9a	size,4*4
	eax4	0		set for first size
	tsx5	getsize
	cmpc	(pr,x0),(),fill(.)	is char "."?
	desc9a	2|0,1
	vfd	36/0
	tnz	check_key		no, don't try for second size
	adx0	1,du		account for the period
	sba	1,dl
	tze	bad_field
	eax4	1		set for second size
	tsx5	getsize
check_key:
	scm	(0),(pr,x0)
	desc9a	keys,key_length
	desc9a	2|0,1
	arg	t1
	ttn	bad_field		error if key not known
"
"	field ok, make sure we have an arg if we need one
"
	lxl6	t1		get position in key string
	szn	movinh		is output inhibited by ^0(?
	tze	arg_start		no
	cmpx6	arg2-arg1,du	see if this op is performed
	tmi	arg_dummy		no, setup dummy one
	cmpx6	arg4-arg1,du
	tmi	argok		always perform this
arg_dummy:
	ldx6	dumtra-arg1,du	set up dummy tra
	tra	argok		and go adjust pointers
arg_start:
	cmpx6	arg3-arg1,du	do we need an arg?
	tmi	3,ic		no, skip check
	szn	no_more_args
	tnz	bad_field
argok:	adx0	1,du		account for field
	sba	1,dl
	a9bd	2|0,0
	spri2	inptr
	sta	inlen
	tra	*+1,6		dispatch
arg1:	tra	put_control	|
	tra	put_control	/
	tra	put_control	-
	tra	put_control	R
	tra	put_control	B
	tra	put_control	^
	tra	put_blanks	x
	tra	skip		s
	tra	tab_to_column	t
arg2:	tra	lp_iterate	(
	tra	rp_iterate	)
	tra	semi_colon	;
	tra	right_bracket	]
arg3:	tra	left_bracket	[
arg4:	tra	put_chars		a
	tra	put_decimal	d
	tra	put_decimal	i
	tra	put_octal		o
	tra	put_pointer	p
	tra	put_octal_word	w
	tra	put_float		f
	tra	put_exponential	e
	tra	put_acc		A
	tra	put_bits		b
dumtra:	tra	loop		dummy tra

"	The order of the above tra's obviously must correspond to the string
"	of keys below. New control types must be positioned so that
"	the following relations hold:
"	  arg1<=X<arg3  means no argument required for control op
"	  arg2<=X<arg4  means that the control op must always be performed,
"		      even if output is inhibited
"	Note that these ranges overlap.

keys:	aci	"|/-RB^xst();][adiopwfeAb"
"
	equ	key_length,24
"
"	we come here when the field is bad.  move a ^ to output
"	and then go look for another field.  when the next field
"	(or end of string) is found, the characters of this field
"	will get copied to target
"
bad_field:
	epp2	save_inptr,*	backup pointer
	spri2	inptr
	lda	save_inlen	chars left in string
	sta	inlen
	lda	1,dl		move 1 character
	ldq	1,dl
	epp2	=a^
	tsx2	move_to_outbuf
	tra	loop		go look for another field
"
"	start iteration block
"
lp_iterate:
	tsx2	get_depth_start	get current nest index
	orx5	brflags.iteration,du	this is iteration (not brackets)
	canx5	brflags.movinh,du	is output already inhibited?
	tnz	lp_iterate2	yes, go do this level once
	szn	sizesp		was iteration count given?
	tnz	lp_iterate4	yes
	orx5	brflags.indefinite,du
	tra	lp_iterate3
lp_iterate4:
	lcq	size		negative of count given
	tnz	lp_iterate3
	aos	movinh		^0( inhibits output
lp_iterate2:
	lcq	1,dl		do loop once
lp_iterate3:
	stx5	brflags,6		save flags
	stq	iter_count,6	save_count
	lda	inlen		characters remaining in control string
	sta	iter_length,6	save for end of iteration
	sprp2	iter_pointer,6	save current control string pointer
	ldx5	cur_arg		current argument list offset
	stx5	iter_cur_arg,6	needed for end of iteration test
	epp2	argp,*		need arg pointer at end too
	sprp2	iter_argp,6
	tra	loop		done

"	subroutine called at start of parens or brackets to setup current level

get_depth_start:
	ldx6	depth		current depth
	adx6	1,du
	cmpx6	max_depth,du	too many?
	tpnz	bad_field		yes
	stx6	depth
	sbx6	1,du		better index for tables
	ldx5	0,du		initialize flag register
	szn	movinh		output inhibited from previous level?
	tze	2,ic		no
	orx5	brflags.movinh,du
	tra	0,2

"	subroutine called for end of parens or brackets to setup current level

get_depth_end:
	ldx6	depth		current depth
	tmoz	bad_field		nothing in progress
	sbx6	1,du
	ldx5	brflags,6		setup flags for current level also
	tra	0,2
"
"	finish iteration block
"
rp_iterate:
	tsx2	get_depth_end	get current depth
	canx5	brflags.iteration,du	really in iteration?
	tze	bad_field
	canx5	brflags.indefinite,du	is there a count?
	tnz	rp_inf		no, use special end test
	lda	iter_count,6	get remaining count
	ada	1,dl		count another iteration
	tpl	rp1		branch if done
	tsx2	arg_used_test	see if iteration will require an argument
	tra	do_rp		no, it will not, so ok to repeat
rp_test:	szn	no_more_args	are there more arguments?
	tnz	rp1		no, dont repeat the iteration
do_rp:	sta	iter_count,6	store remaining count
	lprp2	iter_pointer,6	load input ptr again
	ldq	iter_length,6	load back length
	spri2	inptr		reset input pointer
	stq	inlen		reset input length
	tra	loop		back for next arg

rp_inf:	tsx2	arg_used_test	will iteration require an arg
	tra	rp1		no, cant loop forever
	tra	rp_test		repeat only if args remain
"
"	done with iteration block or right bracket
"
rp1:	stz	movinh		this will allow output now
	canx5	brflags.movinh,du	unless inhibited from lower lovel
	tze	2,ic
	aos	movinh
	stx6	depth
	tra	loop

"	This subroutine compares the current argument being processed with the one
"	that was current when the loop began. If they are the same, the return is
"	to 0,2. Otherwise, the return is to 1,2.

arg_used_test:
	ldx5	cur_arg		current offset in argument list
	cmpx5	iter_cur_arg,6	same as when loop started?
	tnz	1,2		no, do the skip return
"	if offset is same, the actual argument may be different because
"	an array is being scanned.
	epp2	argp,*		current argument pointer
	sprp2	t4		store in packed form
	ldq	t4		get packed pointer
	cmpq	iter_argp,6	same as beginning pointr?
	tze	0,2		yes, loop definitely did not need arg
	tra	1,2		skip return, arg was used
"
"	start if/then/else or case selection (left bracket)

left_bracket:
	ldq	0,dl
	szn	movinh		is output already inhibited?
	tnz	left_bracket4	yes, go to 0th clause (dont get arg)
	eax2	cstype		check for character arg
	tsx3	fillin
	tra	left_bracket5	no
	cmpc	(pr,rl),(),fill(blank)	check for false
	desc9a	2|0,ql
	desc9a	false,5
	tze	left_bracket6	it is, treat like zero bit string
	cmpc	(pr,rl),(),fill(blank)	check for true
	desc9a	2|0,ql
	desc9a	true,4
	tze	left_bracket3	it is, treat like non-zero bit
	tra	left_bracket2	go treat as character digits
left_bracket5:
	eax2	bstype		param to test for bit argument
	tsx3	fillin		do the test
	tra	left_bracket2	not a bit string argument
	cmpb	(pr,rl),(),fill(0)	check bit string for all zero
	descb	2|0,ql
	descb	0,0
	tnz	left_bracket3	string is non-zero
left_bracket6:
	ldq	2,dl		zero string is "else", do second clause
	tra	left_bracket4
left_bracket3:
	ldq	1,dl		non-zero string is "then", do first clause
	tra	left_bracket4
left_bracket2:
	tsx5	load_fixed_bin
	tra	bad_field		error
left_bracket4:
	tsx2	get_depth_start	setup current depth
	stx5	brflags,6		save flags in stack
	stq	bracket_search,6	save clause number to execute
	ldq	1,dl		initialize current clause number
	stq	bracket_clause,6
	cmpq	bracket_search,6	should 1st clause be executed?
	tze	2,ic		yes
	aos	movinh		inhibit output until right clause found
	canx5	brflags.movinh,du	output previously inhibited?
	tnz	loop		yes, dont advance arg pointer
	tra	nextarg

"	end of if/then/else or case section

right_bracket:
	tsx2	get_depth_end	set up currnt level
	canx5	brflags.iteration,du	is this matching a (?
	tnz	bad_field		yes, error 
	tra	rp1		terminate
true:	aci	"true"
false:	aci	"false"
"
"	clause delimiter (semi_colon)

semi_colon:
	tsx2	get_depth_end
	canx5	brflags.iteration,du	be sure not between iterations
	tnz	bad_field
	canx5	brflags.movinh,du	is output inhibited from previous level
	tnz	loop		yes, it shouldn't be changed here
	szn	v_not_done	did scan fail to get value becuase of movinh?
	tnz	semi_colon2	yes, special stuff to do
	ldq	size		number of clauses to advance
	szn	sizesp		was it specified?
	tnz	2,ic		yes
	ldq	1,dl		no, assume 1
	adq	bracket_clause,6	compute new clause number
	stq	bracket_clause,6
	stz	movinh		enable output
	cmpq	bracket_search,6	should it be enabled?
	tze	2,ic		yes, right clause has been found
	aos	movinh		disable output
	tra	loop

"	come here when given "^v;" and the and the 'v' was not evaluated
"	because the movinh switch suppressed fetching the required arg.
"	reset movinh and rescan the control op.

semi_colon2:
	stz	movinh
	lda	save_inlen	reset length
	epp2	save_inptr,*	and pointer (to after the ^)
	tra	rescan_control
"
"	skip forward over arguments
"
skip:	szn	no_more_args	any more arguments?
	tnz	loop		no, so done
	szn	sizesp		was ^_ns given?
	tnz	skip2		yes
	lda	1,dl		default is 1
	sta	size
skip2:	lda	size		this is now number of ^s to do
	tze	loop		done if 0
	szn	array_in_progress	doing an array now?
	tnz	skip_array	yes
	sba	1,dl		account for ^s about to be done
	sta	size		number remaining to do
skip3:	tsx2	getargptr		step to next argument
	szn	no_more_args	see if found last one
	tnz	loop		all done
	tra	skip2		back to do another ^s

"	here to step pointer thru ^_ns array elements

skip_array:
	ldq	array_length	length of array
	sbq	array_position	subtract current position
	adq	1,dl		this gives number of array elements
	cmpq	size		is skip small enough to stay in array
	tpnz	step_array	yes
	stq	t4		number of ^s rest of array will satisfy
	sba	t4		this is remaining ^s to do
	sta	size		save this number
	stz	array_in_progress	no longer processing array
	tra	skip3		go back for next argument
step_array:
	asa	array_position	adjust current position
	lrl	36		get elements skipped in q
	mpy	array_mult	convert to words or bits
	eppbp	argp,*		pointer to current element
	szn	array_packed	is this packed array?
	tnz	step_packed_array	yes
	eppbp	bp|0,ql		add words to pointer
	tra	2,ic		go store result
step_packed_array:
	abd	bp|0,ql		make bit adjustment in packed array
	spribp	argp		store result
	tra	loop		and done
"
"	put out special character
"
mismatch:	tsx2	getargptr		skip bad argument
	ldx6	6,du		get special code for arg mismatch
	szn	size		be sure at least one char is sent
	tnz	2,ic
	aos	size
	aos	sizesp
"
put_control:
	szn	sizesp		was size specified
	tnz	2,ic		yes, skip
	aos	size		no, use size = 1
	szn	size		check for zero
	tze	loop
	epp2	fill_chars	point at appropriate fill character
	a9bd	2|0,6
put_control_loop:
	lda	1,dl		move 1 character
	ldq	1,dl
	tsx2	move_to_outbuf
	lca	1,dl
	asa	size
	tpnz	put_control_loop	loop for count requested
	tra	loop

fill_chars:
	vfd	9/ff,9/nl,9/ht,9/rs,9/bs,9/esc,9/star
new_line_char:
	vfd	9/nl,27/0

"
"	optimized routine for blanks, with one call to move characters

put_blanks:
	ldq	0,dl		no source
	lda	size
	szn	sizesp		size given?
	tnz	2,ic		yes
	lda	1,dl		just do 1
	tsx2	move_to_outbuf
	tra	loop
"
"	tab to specified column

tab_to_column:
	szn	size		valid column specified?
	tze	bad_field		no, error
	szn	sizesp+1		minimum count secified?
	tnz	2,ic		yes
	aos	size+1		no, assume 1
	lda	size		column requested
	sba	out_column	this given number of columns short
	cmpa	size+1		put out at least minumem spaces
	tpl	2,ic
	lda	size+1
	ldq	0,dl		no source chars
	stz	out_to_borrow	we must ignore borrow and goto column
	tsx2	move_to_outbuf	insert spaces
	lda	out_column	compute overshoot
	sba	size		ideally, this is zero
	sta	out_to_borrow	but if not, steal from next field
	tra	loop
"
"	put out F format
"
put_float:
	tsx2	compute_precision	compute default precision, leave in q
	szn	sizesp		was first size specified
	tnz	nf		yes, skip
	szn	sizesp+1		no, was second size specified
	tnz	.df		yes, skip
"
"	have ^f case (or continuation of ^nf case)
"	number of digits to use is in q
"
f1:	tsx5	convert_to_float_dec
	tra	f_zero
	tpnz	e_format		positive exponent means E format needed
	ada	precision		get number of digits before decimal point
	tmi	f2		special action if negative
	eax5	1,al		count decimal point
	mlr	(pr,rl),(pr,rl),fill(.)	move ddd.
	desc9a	temp1(1),al
	desc9a	temp2,x5
	lcq	exponent		get number of digits after .
	tze	gl		skip if none
	epp3	pl1_operators_$tct_octal_060
	tctr	(pr,rl,x5)	count number of trailing zeros
	desc9a	temp1,ql
	arg	3|0
	arg	t2
	ttn	gl		skip if fractional part all zeros
	sta	work		save number of digits before .
	lda	=o177,dl		isolate number of trailing zeros
	ansa	t2
	sbq	t2		compute number of digits to move
	mlr	(pr,rl,x5),(pr,rl,x5)
	desc9a	temp1,ql
	desc9a	temp2,ql
	adq	work		get number of digits moved
	lls	36		and shift to position
gl:	ada	1,dl		get length of number string
"
prefix_sign:
	epp2	temp2		get ptr to result
	eax7	1		get 1 so we can diddle pr
	cmpc	(pr),(0),fill(.)	is first character a decimal point
	desc9a	2|0,1
	vfd	36/0
	tnz	check_sign	no, skip
	mlr	(),(pr),fill(zero)	change .ddd to 0.ddd
	vfd	36/0
	desc9a	2|-1(3),1
	ada	1,dl		adjust field length
	s9bd	2|0,x7		and ptr
check_sign:
	cmpc	(pr),(0),fill(minus)	was input negative
	desc9a	temp1,1
	vfd	36/0
	tnz	move		positive, skip
prefix_minus:
	mlr	(),(pr),fill(minus)	prefix minus sign
	vfd	36/0
	desc9a	2|-1(3),1
	ada	1,dl		adjust field length
	s9bd	2|0,x7
	tra	move		and go move number
"
"	try putting all of precision after the decimal point
"
f2:	neg	0		get number of zeros required after decimal point
	epp3	pl1_operators_$tct_octal_060
	tctr	(pr,rl)		count trailing zeros
	desc9a	temp1(1),ql
	arg	3|0
	arg	t2
	ldq	=o177,dl		isolate number of trailing zeros
	ansq	t2
	cmpa	t2		can we use f format
	tpnz	e_format		no, switch to E format
	ldq	precision		get back precision
	lca	exponent
	sba	t2		get rid of trailing zeros
	sta	size+1
	tra	.df1
"
"	have value of 0 for ^f or ^nf case
"
f_zero:	epp2	=a0.
	lda	2,dl
	tra	move
"
nf:	szn	sizesp+1		first size given, was second?
	tnz	n.df
"
"	have ^nf case, use n-1 digits
"
	ldq	size
	sbq	1,dl
	tra	f1		go join ^f case with precision in q
"
"	have ^n.df case, use n-1 digits
"
n.df:	ldq	size
	sbq	1,dl
"
"	have ^.df case or continuation of ^n.df case, number of digits is in q
"
.df:	cmpq	size+1		make sure field is big enough
	tmi	punt+1
	tsx5	convert_to_float_dec	convert
	tra	ndf_zero		special action if zero
.df1:	sti	t2+1		save indicators
	ldi	=o4000,dl		prevent overflow fault
	lda	size+1		get d
	sba	t3		adjust for exponent correction
	ana	=o377,dl		mask to 8 bits
	ora	=a+01		make value 1ed
	sta	t2		save
	adq	1,dl		get precision+1
	eaa	1,ql		get precision+2
	mp3d	(pr),(pr,rl),(pr,rl),round	move to fixed scaled temp
	desc9fl	t2,4
	desc9fl	temp1,au
	desc9ls	temp1,ql
	tov	punt		can't use this format if overflow on move
	ldi	t2+1		restore indicators
	lda	precision		get number of digits to left of .
	sba	size+1
	eax6	0,al		remember for later
	tze	f3		and skip if none
	epp3	pl1_operators_$tct_octal_060
	tct	(pr,rl)		count leading zeros
	desc9a	temp1(1),al
	arg	3|0
	arg	t2
	ldq	=o177,dl		isolate count of zeros
	ansq	t2
	sba	t2		get number of non-zero chars
	tze	f3		skip if none
	ldq	t2		get number of zeros
	mlr	(pr,rl,ql),(pr,rl)	move non-zero chars
	desc9a	temp1(1),al
	desc9a	temp2,al
"
"	chars to left of . have been moved, number is in a
"
f3:	ldq	size+1		get number of digits after .
	eax7	1,ql		include .
	mrl	(pr,rl,x6),(pr,rl,al),fill(.)	move digits with . on left
	desc9a	temp1(1),ql
	desc9a	temp2,x7
f4:	ada	size+1		form total length of field
	ada	1,dl
	tra	prefix_sign	go put on sign
"
punt:	ldi	t2+1		can't use this format
	stz	size
	tra	put_exponential
"
"	value for .df or n.df format is zero
"
ndf_zero:	lda	0,dl		assume no zero left of decimal
	ldq	size+1		get number of digits after .
	cmpq	precision		is there room for 0 to left?
	tpl	5,ic		no, skip
	mlr	(),(pr),fill(zero)	move zero
	vfd	36/0
	desc9a	temp2,1
	ada	1,dl		account for the zero
	eax7	1,ql		get number of zeros plus .
	mlr	(),(pr,rl,al),fill(zero)	move . with zero fill
	desc9a	ec1(2),1
	desc9a	temp2,x7
	tra	f4		go finish up
"
"	put out E format
"
put_exponential:
	ldq	size		use appropriate digits if size is zero
	tnz	2,ic
	tsx2	compute_precision
e0:	tsx5	convert_to_float_dec	convert to decimal
	tra	e_zero		special case if zero
e1:	epp3	pl1_operators_$tct_octal_060
	tctr	(pr,rl)		count trailing zeros
	desc9a	temp1(1),ql
	arg	3|0
	arg	t2
	lda	=o177,dl
	ansa	t2
	sbq	t2		compute number of digits to edit
	stq	default_precision
	adq	1,dl		get precision+1
	eax4	1,ql		get precision+2
	mvne	(pr,rl),(),(pr,rl)	generate sd.ddd
	desc9ls	temp1,ql
	desc9a	float_edit,8
	desc9a	work,x4
	ldq	precision		get true exponent
	sbq	1,dl
	asq	exponent
	btd	(pr),(pr)		convert exponent to decimal
	desc9a	exponent,4
	desc9ls	temp1,11
	mvne	(pr),(),(pr)	edit to remove leading zeros
	desc9ls	temp1,11
	desc9a	exp_edit,5
	desc9a	temp2,11
	ldq	11,dl		remove leading blanks
	tsx5	strip_blanks
	eax3	1,al		get 1+number of chars in exponent
	mrl	(pr,rl),(pr,rl,x4),fill(e)	move exponent prefixed by "e"
	desc9a	2|0,al
	desc9a	work,x3
	asa	default_precision	update true char count
	ldq	default_precision	length of field is default_precision+3
	adq	3,dl
	epp2	work		get ptr to result
e2:	szn	sizesp		was size specified
	tnz	2,ic
	stq	size		no, set field size
	lda	size		get size of field to be filled
	tsx2	move_to_outbuf
	tra	nextarg
"
"	value is zero
"
e_zero:	epp2	ec1
	ldq	5,dl
	tra	e2		go output
"
ec1:	aci	" 0.e0"
"
"	can't use F format, convert to E format
"
e_format:
	stz	size		act as if size not given
	ldq	default_precision	get default precision
	cmpq	precision		check current precision
	tze	e1		save, nothing to do
	tpl	e0		current smaller, start from beginning
	adq	2,dl		get default precision+2
	lda	precision		get current precision+2
	ada	2,dl
	mvn	(pr,rl),(pr,rl),round	round to default precision
	desc9fl	temp1,al
	desc9fl	temp1,ql
	sbq	2,dl		get back default pecision
	stq	precision		save new precision
	tsx2	extract_exponent
	tra	e1		go do formatting
"
"	routine to convert input argument to float
"	decimal in temp1.  entered with desired output
"	precision in q and source type in x7.
"	return with same precision value in q
"	and exponent in a.  return is 0,5 if source value
"	is 0 and 1,5 if source not 0.
"	at return indicators correspond to exponent value.
"
convert_to_float_dec:
	sxl5	save_x7.x5	save return
	eax5	1		specify rounding
	eax6	2*real_flt_dec_generic_dtype	set target type
"
"	convert to decimal
"
convert_to_decimal:
	cmpq	59,dl		make sure max not exceeded
	tmoz	2,ic
	ldq	59,dl
	stq	precision		save precision

	tsx3	test_numeric	see if numeric
	tra	*+2		it isn't, try other stuff
	tra	cv_check_ok	good numeric, proceed
	eax2	cstype		try character
	tsx3	fillin
	tra	mismatch		not character, error
cv_check_ok:
	epp1	temp1		target ptr
	cmpx6	2*real_flt_dec_generic_dtype,du  see if generic type
	tnz	cv_not_generic	not generic type
	epp1	exponent		point to exponent of generic decimal
cv_not_generic:
	epp3	argp,*		source ptr
	epp5	work		scratch area
	epp2	*		set ptr to base of ourselves
	spbp2	sp|38		text base pptr
	lda	length		get input length & precision
	lrl	12		get scale in left of q, precision in right
	qrl	6
	lrl	12
	qrs	6
	lda	precision		target
	stx7	save_x7.x5	any_to_any_ may change this
	xec	call_any_to_any_,5	call truncate or round entry
	epbp7	sp|0
	lxl5	save_x7.x5	restore return offset
	ldx7	save_x7.x5
	ldq	precision		get target precision
	epp3	pl1_operators_$tct_octal_060
	tct	(pr,rl)		count leading zeros in decimal value
	desc9a	temp1(1),ql
	arg	3|0
	arg	t1
	ttn	0,5		special return if all zero
	cmpx6	2*real_flt_dec_generic_dtype,du d is this float
	tnz	1,5		no, exit
	lda	t1
	ana	=o77,dl
	sta	t3		save exponent correction
	tze	getexp		skip if no leading zeros
	eax2	0,al		save number of leading zeros
	neg	0		get number of chars afterward
	ada	precision
	mlr	(pr,rl,x2),(pr,rl),fill(zero)	shift number to left
	desc9a	temp1(1),al
	desc9a	temp1(1),ql

"     We require a true hardware floating representation for ^n.df format
"     determination at ".df1:".  We setup this exponent as the true exp if
"     within range of fixed bin (7), or with (2**7)-1 appropriately signed.
"     .df1: uses the overflow indication used to determine if e-format needs
"     to be used.

getexp:	lda	exponent		move in real exponent
	sta	save_x7.x5	setup for hardware exponent
	lda	=127,dl		force high hardware exp
	cmg	exponent		in range?
	tpl	getexp.in_range	in range - take normal exponent
	cmpa	exponent		see if we store negative exponent
	tmi	getexp.pos	set positive maximum exponent
	lda	=-127,dl		set negative maximum exponent
getexp.pos:
	sta	save_x7.x5

getexp.in_range:
	lda	exponent		convert exponent to signed value
	sba	t3		subtract correction
	sta	exponent
	mlr	(pr),(pr,ql)	set hardware exponent - needed in ^n.df
	desc9a	save_x7.x5(3),1
	desc9a	temp1(1),1
	tra	1,5		take normal return

"	select proper any to any call

call_any_to_any_:
	tsx0	any_to_any_$any_to_any_truncate_
	tsx0	any_to_any_$any_to_any_round_
"
"	convert input argument to fixed decimal
"	we try to do this without any_to_any_ if at all possible
"	so that wired ring0 code can use it.
"
convert_to_fixed_dec:
	sxl5	save_x7.x5	save return
	eax2	cstype		try character first
	tsx3	fillin
	tra	*+2		not character
	tra	ctfd		it is character, use any_to_any_

	tsx5	load_fixed_bin	take our best shot
	tra	ctfd		too hard, let any_to_any_ do it
	staq	temp1+6
	epp2	argp,*		get ptr to arg
	ldq	23,dl		use precision 23 in simple case
	lxl5	save_x7.x5	get return address
	btd	(pr),(pr)		convert as if input were fixed bin(71)
	desc9a	temp1+6,8
	desc9ls	temp1,24
	tze	0,5		special exit if zero
	tra	1,5		normal exit

ctfd:	eax5	0		no rounding
	eax6	2*real_fix_dec_9bit_ls_dtype	set type
	ldq	59,dl		precisison
	tra	convert_to_decimal
"
"	compute decimal_precision = ceil(binary_precision/3.32)
"
compute_precision:
	ldq	length		get length from descriptor
	anq	=o7777,dl		isolate precision
	eaa	0,7		get argument type
	arl	18+1		leave just type
	sba	1,dl
	cmpb	(al),(),fill(0)	is this binary?
	descb	binary_dtype_mask,1
	descb	0,0
	tze	set_dp		not binary use precision as is
	mpy	=.301205b-1
	cmpq	0,dl
	tze	2,ic
	ada	1,dl
	lrs	36		get decimal precision in q
set_dp:
	stq	default_precision	save default precision
	tra	0,2



"	routine to extract exponent from float dec value
"	in temp1 with precision given in q
"
extract_exponent:
	mlr	(pr,ql),(pr)	extract exponent
	desc9a	temp1(1),1
	desc9a	exponent,1
	lda	exponent		convert exponent to signed value
	als	1
	ars	28
	sba	t3		subtract correction
	sta	exponent
	tra	0,2
"
"	put out ptr
"
put_pointer:
	cmpx7	2*pointer_dtype,du	is this unpacked case
	tze	pp1		yes, do it
	cmpx7	2*label_dtype,du	is this label var
	tze	pp1		yes, dofirst pointer
	cmpx7	2*entry_dtype,du	is this entry var
	tze	pp1		yes, do first pointer
	cmpx7	2*pointer_dtype+packed,du	is this packed case
	tnz	mismatch		have mismatch if not packed

"	start here with packed pointer

	epp2	argp,*		address of the packed pointer
	csl	(pr),(pr),bool(3)	copy to a word aligned place
	descb	2|0,36
	descb	t3+1,36
	lda	t3+1
	eaq	0		zero the q
	lrl	18		word offset in q-upper
	arl	3		get bit offset in position
	ana	=o077000,dl	isolate bit offset
	sta	t3		store bit offset
	orq	t3		bit offset in right place in q
	lda	t3+1		get origional pointer
	ana	=o007777,du	keep only segment
	cmpa	=o007777,du	is in packed form of -1?
	tnz	2,ic		no
	lda	=o077777,du	use standard form of -1
	tra	pp2		join common case

"	start here with unpacked pointer

pp1:	ldaq	argp,*		get unpacked ptr
	anaq	ptrmask		remove un-important bits

"
"	common packed and unpacked pointer section

pp2:	staq	t3
	stz	t1		init output char count
	tsx2	octal_field	put out 6 digits of seg number from au
	mlr	(),(pr,al),fill(bar)	append a |
	vfd	36/0
	desc9a	work,1
	aos	t1		account for |
	lda	t3+1		put out 6 digits of word offset from au
	tsx2	octal_field
	btd	(pr),(pr)		convert bit offset to decimal
	desc9a	t3+1(2),1
	desc9ns	temp1,2
	tze	ptr_done		done if bit offset is zero
	mlr	(),(pr,al),fill(lp)	append a (
	vfd	36/0
	desc9a	work,1
	ada	1,dl		account for (
	eax6	0		assume bit offset is really 2 digits
	ldq	2,dl
	cmpc	(pr),(),fill(zero)	is first character a 0?
	desc9a	temp1,1
	vfd	36/0
	tnz	3,ic		skip if non-zero
	eax6	1		really only 1 digit
	ldq	1,dl
	eax7	1,ql		get number of digits + 1
	mlr	(pr,rl,x6),(pr,rl,al),fill(rp)	add digits followed by )
	desc9a	temp1,ql
	desc9a	work,x7
	sta	t1		get final count
	asq	t1
	aos	t1
ptr_done:
	epp2	work		and go move to target
	ldq	t1		number of characters in edited pointer
	lda	size		use field width given
	tsx2	move_to_outbuf
	tra	nextarg
"
"	routine to put out from 1 to 6 chars of octal from contents of au
"	into work area.  t1 gives numbers of chars already in work,
"	t1 is updated and left in a at exit
"
	odd			to force rpd odd
octal_field:
	eax1	3		init rpd loop
	arl	18		shift au to position
	odd
	rpd	6,0
	lrl	0,1
	qrl	0,1
	orq	=o606060606060	form 6-bit ascii
	stq	temp1		save
	mve	(pr),(),(pr)	convert to 9-bit ascii with leading blanks
	desc6a	temp1,6
	desc9a	oct_edit6,2
	desc9a	temp2,6
	ldq	6,dl		remove leading blanks
	tsx5	strip_blanks
	ldq	t1		get offset to use
	mlr	(pr,rl),(pr,rl,ql)	move to work area
	desc9a	2|0,al
	desc9a	work,al
	ada	t1		update count
	sta	t1
	tra	0,2		return to caller
"
"	put out fixed binary integer in signed octal
"
put_octal:
	tsx5	load_fixed_bin	load input
	tra	mismatch		bad data type
	staq	t1		remember whole value
	lrs	0		test sign
	tpl	2,ic		get abs value
	negl	0
	staq	t2		save abs value
	epp2	temp1		get ptr to where we want octal
	tsx5	octal		convert first word to 12 digits of octal
	epp2	temp1+3		convert 2nd word
	lda	t2+1
	tsx5	octal
	mvne	(pr),(),(pr)	edit leading zeros into blanks
	desc9ns	temp1,24
	desc9a	oct_edit24,3
	desc9a	temp2,24
	ldq	24,dl		remove leading blanks
	tsx5	strip_blanks
	szn	t1		was input negative
	tpl	move		move if positive
	eax7	1
	tra	prefix_minus	put on sign if negative
"
"	put out single word in unsigned octal
"
put_octal_word:
	lda	argp,*		get word for output
	epp2	temp1		get where to put chars
	tsx5	octal
	lda	12,dl		assume size of 12
	szn	sizesp		was size specified
	tze	move		no
	cmpa	size		size greater than 12?
	tmoz	move		yes, go move with leading spaces
"
"	size < 12, see if we can drop leading zeros
"
	epp3	pl1_operators_$tct_octal_060
	tct	(pr)		count leading zeros
	desc9a	temp1,12
	arg	3|0
	arg	t1
	ldq	=o177,dl		isolate number of leading zeros
	ansq	t1
	sba	size		get 12-size
	cmpa	t1		get min(#zeros,12-size)
	tmi	2,ic
	lda	t1
	a9bd	2|0,al		adjust ptr
	neg	0		compute new field size
	ada	12,dl
	sta	size
	tra	move
"
"	put out ascii string
"
put_chars:
	eax2	cstype		we want char info
	tsx3	fillin		go get info about string
	tra	mismatch		error if not right type
"
"	remove trailing blanks from string
"
	epp3	pl1_operators_$tct_octal_040
	tctr	(pr,rl)		scan backward over blanks
	desc9a	2|0,ql
	arg	3|0
	arg	t2
	lda	=o77777777	isolate chars skipped
	ansa	t2
	sbq	t2		adjust length
	lda	out_column	save starting columen
	sta	save_out_column
	lda	0,dl		no specifiec length
"
"	move characters pointed at by pr2 into output
"
	tsx2	move_to_outbuf
	szn	sizesp		column width specified?
	tze	nextarg		no
	szn	newline_moved	any newlines, or friends in data?
	tnz	nextarg		yes, don't try any column adjusting
	lda	save_out_column	starting column
	ada	size		target column
	sba	out_column	amount we are short
	tmoz	nextarg		at or past target
	ldq	0,dl
	tsx2	move_to_outbuf	move spaces to reach descired column
	tra	nextarg
"
"	put out ACC string
"
put_acc:
	epp2	argp,*		get ptr to acc
	epp2	2|0,*
	ldq	bp|0		extract the size
	qrl	27
	lda	0,dl
	eax6	1		adjust ptr
	a9bd	2|0,6
	tsx2	move_to_outbuf
	tra	nextarg
"
"
"	put out bit string
"
put_bits:	eax2	bstype		want info about bit strings
	tsx3	fillin		go get length in q
	tra	mismatch
	lda	size+1		do we have byte size specified
	tpnz	2,ic		yes
	lda	1,dl		no, use 1 bit byte
	cmpa	4,dl		is byte size too big?
	tmoz	2,ic
	lda	4,dl		yes, use hex
	sta	size+1		save correct byte size
	div	size+1		get number output chars to generate
	szn	sizesp		was field size specified
	tze	4,ic		no, skip
	cmpq	size		is number greater than size
	tmoz	3,ic
	ldq	size		yes, just use size specified
	stq	size		save correct field size
	lxl7	size+1		get byte size
	epp5	2|0		pointer to bit string
bit_convert:
	csr	(pr,rl),(pr),fill(0),bool(3)	move byte to right end of word
	descb	5|0,x7
	descb	temp1,36
	lxl5	temp1		load right adjusted byte
	epp2	bit_alpha		get address of converted character
	a9bd	2|0,5
	ldq	1,dl		move 1 character
	lda	1,dl		no padding
	tsx2	move_to_outbuf
	abd	5|0,7		bump bit address
	lca	1,dl
	asa	size		count bytes
	tpnz	bit_convert
	tra	nextarg
"
"	put out fixed binary number in decimal
"
put_decimal:
	tsx5	convert_to_fixed_dec	get decimal
	tra	i_zero		skip if zero
	adq	1,dl		get precision + 1
	mvne	(pr,rl),(),(pr,rl)	get rid of leading zeros and plus sign
	desc9ls	temp1,ql
	desc9a	int_edit,6
	desc9a	temp2,ql
	tsx5	strip_blanks	go remove blanks
"
"	routine to move string into output with padding on left
"	entered with pr2 pointing at string to move, length of string in a
"
move:	sta	t1		save character width
	szn	sizesp		was size specified
	tnz	2,ic		yes
	sta	size		no, set size appropriately
	cmpa	size		is actual field bigger than specified size
	tpl	movea		no leading spaces needed
	sba	size
	neg	0		count of leading spaces
	ldq	0,dl		no source characters for spaces
	tsx2	move_to_outbuf
movea:	ldq	t1		get field size
	lda	0,dl
	tsx2	move_to_outbuf
	tra	nextarg

"
"	have 0 value for i format
"
i_zero:	epp2	=a0.
	lda	1,dl
	tra	move
"
"	routine to load fixed bin input arg into aq
"
load_fixed_bin:
	tsx3	test_numeric	see if numeric value first
	tra	load_fixed_bit	go try bit
	eaa	0,7		pick up type
	arl	18+1		align and drop packed bit
	ldx3	0,du		0 here means signed
	eaq	load_single	routine for simple signed
	cmpa	real_fix_bin_1_dtype,dl
	tze	load_fixed_ok
	eaq	load_double	routine for double prec signed
	cmpa	real_fix_bin_2_dtype,dl
	tze	load_fixed_ok
	ldx3	1,du		1 here means unsigned
	eaq	load_single_uns
	cmpa	real_fix_bin_1_uns_dtype,dl
	tze	load_fixed_ok
	eaq	load_double
	cmpa	real_fix_bin_2_uns_dtype,dl
	tze	load_fixed_ok
	tra	0,5		non-skip for bad type

load_fixed_ok:
	lda	length		be sure no scale 
	arl	12
	ana	=o7777,dl
	tnz	0,5		cant handle non zero scale
	canx7	packed,du		unaligned argument?
	tnz	load_packed_fixed_bin yes
	tra	0,qu		go to handler previously set

load_single:
	lda	argp,*		arg is unpacked single precision
	lrs	36
	tra	1,5

load_single_uns:
	ldq	argp,*
	lda	0,dl
	tra	1,5

load_double:
	ldaq	argp,*
	tra	1,5
"
"	arg is packed, move to aligned temp and then load
"
load_packed_fixed_bin:
	lda	length		get length
	ana	=o7777,dl
load_fixed_bit_join: 
	xec	get_fixed_bin_size,x3 compute field width
	als	18		shift to au
	sta	t2		and save
	epp2	argp,*		load ptr to arg (including bit offset)
	csl	(pr,rl),(pr,rl),bool(3)	move to aligned temp
	descb	2|0,au
	descb	t1,au
	ldaq	t1		load the aligned value
	lcx2	t2		get -(width)
	xec	shift_fixed_bin_field,x3	shift value to position
	tra	1,5		and return

get_fixed_bin_size:
	ada	1,dl		for signed, add 1
	ada	0,dl		for unsigned, do nothing
shift_fixed_bin_field:
	lrs	72,2		for signed, use arithmetic shift
	lrl	72,2		for unsigned, use logical shift

"	try to load a bit string. If it is short enough (<= 72)
"	it is treated like unsigned binary

load_fixed_bit:
	eax2	bstype		see if bit string first
	tsx3	fillin
	tra	load_fixed_char	no, try charracter
	cmpq	72,dl		see if short enough
	tpl	0,5		cant handle it
	lls	36		get length in a
	ldx3	1,du		code for unsigned
	tra	load_fixed_bit_join
"
"
"	try arg as character
"
load_fixed_char:
	eax2	cstype		address of character codes
	tsx3	fillin		get pointer and length
	tra	0,5		not character, error
	stz	t2		0 will mean positive
	cmpq	0,dl		any chars?
	tze	load_fixed_zero	no, return 0
	cmpc	(pr),(),fill(plus)	leading +?
	desc9a	2|0,1
	oct	0
	tze	load_fixed_skip_sign yes
	cmpc	(pr),(),fill(minus)	leading -?
	desc9a	2|0,1
	oct	0
	tnz	load_fixed_digits	no
	aos	t2		flag meaning minus
load_fixed_skip_sign:
	lda	1,dl
	a9bd	2|0,al		bump pointer over sign
	sbq	1,dl		decrement length
load_fixed_digits:
	cmpq	0,dl
	tze	load_fixed_zero	no digits left
	stq	t1		copy of count
	lda	0,dl		index during loop
load_fixed_scan:
	scm	(),(pr,al)	check each char for a digit
	desc9a	digits,10
	desc9a	2|0,1
	arg	t1+1
	ttn	load_fixed_zero
	ada	1,dl		to next character
	cmpa	t1
	tmi	load_fixed_scan
	dtb	(pr,rl),(pr)	convert to binary
	desc9ns	2|0,ql,0
	desc9a	t1,8
	ldaq	t1
	szn	t2		should it be -?
	tze	*+2		no
	lcaq	t1		use complement
	tra	1,5
load_fixed_zero:
	lda	0,dl
	ldq	0,dl
	tra	1,5
"
"	routine to convert fixed bin in a into 12 digits of octal
"	in aligned storage pointed at by pr2
"
	even			to make rpd odd
octal:	eax6	3-1		init count
	eax1	6		init shifts
	eax2	3
	odd
octal1:	rpd	4,0
	lrl	0,2
	qrl	0,1
	orq	=a0000		make into ascii
	stq	2|0,6		save
	eax6	-1,6
	tpl	octal1
	tra	0,5
"
"	routine to strip leading blanks from string in temp2
"	entered with length of input string in q
"	returns with ptr to first non-blank in pr2 and length in a
"
strip_blanks:
	scmr	(pr,rl),(du)		find number of non-blank characters
	desc9a	temp2,ql
	vfd	o9/blank
	arg	t2
	sbq	t2
	epp2	temp2		get ptr to first non-blank
	a9bd	2|0,ql
	lda	t2		get number of chars to output
	tra	0,5
"
"	move characters to output buffer.
"	called with:
"	 q = length of source
"	 a = length of target (> source indicates pad with blanks)
"	 pr2 -> source

move_to_outbuf:
	szn	movinh		is output inhibited?
	tnz	0,2		yes, just return
	stx2	out_save_x2
	spri2	out_save_pr2
	stz	newline_moved
	staq	move_temp
	sba	move_temp+1	compute amount of padding requested
	tpl	2,ic
	lda	0,dl		none
	sta	move_padding	save for later
	cmpq	0,dl		any source characters?
	tze	move_source_done	no
	lda	out_to_borrow	do we need to borrow any leading spaces?
	tze	move_the_stuff		no
	cmpa	move_temp+1	need to borrow more that source length?
	tmi	2,ic		no
	lda	move_temp+1	just try for source length
	epp3	pl1_operators_$tct_octal_040
	tct	(pr,rl)
	desc9a	2|0,al
	arg	3|0
	arg	tct_result
	ttn	3,ic		source is all blank
	lda	tct_result	get blank count
	ana	=o777777777
	cmpa	0,dl		any leading blanks?
	tze	nothing_to_borrow
	sta	move_temp		amount borrowed
	sbq	move_temp		adjust source length
	a9bd	2|0,al		adjust source pointer
	neg
	asa	out_to_borrow	less to borrow now
	cmpq	0,dl		source exhausted?
	tze	move_source_done	yes
nothing_to_borrow:
	stz	out_to_borrow	tried as hard as possible
move_the_stuff:
	stq	left_to_move
	cmpq	out_left		will source fit in buffer?
	tmi	2,ic		yes
	ldq	out_left		use only what fits
	epp3	out_next,*	get current pointer
	mlr	(pr,rl),(pr,rl)
	desc9a	2|0,ql
	desc9a	3|0,ql
	a9bd	3|0,ql		adjust output pointer
	spri3	out_next
	epp3	2|0		compute adjust input pointer
	a9bd	3|0,ql
	spri3	rest_of_source
	asq	out_moved		accumulate characters moved
	stq	move_temp
	lca	move_temp
	asa	out_left		space left in output buffer
	asa	left_to_move

"	scan output to adjust column position

out_scan:
	cmpq	0,dl		any characters?
	tze	check_more_to_move	no
	tct	(pr,rl)		look for interesting characters
	desc9a	2|0,ql
	arg	out_scan_table
	arg	tct_result
	ttn	out_normal	all regular vanilla characters
	lda	tct_result	get count of plain characters before interesting one
	ana	=o777777777
	asa	out_column	update column position for normal characters
	ada	1,dl		char count including interesting one
	a9bd	2|0,al
	sta	move_temp
	sbq	move_temp		remaining characters to scan
	lda	tct_result
	arl	27		isolate tct result code
	tra	*,al		branch based on character found
	tra	out_newline
	tra	out_backspace
	tra	out_tab

out_newline:
	lda	1,dl		set column back to 1
	sta	out_column
	aos	newline_moved	remember this
	tra	out_scan
out_backspace:
	lca	1,dl		back up one column
	asa	out_column
	tra	out_scan

out_tab:	stq	move_temp
	ldq	out_column	get current column
	adq	9,dl		compute next tab stop
	div	10,dl
	mpy	10,dl
	adq	1,dl
	stq	out_column
	ldq	move_temp
	tra	out_scan

out_normal:
	asq	out_column	regular characters take 1 column each

check_more_to_move:
	szn	entry_switch	switch entry?
	tpl	move_source_done	no
	szn	left_to_move	more stuff?
	tze	move_source_done	no
	tsx2	put_chars_buffer	dump what we have
	ldq	left_to_move
	epp2	rest_of_source,*
	cmpq	out_size		very big string to write?
	tmoz	move_the_stuff	no, routine stuff
	tsx2	put_chars_string	write it all in one iox_ call
	ldqc	left_to_move	length to scan
	tra	out_scan		must scan to keep column accurate
move_source_done:
	szn	out_left		buffer full?
	tnz	check_padding	no
	szn	entry_switch
	tpl	done		not switch entry
	tsx2	put_chars_buffer
check_padding: 
	lda	move_padding	any padding needed at end?
	tze	move_output_return	no
	cmpa	out_to_borrow	see if some of these can be borrowed
	tmi	move_borrows_all	we should steal them all
	sba	out_to_borrow	reduce by needed columns
	stz	out_to_borrow
	tra	move_the_padding
move_borrows_all:
	neg
	asa	out_to_borrow	less to borrow later
	tra	move_output_return
move_the_padding:
	sta	left_to_move
	cmpa	out_left		room to do it all?
	tmi	2,ic		yes
	lda	out_left
	epp3	out_next,*
	mlr	(),(pr,rl),fill(blank)
	desc9a	0,0
	desc9a	3|0,al
	a9bd	3|0,al
	spri3	out_next
	asa	out_column	blanks take one column each
	asa	out_moved
	neg
	asa	out_left
	asa	left_to_move
	tze	move_output_return
	szn	entry_switch	pswitch entry?
	tpl	move_output_return	no
	tsx2	put_chars_buffer
	lda	left_to_move
	tra	move_the_padding
move_output_return:
	szn	out_left		is buffer fill?
	tpnz	move_output_exit	no
	szn	entry_switch	switch entry?
	tpl	done		no
	tsx2	put_chars_buffer
move_output_exit: 
	epp2	out_save_pr2,*
	ldx2	out_save_x2
	tra	0,2		return

	tempd	move_temp,out_save_pr2,rest_of_source
	temp	move_padding,tct_result,save_out_column,newline_moved
	tempd	out_next,put_chars_arglist(5),put_chars_codeptr
	temp	out_column,out_moved,out_left,out_to_borrow,out_size
	temp	out_save_x2,left_to_move
"
"	subroutine to dump and reset the buffer

put_chars_buffer:
	szn	out_moved
	tze	0,2
	epp3	buffptr
put_chars_join:
	spri3	put_chars_arglist+4
	call	put_chars_codeptr,*(put_chars_arglist)
	szn	put_chars_arglist+8,*	error?
	tnz	thru		yes, quit
	stz	out_moved		rest all buffer variables
	epp3	buffptr,*
	spri3	out_next
	ldq	out_size
	stq	out_left
	tra	0,2

"	enter here to write a long string
"	q = length
"	pr2 -> data

put_chars_string:
	stq	out_moved
	spri2	out_next
	epp3	out_next
	tra	put_chars_join
"
"	routine to get ptr to next argument
"
getargptr:
	szn	array_in_progress	are we stepping thru an array?
	tnz	get_next_array	yes
advance_cur_arg:
	ldx6	cur_arg
	adlx6	2,du		update arg counter
	stx6	cur_arg
	cmpx6	num_args		are there any more?
	tmoz	getarg		yes
	aos	no_more_args	no more, say so
	epp2	nullptr,*		set null argp so not same as last time
	spri2	argp
	tra	0,2		and return
getarg:	eppbp	pal,*6		get ptr to arg ptr
	ldx6	dpd		get descriptor offset
	lda	bp|0,6*		get the descriptor
	tmi	ga2		skip if Version 2

"	process version 1 desciriptor

	lrl	18		save length field
	arl	3		isolate type field
	cmpa	=16,dl		convert to Version 2 types
	tmoz	4,ic
	cmpa	=32,dl
	tpl	ga3
	sba	=16,dl
	anq	=o77777,du	erase "decimal" bit
	cmpa	5,dl		is this arithmetic data
	tpl	2,ic		no, skip
	ldq	v1prec-1,al	yes, get normal v1 precision
	tra	ga1
ga3:	cmpa	=514,dl
	tnz	3,ic
	lda	=17,dl
	tra	ga1
	lda	cvtype-518,al
ga1:	als	11		make it look like Version 2
	lls	18

"	process version 2 descriptor

ga2:	cana	=o001700,du	is this an array?
	tnz	begin_array	yes, special processing required
ga5:	eppbp	bp|0,*		get pointer to argument
	spribp	argp		and save
ga4:	lrl	24		save 24 bit length field
	qrl	12
	stq	length
	arl	4		isolate type field
	ana	=o177,dl
	eax7	0,al		and leave in x7
	tra	0,2		all done

"
"	come here to begin the processing or an array. The extents of the array
"	must be detemined and the increment (words or bits) to step thru the array
"	must be found.

begin_array:
	sta	array_desc	save a copy of the descriptor
	spri3	t4		save this pointer so i can use it
	epp3	bp|0,6*		this points to first word of descriptor
	ldq	3|3		get multiplier (may be words or bits)
	stq	array_mult	and save
	stz	array_packed	set switch to un-packed array
	cana	=o002000,du	test for packed array
	tze	2,ic		it is not packed
	aos	array_packed	this means array_mult is bits, not words
	arl	24		get numbers of dims in al
	ana	=o17,dl		just that number
	eax7	0,al		number of dims to x7
	lda	1,dl
	sta	array_length	initialize array length
	sta	array_position	and position
array_calc:
	ldq	3|2		upper bound of this dimension
	sbq	3|1		minus lower dimension
	adq	1,dl		+1 gives number of elements
	mpy	array_length	total length is product of dims
	stq	array_length
	epp3	3|3		step to next desc
	sblx7	1,du		count dimension processed
	tnz	array_calc	loop if more
	epp3	t4,*		restore the pointer
	lda	array_desc	restore origional descriptor
	aos	array_in_progress	now processing an array
	tra	ga5		go setup type and length

"
"	come here to step to next element of an array during array processing

get_next_array:
	lda	array_position	current loc
	ada	1,dl		advance by 1
	cmpa	array_length	check for end
	tmoz	3,ic		not past end
	stz	array_in_progress	done array processing
	tra	advance_cur_arg	go get next arg

	sta	array_position	store updated position
	lda	array_mult	increment to be added to pointer (words or bits)
	eppbp	argp,*		get current pointdr
	szn	array_packed	is this a packed array?
	tnz	3,ic		yes
	eppbp	bp|0,al		do word addition
	tra	2,ic
	abd	bp|0,al		do bit adjustment
	spribp	argp		store adjusted pointer
	lda	array_desc	get origional descriptor
	tra	ga4		go process length and type


"
"	table to convert some Version I descriptor types to Version I types
"
cvtype:	dec	18,19,21,20,22,17,18,19,21,20,22
"
"	normal precisions for v1 data
"
v1prec:	dec	35b17,71b17,27b17,63b17
"
"	routine to get ptr to and length of string in arg list
"	x2 points at table of either char types or bit types
"	return 0,3 if not bit|char and return 1,3 if ok
"
fillin:	ldq	length		get length
	epp2	argp,*		get ptr to argument
	eaa	0,7		copy type codes
	ana	=o777776,du	erase packed bit
	tze	1,3		allow 0 type because of pl1 bug in returns(char(*))
	cmpa	0,2		is it varying
	tze	fill_varying	yes, skip
	cmpa	1,2		is this non-varying
	tze	1,3		yes, return
	tra	0,3		no, error
fill_varying:
"				the Q now holds the declared max length
	cmpq	bp|-1		if the current length is greater than the max
	tmi	1,3		then return the max length
	ldq	bp|-1		otherwise pick up the current length
	tpl	1,3		check for garbage (negative number). return if ok
	ldq	length		use max length. negative number causes blowups
	tra	1,3		return
"
cstype:	vfd	17/varying_char_dtype  char varying
	vfd	17/char_dtype	char non-varying
"
bstype:	vfd	17/varying_bit_dtype  bit varying
	vfd	17/bit_dtype	bit non-varying

"	test arg for numeric. skip return if it is

test_numeric: 
	eaa	0,7		get arg type in a
	ars	18+1		align and drop packed bit
	sba	1,dl		bit offsets start at 0
	cmpb	(al),(),fill(0)	test for numeric argument
	descb	numeric_dtype_mask,1
	descb	0,0
	tnz	1,3		it is numeric
	tra	0,3		it isn't
"
"	subroutine to get size from control field
"	entered with	pr2 & x0 pointing at next char of input
"		 	remaining number of chars in input in a
"			x4 = 0 | 1
"	this routine transfers to bad_field if string ends early
"	or if arg is not available for variable size specification
"
getsize:	cmpc	(pr,x0),(),fill(v)	is this "v"
	desc9a	2|0,1
	vfd	36/0
	tze	varsize		yes, size given by variable in arglist
"
"	not variable, look for string of digits
"
	eax1	0		init digit count
	eax2	0,0		remember where string starts
nextdigit:
	scm	(),(pr,x0)	is this character a digit
	desc9a	digits,10
	desc9a	2|0,1
	arg	t1
	ttn	getsize1		not a digit, skip
	adx1	1,du		bump digit count
	adx0	1,du		account for the digit
	sba	1,dl
	tze	bad_field
	tra	nextdigit		look for another digit
"
bit_alpha:
digits:	aci	"0123456789ABCDEF"
"
"	have string of 0 or more digits
"
getsize1:	cmpx1	0,du		do we have any digits
	tze	0,5		no, return
	stc1	sizesp,4		yes, remember size specified
	dtb	(pr,rl,x2),(pr)	convert digits to binary
	desc9ns	2|0,x1,0
	desc9a	t1,4
	ldq	t1		store size
	stq	size,4
	tra	0,5		and return
"
"	size is given by variable
"
varsize:	szn	movinh		is output inhibited by ^0(?
	tze	varsize1		no
	aos	v_not_done	set flag to remember this
	tra	varsize2

varsize1:	szn	no_more_args	error if no arg to be used
	tnz	bad_field
	stc1	sizesp,4		remember size specified
	spri2	work		save some stuff during calls which follow
	sta	work+2
	stx5	work+3
	tsx5	load_fixed_bin	get value of arg
	tra	bad_field		not numeric
	lrs	0		test for negative
	tpl	2,ic		"normalize" it
	lrl	72
	qrs	0
	tpl	2,ic
	ldq	0,dl
	stq	size,4		save size for caller
	tsx2	getargptr		step to next arg
	ldx5	work+3		restore saved stuff
	lda	work+2
	epp2	work,*
varsize2:	adx0	1,du		account for the v
	sba	1,dl
	tra	0,5		and return
"

out_scan_table:
	oct	000000000000,000000000000	000 - 007
	oct	002003001001,001001000000	010 - 017
	dup	124			020 - 777
	oct	0
	dupend
"
"	table to convert ascii to gebcd
"
ascii_to_gebcd:
	oct	020020020020,020020020020 	000
	oct	020020020020,020020020020 	010
	oct	020020020020,020020020020 	020
	oct	020020020020,020020020020 	030
	oct	020020076013,053074032057 	040
	oct	035055054060,073052033061 	050
	oct	000001002003,004005006007 	060
	oct	010011015056,036075016020 	070
	oct	014021022023,024025026027 	100
	oct	030031041042,043044045046 	110
	oct	047050051062,063064065066 	120
	oct	067070071012,037034020052 	130
	oct	037021022023,024025026027 	140
	oct	030031041042,043044045046 	150
	oct	047050051062,063064065066 	160
	oct	067070071020,040020020020 	170
"
"	edit sequences
"
int_edit:	vfd	9/lte+3,9/blank,9/mfls,9/mfls,9/mfls,9/mfls
"
oct_edit6:
	vfd	9/mvzb+5,9/mvc+1
"
oct_edit24:
	vfd	9/mvzb,9/mvzb+7,9/mvc+1
"
float_edit:
	vfd	9/lte+3,9/blank,9/mfls+1,9/insb+7,9/mvc,9/mvc,9/mvc,9/mvc
"
exp_edit:	vfd	9/lte+3,9/blank,9/mfls+9,9/enf,9/mvc+1
	end




		    fort_math_ops_.alm              11/11/89  1150.6rew 11/11/89  0804.6       23229



" ******************************************
" *                                        *
" * Copyright, (C) Honeywell Limited, 1984 *
" *                                        *
" ******************************************
	name	fort_math_ops_

	include	stack_frame

	equ	complex,56
	equ	temp_pt,40

	macro	define	operator,store_inst,arg_count,approximator
	segdef	&1
&1:
	&2	pr6|complex
	tsx0	call_&3_arg_op
	epp5	&4
	&end

	define	cabs,staq,1,<cabs_>|[cabs_]
	define	ccos,staq,1,<ccos_>|[ccos_]
	define	cexp,staq,1,<cexp_>|[cexp_]
	define	clog,staq,1,<clog_>|[clog_]
	define	cmpx_p_cmpx,staq,2,<cxp2_>|[cxp2_]
	define	cosh,dfst,1,<cosh_>|[cosh_]
	define	csin,staq,1,<csin_>|[csin_]
	define	csqrt,staq,1,<csqrt_>|[csqrt_]
	define	dcosh,dfst,1,<dcosh_>|[dcosh_]
	define	dmod,dfst,2,<fort_bfp_builtins_>|[dmod_]
	define	dsinh,dfst,1,<dsinh_>|[dsinh_]
	define	dtanh,dfst,1,<dtanh_>|[dtanh_]
	define	sinh,dfst,1,<sinh_>|[sinh_]
	define	tanh,dfst,1,<tanh_>|[tanh_]

	define	hfp_cabs,staq,1,<fort_hfp_builtins_>|[cabs_]
	define	hfp_ccos,staq,1,<fort_hfp_builtins_>|[ccos_]
	define	hfp_cexp,staq,1,<fort_hfp_builtins_>|[cexp_]
	define	hfp_clog,staq,1,<fort_hfp_builtins_>|[clog_]
	define	hfp_cmpx_p_cmpx,staq,2,<fort_hfp_builtins_>|[cxp2_]
	define	hfp_cosh,dfst,1,<fort_hfp_builtins_>|[cosh_]
	define	hfp_csin,staq,1,<fort_hfp_builtins_>|[csin_]
	define	hfp_csqrt,staq,1,<fort_hfp_builtins_>|[csqrt_]
	define	hfp_dcosh,dfst,1,<fort_hfp_builtins_>|[dcosh_]
	define	hfp_dmod,dfst,2,<fort_hfp_builtins_>|[dmod_]
	define	hfp_dsinh,dfst,1,<fort_hfp_builtins_>|[dsinh_]
	define	hfp_dtanh,dfst,1,<fort_hfp_builtins_>|[dtanh_]
	define	hfp_sinh,dfst,1,<fort_hfp_builtins_>|[sinh_]
	define	hfp_tanh,dfst,1,<fort_hfp_builtins_>|[tanh_]

call_1_arg_op:
	spri3	pr6|stack_frame.return_ptr	save return address
	sti	pr6|stack_frame.return_ptr+1	save indicators
	epp0	pr2|0		build arg list:
	fld	2*2048,dl
	staq	pr0|0		  set arg count
	epp7	pr6|complex
	spri7	pr0|2		  set arg address
	epp7	pr6|temp_pt
	spri7	pr0|4		  set result address
	tsx1	<pl1_operators_>|[get_our_lp]
	xec	0,x0		PR5 = address of approximator
	call6	pr5|0		invoke approximator

call_2_arg_op:
	spri3	pr6|stack_frame.return_ptr	save return address
	sti	pr6|stack_frame.return_ptr+1	save indicators
	epp0	pr2|0		build arg list:
	fld	3*2048,dl
	staq	pr0|0		  set arg count
	epp7	pr6|complex
	spri7	pr0|2		  set 1st arg address
	spri1	pr0|4		  set 2nd arg address
	epp7	pr6|temp_pt
	spri7	pr0|6		  set result address
	tsx1	<pl1_operators_>|[get_our_lp]
	xec	0,x0		PR5 = address of approximator
	call6	pr5|0		invoke approximator

	end




		    hfp_to_bfp_.alm                 11/11/89  1150.6rew 11/11/89  0804.2       10737



" ******************************************
" *                                        *
" * Copyright, (C) Honeywell Limited, 1983 *
" *                                        *
" ******************************************

"	Function:	Convert a Hexadecimal Floating Point number to the
"		nearest Binary Floating Point number.
"
"	Entry:	EAQ = HFP number to convert.
"		PR2 = address of 1 word work area.
"		PR3 = return address.
"
"	Exit:	EAQ = BFP equivalent of original HFP number.

"	Written 20 Dec 83 by HH.

	segdef	hfp_to_bfp_

	equ	exponent,0
	equ	indicators,0

hfp_to_bfp_:
	sti	pr2|indicators	save indicators
	ldi	=o4000,dl		mask overflows and enter BFP mode
	ste	pr2|exponent
	fno
	tze	return_zero
	ade	pr2|exponent
	teo	return_max_bfp
	teu	return_zero
	ade	pr2|exponent
	teo	return_max_bfp
	teu	return_zero
	ade	pr2|exponent
	teo	return_max_bfp
	teu	return_zero
	ldi	pr2|indicators	restore indicators
	tra	pr3|0		return

return_max_bfp:
	ldi	pr2|indicators	restore indicators
	lde	=o376000,du
	era	=o400000,du
	lrs	72
	era	=o400000,du
	tra	pr3|0		return

return_zero:
	ldi	pr2|indicators	restore indicators
	fld	=0.0,du		load "normalized" floating zero
	tra	pr3|0		return

	end




		    integer_power_integer_.alm      11/11/89  1150.6rew 11/11/89  0805.5       21483



" ***********************************************************
" *                                                         *
" * 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.      *
" *                                                         *
" ***********************************************************

"	i ** j for integer i and j
"		ldq	i
"		epp1	j
"		epp2	work
"		tsp3	entry
"
"	Modified 770412 by PG to fix 1602 (indicators not reset before rpd)
"	Modified 840123 by HH to work in both BFP and HFP modes.
"
	segdef	integer_power_integer_
"
	equ	i,0
"
integer_power_integer_:
	lda	1|0		get j
	stq	2|i
	cmpq	0,dl		is i = 0
	tze	test
	cmpa	0,dl		is j = 0
	tze	unity		j = 0 => answer = 1
	tmi	clrt		j < 0, test i
	tsx1	clrt+1		test i for -1
	cmpa	36,dl		check for exponent too bit
	tpl	bigexp		too big, unless abs(i) = 1 or 0
	sba	1,dl
	tze	done		j = i, answer = i
	als	10		shift tally into position for rpdx: C(X0)0,7
	eax0	5,al		set rpdx to terminate on all overflows or carry
	eax1	i
	eax2	35
	lls	36
	teo	1,ic		clear exponent overflow indicator
	tov	1,ic		clear overflow indicator
	odd
	rpdx	0,0		repeat until overflow, carry, or tally runout
	mpf	2|0,1
	lls	0,2
	trc	err3
	lrl	36		result to q register
done:	adq	0,dl		set indicators
	tra	3|0
"
err3:	lda	1|0		get j, if j even, ans is o377...76
	ldq	maxno
	cana	1,dl		if i is +, ans is o377...76
	tze	txtp1		if j is odd & i is (-1), ans is o400...02
	szn	2|i
	tpl	txtp1
	lcq	maxno
txtp1:	stq	2|i		err, save value to return
	ldq	60,dl
txtp2:	tsx0	<call_math_error_>|[call_math_error_]
	ldq	2|i
	tra	3|0
"
bigexp:	ldq	7,dl
bigexp1:	tsx0	<call_math_error_>|[call_math_error_]
	ldq	maxno
	tra	3|0
"
err1:	stz	2|i		0 ** 0
	ldq	1,dl
	tra	txtp2
"
unity:	ldq	1,dl
	tra	3|0
"
clear:	ldq	0,dl		return 0
	tra	3|0
"
clrt:	eax1	clear
	cmpq	1,dl		j < 0, if abs(i) > 1, ans = 0
	tze	unity
	cmpq	minus1
	tnz	0,1
	cana	1,dl		i = -1, ans = 1 if j even
	tze	unity
	lcq	1,dl
	tra	done
"
test:	cmpa	0,dl		i = 0, if j = 0 error
	tze	err1
	tpl	clear
	ldq	2,dl
	tra	bigexp1
"
maxno:	oct	377777777776	avoid "noise" word
minus1:	dec	-1
	end




		    ioa_.pl1                        11/11/89  1150.6r w 11/11/89  0805.5       97596



/****^  ***********************************************************
        *                                                         *
        * 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.      *
        *                                                         *
        *********************************************************** */


/* Initially coded in May 1972 by V. Voydock */
/* Modified June 1974 by B. Wolman to not pad buffer */
/* Last modified:
   07/28/77 by S. Webber to merge with rest_of_ioa_
   10/28/77 by M. R. Jordan to correct call to ios_signal_ ,signalling of ioa_error,
   and padding of varying return strings.
   Modified August 1979 by Larry Johnson for unlimited ioa output.
   Modified November 1981 by Benson I. Margulies for better error message
		         and correct entrypoint declarations.
   Modified September 1982 by BIM for Bootload Multics.
   Modified August 1983 by Keith Loepere for new bce switches.
   Modified 840309 to call arg_list_ptr_ instead of cu_$arg_list_ptr... -E. A. Ranzenbach
*/


/****^  HISTORY COMMENTS:
  1) change(85-09-19,Coren), approve(85-09-19,MCR7266),
     audit(85-09-24,Margolin), install(86-02-20,MR12.0-1023):
     Add general_rs_control_string entry.
                                                   END HISTORY COMMENTS */


%page;
/* format: style2 */
ioa_:
     procedure options (variable);

/* This procedure is the PL/I portion of the standard Multics output string formatting
   routine; it provides varous interfaces to formline_, which is the ALM portion. */

/* Parameters */

	dcl     arg		 char (*);
	dcl     aiocbp		 ptr;
	dcl     a_arglist_ptr	 ptr;
	dcl     a_cs_argno		 fixed bin;
	dcl     a_ff_argno		 fixed bin;
	dcl     a_control_string	 char (*);
	dcl     retstring		 char (*);
	dcl     rlen		 fixed bin (21);
	dcl     padsw		 bit (1) aligned;
	dcl     nlsw		 bit (1) aligned;

/* Automatic */

	dcl     buffer_ptr		 ptr;
	dcl     buffer_length	 fixed bin (21);
	dcl     pad		 fixed bin;
	dcl     cs_argno		 fixed bin;
	dcl     ff_argno		 fixed bin;
	dcl     switch_name		 char (32);
	dcl     iocbp		 ptr;
	dcl     code		 fixed bin (35);
	dcl     number_of_args	 fixed bin;
	dcl     arg_list_arg_count	 fixed bin;
	dcl     orig_arg_list_ptr	 pointer;
	dcl     orig_ff_argno	 fixed bin;
	dcl     system_areap	 ptr;
	dcl     orig_arg		 fixed bin;
	dcl     this_arg		 fixed bin;
	dcl     cs_entry		 bit (1);
	dcl     output_length	 fixed bin (21);
	dcl     rs_type		 fixed bin;
	dcl     arg_list_ptr	 ptr;
          dcl     my_arg_list_ptr        ptr;
	dcl     add_nl		 bit (1) aligned;

/* Builtins */

	dcl     (addr, addrel, bin, currentsize, length, min, null, string, substr)
				 builtin;

	dcl     cleanup		 condition;

/* Static */

	dcl     nl		 char (1) internal static options (constant) initial ("
");						/* New line char */

/* Based */

	dcl     system_area		 area (1024) based (system_areap);

	dcl     1 rs_arg_list	 based (arg_list_ptr),
		2 header		 fixed bin (71),
		2 control_string_ptr ptr,
		2 return_string_ptr	 ptr,
		2 return_len_ptr	 ptr;

	dcl     return_string	 char (131071) based (buffer_ptr);
	dcl     return_string_length	 fixed bin based (rs_arg_list.return_len_ptr);
	dcl     varying_string_length	 fixed bin based (addrel (buffer_ptr, -1));


/* External */

	dcl     iox_$user_output	 ext static ptr;

/* Entries */

	dcl     get_system_free_area_	 entry () returns (ptr);
	dcl     iox_signal_		 entry (ptr, fixed bin (35));
	dcl     iox_$find_iocb	 entry (char (*), ptr, fixed bin (35));
	dcl     arg_list_ptr_	 entry returns (ptr);

	dcl     formline_		 entry (fixed bin, fixed bin, ptr, fixed bin (21), fixed bin, ptr);
	dcl     formline_$switch	 entry (fixed bin, fixed bin, ptr, fixed bin, fixed bin (35));
	dcl     signal_		 entry () options (variable);

	dcl     sys_info$service_system
				 bit (1) aligned external;
	dcl     bce_data$put_chars	 external entry (ptr, ptr, fixed bin, fixed bin (35)) variable;


	add_nl = "1"b;
	go to COMMON;

nnl:
     entry options (variable);

	add_nl = "0"b;


COMMON:
	if sys_info$service_system
	then iocbp = iox_$user_output;
	else iocbp = addr (bce_data$put_chars);
	call formline_$switch (1, 2, iocbp, bin (add_nl), code);
	if code ^= 0
	then do;
		if ^sys_info$service_system
		then return;
		call iox_signal_ (iocbp, code);
		go to COMMON;
	     end;

	return;



/* The following entries return a formatted string */

rs:
     entry options (variable);
	add_nl = "1"b;
	pad = 1;
	goto COMMON_RS;
rsnnl:
     entry options (variable);
	add_nl = "0"b;
	pad = 1;
	goto COMMON_RS;
rsnp:
     entry options (variable);
	add_nl = "1"b;
	pad = 0;
	goto COMMON_RS;
rsnpnnl:
     entry options (variable);
	add_nl = "0"b;
	pad = 0;
	goto COMMON_RS;

COMMON_RS:
	arg_list_ptr = arg_list_ptr_ ();
	buffer_ptr = rs_arg_list.return_string_ptr;

	rs_type = GET_RETURN_TYPE ();

	if rs_type = varying_char_dtype
	then pad = 0;
	else if rs_type ^= char_dtype
	then call signal_error;

	call work_in_buffer (1, 4, pad, arg_list_ptr);

	return_string_length = output_length;
	if rs_type = varying_char_dtype
	then varying_string_length = output_length;
	return;
%page;
/* The following entry is the generalized entry for returning formatted strings */


general_rs:
     entry (a_arglist_ptr, a_cs_argno, a_ff_argno, retstring, rlen, padsw, nlsw);

	arg_list_ptr = a_arglist_ptr;
	cs_argno = a_cs_argno;
	ff_argno = a_ff_argno;
	cs_entry = "0"b;
	go to GENERAL_RS_JOIN;

/* The following entry is like general_rs except that the control string is passed
   explicitly, rather than being in the referenced argument list */

general_rs_control_string:
     entry (a_arglist_ptr, a_control_string, a_ff_argno, retstring, rlen, padsw, nlsw);

	orig_arg_list_ptr = a_arglist_ptr;
	orig_ff_argno = a_ff_argno;
	cs_argno = -1;
	cs_entry = "1"b;

GENERAL_RS_JOIN:
	buffer_ptr = addr (retstring);
	buffer_length = length (retstring);
	add_nl = nlsw;

	if cs_entry				/* control string supplied */
	then do;

/* We have to build a copy of the argument list (for passing to formline_) that contains
   the control string and the data args. */

		number_of_args = orig_arg_list_ptr -> arg_list.arg_count;
		system_areap = get_system_free_area_ ();
		arg_list_ptr = null ();
		on cleanup
		     begin;
			if arg_list_ptr ^= null ()
			then free arg_list_ptr -> arg_list;
		     end;

		arg_list_arg_count = number_of_args - orig_ff_argno + 2;
						/* the original data args, + 1 for the control string */
		allocate arg_list in (system_area) set (arg_list_ptr);

		arg_list_ptr -> arg_list.arg_count = arg_list_arg_count;
		arg_list_ptr -> arg_list.pad1 = "0"b;
		arg_list_ptr -> arg_list.call_type = Interseg_call_type;
		arg_list_ptr -> arg_list.desc_count = arg_list_arg_count;
		arg_list_ptr -> arg_list.pad2 = "0"b;

		arg_list_ptr -> arg_list.arg_ptrs (1) = addr (a_control_string);

		orig_arg = orig_ff_argno;
		do this_arg = 2 to arg_list_arg_count;	/* copy the other arg pointers */
		     arg_list_ptr -> arg_list.arg_ptrs (this_arg) = orig_arg_list_ptr -> arg_list.arg_ptrs (orig_arg);
		     orig_arg = orig_arg + 1;
		end;

/* Now copy the descriptor for the control string from *this entry's* argument list */

		my_arg_list_ptr = arg_list_ptr_ ();
		arg_list_ptr -> arg_list.desc_ptrs (1) = my_arg_list_ptr -> arg_list.desc_ptrs (2);

/* Now copy in the other descriptor pointers */

		orig_arg = orig_ff_argno;

		if orig_arg_list_ptr -> arg_list.call_type = Envptr_supplied_call_type
		then do this_arg = 2 to arg_list_arg_count;
			arg_list_ptr -> arg_list.desc_ptrs (this_arg) =
			     orig_arg_list_ptr -> arg_list_with_envptr.desc_ptrs (orig_arg);
			orig_arg = orig_arg + 1;
		     end;

		else do this_arg = 2 to arg_list_arg_count;
			arg_list_ptr -> arg_list.desc_ptrs (this_arg) =
			     orig_arg_list_ptr -> arg_list.desc_ptrs (orig_arg);
			orig_arg = orig_arg + 1;
		     end;

		cs_argno = 1;
		ff_argno = 2;
	     end;

	call work_in_buffer (cs_argno, ff_argno, bin (padsw, 1), arg_list_ptr);

	rlen = output_length;
	if cs_entry
	then free arg_list_ptr -> arg_list;
	return;
%page;
/* The following entries use an I/O switch or switch name as target */

ioa_switch:
     entry (aiocbp);
	add_nl = "1"b;
	iocbp = aiocbp;
	goto FOUND_SWITCH_PTR;
ioa_switch_nnl:
     entry (aiocbp);
	add_nl = "0"b;
	iocbp = aiocbp;
	goto FOUND_SWITCH_PTR;
ioa_stream:
     entry (arg);
	add_nl = "1"b;
	goto FIND_SWITCH_PTR;
ioa_stream_nnl:
     entry (arg);
	add_nl = "0"b;
	goto FIND_SWITCH_PTR;

FIND_SWITCH_PTR:
	switch_name = arg;
	if sys_info$service_system
	then call iox_$find_iocb (switch_name, iocbp, (0));
	else iocbp = addr (bce_data$put_chars);

FOUND_SWITCH_PTR:
	call formline_$switch (2, 3, iocbp, bin (add_nl), code);
	if code ^= 0
	then do;
		if ^sys_info$service_system
		then return;
		call iox_signal_ (iocbp, code);
		go to FOUND_SWITCH_PTR;
	     end;
	return;
%page;
/* Subroutine to do the actual work when the data is returned to the callers buffer */

work_in_buffer:
     proc (cs_arg_no, ff_arg_no, pad, ap);

	dcl     (cs_arg_no, ff_arg_no, pad)
				 fixed bin;
	dcl     ap		 ptr;


	output_length = buffer_length;
	call formline_ (cs_arg_no, ff_arg_no, buffer_ptr, output_length, pad, ap);

	if add_nl
	then do;
		output_length = min (output_length + 1, buffer_length);
		substr (return_string, output_length, 1) = nl;
	     end;

	return;

     end work_in_buffer;

signal_error:
     procedure;

%include condition_info_header;
	declare 1 CI		 aligned like condition_info_header;
	declare error_table_$bad_arg	 external static fixed bin (35);

	CI.length = currentsize (CI);
	CI.version = 1;
	string (CI.action_flags) = ""b;
	CI.cant_restart = "1"b;
	CI.info_string =
	     "A return string argument to an ioa_$rs* entrypoint was not a character or varying character string.";
	CI.status_code = error_table_$bad_arg;
	call signal_ ("ioa_error", null (), addr (CI));
	return;
     end signal_error;

/* This procedure sets buffer_length as a side effect */

GET_RETURN_TYPE:
     procedure returns (fixed bin);

	if arg_list_ptr -> arg_list.desc_count = 0
	then return (-1);
	if arg_list_ptr -> arg_list.call_type = Interseg_call_type
	then arg_descriptor_ptr = arg_list_ptr -> arg_list.desc_ptrs (2);
	else arg_descriptor_ptr = arg_list_ptr -> arg_list_with_envptr.desc_ptrs (2);
	buffer_length = arg_descriptor.size;
	return (arg_descriptor.type);
     end GET_RETURN_TYPE;


%page;
%include arg_descriptor;
%page;
%include arg_list;
%page;
%include std_descriptor_types;
     end ioa_;




		    logarithm_.alm                  11/11/89  1150.6rew 11/11/89  0805.2       58014



" ******************************************
" *                                        *
" * Copyright, (C) Honeywell Limited, 1985 *
" *                                        *
" ******************************************
	name	logarithm_
" Modification history:
"	Written by H. Hoover, M. Mabey, and B. Wong, April 1985,
"	based on GCOS routine '7naf'.
"
" Function:  Calculates the logarithm functions log_base_e(x), log_base_2(x),
"	and log_base_10(x) to single precision accuracy in either BFP or
"	HFP mode.
"
" Entry:	through the appropriately named entry point with:
" 	EAQ = the argument x.
"	PR2 = the address of a 14 word, even-word aligned scratch area.
"	PR3 = the return address.
"
" Exit:	EAQ = the desired logarithm
"
" Uses:	X0, X1, X3
"	X0 = saves a return address from call_math_error_
"	     or saves a return address from log2
"	X1 = saves a return address from part_log2_of_ratio
"	X3 = address of second argument for part_log2_of_ratio

	segref	math_constants_,hfp_log_10_of_2,hfp_log_e_of_2,log_10_of_2,log_e_of_2,max_value

	equ	xe,0
	equ	xm,2
	equ	bias,4
	equ	shift,6
	equ	x_plus_y,8
	equ	z,10
	equ	zz,12

	segdef	log_base_10_,hfp_log_base_10_
	segdef	log_base_2_,hfp_log_base_2_
	segdef	log_base_e_,hfp_log_base_e_


log_base_10_:
	tsx0	log2		" calculate log2 (x)
	dfmp	log_10_of_2	" EAQ := log_10_of_2 * log2 (x)
	frd	0
	tra	pr3|0		" return to caller

log_base_2_:
	tsx0	log2		" calculate log2 (x)
	frd	0
	tra	pr3|0		" return to caller

log_base_e_:
	tsx0	log2		" calculate log2 (x)
	dfmp	log_e_of_2	" EAQ := log_e_of_2 * log2 (x)
	frd	0
	tra	pr3|0		" return to caller

hfp_log_base_10_:
	tsx0	hfp_log2		" calculate log2 (x)
	dfmp	hfp_log_10_of_2	" EAQ := hfp_log_10_of_2 * log2 (x)
	frd	0
	tra	pr3|0		" return to caller

hfp_log_base_2_:
	tsx0	hfp_log2		" calculate log2 (x)
	frd	0
	tra	pr3|0		" return to caller

hfp_log_base_e_:
	tsx0	hfp_log2		" calculate log2 (x)
	dfmp	hfp_log_e_of_2	" EAQ := hfp_log_e_of_2 * log2 (x)
	frd	0
	tra	pr3|0		" return to caller

log_of_negative:
	ldq	10,dl
	tsx0	<call_math_error_>|[call_math_error_]
	fld	max_value
	fneg	0
	tra	pr3|0

log_of_zero:
	ldq	9,dl
	tsx0	<call_math_error_>|[call_math_error_]
	fld	max_value
	fneg	0
	tra	pr3|0

log2:
	fad	=0.0,du		" normalize input and set indicators
	tmi	log_of_negative
	tze	log_of_zero

	fcmp	square_root_two	" check for x in the range [.707,1.414]
	tpl	6,ic
	  fcmp	square_root_half
	  tmi	4,ic		" if square_root_half >= x & x <= square_root_two
	    eax3	one		"   X3 := addr (1.0)
	    eax1	0,x0		"   copy return address
	    tra	part_log2_of_ratio	"   result = part_log2_of_ratio (x, 1)
				" else
	ste	pr2|xe		"   store addr (x) -> expon in xe 
	lde	=0,du		"   addr (xm) -> expon = 0
	fst	pr2|xm
	lda	pr2|xe		"   A := 8/xe,10/0,18/garbage
	lrs	72-18		"   AQ := 62/xe,10/0
	lde	=61b25,du		"   EAQ := unnormalized float(xe)
	fsb	=0.5,du		"   EAQ := float(xe) - 0.5
	fst	pr2|bias
	fld	pr2|xm
	eax3	square_root_half	"   X3 := addr (square_root_half)
	tsx1	part_log2_of_ratio	"   EAQ := part_log2_of_ratio (x, square_root_half)
          fad       pr2|bias            "   EAQ := part_log2_of_ratio (x, square_root_half) + bias  (= log2(x))
	tra	0,x0		"   return result


" part_log2_of_ratio (x, y) calculates log2(x/y), where x/y is in the
" range [0.5*2**0.5, 2**0.5], given x in the EAQ and the address of y in X3.

part_log2_of_ratio:

	dfad	0,x3		" EAQ := x + y
	dfst	pr2|x_plus_y
	dfsb	0,x3		" EAQ := x
	dfsb	0,x3		" EAQ := x - y
	dfdv	pr2|x_plus_y	" calculate z = (x - y) / (x + y)
	fcmg	eps
	tpnz	3,ic		" if abs(z) < 4.1968417d-11
	  dfmp	p0		"   EAQ := z * p0
	  tra	0,x1		"   return to caller
	dfst	pr2|z
	fmp	pr2|z		" calculate zz = z*z
	fst	pr2|zz		" calculate p(zz)
	fmp	p3
	dfad	p2
	fmp	pr2|zz
	dfad	p1
	fmp	pr2|zz
	dfad	p0
	dfmp	pr2|z		" calculate z*p(zz)

	tra	0,x1		" return to caller


hfp_log2:
	fad	=0.0,du		" normalize input and set indicators
	tmi	log_of_negative
	tze	log_of_zero

	fcmp	hfp_square_root_two	" check for x in the range [.707,1.414]
	tpl	6,ic
	  fcmp	hfp_square_root_half
	  tmi	4,ic		" if square_root_half >= x & x <= square_root_two
	    eax3	hfp_one		"   X3 := addr (1.0)
	    eax1	0,x0		"   copy return address
	    tra	hfp_part_log2_of_ratio
				"   result = hfp_part_log2_of_ratio (x, 1)
				" else
	ste	pr2|xe		"   store addr (x) -> expon in xe
	lde	=0,du		"   addr (xm) -> expon = 0
				"   EAQ := xm
	stz	pr2|shift		"   shift := 0

	even
do_while:				"   do while (xm < 0.5)
	fcmp	=0.5,du
	tpl	end_do_while
	lls	1		"      xm = 2*xm
          aos	pr2|shift		"      shift := shift + 1
	tra	do_while		"   end do_while
end_do_while:

	fst	pr2|xm
	lda	pr2|xe		"   A := 8/xe,10/0,18/garbage
	lrs	36-10		"   AQ := 36/4*xe,8/0,28/garbage
	sba	pr2|shift		"   AQ := 36/4*xe-shift,8/0,28/garbage
	lrs	29		"   AQ := 65/4*xe-shift,7/0
	lde	=16b25,du		"   EAQ := unnormalized float(4*xe-shift)
	fsb	=0.5,du		"   EAQ := float(4*xe-shift)-0.5
	fst	pr2|bias
	fld	pr2|xm
	eax3	hfp_square_root_half
				"   X3 := addr (square_root_half)
	tsx1	hfp_part_log2_of_ratio
				"   EAQ := hfp_part_log2_of_ratio (x, square_root_half)
	fad	pr2|bias		"   EAQ := hfp_part_log2_of_ratio (x, square_root_half) + bias
	tra	0,x0		"   return result


" hfp_part_log2_of_ratio (x, y) calculates log2(x/y), where x/y is in the
" range [0.5*2**0.5, 2**0.5], given x in the EAQ and the address of y in X3.

hfp_part_log2_of_ratio:

	dfad	0,x3		" EAQ := x + y
	dfst	pr2|x_plus_y
	dfsb	0,x3		" EAQ := x
	dfsb	0,x3		" EAQ := x - y
	dfdv	pr2|x_plus_y	" calculate z = (x - y) / (x + y)
	fcmg	hfp_eps
	tpnz	3,ic		" if abs(z) < 4.1968417d-11
	  dfmp	hfp_p0		"   EAQ := z * p0
	  tra	0,x1		"   return to caller
	dfst	pr2|z
	fmp	pr2|z		" calculate zz = z*z
	fst	pr2|zz		" calculate p(zz)
	fmp	hfp_p3
	dfad	hfp_p2
	fmp	pr2|zz
	dfad	hfp_p1
	fmp	pr2|zz
	dfad	hfp_p0
	dfmp	pr2|z		" calculate z*p(zz)

	tra	0,x1		" return to caller

	even
eps:	dec	4.1968417d-11
hfp_eps:	oct	760134224171,000000000000
one:	dec	1.0d0
hfp_one:	oct	002040000000,000000000000
p0:	dec	.288539007275213810d01
hfp_p0:	oct	002134252166,176530650277
p1:	dec	.961800759210250522d00
hfp_p1:	oct	000754342230,541156441462
p2:	dec	.576584541348266310d00
hfp_p2:	oct	000447154133,107411741772
p3:	dec	.434255940790007142d0
hfp_p3:	oct	000336255455,574455321266
square_root_half:
	dec	7.071067811865475244008d-01
hfp_square_root_half:
	oct	000552023631,477473631102
square_root_two:
	dec	1.414213562373095048801d+00
hfp_square_root_two:
	oct	002055202363,147747363110

	end




		    math_constants_.alm             11/11/89  1150.6rew 11/11/89  0805.5       23400



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Bull Inc., 1987                *
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1985 *
" *                                                         *
" ***********************************************************

"
"	Rewritten: 13 Feb 85 by HH to put the HFP constant values
"		immediately after the equivalent BFP values.  This was
"		done for the sake of the math routines that use X
"		register offsets to differentiate between the HFP and BFP
"		values.


	name	math_constants_

	segdef	almost_one,hfp_almost_one
almost_one:
hfp_almost_one:
	oct	000777777777,777777777777


	segdef	half_pi,hfp_half_pi
half_pi:
	dec	1.570796326794896619231d+00
hfp_half_pi:
	oct	002062207732,504205506043


	segdef	log_10_of_2,hfp_log_10_of_2
log_10_of_2:
	dec	3.010299956639811952137d-01
hfp_log_10_of_2:
	oct	000232101152,047674776746


	segdef	log_10_of_e,hfp_log_10_of_e
log_10_of_e:
	dec	4.342944819032518276511d-01
hfp_log_10_of_e:
	oct	000336267542,511562416145


	segdef	log_2_of_e,hfp_log_2_of_e
log_2_of_e:
	dec	1.442695040888963407359d+00
hfp_log_2_of_e:
	oct	002056125073,122560277414


	segdef	log_e_of_2,hfp_log_e_of_2
log_e_of_2:
	dec	6.931471805599453094172d-01
hfp_log_e_of_2:
	oct	000542710277,575071736326


	segdef	max_value,hfp_max_value
max_value:
hfp_max_value:
	oct	376777777777,777777777777


	segdef	one_degree,hfp_one_degree
one_degree:
	dec	1.745329251994329576923d-02
hfp_one_degree:
	oct	776216764324,224516471053


	segdef	one_over_pi,hfp_one_over_pi
one_over_pi:
	dec	3.183098861837906715377d-01
hfp_one_over_pi:
	oct	000242763015,562344202512


	segdef	one_radian,hfp_one_radian
one_radian:
	dec	5.729577951308232087679d+01
hfp_one_radian:
	oct	004162456701,514360373670


	segdef	pi,hfp_pi
pi:
	dec	3.141592653589793238462d+00
hfp_pi:
	oct	002144417665,210413214107


	segdef	quarter_pi,hfp_quarter_pi
quarter_pi:
	dec	7.853981633974483096156d-01
hfp_quarter_pi:
	oct	000622077325,042055060432


	segdef	square_root_half,hfp_square_root_half
square_root_half:
	dec	7.071067811865475244008d-01
hfp_square_root_half:
	oct	000552023631,477473631102


	segdef	square_root_three,hfp_square_root_three
square_root_three:
	dec	1.732050807568877293527d+00
hfp_square_root_three:
	oct	002067331727,205411452472


	segdef	square_root_two,hfp_square_root_two
square_root_two:
	dec	1.414213562373095048801d+00
hfp_square_root_two:
	oct	002055202363,147747363110


	end




		    math_routines_.alm              11/11/89  1150.6rew 11/11/89  0804.6        7254



" ***********************************************************
" *                                                         *
" * 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.      *
" *                                                         *
" ***********************************************************

" this routine must be bound before any of the math
" routines in bound_pl1_operators_.  It is used by
" default_errror_handler_
"
	segdef	math_routines_
math_routines_:
	vfd	36/*
	end




		    math_routines_end_.alm          11/11/89  1150.6rew 11/11/89  0803.9        7317



" ***********************************************************
" *                                                         *
" * 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.      *
" *                                                         *
" ***********************************************************

" this routine must be bound after any of the math
" routines in bound_pl1_operators_.  It is used by
" default_errror_handler_
"
	segdef	math_routines_end_
math_routines_end_:
	vfd	36/*
	end




		    mrl_.alm                        11/11/89  1150.6rew 11/11/89  0804.6       13221



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Bull Inc., 1987                *
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1983 *
" *                                                         *
" ***********************************************************

" Subroutine interface to the MRL and MLR instructions

" Created:  11 January 1983 by G. Palter

	name	mrl_


" mrl_: Moves a character string copying the characters from right-to-left

"	dcl  mrl_ entry (ptr, fixed bin(21), ptr, fixed bin(21));
"	call mrl_ (input_ptr, input_lth, output_ptr, output_lth);

	entry	mrl_

mrl_:	epp1	ap|2,*			" get input_ptr
	epp1	pr1|0,*
	lda	ap|4,*			" get input_lth

	epp2	ap|6,*			" get output_ptr
	epp2	pr2|0,*
	ldq	ap|8,*			" get output_lth

	mrl	(pr,rl),(pr,rl),fill(040)	" do it
	desc9a	pr1|0,al
	desc9a	pr2|0,ql

	short_return



" mlr_: Moves a character string copying the characters from left-to-right

"	dcl  mlr_ entry (ptr, fixed bin(21), ptr, fixed bin(21));
"	call mlr_ (input_ptr, input_lth, output_ptr, output_lth);

	entry	mlr_

mlr_:	epp1	ap|2,*			" get input_ptr
	epp1	pr1|0,*
	lda	ap|4,*			" get input_lth

	epp2	ap|6,*			" get output_ptr
	epp2	pr2|0,*
	ldq	ap|8,*			" get output_lth

	mlr	(pr,rl),(pr,rl),fill(040)	" do it
	desc9a	pr1|0,al
	desc9a	pr2|0,ql

	short_return

	end




		    mvt_.alm                        11/11/89  1150.6r w 11/11/89  0805.2       63639



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Bull Inc., 1987                *
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" ***********************************************************

" Utility to perform extremely fast character string translations

" Created:  October 1982 by G. Palter
" Modified: 3 December 1982 by G. Palter to fix fencepost error in make_translation_table
" Modified: 15 December 1983 by G. Palter to fix make_translation_table's handling of a
"    zero-length second argument (untranslated_list)


	name	mvt_



" mvt_: Translates a character string

"	dcl  mvt_ entry (ptr, ptr, fixed bin(21), char(512) aligned);
"	dcl  mvt_ (input_string_ptr, output_string_ptr, string_lth,
"		 translate_table);

	entry	mvt_

mvt_:	epp1	ap|2,*			" get input_string_ptr
	epp1	pr1|0,*

	epp2	ap|4,*			" get output_string_ptr
	epp2	pr2|0,*

	ldq	ap|6,*			" get string_lth
	epp3	ap|8,*			" get addr(transate_table)

	mvt	(pr,rl),(pr,rl)		" translate me
	desc9a	pr1|0,ql
	desc9a	pr2|0,ql
	arg	pr3|0

	short_return			" simple isn't it

"

" make_translation_table: Constructs the translate table used in calls to mvt_

"	dcl  mvt_$make_translation_table entry (char(*), char(*),
"		char(512) aligned);
"	call mvt_$make_translation_table (translated_list, untranslated_list,
"		translate_table);

	entry	make_translation_table

	temp	translated_lth
	temp	untranslated_lth
	temp	untranslated_char


make_translation_table:
	push				" need a stack frame for this one
	lda	ap|0			" get 2*nargs into AU, code into AL
	cana	8,dl			" is there an evironmentptr?
	tze	2,ic			" ... no
	ada	2,du			" ... yes
	epp4	ap|0,au			" get addr(descriptors)

	epp1	ap|2,*			" get addr(translated_list)
	lda	pr4|2,*			" get length(translated_list)
	tmi	2,ic
	ana	=o777777,dl
	ana	descriptor_mask
	sta	sp|translated_lth

	epp2	ap|4,*			" get addr(untranslated_list)
	lda	pr4|4,*			" get length(untranslated_list)
	tmi	2,ic
	ana	=o777777,dl
	ana	descriptor_mask
	sta	sp|untranslated_lth

	epp3	ap|6,*			" get addr(translation_table)
	mlr	(),(pr)			" initialize translation table to ...
	desc9a	collate9,512		" ... collate9() (no translation)
	desc9a	pr3|0,512

	lda	sp|untranslated_lth		" loop backwards
	tpnz	build_table
	
	return				" zero-length untranslated_list

build_table:
	mrl	(pr,al),(pr),fill(000)	" get rank(untranslated_char)
	desc9a	pr2|-1(3),1
	desc9a	sp|untranslated_char,4
	ldq	sp|untranslated_char	" ... into the Q

	cmpa	sp|translated_lth		" see if there's a translation given
	tpnz	use_blank_for_translation	" ... no

	mlr	(pr,al),(pr,ql)		" ... yes: put into the table
	desc9a	pr1|-1(3),1
	desc9a	pr3|0,1
	tra	continue

use_blank_for_translation:			" put blank in for translation
	mlr	(),(pr,ql),fill(040)
	desc9a	0,0
	desc9a	pr3|0,1

continue: sba	1,dl			" done?
	tpnz	build_table		" ... no

	return				" ... yes


" Constants

descriptor_mask:
	oct	000777777777		" gets length from a descriptor

collate9:	vfd	o9/000,o9/001,o9/002,o9/003,o9/004,o9/005,o9/006,o9/007
	vfd	o9/010,o9/011,o9/012,o9/013,o9/014,o9/015,o9/016,o9/017
	vfd	o9/020,o9/021,o9/022,o9/023,o9/024,o9/025,o9/026,o9/027
	vfd	o9/030,o9/031,o9/032,o9/033,o9/034,o9/035,o9/036,o9/037
	vfd	o9/040,o9/041,o9/042,o9/043,o9/044,o9/045,o9/046,o9/047
	vfd	o9/050,o9/051,o9/052,o9/053,o9/054,o9/055,o9/056,o9/057
	vfd	o9/060,o9/061,o9/062,o9/063,o9/064,o9/065,o9/066,o9/067
	vfd	o9/070,o9/071,o9/072,o9/073,o9/074,o9/075,o9/076,o9/077
	vfd	o9/100,o9/101,o9/102,o9/103,o9/104,o9/105,o9/106,o9/107
	vfd	o9/110,o9/111,o9/112,o9/113,o9/114,o9/115,o9/116,o9/117
	vfd	o9/120,o9/121,o9/122,o9/123,o9/124,o9/125,o9/126,o9/127
	vfd	o9/130,o9/131,o9/132,o9/133,o9/134,o9/135,o9/136,o9/137
	vfd	o9/140,o9/141,o9/142,o9/143,o9/144,o9/145,o9/146,o9/147
	vfd	o9/150,o9/151,o9/152,o9/153,o9/154,o9/155,o9/156,o9/157
	vfd	o9/160,o9/161,o9/162,o9/163,o9/164,o9/165,o9/166,o9/167
	vfd	o9/170,o9/171,o9/172,o9/173,o9/174,o9/175,o9/176,o9/177
	vfd	o9/200,o9/201,o9/202,o9/203,o9/204,o9/205,o9/206,o9/207
	vfd	o9/210,o9/211,o9/212,o9/213,o9/214,o9/215,o9/216,o9/217
	vfd	o9/220,o9/221,o9/222,o9/223,o9/224,o9/225,o9/226,o9/227
	vfd	o9/230,o9/231,o9/232,o9/233,o9/234,o9/235,o9/236,o9/237
	vfd	o9/240,o9/241,o9/242,o9/243,o9/244,o9/245,o9/246,o9/247
	vfd	o9/250,o9/251,o9/252,o9/253,o9/254,o9/255,o9/256,o9/257
	vfd	o9/260,o9/261,o9/262,o9/263,o9/264,o9/265,o9/266,o9/267
	vfd	o9/270,o9/271,o9/272,o9/273,o9/274,o9/275,o9/276,o9/277
	vfd	o9/300,o9/301,o9/302,o9/303,o9/304,o9/305,o9/306,o9/307
	vfd	o9/310,o9/311,o9/312,o9/313,o9/314,o9/315,o9/316,o9/317
	vfd	o9/320,o9/321,o9/322,o9/323,o9/324,o9/325,o9/326,o9/327
	vfd	o9/330,o9/331,o9/332,o9/333,o9/334,o9/335,o9/336,o9/337
	vfd	o9/340,o9/341,o9/342,o9/343,o9/344,o9/345,o9/346,o9/347
	vfd	o9/350,o9/351,o9/352,o9/353,o9/354,o9/355,o9/356,o9/357
	vfd	o9/360,o9/361,o9/362,o9/363,o9/364,o9/365,o9/366,o9/367
	vfd	o9/370,o9/371,o9/372,o9/373,o9/374,o9/375,o9/376,o9/377
	vfd	o9/400,o9/401,o9/402,o9/403,o9/404,o9/405,o9/406,o9/407
	vfd	o9/410,o9/411,o9/412,o9/413,o9/414,o9/415,o9/416,o9/417
	vfd	o9/420,o9/421,o9/422,o9/423,o9/424,o9/425,o9/426,o9/427
	vfd	o9/430,o9/431,o9/432,o9/433,o9/434,o9/435,o9/436,o9/437
	vfd	o9/440,o9/441,o9/442,o9/443,o9/444,o9/445,o9/446,o9/447
	vfd	o9/450,o9/451,o9/452,o9/453,o9/454,o9/455,o9/456,o9/457
	vfd	o9/460,o9/461,o9/462,o9/463,o9/464,o9/465,o9/466,o9/467
	vfd	o9/470,o9/471,o9/472,o9/473,o9/474,o9/475,o9/476,o9/477
	vfd	o9/500,o9/501,o9/502,o9/503,o9/504,o9/505,o9/506,o9/507
	vfd	o9/510,o9/511,o9/512,o9/513,o9/514,o9/515,o9/516,o9/517
	vfd	o9/520,o9/521,o9/522,o9/523,o9/524,o9/525,o9/526,o9/527
	vfd	o9/530,o9/531,o9/532,o9/533,o9/534,o9/535,o9/536,o9/537
	vfd	o9/540,o9/541,o9/542,o9/543,o9/544,o9/545,o9/546,o9/547
	vfd	o9/550,o9/551,o9/552,o9/553,o9/554,o9/555,o9/556,o9/557
	vfd	o9/560,o9/561,o9/562,o9/563,o9/564,o9/565,o9/566,o9/567
	vfd	o9/570,o9/571,o9/572,o9/573,o9/574,o9/575,o9/576,o9/577
	vfd	o9/600,o9/601,o9/602,o9/603,o9/604,o9/605,o9/606,o9/607
	vfd	o9/610,o9/611,o9/612,o9/613,o9/614,o9/615,o9/616,o9/617
	vfd	o9/620,o9/621,o9/622,o9/623,o9/624,o9/625,o9/626,o9/627
	vfd	o9/630,o9/631,o9/632,o9/633,o9/634,o9/635,o9/636,o9/637
	vfd	o9/640,o9/641,o9/642,o9/643,o9/644,o9/645,o9/646,o9/647
	vfd	o9/650,o9/651,o9/652,o9/653,o9/654,o9/655,o9/656,o9/657
	vfd	o9/660,o9/661,o9/662,o9/663,o9/664,o9/665,o9/666,o9/667
	vfd	o9/670,o9/671,o9/672,o9/673,o9/674,o9/675,o9/676,o9/677
	vfd	o9/700,o9/701,o9/702,o9/703,o9/704,o9/705,o9/706,o9/707
	vfd	o9/710,o9/711,o9/712,o9/713,o9/714,o9/715,o9/716,o9/717
	vfd	o9/720,o9/721,o9/722,o9/723,o9/724,o9/725,o9/726,o9/727
	vfd	o9/730,o9/731,o9/732,o9/733,o9/734,o9/735,o9/736,o9/737
	vfd	o9/740,o9/741,o9/742,o9/743,o9/744,o9/745,o9/746,o9/747
	vfd	o9/750,o9/751,o9/752,o9/753,o9/754,o9/755,o9/756,o9/757
	vfd	o9/760,o9/761,o9/762,o9/763,o9/764,o9/765,o9/766,o9/767
	vfd	o9/770,o9/771,o9/772,o9/773,o9/774,o9/775,o9/776,o9/777

	end




		    oc_trans_output_.pl1            11/11/89  1150.6rew 11/11/89  0804.2       36639



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1983 *
        *                                                         *
        *********************************************************** */


/****^  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):
     Changed to allow PAD (\177) characters to pass through without being
     interpreted.
                                                   END HISTORY COMMENTS */


/* format: style4,delnl,insnl,tree,ifthenstmt,indnoniterend */
oc_trans_output_:
     procedure (In_ptr, In_len, In_proc, Out_ptr, Out_words, Line_leng, Cont);

/* Written by C. Hornig, April 1982 */
/* Modified 830620 to support consoles with different line lengths and to 
   delete support of non-ASCII console types... -E. A. Ranzenbach */

dcl  (In_ptr, Out_ptr) ptr parameter;
dcl  (In_len, In_proc) fixed bin (21) parameter;
dcl  Out_words fixed bin (19) parameter;
dcl  Cont bit (1) aligned parameter;
dcl  Line_leng fixed bin (17) parameter;

dcl  in_string char (In_len) based (In_ptr);
dcl  out_string char (256) based (Out_ptr);

dcl  c char (1) aligned;
dcl  b fixed bin (9);
dcl  out_pos fixed bin;
dcl  out_proc fixed bin (21);
dcl  n fixed bin;
dcl  done bit (1) aligned;

dcl  (byte, copy, divide, hbound, lbound, length, mod, rank, string, substr, unspec) builtin;
%page;
	In_proc, Out_words = 0;
	out_proc, out_pos = 0;

	if In_len <= 0 then return;			/* ignore null string */

	if Cont then do;
	     substr (out_string, 1, 2) = "\c";
	     out_proc, out_pos = 2;
	     Cont = "0"b;
	     end;

	done = "0"b;
	do while ((In_proc < In_len) & ^done);
	     c = substr (in_string, In_proc + 1, 1);
	     b = rank (c);

	     if /* case */ (b >= 32) & (b <= 127) then do;
		call inc_pos (1);
		goto copy_char;
		end;

	     else if (b < lbound (cc, 1)) | (b > hbound (cc, 1)) then do;
cc (11):
cc (12):
		call inc_pos (4);
		call inc_proc (4);
		begin;
dcl  oe (4) char (1) unaligned;

		     oe (1) = "\";
		     unspec (oe (2)) = "06"b3 || substr (unspec (c), 1, 3);
		     unspec (oe (3)) = "06"b3 || substr (unspec (c), 4, 3);
		     unspec (oe (4)) = "06"b3 || substr (unspec (c), 7, 3);
		     substr (out_string, out_proc - 3, 4) = string (oe);
		end;
		goto done_cc;
		end;

	     else goto cc (b);

cc (8):						/* BS */
	     if out_pos > 0 then out_pos = out_pos - 1;
	     goto copy_char;

cc (9):						/* HT */
	     n = 1 + mod (-out_pos - 1, 10);
	     call inc_pos (n);
	     call inc_proc (n);
	     substr (out_string, out_proc - n + 1, n) = "";
	     goto done_cc;

cc (10):						/* NL */
	     call add_nl;
	     done = "1"b;
	     goto done_cc;

cc (13):						/* CR */
	     out_pos = 0;
	     goto copy_char;

cc (7):						/* BEL */
copy_char:
	     call inc_proc (1);
	     substr (out_string, out_proc, 1) = c;

done_cc:
	     In_proc = In_proc + 1;
	end;

finish_up:
	Out_words = divide (out_proc + 3, 4, 19, 0);
	n = 4 * Out_words - out_proc;
	substr (out_string, out_proc + 1, n) = copy (byte (127), n);

	return;

/* * * * * * * * * INC_PROC * * * * * * * * */

inc_proc:
     procedure (N);
dcl  N fixed bin parameter;

	if out_proc + N > length (out_string) then goto finish_up;
	out_proc = out_proc + N;
	return;
     end inc_proc;

/* * * * * * * * * * INC_POS * * * * * * * * * */

inc_pos:
     procedure (N);
dcl  N fixed bin parameter;

	if out_pos + N > Line_leng then do;
	     Cont = "1"b;
	     call add_nl;
	     goto finish_up;
	     end;
	out_pos = out_pos + N;
	return;
     end inc_pos;

/* * * * * * * * * * ADD_NL * * * * * * * * * * */

add_nl:
     procedure;
	call inc_proc (2);
	substr (out_string, out_proc - 1, 2) = byte (13) || byte (10);
	out_pos = 0;
	return;
     end add_nl;

     end oc_trans_output_;




		    pc_check_tables_.pl1            11/11/89  1150.6r w 11/11/89  0805.5      222723



/****^  ***********************************************************
        *                                                         *
        * 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,indcomtxt */

pc_check_tables_:
     procedure (Info_pointer, Code);

/**** This procedure is invoked at fault recovery/ESD time to place the
      SST in a consistent state, assuming consistent interruption of  page control.

      It is also called from the user ring to report on the state
      of a file system. In this case, it changes nothing.

      This procedure's function is to reconstruct SST based on critical
      sequences in all of ALM pc and pc.pl1. Every line
      of this procedure that changes SST is critical by same standard, and must
      follow same rules.

      This procedure assumes the following conventions, which ALM page control
      must continue to follow:

      *	A ptw may be moved to full incore state. A cme with ptwp nonzero is wholly
      *	valid.

      *	Any out of service page can be taken non-out of service- if it was a write,
      *	phm may be turned on. If it was a read, it may be taken out of core.


      *	The disk dim has been trained to throw away all requests at
      *	recovery time to validate these assumptions.


      An attempt is made to repair "impossible" damage, i.e., that which could
      not have occured as a result of clean interruption of a properly functioning
      page control. Rather than report each such lossage, about which nothing
      consistent can be done, segments so affected are marked as
      damaged, and pages so involved made null where possible.

      We even attempt to repair "garbage" in the SST (see reasonable_devaddp s/r),
      although in this case and the previous one, segment damage will surely result.

      No attempt is made to handle move_page_table in this version.

      A creation of Bernard Greenberg, May 1977.
      Modified, minimally, 03/06/81, W. Olin Sibert, for ADP conversion
      Modified, minutely,  06/21/82, E. N. Kittlitz, to move core map and not so minutely (auditor's orders) zap page-multilevel.
      Modified, 831220, E. N. Kittlitz, for pc$segmove support.
      Modified, 84-01-05, BIM, to finish above and use debug_check for stats.
      Modified, 84-01-05, BIM, to abstract as subroutine callable from user
      ring. */


	declare Info_pointer	 pointer;
	declare Code		 fixed bin (35);

	dcl     cmap		 ptr;		/* Core map array ppr */
	dcl     ptp		 pointer;
	dcl     (new_nused, new_nwired)
				 fixed bin;	/* Counters for re-computation */
	dcl     (curused, csl, nincore)
				 fixed bin (9);	/* Ast remputation stats */
	dcl     (cbno, ptsi, pts, astx, pno)
				 fixed bin;	/* Walking indices */
	declare reported_aste	 bit (1) aligned;

	declare 1 stats		 aligned,
		2 bad_cme_devadds	 fixed bin,
		2 bad_cme_add_types	 fixed bin,
		2 bad_ptw_devadds	 fixed bin,
		2 cme_ptw_devadd_diffs
				 fixed bin,
		2 bad_cme_ptwps	 fixed bin,
		2 ptws_os_2nd_pass	 fixed bin,
		2 bad_ptw_addrs	 fixed bin,
		2 valid_not_core	 fixed bin;

	dcl     (offs, offdif, bno)	 fixed bin (18);	/* used in validation */
	dcl     (addr, addrel, bit, divide, fixed, null, ptr, rel, size, string, substr, unspec)
				 builtin;

	dcl     page$cam		 entry;		/* used in damaging */
	dcl     fcmep		 ptr;		/* thread heads */
	dcl     lcmep		 ptr;		/* thread tails */
	dcl     astagp		 ptr;		/* AST group (pool) ptr for walk */
	dcl     astesize		 fixed bin;	/* Size of whole ASTE in that pool */
	dcl     astagps		 (0:3) ptr;	/* ast pool ptrs */
	dcl     (astlowers, astuppers, astesizes)
				 (0:3) fixed bin (18);

/* Structures */

	dcl     1 ptwdevadd,			/* Devadd  from PTW */
		2 add		 fixed bin (18) unsigned unal,
						/* Record number (REALLY UNSIGNED!) */
		2 add_type	 like badd_type unal;
						/* add type */

	dcl     1 cmedevadd,			/* Devadd from CME */
		2 cmeadd		 fixed bin (18) unsigned unal,
		2 cmeaddtype	 like badd_type unal;

	dcl     1 fdevadd		 aligned,		/* for general work */
		2 add		 fixed bin (18) unsigned unal,
		2 add_type	 bit (4) unal;
	dcl     1 based_comp_devadd	 like ptwdevadd aligned based;
						/* ditto */

	declare error_table_$unimplemented_version
				 fixed bin (35) ext static;



	dcl     1 ex_aste		 aligned based (astep),
						/* large aste */
		2 aste_proper	 like aste,
		2 aste_ptw	 (0:pts - 1) like ptw aligned;

	dcl     1 astage		 (0:fixed (sst.no_aste (ptsi), 18) - 1) like ex_aste based (astagp) aligned;
						/* array group elements */

/* Set up some pointers. */

	check_tables_info_ptr = Info_pointer;
	Code = 0;
	if check_tables_info.version ^= PC_CHECK_TABLES_INFO_VERSION_1
	then do;
		Code = error_table_$unimplemented_version;
		return;
	     end;

	sstp = check_tables_info.sst_ptr;
	cmap = setwordno (check_tables_info.core_map_ptr, wordno (sst.cmp));
	pvtp = check_tables_info.pvt_ptr;
	pvt_arrayp = addr (pvt.array);

	stats = 0;				/* aggregately */

	astagp = setwordno (sstp, wordno (sst.astap));
	do ptsi = 0 to 3;
	     pts = sst.pts (ptsi);
	     astagps (ptsi) = astagp;
	     astesizes (ptsi) = size (ex_aste);
	     astlowers (ptsi) = wordno (astagp);
	     astagp = addwordno (astagp, size (astage));
	     astuppers (ptsi) = wordno (astagp);
	end;

	call CHECK_SEGMOVE;
	call CHECK_EVICT_PAGE;

/**** First, loop through the core map. In any conflict, the core map
      is right. */

	if check_tables_info.recover_errors
	then sst.usedp, sst.wusedp = "000000"b3;	/* Clear thread heads */

	new_nused = 0;				/* Init new used count */

	do cbno = sst.first_core_block to sst.last_core_block;
	     cmep = addr (cmap -> cma (cbno));		/* Address each block */

	     if cme.fp & "400000"b3
	     then do;
		     if check_tables_info.recover_errors
		     then cme.fp, cme.bp = "777777"b3;	/* Any negative goes deconf */
		end;
	     else if (cme.fp | cme.bp | cme.ptwp) = "000000"b3
	     then go to free_cme;			/* unpaged space */

	     else if cme.ptwp = "000000"b3
	     then ;				/* Was really free to start with. */

	     else do;
		     unspec (cmedevadd) = cme.devadd;
		     if ^reasonable_devaddp (cme.devadd)
		     then do;
			     if check_tables_info.flags.report_errors
			     then do;
				     call check_tables_info.report ("Bad devadd in CME.");
				     call check_tables_info.display_cme (cmep);
				end;
			     stats.bad_cme_devadds = stats.bad_cme_devadds + 1;
			     go to clear_cme;
			end;
		     if cmeaddtype.core
		     then do;
			     if check_tables_info.report_errors
			     then do;
				     call check_tables_info.report ("Core devadd in CME.");
				     call check_tables_info.display_cme (cmep);
				end;
			     stats.bad_cme_add_types = stats.bad_cme_add_types + 1;
			     go to clear_cme;
			end;
		     if (string (cmeaddtype) = "0000"b)
		     then do;
			     if check_tables_info.report_errors
			     then do;
				     call check_tables_info.report ("Null add_type in CME.");
				     call check_tables_info.display_cme (cmep);
				end;
			     go to clear_cme;
			end;
		     ptp = ptr (sstp, cme.ptwp);	/* address ptw */
		     if ^reasonable_ptwpp (ptp, astep)
		     then do;
			     if check_tables_info.report_errors
			     then do;
				     call check_tables_info.report ("Bad ptwp ^o in CME.", cme.ptwp);
				     call check_tables_info.display_cme (cmep);
				end;
			     stats.bad_cme_ptwps = stats.bad_cme_ptwps + 1;
			     go to clear_cme;
			end;
		     else do;			/* ptw is legit */
			     fdevadd.add = cbno * 16; /* set up coreadd */
			     fdevadd.add_type = add_type.core;
			     if ^reasonable_devaddp (mptw.devadd)
			     then do;
				     if check_tables_info.report_errors
				     then do;
					     call check_tables_info.report ("Bad devadd in PTW.");
					     call check_tables_info.display_ptw (ptp);
					end;
				     stats.bad_ptw_devadds = stats.bad_ptw_devadds + 1;
				     if check_tables_info.recover_errors
				     then mptw.devadd = unspec (fdevadd);
						/* bust segment */
				     go to clear_cme;
				end;

			     if check_tables_info.recover_errors
			     then cme.astep = rel (astep);

			     if ptw.os & check_tables_info.recover_errors
			     then do;		/* out of service, may have to free cme */
				     if cme.notify_requested
				     then call pnotify (ptp);
				     if cme.io
				     then ptw.phm1 = "1"b;
						/* was write */
				     else do;	/* was a read -- evict. */
					     cme.fp = "066666"b3;
						/* Cause core to be counted used */
					     ptw.valid = "0"b;
					     call page$cam;
					     mptw.devadd = unspec (cmedevadd);
					     cme.ptwp = "000000"b3;
						/* Will cause freeing */
					end;
				     ptw.os = "0"b; /* This should turn off all legit o/s */
				end;
			     if mptw.devadd ^= unspec (fdevadd) & mptw.devadd ^= unspec (cmedevadd)
			     then do;
				     if check_tables_info.report_errors
				     then do;
					     call check_tables_info
						.report ("PTW devadd inconsistent with CME.");
					     call check_tables_info.display_ptw (ptp);
					end;
				     stats.cme_ptw_devadd_diffs = stats.cme_ptw_devadd_diffs + 1;
				     if check_tables_info.recover_errors
				     then do;
					     aste.damaged = "1"b;
					     ptw.valid = "0"b;
					     call page$cam;
					     mptw.devadd = page_problem_null_addr;
					end;
				end;		/* gonna get the asteps later */
			end;
		end;

	     if cme.ptwp = "000000"b3
	     then do;				/* Free it */
		     if cme.fp ^= "777777"b3
		     then
clear_cme:
			if check_tables_info.recover_errors
			then cme.fp = "066666"b3;
free_cme:
		     if check_tables_info.recover_errors
		     then do;
			     cme.astep, cme.ptwp = "000000"b3;
			     cme.notify_requested = "0"b;
			end;
		end;

	     if check_tables_info.recover_errors
	     then do;

		     if ((cme.fp | cme.ptwp | cme.bp) ^= "000000"b3) & (cme.fp ^= "777777"b3)
		     then do;
			     new_nused = new_nused + 1;
						/* count it */
			     if sst.usedp = "0"b
			     then do;
				     sst.usedp, sst.wusedp = rel (cmep);
				     fcmep, lcmep = cmep;
				end;
			     cme.fp = rel (fcmep);
			     cme.bp = rel (lcmep);
			     lcmep -> cme.fp = rel (cmep);
			     fcmep -> cme.bp = rel (cmep);
						/* continue thread */
			     lcmep = cmep;
			end;
		end;

	     sst.nused = new_nused;
	end;

	/*** Now loop through the AST. There should be no OS ptw's,
	     except those in beginning of readin or end of io window.
	     Any inconsistency still left is simply wrong. Damage segments. */

	do ptsi = 0 to 3;
	     astagp = astagps (ptsi);
	     pts = sst.pts (ptsi);
	     astesize = size (ex_aste);		/* get real size */
	     do astx = 0 to fixed (sst.no_aste (ptsi), 18) - 1;
		astep = addr (astage (astx));		/* address aste */

		curused, nincore, csl = 0;		/* init stats */
		reported_aste = "0"b;
		do pno = 0 to pts - 1;		/* scan page table */
		     ptp = addr (ex_aste.aste_ptw (pno));
		     if ^reasonable_devaddp (mptw.devadd)
		     then do;
			     if check_tables_info.report_errors
			     then do;
				     call check_tables_info
					.report ("Bad PTW devadd for aste at ^o, ptw ^d", rel (astep), pno);
				     if ^reported_aste
				     then do;
					     call check_tables_info.display_aste (astep);
					     reported_aste = "1"b;
					end;
				     call check_tables_info.display_ptw (ptp);
				end;
			     stats.bad_ptw_devadds = stats.bad_ptw_devadds + 1;
			     go to ptwdamage;
			end;

		     unspec (ptwdevadd) = mptw.devadd;	/* get stuff out */

		     if string (ptwdevadd.add_type) = "0000"b
		     then ;			/* true null */
		     else if ptwdevadd.disk
		     then do;
			     if ^substr (ptw.add, 1, 1)
			     then do;		/* not nulled */
				     csl = pno + 1;
				     curused = curused + 1;
						/* count rec used */
				end;
			end;
		     else if ptwdevadd.core
		     then do;
			     cmep = addr (cmap -> cma (divide (fixed (ptw.add, 18), 16, 17, 0)));
			     if reasonable_cmepp (cmep)
			     then do;
				     if cme.ptwp = rel (ptp)
				     then do;	/* all good here */
					     if ptw.os & check_tables_info.recover_errors
					     then do;
						/* This is a complete lie-- not window, as coreadd here.
						   cme pass should have turned these all off. */

						     stats.ptws_os_2nd_pass = stats.ptws_os_2nd_pass + 1;
						     ptw.os = "0"b;
						     go to ptwdamage;
						end;
					     nincore = nincore + 1;
					     csl = pno + 1;
					     curused = curused + 1;
					end;
				     else do;
					     if check_tables_info.report_errors
					     then do;
						     call check_tables_info
							.report ("CME ptwp ^= ptw address.");
						     call check_tables_info.display_ptw (ptp);
						     call check_tables_info.display_cme (cmep);
						end;
					     stats.bad_cme_ptwps = stats.bad_cme_ptwps + 1;
					     go to ptwdamage;
					end;
				end;
			     else do;
				     if check_tables_info.report_errors
				     then do;
					     call check_tables_info.report ("Bad cmep in PTW.");
					     call check_tables_info.display_ptw (ptp);
					end;
				     stats.bad_ptw_addrs = stats.bad_ptw_addrs + 1;
				     go to ptwdamage;
				end;
			end;
		     else do;
			     if check_tables_info.report_errors
			     then do;
				     call check_tables_info.report ("PTW devadd not core, disk, or null.");
				     call check_tables_info.display_ptw (ptp);
				end;

			     stats.bad_ptw_addrs = stats.bad_ptw_addrs + 1;
ptwdamage:
			     if check_tables_info.recover_errors
			     then do;
				     ptw.valid = "0"b;
				     aste.damaged = "1"b;
				     call page$cam;
				     mptw.devadd = page_problem_null_addr;
				     unspec (ptwdevadd) = page_problem_null_addr;
				end;
			end;
		     if check_tables_info.recover_errors
		     then ptw.os = "0"b;
		     if ptwdevadd.core
		     then do;
			     if check_tables_info.recover_errors
			     then ptw.valid = "1"b;	/* Assume NO FAULTED INCORES IN THIS VERSION OF SYS */
			end;
		     else do;			/* next check should never happen */
			     if ptw.valid
			     then do;
				     if check_tables_info.report_errors
				     then do;
					     call check_tables_info.report ("Core PTW not valid.");
					     call check_tables_info.display_ptw (ptp);
					end;
				     stats.valid_not_core = stats.valid_not_core + 1;
				     if check_tables_info.recover_errors
				     then do;
					     ptw.valid = "0"b;
					     call page$cam;
					end;
				end;
			     if check_tables_info.recover_errors
			     then ptw.phm, ptw.phm1 = "0"b;
						/* these bother pc */
			end;
		     if ptw.wired
		     then new_nwired = new_nwired + 1;

		     if check_tables_info.recover_errors
		     then ptw.df_no = "01"b;		/* I hate illegal segfault msgs -- Level 68 only */
		end;				/* page table loop */

/* CAREFUL THESE ALL DECLARED FIXED 9 */

		if check_tables_info.report_errors
		then do;
			if aste.csl ^= bit (csl, 9) | aste.records ^= bit (curused, 9) | aste.np ^= bit (nincore, 9)
			then do;
				call check_tables_info.display_aste (astep);
				call check_tables_info.report ("Bad counter for ASTE.");
				if aste.csl ^= bit (csl, 9)
				then call check_tables_info
					.report (" csl = ^d, should be ^d", bin (aste.csl), csl);
				if aste.records ^= bit (curused, 9)
				then call check_tables_info
					.report (" records = ^d, should be ^d", bin (aste.records), curused);

				if aste.np ^= bit (nincore, 9)
				then call check_tables_info
					.report (" np = ^d, should be ^d", bin (aste.np), nincore);

			     end;
		     end;
		if check_tables_info.recover_errors
		then do;
			aste.csl = bit (csl, 9);
			aste.records = bit (curused, 9);
			aste.np = bit (nincore, 9);
		     end;
	     end;					/* end ast group */
	end;					/* end ast pool */

	if check_tables_info.recover_errors
	then sst.wired = new_nwired;

	sst.wtct = 0;				/* we  stopped 'em all. */
	if check_tables_info.report_error_counts
	then if unspec (stats) ^= ""b
	     then do;
		     call check_tables_info.report ("Statistics:");
		     call stat_print ("Bad cme.devadd", stats.bad_cme_devadds);
		     call stat_print ("Bad cme add_type", stats.bad_cme_add_types);
		     call stat_print ("Bad ptw devadd", stats.bad_ptw_devadds);
		     call stat_print ("ptw/cme devadd mismatch", stats.cme_ptw_devadd_diffs);
		     call stat_print ("Bad cme ptwp", stats.bad_cme_ptwps);
		     call stat_print ("ptw os on second pass", stats.ptws_os_2nd_pass);
		     call stat_print ("Bad ptw address", stats.bad_ptw_addrs);
		     call stat_print ("Valid ptw not in memory", stats.valid_not_core);
		end;

/* Subroutines */

stat_print:
     procedure (what, how_many);

	declare what		 char (*);
	declare how_many		 fixed bin;

	if how_many > 0
	then call check_tables_info.report ("^5x^5d^12t^a", how_many, what);
	return;
     end stat_print;


CHECK_SEGMOVE:
     procedure;

	declare old_astep		 pointer;
	declare old_ptp		 pointer;
	declare new_astep		 pointer;
	declare new_ptp		 pointer;
	declare px		 fixed bin;

	if sst.segmove_lock.pid = ""b
	then return;

	astep = setwordno (sstp, wordno (sst.segmove_astep));
	old_astep = setwordno (sstp, wordno (sst.segmove_old_addr_astep));
	new_astep = setwordno (sstp, wordno (sst.segmove_new_addr_astep));

	if check_tables_info.flags.report_state
	then do;
		call check_tables_info.report ("Segmove in progress, PID: ^w.", sst.segmove_lock.pid);
		if sst.segmove_astep = null ()
		then call check_tables_info.report (" move astep is NULL.");
		else call check_tables_info
			.
			report (" move astep:  ^p, size = ^d.", check_tables_info.display_ptr ((sst.segmove_astep)),
			sst.pts (bin (astep -> aste.ptsi)));

		if sst.segmove_old_addr_astep = null ()
		then call check_tables_info.report (" old addr astep is NULL.");
		else call check_tables_info
			.
			report (" old addr astep:  ^p, size = ^d.",
			check_tables_info.display_ptr ((sst.segmove_old_addr_astep)),
			sst.pts (bin (old_astep -> aste.ptsi)));

		if sst.segmove_new_addr_astep = null ()
		then call check_tables_info.report (" new addr astep is NULL.");
		else call check_tables_info
			.
			report (" new addr astep:  ^p, size = ^d.",
			check_tables_info.display_ptr ((sst.segmove_new_addr_astep)),
			sst.pts (bin (new_astep -> aste.ptsi)));

		if astep ^= null ()
		then call check_tables_info
			.
			report (" Old PV ^a (Vtocx ^d).", check_tables_info.display_pvname (sst.segmove_pvtx),
			sst.segmove_vtocx);

	     end;
/**** to make code clearer, first we do display loop, then real work */
/**** old_astep need not be displayed unless move_astep ^= null indicating
      that some ptws have possibly been changed. */
						/* leave out extensive display, you can poke w/azm */
	if ^check_tables_info.recover_errors
	then return;				/* done */

	if old_astep ^= null ()
	then old_ptp = addwordno (old_astep, sst.astsize);
	if new_astep ^= null ()
	then new_ptp = addwordno (new_astep, sst.astsize);
	if astep ^= null ()
	then ptp = addwordno (astep, sst.astsize);

	begin;
	     declare pt		      (1:sst.pts (bin (astep -> aste.ptsi))) bit (36) aligned based;
	     if sst.segmove_astep ^= null ()
	     then ptp -> pt = old_ptp -> pt;
	     if sst.segmove_old_addr_astep ^= null ()
	     then call NULL_PT (old_ptp, segmove_old_addr_null_addr);
	     if sst.segmove_new_addr_astep ^= null ()
	     then do;
		     call NULL_PT (new_ptp, segmove_new_addr_null_addr);
		     pvtep = addr (pvt_array (bin (new_astep -> aste.pvtx)));
		     pvte.vol_trouble_count = pvte.vol_trouble_count + 1;
		end;

NULL_PT:
     procedure (PTP, NullAddr);

	declare PTP		 pointer;
	declare NullAddr		 bit (22) aligned;
	declare px		 fixed bin;
	declare ptwp		 pointer;

	do px = lbound (PTP -> pt, 1) to hbound (PTP -> pt, 1);
	     unspec (ptwdevadd) = PTP -> pt (px);
	     if string (ptwdevadd.add_type) ^= "0000"b
	     then PTP -> pt (px) = NullAddr;
	end;
     end NULL_PT;
	end;


	aste.pvtx = sst.segmove_pvtx;
	aste.vtocx = sst.segmove_vtocx;

	sst.segmove_astep, sst.segmove_old_addr_astep, sst.segmove_new_addr_astep = null ();
	sst.segmove_vtocx, sst.segmove_pvtx = 0;
	return;

     end CHECK_SEGMOVE;

CHECK_EVICT_PAGE:
     procedure;

/**** If evict_page was moving a page, restore the sequestered modify bit. */

	if sst.evict_ptp = "000000"b3
	then return;

	if check_tables_info.report_state
	then do;
		call check_tables_info.report ("Evict page in progess, ptw at ^o.", sst.evict_ptp);
		call check_tables_info.display_ptw (pointer (sstp, sst.evict_ptp));
	     end;

	ptp = ptr (sstp, sst.evict_ptp);
	if ^reasonable_ptwpp (ptp, astep)
	then do;
		if check_tables_info.report_errors
		then call check_tables_info.report ("Invalid sst.evict_ptwp");
		return;				/* no repair */
	     end;
	else do;
		if ^check_tables_info.recover_errors
		then return;
		if sst.evict_phmbit ^= "000000"b3
		then ptw.phm1 = "1"b;
		sst.evict_phmbit = "000000"b3;
		sst.evict_ptp = "000000"b3;
	     end;
	return;
     end CHECK_EVICT_PAGE;

pnotify:
     proc (p);					/* Notify page control event */

	dcl     p			 ptr;
	dcl     pxss$notify		 entry (bit (36) aligned);

	call pxss$notify ("000000"b3 || rel (p));

     end;


reasonable_cmepp:
     proc (tcmep) returns (bit (1) aligned);		/* test reasonable cmep */

	dcl     tcmep		 ptr;
	dcl     offs		 fixed bin (18);

	offs = fixed (rel (tcmep), 18);
	offdif = offs - fixed (rel (cmap), 18);
	if offdif < 0
	then return ("0"b);
	bno = offdif / size (cme);
	if bno * size (cme) ^= offdif
	then return ("0"b);
	if bno < sst.first_core_block | bno > sst.last_core_block
	then return ("0"b);
	return ("1"b);

     end;

reasonable_ptwpp:
     proc (tptp, rastep) returns (bit (1) aligned);

	dcl     tptp		 ptr;
	dcl     rastep		 ptr;

	offs = fixed (rel (tptp), 18);
	if offs < astlowers (0)
	then return ("0"b);

	do ptsi = 0 to 3;
	     if offs < astuppers (ptsi)
	     then do;
		     offdif = offs - astlowers (ptsi);
		     bno = offdif / astesizes (ptsi);
		     if offdif - bno * astesizes (ptsi) < size (aste)
		     then return ("0"b);
		     rastep = ptr (sstp, bno * astesizes (ptsi) + astlowers (ptsi));
		     return ("1"b);
		end;
	end;
	return ("0"b);

     end;

reasonable_devaddp:
     proc (arg_devadd) returns (bit (1) aligned);		/* tests non-garbage devadd */

	dcl     arg_devadd		 bit (22) unaligned;
	dcl     1 test_devadd,
		2 add		 bit (18) unal,
		2 add_type	 like badd_type unal;

	dcl     LEGAL_ADD_TYPES	 bit (16) unal init ("1010100010000000"b) options (constant) static;

	unspec (test_devadd) = arg_devadd;
	if ^substr (LEGAL_ADD_TYPES, fixed (string (test_devadd.add_type), 4) + 1, 1)
	then return ("0"b);
	if test_devadd.add_type.core
	then if substr (test_devadd.add, 15, 4)
	     then return ("0"b);
	return ("1"b);

     end;


/* format: off */
%page; %include cmp;
%page; %include sst;
%page; %include add_type;
%page; %include aste;
%page; %include null_addresses;
%page; %include "ptw.l68";
/* format: on */

	dcl     1 ptw		 aligned based (ptp) like l68_ptw;
	dcl     1 ptw_flags		 unaligned like l68_ptw_flags based;
	dcl     1 core_ptw		 aligned based (ptp) like l68_core_ptw;
	dcl     1 special_ptw	 aligned based (ptp) like l68_special_ptw;
	dcl     1 real_disk_ptw	 aligned based (ptp) like l68_real_disk_ptw;
	dcl     1 null_disk_ptw	 aligned based (ptp) like l68_null_disk_ptw;

/* Arrays and overlays for various purposes */

	dcl     1 ptwa		 (0:255) based (ptp) aligned like ptw;
						/* page table */

	dcl     ptwa_bits		 (0:255) based (ptp) bit (36) aligned;
						/* page table array as raw bits */

	dcl     1 mptw		 based (ptp) aligned,
						/* page table word while page is not in core */
		2 devadd		 bit (22) unaligned,/* device address where page resides */
		2 pad		 bit (14) unaligned;

	dcl     1 mptwa		 (0:1) based (ptp) aligned,
						/* page table while pages are not in core */
		2 devadd		 bit (22) unaligned,/* device address where page resides */
		2 pad		 bit (14) unaligned;

	dcl     1 atptw		 based (ptp) aligned,
						/* PL/I has problems on overlay-def based */
		2 add		 bit (18) unal,
		2 (core, disk, pd, reserved)
				 bit (1) unal,	/* address types */
		2 pad		 bit (14) unal;

	dcl     1 atptwa		 (0:255) based (ptp) aligned like atptw;

/* format: off */

%include pvt;
%include pvte;
%include syserr_constants;
%include pc_check_tables_info;

     end pc_check_tables_;




		    pl1_operators_.alm              11/11/89  1150.6rew 11/11/89  0803.9     1807884



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Bull Inc., 1987                *
" *                                                         *
" * Copyright, (C) Honeywell Limited, 1984                  *
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1983 *
" *                                                         *
" * Copyright (c) 1972 by Massachusetts Institute of        *
" * Technology and Honeywell Information Systems, Inc.      *
" *                                                         *
" ***********************************************************

" HISTORY COMMENTS:
"  1) change(87-03-05,Huen), approve(87-03-05,MCR7629),
"     audit(87-04-15,RWaters), install(87-05-14,MR12.1-1029):
"     Fix PL/1 error 2138 -
"      Update the comments in "call_ent_var_desc" and "call_ext_in_desc" to
"      indicate the offset of the argument list is in x1.  Fix PL/1 error 2122 -
"      Allow Ceiling function work with negative fixed bin scaled numbers.
"  2) change(87-06-26,Huen), approve(87-06-26,MCR7732),
"     audit(87-07-10,RWaters), install(87-11-30,MR12.2-1004):
"     Fix bug2121
"  3) change(88-06-24,Huen), approve(88-06-24,MCR7916),
"     audit(88-07-11,RWaters), install(88-07-15,MR12.2-1057):
"     Fix high priority fortran error 510 -
"      Fix bug causing fortran inquire statement gives incorrect response after
"      the call to the condition handler.
"  4) change(89-01-16,Huen), approve(89-01-16,MCR8033),
"     audit(89-01-19,RWaters), install(89-02-28,MR12.3-1016):
"     Fix PL/1 error 2192 (phx21224) -
"      Changing indicators to allow maximum negative integer.
"                                                      END HISTORY COMMENTS


" NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
"
" pl1_operators_ MUST be bound with conversion program any_to_any_, put_format_, put_field_,
"	       and ALL of the math routines referenced from transfer vector
"
" NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
"
"	Operator Segment for PL/I Version II
"	Barry Wolman
"	March, 1969
"
"	Modified: 19 October, 1971 by BLW
"	Modified: 27 January, 1972 by BLW
"	Modified:  2 April, 1972 by BLW
"	Modified:  1 July, 1972 by RBSnyder for follow-on
"	Modified: 21 July, 1972 by BLW to fix mod operators
"	Modified: 21 November, 1972 by BLW to add controlled operators
"	Modified: 28 February, 1973 by BLW for odd base register saving
"	Modified: 2 June, 1973 by BLW to use EIS for string operations
"	Modified: 7 April, 1974 by BLW to fix bug 1078
"	Modified: 10 April, 1974 by BLW to fix bug 1083
"	Modified: 15 August, 1974 by BLW to fix bugs 1170, 1171, 1201, and 1202
"	Modified: 1 November, 1974 by RAB to fix bug 1245
"	Modified: 4 November, 1974 by RAB to add ldi to return_words
"	Modified: 6 November, 1974 by SHW for new call/push/return sequences
"	Modified: 14 November, 1974 by RAB to fix bug 1254
"	Modified: 3 January, 1975 by RHS to support quick record i/o
"	Modified:	1 February, 1975 by RAB to fix bug 1318
"	Modified: 5 May, 1975 by RAB for separate static and new trace
"	Modified: 22 May, 1975 by RAB to fix bug 1348
"	Modified:	25 June, 1975 by RAB for new segdefs
"	Modified:	5 November 1975 by RAB for new area package
"	Modified:	29 December 1975 by RAB to fix bug 1449
"	Modified: 27 February, 1976 by GDC for DFAST new entries
"	Modified:  2 March, 1976 by RHS for quick "put list"s, a subset of quick stream i/o
"	Modified:	 1 June, 1976 by RAB to use free_|free_ for alloc_storage
"	Modified:	 6 June, 1976 by RHS for quick "put edit"s
"	Modified:	12 October 1976 by RAB to have signal ops save and restore ALL regs properly
"	Modified:	3 December 1976 by RAB to implement long_profile
"	Modified:	16 December 1976 by RAB to fix 1564 (pointer and offset operators)
"	Modified:	23 December 1976 by RAB for after, before, ltrim, rtrim
"	Modified:	24 March 1977 by RAB for new complex divide algorithm
"	Modified: 10 May 1977 by MBW to use user free area instead of free_
"	Modified 770619 by PG to implement clock, vclock, and stacq
"	Modified: 23 June 1977 by S. Webber to add ftn_open_element, ftn_file_manip_term
"		operators
"	Modified: 7/7/77 D. Levin change ftn_file_manip_term to ftn_get_area_ptr
"	Modified:	7/7/77 by RAB to partially fix bug 1642.  This partially
"		removes formline_ code put in to fix bug 1074.
"	Modified:	16 August 1977 by RAB to complete removal of formline_ code in
"		returns(char(*))
"	Modified:	16 August 1977 by RAB to speed up long_profile operator
"	Modified: 09/20/77 to extend trace interface to ALM and COBOL by P. Krupp.
"	Modified: 19 December 1977 by DSL - implement "static" stack frame for fortran I/O.
"		Refer to comments immediately preceding the label "fortran_read".
"	Modified: 15 Feb 1978 by PCK to implement stop, return_main, set_main_flag and
"		begin_return_main operators
"	Modified: 21 March 1978 by DSL stack_frame.incl.alm changes. stack_frame.fio_ps_ptr
"		changed to stack_frame.support_ptr.
"	Modified: 15 June 1978 by PCK to implement size_check_uns_fx1 and size_check_uns_fx2
"		operators
"	Modified:	28 July 1978 by RAB to fix Fortran bug 169 in which amod failed if 2nd arg
"		was negative
"	Modified 781127 by PG to fix 1800 in which size_check_fx1 and size_check_uns_fx1
"		changed the indicators
"	Modified 790223 by PG to fix 1821 (many, many operators were using signed arithmetic
"		on addresses in the upper when extending the stack!). Also removed
"		a lot of unused labels and names.
"	Modified 790608 by PG to add TCT tables.
"	Modified 790705 by PG to fix 1846 (eaa,neg sequence used by many
"		operators took faults on stacks = 128K.
"	Modified 9 July 1979 by CRD to add new operator fortran_end.
"	Modified 7 August 1979 by CRD to add new operator fort_dmod to fix
"		bug 221 and to bring dmod into inline ALM code.
"	Modified 791205 by PG to fix bug in TCT tables that caused code compiled by 25b
"		to fail if trace was used, due to misplaced even pseudo-op.
"	Modified 6 December 1979 by BSG for ix_rev_chars
"	Modified 12 February 1980 by CRD to add to fort_math_names table.
"	Modified 28 February 1980 by CRD to fix after/before for bit strings. (Bug 1915)
"	Modified 28 February 1980 by CRD to change the way many operators restore pr0.
"		Many operators did eppap operator_table, which doesn't work if trace
"		is being used.  Since the entry sequences store the operator pointer,
"		these instructions were changed to eppap sp|stack_frame.operator_ptr,*.
"	Modified 6 March 1980 by CRD to add three new operators: shorten_stack_protect_ind,
"		save_stack_quick, and restore_stack_quick.
"	Modified 22 October 1980 by CRD to add new operators for new Fortran
"		intrinsic functions.
"	Modified 7 November 1980 by M. N. Davidoff to fix bug 2033 in which longbs_to_bs18
"		always returned zero.
"	Modified 7 November 1980 by M. N. Davidoff to fix bug 2030 in which longbs_to_fx2
"		didn't work for bit strings longer than 71 bits.
"	Modified 8 February 1980 by M. N. Davidoff to fix bug 2041 in which ix_rev_chars
"		failed when length(arg2)=1.
"	Modified 27 February 1981 by PCK to make the alm entry operators
"		preserve the contents of the lisp linkage pointer (pr1)
"		when trace is active
"	Modified 28 July by PCK to fix bug 2068 in which the current stack
"		gets trashed if an asynchronous fault such as an alarm
"		signal or page fault occurs when the stack is being extended
"		by any of the divide operators.
"	Modified 31 August 1981 by C R Davis to fix trans_sign_fl to set the
"		indicators properly, and to add the blank field to
"		ftn_open_element.
"	Modified 27 October 1981 by C R Davis to add ftn_inquire_element.
"	Modified  1 April 1982   by T G Oke to add fortran INTRINSICs for external reference
"	Modified 10 May 1982 by H Hoover to add 'mpy_overflow_check'.
"	Modified 27 August 1982 by T Oke to add 'fort_cleanup' and
"		'fort_return_mac'.
"	Modified September 1982 by C. Hornig to have long_profile work with
"		separate_static.
"	Modified 21 September 1982 by T Oke to add 'fort_storage'.
"	Modified  5 Novemeber 1982 by T Oke to add 'VLA_words_per_seg' to
"		pl1_operators_ pointer referenced, and 'VLA_words_per_seg_'
"		entry.
"	Modified 14 January   1983 by T Oke to ensure indicator storage is
"		is done in stack_frame.return_ptr+1 on all out-calls.
"		References to PR6 changed to 'sp' for consistency.
"		Internal operator calls to pl1_support routines also save
"		and restore the indicators, using a new location
"		'temp_indicators'.
"	Modified 23 November 1983 by H. Hoover to support Hexadecimal
"		Floating Point (HFP).
"	Modified 22 June 1984 by M. Mabey to add the fortran bit-shifting
"		functions to the fort_math_names and hfp_fort_math_names
"		tables.
"	Modified 14 February 1985 by M. Mabey to change the transfers to
"		the double precision arc_sine and arc_cosine routines to
"		reference the new routine 'double_arc_sine_'
"	Modified 10 April 1985 by M. Mabey to change the transfers to the
"		double precision tangent routine to reference the new
"		routine 'double_tangent_'
"         Modified: 15 January, 1987 by SH to correct the comments in routines
"                   "call_ent_var_desc" and "call_ent_in_desc" to indicate
"                   the offset of the argument list is in x1.
"         Modified: 16 January,1987 by SH & RW to allow ceiling function work
"                   with negative fixed bin scaled numbers.
"         Modified: 24 June,1987 by SH to remove the 48 words extension instead
"		of all stack extension upon return from the 'call_signal_'
"		routine.
"         Modified: 24 June, 1988 by SH to adjust the next_stackframe_ptr and
"		perm_extension_ptr in the "ft_fast_call" routine.
"	Modified: 15 January, 1989 by RG & SH to fix size_check_fx1, 
"		size_check_fx2, size_check_uns_fx1, size_check_uns_fx2.
"		Errors previously occurred on Maximum negative of fx1 and
"		fx2 in magnitude comparison.
	name	pl1_operators_

	include	stack_header

"	We are attempting to set a standard for the storage and return of
"	indicators for a program.  On call-out the operators will store the
"	indicator register in the low 18-bits of stack_frame.return_ptr+1,
"	the upper 18-bits are the return word offset, and are stored from
"	X0 typically.  On return the operators will restore the indicators
"	from this low 18-bit portion.

	include	stack_frame
	include	eis_bits
	include	iocbx
	include	plio2_fsb
	include	plio2_ps
	include	fortran_ps
	include	fortran_open_data
	include	fortran_inquire_data
"
	segdef	alloc
	segdef	alm_call
	segdef	alm_entry
	segdef	alm_operators_begin
	segdef	alm_operators_end
	segdef	alm_push
	segdef	alm_return
	segdef	alm_return_no_pop
	segdef	alm_trace_operators_begin
	segdef	alm_trace_operators_end
	segdef	begin_pl1_operators
	segdef	call_signal_
	segdef	end_pl1_operators
	segdef	entry_operators
	segdef	entry_operators_end
	segdef	fort_math_names
	segdef	hfp_fort_math_names
	segdef	forward_call
	segdef	get_our_lp
	segdef	hfp_operator_table
	segdef	operator_table
	segdef	plio4
	segdef	put_return
	segdef	tct_byte_0
	segdef	tct_byte_1
	segdef	tct_byte_2
	segdef	tct_byte_3
	segdef	tct_octal_040
	segdef	tct_octal_060
	segdef	trace_alm_entry
	segdef	trace_entry_operators
	segdef	trace_entry_operators_end
	segdef	trace_operator_table
	segdef	trace_hfp_operator_table
	segdef	var_call
	segdef	VLA_words_per_seg_
"
"	Definitions of variables used by operators.  Since all
"	of the operators execute using the stack frame of the
"	pl/1 program for their temporary storage, locations 8-15 & 32-63
"	of the pl/1 stack frame are reserved for operator use.
"
"	sp|6 has been reserved for probe.
"
	equ	display_ptr,32
	equ	descriptor_ptr,34
	equ	linkage_ptr,36
	equ	text_base_ptr,38
	equ	tbp,38
	equ	temp_pt,40		string register
	equ	ps_ptr,42
	equ	page,44
	equ	temp_indicators,45
	equ	double_temp,46
	equ	cpu,46
	equ	remainder,46
	equ	temp_size,48
	equ	extend_size,49
	equ	bit_lg1,50		string register
	equ	char_lg1,51		string register
	equ	t3,51
	equ	bit_or_char,52		string register
	equ	t1,52
	equ	bit_op,53
	equ	t5,53
	equ	cat_lg1,54
	equ	t2,54
	equ	qmask,55
	equ	arg_list,56
	equ	save_regs,56
	equ	save_x01,56
	equ	label_var,56
	equ	complex,56		complex AQ
	equ	temp2,58
	equ	lv,60
	equ	num,60
	equ	lg2,61
	equ	temp,62
	equ	t4,63
	equ	count,63
"
"	following locations used in stack extension by divide subroutine
"
	equ	divide_extension_size,32
	equ	qhat,0
	equ	rhat,1
	equ	carry,2
	equ	carrya,3
	equ	shift,4
	equ	norm_shift,5
	equ	div_temp,6
	equ	dividend,8
	equ	divisor,14
	equ	quotient,18
	equ	divide_lp,24
"
	bool	rpd_bits,001400	bits for RPD instruction (A,B)
"
	bool	blank,40
"
"	Definitions related to Hexadecimal Floating Point (HFP) mode:
"
	bool	HFP_mask,000010	mask for bit in IR that sets HFP mode
	bool	M2.0H,003700	yields HFP -2.0 under 'du' modification
	bool	M0.5H,001400	yields HFP -0.5 under 'du' modification
	bool	P0.0H,400000	yields HFP +0.0 under 'du' modification
	bool	P0.5H,000400	yields HFP +0.5 under 'du' modification
	bool	P1.0H,002040	yields HFP +1.0 under 'du' modification
	bool	P2.0H,002100	yields HFP +2.0 under 'du' modification
"				
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	MACROS USED IN THIS PROGRAM
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

"	Macro to load PR4 with ptr to linkage section of pl1_operators_.
"	PR7 is set to the base of the stack.  The AQ is effectively clobbered.
"	A subroutine of the same name also exists, when speed is not critical.
"
	macro	get_our_lp
	epbpsb	sp|0		make sure sb is set up
	epaq	*		get ptr to ourselves
	lprplp	sb|stack_header.lot_ptr,*au get packed ptr to linkage from lot
	&end
"
"	Macro to load AU with the complement of the stack frame offset.
"
	macro	get_stack_offset
	eaa	sp|0		get offset of stack frame in au
	era	mask_bit_one	form 2's complement of whole a-reg
	adla	1,dl		w/o overflow
	&end
"
"	The following macro (transfer_vector) is used to duplicate the transfer vector
"	and the constants and code which preceed it for the trace programs. All labels
"	in the macro should be preceeded by "&1" in order to eliminate duplicate labels.
"
"	Any operators which are to be different for the trace vector should have
"	the target of the transfer preceeded by "&1".
"

	macro	transfer_vector
"
" Due to the presence of double-word constants (at bit_mask and mask_bit)
" these instructions must presently begin on an even-word boundary.
" Note that if an odd number  of words is added to the front of the
" operator_table region, then the following even pseudo-op must be
" changed to an odd pseudo-op. If you forget, an assembly error will
" result (due to clever divide-by-zero, below).
"
	even
"
" The following section, from location 0 to label operator_table, is referenced
" directly from PL/1 programs by means of offsets of the form ap|-n (ap pointing
" at pl1_operators_$operator_table).  For this reason, the order of the
" following instructions must not be changed.  Any new coding must be placed at
" the FRONT of the segment.
"
" This table translates a bit number between 0 and 35 to a char number
" between 0 and 3.
"
	even
&1&2bitno_to_charno_table:
	dup	9
	dec	0
	dupend
	dup	9
	dec	1
	dupend
	dup	9
	dec	2
	dupend
	dup	9
	dec	3
	dupend
"
"	The following tables are for use with the TCT instruction.
"	Any single, given, character can be searched for using these
"	tables.
"
	dup	115
	dec	-1
	dupend
"
&1&2tct_octal_060:
	dup	4
	dec	-1
	dupend
"
&1&2tct_octal_040:
	dup	8
	dec	-1
	dupend
&1&2tct_byte_0:
	vfd	9/0,9/-1,9/-1,9/-1
	dup	127
	dec	-1
	dupend
"
&1&2tct_byte_1:
	vfd	9/-1,9/0,9/-1,9/-1
	dup	127
	dec	-1
	dupend
"
&1&2tct_byte_2:
	vfd	9/-1,9/-1,9/0,9/-1
	dup	127
	dec	-1
	dupend
"
&1&2tct_byte_3:
	vfd	9/-1,9/-1,9/-1,9/0
	dup	127
	dec	-1
	dupend
"
"	The number of words per segment of a FORTRAN Very Large Array.
"
&1&2VLA_words_per_seg_:
	vfd	36/256*1024
"
"	table of csl's for use by bool builtin function
"
&1&2csl_vector:
	csl	(pr,rl),(pr,rl),bool(0)
	csl	(pr,rl),(pr,rl),bool(1)
	csl	(pr,rl),(pr,rl),bool(2)
	csl	(pr,rl),(pr,rl),bool(3)
	csl	(pr,rl),(pr,rl),bool(4)
	csl	(pr,rl),(pr,rl),bool(5)
	csl	(pr,rl),(pr,rl),bool(6)
	csl	(pr,rl),(pr,rl),bool(7)
	csl	(pr,rl),(pr,rl),bool(10)
	csl	(pr,rl),(pr,rl),bool(11)
	csl	(pr,rl),(pr,rl),bool(12)
	csl	(pr,rl),(pr,rl),bool(13)
	csl	(pr,rl),(pr,rl),bool(14)
	csl	(pr,rl),(pr,rl),bool(15)
	csl	(pr,rl),(pr,rl),bool(16)
	csl	(pr,rl),(pr,rl),bool(17)
"
"	shift table for character offset
"
&1&2co_to_bo:	dec	0,9b17,18b17,27b17
"
"	shift table for half word offset
"
&1&2ho_to_bo:	dec	0,18b17
"
"	store table from a, 9 bit bytes, character offset
"				OFFSET	SIZE
"
&1&2store_a9_co:
	stba	bp|0,40		0	1
	stba	bp|0,20		1
	stba	bp|0,10		2
	stba	bp|0,04		3
	stba	bp|0,60		0	2
	stba	bp|0,30		1
	stba	bp|0,14		2
	stba	bp|0,04		3
	stba	bp|0,70		0	3
	stba	bp|0,34		1
	stba	bp|0,14		2
	stba	bp|0,04		3
	sta	bp|0		0	4
	stba	bp|0,34		1
	stba	bp|0,14		2
	stba	bp|0,04		3
	sta	bp|0		0	5
	stba	bp|0,34		1
	stba	bp|0,14		2
	stba	bp|0,04		3
"
"	store table from q, 9 bit bytes, character offset
"				OFFSET	SIZE
"
&1&2store_q9_co:
	nop	0,dl		0	2
	nop	0,dl		1
	nop	0,dl		2
	stbq	bp|1,40		3
	nop	0,dl		0	3
	nop	0,dl		1
	stbq	bp|1,40		2
	stbq	bp|1,60		3
	nop	0,dl		0	4
	stbq	bp|1,40		1
	stbq	bp|1,60		2
	stbq	bp|1,70		3
	stbq	bp|1,40		0	5
	stbq	bp|1,60		1
	stbq	bp|1,70		2
	stq	bp|1		3
"
"	store table from a, 9 bit bytes, half word offset
"				OFFSET	SIZE
"
&1&2store_a9_ho:
	stba	bp|0,40		0	1
	stba	bp|0,10		1
	stba	bp|0,60		0	2
	stba	bp|0,14		1
	stba	bp|0,70		0	3
	stba	bp|0,14		1
	sta	bp|0		0	4
	stba	bp|0,14		1
	sta	bp|0		0	5
	stba	bp|0,14		1
	sta	bp|0		0	6
	stba	bp|0,14		1
"
"	store table from q, 9 bit bytes, half word offset
"				OFFSET	SIZE
"
&1&2store_q9_ho:
	nop	0,dl		0	2
	nop	0,dl		1
	nop	0,dl		0	3
	stbq	bp|1,40		1
	nop	0,dl		0	4
	stbq	bp|1,60		1
	stbq	bp|1,40		0	5
	stbq	bp|1,70		1
	stbq	bp|1,60		0	6
	stq	bp|1		1
"
"	store table from a, 6 bit bytes, half word offset
"				OFFSET	SIZE
"
&1&2store_a6_ho:
	stca	bp|0,40		0	1
	stca	bp|0,04		1
	stca	bp|0,60		0	2
	stca	bp|0,06		1
	stca	bp|0,70		0	3
	stca	bp|0,07		1
	stca	bp|0,74		0	4
	stca	bp|0,07		1
	stca	bp|0,76		0	5
	stca	bp|0,07		1
	sta	bp|0		0	6
	stca	bp|0,07		1
	sta	bp|0		0	7
	stca	bp|0,07		1
	sta	bp|0		0	8
	stca	bp|0,07		1
	sta	bp|0		0	9
	stca	bp|0,07		1
"
"	store table from q, 6 bit bytes, half word offset
"				OFFSET	SIZE
"
&1&2store_q6_ho:
	nop	0,dl		0	2
	nop	0,dl		1
	nop	0,dl		0	3
	nop	0,dl		1
	nop	0,dl		0	4
	stcq	bp|1,40		1
	nop	0,dl		0	5
	stcq	bp|1,60		1
	nop	0,dl		0	6
	stcq	bp|1,70		1
	stcq	bp|1,40		0	7
	stcq	bp|1,74		1
	stcq	bp|1,60		0	8
	stcq	bp|1,76		1
	stcq	bp|1,70		0	9
	stq	bp|1		1
"
" THE FOLLOWING SECTION IS DIRECTLY REFERENCED FROM PL/1 PROGRAMS BY MEANS OF
" ap|offset.  FOR THIS REASON, THE ORDER OF THE FOLLOWING INSTRUCTIONS MUST
" NOT BE CHANGED.
"
&1&2operator_table:
&1&2bit_mask:
	vfd	0/-1,72/0
	vfd	1/-1,71/0
	vfd	2/-1,70/0
	vfd	3/-1,69/0
	vfd	4/-1,68/0
	vfd	5/-1,67/0
	vfd	6/-1,66/0
	vfd	7/-1,65/0
	vfd	8/-1,64/0
	vfd	9/-1,63/0
	vfd	10/-1,62/0
	vfd	11/-1,61/0
	vfd	12/-1,60/0
	vfd	13/-1,59/0
	vfd	14/-1,58/0
	vfd	15/-1,57/0
	vfd	16/-1,56/0
	vfd	17/-1,55/0
	vfd	18/-1,54/0
	vfd	19/-1,53/0
	vfd	20/-1,52/0
	vfd	21/-1,51/0
	vfd	22/-1,50/0
	vfd	23/-1,49/0
	vfd	24/-1,48/0
	vfd	25/-1,47/0
	vfd	26/-1,46/0
	vfd	27/-1,45/0
	vfd	28/-1,44/0
	vfd	29/-1,43/0
	vfd	30/-1,42/0
	vfd	31/-1,41/0
	vfd	32/-1,40/0
	vfd	33/-1,39/0
	vfd	34/-1,38/0
	vfd	35/-1,37/0
&1&2ones:	vfd	36/-1,36/0
	vfd	36/-1,1/-1,35/0
	vfd	36/-1,2/-1,34/0
	vfd	36/-1,3/-1,33/0
	vfd	36/-1,4/-1,32/0
	vfd	36/-1,5/-1,31/0
	vfd	36/-1,6/-1,30/0
	vfd	36/-1,7/-1,29/0
	vfd	36/-1,8/-1,28/0
	vfd	36/-1,9/-1,27/0
	vfd	36/-1,10/-1,26/0
	vfd	36/-1,11/-1,25/0
	vfd	36/-1,12/-1,24/0
	vfd	36/-1,13/-1,23/0
	vfd	36/-1,14/-1,22/0
	vfd	36/-1,15/-1,21/0
	vfd	36/-1,16/-1,20/0
	vfd	36/-1,17/-1,19/0
	vfd	36/-1,18/-1,18/0
	vfd	36/-1,19/-1,17/0
	vfd	36/-1,20/-1,16/0
	vfd	36/-1,21/-1,15/0
	vfd	36/-1,22/-1,14/0
	vfd	36/-1,23/-1,13/0
	vfd	36/-1,24/-1,12/0
	vfd	36/-1,25/-1,11/0
	vfd	36/-1,26/-1,10/0
	vfd	36/-1,27/-1,9/0
	vfd	36/-1,28/-1,8/0
	vfd	36/-1,29/-1,7/0
	vfd	36/-1,30/-1,6/0
	vfd	36/-1,31/-1,5/0
	vfd	36/-1,32/-1,4/0
	vfd	36/-1,33/-1,3/0
	vfd	36/-1,34/-1,2/0
	vfd	36/-1,35/-1,1/0
"
&1&2mask_bit:
	vfd	0/0,36/-1,36/-1
	vfd	1/0,35/-1,36/-1
	vfd	2/0,34/-1,36/-1
	vfd	3/0,33/-1,36/-1
	vfd	4/0,32/-1,36/-1
	vfd	5/0,31/-1,36/-1
	vfd	6/0,30/-1,36/-1
	vfd	7/0,29/-1,36/-1
	vfd	8/0,28/-1,36/-1
	vfd	9/0,27/-1,36/-1
	vfd	10/0,26/-1,36/-1
	vfd	11/0,25/-1,36/-1
	vfd	12/0,24/-1,36/-1
	vfd	13/0,23/-1,36/-1
	vfd	14/0,22/-1,36/-1
	vfd	15/0,21/-1,36/-1
	vfd	16/0,20/-1,36/-1
	vfd	17/0,19/-1,36/-1
	vfd	18/0,18/-1,36/-1
	vfd	19/0,17/-1,36/-1
	vfd	20/0,16/-1,36/-1
	vfd	21/0,15/-1,36/-1
	vfd	22/0,14/-1,36/-1
	vfd	23/0,13/-1,36/-1
	vfd	24/0,12/-1,36/-1
	vfd	25/0,11/-1,36/-1
	vfd	26/0,10/-1,36/-1
	vfd	27/0,9/-1,36/-1
	vfd	28/0,8/-1,36/-1
	vfd	29/0,7/-1,36/-1
	vfd	30/0,6/-1,36/-1
	vfd	31/0,5/-1,36/-1
	vfd	32/0,4/-1,36/-1
	vfd	33/0,3/-1,36/-1
	vfd	34/0,2/-1,36/-1
	vfd	35/0,1/-1,36/-1
	vfd	36/0,36/-1
&1&2max_single_value:
	vfd	37/0,35/-1
	vfd	38/0,34/-1
	vfd	39/0,33/-1
	vfd	40/0,32/-1
	vfd	41/0,31/-1
	vfd	42/0,30/-1
	vfd	43/0,29/-1
	vfd	44/0,28/-1
	vfd	45/0,27/-1
	vfd	46/0,26/-1
	vfd	47/0,25/-1
	vfd	48/0,24/-1
	vfd	49/0,23/-1
	vfd	50/0,22/-1
	vfd	51/0,21/-1
	vfd	52/0,20/-1
	vfd	53/0,19/-1
	vfd	54/0,18/-1
	vfd	55/0,17/-1
	vfd	56/0,16/-1
	vfd	57/0,15/-1
	vfd	58/0,14/-1
	vfd	59/0,13/-1
	vfd	60/0,12/-1
	vfd	61/0,11/-1
	vfd	62/0,10/-1
	vfd	63/0,9/-1
	vfd	64/0,8/-1
	vfd	65/0,7/-1
	vfd	66/0,6/-1
	vfd	67/0,5/-1
	vfd	68/0,4/-1
	vfd	69/0,3/-1
	vfd	70/0,2/-1
	vfd	71/0,1/-1
"
&1&2blanks:	oct	040040040040,040040040040
	oct	000040040040,040040040040
	oct	000000040040,040040040040
	oct	000000000040,040040040040
	oct	000000000000,040040040040
	oct	000000000000,000040040040
	oct	000000000000,000000040040
	oct	000000000000,000000000040
"
&1&2ptr_mask:	oct	077777000077,777777077077 mask for use in ptr comparisions
"
"	operator to convert single fixed to double fixed
"
	even
&1&2fx1_to_fx2:
	llr	36
	lrs	36
"
"	operators to convert fixed to float
"
	odd
&1&2fx1_to_fl2:
	xed	&1&2fx1_to_fx2
"
	even
&1&2fx2_to_fl2:
	ife	&2,hfp_
	lde	=18b25,du		EAQ = unnormalized 2*float(number)
	fad	P0.0H,du		EAQ = 2*float(number)
	fmp	P0.5H,du		EAQ = float(number)
	tra	sp|tbp,*x0	return
	ifend

	ine	&2,hfp_
	lde	=71b25,du
	fad	=0.,du
	tra	sp|tbp,*0
	ifend
"
"	operator to reset next stack pointer
"
	even
&1&2reset_stack:
	ldx0	sp|5
	stx0	sp|stack_frame.next_sp+1
"
"	operators to convert indicators into relations
"
&1&2r_l_a:	tmi	true
	lda	0,dl
	tra	sp|tbp,*0
"
&1&2r_g_s:	tze	2,ic
	trc	true
	lda	0,dl
	tra	sp|tbp,*0
"
&1&2r_g_a:	tze	2,ic
	tpl	true
	lda	0,dl
	tra	sp|tbp,*0
"
&1&2r_l_s:	tnc	true
	lda	0,dl
	tra	sp|tbp,*0
"
&1&2r_e_as:	tze	true
	lda	0,dl
	tra	sp|tbp,*0
"
&1&2r_ne_as:	tnz	true
	lda	0,dl
	tra	sp|tbp,*0
"
&1&2r_le_a:	tmi	true
	tze	true
	lda	0,dl
	tra	sp|tbp,*0
"
&1&2r_ge_s:	trc	true
	lda	0,dl
	tra	sp|tbp,*0
"
&1&2r_ge_a:	tpl	true
	lda	0,dl
	tra	sp|tbp,*0
"
&1&2r_le_s:	tnc	true
	tze	true
	lda	0,dl
	tra	sp|tbp,*0
"
&1&2true:	lda	=o400000,du
	tra	sp|tbp,*0
"
"	operator to set stack ptr to that of block N static
"	levels above the current block.  Entered with N in q.
"	(should not be called with N = 0, but will work anyway.)
"
&1&2set_stack:
	tsx1	display_chase	get ptr to proper frame
	eppsp	bp|0		into sp
	tra	set_stack_extend	do three more instructions (added later
"				and since compiled code knows offsets in this
"				area, couldn't add the code inline)
"
"	tables to convert to bit offset ready to be ORed into pointer
"
&1&2mod2_tab:	dec	0,18b26
"
&1&2mod4_tab:	dec	0,9b26,18b26,27b26
"
"	transfer vector for operators not referenced directly
"	by the pl/1 program.  new operators may be added at the
"	end of the list only.
"
&1&2op_vector:
	tra	alloc_char_temp	0
	tra	alloc_bit_temp	1
	tra	alloc_temp	2
	tra	realloc_char_temp	3
	tra	realloc_bit_temp	4
	tra	save_string	5	obsolete
	tra	pk_to_unpk	6
	tra	unpk_to_pk	7
	tra	move_chars	8	obsolete
	tra	move_chars_aligned	9	obsolete
	tra	move_bits		10	obsolete
	tra	move_bits_aligned	11	obsolete
	tra	chars_move	12	obsolete
	tra	chars_move_aligned	13	obsolete
	tra	bits_move		14	obsolete
	tra	bits_move_aligned	15	obsolete
	tra	move_not_bits	16	obsolete
	tra	move_not_bits_aligned 17	obsolete
	tra	ext_and_1		18
	tra	ext_and_2		19
	tra	comp_bits		20
	tra	cpbs3		21	obsolete
	tra	cpbs3_aligned	22	obsolete
	tra	cpbs4		23	obsolete
	tra	cpcs_ext1		24
	tra	cpcs_ext2		25
	tra	cpbs_ext1		26
	tra	cpbs_ext2		27
	tra	store_string	28
	tra	cat_realloc_chars	29
	tra	cat_realloc_bits	30
	tra	cp_chars		31	obsolete
	tra	cp_chars_aligned	32	obsolete
	tra	cp_bits		33	obsolete
	tra	cp_bits_aligned	34	obsolete
	tra	enter_begin_block	35
	tra	leave_begin_block	36
	tra	call_ent_var_desc	37
	tra	call_ent_var	38
	tra	call_ext_in_desc	39
	tra	call_ext_in	40
	tra	call_ext_out_desc	41
	tra	call_ext_out	42
	tra	call_int_this_desc	43
	tra	call_int_this	44
	tra	call_int_other_desc	45
	tra	call_int_other	46
	tra	begin_return_mac	47
	tra	return_mac	48
	tra	cat_move_chars	49	obsolete
	tra	cat_move_chars_aligned 50	obsolete
	tra	cat_move_bits	51	obsolete
	tra	cat_move_bits_aligned 52	obsolete
	tra	cat_chars		53	obsolete
	tra	cat_chars_aligned	54	obsolete
	tra	cat_bits		55	obsolete
	tra	cat_bits_aligned	56	obsolete
	tra	set_chars		57	obsolete
	tra	set_chars_aligned	58	obsolete
	tra	set_bits		59	obsolete
	tra	set_bits_aligned	60	obsolete
	tra	and_bits		61	obsolete
	tra	and_bits_aligned	62	obsolete
	tra	or_bits		63	obsolete
	tra	or_bits_aligned	64	obsolete
	tra	move_label_var	65
	tra	make_label_var	66
	tra	&2fl2_to_fx1	67
	tra	&2fl2_to_fx2	68
	tra	longbs_to_fx2	69
	tra	tra_ext_1		70
	tra	tra_ext_2		71
	tra	alloc_auto_adj	72
	tra	longbs_to_bs18	73
	tra	stac_mac		74
	tra	sign_mac		75
	tra	bound_ck_signal	76
	tra	trans_sign_fx1	77
	tra	trans_sign_fl	78
	tra	copy_words	79	obsolete
	tra	mpfx2		80
	tra	mpfx3		81
	tra	copy_const	82	obsolete
	tra	copy_const_vt	83	obsolete
	tra	sr_check		84	obsolete
	tra	chars_move_vt	85	obsolete
	tra	chars_move_vta	86	obsolete
	tra	bits_move_vt	87	obsolete
	tra	bits_move_vta	88	obsolete
	tra	&2mdfl1		89
	tra	&2mdfl2		90
	tra	mdfx1		91
	tra	mdfx2		92
	tra	mdfx3		93
	tra	mdfx4		94
	tra	copy_double	95	obsolete
	tra	string_store	96	obsolete
	tra	get_chars		97	obsolete
	tra	get_bits		98	obsolete
	tra	pad_chars		99
	tra	pad_bits		100
	tra	signal_op		101
	tra	enable_op		102
	tra	index_chars	103	obsolete
	tra	index_chars_aligned	104	obsolete
	tra	index_bits	105	obsolete
	tra	index_bits_aligned	106	obsolete
	tra	exor_bits		107	obsolete
	tra	exor_bits_aligned	108	obsolete
	tra	set_bits_co	109	obsolete
	tra	set_bits_ho	110	obsolete
	tra	set_chars_co	111	obsolete
	tra	set_chars_ho	112	obsolete
	tra	string_store_co	113	obsolete
	tra	string_store_ho	114	obsolete
	tra	get_chars_co	115	obsolete
	tra	get_chars_ho	116	obsolete
	tra	get_bits_co	117	obsolete
	tra	get_bits_ho	118	obsolete
	tra	and_bits_co	119	obsolete
	tra	and_bits_ho	120	obsolete
	tra	or_bits_co	121	obsolete
	tra	or_bits_ho	122	obsolete
	tra	exor_bits_co	123	obsolete
	tra	exor_bits_ho	124	obsolete
	tra	cat_move_bits_co	125	obsolete
	tra	cat_move_bits_ho	126	obsolete
	tra	move_not_bits_co	127	obsolete
	tra	move_not_bits_ho	128	obsolete
	tra	move_bits_co	129	obsolete
	tra	move_bits_ho	130	obsolete
	tra	move_chars_co	131	obsolete
	tra	move_chars_ho	132	obsolete
	tra	cat_move_chars_co	133	obsolete
	tra	cat_move_chars_ho	134	obsolete
	tra	cat_chars_co	135	obsolete
	tra	cat_chars_ho	136	obsolete
	tra	cat_bits_co	137	obsolete
	tra	cat_bits_ho	138	obsolete
	tra	io_signal		139
	tra	index_cs_1	140	obsolete
	tra	index_cs_1_aligned	141	obsolete
	tra	&2fort_mdfl1	142
	tra	rfb1_to_cflb1	143
	tra	&2rfb2_to_cflb1	144
	tra	mpcfl1_1		145
	tra	mpcfl1_2		146
	tra	dvcfl1_1		147
	tra	dvcfl1_2		148
	tra	chars_move_vt_co	149	obsolete
	tra	chars_move_vt_ho	150	obsolete
	tra	chars_move_co	151	obsolete
	tra	chars_move_ho	152	obsolete
	tra	bits_move_vt_co	153	obsolete
	tra	bits_move_vt_ho	154	obsolete
	tra	bits_move_co	155	obsolete
	tra	bits_move_ho	156	obsolete
	tra	cp_chars_co	157	obsolete
	tra	cp_chars_ho	158	obsolete
	tra	cp_bits_co	159	obsolete
	tra	cp_bits_ho	160	obsolete
	tra	cpbs3_co		161	obsolete
	tra	cpbs3_ho		162	obsolete
	tra	shorten_stack	163
	tra	zero_bits		164	obsolete
	tra	zero_bits_aligned	165	obsolete
	tra	zero_bits_co	166	obsolete
	tra	zero_bits_ho	167	obsolete
	tra	blank_chars	168	obsolete
	tra	blank_chars_aligned	169	obsolete
	tra	blank_chars_co	170	obsolete
	tra	blank_chars_ho	171	obsolete
	tra	index_chars_co	172	obsolete
	tra	index_chars_ho	173	obsolete
	tra	index_bits_co	174	obsolete
	tra	index_bits_ho	175	obsolete
	tra	index_cs_1_co	176	obsolete
	tra	index_cs_1_ho	177	obsolete
	tra	index_bs_1	178	obsolete
	tra	index_bs_1_aligned	179	obsolete
	tra	index_bs_1_co	180	obsolete
	tra	index_bs_1_ho	181	obsolete
	arg	shift_bo		182	obsolete
	tra	return_words	183
	tra	return_bits	184	obsolete
	tra	return_bits_co	185	obsolete
	tra	return_bits_ho	186	obsolete
	tra	return_bits_al	187	obsolete
&1&2entry_operators:
	tra	&1ext_entry		188
	tra	&1ext_entry_desc	189
	tra	int_entry		190
	tra	int_entry_desc	191
	tra	val_entry		192
	tra	val_entry_desc	193
	tra	get_chars_aligned	194	obsolete
	tra	get_bits_aligned	195	obsolete
	tra	fetch_chars	196
	tra	fetch_bits	197
	tra	get_terminate	198
	tra	<put_format_>|[put_terminate]	199
	tra	put_data_aligned	200	obsolete
	tra	get_list_aligned	201	obsolete
	tra	get_edit_aligned	202	obsolete
	tra	put_list_aligned	203	obsolete
	tra	put_edit_aligned	204	obsolete
	tra	<put_format_>|[stream_prep]	205
	tra	<record_io_>|[record_io]		206
	tra	open_file		207
	tra	close_file	208
	tra	put_data		209	obsolete
	tra	put_data_co	210	obsolete
	tra	put_data_ho	211	obsolete
	tra	get_list		212	obsolete
	tra	get_list_co	213	obsolete
	tra	get_list_ho	214	obsolete
	tra	get_edit		215	obsolete
	tra	get_edit_co	216	obsolete
	tra	get_edit_ho	217	obsolete
	tra	put_list		218	obsolete
	tra	put_list_co	219	obsolete
	tra	put_list_ho	220	obsolete
	tra	put_edit		221	obsolete
	tra	put_edit_co	222	obsolete
	tra	put_edit_ho	223	obsolete
	tra	suffix_cs		224	obsolete
	tra	suffix_bs		225	obsolete
	tra	&2fl2_to_fxscaled	226
	tra	trunc_fx1		227
	tra	trunc_fx2		228
	tra	ceil_fx1		229
	tra	ceil_fx2		230
	tra	&2ceil_fl		231
	tra	floor_fx1		232
	tra	floor_fx2		233
	tra	&2floor_fl	234
	tra	&2trunc_fl	235
	tra	round_fx1		236
	tra	round_fx2		237
	tra	repeat		238
	tra	make_bit_table	239	obsolete
	tra	make_bit_table_al	240	obsolete
	tra	make_bit_table_co	241	obsolete
	tra	make_bit_table_ho	242	obsolete
	tra	verify		243	obsolete
	tra	verify_al		244	obsolete
	tra	verify_co		245	obsolete
	tra	verify_ho		246	obsolete
	tra	const_verify	247	obsolete
	tra	const_verify_al	248	obsolete
	tra	const_verify_co	249	obsolete
	tra	const_verify_ho	250	obsolete
	tra	reverse_cs	251
	tra	reverse_bs	252
	tra	form_bit_table	253	obsolete
	tra	form_bit_table_co	254	obsolete
	tra	form_bit_table_ho	255	obsolete
	tra	form_bit_table_al	256	obsolete
	tra	chars_move_ck	257	obsolete
	tra	chars_move_ck_co	258	obsolete
	tra	chars_move_ck_ho	259	obsolete
	tra	chars_move_ck_al	260	obsolete
	tra	bits_move_ck	261	obsolete
	tra	bits_move_ck_co	262	obsolete
	tra	bits_move_ck_ho	263	obsolete
	tra	bits_move_ck_al	264	obsolete
	tra	size_check_fx1	265
	tra	size_check_fx2	266
	tra	signal_stringsize	267
	tra	suffix_cs_ck	268	obsolete
	tra	suffix_bs_ck	269	obsolete
	tra	pointer_hard	270
	tra	alm_call		271	special for alm
	tra	alm_push		272	special for alm
	tra	alm_return	273	special for alm
	tra	alm_return_no_pop	274	special for alm
	tra	&1alm_entry		275	special for alm
	tra	packed_to_bp	276	obsolete
	tra	return_chars	277	obsolete
	tra	return_chars_co	278	obsolete
	tra	return_chars_ho	279	obsolete
	tra	return_chars_aligned 280	obsolete
	tra	rpd_odd_lp_bp	281	obsolete
	tra	rpd_odd_bp_lp	282	obsolete
	tra	rpd_even_lp_bp	283	obsolete
	tra	rpd_even_bp_lp	284	obsolete
	tra	offset_easy	285
	tra	offset_easy_pk	286
	tra	offset_hard	287
	tra	offset_hard_pk	288
	tra	pointer_hard_pk	289
	tra	pointer_easy	290
	tra	pointer_easy_pk	291
	tra	round_fl		292
	tra	enable_file	293
	tra	revert_file	294
	tra	alloc_block	295
	tra	free_block	296
	tra	push_ctl_data	297
	tra	push_ctl_desc	298
	tra	pop_ctl_data	299
	tra	pop_ctl_desc	300
	tra	allocation	301
	tra	set_chars_eis	302
	tra	set_bits_eis	303
	tra	index_chars_eis	304
	tra	index_bits_eis	305
	tra	index_cs_1_eis	306
	tra	index_bs_1_eis	307
	tra	return_chars_eis	308
	tra	return_bits_eis	309
	tra	put_data_eis	310
	tra	<put_format_>|[put_edit_eis]	311
	tra	put_list_eis	312
	tra	<put_format_>|[get_edit_eis]	313
	tra	get_list_eis	314
	tra	verify_eis	315
	tra	search_eis	316
	tra	fortran_read	317
	tra	fortran_write	318
	tra	fortran_manip	319
	tra	fortran_scalar_xmit	320
	tra	fortran_array_xmit	321
	tra	fortran_terminate	322
	tra	<any_to_any_>|[real_to_real_round_]	323
	tra	<any_to_any_>|[real_to_real_truncate_]	324
	tra	<any_to_any_>|[any_to_any_round_]	325
	tra	<any_to_any_>|[any_to_any_truncate_]	326
	tra	unpack_picture	327
	tra	pack_picture	328
	tra	divide_fx1	329
	tra	divide_fx2	330
	tra	divide_fx3	331
	tra	divide_fx4	332
	tra	scaled_mod_fx1	333
	tra	scaled_mod_fx2	334
	tra	scaled_mod_fx3	335
	tra	scaled_mod_fx4	336
	tra	translate_2	337
	tra	translate_3	338
	tra	<square_root_>|[&2square_root_]		339
	tra	<sine_>|[&2sine_radians_]		340
	tra	<sine_>|[&2sine_degrees_]		341
	tra	<sine_>|[&2cosine_radians_]		342
	tra	<sine_>|[&2cosine_degrees_]		343
	tra	<tangent_>|[&2tangent_radians_]	344
	tra	<tangent_>|[&2tangent_degrees_]	345
	tra	<arc_sine_>|[&2arc_sine_radians_]	346
	tra	<arc_sine_>|[&2arc_sine_degrees_]	347
	tra	<arc_sine_>|[&2arc_cosine_radians_]	348
	tra	<arc_sine_>|[&2arc_cosine_degrees_]	349
	tra	<arc_tangent_>|[&2arc_tangent_radians_]	350
	tra	<arc_tangent_>|[&2arc_tangent_degrees_]	351
	tra	<logarithm_>|[&2log_base_2_]		352
	tra	<logarithm_>|[&2log_base_e_]		353
	tra	<logarithm_>|[&2log_base_10_]		354
	tra	<exponential_>|[&2exponential_]		355
	tra	<double_square_root_>|[&2double_square_root_]	356
	tra	<double_sine_>|[&2double_sine_radians_]	357
	tra	<double_sine_>|[&2double_sine_degrees_]	358
	tra	<double_sine_>|[&2double_cosine_radians_]	359
	tra	<double_sine_>|[&2double_cosine_degrees_]	360
	tra	<double_tangent_>|[&2double_tangent_radians_]	361
	tra	<double_tangent_>|[&2double_tangent_degrees_]	362
	tra	<double_arc_sine_>|[&2double_arc_sine_radians_]	363
	tra	<double_arc_sine_>|[&2double_arc_sine_degrees_]	364
	tra	<double_arc_sine_>|[&2double_arc_cosine_radians_]	365
	tra	<double_arc_sine_>|[&2double_arc_cosine_degrees_]	366
	tra	<double_arc_tangent_>|[&2double_arc_tan_radians_]	367
	tra	<double_arc_tangent_>|[&2double_arc_tan_degrees_]	368
	tra	<double_logarithm_>|[&2double_log_base_2_]	369
	tra	<double_logarithm_>|[&2double_log_base_e_]	370
	tra	<double_logarithm_>|[&2double_log_base_10_]	371
	tra	<double_exponential_>|[&2double_exponential_]	372
	tra	<arc_tangent_>|[&2arc_tangent_radians_2_]	373
	tra	<arc_tangent_>|[&2arc_tangent_degrees_2_]	374
	tra	<double_arc_tangent_>|[&2double_arc_tan_radians_2_]	375
	tra	<double_arc_tangent_>|[&2double_arc_tan_degrees_2_]	376
	tra	<power_>|[&2integer_power_single_]	377
	tra	<power_>|[&2integer_power_double_]	378
	tra	<power_>|[&2double_power_single_]	379
	tra	<power_>|[&2double_power_double_]	380
	tra	<power_integer_>|[&2double_power_integer_]	381
	tra	<power_>|[&2single_power_single_]	382
	tra	<power_integer_>|[&2single_power_integer_]	383
	tra	<integer_power_integer_>|[integer_power_integer_]	384
	tra	signal_size	385
	tra	&1ss_ext_entry	386
	tra	&1ss_ext_entry_desc	387
	tra	ss_int_entry	388
	tra	ss_int_entry_desc	389
	tra	ss_val_entry	390
	tra	ss_val_entry_desc	391
	tra	<cplx_dec_ops_>|[mpcdec]	392
	tra	<cplx_dec_ops_>|[dvcdec]	393
	tra	<cplx_dec_ops_>|[dvrcdec]	394
	tra	<dec_ops_>|[ceil]	395
	tra	<dec_ops_>|[floor]	396
	tra	<dec_ops_>|[sign]	397
	tra	<cplx_dec_ops_>|[cabs]	398
	tra	<dec_ops_>|[truncate]	399
	tra	<dec_ops_>|[mod]		400
	tra	set_support	401
	tra	div_4_cplx_ops	402
	tra	fetch_chars_eis	403
	tra	signal_stringrange	404
	tra	ss_enter_begin_block	405
	tra	<put_field_>|[put_field]		406	 
	tra	<put_field_>|[put_field_chk]		407
	tra	<put_field_>|[put_control]	408
	tra	<alloc_>|[op_alloc_]	409
	tra	alloc_storage		410
	tra	<alloc_>|[op_freen_]	411
	tra	<alloc_>|[op_empty_]	412
	tra	<fort_math_ops_>|[&2cabs]		413	fortran only
	tra	<fort_math_ops_>|[&2ccos]		414	fortran only
	tra	<fort_math_ops_>|[&2cexp]		415	fortran only
	tra	<fort_math_ops_>|[&2clog]		416	fortran only
	tra	<fort_math_ops_>|[&2csin]		417	fortran only
	tra	<fort_math_ops_>|[&2csqrt]		418	fortran only
	tra	<fort_math_ops_>|[&2tanh]		419	fortran only
	tra	<fort_math_ops_>|[&2dmod]		420	fortran only (obsolete)
	tra	<fort_math_ops_>|[&2cmpx_p_cmpx]	421	fortran only
	tra	&2get_math_entry	422	fortran only
	tra	fortran_pause	423	fortran only
	tra	fortran_stop	424	fortran only
	tra	fortran_chain	425	fortran only
	tra	long_profile	426
	tra	index_before_cs	427
	tra	index_before_bs	428
	tra	index_after_cs	429
	tra	index_after_bs	430
	tra	index_before_bs_1	431
	tra	index_after_bs_1	432
	tra	verify_for_ltrim	433
	tra	verify_for_rtrim	434
	tra	stacq_mac		435
	tra	clock_mac		436
	tra	vclock_mac	437
	tra	ftn_open_element	438	fortran only
	tra	ftn_get_area_ptr	439	fortran only
	tra	stop		440
	tra	return_main	441
	tra	set_main_flag	442
	tra	begin_return_main	443
	tra	size_check_uns_fx1	444
	tra	size_check_uns_fx2	445
	tra	fortran_end	446	fortran only
	tra	&2fort_dmod	447	fortran only
	tra	ix_rev_chars	448
	tra	verify_rev_chars	449
	tra	search_rev_chars	450
	tra	shorten_stack_protect_ind	451
	tra	save_stack_quick	452
	tra	restore_stack_quick	453
	tra	<fort_math_ops_>|[&2dtanh]	454	fortran only
	tra	<fort_math_ops_>|[&2sinh]	455	fortran only
	tra	<fort_math_ops_>|[&2dsinh]	456	fortran only
	tra	<fort_math_ops_>|[&2cosh]	457	fortran only
	tra	<fort_math_ops_>|[&2dcosh]	458	fortran only
	tra	&2nearest_whole_number	459	fortran only
	tra	&2nearest_integer	460	fortran only
	tra	ftn_inquire_element	461	fortran only
	tra	mpy_overflow_check	462	fortran only
	tra	fort_return_mac	463	fortran only
	tra	fort_cleanup	464	fortran only
	tra	fort_storage	465	fortran only
	tra	&1enter_BFP_mode	466
	tra	&1enter_HFP_mode	467
	tra	unimp		468	future expansion
	tra	unimp		469	future expansion
	tra	unimp		470	future expansion
	tra	unimp		471	future expansion
	tra	unimp		472	future expansion
	tra	unimp		473	future expansion
	tra	unimp		474	future expansion
	tra	unimp		475	future expansion
	tra	unimp		476	future expansion
	tra	unimp		477	future expansion
	tra	unimp		478	future expansion
	tra	unimp		479	future expansion
	tra	unimp		480	future expansion
	&end
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	END OF MACROS
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
begin_pl1_operators:
	transfer_vector

"
"	The following section is not referenced directly by
"	the compiled pl/1 program and may be changed as
"	desired.
"
"	THE FOLLOWING CONVENTIONS APPLY TO STRING OPERATORS
"		1. Unless specified otherwise, a unit size is in the q register
"		2. Operators whose names end in "_aligned" or "vta" deal
"		   with aligned strings having no fractional offset.
"		3. Operators whose names end in "_co" have a character offset in x7.
"		4. Operators whose names end in "_ho" have a half-word offset in x7.
"		5. If not one of the above, the offset is a bit offset in x7.
"		6. A pointer to the string is transmitted in the bp.
"		7. If name of operator ends in "_eis", the bit offset is correct in bp
"		   and index register 7 is not used.
"
"	allocation operators
"	The char and bit allocation operators reserve two extra words
"	the temporary is stored in the second of these.
"
alloc_char_temp:
	stq	sp|char_lg1	save char length
	stz	sp|bit_or_char	indicate char temp
	adq	3+8,dl		compute number of words with 2 more
	qrs	2
	tsx1	alloc		allocate space
	ldq	sp|char_lg1	restore char length
"
act:	eppbp	bp|2		skip over extra 2 words
	stq	bp|-1		save length of temp
abt:	spribp	sp|temp_pt	save pointer to temp
	tra	sp|tbp,*0		and return to pl/1 program
"
alloc_bit_temp:
	stq	sp|bit_lg1	save bit length
	stc1	sp|bit_or_char	indicate bit temp
	adq	35+72,dl		compute number of words (2 extra)
	div	36,dl
	tsx1	alloc		allocate space
	ldq	sp|bit_lg1	restore bit length
	tra	act		and go fill in length
"
alloc_temp:
	eax1	abt		alloc N words and go save ptr
"				fall into alloc coding
"
"	routine to allocate N words at end of stack.
"	entered with N in ql.
"
alloc:	qls	18		shift number to qu
	stq	sp|temp_size	save number of words
	get_stack_offset
	eppbp	sp|stack_header.stack_end_ptr,au* get ptr to extension
	adlq	15,du		make size a multiple of 16
	anq	=o777760,du	..
	stq	sp|extend_size
	adlq	sp|stack_frame.next_sp+1	compute new end of stack frame
	stq	sp|stack_frame.next_sp+1	bump next ptr
	stq	sp|stack_header.stack_end_ptr+1,au	bump stack end pointer
	tra	0,1		return to operator
"
"	reallocation operators
"	allowance is made for the two words at the head of the string
"
cat_realloc_bits:
	lda	sp|bit_lg1	set up for concatenation
	sta	sp|cat_lg1
	stq	sp|bit_lg1	set new bit length
	adq	35+72,dl		compute new length of temp
	div	36,dl
	lda	sp|bit_lg1	restore bit length
	tsx1	realloc		extend stack again
	tra	sp|tbp,*0		an return to caller
"
realloc_bit_temp:
	sta	sp|bit_lg1	set new length
	adq	35+72,dl		compute new word length
	div	36,dl
	lda	sp|bit_lg1	restore bit length
	tsx1	realloc		extend stack
	tra	zero_it		and go zero new space
"
cat_realloc_chars:
	lda	sp|char_lg1	set up for concatenation
	sta	sp|cat_lg1
"
realloc_char_temp:
	stq	sp|char_lg1	set new char length
	adq	3+8,dl		compute new word length
	qrs	2
	lda	sp|char_lg1	restore char lenth
	tsx1	realloc		extend stack
	tra	sp|tbp,*0		and exit
"
realloc:	stx1	sp|save_x01
	ldx1	sp|temp_size	save end position of current temp
	eppbp	sp|temp_pt,*	get ptr to temp
	sta	bp|-1
	lda	sp|save_x01	restore return offset
	qls	18		shift word size to qu
	stq	sp|temp_size	set new size of temp
	sblq	sp|extend_size	subtract size of extension
	tmi	0,au		return if no extension needed
	adlq	15,du		make increment a multiple of 16
	anq	=o777760,du	..
	stq	sp|temp		save increment momentarily
	adlq	sp|extend_size	update extension size
	stq	sp|extend_size	..
	get_stack_offset
	ldq	sp|temp		get extension increment
	adlq	sp|stack_frame.next_sp+1	compute new end of stack frame
	stq	sp|stack_frame.next_sp+1	bump next sp pointer
	stq	sp|stack_header.stack_end_ptr+1,au	bump stack end pointer
	lda	sp|save_x01	restore return offset
	tra	0,au		return to caller
"
"	this operator shortens the stack frame to its original length
"
shorten_stack:
	epbpab	sp|0		get ptr to base of stack
	ldx1	sp|5
	stx1	sp|stack_frame.next_sp+1
	stx1	ab|stack_header.stack_end_ptr+1

	tra	sp|tbp,*0
"
"	This operator is the same as shorten_stack above, but does not change the indicators.
"
shorten_stack_protect_ind:
	sti	sp|temp		Save indicators
	epbpap	sp|0		Get ptr to base of stack
	ldx1	sp|5
	stx1	sp|stack_frame.next_sp+1
	stx1	ab|stack_header.stack_end_ptr+1
	ldi	sp|temp		Restore indicators

	tra	sp|tbp,*0
"
"	This operator makes the current extension permanent,
"	and returns the old permanent extent  in the q.
"
save_stack_quick:
	ldq	sp|5		Get permanent extent
	ldx1	sp|stack_frame.next_sp+1
	stx1	sp|5		Change it
	tra	sp|tbp,*0
"
"	This operator is the inverse of save_stack_quick above.
"	It takes a stack offset in the Q, and makes it the permanent
"	stack extent.
"
restore_stack_quick:
	stq	sp|5		Change permanent extent
	tra	sp|tbp,*0
"
"	code added here to handle 2 extra instructions needed at set_stack
"
set_stack_extend:
	get_stack_offset
	eppbp	sp|stack_frame.next_sp,* set up stack end ptr correctly
	spribp	sp|stack_header.stack_end_ptr,au ..
	tra	sp|tbp,*0		and return to pl1 program
"
"	operator to save the string in the aq in stack so it is
"	accessable to long string operators.  entered with bit_size
"	in x6 and string in aq
"
save_string:
	staq	sp|double_temp	save the string
	eppbp	sp|double_temp	load ptr to string
	eaq	0,6		move bit size to ql
	qrl	18
	spribp	sp|temp_pt	save ptr to string
	stq	sp|bit_lg1	save bit length
	div	9,dl		compute char length
	stq	sp|char_lg1	and save that
	tra	sp|tbp,*0
"
"	operators to save info about a string in the stack.
"
set_chars_eis:
	stq	sp|char_lg1	save char length
	stz	sp|bit_or_char	indicate char string
	spribp	sp|temp_pt	save ptr (with bit offset)
	tra	sp|tbp,*0		and return
"
set_chars:
	eax1	0,7		get bit offset
	tra	sca
"
set_chars_co:
	ldx1	co_to_bo,7	convert to bit offset
	tra	sca
"
set_chars_ho:
	ldx1	ho_to_bo,7	convert to bit offset
	tra	sca
"
set_chars_aligned:
	eax1	0		get zero offset
sca:	stq	sp|char_lg1	save char length
	stz	sp|bit_or_char	indicate char string
"
sca1:	spribp	sp|temp_pt	save ptr to string
	lxl1	shift_bo,1	shift bit offset to left
	sxl1	sp|temp_pt+1	and overwrite former bit offset
	tra	sp|tbp,*0
"
set_bits_eis:
	stq	sp|bit_lg1	save bit length
	stc1	sp|bit_or_char	indicate bit string
	spribp	sp|temp_pt	save ptr (with bit offset)
	tra	sp|tbp,*0		and return
"
set_bits:
	eax1	0,7		get bit offset
	tra	sba
"
set_bits_co:
	ldx1	co_to_bo,7	convert to bit offset
	tra	sba
"
set_bits_ho:
	ldx1	ho_to_bo,7	convert to bit offset
	tra	sba
"
set_bits_aligned:
	eax1	0		get zero offset
"
sba:	stq	sp|bit_lg1	save bit length
	stc1	sp|bit_or_char	indicate bit temp
	tra	sca1
"
"	operator to store a string when size+offset > 72
"	entered with string to be stored in aq, bit_size+offset-72 in x6,
"	bit offset in x7, and ptr to destination in bp
"
store_string:
	stq	sp|temp		save right part of string
	lrl	0,7		shift to proper position
	era	bp|0		insert in first two words
	stq	bp|1		of destination
	ana	mask_bit_one,7	mask has no trailing zeros
	ersa	bp|0
	lda	sp|temp		get right part of string
	ldq	0,dl		clear q register
	lrl	0,7		shift into position
	erq	bp|2		insert into third word
	anq	bit_mask_one,6	mask has no leading zeros
	ersq	bp|2
	tra	sp|tbp,*0		return to pl1 program
"
"	operator to store a string with an adjustable bit offset.
"	entered with bit size in x6.
"
string_store:
	eax1	0,7		bit offset to x1
	tra	ss_0
"
string_store_co:
	eax1	0,7		char offset to x1
	cmpx1	4,du		is offset >= 36 bits
	tmi	3,ic		no
	eppbp	bp|1		yes, adjust destination pointer
	eax1	-4,1		and offset
	ldx1	co_to_bo,1	convert to bit offset
	tra	ss_0
"
string_store_ho:
	eax1	0,7		half word offset to x1
	cmpx1	2,du		is offset >= 36 bits
	tmi	3,ic		no
	eppbp	bp|1		yes, adjust destination pointer
	eax1	-2,1		and offset
	ldx1	ho_to_bo,1	convert to bit offset
"
ss_0:	adwpbp	0,du		erase bit offset
	staq	sp|double_temp	save in aligned temp
	csl	(ar+rl),(ar+rl+x1),bool(move)	move into target
	descb	sp|double_temp,x6
	descb	bp|0,x6
	tra	sp|tbp,*0
"
"	operator to return in aq the first 72 bits of the char string
"	specified by string_aq.  if the length if less than 72 bits, string is padded
"	with blanks
"
fetch_chars:
	ldq	sp|char_lg1	load char length
	eppap	sp|temp_pt,*	get ptr to temp
	tra	gc_1		join common case
"
"	operator to return in aq the first 72 bits of an adjustable char
"	string. if length is less than 72 bits, string is padded.
"	note: compiled code expects bp not to be changed
"
get_chars:
	eax1	0,7		load offset
	tra	gc_0
"
get_chars_co:
	ldx1	co_to_bo,7	convert offset to bits
	tra	gc_0
"
get_chars_ho:
	ldx1	ho_to_bo,7	convert offset to bits
	tra	gc_0
"
get_chars_aligned:
	eax1	0		get zero offset
"
gc_0:	eppap	bp|0		copy ptr to string
	adwpap	0,du		erase bit offset
	abd	ap|0,1		add new bit offset
"
gc_1:	mlr	(ar+rl),(ar),fill(blank)	move to aligned temp
	desc9a	ap|0,ql
	desc9a	sp|temp,8
	eppap	sp|stack_frame.operator_ptr,*
	ldaq	sp|temp
	tra	sp|tbp,*0
"
"	operator to return in aq the first 72 bits of the char string
"	specified by string aq.  if the length is less than 72 bits, string 
"	is padded with binary zeroes.
"
fetch_chars_eis:
	ldq	sp|char_lg1	load char length
	eppap	sp|temp_pt,*	get ptr to temp
	mlr	(ar+rl),(ar),fill(0)	move to aligned temp
	desc9a	ap|0,ql
	desc9a	sp|temp,8
	eppap	sp|stack_frame.operator_ptr,*
	ldaq	sp|temp
	tra	sp|tbp,*0
"
"	operator to return in aq the first 72 bits of the bit string
"	specified by string_aq.  if length is less than 72 bits,
"	string is padded.
"
fetch_bits:			"eis comes here, too
	eppap	sp|temp_pt,*	get ptr to temp
	ldq	sp|bit_lg1	get bit length
	eax1	0		use 0 bit offset
	tra	gb_1
"
"	operator to return in aq the first 72 bits of an adjustable bit
"	string. if length is less than 72 bits, string is padded.
"	note: compiled code expects bp not to be changed
"
get_bits:
	eax1	0,7		load offset
	tra	gb_0
"
get_bits_co:
	ldx1	co_to_bo,7	convert offset to bits
	tra	gb_0
"
get_bits_ho:
	ldx1	ho_to_bo,7	convert offset to bits
	tra	gb_0
"
get_bits_aligned:
	eax1	0		get zero offset
"
gb_0:	eppap	bp|0		copy ptr to string
	adwpap	0,du		erase bit offset
"
gb_1:	csl	(ar+rl+x1),(ar),bool(move)	move to aligned temp
	descb	ap|0,ql
	descb	sp|temp,72
	eppap	sp|stack_frame.operator_ptr,*
	ldaq	sp|temp
	tra	sp|tbp,*0
"
"	operator to pad the char string temporary to 8 chars.
"
pad_chars:
	ldq	8,dl		compute number of chars left
	sbq	sp|char_lg1
	tmoz	sp|tbp,*0
	lda	sp|char_lg1	get offset
	eppap	sp|temp_pt,*	get ptr to temp
	mlr	(0),(ar+rl+a),fill(blank)	put fill(blank)s at end
	vfd	36/0
	desc9a	ap|0,ql
	eppap	sp|stack_frame.operator_ptr,*
	tra	sp|tbp,*0
"
"	operator to pad the bit string temporary to 72 bits.
"
pad_bits:
	ldq	sp|bit_lg1	get bit length of temp
	cmpq	73,dl		is it already long enough
	trc	sp|tbp,*0		yes, return
	adq	sp|bit_lg1	no, form 2*bit_length
	eax1	1,ql		and place in index reg
	ldaq	sp|temp_pt,*	mask string
	anaq	bit_mask,1
	staq	sp|temp_pt,*	replace padded string
	tra	sp|tbp,*0		and return to pl/1 program
"
"	operators to AND a string into the string
"	temporary pointed at by sp|temp_pt.  the string being ANDED
"	is guaranteed to be no bigger than the space in the stack.
"
and_bits:
	eax1	0,7		load offset
	tra	and_1
"
and_bits_co:
	ldx1	co_to_bo,7	convert to bit offset
	tra	and_1
"
and_bits_ho:
	ldx1	ho_to_bo,7	convert to bit offset
	tra	and_1
"
and_bits_aligned:
	eax1	0
"
and_1:	lda	ana_op		pickup logical function to do
	tra	logical		join common section
"
"	operators to OR a string into the string
"	temporary pointed at by sp|temp_pt.  the string being ORED
"	is guaranteed to be no bigger and the space in the stack.
"
or_bits:
	eax1	0,7		load offset
	tra	or_1
"
or_bits_co:
	ldx1	co_to_bo,7	convert to bit offset
	tra	or_1
"
or_bits_ho:
	ldx1	ho_to_bo,7	convert to bit offset
	tra	or_1
"
or_bits_aligned:
	eax1	0		zero offset
"
or_1:	lda	ora_op		pickup logical function to do
	tra	logical		join common section
"
"	operators to EXCLUSIVE OR a string into the string
"	temporary pointed at by sp|temp_pt.  the string being EXORed
"	is guaranteed to be no bigger than the space in the stack.
"
exor_bits:
	eax1	0,7		load offset
	tra	exor_1
"
exor_bits_co:
	ldx1	co_to_bo,7	convert to bit offset
	tra	exor_1
"
exor_bits_ho:
	ldx1	ho_to_bo,7	convert to bit offset
	tra	exor_1
"
exor_bits_aligned:
	eax1	0		zero offset
"
exor_1:	lda	era_op		pickup logical function to do
	tra	logical		join common section
"
"	operators to MOVE a string into the string
"	temporary pointed at by sp|temp_pt.  the string being MOVED
"	is guaranteed to be no bigger than the space in the stack.
"	since this operator is always followed by concatenation, no
"	padding is done.
"
cat_move_bits:
	eax1	0,7		load offset
	tra	cmb_1
"
cat_move_bits_co:
	ldx1	co_to_bo,7	convert to bit offset
	tra	cmb_1
"
cat_move_bits_ho:
	ldx1	ho_to_bo,7	convert to bit offset
	tra	cmb_1
"
cat_move_bits_aligned:
	eax1	0		zero bit offset
"
cmb_1:	stq	sp|cat_lg1	save for later cat operator
	cmpq	0,dl		return if nothing to move (prevent IPR)
	tze	sp|tbp,*0
	adwpbp	0,du		clear bit offset
	eppap	sp|temp_pt,*	get ptr to target
	csl	(ar+rl+x1),(ar+rl),bool(move)	move source into temp
	descb	bp|0,ql
	descb	ap|0,ql
	eppap	sp|stack_frame.operator_ptr,*
	tra	sp|tbp,*0
"
"	operators to MOVE the COMPLEMENT of astring into
"	the string temporary pointed at by sp|temp_pt.  the string
"	being moved is guaranteed to be the same size as the
"	destination.
"
move_not_bits:
	eax1	0,7		load offset
	tra	move_not_1
"
move_not_bits_co:
	ldx1	co_to_bo,7	convert to bit offset
	tra	move_not_1
"
move_not_bits_ho:
	ldx1	ho_to_bo,7	convert to bit offset
	tra	move_not_1
"
move_not_bits_aligned:
	eax1	0		zero offset
"
move_not_1:
	lda	not_op		pickup logical function to do
	tra	logical		join common section
"
"	operators to MOVE a string into the string
"	temporary pointed at by sp|temp_pt.  the string being MOVED
"	is guaranteed to be no bigger than the size of the destination.
"
move_bits:
	eax1	0,7		load offset
	tra	mb_1
"
move_bits_co:
	ldx1	co_to_bo,7	convert to bit offset
	tra	mb_1
"
move_bits_ho:
	ldx1	ho_to_bo,7	convert to bit offset
	tra	mb_1
"
move_bits_aligned:
	eax1	0		zero offset
"
mb_1:	lda	nop_op		pickup logical function to do
"
logical:	sta	sp|bit_op		save operator to perform
	lda	sp|bit_lg1	get length of temp
	tze	sp|tbp,*0		exit if zero (prevent IPR)
	adwpbp	0,du		clear bit offset
	eppap	sp|temp_pt,*	get ptr to temp
	xec	sp|bit_op		do the operation
	descb	bp|0,ql
	descb	ap|0,al
log_exit:
	eppap	sp|stack_frame.operator_ptr,*
	tra	sp|tbp,*0
"
"	logical functions...
"
nop_op:	csl	(ar+rl+x1),(ar+rl),bool(move)
ana_op:	csl	(ar+rl+x1),(ar+rl),bool(and)
ora_op:	csl	(ar+rl+x1),(ar+rl),bool(or)
era_op:	csl	(ar+rl+x1),(ar+rl),bool(xor)
not_op:	csl	(ar+rl+x1),(ar+rl),bool(invert)
"
"	operators to MOVE a string into the string
"	temporary pointed at by sp|temp_pt.  the string being MOVED
"	is guaranteed to be no bigger than the space in the stack.
"	if this is cat_move_chars, no padding will be done since
"	operator is always followed by concat.
"
move_chars:
	eax1	0,7		load offset
	tra	mc_1
"
move_chars_co:
	ldx1	co_to_bo,7	convert to bit offset
	tra	mc_1
"
move_chars_ho:
	ldx1	ho_to_bo,7	convert to bit offset
	tra	mc_1
"
move_chars_aligned:
	eax1	0
"
mc_1:	adwpbp	0,du		clear bit offset
	abd	bp|0,1		add new bit offset
	lda	sp|char_lg1	get length of target
	tze	sp|tbp,*0		exit if zero (prevent IPR)
	eppap	sp|temp_pt,*	get ptr to target
	mlr	(ar+rl),(ar+rl),fill(blank)
	desc9a	bp|0,ql
	desc9a	ap|0,al
	eppap	sp|stack_frame.operator_ptr,*
	tra	sp|tbp,*0
"
cat_move_chars:
	eax1	0,7		load offset
	tra	cmc_1
"
cat_move_chars_co:
	ldx1	co_to_bo,7	convert to bit offset
	tra	cmc_1
"
cat_move_chars_ho:
	ldx1	ho_to_bo,7	convert to bit offset
	tra	cmc_1
"
cat_move_chars_aligned:
	eax1	0		zero bit offset
"
cmc_1:	adwpbp	0,du		clear bit offset
	abd	bp|0,1		add new bit oofset
	stq	sp|cat_lg1	save for following cat
	cmpq	0,dl		exit if nothing to move (prevent IPR)
	tze	sp|tbp,*0
	eppap	sp|temp_pt,*	get ptr to target
	mlr	(ar+rl),(ar+rl)
	desc9a	bp|0,ql
	desc9a	ap|0,ql
	eppap	sp|stack_frame.operator_ptr,*
	tra	sp|tbp,*0
"
"	operator to AND a single length bit string into the string
"	temporary pointed at by sp|temp_pt.  words 1,2,3,... of the
"	temporary are cleared.
"
ext_and_1:
	ldq	0,dl		clear q and join ext_and_2
"
"	operator to AND a double length bit string into the string
"	temporary pointed at by sp|temp_pt.  words 2,3,... of the
"	temporary are cleared.
"
ext_and_2:
	eppbp	sp|temp_pt,*	get ptr to string
	ansa	bp|0		AND in the string
	ansq	bp|1		..
	eax1	2		clear starting at word 2
"
"	routine to zero rest of string temp
"	this routine returns directly to pl/1 program
"	at entry:
"		bp|0,1	points at first word to be cleared
"		sp|temp_size holds total size of temporary
"
zero_it:	eaa	0,1		get current position
	era	mask_bit_one	form 2's complement of whole a-reg
	adla	1,dl		w/o overflow
	adla	sp|temp_size	..
	tmoz	sp|tbp,*0		return if none
	eppbp	bp|0,1		get ptr to starting pos
	arl	18-2		get number of chars
	mlr	(0),(ar+rl)		clear the area
	vfd	36/0
	desc9a	bp|0,al
	eppbp	sp|temp_pt,*	restore ptr to tem (just in case)
	tra	sp|tbp,*0		return to pl/1 program
"
"
"	operator to complement the bit string temporary pointed
"	at by sp|temp_pt
"
comp_bits:
	ldq	sp|bit_lg1	get bit length
	tze	sp|tbp,*0		exit if zero length (prevent IPR)
	eppbp	sp|temp_pt,*	get ptr to temp
	csl	(ar+rl),(ar+rl),bool(invert)	negate
	descb	bp|0,ql
	descb	bp|0,ql
	tra	log_exit
"
"	operator to move string_1 into string_2
"	source string_1 was previously setup
"
chars_move_vt:
	stq	bp|-1		store size of string
"
chars_move:
	eax1	0,7		load offset
	tra	cm_1
"
chars_move_vt_co:
	stq	bp|-1		store size of string
"
chars_move_co:
	ldx1	co_to_bo,7	convert to bit offset
	tra	cm_1
"
chars_move_vt_ho:
	stq	bp|-1		store size of string
"
chars_move_ho:
	ldx1	ho_to_bo,7	convert to bit offset
	tra	cm_1
"
chars_move_vta:
	stq	bp|-1		store size of string
"
chars_move_aligned:
	eax1	0		zero offset
"
cm_1:	cmpq	0,dl		return if target zero length
	tze	sp|tbp,*0
	adwpbp	0,du		clear bit offset
	abd	bp|0,1
	eppap	sp|temp_pt,*	get ptr to source
	lda	sp|char_lg1	get length of source
	mlr	(ar+rl),(ar+rl),fill(blank)
	desc9a	ap|0,al
	desc9a	bp|0,ql
	eppap	sp|stack_frame.operator_ptr,*
	tra	sp|tbp,*0
"
bits_move_vt:
	stq	bp|-1		store size of string
"
bits_move:
	eax1	0,7		load offset
	tra	bm_1
"
bits_move_vt_co:
	stq	bp|-1		store size of string
"
bits_move_co:
	ldx1	co_to_bo,7	convert to bit offset
	tra	bm_1
"
bits_move_vt_ho:
	stq	bp|-1		store size of string
"
bits_move_ho:
	ldx1	ho_to_bo,7
	tra	bm_1
"
bits_move_vta:
	stq	bp|-1		store siqe of string
"
bits_move_aligned:
	eax1	0		zero bit offset
"
bm_1:	cmpq	0,dl		return if zerolength target
	tze	sp|tbp,*0
	adwpbp	0,du		clear target bit offset
	abd	bp|0,1		add new bit offset
	eppap	sp|temp_pt,*	get ptr to source
	lda	sp|bit_lg1
	csl	(ar+rl),(ar+rl),bool(move)
	descb	ap|0,al
	descb	bp|0,ql
	eppap	sp|stack_frame.operator_ptr,*
	tra	sp|tbp,*0
"
"	operators to move string_1 into string_2
"	when the size prefix is enabled
"
chars_move_ck:
	eax1	0,7		get offset
	tra	cmk_1
"
chars_move_ck_co:
	ldx1	co_to_bo,7	convert to bit offset
	tra	cmk_1
"
chars_move_ck_ho:
	ldx1	ho_to_bo,7	convert to bit offset
	tra	cmk_1
"
chars_move_ck_al:
	eax1	0		zero offset
"
cmk_1:	adwpbp	0,du		erase bit offset
	abd	bp|0,1		add new offset
	eppap	sp|temp_pt,*	get ptr to source
	lda	sp|char_lg1	get length of source
	mlr	(ar+rl),(ar+rl),fill(blank),enablefault
	desc9a	ap|0,al
	desc9a	bp|0,ql
	tra	log_exit
"
bits_move_ck:
	eax1	0,7		get offset
	tra	bmk_1
"
bits_move_ck_co:
	ldx1	co_to_bo,7	convert to bit offset
	tra	bmk_1
"
bits_move_ck_ho:
	ldx1	ho_to_bo,7	convert to bit offset
	tra	bmk_1
"
bits_move_ck_al:
	eax1	0		zero offset
"
bmk_1:	adwpbp	0,du		erase bit offset
	abd	bp|0,1		add new offset
	eppap	sp|temp_pt,*	get ptr to source
	lda	sp|bit_lg1	get length of source
	csl	(ar+rl),(ar+rl),bool(move),enablefault
	desc9a	ap|0,al
	desc9a	bp|0,ql
	tra	log_exit
"
"	operators to perform concatenation.  this is done by moving
"	the second string into the stack just after the first string.
"	length of first string is given by sp|cat_lg1 which is set
"	by a previous cat_move_... operator or by a previous cat_realloc_...
"
cat_chars:
	eax1	0,7		save offset
	tra	cat_chars_aligned+1
"
cat_chars_co:
	ldx1	co_to_bo,7	convert to bit offset
	tra	cat_chars_aligned+1
"
cat_chars_ho:
	ldx1	ho_to_bo,7	convert to bit offset
	tra	cat_chars_aligned+1
"
cat_chars_aligned:
	eax1	0		zero offset
	cmpq	0,dl		return if nothing to concat
	tze	cat_done
	adwpbp	0,du		clear bit offset
	abd	bp|0,1		add new bit offset
	lda	sp|cat_lg1	get offset for concat
	eppap	sp|temp_pt,*	get ptr to temp
	mlr	(ar+rl),(ar+rl+a)
	desc9a	bp|0,ql
	desc9a	ap|0,ql
	eppap	sp|stack_frame.operator_ptr,*
cat_done:
	eppbp	sp|temp_pt,*
	tra	sp|tbp,*0
"
cat_bits:
	eax1	0,7		save offset
	tra	cat_bits_aligned+1
"
cat_bits_co:
	ldx1	co_to_bo,7	convert to bit offset
	tra	cat_bits_aligned+1
"
cat_bits_ho:
	ldx1	ho_to_bo,7	convert to bit offset
	tra	cat_bits_aligned+1
"
cat_bits_aligned:
	eax1	0		zero offset
	cmpq	0,dl
	tze	cat_done		return if none to concat
	adwpbp	0,du		erase bit offset
	lda	sp|cat_lg1	get offset in temp
	eppap	sp|temp_pt,*	get ptr to temp
	csl	(ar+rl+x1),(ar+rl+a),bool(move)
	descb	bp|0,ql
	descb	ap|0,ql
	tra	cat_done-1
"
"	operator to perform repeat function (copy builtin) on char string in the string AQ.
"	entered with number of copies desired in q
"
repeat:
	cmpq	0,dl		take max(n_copies,0)
	tpl	2,ic
	ldq	0,dl
	stq	sp|count		save number of copies desired
	eppap	sp|temp_pt,*	get ptr to string
	szn	sp|bit_or_char	which case is this
	tnz	repeat_bs
	ldq	sp|char_lg1	get length of string
	mpy	sp|count		compute length of result
	stq	sp|lg2		and save for later
	adq	3+8,dl		compute number of words (2 extra)
	qrs	2
	tsx1	alloc		allocate new temp
	eppbp	bp|2		skip over 2 words at front
	spribp	sp|temp_pt	save ptr to result
	lxl1	sp|count		init loop
	tze	repeat_exit+1	skip if nothing to do
	ldq	sp|char_lg1	get back length of input
	tze	repeat_exit+2	skip if nothing to do
repeat_cs_loop:
	mlr	(ar+rl),(ar+rl)	move string
	desc9a	ap|0,ql
	desc9a	bp|0,ql
	a9bd	bp|0,ql		add char length
	sbx1	1,du
	tnz	repeat_cs_loop	repeat  until done
repeat_exit:
	eppbp	sp|temp_pt,*	get ptr to result
	ldq	sp|lg2		get length of result
	stq	bp|-1		save
	stq	sp|char_lg1
	stq	sp|bit_lg1
	eppap	sp|stack_frame.operator_ptr,*
	tra	sp|tbp,*0		and return
"
"	operator to perform repeat function (copy builtin) on bit string in the string AQ.
"	entered with number of copies desired in q
"
repeat_bs:
	ldq	sp|bit_lg1	get length of string
	mpy	sp|count		compute length of result
	stq	sp|lg2		and save for later
	adq	35+72,dl		compute number of words (2 extra)
	div	36,dl
	tsx1	alloc		allocate new temp
	eppbp	bp|2		skip over 2 extra words
	spribp	sp|temp_pt	save ptr to result
	lxl1	sp|count		init loop
	tze	repeat_exit+1	skip if nothing to do
	ldq	sp|bit_lg1	get back length of input
	tze	repeat_exit+2	exit now if nothing to do
repeat_bs_loop:
	csl	(ar+rl),(ar+rl),bool(move)
	descb	ap|0,ql
	descb	bp|0,ql
	abd	bp|0,ql		add bit length of string
	sbx1	1,du		repeat until done
	tnz	repeat_bs_loop
	tra	repeat_exit
"
"	operator to reverse bit string in the string AQ.
"
reverse_bs:
	eppap	sp|temp_pt,*	get ptr to source
	ldq	sp|bit_lg1	get bit length
	adq	35+72,dl		compute word length needed (2 extra)
	div	36,dl
	tsx1	alloc		extend stack
	eppbp	bp|2		skip over 2 words at front
	spribp	sp|temp_pt	save ptr to result
	ldq	sp|bit_lg1	get back bit length
	stq	bp|-1		save
	tze	log_exit		exit if nothing to do
	lda	0,dl		init offset
reverse_bs_loop:
	sbq	1,dl
	tmi	reverse_bs_exit	done, exit
	csl	(ar+q),(ar+a),bool(move)	move 1 bit
	descb	ap|0,1
	descb	bp|0,1
	ada	1,dl		update offset
	tra	reverse_bs_loop
reverse_bs_exit:
	ldq	sp|bit_lg1	get back length
	tra	log_exit
"
"	operator to reverse character string in the string AQ.
"
reverse_cs:
	eppap	sp|temp_pt,*	get ptr to source
	ldq	sp|char_lg1	get char length
	adq	3+8,dl		compute word length needed (2 extra)
	qrs	2
	tsx1	alloc		extend stack
	eppbp	bp|2		skip over 2 words at front
	spribp	sp|temp_pt	save ptr to result
	ldq	sp|char_lg1	get back char length
	stq	bp|-1		save
	tze	log_exit		return if nothing to do
	lda	0,dl		init offset
reverse_cs_loop:
	sbq	1,dl
	tmi	reverse_cs_exit	done, exit
	mlr	(ar+q),(ar+a)	move 1 char
	desc9a	ap|0,1
	desc9a	bp|0,1
	ada	1,dl		update offset
	tra	reverse_cs_loop
reverse_cs_exit:
	ldq	sp|char_lg1
	tra	log_exit
"
"	operator to suffix the string previously set up to a varying string.
"	entered with pointer to varying string in bp, max length in q
"
suffix_cs:
	sbq	bp|-1		get number of chars left in string
	tze	sp|tbp,*0		return if string is full
	cmpq	sp|char_lg1	get min(number left,number set up)
	tmi	2,ic
suffix_cs_1:
	ldq	sp|char_lg1	get length of suffix
	tze	sp|tbp,*0		exit if zero (prevent IPR)
	eppap	sp|temp_pt,*	get ptr to suffix
	lda	bp|-1		get offset of end
	mlr	(ar+rl),(ar+rl+a)	suffix string
	desc9a	ap|0,ql
	desc9a	bp|0,ql
	asq	bp|-1		update string length
	eppap	sp|stack_frame.operator_ptr,*
	tra	sp|tbp,*0		and return
"
"	operator to suffix to varying bit string.
"
suffix_bs:
	sbq	bp|-1		get number of bits left in string
	tze	sp|tbp,*0		return if string full
	cmpq	sp|bit_lg1	get min(number left,number set up)
	tmi	2,ic
suffix_bs_1:
	ldq	sp|bit_lg1	get length of suffix
	tze	sp|tbp,*0		exit if zero (prevent IPR)
	eppap	sp|temp_pt,*	get ptr to suffix
	lda	bp|-1		get offset of last bit available
	csl	(ar+rl),(ar+rl+a),bool(move)
	descb	ap|0,ql
	descb	bp|0,ql
	asq	bp|-1		update string length
	eppap	sp|stack_frame.operator_ptr,*
	tra	sp|tbp,*0		and return
"
"	operators to suffix the string previously set up to a varying string
"	when the stringsize condition is enabled.  entered with pointer
"	to string in bp, max length in q
"
suffix_cs_ck:
	sbq	bp|-1		get number of chars left
	tze	3,ic
	cmpq	sp|char_lg1	get min(number left,number set up)
	tpl	suffix_cs_1
	eaa	suffix_cs_1	error, signal stringsize
"
suffix_error:
	sxl0	sp|stack_frame.operator_ret_ptr no, signal stringsize
	spribp	sp|double_temp
	staq	sp|temp
	eppbp	stringsize_name
	eax6	stringsize_length
	ldq	=702,dl		get oncode value
	tsx1	call_signal_
	lxl0	sp|stack_frame.operator_ret_ptr
	eppbp	sp|double_temp,*
	ldaq	sp|temp
	tra	1,au		join standard section
"
suffix_bs_ck:
	sbq	bp|-1
	tze	3,ic
	cmpq	sp|bit_lg1
	tpl	suffix_bs_1
	eaa	suffix_bs_1
	tra	suffix_error
"
"	operator to compare string_2 with previously setup string_1
"
cp_chars:
	eax1	0,7		save offset
	tra	cp_chars_aligned+1
"
cp_chars_co:
	ldx1	co_to_bo,7	convert to bit offset
	tra	cp_chars_aligned+1
"
cp_chars_ho:
	ldx1	ho_to_bo,7	convert to bit offset
	tra	cp_chars_aligned+1
"
cp_chars_aligned:
	eax1	0		zero offset
	adwpbp	0,du
	abd	bp|0,1		add new bit offset
cpcs_1:	eppap	sp|temp_pt,*	get ptr to string_1
	lda	sp|char_lg1	get length(string_1)
	cmpc	(ar+rl),(ar+rl),fill(blank)
	desc9a	bp|0,ql		string_2
	desc9a	ap|0,al		string_1
	eppap	sp|stack_frame.operator_ptr,*
	tra	sp|tbp,*0
"
cp_bits:
	eax1	0,7		save offset
	tra	cp_bits_aligned+1
"
cp_bits_co:
	ldx1	co_to_bo,7	convert to bit offset
	tra	cp_bits_aligned+1
"
cp_bits_ho:
	ldx1	ho_to_bo,7	convert to bit offset
	tra	cp_bits_aligned+1
"
cp_bits_aligned:
	eax1	0		zero ofset
	adwpbp	0,du		erase bit offset
cpbs_1:	eppap	sp|temp_pt,*	get ptr to string_1
	lda	sp|bit_lg1
	cmpb	(ar+rl+x1),(ar+rl)
	descb	bp|0,ql		string_2
	descb	ap|0,al		string 1
	eppap	sp|stack_frame.operator_ptr,*
	tra	sp|tbp,*0
"
"	operators to compare single (double) word string in a-reg (aq_reg)
"	with string previously setup
"
cpcs_ext1:
	ldq	blanks		convert to double length string
"
cpcs_ext2:
	staq	sp|double_temp	save string in aq
	ldq	8,dl		get length
	eppbp	sp|double_temp	get ptr to string
	tra	cpcs_1
"
cpbs_ext1:
	ldq	0,dl		convert to double length string
"
cpbs_ext2:
	staq	sp|double_temp	save string in aq
	ldq	72,dl
	eppbp	sp|double_temp
	tra	cpbs_1
"
"	operator to check an unaligned string for any non-zero bits.
"
cpbs3:
	eax1	0,7		load offset
	tra	cpbs3a
"
cpbs3_co:
	ldx1	co_to_bo,7	convert to bit offset
	tra	cpbs3a
"
cpbs3_ho:
	ldx1	ho_to_bo,7	convert to bit offset
	tra	cpbs3a
"
"	operator to check the aligned string temp pointed at by
"	temp_pt for any non_zero bits
"
cpbs4:	ldq	sp|bit_lg1	get bit length
	eppbp	sp|temp_pt,*	get ptr to string
"
cpbs3_aligned:
	eax1	0		zero offset
"
cpbs3a:	adwpbp	0,du		erase bit offset
	cmpb	(ar+rl+x1),(0)
	descb	bp|0,ql
	vfd	36/0
	tra	sp|tbp,*0
"
"	operators to blank out a character string
"
blank_chars:
	eax1	0,7		get offset
	tra	bc_1
"
blank_chars_co:
	ldx1	co_to_bo,7	convert to bit offset
	tra	bc_1
"
blank_chars_ho:
	ldx1	ho_to_bo,7	convert to bit offset
	tra	bc_1
"
blank_chars_aligned:
	eax1	0		zero offset
"
bc_1:	cmpq	0,dl		return if string zero length
	tze	sp|tbp,*0
	adwpbp	0,du		erase bit offset
	abd	bp|0,1		add new offset
	mlr	(0),(ar+rl),fill(blank)
	vfd	36/0
	desc9a	bp|0,ql
	tra	sp|tbp,*0
"
"	operators to zero out a bit string
"
zero_bits:
	eax1	0,7		get bit offset
	tra	zb_1
"
zero_bits_co:
	ldx1	co_to_bo,7	convert to bit offset
	tra	zb_1
"
zero_bits_ho:
	ldx1	ho_to_bo,7	convert to bit offset
	tra	zb_1
"
zero_bits_aligned:
	eax1	0		get zero offset
"
zb_1:	cmpq	0,dl		return if string zero length
	tze	sp|tbp,*0
	adwpbp	0,du		erase bit offset
	csl	(0),(ar+rl+x1),bool(move)
	descb	bit_mask,0	(avoid csl bug by using real address)
	descb	bp|0,ql
	tra	sp|tbp,*0
"
"	operators to copy a constant into a temporary of the same size
"	entered with destination in bp, length in q, and text location of
"	constant in x1
"
copy_const_vt:
	stq	bp|-1		set size
"
copy_const:
	eppap	sp|tbp,*1		get ptr to constant
	mlr	(ar+rl),(ar+rl)
	desc9a	ap|0,ql
	desc9a	bp|0,ql
	eppap	sp|stack_frame.operator_ptr,*
	tra	sp|tbp,*0
"
"	operator to compute index(str1,str2).  entered with str1 specified
"	by previous set operator.
"
"
index_chars:
	eax1	0,7		get bit offset
	tra	ixc
"
index_chars_co:
	ldx1	co_to_bo,7	convert to bit offset
	tra	ixc
"
index_chars_ho:
	ldx1	ho_to_bo,7	convert to bit offset
	tra	ixc
"
index_chars_aligned:
	eax1	0		get zero offset
"
ixc:	adwpbp	0,du		erase bit offset
	abd	bp|0,1		add new bit offset

"	General entry

index_chars_eis:
ixc2:	eppap	sp|temp_pt,*	get ptr to string_1
	lda	sp|char_lg1	Get length 1
	cmpq	sp|char_lg1	Too long?
	tpnz	zix
	cmpq	1,dl		are we looking for single char
	tpnz	ixcs_long		Big string
	tmi	zix		0-length is failure.
ixc1:	scm	(ar+rl),(ar)
	desc9a	ap|0,al
	desc9a	bp|0,0
	arg	sp|temp
	ttn	zix		tally runout means not found
ixc_ret_ok:
	ldq	sp|temp		get index
	adq	1,dl		convert to pl1 index value
	eppap	sp|stack_frame.operator_ptr,*
	tra	sp|tbp,*0
"
"	index failed
"
zix:	ldq	0,dl
	eppap	sp|stack_frame.operator_ptr,*
	tra	sp|tbp,*0
"
"	string_2 is more than 1 character
"
ixcs_long:
	stq	sp|lg2		save length of string_2
	lrl	36		l(string1) =>q, 0 => a
	sblq	sp|lg2		Don't search last l(string2)
	stq	sp|t2		save lg(s1) - lg (s2)
ixcs_loop:
	adlq	2,dl		ok to match 2 more
	scd	(ar+rl+a),(ar)	Look for prefix
	desc9a	ap|0,ql
	desc9a	bp|0
	arg	sp|temp
	ttn	zix		Fails.
"
"	See if string really won.
"
	adla	1,dl		add 1 both for pl1 result and new offs
	adla	sp|temp		This gonna be real offset.
	sta	sp|temp		Leave in a and temp
	ldq	sp|lg2		Compare whole string
	cmpc	(ar+rl+a),(ar+rl)
	desc9a	ap|-1(3),ql	ql = length
	desc9a	bp|0,ql		string 2 length
	tze	ixc_ret_ok_1	answer in a
	ldq	sp|t2		charlg1 - lg2
	sblq	sp|temp
	tpl	ixcs_loop
	tra	zix		Nothing left to search

ixc_ret_ok_1:
	lrl	36
	eppap	sp|stack_frame.operator_ptr,*
	tra	sp|tbp,*0

"	Operator to compute index (rev(string1),rev(string2))
"	Same conventions as ix_chars.

ix_rev_chars:
	cmpq	sp|char_lg1	String 2 bigger than 1?
	tpnz	zix		Quick failure.
	eppap	sp|temp_pt,*	Get searchee ptr
	lda	sp|char_lg1	Load up searchee length
	cmpq	1,dl		Search for 0, 1, or 2?
	tmi	zix		Immediate failure for 0.
	tpnz	ix_rev_long	2 or more chars

"	Search for 1 char.  Searchee guaranteed to be at least 1 long.
"
"	ap = ptr to string1
"	bp = ptr to string2
"	a = length(string1)
"	q = length(string2) = 1
"	x0 = return offset

	scmr	(pr,rl),(pr)
	desc9a	ap|0,al
	desc9a	bp|0
	arg	sp|temp
	ttn	zix		" Was string2 found in string1?
	tra	ixc_ret_ok	" Yes: return 1-origin index

"	Now known to be 2 or more characters to search for
"	in string guaranteed 2 or more long.  Note that a leading
"	prefix of the searchee of length (length (searchstring)-2)
"	need not be searched.
"
ix_rev_long:
	stq	sp|lg2		length (searchstring)
	sbla	sp|lg2		Deduct l(ss)-2 from searchable len
	adla	2,dl
ix_rev_loop:
	scdr	(ar+rl+q),(ar+q)	q is l(searchstring)
	desc9a	ap|-1(2),al	a is searchable length of searchee
	desc9a	bp|-1(2)		Gets last 2 chars
	arg	sp|temp		Answer
	ttn	zix		Clear and present failure
"
"	See if we really found the string.  This algebra
"	really, really works.
"
	sbla	2,dl
	sbla	sp|temp
"
"	Compare the full string.  Length still in q, offset now in a.
"
	cmpc	(ar+rl+a),(ar+rl)
	desc9a	ap|0,ql
	desc9a	bp|0,ql
	tnz	ix_rev_more	Nope. Try some more.
"
"	String found.  Find how many chars left on other side.
"
	adla	sp|lg2		length(searchstring)
	sbla	sp|char_lg1	this is negative
	neg	0
	adla	1,dl		for PL/I convention
	lrl	36
	eppap	sp|stack_frame.operator_ptr,*
	tra	sp|tbp,*0		return.
ix_rev_more:
	adla	1,dl		This is right.
	cmpa	2,dl		Still left to search?
	tmi	zix		Search fails if not
	tra	ix_rev_loop	New stuff in a.
"
"	Bit index operators
"

index_bits_eis:
	cmpq	0,dl		exit now if string_2 zero length
	tze	sp|tbp,*0
	tra	ixb2		join common case
"
index_bits:
	eax1	0,7		get bit offset
	tra	ixb
"
index_bits_co:
	ldx1	co_to_bo,7	convert to bit offset
	tra	ixb
"
index_bits_ho:
	ldx1	ho_to_bo,7	convert to bit offset
	tra	ixb
"
index_bits_aligned:
	eax1	0		get zero offset
"
ixb:	cmpq	0,dl		exit if string 2 zero length
	tze	sp|tbp,*0
	adwpbp	0,du		erase bit offset
	abd	bp|0,1		use new bit offset
ixb2:	eppap	sp|temp_pt,*	get ptr to string_1
ixb1:	stq	sp|lg2		save length of string_2
	ldq	0,dl		init loop
ixbs_loop:
	stq	sp|count
	lda	sp|bit_lg1	compute number of remaining bits in 1
	sba	sp|count
	cmpa	sp|lg2		must be >= length 2
	tmi	zix
	lda	sp|lg2		get length 2
	adq	1,dl		convert skip count to pl1 index
	cmpb	(ar+rl),(ar+rl+q)
	descb	bp|0,al
	descb	ap|-1(35),al
	tnz	ixbs_loop		failed, try next value
	cmpq	0,dl		set indicators
	eppap	sp|stack_frame.operator_ptr,*	index in q, exit
	tra	sp|tbp,*0
"
"	operator to compute index(str1,str2) when str2 is a single char.
"	entered with value of str2 in a register.
"
index_cs_1_eis:
	cmpq	0,dl		exit now if string 1 zero length
	tze	sp|tbp,*0
	tra	ixcs1_b		join common cae
index_cs_1:
	eax1	0,7		convert to bit offset
	tra	ixcs1_a		join common section
"
index_cs_1_co:
	ldx1	co_to_bo,7	get bit offset
	tra	ixcs1_a
"
index_cs_1_ho:
	ldx1	ho_to_bo,7	convert to bit offset
	tra	ixcs1_a
"
index_cs_1_aligned:
	eax1	0		get zero offset
"
ixcs1_a:	cmpq	0,dl		return immediately if string 1 zero length
	tze	sp|tbp,*0
	adwpbp	0,du		clear bit offset
	abd	bp|0,1		use new bit offset
ixcs1_b:	eppap	bp|0		put ptr to string 1 in proper register
	sta	sp|temp2		save the character
	eppbp	sp|temp2		get ptr to it as string 2
	lls	36		Needed in a
	tra	ixc1
"
"	operators to search a bit string for a single bit
"
index_bs_1_eis:
	cmpq	0,dl		exit now if string 1 zero length
	tze	sp|tbp,*0
	tra	ixbs1_b		join common case
"
index_bs_1:
	eax1	0,7		save bit offset
	tra	ixbs1_a
"
index_bs_1_co:
	ldx1	co_to_bo,7	convert to bit offset
	tra	ixbs1_a
"
index_bs_1_ho:
	ldx1	ho_to_bo,7	convert to bit offset
	tra	ixbs1_a
"
index_bs_1_aligned:
	eax1	0		get zero offset
"
ixbs1_a:	cmpq	0,dl		return immediately if string 1 zero length
	tze	sp|tbp,*0
	adwpbp	0,du		clear bit offset
	abd	bp|0,1		add new bit offset
ixbs1_b:	eppap	bp|0		put ptr to string 1 in proper register
	stq	sp|bit_lg1	save length of string_1
	sta	sp|temp2		save the bit
	eppbp	sp|temp2		get ptr to it as string 2
	ldq	1,dl		get length of string 2
	tra	ixb1
"
"	index operators used with before and after.  entered
"	with str1 specified by previous set operator
"
index_before_cs:
	cmpq	0,dl		exit now if str2 zero length
	tze	sp|tbp,*0
	eax1	0		set flag
	tra	ixba
"
index_after_cs:
	cmpq	0,dl		exit now if str2 zero length
	tze	sp|tbp,*0
	eax1	1		set flag
ixba:	eppap	sp|temp_pt,*	get ptr to str1
	cmpq	1,dl		are we looking for single char
	tnz	ixba_long		no, skip
	ldq	sp|char_lg1	get length of str1
	scm	(ar+rl),(ar)
	desc9a	ap|0,ql
	desc9a	bp|0,1
	arg	sp|temp
	ttn	ixba_fail+1
	ldq	sp|temp		get result
	xec	nop_adq_dl,1
	eppap	sp|stack_frame.operator_ptr,*
	tra	sp|tbp,*0
"
"	index failed
"
ixba_fail:
	ldq	sp|char_lg1
	eppap	sp|stack_frame.operator_ptr,*
	tra	sp|tbp,*0
"
ixba_bs_fail:
	ldq	sp|bit_lg1
	eppap	sp|stack_frame.operator_ptr,*
	tra	sp|tbp,*0
"
nop_adq_dl:
	nop	0,dl		before
	adq	1,dl		after
"
"	str2 is more than 1 char
"
ixba_long:
	stq	sp|lg2		save length(str2)
	ldq	0,dl		init loop
ixba_loop:
	stq	sp|count
	lda	sp|char_lg1	get number remaining in str1
	sba	sp|count
	cmpa	sp|lg2		failed if < length(str2)
	tmi	ixba_fail
	scd	(ar+rl+q),(ar) 	check for first 2 chars of str2
	desc9a	ap|0,al
	desc9a	bp|0,2
	arg	sp|temp
	ttn	ixba_fail		tally runout means failure
	sba	sp|temp		compute length of hit
	cmpa	sp|lg2		must be >= length(str2)
	tmi	ixba_fail
	adq	sp|temp		update
	adq	1,dl		prepare to bump past hit
	lda	sp|lg2		check full str2
	cmpc	(ar+rl+q),(ar+rl)
	desc9a	ap|-1(3),al
	desc9a	bp|0,al
	tnz	ixba_loop
	sbq	1,dl		we want offset, NOT pl1 index
	xec	nop_adq,1
	eppap	sp|stack_frame.operator_ptr,*
	tra	sp|tbp,*0
"
nop_adq:
	nop	0,dl		before
	adq	sp|lg2		after
"
index_before_bs:
	cmpq	0,dl		exit now if str2 zero length
	tze	sp|tbp,*0
	eax1	0
	tra	ixba_bs
"
index_after_bs:
	cmpq	0,dl		exit now if str2 zero length
	tze	sp|tbp,*0
	eax1	1
ixba_bs:	eppap	sp|temp_pt,*	get ptr to str1
ixba_bs1:	stq	sp|lg2		save length(str2)
	ldq	0,dl		init loop
ixba_bs_loop:
	stq	sp|count
	lda	sp|bit_lg1	compute remaining bits in str1
	sba	sp|count
	cmpa	sp|lg2		must be >= length(str2)
	tmi	ixba_bs_fail
	lda	sp|lg2		get length(str2)
	adq	1,dl		prepare to skip past the bit
	cmpb	(ar+rl),(ar+rl+q)
	descb	bp|0,al
	descb	ap|-1(35),al
	tnz	ixba_bs_loop
	sbq	1,dl		want offset, not pl1 index
	xec	nop_adq,1
	eppap	sp|stack_frame.operator_ptr,*
	tra	sp|tbp,*0
"
index_before_bs_1:
	cmpq	0,dl		exit now if str1 zero len
	tze	sp|tbp,*0
	eax1	0
	tra	ixba_bs2
"
index_after_bs_1:
	cmpq	0,dl		exit now if str1 zero length
	tze	sp|tbp,*0
	eax1	1
ixba_bs2:	eppap	bp|0		put ptr to str1 in proper register
	stq	sp|bit_lg1	save length(str1)
	sta	sp|temp2		save the bit
	eppbp	sp|temp2		get ptr to it as str2
	ldq	1,dl		get length of str2
	tra	ixba_bs1
"
"	operators to make bit table for use with verify operator.
"	entered with pointer to string in bp, offset in x7, size in q, and
"	stack offset of bit table in au.
"
make_bit_table:
	eax1	0,7		get offset
	tra	mbt
"
make_bit_table_co:
	ldx1	co_to_bo,7	convert offset to bits
	tra	mbt
"
make_bit_table_ho:
	ldx1	ho_to_bo,7	convert offset to bits
	tra	mbt
"
make_bit_table_al:
	eax1	0		zero offset
"
mbt:	epbpap	sp|0		get ptr to base of stack
	eawpap	0,au		get ptr to bit table
	stq	sp|char_lg1	save - length of string
	fld	0,dl		zero out the bit table
	staq	ap|0
	staq	ap|2
	lcq	sp|char_lg1
	tze	log_exit		return if zero length string
	stq	sp|char_lg1
mbt_1:	ldq	bp|0		get current word of string
	lls	4,1		shift char to straddle aq, i.e. 00xx|yyyyy
	qrl	4+9		put 5 bit index in qu
	ana	3,dl		get 2 bit word index in al
	ldq	single_bit,qu	get single bit at right position
	orsq	ap|0,al		insert in bit table
	aos	sp|char_lg1	count down
	tze	log_exit		zero means we're done
	adx1	9,du		update offset
	cmpx1	36,du		do we need another word
	tmi	mbt_1		no, finish this one
	eax1	0		yes, set offset to zero
	eppbp	bp|1		update for next word
	tra	mbt_1		and repeat
"
"	operators to make bit table for use by search builtin function
"	entered with point to string in bp, offset in x7, size in q, and
"	stack offset of bit table in au.  The bit table constructed by
"	these operators are the complement of that constructed by
"	the make_bit_temp operator.
"
form_bit_table:
	eax1	0,7		get offset
	tra	fbt
"
form_bit_table_co:
	ldx1	co_to_bo,7	convert offset to bits
	tra	fbt
"
form_bit_table_ho:
	ldx1	ho_to_bo,7	convert offset to bits
	tra	fbt
"
form_bit_table_al:
	eax1	0		zero offset
"
fbt:	epbpap	sp|0		get ptr to base of stack
	eawpap	0,au		get ptr to bit table
	stq	sp|char_lg1	save - length of string
	ldaq	mask_bit
	staq	ap|0		init table to all 1s
	staq	ap|2
	lcq	sp|char_lg1
	tze	log_exit		return of zero length string
	stq	sp|char_lg1
fbt_1:	ldq	bp|0		get current word of string
	lls	4,1		shift char to straddle aq, i.e. 00xx|yyyyy
	qrl	4+9		put 5 bit index in qu
	ana	3,dl		get 2 bit word index in al
	ldq	single_bit,qu	get single 1 bit at right position
	erq	ones		convert to single 0 in right position
	ansq	ap|0,al		erase bit in bit table
	aos	sp|char_lg1	cont down
	tze	log_exit		zero means done
	adx1	9,du		update offset
	cmpx1	36,du		do we need another word
	tmi	fbt_1		no, ifnish this one
	eax1	0		yes, set offset to zero
	eppbp	bp|1		update for next word
	tra	fbt_1		and repeat
"
"	operators to verify|search a string with bit table stored in stack.
"	entered with pointer to string in bp, offset in x7, size in q,
"	and tack offset of bit table in au.
"
verify:	eax1	0,7		get offset
	tra	ver_1
"
verify_co:
	ldx1	co_to_bo,7	convert to bit offset
	tra	ver_1
"
verify_ho:
	ldx1	ho_to_bo,7	convert to bit offset
	tra	ver_1
"
verify_al:
	eax1	0		zero offset
ver_1:	epbpap	sp|0		get ptr to bit table
	eawpap	0,au		..
	tra	ver_3		join common section
"
"	operators to verify|search a string with constant bit table.
"	entered with pointer to string in bp, offset in x7, size in q,
"	and text offset of bit table in au.
"
const_verify:
	eax1	0,7		get offset
	tra	ver_2
"
const_verify_co:
	ldx1	co_to_bo,7	convert to bit offset
	tra	ver_2
"
const_verify_ho:
	ldx1	ho_to_bo,7	convert to bit offset
	tra	ver_2
"
const_verify_al:
	eax1	0		zero offset
ver_2:	eppap	sp|tbp,*au	get ptr to bit table
"
ver_3:	stq	sp|char_lg1	save - length of string
	lcq	sp|char_lg1
	tze	log_exit		return zero if zero length
	stq	sp|lg2
ver_4:	ldq	bp|0		get current word of string
	lls	4,1		shift char to straddle aq, i.e. 00xx|yyyyy
	qrl	4+9		put 5 bit index yyyyy in qu
	ana	3,dl		get 2 bit word index in al
	lda	ap|0,al		get word from bit table
	als	0,qu		shift to get bit into sign position
	tpl	ver_fail		plus means char from string not in class
	aos	sp|lg2		char ok, update for next
	tze	ver_done
	adx1	9,du		update shift amount
	cmpx1	36,du		do we need another word
	tmi	ver_4		no, repeat
	eax1	0		yes, zero shift
	eppbp	bp|1		update word pointer
	tra	ver_4		and repeat
ver_done:	ldq	0,dl		all chars in class, return zero
	tra	log_exit
ver_fail:	eppap	sp|stack_frame.operator_ptr,*	restore ptr to operator table
	ldq	sp|lg2		exit with index of char that failed
	adq	sp|char_lg1
	adq	1,dl
	tra	sp|tbp,*0
"
"	operators to do search|verify(s1,s2)
"	entered with bp -> s1, ab -> s2, length(s1) in q, length(s2) in a
"
search_eis:
	eax1	0		set to do ttf
	stq	sp|char_lg1	save length of s1
	ldq	1,dl		init loop
search_loop:
	cmpq	sp|char_lg1	are we done
	tpnz	search_fail	yes, return
	scm	(ar+rl),(ar+q)
	desc9a	ab|0,al
	desc9a	bp|-1(3),0
	arg	sp|t4
	xec	ttf_ttn,1		did we hit char
	adq	1,dl		keep looking
	tra	search_loop
search_fail:
	ldq	0,dl		return 0
	tra	sp|tbp,*0
search_done:
	cmpq	0,dl		set indicators
	tra	sp|tbp,*0		and exit
"
ttf_ttn:
	ttf	search_done
	ttn	search_done
"
verify_eis:
	eax1	1
	tra	search_eis+1
"
"	Reverse versions of above
"
verify_rev_chars:
	eax1	1
	tra	*+2
search_rev_chars:
	eax1	0
	stq	sp|lg2		for later computation
search_rev_loop:
	sblq	1,dl
	tmi	search_fail
	scm	(ar+rl),(ar+q)
	desc9a	ab|0,al
	desc9a	bp|0
	arg	sp|t4
	xec	rev_ttf_ttn,1
	tra	search_rev_loop

rev_ttf_ttn:
	ttf	rev_search_done
	ttn	rev_search_done
rev_search_done:
	stq	sp|temp
	ldq	sp|lg2
	sblq	sp|temp
	tra	sp|tbp,*0
"
"	verify operators for trim bifs entered as above
"
verify_for_ltrim:		"returns offset of 1st char not in str2 scanning from left
	stq	sp|char_lg1	save length of str1
	ldq	0,dl		init loop (we want offset, rather than pl1 verify index)
vfl_loop:
	cmpq	sp|char_lg1	are we done?
	tpl	search_done	yes, return
	scm	(ar+rl),(ar+q)
	desc9a	ab|0,al
	desc9a	bp|0,1
	arg	sp|t4
	ttn	search_done	are we past chars to be trimmed?
	adq	1,dl		no, keep looking
	tra	vfl_loop
"
verify_for_rtrim:		"equivalent to verify_for_ltrim(reverse(...
	cmpq	0,dl		exit if zero
	tze	sp|tbp,*0
	stq	sp|char_lg1	save length(str1)
vfr_loop:
	scm	(ar+rl),(ar+q)
	desc9a	ab|0,al
	desc9a	bp|-1(3),1
	arg	sp|t4
	ttn	vfr_done		have we gone past chars to be trimmed?
	sbq	1,dl		no, keep looking
	tpnz	vfr_loop
vfr_done:
	erq	ones		subtract from length(str1)
	adq	1,dl		..
	adq	sp|char_lg1	..
	tra	sp|tbp,*0
"
"	operator to perform translate(s,r) with string s previously set up
"	entered with pr2 -> r and length(r) in q
"
translate_2:
	stq	sp|temp		save length of r
	spri3	sp|temp2
	epp3	bp|0		save ptr to r
	ldq	sp|char_lg1	get length(s)
	adq	3+8,dl		allocate temp of proper size
	qrs	2
	tsx1	alloc
	eppap	sp|temp_pt,*	get ptr to s
	eppbp	bp|2		skip over temp header
	spribp	sp|temp_pt	save ptr to temp
	ldq	sp|char_lg1	get length(s)
trans2_loop:
	sbq	1,dl		do next char (backwards)
	tmi	trans_done	exit if done
	mrl	(ar+ql),(ar)	isolate next character with leading zeros
	desc9a	ap|0,1
	desc9a	sp|num,4
	lda	sp|num		get character from s
	cmpa	sp|temp		check against length of r
	tpl	trans2_blank	use blank if out of string
	mlr	(ar+al),(ar+ql)	move replacement to target
	desc9a	bb|0,1
	desc9a	bp|0,1
	tra	trans2_loop
trans2_blank:
	mlr	(0),(ar+ql),fill(blank)	move in fill(blank)
	zero
	desc9a	bp|0,1
	tra	trans2_loop
trans_done:
	epp3	sp|temp2,*
	eppap	sp|stack_frame.operator_ptr,*
	tra	sp|tbp,*0
"
"	operator to perform translate(s,r,p) with string s previously set up
"	entered with pr1 -> p, pr2 -> r, length(p) in a, and length(r) in q
"
translate_3:
	staq	sp|temp		save lengths
	spri3	sp|temp2
	epp3	bp|0		save ptr to r
	ldq	sp|char_lg1	get length(s)
	adq	3+8,dl		allocate temp of proper size
	qrs	2
	tsx1	alloc
	eppap	sp|temp_pt,*	get ptr to s
	eppbp	bp|2		skip over temp header
	spribp	sp|temp_pt	save ptr to temp
	ldq	sp|char_lg1	get length(s)
trans3_loop:
	sbq	1,dl		do next char (backwards)
	tmi	trans_done	exit if done
	lda	sp|temp		get length(p)
	scm	(ar+rl),(ar+ql)	is this char of s in p?
	desc9a	ab|0,al
	desc9a	ap|0,0
	arg	sp|num
	ttn	trans3_same	tally on means not found, use same char
	lda	sp|num		get number of chars skipped
	cmpa	sp|temp+1		check against length(r)
	tpl	trans3_blank	use blank if out of range
	mlr	(ar+al),(ar+ql)	replace with char from r
	desc9a	bb|0,1
	desc9a	bp|0,1
	tra	trans3_loop
trans3_blank:
	mlr	(0),(ar+ql),fill(blank)	move in fill(blank)
	zero
	desc9a	bp|0,1
	tra	trans3_loop
trans3_same:
	mlr	(ar+ql),(ar+ql)	move in char from s
	desc9a	ap|0,1
	desc9a	bp|0,1
	tra	trans3_loop
"
"	operator to implement return(*) for unpacked values
"	entered with pointer to return value in bp, number of
"	words to return in q, and number of begin blocks to
"	skip over in x0
"
return_words:
	tsx2	return_pop	pop stack back
"
"	the sp has now been put back to old frame to which we are returning,
"	ap points at the destination of the data being returned.  The old stack
"	frame has been extended to include the stack frame from which we are
"	returning.
"
rw_0:	qls	2		get number of chars to move
	tze	rw_1		skip if zero (prevent IPR)
	mlr	(ar+rl),(ar+rl)
	desc9a	bp|0,ql
	desc9a	ap|0,ql
rw_1:	ldq	sp|count		get back number of words
	qls	18		in upper
	adlq	17,du		make a multiple of 16 (allow for extra words)
	anq	=o777760,du
	eax0	ap|-2,qu		get offset of end of stack
	stx0	sp|stack_frame.next_sp+1 and update old frame
	stx0	sb|stack_header.stack_end_ptr+1 and stack end ptr
	eppap	sp|stack_frame.operator_ptr,* reset pointer to caller's operators
	ldi	sp|stack_frame.return_ptr+1 restore indicators
	rtcd	sp|stack_frame.return_ptr now return to old procedure
"
"	operator to implement return(*) for packed values and bit strings
"	entered with pointer to return value in bp, number of
"	bits to move in q, and offset in x7, and number of begin
"	blocks to skip over in x0
"
return_bits:
	eax1	0,7		get bit offset
	tra	rba
"
return_bits_co:
	ldx1	co_to_bo,7	get bit offset
	tra	rba
"
return_bits_ho:
	ldx1	ho_to_bo,7	get bit offset
	tra	rba
"
return_bits_al:
	eax1	0		get zero offset
"
rba:	adwpbp	0,du		erase bit offset
	abd	bp|0,1		add new bit offset
"
return_bits_eis:
	stq	sp|bit_lg1	save number of bits to move
	adq	35,dl		compute number of words
	div	36,dl
	lda	sp|bit_lg1	get number of units moved
	tsx2	return_pop	pop stack back
"
"	the sp now points at stack frame to which we are returning, this frame
"	has been extended to include the frame we are leaving.  ap points at
"	destination of return value.
"
	ldq	ap|-1		get back bit length
	tze	rw_1		skip if zero (prevent IPR)
	csl	(ar+rl),(ar+rl),bool(move)
	descb	bp|0,ql
	descb	ap|0,ql
	tra	rw_1
"
"	operator to implement return(*) for char strings
"	entered with pointer to return value in bp, number of chars in q,
"	offset in x7, and number of begin blocks to skip over in x0
"
return_chars:
	eax1	0,7		get bit offset
	tra	rca
"
return_chars_co:
	ldx1	co_to_bo,7	get bit offset
	tra	rca
"
return_chars_ho:
	ldx1	ho_to_bo,7	get bit offset
	tra	rca
"
return_chars_aligned:
	eax1	0		get zero offset
"
rca:	adwpbp	0,du		erase bit offset
	abd	bp|0,1		add neew bit offset
"
return_chars_eis:
	stq	sp|char_lg1	save number of chars to move
	adq	3,dl		compute number of words
	qrs	2
	lda	sp|char_lg1	get number of units moved
	tsx2	return_pop
	ldq	ap|-1		get back number of chars
	tra	rw_0+1		and go move them
"
"	subroutine to reset stack frame for return(*) operators
"	entered with number of words in q
"	and number of units (bits|chars) in a
"
return_pop:
	epplp	sp|0		get ptr to frame of proc from which
	cmpx0	0,du		we are returning
	tze	4,ic
	epplp	lp|stack_frame.prev_sp,*
	sbx0	1,du
	tpnz	-2,ic
"
	eppab	lp|stack_frame.arg_ptr,* get ptr to our arglist
	ldx3	ab|0		get head, 2*n_args
"
	eppab	ab|0,3*		get ptr to return arg
"
	epplp	lp|stack_frame.prev_sp,*	get ptr to frame to which we are going
"
	stq	sp|count		save # words in old frame
	eppap	lp|stack_frame.next_sp,*	get ptr to destination
	eppap	ap|2		skip 2 words to allow for varying return value
	spriap	ab|0		set return ptr for last arg
	sta	ap|-1		set varying length
	epaq	sp|0		get seg no of current stack
	sta	sp|temp		save it
	epaq	lp|0		get seg no of stack we are returning to
	cmpa	sp|temp		same stack?
	tze	same_stack	yes
	lda	sp|count		get # of words to move
	als	18		in upper
	adla	17,du		make 0 mod 16 (allow for 2 extra words)
	ana	=o777760,du	..
	eax0	ap|-2,au		get offset of new stack frame end
	stx0	lp|stack_frame.next_sp+1 update next sp of the frame
	epbplb	lp|0		get pointer to base of stack we are returning to
	stx0	lb|stack_header.stack_end_ptr+1 update stack end pointer
	tra	different_stack	join rest of code
same_stack:
	ldaq	sp|stack_frame.next_sp get next ptr of frame we're leaving
	staq	lp|stack_frame.next_sp set next of old to include all of this frame
different_stack:
	ldq	sp|count		get back # of words to move
	eppsp	lp|0		pop stack
	epbpsb	sp|0		set up stack base in case we switched stacks
	stq	sp|count		save of words in new stack frame
	tra	0,2		return with ap -> dest, # units in q

"
"	operator to leave a begin block.
"
leave_begin_block:
	odd
	epbpsb	sp|0		get ptr to base of stack
	even			"see note at label 'alm_return'
	sprisp	sb|stack_header.stack_end_ptr reset stack end ptr
	eppsp	sp|stack_frame.prev_sp,* pop the stack
	tra	sp|tbp,*0		return to pl1 program
"
"	operator to free fortran storage and then do a procedure return
"
fort_return_mac:
	spri6	sp|double_temp	save sp as owner to fortran_storage_manager_
	epp2	sp|double_temp
	spri2	sp|arg_list+2	argument 1 - stack pointer
	lda	2,du		nargs = 1, quick call (no enviptr)
	ldq	0,dl		no descriptors
	staq	sp|arg_list
	epp0	sp|arg_list	get argument list header
	epp2	return_mac	return to return
	spri2	sp|stack_frame.return_ptr	save return point
	tsx1	get_our_lp
	callsp	fortran_storage_manager_$free
"
"	operator to do a procedure return from inside a begin block.
"	entered with number of nested begin blocks in ql.
"
begin_return_mac:
	tze	return_mac	skip if begin block is quick
	epbpsb	sp|0		get ptr to base of stack
	inhibit	on
	sprisp	sb|stack_header.stack_end_ptr keep updating end ptr
	eppsp	sp|stack_frame.prev_sp,* pop stack
	inhibit	off
	sbq	1,dl		count down number of blocks
	tnz	-3,ic		repeat until all done
"
"	operator to do a procedure return
"
return_mac:
	epbpsb	sp|0		get ptr to base of stack
	inhibit	on
	sprisp	sb|stack_header.stack_end_ptr reset stack end pointer
	eppsp	sp|stack_frame.prev_sp,* pop stack
	inhibit	off
	epbpsb	sp|0		set sb up in case we just switched stacks
	eppap	sp|stack_frame.operator_ptr,* set up operator pointer
	ldi	sp|stack_frame.return_ptr+1	restore indicators for caller
	rtcd	sp|stack_frame.return_ptr continue execution after call
"
"	operators to call an entry variable
"	entered with pointer to entry in bp and number
"	of arguments in position in a, offset of arg list is in x1
"
call_ent_var_desc:
	eaq	0,au		there are descriptors
"
call_ent_var:
	sti	sp|stack_frame.return_ptr+1	save indicators
	ora	8,dl		insert pl1 code
	epbpsb	sp|0		get ptr to base of stack
	staq	sb|0,1		save at head of list
	stx0	sp|stack_frame.return_ptr+1 set offset of return point
	epplp	bp|2,*		get display pointer
	eppbp	bp|0,*		and ptr to entry
save_display:
	eppap	sb|0,1		get ptr to arg list
	sprilp	ap|2,au		store display ptr at end
	epplp	sp|linkage_ptr,*	restore ptr to linkage segment
var_call:
	callsp	bp|0		and transfer to entry
"
"	operator to call an external procedure (same or diff seg).
"	entered with pointer to entry in bp and number of args
"	in position in a, offset of arg list is in x1
"
call_ext_in_desc:
call_ext_out_desc:
	eaq	0,au		there are descriptors
"
call_ext_in:
call_ext_out:
	sti	sp|stack_frame.return_ptr+1	save indicators
	epbpsb	sp|0		get ptr to base of stack
	ora	4,dl		insert pl1 code (do this for now)
	staq	sb|0,1		save at head of list
	stx0	sp|stack_frame.return_ptr+1 set offset of return point
	eppap	sb|0,1		get pointer to arg list
	epplp	sp|linkage_ptr,*	reload ptr to linkage segment
"
"	This label is 'segdef'ed but is never transfered to directly. The segdef is
"	merely to allow default_error_handler to see if a fault occured as a result
"	of this particular instruction so that it can print a more informative
"	error message.
"
forward_call:
	callsp	bp|0		transfer to entry
"
"	operator to call an internal procedure defined in the
"	same block as the call.  entered with pointer to entry in
"	bp and number of args in position in a.
"
call_int_this_desc:
	eaq	0,au		there are descriptors
"
call_int_this:
	sti	sp|stack_frame.return_ptr+1	save indicators
	ora	8,dl		insert pl1 code
	epbpsb	sp|0		get ptr to base of stack
	staq	sb|0,1		save at head of list
	stx0	sp|stack_frame.return_ptr+1 save offset of return point
	eppap	sb|0,1		get pointer to arg list
	sprisp	ap|2,au		save display pointer
	tra	bp|0		transfer to entry
"
"	operator to call an interal procedure defined K blocks
"	above the call.  entered with pointer to entry in bp,
"	K in x7, and number of args in position in aq.
"
call_int_other_desc:
	eaq	0,au		there are descriptors
"
call_int_other:
	sti	sp|stack_frame.return_ptr+1	save indicators
	ora	8,dl		insert pl1 code
	epbpsb	sp|0		get ptr to base of stack
	staq	sb|0,1		save at head of list
	stx0	sp|stack_frame.return_ptr+1 save return point
	epplp	sp|display_ptr,*	walk back K levels
	eax7	-1,7		..
	tze	save_display	then go save display
	epplp	lp|display_ptr,*	take another step
	tra	-3,ic		and check again
"
"	operator to move the label variable pointed at by sp|temp_pt
"	into the label variable pointed at by bp
"
move_label_var:
	ldaq	sp|temp_pt,*	move first two words
	staq	bp|0		..
	eax1	2		and second two words
	ldaq	sp|temp_pt,*1	..
	staq	bp|2		..
	tra	sp|tbp,*0		return to pl1 program
"
"	operator to make a label variable in the stack.  entered
"	with pointer to label in bp, number of static blocks to walk
"	back in q.  sp|temp_pt is set to point to the label variable
"
make_label_var:
	spribp	sp|label_var	save pointer to label
	tsx1	display_chase	get pointer to stack frame
	spribp	sp|label_var+2	and save in label var
	eppbp	sp|label_var	get pointer to label var
	spribp	sp|temp_pt	set temp_pt
	tra	sp|tbp,*0		return to pl1 program
"
"	subroutine to walk N levels back along the display chain.
"	entered with N in q register, exit with pointer in bp.
"	NB: indicators must be set from q register at time of entry.
"
display_chase:
	eppbp	sp|0		get pointer to current frame
	tze	0,1		return if N = 0
	eppbp	bp|display_ptr,*	take a step back the chain
	sbq	1,dl		and decrease count
	tra	-3,ic		and check again
"
"	operator to form mod(fx1,fx1)
"	entered with first arg in q, bp pointing at second
"
mdfx1:	szn	bp|0		if divisor is zero, return with dividend
	tze	search_done	go set indicators from q and exit
	stq	sp|temp		save first arg
	div	bp|0		get remainder
	tnz	3,ic		skip if quotient non-zero
	ldq	sp|temp		zero quotient, set q to sign of
	erq	bp|0		quotient
	tpl	mdfx1a		skip if quotient sign +
	cmpa	0,dl		don't correct if remainder 0
	tze	mdfx1a
	ada	bp|0		negative quotient, correct remainder
mdfx1a:	lrs	36		shift remainder to q
	tra	sp|tbp,*0		and return
"
"	operator to form mod(fx1,fx2)
"	entered with first arg in q, bp pointing at second
"
mdfx2:	lls	36		convert to double precision
	lrs	36		and join mdfx4
"
"	operator to form mod(fx2,fx2)
"	entered with first arg in q, bp pointing at second
"
mdfx4:	sreg	sp|save_regs	save registers including aq
	ldaq	bp|0		return 1st arg if second is zero
	tze	use_first
	spri1	sp|temp_pt	save ab
	epp1	sp|save_regs+4	get ptr to first arg
	ldq	0,dl		load scaling amount
	tsx7	divide2		generate remainder
	cmpx1	0,du		check sign of quotient
	tze	mdfx4a+1		skip if quotient +
	ldaq	sp|remainder	correct remainder if it is non-zero
	tze	2,ic
	adaq	bp|0
mdfx4a:	staq	sp|remainder
	lreg	sp|save_regs	restore registers
	epp1	sp|temp_pt,*	restore ab
	ldaq	sp|remainder	get result
	eppap	sp|stack_frame.operator_ptr,*
	tra	sp|tbp,*0		and exit
"
"	operator to form mod(fx2,fx1)
"	entered with first arg in q, bp pointing at second
"
mdfx3:	sreg	sp|save_regs	save registers, including aq
	lda	bp|0		get divisor
	tze	use_first		use first arg as result if divisor zero
	spri1	sp|temp_pt
	epp1	sp|save_regs+4	get ptr to dividend
	ldq	0,dl		get scale amount
	tsx7	divide1		get remainder
	cmpx1	0,du		check sign of quotient
	tze	mdfx4a+1
	ldaq	sp|remainder	correct remainder when quotient neg
	tze	2,ic		and remainder non-zero
	adl	bp|0
	tra	mdfx4a
"
"	operator to form mod(fx1,fx2) with non-zero scales
"	entered with dividend in q, pr2 -> divisor, and
"	scales following tsx0
"
scaled_mod_fx2:
	lls	36		convert to double precision
	lrs	36		and join scaled_mod_fx4
"
"	operator to form mod(fx2,fx2) with non-zero scales
"	entered with dividend in aq, pr2 -> divisor, and
"	scale(dividend) & scale(divisor) following tsx0
"
scaled_mod_fx4:
	adx0	2,du		skip over the two scale words
	sreg	sp|save_regs	save all registers
	ldaq	bp|0		get divisor
	tze	use_first		zero means use dividend as value
	sprp2	sp|temp_pt+1
"
sc_mod_common:
	sprp1	sp|temp_pt
	eppap	sp|tbp,*0		get ptr to just after scale words
	ldq	ap|-1		get scale of divisor
	sbq	ap|-2		- scale of dividend
	tmi	scmd3		skip if scale(divisor) < scale(dividend)
"
"	scale of dividend <= scale of divisor.  let the divide routine
"	shift the dividend left by the amount in the q register.
"
scmd1:	epp1	sp|save_regs+4	get ptr to dividend
	tsx7	divide2		divide
	cmpx1	0,du		check quotient sign
	tze	scmd2		skip if positive
	ldaq	sp|remainder	dont't correct remainder if it is zero
	tze	scmd2
	adaq	bp|0		add divisor to correct remainder
	staq	sp|remainder
scmd2:	lprp1	sp|temp_pt	restore pointers
	lprp2	sp|temp_pt+1
	lreg	sp|save_regs	and registers
	ldaq	sp|remainder	get remainder from the division
	tra	log_exit		and exit
"
"	scale of divisor < scale of dividend, shift divisor
"	left by negative of number of places in q register.
"	if the carry indicator is on at the end of the shift, the
"	division would yield a zero quotient, so the remainder
"	is the dividend with appropriate sign consideration.
"
scmd3:	stq	sp|count		get positive shift amount
	lcq	sp|count
	eax1	0,ql
	ldaq	bp|0		get back the divisor
	lls	0,1		shift it
	trc	scmd4		skip if divisor too big
	staq	sp|bit_lg1	save value temporarily
	epp2	sp|bit_lg1	get ptr to shifted divisor
	ldq	0,dl		don't shift dividend
	tra	scmd1		go do the division
"
"	the division (with both args treated as integers since the scales
"	are now lined up), would give a zero quotient.  if the signs of
"	the two arguments are the same, the value of the function is the
"	value of the dividend--otherwise, we have to signal fixedoverflow
"
scmd4:	era	sp|save_regs+4	check signs of two arguments
	ana	=o400000,du
	tze	use_first		zero means signs the same
	tsx7	signal_overflow
	tra	use_first
"
"	operator to form mod(fx1,fx1) with non-zero scales
"	entered with dividend in aq, pr2 -> divisor, and scales
"	following tsx0
"
scaled_mod_fx1:
	lls	36		convert to double precision
	lrs	36		and join scaled_mod_fx3
"
"	operator to form mod(fx2,fx1) with non-zero scales
"	entered with dividend in q, pr2 -> divisior, and scales
"	following tsx0
"
scaled_mod_fx3:
	adx0	2,du		skip over the two scale words
	sreg	sp|save_regs	save all registers
	lda	bp|0		get divisor
	tze	use_first		zero means use dividend as value
	sprp2	sp|temp_pt+1
	lrs	36		form double precision divisor
	staq	sp|bit_lg1	save new divisior
	epp2	sp|bit_lg1	and get ptr to it
	tra	sc_mod_common
"
"	operator to divide single precision by single precision
"	entered with dividend in q and pr2 -> divisor, and amount
"	to scale result following tsx0
"
divide_fx1:
	lls	36		convert to double precision
	lrs	36		and join divide_fx3
"
"
"	operator to divide double precision by single precision
"	entered with dividend in aq, pr2 -> divisor, and amount
"	to scale result (+ left, - right) following tsx0
"
divide_fx3:
	sreg	sp|save_regs
	spri1	sp|temp_pt	save ab
	epp1	sp|save_regs+4	get ptr to dividend
	lda	bp|0		load divisor
	ldq	sp|tbp,*0		load scale amount
	tsx7	divide1		do the division
dv_done:
	staq	sp|save_regs+4	save quotient
	lreg	sp|save_regs	restore registers
	adx0	1,du		update return pt
	epp1	sp|temp_pt,*	restore ab
	eppap	sp|stack_frame.operator_ptr,*
	cmpaq	bit_mask		set indicators
	tra	sp|tbp,*0		and exit
"
"	operator to divide single precision by double precision
"	entered with dividend in q, pr2 -> divisor, and
"	amount to scale result following tsx0
"
divide_fx2:
	lls	36		convert to double precision
	lrs	36		and join divide_fx3
"
"
"	operator to divide double precision by double precision
"	entered with dividend in aq, pr2 -> divisor, and amount
"	to scale result following tsx0
"
divide_fx4:
	sreg	sp|save_regs
	spri1	sp|temp_pt	save ab
	epp1	sp|save_regs+4	get ptr to dividend
	ldq	sp|tbp,*0
	tsx7	divide2
	tra	dv_done
"
"	operator to divide double precision by double precision
"	same calling sequence as divide_fx4 except scale is
"	in index 1.  Called from fixed_ops_.
"
div_4_cplx_ops:
	sreg	sp|save_regs	save regs
	epp1	sp|save_regs+4	get ptr to dividend
	eaq	0,1		get scale into q
	qrs	18		""
	tsx7	divide2		perform division
	staq	sp|save_regs+4	save quotient
	lreg	sp|save_regs	restore regs
	eppap	sp|stack_frame.operator_ptr,*
	tra	sp|tbp,*0
"
"	internal procedure to divide double precision integer by
"	single precision integer.  entered with divisor in a,
"	pr1 -> dividend, and scale in q
"	returns quotient in aq and remainder in sp|remainder
"
divide1:	tsx1	divide_extension	extend stack
	stq	ap|shift		save scaling amount
	eax1	0		save sign of divisor
	lrs	36
	tpl	3,ic
	negl	0
	erx1	1,du
	tra	div_single
"
"	internal procedure to divide two double precision integers
"	entered with pr1 -> dividend, pr2 -> divisor, scale amount in q
"	returns quotient in aq and remainder in sp|remainder
"
divide2:	tsx1	divide_extension	extend stack
	stq	ap|shift		save scaling amount
	eax1	0		assume positive result
	ldaq	bp|0		get divisor
	tpl	3,ic
	negl	0
	erx1	1,du
	cmpaq	max_single_value
	tmoz	div_single
	cana	=o200000,du	is high bit of divisor on
	tnz	divisor_3		yes, need 3 words
"
"	divisor only needs 2 words
"
	sti	sp|temp_indicators	save indicators
	ldi	0,dl		clear HFP mode if it's set
	lde	=0,du		count leading zeros
	fad	=0.0,du
	ldi	sp|temp_indicators	restore indicators
	qrl	1		split number into two parts
	stq	ap|divisor+1
	sta	ap|divisor+2
	ste	ap|div_temp	get number of leading zeros
	lda	ap|div_temp
	ars	28
	neg	0		make it positive
	sba	1,dl
	eax4	2		set length of number
	tra	prepare_dividend
"
"	divisor requires 3 words
"
divisor_3:
	sta	ap|divisor+3	store high order word
	lls	34+1		shift other parts 34 bits
	qrl	1		and save
	stq	ap|divisor+1
	ana	max_single_value+1
	sta	ap|divisor+2
	lda	34,dl		shift is 34
	eax4	3		and length is 3
"
prepare_dividend:
	sta	ap|norm_shift	save scaling count
	asa	ap|shift		update shift by number of leading zeros
	stx4	ap|divisor	save length of divisor
	ldaq	ab|0	
	tpl	3,ic
	negl	0
	erx1	1,du
	tsx3	shift_dividend
	adx5	1,du
	stz	ap|dividend,5	add zero chunk at front
	stx5	ap|dividend	save number of chunks
	fld	0,dl
	staq	ap|quotient
	staq	ap|quotient+2
	staq	ap|quotient+4
	eax6	0,5		quotient length =
	sbx6	ap|divisor	dividend_length - divisor_length
	tze	done		skip if zero quotient length
"
get_qhat:
	ldx5	ap|dividend	calculate quotient guess
	lda	ap|dividend,5
	cmpa	ap|divisor,4
	tmi	div_less
	ldq	max_single_value+1	=o377777777777
	lda	ap|dividend-1,5
	tra	l3h
dec_qhat:
	ldq	ap|qhat
	sbq	1,dl
	lda	ap|rhat
l3h:	stq	ap|qhat
	adla	ap|divisor,4
	tmi	got_qhat
	sta	ap|rhat
	tra	got_rhat
div_less:
	ldq	ap|dividend-1,5
	qls	1
	dvf	ap|divisor,4
	sta	ap|qhat
	stq	ap|rhat
got_rhat:
	ldq	ap|qhat
	mpy	ap|divisor-1,4
	lls	1
	cmpa	ap|rhat
	tmi	got_qhat
	tnz	dec_qhat
	qrl	1
	cmpq	ap|dividend-2,5
	tmi	got_qhat
	tnz	dec_qhat
got_qhat:
	eax3	0		do multiply and subtract
	stz	ap|carry
	stz	ap|carrya
	sbx5	ap|divisor
	epplp	ap|dividend,5
div_loop:
	eax3	1,3
	ldq	ap|divisor,3
	mpy	ap|qhat
	adl	ap|carry
	lls	1
	qrl	1
	stq	ap|div_temp
	sta	ap|carry
	ldq	lp|-1,3
	sblq	ap|carrya
	sblq	ap|div_temp
	lda	0,dl
	lls	1
	qrl	1
	stq	lp|-1,3
	sta	ap|carrya
	cmpx3	ap|divisor
	tnz	div_loop
	eax3	1,3
	ldq	lp|-1,3
	sblq	ap|carrya
	sblq	ap|carry
	lda	0,dl
	lls	1
	qrl	1
	stq	lp|-1,3
	cmpa	0,dl
	tze	store_q
	lcq	1,dl
	asq	ap|qhat
	eax3	0
	lda	0,dl
div_loop1:
	eax3	1,3		add back in
	ldq	lp|-1,3
	adlq	zero_one,al
	adlq	ap|divisor,3
	lda	0,du
	lls	1
	qrl	1
	stq	lp|-1,3
	cmpx3	ap|divisor
	tnz	div_loop1
	eax3	1,3
	ldq	lp|-1,3
	adlq	zero_one,al
	lls	1
	qrl	1
	stq	lp|-1,3
"
store_q:
	lda	ap|qhat
	sta	ap|quotient,6
	eax3	-1
	asx3	ap|dividend
	eax6	-1,6
	tpnz	get_qhat
"
"	done
"
done:	ldq	ap|dividend+2	assemble remainder
	qls	1
	lda	ap|dividend+3
	lls	35
	ldq	ap|dividend+1
	qls	1
	lrl	1
	lxl6	ap|norm_shift	get amount we scaled divisor
	lrl	0,6		shift back remainder
l2:	szn	ab|0		set remainder sign to sign of dividend
	tpl	2,ic
	negl	0
	staq	sp|remainder
	ldq	ap|quotient+4	assemble quotient
	adq	ap|quotient+5
	tnz	signal_overflow
	ldq	ap|quotient+2
	qls	1
	lda	ap|quotient+3
	lls	35
	trc	signal_overflow
	ldq	ap|quotient+1
	qls	1
	lrl	1
	xec	sign_change,1
	epplp	ap|divide_lp,*	restore lp
	lcx2	sp|qmask		return stack extension
	ldx3	sp|stack_frame.next_sp+1
	sblx3	divide_extension_size,du
	stx3	sp|stack_frame.next_sp+1
	stx3	sp|stack_header.stack_end_ptr+1,2
	tra	0,7
"
signal_overflow:
	spribp	sp|double_temp
	eppbp	overflow_name
	eax6	overflow_length
	ldq	=711,dl
	sxl0	sp|stack_frame.operator_ret_ptr
	tsx1	call_signal_
	eppbp	sp|double_temp,*
	lxl0	sp|stack_frame.operator_ret_ptr
	stz	sp|stack_frame.operator_ret_ptr
	ldaq	mask_bit+2
	tra	0,7
"
overflow_name:
	aci	"fixedoverflow"
"
	equ	overflow_length,13

"
div_single:
	stq	ap|divisor
	ldaq	ab|0	
	tpl	3,ic
	negl	0
	erx1	1,du
	tsx3	shift_dividend
	fld	0,dl
	staq	ap|quotient+2
	staq	ap|quotient+4
l1:	ldq	ap|dividend,5
	qls	1
	dvf	ap|divisor
	sta	ap|quotient,5
	eax5	-1,5
	tze	thru
	llr	36
	tra	l1
thru:	lda	0,dl
	tra	l2
"
"	internal procedure to extend stack for divide operators
"
divide_extension:
	eax2	sp|0		get offset of stack frame
	stx2	sp|qmask
	lcx2	sp|qmask		get - offset
	eppap	sp|stack_header.stack_end_ptr,2*	get ptr to extension
	eax3	divide_extension_size
	adlx3	sp|stack_frame.next_sp+1
	stx3	sp|stack_header.stack_end_ptr+1,2
	stx3	sp|stack_frame.next_sp+1
	sprilp	ap|divide_lp	save lp
	tra	0,1
"
" This procedure shifts the dividend left (+) or right (-) the
" number of places specified by variable shift.  It splits the shifted
" value into chunks which are stored in dividend+1, dividend+2, ...
" The number of chunks stored (which can never exceed 5) is returned in x5.
" The routine is entered with |dividend| in AQ
"
shift_dividend:
	lxl2	ap|shift
	tmi	right_shift
	staq	ap|div_temp
	lls	0,2
	trc	hard_shift	carry means lost a bit on left
split:	lls	1
	qrl	1		split into chunks
	stq	ap|dividend+1
	eax5	1
	lrl	35
	tze	0,3
	qrl	1
	stq	ap|dividend+2
	eax5	2
	cmpa	0,dl
	tze	0,3
	sta	ap|dividend+3
	eax5	3
	tra	0,3
hard_shift:
	lls	1
	qrl	1		store lower 2 chunks
	stq	ap|dividend+1
	lrl	35
	qrl	1
	stq	ap|dividend+2
	ldaq	ap|div_temp	get back original value
	sbx2	70,du		shift 70 places fewer
	tpl	sl
	stx2	ap|div_temp
	lcx2	ap|div_temp
	lrl	0,2
	tra	sl+1
sl:	lls	0,2
	lls	1
	qrl	1
	stq	ap|dividend+3	will always be 3rd chunk
	eax5	3
	lrl	35
	tze	0,3
	qrl	1
	stq	ap|dividend+4
	eax5	4
	cmpa	0,dl
	tze	0,3
	sta	ap|dividend+5
	eax5	5
	tra	0,3
right_shift:
	stx2	ap|div_temp
	lcx2	ap|div_temp
	lrl	0,2
	tra	split
"
zero_one:	dec	0,1
"
sign_change:
	nop	0,du
	negl	0
"
"	operator to convert floating to fixed
"
fl2_to_fx1:
fl2_to_fx2:
	fad	=0.,du
	tmi	3,ic
	ufa	=71b25,du
	tra	sp|tbp,*0
	fneg
	ufa	=71b25,du
	negl
	tra	sp|tbp,*0
"
"	operator to convert float to fixed scaled.  the word following
"	the tsx0 is the encoded scale of the target
"
fl2_to_fxscaled:
	fad	=0.,du
	tmi	4,ic
	ufa	sp|tbp,*0
	adx0	1,du
	tra	sp|tbp,*0
	fneg
	ufa	sp|tbp,*0
	negl
	tra	-5,ic
"
"	stac operator.  entered with word in a and pointer
"	to destination in bp.
"
stac_mac:	stac	bp|0		store a conditionally
	tze	true
	lda	0,dl		..
	tra	sp|tbp,*0		and return
"
"	stacq operator.  entered with old value in Q, new value in A,
"	and pointer to destination in pr2.
"
stacq_mac:
	stacq	pr2|0		store A conditional C(storage) = Q
	tze	true		stored OK, return "1"b
	lda	0,dl		not stored, return "0"b
	tra	sp|tbp,*0		return
"
"	clock operator.  no arguments...returns with value of
"	calendar clock in AQ.
"
clock_mac:
	get_our_lp
	rccl	sys_info$clock_,*	read clock into AQ
	cmpaq	bit_mask		set indicators
	tra	sp|tbp,*0		return
"
"	virtual clock operator.  no arguments...returns with value
"	of virtual cpu time in AQ.
"
vclock_mac:
	get_our_lp
	stx0	sp|stack_frame.return_ptr+1	setup to return directly to user prog
	sti	sp|stack_frame.return_ptr+1	save indicators
	callsp	virtual_cpu_time_op_$virtual_cpu_time_op_	invoke supervisor to do work
"
"
"	stop operator, terminates a run unit by calling stop_run
"
stop:
	eppap	sp|46			get pointer to argument list
	fld	0,dl			create null argument list
	ora	4,dl			     and insert PL/I code
	staq	sp|46
	get_our_lp
	stcd	sp|stack_frame.return_ptr	store pointer to caller
	callsp	stop_run$stop_run
"
"	return_main - terminates a run unit by calling stop_run  if the procedure is a main procedure,
"			   otherwise it performs a normal return
"
return_main:
	lda	sp|stack_frame.flag_word
	ana	stack_frame.main_proc_bit,dl
	tze	return_mac
	tra	stop
"
"	return from a begin block in a main procedure
"
begin_return_main:
	tze	return_main	skip if begin block is quick
	epbpsb	sp|0		get ptr to base of stack
	inhibit	on
	sprisp	sb|stack_header.stack_end_ptr keep updating end ptr
	eppsp	sp|stack_frame.prev_sp,* pop stack
	inhibit	off
	sbq	1,dl		count down number of blocks
	tnz	-3,ic		repeat until all done
	lda	sp|stack_frame.flag_word
	ana	stack_frame.main_proc_bit,dl	is this the first main procedure invoked in the run unit?
	tze	return_mac		no - do a normal return from a begin block
	tra	stop			yes - do a stop run
"
"	set_main_flag - sets a bit in the stack_frame if this is the first procedure in the run unit and  has options(main)
"
set_main_flag:
	epbp7	sp|0			pointer to stack_header
	lxl1	sb|stack_header.main_proc_invoked
	cmpx1	1,du			first main procedure in run unit?
	tnz	zero_main_flag		no
	orx1	=o400000,du		then this is the first main procedure
	sxl1	sb|stack_header.main_proc_invoked	indicate main procedure has been invoked
	lda	stack_frame.main_proc_bit,dl	flag stack frame of first main procedure
	orsa	sp|stack_frame.flag_word
	tra	sp|tbp,*0			return
zero_main_flag:
	lca	stack_frame.main_proc_bit+1,dl	generate mask to turn off main_proc bit
	ansa	sp|stack_frame.flag_word	indicate that this is not the first main procedure
	tra	sp|tbp,*0			return
"
"	sign operator.  entered with indicators set via load

sign_mac:	tze	sp|tbp,*0		return zero if zero
	tmi	3,ic		skip if negative
	ldq	1,dl		return +1
	tra	sp|tbp,*0		..
	lcq	1,dl		return -1
	tra	sp|tbp,*0		..
"
"	operator to transfer sign of number pointed to by bp to integer in q
"
trans_sign_fx1:
	lls	36		form abs value of Q in A
	tpl	2,ic
	neg	0
	szn	bp|0		if second number is negative
	tpl	2,ic
	neg	0		set A negative too
	lrs	36		shift back to Q
	tra	sp|tbp,*0		and return
"
"	operator to transfer sign of floating number pointed to by bp
"	to floating number in EAQ
"
trans_sign_fl:
	tpl	2,ic		set first number positive
	fneg	0
	fszn	bp|0		if second number is positive
	tpl	3,ic		value is OK
	fneg	0		otherwise, set first negative
	tra	sp|tbp,*0		and return
	fcmp	=0.0,du		restore indicators
	tra	sp|tbp,*0		and return
"
"	opearator to perform Fortran type mod function
"
fort_mdfl1:
	fszn	bp|0		return if B zero
	tze	sp|tbp,*0
	fstr	sp|temp		save A
	fdv	bp|0		form A/B
	tmi	3,ic
	fad	=71b25,du		truncate towards 0
	tra	4,ic
	fneg
	fad	=71b25,du		truncate towards 0
	fneg
	fmp	bp|0
	fneg	0
	fad	sp|temp		form A - [A/B]*B
	tra	sp|tbp,*0		and return
"
"	Fortran double precision mod
"	dmod (A,B) = A - INT(A/B) * B
"	A in eaq, bp|0 -> B, result in eaq
"
fort_dmod:
	fszn	bp|0		this only works on normalized numbers!
	tze	sp|tbp,*0		return A if B is zero
	dfstr	sp|temp		save A
	dfdv	bp|0		form A/B
	tmi	3,ic
	dfad	k71b25		truncate toward zero
	tra	4,ic
	fneg
	dfad	k71b25		truncate toward zero
	fneg
	dfmp	bp|0		form [A/B]*B
	fneg
	dfad	sp|temp		form A-[A/B]*B
	tra	sp|tbp,*0		and return it
"
"	operators to convert from fixed point to single float complex
"
rfb1_to_cflb1:
	lls	36		convert to double fixed first
	lrs	36
"
rfb2_to_cflb1:
	lde	=71b25,du		convert to float
	fad	=0.,du
	fst	sp|temp		and save
	lda	sp|temp		get real part
	ldq	=0.,du		and imag part of zero
	tra	sp|tbp,*0		and return
"
"	operator to perform complex multiplication, defined as
"	(a+ib)*(c+id) -> a*c - b*d +i(b*c + a*d)
"	entered with bp pointing at multiplier and multiplicand in AQ
"	or in complex AQ
"
mpcfl1_1:	ldaq	sp|complex	get a+ib
"
mpcfl1_2:	staq	sp|temp		and save
	fld	sp|temp+1		form b*d
	fmp	bp|1
	fst	sp|complex
	fld	sp|temp		form a*c
	fmp	bp|0
	fsb	sp|complex	form a*c - b * d
	fst	sp|complex
	fld	sp|temp		form a*d
	fmp	bp|1
	fst	sp|complex+1
	fld	sp|temp+1		form b*c
	fmp	bp|0
	fad	sp|complex+1	form b*c + a*d
	fst	sp|complex+1
	tra	sp|tbp,*0		and return
"
"	operator to perform complex division entered with
"	bp pointing at divisor, dividend in AQ or complex AQ.
"	This code, written by R. A. Barnes, is based on
"	Algorithm 116 in Collected Algorithms from CACM
"	written by Robert L. Smith from Stanford University.
"	Following is the algorithm written in pseudo PL/I
"	to do (a+ib)/(c+id) = (e+if)
"
"	if abs(c) >= abs(d)
"	then do;
"	     r = d/c;
"	     den = c + r*d;
"	     e = (a + b*r)/den;
"	     f = (b - a*r)/den;
"	     end;
"	else do;
"	     r = c/d;
"	     den = d + r*c;
"	     e = (a*r + b)/den;
"	     f = (b*r - a)/den;
"	     end;
"
dvcfl1_1:	ldaq	sp|complex	get a+ib
"
dvcfl1_2:	staq	sp|temp		and save
	fld	bp|0		get c
	fcmg	bp|1		compare with d
	tmi	dvcfl1_else
"
	fdi	bp|1		get d/c
	fst	sp|num		save as r
	fmp	bp|1		form r*d
	fad	bp|0		c + r*d
	fst	sp|temp2		save as den
	fld	sp|temp+1		get b
	fmp	sp|num		form b*r
	fad	sp|temp		a + b*r
	fdv	sp|temp2		(a + b*r)/den
	fst	sp|complex	store e
	fld	sp|temp		get a
	fmp	sp|num		form a*r
	fneg	0		- a*r
	fad	sp|temp+1		b - a*r
	fdv	sp|temp2		(b - a*r)/den
	fst	sp|complex+1	store f
	tra	sp|tbp,*0		return
"
dvcfl1_else:
	fdv	bp|1		get c/d
	fst	sp|num		save as r
	fmp	bp|0		form r*c
	fad	bp|1		d + r*c
	fst	sp|temp2		save as den
	fld	sp|temp		get a
	fmp	sp|num		form a*r
	fad	sp|temp+1		a*r + b
	fdv	sp|temp2		(a*r + b)/den
	fst	sp|complex	store e
	fld	sp|temp+1		get b
	fmp	sp|num		form b*r
	fsb	sp|temp		(b*r - a)
	fdv	sp|temp2		(b*r - a)/den
	fst	sp|complex+1	store f
	tra	sp|tbp,*0		return
"
"	operator to perform block copy.  entered
"	with block size in ql, ptr to destination in sp|temp_pt and ptr
"	to source in bp.
"
copy_words:
	qls	2		compute number of chars to move
	tze	sp|tbp,*0		skip if zero (prevent IPR)
	eppap	sp|temp_pt,*	get ptr to destination
	mlr	(ar+rl),(ar+rl)
	desc9a	bp|0,ql
	desc9a	ap|0,ql
	eppap	sp|stack_frame.operator_ptr,*
	tra	sp|tbp,*0
"
"	operator to perform block copy from even boundary to even boundary.
"	same conventions as copy_words.
"
copy_double:
	qls	1		get number of chars
	tra	copy_words+1	join copy_words case
"
"	operator to multiply single precision fixed number in q
"	by double precision fixed number pointed at by bp
"
mpfx2:	eax1	0		set for positive sign
	llr	36		shift multiplier to a
	tpl	3,ic		skip if positive
	neg	0		neg, force positive
	eax1	1		flip sign of result
	sta	sp|temp		save multiplier
	ldaq	bp|0		get multiplicand
	tpl	3,ic		skip if positive
	negl	0		neg, force positive
	erx1	1,du		flip sign of answer
	cana	=o200000,du	remember high order bit
	tze	2,ic
	orx1	2,du
	llr	1		get high order bit of q into q
	qrl	1		get zero in s bit of q
	ana	mask_bit+2	and zero in s bit of a
	sta	sp|t5		save upper half
	mpy	sp|temp		form lower product
	staq	sp|lv		save for later
	ldq	sp|t5		get upper half
	mpy	sp|temp		form upper product
	cmpa	0,dl		a should be clear
	tnz	mult_overflow
	lls	35		and shift to position
	adaq	sp|lv		add lower product
	staq	sp|lv		and save
	ldaq	bit_mask		multiply lower by high order bit
	canx1	2,du
	tze	2,ic
	ldq	sp|temp
	lls	70		shift to position (should give only 1 bit)
	trc	mult_overflow
	adaq	sp|lv		add back rest of number
	canx1	1,du		check result of answer
	tnz	3,ic		jump if -
	cmpaq	bit_mask		set indicators
	tra	sp|tbp,*0		return
	negl	0		negate
	tra	sp|tbp,*0		and return to pl/1 program
"
"	operator to multiply double precison fixed integer in aq
"	by double precsion fixed number pointed at by bp.
"
mpfx3:	eax1	0		set positive sign
	cmpa	0,du		skip if number positive
	tpl	3,ic
	negl	0		neg, force positive
	eax1	1		flip sign of answer
	cana	=o200000,du	remember high order bit
	tze	2,ic
	orx1	2,du
	llr	1		split into 2 35 bit pos numbers
	qrl	1
	ana	mask_bit+2
	sta	sp|t1		save for later
	stq	sp|t2
	ldaq	bp|0		get multplier
	tpl	3,ic		force positive
	negl	0
	erx1	1,du		and set answer sign
	cana	=o200000,du	remember high order bit
	tze	2,ic
	orx1	4,du
	llr	1		split
	qrl	1
	ana	mask_bit+2
	sta	sp|t3		save for later
	stq	sp|t4
	mpy	sp|t2		form lower product
	staq	sp|lv		and save
	ldq	sp|t3		form first upper product
	mpy	sp|t2
	cmpa	0,dl		a should be clear
	tnz	mult_overflow
	lls	35		and add to lower
	adaq	sp|lv
	staq	sp|lv		save partial answer
	ldq	sp|t1		form second upper product
	mpy	sp|t4
	cmpa	0,dl
	tnz	mult_overflow
	lls	35		shift to position
	adaq	sp|lv		add previous part
	staq	sp|lv		and save again
	ldq	sp|t3		form upper upper product
	mpy	sp|t1		which may only give one bit
	canx1	2,du
	tze	2,ic
	adq	sp|t4
	canx1	4,du
	tze	2,ic
	adq	sp|t2
	cmpa	0,dl		a should be clear
	tnz	mult_overflow
	lls	70		shift to position
	trc	mult_overflow
	adaq	sp|lv		and add it in
	canx1	1,du		should answer be neg
	tnz	3,ic		yes, jump
	cmpaq	bit_mask		set indicators
	tra	sp|tbp,*0	return
	negl	0		set minus sign
	tra	sp|tbp,*0		and return
"
mult_overflow:
	sreg	sp|save_regs
	tsx7	signal_overflow
use_first:
	lreg	sp|save_regs
	cmpaq	bit_mask		set indicators properly
	tra	sp|tbp,*0
"
"	operator to perform string range check.  entered with
"		length of string (k) in q
"		bp|0	pointing at i (2nd arg of substr)
"		bp|1	pointing at j (3rd arg of substr)
"	exit with new value of j in q
"
sr_check:
	sxl0	sp|stack_frame.operator_ret_ptr
	stq	sp|bit_lg1	save k
	ldq	bp|0		form i' = i - 1
	sbq	1,dl
	stq	bp|0		and save
	tmi	sr_2		signal if i' < 0
	cmpq	sp|bit_lg1	signal if i' >= k
	tpl	sr_2
	ldq	bp|1		get j
	tmi	sr_3		signal if j < 0
	cmpq	sp|bit_lg1	signal if j > k
	tmi	2,ic
	tnz	sr_3
	adq	bp|0		form i' + j
	cmpq	sp|bit_lg1	return if i' + j <= k
	tze	2,ic
	tpl	sr_3
	ldq	bp|1		exit with value of j
z_done:	lxl0	sp|stack_frame.operator_ret_ptr restore return offset
	stz	sp|stack_frame.operator_ret_ptr and clear record
	tra	sp|tbp,*0
"
sr_3:	tsx0	string_signal
	ldq	sp|bit_lg1	get min(k-i+1,j)
	sbq	bp|0
	cmpq	bp|1
	tmi	2,ic
	ldq	bp|1
	cmpq	0,dl		use zero if q < 0
	tpl	2,ic
	ldq	0,dl
	tra	z_done		return
"
sr_2:	tsx0	string_signal
	ldq	0,dl		use j = 0
	tra	z_done		return
"
signal_stringrange:
	sxl0	sp|stack_frame.operator_ret_ptr
	eax0	z_done		set return ptr and fall into string_signal
"
string_signal:
	stx0	sp|temp		save x0
	spribp	sp|lv		and bp
	lxl6	11,dl		get length of condition
	eppbp	strg		get ptr to condition name
	ldq	=701,dl		load oncode value
	tsx1	call_signal_	signal "stringrange"
	ldx0	sp|temp		restore x0
	eppbp	sp|lv,*		and bp
	tra	0,0		and return
strg:	aci	"stringrange"
"
"	non-local transfer operator.  entered with bp pointing
"	at destination and number of stack levels to pop in x7.
"
tra_ext_1:
	eaq	0,7		move number of levels to ql
	qrl	18
	spribp	sp|lv		save ptr to destination
	tsx1	display_chase	get ptr to stack frame
	spribp	sp|lv+2		finish the label variable
	eppbp	sp|lv		fall into unwinder_ call
"
"	non-local transfer operator.  entered with bp pointing
"	at a label variable.
"
tra_ext_2:
	spribp	sp|arg_list+2	save ptr to label var
	fld	2*1024,dl		there are 2 args
	staq	sp|arg_list	..
	eppap	sp|arg_list	get ptr to arg_list
	tsx1	get_our_lp	get ptr to our linkage
	tra	<unwinder_>|[unwinder_] go unwind stack
"
"	operator to assign auto adjustable variables at end of stack
"	frame.  entered with number of words in q, exit with pointer
"	to storage in bp.
"
alloc_auto_adj:
	eaq	15,ql		make size a multiple of 16
	anq	=o777760,du	..
	get_stack_offset
	eppbp	sp|4,*		get ptr to storage
	adlq	sp|5		get new end of stackframe
	stq	sp|stack_frame.next_sp+1 update next sp ptr
	stq	sp|stack_header.stack_end_ptr+1,au update stack end ptr also
	stq	sp|5		and set to remember this storage
	tra	sp|tbp,*0		return to caller
"
"	floating point mod operators entered with x in eaq and
"	bp pointing at y.  mod(x,y) = if y = 0 then x else x - floor(x/y)*y
"
mdfl1:	fszn	bp|0		return x if y = 0
	tze	mdfl1a
	fst	sp|temp		save x
	fdv	bp|0		divide x/y
	tmi	3,ic		get floor
	fad	=71b25,du
	tra	5,ic
	fneg
	fad	almost_one
	fad	=71b25,du
	fneg
	fmp	bp|0		form floor(x/y)*y
	fneg
	fad	sp|temp		form answer
	tra	sp|tbp,*0		and return
mdfl1a:	fcmp	=0.0,du		set indicators properly
	tra	sp|tbp,*0
"
mdfl2:	dfst	sp|temp		save x
	dfld	bp|0		get y
	tze	mdfl2a		return x if y = 0
	dfdi	sp|temp		divide x/y
	tmi	3,ic		form floor
	dfad	k71b25
	tra	5,ic
	fneg
	dfad	almost_one
	dfad	k71b25
	fneg
	dfmp	bp|0		form floor(x/y)*y
	fneg
mdfl2a:	dfad	sp|temp		form answer
	tra	sp|tbp,*0		and return
"
"	real truncation operator
"
trunc_fl:
	tmi	3,ic
	fad	=71b25,du
	tra	sp|tbp,*0
	fneg
	fad	=71b25,du
	fneg
	tra	sp|tbp,*0
"
"	single precision fixed truncate, entered with scale in x2
"
trunc_fx1:
	cmpq	0,dl
	tmi	3,ic
	qrs	0,2
	tra	sp|tbp,*0
	stq	sp|temp
	lcq	sp|temp
	qrs	0,2
	stq	sp|temp
	lcq	sp|temp
	tra	sp|tbp,*0
"
"	double precision fixed truncate, entered with scale in x2
"
trunc_fx2:
	cmpaq	bit_mask
	tmi	3,ic
	lrs	0,2
	tra	sp|tbp,*0
	negl
	lrs	0,2
	negl
	tra	sp|tbp,*0
"
"	operators to do floating point floor and ceiling functions
"	these use the relations
"		floor(-x) = -ceil(|x|)
"		ceil(-x) = -floor(|x|)
"
floor_fl:
	tmi	3,ic
	fad	=71b25,du
	tra	sp|tbp,*0
	fneg
	dfad	almost_one
	fad	=71b25,du
	fneg
	tra	sp|tbp,*0
"
ceil_fl:
	tmi	4,ic
	dfad	almost_one
	fad	=71b25,du
	tra	sp|tbp,*0
	fneg
	fad	=71b25,du
	fneg
	tra	sp|tbp,*0
"
"	operators to do single precision fixed floor and ceiling functions
"	entered with argument in q register and scale in index 2

floor_fx1:
	cmpq	0,dl
	tmi	3,ic
	qrs	0,2
	tra	sp|tbp,*0
	stq	sp|temp
	lcq	sp|temp
	cmpx2	36,du
	tmoz	3,ic
	adq	floor_ceil_mask+36
	tra	2,ic
	adq	floor_ceil_mask,2
	qrs	0,2
	stq	sp|temp
	lcq	sp|temp
	tra	sp|tbp,*0
"
ceil_fx1:
	cmpq	0,dl
	tmi	8,ic
	cmpx2	36,du
	tmoz	3,ic
	adq	floor_ceil_mask+36
	tra	2,ic
	adq	floor_ceil_mask,2
	qrs	0,2
	tra	sp|tbp,*0
	stq	sp|temp
	lcq	sp|temp
	qrs	0,2
	stq	sp|temp
	lcq	sp|temp
	tra	sp|tbp,*0
"
"	operators do double precision fixed floor and ceiling functions
"	entered with argument in aq register, scale in index 2, and -2*scale
"	in index 3
"
floor_fx2:
	cmpaq	bit_mask
	tmi	3,ic
	lrs	0,2
	tra	sp|tbp,*0
	negl
	cmpx3	-144,du
	tpl	3,ic
	adaq	mask_bit
	tra	2,ic
	adaq	mask_bit+144,3
	lrs	0,2
	negl
	tra	sp|tbp,*0
"
ceil_fx2:
	cmpaq	bit_mask
	tmi	8,ic
	cmpx3	-144,du
	tpl	3,ic
	adaq	mask_bit
	tra	2,ic
	adaq	mask_bit+144,3
	lrs	0,2
	tra	sp|tbp,*0
	negl
	lrs	0,2
	negl
	tra	sp|tbp,*0
"
"	operator to round single fixed binary
"	entered with (scale - k) in index 7
"
round_fx1:
	cmpq	0,dl		set indicators
	tmi	round_fx1b	skip if negative
	eax1	0		remember was positive
round_fx1a:
	stq	sp|temp		save abs(arg)
	ldq	1,dl		form 1/2 at proper scale
	qls	-1,7
	adq	sp|temp		add abs(arg)
	qrs	0,7		drop bits to right
	cmpx1	0,du		was arg positive
	tze	sp|tbp,*0		yes, can return
	stq	sp|temp		arg was negative, negate result
	lcq	sp|temp
	tra	sp|tbp,*0		before returning
round_fx1b:
	stq	sp|temp		get abs(arg)
	lcq	sp|temp
	eax1	1		remember arg was negative
	tra	round_fx1a	and join positive case
"
"	operator to round double fixed binary
"	entered with (scale - k) in index 7
"
round_fx2:
	cmpaq	bit_mask		set indicators
	tmi	round_fx2b	skip if negative
	eax1	0		remember arg was positive
round_fx2a:
	staq	sp|temp		save abs(arg)
	ldaq	one		form 1/2 at proper scale
	lls	-1,7
	adaq	sp|temp		add abs(arg)
	lrs	0,7		drop bits to right
	xec	sign_change,1	put back proper sign
	tra	sp|tbp,*0		and return
round_fx2b:
	negl	0		take abs(arg)
	eax1	1		remember arg was negative
	tra	round_fx2a	join positive case
"
"	operator to compute round(x,k) for floating point values.
"	entered with x in eaq and k immediately following tsx0
"
round_fl:
	eax1	0		assume sign +
	eppbp	sp|tbp,*0		get ptr to K in lhs
	fcmp	=0.0,du
	tze	bp|1		return if 0
	tpl	3,ic
	fneg	0		get abs value
	eax1	1
	ldx0	bp|0		load k
	dfst	sp|temp		save value
	lda	=o200000,du	get bit in proper position
	ldq	0,dl
	lrs	0,0		shift
	dfad	sp|temp		perform rounding
	adx0	bp|0		get 2*k
	anaq	bit_mask+2,0	erase low order bits
	xec	fl_sign_change,1	put back correct sign
	tra	bp|1		and return
"
fl_sign_change:
	nop	0
	fneg	0
"
"	Operator to round a floating point number to the nearest whole
"	number.  Entered with value in EAQ and indicators set.  Result in
"	EAQ.
"
nearest_whole_number:
	tmi	nearest_whole_negative
	fad	=0.5,du
	fad	=71b25,du
	tra	sp|tbp,*0

nearest_whole_negative:
	fneg
	fad	=0.5,du
	fad	=71b25,du
	fneg
	tra	sp|tbp,*0
"
"	Operator to round a floating point number to the nearest integer.
"	Entered with value in EAQ and indicators set.  Result in Q.
"
nearest_integer:
	tmi	nearest_integer_negative
	fad	=0.5,du
	ufa	=71b25,du
	tra	sp|tbp,*0

nearest_integer_negative:
	fneg
	fad	=0.5,du
	ufa	=71b25,du
	negl
	tra	sp|tbp,*0

"	Operator to convert a long bit string to double precision fixed binary.
"	Entered with bit string previously setup.

longbs_to_fx2:
	epp2	sp|temp_pt,*	" pr2 = ptr to string
	ldq	sp|bit_lg1	" q = length of string in bits
	stz	sp|temp		" clear high order bit of result
	csr	(pr,rl),(pr),bool(move),fill(0)
	descb	pr2|0,ql
	descb	sp|temp(1),71
	trtf	longbs_to_fx2_short	" Was string longer than 71 bits?
	sbq	71,dl		" Yes: Remove last 71 bits from string length
	cmpb	(pr,rl),(),fill(0)	" Make sure the leading bits are zero.
	descb	pr2|0,ql
	descb	0,0
	tnz	signal_size_condition
longbs_to_fx2_short:
	ldaq	sp|temp		" aq = result
	tra	sp|tbp,*x0	" return

"	Operator to convert a long bit string to bit 18 (used for ptr built-ins).
"	Entered with bit string previously setup.

longbs_to_bs18:
	epp2	sp|temp_pt,*	" pr2 = ptr to string
	lda	sp|bit_lg1	" a = length of string in bits
	csl	(pr,rl),(pr),bool(move),fill(0)
	descb	pr2|0,al
	descb	sp|temp,18
	lda	sp|temp		" au = first 18 bits of string
	anaq	bit_mask+2*18	" al, q = 0
	tra	sp|tbp,*x0	" return

"	operator to convert a packed (single word) ptr to unpacked (its)
"	enter with packed pointer in q, exit with its pair in aq
"
pk_to_unpk:
	stq	sp|lv		save packed ptr
	spribp	sp|temp2
	lprpbp	sp|lv		load packed ptr (get ring no right)
	spribp	sp|save_regs		store as unpacked ptr
	ldaq	sp|save_regs		load ITS pair into aq
	eppbp	sp|temp2,*	restore original bp
	tra	sp|tbp,*0
"
"	operator to convert an unpacked (its) ptr to packed (single word)
"	enter with its pair in aq, exit with packed pointer in q
"
unpk_to_pk:
	arl	18
	lls	18
	qls	3
	lrl	30
	qlr	30
	tra	sp|tbp,*0
"
"	operator to load the packed pointer in q register into bp register
"
packed_to_bp:
	stq	sp|temp
	lprpbp	sp|temp
	tra	sp|tbp,*0		and return
"
"	The following operators are used to move a block of <= 256 elements
"	They are entered with lp and bp pointing to source and destination
"	and au holding value for x0 during rpd loop.
"
"	Single word items, lp -> source, bp -> destination
"
	odd			"to force rpd odd
rpd_odd_lp_bp:
	sxl0	sp|stack_frame.operator_ret_ptr
	eax0	rpd_bits,au	init rpd loop
	eax1	0
	eax2	0
	rpdx	0,1
	lda	lp|0,1
	sta	bp|0,2
	tra	z_done		return
"
"	Single word items, bp -> source, lp -> destination
"
	odd			"to force rpd odd
rpd_odd_bp_lp:
	sxl0	sp|stack_frame.operator_ret_ptr
	eax0	rpd_bits,au
	eax1	0
	eax2	0
	rpdx	0,1
	lda	bp|0,1
	sta	lp|0,2
	tra	z_done		return
"
"	Double word items, lp -> source, bp -> destination
"
	odd			"to force rpd odd
rpd_even_lp_bp:
	sxl0	sp|stack_frame.operator_ret_ptr
	eax0	rpd_bits,au	init rpd loop
	eax1	0
	eax2	0
	rpdx	0,2
	ldaq	lp|0,1
	staq	bp|0,2
	tra	z_done		return
"
"	Double word items, bp -> source, lp -> destination
"
	odd			"to force rpd odd
rpd_even_bp_lp:
	sxl0	sp|stack_frame.operator_ret_ptr
	eax0	rpd_bits,au	init rpd loop
	eax1	0
	eax2	0
	rpdx	0,2
	ldaq	bp|0,1
	staq	lp|0,2
	tra	z_done		return
"
" 
"	The following macro is the trace macro.  It contains the calling
"	sequence to trace.
"
	macro	trace
	ife	&1,trace_
	epaq	*		get segment number of pl1_operators_
	lprplp	sb|stack_header.lot_ptr,*au 	get our linkage ptr
	sprpbp	sb|stack_header.stack_end_ptr,* save entry ptr as packed ptr
	eppbp	sb|stack_header.stack_end_ptr,*
	sprpab	bp|1		save lisp linkage ptr (might be lisp environment)
	tspbp	trace_catch_$catch_pl1_
	eppab	sb|stack_header.stack_end_ptr,*
	lprpbp	ab|0		restore entry ptr
	lprpab	ab|1		restore lisp linkage ptr
ifend
	&end
" 
" Macro to generate the ALM entry operator with or without the calling sequence for
" trace_catch_$catch_pl1_.  When the ALM entry operator with the calling sequence for
" trace is invoked it will allow trace to meter the ALM program and print its arguments
" on entrance and exit.  (P. Krupp 09/20/77)

          macro     alm_entry_op
"         BEGIN MACRO alm_entry_op
&1alm_entry:
          eppbp     bp|-1               generate pointer to entry structure
	trace	&1
	epplp	sb|stack_header.stack_end_ptr,* get a pointer to the next stack frame
	spribp	lp|stack_frame.entry_ptr
	epaq	bp|0		get seg no of object in a
	lprplb	sb|stack_header.isot_ptr,*au get packed ptr to static from isot
	sprplb	lp|stack_frame.static_ptr save in next stack frame
	lprplp	sb|stack_header.lot_ptr,*au get packed ptr to linkage from lot
	tra	bp|1		return to alm prog
"         END MACRO alm_entry_op
          &end

"	The following operators are used by ALM
"	The order of the following operators must be maintained because of
"	coding of default_error_handler_
"
alm_operators_begin:
alm_call:
	sprilp	sp|stack_frame.return_ptr save return pointer
	sti	sp|stack_frame.return_ptr+1	save indicators
	epplp	sp|stack_frame.lp_ptr,* set up our lp
	callsp	bp|0		do the call
"
alm_push:
	spribp	sb|stack_header.stack_end_ptr,* save return from operator
	eppbp	sb|stack_header.stack_end_ptr,* get pointer to new stack frame
	sprisp	bp|stack_frame.prev_sp save previous ptr in new frame
	spriap	bp|stack_frame.arg_ptr save argument ptr
	sprilp	bp|stack_frame.lp_ptr save linkage ptr
	eppsp	bp|0		move up to new frame
	eppbp	sp|0,7		get pointer to end of this new frame
	spribp	sb|stack_header.stack_end_ptr and update stack end pointer
	spribp	sp|stack_frame.next_sp and set next sp of new frame
	eax7	1		set ALM translator ID for debugging
	stx7	sp|stack_frame.translator_id
	tra	sp|0,*		return to alm program
"
          alm_entry_op
"
alm_return:
	inhibit	on
	sprisp	sb|stack_header.stack_end_ptr update stack end ptr
	eppsp	sp|stack_frame.prev_sp,* pop stack
	inhibit	off
	epbpsb	sp|0		set up stack base in case we just switched stacks
	eppap	sp|stack_frame.operator_ptr,* set op ptr of frame being returned to
	ldi	sp|stack_frame.return_ptr+1	restore indicators for caller
	rtcd	sp|stack_frame.return_ptr return to calling program
"
alm_return_no_pop:
	epbpsb	sp|0		set up stack base in case returning to outer ring
	eppap	sp|stack_frame.operator_ptr,* set up operator ptr of frame being returned to
	ldi	sp|stack_frame.return_ptr+1	restore indicators for caller
	rtcd	sp|stack_frame.return_ptr return to calling program
"
alm_operators_end:
" 
"
"	operator to check size condition for single fixed binary
"	entered with number in q and -precision in x7
"	Registers modified: none
"
"	Algorithm: If a number is in range then all of the high order bits
"	that are in the word but aren't in the precision range should not
"	contain any useful information. IE they should all be zeros for
"	positive numbers and all ones for negative numbers.
"
"	If we left shift out all of the higher order bits, then the carry
"	flag is set if any of these bits change.
"
size_check_fx1:
	staq	sp|temp		save AQ
          sti       sp|temp_indicators  save indicators
          qls       35,x7        	sample upper bits (35-precision)
"				C set if removed bits not all 0 or 1
	tnc	size_ok_fx	restore & return

signal_size_condition:
	spribp	sp|double_temp
	eppbp	size_name		get ptr to name of condition
	stx6	sp|temp2		save x6
	eax6	size_length	and load size
	ldq	=703,dl		load oncode value
ssc:	sxl0	sp|stack_frame.operator_ret_ptr save return offset
	tsx1	call_signal_
	ldx6	sp|temp2		restore x6
	eppbp	sp|double_temp,*	restore bp
	lxl0	sp|stack_frame.operator_ret_ptr
	stz	sp|stack_frame.operator_ret_ptr
size_ok_fx:
	ldaq	sp|temp		restore AQ
	ldi	sp|temp_indicators  restore indicators
	tra	sp|tbp,*0		and return
"
"	operator to check size condition for double fixed binary
"	entered with number in aq and -2*precision in x7
"	Registers modified: none
"
size_check_fx2:
	staq	sp|temp		save AQ
	sti	sp|temp_indicators  save indicators
	stx7	sp|temp_indicators  save -2*precision, want -precision
	eaa	0,x7		cannot divide an Xreg, so use A
	ars	1		divide -2*precision by 2
	eax7	0,au		x7 now contains -precision
	lda	sp|temp		restore A (original)
	lls	71,x7		sample upper bits (71-prec)
"				C set if removed bits not all 0 or 1
	ldx7	sp|temp_indicators  restore x7 
	trc	signal_size_condition	if C set : |num| too big
	ldaq	sp|temp		restore AQ
	ldi	sp|temp_indicators  restore indicators
	tra	sp|tbp,*0		and return
"
"	operator to check size condition for unsigned single fixed binary
"	entered with number in q and -precision in x7
"	Registers modified: none
"
size_check_uns_fx1:
	staq	sp|temp		save AQ
	sti	sp|temp_indicators  save indicators
	cmpq	mask_bit_one+36,x7	check against table of max values
	tnc	size_ok_fx	magnitude less than max value
	tnz	signal_size_condition	greater than max value
	tra	size_ok_fx	equal to max value

"
"	operator to check size condition for unsigned double fixed binary
"	entered with number in aq and -2*precision in x7
"	Registers modified: none
"
size_check_uns_fx2:
	staq	sp|temp		save AQ
	sti	sp|temp_indicators  save indicators
	cmpaq	mask_bit+144,x7	check against table of max values
	tnc	size_ok_fx	magnitude less than max value
	tnz	signal_size_condition	greater than max value
	tra	size_ok_fx	equal to max value
"				
"	operator to check if result of an 'mpy' exceeds one word.
"	entered with result of 'mpy' in AQ.
"
mpy_overflow_check:
	staq	sp|temp		save AQ
	sti	sp|temp_indicators	save indicators
	lls	36		sets carry flag if result too big
	tnc	size_ok_fx	restore & return
	spribp	sp|double_temp	signal "fixedoverflow"
	eppbp	overflow_name
	stx6	sp|temp2
	eax6	overflow_length
	ldq	=711,dl
	tra	ssc
"
"	operator to signal "size" condition
"
signal_size:
	staq	sp|temp
	tra	signal_size_condition
"
size_name:
	aci	"size"
	equ	size_length,4
"
"	operator to signal "stringsize" condition
"
signal_stringsize:
	staq	sp|temp
	spribp	sp|double_temp
	stx6	sp|temp2
	eppbp	stringsize_name
	eax6	stringsize_length
	ldq	=702,dl
	tra	ssc
"
stringsize_name:
	aci	"stringsize"
	equ	stringsize_length,10
"
"	operator to request fortran external storage allocation and/or 
"	     initialization.
"
fort_storage:
	spri6	sp|double_temp	stack frame pointer
	epp2	sp|double_temp
	spri2	sp|arg_list+2	argument 1 - stack pointer
	epp2	sp|linkage_ptr	 linkage pointer
	spri2	sp|arg_list+4	argument 2 - linkage pointer
	epp2	sp|tbp,*0		text pointer to arg_list
	spri2	sp|temp_pt
	epp2	sp|temp_pt
	spri2	sp|arg_list+6	argument 3 - argument pointer
	lda	6,du		nargs = 3, quick call (no enviptr)
	ldq	0,dl		no descriptors
	staq	sp|arg_list
	epp0	sp|arg_list	get argument list header
	adx0	1,du
	stx0	sp|stack_frame.return_ptr+1	save return point
	sti	sp|stack_frame.return_ptr+1	save indicators
	tsx1	get_our_lp
	callsp	fortran_storage_$create
"
"	operator to enable a condition.  calling sequence is:
"		eppbp	name
"		lxl6	name_size
"		tsx0	ap|enable
"		tra	on_unit_body
"		arg	on_unit	(snap & system flags in RHS if used)
"		tra	skip_around_body
"	body of on unit starts here
"
	include	on_unit
enable_op:
	sxl0	sp|stack_frame.operator_ret_ptr
	epplp	sp|tbp,*0
	lda	=o100,dl		is there a valid on_unit_list
	cana	sp|stack_frame.prev_sp check bit 29 of sp|stack_frame.prev_sp
	tnz	3,ic		non-zero means ok
	stz	sp|stack_frame.on_unit_rel_ptrs init ptr
	orsa	sp|stack_frame.prev_sp and set bit
"
	ldx1	sp|stack_frame.on_unit_rel_ptrs get rel ptr to first enabled unit
	tze	add_on		zero means chain empty
on_1:	cmpx1	lp|1		is this the unit we want
	tze	have_on		yes, go process
	ldx1	sp|on_unit.next,1	no, get ptr to next on chain
	tnz	on_1		and repeat if end not reached
add_on:	ldx1	lp|1		get rel ptr to new unit
	ldx0	sp|stack_frame.on_unit_rel_ptrs get rel ptr to first unit
	stx0	sp|on_unit.next,1	set next ptr of new unit
	stx1	sp|stack_frame.on_unit_rel_ptrs make new unit first on chain
have_on:	spribp	sp|on_unit.name,1	set name of new unit
	sprilp	sp|on_unit.body,1	set ptr to body
	stz	sp|on_unit.size,1	clear size field
	sxl6	sp|on_unit.size,1	set size of unit name
	lxl0	lp|1		get snap & system flags
	sxl0	sp|on_unit.flags,1	and save in on unit
	stz	sp|stack_frame.operator_ret_ptr
	tra	lp|2		return to pl1 program
"
"
"	operator to create and enable a cleanup handler for a fortran
"	program.  calling sequence is:
"		tsx0	ap|fort_cleanup
"		arg	on_unit_body 	(snap & system flags in RHS if used)
"	Uses pr2 (bp) and pr4 (lp) - restores pr4 (lp) from stack
"
fort_cleanup:
	sxl0	sp|stack_frame.operator_ret_ptr
	eppbp	sp|tbp,*0
	lda	=o100,dl		is there a valid on_unit_list
	cana	sp|stack_frame.prev_sp check bit 29 of sp|stack_frame.prev_sp
	tnz	3,ic		non-zero means ok
	stz	sp|stack_frame.on_unit_rel_ptrs init ptr
	orsa	sp|stack_frame.prev_sp and set bit
"
	ldx1	sp|stack_frame.on_unit_rel_ptrs get rel ptr to first enabled unit
	tze	add_fort_cleanup	zero means chain empty
fort_cleanup_1:
	cmpx1	bp|0		is this the unit we want
	tze	have_fort_cleanup	yes, go process
	ldx1	sp|on_unit.next,1	no, get ptr to next on chain
	tnz	fort_cleanup_1	and repeat if end not reached
add_fort_cleanup:
	ldx1	bp|0		get rel ptr to new unit
	ldx0	sp|stack_frame.on_unit_rel_ptrs get rel ptr to first unit
	stx0	sp|on_unit.next,1	set next ptr of new unit
	stx1	sp|stack_frame.on_unit_rel_ptrs make new unit first on chain
have_fort_cleanup:
" Point to our cleanup handler and our name and length
	epplp	fort_cleanup_name
	sprilp	sp|on_unit.name,1	set name of new unit
	get_our_lp			" need our linkage section
	epplp	<fort_cleanup_>|[fort_cleanup_]
	sprilp	sp|on_unit.body,1	set ptr to body
	epplp	sp|linkage_ptr,*	restore ptr to linkage segment
	lxl0	fort_cleanup_length,dl
	stz	sp|on_unit.size,1	clear size field
	sxl0	sp|on_unit.size,1	set size of unit name
	lxl0	bp|0		get snap & system flags
	sxl0	sp|on_unit.flags,1	and save in on unit
	stz	sp|stack_frame.operator_ret_ptr
	tra	bp|1		return to fortran program

fort_cleanup_name:
	aci	"cleanup"

	equ fort_cleanup_length,7

"
"	operator to signal a condition.  entered with ptr to name in bp
"	and size of name in x6.
"
signal_op:
	sxl0	sp|stack_frame.operator_ret_ptr
	ldq	=1000,dl		load oncode value
	tsx1	call_signal_	call signal_
	tra	z_done		and return
"
"	operator to signal "subscriptrange" condition
"
bound_ck_signal:
	sxl0	sp|stack_frame.operator_ret_ptr
	stx6	sp|temp		save x6
	lxl6	14,dl		get size of condition
	eppbp	subrg		get ptr to name
	ldq	=704,dl		load oncode value
	tsx1	call_signal_	call signal_
	ldx6	sp|temp		restore x6
	tra	z_done		and return
subrg:	aci	"subscriptrange"
"
"	operator to enable a condition with file specified, usage is
"		eppbp	file
"		eaa	name	(in text)
"		ora	flags,dl	snap & system flags (optional)
"		lxl6	name_size
"		tsx0	ap|enable_file
"
enable_file:
	sxl0	sp|stack_frame.operator_ret_ptr save return point
	spribp	sp|temp		save pointer to file
	eppbp	sp|tbp,*au	get pointer to name
	sta	sp|double_temp	save snap & system flags
	lda	=o100,dl		check for existence of condition list
	cana	sp|stack_frame.condition_word
	tnz	ef_1		if we have list, go check it
	stz	sp|stack_frame.on_unit_rel_ptrs no list, initialize it
	orsa	sp|stack_frame.condition_word ..
"
make_unit:
	get_stack_offset
	epplp	sp|stack_header.stack_end_ptr,au* get ptr to next stack frame
	eax0	16		extend stack by 16 words
	adlx0	sp|stack_frame.next_sp+1	..
	stx0	sp|stack_frame.next_sp+1	..
	stx0	sp|stack_header.stack_end_ptr+1,au	..
	stx0	sp|5		make extension "permanent"
	eax1	lp|0,au		into x1
"
	ldx0	sp|stack_frame.on_unit_rel_ptrs get rel ptr to first unit
	stx0	sp|on_unit.next,1	and save as next of new unit
	stx1	sp|stack_frame.on_unit_rel_ptrs make new unit first unit
"
	spribp	sp|on_unit.name,1	save ptr to name
	epplp	sp|temp,*		get back ptr to file
	ldaq	lp|0		copy file into stack
	staq	sp|on_unit.file_copy,1
	ldaq	lp|2
	staq	sp|on_unit.file_copy+2,1
	epplp	sp|on_unit.file_copy,1	get ptr to copy of file
	sprilp	sp|on_unit.file,1	and save as ptr to file
	stz	sp|on_unit.size,1	clear size field
"
init_unit:
	sxl6	sp|on_unit.size,1	set size of name
	lxl0	sp|double_temp	get snap & system flags
	sxl0	sp|on_unit.flags,1	store them
	lxl0	sp|stack_frame.operator_ret_ptr restore return
	stz	sp|stack_frame.operator_ret_ptr
	epplp	sp|tbp,*0		get ptr to entry point of unit
	sprilp	sp|on_unit.body,1	and save it
	tra	lp|1		and then return
"
ef_1:	tsx0	find_unit		go search for unit
	tra	init_unit		found it
	eppbp	sp|temp2,*	restore ptr to name
	tra	make_unit		not found, must go make it
"
"	operator to revert a condition with file specified, usage is
"		eppbp	file
"		eaa	name	(in text)
"		lxl6	name_size
"		tsx0	ap|revert_file
"
revert_file:
	ldq	=o100,dl		do we have any conditions enabled
	canq	sp|stack_frame.condition_word
	tze	sp|tbp,*0		no, return immediately
	sxl0	sp|stack_frame.operator_ret_ptr yes, save return
	spribp	sp|temp		save  pointer to file
	eppbp	sp|tbp,*au	get ptr to name
	tsx0	find_unit		go search for unit
	stz	sp|on_unit.size,1	found it, zero size
	tra	z_done		ok to return now
"
"	subroutine to search for enabled condition, entered with
"		bp	pointing at name in text
"		x6	holding size of name
"		sp|temp	holding ptr to file
"	returns	0,0	if condition found
"		1,0	if condition not found
"
"	N.B. we assume that we only have to compare ptrs to check if name
"	is the same because of constant pooling done by compiler
"
find_unit:
	spribp	sp|temp2		save ptr to name
	eppbp	sp|temp,*		get ptr to file
	ldx1	sp|stack_frame.on_unit_rel_ptrs get offset of first unit
	tra	2,ic		and enter loop
"
fu_1:	ldx1	sp|on_unit.next,1	get off of next unit
	tze	1,0		none means we failed
	ldaq	sp|on_unit.name,1	get name in on unit
	cmpaq	sp|temp2		compare with name we want
	tnz	fu_1		if not same keep looking
	ldaq	sp|on_unit.file_copy+2,1	get second ptr in file
	cmpaq	bp|2		compare with file we want
	tnz	fu_1		keep looking if different
	tra	0,0		found it
"
"	operators for put data
"	entered with pointer to datum in bp, offset in x7, symtab offset in a
"
put_data_eis:
	eax6	2		set procedure to call
	tra	plio_eis		join common section
"
put_data:
	eax1	0,7		get offset
	tra	pd_1
"
put_data_co:
	ldx1	co_to_bo,7	convert offset to bits
	tra	pd_1
"
put_data_ho:
	ldx1	ho_to_bo,7	convert offset to bits
	tra	pd_1
"
put_data_aligned:
	eax1	0		zero offset
"
pd_1:	eax6	2		set procedure to call
	tra	plio		join common section
"
"	operators for get list
"	entered with pointer to datum in bp, offset in x7, descriptor in q
"
get_list_eis:
	eax6	3		set procedure to call
	tra	plio_eis		join common section
"
get_list:
	eax1	0,7		get offset
	tra	gl_1
"
get_list_co:
	ldx1	co_to_bo,7	convert offset to bits
	tra	gl_1
"
get_list_ho:
	ldx1	ho_to_bo,7	convert offset to bits
	tra	gl_1
"
get_list_aligned:
	eax1	0		zero offset
"
gl_1:	eax6	3		set procedure to call
	tra	plio		join common section
"
"	operators for get edit
"	entered with pointer to datum in bp, offset in x7, descriptor in q
"
get_edit:
	eax1	0,7		get offset
	tra	ge_1
"
get_edit_co:
	ldx1	co_to_bo,7	convert offset to bits
	tra	ge_1
"
get_edit_ho:
	ldx1	ho_to_bo,7	convert offset to bits
	tra	ge_1
"
get_edit_aligned:
	eax1	0		zero offset
"
ge_1:	eax6	4		set procedure to call
	tra	plio		join common section
"
"
"
"	operator for put list
"	entered with pointer to datum in bp, offset in x7, descriptor in q
"
put_list_eis:
	eax6	5		set procedure to call
	stq	sp|temp		save descriptor
	anq	=o374000,du
	cmpq	=o114000,du	bit_str_desc
	tze	<put_field_>|[put_field_str]
	cmpq	=o120000,du	var_bit_str_desc
	tze	<put_field_>|[put_field_str]
	cmpq	=o124000,du	char_str_desc
	tze	<put_field_>|[put_field_str]
	cmpq	=o130000,du	var_char_str_desc
	tze	<put_field_>|[put_field_str]
	ldq	sp|temp
"
plio_eis:
	eppap	sp|ps_ptr,*	get ptr to ps
	stq	ap|ps.descriptor	set descriptor
	sta	ap|ps.offset	store offset or picture constant loc
	spribp	ap|ps.value_p	set ptr to datum
	tra	plio4
"
put_list:
	eax1	0,7		get offset
	tra	pl_1
"
put_list_co:
	ldx1	co_to_bo,7	convert offset to bits
	tra	pl_1
"
put_list_ho:
	ldx1	ho_to_bo,7	convert offset to bits
	tra	pl_1
"
put_list_aligned:
	eax1	0		zero offset
"
pl_1:	eax6	5		set procedure to call
	tra	plio		join common section
"
"	operators for put edit
"	entered with pointer to datum in bp, offset in x7, descriptor in q
"
put_edit:
	eax1	0,7		get offset
	tra	pe_1
"
put_edit_co:
	ldx1	co_to_bo,7	convert offset to bits
	tra	pe_1
"
put_edit_ho:
	ldx1	ho_to_bo,7	convert offset to bits
	tra	pe_1
"
put_edit_aligned:
	eax1	0		zero offset
"
pe_1:	eax6	6		set procedure to call
"
plio:	eppap	sp|ps_ptr,*	get ptr to ps
	stq	ap|ps.descriptor	set descriptor
	sta	ap|ps.offset	store offset or picture constant loc
	spribp	ap|ps.value_p	set ptr to datum
	lxl1	shift_bo,1	shift bit offset to position
	sxl1	ap|ps.value_p+1	and set bit offset of pointer
"
plio4:	eppbp	sp|ps_ptr		save pointer to ps as arg
	spribp	sp|arg_list+2
	sreg	sp|8		save registers
	fld	2*1024,dl
	staq	sp|arg_list
	eppap	sp|arg_list	get ptr to arg list
	tsx1	get_our_lp	get ptr to our linkage section
	epp1	4,ic		store return address and indicators
	spri1	sp|stack_frame.return_ptr
	sti	sp|stack_frame.return_ptr+1
	tra	plio2,6		jump to appropriate proc
	lreg	sp|8		restore registers
put_return:
	eppap	sp|tbp,*		get ptr to object
	spriap	sp|stack_frame.return_ptr	reset return ptr
	eppap	sp|stack_frame.operator_ptr,*	restore ptr to operators
	tra	sp|tbp,*0		and return
"
plio2:	callsp	<plio2_>|[get_terminate_]
	callsp	<plio2_>|[put_terminate_]
	callsp	<plio2_>|[put_value_data_]
	callsp	<plio2_>|[get_value_list_]
	tra	signal_error_missing
	callsp	<plio2_>|[put_value_list_]
	callsp	<plio2_>|[put_value_edit_]
	callsp	<plio2_recio_>|[plio2_recio_]
	callsp	<plio2_>|[open_explicit_]
	callsp	<plio2_>|[close_]
	callsp	<plio2_>|[get_prep_]
	callsp	<plio2_>|[put_prep_]
	callsp	<fortran_io_>|[read_or_write]
	callsp	<fortran_io_>|[file_control]
	callsp	<fortran_io_>|[terminate]
	callsp	<fortran_io_>|[element]
	callsp	<plio2_>|[put_field_]
	tra	signal_error_missing
	tra	signal_error_missing
	tra	signal_error_missing
	tra	signal_error_missing
	callsp	<plio2_>|[put_blanks_]
	callsp	<fortran_io_>|[get_io_area_ptr]
"
"	operator to terminate a get
"
get_terminate:
	eax6	0		set proc to call
	tra	plio4
"
"	operator to terminate a put
"
put_terminate:
	eax6	1		set proc to call
	tra	plio4
"
"	operator to open a file
"
open_file:
	eax6	8		set proc to call
	tra	plio4
"
"	operator to close a file
"
close_file:
	eax6	9		set proc to call
	tra	plio4
"
"	operators for doing FORTRAN I/O
"
"		WARNING   WARNING   WARNING   WARNING   WARNING   WARNING
"
"	     The following code was modified on 19 Dec 1977, by D. Levin to allow
"	fortran I/O's stack frame to remain active after control returns to the user's
"	program. This is accomplished by a coordinated effort on the parts of:
"
"		1. this operator segment
"		2. fortran_io_.pl1 (in bound_fort_runtime_)
"		3. return_to_user.alm (in bound_fort_runtime_)
"
"	     The first time a user program references fortran_io_ from its stack frame,
"	the high-order bit of stack_frame.ps_ptr is zero. This implementation takes advantage
"	of that fact and uses the high-order bit of stack_frame.ps_ptr as a flag to
"	indicate whether or not a stack frame exists for fortran_io_.
"
"	     The first time fortran_io_ is referenced from a stack frame, the high-order
"	bit is zero, so a standard PL/I call is made to the appropriate entry point in
"	fortran_io_, with the user's stack_frame.return_ptr set to return
"	to the word after the operator call.  Once within fortran_io_, the
"	user's stack frame is modified as follows:
"
"	     1. Copy fortran_io_'s stack_frame|4 to the user's frame. This field is used
"		by PL/I to determine the true end of the stack frame after a stack
"		extension.
"	     2. Store a packed ptr to fio_ps at stack_frame.support_ptr. See next
"		paragraph.
"	     3. Set high-order bit of stack_frame.ps_ptr to "1"b.
"
"	     The structure "fio_ps" is in fortran_io_'s stack frame and contains all the
"	necessary fields to allow communication between the user program and fortran_io_.
"	It includes:
"	     1. The address of a location within fortran_io_ to which control is passed
"		instead of performing a PL/I call.
"	     2. The address of fortran_io_'s stack frame.
"	     3. The address of a variable in fortran_io_'s stack frame into which the value
"		of xr7 is stored. This value identifies the entry point desired.
"
"	     When fortran_io_ returns to the user program, return_to_user$special_return
"	is called. This routine copies fortran_io_'s stack_frame.next_sp into the user's
"	stack_frame.next_sp, sets sp to the user's frame, and does a short_return.
"	Fortran_io_'s stack frame is now part of the user's frame and remains so until
"	the next I/O operation. Each fortran program frame has its own fortran_io_ frame.
"	This causes the user frame to "absorb" fortran_io_'s frame.
"
"	NOTE - The procedure fortran_io_ must never perform a return_mac or
"	fortran_io_'s frame will go away although the flag in the user's frame claims
"	that it is still there.
"
"	Setup operators entered with unit number in q, job_bits in a. Read previous page
"	of comments before modifying any FORTRAN I/O operators.
"
fortran_read:
fortran_write:
	eax6	12
"
ft_io:	szn	sp|ps_ptr			" <0 if fortran_io_ already has a stack frame
	tmi	ft_fast_read_or_write
	eppap	sp|ps_ptr,*		" load ptr to user's ps
	stq	ap|ft_ps.unit
	sta	ap|ft_ps.job_bits

ft_io1:	eppbp	sp|ps_ptr			" save pointer to ps as arg
	spribp	sp|arg_list+2
	sreg	sp|8			" save registers
	fld	2*1024,dl
	staq	sp|arg_list
	eppap	sp|arg_list		" get ptr to arg list
	tsx1	get_our_lp		" get ptr to our linkage section
	stx0	sp|stack_frame.return_ptr+1	" save offset into user's segment
	sti	sp|stack_frame.return_ptr+1	" save indicators
	tra	plio2,x6			" jump to appropriate proc
"
ft_fast_read_or_write:
	lprpbb	sp|stack_frame.support_ptr	" load ptr to fortran_io_'s fio_ps
	staq	bb|fio_ps.job_bits_and_file
ft_fast_call:
	stx0	sp|stack_frame.return_ptr+1	" save offset into user's segment
	sti	sp|stack_frame.return_ptr+1	" save indicators
	sreg	sp|8
	eppbp	bb|fio_ps.stack_frame_p,*	" load ptr to fortran_io_'s static stack frame
	epp5      sp|stack_frame.next_sp,*      " use parents next_sp
	spri5     bp|stack_frame.next_sp        " for fortran_io_'s next_sp
	spri5     bp|4                          " & for fortran_io_'s perm extension
	spribp	sp|stack_frame.next_sp	" store as next sp for user frame
	eppsp	bp|0			" activate fortran_io_'s stack frame
	sxl6	bb|fio_ps.label_index_addr,*	" store index value for fortran_io_'s transfer
	ldi	0,dl			" force binary floating point mode
	tra	bb|fio_ps.label_addr,*	" transfer directly into fortran_io_
"
"	Transmission operators entered with pointer to element in pr2, descriptor in a,
"	and count in q. Read comments preceding the label "fortran_read" before modifying
"	this operator.
"

fortran_scalar_xmit:
fortran_array_xmit:
	eax6	15

ft_fast_xmit:
	lprpbb	sp|stack_frame.support_ptr	" load ptr to fortran_io_'s fio_ps
	spribp	bb|fio_ps.element_ptr
	staq	bb|fio_ps.ele_desc_and_count
	tra	ft_fast_call
"
"	File control operator entered with unit number in q, job_bits in a. Read comments
"	preceding the label "fortran_read" before modifying this operator.
"
fortran_manip:
	eax6	13
	tra	ft_io
"
"	Termination operator, no registers. Read comments preceding the label
"	"fortran_read" before modifying this operator.
"
fortran_terminate:
	eax6	14
	lprpbb	sp|stack_frame.support_ptr	" load ptr to fortran_io_'s fio_ps
	tra	ft_fast_call
"
"	fortran open element
"
"	Called with:
"	a-reg	= bit string (boolean value)
"	q-reg	= integer (string length, etc.)
"	x1	= case selector
"	pr2	= string pointer
"	pr3	= PS.buffer_p
"
ftn_open_element:
	tra	*+1,1*
	arg	ftn_open_indicators			" 0
	arg	ftn_open_status			" 1
	arg	ftn_open_io_switch			" 2
	arg	ftn_open_attach_desc		" 3
	arg	ftn_open_filename			" 4
	arg	ftn_open_mode			" 5
	arg	ftn_open_access			" 6
	arg	ftn_open_form			" 7
	arg	ftn_open_max_rec_len		" 8
	arg	ftn_open_binary			" 9
	arg	ftn_open_prompt			" 10
	arg	ftn_open_carriage			" 11
	arg	ftn_open_defer			" 12
	arg	ftn_open_blank			" 13

ftn_open_indicators:
	sta	pr3|fortran_open_data.specified
	tra	sp|tbp,*0

	macro	ftn_open_string
ftn_open_&1:
	stq	pr3|fortran_open_data.&1
	lxl1	pr3|fortran_open_data.char_str
	stx1	pr3|fortran_open_data.&1
	mlr	(pr,rl),(pr,x1,rl)
	desc9a	pr2|0,ql
	desc9a	pr3|fortran_open_data.char_str+1,ql
	asq	pr3|fortran_open_data.char_str
	tra	sp|tbp,*0
	&end

	ftn_open_string	status

	ftn_open_string	io_switch

	ftn_open_string	attach_desc

	ftn_open_string	filename

	ftn_open_string	mode

	ftn_open_string	access

	ftn_open_string	form

	ftn_open_string	blank

ftn_open_max_rec_len:
	stq	pr3|fortran_open_data.max_rec_len
	tra	sp|tbp,*0

	macro	ftn_open_flag
ftn_open_&1:
	sta	pr3|fortran_open_data.&1
	tra	sp|tbp,*0
	&end

	ftn_open_flag	binary

	ftn_open_flag	prompt

	ftn_open_flag	carriage

	ftn_open_flag	defer
"
"
"	ftn_inquire_element
"
"	Called with:
"	a	= bit mask
"	q	= string length or unit number
"	pr2	= data pointer
"	pr3	= area pointer
"	x1	= case selector
"
ftn_inquire_element:
	tra	*+1,x1*
	arg	ftn_inquire_indicators		" 0
	arg	ftn_inquire_noop			" 1
	arg	ftn_inquire_noop			" 2
	arg	ftn_inquire_noop			" 3
	arg	ftn_inquire_filename		" 4
	arg	ftn_inquire_noop			" 5
	arg	ftn_inquire_access			" 6
	arg	ftn_inquire_form			" 7
	arg	ftn_inquire_recl			" 8
	arg	ftn_inquire_noop			" 9
	arg	ftn_inquire_noop			" 10
	arg	ftn_inquire_noop			" 11
	arg	ftn_inquire_noop			" 12
	arg	ftn_inquire_blank			" 13
	arg	ftn_inquire_unit			" 14
	arg	ftn_inquire_noop			" 15
	arg	ftn_inquire_noop			" 16
	arg	ftn_inquire_exist			" 17
	arg	ftn_inquire_opened			" 18
	arg	ftn_inquire_number			" 19
	arg	ftn_inquire_named			" 20
	arg	ftn_inquire_name			" 21
	arg	ftn_inquire_sequential		" 22
	arg	ftn_inquire_formatted		" 23
	arg	ftn_inquire_unformatted		" 24
	arg	ftn_inquire_nextrec			" 25
	arg	ftn_inquire_direct			" 26


ftn_inquire_indicators:
	sta	pr3|ftn_inquire_data.specified
	tra	sp|tbp,*x0

ftn_inquire_noop:
	tra	sp|tbp,*x0

ftn_inquire_filename:
	mlr	(pr,rl),(pr),fill(040)
	desc9a	pr2|0,ql
	desc9a	pr3|ftn_inquire_data.filename,168
	tra	sp|tbp,*x0

ftn_inquire_unit:
	stq	pr3|ftn_inquire_data.unit
	tra	sp|tbp,*x0

	macro	ftn_inquire_string
ftn_inquire_&1:
	sprp2	pr3|ftn_inquire_data.&1
	stq	pr3|ftn_inquire_data.&1+1
	tra	sp|tbp,*x0
	&end

	ftn_inquire_string	access

	ftn_inquire_string	form

	ftn_inquire_string	blank

	ftn_inquire_string	name

	ftn_inquire_string	sequential

	ftn_inquire_string	formatted

	ftn_inquire_string	unformatted

	ftn_inquire_string	direct

	macro	ftn_inquire_word
ftn_inquire_&1:
	sprp2	pr3|ftn_inquire_data.&1
	tra	sp|tbp,*x0
	&end

	ftn_inquire_word	recl

	ftn_inquire_word	exist

	ftn_inquire_word	opened

	ftn_inquire_word	number

	ftn_inquire_word	named

	ftn_inquire_word	nextrec
"
"
"	get address of I/O area operator, no registers. Read comments preceding the label
"	"fortran_read" before modifying this operator.
"
ftn_get_area_ptr:
	eax6	22
	szn	sp|ps_ptr			" <0 if fortran_io_ already has a stack frame
	tpl	ft_io1
	lprpbb	sp|stack_frame.support_ptr	" load ptr to fortran_io_'s fio_ps
	tra	ft_fast_call

"
"	operators to do pl1 pointer function, entered with pointer to area in bp
"	and offset in q.
"
pointer_easy:
pointer_hard:
	cmpq	nullo		are we converting null offset
	tnz	4,ic		no, do conversion
	ldaq	null		yes, get null ptr
	eppbp	null,*		and in bp
	tra	sp|tbp,*0		and return
	spribp	sp|temp
	adlq	sp|temp+1		add in word and bit offset
	stq	sp|temp+1		..
	eppbp	sp|temp,*		load ptr into bp
	ldaq	sp|temp		and into aq
	tra	sp|tbp,*0		and return
"
"	operator to do pl1 pointer function when packed ptr should be returned
"
pointer_easy_pk:
pointer_hard_pk:
	cmpq	nullo		return null if null input
	tnz	4,ic
	ldq	null_pk
	eppbp	null,*
	tra	sp|tbp,*0
	spribp	sp|temp
	adlq	sp|temp+1		add in word and bit offset
	stq	sp|temp+1		..
	eppbp	sp|temp,*		load ptr into bp
	ldaq	sp|temp		and into aq
	tra	unpk_to_pk	go return packed value
"
"	operators for doing pl1 offset function.  entered with pointer to area in bp
"	and pointer value in aq or q
"
offset_easy:
offset_hard:
	anaq	ptr_mask		is input null
	cmpaq	nullx
	tnz	3,ic		no, do conversion
oe:	ldq	nullo		return null offset
	tra	sp|tbp,*0
oe1:	stq	sp|temp2		save word and bit offset
	eaa	bp|0		get offset of area in au
	era	mask_bit_one	form 2's complement of whole a-reg
	adla	1,dl		w/o overflow
	adla	sp|temp2		subtract area origin from word offset
	lrl	36		shift into q
	tra	sp|tbp,*0		and return
"
offset_easy_pk:
offset_hard_pk:
	cmpq	null_pk		is input null
	tze	oe		yes, go return null offset
	qlr	6		no, convert to proper form
	qls	12
	lls	18
	qrl	3
	lrl	18
	tra	oe1		go subtract area origin
"
"	operator to alloc block of N words in the user storage area
"	as defined by the stack header
"	entered with N in q, returns with pointer to block
"	in bp.
"
alloc_storage:
	epbpsb	sp|0
	eppbp	sb|stack_header.user_free_ptr,*
	tra	<alloc_>|[op_storage_]
"
"	operator to alloc block of N words in user storage area
"	entered with N in q and bp pointing at where to put ptr
"
alloc_block:
	sxl0	sp|stack_frame.operator_ret_ptr save return
	eax0	z_done		load index with return
"
call_alloc:
	sreg	sp|8		save registers include size of block in Q
	spribp	sp|arg_list+6	save address of ptr
	eppbp	sp|8+5		get address of saved size
	spribp	sp|arg_list+2	and use as 1st arg
	epbpsb	sp|0			get ptr to our stack header
	eppbp	sb|stack_header.user_free_ptr  and pass user free ptr as 2nd arg
	spribp	sp|arg_list+4
	fld	3*2048,dl
	eppbp	<alloc_>|[storage_]	call alloc_|storage_
"
call_alloc_free:
	staq	sp|arg_list	save head of arg list
	eppap	sp|arg_list	get ptr to arg list
	epp1	4,ic		store return address and indicators
	spri1	sp|stack_frame.return_ptr
	sti	sp|stack_frame.return_ptr+1
	callsp	bp|0
	lreg	sp|8		restore registers
	eppbp	sp|tbp,*		restore ptr in sp|stack_frame.return_ptr
	spribp	sp|stack_frame.return_ptr
	tra	0,0		return to caller
"
"	operator to free block pointed at by pointer pointed at by bp
"
free_block:
	ldaq	bp|0		return if there is nothing to free
	eraq	null
	anaq	ptr_mask
	tze	sp|tbp,*0
	sxl0	sp|stack_frame.operator_ret_ptr save return
	eax0	z_done		load index with return
"
call_free:
	sreg	sp|8		save registers
	spribp	sp|arg_list+2	save address of pointer
	eppbp	<freen_>|[freen_]	get ptr to proc
	fld	1*2048,dl
	tra	call_alloc_free	go call proc
"
"	operator to allocate controlled generation given size of descriptor in q
"	and pointer to controlled block in bp
"
push_ctl_desc:
	eax1	2		init offset
	tra	push_ctl_data+1
"
"	operator to allocate controlled generation given size of data in q
"	and pointer to controlled block in bp
"
push_ctl_data:
	eax1	0		init offset
"
	sxl0	sp|stack_frame.operator_ret_ptr
	spribp	sp|temp_pt	save ptr to ctl variable
	adq	6,dl		add in size of ctl block
	eppbp	sp|double_temp	get ptr to temp
	tsx0	call_alloc	go allocate space
	eppbp	sp|temp_pt,*	get back ptr to ctl block
	epplp	sp|double_temp,*	get ptr to allocated space
	ldaq	bp|0		copy current generation
	staq	lp|0
	ldaq	bp|2
	staq	lp|2
	ldaq	bp|4
	staq	lp|4
	sprilp	bp|4		store ptr to old generation
	epplp	lp|6		get ptr to data|desc
	sprilp	bp|0,1		store ptr to data|desc
	tra	z_done		and return
"
"	operators to free a controlled generation, entered with
"	pointer to controlled block in bp
"
pop_ctl_data:
pop_ctl_desc:
	ldaq	bp|4		return if there is nothing to free
	eraq	null
	anaq	ptr_mask
	tze	sp|tbp,*0
	sxl0	sp|stack_frame.operator_ret_ptr
	epplp	bp|4,*		get ptr to previous generation
	sprilp	sp|temp_pt	save for freeing
	ldaq	lp|0		copy old generation into current
	staq	bp|0
	ldaq	lp|2
	staq	bp|2
	ldaq	lp|4
	staq	bp|4
	eppbp	sp|temp_pt	get ptr to block to be freed
	tsx0	call_free		free it
	tra	z_done		and then return
"
"	operator to return number of allocated generation of contrlled
"	variable specified by bp
"
allocation:
	eax1	0		init count
	ldaq	bp|4		get ptr to previous generation
	eraq	null		check for null
	anaq	ptr_mask
	tze	allocation_done	null means done
	eppbp	bp|4,*		not null, step backwards
	adlx1	1,du		update count
	tra	allocation+1
allocation_done:
	eaq	0,1		move count to ql
	qrl	18
	tra	sp|tbp,*0		and return
"
"	operators for unpacking|packing pictured values
"	entered with pr1 -> target, pr3 -> picture, pr5 -> source
"
unpack_picture:
	tsx1	get_our_lp
	eppbp	<unpack_picture_>|[unpack_picture_]
	tra	picture_common
"
pack_picture:
	tsx1	get_our_lp
	eppbp	<pack_picture_>|[pack_picture_]
"
picture_common:
	sxl0	sp|stack_frame.operator_ret_ptr
	eax0	z_done
	sreg	sp|8
	spri1	sp|arg_list+2
	spri3	sp|arg_list+4
	spri5	sp|arg_list+6
	fld	3*2048,dl
	tra	call_alloc_free
"
"	internal subroutine to signal a condition.  entered with
"	bp pointing at name and x6 holding size of name
"
call_signal_:
	sreg	sp|8		save registers for call
	get_stack_offset
	eppap	sp|stack_header.stack_end_ptr,au* get ptr to end of stack frame
	eax0	48		increase stack frame by 48 words
	adlx0	sp|stack_frame.next_sp+1	..
	stx0	sp|stack_frame.next_sp+1
	stx0	sp|stack_header.stack_end_ptr+1,au adjust stack end pointer too
	spri	ap|0		save bases
	eppap	ap|24		get ptr to arg list
	spribp	ap|2		save ptr to condition name as 1st arg
	eppbp	null		get ptr to null file
	spribp	ap|10		save as 5th arg
signal_common:
	stq	ap|14		store oncode value
	eppbp	ap|14		use oncode value
	spribp	ap|8		as 4th arg
	stz	ap|15		save string length of condition name
	sxl6	ap|15
	eppbp	ap|15		pass name length
	spribp	ap|4		as 2nd arg
	lxl7	sp|stack_frame.operator_ret_ptr get ptr to entry into pl1_operators_
	sbx7	1,du
	eppbp	sp|tbp,*7		and save for use
	spribp	ap|12		as 3rd arg
	eppbp	ap|12
	spribp	ap|6
	fld	5*2048,dl		set number of args
	staq	ap|0
	tsx1	get_our_lp	get ptr to our linkage
	epp1	4,ic		store return address and indicators
	spri1	sp|stack_frame.return_ptr
	sti	sp|stack_frame.return_ptr+1
	tra	<pl1_signal_from_ops_>|[pl1_signal_from_ops_]
	eppap	sp|stack_frame.next_sp,*	point 48 words past stack extension
	lpri	ap|-48		restore pointer regs
	get_stack_offset
          ldx0      sp|stack_frame.next_sp+1 reset the stack frame size
          sblx0     48,du               by subtracting the 48 words we added.
	stx0	sp|stack_frame.next_sp+1 update next sp pointer
	stx0	sp|stack_header.stack_end_ptr+1,au update stack end too
	lreg	sp|8		restore machine registers
	epbpap	sp|tbp,*0		restore return word pair
	spriap	sp|stack_frame.return_ptr segment number
	eppap	sp|stack_frame.operator_ptr,*	and pointer to operators
	tra	0,1		and return
"
"	Subroutine to load PR4 with a pointer to linkage of
"	pl1_operators_. Also sets PR7 to stack|0. Calling sequence:
"		tsx1	get_our_lp
"
get_our_lp:
	get_our_lp
	tra	0,1		return with lp loaded to our linkage
"
"	operator to signal io condition, same as signal except sp|40 holds
"	pointer to file name.
"
io_signal:
	eax1	z_done		get return_pt for call to signal_common
	sreg	sp|8		save register for call
	get_stack_offset
	sxl0	sp|stack_frame.operator_ret_ptr
	eppap	sp|stack_header.stack_end_ptr,au* get pointer to end of stack frame
	eax0	48		increase stack frame by 48 words
	adlx0	sp|stack_frame.next_sp+1	..
	stx0	sp|stack_frame.next_sp+1	..
	stx0	sp|stack_header.stack_end_ptr+1,au	don't forget stack end ptr
	spri	ap|0		store bases
	eppap	ap|24		get ptr to arg list
	ldq	=1000,dl		get oncode value
	spribp	ap|2		store ptr to cond name as 1st arg
	eppbp	sp|40		store ptr to file
	spribp	ap|10		as 5th arg
	tra	signal_common	jump into common section to signal and return
"
"	operator to set support bit in stack frame
"
set_support:
	lda	stack_frame.support_bit,dl
	orsa	sp|stack_frame.flag_word
	tra	sp|tbp,*0
"
get_math_entry:
	tsx1	get_our_lp
	xec	fort_math_names-1,2		get entry
	tra	sp|tbp,*0	return


fort_math_names:
	epp2	<fort_bfp_builtins_>|[exp_]		1
	epp2	<fort_bfp_builtins_>|[alog_]		2
	epp2	<fort_bfp_builtins_>|[alog10_]	3
	epp2	<fort_bfp_builtins_>|[atan_]		4
	epp2	<fort_bfp_builtins_>|[atan2_]		5
	epp2	<fort_bfp_builtins_>|[sin_]		6
	epp2	<fort_bfp_builtins_>|[cos_]		7
	epp2	<fort_bfp_builtins_>|[tanh_]		8
	epp2	<fort_bfp_builtins_>|[sqrt_]		9
	epp2	<fort_bfp_builtins_>|[dmod_]		10
	epp2	<fort_bfp_builtins_>|[dexp_]		11
	epp2	<fort_bfp_builtins_>|[dlog_]		12
	epp2	<fort_bfp_builtins_>|[dlog10_]	13
	epp2	<fort_bfp_builtins_>|[datan_]		14
	epp2	<fort_bfp_builtins_>|[datan2_]	15
	epp2	<fort_bfp_builtins_>|[dsin_]		16
	epp2	<fort_bfp_builtins_>|[dcos_]		17
	epp2	<fort_bfp_builtins_>|[dsqrt_]		18
	epp2	<fort_bfp_builtins_>|[cabs_]		19
	epp2	<fort_bfp_builtins_>|[cexp_]		20
	epp2	<fort_bfp_builtins_>|[clog_]		21
	epp2	<fort_bfp_builtins_>|[csin_]		22
	epp2	<fort_bfp_builtins_>|[ccos_]		23
	epp2	<fort_bfp_builtins_>|[csqrt_]		24
	epp2	<fort_bfp_builtins_>|[cxp2_]		25
	epp2	<fort_bfp_builtins_>|[tan_]		26
	epp2	<fort_bfp_builtins_>|[dtan_]		27
	epp2	<fort_bfp_builtins_>|[asin_]		28
	epp2	<fort_bfp_builtins_>|[dasin_]		29
	epp2	<fort_bfp_builtins_>|[acos_]		30
	epp2	<fort_bfp_builtins_>|[dacos_]		31
	epp2	<fort_int_builtins_>|[index_]		32
	epp2	<fort_bfp_builtins_>|[dtanh_]		33
	epp2	<fort_bfp_builtins_>|[sinh_]		34
	epp2	<fort_bfp_builtins_>|[dsinh_]		35
	epp2	<fort_bfp_builtins_>|[cosh_]		36
	epp2	<fort_bfp_builtins_>|[dcosh_]		37
	epp2	<fort_bfp_builtins_>|[abs_]		38
	epp2	<fort_int_builtins_>|[iabs_]		39
	epp2	<fort_bfp_builtins_>|[dabs_]		40
	epp2	<fort_bfp_builtins_>|[dim_]		41
	epp2	<fort_int_builtins_>|[idim_]		42
	epp2	<fort_bfp_builtins_>|[ddim_]		43
	epp2	<fort_bfp_builtins_>|[sign_]		44
	epp2	<fort_int_builtins_>|[isign_]		45
	epp2	<fort_bfp_builtins_>|[dsign_]		46
	epp2	<fort_bfp_builtins_>|[aint_]		47
	epp2	<fort_bfp_builtins_>|[aimag_]		48
	epp2	<fort_bfp_builtins_>|[conjg_]		49
	epp2	<fort_int_builtins_>|[len_]		50
	epp2	<fort_bfp_builtins_>|[dint_]		51
	epp2	<fort_bfp_builtins_>|[anint_]		52
	epp2	<fort_bfp_builtins_>|[dnint_]		53
	epp2	<fort_bfp_builtins_>|[nint_]		54
	epp2	<fort_bfp_builtins_>|[idnint_]	55
	epp2	<fort_bfp_builtins_>|[dprod_]		56
	epp2	<fort_int_builtins_>|[mod_]		57
	epp2	<fort_bfp_builtins_>|[amod_]		58
	epp2	<fort_int_builtins_>|[ilr_]		59
	epp2	<fort_int_builtins_>|[ils_]		60
	epp2	<fort_int_builtins_>|[irl_]		61
	epp2	<fort_int_builtins_>|[irs_]		62

fortran_end:
	ldq	4,dl
	stq	sp|arg_list
	stz	sp|arg_list+1
	epp0	sp|arg_list
	tsx1	get_our_lp
	callsp	<fortran_stop_>|[fortran_end]


fortran_pause:
	eax2	0
	tra	pause_stop

fortran_stop:
	eax2	1

pause_stop:
	spri2	sp|arg_list+2	argument 1
	orq	=o524000,du
	stq	sp|temp
	epp2	sp|temp
	spri2	sp|arg_list+4	descriptor 1
	fld	1*2048,dl		one argument
	eaq	0,au		there are descriptors
	staq	sp|arg_list
	epp0	sp|arg_list	get argument list header
	stx0	sp|stack_frame.return_ptr+1	save return point
	sti	sp|stack_frame.return_ptr+1	save indicators
	tsx1	get_our_lp
	xec	pause_stop_names,2
	callsp	pr2|0

pause_stop_names:
	epp2	<fortran_pause_>|[fortran_pause_]
	epp2	<fortran_stop_>|[fortran_stop_]

fortran_chain:
	spri2	sp|arg_list+2	argument 1

	ldaq	old_sys_name	old system name
	staq	pr2|43

	tsx1	get_our_lp
	epp2	<fast_related_data_>|[chain_entry]

	fld	1*2048,dl		one argument
	staq	sp|arg_list
	epp0	sp|arg_list	get argument list header

	epp3	pr2|2,*		get display pointer
	spri3	pr0|2,au		store at the end of the argument list

	stx0	sp|stack_frame.return_ptr+1	save return point
	sti	sp|stack_frame.return_ptr+1	save indicators
	callsp	pr2|0,*		make the call

old_sys_name:
	even
	aci	"fortran "

"
"	Function:	enter Binary Floating Point (BFP) mode
"
"	Entry:	X0 = offset in caller's text section of return point
"
"	Exit:	PR0, (sp|stack_frame.operator_ptr) -> operator_table
"
enter_BFP_mode:
	ldi	0,dl		clear HFP mode if it's set
	epp0	operator_table	change to BFP operators
	spri0	sp|stack_frame.operator_ptr
	tra	sp|tbp,*x0

"
"	Function:	enter Hexadecimal Floating Point (HFP) mode
"
"	Entry:	X0 = offset in caller's text section of return point
"
"	Exit:	PR0, (sp|stack_frame.operator_ptr) = hfp_operator_table
"
"	Note:	It is not sufficient to just request HFP mode.  We must
"		check that our request has been honoured, since if HFP
"		mode has not been enabled (or if it is not supported), a
"		request to enter HFP mode is simply ignored.  If we find
"		that our request to enter HFP mode has not been honoured,
"		we attempt to enable HFP mode.  If we are unsuccessful,
"		we signal the condition 'cannot_enable_HFP_mode'.  If we
"		are restarted after signalling this condition, we repeat
"		all the above steps.
"
enter_HFP_mode:
	ldi	HFP_mask,dl	request HFP mode
	fld	P1.0H,du		check if request honoured
	fad	P0.0H,du
	sba	=o020000,du
	tze	enter_HFP_mode.entered
	lda	=o600000,du	try to enable HFP mode
	tsx1	call_set_hexfp_control
	ldi	HFP_mask,dl	check if successful
	fld	P1.0H,du
	fad	P0.0H,du
	sba	=o020000,du
	tze	enter_HFP_mode.entered
	ldi	=0,dl		clear HFP mode request
	eppbp	=22acannot_enable_HFP_mode
	eax6	22
	ldq	=1000,dl
	tsx1	call_signal_	signal 'cannot_enable_HFP_mode' condition
	tra	enter_HFP_mode	try again

enter_HFP_mode.entered:
	epp0	hfp_operator_table	change to HFP operators
	spri0	sp|stack_frame.operator_ptr
	tra	sp|tbp,*x0

"
"	Function:	call 'hcs_$set_hexfp_control'.
"
"	Entry:	A = desired value for 1st argument:
"		    1b2 => retain current mode
"		    2b2 => disable HFP mode
"		    3b2 => enable HFP mode
"		X1 = offset of return address
"
"	Exit:	A = returned value of 2nd argument:
"		    2b2 => HFP mode was disabled before call
"		    3b2 => HFP mode was enabled before call
"		Q = returned value of 3rd argument:
"		    a standard system status code.
"
"	Alters:	A, Q, (sp|8:sp|15).
"
call_set_hexfp_control:
	sreg	sp|8		save X0:X7, AQ and E
	get_stack_offset
	eppap	sp|stack_header.stack_end_ptr,au* get ptr to end of stack frame
	eax0	32		increase stack frame by 32 words
	adlx0	sp|stack_frame.next_sp+1	..
	stx0	sp|stack_frame.next_sp+1
	stx0	sp|stack_header.stack_end_ptr+1,au adjust stack end pointer too
	spri	ap|0		save PR0:PR7
	eppap	ap|16		form argument list
	fld	3*2048,dl
	staq	ap|0		there are 3 arguments
	epp1	sp|8+4
	spri1	ap|2		1st argument is cache for A
	spri1	ap|4		2nd argument is cache for A
	epp1	sp|8+5
	spri1	ap|6		3rd argument is cache for Q
	tsx1	get_our_lp
	epp1	4,ic		make the call:
	  spri1	  sp|stack_frame.return_ptr
	  sti	  sp|stack_frame.return_ptr+1
	  callsp	  <hcs_>|[set_hexfp_control]
	eppap	sp|stack_frame.next_sp,*	point 32 words past stack extension
	lpri	ap|-32		restore pointer regs
	get_stack_offset
	ldx0	sp|5		get offset of original end of frame
	stx0	sp|stack_frame.next_sp+1 update next sp pointer
	stx0	sp|stack_header.stack_end_ptr+1,au update stack end too
	lreg	sp|8		restore machine registers
	epbpap	sp|tbp,*0		restore return word pair
	spriap	sp|stack_frame.return_ptr segment number
	eppap	sp|stack_frame.operator_ptr,*	and pointer to operators
	tra	0,x1		return

"
"	this code execute for unimplemented operators
"
unimp:	spribp	sp|double_temp	save bp
	stx6	sp|temp2
	eppbp	error_name	signal error condition
	eax6	error_length
	ldq	=710,dl		with oncode = 710
	tra	ssc
error_name:
	aci	"error"
	equ	error_length,5
"
"	Single word mask arrays are used only by operators
"
bit_mask_one:
	vfd	0/-1,36/0
	vfd	1/-1,35/0
	vfd	2/-1,34/0
	vfd	3/-1,33/0
	vfd	4/-1,32/0
	vfd	5/-1,31/0
	vfd	6/-1,30/0
	vfd	7/-1,29/0
	vfd	8/-1,28/0
	vfd	9/-1,27/0
	vfd	10/-1,26/0
	vfd	11/-1,25/0
	vfd	12/-1,24/0
	vfd	13/-1,23/0
	vfd	14/-1,22/0
	vfd	15/-1,21/0
	vfd	16/-1,20/0
	vfd	17/-1,19/0
	vfd	18/-1,18/0
	vfd	19/-1,17/0
	vfd	20/-1,16/0
	vfd	21/-1,15/0
	vfd	22/-1,14/0
	vfd	23/-1,13/0
	vfd	24/-1,12/0
	vfd	25/-1,11/0
	vfd	26/-1,10/0
	vfd	27/-1,9/0
	vfd	28/-1,8/0
	vfd	29/-1,7/0
	vfd	30/-1,6/0
	vfd	31/-1,5/0
	vfd	32/-1,4/0
	vfd	33/-1,3/0
	vfd	34/-1,2/0
	vfd	35/-1,1/0
"
mask_bit_one:
	vfd	0/0,36/-1
	vfd	1/0,35/-1
	vfd	2/0,34/-1
	vfd	3/0,33/-1
	vfd	4/0,32/-1
	vfd	5/0,31/-1
	vfd	6/0,30/-1
	vfd	7/0,29/-1
	vfd	8/0,28/-1
	vfd	9/0,27/-1
	vfd	10/0,26/-1
	vfd	11/0,25/-1
	vfd	12/0,24/-1
	vfd	13/0,23/-1
	vfd	14/0,22/-1
	vfd	15/0,21/-1
	vfd	16/0,20/-1
	vfd	17/0,19/-1
	vfd	18/0,18/-1
	vfd	19/0,17/-1
	vfd	20/0,16/-1
	vfd	21/0,15/-1
	vfd	22/0,14/-1
	vfd	23/0,13/-1
	vfd	24/0,12/-1
	vfd	25/0,11/-1
	vfd	26/0,10/-1
	vfd	27/0,9/-1
	vfd	28/0,8/-1
	vfd	29/0,7/-1
	vfd	30/0,6/-1
	vfd	31/0,5/-1
	vfd	32/0,4/-1
	vfd	33/0,3/-1
	vfd	34/0,2/-1
	vfd	35/0,1/-1
"
single_bit:
"
	vfd	0/0,1/1
	vfd	1/0,1/1
	vfd	2/0,1/1
	vfd	3/0,1/1
	vfd	4/0,1/1
	vfd	5/0,1/1
	vfd	6/0,1/1
	vfd	7/0,1/1
	vfd	8/0,1/1
	vfd	9/0,1/1
	vfd	10/0,1/1
	vfd	11/0,1/1
	vfd	12/0,1/1
	vfd	13/0,1/1
	vfd	14/0,1/1
	vfd	15/0,1/1
	vfd	16/0,1/1
	vfd	17/0,1/1
	vfd	18/0,1/1
	vfd	19/0,1/1
	vfd	20/0,1/1
	vfd	21/0,1/1
	vfd	22/0,1/1
	vfd	23/0,1/1
	vfd	24/0,1/1
	vfd	25/0,1/1
	vfd	26/0,1/1
	vfd	27/0,1/1
	vfd	28/0,1/1
	vfd	29/0,1/1
	vfd	30/0,1/1
	vfd	31/0,1/1
	vfd	32/0,1/1
	vfd	33/0,1/1
	vfd	34/0,1/1
	vfd	35/0,1/1
"
floor_ceil_mask:
"
	vfd	36/0,0/-1
	vfd	35/0,1/-1
	vfd	34/0,2/-1
	vfd	33/0,3/-1
	vfd	32/0,4/-1
	vfd	31/0,5/-1
	vfd	30/0,6/-1
	vfd	29/0,7/-1
	vfd	28/0,8/-1
	vfd	27/0,9/-1
	vfd	26/0,10/-1
	vfd	25/0,11/-1
	vfd	24/0,12/-1
	vfd	23/0,13/-1
	vfd	22/0,14/-1
	vfd	21/0,15/-1
	vfd	20/0,16/-1
	vfd	19/0,17/-1
	vfd	18/0,18/-1
	vfd	17/0,19/-1
	vfd	16/0,20/-1
	vfd	15/0,21/-1
	vfd	14/0,22/-1
	vfd	13/0,23/-1
	vfd	12/0,24/-1
	vfd	11/0,25/-1
	vfd	10/0,26/-1
	vfd	9/0,27/-1
	vfd	8/0,28/-1
	vfd	7/0,29/-1
	vfd	6/0,30/-1
	vfd	5/0,31/-1
	vfd	4/0,32/-1
	vfd	3/0,33/-1
	vfd	2/0,34/-1
	vfd	1/0,35/-1
	vfd	0/0,36/-1
" 
"
"	Entry operators, entered by following sequence in text section
"
"		eax7	stack_size
"		eppbp	sb|stack_header.pl1_operators_ptr,*
"		tspbp	bp|n	(bp points at segdef operator_table)
"		vfd	18/n_args,18/unused
"		vfd	18/link,18/block
"
"
"
"
"	The following macro is the ext_entry macro. It conditionally expands the
"	trace code if the first argument is "trace_".  It conditionally sets
"	the static ptr if the second argument is "ss_".
"

	macro	ext_entry
&1&2ext_entry:
	eppbp	bp|-3		get correct entry pointer value
	trace	&1
	epaq	bp|0		get segment number in a
	lprplp	sb|stack_header.lot_ptr,*au get seg no, offset of linkage from packed ptr
	ife	&2,ss_
	lprplb	sb|stack_header.isot_ptr,*au get seg no, offset of static from packed ptr
ifend
	eppbb	sb|stack_header.stack_end_ptr,* get ptr to next stack frame
	sprisp	bb|stack_frame.prev_sp set back ptr of new frame
	spriap	bb|stack_frame.arg_ptr save arg pointer
	eppab	bb|0,7		get pointer to end of new frame
	spriab	bb|stack_frame.next_sp set next pointer of new frame
	spriab	sb|stack_header.stack_end_ptr update stack end ptr
	eppsp	bb|0		update sp
&1&2save_link:
	sprilp	sp|linkage_ptr	save ptr to linkage in stack head
	ife	&2,ss_
	sprplb	sp|stack_frame.static_ptr save static ptr
ifend
	spribp	sp|stack_frame.entry_ptr save ptr to entry point
&1&2init_stack_join:
	spbpbp	sp|text_base_ptr	save ptr to base of text segment
	spbpbp	sp|stack_frame.return_ptr init procedure call return point
	stz	sp|stack_frame.operator_ret_ptr init operator return offset
"
	eppap	&1operator_table	and pointer to operators
	spriap	sp|stack_frame.operator_ptr save pointer to operator segment
	spriab	sp|4		save pointer to end of frame for temp extensions
	ldi	0,dl		reset all indicators (overflow mask in particular)
	tra	bp|5		and return to user program
	&end

	ext_entry
"
"	The following macro is analogous to ext_entry except for entries which expect
"	descriptors.
"
	macro	ext_entry_desc
&1&2ext_entry_desc:
	eppbp	bp|-3		get correct entry pointer value
	trace	&1
	epaq	bp|0		get segment number of text
	lprplp	sb|stack_header.lot_ptr,*au get seg no, offset of linkage from  packed ptr
	ife	&2,ss_
	lprplb	sb|stack_header.isot_ptr,*au get seg no, offset of static from packed ptr
ifend
	eppbb	sb|stack_header.stack_end_ptr,* get ptr to next stack frame
	sprisp	bb|stack_frame.prev_sp set back ptr of new frame
	spriap	bb|stack_frame.arg_ptr save arg pointer
	eppab	bb|0,7		get pointer to end of new frame
	spriab	bb|stack_frame.next_sp set next pointer of new frame
	spriab	sb|stack_header.stack_end_ptr set new stack end ptr
	eppsp	bb|0		update sp
"
&1&2eed:
	lda	ap|0		get 2*n_args in au, code in al
	cana	8,dl		is there an extra arg
	tze	2,ic		no
	ada	2,du		yes, allow for it
	eppbb	ap|2,au		get ptr to descriptors
	spribb	sp|descriptor_ptr	set ptr in stack frame
	tra	&1&2save_link		join common section
	&end
"
	ext_entry_desc

"
"	The following macro is the other_entries macro.  It conditionally
"	sets the static ptr if the first argument is "ss_".
"
	macro	other_entries
&1int_entry:
	epaq	bp|0		get segment number of text
	lprplp	sb|stack_header.lot_ptr,*au get seg no, offset of linkage from packed ptr
	ife	&1,ss_
	lprplb	sb|stack_header.isot_ptr,*au get seg no, offset of static from packed ptr
ifend
	eppbb	sb|stack_header.stack_end_ptr,* get ptr to next stack frame
	sprisp	bb|stack_frame.prev_sp set back ptr of new frame
	spriap	bb|stack_frame.arg_ptr save arg pointer
	eppab	bb|0,7		get pointer to end of new frame
	spriab	bb|stack_frame.next_sp set next pointer of new frame
	spriab	sb|stack_header.stack_end_ptr set new stack end ptr
	eppsp	bb|0		update sp
"
	lda	ap|0		get 2*n_args in au
"
&1set_display:
	eppbb	ap|2,au*		get display ptr
	spribb	sp|display_ptr	and save in stack frame
	eppbp	bp|-3		set correct entry pointer value
	tra	&1save_link		join common section
"
&1int_entry_desc:
	epaq	bp|0		get segment number of text
	lprplp	sb|stack_header.lot_ptr,*au get seg no, offset of linkage from packed ptr
	ife	&1,ss_
	lprplb	sb|stack_header.isot_ptr,*au get seg no, offset of static from packed ptr
ifend
	eppbb	sb|stack_header.stack_end_ptr,* get ptr to next stack frame
	sprisp	bb|stack_frame.prev_sp set back ptr of new frame
	spriap	bb|stack_frame.arg_ptr save arg pointer
	eppab	bb|0,7		get pointer to end of new frame
	spriab	bb|stack_frame.next_sp set next pointer of new frame
	spriab	sb|stack_header.stack_end_ptr set new stack end ptr
	eppsp	bb|0		update sp
"
	lda	ap|0		get 2*n_args in au, code in al
	eppbb	ap|4,au		get ptr to descriptors
	spribb	sp|descriptor_ptr	set ptr in stack frame
	tra	&1set_display	go set display ptr
"
&1val_entry_desc:
	eax0	&1eed		get final destination
	tra	&1val_entry+1	join common validate code
"
&1val_entry:
	eax0	&1save_link		get final destination
"
	spribp	sb|stack_header.stack_end_ptr,* save entry pointer
	eppbb	sb|stack_header.stack_end_ptr,* get ptr to next stack frame
	sprisp	bb|stack_frame.prev_sp set back ptr of new frame
	spriap	bb|stack_frame.arg_ptr save arg pointer
	eppab	bb|0,7		get pointer to end of new frame
	spriab	bb|stack_frame.next_sp set next pointer of new frame
	spriab	sb|stack_header.stack_end_ptr set up new end ptr
	eppsp	bb|0		update sp
"
	epaq	bp|0		get segment number of text
	lprplp	sb|stack_header.lot_ptr,*au get seg no, offset of linkage
	ife	&1,ss_
	lprplb	sb|stack_header.isot_ptr,*au get seg no, offset of static
ifend
	eppap	operator_table
	spriap	sp|stack_frame.operator_ptr
	eppap	sp|stack_frame.arg_ptr get ptr to arglist
	spriap	sp|arg_list+2	save as arg of validate call
	fld	2*1024,dl
	staq	sp|arg_list
	eppap	sp|arg_list	get ptr to arglist for validate call
	sprplp	sp|4		save lp - we need it at save_link
	ife	&1,ss_
	sprplb	sp|5		save lb
ifend
	stx0	sp|8		save x0 for eventual exit
	ldx1	bp|2		get link offset of validate proc
	stcd	sp|stack_frame.return_ptr call the validate proc
	tra	lp|0,1*
	ldx0	sp|8		restore x0
	lprplp	sp|4		and lp
	ife	&1,ss_
	lprplb	sp|5		and lb
ifend
	eppab	sb|stack_header.stack_end_ptr,*
	eppap	sp|stack_frame.arg_ptr,* restore argument list pointer
	eppbp	sp|0,*		restore entry return pointer
	eppbp	bp|-3		set correct entry pointer value
	tra	0,0		and re-enter main stream
	&end
"
	other_entries
"
	ext_entry		,ss_
"
	ext_entry_desc	,ss_
"
	other_entries	ss_
"
"
"	operator to enter a begin block
"	calling sequence is:
"
"		eax7	stack_size
"		tspbp	ap|enter_begin_block
"		vfd	18/link,18/block	for symbol table
"
	macro	enter_begin
&1enter_begin_block:
	epplp	sp|linkage_ptr,*	get linkage pointer from parent frame
	ife	&1,ss_
	lprplb	sp|stack_frame.static_ptr	get static pointer from parent frame
ifend
	epbpsb	sp|0		get ptr to base of stack
	eppbb	sb|stack_header.stack_end_ptr,* get ptr to next stack frame
	sprisp	bb|stack_frame.prev_sp set back pointer of new frame
	eppab	bb|0,7		get pointer to end of new frame
	spriab	bb|stack_frame.next_sp set next pointer of new frame
	spriab	sb|stack_header.stack_end_ptr set stack end pointer
	sprisp	bb|display_ptr	set display pointer
	eppsp	bb|0		update sp
"
	ldaq	null		set arg list pointer to null
	staq	sp|stack_frame.arg_ptr ..
	sprilp	sp|linkage_ptr	save linkage ptr
	ife	&1,ss_
	sprplb	sp|stack_frame.static_ptr	save static ptr
ifend
	eppbp	bp|-2
	spribp	sp|stack_frame.entry_ptr
	eppbp	bp|-2		get correct entry pointer
	tra	init_stack_join	go init stack frame
	&end
"
	enter_begin
"
	enter_begin	ss_
"
"
entry_operators_end:
	zero	0,*	marks end of entry operators
"
"
	even
null:	its	-1,1,n
nullx:	oct	077777000043,000001000000
null_pk:	oct	007777000001
nullo:	oct	777777777777
one:	dec	0,1
almost_one:
hfp_almost_one:
	oct	000777777777,777777777777
k71b25:	oct	216000000000,000000000000
"
shift_bo:	dec	0b26,1b26,2b26,3b26,4b26,5b26,6b26,7b26,8b26,9b26
	dec	10b26,11b26,12b26,13b26,14b26,15b26,16b26,17b26,18b26,19b26
	dec	20b26,21b26,22b26,23b26,24b26,25b26,26b26,27b26,28b26,29b26
	dec	30b26,31b26,32b26,33b26,34b26,35b26

"
" The follow line must appear after everything else in text segment
"
end_pl1_operators:
	zero	0,*		marks end of pl1_operators
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"							"
"		END OF WIRED SECTION			"
"							"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
" 
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"							"
"		START OF PAGED SECTION			"
"							"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
" The following code is used when hexadecimal floating point mode has been
"selected via a call to the 'enter_HFP_mode' operator.
"
	transfer_vector	,hfp_


"
"	Function:	ceiling of a float hex (71) number
"
"	Entry:	EAQ = number
"		X0 = offset in caller's text section of return point
"
"	Exit:	EAQ = ceil(number)
"
hfp_ceil_fl:
	tmi	6,ic		if number +ve then:
	  dfad	  hfp_almost_one	  EAQ = number + almost_one
	  fmp	  P2.0H,du	  EAQ = 2*(number + almost_one)
	  fad	  =18b25,du	  EAQ = 2*ceil(number)
	  fmp	  P0.5H,du	  EAQ = ceil(number)
	  tra	  sp|tbp,*x0	  return
"				else:
	  fmp	  M2.0H,du	  EAQ = 2*abs(number)
	  fad	  =18b25,du	  EAQ = 2*floor(abs(number))
	  fmp	  M0.5H,du	  EAQ = -floor(abs(number))
	  tra	  sp|tbp,*x0	  return


"
"	Function:	convert a float hex (71) number to fixed bin (71)
"
"	Entry:	EAQ = number
"		X0 = offset in caller's text section of return point
"
"	Exit:	AQ = fixed (number, 71)
"
hfp_fl2_to_fx1:
hfp_fl2_to_fx2:
	fad	P0.0H,du
	tmi	4,ic		if number +ve then:
	  fmp	  P2.0H,du	  EAQ = 2*number
	  ufa	  =18b25,du	  AQ = floor(number)
	  tra	  sp|tbp,*x0	  return
"				else:
	  fmp	  M2.0H,du	  EAQ = 2*abs(number)
	  ufa	  =18b25,du	  AQ = floor (abs (number))
	  negl	  0	  	  AQ = -floor(abs(number))
	  tra	  sp|tbp,*x0	  return


"
"	Function:	convert a float hex (71) number to fixed bin
"		(71, scale)
"
"	Entry:	EAQ = number
"		X0 = offset in caller's text section of the word
"		     containing the scale factor in the format
"		     8/71-scale,28/0
"
"	Exit:	to word after scale factor word with:
"		AQ = floor(number * 2**scale)
"
"	Note:	The format of the word containing the scale factor is the
"		same as that used when converting float bin (71) to fixed
"		bin (71, scale).  THIS IS NOT THE BEST FORMAT FOR
"		CONVERTING HEX NUMBERS.  It is used because that is what
"		the current PL/I compiler generates.  If float hex is ever
"		added as a proper 'pl1' data type, it would be wise to
"		change the format of the scale word to contain the float
"		hex (27) representation of 2**(scale-1).  This would
"		shorten the conversion code to:
"
"hfp_fl2_to_fxscaled:
"	fad	P0.0H,du
"	tmi	4,ic		if number +ve then:
"	  fmp	  sp|tbp,*x0	  EAQ = 2*number * 2**scale
"	  ufa	  =18b25,du	  AQ = floor(number * 2**scale)
"	tra	5,ic		else:
"	  fneg	  0		  EAQ = abs(number)
"	  fmp	  sp|tbp,*x0	  EAQ = 2*abs(number) * 2**scale
"	  ufa	  =18b25,du	  AQ = floor(abs(number) * 2**scale)
"	  negl	  0		  AQ = -floor(abs(number) * 2**scale)
"	adx0	=1,du		skip scale word
"	tra	sp|tbp,*x0	return
"
hfp_fl2_to_fxscaled:
	staq	sp|temp		save mantissa of number
	lda	sp|tbp,*x0	A = 8/71-scale,28/0
	ars	28		A = 71-scale
	neg	0		A = scale-71
	ada	=72,dl		A = scale+1
	lrs	2		A = floor((scale+1)/4)
	qrl	34		Q = (scale+1) - 4*floor((scale+1)/4)
	eax1	0,ql		X1 = (scale+1) - 4*floor((scale+1)/4)
	ada	=1,dl		A = floor((scale+1)/4) + 1
	ldq	=1,dl		Q = 2**0
	qls	31,x1		Q = 2**(X1+31)
	lls	28		A = HFP representation of 2**(scale+1)
	sta	sp|temp2		save scale factor
	ldaq	sp|temp		restore mantissa of number
	tmi	4,ic		if number +ve then:
	  fmp	  sp|temp2	  EAQ = 2*number * 2**scale
	  ufa	  =18b25,du	  AQ = floor(number * 2**scale)
	tra	5,ic		else:
	  fneg	  0		  EAQ = abs(number)
	  fmp	  sp|temp2	  EAQ = 2*abs(number) * 2**scale
	  ufa	  =18b25,du	  AQ = floor(abs(number) * 2**scale)
	  negl	  0		  AQ = -floor(abs(number) * 2**scale)
	adx0	=1,du		skip scale word
	tra	sp|tbp,*x0	return



"
"	Function:	floor of a float hex (71) number
"
"	Entry:	EAQ = number
"		X0 = offset in caller's text section of return point
"
"	Exit:	EAQ = floor(number)
"
hfp_floor_fl:
	tmi	5,ic		if number +ve then:
	  fmp	  P2.0H,du	  EAQ = 2*number
	  fad	  =18b25,du	  EAQ = 2*floor(number)
	  fmp	  P0.5H,du	  EAQ = floor(number)
	  tra	  sp|tbp,*x0	  return
"				else:
	  dfsb	  hfp_almost_one	  EAQ = -(abs(number) + almost_one)
	  fmp	  M2.0H,du	  EAQ = 2*(abs(number) + almost_one)
	  fad	  =18b25,du	  EAQ = 2*ceil(abs(number))
	  fmp	  M0.5H,du	  EAQ = -ceil(abs(number))
	  tra	  sp|tbp,*x0	  return


"
"	Function:	FORTRAN float hex (63) modulus: dmod(x, y)
"
"	Entry:	EAQ = x
"		bp|0 -> y
"		X0 = offset in caller's text section of return point

"	Exit:	EAQ = if y=0 then 0 else x - trunc(x/y)*y
"
hfp_fort_dmod:
	fszn	bp|0		return 0 if y is 0
	tze	sp|tbp,*x0
	dfstr	sp|temp		save x
	dfdv	bp|0		EAQ = x/y
	tmi	5,ic		if EAQ >= 0 then:
	   fmp	   P2.0H,du	   EAQ = 2*x/y
	   fad	   =18b25,du	   EAQ = 2*floor(x/y)
	   fmp	   M0.5H,du	   EAQ = -trunc(x/y)
	tra	4,ic 		else:
	   fmp	   M2.0H,du	   EAQ = 2*abs(x/y)
	   fad	   =18b25,du	   EAQ = 2*floor(abs(x/y))
	   fmp	   P0.5H,du	   EAQ = -trunc(x/y)
	dfmp	bp|0		EAQ = -trunc(x/y)*y
	dfad	sp|temp		EAQ = x - trunc(x/y)*y
	tra	sp|tbp,*x0	return


"
"	Function:	FORTRAN float hex (27) modulus: amod(x, y)
"
"	Entry:	EAQ = x
"		bp|0 -> y
"		X0 = offset in caller's text section of return point
"
"	Exit:	EAQ = if y=0 then 0 else x - trunc(x/y)*y
"
hfp_fort_mdfl1:
	fszn	bp|0		return 0 if y is 0
	tze	sp|tbp,*x0
	fstr	sp|temp		save x
	fdv	bp|0		EAQ = x/y
	tmi	5,ic		if EAQ >= 0 then:
	   fmp	   P2.0H,du	   EAQ = 2*x/y
	   fad	   =18b25,du	   EAQ = 2*floor(x/y)
	   fmp	   M0.5H,du	   EAQ = -trunc(x/y)
	tra	4,ic		else:
	   fmp	   M2.0H,du	   EAQ = 2*abs(x/y)
	   fad	   =18b25,du	   EAQ = 2*floor(abs(x/y))
	   fmp	   P0.5H,du	   EAQ = -trunc(x/y)
	fmp	bp|0		EAQ = -trunc(x/y)*y
	fad	sp|temp		EAQ = x - trunc(x/y)*y
	tra	sp|tbp,*x0	return


"
"	Function:	Get address of a specified FORTRAN intrinsic function.
"
"	Entry:	X0 = offset in caller's text section of return point.
"		X2 = index of the intrinsic function.
"
"	Exit:	PR2 = address of entry point of specified intrinsic.
"
hfp_get_math_entry:
	tsx1	get_our_lp
	xec	hfp_fort_math_names-1,2	get entry
	tra	sp|tbp,*0	return


hfp_fort_math_names:
	epp2	<fort_hfp_builtins_>|[exp_]		1
	epp2	<fort_hfp_builtins_>|[alog_]		2
	epp2	<fort_hfp_builtins_>|[alog10_]	3
	epp2	<fort_hfp_builtins_>|[atan_]		4
	epp2	<fort_hfp_builtins_>|[atan2_]		5
	epp2	<fort_hfp_builtins_>|[sin_]		6
	epp2	<fort_hfp_builtins_>|[cos_]		7
	epp2	<fort_hfp_builtins_>|[tanh_]		8
	epp2	<fort_hfp_builtins_>|[sqrt_]		9
	epp2	<fort_hfp_builtins_>|[dmod_]		10
	epp2	<fort_hfp_builtins_>|[dexp_]		11
	epp2	<fort_hfp_builtins_>|[dlog_]		12
	epp2	<fort_hfp_builtins_>|[dlog10_]	13
	epp2	<fort_hfp_builtins_>|[datan_]		14
	epp2	<fort_hfp_builtins_>|[datan2_]	15
	epp2	<fort_hfp_builtins_>|[dsin_]		16
	epp2	<fort_hfp_builtins_>|[dcos_]		17
	epp2	<fort_hfp_builtins_>|[dsqrt_]		18
	epp2	<fort_hfp_builtins_>|[cabs_]		19
	epp2	<fort_hfp_builtins_>|[cexp_]		20
	epp2	<fort_hfp_builtins_>|[clog_]		21
	epp2	<fort_hfp_builtins_>|[csin_]		22
	epp2	<fort_hfp_builtins_>|[ccos_]		23
	epp2	<fort_hfp_builtins_>|[csqrt_]		24
	epp2	<fort_hfp_builtins_>|[cxp2_]		25
	epp2	<fort_hfp_builtins_>|[tan_]		26
	epp2	<fort_hfp_builtins_>|[dtan_]		27
	epp2	<fort_hfp_builtins_>|[asin_]		28
	epp2	<fort_hfp_builtins_>|[dasin_]		29
	epp2	<fort_hfp_builtins_>|[acos_]		30
	epp2	<fort_hfp_builtins_>|[dacos_]		31
	epp2	<fort_int_builtins_>|[index_]		32
	epp2	<fort_hfp_builtins_>|[dtanh_]		33
	epp2	<fort_hfp_builtins_>|[sinh_]		34
	epp2	<fort_hfp_builtins_>|[dsinh_]		35
	epp2	<fort_hfp_builtins_>|[cosh_]		36
	epp2	<fort_hfp_builtins_>|[dcosh_]		37
	epp2	<fort_hfp_builtins_>|[abs_]		38
	epp2	<fort_int_builtins_>|[iabs_]		39
	epp2	<fort_hfp_builtins_>|[dabs_]		40
	epp2	<fort_hfp_builtins_>|[dim_]		41
	epp2	<fort_int_builtins_>|[idim_]		42
	epp2	<fort_hfp_builtins_>|[ddim_]		43
	epp2	<fort_hfp_builtins_>|[sign_]		44
	epp2	<fort_int_builtins_>|[isign_]		45
	epp2	<fort_hfp_builtins_>|[dsign_]		46
	epp2	<fort_hfp_builtins_>|[aint_]		47
	epp2	<fort_hfp_builtins_>|[aimag_]		48
	epp2	<fort_hfp_builtins_>|[conjg_]		49
	epp2	<fort_int_builtins_>|[len_]		50
	epp2	<fort_hfp_builtins_>|[dint_]		51
	epp2	<fort_hfp_builtins_>|[anint_]		52
	epp2	<fort_hfp_builtins_>|[dnint_]		53
	epp2	<fort_hfp_builtins_>|[nint_]		54
	epp2	<fort_hfp_builtins_>|[idnint_]	55
	epp2	<fort_hfp_builtins_>|[dprod_]		56
	epp2	<fort_int_builtins_>|[mod_]		57
	epp2	<fort_hfp_builtins_>|[amod_]		58
	epp2	<fort_int_builtins_>|[ilr_]		59
	epp2	<fort_int_builtins_>|[ils_]		60
	epp2	<fort_int_builtins_>|[irl_]		61
	epp2	<fort_int_builtins_>|[irs_]		62

"
"	Function:	PL/I float hex (27) modulus: mod(x, y)
"
"	Entry:	EAQ = x
"		bp|0 -> y
"		X0 = offset in caller's text section of return point
"
"	Exit:	EAQ = if y=0 then x else x - floor(x/y)*y
"
hfp_mdfl1:
	fszn	bp|0		return x if y = 0
	tze	hfp_mdfl1a
	fst	sp|temp		save x
	fdv	bp|0		EAQ = x/y
	tmi	5,ic		if EAQ >= 0 then:
	   fmp	   P2.0H,du	   EAQ = 2*(x/y)
	   fad	   =18b25,du	   EAQ = 2*floor(x/y)
	   fmp	   M0.5H,du	   EAQ = -floor(x/y)
	tra	5,ic		else:
	   dfsb	   hfp_almost_one	   EAQ = -(abs(x/y) + almost_one)
	   fmp	   M2.0H,du	   EAQ = 2*(abs(x/y) + almost_one)
	   fad	   =18b25,du	   EAQ = 2*floor(abs(x/y) + almost_one)
	   fmp	   P0.5H,du	   EAQ = -floor(x/y)
	fmp	bp|0		EAQ = -floor(x/y)*y
	fad	sp|temp		EAQ = x - floor(x/y)*y
	tra	sp|tbp,*x0	return

hfp_mdfl1a:
	fcmp	P0.0H,du		set indicators properly
	tra	sp|tbp,*x0	return


"
"	Function:	PL/I float hex (63) modulus: mod(x, y)
"
"	Entry:	EAQ = x
"		bp|0 -> y
"		X0 = offset in caller's text section of return point
"
"	Exit:	EAQ = if y=0 then x else x - floor(x/y)
"
hfp_mdfl2:
	dfst	sp|temp		save x
	dfld	bp|0		load y
	tze	hfp_mdfl2a	return x if y = 0
	dfdi	bp|0		EAQ = x/y
	tmi	5,ic		if EAQ >= 0 then:
	   fmp	   P2.0H,du	   EAQ = 2*(x/y)
	   fad	   =18b25,du	   EAQ = 2*floor(x/y)
	   fmp	   M0.5H,du	   EAQ = -floor(x/y)
	tra	5,ic		else:
	   dfsb	   hfp_almost_one	   EAQ = -(abs(x/y) + almost_one)
	   fmp	   M2.0H,du	   EAQ = 2*(abs(x/y) + almost_one)
	   fad	   =18b25,du	   EAQ = 2*floor(abs(x/y) + almost_one)
	   fmp	   P0.5H,du	   EAQ = -floor(x/y)
	dfmp	bp|0		EAQ = -floor(x/y)*y

hfp_mdfl2a:
	dfad	sp|temp		EAQ = if y=0 then x else x-floor(x/y)*y
	tra	sp|tbp,*x0	return


"
"	Function:	round a float hex (71) number to fixed bin (71)
"
"	Entry:	EAQ = number
"		X0 = offset in caller's text section of return point
"
"	Exit:	AQ = nearest fixed bin (71) number
"
hfp_nearest_integer:
	tmi	5,ic		if number +ve then:
	  fad	  P0.5H,du	  EAQ = number + 0.5
	  fmp	  P2.0H,du	  EAQ = 2*(number + 0.5)
	  ufa	  =18b25,du	  AQ = floor(number + 0.5)
	  tra	  sp|tbp,*x0	  return
"				else:
	  fad	  M0.5H,du	  EAQ = -(abs(number) + 0.5)
	  fmp	  M2.0H,du	  EAQ = 2*(abs(number) + 0.5)
	  ufa	  =18b25,du	  AQ = floor(abs(number) + 0.5)
	  negl	  0	  	  AQ = -floor(abs(number) + 0.5)
	  tra	  sp|tbp,*x0	  return


"
"	Function:	round off a float hex (71) number
"
"	Entry:	EAQ = number
"		X0 = offset in caller's text section of return point
"
"	Exit:	EAQ = nearest whole float hex (71) number
"
hfp_nearest_whole_number:
	tmi	6,ic		if number +ve then:
	  fad	  P0.5H,du	  EAQ = number + 0.5
	  fmp	  P2.0H,du	  EAQ = 2*(number + 0.5)
	  fad	  =18b25,du	  EAQ = 2*floor(number + 0.5)
	  fmp	  P0.5H,du	  EAQ = floor(number + 0.5)
	  tra	  sp|tbp,*x0	  return
"				else:
	  fad	  M0.5H,du	  EAQ = -(abs(number) + 0.5)
	  fmp	  M2.0H,du	  EAQ = 2*(abs(number) + 0.5)
	  fad	  =18b25,du	  EAQ = 2*floor(abs(number) + 0.5)
	  fmp	  M0.5H,du	  EAQ = -floor(abs(number) + 0.5)
	  tra	  sp|tbp,*x0	  return


"
"	Function:	convert a fixed bin (35) number to complex float hex (27)
"
"	Entry:	Q = number
"		X0 = offset in caller's text section of return point
"
"	Exit:	EAQ = complex float hex (27) result
"
hfp_rfb1_to_cflb1:
	lls	36		convert to fixed bin (71) first
	lrs	36


"
"	Function:	convert from fixed bin (71) to complex float hex (27)
"
"	Entry:	AQ = number
"		X0 = offset in caller's text section of return point
"
"	Exit:	EAQ = complex float hex (27) result
"
hfp_rfb2_to_cflb1:
	lde	=18b25,du		EAQ = unnormalized 2*float(source)
	fad	P0.0H,du		EAQ = 2*float(source)
	fmp	P0.5H,du		EAQ = float(source)
	fst	sp|temp
	lda	sp|temp		load real part
	ldq	P0.0H,du		load imaginary part
	tra	sp|tbp,*x0	return


"
"	Function:	truncate a float hex (71) number
"
"	Entry:	EAQ = number
"		X0 = offset in caller's text section of return point
"
"	Exit:	EAQ = trunc (number)
"
hfp_trunc_fl:
	tmi	5,ic		if number +ve then:
	  fmp	  P2.0H,du	  EAQ = 2*number
	  fad	  =18b25,du	  EAQ = 2*trunc(number)
	  fmp	  P0.5H,du	  EAQ = trunc(number)
	  tra	  sp|tbp,*x0	  return
"				else:
	  fmp	  M2.0H,du	  EAQ = 2*abs(number)
	  fad	  =18b25,du	  EAQ = 2*trunc(abs(number))
	  fmp	  M0.5H,du	  EAQ = trunc(number)
	  tra	  sp|tbp,*x0	  return

"
" The following code is used by trace to gain control of PL/I and FORTRAN programs.
"
	transfer_vector	trace_

"
"	Function:	enter Binary Floating Point (BFP) mode
"
"	Entry:	X0 = offset in caller's text section of return point
"
"	Exit:	PR0, (sp|stack_frame.operator_ptr) -> operator_table
"
trace_enter_BFP_mode:
	ldi	0,dl		clear HFP mode if it's set
	epp0	trace_operator_table	change to HFP trace operators
	spri0	sp|stack_frame.operator_ptr
	tra	sp|tbp,*x0

"
"	Function:	enter Hexadecimal Floating Point (HFP) mode
"
"	Entry:	X0 = offset in caller's text section of return point
"
"	Exit:	PR0, (sp|stack_frame.operator_ptr) = hfp_operator_table
"
"	Note:	It is not sufficient to just request HFP mode.  We must
"		check that our request has been honoured, since if HFP
"		mode has not been enabled (or if it is not supported), a
"		request to enter HFP mode is simply ignored.  If we find
"		that our request to enter HFP mode has not been honoured,
"		we attempt to enable HFP mode.  If we are unsuccessful,
"		we signal the condition 'cannot_enable_HFP_mode'.  If we
"		are restarted after signalling this condition, we repeat
"		all the above steps.
"
trace_enter_HFP_mode:
	ldi	HFP_mask,dl	request HFP mode
	fld	P1.0H,du		check if request honoured
	fad	P0.0H,du
	sba	=o020000,du
	tze	trace_enter_HFP_mode.entered
	lda	=o600000,du	try to enable HFP mode
	tsx1	call_set_hexfp_control
	ldi	HFP_mask,dl	check if successful
	fld	P1.0H,du
	fad	P0.0H,du
	sba	=o020000,du
	tze	trace_enter_HFP_mode.entered
	ldi	=0,dl		clear HFP mode request
	eppbp	=22acannot_enable_HFP_mode
	eax6	22
	ldq	=1000,dl
	tsx1	call_signal_	signal 'cannot_enable_HFP_mode' condition
	tra	trace_enter_HFP_mode	try again

trace_enter_HFP_mode.entered:
	epp0	hfp_operator_table	change to HFP trace operators
	spri0	sp|stack_frame.operator_ptr
	tra	sp|tbp,*x0
"
	ext_entry		trace_
"
	ext_entry_desc	trace_
"
	ext_entry		trace_,ss_
"
	ext_entry_desc	trace_,ss_
"
trace_entry_operators_end:

"
" The following code is used by trace to gain control of PL/I and FORTRAN
" programs running in HFP mode.
"
	transfer_vector	trace_,hfp_

"
" The ALM entry operator used by trace.
"
alm_trace_operators_begin:
	alm_entry_op trace_
alm_trace_operators_end:
" 
"	operator to update long_profile entry
"	Calling sequence:
"
"	tsx0	ap|long_profile
"	zero	header_relp,entry_offset
"
	include	long_profile
"
"	NB:  THIS OPERATOR IS NOT ALLOWED TO DESTROY ANY REGISTERS,
"	INCLUDING A, Q, index registers, pointer registers,
"	THE INDICATOR OR STRING REGISTERS.  This is part of the
"	contract of long_profile not to affect the object
"	code.
"
"
long_profile:
	sti	sp|temp_indicators		save indicators
	sreg	sp|8			save registers
	get_stack_offset
	spri	sp|stack_header.stack_end_ptr,au*
"
	get_our_lp
	stcd	sp|stack_frame.return_ptr
	callsp	<cpu_time_and_paging_op_>|[cpu_time_and_paging_op_]
"
	staq	sp|cpu		save virtual cpu time
	stx0	sp|page		save page faults
	sxl1	sp|page		..
"
	ldx0	sp|8			restore x0
	eppbp	sp|tbp,*0			pt at arg word
	spbpbp	sp|stack_frame.return_ptr	restore return ptr
	epbpsb	sp|0			sb = stack base
"
	ldi	=o004000,dl		mask against overflow (vcpu faults at 19 hrs)
	epaq	bp|0			get ptr to static section
	lprplb	sb|stack_header.isot_ptr,*au
	ldx1	bp|0			get header relp
	epplb	lb|0,1			point at long_profile_header
	lxl2	lb|long_profile_header.last_offset	point at profile entry to be updated
	aos	lb|long_profile_entry.count,2	update
	ldaq	sp|cpu
	sblaq	lb|long_profile_header.last_vcpu
	asq	lb|long_profile_entry.vcpu,2
	ldq	sp|page
	sblq	lb|long_profile_header.last_pf
	asq	lb|long_profile_entry.pf,2
"
	ldaq	sp|cpu			set up for next time
	staq	lb|long_profile_header.last_vcpu
	ldq	sp|page
	stq	lb|long_profile_header.last_pf
	lxl3	bp|0
	sxl3	lb|long_profile_header.last_offset
"
	lpri	sb|stack_header.stack_end_ptr,* restore regs
	lreg	sp|8			..
	eax0	1,0			increment for return
	ldi	sp|temp_indicators		restore indicators
	tra	sp|tbp,*0			return
signal_error_missing:
	eppbp	missing_error
	ldx6	missing_error_length,du
	tra	signal_op
missing_error:
	aci	"missing_pl1_io_operator"
	equ	missing_error_length,23
" 
" The following code performs an assembly-time cross-check of the consistency
" of the operator_table region. The location referenced by operator_table itself
" must be even...if it is not, the compiled code that references it will fail.
" The following expression will divide-by-zero if operator_table is odd.
" in PL/I: error1 = 1 / (1 - mod (operator_table - reloc_0, 2));
"
	equ	optbl_abs,operator_table-begin_pl1_operators	" kill off relocation
	equ	error1,1/(1-(optbl_abs-2*(optbl_abs/2)))	" ERROR 1: operator_table on ODD location.
"
	end




		    power_.alm                      11/11/89  1150.6rew 11/11/89  0804.2       34758



" ***********************************************************
" *                                                         *
" * 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.      *
" *                                                         *
" ***********************************************************

"	Modified 24 June 1980 by C R Davis to fix bug in which |b| < 1.0
"		causes overflow fault in power_integer_.
"	Modified 21 Dec 83 by HH to add HFP support.

"	evaluate a ** b in double precision
"	Note: the log routine uses index registers 0-4, so we must avoid using these
"
	segdef	integer_power_single_
	segdef	integer_power_double_
	segdef	single_power_single_
	segdef	single_power_double_
	segdef	double_power_single_
	segdef	double_power_double_
	segdef	hfp_integer_power_single_
	segdef	hfp_integer_power_double_
	segdef	hfp_single_power_single_
	segdef	hfp_single_power_double_
	segdef	hfp_double_power_single_
	segdef	hfp_double_power_double_
"
	equ	return,-2
	equ	work_size,2
	equ	a,0		same as in power_integer_
"
integer_power_single_:
	lda	0,dl		float a
	lde	=71b25,du
	fad	=0.0,du
"
single_power_single_:
double_power_single_:
	tsx5	common
	fmp	1|0
	fld	1|0
	fcmg	1|0
	tsp3	<double_logarithm_>|[double_log_base_e_]
	tra	<double_exponential_>|[double_exponential_]
"
integer_power_double_:
	lda	0,dl		float a
	lde	=71b25,du
	fad	=0.0,du
"
single_power_double_:
double_power_double_:
	tsx5	common
	dfmp	1|0
	dfld	1|0
	dfcmg	1|0
	tsp3	<double_logarithm_>|[double_log_base_e_]
	tra	<double_exponential_>|[double_exponential_]
"
hfp_integer_power_single_:
	lda	0,dl		float Q
	lde	=18b25,du
	fno
	fmp	=0.5,du
"
hfp_single_power_single_:
hfp_double_power_single_:
	tsx5	hfp_common
	fmp	1|0
	fld	1|0
	fcmg	1|0
	tsp3	<double_logarithm_>|[hfp_double_log_base_e_]
	tra	<double_exponential_>|[hfp_double_exponential_]
"
hfp_integer_power_double_:
	lda	0,dl		float Q
	lde	=18b25,du
	fno
	fmp	=0.5,du
"
hfp_single_power_double_:
hfp_double_power_double_:
	tsx5	hfp_common
	dfmp	1|0
	dfld	1|0
	dfcmg	1|0
	tsp3	<double_logarithm_>|[hfp_double_log_base_e_]
	tra	<double_exponential_>|[hfp_double_exponential_]
"
common:	fcmp	=0.0,du		check a
	tze	test		skip if a = 0
	dfst	2|a		save a
	xec	1,5		load b
	tze	spec		skip if b = 0
	fcmg	28*1024+256,du	is b < 2**27
	tpl	begin		no, skip
	fcmg	=1.0,du		is b > 1?
	tmi	begin		no, must use logs
	ufa	=35b25,du		get int(b) in a
	cmpq	0,dl		is it an integer
	tnz	begin		no, use logs
	cmpa	0,dl		set indicators from a
	tra	<power_integer_>|[power_integer_]
"
hfp_common:
	fcmp	=0.0,du		check a
	tze	test		skip if a = 0
	dfst	2|a		save a
	xec	1,5		load b
	tze	spec		skip if b = 0
	fcmg	=o016400,du	is abs(b) < 2**27?
	tpl	begin		no, skip
	fcmg	=-1.0,du		is abs(b) >= 1?
	tmi	begin		no, must use logs
	ufa	=9b25,du		get int(b) in A
	lls	1
	cmpq	0,dl		is it an integer?
	tnz	begin		no, use logs
	cmpa	0,dl		set indicators from A
	tra	<power_integer_>|[hfp_power_integer_]
"
begin:	dfld	2|a		not integer, restore a
	tmi	err1
	epp2	2|work_size	reserve work space for ourselves
	spri3	2|return		save our return
	xec	3,5		log(a)
	xec	0,5		b * log(a)
	epp3	2|return,*	restore return pt
	xec	4,5		exp(b*log(a))  (exit through exp)
"
spec:	fld	=0.5,du
	fad	=0.5,du
	tra	3|0
"
test:	fszn	1|0		special case when a = 0
	tze	err2		error if a = 0 & b = 0
	tpl	3|0		0 ** positive is 0
	ldq	18,dl
err:	tsx0	<call_math_error_>|[call_math_error_]
	fld	=0.0,du
	tra	3|0
"
err1:	ldq	16,dl
	tsx0	<call_math_error_>|[call_math_error_]
	dfld	2|a		evaluate for abs(a)
	fneg	0
	tra	begin+2
"
err2:	ldq	17,dl		0 ** 0
	tra	err
	end




		    power_integer_.alm              11/11/89  1150.6rew 11/11/89  0804.6       25299



" ***********************************************************
" *                                                         *
" * 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.      *
" *                                                         *
" ***********************************************************

"	evaluate a ** k for integer k
"		fld	a	(or dfld)
"		epp1	k
"		epp2	work
"		tsp3	entry
"
"	Modified 770412 by PG to fix 1602 (overflow indicator not reset before rpt)
"	Modified 790904 by PES to fix fortran bug 231 (2**-127 takes overflow.
"	Modified 831221 by HH to work in both BFP and HFP modes.
"
	segdef	single_power_integer_
	segdef	double_power_integer_
	segdef	power_integer_
	segdef	hfp_single_power_integer_
	segdef	hfp_double_power_integer_
	segdef	hfp_power_integer_
"
	equ	a,0
	equ	f,2
	equ	k,4
	equ	sign_k,5
"
single_power_integer_:
double_power_integer_:
hfp_single_power_integer_:
hfp_double_power_integer_:
	fcmp	=0.0,du		set indicators for a
	dfst	2|a
	tze	test		transfer if a = 0
	lda	1|0		get k
	tze	fequ1		f = 1.0 if k = 0
"
"	power_ comes here when exponent is found to be integral
"	if entered here, k is in the a register--the value of k
"	is NOT valid at 1|0, and the work area at 2|<n> has been
"	set up.
"
power_integer_:
hfp_power_integer_:
	sta	2|sign_k		save k (not necessarily found at 1|0)
	tpl	invert_a		if k negative, invert a, get abs(k)
	fld	=0.5,du
	fad	=0.5,du
	dfdv	2|a		if this over-/under-flows, would have anyhow
	dfst	2|a
	lca	2|sign_k		this is abs(k)
invert_a:
	cmpa	20,dl
	trc	patha
	sba	1,dl
	tze	pathd		answer = a
	als	10		shift tally into position for rptx: C(X0)0,7
	eax0	1,al		set rptx to terminate on all overflows
	eax1	0		index 1 is a placeholder for RPT...make it zero
	dfld	2|a		initialize C(EAQ) to a
	teo	1,ic		clear exponent overflow indicator
	tov	1,ic		clear overflow indicator
	rptx	0,0		repeat dfmp until overflow or tally runout
	dfmp	2|a,1		multiply C(EAQ) by a
done:	fad	=0.0,du		set indicators
	tra	3|0
"
patha:	sta	2|k
	fld	=0.5,du
	fad	=0.5,du
	dfst	2|f
pathc:	lda	2|k
	cana	1,dl		is k even
	tze	even
	dfld	2|a
	dfmp	2|f
	dfst	2|f
even:	lda	2|k
	arl	1		k = k / 2
	tze	pathb
	sta	2|k
	dfld	2|a
	dfmp	2|a
	dfst	2|a		a = a * a
	tra	pathc
pathb:	dfld	2|f
	tra	done
pathd:	dfld	2|a
	tra	done
"
fequ1:	fld	=0.5,du
	fad	=0.5,du
	tra	3|0
"
test:	szn	1|0		special case if a = 0
	tze	err1
	tpl	3|0		0 ** k = 0
	ldq	4,dl		0 ** 0
err:	tsx0	<call_math_error_>|[call_math_error_]
	fld	=0.0,du
	tra	3|0
"
err1:	ldq	3,dl
	tra	err
"
	end




		    principal_angle_.alm            11/11/89  1150.6rew 11/11/89  0805.6       57564



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Bull Inc., 1987                *
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1985 *
" *                                                         *
" ***********************************************************
	name	principal_angle_
" Modification history:
"	Written by H. Hoover, M. Mabey, and B. Wong, April 1985.
"
" Function:  Scale an angle into the range -pi/4 to pi/4.
"
" Entry:  through the appropriately named entry point with:
"	EAQ = input angle to be scaled.
"	X0  = the return address.
"	X2  = a two word HFP offset.  This register is by all of the
"	      floating point math routines for the same purpose.
"	PR2 = points to an even word aligned, 12 word long, scratch area.
"
" Exit:	EAQ = the scaled angle.
"	X1  = mod ((input EAQ)/HALF_PI + 0.5), 4)
"
" Uses:	X1
"	X1  = used to return mod ((input EAQ)/HALF_PI + 0.5), 4)

	segdef	principal_degrees_,principal_radians_

	segref	math_constants_,almost_one

	bool	P2.0H,002100	" yields HFP +2.0 under 'du' modification
	bool	P45.0H,004132	" yields HFP +45.0 under 'du' modification

	equ	angle,0
	equ	temp,angle
	equ	n1,2
	equ	n2,3
	equ	t1,4
	equ	t2,6
	equ	t3,8
	equ	t4,10
	equ	HFP,2

principal_degrees_:
	cmpx2	HFP,du
	tze	hfp_principal_degrees

bfp_principal_degrees:
	frd	0
	fcmg	two_pwr_54	" is the EAQ too large
	tpnz	angle_too_big	" Yup.

	fst	pr2|angle
	dfdv	ninety		" EAQ = EAQ/90
	fad	=0.5,du		" EAQ = EAQ/90 + 0.5
	dufa	almost_one
	dufs	almost_one
	ufa	=71b25,du		" AQ = EAQ/90 + 0.5 in integer form

	eax1	0,ql
	anx1	3,du		" X1 = mod(AQ,4)

	fad	=0.0,du		" EAQ = floor(EAQ/90 + 0.5) in floating point form
	fmp	=90.0,du		" EAQ = floor(EAQ/90 + 0.5)*90
	fneg	0		" EAQ = -floor(EAQ/90 + 0.5)*90
	fad	pr2|angle		" EAQ = angle-floor(EAQ/90 + 0.5)*90
	tra	0,x0		" return to caller

hfp_principal_degrees:
	frd	0
	fcmg	hfp_two_pwr_48	" is the EAQ too large
	tpl	angle_too_big	" Yup.

	fst	pr2|angle
	dfdv	hfp_ninety	" EAQ = EAQ/90
	fad	=0.5,du		" EAQ = EAQ/90 + 0.5
	dufa	almost_one
	dufs	almost_one
	ufm	P2.0H,du
	ufa	=18b25,du		" AQ = EAQ/90 + 0.5 in integer form

	eax1	0,ql
	anx1	=3,du		" X1 = mod(AQ,4)

	fad	=0.0,du		" EAQ = floor(EAQ/90 + 0.5)*2
	fmp	P45.0H,du		" EAQ = floor(EAQ/90 + 0.5)*90 in floating point form
	fneg	0		" EAQ = -floor(EAQ/90 + 0.5)*90
	fad	pr2|angle		" EAQ = angle-floor(EAQ/90 + 0.5)*90
	tra	0,x0		" return to caller


principal_radians_:
	cmpx2	HFP,du
	tze	hfp_principal_radians

bfp_principal_radians:
	frd	0
	fst	pr2|angle
	fcmg	two_pwr_27	" is the EAQ too large
	tpnz	bfp_big_angle	" Yup.

	dfmp	one_over_half_pi	" EAQ = EAQ/half_pi
	fad	=0.5,du		" EAQ = EAQ/half_pi + 0.5
	dufa	almost_one
	dufs	almost_one
	ufa	=71b25,du		" AQ = EAQ/half_pi + 0.5 in integer form

	eax1	0,ql
	anx1	3,du		" X1 = mod(AQ,4)

	fad	=0.0,du		" EAQ = floor(EAQ/half_pi + 0.5) in floating point form
	fst	pr2|n1		" n1 = EAQ
	tra	small_angle_join

hfp_principal_radians:
	frd	0
	fst	pr2|angle
	fcmg	hfp_two_pwr_24	" is the EAQ too large
	tpnz	hfp_big_angle	" Yup.

	dfmp	one_over_half_pi,x2	" EAQ = EAQ/half_pi
	fad	=0.5,du		" EAQ = EAQ/half_pi + 0.5
	dufa	almost_one
	dufs	almost_one
	ufm	P2.0H,du
	ufa	=18b25,du		" AQ = EAQ/half_pi + 0.5 in integer form in integer form

	eax1	0,ql
	anx1	=3,du		" X1 = mod(AQ,4)

	fad	=0.0,du
	fmp	=0.5,du		" EAQ = floor(EAQ/half_pi + 0.5) in floating point form
	fst	pr2|n1		" n1 = EAQ

small_angle_join:
	fmp	half_pi1,x2
	dfst	pr2|t1		" t1 = n1*half_pi1

	fld	pr2|n1
	fmp	half_pi2,x2
	dfst	pr2|t2		" t2 = n1*half_pi2

	fld	pr2|n1
	fmp	half_pi3,x2
	dfst	pr2|t3		" t3 = n1*half_pi3

	fld	pr2|angle		" answer = angle - t1 - t2 - t3
	dfsb	pr2|t1
	dfsb	pr2|t2
	dfsb	pr2|t3
	tra	0,x0

hfp_big_angle:
	fcmg	hfp_two_pwr_48	" is the EAQ too large?
	tpnz	angle_too_big	" Yup.

	dfmp	one_over_half_pi,x2	" EAQ = EAQ/half_pi
	fad	=0.5,du		" EAQ = EAQ/half_pi + 0.5
	dufa	almost_one
	dufs	almost_one
	ufm	P2.0H,du
	ufa	=18b25,du		" AQ = EAQ/half_pi + 0.5 in integer form in integer form

	eax1	0,ql
	anx1	=3,du		" X1 = mod(AQ,4)

	fad	=0.0,du		" EAQ = floor(EAQ/half_pi + 0.5)*2
	fmp	=0.5,du		" EAQ = floor(EAQ/half_pi + 0.5) in floating point form
	fst	pr2|n1		" n1 = EAQ
	tra	big_angle_join


bfp_big_angle:
	fcmg	two_pwr_54	" is the EAQ too large?
	tpnz	angle_too_big	" Yup.

	dfmp	one_over_half_pi	" EAQ = EAQ/half_pi
	fad	=0.5,du		" EAQ = EAQ/half_pi + 0.5
	dufa	almost_one
	dufs	almost_one
	ufa	=71b25,du		" AQ = EAQ/half_pi + 0.5 in integer form

	eax1	0,ql
	anx1	=3,du		" X1 = mod(AQ,4)

	fad	=0.0,du		" EAQ = floor(EAQ/half_pi + 0.5) in floating point form
	fst	pr2|n1		" n1 = EAQ

big_angle_join:
	fsb	pr2|n1
	fst	pr2|n2		" n2 = n - n1

	fld	pr2|n1
	fmp	half_pi1,x2
	dfst	pr2|t1		" t1 = n1*half_pi1

	fld	pr2|n1		" calculate n1*half_pi2 + n2*half_pi1
	fmp	half_pi2,x2
	dfst	pr2|t2
	fld	pr2|n2
	fmp	half_pi1,x2
	dfad	pr2|t2
	dfst	pr2|t2		" t2 = (n1*half_pi2 + n2*half_pi1)

	fld	pr2|n1		" calculate n1*half_pi3 + n2*half_pi2
	fmp	half_pi3,x2
	dfst	pr2|t3
	fld	pr2|n2
	fmp	half_pi2,x2
	dfad	pr2|t3
	dfst	pr2|t3		" t3 = (n1*half_pi3 + n2*half_pi2)

	fld	pr2|n1		" calculate n1*half_pi4 + n2*half_pi3
	fmp	half_pi4,x2
	dfst	pr2|t4
	fld	pr2|n2
	fmp	half_pi3,x2
	dfad	pr2|t4
	dfst	pr2|t4		" t4 = (n1*half_pi4 + n2*half_pi3)

	fld	pr2|angle		" answer = angle - t1 - t2 - t3
	dfsb	pr2|t1
	dfsb	pr2|t2
	dfsb	pr2|t3
	dfsb	pr2|t4

	tra	0,x0		" return to caller

angle_too_big:
	ldq	code,x2		" pick the appropriate error message
	stx0	pr2|temp		" save X0
	tsx0	<call_math_error_>|[call_math_error_]
	ldx0	pr2|temp		" restore X0

	eax1	0		" X1 = 0
	fld	=0.0,du		" EAQ = 0, set indicators
	tra	0,x0		" return to caller


" Constants:

	even
ninety:	dec	90.0d0
hfp_ninety:
	oct	004264000000,000000000000
one_over_half_pi:
	dec	6.3661977236758134307553d-1
	oct	000505746033,344710405225
hfp_two_pwr_24:
	oct	016040000000,000000000000
two_pwr_27:
	oct	070400000000,000000000000
hfp_two_pwr_48:
	oct	032040000000,000000000000
two_pwr_54:
	oct	156400000000,000000000000
half_pi1:	oct	002622077325,000000000000
	oct	002062207732,000000000000
half_pi2:	oct	706420550604,000000000000
	oct	766050420550,000000000000
half_pi3: oct	616646114314,000000000000
	oct	752060432304,000000000000
half_pi4: oct	526505600670,000000000000
	oct	736061461213,000000000000
code:	dec	70,0,71
	end




		    put_field_.alm                  11/11/89  1150.6rew 11/11/89  0804.6      217872



" ***********************************************************
" *                                                         *
" * 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(88-04-06,Huen), approve(88-04-06,MCR7871),
"     audit(88-04-19,RWaters), install(88-04-26,MR12.2-1043):
"     Fix PL/1 bug  2140 and 2152.
"                                                      END HISTORY COMMENTS


"
"	Operators for QUICK STREAM I/O
"
"	Modified:	03/01/78 by RAB to fix 1712
"	Modified:	04/04/78 by RAB to fix 1721
"	Modified: 02/16/84 by MBW to fix probe 13 / TR14172 
"	Modified: 04/06/88 by SH to fix 2140 and 2152
"
"
" Written during 1975 by R.Schoeman to reimplement pl1 stream output in the
" operators to improve performance.
"
	name	put_field_
	include	stack_header
	include	plio2_fsb
	include	plio2_ps
	include	stack_frame
	include	iocbx
	equ	tbp,38
	equ	ps_ptr,42
	equ	total_len,44
	equ	t6,45
	equ	x7_stored,46	upper half of word in storage
	equ	source_str_offset,46	lower half of word
	equ	t2,47
	equ	ctrl_ret_loc,47
	equ	output_request_type,48	0 - edit, 1 - list, other - control requests
"					that abort on endpage
	equ	storage_taken,49		known and set as extend_size in alloc
	equ	double_temp,52
	equ	orig_len,52		yes this conflicts with double_temp, but I'm short of space
	equ	io_arg_list,54
	equ	temp,62
	segdef	restore_regs_and_frame_and_ret
	segdef	put_control_from_format
	segdef	any_qs_error_no_ret
	segdef	set_no_ret_error
	segdef	put_field
	segdef	put_field_str
	segdef	put_field_chk
	segdef	put_field_from_format
	segdef	put_control
"	operator to put out a string, entered via put_list_eis with the
"	descriptor of the output item in sp|temp as well  as in the q
"
put_field_str:
	eppap	sp|ps_ptr,*
	sta	ap|ps.a_stored	we can't clobber  most regs
	stx7	sp|x7_stored
	lda	sp|temp		temp has  the desc, put there by put_list_eis
	sta	ap|ps.q_stored	since the desc was in the q on entry to put_list_eis
	sta	ap|ps.descr
	canq	=o004000,du
	tze	var_str		var_str handles both char & bit varying strs
	ana	=o000077777777	change descr  into length, blocking out type
	cmpq	=o114000,du
	tze	bit_str
	tra	char_str
var_str:
	lda	bp|-1		length word is adr(str) -1
	cmpq	=o120000,du	bit str?
	tnz	char_str
bit_str:
	ada	3,dl		add three to length, for leading&trailing quotes & "b"
	sta	sp|total_len	this will be the final length output
	ldq	sp|total_len
	tsx6	get_newbuf	we  must get a buffer big  enough for len(bit_str)+3 chars
	mlr	(),(pr),fill(042)		042 is ascii quote
	zero	0		only interested in fill char
	desc9a	bp|0,1		pr2 is  where to shove it
	lda	sp|total_len	at this point bp->final char string and pr3->source bit str
	sba	3,dl		this is how  many bits need conversion to "1" or "0"
bit_loop:
	sba	1,dl		loop through all bits converting them to char "1" or "0"
	tmi	bit_loop_done
	cmpb	(pr,al),()
	descb	pr3|0,1
	zero	0		remember, pr3 is pointing to the original bit str
	tze	bit_is_zero
	mlr	(),(pr,al),fill(061)	move in a "1" (061), since the bit is "on"
	zero	0
	desc9a	pr2|0(1),1	target is pr2 up on char since there is a quote in position 1
	tra	bit_loop
bit_is_zero:
	mlr	(),(pr,al),fill(060)	(060) is an ascii "0"
	zero	0
	desc9a	pr2|0(1),1
	tra	bit_loop
bit_loop_done:
	lda	sp|total_len	now to insert trailing quote
	sba	2,dl		trailing quote will be the second to last char
	mlr	(0),(pr,al),fill(142)	142 is ascii "b"
	desc9a	quote_char,1
	desc9a	bp|0,2		pr2 is  where to shove it
	ldq	sp|total_len	conversion to final form is done, put len in q & off we go
	tra	put_field_from_str	pr2->char string to put out, q has len, we're set up for put_field
"
"
char_str:
	epp4	ap|ps.fsbp,*	we have to  ask the fsb if its a print file
	ldq	pr4|fsb.switch	cause if not, we must  double quotes and enclose
	canq	fsb.print,du	the string in quotes.  If it is a print file,
	tze	not_print		a vanilla put_field will do.
	lrs	36		length is in a, move it to  q for put_field
	stz	sp|storage_taken	set sortage_taken
	tra	put_field_from_print	and off we go
not_print:
	sta	sp|orig_len	we must know orig len  to know when we're finished
	sta	sp|total_len
	lrs	35		get 2*total_len in the q
	adq	2,dl		output string, which would be all quotes. Each quote would
	tsx6	get_newbuf	be doubled and a quote on each end: total_len=2*orig_len+2
	epp7	pr2|0		now pr2->new buffer and pr3->source string(a side effect of get_newbuf)
	mlr	(0),(pr),fill(042)	042 is ascii quote, put in the leading one
	zero	0		only interested in fill char
	desc9a	bp|0,1		pr2 is  where to shove it
	aos	sp|total_len	and update the true total len
	ldq	sp|orig_len
"
copy_more:
	scm	(pr,rl),()	scan to find the first quote  in  source str
	desc9a	pr3|0,ql		string to scan(source)
	desc9a	quote_char,1	what to scan for
	arg	sp|temp		place to put offset of  first quote
	ttn	2,ic		tally on  if string has no more quotes
	aos	sp|temp		add  one cause we want to move the original quote  also
	lda	sp|temp		now temp is up to and including any quote found
	aos	sp|total_len	this one will be for the new doubled quote or trailing quote if none foundd
"
	mlr	(pr,rl),(pr,rl)	move up to and  including quote
	desc9a	pr3|0,al		pr3->source string
	desc9a	bp|0(1),al	pr2->target string, up 1 char for leading quote
	a9bd	bp|0,al		update pr2 to reflect new contents
	a9bd	pr3|0,al		update pr3 to point to as-yet unmoved string
	mlr	(0),(pr),fill(042)	insert quote at pr2|(1) cause pr2's always a byte behind
	zero	0		only interested in fill char
	desc9a	bp|0(1),1		pr2 is  where to shove it
	ttn	move_is_over	tally still set on if no quote was found
"
	lda	1,dl
	a9bd	bp|0,al		update target  to reflect new quote just doubled
	sbq	sp|temp		length  of string left to scan is decreased
	tra	copy_more
"
move_is_over:
	ldq	sp|total_len	put_field expects length in q,  pr2 must be reset to start of string
	epp2	pr7|0		reset pr2 to start of string
	tra	put_field_from_str	and off
"
"
get_newbuf:
	epp3	bp|0		we set pr3 to where pr2 was, and set pr2 to the new buffer
	tsx1	<pl1_operators_>|[alloc]	length of new buffer in bytes is in the a
	tra	0,6		and return
"
"	operator for put_field_chk
"	entered with pointer to datum in bp,offset to check for minus sign
"	in x6, length in q
"
put_field_chk:
	cmpc	(),(pr,x6)	check that offset x6 is not "-"
	desc9a	minus_sign,1
	desc9a	bp|0,1
	tnz	check_okay		if its a "-",e_format too small for value
	eppap	sp|ps_ptr,*
	sta	ap|ps.a_stored
	stx7	sp|x7_stored
	eppap	sp|ps_ptr
	spriap	sp|io_arg_list+2
	fld	1*2048,dl
	staq	sp|io_arg_list
	eppap	sp|tbp,*0			get ptr to inst that invoked op
	spriap	sp|stack_frame.return_ptr	reset return ptr so stack_frame_exit_
"					will know where we came from
	eppap	sp|io_arg_list
	tsx1	<pl1_operators_>|[get_our_lp]
	callsp	<plio2_>|[pve_error]

check_okay:
	eax1	1			this reg. needed for next instructtion
	a9bd	bp|0,1			get rid of extra "check" character
"
"	operator for put_field and continuation fo put_field_chk operator
"	entered withpointer to datum in bp,length of output string in q
"
"
"
put_field:
	eppap	sp|ps_ptr,*
	stq	ap|ps.q_stored	we can't clobber q,a,x7, which we use, so save for restoration
	sta	ap|ps.a_stored
	stx7	sp|x7_stored
	stz	sp|storage_taken	BUGFIX, format and print set it
put_field_from_format:
	eppap	sp|ps_ptr,*
put_field_from_print:
	stq	sp|total_len	total_len will be length of string to be put
put_field_from_str:
	spribp	ap|ps.value_p
	epp4	ap|ps.fsbp,*		pr4 will point to fsb
	epp3	pr4|fsb.bptr,*
	stz	sp|output_request_type	output_request_type =0 means edit_dir_out 
	eax6	0
	sxl6	sp|source_str_offset	source_str_offset is offset within string for putting to start
	cmpq	260,dl		we'll allow max string len of 260, cause bit strs add three to 256
	tmoz	3,ic		at this point q must have sp|total_len in it!!!
	lda	8,dl
	tra	any_qs_error_no_ret
	lda	ap|ps.job
	cana	ps.list,du
	tze	reput
	aos	sp|output_request_type	output_request_type =1 means list_dir_out 
	lda	pr4|fsb.switch		fsb_switch is at beginning of fsb
	cana	fsb.print,du		print_switch is bit five of fsb_switch
	tze	check_line	if not print, just check if there's space enough left  on the line
	ldq	pr4|fsb.kol	if it is print, might need leading tab
	div	10,dl		are we on a tab boundary?
	cmpa	0,dl
	tze	check_line	if so, no tab needed
	mpy	10,dl		is there room enough left on line?
	adq	10,dl		BUGFIX, next column position is 10 characters over
	cmpq	pr4|fsb.lsize
	tpnz	line_and_chk_print	if not, needs new_line
	stq	sp|t2		t2 is where the new column position will  be after tab
	lda	tab_char		a is what char should be inserted by insert_char sub-routine
	tsx6	insert_char	and insert the tab
	lda	sp|t2		set the column position
	sta	pr4|fsb.kol
	tsx7	set_fsb_limit	since the tab messes up the old  limit
"
check_line:
	lda	pr4|fsb.lsize	is there room enough on line for output item?
	sba	pr4|fsb.kol
	cmpa	sp|total_len
	tpl	reput		if there is, no more preliminaries neded, just put it out
"
"	now check for the unique case where although the line is not big enough, we do not
"	insert a newline because we are already at the 1st columnposition.
"
	ldq	pr4|fsb.kol
	tze	reput
"
line_and_chk_print:
	tsx6	insert_new_line	if not insert a new_line. This subroutine takes care of kol & pagesize,too
reput:
	ldq	sp|total_len
	adq	pr4|fsb.bnc	q+bnc is buffer_next_char after this io operation
	adq	sp|output_request_type	output_request_type is one iff ldo, this gives trailing blank
	sbq	1,dl		to get buf pos reached, not next free one
	cmpq	pr4|fsb.limit		future bnc>limit?
	tpnz	overlimit		if so, goto overlimit
	lda	pr4|fsb.bnc		get bnc for offset for mlr
	adq	1,dl
	stq	pr4|fsb.bnc		store future bnc into bnc
	sba	1,dl			offset is bnc minus 1
	ldq	sp|total_len
	adq	sp|output_request_type	this restores q to "length to be put"
	lxl7	sp|total_len	x7 will be length to be taken from source str
	asq	pr4|fsb.kol		set proper column
	lxl6	sp|source_str_offset	offset of source string
	mlr	(pr,rl,x6),(pr,rl,al),fill(040)	040=ascii blank,q might=x7+1,where we want trail blank
	desc9a	bp|0,x7		pr2 is source string to move
	desc9a	pr3|0,ql		pr3 is target string,i.e. fsb's buffer
restore_regs_and_frame_and_ret:
	lcq	sp|storage_taken	q is how much to collapse stack
	tze	reset_regs_and_return	if zero, we didn't extend  it and can  return
	epbp3	sp|0		else collapse it the amount we extended it
	asq	sp|stack_frame.next_sp+1
	asq	pr3|stack_header.stack_end_ptr+1
reset_regs_and_return:
	eppap	sp|ps_ptr,*
	ldq	ap|ps.q_stored	we changed the a,q, and x7 & were't allowed to clobber them,  so restore
	lda	ap|ps.a_stored
	ldx7	sp|x7_stored
	tra	<pl1_operators_>|[put_return]		and were finished
"				getting here means the requested job would violate the limit on
overlimit:
	ldq	pr4|fsb.bnc	the last permissable char position in the fsb.buffer, so
	sbq	1,dl		either bsize or lsize was exceeded. First task is to figure out how much
	stq	sp|t2		of the output request falls before the limit, and move those chars.
	lxl6	sp|source_str_offset	t2 now =bnc-1
	lda	pr4|fsb.limit	amount pre-limit will =limit-bnc-1, so subtract t2 from limit
	ssa	sp|t2
	lda	sp|t2		a is now number of chars before the limit
	asa	pr4|fsb.kol	update column index, bnc, and source offset
	asa	pr4|fsb.bnc
	asa	sp|source_str_offset
	mlr	(pr,rl,x6),(pr,rl,ql)	move from pr2 up source offset to fsb.buffer up bnc-1
	desc9a	bp|0,al		length to be moved is limit-bnc-1
	desc9a	pr3|0,al		which is in a
"
	ldq	pr4|fsb.limit	compare limit against bsize to see if bsize was violated
	cmpq	pr4|fsb.bsize	remember that limit represents a character position in the buffer
	tpl	overbuffer	go to overbuffer if buffer is full
	tsx6	insert_new_line	otherwise it must be linesize we exceeded
overmerge:
	ldq	sp|total_len	we get here after handling the limiting condition
	sbq	sp|t2		so figure out how much we must still put out
	stq	sp|total_len	t2 is the amount we put out, so total_len-t2 is the amount left to put
	tra 	reput		and put it out
overbuffer:
	tsx1	call_putchars	if buffer is full, we must put it out
	tra	overmerge		now the limiting condition is resolved, and we can continue
"
"				subroutine to empty the guarenteed-full fsb.buffer into the output stream
call_putchars:
	lda	ap|ps.job		check if its string-option
	cana	ps.string,du
	tnz	string_option_overflow	if it is, this is an error
	lprp5	pr4|fsb.iocb_p		now set up arg list for iox
	spri5	sp|double_temp
	epp3	sp|double_temp
	spri3	sp|io_arg_list+2
	epp3	pr4|fsb.bptr
	spri3	sp|io_arg_list+4
	epp3	pr4|fsb.bsize
	spri3	sp|io_arg_list+6
	epp3	pr4|fsb.lnzc	fsb.lnzc will be status code
	spri3	sp|io_arg_list+8
	sreg	sp|8
	fld	4*2048,dl
	staq	sp|io_arg_list
	eppap	sp|io_arg_list
	stcd	sp|stack_frame.return_ptr
	callsp	pr5|iocb.put_chars,*
	lreg	sp|8
	eppap	sp|ps_ptr,*		restore ptrs
	epp4	ap|ps.fsbp,*
	epp3	pr4|fsb.bptr,*
	eppbp	ap|ps.value_p,*
	stz	pr4|fsb.bnc	next_char must be 1, since we emptied buf
	aos	pr4|fsb.bnc
	lda	pr4|fsb.lnzc	status code
	tnz	put_char_error
	tsx7	set_fsb_limit
	tra	0,1
"
string_option_overflow:
	lda	7,dl			quick_condition_code
	tra	any_qs_error_no_ret
"
set_no_ret_error:
	lda	13,dl
"
any_qs_error_no_ret:
	eax6	set_no_ret_error
	stz	sp|output_request_type
	tra	any_qs_error
"
put_char_error:
	lda	0,dl
	eax6	reset_regs_and_return		x6 points to where to go on return from on-unit
"	label for raising a condition, reached with a code in reg a.
"	code = 0 :: error in xmitting
"	code = 1 :: endpage cond
"	code = 2 :: not a print file when must be
"	code = 3 :: line(n), n<= 0.
"	code = 4 :: control format with value <0, err437
"	code = 5 :: skip(0) requested on non-print file
"	code = 6 :: infinite num. of new-lines to fill page, err433
"	code = 7 :: "buffer" overflow on string-option put, err420
"	code = 8 :: string length over 260, err 242
"	code = 9 :: put_format_ (pfo) , line(0) requested, err 262
"	code = 10:: pfo, no param where needed, err 148
"	code = 11:: pfo, stu_ returned non-zero code, err 195
"	code = 12:: pfo, nesting depth for r_formats exceeded, = 10, err 197
"	code = 13:: attempt to restart after an ERROR or SIZE condition, err 266->OM 466
any_qs_error:
	sta	sp|t6
	spri2	sp|io_arg_list+6	not an argument but must be saved/restored
	epp5	sp|ps_ptr
	spri5	sp|io_arg_list+2
	epp5	sp|t6		t6 is condition code
	spri5	sp|io_arg_list+4
	sreg	sp|8
	tsx1	<pl1_operators_>|[get_our_lp]
	fld	2*2048,dl
	staq	sp|io_arg_list
	eppap	sp|io_arg_list
	stcd	sp|stack_frame.return_ptr
	callsp	<plio2_>|[quick_condition]
	lreg	sp|8
	eppap	sp|tbp,*0
	spriap	sp|stack_frame.return_ptr
	eppap	sp|ps_ptr,*
	epp4	ap|ps.fsbp,*
	epp3	pr4|fsb.bptr,*
	epp2	sp|io_arg_list+6,*
	lda	sp|output_request_type
	cmpa	2,dl
	tmi	0,6		if output_request_type<2, must be list/edit, not control
	tra	ret_from_control		if output_request_type=>2,must be a control so finish here
"
"		subroutine to set the fsb.limit=min(len_left_on_line,len_left_in_buffer)
set_fsb_limit:
	lda	pr4|fsb.lsize
	sba	pr4|fsb.kol
	ada	pr4|fsb.bnc
	sba	1,dl		a is now the pos in buffer of last char on present line
	cmpa	pr4|fsb.bsize	compare to pos in buffer of last char in buffer
	tnc	2,ic
	lda	pr4|fsb.bsize
	sta	pr4|fsb.limit	set limit to the greater of the two
	tra	0,7		and return
"
insert_new_line:
	lda	pr4|fsb.bnc
	sba	1,dl
	cmpa	pr4|fsb.bsize	check if there's room in the buffer for this char
	tmi	3,ic		if there is, no problem
	tsx1	call_putchars	if there isn't , put out the guaranteed-full buffer
	lda	0,dl		reset a to the buffer offset to put the char
	mlr	(pr),(pr,al),fill(012)	move the new_line
	zero	0
	desc9a	pr3|0,1
	aos	pr4|fsb.bnc	update the buffer index
	stz	pr4|fsb.kol	now set column to 0
	lda	=o777777777757	zero out bit32, "emptyline"
	ansa	pr4|fsb.switch	can't be emptyline any longer
	aos	pr4|fsb.lineno	increment lineno
	tsx7	set_fsb_limit	since we reset kol must recalculate the limit
	lda	pr4|fsb.psize	now we must check for possible pagesize violation
	tze	0,6		psize=0 means non-print file, so no ENDPAGE
	ada	1,dl
	cmpa	pr4|fsb.lineno	is lineno = pagesize + 1?
	tnz	0,6		if it is not, return
raise_endpage:
	lda	1,dl		this is the code fora pagesize error
	tra	any_qs_error	and raise the error
"
"	beginning of insert_char subroutine
"
insert_char:
	sta	sp|t6		a has the char to be inserted
	lda	pr4|fsb.bnc
	sba	1,dl
	cmpa	pr4|fsb.bsize	check if there's room in the buffer for this char
	tmi	3,ic		if there is, no problem
	tsx1	call_putchars	if there isn't , put out the guaranteed-full buffer
	lda	0,dl		reset a to the buffer offset to put the char
	mlr	(pr),(pr,al)	move the char
	desc9a	sp|t6,1		we squirreled it away in t6
	desc9a	pr3|0,1
	aos	pr4|fsb.bnc	update the buffer index
	tra	0,6
"
" end of insert_char subroutine
"
"	operator for put_control
"	entered with type of control index in x6,
"	number of times to do that control (or target for the control) in q
"
put_control:
	eppap	sp|ps_ptr,*
	epp1	reset_regs_and_return	pr1 will be where to go after we're done
	stq	ap|ps.q_stored	save the regs we can't clobber
	sta	ap|ps.a_stored
	stx7	sp|x7_stored
put_control_from_format:
	sprp1	sp|ctrl_ret_loc	call_putchars will clobber pr1, so save it here
	eppap	sp|ps_ptr,*	pr1 has been set by put_format
	epp4	ap|ps.fsbp,*
	epp3	pr4|fsb.bptr,*
	stc1	sp|output_request_type	this "I am a control" flag is for endpage
"					processing -- endpage aborts processing of
"					most controls
	cmpx6	3,du		3=page request, which has no value in q
	tze	check_print_file	so just check if its print file and go on from there
	cmpq	0,dl		otherwise see if count is >= 0
	tpl	3,ic		no control is allowed a negative count
	lda	4,dl		this is the error code for negative control count
	tra	any_qs_error	and raise the error
"
	cmpx6	1,du		1 is code for skip request
	tnz	check_x_format	if not, try next test
"
	cmpq	0,dl		skip is allowed a 0 count in the request
	tnz	skip_more		but only if it is a print file
	lda	pr4|fsb.switch	so test to see if print-file bit is on
	cana	fsb.print,du
	tnz	3,ic		if it is, were safe
	lda	5,dl		if not, set error code
	tra	any_qs_error	and raise the error
	lda	carr_rtn_char	skip(0) means give a carriage return but no line-feed
	tsx6	insert_char	so insert the carr-return
	stz	pr4|fsb.kol	kol is now 0
set_fsb_and_ret:
	tsx7	set_fsb_limit	we have to set the limit since control chars usually change it
ret_from_control:
	lprp1	sp|ctrl_ret_loc
	tra	pr1|0		and return,pr1 having been set on or prior to entry to put_control
skip_more:
	tsx6	insert_new_line	non-zero skip count, so insert a new_line
	sbq	1,dl		reset count, is it still > 0?
	tmoz	ret_from_control	if not, return, limit was set by insert_new_line
	tra	skip_more		count was not zero,so repeat
"
check_x_format:
	cmpx6	5,du		5 is request code for x_format,i.e. blank spaces
	tnz	check_q_gt_zero	x and skip formats are the only ones which allow a zero count
"
	stz	sp|output_request_type	endpage does not abort x format
put_q_blanks:
	adq	pr4|fsb.bnc	now put q blanks out
	sbq	1,dl		to get buffer position reached after operation, not next one
	cmpq	pr4|fsb.limit	see if we can move all the blanks in one move without violating the limit
	tmoz	easy_blanks	if we can, we save time & work
	sbq	pr4|fsb.bnc	restore q to original value with this subtraction
	adq	1,dl		compensate for earlier subtraction of 1 (fixes 1721)
"			now we put out the blanks one by one
repeat_blank:
	cmpq	0,dl		more to put out?
	tze	ret_from_control	if not, return. Blanks don't require resetting fsb.limit.
	lda	pr4|fsb.kol	first check if there's room for a char on this line
	cmpa	pr4|fsb.lsize
	tmi	2,ic		if kol<lsize, no problem
	tsx6	insert_new_line	if kol>=lsize, insert a new_line
	lda	pr4|fsb.bnc
	sba	1,dl
	cmpa	pr4|fsb.bsize
	tmi	3,ic
	tsx1	call_putchars
	lda	0,dl
	mlr	(pr),(pr,al),fill(040)
	zero	0
	desc9a	pr3|0,1
	aos	pr4|fsb.bnc
	aos	pr4|fsb.kol	we know we inserted a single char
	sbq	1,dl		decrement count by one
	tra	repeat_blank	and repeat
"
"			this means we dont have to watch out for the limit
easy_blanks:
	sbq	pr4|fsb.bnc	restore q to its original value,i.e. the number of blanks to be put
	adq	1,dl		we subtracted one before,so add 1 now
	lxl6	pr4|fsb.bnc	set up regs for the mlr
	sbx6	1,du
	mlr	(),(pr,rl,x6),fill(040)	040 is ascii blank
	zero	0
	desc9a	pr3|0,ql
	asq	pr4|fsb.bnc	correct indexes
	asq	pr4|fsb.kol
	tra	ret_from_control	and return
"
check_q_gt_zero:
	cmpq	0,dl		the rest of the controls forbid a zero count
	tnz	check_column	if q=0 error unless col  format
	cmpx6	2,du		is it col(0)?
	tze	column_zero	make it col(1),effectively
	lda	9,dl		the error code is 9
	tra	any_qs_error	and raise the error
"
"	now check for column, then page, format
check_column:
	cmpx6	2,du		request code=2 means column format
	tnz	check_print_file	page is only allowed for a print file
"
	stz	sp|output_request_type	endpage does not abort column format
	cmpq	pr4|fsb.kol	is the requested column less than the present one?
	tmoz	pre_column	if it is, we must produce a new-line first
	cmpq	pr4|fsb.lsize	is the column <= than the line size?
	tmoz	within_line	if so,we're ok
	tsx6	insert_new_line	else insert a new-line first
	tra	ret_from_control	we needn't set fsb.limit cause insert_new_line does
"
column_zero:
	tsx6	insert_new_line
	tra	ret_from_control	and were done
"			our task now is to put out enough blanks to reach the desired column
within_line:
	sbq	pr4|fsb.kol	how many more blanks needed?
	tra	pre_column+1	and put them out
pre_column:
	tsx6	insert_new_line	the rules say start with a new_line
	sbq	1,dl		since if we want kol 5 we need only 4 blanks to get there
	tra	put_q_blanks	and put out the blanks
"
check_print_file:
	lda	pr4|fsb.switch
	cana	fsb.print,du
	tnz	3,ic
	lda	2,dl		the page & line requests require a print file, if not, it is error code 2
	tra	any_qs_error	and raise the error
	cmpx6	3,du		page request?
	tnz	must_be_line	as the man says, if not it must be line
"
new_page:
	lda	pr4|fsb.lineno	in most cases pagemark must be preceeded by a newline
	cmpa	pr4|fsb.psize	unless lineno>psize & kol=0 & ^emptyline
	tmoz	new_page_and_line
	lda	pr4|fsb.kol
	tnz	new_page_and_line
	lda	fsb.emptyline,dl
	cana	pr4|fsb.switch
	tze	just_page
"
new_page_and_line:
	tsx6	insert_new_line
just_page:
	lda	pagemark_char
	tsx6	insert_char
	stz	pr4|fsb.kol	a pagemark resets the kol to 0
	ldq	1,dl		and sets lineno to one
	stq	pr4|fsb.lineno
	aos	pr4|fsb.pageno
	tra	set_fsb_and_ret	since kol was reset, fsb.limit must be
"
must_be_line:
	cmpq	pr4|fsb.psize	is the requested lineno>pagesize?
	tmoz	not_overp		iif not, go to not_overp
"
page_time:
	lda	pr4|fsb.lineno	if lineno is already>pagesize, just insert a new pagemark and return
	cmpa	pr4|fsb.psize
	tpnz	new_page
fill_pg_and_raise_ep:
	tsx1	<pl1_operators_>|[get_our_lp]	else we must fill the page with new_lines. which we don't
	ldq	<plio2_data_>|[max_page_size]	want to do if pagesize=max_page_size,i.e. is virtually infinite
	epp4	ap|ps.fsbp,*	but would rather print a message in that case
	cmpq	pr4|fsb.psize
	tnz	3,ic		is pagesize=max_page_size?
	lda	6,dl		if so, error code=6
	tra	any_qs_error	and raise the error
	ldq	pr4|fsb.lineno	otherwise, proceed to fill the page with new_lines
fill_more:
	tsx6	insert_new_line
	adq	1,dl
	cmpq	pr4|fsb.psize
	tpnz	raise_endpage
	tra	fill_more
"
not_overp:
	cmpq	pr4|fsb.lineno	if the requested lineno is <present lineno
	tmi	page_time		we must fill the page with new_lines and put out a new page
	tze	q_equ_lineno	if they are equal, we must check the column
	sbq	pr4|fsb.lineno	if requested lineno > present lineno, just skip the right number of lines
	tra	skip_more
q_equ_lineno:
	lda	pr4|fsb.kol	if kol is zero, we're where we want to be
	tze	ret_from_control
	tra	page_time		else we need to go to the next page
b_char:
	oct	142000000000
quote_char:
	oct	042000000000
blank_char:
	oct	040000000000
pagemark_char:
	oct	014000000000
minus_sign:
	oct	055000000000
new_line:
	oct	012000000000
tab_char:
	oct	011000000000
carr_rtn_char:
	oct	015000000000
	end




		    put_format_.alm                 11/11/89  1150.6r w 11/11/89  0805.6      486693



" ***********************************************************
" *                                                         *
" * 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.      *
" *                                                         *
" ***********************************************************

"	Operator  for doing format-driven conversions
"
"	Written by R.Schoeman 1975-6 to implement operators to do put-edit
"	requests in the operators, for improved performance.
"
"	Modified Oct 1976 by R.H.Schoeman to put in radix factor constants
"	Modified Mar 29, 1978 by R.A.Barnes to fix bug 1719
"	Modified August 14, 1978 by PCK to fix bug 1745
"	Modified September 1, 1978 by RAB to fix bug 1781
"
	include stack_frame
	include stack_header
	include eis_bits
"
"	The following include file describes a region of storage which is used
"	exclusively by put_format_, for internal manipulation.  It's primary
"	purpose is to hold the evaluated fields of the format constants
"	produced by the compiler(evaluated by stu_), but is also used
"	for most other storage needed by the format list processing
"	and format conversions. The program plio2_fl_ uses the same storage region,
"	there called sb, similiarly but not identically. plio_sb is 136 words long,
"	and was provided by the compiled code, and the ptr to it was placed in the ps, at
"	ps.format_area_p.
"
	include plio_sb
"
"	The following include file describes the format constants produced
"	by the compiler. A format con contain from zero (as in a put edit(foo)(a) statement)
"	to three values (as in put edit(foo)(e(11,5,2))), hence 3 value fields
"	are provided along with nval, to show how many are used. offset is the
"	relative offset to the next format constant.
"
	include plio_fb
	include pic_image
	include plio2_ps
	include plio_format_codes
	include desc_types
	equ	new_stack_size,48
	equ	max_dec_precision,59	this is system defined constant
	equ	w_temp,47		this temp is field width for e_format maniputlation
	equ	radix_fac_bits,47	this temp used in bn_format to hold bits to be index in hex_table
	equ	nval_temp,44
	equ	radix_factor,44
	equ	d_temp,54		num of decimal places for e_formats
	equ	k_temp,48
	equ	extra_bits,48
	equ	sd_temp,48
	equ	storage_taken,49
	equ	double_temp,52
	equ	temp,62
	equ	ps_ptr,42
	equ	source_val_type,44
	equ	source_val_scaleprec,45
	equ	b_temp,45
	equ	x7_stored,46	upper half of word only
	equ	int_val_type,54
	equ	int_val_scaleprec,47
"				qs_arg_list will clobber many variables if ever used from
"				pr6|, and it NEVER should be. It is to be used within the
"				region allocated as temporary workspace.
	equ	qs_arg_list,48
	equ	tbp,38
	segdef	put_edit_eis
	segdef	get_edit_eis
	segdef	put_terminate
	segdef	stream_prep
formats_mask:
	oct	000000000017
"
"	operator to prepare for an I/O operator (stream)
"
" stream_prep is executed once per put request, and as such should not
" be confused with "get_prep"
"  stream_prep sets several fields in the ps, which
" is the storage block associated with an io request, including "ps.prep",
" which when non-zero tells get_or put_ prep to do other preparatory  functions.
"
stream_prep:
	eppap	sp|ps_ptr,*	get ptr to ps
	spribp	ap|ps.abret	save label
	sprisp	ap|ps.abret+2
	sta	ap|ps.job		set job to do
	stc1	ap|ps.prep	set prep switch non-zero
	eax6	10		assume this is get prep
	cana	=o002000,du	check for put bit
	tze	<pl1_operators_>|[plio4]	go make call to get_prep_ if bit off
	eax6	11		this means its a put_prep call
	tra	<pl1_operators_>|[plio4]	and away we go
"
"	operator for get edit entered with ptr to datum in bp,
"	offset in x7, descriptor in q
"
get_edit_eis:
"	epp4	sp|ps_ptr,*	pr4 will point to ps throughout
"	sxl7	sp|ps.offset
"	tra	put_and_get_merge
"
" 	Operator to do put edits, entered with descriptor in q and pointer to value
"	in the bp, and the offset, for pictures, in the a.
"
"	The first  section of code, up to the transfer vector called
"	"action", walks the format list, evaluates any variables
"	found, and creates a secondary, pre-processed format list,
"	which is then used by the code which does the
"	format-driven conversions. The original format list is
"	pointed to by ps.special_list_p, and the structure of
"	the format items on it is described by plio_fb. The fully
"	processed format list is pointed to by pr5, and its structure
"	is plio_sb. fb is mnemonic for format block, and sb is for
"	storage block. This format list processing is used by both
"	output, in which case the format conversions are done by the
"	latter part of put_format_, and by input, in which case the
"	conversion part is done by plio2_qge_ (which stands for
"	quick_get_edit_).
put_edit_eis:
	epp4	sp|ps_ptr,*	pr4 will point to the ps throughout this code
	sta	pr4|ps.offset	since the a has the offset for the picture
put_and_get_merge:
	stq	pr4|ps.descr	since the q has the descriptor
	stq	pr4|ps.q_stored	we also must save it here, for final restoration after put_field_
	sta	pr4|ps.a_stored	same here.
	stx7	sp|x7_stored	we cannot clobber any regs but a,q,bases,x0, and x1
	spri2	pr4|ps.value_p	we were entered with ptr->value in bp
	epp5	pr4|ps.format_area_p,*	pr5 points to the original format thruout
	sxl0	sp|stack_frame.operator_ret_ptr	this needed to return from any_to_any
	ldq	240,dl
	tsx1	<pl1_operators_>|[alloc]
	spribp	pr5|plio_sb.space_ptr		this is temporary work space
	lda	pr4|ps.new_format	this flag,if not 0,means we are handling a new format list 
	tze	test_currep	not the first so  dont initialize,else
"				set up the sb format "model" from scratch, and initialize some stuff
init_format:
	stz	pr5|plio_sb.stk_index	init to zero,though plio2_fl_.pl1 inits to 1
	stz	pr5|plio_sb.cur_rep	init to zero
	stz	pr4|ps.new_format	no longer a new format since were initializing it
	epp3	null_loc,*
	spri3	pr5|plio_sb.sf1p
	spri3	pr5|plio_sb.fe1p
	spri6	pr5|plio_sb.sf2p
	epp3	pr4|ps.special_list_p,*	this is set to the beginning of the formats
	spri3	pr5|plio_sb.cur_fep	so it is the first format_ptr
	epp3	pr3|1		the 1st word is zeros to identify this as the start of a format list
	spri3	pr5|plio_sb.fe2p	so for real use set the ptr one ahead
"			if the current rep factor>0,use the current format in the sb
test_currep:
	epp7	pr5|plio_sb.cur_fep,*	else follow the ptr in the last format to the next one & load the sb
	lda	pr5|plio_sb.cur_rep	However,if this is the 1st,we get the initial values from xx2p's, set
	tze	test_offset	in init_format.
"
"	this is the format to do since the currep is > 0
"
	sba	1,dl		1st decrement currep, since we're finally using fep's fields
	sta	pr5|plio_sb.cur_rep
	lda	pr5|plio_sb.type
	cmpa	c_format,dl	if c_format we must set the real & imag formats in plio_sb.val(2) and plio_sb.val(3),
	tze	exec_c_format	else we only eval current fep's arguments and set plio_sb.val(1)'s values to them
	cmpa	picture_format,dl	and we're done. p_format's, however,get evaluated differently.
	tnz	format_decoded
	ldq	0,dl
	eax0	got_format	after decode_format,we want to go staight to got_format
"
decode_pic_format:
	lda	pr7|plio_fb.val	the picture image is at format's addr up the 1st value
	epp3	pr7|0,al		so now pr3 points to it
	mpy	5,dl		each set-of-values frame in the plio_fb structure is 5 wds long
	lda	2,dl		so skip to the frame index which was in q on entry
	sta	pr5|plio_sb.nval,ql	set fframe's nval to 3
	lda	pr3|1		pic_image.varlength is up one,leftmost f.bin.(8)
	arl	27		get pure pic_image.varlength
	sta	pr5|plio_sb.val_1,ql	which is to be the 1st  value
	sprp3	pr5|plio_sb.val_2,ql	store as val_2 a ptr to the picture_image
	tra	0,0		and return through x0, since we were tsx0'd here
"
"			Try to get the next format from the ptr in the last one. If its 0,we are
test_offset:
	lxl1	pr7|plio_fb.offset	at the end of a format list and must be in 1 of 3 cases--a)About to do
	tze	test_stk_index	the 1st format,initialized in init_format b)in a non-mainstream format list
	epp7	pr7|0,1		reached thru a r_format c)at the end of the list & should start over from top.
	spri7	pr5|plio_sb.cur_fep	we just set the format-ptr to plio_fb.offset
"				since we have a new format,eval rep factor & set currep to it
eval_rep:
	ldq	pr7|plio_fb.rep
	tpl	2,ic		if it is >0, it is a constant and needn't be evaluated
	tsx6	decode_q		else we must call stu_
	stq	pr5|plio_sb.cur_rep
	lda	pr7|0		get the num of values in the format
	arl	plio_fb.nval_shift
	ana	plio_fb.nval_mask,dl
	sta	pr5|plio_sb.nval	sb hold our present values. It stands for storage_block.
	lda	pr7|0		now get the type code of the format
	arl	plio_fb.code_shift	since we're shifting 27 we needn't mask the remaining 9 bits
	sta	pr5|plio_sb.type
	cmpa	c_format,dl	if >c_format, is a simple type.. if <, us r_format or l_paren,etc.
	tpnz	test_currep	if a_,b_,e_,f_,p_format, off we go
	cmpq	1,dl		q still has currep, if 0 we want next format
	tmi	test_offset
	cmpa	c_format,dl	if c_format there two sets of values to fill
	tze	c_format_to_sb
	aos	pr5|plio_sb.stk_index	must be a case which requires another stack frame in the sb
	ldq	pr5|plio_sb.stk_index	i.e. either r_format or l_paren
	cmpq	9,dl		check that max nesting depth is not exceeded
	tmoz	3,ic
	lda	12,dl
	tra	<put_field_>|[any_qs_error_no_ret]
	mpy	10,dl		each stack frame takes up 9 words, so this gets the offset
	epp1	pr5|plio_sb.cur_sfp,*	now set the new frame's values to the current format
	spri1	pr5|plio_sb.sf1p,ql
	spri7	pr5|plio_sb.fe1p,ql	pr7,now as always,points to the format item
	lda	pr5|plio_sb.cur_rep	we clobbered the q during multiplication,so it isn't currep like usual
	sta	pr5|plio_sb.rep,ql	set the frame's rep factor
	lda	pr5|plio_sb.type	and it's type
	cmpa	r_format,dl	r_format's values need stu_ to get them, while l_paren's are easier
	tze	r_format_to_sb
	spri1	pr5|plio_sb.sf2p,ql	this is l_paren,set sf2p to the current sfp--stack_frame_ptr
	lda	pr7|plio_fb.val	and set the fe2p to current format_ptr up its own val(1)
	epp3	pr7|0,al
	spri3	pr5|plio_sb.fe2p,ql	we used pr3 cause we didn't want to clobber pr7, which always is the fep
"			test stack index, if=1 we're at the bottom of the stack & should continue
test_stk_index:
	ldq	pr5|plio_sb.stk_index	with the xx2p ptrs, else if the frame's rep factor>0 use it over
	mpy	10,dl
	tze	use_2s		again & decrement the rep factor, else use the xx1p ptrs and decrement
	lda	pr5|plio_sb.rep,ql	the stack index
	tze	use_1s
	sba	1,dl
	sta	pr5|plio_sb.rep,ql
"				this means use the xx2p ptrs and reenter the mainstream
use_2s:
	epp7	pr5|plio_sb.fe2p,ql*	pr7 will be the format ptr, fep
	spri7	pr5|plio_sb.cur_fep	and store it
	epp3	pr5|plio_sb.sf2p,ql*
	spri3	pr5|plio_sb.cur_sfp	cur_sfp will be taken from plio_sb.sf2p
	tra	eval_rep
"
"				set the sfp, fep from the frame's xx1p's and decrement stack frame index
use_1s:
	epp3	pr5|plio_sb.sf1p,ql*
	spri3	pr5|plio_sb.cur_sfp
	epp7	pr5|plio_sb.fe1p,ql*
	spri7	pr5|plio_sb.cur_fep	q had the stck index times 10 to yield the offset, remember
	lcq	1,dl
	asq	pr5|plio_sb.stk_index
	tra	test_offset	and rejoin the mainstream
"
"
"			this is the only way to get out of this routine
"
format_decoded:
	lda	0,du		this means the format has been decoded,so start the evaluation loop
eval_loop:
	cmpa	pr5|plio_sb.nval	have we eval'd as many args as there are?
	tze	got_format	if so, the format list walk is over
	ldq	pr7|plio_fb.val,al	otherwise, load the format's value
	tpl	2,ic		if non-negative, its a constant so no stu_ call
	tsx6	decode_q		if negative, call stu_ to decode it
	stq	pr5|plio_sb.val,al	store it in the sb storage block
	ada	1,dl		add one to the value count
	tra	eval_loop		and loop over again
"
exec_c_format:
	stz	pr5|7		zero out the real, imag value fields
	stz	pr5|8
	stz	pr5|9
	stz	pr5|12
	stz	pr5|13
	stz	pr5|14
	tsx6	check_for_param	if there are no parameters it is an error
	stq	sp|nval_temp	check_for_param checks that plio_sb.nval>0 and leaves it in the q
	lda	pr5|plio_sb.val	the ptr to the real format is addrel(cur_fep,val_1)
	epp7	pr5|plio_sb.cur_fep,*al	so figure out ptr to the real format
	ldq	pr5|5		plio_sb.type(2),i.e. real format parts
	cmpq	picture_format,dl	if  its a picture format we must decode
	tnz	4,ic		otherwise we dont have to
"
	eax0	real_part_ok	after decoding the pis format we want to go here
	ldq	1,dl		since it is the second value frame in the sb for the results
	tra	decode_pic_format
"
	lda	0,dl		now eval each of the values in the format block's real part
real_loop:
	cmpa	pr5|6		plio_sb.nval(2), real part
	tpl	real_part_ok	this means they are all eval'd
	ldq	pr7|plio_fb.val,al	else get the next one
	tpl	2,ic		if its negative we must call stu_ to decode it
	tsx6	decode_q
	stq	pr5|7,al		2nd formats values start at 7
	ada	1,dl		and reloop evaluating the next value
	tra	real_loop
real_part_ok:
	ldq	sp|nval_temp
	cmpq	2,dl		if there's only 1 then only one format given for both imag & real
	tmi	imag_like_real
	epp7	pr5|plio_sb.cur_fep,*	else we must figure out imag format
	lda	pr5|plio_sb.val_2	this is offset for imag format's format item
	epp7	pr7|0,al		set up a correct ptr to it in pr7
	ldq	pr5|10		this is the format-type of imag format
	cmpq	picture_format,dl
	tnz	4,ic		if its not picture do not call decode_pic
	ldq	2,dl		this tells decode_pic which format-frame to store results in
	eax0	got_format	this is where to return to after decode_pic is done
	tra	decode_pic_format	and off we go
	lda	0,dl		now evaluate format block's values one by one
imag_loop:
	cmpa	pr5|11		this is imag format's nval,if = we've eval'd them all
	tpl	got_format	if we've eval'd them all we've finished the format-list walk!
	ldq	pr7|plio_fb.val,al	otherwise eval the next  one
	tpl	2,ic
	tsx6	decode_q
	stq	pr5|12,al		and store it into the sb block
	ada	1,dl		add one to our count
	tra	imag_loop		and continue
"
imag_like_real:
	mlr	(pr),(pr)		we're here if only one format given within c_format,so
	desc9a	pr5|7,12		just move all the sb's real values to the sb imag-values
	desc9a	pr5|12,12		section and we're done
	tra	got_format
"
c_format_to_sb:
	mlr	(pr),(pr)		move fields from format block to sb
	desc9a	pr7|plio_fb.val,12
	desc9a	pr5|plio_sb.val,12
	tsx6	check_for_param	if nval<1 there is an error
	epp7	pr5|plio_sb.cur_fep,*	get ptr to the first value in format block
	lxl0	pr7|plio_fb.val_1	use it as offset to the real format's block--real vs.cplx
	lda	pr7|0,x0
	arl	plio_fb.code_shift	get the real part of the format's type code
	ana	plio_fb.code_mask,dl

	sta	pr5|5		and store it in storage block's fields for the real part
	ldq	pr7|0,x0		now go after the real part's nval
	qrl	plio_fb.nval_shift
	anq	plio_fb.nval_mask,dl
	stq	pr5|6		and store it in plio_sb.real-part's nval
	lxl6	pr5|plio_sb.nval	now see if a separate imag format was even specified
	cmpx6	2,du		if it was nval>1,  and extract & store the imag part's type &nval
	tpl	set_imag		which is done in set_imag
store_imag:
	staq	pr5|10		else just repeat the real part's values for plio_sb.imag's type, nval
	tra	test_currep	and were finished setting the cplx format's real,imag type, nval
"
set_imag:
	lxl0	pr7|plio_fb.val_2	get offset to imag part of complex format
	lda	pr7|0,x0		load the first word, which contains the type code
	arl	plio_fb.code_shift	extract it
	ana	plio_fb.code_mask,dl
	ldq	pr7|0,x0		extrace the nval,too--number of values
	qrl	plio_fb.nval_shift
	anq	plio_fb.nval_mask,dl
	tra	store_imag	and store them in plio_sb.imag part's type,nval
"
r_format_to_sb:
	epp0	pr5|plio_sb.space_ptr,*	to evaluate remote format we must 1st call stu$remote_format
	epp4	pr7|plio_fb.val	1st arg is plio_fb.val_1, which gets eval'd to the rmote format
	spri4	pr0|2		store it in arg list
	epp4	pr5|plio_sb.cur_sfp	2nd arg is stack_frame ptr to frame of format, not necessarily ours!
	spri4	pr0|4
	epp4 	null_loc		3rd arg is null
	spri4	pr0|6
	epp4	pr0|20		4th arg is a label(4 wds) in which to store loc of value of remote format
	spri4	pr0|8
	epp4	pr0|24		last arg is return value, which is error code
	spri4	pr0|10
	sreg	sp|8		and now do the call
	fld	5*2048,dl		5 args in all
	staq	pr0|0
	tsx1	<pl1_operators_>|[get_our_lp]
	stcd	sp|stack_frame.return_ptr
	callsp	<stu_>|[remote_format]
	lreg	sp|8
	epp4	sp|ps_ptr,*	restore ptr registers
	epp5	pr4|ps.format_area_p,*
	epp7	pr5|plio_sb.cur_fep,*
	epp3	pr5|plio_sb.space_ptr,*
	ldq	pr3|24		check error code
	tze	3,ic		if zero there's no problem
	lda	11,dl		else raise an error
	tra	<put_field_>|[any_qs_error_no_ret]
	epp2	pr3|22,*		get the format value's stack frame ptr
	ldq	pr5|plio_sb.stk_index
	mpy	10,dl		store each of the 2 ptrs making  up the label figured out by stu_
	spri2	pr5|plio_sb.sf2p,ql	into the right fields in the sb
	epp2	pr3|20,*		get fe pointer
	epp2	pr2|1		since the 1st word is a flag word of all zero's
	spri2	pr5|plio_sb.fe2p,ql
	tra	test_stk_index	and we're done
"
got_format:
	lda	pr5|plio_sb.type	transfer through a table to the right type-specific action
	ldq	pr4|ps.job
	canq	=o002000,du	check the put bit
	tnz	action-3,al	the name of the table is action
	xec	get_code-3,al	sp|temp will be 0 for data's, non-zero for stls
	epp7	pr5|plio_sb.space_ptr,*
	epp4	sp|ps_ptr		else set up the call to plio2_$quick_get_edit
	spri4	pr7|qs_arg_list+2	1st arg is ps ptr
	sreg	sp|8
	fld	1*2048,dl
	staq	pr7|qs_arg_list
	eppap	pr7|qs_arg_list	the qge stands for quick_get_edit, naturellement
	tsx1	<pl1_operators_>|[get_our_lp]
	stcd	sp|stack_frame.return_ptr
	callsp	<plio2_>|[quick_get_edit_]
	lreg	sp|8
	ldq	sp|temp
	tnz	ret_from_control
	lxl0	sp|stack_frame.operator_ret_ptr
	stz	sp|stack_frame.operator_ret_ptr
	tra	<put_field_>|[restore_regs_and_frame_and_ret]
"
decode_q:
	spri7	sp|double_temp	this code calls stu_$decode_runtime_value to decode the value
	epp0	pr5|plio_sb.space_ptr,*	which is in q on entry, and leaves the decoded value in q whin it
	stq	pr0|20		returns to the location in the operator which is in x6
	epp4	pr0|22		arg8 will be return value, which will be at pr0|22
	spri4	pr0|16		so put ptr to it in arg list as arg 8
	epp4	pr0|20
	spri4	pr0|2		arg1 is the value to eval
	epp4	pr5|plio_sb.cur_sfp
	spri4	pr0|6		arg3 is the stack_frame_p for the stack frame in which the value is
	epp4 	pr0|21
	spri4	pr0|14		arg7 is the returned error code
	epp4 	null_loc
	spri4	pr0|4		arg2 is null
	spri4	pr0|8		as is arg4
	spri4	pr0|10		arg5 is also null
	spri4	pr0|12		arg6 is also null
	sreg	sp|8		now do the call
	fld	8*2048,dl		there were 8 args including the return value which is the decoded value
	staq	pr0|0
	tsx1	<pl1_operators_>|[get_our_lp]
	stcd	sp|stack_frame.return_ptr
	callsp	<stu_>|[decode_runtime_value]
	lreg	sp|8
	epp4	sp|ps_ptr,*	restore ptr registers
	epp5	pr4|ps.format_area_p,*
	epp7	sp|double_temp,*	we saved pr7 in double_temp for the duration of this call
	epp3	pr5|plio_sb.space_ptr,*
	ldq	pr3|21		check returned error code, if non-zero raise error
	tze	3,ic
	lda	11,dl
	tra	<put_field_>|[any_qs_error_no_ret]
	ldq	pr3|22		return value is here, put it in q
	tra	0,6		and return to caller with evaluated value in q
"
"	what follows is the transfer table to the format-specific action
"	dictated by the format type,See include file  plio_format_codes for
"	numeric values of the differet format types
action:
	tra	do_c_format
	tra	do_f_format
	tra	do_e_format
	tra	do_b_format
	tra	do_a_format
	tra	do_x_format
	tra	do_skip_format
	tra	do_col_format
	tra	do_page_format
	tra	do_line_format
	tra	do_pic_format
	tra	do_bn_format
"
get_code:
	stz	sp|temp
	stz	sp|temp
	stz	sp|temp
	stz	sp|temp
	stz	sp|temp
	stcd	sp|temp
	stcd	sp|temp
	stcd	sp|temp
	stcd	sp|temp
	stcd	sp|temp
	stz	sp|temp
	stz	sp|temp
"
do_x_format:
	tsx6	check_for_param	x_format requires a parameter, else it is an error
	eax6	5		this is the code understood by put_field_$put_control for x format
	ldq	pr5|plio_sb.val_1	this is the parameter, or number of spaces to skip
	tze	test_currep	if its zero, ignore the format completely
	tra	do_control	else do the control
do_page_format:
	eax6	3		this is the code for page format which takes no parameter!
	tra	do_control
"
do_col_format:
	tsx6	check_for_param	this format requires a parameter
	eax6	2
	ldq	pr5|plio_sb.val_1	x6 has the format's code for put_control, q has the parameter itself
	tpnz	do_control
	ldq	1,dl		if the param was 0,make it 1 instead
	tra	do_control
"
do_line_format:
	tsx6	check_for_param
	eax6	4
	ldq	pr5|plio_sb.val_1
	tpnz	do_control
	lda	9,dl
	tra	<put_field_>|[any_qs_error_no_ret]
"
do_skip_format:
	eax6	1
	ldq	pr5|plio_sb.nval
	tze	no_skip_arg
"
do_most_controls:
	ldq	pr5|plio_sb.val_1
do_control:
	tsp1	<put_field_>|[put_control_from_format]
ret_from_control:
	epp4	sp|ps_ptr,*,
	epp5	pr4|ps.format_area_p,*	restore ptrs and continue with format-list walk
	tra	test_currep
no_skip_arg:
	ldq	1,dl
	tra	do_control
"
"	now for the data formats
"
do_a_format:
	epp1	pr5|plio_sb.space_ptr,*	it is my convention that pr1 points to the newly-alloc'd space
	lda	pr4|ps.descr	descr=0 means its a picture
	tze	a_f_pic_source
	ana	=o374000000000	otherwise,extract the source type from the descr
	arl	28
	cmpa	char_desc,dl	a is now the source type,lets filter out superquick conversons
	tze	char_to_char	character to char conversion can be superquick
	cmpa	v_char_desc,dl	as can varying_char to char
	tze	vchar_to_char
	tsx0	set_source_wa	any other situation is guaranteed to need an any_to_any conv.
a_f_source_ok:
	lda	pr5|plio_sb.nval	set_source_wa set the source regs used by a_to_a
	tze	no_len_given	if nval=0 no length given in a format
	lda	pr5|plio_sb.val_1	otherwise use it as the target length in a_to_a
	tnz	not_zero_targ		if a(0), must be pulled out,else assumed var str
ab_null_string:
	ldq	0,dl
	epp2	0			just to be safe
	tra	superquick_return
"
not_zero_targ:
	sta	pr5|plio_sb.format_len	we need it after the a_to_a call so save it
	eax6	char_desc		this is the target descriptor for a_to_a
	tra	source_been_set	and off to any_to_any and then put_field
"
no_len_given:
	stz	pr5|plio_sb.format_len	if no len given,make the target a varying char
	lda	256,dl		of max length 256 and store a 0 in format_len as a flag
	eax6	v_char_desc
"
source_been_set:
	epp5	pr1|66		pr5 points to work area of 156 words,starting at space|66
"	code to push a stack,needed for any_to_any call
	epbp7	pr6|0		point to stack header
	epp2	pr6|stack_frame.next_sp,*	point to next frame
	spri6	pr2|stack_frame.prev_sp	link next frame
	epp6	pr2|0
	epp2	pr2|new_stack_size
	spri2	pr7|stack_header.stack_end_ptr	store ptr to end of frame
	spri2	pr6|stack_frame.next_sp
	lxl0	pr6|stack_frame.flag_word	turn support bit on
	orx0	stack_frame.support_bit,du
	sxl0	pr6|stack_frame.flag_word
	epp2	*
	spbp2	pr6|tbp		set text_base_ptr
ata_call:
	tsx0	<any_to_any_>|[any_to_any_]	separate entry point for error signalling differences
"	code to pop my stack
after_ata_call:
	epbp7	pr6|0		point to stack header
	inhibit	on
	spri6	pr7|stack_header.stack_end_ptr
	epp6	pr6|stack_frame.prev_sp,*
	inhibit	off
"
	epp0	sp|ps_ptr,*	restore pointers
	epp5	pr0|ps.format_area_p,*
	epp2	pr5|plio_sb.space_ptr,*
af_return:
	ldq	pr5|plio_sb.format_len	put_field expects the output string's length in q
	tnz	2,ic		if it was zero, that means target was a varying string
	ldq	pr2|-1		so get the length from the length word at addr|-1
superquick_return:
	lxl0	sp|stack_frame.operator_ret_ptr	restore x0 to its value on entry to put_format
	stz	sp|stack_frame.operator_ret_ptr
	tra	<put_field_>|[put_field_from_format]	and off we go
"
vchar_to_char:
	ldq	pr5|plio_sb.nval	if no length specified no move is needed
	tze	vc_no_len		use source string as output
	epp3	pr4|ps.value_p,*	else move the string with padding/truncation
	lda	pr3|-1
	ldq	pr5|plio_sb.val_1	get the target len
	tra	superquick_af_2	and merge with the move, but pr3 already set
"
vc_no_len:
	epp2	pr4|ps.value_p,*
	ldq	pr2|-1		length of output string will be len of orig source var string
	tra	superquick_return	and were done
"
char_to_char:
	lda	pr4|ps.descr	get the length from descriptor's 2nd 1/2
	ana	=o000077777777
char_to_char_len:
	ldq	pr5|plio_sb.nval	if no length specified,use source string's len & no conversion
	tze	no_move		if no target len given, no move needed,use orig string as output
	ldq	pr5|plio_sb.val_1	
superquick_af:
	epp3	pr4|ps.value_p,*
superquick_af_2:
	epp2	pr1|0
	mlr	(pr,rl),(pr,rl),fill(040),enablefault
	desc9a	pr3|0,al
	desc9a	pr2|0,ql
	tra	superquick_return
"
no_move:
	epp2	pr4|ps.value_p,*
	lrs	36
	tra	superquick_return
"
a_f_pic_source:
	ldx0	pr4|ps.top_half	top_half is offset for the picture image
	epp7	sp|tbp,*x0	get a ptr  to it
	lda	pr7|1		extract its length & leave it in the a
	arl	27		length is top 9 bits of the word
	tra	char_to_char_len	since it must be a character picture merge with char_to_char
"
do_b_format:
	epp1	pr5|plio_sb.space_ptr,*	pr1 should point to the newly alloc'd space
	tsx0	set_source_wa	set the source registers for a_to_a
	lda	pr5|plio_sb.nval	save the param for the len of the final string,not this one
	tze	2,ic		if no format param given,let lang rules determine final length
	lda	pr5|plio_sb.val_1	
merge_b_bn:
	sta	pr5|plio_sb.format_len
	lda	256,dl		b format needs 2 conversions-1st to bit string, then to character
	eax6	v_bit_desc	for bit string, make it varying bit string with only max len given
	epp5	pr1|0		pr5 points to the work space
	epp1	pr1|222		pr1 points to where to put the result of conversion
"	code to push a stack,needed for any_to_any call
	epbp7	pr6|0		point to stack header
	epp2	pr6|stack_frame.next_sp,*	point to next frame
	spri6	pr2|stack_frame.prev_sp	link next frame
	epp6	pr2|0
	epp2	pr2|new_stack_size
	spri2	pr7|stack_header.stack_end_ptr	store ptr to end of frame
	spri2	pr6|stack_frame.next_sp
	lxl0	pr6|stack_frame.flag_word	turn support bit on
	orx0	stack_frame.support_bit,du
	sxl0	pr6|stack_frame.flag_word
	spri4	sp|ps_ptr
	epp2	*
	spbp2	pr6|tbp		set text_base_ptr
	tsx0	<any_to_any_>|[any_to_any_]
	epp4	sp|ps_ptr,*	restore pointers
	epp5	pr4|ps.format_area_p,*
	epp1	pr5|plio_sb.space_ptr,*
	epp3	pr1|222		source for final conversion=target of preliminary one
	lda	pr5|plio_sb.type	if its bn format 2nd half of conversion is different
	cmpa	bn_format,dl
	tze	final_conv_for_bn	this is who does the 2nd half for bn_format
	ldq	pr3|-1		length of bit string is at addr|-1
	lda	pr5|plio_sb.format_len	we saved length of final character string here
	tnz	2,ic		but  if no length given in b_format, use length of intermediate bit string
	lda	pr3|-1
	sta	pr5|plio_sb.format_len	in any case remember the length for later use
	eax6	char_desc		and convert to a character string
	eax7	v_bit_desc	from a varying bit string
	epp5	pr1|66		this is the 156 word work space for a_to_a
	tra	ata_call		do the second conversion & go straight to put_field
"
ata_call_and_ret:
	stx0	sp|temp		we will return here later
"	code to push a stack,needed for any_to_any call
	epbp7	pr6|0		point to stack header
	epp2	pr6|stack_frame.next_sp,*	point to next frame
	spri6	pr2|stack_frame.prev_sp	link next frame
	epp6	pr2|0
	epp2	pr2|new_stack_size
	spri2	pr7|stack_header.stack_end_ptr	store ptr to end of frame
	spri2	pr6|stack_frame.next_sp
	lxl0	pr6|stack_frame.flag_word	turn support bit on
	orx0	stack_frame.support_bit,du
	sxl0	pr6|stack_frame.flag_word
	epp2	*
	spbp2	pr6|tbp		set text_base_ptr
	tsx0	0,1		call the a_to_a entry point in index reg 1
"	code to pop my stack
	epbp7	pr6|0		point to stack header
	inhibit	on
	spri6	pr7|stack_header.stack_end_ptr
	epp6	pr6|stack_frame.prev_sp,*
	inhibit	off
"
	epp4	sp|ps_ptr,*	restore pointers
	epp5	pr4|ps.format_area_p,*
	epp1	pr5|plio_sb.space_ptr,*
	ldx0	sp|temp		restore index reg 0  and return through it
	tra	0,0
"
do_bn_format:
	epp1	pr5|plio_sb.space_ptr,*	pr1 should point to the newly alloc'd space
	tsx0	set_source_wa	set the source registers for a_to_a
	lda	pr5|plio_sb.nval	save the param for the len of the final string,not this one
	cmpa	2,dl
	tze	bn_with_len	if an explicit length was given we must put it in a register
	eaa	0		otherwise a length of 0 means no length was given
	tra	merge_b_bn	join flow of vanilla b_format
bn_with_len:
	lda	pr5|plio_sb.val_2	load the output length in a
	tra	merge_b_bn	and join b_format flow
"
final_conv_for_bn:
	ldq	pr3|-1		get length of source bit string,now converted
	div	pr5|plio_sb.val_1	now divide by the radix_factor to find out how many output-chars needed
	sta	sp|extra_bits	and save the remainder for later
	cmpa	0,dl		if there was a remainder, the # of output chars will be 1 greater
	tze	2,ic		to hold the left-overs,padded on the left with 0's
	adq	1,dl
	stq	pr5|plio_sb.extra_temp	now save this "real_len", or number of chars needed to hold value
"
	eax7	0		x7 is the count of how many output chars we have put out so far
	lda	pr5|plio_sb.nval	now find out if an explicit length was given
	cmpa	1,dl		if nval=1, there was only a radix-factor, no length
	tnz	bn_len_given	else goto to this label
	stq	pr5|plio_sb.format_len	final format len will be this length, not 0, which is
	tra	use_real_len	what is in plio_sb.format_len now ,for formats with no explicit length
bn_len_given:
	lda	pr5|plio_sb.val_2	get the given format length
	tze	ab_null_string	if its zero, put out a null string without raising stringsize
	cmpq	pr5|plio_sb.val_2	is the required num of char>format len?
	tpnz	raise_stringsize	if so, we must raise stringsize
	tze	use_real_len	if they are equal, no padding is needed
"
	mlr	(),(pr,rl),fill(040)	move in the blanks
	zero	0
	desc9a	pr1|0,al		pr1 points to output string
"
use_real_len:
	lxl0	pr5|plio_sb.extra_temp	move value to upper half of word, for later cmpxning
	stx0	pr5|plio_sb.extra_temp
	lxl1	pr5|plio_sb.val_1	x1 needs radix-factor , to know how long a string to csl
	stx1	sp|radix_factor	we need radix-factor in upper half of a word for adxning
	ldq	pr3|-1
	lda	sp|extra_bits
	eax0	0
	csl	(),(pr,rl,ql),bool(clear)
	zero
	descb	pr3|0,al
	ldq	36,dl		now handle the first  digit by hand,which we must cause we must
	sbq	pr5|plio_sb.val_1	assume leading 0's.We will load it and then shift it right 36-extra_bits bits.
	eax6	0,ql		x6 is how much to right-shift all other digits,=36-radix_factor
"
bn_loop:
	csl	(pr,rl,x0),(pr),bool(move)	move x1--radix-factor--bits from pr3 up x0--offset--
	descb	pr3|0,x1		to sp|rad_fac_bits
	descb	sp|radix_fac_bits,x1
"
	lda	sp|radix_fac_bits	now load those bits in a and shift them right enough to
	arl	0,x6		leave only one digit's worth
	adx0	sp|radix_factor	increment offset in source bits for next csl. Offset is in x0.
"
first_radix_factor_bits:
	mlr	(al),(pr,x7)	now use the digit in a-reg as index into hex_table to get correct character,
	desc9a	hex_table,1	and move that char to output string at offset x7
	desc9a	pr1|0,1
"
	adx7	1,du		increment output offset
	cmpx7	pr5|plio_sb.extra_temp	did we reach end of output string?
	tmi	bn_loop		if not, loop back and do the next digit
	tra	after_ata_call	at this point were done, so go here to pop stack, restore regs,
"				and go off to put field with the newly-created string.
"
hex_table:
	aci	"0123456789abcdef"
"
raise_stringsize:
	mlr	(pr),(pr),enablefault	this is a fake move whose only purpose in life is to raise
	desc9a	pr3|0,1		a stringsize condition if a truncation was implied by the output
	desc9a	pr1|0,0		request.
	tra	use_real_len	return to main body after the stringsize was raised
"
do_c_format:
	stz	pr5|plio_sb.cplx_flags	this is 2 flags-1st  half wd is real,2nd halfword is imag
	epp1	real_part_done	pef formats return to this label variable
	ldq	64,dl		we need more storage for complex final output string
	tsx1	<pl1_operators_>|[alloc]	dont change stor_taken cause put_term uses sp|5 to reset stack
	eaq	304
	stq	sp|storage_taken
	mlr	(pr),(pr)
	desc9a	pr5|5,20
	desc9a	pr5|0,20
"				space_ptr|240  will be the loc of the final string
handle_pef:
	spri1	pr5|plio_sb.pef_finish	pef format returns through here
	lda	pr5|plio_sb.type	find out format type
	cmpa	e_format,dl	can be e,f,or p format--f_format=4,e=5,pic=13
	tze	e_format_from_cplx
	tmi	f_format_from_cplx
	tra	p_format_from_cplx
"
real_part_done:
	epp7	pr5|plio_sb.space_ptr,*	we'll move the output str for the real part here
	epp7	pr7|240
	mlr	(pr,rl),(pr,rl)
	desc9a	pr2|0,ql
	desc9a	pr7|0,ql
	stq	pr5|plio_sb.real_parts_len	we need this to know where to put imag part &how long final string is
	eax1	2		imag_flag is 2 to be added to prec of dec float num to give len in bytes
	sxl1	pr5|plio_sb.cplx_flags
	epp1	imag_part_done
	mlr	(pr),(pr)
	desc9a	pr5|10,20
	desc9a	pr5|0,20
	tra	handle_pef	this will call pef format after storing return loc & setting format ptr in sb
"
imag_part_done:
	lda	pr5|plio_sb.real_parts_len	so we know where to put imag part of output string
	epp7	pr5|plio_sb.space_ptr,*
	a9bd	pr7|240,al
	mlr	(pr,rl),(pr,rl)
	desc9a	pr2|0,ql		q is len of imag part, pr2 points to it
	desc9a	pr7|0,ql		pr7 points to cplx_output up real_part_len
	adq	pr5|plio_sb.real_parts_len	so q has the length of the final complex string
	epp2	pr5|plio_sb.space_ptr,*	pr2 must point to string to be put
	epp2	pr2|240
	tra	end_of_pef
"
"
do_e_format:
	stz	pr5|plio_sb.cplx_flags
	epp1	end_of_pef
	spri1	pr5|plio_sb.pef_finish	pr5|plio_sb.pef_finish will be where to go on completion--in this case to put_field_
e_format_from_cplx:
	lda	pr5|plio_sb.nval	if coming in this entry, pef_finish will be a location in the complx handling
"				stuff. Now get the number of args to e_format- 1,2,3, corresponding to
"				e(w[,d[,s]]).. w is field width, d is num of decimal locations, s is num sig
	cmpa	2,dl		digits.
	tmi	e_one_op		one op is w, d=w-8, s=d+1
	tze	e_two_ops		two  ops are w,d..s=d+1
"				must have 3 ops
	lda	pr5|plio_sb.val_3	get the third one
	ldq	pr5|plio_sb.val_2	get  the 2nd one and put it in the q
	stq	sp|d_temp		since the 2nd arg is d, store it in d_temp
	cmpa	sp|d_temp		we must check that s is not < d, BUGFIX!
	tpl	e_merge_for_w	where we will extract the 1st val, or "w", and continue		
	tra	raise_size
"
e_two_ops:
"				get the 2nd arg, or "d"--num of decimal digits
	lda	pr5|plio_sb.val_2
	sta	sp|d_temp		and store it
	ada	1,dl		if s is not explicit, it =d+1, so now calc it
e_merge_for_w:
	ldq	pr5|plio_sb.val_1	get the 1st val, or "w"
	tze	ef_null_string
	stq	sp|w_temp		and store it
	tra	e_merge		e_merge assumes "s" is in a reg
"
e_one_op:
	lda	pr5|plio_sb.val_1	get "w"
	tze	ef_null_string
	sta	sp|w_temp		otherwise, w_temp never gets set, this is a BUGFIX!
	sba	8,dl		s=w-7
	sta	sp|d_temp		d=w-8
	ada	1,dl		and leave "s" in the a_reg
e_merge:
	sta	pr5|plio_sb.format_len	a has "s", or prec of fl dec intermed val
	epp1	pr5|plio_sb.space_ptr,*	pr1 always should point to our work space
	tsx0	set_source_wa		set the source regs for a_to_a call
	lda	pr5|plio_sb.format_len	load a with the precision of the float dec target
	lxl6	pr5|plio_sb.cplx_flags	we want  to see if its the imag part of a c_format
	tze	not_e_imag	if it is,we must force intermed value to cplx
	eax6	D_float_cplx_desc
	tra	not_e_imag+1
zero_value:
	mlr	(),(pr),fill(000)	AG94 says if the value is zero the exponent is printed as "000"
	zero	0		even though it isn't really, so move a 0 to exponent byte of value
	desc9a	pr1|0,1		at this point pr1 points to exponent byte of float dec number
	lda	pr5|plio_sb.format_len	now set a to the number of pre-decimal digits--all zeros
	sba	sp|d_temp		d_temp is the number of post-decimal digits
	s9bd	pr1|0,al		move pr1 backwards to encompass the requisite number of ascii "0"'s
	tra	zero_merge	and merge with main flow
not_e_imag:
	eax6	D_float_real_desc	this is the type of the intermed value to  convert to
	epp1	pr5|plio_sb.space_ptr,*	set up pr's for a_to_a call
	epp5	pr1|66		pr5 points to a_to_a's workspace
	eax1	<any_to_any_>|[any_to_any_round_]	lang rules say we must round,not truncate
	tsx0	ata_call_and_ret	and do conversion to float decimal
"
	ldq	pr5|plio_sb.format_len	put precision of float dec value in q
	epp7	pr1|66		pr7 is where we'll put result of our hand-conversion
	epp2	pr7|0		put_field expects pr2 to point to output string,so set it here
	lxl0	pr5|plio_sb.cplx_flags	we must throw away real part of cplx result if imag part of c_format
	tze	e_imag_merge	otherwise skip the next 2 instructions
	a9bd	pr1|0,ql		the real part of the complex value is of len prec+2
	a9bd	pr1|0,x0		and cplx_flag has a value of 2
e_imag_merge:
	eax0	1		we will frequently need a register with a 1 in it
	mlr	(pr),(pr),fill(000)	squirrel the sign char away for later use, in x1
	desc9a	pr1|0,1		we'll have to use sp|temp as a conduit
	desc9a	sp|temp,4		zeroing the rest of sp|temp
	ldx1	sp|temp		now x1 has the sign char,as desired
	a9bd	pr1|0,x0		x0 has a 1 in it, this is to skip sign char in source
	tct	(pr,rl)		find the 1st non-zero char in the float dec value
	desc9a	pr1|0,ql		this skips leading ascii zeros
	arg	table
	arg	sp|temp		offset of 1st non-zero will appear in sp|temp
	lda	sp|temp
	ana	=o000777777777	zero out the 1st byte of it, which is the char found
	a9bd	pr1|0,al		advance the source ptr over the leading zeros
	ttn	zero_value	if they are all zero, value is zero & we must change exponent's value
	neg	0
	ada	pr5|plio_sb.format_len	otherwise let a be the number of remaining digits after the 0's
zero_merge:
	sta	pr5|plio_sb.extra_temp		extra_temp is  the number of post-leading 0's digits
	ldq	sp|w_temp		w_temp is the total output field length
	mlr	(),(pr,rl),fill(040)	blank out entire target area
	zero	0
	desc9a	pr7|0,ql		pr7 points to target area
	lda	sp|d_temp		if d=0, no decimal point printed hence an extra leading blank
	tnz	2,ic
	a9bd	pr7|0,x0		this is the extra leading blank taking the place of the "."
	sbq	pr5|plio_sb.format_len	skip field-width-prec-6 leading blanks
	sbq	6,dl
	a9bd	pr7|-1,ql		for a while pr7 points to one word before where we are in output string
	cmpa	pr5|plio_sb.format_len	if s=d we must insert a pre-"." zero to look nice
	tze	s_is_d_move
	eax6	3		x6 is offset off of pr7 to put a "-" if needed
	eax7	4		x7 is offset off pr7 to move the pre-"." string
	lda	pr5|plio_sb.format_len	calculate the number of pre-"." digits
	sba	sp|d_temp		which is s-d, or num of sig digits - num of decimal digits
	sta	sp|sd_temp	sd_temp saves the value s-d
	ldq	sp|sd_temp	q is the number of pre-"." digits to move into
	cmpa	pr5|plio_sb.extra_temp		a is the num of pre-"." digits to move from, or min(s-d,extra_temp)
	tmoz	e_move
	lda	pr5|plio_sb.extra_temp
	tra	e_move		and now perform the move
"
	equ	table,*-12
	oct	000777777777
	oct	777777777777
	oct	777777000000
"
s_is_d_move:
	eax6	2		set the offsets & lengths for the case where s=d
	lda	0,dl		a = num of pre-"." digits to move from, or 0
	ldq	1,dl		q is the num of pre-"." digits to move to, or 1 "0"
	eax7	3		x7 is the offset for the pre-"." string of digits
	stz	sp|sd_temp	s-d is obviously 0
e_move:
	sta	sp|b_temp		the num of digits we're using from the float dec string will be needed later
	mlr	(pr,rl),(pr,rl,x7),fill(060)	fill is "0"
	desc9a	pr1|0,al		pr1 points to source string
	desc9a	pr7|0,ql		pr7 is our hand-converted result string
	cmpx1	minus_char	if float dec was <0 we must move in a "-"
	tnz	not_minus
	mlr	(),(pr,x6),fill(055)	fill is "-"
	zero	0
	desc9a	pr7|0,1		we set x6 previously to the offset for the "-" if needed
not_minus:
	ldq	sp|sd_temp	advance the source & targ ptrs past the chars we just moved
	a9bd	pr7|1,ql		we can now make pr7 point to targ string, not targ string-1word
	a9bd	pr1|0,ql		which was done cause negative offsets in strings not allowed
	ldq	sp|d_temp		now move the "." 
	tze	no_dec		if there are any decimal digits
	mlr	(),(pr),fill(056)	fill char is "."
	zero	0
	desc9a	pr7|0,1		so move the "." to the target string
	a9bd	pr7|0,x0		and advance the target ptr past it, x0 having a 1 in it
no_dec:
	lda	pr5|plio_sb.extra_temp		now move the post-"." digits
	sba	sp|b_temp		taking m-b digits from the source string,b being num previously moved
	ldq	sp|d_temp		and moving them into d digits, filling with "0"'s
	mlr	(pr,rl),(pr,rl),fill(060)	fill char is "0"
	desc9a	pr1|0,al		a has num of post-leading 0's digits minus num previously moved
	desc9a	pr7|0,ql		q has d, or num of  decimal digits specified by e format
	a9bd	pr7|0,ql		advance target ptr past just-moved digits
	a9bd	pr1|0,al		and source ptr,too
	mlr	(),(pr),fill(145)	move in the "e" which precedes the exponent's value
	zero	0
	desc9a	pr7|0,1
	a9bd	pr7|0,x0		advance targ ptr 1 char past the "e" we just moved in
	mlr	(pr),(pr)		now move the value of the exponent into sp|temp
	desc9a	pr1|0,1		pr1 now points to the exponent's value in the source string
	desc9a	sp|temp,1
	lda	sp|temp		load the exponent's value
	als	1		and make it into a normal number(it was 8 bits before)
	ars	28
	ada	pr5|plio_sb.extra_temp		final exponent=exp+m-s+d,where m=num of non-leading-0 digits
	sba	sp|sd_temp
	sta	sp|temp		store the final exponent's  value since btd is storage-to-storage
	btd	(pr),(pr)		and convert it to decimal form
	desc9a	sp|temp,4		putting it directly into the output string with a sign
	desc9ls	pr7|0,4		and three digits
	ldq	sp|w_temp		put_field want's field's length in q
	tra	pr5|plio_sb.pef_finish,*	and were finished with this conversion
"
end_of_pef:
	lxl0	sp|stack_frame.operator_ret_ptr	and we must restore x0, which we clobbered
	stz	sp|stack_frame.operator_ret_ptr
	tra	<put_field_>|[put_field_from_format]	and off we go
"
"	this routine sets up the registers describing the source to be converted
"	by any_to_any_. It is tsx0'd to
set_source_wa:
	ldq	pr4|ps.descr	picture sources,which have descr=0, must be handled differently
	tze	general_pic_source
	anq	=o376000000000	extract the source type from the descriptor
	qrl	10
	epp3	pr4|ps.value_p,*	pr3 must point to the source to be converted
	eax7	0,qu		x7 must have the source's type
	cmpx7	v_char_desc,du	fixed or varying strings must be handled differently
	tze	fix_len		since there descriptor has a len field rather than scale-prec
	cmpx7	v_bit_desc,du
	tze	fix_len
	cmpx7	char_desc,du
	tze	string_desc
	cmpx7	bit_desc,du
	tze	string_desc
	sta	sp|temp		we know it is an arithmetic source, so extract scale-prec from descr
	lda	pr4|ps.descr
	ana	=o000077777777
	lrl	12
	qrl	6
	lrl	18
	lda	sp|temp		now q has scale in top 1/2, prec in lower, and a has been restored
	tra	0,0		so were done
string_desc:
	ldq	pr4|ps.descr	strings have to have only the length extracted, which is lower 2/3 of descr
	anq	=o000077777777
	tra	0,0		and return, since x7 has already been correctly set
fix_len:
	ldq	pr3|-1		for varying strings we must extract the len of the source from addr|-1
	tra	0,0		and return. The a has not  been clobbered,x7 has been set
"
ef_null_string:
	ldq	0,dl		if e_format or f_format field width =0, AG94 says output
	epp2	pr5|plio_sb.space_ptr,*	is just a null string, so set it up
	tra	pr5|plio_sb.pef_finish,*	and we're finished with the entire ccnversion.
"
do_f_format:
	stz	pr5|plio_sb.cplx_flags	we are not in the middle of a complex format, so zero this flag
	epp1	end_of_pef	we want to go here when done with the conversion
	spri1	pr5|plio_sb.pef_finish
f_format_from_cplx:
	lda	pr5|plio_sb.nval	get num of values to f(...) from processed format block
	stz	sp|k_temp		k=scaling factor, usually zero so set it now, can be reset later if one found
	ldq	pr5|plio_sb.val_1	get 1st value, or w (field width).This MUST be there
	tze	ef_null_string	e,f formats are defined as null strings if w=0
	stq	sp|w_temp
	cmpa	2,dl		reg. a still has num of args to f_format
	tmi	f_one_op
	tze	f_two_ops
	ldq	pr5|plio_sb.val_3
	stq	sp|k_temp
f_two_ops:
"				now get 2nd arg,or num of dec positions (d)
	ldq	pr5|plio_sb.val_2
	stq	sp|d_temp
	tra	f_merge		to skip next instruction
f_one_op:
	stz	sp|d_temp		by definition, d=0 if not given
f_merge:
	epp1	pr5|plio_sb.space_ptr,*
	tsx0	set_source_wa
	stq	sp|temp
	ldq	sp|w_temp
	lda	sp|d_temp
	tze	2,ic		if d=0,prec=min(max_dec_precision,w), else prec=min(max_dec_precision,w-1).
	sbq	1,dl		this gives room for decimal point
	cmpq	max_dec_precision,dl
	tmoz	2,ic
	ldq	max_dec_precision,dl	if here, max_dec_precision<other width
	stq	pr5|plio_sb.extra_temp		you want to remember prec for 2nd half of conversion process
	ada	sp|k_temp		scale of fix dec num to convert to is d+k,d is already in q
	qls	18		should have prec in lower half, scale in upper, of a reg
	lls	18		prec was in al, now in au and scale in al
	lxl0	pr5|plio_sb.cplx_flags
	tze	3,ic
	eax6	D_fixed_cplx_desc
	tra	f_call
	eax6	D_fixed_real_desc	this is target type for a_to_a
f_call:
	ldq	sp|temp
	epp5	pr1|66
	eax1	<any_to_any_>|[any_to_any_round_]
	tsx0	ata_call_and_ret
"
	ldq	pr5|plio_sb.extra_temp		1st task is to blank out target string,for possible leading blanks
	eax6	1
	mlr	(pr),(pr),fill(000)	pr1 now pts to fix dec number
	desc9a	pr1|0,1		squirrel away sign char in x0
	desc9a	sp|temp,4
	ldx0	sp|temp
	epp3	pr1|0		pr3 is source_ptr
	lxl7	pr5|plio_sb.cplx_flags
	tze	3,ic
	a9bd	pr3|0,ql
	a9bd	pr3|0,x6
	epp7	pr1|66		pr7 will be loc of final output string
	epp2	pr7|0
	mlr	(),(pr,rl),fill(040)
	zero
	desc9a	pr7|0,ql		we just provided the leading, as well as more,blanks
	a9bd	pr3|0,x6		to skip sign in source
	sbq	sp|d_temp		q still has field width in it.We want to extract pre-decimal pt.
	sbq	1,dl		digits from the f.dec number,skipping leading zeros.
	tct	(pr,rl)
	desc9a	pr3|0,ql
	arg	table
	arg	sp|k_temp		p-q-1 is max possible num of leading zeros.
"
	ldq	sp|k_temp		k_temp has number of leading zeros
	anq	=o000777777777
	stq	sp|k_temp
	a9bd	pr3|0,ql		skip them by advancing source_p past them
	a9bd	pr7|0,ql		advance targ_ptr to leave the leading blanks virgin
"
	lda	pr5|plio_sb.extra_temp		the num of pre-"." digits is prec-num of skipped zeros-scale,so calc it
	sba	sp|k_temp		k_temp being num of skipped zeros
	sba	sp|d_temp		and d_temp being scale,s
	tmoz	raise_size	there must be at least one digit before "." BUGFIX
	cmpx0	minus_char	look at sign_p->char1 to see if orig value was <0,if so insert "-"
	tze	source_lt_zero	since sign_p->"-",insert a "-"
"
sign_set:
	mlr	(pr,rl),(pr,rl)	now move the pre-"." digits
	desc9a	pr3|0,al
	desc9a	pr7|0,al		remember pr7 is target ptr
	a9bd	pr3|0,al		advance source_p past digits we just moved
	a9bd	pr7|0,al		do the same for targ_ptr
	ldq	sp|d_temp		if scale=0,there is nothing but the pre-"." stuff so were finished
	tze	f_done
"
	mlr	(),(pr),fill(056)
	zero	0		move in the "." to the target	
	desc9a	pr7|0,1		which is pr7
	a9bd	pr7|0,x6		and up the targ ptr
	mlr	(pr,rl),(pr,rl)	now move in the last post-"." digits
	desc9a	pr3|0,ql		q still has q, which serves as the numbber
	desc9a	pr7|0,ql		of digits after the dec point
"			if you didnt notice, were finished!
f_done:
	ldq	sp|w_temp		q should be length of output string
	tra	pr5|plio_sb.pef_finish,*
"
source_lt_zero:
	cmpq	0,dl		if no zeros were skipped,no room for "-"	
	tpnz	dont_raise_size	if any 0's were skipped we have room
raise_size:
	epp7	pr5|plio_sb.space_ptr,*
	epp4	sp|ps_ptr		else set up the size-condition raising call
	spri4	pr7|qs_arg_list+2	1st arg is ps ptr
	sreg	sp|8
	lxl0	sp|stack_frame.operator_ret_ptr
	fld	1*2048,dl
	staq	pr7|qs_arg_list
	eppap	pr7|qs_arg_list
	tsx1	<pl1_operators_>|[get_our_lp]
	stcd	sp|stack_frame.return_ptr
	callsp	<plio2_>|[pve_error]
	lreg	sp|8
	tra	<put_field_>|[set_no_ret_error]
dont_raise_size:
	mlr	(),(pr),fill(055)	fill char is a "-", this moves it into output string
	zero	0
	desc9a	pr7|-1(3),1	pr7 points to output string
	tra	sign_set		and remerge with mainstream code, sign having been inserted
"
do_pic_format:
	stz	pr5|plio_sb.cplx_flags	snce were not doing imag  part of cplx format
	epp1	end_of_pef	where to go when finished
	spri1	pr5|plio_sb.pef_finish
p_format_from_cplx:
	lprp1	pr5|plio_sb.val_2	get a ptr to the format's picture_image in pr1
	spri1	sp|double_temp	and save it in  double_temp
	tsx1	decode_pic_desc	now decode the picture pointed to  by pr1
	sta	sp|int_val_scaleprec	a has the scale-prec specified by the picture
	stx6	sp|int_val_type	x6 has the type to convert through specified by the picture
	lda	pr4|ps.descr	find out if the source is pic,if so must unpack picture
	tnz	not_pic_source	if it isn't a picture skip call to unpack_pic
	eax0	ass_pic_source_to_intermed	this is where to go after unpacking the picture
"
"	This routine is dropped through to in the case of p_formats, and is tsx0'd to
"	from the other formats in the case in which the source value is a picture. The
"	routine calls unpack_pic and transfers to the location  in x0.
"
general_pic_source:
	ldx1	pr4|ps.top_half
	epp1	sp|tbp,*x1	1st build  a ptr  to the picture description,*x1at base|ps.top_half
	tsx1	decode_pic_desc	this routine assumes the ptr to the pic is in pr1
	sta	sp|source_val_scaleprec	store the returned scale-prec
	sxl6	sp|source_val_type	store the returned type
	epp7	pr5|plio_sb.space_ptr,*	we need space for the result of the unpacking
	epp7	pr7|156
	epp3	pr4|ps.value_p,*
	spri7	pr7|qs_arg_list+2	1st arg is buffer in which to  place result
	spri3	pr7|qs_arg_list+6	3rd arg is ptr  to source value
	spri1	pr7|qs_arg_list+4	2nd arg is ptr to  picture description
	sreg	sp|8		and make the call
	fld	3*2048,dl
	staq	pr7|qs_arg_list
	eppap	pr7|qs_arg_list
	tsx1	<pl1_operators_>|[get_our_lp]
	stcd	sp|stack_frame.return_ptr
	callsp	<unpack_picture_>|[unpack_picture_]
	lreg	sp|8
	epp4	sp|ps_ptr,*	restore ptr registers
	epp5	pr4|ps.format_area_p,*
	epp1	pr5|plio_sb.space_ptr,*
	epp3	pr1|156		let pr3->result of unpacking,which a_to_a will use as source ptr
	ldq	sp|source_val_scaleprec	scale-prec of source in q, for a_to_a call
	lxl7	sp|source_val_type	also for  a_to_a call
	tra	0,0		and return to sender
"
decode_pic_type:
	dec	42	char
	dec	18	real fix dec
	dec	22	cmplx fix dec
	dec	20	real fl dec
	dec	24	cmplx fl dec
not_pic_source:
	lrl	12		at this point a has the descr & we must extract scale-prec
	qrl	6		scale  is in 2nd 3rd of word, prec in 3rd 3rd
	lrl	12
	qrl	6
	stq	sp|source_val_scaleprec	scale is now in top 1/2 of q,prec in lower 1/2
	als	25		now extract the type field, adding to it the "packed" bit
	arl	29
	sta	sp|source_val_type	pr3 ->source val, all  nice for a_to_a
	epp3	pr4|ps.value_p,*
ass_source_to_intermed:
	ldq	sp|source_val_scaleprec	whether or not source is original or unpacked, now we convert it
	lxl7	sp|source_val_type	to the intermediate value specified by the  picture format
ass_pic_source_to_intermed:
	epp1	pr5|plio_sb.space_ptr,*	if we come from unpack_pic, q & x7 were already set
	epp7	pr1|48		set up the rest of the registers for a_to_a
	epp1	pr1|16
	lda	sp|int_val_scaleprec
	ldx6	sp|int_val_type	these are the conversion's target's scale-prec & type
	lxl1	pr5|plio_sb.cplx_flags
	tze	2,ic
	adx6	4,du		if imag part of c_format,force interm val to cplx
	epp5	pr7|0		this is ptr to work area
	eax1	<any_to_any_>|[any_to_any_]	this is proper entry to call
	tsx0	ata_call_and_ret	and do the conversion
"
	epp2	pr1|16		set pr2->output of conversion
	lda	pr5|plio_sb.cplx_flags	if imag part of cplx we must skip real part
	tze	image_pic_merge
	eax0	1		we will  skip 1 char for the exponent byte if dec float
	ldx6	sp|int_val_type	find out type
	cmpx6	D_float_real_desc	decimal float?
	tnz	2,ic		if not, just skip 1 extra byte for sign char, must be fixed decimal
	a9bd	pr2|0,x0		skip exponent  byte
	a9bd	pr2|0,x0		skip sign byte
	lda	sp|int_val_scaleprec	skip body of real value now
	a9bd	pr2|0,al		no mask needed to elim scale cause al takes only lower
image_pic_merge:
"				now call pack_picture for the final cconversion
	spri1	pr1|qs_arg_list+2	arg1 is ptr to where to put resulting output string
	epp7	sp|double_temp,*	double temp has ptr to picture description of p_format, remember
	spri7	pr1|qs_arg_list+4	which is arg2
	spri2	pr1|qs_arg_list+6	arg3 is ptr  ot source to be packed
	sreg	sp|8		set up the 3 argument call
	fld	3*2048,dl
	staq	pr1|qs_arg_list
	eppap	pr1|qs_arg_list
	tsx1	<pl1_operators_>|[get_our_lp]
	stcd	sp|stack_frame.return_ptr
	callsp	<unpack_picture_>|[pack_picture_]
	lreg	sp|8		restore registers and pointer regs
	epp4	sp|ps_ptr,*
	epp5	pr4|ps.format_area_p,*
	epp3	pr5|plio_sb.space_ptr,*
	epp2	pr3|0		pr2 should point to output string to be put out
	epp7	sp|double_temp,*	now calculate length of output for put_field
	ldq	pr7|1		which is found in pic_image.varlength
	qrl	pic_image.varlength_shift
	tra	pr5|plio_sb.pef_finish,*	and we're done with this exercise in the sublime
"	subroutine to decode a picture's descriptor,entered with pr1->picutre's
"	image and exited with the scale-prec in a and type in x6
"
decode_pic_desc:
	ldq	pr1|0		get  the pic_image type & decode it with use of the "decode_pic_type" table
	qrl	pic_image.type_shift
	lxl6	decode_pic_type-24,ql
	cmpx6	char_desc,du	now  the decoded type is in x6, so extract the scale-prec
	tze	char_desc_decode	if its a char type there is only a length, no scale-prec
	lda	pr1|0		else extract the scale-prec
	arl	pic_image.scale_shift
	ana	=o000000000777
	ldq	pr1|1		now scale is in lowest byte  of a,get prec in  q & merge them
	qrl	pic_image.scalefactor_shift	but first must handle the scalefactor, just in case there is one
	anq	pic_image.mask,dl
	stq	sp|temp		store the scalefactor in sp|temp
	sba	sp|temp		and subtract it from the scale
	ldq	pr1|0		now get the precision, at last
	anq	=o000777,du	and move it to the a with scale in  top 1/2 of a
	lls	18
	tra	0,1		and we're done & return to he who tsx1'd  to us
char_desc_decode:
	lda	pr1|1		get the length from the pic image, leave it in the a
	arl	27
	tra	0,1		and return
"
"	This subroutine checks that plio_sb.nval>0, if not it raises an error, if it
"	is it leaves the value of it in the q. It is tsx6'd to, and clobbers only the q.
"
check_for_param:
	ldq	pr5|plio_sb.nval
	tpnz	0,6
	lda	10,dl
	tra	<put_field_>|[any_qs_error_no_ret]
"
"	operator to terminate a put
"
put_terminate:
	eax6	1		set proc to call
	tra	<pl1_operators_>|[plio4]
"
minus_char:
	oct	055000000000
"
	even
null_loc:	its	-1,1,n		this is where we get "null" for argument ptrs  which should be null
	end




		    record_io_.alm                  11/11/89  1150.6rew 11/11/89  0803.9       73782



" ***********************************************************
" *                                                         *
" * 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.      *
" *                                                         *
" ***********************************************************

"	Operator to interface with record I/O programs. Entered with job in register a.
"	Bulk of code is to handle quick record i/o.
	name 	record_io_
	include	stack_frame
	include	iocbx
	include	plio2_psr
	include	plio2_fsb
	equ	io_arg_list,52	all equ's in this program come from pl1_operators_
	equ	tbp,38		loc of ptr to base of text
	equ	ps_ptr,42		loc of ptr to PS
	equ	t6,44
	equ	t7,45
	equ	double_temp,46
	equ	t3,51
"
"	The following declarations may be removed when a
"	fsbr include file is generated.
"
	equ	fsbr.recio,fsb.lsep	these overlay same word
	bool	fsbr.rec_valid,200000
"
	segdef	record_io
"
"	Program to filter "quick" record I/O operations from "slow" ones.
"	Calling sequence:
"		lda	job_bits
"		tsx0	ap|record_io_op
"
record_io:
	eppap	sp|ps_ptr,*
	spribp	ap|psr.ab_return
	sprisp	ap|psr.ab_return+2
	sta	ap|psr.job		save the job bits
	cana	psr.version_mask_inplace,dl	check version
	tze	slow		we only handle version>0
	ana	=v18/-1-psr.explicit_file-psr.varying_string,18/-1-psr.key-psr.keyto-psr.keyfrom-psr.version_mask_inplace
	cmpa	=v18/psr.read,18/psr.into
	tnz	3,ic
	eax1	0		= read stmnt
	tra	quick
	cmpa	=v18/psr.write,18/psr.from
	tnz	3,ic
	eax1	1		= write stmnt
	tra	quick
	cmpa	=v18/psr.rewrite,18/psr.from
	tnz	3,ic
	eax1	2		= rewrite stmnt
	tra	quick
	cmpa	psr.delete,dl
	tnz	slow
	eax1	3		= delete stmnt
"
quick:	epp4	ap|psr.source_p,*	now to get fsb bits
	epp4	pr4|2,*		fsb ptr is 2 wds up
	spri4	ap|psr.fsbp
	lda	pr4|fsb.switch
	ana	=v18/-1-fsb.zot1-fsb.zot2-fsb.not_used_1,18/-1-fsb.detach-fsb.iox_close
	ldq	ap|psr.job		we need unclobbered job bits
	canq	psr.key+psr.keyto+psr.keyfrom,dl
	tnz	keyed_job
"
good_key:
	eax6	0		x6=1 if stringvalue
	canq	psr.varying_string,du
	tze	not_var
	cana	fsb.stringvalue,du
	tze	slow
	eax6	1		stringvalue
"
not_var:	ana	=v18/-1-fsb.version_2-fsb.stringvalue,18/-1-fsb.implementation-fsb.internal-fsb.threaded
	cmpa	fsb_masks,1
	tze	action,1
	cmpx1	2,du		still could be read/update or write/update
	tpl	slow
	cmpa	fsb_masks+2	is it read or write update?
	tze	action,1
	tra	slow
"
fsb_masks:
	zero	fsb.open+fsb.input+fsb.notkeyed+fsb.record+fsb.sequential,fsb.emptyline
	zero	fsb.open+fsb.output+fsb.notkeyed+fsb.record+fsb.sequential,fsb.emptyline
	zero	fsb.open+fsb.update+fsb.notkeyed+fsb.record+fsb.sequential,fsb.emptyline
	oct	042700000020	open/update/threaded/emptyline	(NU)
"
action:	tra	quick_read
	tra	quick_write
	tra	quick_write
"
quick_delete:
	fld	2048*2,dl
	staq	sp|io_arg_list
	epp3	sp|t3
	tra	dl_too
"
quick_write:
	fld	2*1024*4,dl
	staq	sp|io_arg_list
	cmpx6	0,du		stringvalue?
	tze	simple_length
	epp3	ap|psr.variable_p,*		
	ldq	pr3|-1		length field
	tra	make_call
"
quick_read:
	fld	2*1024*5,dl	arg_list header = 2*number of args
	staq	sp|io_arg_list
	epp3	sp|t7		t7 = status code of read stmnt
	spri3	sp|io_arg_list+10
"
simple_length:
	ldq	ap|psr.variable_bitlen		
	div	9,dl		byte_length
"
make_call:
	stq	sp|t6		t6 = length (output to iox_)
	epp3	sp|t3		t3 = length(read stmnt),status(other)
	spri3	sp|io_arg_list+8
	epp3	sp|t6
	spri3	sp|io_arg_list+6
	epp3	ap|psr.variable_p		
"
dl_too:	spri3	sp|io_arg_list+4
	lprp5	pr4|fsb.iocb_p	p4->fsb, offset iocb_p (packed ptr)
	spri5	sp|double_temp	packed ptr must become unpacked
	epp3	sp|double_temp
	spri3	sp|io_arg_list+2
	eaa	0,1
	als	2		to multiply x1*4(4 words per entry var)
	eppbp	pr5|iocb.read_record,au*	bp -> the correct entry var. in iocb
	sreg	sp|8
	eppap	sp|io_arg_list
	stcd	sp|stack_frame.return_ptr
	callsp	bp|0
	lreg	sp|8
	cmpx1	0,du		read?
	tze	read_rtn
	lda	sp|t3		check status code(not read stmnt)
	tze	ret_to_caller
	epp3	sp|t3		get ptr to status for error call
"
error_call:
	spri3	sp|io_arg_list+4	2nd arg is status code
	sreg	sp|8		be prepared for a return from error
	fld	2*1024*2,dl
	staq	sp|io_arg_list
	eppbp	sp|ps_ptr		1st arg is ptr to ps
	spribp	sp|io_arg_list+2
	eppap	sp|io_arg_list
	tsx1	<pl1_operators_>|[get_our_lp]
	stcd	sp|stack_frame.return_ptr
	callsp	<plio2_recio_>|[error]
	lreg	sp|8
	tra	ret_to_caller
"
read_rtn:	
	lda	sp|t7
	tnz	read_error	if status^=0 its an error
	epp4	sp|ps_ptr,*	ap has been clobbered & we must get ps
	epp4	pr4|psr.fsbp,*
	lda	fsbr.rec_valid,du		since it was a successful read, set flag
	orsa	pr4|fsbr.recio
	lda	sp|t3		get returned length
	cmpx6	1,du		stringvalue?
	tnz	check_len
	epp3	sp|io_arg_list+4,*	get ptr to target variable
	epp3	pr3|0,*
	sta	pr3|-1		put returned length in length field of target var
"
ret_to_caller:
	eppap	sp|tbp,*0
	spriap	sp|stack_frame.return_ptr
	eppap	<pl1_operators_>|[operator_table]
	tra	sp|tbp,*0
"
check_len:
	cmpa	sp|t6		targ.len.=returned length?
	tze	ret_to_caller	if they're equal we're through
"
read_error:
	epp3	sp|t7		get ptr to status for error call
	tra	error_call
"
slow:	eax6	7
	tra	<pl1_operators_>|[plio4]
"
keyed_job:
	ana	=o077625573567	zero zots,v2,seq,dir,buf'd,str_val,env,threaded,detach,iox_closeHELP!!!
	canq	psr.keyto,dl
	tze	seek_key_call	cant be a read keyto
	eax1	4		table lookup for a read_keyto job string
	eax6	5		will be a call to read_key
	ldq	=v18/-1-psr.keyto_keyset,18/-1	turn keyset flag OFF
	ansq	ap|psr.pl1_ops_flags	keyset is zero till keytemp is filled
	tra	seek_key_call+1
"
seek_key_call:
	eax6	4		will be a call to seek_key
	cmpa	fsb_key_masks,1
	tze	key_call
	cmpx1	2,du		could be read/key or write/keyfrom on update file
	tmi	3,ic		
	cmpx1	4,du		could be read/keyto on update file
	tnz	slow
	cmpa	fsb_key_masks+2
	tze	key_call
	tra 	slow		give up
"
fsb_key_masks:
	zero	fsb.open+fsb.input+fsb.record+fsb.keyed,fsb.emptyline	READ KEY
	zero	fsb.open+fsb.output+fsb.record+fsb.keyed,fsb.emptyline	WRITE KEY
	zero	fsb.open+fsb.update+fsb.record+fsb.keyed,fsb.emptyline	REWRITE KEY
	zero	fsb.open+fsb.update+fsb.record+fsb.keyed,fsb.emptyline	DELETE KEY
	zero	fsb.open+fsb.input+fsb.record+fsb.keyed,fsb.emptyline	READ KEYTO
"
key_call:
	fld	2*1024*4,dl	4 arguments for seek_ or read_key
	staq	sp|io_arg_list
	epp3	ap|psr.keytemp+1	the addr of a var str is not its start
	spri3	sp|io_arg_list+4	arg2 is the key
	epp3	sp|t6
	spri3	sp|io_arg_list+6	arg3 is rtned length,we ignore
	lprp5	pr4|fsb.iocb_p	p4->fsb, offset iocb_p (packed ptr)
	spri5	sp|double_temp	packed ptr must become unpacked
	epp3	sp|double_temp
	spri3	sp|io_arg_list+2	arg1 \is iocb_ptr
	eaa	0,6		use x6 to get right entry var.
	als	2		to multiply x6*4(4 words per entry var)
	eppbp	pr5|iocb.read_record,au*	bp -> the correct entry var. in iocb
	epp3	sp|t3		status code
	spri3	sp|io_arg_list+8	arg4is of course status code
	sreg	sp|8
	eppap	sp|io_arg_list
	stcd	sp|stack_frame.return_ptr
	callsp	bp|0
	lreg	sp|8
	cmpx1	1,du		fancy  stuff only if a write
	tnz	not_key_write	handle non-writes differently
	tsx1	<pl1_operators_>|[get_our_lp]
	ldq	<error_table_>|[no_record]
	cmpq	sp|t3		must be new key to be right
	tnz	key_error		if key was there its an error
	eax1	1		restore x1 to 1 for write
	tra	key_ok
"
not_key_write:
	ldq	sp|t3		returned status code
	tnz	key_error		if not zero its an error
	cmpx1	4,du		read keyto?
	tze	keyto_done
"
key_ok:	eppap	sp|ps_ptr,*	restore the stuff we clobbered
	ldq	ap|psr.job
	epp4	ap|psr.fsbp,*	get fsbp again
	lda	pr4|fsb.switch
	ana	=o177726773767	zero zots,n_used1,dir,key,detach,iox_close	HELP!!!
	ora	fsb.notkeyed+fsb.sequential,du
	tra	good_key		now its looks like a unkeyed io op
"
keyto_done:
	eax1	0		if read-keyto restore x1 to 0 for read
	lda	psr.keyto_keyset,du
	eppap	sp|ps_ptr,*	ap has been clobbered,need to get at ps
	orsa	ap|psr.pl1_ops_flags	set keyset bit on, assgnmt has been made
	tra	key_ok+1
"
key_error:
	epp3	sp|t3		get ptr to status for error call
	tra	error_call
	end




		    sine_.alm                       11/11/89  1150.6rew 11/11/89  0805.6       50661



" ******************************************
" *                                        *
" * Copyright, (C) Honeywell Limited, 1985 *
" *                                        *
" ******************************************
	name	sine_
" Modification history:
"	Written by H. Hoover, M. Mabey, and B. Wong, April 1985,
"	based on GCOS routine '7nba'.
"
" Function:  Approximate to single precision the sine or cosine of an
"	angle given in degrees or radians.
"
" Entry:	through the appropriately named entry point with:
" 	EAQ = the angle whose sine or cosine is desired.
"	PR2 = the address of a 12 word, even-word aligned scratch area.
"	      4 words are used in this program and 12 are used by the
"	      routine "principal_angle_".  The storage for sine_ and
"	      principal_angle_ overlap.
"	PR3 = the return address.
"
" Exit:	EAQ = the desired sine or cosine.
"
" Uses:	X0, X1, X2.
"	X0 = saves a return address from principal_angle_ routines
"	X1 = shift (returned by principal_angle_ routines)
"	X2 = indicates BFP or HFP mode - all the floating point math
"	     routines use this register for the same purpose.
"	The principal_angle_ routines use registers X1 and X2.
"

	segref	math_constants_,half_pi,one_degree,pi
	segref	principal_angle_,principal_radians_,principal_degrees_

	equ	BFP,0
	equ	HFP,2
	equ	x,0
	equ	xx,2

	segdef	cosine_degrees_,hfp_cosine_degrees_
	segdef	cosine_radians_,hfp_cosine_radians_
	segdef	sine_degrees_,hfp_sine_degrees_
	segdef	sine_radians_,hfp_sine_radians_


hfp_cosine_degrees_:
	eax2	HFP		" 2 word offset for HFP constants
	tra	cosine_degrees

cosine_degrees_:
	eax2	BFP		" no offset for BFP constants

cosine_degrees:
	fad	=0.0,du		" normalize input
	fcmg	one_eighty,x2	" if abs_angle <= 180:
	tmi	case1_degrees	" then no angle reduction is necessary
	tsx0	principal_degrees_
	tra	case_degrees+1,x1	" select appropriate case


hfp_cosine_radians_:
	eax2	HFP		" 2 word offset for HFP constants
	tra	cosine_radians

cosine_radians_:
	eax2	BFP		" no offset for BFP constants

cosine_radians:
	fad	=0.0,du		" normalize input and set indicators
	fcmg	pi,x2		" if abs (angle) <= pi
	tmi	case1_radians	" then no angle reduction is necessary
	tsx0	principal_radians_
	tra	case_radians+1,x1	" select appropriate case
				

hfp_sine_degrees_:
	eax2	HFP		" 2 word offset for HFP constants
	tra	sine_degrees

sine_degrees_:
	eax2	BFP		" no offset for BFP constants

sine_degrees:
	fad	=0.0,du		" normalize input
	fcmg	ninety,x2		" if abs (angle) < pi/2
	tmi	case0_degrees	" then no angle reduction is necessary
	tsx0	principal_degrees_
	tra	case_degrees,x1	" select appropriate case


hfp_sine_radians_:
	eax2	HFP		" 2 word offset for HFP constants
	tra	sine_radians

sine_radians_:
	eax2	BFP		" no offset for BFP constants

sine_radians:
	fad	=0.0,du		" normalize input
	fcmg	half_pi,x2	" if abs (angle) <= pi/2
	tmoz	case0_radians	" then no angle reduction is necessary
	tsx0	principal_radians_
	tra	case_radians,x1	" Case select appropriate case_radians

case_radians:
	tra	case0_radians
	tra	case1_radians
	tra	case2_radians
	tra	case3_radians
	tra	case0_radians

case1_radians:
	fad	=0.0,du		" set indicators
	tmi	2,ic		" EAQ = - abs (EAQ)
	  negl	0		" fneg underflows at o400400000000

	dfad	half_pi1,x2
	dfad	half_pi2,x2
	tra	part_sine_radians

case2_radians:
	fneg	0
	tra	part_sine_radians

case3_radians:
	fad	=0.0,du		" set indicators
	tpl	2,ic		" EAQ = abs (EAQ)
	  fneg	0

	dfsb	half_pi1,x2
	dfsb	half_pi2,x2
	tra	part_sine_radians

case_degrees:
	tra	case0_degrees
	tra	case1_degrees
	tra	case2_degrees
	tra	case3_degrees
	tra	case0_degrees

case1_degrees:
	fad	=0.0,du		" set indicators
	tmi	2,ic		" EAQ = - abs (EAQ)
	  negl	0		" fneg underflows at o400400000000

	fad	ninety,x2
	tra	part_sine_degrees

case2_degrees:
	fneg	0
	tra	part_sine_degrees

case3_degrees:
	fad	=0.0,du		" set indicators
	tpl	2,ic		" EAQ = abs (EAQ)
	fneg

	fsb	ninety,x2
"	tra	part_sine_degrees

case0_degrees:			" case0_degrees is just part_sine_degrees

part_sine_degrees:
	dfcmg	eps2,x2		" if conversion to radians underflows
	tpl	2,ic
	  fld	=0.0,du		" then use zero
	dfmp	one_degree,x2	" convert to radians.
"	tra	part_sine_radians

case0_radians:			" case0_radians is just part_sine_radians


" Procedure part_sine_radians (x) calculates 'sin(x)' for 'x' in the range
" [-pi/2, pi/2] given 'x' in the EAQ.

part_sine_radians:
	dfcmg	eps3,x2		" if abs (x) < 5e-10:
	tpl	3,ic
	  frd	0
	  tra	pr3|0		"    sine is x for small x
	dfst	pr2|x
	dfmp	pr2|x		" calculate xx = x*x
	dfst	pr2|xx
	fmp	p5,x2		" calculate p(xx)
	dfad	p4,x2
	fmp	pr2|xx
	dfad	p3,x2
	fmp	pr2|xx
	dfad	p2,x2
	fmp	pr2|xx
	dfad	p1,x2
	dfmp	pr2|xx
	dfad	p0,x2
	dfmp	pr2|x		" return x*p(xx)
	frd	0
	tra	pr3|0


" Constants:

	even
eps1:	dec	1.886591d-8
	oct	764242035115,000000000000
eps2:	dec	8.418858142948452884d-38
	oct	402162456701,514360373670	" 2.670821537926801391d-154
eps3:	dec	5.0d-10
	oct	762104560276,404665512263
half_pi1:	oct	002622077325,042055060432	" 1.570796326794896619d0
	oct	002062207732,504205506043	" 1.570796326794896619d0
half_pi2:	oct	602611431424,270033407150	" 8.333742918520878328d-20
	oct	742461143142,427003340714	" 5.170182981794105568d-19
ninety:	dec	90.0d0
	oct	004264000000,000000000000
one_eighty:
	dec	180.0d0
	oct	004550000000,000000000000
p0:	dec	 9.999999999788d-1
	oct	000777777777,776426056601
p1:	dec	-1.6666666608826d-1
	oct	001652525252,575051425416
p2:	dec	 8.333330720556d-3
	oct	776104210413,351265306744
p3:	dec	-1.98408328231d-4
	oct	773137720534,017765224715
p4:	dec	 2.7523971068d-6
	oct	770134265644,770436615640
p5:	dec	-2.386834641d-8
	oct	765462761716,000402576424

	end




		    square_root_.alm                11/11/89  1150.6rew 11/11/89  0805.2       37044



" ******************************************
" *                                        *
" * Copyright, (C) Honeywell Limited, 1985 *
" *                                        *
" ******************************************
	name	square_root_
" Modification history:
"	Written by H. Hoover, M. Mabey, and B. Wong, April 1985,
"	based on the GCOS routine '7nbb'.
"
" Function:  Approximate to single precision the square root of a number.
"
" Entry:	through the appropriately named entry point with:
" 	EAQ = the number whose square root is desired.
"	PR2 = the address of an 8 word, even-word aligned scratch area.
"	PR3 = the return address.
"
" Exit:	EAQ = the desired square root.
"
" Uses:	X0, X1
"	X0 = temporary storage for exponent of input argument
"	     and saves a return address from call_math_error_
"	X1 = index to scale table

	equ	BFP,0
	equ	HFP,2
	equ	root_m,0
	equ	x,2
	equ	m,4
	equ	e,6

	bool	P0.25H,000200	" yields HFP +0.25 under 'du' modification
	bool	P4.0H,002200	" yields HFP +4.0 under 'du' modification

	segdef	square_root_,hfp_square_root_


square_root_:
	fad	=0.0,du		" normalize input arg
	tze	pr3|0		" if x = 0 return (0)
	tpl	calc_square_root	" if x < 0:
	  fneg	0		"   x = -x
	  fst	pr2|x
	  ldq	13,dl
	  tsx0	<call_math_error_>|[call_math_error_]
	  fld	pr2|x		"   calculate sqrt (abs(x))

calc_square_root:
	fst	pr2|x		" store EA := input arg
	ldx0	pr2|x		" X0 := addr (x) -> expon
				" m = x
	lde	=0b25,du		" addr (m) -> expon = 0
	canx0	=1b25,du		" calculate mod (e, 2)
	tze	2,ic		" if mod (e, 2) = 1:
	  lde	=-1b25,du		"   EA := m = .5*m
	ldq	pr2|x		" Q := 8/expon,28/garbage
	qrs	28		" Q := 28/0,8/expon
	adq	=1,dl		" calculate e+1
	qrs	1		" calculate divide (e+1, 2, 7)
	qls	28		" position result in exponent field
	stq	pr2|e		" store Q := e = divide (e+1, 2, 7)
	ldq	=0		" clear Q
	dfst	pr2|m		" store EAQ := m
	fmp	p2		" calculate root_m = p(m)
	fad	p1
	fmp	pr2|m
	fad	p0

	fst	pr2|root_m
	fdi	pr2|m		" calculate root_m = .5 * (root_m + m/root_m)
	fad	pr2|root_m
	fmp	=0.5,du

	dfst	pr2|root_m	" calculate root_m + float (m, 63)/root_m
	dfdi	pr2|m
	dfad	pr2|root_m
	ade	=-1b25,du		" root_m = .5 * (root_m + float (m, 63)/root_m)
				" root_x = root_m
	ade	pr2|e		" calculate addr (root_x) -> expon =
				"   addr (root_x) -> expon + divide (e+1, 2, 7)
	frd	0
	tra	pr3|0		" return (root_x)

hfp_square_root_:
	fad	=0.0,du		" normalize input arg
	tze	pr3|0		" if x = 0 return (0)
	tpl	hfp_calc_square_root
				" if x < 0:
	  fneg	0		"   x = -x
	  fst	pr2|x
	  ldq	13,dl
	  tsx0	<call_math_error_>|[call_math_error_]
	  fld	pr2|x		"   calculate sqrt (abs(x))

hfp_calc_square_root:
	fst	pr2|x		" store EA := input arg
	ldx0	pr2|x		" X0 := addr (x) -> expon
				" m = x
	lde	=0b25,du		" addr (m) -> expon = 0
	eax1	0		" scale = 0.5
	fcmp	P0.25H,du
	tpl	3,ic		" if m >= .25:  scale = 0.5
	  eax1	2		" else:         scale = 0.25
	  fmp	P4.0H,du		"               EA := m = 4*m
	canx0	=1b25,du		" calculate mod (e, 2)
	tze	2,ic		" if mod (e, 2) = 1:
	  adx1	=1,du		"   scale = 0.25*scale
	ldq	pr2|x		" Q := 8/expon,28/garbage
	qrs	28		" Q := 28/0,8/expon
	adq	=1,dl		" calculate e+1
	qrs	1		" calculate divide (e+1, 2, 7)
	qls	28		" position result in exponent field
	stq	pr2|e		" store Q := e = divide (e+1, 2, 7)
	ldq	=0		" clear Q
	dfst	pr2|m		" store EAQ := m
	fmp	hfp_p2		" calculate root_m = p(m)
	fad	hfp_p1
	fmp	pr2|m
	fad	hfp_p0

	fst	pr2|root_m
	fdi	pr2|m		" calculate root_m = .5 * (root_m + m/root_m)
	fad	pr2|root_m
	fmp	=0.5,du

	dfst	pr2|root_m	" calculate root_m + float (m, 63)/root_m
	dfdi	pr2|m
	dfad	pr2|root_m
	fmp	scale,x1		" root_m = scale * (root_m + float (m, 63)/root_m)
				" root_x = root_m
	ade	pr2|e		" calculate addr (root_x) -> expon =
				"   addr (root_x) -> expon + divide (e+1, 2, 7)
	frd	0
	tra	pr3|0		" return (root_x)

	even
p0:	dec	2.5927688d-1
hfp_p0:	oct	000204577702,000000000000
p1:	dec	1.0521212d0
hfp_p1:	oct	002041525750,000000000000
p2:	dec	-3.1632214d-1
hfp_p2:	oct	001536026031,000000000000
scale:	oct	000400000000	" 0.5
	oct	000100000000	" 0.25*0.5 = 0.125
	oct	000200000000	" 0.25
	oct	000040000000	" 0.25*0.25 = 0.0625

	end




		    tangent_.alm                    11/11/89  1150.6rew 11/11/89  0805.6       61605



" ******************************************
" *                                        *
" * Copyright, (C) Honeywell Limited, 1985 *
" *                                        *
" ******************************************
	name	tangent_
" Modification history:
"	Written by H. Hoover, M. Mabey, and B. Wong, April 1985,
"	based on GCOS routine '7nbc'.
"
" Function:  Approximate to single precision the tangent or cotangent of an
"	angle given in degrees or radians.
"
" Entry:	through the appropriately named entry point with:
" 	EAQ = the angle whose tangent is desired.
"	PR2 = the address of a 12 word, even-word aligned scratch area.
"	      6 words are used in this program and 12 are used by the
"	      routine "principal_angle_".  The storage for tangent_ and
"	      principal_angle_ overlap.
"	PR3 = the return address.
"
" Exit:	EAQ = the desired tangent or cotangent.
"
" Uses:	X0, X1, X2, X3.
"	X0 = saves a return address from principal_angle_ routines
"	X1 = shift (returned by principal_angle_ routines)
"	X2 = indicates BFP or HFP mode - all the floating point math
"	     routines use this register for the same purpose.
"	X3 = indicates Tangent or Cotangent function
"	The principal_angle_ routines use registers X1 and X2.

	segref	math_constants_,max_value,one_degree,quarter_pi
	segref	principal_angle_,principal_radians_,principal_degrees_

	equ	BFP,0
	equ	HFP,2
	equ	Cotangent,-1
	equ	Tangent,1
	equ	sign,0
	equ	x,0
	equ	xx,2
	equ	q,4

	segdef	cotangent_degrees_,hfp_cotangent_degrees_
	segdef	cotangent_radians_,hfp_cotangent_radians_
	segdef	tangent_degrees_,hfp_tangent_degrees_
	segdef	tangent_radians_,hfp_tangent_radians_


hfp_cotangent_degrees_:
	eax2	HFP		" 2 word offset for HFP constants
	tra	cotangent_degrees

cotangent_degrees_:
	eax2	BFP		" no offset for BFP constants

cotangent_degrees:
	fad	=0.0,du		" normalize input
	eax1	0		" initialize X1 := shift = 1
	fcmg	forty_five,x2
	tmoz	2,ic		" if abs (angle) > 45:
	  tsx0	principal_degrees_	"   call principal_degrees_

	dfcmg	eps1,x2		" if conversion to degrees underflows
	tmi	infinity		"   return (infinity (degrees))
				" else:
	dfmp	one_degree,x2	"   EAQ := degrees * one_degree

	canx1	=1,du
	tnz	3,ic		" if shift = 0 | shift = 2:
	  eax3	Cotangent		"   X3 := Cotangent
	  tra	part_tan_or_cot	"   return (part_tan_or_cot (Cotangent, degrees*one_degree))
				" else if shift = 1 | shift = 3
	eax3	Tangent		"   X3 := Cotangent
	fneg	0		"   EAQ := -degrees*one_degree
	tra	part_tan_or_cot	"   return (part_tan_or_cot (Tangent, -(degrees*one_degree)))


hfp_cotangent_radians_:
	eax2	HFP		" 2 word offset for HFP constants
	tra	cotangent_radians

cotangent_radians_:
	eax2	BFP		" no offset for BFP constants

cotangent_radians:
	fad	=0.0,du		" normalize input
	fcmg	quarter_pi,x2
	tpl	3,ic		" if abs (angle) > quarter_pi:
	  eax3	Cotangent		"   X3 := Cotangent
	  tra	part_tan_or_cot	"   return (part_tan_or_cot (Cotangent, radians)
	tsx0	principal_radians_	" call principal_radians_

	canx1	=1,du
	tnz	3,ic		" if shift = 0 | shift = 2:
	  eax3	Cotangent		"   X3 := Cotangent
	  tra	part_tan_or_cot	"   return (part_tan_or_cot (Cotangent, radians))
				" else if shift = 1 | shift = 3
	eax3	Tangent		"   X3 := Cotangent
	fneg	0		"   EAQ := -radians
	tra	part_tan_or_cot	"   return (part_tan_or_cot (Tangent, -radians))


hfp_tangent_degrees_:
	eax2	HFP		" 2 word offset for HFP constants
	tra	tangent_degrees

tangent_degrees_:
	eax2	BFP		" no offset for BFP constants

tangent_degrees:
	fad	=0.0,du		" normalize input
	eax1	0		" initialize X1 := shift = 1
	fcmg	forty_five,x2
	tmoz	2,ic		" if abs (angle) > 45:
	  tsx0	principal_degrees_	"   call principal_degrees_

	dfcmg	eps1,x2		" if conversion to radians underflows 
	tpl	2,ic
	  fld	=0.0,du	  	"   then use zero
				" else:
	dfmp	one_degree,x2	"   EAQ := degrees * one_degree

	canx1	=1,du
	tnz	3,ic		" if shift = 0 | shift = 2:
	  eax3	Tangent		"   X3 := Tangent
	  tra	part_tan_or_cot	"   return (part_tan_or_cot (Tangent, degrees*one_degree))
				" else if shift = 1 | shift = 3
	eax3	Cotangent		"   X3 := Cotangent
	fneg	0		"   EAQ := -radians
	tra	part_tan_or_cot	"   return (part_tan_or_cot (Cotangent, -(degrees*one_degree)))


hfp_tangent_radians_:
	eax2	HFP		" 2 word offset for HFP constants
	tra	tangent_radians

tangent_radians_:
	eax2	BFP		" no offset for BFP constants

tangent_radians:
	fad	=0.0,du		" normalize input
	fcmg	quarter_pi,x2
	tpl	3,ic		" if abs (angle) <= quarter_pi:
	  eax3	Tangent
	  tra	part_tan_or_cot	"   return (part_tan_or_cot (Tangent, radians))

	tsx0	principal_radians_	" call principal_radians_

	canx1	=1,du
	tnz	3,ic		" if shift = 0 | shift = 2:
	  eax3	Tangent		"   X3 := Tangent
	  tra	part_tan_or_cot	"   return (part_tan_or_cot (Tangent, radians))
				" else if shift = 1 | shift = 3
	eax3	Cotangent		"   X3 := Cotangent
	fneg	0		"   EAQ := -radians
"	tra	part_tan_or_cot	"   return (part_tan_or_cot (Cotangent, -radians))


" Procedure 'part_tan_or_cot' (function, x) calculates either 'tan(x)'
" or 'cot(x)' to double precision accuracy, for 'x' in [-pi/4, pi/4].
" Argument 'x' is given in the EAQ and the function to be calculated is
" given in X3.  X3=-1 indicates 'cot' and X3=1 indicates 'tan'.

part_tan_or_cot:
	fcmg	eps2		" if abs(x) < 5e-10:
	tpl	use_polynomial
	  cmpx3	Tangent,du	"   if function = Tangent
	  tnz	3,ic
	    frd	0		"     then return (result)
	    tra	pr3|0
	  dfcmg	eps3,x2		"   else if (1/result) overflows
	    tmoz	infinity		"     then return (infinity (result))
	    fdi	one,x2    	"     else return (1/result)
	    tra	pr3|0

use_polynomial:
	dfstr	pr2|x
	dfmp	pr2|x		" calculate xx = x*x
	dfstr	pr2|xx
	dfad	q1,x2		" calculate q = q(xx)
	dfmp	pr2|xx
	dfad	q0,x2
	dfstr	pr2|q
	dfld	pr2|xx		" calculate p(xx)
	dfmp	p2,x2
	dfad	p1,x2
	dfmp	pr2|xx
	dfad	p0,x2
	dfmp	pr2|x		" calculate p = x*p(xx)
	cmpx3	Tangent,du
	tnz	4,ic		" if function = Tangent
	  dfdv	pr2|q		" then return (p/q)
	  frd	0
	  tra	pr3|0
	dfdi	pr2|q		" else return (q/p)
	frd	0
	tra	pr3|0


infinity:
	fst	pr2|sign
	fld	max_value
	fad	max_value		" signal overflow
	fld	max_value
	fszn	pr2|sign		" if sign >= 0
	tpl	pr3|0		" then return (max_value)
	fneg	0		" else return (-max_value)
	tra	pr3|0


" Constants:

	even
eps1:	dec	8.418858142948452884d-38
	oct	402162456701,514360373670	" 2.670821537926801391d-154
eps2:	dec	5.0d-10
	oct	762104560277,000000000000
eps3:	oct	404400000000,000000000001
	oct	404040000000,000000000001
forty_five:
	dec	45.0d0
	oct	004132000000,000000000000
one:	dec	1.d0
	oct	002040000000,000000000000
p0:	dec	 6.26041119547433196d1
	oct	 004175152470,514027661141
p1:	dec	-6.97168400629442048d0
	oct	 003440717733,612726504236
p2:	dec	 6.73091025875915d-2
	oct	 000042354532,645307136212
q0:	dec	 6.260411195336057284d1
	oct	 004175152470,513531633022
q1:	dec	-2.78397212200427089d1
	oct	 005710244100,173305062557

	end




		    template_area_header.cds        11/11/89  1150.6rew 11/11/89  0804.2       15390



/* ***********************************************************
   *                                                         *
   * 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.      *
   *                                                         *
   *********************************************************** */


template_area_header: proc;


/* Automatic */

dcl 1 template_area aligned,
    2 template_area_header aligned like area_header;
dcl 1 cdsa aligned like cds_args;
dcl  code fixed bin (35);

/* Builtin */

dcl (null, unspec, bit, bin, size, addr, string) builtin;

/* Entries */

dcl  create_data_segment_ entry (ptr, fixed bin (35));

/*  */
	unspec (template_area) = "0"b;

	template_area.version = 1;
	template_area.next_virgin = bit (bin (size (template_area), 18), 18);
	template_area.last_size = bit (bin (2, 18), 18);
	template_area.last_block = bit (bin (size (template_area)-2, 18), 18);


/* Now call data base create program */

	cdsa.sections (1).p = addr (template_area);
	cdsa.sections (1).len = size (template_area);
	cdsa.sections (1).struct_name = "template_area";

	cdsa.seg_name = "template_area_header";
	cdsa.num_exclude_names = 0;
	cdsa.exclude_array_ptr = null;;

	string (cdsa.switches) = "0"b;
	cdsa.switches.have_text = "1"b;

	call create_data_segment_ (addr (cdsa), code);
	return;

/*  */

%include area_structures;
%include cds_args;
     end;




		    wired_utility_.alm              11/11/89  1150.6r w 11/11/89  0804.6       56799



" ***********************************************************
" *                                                         *
" * 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.      *
" *                                                         *
" ***********************************************************

" 

	include	stack_header

" 

	include	stack_frame

" 
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"							"
"	caller						"
"							"
"	Primitive to return a pointer to the caller of the	"
"	program which called this primitive.			"
"							"
"	Usage:						"
"							"
"	caller_ptr = wired_utility$caller ();			"
"							"
"							"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

	segdef	caller

caller:	eppbp	sp|stack_frame.prev_sp,*	get ptr to previous stack frame
	eppbp	bp|stack_frame.return_ptr,*	get caller
	spribp	ap|2,*			return the pointer
	short_return

" 
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"							"
"	stacq						"
"							"
"	Primitive to perform an stacq function analogous		"
"	to the stac builtin function.				"
"							"
"	Usage:						"
"							"
"	bit_1 = stacq (word_ptr, old_value, new_value);		"
"							"
"	word_ptr is a pointer to the word to change		"
"	new_value is the new value to place in the word if	"
"	old_value is the current contents of the word.		"
"							"
"	If the current contents of the word pointed to by word_ptr	"
"	is not the same as old_value the function returns "0"b,	"
"	if they match the function returns "1"b.		"
"							"
"							"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

	segdef	stacq

stacq:	ldq	ap|4,*		fetch the expected old value
	lda	ap|6,*		fetch the new value to store in the cell
	eppbp	ap|2,*		get pointer to input pointer

	stacq	bp|0,*		try to store the new value in the cell
	tze	success		if zero indicator set, the store went through (matched old value)
	stz	ap|8,*		return "0"b
	short_return

success:
	lda	=o400000,du	return "1"b
	sta	ap|8,*
	short_return

" 
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"							"
"	ldac						"
"							"
"	Primitive to use ldac instruction to load and clear a word	"
"	using one memory operation.				"
"							"
"	Usage:						"
"							"
"	word = ldac (word_ptr);				"
"							"
"	word_ptr is a pointer to the word to load and clear	"
"	word receives contents of the word pointed to by word_ptr	"
"							"
"							"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

	segdef	ldac

ldac:	eppbp	ap|2,*		get pointer to input pointer
	ldac	bp|0,*		load and clear the word
	sta	ap|4,*		return the value of the word
	short_return

" 
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"							"
"	get_sp						"
"							"
"	Primitive to return the current value of sp to the caller	"
"							"
"	Usage:						"
"							"
"	sp = wired_utility_$get_sp;				"
"							"
"	sp will receive the value of the stack pointer		"
"							"
"							"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

	segdef	get_sp

get_sp:	sprisp	ap|2,*		return the value of sp to the caller
	short_return

" 
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"							"
"	grow_stack_frame					"
"	shrink_stack_frame					"
"							"
"	Primitives to increase and decrease the size of the	"
"	caller's stack frame.  Use these entries with care!	"
"							"
"	Usage:						"
"							"
"	p = wired_utility_$grow_stack_frame (size);		"
"	call wired_utility_$shrink_stack_frame (endp);		"
"							"
"	grow_stack_frame will increase the stack fame by size words	"
"	and return a pointer to the previous end of the frame.	"
"	shrink stack_frame will shrink the frame back to the	"
"	supplied endp.					"
"							"
"							"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

	segdef	grow_stack_frame
	segdef	shrink_stack_frame

grow_stack_frame:
	eppbp	sb|stack_header.stack_end_ptr,*	bp -> end of frame
	spribp	ap|4,*		return end pointer

	lda	ap|2,*		get size to grow frame
	eaa	bp|0,al		AU is new end pointer
adjust_stack_frame:
	eaa	15,au		round to 0 mod 16
	ana	=o777760,du	..
	eawpbp	0,au		bp -> new end of frame
	spribp	sb|stack_header.stack_end_ptr	set new end of frame
	spribp	sp|stack_frame.next_sp
	spribp	sp|4		set for PL/1
	short_return

shrink_stack_frame:
	eppbp	sb|stack_header.stack_end_ptr,*	bp -> end of frame
	eppbb	ap|2,*		bb -> new end point
	eaa	bb|0,*		stack end offset in AU
	tra	adjust_stack_frame	use common code


" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"
"	get_ring_ - this entry returns the number of the current ring
"
"	declare get_ring_ entry(fixed bin(3));
"	call get_ring_(ring);
"
"	1. ring	the number of the current ring. (Output)
"
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

	segdef	get_ring_
get_ring_:
	epaq	*		get ring number from effective pointer
	ana	=o7,dl		leave only ring number in a-reg
	sta	ap|2,*		return to caller
	short_return



" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"
"	arg_count_ - this entry returns the number of arguments with which the
"		calling procedure was invoked.
"
"	declare arg_count_ entry(fixed bin);
"	call arg_count_(args);
"
"	1. args	the number of arguments. (Output)
"
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

	segdef	arg_count_
arg_count_:
	lda	sp|stack_frame.arg_ptr,* get argument list header
	arl	18+1		shift right and divide by two
	sta	ap|2,*		store in argument
	short_return

"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
"
"         arg_list_ptr_
"
"         declare arg_list_ptr entry returns (pointer);
"         alp = arg_list_ptr_ ();
"
""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""

	segdef	arg_list_ptr_
arg_list_ptr_:
	epp1	sp|stack_frame.arg_ptr,* Pointer to arglist header
	spri1	ap|2,*
	short_return

	end




		    bull_copyright_notice.txt       08/30/05  1008.4r   08/30/05  1007.3    00020025

                                          -----------------------------------------------------------


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull
and Bull HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for 
managing computer hardware properly and for executing programs. Many subsequent operating systems
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

                                          -----------------------------------------------------------

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by Bull HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved
