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_] eppbp |[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_] 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_] 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] 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_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] 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_] 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] 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_] 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_] 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 |[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 " 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_] " 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_] nop tra |[hfp_double_square_root_] arcsine_domain_error: " abs_x > 1 ldq 58,dl tsx0 |[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_] 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 |[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_](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 |[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 |[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 |[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_] 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 |[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_] 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_] nop tra |[hfp_double_square_root_] arcsine_domain_error: " abs_x > 1 ldq 65,dl tsx0 |[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_] 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_] dfld max_value fneg 0 tra pr3|0 log_of_zero: ldq 20,dl tsx0 |[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_] 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_] 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_] 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 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_] define ccos,staq,1,|[ccos_] define cexp,staq,1,|[cexp_] define clog,staq,1,|[clog_] define cmpx_p_cmpx,staq,2,|[cxp2_] define cosh,dfst,1,|[cosh_] define csin,staq,1,|[csin_] define csqrt,staq,1,|[csqrt_] define dcosh,dfst,1,|[dcosh_] define dmod,dfst,2,|[dmod_] define dsinh,dfst,1,|[dsinh_] define dtanh,dfst,1,|[dtanh_] define sinh,dfst,1,|[sinh_] define tanh,dfst,1,|[tanh_] define hfp_cabs,staq,1,|[cabs_] define hfp_ccos,staq,1,|[ccos_] define hfp_cexp,staq,1,|[cexp_] define hfp_clog,staq,1,|[clog_] define hfp_cmpx_p_cmpx,staq,2,|[cxp2_] define hfp_cosh,dfst,1,|[cosh_] define hfp_csin,staq,1,|[csin_] define hfp_csqrt,staq,1,|[csqrt_] define hfp_dcosh,dfst,1,|[dcosh_] define hfp_dmod,dfst,2,|[dmod_] define hfp_dsinh,dfst,1,|[dsinh_] define hfp_dtanh,dfst,1,|[dtanh_] define hfp_sinh,dfst,1,|[sinh_] define hfp_tanh,dfst,1,|[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 |[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 |[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_] ldq 2|i tra 3|0 " bigexp: ldq 7,dl bigexp1: tsx0 |[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_] fld max_value fneg 0 tra pr3|0 log_of_zero: ldq 9,dl tsx0 |[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