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